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

functions work (still needs testing)

Browse Source
This commit is contained in:
Macocian Adrian Radu
2022-06-01 17:23:30 +02:00
parent 63ae41e612
commit d7a0d46344
14 changed files with 1094 additions and 40 deletions
Download Patch File Download Diff File Expand all files Collapse all files

22
src/Model/Type.hs
View File

@@ -1,4 +1,5 @@
module Model.Type where
-- |The representation of a Rosetta data type
data Type = MakeType {
typeName :: String,
@@ -39,6 +40,8 @@ data Expression = Variable String
| Enum String String
| Empty
| Parens Expression
| ListUnaryOp String Expression
| ListOp String Expression Expression
| List [Expression]
| Function String [Expression]
| PrefixExp String Expression
@@ -54,6 +57,8 @@ data ExplicitExpression = ExplicitEmpty
| ExplicitList [ExplicitExpression]
| ExplicitEnumCall {name :: String, val :: String, returnCoercion :: Coercion}
| ExplicitKeyword String
| ExplicitListUnaryOp {op :: String, list :: ExplicitExpression, returnCoercion :: Coercion}
| ExplicitListOp {op :: String, list :: ExplicitExpression, arg :: ExplicitExpression, returnCoercion :: Coercion}
| ExplicitParens {expression :: ExplicitExpression, returnCoercion :: Coercion}
| ExplicitPath {super :: ExplicitExpression, sub :: ExplicitExpression, returnCoercion :: Coercion}
| ExplicitFunction {name :: String, args :: [(ExplicitExpression, Coercion)], returnCoercion :: Coercion}
@@ -68,6 +73,8 @@ changeCoercion (ExplicitList e) _ = ExplicitList e
changeCoercion (ExplicitKeyword n) _ = ExplicitKeyword n
changeCoercion (ExplicitParens e _) c = ExplicitParens e c
changeCoercion (ExplicitPath s n _) c = ExplicitPath s n c
changeCoercion (ExplicitListOp n o ar _) c = ExplicitListOp n o ar c
changeCoercion (ExplicitListUnaryOp n o _) c = ExplicitListUnaryOp n o c
changeCoercion (ExplicitFunction n args _) c = ExplicitFunction n args c
changeCoercion (ExplicitIfSimple cond block _) c = ExplicitIfSimple cond block c
changeCoercion (ExplicitIfElse cond block block2 _) c = ExplicitIfElse cond block block2 c
@@ -84,6 +91,8 @@ instance Show ExplicitExpression where
show (ExplicitIfSimple cond block coer) = show $ "if" ++ show cond ++ " then " ++ show block
show (ExplicitIfElse cond block1 block2 coer) = show $ "if" ++ show cond ++ " then " ++ show block1 ++ " else " ++ show block2
show ExplicitEmpty = show "Empty"
show (ExplicitListOp lst op ar coer) = show $ show lst ++ " " ++ show op ++ " " ++ show ar
show (ExplicitListUnaryOp lst op coer) = show $ show lst ++ " " ++ show op
show (ExplicitEnumCall n val coer) = show $ "Enumcall: " ++ n ++ "->" ++ val
data TypeCoercion =
@@ -136,6 +145,14 @@ smallestBound (OneBound x) (Bounds (y, _)) = smallestBound (OneBound x) (OneBoun
smallestBound (Bounds (x, _)) (OneBound y) = smallestBound (OneBound x) (OneBound y)
smallestBound (Bounds (x1, x2)) (Bounds (y1, y2)) = Bounds (min x1 y1, max x2 y2)
lowerBound :: Cardinality -> Integer
lowerBound (Bounds (x, _)) = x
lowerBound (OneBound x) = x
upperBound :: Cardinality -> Integer
upperBound (Bounds (_, x)) = x
upperBound (OneBound _) = toInteger (maxBound :: Int)
-- |A function used to add two cardinalities
addBounds :: Cardinality -> Cardinality -> Cardinality
addBounds (Bounds (x1, x2)) (Bounds (y1, y2)) = Bounds (x1 + y1, x2 + y2)
@@ -171,4 +188,7 @@ coercionCardinality [x] = toCardinality x
coercionCardinality (x:rst) = coercionCardinality rst
createCoercion :: (Type, Cardinality) -> Coercion
createCoercion (t, c) = MakeCoercion [MakeIdCoercion t] (MakeCardinalityIdCoercion c)
createCoercion (t, c) = MakeCoercion [MakeIdCoercion t] (MakeCardinalityIdCoercion c)
anyListCoercion :: Coercion
anyListCoercion = MakeCoercion [MakeIdCoercion (BasicType "Any")] (MakeCardinalityIdCoercion (OneBound 0))

87
src/Parser/Expression.hs
View File

@@ -65,6 +65,9 @@ listParser =
_ <- lexeme $ char ']'
return $ List (expressions ++ [lastExpr])
listOperations :: [String]
listOperations = ["map", "filter", "reduce"]
-- |Parses a variable in Rosetta into an Expression
variableParser :: Parser Expression
variableParser =
@@ -113,7 +116,7 @@ terminalParser :: Parser Expression
terminalParser =
do
choice
[
[
try keywordParser,
prefixParser,
parens expressionParser >>= \e -> return (Parens e),
@@ -133,8 +136,8 @@ keywords :: [String]
keywords = ["one-of"]
keywordParser :: Parser Expression
keywordParser =
do
keywordParser =
do
word <- lexeme $ choice $ fmap (try . string . Text.pack) keywords
return $ Keyword $ Text.unpack word
@@ -161,17 +164,17 @@ eqParser =
-- |The list of equality statements in Rosetta
eqFunctions :: [String]
eqFunctions = ["=", "<", "<=", ">", ">=", "<>", "all =", "all <>", "any =", "any <>"]
eqFunctions = ["=", "<", "<=", ">", ">=", "<>"]
-- |Parses a sum statement in Rosetta into an Expression
sumParser :: Parser Expression
sumParser =
do
f <- factorParser
op <- lexeme $ observing (char '+' <|> char '-')
op <- lexeme $ observing (string "+" <|> string "- ")
case op of
Left _ -> return f
Right o -> sumParser >>= \ex -> return $ reverseExpression $ InfixExp [o] f ex
Right o -> sumParser >>= \ex -> return $ reverseExpression $ InfixExp (Text.unpack o) f ex
-- |Parses a multiplication or division statement in Rosetta into an Expression
factorParser :: Parser Expression
@@ -197,7 +200,7 @@ powerParser =
boolOpParser :: Parser Expression
boolOpParser =
do
p <- postfixParser
p <- pathExpressionParser
op <- lexeme $ observing (string "or" <|> string "and")
case op of
Left _ -> return p
@@ -207,18 +210,74 @@ boolOpParser =
postfixParser :: Parser Expression
postfixParser =
do
t <- pathExpressionParser
t <- listUnaryOpParser
op <- lexeme $ observing $ choice $ fmap (try . string . Text.pack) postfixFunctions
case op of
Left _ -> return t
Right o -> return $ PostfixExp (Text.unpack o) t
listUnaryOperations :: [String]
listUnaryOperations = ["sum", "max", "flatten", "min", "join", "only-element", "count", "first", "last", "sort", "distinct"]
-- |Parses a simple operation on a list
listUnaryOpParser :: Parser Expression
listUnaryOpParser =
do
lst <- listOpParser
op <- lexeme $ observing $ choice $ fmap (try . string . Text.pack) listUnaryOperations
case op of
Left er -> return lst
Right o ->
do
exp <- nestedPostOp lst
return $ reverseExpression $ ListUnaryOp (Text.unpack o) exp
-- |Parses an operation on a list
listOpParser :: Parser Expression
listOpParser =
do
lst <- terminalParser
op <- lexeme $ observing $ choice $ fmap (try . string . Text.pack) listOperations
case op of
Left _ -> return lst
Right o ->
do
con <- between (lexeme $ char '[') (lexeme $ char ']') expressionParser
exp <- nestedPostOp lst
return $ reverseExpression $ ListOp (Text.unpack o) exp con
-- |Parses nested post operations on lists
nestedPostOp :: Expression -> Parser Expression
nestedPostOp ex =
do
op <- lexeme $ observing $ choice $ fmap (try . string . Text.pack) listUnaryOperations
case op of
Left er -> nestedListOp ex
Right o ->
do
exp <- nestedPostOp ex
return $ reverseExpression $ ListUnaryOp (Text.unpack o) exp
-- |Parses nested normal operations on lists
nestedListOp :: Expression -> Parser Expression
nestedListOp ex =
do
op <- lexeme $ observing $ choice $ fmap (try . string . Text.pack) listOperations
case op of
Left er -> return ex
Right o ->
do
con <- between (lexeme $ char '[') (lexeme $ char ']') expressionParser
exp <- nestedPostOp ex
return $ reverseExpression $ ListOp (Text.unpack o) exp con
-- |Parses a path expression (a -> b) in Rosetta into an Expression
pathExpressionParser :: Parser Expression
pathExpressionParser =
do
var <- terminalParser
var <- postfixParser
op <- lexeme $ observing $ string "->"
case op of
Left _ -> return var
@@ -237,7 +296,13 @@ 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 (PathExpression e1 (PathExpression e2 e3)) = PathExpression (reverseExpression (PathExpression e1 e2)) e3
reverseExpression (PathExpression e1 (ListOp op ex2 cond)) = ListOp op cond (reverseExpression (PathExpression e1 ex2))
reverseExpression (PathExpression e1 (ListUnaryOp op ex2)) = ListUnaryOp op (reverseExpression (PathExpression e1 ex2))
reverseExpression (ListOp op1 (ListOp op2 ex2 con2) con1) = ListOp op2 (reverseExpression (ListOp op1 ex2 con1)) con2
reverseExpression (ListOp op1 (ListUnaryOp op2 ex2) con1) = ListUnaryOp op2 (reverseExpression (ListOp op1 ex2 con1))
reverseExpression (ListUnaryOp op1 (ListOp op2 ex2 con2)) = ListOp op2 (reverseExpression (ListUnaryOp op1 ex2)) con2
reverseExpression (ListUnaryOp op1 (ListUnaryOp op2 ex2)) = ListUnaryOp op2 (reverseExpression (ListUnaryOp op1 ex2))
reverseExpression e = e

2
src/PrettyPrinter/Enum.hs
View File

@@ -13,7 +13,7 @@ printEnum (MakeEnum name description values) =
(vcat ["data" <+> pretty name <+> "=",
indent 4 (printEnumValues name values), indent 4 "deriving (Eq)",
"",
printDisplayNames name values]) <> emptyDoc <> emptyDoc
printDisplayNames name values]) <> line <> line
-- |Converts a list of EnumValues into a haskell valid Doc
printEnumValues :: String -> [EnumValue] -> Doc a

13
src/PrettyPrinter/Expression.hs
View File

@@ -6,15 +6,24 @@ import Model.Type
import Prettyprinter
import Semantic.ExpressionChecker(coercionIncluded)
import Utils.Utils
import Data.List (isPrefixOf)
printExpression :: ExplicitExpression -> Doc a
printExpression ExplicitEmpty = "[]"
printExpression (ExplicitVariable name coer) = printCoercion coer $ pretty name
printExpression (ExplicitVariable name coer)
| "item" `isPrefixOf` name = printCoercion coer $ pretty (replacePrefix "item" name "x")
| otherwise = printCoercion coer $ pretty name
printExpression (Value s coer) = printCoercion coer $ pretty s
printExpression (ExplicitKeyword k) = pretty k
printExpression (ExplicitEnumCall name val coer) = printCoercion coer $ pretty name <> pretty val
printExpression (ExplicitParens ex c) = "(" <> printExpression ex <> ")"
printExpression (ExplicitList ex) = list [printExpression x | x <- ex]
printExpression (ExplicitList ex) = Prettyprinter.list [printExpression x | x <- ex]
printExpression (ExplicitListOp "map" lst cond coer) = enclose "[" "]" (printExpression cond <+> "|" <+> "x" <+> "<-" <+> printExpression lst)
printExpression (ExplicitListOp "filter" lst cond coer) = enclose "[" "]" ("x" <+> "|" <+> "x" <+> "<-" <+> printExpression lst <> "," <+> printExpression cond)
printExpression (ExplicitListOp op lst cond coer) = pretty op <+> nest 4 (vsep [emptyDoc, enclose "(" ")" (printExpression cond), enclose "(" ")" (printExpression lst)])
printExpression (ExplicitListUnaryOp "only-element" lst coer) = "head" <+> enclose "(" ")" (nest 4 (line <> printExpression lst))
printExpression (ExplicitListUnaryOp "flatten" lst coer) = "concat" <+> enclose "(" ")" (nest 4 (line <> printExpression lst))
printExpression (ExplicitListUnaryOp op lst coer) = pretty op <+> nest 4 (printExpression lst)
printExpression (ExplicitPath ex1 (ExplicitVariable var ret) returnCoerce) =
pretty (uncapitalize $ typeName $ coercionType $ typeCoercion $ returnCoercion ex1) <> pretty (capitalize var) <+>
enclose "(" ")" (printExpression ex1)

4
src/PrettyPrinter/Function.hs
View File

@@ -48,7 +48,7 @@ printFunctionBody (MakeExplicitFunction (MakeFunctionSignature name _ inp out) a
printAlias :: (String, ExplicitExpression) -> Doc a
printAlias (name, exp) = "let" <+> pretty name <+> "=" <+> printExpression exp <+> "in"
printAlias (name, exp) = nest 4 (line <> "let" <+> pretty name <+> "=" <+> nest 8 (line <> printExpression exp) <+> "in")
-- |Converts a function into a haskell valid Doc representing the signature of the function
printFunctionSignature :: FunctionSignature -> Doc a
@@ -66,7 +66,7 @@ printAssignmentTree (AssignmentNode var typ c)
AssignmentLeaf e -> printAssignmentTree (head c)
AssignmentNode v t _ -> printConstructor typ <> pretty (capitalize v) <+> "(" <> printAssignmentTree (head c) <> ")"
| otherwise = case typ of
MakeType t _ _ _ _ -> "Make" <> pretty t <+> "{" <> hsep (punctuate "," [pretty (uncapitalize t) <> getVarName child <+> "=" <+> printAssignmentTree child | child <- c]) <> "}"
MakeType t _ _ _ _ -> "make" <> pretty t <+> "{" <> hsep (punctuate "," [pretty (uncapitalize t) <> getVarName child <+> "=" <+> printAssignmentTree child | child <- c]) <> "}"
BasicType _ -> sep ["(" <> printAssignmentTree child <> ")" | child <- c]
getVarName :: AssignmentTree -> Doc a

21
src/PrettyPrinter/Type.hs
View File

@@ -19,6 +19,11 @@ printType (BasicType name) = show $ pretty name
printTypeName :: String -> Maybe String -> Doc a
printTypeName name desc = printDescription desc ("data" <+> pretty name <+> "=")
printDefault :: String -> String -> [TypeAttribute] -> Doc a
printDefault name cons ats = "make" <> pretty name <+> "=" <+> pretty cons <+> "{" <> sep (punctuate ","
([pretty (uncapitalize name) <> pretty (capitalize (attributeName x)) <+> "=" <+> "Nothing" | x <- ats, cardinality x == Bounds (0, 1)] ++
[pretty (uncapitalize name) <> pretty (capitalize (attributeName x)) <+> "=" <+> "[]" | x <- ats, lowerBound (cardinality x) == 0 && upperBound (cardinality x) > 1])) <> "}"
-- |Creates an attribute that accesses the super type
superToAttribute :: String -> TypeAttribute
superToAttribute typ = MakeTypeAttribute "super" (MakeType typ (BasicType "Object") Nothing [] []) (Bounds (1, 1)) (Just "Pointer to super class")
@@ -26,10 +31,12 @@ superToAttribute typ = MakeTypeAttribute "super" (MakeType typ (BasicType "Objec
-- |Converts a list of TypeAttributes into a list of haskell valid Docs
printAttributes :: String -> [Condition] -> [TypeAttribute] -> Doc a
printAttributes objName conditions ats
| MakeCondition Nothing (Keyword "one-of") `elem` conditions || length ats < 2 = vcat [nest 4 $ vcat $
zipWith (<>) ("" : repeat "| ") (map (printSumType objName) ats) ++ map printCondition conditions, " deriving (Eq)"]
| MakeCondition Nothing (Keyword "one-of") `elem` conditions = vcat [nest 4 $ vcat $
zipWith (<>) ("" : repeat "| ") (map (printSumType objName) (increaseBound ats)) ++ map printCondition conditions, " deriving (Eq)"]
| length ats < 2 = vcat [nest 4 $ vcat $
zipWith (<>) ("" : repeat "| ") (map (printSumType objName) ats) ++ map printCondition conditions, " deriving (Eq)", printDefault objName (objName ++ capitalize (attributeName (head ats))) ats]
| otherwise = vcat [nest 4 $ vcat ("Make" <> pretty objName <+> "{" :
punctuate comma (map (printAttribute objName) ats) ++ map printCondition conditions), "}"] <+> "deriving (Eq)"
punctuate comma (map (printAttribute objName) ats) ++ map printCondition conditions), "}"] <+> "deriving (Eq)" <> line <> printDefault objName ("Make" ++ objName) ats
-- |Converts a TypeAttribute into a haskell valid Doc
printAttribute :: String -> TypeAttribute -> Doc a
@@ -49,4 +56,10 @@ printCondition :: Condition -> Doc a
printCondition (MakeCondition desc e) = printDescription desc ("--" <+> pretty (show e))
printSumType :: String -> TypeAttribute -> Doc a
printSumType objName (MakeTypeAttribute name typ crd _) = pretty objName <> pretty (capitalize name) <+> pretty (typeName typ)
printSumType objName (MakeTypeAttribute name typ crd d) = pretty objName <> pretty (capitalize name) <+> "{"<> pretty (uncapitalize objName) <> pretty (capitalize name) <+> "::" <+> printCardinality (MakeTypeAttribute name typ crd d) <> "}"
-- |Increase the lower bound when it is 0 to 1. Used for printing types with "one-of" condition
increaseBound :: [TypeAttribute] -> [TypeAttribute]
increaseBound [] = []
increaseBound (MakeTypeAttribute name typ (Bounds (0, b)) desc : ts) = MakeTypeAttribute name typ (Bounds (1, b)) desc : increaseBound ts
increaseBound (t : ts) = t : increaseBound ts

74
src/Semantic/ExpressionChecker.hs
View File

@@ -75,6 +75,14 @@ defaultMap = [
Func "count" [(BasicType "Any", OneBound 0)] (BasicType "Integer", Bounds (1, 1))
]
-- |A list of the allowed list functions, the type of their expression and their return type
listFunctionTypes :: Coercion -> Coercion -> [(String, Coercion, Coercion)]
listFunctionTypes inp ex = [
-- The function given to a filter must be boolean and it can return anything
("filter", MakeCoercion [MakeIdCoercion (BasicType "Boolean")] (MakeCardinalityIdCoercion (OneBound 0)), inp),
("map", MakeCoercion [MakeIdCoercion (BasicType "Any")] (MakeCardinalityIdCoercion (OneBound 0)), ex)
]
-- |Checks whether a function is valid (inputs, outputs are of valid type and all variables are defined) and adds it to the symbol table
addFunction :: ([Type], [Symbol]) -> Function -> Either [TypeCheckError] [Symbol]
addFunction (definedTypes, definedSymbols) (MakeFunction (MakeFunctionSignature name _ inps out) _ _) =
@@ -106,13 +114,33 @@ checkExpression defT symbolMap (Enum enum val) = case getType enum defT of
Right typ -> if val `elem` map attributeName (typeAttributes typ)
then Right $ ExplicitEnumCall enum val $ MakeCoercion [MakeIdCoercion typ] (MakeCardinalityIdCoercion (Bounds (1, 1)))
else Left $ UndefinedVariable val
checkExpression defT symbolMap (ListOp op lst cond) =
case checkExpression defT symbolMap lst of
Left err -> Left err
Right checkedLst -> if toCardinality (cardinalityCoercion (returnCoercion checkedLst)) == Bounds(1, 1)
then Left $ ListOperationNotOnList $ show lst
else let it = getNextItem symbolMap in
case checkExpression defT
(addVariables symbolMap [MakeTypeAttribute it (coercionType $ typeCoercion $ returnCoercion checkedLst) (toCardinality $ cardinalityCoercion $ returnCoercion checkedLst) Nothing])
(replaceVar cond it) of
Left err -> Left err
Right condType -> case returnCoercion condType `coercionIncluded` head [snd3 x | x <- listOps, fst3 x == op] of
Left err -> Left err
Right checkedCond -> Right $ ExplicitListOp op checkedLst (changeCoercion condType checkedCond) (head [trd3 x | x <- listOps, fst3 x == op])
where
listOps = listFunctionTypes (returnCoercion checkedLst) (returnCoercion condType)
checkExpression defT symbolMap (ListUnaryOp op lst) =
case checkExpression defT symbolMap lst of
Left err -> Left $ ErrorInsideFunction $ op ++ ": " ++ show err
Right checkedLst -> if toCardinality (cardinalityCoercion (returnCoercion checkedLst)) == Bounds(1, 1)
then Left $ ListOperationNotOnList $ show lst
else Right $ ExplicitListUnaryOp op checkedLst (returnCoercion checkedLst)
checkExpression _ _ (Keyword k) = Right $ ExplicitKeyword k
checkExpression defT symbolMap (PathExpression ex1 (Variable b)) =
case checkExpression defT symbolMap ex1 of
Left err -> Left err
Right exp1 -> case findAttributeType b (getTypeAttributes defT type1) of
Left err -> Left $ UndefinedVariable $ show type1 ++ " -> " ++ b
Right exp1 -> case findAttributeTypeRec defT b type1 of
Left err -> Left $ UndefinedVariable $ show (typeName type1) ++ " -> " ++ b
Right exp2 -> Right $ ExplicitPath exp1 exp2 (returnCoercion exp2)
where
type1 = coercionType $ typeCoercion $ returnCoercion exp1
@@ -196,11 +224,11 @@ checkList1 defT symbs (ex : exps) typ =
-- |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 [] fun args = error $ show 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
| not $ null $ lefts args = Left $ ErrorInsideFunction (name ++ ": " ++ show args ++ show (lefts args))
| not $ null $ lefts args = Left $ ErrorInsideFunction (name ++ ": " ++ show (lefts args))
| name == n = if all isRight coerce then Right $ ExplicitFunction name (zip (rights args) (rights coerce)) (MakeCoercion [MakeIdCoercion (fst r)] (MakeCardinalityIdCoercion (snd r)))
else error $ show argCoerce
else checkFunctionCall symbolMap name args--Left $ UndefinedFunction $ "Undefined function: " ++ name ++ " [" ++ show (rights args) ++ "]"
| otherwise = checkFunctionCall symbolMap name args
where
argCoerce = map returnCoercion (rights args)
@@ -222,6 +250,7 @@ typeIncluded (t1, c1) (t2, c2) =
Left err -> Left err
Right cardCoercion -> Right $ MakeCoercion typeCoercion cardCoercion
-- | Checks whether the first coercion can be transformed into the second coercion
coercionIncluded :: Coercion -> Coercion -> Either TypeCheckError Coercion
coercionIncluded c1 c2 = (coercionType (typeCoercion c1), coercionCardinality [cardinalityCoercion c1]) `typeIncluded` (coercionType (typeCoercion c2), coercionCardinality [cardinalityCoercion c2])
@@ -250,6 +279,18 @@ findVarType x ((Var name typ crd):symbols)
| otherwise = findVarType x symbols
findVarType x (_:symbols) = findVarType x symbols
-- |Look for a type attribute in a given type and its super types
findAttributeTypeRec :: [Type] -> String -> Type -> Either TypeCheckError ExplicitExpression
findAttributeTypeRec _ var (BasicType _) = Left $ UndefinedVariable var
findAttributeTypeRec sTable var t = case findAttributeType var (getTypeAttributes sTable t) of
Left err -> case findAttributeTypeRec sTable var (superType t) of
Left err -> Left err
Right (ExplicitVariable n (MakeCoercion tc cc)) -> Right $
ExplicitVariable n
(MakeCoercion (MakeSuperCoercion t (toType $ head tc) : tc) cc)
Right typ -> Right typ
Right typ -> Right typ
-- |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
@@ -257,6 +298,22 @@ findAttributeType var (t : ts)
| var == attributeName t = Right $ ExplicitVariable var (MakeCoercion [MakeIdCoercion $ attributeType t] (MakeCardinalityIdCoercion $ Model.Type.cardinality t))
| otherwise = findAttributeType var ts
-- |Removes the path expression from item in a list operation
-- ex: person map [item -> firstname] => person map [person -> firsname]
replaceVar :: Expression -> String -> Expression
replaceVar (Variable "item") var = Variable var
replaceVar (PathExpression a b) var = PathExpression (replaceVar a var) b
replaceVar (Parens e) var = Parens (replaceVar e var)
replaceVar (ListUnaryOp o e) var = ListUnaryOp o (replaceVar e var)
replaceVar (ListOp o e c) var = ListOp o (replaceVar e var) c
replaceVar (Function f e) var = Function f [replaceVar ex var | ex <- e]
replaceVar (PrefixExp o e) var = PrefixExp o (replaceVar e var)
replaceVar (PostfixExp o e) var = PostfixExp o (replaceVar e var)
replaceVar (InfixExp o e1 e2) var = InfixExp o (replaceVar e1 var) (replaceVar e2 var)
replaceVar (IfSimple c e1) var = IfSimple (replaceVar c var) (replaceVar e1 var)
replaceVar (IfElse c e1 e2) var = IfElse (replaceVar c var) (replaceVar e1 var) (replaceVar e2 var)
replaceVar e _ = e
-- |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"]
@@ -270,6 +327,11 @@ isSubType x y
Left e -> Left e
Right transforms -> Right $ MakeSuperCoercion x y : transforms
getNextItem :: [Symbol] -> String
getNextItem symbs
| Var "item" (BasicType "Any") (OneBound 0) `notElem` symbs = "item"
| otherwise = head ["list" ++ show x | x <- [1..], Var ("list" ++ show x) (BasicType "Any") (OneBound 0) `notElem` symbs]
-- |Finds the type attributes from a type in the symbol table
getTypeAttributes :: [Type] -> Type -> [TypeAttribute]
getTypeAttributes [] t = []

1
src/Semantic/TypeChecker.hs
View File

@@ -17,6 +17,7 @@ data TypeCheckError =
| MultipleDeclarations String
| TypeNameReserved String
| UnsupportedExpressionInPathExpression String
| ListOperationNotOnList String
deriving (Show)
-- |Checks whether a data type is valid

19
src/Utils/Utils.hs
View File

@@ -2,6 +2,7 @@ module Utils.Utils where
import Data.Either
import Data.Char
import Data.List (stripPrefix)
-- |Capitalize a string
@@ -84,4 +85,20 @@ checkDuplicates :: Eq a => [a] -> [a]
checkDuplicates [] = []
checkDuplicates (a : as)
| a `elem` as = a : checkDuplicates as
| otherwise = checkDuplicates as
| otherwise = checkDuplicates as
fst3 :: (a, b, c) -> a
fst3 (x, _, _) = x
snd3 :: (a, b, c) -> b
snd3 (_, x, _) = x
trd3 :: (a, b, c) -> c
trd3 (_, _, x) = x
-- |If the second list contains the first list, it replaces that occurances with the third list
replacePrefix :: Eq a => [a] -> [a] -> [a] -> [a]
replacePrefix a b c = case stripPrefix a b of
Nothing -> b
Just bs -> c ++ bs