kind of working,

still needs testing. Added output return coercion in expression Fixed formatting bugs
2026-03-18 21:10:07 +00:00 · 2022-05-17 02:26:18 +02:00
parent 8d3d00b7a5
commit 26daa85feb
9 changed files with 193 additions and 80 deletions
--- a/src/Model/Type.hs
+++ b/src/Model/Type.hs
@@ -58,6 +58,18 @@ data ExplicitExpression = ExplicitEmpty
    | ExplicitIfSimple {cond :: (ExplicitExpression, Coercion), block1 :: (ExplicitExpression, Coercion), returnCoercion :: Coercion}
    | ExplicitIfElse {cond :: (ExplicitExpression, Coercion), block1 :: (ExplicitExpression, Coercion), block2 :: (ExplicitExpression, Coercion), returnCoercion :: Coercion}

+changeCoercion :: ExplicitExpression -> Coercion -> ExplicitExpression
+changeCoercion ExplicitEmpty _ = ExplicitEmpty
+changeCoercion (ExplicitVariable n _) c = ExplicitVariable n c 
+changeCoercion (Value n _) c = Value n c
+changeCoercion (ExplicitList e) _ = ExplicitList e
+changeCoercion (ExplicitKeyword n) _ = ExplicitKeyword n
+changeCoercion (ExplicitParens e) _ = ExplicitParens e
+changeCoercion (ExplicitPath s n _) c = ExplicitPath s n c
+changeCoercion (ExplicitFunction n args _) c = ExplicitFunction n args c 
+changeCoercion (ExplicitIfSimple cond block _) c = ExplicitIfSimple cond block c
+changeCoercion (ExplicitIfElse cond block block2 _) c = ExplicitIfElse cond block block2 c       
+
 instance Show ExplicitExpression where
    show (ExplicitVariable name coer) = show $ "Variable: " ++ name
    show (Value name coer) = show $ "Value: " ++ name
@@ -139,7 +151,8 @@ toHaskell :: Type -> Type
 toHaskell a
    | typeName a == "int" = BasicType "Integer"
    | typeName a == "boolean" = BasicType "Boolean"
-    | typeName a == "real" = BasicType "Double"
+    | typeName a == "number" = BasicType "Double"
+    | typeName a == "string" = BasicType "String"
    | otherwise = a

 coercionType :: [TypeCoercion] -> Type
--- a/src/Parser/Expression.hs
+++ b/src/Parser/Expression.hs
@@ -69,7 +69,10 @@ listParser =
 variableParser :: Parser Expression
 variableParser =
    do
-        Variable <$> camelNameParser
+        name <- camelNameParser
+        if name == "endDate," then error "lool"
+        else return $ Variable name
+        --Variable <$> camelNameParser

 -- |Parses an integer in Rosetta into an Expression
 integerParser :: Parser Expression
--- a/src/PrettyPrinter/Expression.hs
+++ b/src/PrettyPrinter/Expression.hs
@@ -5,45 +5,45 @@ module PrettyPrinter.Expression where
 import Model.Type
 import Prettyprinter
 import Semantic.ExpressionChecker(coercionIncluded)
+import Utils.Utils

-printExpression :: ExplicitExpression -> Coercion -> Doc a
-printExpression ExplicitEmpty _ = "[]" 
-printExpression (ExplicitVariable name coer) out = case coer `coercionIncluded` out of 
-    Left err -> error $ show coer ++ "//" ++ show out --err
-    Right c -> printCoercion c $ pretty name
-printExpression (Value s coer) out = case coer `coercionIncluded` out of
-    Left err -> error $ show err 
-    Right c -> printCoercion c $ pretty s
-printExpression (ExplicitKeyword k) out = pretty k
-printExpression (ExplicitParens ex) out = "(" <> printExpression ex out <> ")"
-printExpression (ExplicitList ex) out = list [printExpression x out | x <- ex]
-printExpression (ExplicitPath ex1 ex2 returnCoerce) out = printCoercion (returnCoercion ex1) (printExpression ex1 (returnCoercion ex1)) <+> "->" <+> printCoercion (returnCoercion ex2) (printExpression ex2 out)
-printExpression (ExplicitFunction "exists" args returnCoerce) out = printCoercion returnCoerce "isJust" <+> printCoercion (snd $ head args) (printExpression (fst $ head args) out)
-printExpression (ExplicitFunction "is absent" args returnCoerce) out = printCoercion returnCoerce "isNothing" <+> printCoercion (snd $ head args) (printExpression (fst $ head args) out)
-printExpression (ExplicitFunction "single exists" args returnCoerce) out = printCoercion returnCoerce "length" <+> printCoercion (snd $ head args) (printExpression (fst $ head args) out) <+> "==" <+> "1"
-printExpression (ExplicitFunction "multiple exists" args returnCoerce) out = printCoercion returnCoerce "length" <+> printCoercion (snd $ head args) (printExpression (fst $ head args) out) <+> ">" <+> "1" 
-printExpression (ExplicitFunction "count" args returnCoerce) out = printCoercion returnCoerce "length" <+> printCoercion (snd $ head args) (printExpression (fst $ head args) out)
+printExpression :: ExplicitExpression -> Doc a
+printExpression ExplicitEmpty = "[]" 
+printExpression (ExplicitVariable name coer) = printCoercion coer $ pretty name
+printExpression (Value s coer) = printCoercion coer $ pretty s
+printExpression (ExplicitKeyword k) = pretty k
+printExpression (ExplicitParens ex) = "(" <> printExpression ex <> ")"
+printExpression (ExplicitList ex)  = list [printExpression x | x <- ex]
+printExpression (ExplicitPath ex1 ex2 returnCoerce) = printCoercion (returnCoercion ex1) (printExpression ex1) <+> "->" <+> printCoercion (returnCoercion ex2) (printExpression ex2)
+printExpression (ExplicitFunction "exists" args returnCoerce) = printCoercion returnCoerce "isJust" <+> printCoercion (snd $ head args) (printExpression (fst $ head args))
+printExpression (ExplicitFunction "is absent" args returnCoerce) = printCoercion returnCoerce "isNothing" <+> printCoercion (snd $ head args) (printExpression (fst $ head args))
+printExpression (ExplicitFunction "single exists" args returnCoerce) = printCoercion returnCoerce "length" <+> printCoercion (snd $ head args) (printExpression (fst $ head args)) <+> "==" <+> "1"
+printExpression (ExplicitFunction "multiple exists" args returnCoerce) = printCoercion returnCoerce "length" <+> printCoercion (snd $ head args) (printExpression (fst $ head args)) <+> ">" <+> "1" 
+printExpression (ExplicitFunction "count" args returnCoerce) = printCoercion returnCoerce "length" <+> printCoercion (snd $ head args) (printExpression (fst $ head args))
 -- Equality expressions
 -- [a] a all = 
 -- any <>
-printExpression (ExplicitFunction "=" args returnCoerce) out = printCoercion (snd $ head args) (printExpression (fst $ head args) out) <+> "==" <+> printCoercion (snd $ head $ tail args) (printExpression (fst $ head $ tail args) out)
-printExpression (ExplicitFunction "<>" args returnCoerce) out = printCoercion (snd $ head args) (printExpression (fst $ head args) out) <+> "/=" <+> printCoercion (snd $ head $ tail args) (printExpression (fst $ head $ tail args) out)
-printExpression (ExplicitFunction "any =" args returnCoerce) out = printCoercion (snd $ head $ tail args) (printExpression (fst $ head $ tail args) out) <+> "`elem`" <+> printCoercion (snd $ head args) (printExpression (fst $ head args) out)
-printExpression (ExplicitFunction "all <>" args returnCoerce) out = printCoercion (snd $ head $ tail args) (printExpression (fst $ head $ tail args) out) <+> "`notElem`" <+> printCoercion (snd $ head args) (printExpression (fst $ head args) out)
-printExpression (ExplicitFunction "all =" args returnCoerce) out = "all (Eq)" <+> printCoercion (snd $ head $ tail args) (printExpression (fst $ head $ tail args) out) <+> printCoercion (snd $ head args) (printExpression (fst $ head args) out)
-printExpression (ExplicitFunction "and" args returnCoerce) out = printCoercion (snd $ head args) (printExpression (fst $ head args) out) <+> "&&" <+> printCoercion (snd $ head $ tail args) (printExpression (fst $ head $ tail args) out)
-printExpression (ExplicitFunction "or" args returnCoerce) out = printCoercion (snd $ head args) (printExpression (fst $ head args) out) <+> "||" <+> printCoercion (snd $ head $ tail args) (printExpression (fst $ head $ tail args) out)
-printExpression (ExplicitFunction name args returnCoerce) out = pretty name <+> tupled (zipWith printCoercion [c | (e,c) <- args] [printExpression e out | (e, c) <- args])
-printExpression (ExplicitIfSimple cond thenBlock returnCoercion) out = 
-    "if" <+> printCoercion (snd cond) (printExpression (fst cond) (MakeCoercion [MakeIdCoercion (BasicType "Boolean")] (MakeCardinalityIdCoercion (Bounds (1, 1))))) <+> 
-    "then" <+> printCoercion (snd thenBlock) (printExpression (fst thenBlock) out) <+> 
-    "else" <+> case MakeCoercion [MakeIdCoercion $ coercionType $ typeCoercion returnCoercion] (MakeCardinalityIdCoercion (Bounds (0, 0))) `coercionIncluded` out of
+printExpression (ExplicitFunction "=" args returnCoerce) = printCoercion (snd $ head args) (printExpression (fst $ head args)) <+> "==" <+> printCoercion (snd $ head $ tail args) (printExpression (fst $ head $ tail args))
+printExpression (ExplicitFunction "<>" args returnCoerce) = printCoercion (snd $ head args) (printExpression (fst $ head args)) <+> "/=" <+> printCoercion (snd $ head $ tail args) (printExpression (fst $ head $ tail args))
+printExpression (ExplicitFunction "any =" args returnCoerce) = printCoercion (snd $ head $ tail args) (printExpression (fst $ head $ tail args)) <+> "`elem`" <+> printCoercion (snd $ head args) (printExpression (fst $ head args))
+printExpression (ExplicitFunction "all <>" args returnCoerce) = printCoercion (snd $ head $ tail args) (printExpression (fst $ head $ tail args)) <+> "`notElem`" <+> printCoercion (snd $ head args) (printExpression (fst $ head args))
+printExpression (ExplicitFunction "all =" args returnCoerce) = "all (Eq)" <+> printCoercion (snd $ head $ tail args) (printExpression (fst $ head $ tail args)) <+> printCoercion (snd $ head args) (printExpression (fst $ head args))
+printExpression (ExplicitFunction "and" args returnCoerce) = printCoercion (snd $ head args) (printExpression (fst $ head args)) <+> "&&" <+> printCoercion (snd $ head $ tail args) (printExpression (fst $ head $ tail args))
+printExpression (ExplicitFunction "or" args returnCoerce) = printCoercion (snd $ head args) (printExpression (fst $ head args)) <+> "||" <+> printCoercion (snd $ head $ tail args) (printExpression (fst $ head $ tail args))
+printExpression (ExplicitFunction name args returnCoerce) = 
+    if null printedArgs then pretty (uncapitalize name) 
+    else  "(" <> pretty (uncapitalize name) <+> printCoercion returnCoerce (hsep printedArgs) <> ")"
+    where printedArgs = zipWith printCoercion [c | (e,c) <- args] [printExpression e | (e, c) <- args]
+printExpression (ExplicitIfSimple cond thenBlock returnCoercion) = 
+    "if" <+> printCoercion (snd cond) (printExpression (fst cond)) <+> 
+    "then" <+> printCoercion (snd thenBlock) (printExpression (fst thenBlock)) <+> 
+    "else" <+> case MakeCoercion [MakeIdCoercion $ coercionType $ typeCoercion returnCoercion] (MakeCardinalityIdCoercion (Bounds (0, 0))) `coercionIncluded` returnCoercion of
        Left err -> error $ show err
        Right c -> printCoercion c emptyDoc
-printExpression (ExplicitIfElse cond thenBlock elseBlock returnCoercion) out = 
-    "if" <+> printCoercion (snd cond) (printExpression (fst cond) (MakeCoercion [MakeIdCoercion (BasicType "Boolean")] (MakeCardinalityIdCoercion (Bounds (1, 1))))) <+> 
-    "then" <+> printCoercion (snd thenBlock) (printExpression (fst thenBlock) out) <+> 
-    "else" <+> printCoercion (snd elseBlock) (printExpression (fst elseBlock) out)
+printExpression (ExplicitIfElse cond thenBlock elseBlock returnCoercion) = 
+    "if" <+> printCoercion (snd cond) (printExpression (fst cond)) <+> 
+    "then" <+> printCoercion (snd thenBlock) (printExpression (fst thenBlock)) <+> 
+    "else" <+> printCoercion (snd elseBlock) (printExpression (fst elseBlock))

 -- |Converts a coercion into a haskell string
 printCoercion :: Coercion -> Doc a -> Doc a
--- a/src/PrettyPrinter/Function.hs
+++ b/src/PrettyPrinter/Function.hs
@@ -8,7 +8,7 @@ import Model.Function
 import PrettyPrinter.General
 import PrettyPrinter.Type
 import Model.Type
-import Utils.Utils (uncapitalize)
+import Utils.Utils (capitalize, uncapitalize)

 {-
 Consider all assignments as trees
@@ -42,7 +42,7 @@ printFunction f = show $ vcat [printFunctionSignature (sign f), printFunctionBod
 printFunctionBody :: ExplicitFunction -> Doc a
 printFunctionBody (MakeExplicitFunction (MakeFunctionSignature name _ inp out) ex) =
    pretty name <+> printVariableNames inp <+> "=" <+> 
-    printAssignmentTree (head $ mergeAssignmentTrees [convertToAssignmentTree (fst exp) (AssignmentLeaf (snd exp)) | exp <- ex]) (returnCoercion (fst $ head ex))
+    printAssignmentTree (head $ mergeAssignmentTrees [convertToAssignmentTree (fst exp) (AssignmentLeaf (snd exp)) | exp <- ex])
    --error $ show $ mergeAssignmentTrees [convertToAssignmentTree (fst exp) (AssignmentLeaf (snd exp)) | exp <- ex]


@@ -55,15 +55,19 @@ printFunctionSignature (MakeFunctionSignature name description inputs output) =
 prettyPrintType :: [Doc x] -> Doc x
 prettyPrintType = align . sep . Prelude.zipWith (<+>) ("::" : repeat "->")

-printAssignmentTree :: AssignmentTree -> Coercion -> Doc a
-printAssignmentTree (AssignmentLeaf exp) coer = printExpression exp coer
-printAssignmentTree (AssignmentNode var typ c) coer
+printAssignmentTree :: AssignmentTree -> Doc a
+printAssignmentTree (AssignmentLeaf exp) = printExpression exp
+printAssignmentTree (AssignmentNode var typ c)
    | length c == 1 = case head c of
-        AssignmentLeaf e -> printConstructor typ <+>  "(" <+> printAssignmentTree (head c) coer <> ")" 
-        AssignmentNode v t _ -> printConstructor typ <> printConstructor t <+> "(" <+> printAssignmentTree (head c) coer <> ")" 
+        AssignmentLeaf e -> printAssignmentTree (head c) 
+        AssignmentNode v t _ -> printConstructor typ <> pretty (capitalize v) <+> "(" <> printAssignmentTree (head c) <> ")" 
    | otherwise = case typ of
-        MakeType t _ _ _ _ -> "Make" <> pretty t <+> group (sep [printAssignmentTree child coer | child <- c])
-        BasicType _ -> sep [printAssignmentTree child coer | child <- c]
+        MakeType t _ _ _ _ -> "Make" <> pretty t <+> "{" <> hsep (punctuate "," [pretty (uncapitalize t) <> getVarName child <+> "=" <+> printAssignmentTree child | child <- c]) <> "}"
+        BasicType _ -> sep ["(" <> printAssignmentTree child <> ")" | child <- c]
+
+getVarName :: AssignmentTree -> Doc a
+getVarName (AssignmentLeaf _) = emptyDoc
+getVarName (AssignmentNode var _ _) = pretty (capitalize var)

 mergeAssignmentTrees :: [AssignmentTree] -> [AssignmentTree]
 mergeAssignmentTrees [] = []
--- a/src/Semantic/ExpressionChecker.hs
+++ b/src/Semantic/ExpressionChecker.hs
@@ -254,7 +254,7 @@ getTypeAttributes (defT : ts) t
    | typeName defT == typeName t = 
        [MakeTypeAttribute {attributeName = attributeName attr, 
            attributeType = toHaskell (attributeType attr), 
-            Model.Type.cardinality = Model.Type.cardinality attr, 
+            Model.Type.cardinality = if MakeCondition Nothing (Keyword "one-of") `elem` conditions defT then Bounds (1,1) else Model.Type.cardinality attr, 
            attributeDescription = attributeDescription attr} 
            | attr <- typeAttributes defT]
    | otherwise = getTypeAttributes ts t
--- a/src/Semantic/FunctionChecker.hs
+++ b/src/Semantic/FunctionChecker.hs
@@ -24,12 +24,15 @@ checkFunction (definedTypes, symbols) (MakeFunction (MakeFunctionSignature name

 checkAssignment :: [Type] -> [Symbol] -> [(Expression, Expression)] -> Either [TypeCheckError] [(ExplicitExpression, ExplicitExpression)]
 checkAssignment _ _ [] = Right []
-checkAssignment defT symbs ((assign, ex): assigns) = 
+checkAssignment defT symbs ((assign, ex): assigns) =
    case checkExpression defT (tail symbs) ex of
    Left err -> Left [err]
    -- Here we use only tail symbs, beacuse the head of the symbol table is the out variable, and that can't be used in the expression body
    Right checkedExp -> case checkExpression defT symbs assign of
        Left err -> Left [err]
        Right checkedA -> case checkAssignment defT symbs assigns of
-            Left err -> Left err
-            Right checked -> Right $ (checkedA, checkedExp) : checked
+                Left err -> Left err
+                -- Add a final explicit transformation to match the expected output
+                Right checked -> case returnCoercion checkedExp `coercionIncluded` returnCoercion checkedA of
+                    Left err -> Left [err]
+                    Right c -> Right $ (checkedA, changeCoercion checkedExp c) : checked
--- a/src/Semantic/TypeChecker.hs
+++ b/src/Semantic/TypeChecker.hs
@@ -47,27 +47,6 @@ checkAttributes definedTypes ((MakeTypeAttribute name typ crd desc):as) =
        Left err -> Left err : checkAttributes definedTypes as
        Right checked -> Right (MakeTypeAttribute name checked crd desc) : checkAttributes definedTypes as 

-populateAttributeType :: [Type] -> [Type] -> TypeAttribute -> Either TypeCheckError TypeAttribute
-populateAttributeType _ _ (MakeTypeAttribute n (MakeType "int" _ _ _ _) c d ) = Right $ MakeTypeAttribute n (BasicType "Integer") c d 
-populateAttributeType _ _  (MakeTypeAttribute n (MakeType "string" _ _ _ _) c d ) = Right $ MakeTypeAttribute n (BasicType "String") c d 
-populateAttributeType _ _  (MakeTypeAttribute n (MakeType "number" _ _ _ _) c d ) = Right $ MakeTypeAttribute n (BasicType "Double") c d 
-populateAttributeType _ _  (MakeTypeAttribute n (MakeType "boolean" _ _ _ _) c d ) = Right $ MakeTypeAttribute n (BasicType "Bool") c d 
-populateAttributeType _ _  (MakeTypeAttribute n (MakeType "time" _ _ _ _) c d ) = Right $ MakeTypeAttribute n (BasicType "Time") c d 
-populateAttributeType _ _ (MakeTypeAttribute n (BasicType t) c d) = Right $ MakeTypeAttribute n (BasicType t) c d 
-populateAttributeType _ [] t = Left $ UndefinedType $ typeName $ attributeType t
-populateAttributeType t (definedT : ts) typ
-    | definedT == attributeType typ = 
-        let populatedAttr = map (populateAttributeType t t) (typeAttributes definedT) 
-        in
-        if null $ lefts populatedAttr 
-        then Right $ MakeTypeAttribute 
-            (attributeName typ) 
-            (MakeType (typeName definedT) (superType definedT) (typeDescription definedT) (rights populatedAttr) (conditions definedT)) 
-            (cardinality typ)
-            (attributeDescription typ)
-        else Left $ head $ lefts populatedAttr
-    | otherwise = populateAttributeType t ts typ
-
 -- |Checks whether a type is predefined or in the symbol table
 checkAttributeType :: [Type] -> Type -> Either TypeCheckError Type
 checkAttributeType [] t = Left $ UndefinedType $ typeName t