mirror of
https://github.com/macocianradu/RosettaHaskellCompiler.git
synced 2026-03-18 13:00:08 +00:00
Working multiple assignments,
Need to fix recursive types
This commit is contained in:
Macocian Adrian Radu
@@ -37,6 +37,7 @@ library
|
||||
Parser.Header
|
||||
Parser.Type
|
||||
PrettyPrinter.Enum
|
||||
PrettyPrinter.Expression
|
||||
PrettyPrinter.Function
|
||||
PrettyPrinter.General
|
||||
PrettyPrinter.Header
|
||||
|
||||
@@ -26,9 +26,13 @@ data Condition = MakeCondition {
|
||||
expressionExpression :: Expression
|
||||
} deriving (Show)
|
||||
|
||||
instance Eq Condition where
|
||||
(==) (MakeCondition _ ex) (MakeCondition _ ex2) = ex == ex2
|
||||
|
||||
-- |The representation of an expression
|
||||
data Expression = Variable String
|
||||
| PathExpression Expression Expression
|
||||
| Keyword String
|
||||
| Int String
|
||||
| Real String
|
||||
| Boolean String
|
||||
@@ -47,12 +51,24 @@ data ExplicitExpression = ExplicitEmpty
|
||||
| ExplicitVariable {name :: String, returnCoercion :: Coercion}
|
||||
| Value {name :: String, returnCoercion :: Coercion}
|
||||
| ExplicitList [ExplicitExpression]
|
||||
| ExplicitKeyword String
|
||||
| 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}
|
||||
deriving (Show)
|
||||
|
||||
instance Show ExplicitExpression where
|
||||
show (ExplicitVariable name coer) = show $ "Variable: " ++ name
|
||||
show (Value name coer) = show $ "Value: " ++ name
|
||||
show (ExplicitList lst) = concatMap show lst
|
||||
show (ExplicitKeyword name) = show $ "Keyword: " ++ name
|
||||
show (ExplicitParens name) = show $ "(" ++ show name ++ ")"
|
||||
show (ExplicitPath super sub coer) = show $ "(->" ++ show super ++ " " ++ show sub ++ ")"
|
||||
show (ExplicitFunction name args coer) = show $ name ++ "(" ++ concatMap show args ++ ")"
|
||||
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"
|
||||
|
||||
data TypeCoercion =
|
||||
MakeIdCoercion {toType :: Type}
|
||||
|
||||
@@ -106,7 +106,9 @@ terminalParser :: Parser Expression
|
||||
terminalParser =
|
||||
do
|
||||
choice
|
||||
[ prefixParser,
|
||||
[
|
||||
try keywordParser,
|
||||
prefixParser,
|
||||
parens expressionParser >>= \e -> return (Parens e),
|
||||
listParser,
|
||||
try booleanParser,
|
||||
@@ -119,6 +121,14 @@ terminalParser =
|
||||
--------------------------------------------
|
||||
-- Expressions -----------------------------
|
||||
--------------------------------------------
|
||||
keywords :: [String]
|
||||
keywords = ["one-of"]
|
||||
|
||||
keywordParser :: Parser Expression
|
||||
keywordParser =
|
||||
do
|
||||
word <- lexeme $ choice $ fmap (try . string . Text.pack) keywords
|
||||
return $ Keyword $ Text.unpack word
|
||||
|
||||
-- |Parses an prefix function statement in Rosetta into an Expression
|
||||
prefixParser :: Parser Expression
|
||||
|
||||
69
src/PrettyPrinter/Expression.hs
Normal file
69
src/PrettyPrinter/Expression.hs
Normal file
@@ -0,0 +1,69 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module PrettyPrinter.Expression where
|
||||
|
||||
import Model.Type
|
||||
import Prettyprinter
|
||||
import Semantic.ExpressionChecker(coercionIncluded)
|
||||
|
||||
printExpression :: ExplicitExpression -> Coercion -> Doc a
|
||||
printExpression ExplicitEmpty _ = "[]"
|
||||
printExpression (ExplicitVariable name coer) out = case coer `coercionIncluded` out of
|
||||
Left err -> error $ 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 (ExplicitKeyword k) out = pretty k
|
||||
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"
|
||||
printExpression (ExplicitFunction "multiple exists" args returnCoerce) out = printCoercion returnCoerce "length" <+> printCoercion (snd $ head args) (printExpression (fst $ head args) out) <+> ">" <+> "1"
|
||||
printExpression (ExplicitFunction "count" args returnCoerce) out = printCoercion returnCoerce "length" <+> printCoercion (snd $ head args) (printExpression (fst $ head args) out)
|
||||
-- Equality expressions
|
||||
-- [a] a all =
|
||||
-- any <>
|
||||
printExpression (ExplicitFunction "=" args returnCoerce) out = printCoercion (snd $ head args) (printExpression (fst $ head args) out) <+> "==" <+> printCoercion (snd $ head $ tail args) (printExpression (fst $ head $ tail args) out)
|
||||
printExpression (ExplicitFunction "<>" args returnCoerce) out = printCoercion (snd $ head args) (printExpression (fst $ head args) out) <+> "/=" <+> printCoercion (snd $ head $ tail args) (printExpression (fst $ head $ tail args) out)
|
||||
printExpression (ExplicitFunction "any =" args returnCoerce) out = printCoercion (snd $ head $ tail args) (printExpression (fst $ head $ tail args) out) <+> "`elem`" <+> printCoercion (snd $ head args) (printExpression (fst $ head args) out)
|
||||
printExpression (ExplicitFunction "all <>" args returnCoerce) out = printCoercion (snd $ head $ tail args) (printExpression (fst $ head $ tail args) out) <+> "`notElem`" <+> printCoercion (snd $ head args) (printExpression (fst $ head args) out)
|
||||
printExpression (ExplicitFunction "all =" args returnCoerce) out = "all (Eq)" <+> printCoercion (snd $ head $ tail args) (printExpression (fst $ head $ tail args) out) <+> printCoercion (snd $ head args) (printExpression (fst $ head args) out)
|
||||
printExpression (ExplicitFunction "and" args returnCoerce) out = printCoercion (snd $ head args) (printExpression (fst $ head args) out) <+> "&&" <+> printCoercion (snd $ head $ tail args) (printExpression (fst $ head $ tail args) out)
|
||||
printExpression (ExplicitFunction "or" args returnCoerce) out = printCoercion (snd $ head args) (printExpression (fst $ head args) out) <+> "||" <+> printCoercion (snd $ head $ tail args) (printExpression (fst $ head $ tail args) out)
|
||||
printExpression (ExplicitFunction name args returnCoerce) out = pretty name <+> tupled (zipWith printCoercion [c | (e,c) <- args] [printExpression e out | (e, c) <- args])
|
||||
printExpression (ExplicitIfSimple cond thenBlock returnCoercion) out =
|
||||
"if" <+> printCoercion (snd cond) (printExpression (fst cond) (MakeCoercion [MakeIdCoercion (BasicType "Boolean")] (MakeCardinalityIdCoercion (Bounds (1, 1))))) <+>
|
||||
"then" <+> printCoercion (snd thenBlock) (printExpression (fst thenBlock) out) <+>
|
||||
"else" <+> case MakeCoercion [MakeIdCoercion $ coercionType $ typeCoercion returnCoercion] (MakeCardinalityIdCoercion (Bounds (0, 0))) `coercionIncluded` out of
|
||||
Left err -> error $ show err
|
||||
Right c -> printCoercion c emptyDoc
|
||||
printExpression (ExplicitIfElse cond thenBlock elseBlock returnCoercion) out =
|
||||
"if" <+> printCoercion (snd cond) (printExpression (fst cond) (MakeCoercion [MakeIdCoercion (BasicType "Boolean")] (MakeCardinalityIdCoercion (Bounds (1, 1))))) <+>
|
||||
"then" <+> printCoercion (snd thenBlock) (printExpression (fst thenBlock) out) <+>
|
||||
"else" <+> printCoercion (snd elseBlock) (printExpression (fst elseBlock) out)
|
||||
|
||||
-- |Converts a coercion into a haskell string
|
||||
printCoercion :: Coercion -> Doc a -> Doc a
|
||||
printCoercion (MakeCoercion [] crd) d = printCardinalityCoercion crd d
|
||||
printCoercion (MakeCoercion (t: ts) crd) d = printTypeCoercion t <> printCoercion (MakeCoercion ts crd) d
|
||||
|
||||
printCardinalityCoercion :: CardinalityCoercion -> Doc a -> Doc a
|
||||
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" <+> emptyDoc
|
||||
printTypeCoercion (MakeTypeCoercion _ _ t) = pretty t <+> emptyDoc
|
||||
|
||||
-- |Converts a list of type attributes to a Doc with a list of variable names
|
||||
printVariableNames :: [TypeAttribute] -> Doc a
|
||||
printVariableNames vars = foldl (<+>) emptyDoc (map (pretty . attributeName) vars)
|
||||
@@ -3,13 +3,36 @@
|
||||
module PrettyPrinter.Function where
|
||||
|
||||
import Prettyprinter
|
||||
import PrettyPrinter.Expression
|
||||
import Model.Function
|
||||
import PrettyPrinter.General
|
||||
import PrettyPrinter.Type
|
||||
import Model.Type
|
||||
import Semantic.ExpressionChecker(coercionIncluded)
|
||||
import Utils.Utils (uncapitalize)
|
||||
|
||||
-- show printStatementTree
|
||||
{-
|
||||
Consider all assignments as trees
|
||||
Root must always bee the same type (output type of the functions)
|
||||
Merge at every level, the nodes that have the same type
|
||||
1 1 1 1 1 1
|
||||
| | | / | \ / \ / \
|
||||
2 2 4 ---> 2 2 4 ---> 2 4 ---> 2 4
|
||||
| | | | | | | \ | | |
|
||||
3 3 5 ---> 3 3 5 ---> 3 3 5 ---> 3 5
|
||||
| | | | | | | | | | \ |
|
||||
EX1 EX2 EX3 EX1 EX2 EX3 EX1 EX2 EX3 EX1 EX2 EX3
|
||||
-}
|
||||
|
||||
data AssignmentTree = AssignmentNode {
|
||||
var :: String,
|
||||
typ :: Type,
|
||||
children :: [AssignmentTree]
|
||||
}
|
||||
| AssignmentLeaf ExplicitExpression
|
||||
|
||||
instance Show AssignmentTree where
|
||||
show (AssignmentNode var typ child) = "Node: " ++ show (typeName typ) ++ show child
|
||||
show (AssignmentLeaf exp) = "Leaf: " ++ show exp
|
||||
|
||||
-- |Converts a Function into a haskell valid String
|
||||
printFunction :: ExplicitFunction -> String
|
||||
@@ -17,69 +40,11 @@ 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 <+> "= 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
|
||||
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"
|
||||
printExpression (ExplicitFunction "multiple exists" args returnCoerce) out = printCoercion returnCoerce "length" <+> printCoercion (snd $ head args) (printExpression (fst $ head args) out) <+> ">" <+> "1"
|
||||
printExpression (ExplicitFunction "count" args returnCoerce) out = printCoercion returnCoerce "length" <+> printCoercion (snd $ head args) (printExpression (fst $ head args) out)
|
||||
-- Equality expressions
|
||||
-- [a] a all =
|
||||
-- any <>
|
||||
printExpression (ExplicitFunction "=" args returnCoerce) out = printCoercion (snd $ head args) (printExpression (fst $ head args) out) <+> "==" <+> printCoercion (snd $ head $ tail args) (printExpression (fst $ head $ tail args) out)
|
||||
printExpression (ExplicitFunction "<>" args returnCoerce) out = printCoercion (snd $ head args) (printExpression (fst $ head args) out) <+> "/=" <+> printCoercion (snd $ head $ tail args) (printExpression (fst $ head $ tail args) out)
|
||||
printExpression (ExplicitFunction "any =" args returnCoerce) out = printCoercion (snd $ head $ tail args) (printExpression (fst $ head $ tail args) out) <+> "`elem`" <+> printCoercion (snd $ head args) (printExpression (fst $ head args) out)
|
||||
printExpression (ExplicitFunction "all <>" args returnCoerce) out = printCoercion (snd $ head $ tail args) (printExpression (fst $ head $ tail args) out) <+> "`notElem`" <+> printCoercion (snd $ head args) (printExpression (fst $ head args) out)
|
||||
printExpression (ExplicitFunction "all =" args returnCoerce) out = "all (Eq)" <+> printCoercion (snd $ head $ tail args) (printExpression (fst $ head $ tail args) out) <+> printCoercion (snd $ head args) (printExpression (fst $ head args) out)
|
||||
printExpression (ExplicitFunction "and" args returnCoerce) out = printCoercion (snd $ head args) (printExpression (fst $ head args) out) <+> "&&" <+> printCoercion (snd $ head $ tail args) (printExpression (fst $ head $ tail args) out)
|
||||
printExpression (ExplicitFunction "or" args returnCoerce) out = printCoercion (snd $ head args) (printExpression (fst $ head args) out) <+> "||" <+> printCoercion (snd $ head $ tail args) (printExpression (fst $ head $ tail args) out)
|
||||
printExpression (ExplicitFunction name args returnCoerce) out = pretty name <+> tupled (zipWith printCoercion [c | (e,c) <- args] [printExpression e out | (e, c) <- args])
|
||||
printExpression (ExplicitIfSimple cond thenBlock returnCoercion) out =
|
||||
"if" <+> printCoercion (snd cond) (printExpression (fst cond) (MakeCoercion [MakeIdCoercion (BasicType "Boolean")] (MakeCardinalityIdCoercion (Bounds (1, 1))))) <+>
|
||||
"then" <+> printCoercion (snd thenBlock) (printExpression (fst thenBlock) out) <+>
|
||||
"else" <+> case MakeCoercion [MakeIdCoercion $ coercionType $ typeCoercion returnCoercion] (MakeCardinalityIdCoercion (Bounds (0, 0))) `coercionIncluded` out of
|
||||
Left err -> error $ show err
|
||||
Right c -> printCoercion c emptyDoc
|
||||
printExpression (ExplicitIfElse cond thenBlock elseBlock returnCoercion) out =
|
||||
"if" <+> printCoercion (snd cond) (printExpression (fst cond) (MakeCoercion [MakeIdCoercion (BasicType "Boolean")] (MakeCardinalityIdCoercion (Bounds (1, 1))))) <+>
|
||||
"then" <+> printCoercion (snd thenBlock) (printExpression (fst thenBlock) out) <+>
|
||||
"else" <+> printCoercion (snd elseBlock) (printExpression (fst elseBlock) out)
|
||||
printFunctionBody (MakeExplicitFunction (MakeFunctionSignature name _ inp out) ex) =
|
||||
pretty name <+> printVariableNames inp <+> "=" <+>
|
||||
printAssignmentTree (head $ mergeAssignmentTrees [convertToAssignmentTree (fst exp) (AssignmentLeaf (snd exp)) | exp <- ex]) (returnCoercion (fst $ head ex))
|
||||
--error $ show $ mergeAssignmentTrees [convertToAssignmentTree (fst exp) (AssignmentLeaf (snd exp)) | exp <- ex]
|
||||
|
||||
-- |Converts a coercion into a haskell string
|
||||
printCoercion :: Coercion -> Doc a -> Doc a
|
||||
printCoercion (MakeCoercion [] crd) d = printCardinalityCoercion crd d
|
||||
printCoercion (MakeCoercion (t: ts) crd) d = printTypeCoercion t <> printCoercion (MakeCoercion ts crd) d
|
||||
|
||||
printCardinalityCoercion :: CardinalityCoercion -> Doc a -> Doc a
|
||||
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" <+> emptyDoc
|
||||
printTypeCoercion (MakeTypeCoercion _ _ t) = pretty t <+> emptyDoc
|
||||
|
||||
-- |Converts a list of type attributes to a Doc with a list of variable names
|
||||
printVariableNames :: [TypeAttribute] -> Doc a
|
||||
printVariableNames vars = foldl (<+>) emptyDoc (map (pretty . attributeName) vars)
|
||||
|
||||
-- |Converts a function into a haskell valid Doc representing the signature of the function
|
||||
printFunctionSignature :: FunctionSignature -> Doc a
|
||||
@@ -90,9 +55,40 @@ printFunctionSignature (MakeFunctionSignature name description inputs output) =
|
||||
prettyPrintType :: [Doc x] -> Doc x
|
||||
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
|
||||
printAssignmentTree :: AssignmentTree -> Coercion -> Doc a
|
||||
printAssignmentTree (AssignmentLeaf exp) coer = printExpression exp coer
|
||||
printAssignmentTree (AssignmentNode var typ c) coer
|
||||
| length c == 1 = case head c of
|
||||
AssignmentLeaf e -> printConstructor typ <+> "(" <+> printAssignmentTree (head c) coer <> ")"
|
||||
AssignmentNode v t _ -> printConstructor typ <> printConstructor t <+> "(" <+> printAssignmentTree (head c) coer <> ")"
|
||||
| otherwise = case typ of
|
||||
MakeType t _ _ _ _ -> "Make" <> pretty t <+> group (sep [printAssignmentTree child coer | child <- c])
|
||||
BasicType _ -> sep [printAssignmentTree child coer | child <- c]
|
||||
|
||||
mergeAssignmentTrees :: [AssignmentTree] -> [AssignmentTree]
|
||||
mergeAssignmentTrees [] = []
|
||||
mergeAssignmentTrees [a1] = [a1]
|
||||
mergeAssignmentTrees (a1: a2 : as)
|
||||
| length merge == 1 = mergeAssignmentTrees [AssignmentNode {var = var a1, typ = typ a1, children = mergeAssignmentTrees (children (head merge))}] ++ as
|
||||
| otherwise = mergeAssignmentTrees (a1 : as) ++ mergeAssignmentTrees (a2 : as)
|
||||
where
|
||||
merge = mergeAssignmentTree a1 a2
|
||||
|
||||
mergeAssignmentTree :: AssignmentTree -> AssignmentTree -> [AssignmentTree]
|
||||
mergeAssignmentTree (AssignmentNode var1 typ1 c1) (AssignmentNode var2 typ2 c2)
|
||||
| typ1 == typ2 && var1 == var2 = [AssignmentNode var1 typ1 (c1 ++ c2)]
|
||||
| otherwise = [AssignmentNode var1 typ1 c1, AssignmentNode var2 typ2 c2]
|
||||
mergeAssignmentTree t1 t2 = [t1, t2]
|
||||
|
||||
-- |Convert an assignment expression into an assignment tree
|
||||
convertToAssignmentTree :: ExplicitExpression -> AssignmentTree -> AssignmentTree
|
||||
convertToAssignmentTree (ExplicitVariable a c) t = AssignmentNode {var = a, typ = coercionType $ typeCoercion c, children = [t]}
|
||||
convertToAssignmentTree (ExplicitPath ex1 (ExplicitVariable a c) _) t =
|
||||
convertToAssignmentTree ex1 (AssignmentNode {var = a, typ = coercionType $ typeCoercion c, children = [t]})
|
||||
convertToAssignmentTree e _ = error $ "Unsupported expression in path expression " ++ show e
|
||||
|
||||
|
||||
-- |Prints the type name if it is new type, or nothing for basic types
|
||||
printConstructor :: Type -> Doc a
|
||||
printConstructor (MakeType a _ _ _ _) = pretty a
|
||||
printConstructor (BasicType a) = emptyDoc
|
||||
@@ -11,19 +11,25 @@ import Utils.Utils
|
||||
printType :: Type -> String
|
||||
printType (MakeType name (MakeType super _ _ _ _) description attributes conditions) = printType (MakeType name (BasicType "Object") description (superToAttribute super:attributes) conditions)
|
||||
printType (MakeType name (BasicType "Object") description attributes conditions) =
|
||||
show $ printDescription description (vcat [nest 4 $ vcat ("data" <+> pretty name <+> "=" <+> "Make" <> pretty name <+> "{": printAttributes name attributes ++ map printCondition conditions), "}", emptyDoc, emptyDoc])
|
||||
show $ printTypeName name description <+>
|
||||
printAttributes name conditions attributes
|
||||
printType (MakeType _ (BasicType _) _ _ _) = error "Can't extend basic types"
|
||||
printType (BasicType name) = show $ pretty name
|
||||
|
||||
printTypeName :: String -> Maybe String -> Doc a
|
||||
printTypeName name desc = printDescription desc (line <> "data" <+> pretty name <+> "=")
|
||||
|
||||
-- |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")
|
||||
|
||||
-- |Converts a list of TypeAttributes into a list of haskell valid Docs
|
||||
printAttributes :: String -> [TypeAttribute] -> [Doc a]
|
||||
printAttributes _ [] = []
|
||||
printAttributes objName [at] = [printAttribute objName at]
|
||||
printAttributes objName (at : ats) = (printAttribute objName at <> ",") : printAttributes objName ats
|
||||
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, emptyDoc, emptyDoc]
|
||||
| otherwise = vcat [nest 4 $ vcat ("Make" <> pretty objName <+> "{" :
|
||||
reverse (zipWith (<>) (reverse (map (printAttribute objName) ats)) ("" : repeat ",")) ++ map printCondition conditions), "}", emptyDoc, emptyDoc]
|
||||
|
||||
-- |Converts a TypeAttribute into a haskell valid Doc
|
||||
printAttribute :: String -> TypeAttribute -> Doc a
|
||||
@@ -41,3 +47,6 @@ printCardinality (MakeTypeAttribute _ typ (OneBound _) _) = "[" <> pretty (typeN
|
||||
|
||||
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)
|
||||
|
||||
@@ -92,6 +92,7 @@ checkExpression _ (Int val) = Right $ Value val $ MakeCoercion [MakeIdCoercion (
|
||||
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 _ (Keyword k) = Right $ ExplicitKeyword k
|
||||
checkExpression symbolMap (PathExpression ex1 (Variable b)) =
|
||||
case checkExpression symbolMap ex1 of
|
||||
Left err -> Left err
|
||||
@@ -100,13 +101,13 @@ checkExpression symbolMap (PathExpression ex1 (Variable b)) =
|
||||
Right exp2 -> Right $ ExplicitPath exp1 exp2 (returnCoercion exp2)
|
||||
where
|
||||
type1 = coercionType $ typeCoercion $ returnCoercion exp1
|
||||
-- |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 (PathExpression ex1 (PathExpression ))
|
||||
checkExpression symbolMap (Parens ex) =
|
||||
case checkExpression symbolMap ex of
|
||||
Left err -> Left err
|
||||
Right exp -> Right $ ExplicitParens exp
|
||||
-- |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)
|
||||
|
||||
Reference in New Issue
Block a user