kind of working,

still needs testing.
Added output return coercion in expression
Fixed formatting bugs

resources/Rosetta/test-multiple.rosetta

@@ -11,6 +11,14 @@ type Obs:
   exchangeRate ExchangeRate (0..1)
   condition: one-of
 
+func Konst:
+  inputs:
+    constant number (1..1)
+  output:
+    observable Obs (1..1)
+  assign-output observable -> constant:
+    constant
+
 func ExchangeRateFunc:
   inputs:
     from int (1..1)
@@ -78,7 +86,7 @@ func MkExpired:
 
 func MkOne:
   inputs:
-    currency UnitType (1..1)
+    currency int (1..1)
   output:
     contract Contract (1..1)
   assign-output contract -> one -> currency:
@@ -105,3 +113,98 @@ func MkBoth:
     left
   assign-output contract -> both -> right:
     right
+
+func MkThereafter:
+  inputs:
+    earlier  Contract (1..1)
+    later Contract (1..1)
+  output:
+    contract Contract (1..1)
+  assign-output contract -> thereafter -> earlier:
+    earlier
+  assign-output contract -> thereafter -> later:
+    later
+
+func MkGive:
+  inputs:
+    subContract Contract (1..1)
+  output:
+    contract Contract (1..1)
+  assign-output contract -> give -> contract:
+    subContract
+
+func MkTruncate:
+  inputs:
+    truncateTo string      (1..1)
+    subContract Contract (1..1)
+  output:
+    contract Contract (1..1)
+  assign-output contract -> truncate -> contract:
+    subContract
+  assign-output contract -> truncate -> expiryDate:
+    truncateTo
+
+func MkScale:
+  inputs:
+    observable Obs (1..1)
+    subContract Contract (1..1)
+  output:
+    contract Contract (1..1)
+  assign-output contract -> scale -> contract:
+    subContract
+  assign-output contract -> scale -> observable:
+    observable
+
+func MkGet:
+  inputs:
+    subContract Contract (1..1)
+  output:
+    contract Contract (1..1)
+  assign-output contract -> get -> contract:
+    subContract
+
+func MkAnytime:
+  inputs:
+    subContract Contract (1..1)
+  output:
+    contract Contract (1..1)
+  assign-output contract -> anytime -> contract:
+    subContract
+
+func MkAnd:
+  inputs:
+    left Contract (1..1)
+    right Contract (1..1)
+  output:
+    contract Contract (1..1)
+  assign-output contract:
+    MkThereafter(MkBoth(left,right),MkOr(left,right))
+
+func ZeroCouponBond:
+  inputs:
+    maturesOn string   (1..1)  <"Date the bond matures on">
+    amount number     (1..1)  <"Amount of the bond is worth">
+    currency int (1..1)  <"Unit the bond is denoted in">
+  output:
+    contract Contract (1..1)
+  assign-output contract:
+    MkGet (MkTruncate(maturesOn, MkScale(Konst(amount),MkOne(currency))))
+
+func Perhaps:
+  inputs:
+    endDate  string     (1..1)
+    contract Contract (1..1)
+  output:
+    perhaps Contract (1..1)
+  assign-output perhaps:
+    MkTruncate(endDate,MkOr(contract,MkZero()))
+
+func EuropeanOption:
+  inputs:
+    endDate  string     (1..1)
+    contract Contract (1..1)
+  output:
+    option Contract (1..1)
+
+  assign-output option:
+    MkGet(Perhaps(endDate,contract))

resources/Rosetta/test-period.rosetta

@@ -1,13 +1,21 @@
 namespace test.period : <"Something">
 version "${version.ok}"
 
-enum PeriodEnum: <"The enumerated values to specified the period, e.g. day, week.">
-    D displayName "day" <"Day">
-    M displayName "month" <"Month">
-    Y displayName "year" <"Year">
 
-type Period: <"description">
+type ExchangeRate:
-    periodMultiplier int (1..1) <"A time period multiplier, e.g. 1, 2 or 3 etc. A negative value can be used when specifying an offset relative to another date, e.g. -2 days.">
+  from int (1..1)
-    testMany boolean (0..*) <"Test many">
+  to int (1..1)
-    testSome boolean (1..*) <"Test some">
+  
-    testMaybeOne int (0..1) <"Test zero or one">
+
+type Obs:
+  constant number (0..1)
+  exchangeRate ExchangeRate (0..1)
+  condition: one-of
+
+func Konst:
+  inputs:
+    constant number (1..1)
+  output:
+    observable Obs (1..1)
+  assign-output observable -> constant:
+    constant

src/Model/Type.hs

@@ -58,6 +58,18 @@ data ExplicitExpression = ExplicitEmpty
     | ExplicitIfSimple {cond :: (ExplicitExpression, Coercion), block1 :: (ExplicitExpression, Coercion), returnCoercion :: Coercion}
     | ExplicitIfElse {cond :: (ExplicitExpression, Coercion), block1 :: (ExplicitExpression, Coercion), block2 :: (ExplicitExpression, Coercion), returnCoercion :: Coercion}
 
+changeCoercion :: ExplicitExpression -> Coercion -> ExplicitExpression
+changeCoercion ExplicitEmpty _ = ExplicitEmpty
+changeCoercion (ExplicitVariable n _) c = ExplicitVariable n c 
+changeCoercion (Value n _) c = Value n c
+changeCoercion (ExplicitList e) _ = ExplicitList e
+changeCoercion (ExplicitKeyword n) _ = ExplicitKeyword n
+changeCoercion (ExplicitParens e) _ = ExplicitParens e
+changeCoercion (ExplicitPath s n _) c = ExplicitPath s n c
+changeCoercion (ExplicitFunction n args _) c = ExplicitFunction n args c 
+changeCoercion (ExplicitIfSimple cond block _) c = ExplicitIfSimple cond block c
+changeCoercion (ExplicitIfElse cond block block2 _) c = ExplicitIfElse cond block block2 c       
+
 instance Show ExplicitExpression where
     show (ExplicitVariable name coer) = show $ "Variable: " ++ name
     show (Value name coer) = show $ "Value: " ++ name
@@ -139,7 +151,8 @@ toHaskell :: Type -> Type
 toHaskell a
     | typeName a == "int" = BasicType "Integer"
     | typeName a == "boolean" = BasicType "Boolean"
-    | typeName a == "real" = BasicType "Double"
+    | typeName a == "number" = BasicType "Double"
+    | typeName a == "string" = BasicType "String"
     | otherwise = a
 
 coercionType :: [TypeCoercion] -> Type

src/Parser/Expression.hs

@@ -69,7 +69,10 @@ listParser =
 variableParser :: Parser Expression
 variableParser =
     do
-        Variable <$> camelNameParser
+        name <- camelNameParser
+        if name == "endDate," then error "lool"
+        else return $ Variable name
+        --Variable <$> camelNameParser
 
 -- |Parses an integer in Rosetta into an Expression
 integerParser :: Parser Expression

src/PrettyPrinter/Expression.hs

@@ -5,45 +5,45 @@ module PrettyPrinter.Expression where
 import Model.Type
 import Prettyprinter
 import Semantic.ExpressionChecker(coercionIncluded)
+import Utils.Utils
 
-printExpression :: ExplicitExpression -> Coercion -> Doc a
+printExpression :: ExplicitExpression -> Doc a
-printExpression ExplicitEmpty _ = "[]" 
+printExpression ExplicitEmpty = "[]" 
-printExpression (ExplicitVariable name coer) out = case coer `coercionIncluded` out of 
+printExpression (ExplicitVariable name coer) = printCoercion coer $ pretty name
-    Left err -> error $ show coer ++ "//" ++ show out --err
+printExpression (Value s coer) = printCoercion coer $ pretty s
-    Right c -> printCoercion c $ pretty name
+printExpression (ExplicitKeyword k) = pretty k
-printExpression (Value s coer) out = case coer `coercionIncluded` out of
+printExpression (ExplicitParens ex) = "(" <> printExpression ex <> ")"
-    Left err -> error $ show err 
+printExpression (ExplicitList ex)  = list [printExpression x | x <- ex]
-    Right c -> printCoercion c $ pretty s
+printExpression (ExplicitPath ex1 ex2 returnCoerce) = printCoercion (returnCoercion ex1) (printExpression ex1) <+> "->" <+> printCoercion (returnCoercion ex2) (printExpression ex2)
-printExpression (ExplicitKeyword k) out = pretty k
+printExpression (ExplicitFunction "exists" args returnCoerce) = printCoercion returnCoerce "isJust" <+> printCoercion (snd $ head args) (printExpression (fst $ head args))
-printExpression (ExplicitParens ex) out = "(" <> printExpression ex out <> ")"
+printExpression (ExplicitFunction "is absent" args returnCoerce) = printCoercion returnCoerce "isNothing" <+> printCoercion (snd $ head args) (printExpression (fst $ head args))
-printExpression (ExplicitList ex) out = list [printExpression x out | x <- ex]
+printExpression (ExplicitFunction "single exists" args returnCoerce) = printCoercion returnCoerce "length" <+> printCoercion (snd $ head args) (printExpression (fst $ head args)) <+> "==" <+> "1"
-printExpression (ExplicitPath ex1 ex2 returnCoerce) out = printCoercion (returnCoercion ex1) (printExpression ex1 (returnCoercion ex1)) <+> "->" <+> printCoercion (returnCoercion ex2) (printExpression ex2 out)
+printExpression (ExplicitFunction "multiple exists" args returnCoerce) = printCoercion returnCoerce "length" <+> printCoercion (snd $ head args) (printExpression (fst $ head args)) <+> ">" <+> "1" 
-printExpression (ExplicitFunction "exists" args returnCoerce) out = printCoercion returnCoerce "isJust" <+> printCoercion (snd $ head args) (printExpression (fst $ head args) out)
+printExpression (ExplicitFunction "count" args returnCoerce) = printCoercion returnCoerce "length" <+> printCoercion (snd $ head args) (printExpression (fst $ head args))
-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) = printCoercion (snd $ head args) (printExpression (fst $ head args)) <+> "==" <+> printCoercion (snd $ head $ tail args) (printExpression (fst $ head $ tail args))
-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) = printCoercion (snd $ head args) (printExpression (fst $ head args)) <+> "/=" <+> printCoercion (snd $ head $ tail args) (printExpression (fst $ head $ tail args))
-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 "any =" args returnCoerce) = printCoercion (snd $ head $ tail args) (printExpression (fst $ head $ tail args)) <+> "`elem`" <+> printCoercion (snd $ head args) (printExpression (fst $ head args))
-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) = printCoercion (snd $ head $ tail args) (printExpression (fst $ head $ tail args)) <+> "`notElem`" <+> printCoercion (snd $ head args) (printExpression (fst $ head args))
-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 "all =" args returnCoerce) = "all (Eq)" <+> printCoercion (snd $ head $ tail args) (printExpression (fst $ head $ tail args)) <+> printCoercion (snd $ head args) (printExpression (fst $ head args))
-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 "and" args returnCoerce) = printCoercion (snd $ head args) (printExpression (fst $ head args)) <+> "&&" <+> printCoercion (snd $ head $ tail args) (printExpression (fst $ head $ tail args))
-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 "or" args returnCoerce) = printCoercion (snd $ head args) (printExpression (fst $ head args)) <+> "||" <+> printCoercion (snd $ head $ tail args) (printExpression (fst $ head $ tail args))
-printExpression (ExplicitFunction name args returnCoerce) out = pretty name <+> tupled (zipWith printCoercion [c | (e,c) <- args] [printExpression e out | (e, c) <- args])
+printExpression (ExplicitFunction name args returnCoerce) = 
-printExpression (ExplicitIfSimple cond thenBlock returnCoercion) out = 
+    if null printedArgs then pretty (uncapitalize name) 
-    "if" <+> printCoercion (snd cond) (printExpression (fst cond) (MakeCoercion [MakeIdCoercion (BasicType "Boolean")] (MakeCardinalityIdCoercion (Bounds (1, 1))))) <+> 
+    else  "(" <> pretty (uncapitalize name) <+> printCoercion returnCoerce (hsep printedArgs) <> ")"
-    "then" <+> printCoercion (snd thenBlock) (printExpression (fst thenBlock) out) <+> 
+    where printedArgs = zipWith printCoercion [c | (e,c) <- args] [printExpression e | (e, c) <- args]
-    "else" <+> case MakeCoercion [MakeIdCoercion $ coercionType $ typeCoercion returnCoercion] (MakeCardinalityIdCoercion (Bounds (0, 0))) `coercionIncluded` out of
+printExpression (ExplicitIfSimple cond thenBlock returnCoercion) = 
+    "if" <+> printCoercion (snd cond) (printExpression (fst cond)) <+> 
+    "then" <+> printCoercion (snd thenBlock) (printExpression (fst thenBlock)) <+> 
+    "else" <+> case MakeCoercion [MakeIdCoercion $ coercionType $ typeCoercion returnCoercion] (MakeCardinalityIdCoercion (Bounds (0, 0))) `coercionIncluded` returnCoercion of
         Left err -> error $ show err
         Right c -> printCoercion c emptyDoc
-printExpression (ExplicitIfElse cond thenBlock elseBlock returnCoercion) out = 
+printExpression (ExplicitIfElse cond thenBlock elseBlock returnCoercion) = 
-    "if" <+> printCoercion (snd cond) (printExpression (fst cond) (MakeCoercion [MakeIdCoercion (BasicType "Boolean")] (MakeCardinalityIdCoercion (Bounds (1, 1))))) <+> 
+    "if" <+> printCoercion (snd cond) (printExpression (fst cond)) <+> 
-    "then" <+> printCoercion (snd thenBlock) (printExpression (fst thenBlock) out) <+> 
+    "then" <+> printCoercion (snd thenBlock) (printExpression (fst thenBlock)) <+> 
-    "else" <+> printCoercion (snd elseBlock) (printExpression (fst elseBlock) out)
+    "else" <+> printCoercion (snd elseBlock) (printExpression (fst elseBlock))
 
 -- |Converts a coercion into a haskell string
 printCoercion :: Coercion -> Doc a -> Doc a

src/PrettyPrinter/Function.hs

@@ -8,7 +8,7 @@ import Model.Function
 import PrettyPrinter.General
 import PrettyPrinter.Type
 import Model.Type
-import Utils.Utils (uncapitalize)
+import Utils.Utils (capitalize, uncapitalize)
 
 {-
 Consider all assignments as trees
@@ -42,7 +42,7 @@ printFunction f = show $ vcat [printFunctionSignature (sign f), printFunctionBod
 printFunctionBody :: ExplicitFunction -> Doc a
 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))
+    printAssignmentTree (head $ mergeAssignmentTrees [convertToAssignmentTree (fst exp) (AssignmentLeaf (snd exp)) | exp <- ex])
     --error $ show $ mergeAssignmentTrees [convertToAssignmentTree (fst exp) (AssignmentLeaf (snd exp)) | exp <- ex]
 
 
@@ -55,15 +55,19 @@ printFunctionSignature (MakeFunctionSignature name description inputs output) =
 prettyPrintType :: [Doc x] -> Doc x
 prettyPrintType = align . sep . Prelude.zipWith (<+>) ("::" : repeat "->")
 
-printAssignmentTree :: AssignmentTree -> Coercion -> Doc a
+printAssignmentTree :: AssignmentTree -> Doc a
-printAssignmentTree (AssignmentLeaf exp) coer = printExpression exp coer
+printAssignmentTree (AssignmentLeaf exp) = printExpression exp
-printAssignmentTree (AssignmentNode var typ c) coer
+printAssignmentTree (AssignmentNode var typ c)
     | length c == 1 = case head c of
-        AssignmentLeaf e -> printConstructor typ <+>  "(" <+> printAssignmentTree (head c) coer <> ")" 
+        AssignmentLeaf e -> printAssignmentTree (head c) 
-        AssignmentNode v t _ -> printConstructor typ <> printConstructor t <+> "(" <+> printAssignmentTree (head c) coer <> ")" 
+        AssignmentNode v t _ -> printConstructor typ <> pretty (capitalize v) <+> "(" <> printAssignmentTree (head c) <> ")" 
     | otherwise = case typ of
-        MakeType t _ _ _ _ -> "Make" <> pretty t <+> group (sep [printAssignmentTree child coer | child <- c])
+        MakeType t _ _ _ _ -> "Make" <> pretty t <+> "{" <> hsep (punctuate "," [pretty (uncapitalize t) <> getVarName child <+> "=" <+> printAssignmentTree child | child <- c]) <> "}"
-        BasicType _ -> sep [printAssignmentTree child coer | child <- c]
+        BasicType _ -> sep ["(" <> printAssignmentTree child <> ")" | child <- c]
+
+getVarName :: AssignmentTree -> Doc a
+getVarName (AssignmentLeaf _) = emptyDoc
+getVarName (AssignmentNode var _ _) = pretty (capitalize var)
 
 mergeAssignmentTrees :: [AssignmentTree] -> [AssignmentTree]
 mergeAssignmentTrees [] = []

src/Semantic/ExpressionChecker.hs

@@ -254,7 +254,7 @@ getTypeAttributes (defT : ts) t
     | typeName defT == typeName t = 
         [MakeTypeAttribute {attributeName = attributeName attr, 
             attributeType = toHaskell (attributeType attr), 
-            Model.Type.cardinality = Model.Type.cardinality attr, 
+            Model.Type.cardinality = if MakeCondition Nothing (Keyword "one-of") `elem` conditions defT then Bounds (1,1) else Model.Type.cardinality attr, 
             attributeDescription = attributeDescription attr} 
             | attr <- typeAttributes defT]
     | otherwise = getTypeAttributes ts t

src/Semantic/FunctionChecker.hs

@@ -32,4 +32,7 @@ checkAssignment defT symbs ((assign, ex): assigns) =
         Left err -> Left [err]
         Right checkedA -> case checkAssignment defT symbs assigns of
                 Left err -> Left err
-            Right checked -> Right $ (checkedA, checkedExp) : checked
+                -- Add a final explicit transformation to match the expected output
+                Right checked -> case returnCoercion checkedExp `coercionIncluded` returnCoercion checkedA of
+                    Left err -> Left [err]
+                    Right c -> Right $ (checkedA, changeCoercion checkedExp c) : checked

src/Semantic/TypeChecker.hs

@@ -47,27 +47,6 @@ checkAttributes definedTypes ((MakeTypeAttribute name typ crd desc):as) =
         Left err -> Left err : checkAttributes definedTypes as
         Right checked -> Right (MakeTypeAttribute name checked crd desc) : checkAttributes definedTypes as 
 
-populateAttributeType :: [Type] -> [Type] -> TypeAttribute -> Either TypeCheckError TypeAttribute
-populateAttributeType _ _ (MakeTypeAttribute n (MakeType "int" _ _ _ _) c d ) = Right $ MakeTypeAttribute n (BasicType "Integer") c d 
-populateAttributeType _ _  (MakeTypeAttribute n (MakeType "string" _ _ _ _) c d ) = Right $ MakeTypeAttribute n (BasicType "String") c d 
-populateAttributeType _ _  (MakeTypeAttribute n (MakeType "number" _ _ _ _) c d ) = Right $ MakeTypeAttribute n (BasicType "Double") c d 
-populateAttributeType _ _  (MakeTypeAttribute n (MakeType "boolean" _ _ _ _) c d ) = Right $ MakeTypeAttribute n (BasicType "Bool") c d 
-populateAttributeType _ _  (MakeTypeAttribute n (MakeType "time" _ _ _ _) c d ) = Right $ MakeTypeAttribute n (BasicType "Time") c d 
-populateAttributeType _ _ (MakeTypeAttribute n (BasicType t) c d) = Right $ MakeTypeAttribute n (BasicType t) c d 
-populateAttributeType _ [] t = Left $ UndefinedType $ typeName $ attributeType t
-populateAttributeType t (definedT : ts) typ
-    | definedT == attributeType typ = 
-        let populatedAttr = map (populateAttributeType t t) (typeAttributes definedT) 
-        in
-        if null $ lefts populatedAttr 
-        then Right $ MakeTypeAttribute 
-            (attributeName typ) 
-            (MakeType (typeName definedT) (superType definedT) (typeDescription definedT) (rights populatedAttr) (conditions definedT)) 
-            (cardinality typ)
-            (attributeDescription typ)
-        else Left $ head $ lefts populatedAttr
-    | otherwise = populateAttributeType t ts typ
-
 -- |Checks whether a type is predefined or in the symbol table
 checkAttributeType :: [Type] -> Type -> Either TypeCheckError Type
 checkAttributeType [] t = Left $ UndefinedType $ typeName t