diff --git a/src/Model/Type.hs b/src/Model/Type.hs index a2528b5..5ead1e6 100644 --- a/src/Model/Type.hs +++ b/src/Model/Type.hs @@ -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 diff --git a/src/Parser/Expression.hs b/src/Parser/Expression.hs index 7c57b11..414b2b2 100644 --- a/src/Parser/Expression.hs +++ b/src/Parser/Expression.hs @@ -247,9 +247,17 @@ listOpParser = Left _ -> return lst Right o -> do - con <- between (lexeme $ char '[') (lexeme $ char ']') expressionParser - exp <- nestedPostOp lst - return $ reverseExpression $ ListOp (Text.unpack o) exp con + 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 -- |Parses nested post operations on lists nestedPostOp :: Expression -> Parser Expression @@ -271,10 +279,17 @@ nestedListOp ex = case op of Left er -> return ex Right o -> - do - con <- between (lexeme $ char '[') (lexeme $ char ']') expressionParser - exp <- nestedPostOp ex - return $ reverseExpression $ ListOp (Text.unpack o) exp con + 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 -- |Parses a path expression (a -> b) in Rosetta into an Expression @@ -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 diff --git a/src/PrettyPrinter/Expression.hs b/src/PrettyPrinter/Expression.hs index 0d337dc..3fbeac9 100644 --- a/src/PrettyPrinter/Expression.hs +++ b/src/PrettyPrinter/Expression.hs @@ -19,15 +19,18 @@ 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)= - pretty (uncapitalize $ typeName $ typeFromExpression ex1) <> pretty (capitalize var) <+> nest 4 (line <> - enclose "(" ")" (printCoercion (returnCoercion ex1) (printExpression (ex1{returnCoercion = MakeCoercion [MakeIdCoercion (typeFromExpression ex1)] (MakeCardinalityIdCoercion (Bounds (1,1)))})))) +printExpression (ExplicitPath ex1 (ExplicitVariable var ret) returnCoerce) = + pretty (uncapitalize $ typeName $ typeFromExpression ex1) <> pretty (capitalize var) <+> nest 4 (line <> + enclose "(" ")" (printCoercion (returnCoercion ex1) (printExpression (ex1{returnCoercion = MakeCoercion [MakeIdCoercion (typeFromExpression ex1)] (MakeCardinalityIdCoercion (Bounds (1,1)))})))) printExpression ExplicitPath {} = error "This should never happen. Path Expression 2nd argument is not variable" printExpression (ExplicitFunction "exists" args returnCoerce) | toCardinality (cardinalityCoercion (snd (head args))) == Bounds (0, 1) = printCoercion returnCoerce "isJust" <+> enclose "(" ")" (printCoercion (snd $ head args) (printExpression (fst $ head args))) @@ -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 diff --git a/src/Semantic/ExpressionChecker.hs b/src/Semantic/ExpressionChecker.hs index d727a78..8341b04 100644 --- a/src/Semantic/ExpressionChecker.hs +++ b/src/Semantic/ExpressionChecker.hs @@ -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