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 Data.Text (Text)
-- :set args resources/Rosetta/test-multiple.rosetta
-- :set args resources/Rosetta/test-all.rosetta
-- :l resources/Generated/testAll.hs resources/Generated/testPeriod.hs
@@ -62,10 +64,12 @@ parseWithImport file =
let importedFunctions = concat $ sndlst importedSymbolTable
case addNewTypes importedTypes objs of
Left errors -> error $ show errors
Right definedTypes ->
case addNewFunctions (definedTypes, importedFunctions) objs of
Right emptyTypes ->
case populateTypes emptyTypes of
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
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:
testZeroOneType int (1..1)
condition important: <"This is an important condition">
observationPrimitive < 0
type ObservationPrimitive:
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 =
MakeFunction {
signature :: FunctionSignature,
assignment :: Expression
assignment :: [(Expression, Expression)]
}
deriving (Show)
data ExplicitFunction =
MakeExplicitFunction {
sign :: FunctionSignature,
explicitAssignment :: ExplicitExpression
explicitAssignment :: [(ExplicitExpression, ExplicitExpression)]
}
deriving Show

3
src/Model/Type.hs
View File

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

71
src/Parser/Expression.hs
View File

@@ -12,7 +12,7 @@ import Text.Megaparsec.Char
-- |Parses a complete Rosetta expression into an Expression type
expressionParser :: Parser Expression
expressionParser =
expressionParser =
choice [ ifParser,
try functionCallParser,
eqParser]
@@ -46,7 +46,7 @@ ifParser =
case els of
Left _ -> return (IfSimple condition expr)
Right _ -> expressionParser >>= \expr2 -> return (IfElse condition expr expr2)
-- |Parses an expression between parentheses in Rosetta into an Expression
parens :: Parser a -> Parser a
parens = between (char '(') (char ')')
@@ -69,16 +69,7 @@ listParser =
variableParser :: Parser Expression
variableParser =
do
var <- 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
Variable <$> camelNameParser
-- |Parses an integer in Rosetta into an Expression
integerParser :: Parser Expression
@@ -86,7 +77,7 @@ integerParser =
do
nr <- lexeme $ some digitChar
return $ Int nr
-- |Parses a real number in Rosetta into an Expression
decimalParser :: Parser Expression
decimalParser =
@@ -95,7 +86,7 @@ decimalParser =
_ <- char '.'
real <- lexeme $ many digitChar
return $ Real $ nr ++ "." ++ real
-- |Parses a boolean in Rosetta into an Expression
booleanParser :: Parser Expression
booleanParser =
@@ -105,7 +96,7 @@ booleanParser =
-- |Parses the empty statement in Rosetta into an Expression
emptyParser :: Parser Expression
emptyParser =
emptyParser =
do
_ <- lexeme $ string "empty"
return Empty
@@ -114,7 +105,7 @@ emptyParser =
terminalParser :: Parser Expression
terminalParser =
do
choice
choice
[ prefixParser,
parens expressionParser >>= \e -> return (Parens e),
listParser,
@@ -131,11 +122,11 @@ terminalParser =
-- |Parses an prefix function statement in Rosetta into an Expression
prefixParser :: Parser Expression
prefixParser =
prefixParser =
do
op <- lexeme $ choice $ fmap (try . string . Text.pack) prefixOperators
PrefixExp (Text.unpack op) <$> expressionParser
-- |List of prefix operators
prefixOperators :: [String]
prefixOperators = ["-", "not"]
@@ -166,44 +157,55 @@ sumParser =
-- |Parses a multiplication or division statement in Rosetta into an Expression
factorParser :: Parser Expression
factorParser =
do
factorParser =
do
p <- powerParser
op <- lexeme $ observing (char '*' <|> char '/')
case op of
Left _ -> return p
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
powerParser :: Parser Expression
powerParser =
powerParser =
do
p <- boolOpParser
op <- lexeme $ observing $ char '^'
case op of
Left _ -> return p
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
postfixParser :: Parser Expression
postfixParser =
postfixParser =
do
t <- terminalParser
t <- pathExpressionParser
op <- lexeme $ observing $ choice $ fmap (try . string . Text.pack) postfixFunctions
case op of
Left _ -> return 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
postfixFunctions :: [String]
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))
| precedence op == precedence op2 = InfixExp op2 (reverseExpression (InfixExp op t1 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

9
src/Parser/Function.hs
View File

@@ -20,15 +20,18 @@ functionParser =
fDescription <- optional descriptionParser
fInput <- inputAttributesParser
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
assignmentParser :: Parser Expression
assignmentParser :: Parser (Expression, Expression)
assignmentParser =
do
_ <- lexeme $ string "assign-output"
out <- expressionParser
_ <- lexeme $ char ':'
expressionParser
assignment <- expressionParser
return (out, assignment)
-- |Parses the input attributes from a function statement in Rosetta into a list of TypeAttributes
inputAttributesParser :: Parser [TypeAttribute]

5
src/Parser/Type.hs
View File

@@ -50,10 +50,9 @@ cardinalityParser = try parseBounded <|> try parseSemiBounded
conditionParser :: Parser Condition
conditionParser = do
_ <- lexeme $ string "condition"
name <- lexeme camelNameParser
_ <- lexeme $ char ':'
description <- optional descriptionParser
MakeCondition name description <$> expressionParser
_ <- lexeme $ char ':'
MakeCondition description <$> expressionParser
-- |Parses a bounded cardinality statement in Rosetta into a 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
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 ExplicitEmpty _ = "[]"
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
printExpression (Value s coer) out = case coer `coercionIncluded` out of
Left err -> error $ show err
Right c -> printCoercion c $ pretty s
printExpression (ExplicitParens ex) out = "(" <> printExpression ex out <> ")"
printExpression (ExplicitList ex) out = list [printExpression x out | x <- ex]
printExpression (ExplicitPath ex1 ex2 returnCoerce) out = printCoercion (returnCoercion ex1) (printExpression ex1 (returnCoercion ex1)) <+> "->" <+> printCoercion (returnCoercion ex2) (printExpression ex2 out)
printExpression (ExplicitFunction "exists" args returnCoerce) out = printCoercion returnCoerce "isJust" <+> printCoercion (snd $ head args) (printExpression (fst $ head args) out)
printExpression (ExplicitFunction "is absent" args returnCoerce) out = printCoercion returnCoerce "isNothing" <+> printCoercion (snd $ head args) (printExpression (fst $ head args) out)
printExpression (ExplicitFunction "single exists" args returnCoerce) out = printCoercion returnCoerce "length" <+> printCoercion (snd $ head args) (printExpression (fst $ head args) out) <+> "==" <+> "1"

2
src/PrettyPrinter/Type.hs
View File

@@ -40,4 +40,4 @@ printCardinality (MakeTypeAttribute _ typ (Bounds (x, y)) _)
printCardinality (MakeTypeAttribute _ typ (OneBound _) _) = "[" <> pretty (typeName typ) <> "]"
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 Semantic.TypeChecker
import Utils.Utils
import Model.Type (CardinalityCoercion(MakeNothing2MaybeCoercion, MakeNothing2ListCoercion, MakeMaybe2ListCoercion, MakeObject2MaybeCoercion, MakeObject2ListCoercion))
-- |A declared variable or function
data Symbol = Var{
varName :: String,
@@ -28,8 +27,8 @@ instance Eq Symbol where
| name1 == name2 = True
| otherwise = False
(==) _ _ = False
-- |A map of the predefined functions, their arguments and their return type
defaultMap :: [Symbol]
defaultMap = [
@@ -41,7 +40,7 @@ defaultMap = [
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 "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)),
@@ -52,7 +51,7 @@ defaultMap = [
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 "+" [(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 "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 "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 "count" [(BasicType "Any", OneBound 0)] (BasicType "Integer", Bounds (1, 1))
]
@@ -77,26 +76,38 @@ addFunction (definedTypes, definedSymbols) (MakeFunction (MakeFunctionSignature
then Left [MultipleDeclarations name]
else Right $ Func name (map typeAndCardinality (rights checkedInputs)) (attributeType checkedOutput, Model.Type.cardinality out) : definedSymbols
else Left $ lefts checkedInputs
where
where
checkedInputs = checkAttributes definedTypes inps
-- |Adds a newly defined variable to the symbol table
addVariables :: [Symbol] -> [TypeAttribute] -> [Symbol]
addVariables s [] = s
addVariables s ((MakeTypeAttribute name typ crd _) : vars) = Var name (toHaskell typ) crd : addVariables s vars
-- |Checks the type of a given expression
checkExpression :: [Symbol] -> Expression -> Either TypeCheckError ExplicitExpression
checkExpression symbolMap (Variable var) = findVarType var symbolMap
checkExpression :: [Symbol] -> Expression -> Either TypeCheckError ExplicitExpression
--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 _ (Real val) = Right $ Value val $ MakeCoercion [MakeIdCoercion (BasicType "Double")] (MakeCardinalityIdCoercion (Bounds (1, 1)))
checkExpression _ (Boolean val) = Right $ Value val $ MakeCoercion [MakeIdCoercion (BasicType "Boolean")] (MakeCardinalityIdCoercion (Bounds (1, 1)))
checkExpression _ Empty = Right $ Value "empty" $ MakeCoercion [MakeIdCoercion (BasicType "Empty")] (MakeCardinalityIdCoercion (Bounds (0, 0)))
checkExpression 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
Left err -> Left err
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 (Function name exps) = checkFunctionCall symbolMap name (map (checkExpression symbolMap) exps)
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
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)
Right condCoerce ->
Right condCoerce ->
case checkExpression symbolMap ex of
Left err -> Left err
Right thenExp ->
Right $ ExplicitIfSimple (condType, condCoerce)
(thenExp, thenCoercion)
Right thenExp ->
Right $ ExplicitIfSimple (condType, condCoerce)
(thenExp, thenCoercion)
(MakeCoercion [MakeIdCoercion $ coercionType $ typeCoercion $ returnCoercion thenExp]
(MakeCardinalityIdCoercion $ smallestBound (Bounds (0, 0)) (toCardinality $ cardinalityCoercion $ returnCoercion thenExp)))
where
thenCoercion = MakeCoercion [MakeIdCoercion $ coercionType $ typeCoercion $ returnCoercion thenExp]
where
thenCoercion = MakeCoercion [MakeIdCoercion $ coercionType $ typeCoercion $ 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
@@ -125,19 +136,18 @@ checkExpression symbolMap (IfElse cond ex1 ex2) =
Left err -> Left $ IfConditionNotBoolean $ show err
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)
Right condCoerce ->
Right condCoerce ->
case checkExpression symbolMap ex1 of
Left err -> Left $ ErrorInsideFunction $ show err
Right thenExp -> case checkExpression symbolMap ex2 of
Left err -> Left $ ErrorInsideFunction $ show err
Right elseExp ->
Right $ ExplicitIfElse (condType, condCoerce)
Right elseExp ->
Right $ ExplicitIfElse (condType, condCoerce)
(thenExp, MakeCoercion [MakeIdCoercion $ coercionType $ typeCoercion $ returnCoercion thenExp]
(MakeCardinalityIdCoercion $ toCardinality $ cardinalityCoercion $ returnCoercion thenExp))
(elseExp, MakeCoercion [MakeIdCoercion $ coercionType $ typeCoercion $ returnCoercion elseExp]
(MakeCardinalityIdCoercion $ toCardinality $ cardinalityCoercion $ returnCoercion elseExp)) (returnCoercion thenExp)
--(typeMatch ex1Type ex2Type, smallestBound ex1Card ex2Type)
-- |TODO Handle nested lists and lists with parens
-- |Checks that all the expressions in a list have compatible types
@@ -146,39 +156,39 @@ checkList _ [] = Right $ ExplicitList [ExplicitEmpty]
checkList symbs (ex : exps) =
case checkExpression symbs ex of
Left err -> Left err
Right x ->
Right x ->
case checkList1 symbs exps (coercionType $ typeCoercion $ returnCoercion x, toCardinality $ cardinalityCoercion $ returnCoercion x) of
Left err -> Left err
Right exp -> Right $ ExplicitList exp
-- |Auxiliary function for the check list function
checkList1 :: [Symbol] -> [Expression] -> (Type, Cardinality) -> Either TypeCheckError [ExplicitExpression]
checkList1 _ [] typ = Right [ExplicitEmpty]
checkList1 symbs (ex : exps) typ =
case checkExpression symbs ex of
Left err -> Left err
Right exCo ->
Right exCo ->
case fst typ `isSubType` exTyp of
Left err -> Left err
Right _ ->
Right _ ->
case checkList1 symbs exps (exTyp, smallestBound exCard (snd typ)) of
Left err -> Left err
Right explicitEx -> Right [ExplicitList explicitEx]
Right explicitEx -> Right [ExplicitList explicitEx]
where
exTyp = coercionType $ typeCoercion $ returnCoercion exCo
exCard = toCardinality $ cardinalityCoercion $ returnCoercion exCo
-- |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 ((Func n a r):symbolMap) name 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
where
where
argCoerce = map returnCoercion (rights args)
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 (t1, c1) (t2, c2) =
@@ -189,8 +199,8 @@ typeIncluded (t1, c1) (t2, c2) =
Left err -> Left err
Right cardCoercion -> Right $ MakeCoercion typeCoercion cardCoercion
coercionIncluded :: Coercion -> Coercion -> Either TypeCheckError Coercion
coercionIncluded c1 c2 = (coercionType (typeCoercion c1), coercionCardinality [cardinalityCoercion c1]) `typeIncluded` (coercionType (typeCoercion c2), coercionCardinality [cardinalityCoercion c2])
coercionIncluded :: Coercion -> Coercion -> Either TypeCheckError Coercion
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
typeMatch :: Type -> Type -> Type
@@ -210,20 +220,27 @@ typeMatch x y = case x `isSubType` y of
Right _ -> y
-- |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 x ((Var name typ crd):symbols)
| x == name = Right $ ExplicitVariable x (MakeCoercion [MakeIdCoercion typ] (MakeCardinalityIdCoercion crd))
| otherwise = 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
isSubType :: Type -> Type -> Either TypeCheckError [TypeCoercion]
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]
| otherwise = Left $ TypeMismatch x (typeName y)
isSubType x y
| otherwise = Left $ TypeMismatch x (typeName y)
isSubType x y
| typeName x == typeName y = Right [MakeIdCoercion x]
| otherwise = case isSubType (superType x) y of
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
checkFunction :: ([Type], [Symbol]) -> Function -> Either [TypeCheckError] ExplicitFunction
checkFunction (definedTypes, symbols) (MakeFunction (MakeFunctionSignature name desc inp out) ex) =
let checkedIn = checkAttributes definedTypes inp in
if null $ lefts checkedIn
then
case head $ checkAttributes definedTypes [out] of
Left err -> Left [err]
Right checkedOut -> case checkExpression (addVariables symbols inp) ex of
Left err -> Left [err]
Right checkedEx -> case returnCoercion checkedEx `coercionIncluded` createCoercion (attributeType checkedOut, Model.Type.cardinality out) of
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))
Right checkedOut -> case checkAssignment (addVariables symbols (checkedOut : rights checkedIn)) ex of
Left err -> Left err
Right checkedEx -> Right $ MakeExplicitFunction (MakeFunctionSignature (toLower (head name) : tail name) desc (rights checkedIn) checkedOut) checkedEx
else
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
| MultipleDeclarations String
| TypeNameReserved String
| UnsupportedExpressionInPathExpression String
deriving (Show)
-- |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
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
checkAttributeType :: [Type] -> Type -> Either TypeCheckError Type
checkAttributeType [] t = Left $ UndefinedType $ typeName t
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)
checkAttributeType (defined : ts) t
| defined == t = Right defined
| 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
addDefinedTypes :: [Type] -> [Type] -> Either [TypeCheckError] [Type]
addDefinedTypes l [] = Right l

8
test/Model/TypeSpec.hs
View File

@@ -51,16 +51,16 @@ spec = do
cards1 :: [Cardinality]
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 =
[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 =
[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 =
[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 Text.Megaparsec
import Model.Function
import Model.Type
import Parser.Expression
spec :: Spec
@@ -70,10 +71,10 @@ exps = [
Function "Function" [Int "3", InfixExp "+" (Int "3") (Int "2"), Variable "e"],
-- 10
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"))),
-- 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
InfixExp "or" (Variable "a") (Variable "b")
]

38
test/Parser/TypeSpec.hs
View File

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