finished generator for basic types, enums and functions.

Functions still need to print a body

src/Model/Function.hs

@@ -8,7 +8,7 @@ data Function =
         functionDescription :: Maybe String,
         inputParameters :: [TypeAttribute],
         outputParameter :: TypeAttribute,
-        assignments :: [(Expression, Expression)]
+        assignment :: Expression
     }
     deriving (Show)
     

src/Model/RosettaObject.hs

@@ -0,0 +1,10 @@
+module Model.RosettaObject where
+
+import Model.Enum
+import Model.Function
+import Model.Type
+  
+data RosettaObject = 
+    EnumObject EnumType
+    | TypeObject Type
+    | FunctionObject Function

src/Model/Type.hs

@@ -29,7 +29,6 @@ data TypeAttribute = MakeTypeAttribute {
     attributeDescription :: Maybe String
 } deriving (Show)
 
---TODO use bounded class
 data Cardinality = Bounds (Integer, Integer)
   | OneBound Integer
   | NoBounds 

src/Parser/Enum.hs

@@ -10,7 +10,7 @@ import Model.Enum
 enumParser :: Parser EnumType
 enumParser = 
     do 
-        eName <- enumNameParser
+        eName <- try enumNameParser
         eDescription <- optional descriptionParser
         values <- some enumValueParser
         return (MakeEnum eName eDescription values)
@@ -18,7 +18,7 @@ enumParser =
 enumValueParser :: Parser EnumValue
 enumValueParser = 
     do
-        vName <- nameParser
+        vName <- try nameParser
         dName <- optional enumValueDisplayNameParser
         vDescription <- optional descriptionParser
         return (MakeEnumValue vName vDescription dName)

src/Parser/Expression.hs

@@ -193,7 +193,7 @@ reverseExpression e = e
 
 precedence :: String -> Int
 precedence "or" = 1
-precedence "and" = 1
+precedence "and" = 10
 precedence "+" = 2
 precedence "-" = 2
 precedence "*" = 3

src/Parser/Function.hs

@@ -14,22 +14,19 @@ functionParser :: Parser Function
 functionParser =
     do
         _ <- lexeme $ string "func"
-        fName <- pascalNameParser
+        fName <- try pascalNameParser
         _ <- lexeme $ char ':'
         fDescription <- optional descriptionParser
         fInput <- inputAttributesParser
         fOutput <- outputAttributeParser
-        fAssignments <- many assignmentParser
-        return (MakeFunction fName fDescription fInput fOutput fAssignments)
+        MakeFunction fName fDescription fInput fOutput <$> assignmentParser
 
-assignmentParser :: Parser (Expression, Expression)
+assignmentParser :: Parser Expression
 assignmentParser =
     do
         _ <- lexeme $ string "assign-output"
-        name <- expressionParser
         _ <- lexeme $ char ':'
-        expr <- expressionParser
-        return (name, expr)
+        expressionParser
 
 inputAttributesParser :: Parser [TypeAttribute]
 inputAttributesParser =
@@ -46,8 +43,8 @@ outputAttributeParser =
 attributeParser :: Parser TypeAttribute
 attributeParser =
     do
-        nam <- camelNameParser 
-        typ <- pascalNameParser <|> camelNameParser
+        nam <- try camelNameParser 
+        typ <- try (pascalNameParser <|> camelNameParser)
         crd <- cardinalityParser
         desc <- optional descriptionParser
         return $ MakeTypeAttribute nam (MakeType typ Nothing Nothing []) crd desc

src/Parser/General.hs

@@ -27,19 +27,33 @@ pascalNameParser :: Parser String
 pascalNameParser =
     do
         first <- upperChar
-        rest <- lexeme $ many (letterChar <|> digitChar <|> char '_')
-        return (first : rest)
+        rest <- lexeme $ many allowedChars
+        if first:rest `notElem` restrictedNames then return (first:rest) else fail ((first:rest) ++ " is a restricted name")
 
 camelNameParser :: Parser String
 camelNameParser =
     do
         first <- lowerChar
-        rest <- lexeme $ many (letterChar <|> digitChar <|> char '_')
-        return (first : rest)
+        rest <- lexeme $ many allowedChars
+        if first:rest `notElem` restrictedNames then return (first:rest) else fail ((first:rest) ++ " is a restricted name")
 
 nameParser :: Parser String
 nameParser = 
     do 
         first <- letterChar <|> char '_'
-        rest <- lexeme $ many (letterChar <|> digitChar <|> char '_')
-        return (first:rest)
+        rest <- lexeme $ many allowedChars
+        if first:rest `notElem` restrictedNames then return (first:rest) else fail ((first:rest) ++ " is a restricted name")
+
+allowedChars :: Parser Char
+allowedChars = letterChar <|> digitChar <|> char '_'
+        
+restrictedNames :: [String]
+restrictedNames = [
+    "displayName",
+    "enum",
+    "func",
+    "type",
+    "extends",
+    "inputs",
+    "output"
+  ]

src/Parser/Type.hs

@@ -10,7 +10,7 @@ import Parser.General
 typeParser :: Parser Type
 typeParser = 
     do 
-        tName <- typeNameParser
+        tName <- try typeNameParser
         tSuper <- optional superTypeParser
         _ <- lexeme $ char ':'
         tDescription <- optional descriptionParser
@@ -27,8 +27,8 @@ superTypeParser =
 typeAttributeParser :: Parser TypeAttribute
 typeAttributeParser = 
     do
-        aName <- camelNameParser
-        aType <- nameParser
+        aName <- try camelNameParser
+        aType <- try nameParser
         card <- cardinalityParser
         desc <- optional descriptionParser
         return (MakeTypeAttribute aName (MakeType aType Nothing Nothing []) card desc)

src/PrettyPrinter/Function.hs

@@ -9,6 +9,9 @@ import PrettyPrinter.Type
   
 -- show printStatementTree 
 
+printFunction :: Function -> String
+printFunction = show . printFunctionSignature
+
 printFunctionSignature :: Function -> Doc a
 printFunctionSignature (MakeFunction name description inputs output _) =
     printDescription description (pretty name <+> prettyPrintType (Prelude.map printCardinality (inputs ++ [output])))

src/PrettyPrinter/RosettaObject.hs

@@ -0,0 +1,11 @@
+module PrettyPrinter.RosettaObject where
+
+import Model.RosettaObject
+import PrettyPrinter.Enum
+import PrettyPrinter.Function
+import PrettyPrinter.Type
+  
+printRosettaObject :: RosettaObject -> String
+printRosettaObject (EnumObject a) = printEnum a
+printRosettaObject (TypeObject a) = printType a
+printRosettaObject (FunctionObject a) = printFunction a

src/PrettyPrinter/Type.hs

@@ -7,15 +7,24 @@ import PrettyPrinter.General
 import Model.Type
 
 printType :: Type -> String
-printType (MakeType name _ description attributes) =
-    show $ printDescription description (vcat [nest 4 $ vcat ("data" <+> pretty name <+> "=" <+> "Make" <> pretty name <+> "{": map printAttribute attributes), "}", ""])
+printType (MakeType name (Just (MakeType super _ _ _)) description attributes) = printType (MakeType name Nothing description (superToAttribute super:attributes))
+printType (MakeType _ (Just (BasicType _)) _ _) = error "Can't extend basic types"
+printType (MakeType name Nothing description attributes) =
+    show $ printDescription description (vcat [nest 4 $ vcat ("data" <+> pretty name <+> "=" <+> "Make" <> pretty name <+> "{": printAttributes attributes), "}", ""])
 printType (BasicType name) = show $ pretty name
    
+--printSuperType :: Maybe Type -> Doc a
+--printSuperType (Just (MakeType name _ _ _)) = "super" <+> "::" <+> pretty name
+--printSuperType (Just (BasicType _)) = error "Can't extend basic types"
+--printSuperType Nothing = emptyDoc
+   
+superToAttribute :: String -> TypeAttribute
+superToAttribute name = MakeTypeAttribute "super" (MakeType name Nothing Nothing []) (Bounds (1, 1)) (Just "Pointer to super class")  
+   
 printAttributes :: [TypeAttribute] -> [Doc a]
 printAttributes [] = []
 printAttributes [at] = [printAttribute at]
 printAttributes (at : ats) = (printAttribute at <> ",") : printAttributes ats
-
    
 printAttribute :: TypeAttribute -> Doc a
 printAttribute (MakeTypeAttribute name typ crd description) =

src/Semantic/ExpressionChecker.hs

@@ -51,7 +51,21 @@ defaultMap = [
   
   Func "count" [BasicType "Any"] (BasicType "Integer")
   ]
-    
+
+addFunction :: ([Type], [Symbol]) -> Function -> Either [TypeCheckError] [Symbol]
+addFunction (definedTypes, definedSymbols) (MakeFunction name _ inps out _)
+    | null (lefts checkedInputs) && isRight checkedOutput = Right $ Func name (map attributeType (rights checkedInputs)) (attributeType $ fromRightUnsafe checkedOutput) : allSymbols
+    | isLeft checkedOutput = Left [fromLeftUnsafe checkedOutput]
+    | otherwise = Left $  lefts checkedInputs 
+    where 
+        checkedInputs = checkAttributes definedTypes inps
+        checkedOutput = head $ checkAttributes definedTypes [out]
+        allSymbols = addVariables definedSymbols inps
+        
+addVariables :: [Symbol] -> [TypeAttribute] -> [Symbol]
+addVariables s [] = s
+addVariables s ((MakeTypeAttribute name typ _ _)  : vars) = Var name typ : addVariables s vars
+        
 checkExpression :: [Symbol] -> Expression -> Either TypeCheckError Type
 checkExpression symbolMap (Variable var) = findVarType var symbolMap
 checkExpression _ (Int _) = Right $ BasicType "Integer"
@@ -65,7 +79,7 @@ checkExpression symbolMap (Function name exps) = checkFunctionCall symbolMap nam
 checkExpression symbolMap (PostfixExp name ex) = checkFunctionCall symbolMap name [checkExpression symbolMap ex]
 checkExpression symbolMap (InfixExp name ex1 ex2) = checkFunctionCall symbolMap name (checkExpression symbolMap ex1: [checkExpression symbolMap ex2])
 checkExpression symbolMap (IfSimple cond ex)
-    | isLeft condType && isLeft (typeMatch (fromRightUnsafe condType) (BasicType "Boolean")) = checkExpression symbolMap ex
+    | isRight condType && isRight (typeMatch (fromRightUnsafe condType) (BasicType "Boolean")) = checkExpression symbolMap ex
     | otherwise = Left IfConditionNotBoolean
     where condType = checkExpression symbolMap cond
 checkExpression symbolMap (IfElse cond ex1 ex2)
@@ -95,7 +109,7 @@ checkList1 symbs (ex : exps) typ
 checkFunctionCall :: [Symbol] -> String -> [Either TypeCheckError Type] -> Either TypeCheckError Type
 checkFunctionCall [] fun args = Left $ UndefinedFunction $ "Undefined function: \"" ++ fun ++ "\" [" ++ concatMap typeName (rights args) ++ "]"
 checkFunctionCall ((Func n a r):symbolMap) name args
-    | length right /= length args = Left ErrorInsideFunction
+    | length right /= length args = Left $ ErrorInsideFunction (name ++ ": " ++ show args)
     | name == n && all isRight (zipWith typeMatch a right) = Right r
     | otherwise = checkFunctionCall symbolMap name args
     where right = rights args
@@ -118,14 +132,4 @@ findVarType var [] = Left $ UndefinedVariable var
 findVarType x ((Var name typ):symbols) 
     | x == name = Right typ
     | otherwise = findVarType x symbols
-findVarType x (_:symbols) = findVarType x symbols
-
-fromRightUnsafe :: Either a b -> b
-fromRightUnsafe x = case x of
-    Left _ -> error "Value is Left"
-    Right b -> b
-    
-fromLeftUnsafe :: Either a b -> a
-fromLeftUnsafe x = case x of
-    Left a -> a
-    Right _ -> error "Value is Right"
+findVarType x (_:symbols) = findVarType x symbols

src/Semantic/TypeChecker.hs

@@ -1,32 +1,53 @@
 module Semantic.TypeChecker where
 
 import Model.Type
+import Data.Either
 
 data TypeCheckError =
    UndefinedType String
    | IfConditionNotBoolean
    | IfExpressionsDifferentTypes
    | UndefinedFunction String
-   | ErrorInsideFunction
+   | ErrorInsideFunction String
    | UndefinedVariable String
    | TypeMismatch String String
    deriving (Show)
 
-checkAttributes :: [Type] -> [TypeAttribute] -> [Either TypeCheckError Type]
-checkAttributes _ [] = []
-checkAttributes definedTypes ((MakeTypeAttribute _ name _ _):as) = checkType definedTypes name : checkAttributes definedTypes as 
+checkType :: [Type] -> Type -> Either [TypeCheckError] Type
+checkType definedTypes (MakeType name super desc attr)
+    | null (lefts checkedAttr) = Right $ MakeType name super desc (rights checkedAttr)
+    | otherwise = Left $ lefts checkedAttr  
+    where checkedAttr = checkAttributes definedTypes attr 
+checkType _ (BasicType b) = Right (BasicType b)
 
-checkType :: [Type] -> Type -> Either TypeCheckError Type
-checkType _ (MakeType "int" _ _ _) = Right $ BasicType "Integer"
-checkType _ (MakeType "string" _ _ _) = Right $ BasicType "String"
-checkType _ (MakeType "number" _ _ _) = Right $ BasicType "Double"
-checkType _ (MakeType "boolean" _ _ _) = Right $ BasicType "Bool"
-checkType _ (MakeType "time" _ _ _) = Right $ BasicType "Time"
-checkType definedTypes name
+checkAttributes :: [Type] -> [TypeAttribute] -> [Either TypeCheckError TypeAttribute]
+checkAttributes _ [] = []
+checkAttributes definedTypes ((MakeTypeAttribute name typ crd desc):as)
+    | isRight checked = Right (MakeTypeAttribute name (fromRightUnsafe checked) crd desc) : checkAttributes definedTypes as
+    | otherwise = Left (fromLeftUnsafe checked) : checkAttributes definedTypes as
+    where checked = checkAttributeType definedTypes typ 
+
+checkAttributeType :: [Type] -> Type -> Either TypeCheckError Type
+checkAttributeType _ (MakeType "int" _ _ _) = Right $ BasicType "Integer"
+checkAttributeType _ (MakeType "string" _ _ _) = Right $ BasicType "String"
+checkAttributeType _ (MakeType "number" _ _ _) = Right $ BasicType "Double"
+checkAttributeType _ (MakeType "boolean" _ _ _) = Right $ BasicType "Bool"
+checkAttributeType _ (MakeType "time" _ _ _) = Right $ BasicType "Time"
+checkAttributeType definedTypes name
     | name `elem` definedTypes = Right name
     | otherwise = Left $ UndefinedType (typeName name)
     
 addDefinedTypes :: [Type] -> [Type] -> [Type]
 addDefinedTypes l [] = l
 addDefinedTypes l (BasicType _ : ts) = addDefinedTypes l ts
-addDefinedTypes l (t:ts) = t : addDefinedTypes l ts
+addDefinedTypes l (t:ts) = t : addDefinedTypes l ts
+
+fromRightUnsafe :: (Show a) => Either a b -> b
+fromRightUnsafe x = case x of
+    Left a -> error ("Value is Left" ++ show a)
+    Right b -> b
+    
+fromLeftUnsafe :: Either a b -> a
+fromLeftUnsafe x = case x of
+    Left a -> a
+    Right _ -> error "Value is Right"