I don't even know anymore

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

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
 

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

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