radumaco/RosettaHaskellCompiler
1
0
Fork 0
mirror of https://github.com/macocianradu/RosettaHaskellCompiler.git synced 2026-03-18 13:00:08 +00:00
Code Issues Packages Projects Releases Wiki Activity

parsing works with path expressions

Browse Source
This commit is contained in:
Macocian Adrian Radu
2022-05-15 01:51:49 +02:00
parent ee26710515
commit 47051dbbbd
16 changed files with 238 additions and 122 deletions
Download Patch File Download Diff File Expand all files Collapse all files

10
app/Main.hs
View File

@@ -26,6 +26,8 @@ import Data.Void
import Utils.Utils import Utils.Utils
import Data.Text (Text) import Data.Text (Text)
-- :set args resources/Rosetta/test-multiple.rosetta
-- :set args resources/Rosetta/test-all.rosetta -- :set args resources/Rosetta/test-all.rosetta
-- :l resources/Generated/testAll.hs resources/Generated/testPeriod.hs -- :l resources/Generated/testAll.hs resources/Generated/testPeriod.hs
@@ -62,10 +64,12 @@ parseWithImport file =
let importedFunctions = concat $ sndlst importedSymbolTable let importedFunctions = concat $ sndlst importedSymbolTable
case addNewTypes importedTypes objs of case addNewTypes importedTypes objs of
Left errors -> error $ show errors Left errors -> error $ show errors
Right definedTypes -> Right emptyTypes ->
case addNewFunctions (definedTypes, importedFunctions) objs of case populateTypes emptyTypes of
Left errors -> error $ show errors Left errors -> error $ show errors
Right definedFunctions -> return $ ((definedTypes, definedFunctions), (MakeHeader name desc vers imp, objs)) : concat imports Right definedTypes -> case addNewFunctions (definedTypes, importedFunctions) objs of
Left errors -> error $ show errors
Right definedFunctions -> return $ ((definedTypes, definedFunctions), (MakeHeader name desc vers imp, objs)) : concat imports
-- |Parse a file into a list of RosettaObjects -- |Parse a file into a list of RosettaObjects
parseFile :: String -> Either (ParseErrorBundle Text Void) (Header, [RosettaObject]) parseFile :: String -> Either (ParseErrorBundle Text Void) (Header, [RosettaObject])

2
resources/Rosetta/test-all.rosetta
View File

@@ -11,6 +11,8 @@ type TestSomeType: <"description">
type TestZeroOneType extends Period: type TestZeroOneType extends Period:
testZeroOneType int (1..1) testZeroOneType int (1..1)
condition important: <"This is an important condition">
observationPrimitive < 0
type ObservationPrimitive: type ObservationPrimitive:
observationPrimitive int (1..1) observationPrimitive int (1..1)

23
resources/Rosetta/test-multiple.rosetta Normal file
View File

@@ -0,0 +1,23 @@
namespace test.multiple : <"Something">
version "${version.ok}"
type ExchangeRate:
from int (1..1)
to int (1..1)
type Obs:
constant number (0..1)
exchangeRate ExchangeRate (0..1)
condition: one-of
func ExchangeRateFunc:
inputs:
from int (1..1)
to int (1..1)
output:
observable Obs (1..1)
assign-output observable -> exchangeRate -> from:
from
assign-output observable -> exchangeRate -> to:
to

4
src/Model/Function.hs
View File

@@ -15,13 +15,13 @@ data FunctionSignature =
data Function = data Function =
MakeFunction { MakeFunction {
signature :: FunctionSignature, signature :: FunctionSignature,
assignment :: Expression assignment :: [(Expression, Expression)]
} }
deriving (Show) deriving (Show)
data ExplicitFunction = data ExplicitFunction =
MakeExplicitFunction { MakeExplicitFunction {
sign :: FunctionSignature, sign :: FunctionSignature,
explicitAssignment :: ExplicitExpression explicitAssignment :: [(ExplicitExpression, ExplicitExpression)]
} }
deriving Show deriving Show

3
src/Model/Type.hs
View File

@@ -22,13 +22,13 @@ instance Eq Type where
(==) _ _ = False (==) _ _ = False
data Condition = MakeCondition { data Condition = MakeCondition {
conditionName :: String,
conditionDescription :: Maybe String, conditionDescription :: Maybe String,
expressionExpression :: Expression expressionExpression :: Expression
} deriving (Show) } deriving (Show)
-- |The representation of an expression -- |The representation of an expression
data Expression = Variable String data Expression = Variable String
| PathExpression Expression Expression
| Int String | Int String
| Real String | Real String
| Boolean String | Boolean String
@@ -48,6 +48,7 @@ data ExplicitExpression = ExplicitEmpty
| Value {name :: String, returnCoercion :: Coercion} | Value {name :: String, returnCoercion :: Coercion}
| ExplicitList [ExplicitExpression] | ExplicitList [ExplicitExpression]
| ExplicitParens ExplicitExpression | ExplicitParens ExplicitExpression
| ExplicitPath {super :: ExplicitExpression, sub :: ExplicitExpression, returnCoercion :: Coercion}
| ExplicitFunction {name :: String, args :: [(ExplicitExpression, Coercion)], returnCoercion :: Coercion} | ExplicitFunction {name :: String, args :: [(ExplicitExpression, Coercion)], returnCoercion :: Coercion}
| ExplicitIfSimple {cond :: (ExplicitExpression, Coercion), block1 :: (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} | ExplicitIfElse {cond :: (ExplicitExpression, Coercion), block1 :: (ExplicitExpression, Coercion), block2 :: (ExplicitExpression, Coercion), returnCoercion :: Coercion}

71
src/Parser/Expression.hs
View File

@@ -12,7 +12,7 @@ import Text.Megaparsec.Char
-- |Parses a complete Rosetta expression into an Expression type -- |Parses a complete Rosetta expression into an Expression type
expressionParser :: Parser Expression expressionParser :: Parser Expression
expressionParser = expressionParser =
choice [ ifParser, choice [ ifParser,
try functionCallParser, try functionCallParser,
eqParser] eqParser]
@@ -46,7 +46,7 @@ ifParser =
case els of case els of
Left _ -> return (IfSimple condition expr) Left _ -> return (IfSimple condition expr)
Right _ -> expressionParser >>= \expr2 -> return (IfElse condition expr expr2) Right _ -> expressionParser >>= \expr2 -> return (IfElse condition expr expr2)
-- |Parses an expression between parentheses in Rosetta into an Expression -- |Parses an expression between parentheses in Rosetta into an Expression
parens :: Parser a -> Parser a parens :: Parser a -> Parser a
parens = between (char '(') (char ')') parens = between (char '(') (char ')')
@@ -69,16 +69,7 @@ listParser =
variableParser :: Parser Expression variableParser :: Parser Expression
variableParser = variableParser =
do do
var <- camelNameParser Variable <$> camelNameParser
inner <- many innerVariableParser
return $ Variable (var ++ concatMap ("->" ++) inner)
-- |Parses an inner variable (a -> b) in Rosetta into an Expression
innerVariableParser :: Parser String
innerVariableParser =
do
_ <- lexeme $ string "->"
camelNameParser
-- |Parses an integer in Rosetta into an Expression -- |Parses an integer in Rosetta into an Expression
integerParser :: Parser Expression integerParser :: Parser Expression
@@ -86,7 +77,7 @@ integerParser =
do do
nr <- lexeme $ some digitChar nr <- lexeme $ some digitChar
return $ Int nr return $ Int nr
-- |Parses a real number in Rosetta into an Expression -- |Parses a real number in Rosetta into an Expression
decimalParser :: Parser Expression decimalParser :: Parser Expression
decimalParser = decimalParser =
@@ -95,7 +86,7 @@ decimalParser =
_ <- char '.' _ <- char '.'
real <- lexeme $ many digitChar real <- lexeme $ many digitChar
return $ Real $ nr ++ "." ++ real return $ Real $ nr ++ "." ++ real
-- |Parses a boolean in Rosetta into an Expression -- |Parses a boolean in Rosetta into an Expression
booleanParser :: Parser Expression booleanParser :: Parser Expression
booleanParser = booleanParser =
@@ -105,7 +96,7 @@ booleanParser =
-- |Parses the empty statement in Rosetta into an Expression -- |Parses the empty statement in Rosetta into an Expression
emptyParser :: Parser Expression emptyParser :: Parser Expression
emptyParser = emptyParser =
do do
_ <- lexeme $ string "empty" _ <- lexeme $ string "empty"
return Empty return Empty
@@ -114,7 +105,7 @@ emptyParser =
terminalParser :: Parser Expression terminalParser :: Parser Expression
terminalParser = terminalParser =
do do
choice choice
[ prefixParser, [ prefixParser,
parens expressionParser >>= \e -> return (Parens e), parens expressionParser >>= \e -> return (Parens e),
listParser, listParser,
@@ -131,11 +122,11 @@ terminalParser =
-- |Parses an prefix function statement in Rosetta into an Expression -- |Parses an prefix function statement in Rosetta into an Expression
prefixParser :: Parser Expression prefixParser :: Parser Expression
prefixParser = prefixParser =
do do
op <- lexeme $ choice $ fmap (try . string . Text.pack) prefixOperators op <- lexeme $ choice $ fmap (try . string . Text.pack) prefixOperators
PrefixExp (Text.unpack op) <$> expressionParser PrefixExp (Text.unpack op) <$> expressionParser
-- |List of prefix operators -- |List of prefix operators
prefixOperators :: [String] prefixOperators :: [String]
prefixOperators = ["-", "not"] prefixOperators = ["-", "not"]
@@ -166,44 +157,55 @@ sumParser =
-- |Parses a multiplication or division statement in Rosetta into an Expression -- |Parses a multiplication or division statement in Rosetta into an Expression
factorParser :: Parser Expression factorParser :: Parser Expression
factorParser = factorParser =
do do
p <- powerParser p <- powerParser
op <- lexeme $ observing (char '*' <|> char '/') op <- lexeme $ observing (char '*' <|> char '/')
case op of case op of
Left _ -> return p Left _ -> return p
Right o -> factorParser >>= \ex -> return $ reverseExpression $ InfixExp [o] p ex Right o -> factorParser >>= \ex -> return $ reverseExpression $ InfixExp [o] p ex
-- |Parses a boolean statement in Rosetta into an Expression
boolOpParser :: Parser Expression
boolOpParser =
do
p <- postfixParser
op <- lexeme $ observing (string "or" <|> string "and")
case op of
Left _ -> return p
Right o -> boolOpParser >>= \ex -> return $ InfixExp (Text.unpack o) p ex
-- |Parses a power statement in Rosetta into an Expression -- |Parses a power statement in Rosetta into an Expression
powerParser :: Parser Expression powerParser :: Parser Expression
powerParser = powerParser =
do do
p <- boolOpParser p <- boolOpParser
op <- lexeme $ observing $ char '^' op <- lexeme $ observing $ char '^'
case op of case op of
Left _ -> return p Left _ -> return p
Right _ -> powerParser >>= \ex -> return $ InfixExp "^" p ex Right _ -> powerParser >>= \ex -> return $ InfixExp "^" p ex
-- |Parses a boolean statement in Rosetta into an Expression
boolOpParser :: Parser Expression
boolOpParser =
do
p <- postfixParser
op <- lexeme $ observing (string "or" <|> string "and")
case op of
Left _ -> return p
Right o -> boolOpParser >>= \ex -> return $ InfixExp (Text.unpack o) p ex
-- |Parses a postfix function in Rosetta into an Expression -- |Parses a postfix function in Rosetta into an Expression
postfixParser :: Parser Expression postfixParser :: Parser Expression
postfixParser = postfixParser =
do do
t <- terminalParser t <- pathExpressionParser
op <- lexeme $ observing $ choice $ fmap (try . string . Text.pack) postfixFunctions op <- lexeme $ observing $ choice $ fmap (try . string . Text.pack) postfixFunctions
case op of case op of
Left _ -> return t Left _ -> return t
Right o -> return $ PostfixExp (Text.unpack o) t Right o -> return $ PostfixExp (Text.unpack o) t
-- |Parses a path expression (a -> b) in Rosetta into an Expression
pathExpressionParser :: Parser Expression
pathExpressionParser =
do
var <- terminalParser
op <- lexeme $ observing $ string "->"
case op of
Left _ -> return var
Right _ -> pathExpressionParser >>= \ex -> return $ reverseExpression $ PathExpression var ex
-- |The list of existing postfix Rosetta functions -- |The list of existing postfix Rosetta functions
postfixFunctions :: [String] postfixFunctions :: [String]
postfixFunctions = ["exists", "is absent", "count", "only-element", "single exists", "multiple exists"] postfixFunctions = ["exists", "is absent", "count", "only-element", "single exists", "multiple exists"]
@@ -217,6 +219,7 @@ reverseExpression :: Expression -> Expression
reverseExpression (InfixExp op t1 (InfixExp op2 t2 e)) reverseExpression (InfixExp op t1 (InfixExp op2 t2 e))
| precedence op == precedence op2 = InfixExp op2 (reverseExpression (InfixExp op t1 t2)) e | precedence op == precedence op2 = InfixExp op2 (reverseExpression (InfixExp op t1 t2)) e
| otherwise = InfixExp op t1 (InfixExp op2 t2 e) | otherwise = InfixExp op t1 (InfixExp op2 t2 e)
reverseExpression (PathExpression e1 (PathExpression e2 e3)) = PathExpression (reverseExpression (PathExpression e1 e2)) e3
reverseExpression e = e reverseExpression e = e

9
src/Parser/Function.hs
View File

@@ -20,15 +20,18 @@ functionParser =
fDescription <- optional descriptionParser fDescription <- optional descriptionParser
fInput <- inputAttributesParser fInput <- inputAttributesParser
fOutput <- outputAttributeParser fOutput <- outputAttributeParser
MakeFunction (MakeFunctionSignature fName fDescription fInput fOutput) <$> assignmentParser MakeFunction (MakeFunctionSignature fName fDescription fInput fOutput) <$> many assignmentParser
-- parseTest assignmentParser (Text.pack "assign-output observable -> exchangeRate -> from: from")
-- |Parses the output assignment statement from a function in Rosetta into an Expression -- |Parses the output assignment statement from a function in Rosetta into an Expression
assignmentParser :: Parser Expression assignmentParser :: Parser (Expression, Expression)
assignmentParser = assignmentParser =
do do
_ <- lexeme $ string "assign-output" _ <- lexeme $ string "assign-output"
out <- expressionParser
_ <- lexeme $ char ':' _ <- lexeme $ char ':'
expressionParser assignment <- expressionParser
return (out, assignment)
-- |Parses the input attributes from a function statement in Rosetta into a list of TypeAttributes -- |Parses the input attributes from a function statement in Rosetta into a list of TypeAttributes
inputAttributesParser :: Parser [TypeAttribute] inputAttributesParser :: Parser [TypeAttribute]

5
src/Parser/Type.hs
View File

@@ -50,10 +50,9 @@ cardinalityParser = try parseBounded <|> try parseSemiBounded
conditionParser :: Parser Condition conditionParser :: Parser Condition
conditionParser = do conditionParser = do
_ <- lexeme $ string "condition" _ <- lexeme $ string "condition"
name <- lexeme camelNameParser
_ <- lexeme $ char ':'
description <- optional descriptionParser description <- optional descriptionParser
MakeCondition name description <$> expressionParser _ <- lexeme $ char ':'
MakeCondition description <$> expressionParser
-- |Parses a bounded cardinality statement in Rosetta into a Cardinality -- |Parses a bounded cardinality statement in Rosetta into a Cardinality
parseBounded :: Parser Cardinality parseBounded :: Parser Cardinality

7
src/PrettyPrinter/Function.hs
View File

@@ -17,17 +17,20 @@ printFunction f = show $ vcat [printFunctionSignature (sign f), printFunctionBod
-- |Converts the body of a Function into a haskell valid Doc -- |Converts the body of a Function into a haskell valid Doc
printFunctionBody :: ExplicitFunction -> Doc a printFunctionBody :: ExplicitFunction -> Doc a
printFunctionBody (MakeExplicitFunction (MakeFunctionSignature name _ inp out) ex) = pretty name <+> printVariableNames inp <+> "=" <+> printExpression ex (createCoercion (attributeType out, Model.Type.cardinality out)) 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 :: ExplicitExpression -> Coercion -> Doc a
printExpression ExplicitEmpty _ = "[]" printExpression ExplicitEmpty _ = "[]"
printExpression (ExplicitVariable name coer) out = case coer `coercionIncluded` out of printExpression (ExplicitVariable name coer) out = case coer `coercionIncluded` out of
Left err -> error $ show err Left err -> error $ show coer ++ " /// " ++ show out--show err
Right c -> printCoercion c $ pretty name Right c -> printCoercion c $ pretty name
printExpression (Value s coer) out = case coer `coercionIncluded` out of printExpression (Value s coer) out = case coer `coercionIncluded` out of
Left err -> error $ show err Left err -> error $ show err
Right c -> printCoercion c $ pretty s Right c -> printCoercion c $ pretty s
printExpression (ExplicitParens ex) out = "(" <> printExpression ex out <> ")" printExpression (ExplicitParens ex) out = "(" <> printExpression ex out <> ")"
printExpression (ExplicitList ex) out = list [printExpression x out | x <- ex] 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 "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 "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 "single exists" args returnCoerce) out = printCoercion returnCoerce "length" <+> printCoercion (snd $ head args) (printExpression (fst $ head args) out) <+> "==" <+> "1"

2
src/PrettyPrinter/Type.hs
View File

@@ -40,4 +40,4 @@ printCardinality (MakeTypeAttribute _ typ (Bounds (x, y)) _)
printCardinality (MakeTypeAttribute _ typ (OneBound _) _) = "[" <> pretty (typeName typ) <> "]" printCardinality (MakeTypeAttribute _ typ (OneBound _) _) = "[" <> pretty (typeName typ) <> "]"
printCondition :: Condition -> Doc a printCondition :: Condition -> Doc a
printCondition (MakeCondition name desc e) = printDescription desc ("--" <+> pretty name <+> pretty (show e)) printCondition (MakeCondition desc e) = printDescription desc ("--" <+> pretty (show e))

95
src/Semantic/ExpressionChecker.hs
View File

@@ -6,8 +6,7 @@ import Data.Maybe
import Model.Type import Model.Type
import Semantic.TypeChecker import Semantic.TypeChecker
import Utils.Utils import Utils.Utils
import Model.Type (CardinalityCoercion(MakeNothing2MaybeCoercion, MakeNothing2ListCoercion, MakeMaybe2ListCoercion, MakeObject2MaybeCoercion, MakeObject2ListCoercion))
-- |A declared variable or function -- |A declared variable or function
data Symbol = Var{ data Symbol = Var{
varName :: String, varName :: String,
@@ -28,8 +27,8 @@ instance Eq Symbol where
| name1 == name2 = True | name1 == name2 = True
| otherwise = False | otherwise = False
(==) _ _ = False (==) _ _ = False
-- |A map of the predefined functions, their arguments and their return type -- |A map of the predefined functions, their arguments and their return type
defaultMap :: [Symbol] defaultMap :: [Symbol]
defaultMap = [ defaultMap = [
@@ -41,7 +40,7 @@ defaultMap = [
Func "multiple exists" [(BasicType "Any", OneBound 0)] (BasicType "Boolean", Bounds (1, 1)), Func "multiple exists" [(BasicType "Any", OneBound 0)] (BasicType "Boolean", Bounds (1, 1)),
Func "contains" [(BasicType "Any", OneBound 0), (BasicType "Any", OneBound 0)] (BasicType "Boolean", Bounds (1, 1)), Func "contains" [(BasicType "Any", OneBound 0), (BasicType "Any", OneBound 0)] (BasicType "Boolean", Bounds (1, 1)),
Func "disjoint" [(BasicType "Any", OneBound 0), (BasicType "Any", OneBound 0)] (BasicType "Boolean", Bounds (1, 1)), Func "disjoint" [(BasicType "Any", OneBound 0), (BasicType "Any", OneBound 0)] (BasicType "Boolean", Bounds (1, 1)),
Func "=" [(BasicType "Any", OneBound 0), (BasicType "Any", OneBound 0)] (BasicType "Boolean", Bounds(1, 1)), Func "=" [(BasicType "Any", OneBound 0), (BasicType "Any", OneBound 0)] (BasicType "Boolean", Bounds(1, 1)),
Func ">=" [(BasicType "Any", OneBound 0), (BasicType "Any", OneBound 0)] (BasicType "Boolean", Bounds(1, 1)), Func ">=" [(BasicType "Any", OneBound 0), (BasicType "Any", OneBound 0)] (BasicType "Boolean", Bounds(1, 1)),
Func "<=" [(BasicType "Any", OneBound 0), (BasicType "Any", OneBound 0)] (BasicType "Boolean", Bounds(1, 1)), Func "<=" [(BasicType "Any", OneBound 0), (BasicType "Any", OneBound 0)] (BasicType "Boolean", Bounds(1, 1)),
@@ -52,7 +51,7 @@ defaultMap = [
Func "all <>" [(BasicType "Any", OneBound 0), (BasicType "Any", Bounds(1, 1))] (BasicType "Boolean", Bounds(1, 1)), Func "all <>" [(BasicType "Any", OneBound 0), (BasicType "Any", Bounds(1, 1))] (BasicType "Boolean", Bounds(1, 1)),
Func "any =" [(BasicType "Any", OneBound 0), (BasicType "Any", Bounds(1, 1))] (BasicType "Boolean", Bounds(1, 1)), Func "any =" [(BasicType "Any", OneBound 0), (BasicType "Any", Bounds(1, 1))] (BasicType "Boolean", Bounds(1, 1)),
Func "any <>" [(BasicType "Any", OneBound 0), (BasicType "Any", Bounds(1, 1))] (BasicType "Boolean", Bounds(1, 1)), Func "any <>" [(BasicType "Any", OneBound 0), (BasicType "Any", Bounds(1, 1))] (BasicType "Boolean", Bounds(1, 1)),
Func "+" [(BasicType "Integer", Bounds (1, 1)), (BasicType "Integer", Bounds (1, 1))] (BasicType "Integer", Bounds (1, 1)), Func "+" [(BasicType "Integer", Bounds (1, 1)), (BasicType "Integer", Bounds (1, 1))] (BasicType "Integer", Bounds (1, 1)),
Func "+" [(BasicType "Double", Bounds (1, 1)), (BasicType "Double", Bounds (1, 1))] (BasicType "Double", Bounds (1, 1)), Func "+" [(BasicType "Double", Bounds (1, 1)), (BasicType "Double", Bounds (1, 1))] (BasicType "Double", Bounds (1, 1)),
Func "-" [(BasicType "Integer", Bounds (1, 1)), (BasicType "Integer", Bounds (1, 1))] (BasicType "Integer", Bounds (1, 1)), Func "-" [(BasicType "Integer", Bounds (1, 1)), (BasicType "Integer", Bounds (1, 1))] (BasicType "Integer", Bounds (1, 1)),
@@ -63,7 +62,7 @@ defaultMap = [
Func "/" [(BasicType "Double", Bounds (1, 1)), (BasicType "Double", Bounds (1, 1))] (BasicType "Double", Bounds (1, 1)), Func "/" [(BasicType "Double", Bounds (1, 1)), (BasicType "Double", Bounds (1, 1))] (BasicType "Double", Bounds (1, 1)),
Func "^" [(BasicType "Integer", Bounds (1, 1)), (BasicType "Integer", Bounds (1, 1))] (BasicType "Integer", Bounds (1, 1)), Func "^" [(BasicType "Integer", Bounds (1, 1)), (BasicType "Integer", Bounds (1, 1))] (BasicType "Integer", Bounds (1, 1)),
Func "^" [(BasicType "Double", Bounds (1, 1)), (BasicType "Double", Bounds (1, 1))] (BasicType "Double", Bounds (1, 1)), Func "^" [(BasicType "Double", Bounds (1, 1)), (BasicType "Double", Bounds (1, 1))] (BasicType "Double", Bounds (1, 1)),
Func "count" [(BasicType "Any", OneBound 0)] (BasicType "Integer", Bounds (1, 1)) Func "count" [(BasicType "Any", OneBound 0)] (BasicType "Integer", Bounds (1, 1))
] ]
@@ -77,26 +76,38 @@ addFunction (definedTypes, definedSymbols) (MakeFunction (MakeFunctionSignature
then Left [MultipleDeclarations name] then Left [MultipleDeclarations name]
else Right $ Func name (map typeAndCardinality (rights checkedInputs)) (attributeType checkedOutput, Model.Type.cardinality out) : definedSymbols else Right $ Func name (map typeAndCardinality (rights checkedInputs)) (attributeType checkedOutput, Model.Type.cardinality out) : definedSymbols
else Left $ lefts checkedInputs else Left $ lefts checkedInputs
where where
checkedInputs = checkAttributes definedTypes inps checkedInputs = checkAttributes definedTypes inps
-- |Adds a newly defined variable to the symbol table -- |Adds a newly defined variable to the symbol table
addVariables :: [Symbol] -> [TypeAttribute] -> [Symbol] addVariables :: [Symbol] -> [TypeAttribute] -> [Symbol]
addVariables s [] = s addVariables s [] = s
addVariables s ((MakeTypeAttribute name typ crd _) : vars) = Var name (toHaskell typ) crd : addVariables s vars addVariables s ((MakeTypeAttribute name typ crd _) : vars) = Var name (toHaskell typ) crd : addVariables s vars
-- |Checks the type of a given expression -- |Checks the type of a given expression
checkExpression :: [Symbol] -> Expression -> Either TypeCheckError ExplicitExpression checkExpression :: [Symbol] -> Expression -> Either TypeCheckError ExplicitExpression
checkExpression symbolMap (Variable var) = findVarType var symbolMap --checkExpression sym _ = error $ show sym
checkExpression symbolMap (Variable var) = findVarType var symbolMap
checkExpression _ (Int val) = Right $ Value val $ MakeCoercion [MakeIdCoercion (BasicType "Integer")] (MakeCardinalityIdCoercion (Bounds (1, 1))) checkExpression _ (Int val) = Right $ Value val $ MakeCoercion [MakeIdCoercion (BasicType "Integer")] (MakeCardinalityIdCoercion (Bounds (1, 1)))
checkExpression _ (Real val) = Right $ Value val $ MakeCoercion [MakeIdCoercion (BasicType "Double")] (MakeCardinalityIdCoercion (Bounds (1, 1))) 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 _ (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 _ Empty = Right $ Value "empty" $ MakeCoercion [MakeIdCoercion (BasicType "Empty")] (MakeCardinalityIdCoercion (Bounds (0, 0)))
checkExpression symbolMap (Parens ex) = checkExpression symbolMap (PathExpression ex1 (Variable b)) =
case checkExpression symbolMap ex1 of
Left err -> Left err
Right exp1 -> case findAttributeType b (typeAttributes type1) of
Left err -> Left $ UndefinedVariable $ show type1--ex1 ++ " -> " ++ b
Right exp2 -> Right $ ExplicitPath exp1 exp2 (returnCoercion exp2)
where
type1 = coercionType $ typeCoercion $ returnCoercion exp1
--checkExpression symbolMap (PathExpression ex1 (PathExpression ))
checkExpression symbolMap (Parens ex) =
case checkExpression symbolMap ex of case checkExpression symbolMap ex of
Left err -> Left err Left err -> Left err
Right exp -> Right $ ExplicitParens exp Right exp -> Right $ ExplicitParens exp
checkExpression symbolMap (List lst) = checkList symbolMap lst -- |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 (PrefixExp name ex) = checkFunctionCall symbolMap name [checkExpression symbolMap ex]
checkExpression symbolMap (Function name exps) = checkFunctionCall symbolMap name (map (checkExpression symbolMap) exps) checkExpression symbolMap (Function name exps) = checkFunctionCall symbolMap name (map (checkExpression symbolMap) exps)
checkExpression symbolMap (PostfixExp name ex) = checkFunctionCall symbolMap name [checkExpression symbolMap ex] checkExpression symbolMap (PostfixExp name ex) = checkFunctionCall symbolMap name [checkExpression symbolMap ex]
@@ -107,16 +118,16 @@ checkExpression symbolMap (IfSimple cond ex) =
Left err -> Left $ IfConditionNotBoolean $ show err Left err -> Left $ IfConditionNotBoolean $ show err
Right condType -> case returnCoercion condType `coercionIncluded` MakeCoercion [MakeIdCoercion (BasicType "Boolean")] (MakeCardinalityIdCoercion (Bounds (1, 1))) of Right condType -> case returnCoercion condType `coercionIncluded` MakeCoercion [MakeIdCoercion (BasicType "Boolean")] (MakeCardinalityIdCoercion (Bounds (1, 1))) of
Left err -> Left $ IfConditionNotBoolean $ show cond ++ " :: " ++ show (coercionType $ typeCoercion $ returnCoercion condType) Left err -> Left $ IfConditionNotBoolean $ show cond ++ " :: " ++ show (coercionType $ typeCoercion $ returnCoercion condType)
Right condCoerce -> Right condCoerce ->
case checkExpression symbolMap ex of case checkExpression symbolMap ex of
Left err -> Left err Left err -> Left err
Right thenExp -> Right thenExp ->
Right $ ExplicitIfSimple (condType, condCoerce) Right $ ExplicitIfSimple (condType, condCoerce)
(thenExp, thenCoercion) (thenExp, thenCoercion)
(MakeCoercion [MakeIdCoercion $ coercionType $ typeCoercion $ returnCoercion thenExp] (MakeCoercion [MakeIdCoercion $ coercionType $ typeCoercion $ returnCoercion thenExp]
(MakeCardinalityIdCoercion $ smallestBound (Bounds (0, 0)) (toCardinality $ cardinalityCoercion $ returnCoercion thenExp))) (MakeCardinalityIdCoercion $ smallestBound (Bounds (0, 0)) (toCardinality $ cardinalityCoercion $ returnCoercion thenExp)))
where where
thenCoercion = MakeCoercion [MakeIdCoercion $ coercionType $ typeCoercion $ returnCoercion thenExp] thenCoercion = MakeCoercion [MakeIdCoercion $ coercionType $ typeCoercion $ returnCoercion thenExp]
(MakeCardinalityIdCoercion $ toCardinality $ cardinalityCoercion $ returnCoercion thenExp) (MakeCardinalityIdCoercion $ toCardinality $ cardinalityCoercion $ returnCoercion thenExp)
-- |Checks if the condition of the if statement is of type boolean, and then checks that both the then and else statements have the same type -- |Checks if the condition of the if statement is of type boolean, and then checks that both the then and else statements have the same type
@@ -125,19 +136,18 @@ checkExpression symbolMap (IfElse cond ex1 ex2) =
Left err -> Left $ IfConditionNotBoolean $ show err Left err -> Left $ IfConditionNotBoolean $ show err
Right condType -> case returnCoercion condType `coercionIncluded` MakeCoercion [MakeIdCoercion (BasicType "Boolean")] (MakeCardinalityIdCoercion (Bounds (1, 1))) of Right condType -> case returnCoercion condType `coercionIncluded` MakeCoercion [MakeIdCoercion (BasicType "Boolean")] (MakeCardinalityIdCoercion (Bounds (1, 1))) of
Left err -> Left $ IfConditionNotBoolean $ show cond ++ " :: " ++ show (coercionType $ typeCoercion $ returnCoercion condType) Left err -> Left $ IfConditionNotBoolean $ show cond ++ " :: " ++ show (coercionType $ typeCoercion $ returnCoercion condType)
Right condCoerce -> Right condCoerce ->
case checkExpression symbolMap ex1 of case checkExpression symbolMap ex1 of
Left err -> Left $ ErrorInsideFunction $ show err Left err -> Left $ ErrorInsideFunction $ show err
Right thenExp -> case checkExpression symbolMap ex2 of Right thenExp -> case checkExpression symbolMap ex2 of
Left err -> Left $ ErrorInsideFunction $ show err Left err -> Left $ ErrorInsideFunction $ show err
Right elseExp -> Right elseExp ->
Right $ ExplicitIfElse (condType, condCoerce) Right $ ExplicitIfElse (condType, condCoerce)
(thenExp, MakeCoercion [MakeIdCoercion $ coercionType $ typeCoercion $ returnCoercion thenExp] (thenExp, MakeCoercion [MakeIdCoercion $ coercionType $ typeCoercion $ returnCoercion thenExp]
(MakeCardinalityIdCoercion $ toCardinality $ cardinalityCoercion $ returnCoercion thenExp)) (MakeCardinalityIdCoercion $ toCardinality $ cardinalityCoercion $ returnCoercion thenExp))
(elseExp, MakeCoercion [MakeIdCoercion $ coercionType $ typeCoercion $ returnCoercion elseExp] (elseExp, MakeCoercion [MakeIdCoercion $ coercionType $ typeCoercion $ returnCoercion elseExp]
(MakeCardinalityIdCoercion $ toCardinality $ cardinalityCoercion $ returnCoercion elseExp)) (returnCoercion thenExp) (MakeCardinalityIdCoercion $ toCardinality $ cardinalityCoercion $ returnCoercion elseExp)) (returnCoercion thenExp)
--(typeMatch ex1Type ex2Type, smallestBound ex1Card ex2Type) --(typeMatch ex1Type ex2Type, smallestBound ex1Card ex2Type)
-- |TODO Handle nested lists and lists with parens -- |TODO Handle nested lists and lists with parens
-- |Checks that all the expressions in a list have compatible types -- |Checks that all the expressions in a list have compatible types
@@ -146,39 +156,39 @@ checkList _ [] = Right $ ExplicitList [ExplicitEmpty]
checkList symbs (ex : exps) = checkList symbs (ex : exps) =
case checkExpression symbs ex of case checkExpression symbs ex of
Left err -> Left err Left err -> Left err
Right x -> Right x ->
case checkList1 symbs exps (coercionType $ typeCoercion $ returnCoercion x, toCardinality $ cardinalityCoercion $ returnCoercion x) of case checkList1 symbs exps (coercionType $ typeCoercion $ returnCoercion x, toCardinality $ cardinalityCoercion $ returnCoercion x) of
Left err -> Left err Left err -> Left err
Right exp -> Right $ ExplicitList exp Right exp -> Right $ ExplicitList exp
-- |Auxiliary function for the check list function -- |Auxiliary function for the check list function
checkList1 :: [Symbol] -> [Expression] -> (Type, Cardinality) -> Either TypeCheckError [ExplicitExpression] checkList1 :: [Symbol] -> [Expression] -> (Type, Cardinality) -> Either TypeCheckError [ExplicitExpression]
checkList1 _ [] typ = Right [ExplicitEmpty] checkList1 _ [] typ = Right [ExplicitEmpty]
checkList1 symbs (ex : exps) typ = checkList1 symbs (ex : exps) typ =
case checkExpression symbs ex of case checkExpression symbs ex of
Left err -> Left err Left err -> Left err
Right exCo -> Right exCo ->
case fst typ `isSubType` exTyp of case fst typ `isSubType` exTyp of
Left err -> Left err Left err -> Left err
Right _ -> Right _ ->
case checkList1 symbs exps (exTyp, smallestBound exCard (snd typ)) of case checkList1 symbs exps (exTyp, smallestBound exCard (snd typ)) of
Left err -> Left err Left err -> Left err
Right explicitEx -> Right [ExplicitList explicitEx] Right explicitEx -> Right [ExplicitList explicitEx]
where where
exTyp = coercionType $ typeCoercion $ returnCoercion exCo exTyp = coercionType $ typeCoercion $ returnCoercion exCo
exCard = toCardinality $ cardinalityCoercion $ returnCoercion exCo exCard = toCardinality $ cardinalityCoercion $ returnCoercion exCo
-- |Checks whether the function that is called is already defined with the same argument types -- |Checks whether the function that is called is already defined with the same argument types
checkFunctionCall :: [Symbol] -> String -> [Either TypeCheckError ExplicitExpression ] -> Either TypeCheckError ExplicitExpression checkFunctionCall :: [Symbol] -> String -> [Either TypeCheckError ExplicitExpression ] -> Either TypeCheckError ExplicitExpression
checkFunctionCall [] fun args = Left $ UndefinedFunction $ "Undefined function: \"" ++ fun ++ "\" [" ++ show (rights args) ++ "]" checkFunctionCall [] fun args = Left $ UndefinedFunction $ "Undefined function: \"" ++ fun ++ "\" [" ++ show (rights args) ++ "]"
checkFunctionCall ((Func n a r):symbolMap) name args checkFunctionCall ((Func n a r):symbolMap) name args
| length (rights args) /= length args = Left $ ErrorInsideFunction (name ++ ": " ++ show args ++ show (lefts args)) | length (rights args) /= length args = Left $ ErrorInsideFunction (name ++ ": " ++ show args ++ show (lefts args))
| name == n && all isRight coerce = Right $ ExplicitFunction name (zip (rights args) (rights coerce)) (MakeCoercion [MakeIdCoercion (fst r)] (MakeCardinalityIdCoercion (snd r))) | name == n && all isRight coerce = Right $ ExplicitFunction name (zip (rights args) (rights coerce)) (MakeCoercion [MakeIdCoercion (fst r)] (MakeCardinalityIdCoercion (snd r)))
| otherwise = checkFunctionCall symbolMap name args | otherwise = checkFunctionCall symbolMap name args
where where
argCoerce = map returnCoercion (rights args) argCoerce = map returnCoercion (rights args)
coerce = zipWith coercionIncluded argCoerce (map createCoercion a) coerce = zipWith coercionIncluded argCoerce (map createCoercion a)
checkFunctionCall (_:symbolMap) name args = checkFunctionCall symbolMap name args checkFunctionCall (_:symbolMap) name args = checkFunctionCall symbolMap name args
typeIncluded :: (Type, Cardinality) -> (Type, Cardinality) -> Either TypeCheckError Coercion typeIncluded :: (Type, Cardinality) -> (Type, Cardinality) -> Either TypeCheckError Coercion
typeIncluded (t1, c1) (t2, c2) = typeIncluded (t1, c1) (t2, c2) =
@@ -189,8 +199,8 @@ typeIncluded (t1, c1) (t2, c2) =
Left err -> Left err Left err -> Left err
Right cardCoercion -> Right $ MakeCoercion typeCoercion cardCoercion Right cardCoercion -> Right $ MakeCoercion typeCoercion cardCoercion
coercionIncluded :: Coercion -> Coercion -> Either TypeCheckError Coercion coercionIncluded :: Coercion -> Coercion -> Either TypeCheckError Coercion
coercionIncluded c1 c2 = (coercionType (typeCoercion c1), coercionCardinality [cardinalityCoercion c1]) `typeIncluded` (coercionType (typeCoercion c2), coercionCardinality [cardinalityCoercion c2]) coercionIncluded c1 c2 = (coercionType (typeCoercion c1), coercionCardinality [cardinalityCoercion c1]) `typeIncluded` (coercionType (typeCoercion c2), coercionCardinality [cardinalityCoercion c2])
-- |Finds the most specific super type of the two types -- |Finds the most specific super type of the two types
typeMatch :: Type -> Type -> Type typeMatch :: Type -> Type -> Type
@@ -210,20 +220,27 @@ typeMatch x y = case x `isSubType` y of
Right _ -> y Right _ -> y
-- |Looks in the symbol map for the type of a variable -- |Looks in the symbol map for the type of a variable
findVarType :: String -> [Symbol] -> Either TypeCheckError ExplicitExpression findVarType :: String -> [Symbol] -> Either TypeCheckError ExplicitExpression
findVarType var [] = Left $ UndefinedVariable var findVarType var [] = Left $ UndefinedVariable var
findVarType x ((Var name typ crd):symbols) findVarType x ((Var name typ crd):symbols)
| x == name = Right $ ExplicitVariable x (MakeCoercion [MakeIdCoercion typ] (MakeCardinalityIdCoercion crd)) | x == name = Right $ ExplicitVariable x (MakeCoercion [MakeIdCoercion typ] (MakeCardinalityIdCoercion crd))
| otherwise = findVarType x symbols | otherwise = findVarType x symbols
findVarType x (_:symbols) = findVarType x symbols findVarType x (_:symbols) = findVarType x symbols
-- |Find whether there is a attribute with the given name in the given type, and returns the attribute's type
findAttributeType :: String -> [TypeAttribute] -> Either TypeCheckError ExplicitExpression
findAttributeType var [] = Left $ UndefinedVariable var
findAttributeType var (t : ts)
| var == attributeName t = Right $ ExplicitVariable var (MakeCoercion [MakeIdCoercion $ attributeType t] (MakeCardinalityIdCoercion $ Model.Type.cardinality t))
| otherwise = findAttributeType var ts
-- |Checks whether the first argument is a subtype of the second argument -- |Checks whether the first argument is a subtype of the second argument
isSubType :: Type -> Type -> Either TypeCheckError [TypeCoercion] isSubType :: Type -> Type -> Either TypeCheckError [TypeCoercion]
isSubType (BasicType "Integer") (BasicType "Double") = Right [MakeTypeCoercion (BasicType "Integer") (BasicType "Double") "fromInteger"] isSubType (BasicType "Integer") (BasicType "Double") = Right [MakeTypeCoercion (BasicType "Integer") (BasicType "Double") "fromInteger"]
isSubType (BasicType x) y isSubType (BasicType x) y
| x == typeName y = Right [MakeIdCoercion y] | x == typeName y = Right [MakeIdCoercion y]
| otherwise = Left $ TypeMismatch x (typeName y) | otherwise = Left $ TypeMismatch x (typeName y)
isSubType x y isSubType x y
| typeName x == typeName y = Right [MakeIdCoercion x] | typeName x == typeName y = Right [MakeIdCoercion x]
| otherwise = case isSubType (superType x) y of | otherwise = case isSubType (superType x) y of
Left e -> Left e Left e -> Left e

23
src/Semantic/FunctionChecker.hs
View File

@@ -11,16 +11,25 @@ import Utils.Utils
-- |Checks if all the inputs and the output of a function call have valid types, and then checks that the assign-output expression is valid -- |Checks if all the inputs and the output of a function call have valid types, and then checks that the assign-output expression is valid
checkFunction :: ([Type], [Symbol]) -> Function -> Either [TypeCheckError] ExplicitFunction checkFunction :: ([Type], [Symbol]) -> Function -> Either [TypeCheckError] ExplicitFunction
checkFunction (definedTypes, symbols) (MakeFunction (MakeFunctionSignature name desc inp out) ex) = checkFunction (definedTypes, symbols) (MakeFunction (MakeFunctionSignature name desc inp out) ex) =
let checkedIn = checkAttributes definedTypes inp in
if null $ lefts checkedIn if null $ lefts checkedIn
then then
case head $ checkAttributes definedTypes [out] of case head $ checkAttributes definedTypes [out] of
Left err -> Left [err] Left err -> Left [err]
Right checkedOut -> case checkExpression (addVariables symbols inp) ex of Right checkedOut -> case checkAssignment (addVariables symbols (checkedOut : rights checkedIn)) ex of
Left err -> Left [err] Left err -> Left err
Right checkedEx -> case returnCoercion checkedEx `coercionIncluded` createCoercion (attributeType checkedOut, Model.Type.cardinality out) of Right checkedEx -> Right $ MakeExplicitFunction (MakeFunctionSignature (toLower (head name) : tail name) desc (rights checkedIn) checkedOut) checkedEx
Left err -> Left [err]
Right retCoercion -> Right $ MakeExplicitFunction (MakeFunctionSignature (toLower (head name) : tail name) desc (rights checkedIn) checkedOut) checkedEx
--Right _ -> error $ show (returnCoercion checkedEx) ++ " // " ++ show (createCoercion (attributeType checkedOut, Model.Type.cardinality out))
else else
Left $ lefts checkedIn Left $ lefts checkedIn
where checkedIn = checkAttributes definedTypes inp
checkAssignment :: [Symbol] -> [(Expression, Expression)] -> Either [TypeCheckError] [(ExplicitExpression, ExplicitExpression)]
checkAssignment _ [] = Right []
checkAssignment symbs ((assign, ex): assigns) =
case checkExpression (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 symbs assign of
Left err -> Left [err]
Right checkedA -> case checkAssignment symbs assigns of
Left err -> Left err
Right checked -> Right $ (checkedA, checkedExp) : checked

55
src/Semantic/TypeChecker.hs
View File

@@ -16,6 +16,7 @@ data TypeCheckError =
| CardinalityMismatch Cardinality Cardinality | CardinalityMismatch Cardinality Cardinality
| MultipleDeclarations String | MultipleDeclarations String
| TypeNameReserved String | TypeNameReserved String
| UnsupportedExpressionInPathExpression String
deriving (Show) deriving (Show)
-- |Checks whether a data type is valid -- |Checks whether a data type is valid
@@ -46,17 +47,63 @@ checkAttributes definedTypes ((MakeTypeAttribute name typ crd desc):as) =
Left err -> Left err : checkAttributes definedTypes as Left err -> Left err : checkAttributes definedTypes as
Right checked -> Right (MakeTypeAttribute name checked crd desc) : 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 -- |Checks whether a type is predefined or in the symbol table
checkAttributeType :: [Type] -> Type -> Either TypeCheckError Type checkAttributeType :: [Type] -> Type -> Either TypeCheckError Type
checkAttributeType [] t = Left $ UndefinedType $ typeName t
checkAttributeType _ (MakeType "int" _ _ _ _) = Right $ BasicType "Integer" checkAttributeType _ (MakeType "int" _ _ _ _) = Right $ BasicType "Integer"
checkAttributeType _ (MakeType "string" _ _ _ _) = Right $ BasicType "String" checkAttributeType _ (MakeType "string" _ _ _ _) = Right $ BasicType "String"
checkAttributeType _ (MakeType "number" _ _ _ _) = Right $ BasicType "Double" checkAttributeType _ (MakeType "number" _ _ _ _) = Right $ BasicType "Double"
checkAttributeType _ (MakeType "boolean" _ _ _ _) = Right $ BasicType "Bool" checkAttributeType _ (MakeType "boolean" _ _ _ _) = Right $ BasicType "Bool"
checkAttributeType _ (MakeType "time" _ _ _ _) = Right $ BasicType "Time" checkAttributeType _ (MakeType "time" _ _ _ _) = Right $ BasicType "Time"
checkAttributeType definedTypes name checkAttributeType (defined : ts) t
| name `elem` definedTypes = Right name | defined == t = Right defined
| otherwise = Left $ UndefinedType (typeName name) | otherwise = checkAttributeType ts t
populateTypes :: [Type] -> Either [TypeCheckError] [Type]
populateTypes t = populateTypes1 t t
populateTypes1 :: [Type] -> [Type] -> Either [TypeCheckError] [Type]
populateTypes1 _ [] = Right []
populateTypes1 emptyTypes (BasicType t : ts) =
case populateTypes1 emptyTypes ts of
Left error -> Left error
Right definedTypes -> Right $ BasicType t : definedTypes
populateTypes1 emptyTypes (t : ts) =
case populateTypes1 emptyTypes ts of
Left error -> Left error
Right definedTypes ->
let populated = map (populateAttributeType emptyTypes emptyTypes) (typeAttributes t) in
if null $ lefts populated
then Right $ MakeType
(typeName t)
(superType t)
(typeDescription t)
(rights populated)
(conditions t) : definedTypes
else
Left $ lefts populated
-- |Add a list of defined types to the symbol table -- |Add a list of defined types to the symbol table
addDefinedTypes :: [Type] -> [Type] -> Either [TypeCheckError] [Type] addDefinedTypes :: [Type] -> [Type] -> Either [TypeCheckError] [Type]
addDefinedTypes l [] = Right l addDefinedTypes l [] = Right l

8
test/Model/TypeSpec.hs
View File

@@ -51,16 +51,16 @@ spec = do
cards1 :: [Cardinality] cards1 :: [Cardinality]
cards1 = cards1 =
[Bounds (0, 20), Bounds (10, 15), Bounds (25, 50), Bounds (15, 16), NoBounds, OneBound 25, OneBound 2, OneBound 1, NoBounds, NoBounds] [Bounds (0, 20), Bounds (10, 15), Bounds (25, 50), Bounds (15, 16), OneBound 0, OneBound 25, OneBound 2, OneBound 1, OneBound 0, OneBound 0]
cards2 :: [Cardinality] cards2 :: [Cardinality]
cards2 = cards2 =
[Bounds (2, 4), Bounds (4, 45), OneBound 6, NoBounds, Bounds (2, 5), Bounds (2, 30), OneBound 5, NoBounds, OneBound 5, NoBounds] [Bounds (2, 4), Bounds (4, 45), OneBound 6, OneBound 0, Bounds (2, 5), Bounds (2, 30), OneBound 5, OneBound 0, OneBound 5, OneBound 0]
cardsSum :: [Cardinality] cardsSum :: [Cardinality]
cardsSum = cardsSum =
[Bounds (2, 24), Bounds (14, 60), OneBound 31, OneBound 15, OneBound 2, OneBound 27, OneBound 7, OneBound 1, OneBound 5, NoBounds] [Bounds (2, 24), Bounds (14, 60), OneBound 31, OneBound 15, OneBound 2, OneBound 27, OneBound 7, OneBound 1, OneBound 5, OneBound 0]
smallestCards :: [Cardinality] smallestCards :: [Cardinality]
smallestCards = smallestCards =
[Bounds (0, 20), Bounds (4, 45), OneBound 6, NoBounds, NoBounds, OneBound 2, OneBound 2, NoBounds, NoBounds, NoBounds] [Bounds (0, 20), Bounds (4, 45), OneBound 6, OneBound 0, OneBound 0, OneBound 2, OneBound 2, OneBound 0, OneBound 0, OneBound 0]

5
test/Parser/ExpressionSpec.hs
View File

@@ -6,6 +6,7 @@ import Test.Hspec
import Test.Hspec.Megaparsec import Test.Hspec.Megaparsec
import Text.Megaparsec import Text.Megaparsec
import Model.Function import Model.Function
import Model.Type
import Parser.Expression import Parser.Expression
spec :: Spec spec :: Spec
@@ -70,10 +71,10 @@ exps = [
Function "Function" [Int "3", InfixExp "+" (Int "3") (Int "2"), Variable "e"], Function "Function" [Int "3", InfixExp "+" (Int "3") (Int "2"), Variable "e"],
-- 10 -- 10
IfElse (Function "Function" [InfixExp "+" (Int "2") (Int "3"), Variable "e"]) IfElse (Function "Function" [InfixExp "+" (Int "2") (Int "3"), Variable "e"])
(InfixExp "-" (InfixExp "+" (Variable "a") (Variable "b")) (InfixExp "*" (Variable "c") (InfixExp "^" (Variable "d") (Variable "e->x")))) (InfixExp "-" (InfixExp "+" (Variable "a") (Variable "b")) (InfixExp "*" (Variable "c") (InfixExp "^" (Variable "d") (PathExpression (Variable "e") (Variable "x")))))
(PrefixExp "not" (PostfixExp "exists" (Variable "a"))), (PrefixExp "not" (PostfixExp "exists" (Variable "a"))),
-- 11 -- 11
IfSimple (List [Int "1", Function "Function" [Int "3"]]) (InfixExp "-" (InfixExp "-" (Int "1") (Int "2")) (InfixExp "*" (Int "3") (InfixExp "^" (Variable "a->b") (Variable "c")))), IfSimple (List [Int "1", Function "Function" [Int "3"]]) (InfixExp "-" (InfixExp "-" (Int "1") (Int "2")) (InfixExp "*" (Int "3") (InfixExp "^" (PathExpression (Variable "a") (Variable "b")) (Variable "c")))),
-- 12 -- 12
InfixExp "or" (Variable "a") (Variable "b") InfixExp "or" (Variable "a") (Variable "b")
] ]

38
test/Parser/TypeSpec.hs
View File

@@ -36,42 +36,46 @@ types :: [Type]
types = [ types = [
MakeType {typeName = "Period", MakeType {typeName = "Period",
typeDescription = Just "description", typeDescription = Just "description",
superType = MakeType "Something" (BasicType "Object") Nothing [], superType = MakeType "Something" (BasicType "Object") Nothing [] [],
typeAttributes = [MakeTypeAttribute {attributeName = "periodMultiplier", attributeType = MakeType "int" (BasicType "Object") Nothing [], cardinality = Bounds(1, 1), typeAttributes = [MakeTypeAttribute {attributeName = "periodMultiplier", attributeType = MakeType "int" (BasicType "Object") Nothing [] [], cardinality = Bounds(1, 1),
attributeDescription = Just "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."}, attributeDescription = Just "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."},
MakeTypeAttribute {attributeName = "testMany", attributeType = MakeType "TestType" (BasicType "Object") Nothing [], cardinality = OneBound 0, MakeTypeAttribute {attributeName = "testMany", attributeType = MakeType "TestType" (BasicType "Object") Nothing [] [], cardinality = OneBound 0,
attributeDescription = Just "Test many"}, attributeDescription = Just "Test many"},
MakeTypeAttribute {attributeName = "testSome", attributeType = MakeType "TestSomeType" (BasicType "Object") Nothing [], cardinality = OneBound 1, MakeTypeAttribute {attributeName = "testSome", attributeType = MakeType "TestSomeType" (BasicType "Object") Nothing [] [], cardinality = OneBound 1,
attributeDescription = Just "Test some"}, attributeDescription = Just "Test some"},
MakeTypeAttribute {attributeName = "testMaybeOne", attributeType = MakeType "TestZeroOneType" (BasicType "Object") Nothing [], cardinality = Bounds (0, 1), MakeTypeAttribute {attributeName = "testMaybeOne", attributeType = MakeType "TestZeroOneType" (BasicType "Object") Nothing [] [], cardinality = Bounds (0, 1),
attributeDescription = Just "Test zero or one"}, attributeDescription = Just "Test zero or one"},
MakeTypeAttribute {attributeName = "testAll", attributeType = MakeType "Test" (BasicType "Object") Nothing [], cardinality = Bounds (2, 15), MakeTypeAttribute {attributeName = "testAll", attributeType = MakeType "Test" (BasicType "Object") Nothing [] [], cardinality = Bounds (2, 15),
attributeDescription = Just "Test all"}]}, attributeDescription = Just "Test all"}],
conditions = []},
MakeType {typeName = "TestType", MakeType {typeName = "TestType",
typeDescription = Nothing, typeDescription = Nothing,
superType = BasicType "Object", superType = BasicType "Object",
typeAttributes = [MakeTypeAttribute {attributeName = "periodMultiplier", attributeType = MakeType "int" (BasicType "Object") Nothing [], cardinality = Bounds(1, 1), typeAttributes = [MakeTypeAttribute {attributeName = "periodMultiplier", attributeType = MakeType "int" (BasicType "Object") Nothing [] [], cardinality = Bounds(1, 1),
attributeDescription = Nothing}]}, attributeDescription = Nothing}],
conditions = []},
MakeType {typeName = "TestSomeType", MakeType {typeName = "TestSomeType",
typeDescription = Just "description", typeDescription = Just "description",
superType = BasicType "Object", superType = BasicType "Object",
typeAttributes = [MakeTypeAttribute {attributeName = "periodMultiplier", attributeType = MakeType "int" (BasicType "Object") Nothing [], cardinality = Bounds(1, 1), typeAttributes = [MakeTypeAttribute {attributeName = "periodMultiplier", attributeType = MakeType "int" (BasicType "Object") Nothing [] [], cardinality = Bounds(1, 1),
attributeDescription = Just "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."}]}, attributeDescription = Just "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."}],
conditions = []},
MakeType {typeName = "TestZeroOneType", MakeType {typeName = "TestZeroOneType",
typeDescription = Nothing, typeDescription = Nothing,
superType = MakeType "Period" (BasicType "Object") Nothing [], superType = MakeType "Period" (BasicType "Object") Nothing [] [],
typeAttributes = [MakeTypeAttribute {attributeName = "periodMultiplier", attributeType = MakeType "int" (BasicType "Object") Nothing [], cardinality = Bounds(1, 1), typeAttributes = [MakeTypeAttribute {attributeName = "periodMultiplier", attributeType = MakeType "int" (BasicType "Object") Nothing [] [], cardinality = Bounds(1, 1),
attributeDescription = Nothing}]}, attributeDescription = Nothing}],
conditions = []},
MakeType {typeName = "WrongCardinality", superType = BasicType "Object", typeDescription = Just "description", typeAttributes = []}, MakeType {typeName = "WrongCardinality", superType = BasicType "Object", typeDescription = Just "description", typeAttributes = [], conditions = []},
MakeType {typeName = "WrongCardinality2", superType = BasicType "Object", typeDescription = Just "description", typeAttributes = []}, MakeType {typeName = "WrongCardinality2", superType = BasicType "Object", typeDescription = Just "description", typeAttributes = [], conditions = []},
MakeType {typeName = "MissingType", superType = BasicType "Object", typeDescription = Just "description", typeAttributes = []} MakeType {typeName = "MissingType", superType = BasicType "Object", typeDescription = Just "description", typeAttributes = [], conditions = []}
] ]