mirror of
https://github.com/macocianradu/RosettaHaskellCompiler.git
synced 2026-03-18 13:00:08 +00:00
I don't even know anymore
This commit is contained in:
Macocian Adrian Radu
@@ -42,6 +42,7 @@ data Expression = Variable String
|
||||
| Parens Expression
|
||||
| ListUnaryOp String Expression
|
||||
| ListOp String Expression Expression
|
||||
| Reduce String Expression String String Expression
|
||||
| List [Expression]
|
||||
| Function String [Expression]
|
||||
| PrefixExp String Expression
|
||||
@@ -60,6 +61,7 @@ data ExplicitExpression = ExplicitEmpty
|
||||
| ExplicitListUnaryOp {op :: String, list :: ExplicitExpression, returnCoercion :: Coercion}
|
||||
| ExplicitListOp {op :: String, list :: ExplicitExpression, arg :: ExplicitExpression, returnCoercion :: Coercion}
|
||||
| ExplicitParens {expression :: ExplicitExpression, returnCoercion :: Coercion}
|
||||
| ExplicitReduce {op :: String, list :: ExplicitExpression, var1 :: String, var2 :: String, arg :: ExplicitExpression, returnCoercion :: Coercion}
|
||||
| ExplicitPath {super :: ExplicitExpression, sub :: ExplicitExpression, returnCoercion :: Coercion}
|
||||
| ExplicitFunction {name :: String, args :: [(ExplicitExpression, Coercion)], returnCoercion :: Coercion}
|
||||
| ExplicitIfSimple {cond :: (ExplicitExpression, Coercion), block1 :: (ExplicitExpression, Coercion), returnCoercion :: Coercion}
|
||||
@@ -75,6 +77,7 @@ 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 (ExplicitReduce n o v1 v2 ar _) c = ExplicitReduce n o v1 v2 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
|
||||
@@ -93,6 +96,7 @@ instance Show ExplicitExpression where
|
||||
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 (ExplicitReduce lst op v1 v2 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
|
||||
|
||||
@@ -110,6 +114,7 @@ data CardinalityCoercion =
|
||||
| MakeMaybe2ListCoercion {fromCardinality :: Cardinality, toCardinality :: Cardinality}
|
||||
| MakeObject2MaybeCoercion {fromCardinality :: Cardinality, toCardinality :: Cardinality}
|
||||
| MakeObject2ListCoercion {fromCardinality :: Cardinality, toCardinality :: Cardinality}
|
||||
| MakeOneOfCoercion {toCardinality :: Cardinality}
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- |Used to handle polymorphism in Rosetta
|
||||
|
||||
@@ -247,6 +247,14 @@ listOpParser =
|
||||
Left _ -> return lst
|
||||
Right o ->
|
||||
do
|
||||
case o of
|
||||
"reduce" -> do
|
||||
v1 <- lexeme camelNameParser
|
||||
v2 <- lexeme camelNameParser
|
||||
con <- between (lexeme $ char '[') (lexeme $ char ']') expressionParser
|
||||
exp <- nestedPostOp lst
|
||||
return $ reverseExpression $ Reduce (Text.unpack o) exp v1 v2 con
|
||||
_ -> do
|
||||
con <- between (lexeme $ char '[') (lexeme $ char ']') expressionParser
|
||||
exp <- nestedPostOp lst
|
||||
return $ reverseExpression $ ListOp (Text.unpack o) exp con
|
||||
@@ -271,7 +279,14 @@ nestedListOp ex =
|
||||
case op of
|
||||
Left er -> return ex
|
||||
Right o ->
|
||||
do
|
||||
case o of
|
||||
"reduce" -> do
|
||||
v1 <- lexeme camelNameParser
|
||||
v2 <- lexeme camelNameParser
|
||||
con <- between (lexeme $ char '[') (lexeme $ char ']') expressionParser
|
||||
exp <- nestedPostOp ex
|
||||
return $ reverseExpression $ Reduce (Text.unpack o) exp v1 v2 con
|
||||
_ -> do
|
||||
con <- between (lexeme $ char '[') (lexeme $ char ']') expressionParser
|
||||
exp <- nestedPostOp ex
|
||||
return $ reverseExpression $ ListOp (Text.unpack o) exp con
|
||||
@@ -299,9 +314,15 @@ reverseExpression (InfixExp op t1 (InfixExp op2 t2 e))
|
||||
reverseExpression (PathExpression e1 (PathExpression e2 e3)) = PathExpression (reverseExpression (PathExpression e1 e2)) e3
|
||||
reverseExpression (PathExpression e1 (ListOp op ex2 cond)) = ListOp op (reverseExpression (PathExpression e1 ex2)) cond
|
||||
reverseExpression (PathExpression e1 (ListUnaryOp op ex2)) = ListUnaryOp op (reverseExpression (PathExpression e1 ex2))
|
||||
reverseExpression (PathExpression e1 (Reduce op ex2 v1 v2 cond)) = Reduce op (reverseExpression (PathExpression e1 ex2)) v1 v2 cond
|
||||
reverseExpression (ListOp op1 (ListOp op2 ex2 con2) con1) = ListOp op2 (reverseExpression (ListOp op1 ex2 con1)) con2
|
||||
reverseExpression (ListOp op1 (Reduce op2 ex2 v1 v2 con2) con1) = Reduce op2 (reverseExpression (ListOp op1 ex2 con1)) v1 v2 con2
|
||||
reverseExpression (ListOp op1 (ListUnaryOp op2 ex2) con1) = ListUnaryOp op2 (reverseExpression (ListOp op1 ex2 con1))
|
||||
reverseExpression (Reduce op1 (Reduce op2 ex2 u1 u2 con2) v1 v2 con1) = Reduce op2 (reverseExpression (Reduce op1 ex2 v1 v2 con1)) u1 u2 con2
|
||||
reverseExpression (Reduce op1 (ListOp op2 ex2 con2) v1 v2 con1) = ListOp op2 (reverseExpression (Reduce op1 ex2 v1 v2 con1)) con2
|
||||
reverseExpression (Reduce op1 (ListUnaryOp op2 ex2) v1 v2 con1) = ListUnaryOp op2 (reverseExpression (Reduce op1 ex2 v1 v2 con1))
|
||||
reverseExpression (ListUnaryOp op1 (ListOp op2 ex2 con2)) = ListOp op2 (reverseExpression (ListUnaryOp op1 ex2)) con2
|
||||
reverseExpression (ListUnaryOp op1 (Reduce op2 ex2 v1 v2 con2)) = Reduce op2 (reverseExpression (ListUnaryOp op1 ex2)) v1 v2 con2
|
||||
reverseExpression (ListUnaryOp op1 (ListUnaryOp op2 ex2)) = ListUnaryOp op2 (reverseExpression (ListUnaryOp op1 ex2))
|
||||
reverseExpression e = e
|
||||
|
||||
|
||||
@@ -19,10 +19,13 @@ 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) = Prettyprinter.list [printExpression x | x <- ex]
|
||||
printExpression (ExplicitReduce op lst v1 v2 cond coer) = "foldl1" <+> enclose "(" ")" ("\\" <+> pretty v1 <+> pretty v2 <+> "->" <+> printExpression cond) <+> enclose "(" ")" (printExpression lst)
|
||||
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 "only-element" lst coer)
|
||||
| toCardinality (cardinalityCoercion (returnCoercion lst)) == Bounds (0, 1) = "fromJust" <+> enclose "(" ")" (nest 4 (line <> printExpression lst))
|
||||
| otherwise = "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) =
|
||||
@@ -88,7 +91,9 @@ printIf cond thenBlock elseBlock = "if" <+> cond <+> nest 4 ( line <>
|
||||
-- |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 = printCoercion (MakeCoercion ts crd) d <> printTypeCoercion t
|
||||
printCoercion (MakeCoercion (MakeIdCoercion _: ts) crd) d = printCoercion (MakeCoercion ts crd) d
|
||||
printCoercion (MakeCoercion (MakeSuperCoercion _ _: ts) crd) d = d <> "Super" <+> printCoercion (MakeCoercion ts crd) d
|
||||
printCoercion (MakeCoercion (MakeTypeCoercion {}: ts) crd) d = printCoercion (MakeCoercion ts crd) d
|
||||
|
||||
printCardinalityCoercion :: CardinalityCoercion -> Doc a -> Doc a
|
||||
printCardinalityCoercion (MakeCardinalityIdCoercion _) d = d
|
||||
@@ -98,11 +103,12 @@ printCardinalityCoercion (MakeNothing2ListCoercion _ _) d = "[]"
|
||||
printCardinalityCoercion (MakeMaybe2ListCoercion _ _) d = "maybeToList" <+> enclose "(" ")" d
|
||||
printCardinalityCoercion (MakeObject2MaybeCoercion _ _) d = "fromJust" <+> enclose "(" ")" d
|
||||
printCardinalityCoercion (MakeObject2ListCoercion _ _) d = "[" <> d <> "]"
|
||||
printCardinalityCoercion (MakeOneOfCoercion _) d = d
|
||||
|
||||
printTypeCoercion :: TypeCoercion -> Doc a
|
||||
printTypeCoercion (MakeIdCoercion _) = emptyDoc
|
||||
printTypeCoercion (MakeSuperCoercion _ _) = "Super"
|
||||
printTypeCoercion (MakeTypeCoercion _ _ t) = pretty t
|
||||
printTypeCoercion :: TypeCoercion -> Doc a -> Doc a
|
||||
printTypeCoercion (MakeIdCoercion _) v = emptyDoc
|
||||
printTypeCoercion (MakeSuperCoercion _ _) v = v <> "Super"
|
||||
printTypeCoercion (MakeTypeCoercion _ _ t) v = pretty t
|
||||
|
||||
-- |Converts a list of type attributes to a Doc with a list of variable names
|
||||
printVariableNames :: [TypeAttribute] -> Doc a
|
||||
|
||||
@@ -121,12 +121,28 @@ 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 (Reduce op lst v1 v2 cond) =
|
||||
case checkExpression defT symbolMap lst of
|
||||
Left err -> Left $ ErrorInsideFunction $ op ++ ": " ++ show err
|
||||
Right checkedLst -> let it = getNextItem symbolMap in
|
||||
case checkExpression defT
|
||||
(addVariables symbolMap [MakeTypeAttribute it (typeFromExpression checkedLst) (Bounds (1,1)) Nothing,
|
||||
MakeTypeAttribute v1 (typeFromExpression checkedLst) (Bounds (1,1)) Nothing,
|
||||
MakeTypeAttribute v2 (typeFromExpression checkedLst) (Bounds (1,1)) Nothing])
|
||||
(replaceVar cond it) of
|
||||
Left err -> Left $ ErrorInsideFunction $ op ++ ": " ++ show err
|
||||
Right condType -> case returnCoercion condType `coercionIncluded` head [snd3 x | x <- listOps, fst3 x == op] of
|
||||
Left err -> Left $ ErrorInsideFunction $ op ++ ": " ++ show err
|
||||
Right checkedCond -> Right $ ExplicitReduce op checkedLst v1 v2 (changeCoercion condType checkedCond) (head [trd3 x | x <- listOps, fst3 x == op])
|
||||
where
|
||||
listOps = listFunctionTypes (returnCoercion checkedLst) (returnCoercion condType)
|
||||
|
||||
checkExpression defT symbolMap (ListOp op lst cond) =
|
||||
case checkExpression defT symbolMap lst of
|
||||
Left err -> Left $ ErrorInsideFunction $ op ++ ": " ++ show err
|
||||
Right checkedLst -> if toCardinality (cardinalityCoercion (returnCoercion checkedLst)) == Bounds(1, 1)
|
||||
Right checkedLst -> {-if toCardinality (cardinalityCoercion (returnCoercion checkedLst)) == Bounds(1, 1)
|
||||
then Left $ ListOperationNotOnList $ show op ++ ": " ++ show lst
|
||||
else let it = getNextItem symbolMap in
|
||||
else -}let it = getNextItem symbolMap in
|
||||
case checkExpression defT
|
||||
(addVariables symbolMap [MakeTypeAttribute it (typeFromExpression checkedLst) (Bounds (1,1)) Nothing])
|
||||
(replaceVar cond it) of
|
||||
@@ -139,9 +155,9 @@ checkExpression defT symbolMap (ListOp op lst cond) =
|
||||
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)
|
||||
Right checkedLst -> {-if toCardinality (cardinalityCoercion (returnCoercion checkedLst)) == Bounds(1, 1)
|
||||
then Left $ ListOperationNotOnList $ show op ++ ": " ++ show lst
|
||||
else if op `elem` map fst (listUnaryFunctionTypes (returnCoercion checkedLst))
|
||||
else -}if op `elem` map fst (listUnaryFunctionTypes (returnCoercion checkedLst))
|
||||
then Right $ ExplicitListUnaryOp op checkedLst (head [snd x | x <- listUnaryFunctionTypes (returnCoercion checkedLst), fst x == op])
|
||||
else Left $ UndefinedFunction op
|
||||
checkExpression _ _ (Keyword k) = Right $ ExplicitKeyword k
|
||||
@@ -152,7 +168,11 @@ checkExpression defT symbolMap (PathExpression ex1 (Variable b)) =
|
||||
Left err -> Left $ UndefinedVariable $ show (typeName type1) ++ " -> " ++ b
|
||||
Right exp2 -> case Bounds(1, 1) `cardinalityIncluded` crd1 of
|
||||
Left err -> Left $ PathExpressionOnList (show ex1)
|
||||
Right c -> Right $ ExplicitPath (changeCoercion exp1 ((returnCoercion exp1){cardinalityCoercion = c})) exp2 (returnCoercion exp2)
|
||||
Right c -> if MakeCondition Nothing (Keyword "one-of") `elem` conditions (typeFromExpression exp1)
|
||||
then Right $ ExplicitPath (changeCoercion exp1 ((returnCoercion exp1){cardinalityCoercion = c})) (changeCoercion exp2 exp2C) exp2C
|
||||
else Right $ ExplicitPath (changeCoercion exp1 ((returnCoercion exp1){cardinalityCoercion = c})) exp2 (returnCoercion exp2)
|
||||
where
|
||||
exp2C = MakeCoercion (typeCoercion $ returnCoercion exp2) (MakeOneOfCoercion (Bounds (1,1)))
|
||||
where
|
||||
type1 = typeFromExpression exp1
|
||||
crd1 = toCardinality $ cardinalityCoercion $ returnCoercion exp1
|
||||
|
||||
Reference in New Issue
Block a user