diff --git a/RosettaParser.cabal b/RosettaParser.cabal index 14df146..c128d80 100644 --- a/RosettaParser.cabal +++ b/RosettaParser.cabal @@ -37,6 +37,7 @@ library Parser.Header Parser.Type PrettyPrinter.Enum + PrettyPrinter.Expression PrettyPrinter.Function PrettyPrinter.General PrettyPrinter.Header diff --git a/src/Model/Type.hs b/src/Model/Type.hs index 9ac5f06..0f0a7a0 100644 --- a/src/Model/Type.hs +++ b/src/Model/Type.hs @@ -26,9 +26,13 @@ data Condition = MakeCondition { expressionExpression :: Expression } deriving (Show) +instance Eq Condition where + (==) (MakeCondition _ ex) (MakeCondition _ ex2) = ex == ex2 + -- |The representation of an expression data Expression = Variable String | PathExpression Expression Expression + | Keyword String | Int String | Real String | Boolean String @@ -47,12 +51,24 @@ data ExplicitExpression = ExplicitEmpty | ExplicitVariable {name :: String, returnCoercion :: Coercion} | Value {name :: String, returnCoercion :: Coercion} | ExplicitList [ExplicitExpression] + | ExplicitKeyword String | ExplicitParens ExplicitExpression | ExplicitPath {super :: ExplicitExpression, sub :: ExplicitExpression, returnCoercion :: Coercion} | ExplicitFunction {name :: String, args :: [(ExplicitExpression, Coercion)], returnCoercion :: Coercion} | ExplicitIfSimple {cond :: (ExplicitExpression, Coercion), block1 :: (ExplicitExpression, Coercion), returnCoercion :: Coercion} | ExplicitIfElse {cond :: (ExplicitExpression, Coercion), block1 :: (ExplicitExpression, Coercion), block2 :: (ExplicitExpression, Coercion), returnCoercion :: Coercion} - deriving (Show) + +instance Show ExplicitExpression where + show (ExplicitVariable name coer) = show $ "Variable: " ++ name + show (Value name coer) = show $ "Value: " ++ name + show (ExplicitList lst) = concatMap show lst + show (ExplicitKeyword name) = show $ "Keyword: " ++ name + show (ExplicitParens name) = show $ "(" ++ show name ++ ")" + show (ExplicitPath super sub coer) = show $ "(->" ++ show super ++ " " ++ show sub ++ ")" + show (ExplicitFunction name args coer) = show $ name ++ "(" ++ concatMap show args ++ ")" + show (ExplicitIfSimple cond block coer) = show $ "if" ++ show cond ++ " then " ++ show block + show (ExplicitIfElse cond block1 block2 coer) = show $ "if" ++ show cond ++ " then " ++ show block1 ++ " else " ++ show block2 + show ExplicitEmpty = show "Empty" data TypeCoercion = MakeIdCoercion {toType :: Type} diff --git a/src/Parser/Expression.hs b/src/Parser/Expression.hs index a53ddd5..1ecddf9 100644 --- a/src/Parser/Expression.hs +++ b/src/Parser/Expression.hs @@ -106,7 +106,9 @@ terminalParser :: Parser Expression terminalParser = do choice - [ prefixParser, + [ + try keywordParser, + prefixParser, parens expressionParser >>= \e -> return (Parens e), listParser, try booleanParser, @@ -119,6 +121,14 @@ terminalParser = -------------------------------------------- -- Expressions ----------------------------- -------------------------------------------- +keywords :: [String] +keywords = ["one-of"] + +keywordParser :: Parser Expression +keywordParser = + do + word <- lexeme $ choice $ fmap (try . string . Text.pack) keywords + return $ Keyword $ Text.unpack word -- |Parses an prefix function statement in Rosetta into an Expression prefixParser :: Parser Expression diff --git a/src/PrettyPrinter/Expression.hs b/src/PrettyPrinter/Expression.hs new file mode 100644 index 0000000..650dd42 --- /dev/null +++ b/src/PrettyPrinter/Expression.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE OverloadedStrings #-} + +module PrettyPrinter.Expression where + +import Model.Type +import Prettyprinter +import Semantic.ExpressionChecker(coercionIncluded) + +printExpression :: ExplicitExpression -> Coercion -> Doc a +printExpression ExplicitEmpty _ = "[]" +printExpression (ExplicitVariable name coer) out = case coer `coercionIncluded` out of + Left err -> error $ show 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) +-- 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 + 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) + +-- |Converts a coercion into a haskell string +printCoercion :: Coercion -> Doc a -> Doc a +printCoercion (MakeCoercion [] crd) d = printCardinalityCoercion crd d +printCoercion (MakeCoercion (t: ts) crd) d = printTypeCoercion t <> printCoercion (MakeCoercion ts crd) d + +printCardinalityCoercion :: CardinalityCoercion -> Doc a -> Doc a +printCardinalityCoercion (MakeCardinalityIdCoercion _) d = d +printCardinalityCoercion (MakeListCardinalityCoercion _ _) d = d +printCardinalityCoercion (MakeNothing2MaybeCoercion _ _) d = "Nothing" +printCardinalityCoercion (MakeNothing2ListCoercion _ _) d = "[]" +printCardinalityCoercion (MakeMaybe2ListCoercion _ _) d = "maybeToList" <+> d +printCardinalityCoercion (MakeObject2MaybeCoercion _ _) d = "Just" <+> d +printCardinalityCoercion (MakeObject2ListCoercion _ _) d = "[" <> d <> "]" + +printTypeCoercion :: TypeCoercion -> Doc a +printTypeCoercion (MakeIdCoercion _) = emptyDoc +printTypeCoercion (MakeSuperCoercion _ _) = "super" <+> emptyDoc +printTypeCoercion (MakeTypeCoercion _ _ t) = pretty t <+> emptyDoc + +-- |Converts a list of type attributes to a Doc with a list of variable names +printVariableNames :: [TypeAttribute] -> Doc a +printVariableNames vars = foldl (<+>) emptyDoc (map (pretty . attributeName) vars) \ No newline at end of file diff --git a/src/PrettyPrinter/Function.hs b/src/PrettyPrinter/Function.hs index b694782..302deaf 100644 --- a/src/PrettyPrinter/Function.hs +++ b/src/PrettyPrinter/Function.hs @@ -3,13 +3,36 @@ module PrettyPrinter.Function where import Prettyprinter +import PrettyPrinter.Expression import Model.Function import PrettyPrinter.General import PrettyPrinter.Type import Model.Type -import Semantic.ExpressionChecker(coercionIncluded) - --- show printStatementTree +import Utils.Utils (uncapitalize) + +{- +Consider all assignments as trees +Root must always bee the same type (output type of the functions) +Merge at every level, the nodes that have the same type + 1 1 1 1 1 1 + | | | / | \ / \ / \ + 2 2 4 ---> 2 2 4 ---> 2 4 ---> 2 4 + | | | | | | | \ | | | + 3 3 5 ---> 3 3 5 ---> 3 3 5 ---> 3 5 + | | | | | | | | | | \ | + EX1 EX2 EX3 EX1 EX2 EX3 EX1 EX2 EX3 EX1 EX2 EX3 +-} + +data AssignmentTree = AssignmentNode { + var :: String, + typ :: Type, + children :: [AssignmentTree] + } + | AssignmentLeaf ExplicitExpression + +instance Show AssignmentTree where + show (AssignmentNode var typ child) = "Node: " ++ show (typeName typ) ++ show child + show (AssignmentLeaf exp) = "Leaf: " ++ show exp -- |Converts a Function into a haskell valid String printFunction :: ExplicitFunction -> String @@ -17,69 +40,11 @@ printFunction f = show $ vcat [printFunctionSignature (sign f), printFunctionBod -- |Converts the body of a Function into a haskell valid Doc printFunctionBody :: ExplicitFunction -> Doc a -printFunctionBody (MakeExplicitFunction (MakeFunctionSignature name _ inp out) ex) = pretty name <+> printVariableNames inp <+> "= where" - <+> vcat [printExpression (fst exp) (returnCoercion (fst exp)) <+> " = " - <+> printExpression (snd exp) (returnCoercion (fst exp)) |exp <- ex] -printExpression :: ExplicitExpression -> Coercion -> Doc a -printExpression ExplicitEmpty _ = "[]" -printExpression (ExplicitVariable name coer) out = case coer `coercionIncluded` out of - Left err -> error $ show 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 (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) --- 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 - 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) +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)) + --error $ show $ mergeAssignmentTrees [convertToAssignmentTree (fst exp) (AssignmentLeaf (snd exp)) | exp <- ex] --- |Converts a coercion into a haskell string -printCoercion :: Coercion -> Doc a -> Doc a -printCoercion (MakeCoercion [] crd) d = printCardinalityCoercion crd d -printCoercion (MakeCoercion (t: ts) crd) d = printTypeCoercion t <> printCoercion (MakeCoercion ts crd) d - -printCardinalityCoercion :: CardinalityCoercion -> Doc a -> Doc a -printCardinalityCoercion (MakeCardinalityIdCoercion _) d = d -printCardinalityCoercion (MakeListCardinalityCoercion _ _) d = d -printCardinalityCoercion (MakeNothing2MaybeCoercion _ _) d = "Nothing" -printCardinalityCoercion (MakeNothing2ListCoercion _ _) d = "[]" -printCardinalityCoercion (MakeMaybe2ListCoercion _ _) d = "maybeToList" <+> d -printCardinalityCoercion (MakeObject2MaybeCoercion _ _) d = "Just" <+> d -printCardinalityCoercion (MakeObject2ListCoercion _ _) d = "[" <> d <> "]" - -printTypeCoercion :: TypeCoercion -> Doc a -printTypeCoercion (MakeIdCoercion _) = emptyDoc -printTypeCoercion (MakeSuperCoercion _ _) = "super" <+> emptyDoc -printTypeCoercion (MakeTypeCoercion _ _ t) = pretty t <+> emptyDoc - --- |Converts a list of type attributes to a Doc with a list of variable names -printVariableNames :: [TypeAttribute] -> Doc a -printVariableNames vars = foldl (<+>) emptyDoc (map (pretty . attributeName) vars) -- |Converts a function into a haskell valid Doc representing the signature of the function printFunctionSignature :: FunctionSignature -> Doc a @@ -90,9 +55,40 @@ printFunctionSignature (MakeFunctionSignature name description inputs output) = prettyPrintType :: [Doc x] -> Doc x prettyPrintType = align . sep . Prelude.zipWith (<+>) ("::" : repeat "->") --- |Gets the cardinality of a variable by name -getVarCardinality :: [TypeAttribute] -> String -> Cardinality -getVarCardinality [] _ = error "Variable not a parameter" -getVarCardinality (MakeTypeAttribute name _ card _ : inps) varName - | name == varName = card - | otherwise = getVarCardinality inps varName \ No newline at end of file +printAssignmentTree :: AssignmentTree -> Coercion -> Doc a +printAssignmentTree (AssignmentLeaf exp) coer = printExpression exp coer +printAssignmentTree (AssignmentNode var typ c) coer + | 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 <> ")" + | otherwise = case typ of + MakeType t _ _ _ _ -> "Make" <> pretty t <+> group (sep [printAssignmentTree child coer | child <- c]) + BasicType _ -> sep [printAssignmentTree child coer | child <- c] + +mergeAssignmentTrees :: [AssignmentTree] -> [AssignmentTree] +mergeAssignmentTrees [] = [] +mergeAssignmentTrees [a1] = [a1] +mergeAssignmentTrees (a1: a2 : as) + | length merge == 1 = mergeAssignmentTrees [AssignmentNode {var = var a1, typ = typ a1, children = mergeAssignmentTrees (children (head merge))}] ++ as + | otherwise = mergeAssignmentTrees (a1 : as) ++ mergeAssignmentTrees (a2 : as) + where + merge = mergeAssignmentTree a1 a2 + +mergeAssignmentTree :: AssignmentTree -> AssignmentTree -> [AssignmentTree] +mergeAssignmentTree (AssignmentNode var1 typ1 c1) (AssignmentNode var2 typ2 c2) + | typ1 == typ2 && var1 == var2 = [AssignmentNode var1 typ1 (c1 ++ c2)] + | otherwise = [AssignmentNode var1 typ1 c1, AssignmentNode var2 typ2 c2] +mergeAssignmentTree t1 t2 = [t1, t2] + +-- |Convert an assignment expression into an assignment tree +convertToAssignmentTree :: ExplicitExpression -> AssignmentTree -> AssignmentTree +convertToAssignmentTree (ExplicitVariable a c) t = AssignmentNode {var = a, typ = coercionType $ typeCoercion c, children = [t]} +convertToAssignmentTree (ExplicitPath ex1 (ExplicitVariable a c) _) t = + convertToAssignmentTree ex1 (AssignmentNode {var = a, typ = coercionType $ typeCoercion c, children = [t]}) +convertToAssignmentTree e _ = error $ "Unsupported expression in path expression " ++ show e + + +-- |Prints the type name if it is new type, or nothing for basic types +printConstructor :: Type -> Doc a +printConstructor (MakeType a _ _ _ _) = pretty a +printConstructor (BasicType a) = emptyDoc \ No newline at end of file diff --git a/src/PrettyPrinter/Type.hs b/src/PrettyPrinter/Type.hs index 75cd628..e94f05d 100644 --- a/src/PrettyPrinter/Type.hs +++ b/src/PrettyPrinter/Type.hs @@ -10,20 +10,26 @@ import Utils.Utils -- |Converts an EnumType into a haskell valid String printType :: Type -> String printType (MakeType name (MakeType super _ _ _ _) description attributes conditions) = printType (MakeType name (BasicType "Object") description (superToAttribute super:attributes) conditions) -printType (MakeType name (BasicType "Object") description attributes conditions) = - show $ printDescription description (vcat [nest 4 $ vcat ("data" <+> pretty name <+> "=" <+> "Make" <> pretty name <+> "{": printAttributes name attributes ++ map printCondition conditions), "}", emptyDoc, emptyDoc]) +printType (MakeType name (BasicType "Object") description attributes conditions) = + show $ printTypeName name description <+> + printAttributes name conditions attributes printType (MakeType _ (BasicType _) _ _ _) = error "Can't extend basic types" printType (BasicType name) = show $ pretty name +printTypeName :: String -> Maybe String -> Doc a +printTypeName name desc = printDescription desc (line <> "data" <+> pretty name <+> "=") + -- |Creates an attribute that accesses the super type superToAttribute :: String -> TypeAttribute superToAttribute typ = MakeTypeAttribute "super" (MakeType typ (BasicType "Object") Nothing [] []) (Bounds (1, 1)) (Just "Pointer to super class") -- |Converts a list of TypeAttributes into a list of haskell valid Docs -printAttributes :: String -> [TypeAttribute] -> [Doc a] -printAttributes _ [] = [] -printAttributes objName [at] = [printAttribute objName at] -printAttributes objName (at : ats) = (printAttribute objName at <> ",") : printAttributes objName ats +printAttributes :: String -> [Condition] -> [TypeAttribute] -> Doc a +printAttributes objName conditions ats + | MakeCondition Nothing (Keyword "one-of") `elem` conditions || length ats < 2 = vcat [nest 4 $ vcat $ + zipWith (<>) ("" : repeat "| ") (map (printSumType objName) ats) ++ map printCondition conditions, emptyDoc, emptyDoc] + | otherwise = vcat [nest 4 $ vcat ("Make" <> pretty objName <+> "{" : + reverse (zipWith (<>) (reverse (map (printAttribute objName) ats)) ("" : repeat ",")) ++ map printCondition conditions), "}", emptyDoc, emptyDoc] -- |Converts a TypeAttribute into a haskell valid Doc printAttribute :: String -> TypeAttribute -> Doc a @@ -40,4 +46,7 @@ printCardinality (MakeTypeAttribute _ typ (Bounds (x, y)) _) printCardinality (MakeTypeAttribute _ typ (OneBound _) _) = "[" <> pretty (typeName typ) <> "]" printCondition :: Condition -> Doc a -printCondition (MakeCondition desc e) = printDescription desc ("--" <+> pretty (show e)) \ No newline at end of file +printCondition (MakeCondition desc e) = printDescription desc ("--" <+> pretty (show e)) + +printSumType :: String -> TypeAttribute -> Doc a +printSumType objName (MakeTypeAttribute name typ crd _) = pretty objName <> pretty (capitalize name) <+> pretty (typeName typ) diff --git a/src/Semantic/ExpressionChecker.hs b/src/Semantic/ExpressionChecker.hs index c4a392a..cd470a5 100644 --- a/src/Semantic/ExpressionChecker.hs +++ b/src/Semantic/ExpressionChecker.hs @@ -92,6 +92,7 @@ checkExpression _ (Int val) = Right $ Value val $ MakeCoercion [MakeIdCoercion ( checkExpression _ (Real val) = Right $ Value val $ MakeCoercion [MakeIdCoercion (BasicType "Double")] (MakeCardinalityIdCoercion (Bounds (1, 1))) checkExpression _ (Boolean val) = Right $ Value val $ MakeCoercion [MakeIdCoercion (BasicType "Boolean")] (MakeCardinalityIdCoercion (Bounds (1, 1))) checkExpression _ Empty = Right $ Value "empty" $ MakeCoercion [MakeIdCoercion (BasicType "Empty")] (MakeCardinalityIdCoercion (Bounds (0, 0))) +checkExpression _ (Keyword k) = Right $ ExplicitKeyword k checkExpression symbolMap (PathExpression ex1 (Variable b)) = case checkExpression symbolMap ex1 of Left err -> Left err @@ -100,13 +101,13 @@ checkExpression symbolMap (PathExpression ex1 (Variable b)) = Right exp2 -> Right $ ExplicitPath exp1 exp2 (returnCoercion exp2) where type1 = coercionType $ typeCoercion $ returnCoercion exp1 +-- |Getting here means that an expression is used inside a path expression and this is not supported +checkExpression _ (PathExpression _ ex) = Left $ UnsupportedExpressionInPathExpression $ show ex --checkExpression symbolMap (PathExpression ex1 (PathExpression )) checkExpression symbolMap (Parens ex) = case checkExpression symbolMap ex of Left err -> Left err Right exp -> Right $ ExplicitParens exp --- |Getting here means that an expression is used inside a path expression and this is not supported -checkExpression _ (PathExpression _ ex) = Left $ UnsupportedExpressionInPathExpression $ show ex checkExpression symbolMap (List lst) = checkList symbolMap lst checkExpression symbolMap (PrefixExp name ex) = checkFunctionCall symbolMap name [checkExpression symbolMap ex] checkExpression symbolMap (Function name exps) = checkFunctionCall symbolMap name (map (checkExpression symbolMap) exps)