initial commit

src/Parser/AnotherExpression.hs

@@ -0,0 +1,251 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Parser.AnotherExpression where
+
+import Parser.General
+import qualified Data.Text as Text
+import Text.Megaparsec
+import Text.Megaparsec.Char
+  
+data Expression = Variable String
+    | Int String
+    | Real String
+    | Boolean String
+    | Empty
+    | Parens Expression
+    | List [Expression]
+    | Function String [Expression]
+    | PrefixExp String Expression
+    | PostfixExp String Expression
+    | InfixExp String Expression Expression
+    | IfSimple Expression Expression
+    | IfElse Expression Expression Expression
+    deriving (Show)
+
+
+expressionParser :: Parser Expression
+expressionParser = 
+    choice [ ifParser,
+    try functionParser,
+    eqParser]
+
+--------------------------------------------
+-- Command Structures ----------------------
+--------------------------------------------
+
+functionParser :: Parser Expression
+functionParser =
+    do
+        f <- pascalNameParser
+        _ <- spaceConsumer
+        _ <- char '('
+        ats <- many $ try (expressionParser >>= \ats -> spaceConsumer >> char ',' >> spaceConsumer >> return ats)
+        lat <- optional expressionParser
+        _ <- spaceConsumer
+        _ <- char ')'
+        _ <- spaceConsumer
+        case lat of
+            Nothing -> return $ Function f []
+            Just at -> return $ Function f (ats ++ [at])
+
+ifParser :: Parser Expression
+ifParser =
+    do
+        _ <- string "if"
+        _ <- spaceConsumer
+        condition <- between (char '(') (char ')') expressionParser <|> expressionParser
+        _ <- spaceConsumer
+        _ <- string "then"
+        _ <- spaceConsumer
+        expr <- expressionParser
+        _ <- spaceConsumer
+        els <- observing $ string "else"
+        _ <- spaceConsumer
+        case els of
+            Left _ -> return (IfSimple condition expr)
+            Right _ -> expressionParser >>= \expr2 -> return (IfElse condition expr expr2)
+    
+parens :: Parser a -> Parser a
+parens = between (char '(') (char ')')
+
+--------------------------------------------
+-- Terminals -------------------------------
+--------------------------------------------
+
+listParser :: Parser Expression
+listParser =
+    do
+        _ <- char '['
+        _ <- spaceConsumer
+        expressions <- many $ try (expressionParser >>= \ex -> spaceConsumer >> char ',' >> spaceConsumer >> return ex)
+        _ <- spaceConsumer
+        lastExpr <- try expressionParser
+        _ <- spaceConsumer
+        _ <- char ']'
+        _ <- spaceConsumer
+        return $ List (expressions ++ [lastExpr])
+
+variableParser :: Parser Expression
+variableParser =
+    do
+        var <- camelNameParser
+        _ <- spaceConsumer
+        inner <- many innerVariableParser
+        return $ Variable (var ++ concatMap ("->" ++) inner)
+
+innerVariableParser :: Parser String
+innerVariableParser =
+    do
+        _ <- string "->"
+        _ <- spaceConsumer
+        var <- camelNameParser
+        _ <- spaceConsumer
+        return var
+
+integerParser :: Parser Expression
+integerParser =
+    do
+        nr <- some digitChar
+        _ <- spaceConsumer
+        return $ Int $ show nr
+        
+decimalParser :: Parser Expression
+decimalParser =
+    do
+        nr <- some digitChar
+        _ <- char '.'
+        real <- many digitChar
+        _ <- spaceConsumer
+        return $ Real $ show nr ++ "." ++ real
+        
+booleanParser :: Parser Expression
+booleanParser =
+    do
+        bol <- string "True" <|> string "False"
+        _ <- spaceConsumer
+        return $ Boolean $ Text.unpack bol
+
+emptyParser :: Parser Expression
+emptyParser = 
+    do
+        _ <- string "empty"
+        _ <- spaceConsumer
+        return Empty
+
+terminalParser :: Parser Expression
+terminalParser =
+    do
+        choice 
+            [ prefixParser,
+             parens expressionParser >>= \e -> return (Parens e),
+             listParser,
+             try booleanParser,
+             try emptyParser,
+             try decimalParser,
+             try variableParser,
+             integerParser
+            ]
+
+--------------------------------------------
+-- Expressions -----------------------------
+--------------------------------------------
+
+prefixParser :: Parser Expression
+prefixParser = 
+    do
+        op <- choice $ fmap (try . string . Text.pack) prefixOperators
+        _ <- spaceConsumer
+        ex <- expressionParser
+        _ <- spaceConsumer
+        return $ PrefixExp (Text.unpack op) ex
+
+eqParser :: Parser Expression
+eqParser =
+    do
+        s <- sumParser
+        _ <- spaceConsumer
+        op <- observing (string  "<=" <|> string "=" <|> string "<" <|> string ">" <|> string ">=")
+        _ <- spaceConsumer
+        case op of
+            Left _ -> return s
+            Right o -> eqParser >>= \ex -> return $ InfixExp (Text.unpack o) s ex
+
+sumParser :: Parser Expression
+sumParser =
+    do
+        f <- factorParser
+        _ <- spaceConsumer
+        op <- observing (char '+' <|> char '-')
+        _ <- spaceConsumer
+        case op of
+            Left _ -> return f
+            Right o -> sumParser >>= \ex -> return $ reverseExpression $ InfixExp [o] f ex
+
+factorParser :: Parser Expression
+factorParser = 
+    do 
+        p <- powerParser
+        _ <- spaceConsumer
+        op <- observing (char '*' <|> char '/')
+        _ <- spaceConsumer
+        case op of
+            Left _ -> return p
+            Right o -> factorParser >>= \ex -> return $ reverseExpression $ InfixExp [o] p ex
+
+powerParser :: Parser Expression
+powerParser = 
+    do
+        p <- postfixParser
+        _ <- spaceConsumer
+        op <- observing $ char '^'
+        _ <- spaceConsumer
+        case op of
+            Left _ -> return p
+            Right _ -> powerParser >>= \ex -> return $ InfixExp "^" p ex
+            
+postfixParser :: Parser Expression
+postfixParser = 
+    do
+        t <- terminalParser
+        _ <- spaceConsumer
+        op <- observing (string "exists" <|> string "is absent" <|> string "count" <|> string "only-element")
+        _ <- spaceConsumer
+        case op of
+            Left _ -> return t
+            Right o -> return $ PostfixExp (Text.unpack o) t
+
+--------------------------------------------
+-- Auxiliary  ------------------------------
+--------------------------------------------
+
+reverseExpression :: Expression -> Expression
+reverseExpression (InfixExp op t1 (InfixExp op2 t2 e))
+    | precedence op == precedence op2 = InfixExp op2 (reverseExpression (InfixExp op t1 t2)) e
+    | otherwise = InfixExp op t1 (InfixExp op2 t2 e)
+reverseExpression e = e
+
+precedence :: String -> Int
+precedence "or" = 1
+precedence "and" = 1
+precedence "+" = 2
+precedence "-" = 2
+precedence "*" = 3
+precedence "/" = 3
+precedence "^" = 4
+precedence _ = 100
+
+prefixOperators :: [String]
+prefixOperators = ["-", "not"]
+
+testArith3 = parseTest expressionParser "1 + (2 - 3)"
+testArith4 = parseTest expressionParser "a * b - c * d - e * f = g * h - i * j - k * l"
+testArith5 = parseTest expressionParser "a + b - c * d ^ e"
+testArith6 = parseTest expressionParser "1 - 2 - 3 - 4 - 5 - 6"
+testList = parseTest expressionParser "[1, 2, 3]"
+testList2 = parseTest expressionParser "[1, 2 + 3, e]"
+testFun = parseTest functionParser "Function()"
+testFun2 = parseTest functionParser "Function(e)"
+testFun3 = parseTest functionParser "Function(3, 3+2,e)"
+testIf = parseTest expressionParser "if (Function(2 + 3, e)) then a + b - c * d ^ e -> x else not a exists"
+testEverything = parseTest expressionParser "if [1, Function(3)] then 1 - 2 - 3 * a -> b ^ c"
+testFail = parseTest expressionParser "if[1,as]thenxandoelseaora"

src/Parser/Enum.hs

@@ -0,0 +1,72 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Parser.Enum where
+
+import Parser.General
+import Text.Megaparsec.Char
+import Text.Megaparsec
+import Model.Enum
+
+--parseTest enumParser "enum periodEnum: <\"description\"> D displayName \"day\" <\"Day\">"
+enumParser :: Parser EnumType
+enumParser = 
+    do 
+        eName <- enumNameParser
+        eDescription <- descriptionParser
+        values <- many enumValueParser
+        _ <- spaceConsumer
+        return (MakeEnum eName (Just eDescription) values)
+
+--parseTest enumValueParser "D displayName \"day\" <\"Day\">"        
+enumValueParser :: Parser EnumValue
+enumValueParser = 
+    do
+        vName <- enumValueNameParser
+        dName <- enumValueDisplayNameParser
+        vDescription <- descriptionParser
+        return (MakeEnumValue vName (Just vDescription) (Just dName))
+
+enumValueNameParser :: Parser String
+enumValueNameParser = 
+    do
+        name <- nameParser
+        _ <- spaceConsumer
+        return name
+
+enumValueDisplayNameParser :: Parser String
+enumValueDisplayNameParser =
+    do
+        _ <- string "displayName \""
+        name <- anySingle `manyTill` char '"'
+        _ <- spaceConsumer
+        return name
+
+enumNameParser :: Parser String
+enumNameParser = 
+    do
+        _ <- string "enum"
+        _ <- spaceConsumer
+        name <- nameParser
+        _ <- char ':'
+        _ <- spaceConsumer
+        return name 
+
+periodEnum :: EnumType
+periodEnum = MakeEnum 
+    "PeriodEnum" 
+    (Just "The enumerated values to specifie the period, e.g. day, week.")
+    [MakeEnumValue 
+    "D"
+    (Just "Day")
+    Nothing,
+    
+    MakeEnumValue
+    "W"
+    (Just "Week")
+    Nothing,
+    
+    MakeEnumValue
+    "Y"
+    (Just "Year")
+    Nothing
+    ]

src/Parser/Expr.hs

@@ -0,0 +1,3 @@
+module Parser.Expr where
+
+import Parser.General

src/Parser/Expression.hs

@@ -0,0 +1,165 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Parser.Expression where
+
+import Text.Megaparsec
+import Text.Megaparsec.Char
+import Model.Function
+import Parser.General
+import Data.Text
+     
+variableParser :: Parser Expression
+variableParser =
+    do
+        var <- camelNameParser
+        _ <- spaceConsumer
+        return $ Variable var
+   
+integerParser :: Parser Expression
+integerParser =
+    do
+        nr <- some digitChar
+        _ <- spaceConsumer
+        return $ Literal $ show nr
+        
+decimalParser :: Parser Expression
+decimalParser =
+    do
+        nr <- some digitChar
+        _ <- char '.'
+        real <- many digitChar
+        _ <- spaceConsumer
+        return $ Literal $ show nr ++ "." ++ real
+        
+booleanParser :: Parser Expression
+booleanParser =
+    do
+        bol <- string (pack "True") <|> string (pack "False")
+        _ <- spaceConsumer
+        return $ Literal $ unpack bol
+
+listParser :: Parser Expression
+listParser = 
+    do
+        _ <- char '['
+        _ <- spaceConsumer
+        expressions <- many $ try expressionList
+        _ <- spaceConsumer
+        lastExpr <- try expressionParser
+        _ <- spaceConsumer
+        _ <- char ']'
+        _ <- spaceConsumer
+        return $ ExpressionList (expressions ++ [lastExpr])
+        where
+            expressionList = 
+                do
+                    expr <- expressionParser
+                    _ <- spaceConsumer
+                    _ <- char ','
+                    _ <- spaceConsumer
+                    return expr
+
+emptyParser :: Parser Expression
+emptyParser = 
+    do
+        _ <- string "empty"
+        _ <- spaceConsumer
+        return $ Literal "empty"
+
+literalParser :: Parser Expression
+literalParser =
+    do
+        choice 
+            [ booleanParser,
+             try emptyParser,
+             try decimalParser,
+             try variableParser,
+             integerParser
+            ]
+        
+parensParser :: Parser Expression 
+parensParser = 
+    do
+        _ <- char '('
+        expr <- expressionParser
+        _ <- char ')'
+        return expr
+
+ifElseParser :: Parser Expression
+ifElseParser =
+    do
+        (IfSimple cond expr) <- simpleIfParser
+        _ <- string "else"
+        _ <- spaceConsumer
+        expr2 <- expressionParser
+        _ <- spaceConsumer
+        return $ IfElse cond expr expr2
+
+simpleIfParser :: Parser Expression
+simpleIfParser = 
+    do
+        _ <- string "if"
+        _ <- spaceConsumer
+        condition <- expressionParser
+        _ <- spaceConsumer
+        _ <- string "then"
+        _ <- spaceConsumer
+        expr <- expressionParser
+        _ <- spaceConsumer
+        return $ IfSimple condition expr
+  
+andParser :: Parser Expression
+andParser = 
+    do
+        (ex1, ex2) <- try $ binaryParser "and"
+        return $ And ex1 ex2
+        
+orParser :: Parser Expression
+orParser =
+    do
+        (ex1, ex2) <- try $ binaryParser "or"
+        return $ Or ex1 ex2
+        
+subParser :: Parser Expression
+subParser =
+    do
+        (ex1, ex2) <- try $ binaryParser "-"
+        return $ Subtract ex1 ex2
+        
+notParser :: Parser Expression
+notParser =
+    do
+        _ <- string "not"
+        _ <- spaceConsumer
+        ex <- expressionParser
+        _ <- spaceConsumer
+        return $ Not ex
+        
+binaryParser :: String -> Parser (Expression, Expression)
+binaryParser op =
+    do
+        ex1 <- literalParser
+        _ <- spaceConsumer
+        _ <- string $ pack op
+        _ <- spaceConsumer
+        ex2 <- expressionParser
+        _ <- spaceConsumer
+        return (ex1, ex2)
+        
+expressionParser :: Parser Expression
+expressionParser = choice 
+    [parensParser,
+    notParser,
+    andParser,
+    orParser,
+    subParser,
+    ifElseParser,
+    simpleIfParser,
+    literalParser,
+    variableParser
+    ]
+
+testIfElse = parseTest expressionParser "if asd then 123 else 4"
+testAnd = parseTest expressionParser "23 and 34 and 24 and a"
+testOr = parseTest expressionParser "23 or 34 or 24 or a"
+testMin = parseTest expressionParser "(a - b) - c"

src/Parser/Function backup.hs

@@ -0,0 +1,185 @@
+module Parser.Function where
+
+import Model.Function
+import Model.Type (TypeAttribute)
+import Parser.Type (typeAttributeParser)
+import Text.Megaparsec.Char
+import Text.Megaparsec
+import Parser.General
+import Data.Text
+
+functionParser :: Parser Function
+functionParser =
+    do
+        _ <- string $ pack "func"
+        _ <- spaceConsumer
+        fName <- pascalNameParser
+        _ <- char ':'
+        _ <- spaceConsumer
+        fDescription <- descriptionParser
+        fInput <- inputAttributesParser
+        fOutput <- outputAttributeParser
+        fConditions <- many (try postConditionParser <|> try conditionParser)
+        _ <- spaceConsumer
+        return (MakeFunction fName (Just fDescription) fInput fOutput fConditions)
+
+inputAttributesParser :: Parser [TypeAttribute]
+inputAttributesParser =
+    do
+        _ <- string $ pack "inputs:"
+        _ <- spaceConsumer
+        inputs <- many $ try typeAttributeParser
+        _ <- spaceConsumer
+        return inputs
+
+outputAttributeParser :: Parser TypeAttribute
+outputAttributeParser =
+    do
+        _ <- string $ pack "output:"
+        _ <- spaceConsumer
+        outputs <- typeAttributeParser
+        _ <- spaceConsumer
+        return outputs
+
+--parseTest conditionParser pack "condition: <\"Optional choice between directly passing a time or a timeType, which has to be resolved into a time based on the determination method.\"> if valuationTime exists then timeType is absent else if timeType exists then valuationTime is absent else False"
+
+conditionParser :: Parser Condition
+conditionParser =
+    do
+        _ <- string $ pack "condition:"
+        _ <- spaceConsumer
+        description <- descriptionParser
+        (Expression statementString) <- lookAhead expressionParser
+        _ <- string $ pack statementString
+        rest <- getInput
+        _ <- setInput $ pack statementString
+        statement <- statementParser
+        _ <- setInput rest
+        _ <- spaceConsumer
+        return $ MakeCondition (Just description) statement
+--parseTest postConditionParser (pack "post-condition: <\"The date and time must be properly resolved as attributes on the output.\"> observation -> date = ResolveAdjustableDate(valuationDate) and if valuationTime exists then observation -> time = TimeZoneFromBusinessCenterTime(valuationTime) else observation -> time = ResolveTimeZoneFromTimeType(timeType, determinationMethod)")
+
+postConditionParser :: Parser Condition
+postConditionParser =
+    do
+        _ <- string $ pack "post-condition:"
+        _ <- spaceConsumer
+        description <- descriptionParser
+        (Expression statementString) <- lookAhead expressionParser
+        _ <- string $ pack statementString
+        rest <- getInput
+        _ <- setInput $ pack statementString
+        statement <- statementParser
+        _ <- setInput rest
+        _ <- spaceConsumer
+        return $ MakePostCondition (Just description) statement
+
+statementParser :: Parser Expression
+statementParser =
+    do
+        statement <-
+            try ifElseParser <|>
+            try ifParser <|>
+
+            try (binaryOpParser " and ") <|>
+            try (binaryOpParser " contains ") <|>
+            try (binaryOpParser " or ") <|>
+            try (binaryOpParser " = ") <|>
+            try (binaryOpParser " <> ") <|>
+            try (binaryOpParser " < ") <|>
+            try (binaryOpParser " <= ") <|>
+            try (binaryOpParser " >") <|>
+            try (binaryOpParser " >= ") <|>
+
+            try (unaryOpParser " count") <|>
+            try (unaryOpParser " exists") <|>
+            try (unaryOpParser " is absent") <|>
+            
+            expressionParser
+        _ <- spaceConsumer
+        return statement
+
+--binaryOpParser :: String -> Parser Expression
+--binaryOpParser op =
+--    do
+--        argument1String <- untilParser op
+--        rest <- getInput
+--        _ <- setInput $ pack argument1String
+--        argument1 <- statementParser
+--        _ <- setInput rest
+--        _ <- spaceConsumer
+--        argument2 <- statementParser
+--        _ <- spaceConsumer
+--        return $ BinaryOp (unpack $ strip $ pack op) argument1 argument2
+--
+--unaryOpParser :: String -> Parser Expression
+--unaryOpParser op =
+--    do
+--        statementString <- untilParser op
+--        rest <- getInput
+--        _ <- setInput $ pack statementString
+--        statement <- statementParser
+--        _ <- setInput rest
+--        _ <- spaceConsumer
+--        return $ UnaryOp (unpack $ strip $ pack op) statement 
+--
+--ifParser :: Parser Expression
+--ifParser =
+--    do
+--        _ <- string $ pack "if"
+--        _ <- spaceConsumer
+--        cond <- statementParser
+--        _ <- spaceConsumer
+--        _ <- string $ pack "then"
+--        expr <- statementParser
+--        _ <- spaceConsumer
+--        return $ IfSimple cond expr
+
+--ifParser :: Parser Expression
+--ifParser =
+--    do
+--        _ <- string $ pack "if"
+--        _ <- spaceConsumer
+--        conditionString <- untilParser "then"
+--        rest <- getInput
+--        _ <- setInput $ pack conditionString
+--        condition <- statementParser
+--        _ <- setInput rest
+--        _ <- spaceConsumer
+--        stmt <- statementParser
+--        return $ If condition stmt
+
+--ifElseParser :: Parser Expression
+--ifElseParser =
+--    do
+--        _ <- string $ pack "if"
+--        _ <- spaceConsumer
+--        conditionString <- untilParser "then"
+--        rest <- getInput
+--        _ <- setInput $ pack conditionString
+--        condition <- statementParser
+--        _ <- setInput rest
+--        _ <- spaceConsumer
+--        thenString <- untilParser "else"
+--        rest1 <- getInput
+--        _ <- setInput $ pack thenString
+--        thenExpression <- statementParser
+--        _ <- setInput rest1
+--        _ <- spaceConsumer
+--        elseExpression <- statementParser
+--        return $ IfElse condition thenExpression elseExpression
+
+--parseTest expressionParser (pack "alalala condition:")
+
+expressionParser :: Parser Expression
+expressionParser =
+    do
+        statement <-
+            untilParser "post-condition:" <|>
+            untilParser "condition:" <|>
+            untilParser "func" <|>
+            untilParser "enum" <|>
+            untilParser "type" <|>
+            try (anySingle `manyTill` eof)
+        _ <- spaceConsumer
+        return $ Expression $ unpack (strip $ pack statement)

src/Parser/Function.hs

@@ -0,0 +1,70 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Parser.Function where
+
+import Parser.Expression
+import Parser.Type
+import Model.Function
+import Model.Type
+import Text.Megaparsec
+import Text.Megaparsec.Char
+import Parser.General
+  
+functionParser :: Parser Function
+functionParser =
+    do
+        _ <- string "func"
+        _ <- spaceConsumer
+        fName <- pascalNameParser
+        _ <- char ':'
+        _ <- spaceConsumer
+        fDescription <- descriptionParser
+        fInput <- inputAttributesParser
+        fOutput <- outputAttributeParser
+        fAssignments <- many assignmentParser
+        _ <- spaceConsumer
+        return (MakeFunction fName (Just fDescription) fInput fOutput fAssignments)
+
+assignmentParser :: Parser (Expression, Expression)
+assignmentParser =
+    do
+        _ <- string "assign-output"
+        _ <- spaceConsumer
+        name <- expressionParser
+        _ <- spaceConsumer
+        _ <- char ':'
+        _ <- spaceConsumer
+        expr <- expressionParser
+        _ <- spaceConsumer
+        return (name, expr)
+
+inputAttributesParser :: Parser [TypeAttribute]
+inputAttributesParser =
+    do
+        _ <- string "inputs:"
+        _ <- spaceConsumer
+        inputs <- many $ try attributeParser
+        _ <- spaceConsumer
+        return inputs
+
+outputAttributeParser :: Parser TypeAttribute
+outputAttributeParser =
+    do
+        _ <- string "output:"
+        _ <- spaceConsumer
+        outputs <- attributeParser
+        _ <- spaceConsumer
+        return outputs
+        
+attributeParser :: Parser TypeAttribute
+attributeParser =
+    do
+        nam <- camelNameParser 
+        _ <- spaceConsumer
+        typ <- pascalNameParser <|> camelNameParser
+        _ <- spaceConsumer
+        crd <- cardinalityParser
+        _ <- spaceConsumer
+        desc <- optional descriptionParser
+        return $ MakeTypeAttribute nam typ crd desc
+        

src/Parser/General.hs

@@ -0,0 +1,53 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Parser.General where
+
+import Text.Megaparsec
+import Data.Void
+import Text.Megaparsec.Char
+import qualified Text.Megaparsec.Char.Lexer as L
+import Data.Text
+
+type Parser = Parsec Void Text
+
+spaceConsumer :: Parser ()
+spaceConsumer = L.space space1 (L.skipLineComment "//") (L.skipBlockComment "/*" "*/")
+
+symbol :: Text -> Parser Text
+symbol = L.symbol spaceConsumer
+
+descriptionParser :: Parser String
+descriptionParser = 
+    do
+        _ <- string "<\""
+        description <- anySingle `manyTill` string "\">"
+        _ <- spaceConsumer
+        return description
+        
+
+pascalNameParser :: Parser String
+pascalNameParser =
+    do
+        first <- upperChar
+        rest <- many (letterChar <|> digitChar <|> char '_')
+        _ <- spaceConsumer
+        return (first : rest)
+
+camelNameParser :: Parser String
+camelNameParser =
+    do
+        first <- lowerChar
+        rest <- many (letterChar <|> digitChar <|> char '_')
+        _ <- spaceConsumer
+        return (first : rest)
+
+nameParser :: Parser String
+nameParser = 
+    do 
+        first <- letterChar <|> char '_'
+        rest <- many (letterChar <|> digitChar <|> char '_')
+        _ <- spaceConsumer
+        return (first:rest)
+        
+untilParser :: String -> Parser String
+untilParser x = try (anySingle `manyTill` string (pack x))

src/Parser/Type.hs

@@ -0,0 +1,110 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Parser.Type where
+
+import Model.Type
+import Text.Megaparsec.Char
+import Text.Megaparsec
+import Parser.General 
+  
+--parseTest typeParser "type Period: <\"description\"> periodMultiplier int (1..1) <\"A time period multiplier\"> period periodEnum (1..1) <\"A time period \">"
+typeParser :: Parser Type
+typeParser = 
+    do 
+        tName <- typeNameParser
+        tDescription <- descriptionParser
+        tAttributes <- many $ try typeAttributeParserWDesc <|> try typeAttributeParser
+        _ <- spaceConsumer
+        return (MakeType tName (Just tDescription) tAttributes)
+
+typeAttributeParserWDesc :: Parser TypeAttribute
+typeAttributeParserWDesc = 
+    do
+        (MakeTypeAttribute aName aType card Nothing) <- typeAttributeParser
+        descriptionParser >>= \aDescription -> return (MakeTypeAttribute aName aType card (Just aDescription))
+
+typeAttributeParser :: Parser TypeAttribute
+typeAttributeParser = 
+    do
+        aName <- attributeNameParser
+        aType <- nameParser
+        _ <- spaceConsumer
+        card <- cardinalityParser
+        _ <- spaceConsumer
+        return (MakeTypeAttribute aName aType card Nothing)
+
+cardinalityParser :: Parser Cardinality
+cardinalityParser =
+    do
+        card <- parseExactlyOne <|> parseOneOrMore <|> parseZeroOrMore <|> parseZeroOrOne
+        _ <- spaceConsumer
+        return card
+
+parseOneOrMore :: Parser Cardinality
+parseOneOrMore = 
+    do
+        _ <- string "(1..*)"
+        return OneOrMore
+
+
+parseExactlyOne :: Parser Cardinality
+parseExactlyOne = 
+    do
+        _ <- string "(1..1)"
+        return ExactlyOne
+        
+        
+parseZeroOrMore :: Parser Cardinality
+parseZeroOrMore = 
+    do
+        _ <- string "(0..*)"
+        return ZeroOrMore
+        
+        
+parseZeroOrOne :: Parser Cardinality
+parseZeroOrOne = 
+    do
+        _ <- string "(0..1)"
+        return ZeroOrOne
+
+attributeNameParser :: Parser String
+attributeNameParser = 
+    do
+        name <- camelNameParser
+        _ <- spaceConsumer
+        return name
+
+enumValueDisplayNameParser :: Parser String
+enumValueDisplayNameParser =
+    do
+        _ <- string "displayName \""
+        name <- anySingle `manyTill` char '"'
+        _ <- spaceConsumer
+        return name
+
+typeNameParser :: Parser String
+typeNameParser = 
+    do
+        _ <- string "type"
+        _ <- spaceConsumer
+        name <- pascalNameParser
+        _ <- char ':'
+        _ <- spaceConsumer
+        return name 
+
+periodType :: Type
+periodType = MakeType 
+    "Period" 
+    (Just "A class to define recurring periods or time offsets")
+    [MakeTypeAttribute 
+        "periodMultiplier"
+        "Integer"
+        ExactlyOne
+        (Just "A time period multiplier"),
+    
+    MakeTypeAttribute 
+        "period"
+        "periodEnum"
+        ExactlyOne
+        (Just "A time period")
+    ]