finished generator for basic types, enums and functions.

Functions still need to print a body

.gitignore

@@ -22,3 +22,4 @@ cabal.project.local~
 .HTF/
 .ghc.environment.*
 .idea/
+/resources/Generated/

RosettaParser.cabal

@@ -27,6 +27,7 @@ library
   exposed-modules:
       Model.Enum
       Model.Function
+      Model.RosettaObject
       Model.Type
       Parser.Enum
       Parser.Expression
@@ -36,6 +37,7 @@ library
       PrettyPrinter.Enum
       PrettyPrinter.Function
       PrettyPrinter.General
+      PrettyPrinter.RosettaObject
       PrettyPrinter.Type
       Semantic.ExpressionChecker
       Semantic.TypeChecker

RosettaParser.iml

@@ -7,6 +7,7 @@
       <sourceFolder url="file://$MODULE_DIR$/src" isTestSource="false" />
       <sourceFolder url="file://$MODULE_DIR$/test" isTestSource="true" />
       <excludeFolder url="file://$MODULE_DIR$/.stack-work" />
+      <excludeFolder url="file://$MODULE_DIR$/resources/Generated" />
     </content>
     <orderEntry type="inheritedJdk" />
     <orderEntry type="sourceFolder" forTests="false" />

app/Main.hs

@@ -3,28 +3,84 @@ module Main where
 import Parser.Enum
 import Parser.Type
 import Parser.Function
+import Parser.General
+import Model.RosettaObject
 import qualified Data.Text as Text
 import Text.Megaparsec
 import PrettyPrinter.Enum
 import PrettyPrinter.Type
 import PrettyPrinter.Function
 import Semantic.TypeChecker
+import Semantic.ExpressionChecker
 import Model.Function
 import Model.Type
+import System.Environment.Blank (getArgs)
+import Model.Enum
+import Data.Either
 
+-- :set args resources/testAll.rosetta resources/Generated/testAll.hs
 main :: IO ()
 main = do
-    rosettaString <- readFile "app/testFile.rosetta"
-    putStrLn "rosetta String: " 
-    putStrLn rosettaString
-    putStrLn "\nFinal enum: \n"
-    case parse enumParser "" (Text.pack rosettaString) of
+    args <- getArgs
+    rosettaString <- readFile $ head args
+    case parse rosettaParser "" (Text.pack rosettaString) of
         Left errorBundle -> print (errorBundlePretty errorBundle)
-        Right enum -> putStrLn $ printEnum enum
+        Right objs -> do
+            putStrLn $ printObjects (definedTypes, definedFunctions) objs
+            where 
+                definedFunctions = addNewFunctions (definedTypes, defaultMap) objs
+                definedTypes = addNewTypes [] objs
+      
+printObjects :: ([Type], [Symbol]) -> [RosettaObject] -> String
+printObjects (t, s) objs
+    | null (lefts finalString) = concat $ rights finalString
+    | otherwise = error $ show $ lefts finalString
+    where finalString = map (printObject (t, s)) objs  
+                    
+printObject :: ([Type], [Symbol]) -> RosettaObject -> Either [TypeCheckError] String
+printObject (definedTypes, _) (TypeObject t)
+    | isRight checked = Right $ printType t
+    | otherwise = Left $ fromLeftUnsafe checked
+    where checked = checkType definedTypes t
+printObject _ (EnumObject e) = Right $ printEnum e
+printObject (_, definedFunctions) (FunctionObject (MakeFunction name desc inp out ex))
+    | isRight checked = Right $ printFunction (MakeFunction name desc inp out ex)
+    | otherwise = Left [fromLeftUnsafe checked]
+    where 
+        checked = checkExpression definedFunctions ex
+
+addNewFunctions :: ([Type], [Symbol]) -> [RosettaObject] -> [Symbol]
+addNewFunctions (_, s) [] = s
+addNewFunctions (t, s) ((FunctionObject f):os)
+    | isRight definedFunctions = fromRightUnsafe definedFunctions
+    | otherwise = error $ show $ fromLeftUnsafe definedFunctions
+    where definedFunctions = addFunction (t, addNewFunctions (t, s) os) f
+addNewFunctions (t, s) (_:os) = addNewFunctions (t, s) os
+
+addNewTypes :: [Type] -> [RosettaObject] -> [Type]
+addNewTypes l [] = l
+addNewTypes defined (TypeObject o: os) = addDefinedTypes (addNewTypes defined os) [o] 
+addNewTypes defined (EnumObject (MakeEnum name _ _): os) = addDefinedTypes (addNewTypes defined os) [MakeType name Nothing Nothing []]
+addNewTypes defined (_ :os) = addNewTypes defined os
+
+rosettaParser :: Parser [RosettaObject]
+rosettaParser = many (try parseEnum <|> try parseType <|> try parseFunction) <* eof
+
+parseEnum :: Parser RosettaObject
+parseEnum = do
+    EnumObject <$> enumParser
+    
+parseType :: Parser RosettaObject
+parseType = do
+    TypeObject <$> typeParser
+    
+parseFunction :: Parser RosettaObject
+parseFunction = do
+    FunctionObject <$> functionParser
 
 testEnum :: IO()
 testEnum = do
-    rosettaString <- readFile "resources/Enums/testEnum5.rosetta"
+    rosettaString <- readFile "resources/Enums/testEnum1.rosetta"
     case parse enumParser "" (Text.pack rosettaString) of
         Left errorBundle -> print errorBundle
         Right enum -> 
@@ -61,5 +117,5 @@ testFunc = do
         Right fun -> 
             do
                 print $ printFunctionSignature fun
-                print (assignments fun)
+                print (assignment fun)
                 writeFile "resources/Generated/generatedFunction.hs" (show $ printFunctionSignature fun) 

resources/Types/testType1.rosetta

@@ -1,4 +1,4 @@
-type Period: <"description">
+type Period extends Something: <"description">
     periodMultiplier int (1..1) <"A time period multiplier, e.g. 1, 2 or 3 etc. A negative value can be used when specifying an offset relative to another date, e.g. -2 days.">
     testMany TestType (0..*) <"Test many">
     testSome TestSomeType (1..*) <"Test some">

resources/testAll.rosetta

@@ -0,0 +1,34 @@
+enum PeriodEnum: <"The enumerated values to specified the period, e.g. day, week.">
+    D displayName "day" <"Day">
+    M displayName "month" <"Month">
+    Y displayName "year" <"Year">
+
+type Period extends Something: <"description">
+    periodMultiplier int (1..1) <"A time period multiplier, e.g. 1, 2 or 3 etc. A negative value can be used when specifying an offset relative to another date, e.g. -2 days.">
+    testMany TestType (0..*) <"Test many">
+    testSome TestSomeType (1..*) <"Test some">
+    testMaybeOne TestZeroOneType (0..1) <"Test zero or one">
+
+type TestType:
+    periodMultiplier int (1..1)
+
+type TestSomeType: <"description">
+    periodMultiplier int (1..1) <"A time period multiplier, e.g. 1, 2 or 3 etc. A negative value can be used when specifying an offset relative to another date, e.g. -2 days.">
+
+type TestZeroOneType extends Period:
+    periodMultiplier int (1..1)
+
+type ObservationPrimitive:
+    periodMultiplier int (1..1)
+
+func EquityPriceObservation: <"Function specification for the observation of an equity price, based on the attributes of the 'EquityValuation' class.">
+   inputs:
+      equity int (1..1)
+      valuationDate int (1..1)
+      valuationTime int (0..1)
+      timeType TestType (0..1)
+      determinationMethod ObservationPrimitive (1..*)
+   output:
+      observation ObservationPrimitive (1..1)
+
+   assign-output: if equity exists then valuationDate

resources/testFunction.rosetta

@@ -8,5 +8,4 @@ func EquityPriceObservation: <"Function specification for the observation of an
    output:
       observation ObservationPrimitive (1..1)
 
-   assign-output
-       observation: if asd exists then var2
+   assign-output: if asd exists then var2

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,16 +7,25 @@ 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) =
     printDescription description 

src/Semantic/ExpressionChecker.hs

@@ -52,6 +52,20 @@ 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
@@ -119,13 +133,3 @@ 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"

src/Semantic/TypeChecker.hs

@@ -1,28 +1,39 @@
 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)
     
@@ -30,3 +41,13 @@ addDefinedTypes :: [Type] -> [Type] -> [Type]
 addDefinedTypes l [] = l
 addDefinedTypes l (BasicType _ : ts) = 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"