Pattern match sum types

wasm-calc11/demo/draw.calc

@@ -21,22 +21,22 @@ function drawBounded(
 ) -> (Int64,Int64,Int64) { 
   let maxWidth: Int64 = 600; 
   let maxHeight: Int64 = 600; 
-  let (r,g,b) = color; 
+  let (r, g, b) = color; 
   draw(
     clamp(0, maxWidth, x), clamp(0, maxHeight, y), r, g, b
   ); 
-  (r,g,b)
+  (r, g, b)
 }
 
 function cycle(color: (Int64,Int64,Int64)) -> (Int64,
 Int64,
-Int64) { let (r,g,b) = color;  (g,b,r)}
+Int64) { let (r, g, b) = color;  (g, b, r)}
 
 function initial(index: Int64) -> (Int64,Int64,Int64) { 
   let r = clamp(0, 255, index * 2); 
   let g = clamp(0, 255, 255 - r); 
   let b = clamp(0, 255, r * 3); 
-  (r,g,b)
+  (r, g, b)
 }
 
 export function test() -> Void { 

wasm-calc11/src/Calc/Ability/Check.hs

@@ -156,6 +156,9 @@ abilityExpr (EBox ann a) = do
   -- we'll need to account for other allocations in future
   tell (S.singleton $ AllocateMemory ann)
   EBox ann <$> abilityExpr a
+abilityExpr (EConstructor ann constructor as) = do
+  tell (S.singleton $ AllocateMemory ann)
+  EConstructor ann constructor <$> traverse abilityExpr as
 abilityExpr (EApply ann fn args) = do
   isImport <- asks (S.member fn . aeImportNames)
   if isImport

wasm-calc11/src/Calc/ExprUtils.hs

@@ -90,3 +90,4 @@ getOuterPatternAnnotation (PVar ann _) = ann
 getOuterPatternAnnotation (PTuple ann _ _) = ann
 getOuterPatternAnnotation (PLiteral ann _) = ann
 getOuterPatternAnnotation (PBox ann _) = ann
+getOuterPatternAnnotation (PConstructor ann _ _) = ann

wasm-calc11/src/Calc/Linearity/Decorate.hs

@@ -94,6 +94,12 @@ decoratePattern (PLiteral ty prim) =
 decoratePattern (PBox ty pat) = do
   (decoratedPat, innerIdents) <- decoratePattern pat
   pure (PBox (ty, dropForType ty) decoratedPat, innerIdents)
+decoratePattern (PConstructor ty constructor pats) = do
+  decoratedPatsAndIdents <- traverse decoratePattern pats
+
+  let allIdents = foldMap snd decoratedPatsAndIdents
+
+  pure (PConstructor (ty, dropForType ty) constructor (fst <$> decoratedPatsAndIdents), allIdents)
 decoratePattern (PTuple ty p ps) = do
   (decoratedPat, innerIdents) <- decoratePattern p
   decoratedPatsAndIdents <- traverse decoratePattern ps

wasm-calc11/src/Calc/Parser/Expr.hs

@@ -201,7 +201,7 @@ constructorParser =
         stringLiteral ")"
         pure args
    in label "constructor" $ addLocation $ do
-        constructor <- constructorParserInternal
+        constructor <- myLexeme constructorParserInternal
         args <- try argsParser <|> pure mempty
         pure $ EConstructor mempty constructor args
 

wasm-calc11/src/Calc/Parser/Pattern.hs

@@ -19,11 +19,12 @@ patternParser =
   label
     "pattern match"
     ( orInBrackets
-        ( try patTupleParser
-            <|> try patWildcardParser
-            <|> try patVariableParser
-            <|> patBoxParser
+        ( try patWildcardParser
             <|> patPrimParser
+            <|> try patVariableParser
+            <|> try patBoxParser
+            <|> patConstructorParser
+            <|> patTupleParser
         )
     )
 
@@ -71,3 +72,26 @@ patBoxParser = label "box" $
 patPrimParser :: Parser ParserPattern
 patPrimParser =
   myLexeme $ withLocation PLiteral primParser
+
+----
+
+patArgsParser :: Parser [ParserPattern]
+patArgsParser =
+  let argsWithBrackets = do
+        stringLiteral "("
+        args <- sepBy1 patternParser (stringLiteral ",")
+        stringLiteral ")"
+        pure args
+   in try argsWithBrackets <|> pure []
+
+patConstructorParser :: Parser ParserPattern
+patConstructorParser =
+  let parser = do
+        cons <- myLexeme constructorParserInternal
+        args <- patArgsParser
+        pure (cons, args)
+   in withLocation
+        ( \loc (cons, args) ->
+            PConstructor loc cons args
+        )
+        parser

wasm-calc11/src/Calc/Typecheck/Elaborate.hs

@@ -13,6 +13,7 @@ import Calc.Typecheck.Helpers
 import Calc.Typecheck.Infer
 import Calc.Typecheck.Substitute
 import Calc.Typecheck.Types
+import Calc.Types.Data
 import Calc.Types.Expr
 import Calc.Types.Function
 import Calc.Types.Global
@@ -90,9 +91,13 @@ elaborateModule
             mdMemory = elaborateMemory <$> mdMemory,
             mdGlobals = globals,
             mdTests = tests,
-            mdDataTypes = mempty
+            mdDataTypes = elaborateDataType <$> mdDataTypes
           }
 
+elaborateDataType :: Data ann -> Data (Type ann)
+elaborateDataType (Data dtName vars cons) =
+  Data dtName vars ((fmap . fmap) (\ty -> ty $> ty) cons)
+
 -- check a test expression has type `Bool`
 -- later we'll also check it does not use any imports
 elaborateTest :: Test ann -> TypecheckM ann (Test (Type ann))

wasm-calc11/src/Calc/Typecheck/Error/TypeError.hs

@@ -40,7 +40,12 @@ data TypeError ann
   | ManualMemoryAccessOutsideLimit ann Natural Natural -- limit, value
   | CantSetConstant ann Identifier
   | ConstructorNotFound ann Constructor
+  | UnknownGenericInConstructor ann Constructor TypeVar
   | PatternMatchError (PatternMatchError ann)
+  | DataTypeMismatch ann DataName DataName -- expected, actual
+  | StoringNonPrimitiveType ann (Type ann)
+  | LoadingNonPrimitiveType ann (Type ann)
+  | UnknownLoadType ann
   deriving stock (Eq, Ord, Show)
 
 positionFromAnnotation ::
@@ -69,6 +74,69 @@ typeErrorDiagnostic input e =
    in case e of
         (PatternMatchError patternMatchError) ->
           patternMatchErrorDiagnostic input patternMatchError
+        (UnknownLoadType ann) ->
+          Diag.addReport diag $
+            Diag.Err
+              Nothing
+              ( prettyPrint "Can't load into unknown type."
+              )
+              ( catMaybes
+                  [ (,)
+                      <$> positionFromAnnotation
+                        filename
+                        input
+                        ann
+                      <*> pure
+                        ( Diag.This
+                            ( prettyPrint
+                                "Consider providing a type annotation"
+                            )
+                        )
+                  ]
+              )
+              []
+        (StoringNonPrimitiveType ann ty) ->
+          Diag.addReport diag $
+            Diag.Err
+              Nothing
+              ( prettyPrint "Can only store primitive types"
+              )
+              ( catMaybes
+                  [ (,)
+                      <$> positionFromAnnotation
+                        filename
+                        input
+                        ann
+                      <*> pure
+                        ( Diag.This
+                            ( prettyPrint $
+                                "This is trying to store " <> PP.pretty ty
+                            )
+                        )
+                  ]
+              )
+              []
+        (LoadingNonPrimitiveType ann ty) ->
+          Diag.addReport diag $
+            Diag.Err
+              Nothing
+              ( prettyPrint "Can only load primitive types"
+              )
+              ( catMaybes
+                  [ (,)
+                      <$> positionFromAnnotation
+                        filename
+                        input
+                        ann
+                      <*> pure
+                        ( Diag.This
+                            ( prettyPrint $
+                                "This is trying to load " <> PP.pretty ty
+                            )
+                        )
+                  ]
+              )
+              []
         (ExpectedInteger ann tyPrim) ->
           Diag.addReport diag $
             Diag.Err
@@ -111,6 +179,27 @@ typeErrorDiagnostic input e =
                   ]
               )
               []
+        (UnknownGenericInConstructor ann constructor var) ->
+          Diag.addReport diag $
+            Diag.Err
+              Nothing
+              ( prettyPrint $ "Constructor " <> PP.pretty constructor <> " does not provide a type for var" <> PP.pretty var
+              )
+              ( catMaybes
+                  [ (,)
+                      <$> positionFromAnnotation
+                        filename
+                        input
+                        ann
+                      <*> pure
+                        ( Diag.This
+                            ( prettyPrint
+                                "Perhaps add a type annotation so that we know what should go here?"
+                            )
+                        )
+                  ]
+              )
+              []
         (CantSetConstant ann ident) ->
           Diag.addReport diag $
             Diag.Err
@@ -132,6 +221,26 @@ typeErrorDiagnostic input e =
                   ]
               )
               []
+        (DataTypeMismatch ann expected actual) ->
+          Diag.addReport diag $
+            Diag.Err
+              Nothing
+              ( prettyPrint $ "Unexpected data type. Found " <> PP.pretty actual
+              )
+              ( catMaybes
+                  [ (,)
+                      <$> positionFromAnnotation
+                        filename
+                        input
+                        ann
+                      <*> pure
+                        ( Diag.This
+                            ( prettyPrint $ "Expected " <> PP.pretty expected
+                            )
+                        )
+                  ]
+              )
+              []
         (ConstructorNotFound ann constructor) ->
           Diag.addReport diag $
             Diag.Err

wasm-calc11/src/Calc/Typecheck/Generalise.hs

@@ -10,7 +10,7 @@ import Calc.Typecheck.Types
 import Calc.Types.Type
 import Calc.Types.TypeVar
 import Control.Monad.State
-import qualified Data.HashMap.Strict as HM
+import qualified Data.Map.Strict as M
 import qualified Data.Set as S
 import GHC.Natural
 
@@ -20,10 +20,10 @@ freshUnificationVariable = do
   modify (\tcs -> tcs {tcsUnique = tcsUnique tcs + 1})
   gets tcsUnique
 
-allFresh :: S.Set TypeVar -> TypecheckM ann (HM.HashMap TypeVar Natural)
+allFresh :: S.Set TypeVar -> TypecheckM ann (M.Map TypeVar Natural)
 allFresh generics =
   let freshOne typeVar =
-        HM.singleton typeVar <$> freshUnificationVariable
+        M.singleton typeVar <$> freshUnificationVariable
    in mconcat <$> traverse freshOne (S.toList generics)
 
 -- given a type, replace anything that should be generic with unification
@@ -34,7 +34,7 @@ generalise generics ty =
     fresh <- allFresh generics
     pure $ generaliseInternal fresh ty
 
-generaliseMany :: S.Set TypeVar -> [Type ann] -> TypecheckM ann (HM.HashMap TypeVar Natural, [Type ann])
+generaliseMany :: S.Set TypeVar -> [Type ann] -> TypecheckM ann (M.Map TypeVar Natural, [Type ann])
 generaliseMany generics tys =
   do
     fresh <- allFresh generics
@@ -43,9 +43,9 @@ generaliseMany generics tys =
 
 -- given a type, replace anything that should be generic with unification
 -- variables so that we know to replace them with types easily
-generaliseInternal :: HM.HashMap TypeVar Natural -> Type ann -> Type ann
+generaliseInternal :: M.Map TypeVar Natural -> Type ann -> Type ann
 generaliseInternal fresh (TVar ann var) =
-  case HM.lookup var fresh of
+  case M.lookup var fresh of
     Just nat ->
       TUnificationVar ann nat
     Nothing -> error "oh no generalise error"