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

added coercions and explicit functions

Browse Source 
it compiles
needs testing
This commit is contained in:
Macocian Adrian Radu
2022-04-16 02:23:33 +03:00
parent de940ca92e
commit 3caea6f18a
7 changed files with 118 additions and 96 deletions
Download Patch File Download Diff File Expand all files Collapse all files

23
app/Main.hs
View File

@@ -10,6 +10,7 @@ import Text.Megaparsec
import PrettyPrinter.Enum import PrettyPrinter.Enum
import PrettyPrinter.Type import PrettyPrinter.Type
import PrettyPrinter.Function import PrettyPrinter.Function
import PrettyPrinter.RosettaObject
import Semantic.TypeChecker import Semantic.TypeChecker
import Semantic.ExpressionChecker import Semantic.ExpressionChecker
import Semantic.FunctionChecker import Semantic.FunctionChecker
@@ -71,32 +72,32 @@ parseFile :: String -> Either (ParseErrorBundle Text Void) (Header, [RosettaObje
parseFile plainText = parse rosettaParser "" (Text.pack plainText) parseFile plainText = parse rosettaParser "" (Text.pack plainText)
-- |Converts a RosettaObject into a plain haskell string -- |Converts a RosettaObject into a plain haskell string
printObject :: RosettaObject -> String -- printObject :: CheckedRosettaObject -> String
printObject (TypeObject t) = printType t -- printObject (CheckedTypeObject t) = printType t
printObject (FunctionObject f) = printFunction f -- printObject (CheckedFunctionObject f) = printFunction f
printObject (EnumObject e) = printEnum e -- printObject (CheckedEnumObject e) = printEnum e
-- |Checks all the objects from a list -- |Checks all the objects from a list
checkObjects :: [(([Type], [Symbol]), (Header, [RosettaObject]))] -> [(Header, [Either [TypeCheckError] RosettaObject])] checkObjects :: [(([Type], [Symbol]), (Header, [RosettaObject]))] -> [(Header, [Either [TypeCheckError] CheckedRosettaObject])]
checkObjects [] = [] checkObjects [] = []
checkObjects (((definedTypes, definedSymbols), (header, objs)) : rest) = (header, checked) : checkObjects rest checkObjects (((definedTypes, definedSymbols), (header, objs)) : rest) = (header, checked) : checkObjects rest
where where
checked = map (checkObject (definedTypes, definedSymbols)) objs checked = map (checkObject (definedTypes, definedSymbols)) objs
-- |Checks the RosettaObject for type errors -- |Checks the RosettaObject for type errors
checkObject :: ([Type], [Symbol]) -> RosettaObject -> Either [TypeCheckError] RosettaObject checkObject :: ([Type], [Symbol]) -> RosettaObject -> Either [TypeCheckError] CheckedRosettaObject
-- |Checks the type and attributes of a type -- |Checks the type and attributes of a type
checkObject (definedTypes, _) (TypeObject t) = checkObject (definedTypes, _) (TypeObject t) =
case checkType definedTypes t of case checkType definedTypes t of
Left errors -> Left errors Left errors -> Left errors
Right typ -> Right $ TypeObject typ Right typ -> Right $ CheckedTypeObject typ
-- |If an enum parses, it cannot throw an error -- |If an enum parses, it cannot throw an error
checkObject _ (EnumObject e) = Right (EnumObject e) checkObject _ (EnumObject e) = Right $ CheckedEnumObject e
-- |Checks the function inputs, output and assignment -- |Checks the function inputs, output and assignment
checkObject (definedTypes, definedFunctions) (FunctionObject fun) = checkObject (definedTypes, definedFunctions) (FunctionObject fun) =
case checkFunction (definedTypes, defaultMap ++ definedFunctions) fun of case checkFunction (definedTypes, defaultMap ++ definedFunctions) fun of
Left errors -> Left errors Left errors -> Left errors
Right func -> Right $ FunctionObject func Right func -> Right $ CheckedFunctionObject func
-- |Adds new defined functions into the symbol table -- |Adds new defined functions into the symbol table
addNewFunctions :: ([Type], [Symbol]) -> [RosettaObject] -> Either [TypeCheckError] [Symbol] addNewFunctions :: ([Type], [Symbol]) -> [RosettaObject] -> Either [TypeCheckError] [Symbol]
@@ -140,5 +141,5 @@ parseFunction = do
FunctionObject <$> functionParser FunctionObject <$> functionParser
-- |Generate a new haskell file based on the rosetta objects and header -- |Generate a new haskell file based on the rosetta objects and header
generateFile :: (Header, [RosettaObject]) -> IO () generateFile :: (Header, [CheckedRosettaObject]) -> IO ()
generateFile (header, objects) = writeFile (haskellFileName $ namespace header) (printHeader header ++ concatMap printObject objects) generateFile (header, objects) = writeFile (haskellFileName $ namespace header) (printHeader header ++ concatMap printRosettaObject objects)

3
src/Model/Function.hs
View File

@@ -23,4 +23,5 @@ data ExplicitFunction =
MakeExplicitFunction { MakeExplicitFunction {
sign :: FunctionSignature, sign :: FunctionSignature,
explicitAssignment :: ExplicitExpression explicitAssignment :: ExplicitExpression
} }
deriving Show

6
src/Model/RosettaObject.hs
View File

@@ -9,4 +9,10 @@ data RosettaObject =
EnumObject EnumType EnumObject EnumType
| TypeObject Type | TypeObject Type
| FunctionObject Function | FunctionObject Function
deriving Show
data CheckedRosettaObject =
CheckedEnumObject EnumType
| CheckedTypeObject Type
| CheckedFunctionObject ExplicitFunction
deriving Show deriving Show

15
src/Model/Type.hs
View File

@@ -45,12 +45,12 @@ data Expression = Variable String
data ExplicitExpression = ExplicitEmpty data ExplicitExpression = ExplicitEmpty
| ExplicitVariable {name :: String, returnCoercion :: Coercion} | ExplicitVariable {name :: String, returnCoercion :: Coercion}
| Value {returnCoercion :: Coercion} | Value {name :: String, returnCoercion :: Coercion}
| ExplicitList [ExplicitExpression] | ExplicitList [ExplicitExpression]
| ExplicitParens ExplicitExpression | ExplicitParens ExplicitExpression
| ExplicitFunction {name :: String, args :: [Coercion], returnCoercion :: Coercion} | ExplicitFunction {name :: String, args :: [(ExplicitExpression, Coercion)], returnCoercion :: Coercion}
| ExplicitIfSimple {cond :: Coercion, returnCoercion :: Coercion} | ExplicitIfSimple {cond :: (ExplicitExpression, Coercion), block1 :: (ExplicitExpression, Coercion), returnCoercion :: Coercion}
| ExplicitIfEsle {cond :: Coercion, args :: [Coercion], returnCoercion :: Coercion} | ExplicitIfElse {cond :: (ExplicitExpression, Coercion), block1 :: (ExplicitExpression, Coercion), block2 :: (ExplicitExpression, Coercion), returnCoercion :: Coercion}
deriving (Show) deriving (Show)
data TypeCoercion = data TypeCoercion =
@@ -61,7 +61,12 @@ data TypeCoercion =
data CardinalityCoercion = data CardinalityCoercion =
MakeCardinalityIdCoercion {toCardinality :: Cardinality} MakeCardinalityIdCoercion {toCardinality :: Cardinality}
| MakeCardinalityCoercion {fromCardinality :: Cardinality, toCardinality :: Cardinality, transformCardinality :: String} | MakeListCardinalityCoercion {fromCardinality :: Cardinality, toCardinality :: Cardinality}
| MakeNothing2MaybeCoercion {fromCardinality :: Cardinality, toCardinality :: Cardinality}
| MakeNothing2ListCoercion {fromCardinality :: Cardinality, toCardinality :: Cardinality}
| MakeMaybe2ListCoercion {fromCardinality :: Cardinality, toCardinality :: Cardinality}
| MakeObject2MaybeCoercion {fromCardinality :: Cardinality, toCardinality :: Cardinality}
| MakeObject2ListCoercion {fromCardinality :: Cardinality, toCardinality :: Cardinality}
deriving (Show) deriving (Show)
-- |Used to handle polymorphism in Rosetta -- |Used to handle polymorphism in Rosetta

87
src/PrettyPrinter/Function.hs
View File

@@ -11,60 +11,63 @@ import Model.Type
-- show printStatementTree -- show printStatementTree
-- |Converts a Function into a haskell valid String -- |Converts a Function into a haskell valid String
printFunction :: Function -> String printFunction :: ExplicitFunction -> String
printFunction f = show $ vcat [printFunctionSignature f, printFunctionBody f, emptyDoc] printFunction f = show $ vcat [printFunctionSignature (sign f), printFunctionBody f, emptyDoc]
-- |Converts the body of a Function into a haskell valid Doc -- |Converts the body of a Function into a haskell valid Doc
printFunctionBody :: Function -> Doc a printFunctionBody :: ExplicitFunction -> Doc a
printFunctionBody (MakeFunction name _ inp out ex) = pretty name <+> printVariableNames inp <+> "=" <+> printExpression inp (cardinality out) ex printFunctionBody (MakeExplicitFunction (MakeFunctionSignature name _ inp out) ex) = pretty name <+> printVariableNames inp <+> "=" <+> printExpression ex
printExpression :: [TypeAttribute] -> Cardinality -> Expression -> Doc a printExpression :: ExplicitExpression -> Doc a
printExpression inps c (Variable s) = printVariable varC c s printExpression ExplicitEmpty = "[]"
where printExpression (ExplicitVariable name coer) = printCoercion coer $ pretty name
varC = getVarCardinality inps s printExpression (Value s coer) = printCoercion coer $ pretty s
printExpression inps c (Int s) = printVariable (Bounds (1, 1)) c s printExpression (ExplicitParens ex) = "(" <> printExpression ex <> ")"
printExpression inps c (Real s) = printVariable (Bounds (1, 1)) c s printExpression (ExplicitList ex) = list (map printExpression ex)
printExpression inps c (Boolean s) = printVariable (Bounds (1, 1)) c s printExpression (ExplicitFunction "exists" args returnCoerce) = printCoercion returnCoerce "isJust" <+> printCoercion (snd $ head args) (printExpression $ fst $ head args)
printExpression inps c Empty = "empty" printExpression (ExplicitFunction "is absent" args returnCoerce) = printCoercion returnCoerce "isNothing" <+> printCoercion (snd $ head args) (printExpression $ fst $ head args)
printExpression inps c (Parens ex) = "(" <> printExpression inps c ex <> ")" printExpression (ExplicitFunction "single exists" args returnCoerce) = printCoercion returnCoerce "length" <+> printCoercion (snd $ head args) (printExpression $ fst $ head args) <+> "==" <+> "1"
printExpression inps c (List ex) = list (map (printExpression inps c) ex) printExpression (ExplicitFunction "multiple exists" args returnCoerce) = printCoercion returnCoerce "length" <+> printCoercion (snd $ head args) (printExpression $ fst $ head args) <+> ">" <+> "1"
printExpression inps c (Function name ex) = pretty name <> tupled (map (printExpression inps c) ex) printExpression (ExplicitFunction "count" args returnCoerce) = printCoercion returnCoerce "length" <+> printCoercion (snd $ head args) (printExpression $ fst $ head args)
printExpression inps c (PrefixExp name ex) = pretty name <+> printExpression inps c ex
printExpression inps c (PostfixExp "exists" ex) = "isJust" <+> printExpression inps c ex
printExpression inps c (PostfixExp "is absent" ex) = "isNothing" <+> printExpression inps c ex
printExpression inps c (PostfixExp "single exists" ex) = "length" <+> printExpression inps c ex <+> "==" <+> "1"
printExpression inps c (PostfixExp "multiple exists" ex) = "length" <+> printExpression inps c ex <+> ">" <+> "1"
printExpression inps c (PostfixExp "count" ex) = "length" <+> printExpression inps c ex
printExpression inps c (PostfixExp name ex) = pretty name <+> printExpression inps c ex
-- Equality expressions -- Equality expressions
-- [a] a all = -- [a] a all =
-- any <> -- any <>
printExpression inps c (InfixExp "=" ex1 ex2) = printExpression inps c ex1 <+> "==" <+> printExpression inps c ex2 printExpression (ExplicitFunction "=" args returnCoerce) = printCoercion (snd $ head args) (printExpression $ fst $ head args) <+> "==" <+> printCoercion (snd $ head $ tail args) (printExpression $ fst $ head $ tail args)
printExpression inps c (InfixExp "<>" ex1 ex2) = printExpression inps c ex1 <+> "/=" <+> printExpression inps c ex2 printExpression (ExplicitFunction "<>" args returnCoerce) = printCoercion (snd $ head args) (printExpression $ fst $ head args) <+> "/=" <+> printCoercion (snd $ head $ tail args) (printExpression $ fst $ head $ tail args)
printExpression inps c (InfixExp "any =" ex1 ex2) = printExpression inps c ex2 <+> "`elem`" <+> printExpression inps c ex1 printExpression (ExplicitFunction "any =" args returnCoerce) = printCoercion (snd $ head $ tail args) (printExpression $ fst $ head $ tail args)<+> "`elem`" <+> printCoercion (snd $ head args) (printExpression $ fst $ head args)
printExpression inps c (InfixExp "all <>" ex1 ex2) = printExpression inps c ex2 <+> "`notElem`" <+> printExpression inps c ex1 printExpression (ExplicitFunction "all <>" args returnCoerce) = printCoercion (snd $ head $ tail args) (printExpression $ fst $ head $ tail args)<+> "`notElem`" <+> printCoercion (snd $ head args) (printExpression $ fst $ head args)
--printExpression (InfixExp "all =" ex1 ex2) = "all (Eq)" <+> printExpression ex2 <+> printExpression ex1 printExpression (ExplicitFunction "all =" args returnCoerce) = "all (Eq)" <+> printCoercion (snd $ head $ tail args) (printExpression $ fst $ head $ tail args) <+> printCoercion (snd $ head args) (printExpression $ fst $ head args)
printExpression inps c (InfixExp "and" ex1 ex2) = printExpression inps c ex1 <+> "&&" <+> printExpression inps c ex2 printExpression (ExplicitFunction "and" args returnCoerce) = printCoercion (snd $ head args) (printExpression $ fst $ head args) <+> "&&" <+> printCoercion (snd $ head $ tail args) (printExpression $ fst $ head $ tail args)
printExpression inps c (InfixExp "or" ex1 ex2) = printExpression inps c ex1 <+> "||" <+> printExpression inps c ex2 printExpression (ExplicitFunction "or" args returnCoerce) = printCoercion (snd $ head args) (printExpression $ fst $ head args) <+> "||" <+> printCoercion (snd $ head $ tail args) (printExpression $ fst $ head $ tail args)
printExpression inps c (InfixExp name ex1 ex2) = printExpression inps c ex1 <+> pretty name <+> printExpression inps c ex2 printExpression (ExplicitFunction name args returnCoerce) = pretty name <+> tupled (zipWith printCoercion [c | (e,c) <- args] [printExpression e | (e, c) <- args])
printExpression inps (Bounds (0, 1)) (IfSimple cond ex) = "if" <+> printExpression inps (Bounds (1, 1)) cond <+> "then" <+> printExpression inps (Bounds (0, 1)) ex <+> "else" <+> "Nothing" printExpression (ExplicitIfSimple cond thenBlock returnCoercion) = "if" <+> printCoercion (snd cond) (printExpression $ fst cond) <+> "then" <+> printCoercion (snd thenBlock) (printExpression $ fst thenBlock) <+> "else" <+> "Nothing"
printExpression inps c (IfSimple cond ex) = "if" <+> printExpression inps (Bounds (1, 1)) cond <+> "then" <+> printExpression inps c ex <+> "else" <+> "[]" printExpression (ExplicitIfElse cond thenBlock elseBlock returnCoercion) = "if" <+> printCoercion (snd cond) (printExpression $ fst cond) <+> "then" <+> printCoercion (snd thenBlock) (printExpression $ fst thenBlock) <+> "else" <+> printCoercion (snd elseBlock) (printExpression $ fst elseBlock)
printExpression inps c (IfElse cond ex1 ex2) = "if" <+> printExpression inps (Bounds (1, 1)) cond <+> "then" <+> printExpression inps c ex1 <+> "else" <+> printExpression inps c ex2
-- |Converts a variable into a maybe or list depending on necessity -- |Converts a coercion into a haskell string
printVariable :: Cardinality -> Cardinality -> String -> Doc a printCoercion :: Coercion -> Doc a -> Doc a
printVariable (Bounds (1, 1)) (Bounds (1, 1)) s = pretty s printCoercion (MakeCoercion [] crd) d = printCardinalityCoercion crd d
printVariable (Bounds (1, 1)) (Bounds (0, 1)) s = "Just" <+> pretty s printCoercion (MakeCoercion (t: ts) crd) d = printTypeCoercion t <+> printCoercion (MakeCoercion ts crd) d
printVariable (Bounds (0, 1)) (Bounds (0, 1)) s = pretty s
printVariable (Bounds (1, 1)) _ s = "[" <+> pretty s <+> "]" printCardinalityCoercion :: CardinalityCoercion -> Doc a -> Doc a
printVariable _ _ s = pretty s printCardinalityCoercion (MakeCardinalityIdCoercion _) d = d
printCardinalityCoercion (MakeListCardinalityCoercion _ _) d = d
printCardinalityCoercion (MakeNothing2MaybeCoercion _ _) d = "Nothing"
printCardinalityCoercion (MakeNothing2ListCoercion _ _) d = "[]"
printCardinalityCoercion (MakeMaybe2ListCoercion _ _) d = "maybeToList" <+> d
printCardinalityCoercion (MakeObject2MaybeCoercion _ _) d = "Just" <+> d
printCardinalityCoercion (MakeObject2ListCoercion _ _) d = "[" <> d <> "]"
printTypeCoercion :: TypeCoercion -> Doc a
printTypeCoercion (MakeIdCoercion _) = emptyDoc
printTypeCoercion (MakeSuperCoercion _ _) = "super"
printTypeCoercion (MakeTypeCoercion _ _ t) = pretty t
-- |Converts a list of type attributes to a Doc with a list of variable names -- |Converts a list of type attributes to a Doc with a list of variable names
printVariableNames :: [TypeAttribute] -> Doc a printVariableNames :: [TypeAttribute] -> Doc a
printVariableNames vars = foldl (<+>) emptyDoc (map (pretty . attributeName) vars) printVariableNames vars = foldl (<+>) emptyDoc (map (pretty . attributeName) vars)
-- |Converts a function into a haskell valid Doc representing the signature of the function -- |Converts a function into a haskell valid Doc representing the signature of the function
printFunctionSignature :: Function -> Doc a printFunctionSignature :: FunctionSignature -> Doc a
printFunctionSignature (MakeFunction name description inputs output _) = printFunctionSignature (MakeFunctionSignature name description inputs output) =
printDescription description (pretty name <+> prettyPrintType (Prelude.map printCardinality (inputs ++ [output]))) printDescription description (pretty name <+> prettyPrintType (Prelude.map printCardinality (inputs ++ [output])))
-- |Zips the signature with the needed characters ('::', '->') -- |Zips the signature with the needed characters ('::', '->')

8
src/PrettyPrinter/RosettaObject.hs
View File

@@ -6,7 +6,7 @@ import PrettyPrinter.Function
import PrettyPrinter.Type import PrettyPrinter.Type
-- |Converts a supported Rosetta object into a haskell valid String -- |Converts a supported Rosetta object into a haskell valid String
printRosettaObject :: RosettaObject -> String printRosettaObject :: CheckedRosettaObject -> String
printRosettaObject (EnumObject a) = printEnum a printRosettaObject (CheckedEnumObject a) = printEnum a
printRosettaObject (TypeObject a) = printType a printRosettaObject (CheckedTypeObject a) = printType a
printRosettaObject (FunctionObject a) = printFunction a printRosettaObject (CheckedFunctionObject a) = printFunction a

72
src/Semantic/ExpressionChecker.hs
View File

@@ -6,6 +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{
@@ -87,10 +88,10 @@ addVariables s ((MakeTypeAttribute name typ crd _) : vars) = Var name (toHaskel
-- |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 symbolMap (Variable var) = findVarType var symbolMap
checkExpression _ (Int _) = Right $ Value $ MakeCoercion [MakeIdCoercion (BasicType "Integer")] (MakeCardinalityIdCoercion (Bounds (1, 1))) checkExpression _ (Int val) = Right $ Value val $ MakeCoercion [MakeIdCoercion (BasicType "Integer")] (MakeCardinalityIdCoercion (Bounds (1, 1)))
checkExpression _ (Real _) = Right $ Value $ MakeCoercion [MakeIdCoercion (BasicType "Double")] (MakeCardinalityIdCoercion (Bounds (1, 1))) checkExpression _ (Real val) = Right $ Value val $ MakeCoercion [MakeIdCoercion (BasicType "Double")] (MakeCardinalityIdCoercion (Bounds (1, 1)))
checkExpression _ (Boolean _) = Right $ Value $ 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 $ 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 (Parens ex) =
case checkExpression symbolMap ex of case checkExpression symbolMap ex of
Left err -> Left err Left err -> Left err
@@ -104,34 +105,34 @@ checkExpression symbolMap (InfixExp name ex1 ex2) = checkFunctionCall symbolMap
checkExpression symbolMap (IfSimple cond ex) = checkExpression symbolMap (IfSimple cond ex) =
case checkExpression symbolMap cond of case checkExpression symbolMap cond of
Left err -> Left $ IfConditionNotBoolean $ show err Left err -> Left $ IfConditionNotBoolean $ show err
Right condType -> case coercionType conditionPreCoercion `isSubType` BasicType "Boolean" of Right condType -> case returnCoercion condType `coercionIncluded` MakeCoercion [MakeIdCoercion (BasicType "Boolean")] (MakeCardinalityIdCoercion (Bounds (1, 1))) of
Left err -> Left $ IfConditionNotBoolean $ show cond ++ " :: " ++ show (coercionType conditionPreCoercion) 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 thenCoerce -> Right thenExp ->
Right $ ExplicitIfSimple Right $ ExplicitIfSimple (condType, condCoerce)
(MakeCoercion (condCoerce ++ conditionPreCoercion) (cardinalityCoercion $ returnCoercion condType)) (returnCoercion thenCoerce) (thenExp, MakeCoercion [MakeIdCoercion $ coercionType $ typeCoercion $ returnCoercion thenExp]
where (MakeCardinalityIdCoercion $ toCardinality $ cardinalityCoercion $ returnCoercion thenExp)) (returnCoercion thenExp)
conditionPreCoercion = typeCoercion $ returnCoercion condType
-- |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
checkExpression symbolMap (IfElse cond ex1 ex2) = checkExpression symbolMap (IfElse cond ex1 ex2) =
case checkExpression symbolMap cond of case checkExpression symbolMap cond of
Left err -> Left $ IfConditionNotBoolean $ show err Left err -> Left $ IfConditionNotBoolean $ show err
Right condType -> Right condType -> case returnCoercion condType `coercionIncluded` MakeCoercion [MakeIdCoercion (BasicType "Boolean")] (MakeCardinalityIdCoercion (Bounds (1, 1))) of
case coercionType conditionPreCoercion `isSubType` BasicType "Boolean" of Left err -> Left $ IfConditionNotBoolean $ show cond ++ " :: " ++ show (coercionType $ typeCoercion $ returnCoercion condType)
Left err -> Left $ IfConditionNotBoolean $ show cond ++ " :: " ++ show (coercionType conditionPreCoercion) Right condCoerce ->
Right condCoerce -> case checkExpression symbolMap ex1 of
case checkExpression symbolMap ex1 of Left err -> Left $ ErrorInsideFunction $ show err
Right thenExp -> case checkExpression symbolMap ex2 of
Left err -> Left $ ErrorInsideFunction $ show err Left err -> Left $ ErrorInsideFunction $ show err
Right ex1Checked -> case checkExpression symbolMap ex2 of Right elseExp ->
Left err -> Left $ ErrorInsideFunction $ show err Right $ ExplicitIfElse (condType, condCoerce)
Right ex2Checked -> Right $ ExplicitIfEsle (thenExp, MakeCoercion [MakeIdCoercion $ coercionType $ typeCoercion $ returnCoercion thenExp]
(MakeCoercion (condCoerce ++ conditionPreCoercion) (cardinalityCoercion $ returnCoercion condType)) (MakeCardinalityIdCoercion $ toCardinality $ cardinalityCoercion $ returnCoercion thenExp))
(returnCoercion ex1Checked : [returnCoercion ex2Checked]) (returnCoercion ex1Checked) (elseExp, MakeCoercion [MakeIdCoercion $ coercionType $ typeCoercion $ returnCoercion elseExp]
--(typeMatch ex1Type ex2Type, smallestBound ex1Card ex2Type) (MakeCardinalityIdCoercion $ toCardinality $ cardinalityCoercion $ returnCoercion elseExp)) (returnCoercion thenExp)
where --(typeMatch ex1Type ex2Type, smallestBound ex1Card ex2Type)
conditionPreCoercion = typeCoercion $ returnCoercion condType
-- |TODO Handle nested lists and lists with parens -- |TODO Handle nested lists and lists with parens
@@ -168,7 +169,7 @@ checkFunctionCall :: [Symbol] -> String -> [Either TypeCheckError ExplicitExpres
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 (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)
@@ -227,19 +228,24 @@ isSubType x y
-- |Checks whether the first cardinality is included into the second one -- |Checks whether the first cardinality is included into the second one
cardinalityIncluded :: Cardinality -> Cardinality -> Either TypeCheckError CardinalityCoercion cardinalityIncluded :: Cardinality -> Cardinality -> Either TypeCheckError CardinalityCoercion
-- |Special Cases -- |Special Cases
cardinalityIncluded (Bounds (0, 0)) (Bounds (0, 1)) = Right $ MakeCardinalityCoercion (Bounds (0, 0)) (Bounds (0, 1)) "Nothing" -- |Transform nothing into a maybe
cardinalityIncluded (Bounds (0, 0)) (OneBound 0) = Right $ MakeCardinalityCoercion (Bounds (0, 0)) (OneBound 0) "[]" cardinalityIncluded (Bounds (0, 0)) (Bounds (0, 1)) = Right $ MakeNothing2MaybeCoercion (Bounds (0, 0)) (Bounds (0, 1))
cardinalityIncluded (Bounds (0, 1)) (OneBound 0) = Right $ MakeCardinalityCoercion (Bounds (0, 1)) (OneBound 0) "[Just]" -- |Transform nothing into a list
cardinalityIncluded (Bounds (1, 1)) (Bounds (0, 1)) = Right $ MakeCardinalityCoercion (Bounds (0, 1)) (Bounds (0, 1)) "Just" cardinalityIncluded (Bounds (0, 0)) (OneBound 0) = Right $ MakeNothing2ListCoercion (Bounds (0, 0)) (OneBound 0)
cardinalityIncluded (Bounds (1, 1)) (OneBound 1) = Right $ MakeCardinalityCoercion (Bounds (0, 1)) (OneBound 1) "[]" -- |Transform maybe into list
cardinalityIncluded (Bounds (0, 1)) (OneBound 0) = Right $ MakeMaybe2ListCoercion (Bounds (0, 1)) (OneBound 0)
-- |Transform object into maybe
cardinalityIncluded (Bounds (1, 1)) (Bounds (0, 1)) = Right $ MakeObject2MaybeCoercion (Bounds (0, 1)) (Bounds (0, 1))
-- |Transform object into list
cardinalityIncluded (Bounds (1, 1)) (OneBound 1) = Right $ MakeObject2ListCoercion (Bounds (0, 1)) (OneBound 1)
-- |General -- |General
cardinalityIncluded (OneBound x) (OneBound y) cardinalityIncluded (OneBound x) (OneBound y)
| x >= y = Right $ MakeCardinalityCoercion (OneBound x) (OneBound y) "id" | x >= y = Right $ MakeListCardinalityCoercion (OneBound x) (OneBound y)
| otherwise = Left $ CardinalityMismatch (OneBound x) (OneBound y) | otherwise = Left $ CardinalityMismatch (OneBound x) (OneBound y)
cardinalityIncluded (Bounds (x1, y1)) (OneBound y) cardinalityIncluded (Bounds (x1, y1)) (OneBound y)
| x1 >= y = Right $ MakeCardinalityCoercion (Bounds (x1, y1)) (OneBound y) "id" | x1 >= y = Right $ MakeListCardinalityCoercion (Bounds (x1, y1)) (OneBound y)
| otherwise = Left $ CardinalityMismatch (Bounds (x1, y1)) (OneBound y) | otherwise = Left $ CardinalityMismatch (Bounds (x1, y1)) (OneBound y)
cardinalityIncluded (OneBound x) (Bounds (x2, y2)) = Left $ CardinalityMismatch (OneBound x) (Bounds (x2, y2)) cardinalityIncluded (OneBound x) (Bounds (x2, y2)) = Left $ CardinalityMismatch (OneBound x) (Bounds (x2, y2))
cardinalityIncluded (Bounds (x1, x2)) (Bounds (y1, y2)) cardinalityIncluded (Bounds (x1, x2)) (Bounds (y1, y2))
| x1 >= y1 && x2 <= y2 = Right $ MakeCardinalityCoercion (Bounds (x1, x2)) (Bounds (y1, y2)) "id" | x1 >= y1 && x2 <= y2 = Right $ MakeListCardinalityCoercion (Bounds (x1, x2)) (Bounds (y1, y2))
| otherwise = Left $ CardinalityMismatch (Bounds (x1, x2)) (Bounds (y1, y2)) | otherwise = Left $ CardinalityMismatch (Bounds (x1, x2)) (Bounds (y1, y2))