mirror of
https://github.com/macocianradu/RosettaHaskellCompiler.git
synced 2026-03-18 21:10:07 +00:00
fixed cardinality of is statements
This commit is contained in:
1
.gitignore
vendored
1
.gitignore
vendored
@@ -23,3 +23,4 @@ cabal.project.local~
|
|||||||
.ghc.environment.*
|
.ghc.environment.*
|
||||||
.idea/
|
.idea/
|
||||||
/resources/Generated/
|
/resources/Generated/
|
||||||
|
.vscode/
|
||||||
|
|||||||
@@ -27,12 +27,14 @@ library
|
|||||||
exposed-modules:
|
exposed-modules:
|
||||||
Model.Enum
|
Model.Enum
|
||||||
Model.Function
|
Model.Function
|
||||||
|
Model.Header
|
||||||
Model.RosettaObject
|
Model.RosettaObject
|
||||||
Model.Type
|
Model.Type
|
||||||
Parser.Enum
|
Parser.Enum
|
||||||
Parser.Expression
|
Parser.Expression
|
||||||
Parser.Function
|
Parser.Function
|
||||||
Parser.General
|
Parser.General
|
||||||
|
Parser.Header
|
||||||
Parser.Type
|
Parser.Type
|
||||||
PrettyPrinter.Enum
|
PrettyPrinter.Enum
|
||||||
PrettyPrinter.Function
|
PrettyPrinter.Function
|
||||||
@@ -76,6 +78,7 @@ test-suite RosettaParser-test
|
|||||||
type: exitcode-stdio-1.0
|
type: exitcode-stdio-1.0
|
||||||
main-is: Spec.hs
|
main-is: Spec.hs
|
||||||
other-modules:
|
other-modules:
|
||||||
|
Model.TypeSpec
|
||||||
Parser.EnumSpec
|
Parser.EnumSpec
|
||||||
Parser.ExpressionSpec
|
Parser.ExpressionSpec
|
||||||
Parser.TypeSpec
|
Parser.TypeSpec
|
||||||
|
|||||||
@@ -1,13 +0,0 @@
|
|||||||
{-The enumerated values to specified the period, e.g. day, week.-}
|
|
||||||
data PeriodEnum =
|
|
||||||
{-Day-}
|
|
||||||
D
|
|
||||||
{-Month-}
|
|
||||||
| M
|
|
||||||
{-Year-}
|
|
||||||
| Y
|
|
||||||
|
|
||||||
instance Show PeriodEnum where
|
|
||||||
show D = "day"
|
|
||||||
show M = "month"
|
|
||||||
show Y = "year"
|
|
||||||
@@ -1,13 +0,0 @@
|
|||||||
{-The enumerated values to specified the period, e.g. day, week.-}
|
|
||||||
data EnumWithoutDisplay =
|
|
||||||
{-Day-}
|
|
||||||
D
|
|
||||||
{-Month-}
|
|
||||||
| M
|
|
||||||
{-Year-}
|
|
||||||
| Y
|
|
||||||
|
|
||||||
instance Show EnumWithoutDisplay where
|
|
||||||
show D = "D"
|
|
||||||
show M = "M"
|
|
||||||
show Y = "Y"
|
|
||||||
@@ -1,7 +0,0 @@
|
|||||||
data EnumWithoutDescription =
|
|
||||||
X
|
|
||||||
| Y
|
|
||||||
|
|
||||||
instance Show EnumWithoutDescription where
|
|
||||||
show X = "xs"
|
|
||||||
show Y = "ys"
|
|
||||||
@@ -41,3 +41,11 @@ func Something: <"asd">
|
|||||||
valuation ObservationPrimitive (0..*)
|
valuation ObservationPrimitive (0..*)
|
||||||
|
|
||||||
assign-output: if True and False then valuationTime
|
assign-output: if True and False then valuationTime
|
||||||
|
|
||||||
|
func SomethingElse: <"dsa">
|
||||||
|
inputs:
|
||||||
|
valuationTime ObservationPrimitive (1..1)
|
||||||
|
output:
|
||||||
|
valuation ObservationPrimitive (0..1)
|
||||||
|
|
||||||
|
assign-output: if True and False then valuationTime
|
||||||
9
src/Model/Header.hs
Normal file
9
src/Model/Header.hs
Normal file
@@ -0,0 +1,9 @@
|
|||||||
|
module Model.Header where
|
||||||
|
|
||||||
|
-- |Representation of the information stored in the file header
|
||||||
|
data Header = MakeHeader {
|
||||||
|
namespace :: String,
|
||||||
|
headerDescription :: Maybe String,
|
||||||
|
version :: String,
|
||||||
|
imports :: [String]
|
||||||
|
} deriving (Show, Eq)
|
||||||
@@ -50,6 +50,15 @@ instance Eq Cardinality where
|
|||||||
(==) NoBounds NoBounds = True
|
(==) NoBounds NoBounds = True
|
||||||
(==) _ _ = False
|
(==) _ _ = False
|
||||||
|
|
||||||
|
-- |Function to create the smallest cardinality that includes two others
|
||||||
|
smallestBound :: Cardinality -> Cardinality -> Cardinality
|
||||||
|
smallestBound NoBounds _ = NoBounds
|
||||||
|
smallestBound _ NoBounds = NoBounds
|
||||||
|
smallestBound (OneBound x) (OneBound y) = OneBound $ min x y
|
||||||
|
smallestBound (OneBound x) (Bounds (y, _)) = smallestBound (OneBound x) (OneBound y)
|
||||||
|
smallestBound (Bounds (x, _)) (OneBound y) = smallestBound (OneBound x) (OneBound y)
|
||||||
|
smallestBound (Bounds (x1, x2)) (Bounds (y1, y2)) = Bounds (min x1 y1, max x2 y2)
|
||||||
|
|
||||||
-- |A function used to add two cardinalities
|
-- |A function used to add two cardinalities
|
||||||
addBounds :: Cardinality -> Cardinality -> Cardinality
|
addBounds :: Cardinality -> Cardinality -> Cardinality
|
||||||
addBounds (Bounds (x1, x2)) (Bounds (y1, y2)) = Bounds (x1 + y1, x2 + y2)
|
addBounds (Bounds (x1, x2)) (Bounds (y1, y2)) = Bounds (x1 + y1, x2 + y2)
|
||||||
@@ -69,3 +78,28 @@ infixl 5 .+
|
|||||||
|
|
||||||
typeAndCardinality :: TypeAttribute -> (Type, Cardinality)
|
typeAndCardinality :: TypeAttribute -> (Type, Cardinality)
|
||||||
typeAndCardinality (MakeTypeAttribute _ typ crd _) = (typ, crd)
|
typeAndCardinality (MakeTypeAttribute _ typ crd _) = (typ, crd)
|
||||||
|
|
||||||
|
|
||||||
|
-- |Checks whether the first argument is a subtype of the second argument
|
||||||
|
isSubType :: Type -> Type -> Bool
|
||||||
|
isSubType (BasicType "Integer") (BasicType "Double") = True
|
||||||
|
isSubType _ (BasicType "Any") = True
|
||||||
|
isSubType _ (BasicType "Object") = False
|
||||||
|
isSubType x y
|
||||||
|
| x == y = True
|
||||||
|
| otherwise = isSubType (superType x) y
|
||||||
|
|
||||||
|
-- |Checks whether the first cardinality is included into the second one
|
||||||
|
cardinalityIncluded :: Cardinality -> Cardinality -> Bool
|
||||||
|
cardinalityIncluded _ NoBounds = True
|
||||||
|
cardinalityIncluded NoBounds _ = False
|
||||||
|
cardinalityIncluded (OneBound x) (OneBound y)
|
||||||
|
| x >= y = True
|
||||||
|
| otherwise = False
|
||||||
|
cardinalityIncluded (Bounds (x1, _)) (OneBound y)
|
||||||
|
| x1 >= y = True
|
||||||
|
| otherwise = False
|
||||||
|
cardinalityIncluded (OneBound _) (Bounds (_, _)) = False
|
||||||
|
cardinalityIncluded (Bounds (x1, x2)) (Bounds (y1, y2))
|
||||||
|
| x1 >= y1 && x2 <= y2 = True
|
||||||
|
| otherwise = False
|
||||||
@@ -57,6 +57,9 @@ allowedChars = letterChar <|> digitChar <|> char '_'
|
|||||||
-- |List of restricted names used by Rosetta
|
-- |List of restricted names used by Rosetta
|
||||||
restrictedNames :: [String]
|
restrictedNames :: [String]
|
||||||
restrictedNames = [
|
restrictedNames = [
|
||||||
|
"if",
|
||||||
|
"then",
|
||||||
|
"else",
|
||||||
"displayName",
|
"displayName",
|
||||||
"enum",
|
"enum",
|
||||||
"func",
|
"func",
|
||||||
|
|||||||
27
src/Parser/Header.hs
Normal file
27
src/Parser/Header.hs
Normal file
@@ -0,0 +1,27 @@
|
|||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
|
module Parser.Header where
|
||||||
|
|
||||||
|
import Model.Header
|
||||||
|
import Parser.General
|
||||||
|
import Text.Megaparsec
|
||||||
|
import Text.Megaparsec.Char
|
||||||
|
import Text.ParserCombinators.ReadP (many1)
|
||||||
|
|
||||||
|
headerParser :: Parser Header
|
||||||
|
headerParser = do
|
||||||
|
_ <- lexeme $ string "namespace"
|
||||||
|
name <- namespaceParser
|
||||||
|
desc <- optional descriptionParser
|
||||||
|
_ <- lexeme $ string "version"
|
||||||
|
vers <- between (char '\"') (char '\"') (many (letterChar <|> char '.' <|> char '$' <|> digitChar))
|
||||||
|
imports <- many importParser
|
||||||
|
return $ MakeHeader name desc vers imports
|
||||||
|
|
||||||
|
importParser :: Parser String
|
||||||
|
importParser = do
|
||||||
|
_ <- lexeme $ string "import"
|
||||||
|
namespaceParser
|
||||||
|
|
||||||
|
namespaceParser :: Parser String
|
||||||
|
namespaceParser = many (letterChar <|> digitChar <|> char '.' <|> char '*')
|
||||||
@@ -16,36 +16,47 @@ printFunction f = show $ vcat [printFunctionSignature f, printFunctionBody f, em
|
|||||||
|
|
||||||
-- |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 :: Function -> Doc a
|
||||||
printFunctionBody (MakeFunction name _ inp _ ex) = pretty name <+> printVariableNames inp <+> "=" <+> printExpression ex
|
printFunctionBody (MakeFunction name _ inp out ex) = pretty name <+> printVariableNames inp <+> "=" <+> printExpression inp (cardinality out) ex
|
||||||
printExpression :: Expression -> Doc a
|
printExpression :: [TypeAttribute] -> Cardinality -> Expression -> Doc a
|
||||||
printExpression (Variable s) = pretty s
|
printExpression inps c (Variable s) = printVariable varC c s
|
||||||
printExpression (Int s) = pretty s
|
where
|
||||||
printExpression (Real s) = pretty s
|
varC = getVarCardinality inps s
|
||||||
printExpression (Boolean s) = pretty s
|
printExpression inps c (Int s) = printVariable (Bounds (1, 1)) c s
|
||||||
printExpression Empty = "empty"
|
printExpression inps c (Real s) = printVariable (Bounds (1, 1)) c s
|
||||||
printExpression (Parens ex) = "(" <> printExpression ex <> ")"
|
printExpression inps c (Boolean s) = printVariable (Bounds (1, 1)) c s
|
||||||
printExpression (List ex) = list (map printExpression ex)
|
printExpression inps c Empty = "empty"
|
||||||
printExpression (Function name ex) = pretty name <> tupled (map printExpression ex)
|
printExpression inps c (Parens ex) = "(" <> printExpression inps c ex <> ")"
|
||||||
printExpression (PrefixExp name ex) = pretty name <+> printExpression ex
|
printExpression inps c (List ex) = list (map (printExpression inps c) ex)
|
||||||
printExpression (PostfixExp "exists" ex) = "isJust" <+> printExpression ex
|
printExpression inps c (Function name ex) = pretty name <> tupled (map (printExpression inps c) ex)
|
||||||
printExpression (PostfixExp "is absent" ex) = "isNothing" <+> printExpression ex
|
printExpression inps c (PrefixExp name ex) = pretty name <+> printExpression inps c ex
|
||||||
printExpression (PostfixExp "single exists" ex) = "length" <+> printExpression ex <+> "==" <+> "1"
|
printExpression inps c (PostfixExp "exists" ex) = "isJust" <+> printExpression inps c ex
|
||||||
printExpression (PostfixExp "multiple exists" ex) = "length" <+> printExpression ex <+> ">" <+> "1"
|
printExpression inps c (PostfixExp "is absent" ex) = "isNothing" <+> printExpression inps c ex
|
||||||
printExpression (PostfixExp "count" ex) = "length" <+> printExpression ex
|
printExpression inps c (PostfixExp "single exists" ex) = "length" <+> printExpression inps c ex <+> "==" <+> "1"
|
||||||
printExpression (PostfixExp name ex) = pretty name <+> printExpression ex
|
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 (InfixExp "=" ex1 ex2) = printExpression ex1 <+> "==" <+> printExpression ex2
|
printExpression inps c (InfixExp "=" ex1 ex2) = printExpression inps c ex1 <+> "==" <+> printExpression inps c ex2
|
||||||
printExpression (InfixExp "<>" ex1 ex2) = printExpression ex1 <+> "/=" <+> printExpression ex2
|
printExpression inps c (InfixExp "<>" ex1 ex2) = printExpression inps c ex1 <+> "/=" <+> printExpression inps c ex2
|
||||||
printExpression (InfixExp "any =" ex1 ex2) = printExpression ex2 <+> "`elem`" <+> printExpression ex1
|
printExpression inps c (InfixExp "any =" ex1 ex2) = printExpression inps c ex2 <+> "`elem`" <+> printExpression inps c ex1
|
||||||
printExpression (InfixExp "all <>" ex1 ex2) = printExpression ex2 <+> "`notElem`" <+> printExpression ex1
|
printExpression inps c (InfixExp "all <>" ex1 ex2) = printExpression inps c ex2 <+> "`notElem`" <+> printExpression inps c ex1
|
||||||
--printExpression (InfixExp "all =" ex1 ex2) = "all (Eq)" <+> printExpression ex2 <+> printExpression ex1
|
--printExpression (InfixExp "all =" ex1 ex2) = "all (Eq)" <+> printExpression ex2 <+> printExpression ex1
|
||||||
printExpression (InfixExp "and" ex1 ex2) = printExpression ex1 <+> "&&" <+> printExpression ex2
|
printExpression inps c (InfixExp "and" ex1 ex2) = printExpression inps c ex1 <+> "&&" <+> printExpression inps c ex2
|
||||||
printExpression (InfixExp "or" ex1 ex2) = printExpression ex1 <+> "||" <+> printExpression ex2
|
printExpression inps c (InfixExp "or" ex1 ex2) = printExpression inps c ex1 <+> "||" <+> printExpression inps c ex2
|
||||||
printExpression (InfixExp name ex1 ex2) = printExpression ex1 <+> pretty name <+> printExpression ex2
|
printExpression inps c (InfixExp name ex1 ex2) = printExpression inps c ex1 <+> pretty name <+> printExpression inps c ex2
|
||||||
printExpression (IfSimple cond ex) = "if" <+> printExpression cond <+> "then" <+> printExpression ex <+> "else" <+> "Nothing"
|
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 (IfElse cond ex1 ex2) = "if" <+> printExpression cond <+> "then" <+> printExpression ex1 <+> "else" <+> printExpression ex2
|
printExpression inps c (IfSimple cond ex) = "if" <+> printExpression inps (Bounds (1, 1)) cond <+> "then" <+> printExpression inps c ex <+> "else" <+> "[]"
|
||||||
|
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
|
||||||
|
printVariable :: Cardinality -> Cardinality -> String -> Doc a
|
||||||
|
printVariable (Bounds (1, 1)) (Bounds (1, 1)) s = pretty s
|
||||||
|
printVariable (Bounds (1, 1)) (Bounds (0, 1)) s = "Just" <+> pretty s
|
||||||
|
printVariable (Bounds (0, 1)) (Bounds (0, 1)) s = pretty s
|
||||||
|
printVariable (Bounds (1, 1)) _ s = "[" <+> pretty s <+> "]"
|
||||||
|
printVariable _ _ s = pretty s
|
||||||
|
|
||||||
-- |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
|
||||||
@@ -59,3 +70,10 @@ printFunctionSignature (MakeFunction name description inputs output _) =
|
|||||||
-- |Zips the signature with the needed characters ('::', '->')
|
-- |Zips the signature with the needed characters ('::', '->')
|
||||||
prettyPrintType :: [Doc x] -> Doc x
|
prettyPrintType :: [Doc x] -> Doc x
|
||||||
prettyPrintType = align . sep . Prelude.zipWith (<+>) ("::" : repeat "->")
|
prettyPrintType = align . sep . Prelude.zipWith (<+>) ("::" : repeat "->")
|
||||||
|
|
||||||
|
-- |Gets the cardinality of a variable by name
|
||||||
|
getVarCardinality :: [TypeAttribute] -> String -> Cardinality
|
||||||
|
getVarCardinality [] _ = error "Variable not a parameter"
|
||||||
|
getVarCardinality (MakeTypeAttribute name _ card _ : inps) varName
|
||||||
|
| name == varName = card
|
||||||
|
| otherwise = getVarCardinality inps varName
|
||||||
@@ -88,9 +88,7 @@ checkExpression symbolMap (InfixExp name ex1 ex2) = checkFunctionCall symbolMap
|
|||||||
checkExpression symbolMap (IfSimple cond ex)
|
checkExpression symbolMap (IfSimple cond ex)
|
||||||
| isRight condType && isSubType (fst $ fromRightUnsafe condType) (BasicType "Boolean") && snd (fromRightUnsafe condType) == Bounds (1, 1) =
|
| isRight condType && isSubType (fst $ fromRightUnsafe condType) (BasicType "Boolean") && snd (fromRightUnsafe condType) == Bounds (1, 1) =
|
||||||
case checkedExp of
|
case checkedExp of
|
||||||
-- |The if without else statement always has a cardinality lower bound of 0
|
|
||||||
Right (typ, Bounds(_, x)) -> Right (typ, Bounds(0, x))
|
Right (typ, Bounds(_, x)) -> Right (typ, Bounds(0, x))
|
||||||
-- |The unbounded or semi-bounded cardinalities already have 0 included
|
|
||||||
Right x -> Right x
|
Right x -> Right x
|
||||||
Left err -> Left err
|
Left err -> Left err
|
||||||
| otherwise = Left $ IfConditionNotBoolean $ show condType
|
| otherwise = Left $ IfConditionNotBoolean $ show condType
|
||||||
@@ -101,7 +99,6 @@ checkExpression symbolMap (IfSimple cond ex)
|
|||||||
checkExpression symbolMap (IfElse cond ex1 ex2)
|
checkExpression symbolMap (IfElse cond ex1 ex2)
|
||||||
| isLeft condType || isSubType (fst $ fromRightUnsafe condType) (BasicType "Boolean") && snd (fromRightUnsafe condType) == Bounds (1, 1) = Left $ IfConditionNotBoolean $ show cond
|
| isLeft condType || isSubType (fst $ fromRightUnsafe condType) (BasicType "Boolean") && snd (fromRightUnsafe condType) == Bounds (1, 1) = Left $ IfConditionNotBoolean $ show cond
|
||||||
| isLeft ex1Type || isLeft ex2Type ||
|
| isLeft ex1Type || isLeft ex2Type ||
|
||||||
-- |Both branches must resolve to the same type and cardinality
|
|
||||||
isLeft (typeMatch (fst $ fromRightUnsafe ex1Type) (fst $ fromRightUnsafe ex2Type)) ||
|
isLeft (typeMatch (fst $ fromRightUnsafe ex1Type) (fst $ fromRightUnsafe ex2Type)) ||
|
||||||
snd (fromRightUnsafe ex1Type) /= snd (fromRightUnsafe ex2Type) = Left $ IfExpressionsDifferentTypes (show ex1) (show ex2)
|
snd (fromRightUnsafe ex1Type) /= snd (fromRightUnsafe ex2Type) = Left $ IfExpressionsDifferentTypes (show ex1) (show ex2)
|
||||||
| otherwise = ex1Type
|
| otherwise = ex1Type
|
||||||
@@ -122,12 +119,13 @@ checkList1 :: [Symbol] -> [Expression] -> (Type, Cardinality) -> Either TypeChec
|
|||||||
checkList1 _ [] typ = Right typ
|
checkList1 _ [] typ = Right typ
|
||||||
checkList1 symbs (ex : exps) typ
|
checkList1 symbs (ex : exps) typ
|
||||||
| isLeft exTyp = exTyp
|
| isLeft exTyp = exTyp
|
||||||
| not match = Left $ TypeMismatch (typeName $ fst typ) (typeName $ fst (fromRightUnsafe exTyp))
|
| sub = checkList1 symbs exps (fst typ, smallestBound (snd $ fromRightUnsafe exTyp) (snd typ))
|
||||||
| otherwise = checkList1 symbs exps (fst typ, crd)
|
| sup = checkList1 symbs exps (fst $ fromRightUnsafe exTyp, smallestBound (snd $ fromRightUnsafe exTyp) (snd typ))
|
||||||
|
| otherwise = Left $ TypeMismatch (typeName $ fst typ) (typeName $ fst (fromRightUnsafe exTyp))
|
||||||
where
|
where
|
||||||
exTyp = checkExpression symbs ex
|
exTyp = checkExpression symbs ex
|
||||||
match = fst typ == fst (fromRightUnsafe exTyp)
|
sub = isSubType (fst typ) (fst (fromRightUnsafe exTyp))
|
||||||
crd = snd typ .+ snd (fromRightUnsafe exTyp)
|
sup = isSubType (fst (fromRightUnsafe exTyp)) (fst typ)
|
||||||
|
|
||||||
-- |Checks whether the function that is called is already defined with the same argument types
|
-- |Checks whether the function that is called is already defined with the same argument types
|
||||||
checkFunctionCall :: [Symbol] -> String -> [Either TypeCheckError (Type, Cardinality)] -> Either TypeCheckError (Type, Cardinality)
|
checkFunctionCall :: [Symbol] -> String -> [Either TypeCheckError (Type, Cardinality)] -> Either TypeCheckError (Type, Cardinality)
|
||||||
@@ -142,11 +140,11 @@ checkFunctionCall (_:symbolMap) name args = checkFunctionCall symbolMap name arg
|
|||||||
|
|
||||||
typeIncluded :: (Type, Cardinality) -> (Type, Cardinality) -> Either TypeCheckError Bool
|
typeIncluded :: (Type, Cardinality) -> (Type, Cardinality) -> Either TypeCheckError Bool
|
||||||
typeIncluded (t1, c1) (t2, c2)
|
typeIncluded (t1, c1) (t2, c2)
|
||||||
| isSubType t1 t2 && cardinalityIncluded c1 c2 = Right True
|
| t1 `isSubType` t2 && cardinalityIncluded c1 c2 = Right True
|
||||||
| isSubType t1 t2 = Left $ CardinalityMismatch c1 c2
|
| t1 `isSubType` t2 = Left $ CardinalityMismatch c1 c2
|
||||||
| otherwise = Left $ TypeMismatch (typeName t1) (typeName t2)
|
| otherwise = Left $ TypeMismatch (typeName t1) (typeName t2)
|
||||||
|
|
||||||
-- |Checks whether two types are compatible
|
-- |Checks whether two types are compatible (i.e. they have a common super type)
|
||||||
typeMatch :: Type -> Type -> Either TypeCheckError Type
|
typeMatch :: Type -> Type -> Either TypeCheckError Type
|
||||||
-- |An object matches only with object
|
-- |An object matches only with object
|
||||||
typeMatch (BasicType "Object") _ = Right $ BasicType "Object"
|
typeMatch (BasicType "Object") _ = Right $ BasicType "Object"
|
||||||
@@ -164,30 +162,6 @@ typeMatch x y
|
|||||||
| otherwise = typeMatch (superType x) y
|
| otherwise = typeMatch (superType x) y
|
||||||
where match = typeMatch x (superType y)
|
where match = typeMatch x (superType y)
|
||||||
|
|
||||||
-- |Checks whether the first argument is a subtype of the second argument
|
|
||||||
isSubType :: Type -> Type -> Bool
|
|
||||||
isSubType (BasicType "Integer") (BasicType "Double") = True
|
|
||||||
isSubType _ (BasicType "Any") = True
|
|
||||||
isSubType _ (BasicType "Object") = False
|
|
||||||
isSubType x y
|
|
||||||
| x == y = True
|
|
||||||
| otherwise = isSubType (superType x) y
|
|
||||||
|
|
||||||
-- |Checks whether the first cardinality is included into the second one
|
|
||||||
cardinalityIncluded :: Cardinality -> Cardinality -> Bool
|
|
||||||
cardinalityIncluded _ NoBounds = True
|
|
||||||
cardinalityIncluded NoBounds _ = False
|
|
||||||
cardinalityIncluded (OneBound x) (OneBound y)
|
|
||||||
| x >= y = True
|
|
||||||
| otherwise = False
|
|
||||||
cardinalityIncluded (Bounds (x1, _)) (OneBound y)
|
|
||||||
| x1 >= y = True
|
|
||||||
| otherwise = False
|
|
||||||
cardinalityIncluded (OneBound _) (Bounds (_, _)) = False
|
|
||||||
cardinalityIncluded (Bounds (x1, x2)) (Bounds (y1, y2))
|
|
||||||
| x1 >= y1 && x2 <= y2 = True
|
|
||||||
| otherwise = False
|
|
||||||
|
|
||||||
-- |Looks in the symbol map for the type of a variable
|
-- |Looks in the symbol map for the type of a variable
|
||||||
findVarType :: String -> [Symbol] -> Either TypeCheckError (Type, Cardinality)
|
findVarType :: String -> [Symbol] -> Either TypeCheckError (Type, Cardinality)
|
||||||
findVarType var [] = Left $ UndefinedVariable var
|
findVarType var [] = Left $ UndefinedVariable var
|
||||||
|
|||||||
@@ -11,7 +11,7 @@ import Data.Char
|
|||||||
checkFunction :: ([Type], [Symbol]) -> Function -> Either [TypeCheckError] Function
|
checkFunction :: ([Type], [Symbol]) -> Function -> Either [TypeCheckError] Function
|
||||||
checkFunction (definedTypes, symbols) (MakeFunction name desc inp out ex)
|
checkFunction (definedTypes, symbols) (MakeFunction name desc inp out ex)
|
||||||
| isRight checkedEx && isRight checkedOut && null (lefts checkedIn) =
|
| isRight checkedEx && isRight checkedOut && null (lefts checkedIn) =
|
||||||
case typeIncluded (attributeType $ fromRightUnsafe checkedOut, Model.Type.cardinality out) (fromRightUnsafe checkedEx) of
|
case typeIncluded (fromRightUnsafe checkedEx) (attributeType $ fromRightUnsafe checkedOut, Model.Type.cardinality out) of
|
||||||
Right _ -> Right $ MakeFunction (toLower (head name) : tail name) desc (rights checkedIn) (fromRightUnsafe checkedOut) ex
|
Right _ -> Right $ MakeFunction (toLower (head name) : tail name) desc (rights checkedIn) (fromRightUnsafe checkedOut) ex
|
||||||
Left err -> Left [err]
|
Left err -> Left [err]
|
||||||
| otherwise = Left $ lefts [checkedOut] ++ lefts checkedIn ++ lefts [checkedEx]
|
| otherwise = Left $ lefts [checkedOut] ++ lefts checkedIn ++ lefts [checkedEx]
|
||||||
|
|||||||
@@ -28,10 +28,10 @@ checkType _ (BasicType b) = Right (BasicType b)
|
|||||||
populateSuper :: [Type] -> [Type] -> Type -> Either TypeCheckError Type
|
populateSuper :: [Type] -> [Type] -> Type -> Either TypeCheckError Type
|
||||||
populateSuper _ _ (BasicType "Object") = Right (BasicType "Object")
|
populateSuper _ _ (BasicType "Object") = Right (BasicType "Object")
|
||||||
populateSuper _ _ (BasicType _) = Left $ UndefinedType "Can't extend basic types"
|
populateSuper _ _ (BasicType _) = Left $ UndefinedType "Can't extend basic types"
|
||||||
populateSuper _ [] t = Left $ UndefinedType (typeName t)
|
populateSuper _ [] t = error "WTF" --Left $ UndefinedType (typeName t)
|
||||||
populateSuper allTypes (currType : types) (MakeType t super d a)
|
populateSuper allTypes (currType : types) (MakeType t super d a)
|
||||||
| typeName currType == typeName super = case populateSuper allTypes allTypes currType of
|
| typeName currType == t = case populateSuper allTypes allTypes super of
|
||||||
Right superChecked -> Right $ MakeType t superChecked d a
|
Right superChecked -> Right $ MakeType t superChecked (typeDescription currType) (typeAttributes currType)
|
||||||
Left err -> Left err
|
Left err -> Left err
|
||||||
| otherwise = populateSuper allTypes types (MakeType t super d a)
|
| otherwise = populateSuper allTypes types (MakeType t super d a)
|
||||||
|
|
||||||
|
|||||||
66
test/Model/TypeSpec.hs
Normal file
66
test/Model/TypeSpec.hs
Normal file
@@ -0,0 +1,66 @@
|
|||||||
|
module Model.TypeSpec where
|
||||||
|
|
||||||
|
import Test.Hspec
|
||||||
|
import Model.Type
|
||||||
|
|
||||||
|
spec :: Spec
|
||||||
|
spec = do
|
||||||
|
describe "Testing cardinality addition" $ do
|
||||||
|
it "[Test add 1]" $ do
|
||||||
|
head cards1 .+ head cards2 `shouldBe` head cardsSum
|
||||||
|
it "[Test add 2]" $ do
|
||||||
|
cards1 !! 1 .+ cards2 !! 1 `shouldBe` cardsSum !! 1
|
||||||
|
it "[Test add 3]" $ do
|
||||||
|
cards1 !! 2 .+ cards2 !! 2 `shouldBe` cardsSum !! 2
|
||||||
|
it "[Test add 4]" $ do
|
||||||
|
cards1 !! 3 .+ cards2 !! 3 `shouldBe` cardsSum !! 3
|
||||||
|
it "[Test add 5]" $ do
|
||||||
|
cards1 !! 4 .+ cards2 !! 4 `shouldBe` cardsSum !! 4
|
||||||
|
it "[Test add 6]" $ do
|
||||||
|
cards1 !! 5 .+ cards2 !! 5 `shouldBe` cardsSum !! 5
|
||||||
|
it "[Test add 7]" $ do
|
||||||
|
cards1 !! 6 .+ cards2 !! 6 `shouldBe` cardsSum !! 6
|
||||||
|
it "[Test add 8]" $ do
|
||||||
|
cards1 !! 7 .+ cards2 !! 7 `shouldBe` cardsSum !! 7
|
||||||
|
it "[Test add 9]" $ do
|
||||||
|
cards1 !! 8 .+ cards2 !! 8 `shouldBe` cardsSum !! 8
|
||||||
|
it "[Test add 10]" $ do
|
||||||
|
cards1 !! 9 .+ cards2 !! 9 `shouldBe` cardsSum !! 9
|
||||||
|
describe "Testing smallest cardinality" $ do
|
||||||
|
it "[Test smallest 1]" $ do
|
||||||
|
smallestBound (head cards1) (head cards2) `shouldBe` head smallestCards
|
||||||
|
it "[Test smallest 2]" $ do
|
||||||
|
smallestBound (cards1 !! 1) (cards2 !! 1) `shouldBe` smallestCards !! 1
|
||||||
|
it "[Test smallest 3]" $ do
|
||||||
|
smallestBound (cards1 !! 2) (cards2 !! 2) `shouldBe` smallestCards !! 2
|
||||||
|
it "[Test smallest 4]" $ do
|
||||||
|
smallestBound (cards1 !! 3) (cards2 !! 3) `shouldBe` smallestCards !! 3
|
||||||
|
it "[Test smallest 5]" $ do
|
||||||
|
smallestBound (cards1 !! 4) (cards2 !! 4) `shouldBe` smallestCards !! 4
|
||||||
|
it "[Test smallest 6]" $ do
|
||||||
|
smallestBound (cards1 !! 5) (cards2 !! 5) `shouldBe` smallestCards !! 5
|
||||||
|
it "[Test smallest 7]" $ do
|
||||||
|
smallestBound (cards1 !! 6) (cards2 !! 6) `shouldBe` smallestCards !! 6
|
||||||
|
it "[Test smallest 8]" $ do
|
||||||
|
smallestBound (cards1 !! 7) (cards2 !! 7) `shouldBe` smallestCards !! 7
|
||||||
|
it "[Test smallest 9]" $ do
|
||||||
|
smallestBound (cards1 !! 8) (cards2 !! 8) `shouldBe` smallestCards !! 8
|
||||||
|
it "[Test smallest 10]" $ do
|
||||||
|
smallestBound (cards1 !! 9) (cards2 !! 9) `shouldBe` smallestCards !! 9
|
||||||
|
|
||||||
|
|
||||||
|
cards1 :: [Cardinality]
|
||||||
|
cards1 =
|
||||||
|
[Bounds (0, 20), Bounds (10, 15), Bounds (25, 50), Bounds (15, 16), NoBounds, OneBound 25, OneBound 2, OneBound 1, NoBounds, NoBounds]
|
||||||
|
|
||||||
|
cards2 :: [Cardinality]
|
||||||
|
cards2 =
|
||||||
|
[Bounds (2, 4), Bounds (4, 45), OneBound 6, NoBounds, Bounds (2, 5), Bounds (2, 30), OneBound 5, NoBounds, OneBound 5, NoBounds]
|
||||||
|
|
||||||
|
cardsSum :: [Cardinality]
|
||||||
|
cardsSum =
|
||||||
|
[Bounds (2, 24), Bounds (14, 60), OneBound 31, OneBound 15, OneBound 2, OneBound 27, OneBound 7, OneBound 1, OneBound 5, NoBounds]
|
||||||
|
|
||||||
|
smallestCards :: [Cardinality]
|
||||||
|
smallestCards =
|
||||||
|
[Bounds (0, 20), Bounds (4, 45), OneBound 6, NoBounds, NoBounds, OneBound 2, OneBound 2, NoBounds, NoBounds, NoBounds]
|
||||||
Reference in New Issue
Block a user