Typecheck those constructor patterns

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

@@ -23,6 +23,7 @@ patternParser =
             <|> try patWildcardParser
             <|> try patVariableParser
             <|> patBoxParser
+            <|> patConstructorParser
             <|> patPrimParser
         )
     )
@@ -71,3 +72,24 @@ patBoxParser = label "box" $
 patPrimParser :: Parser ParserPattern
 patPrimParser =
   myLexeme $ withLocation PLiteral primParser
+
+----
+
+argsParser :: Parser [ParserPattern]
+argsParser = try someP <|> pure []
+  where
+    someP = some patternParser
+
+patConstructorParser :: Parser ParserPattern
+patConstructorParser =
+  let parser = do
+        cons <- myLexeme constructorParserInternal
+        args <- argsParser
+        pure (cons, args)
+   in withLocation
+        ( \loc (cons, args) ->
+            PConstructor loc cons args
+        )
+        parser
+
+

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

@@ -1,6 +1,6 @@
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE NamedFieldPuns #-}
-
+  {-# LANGUAGE LambdaCase #-}
 module Calc.Typecheck.Helpers
   ( runTypecheckM,
     lookupVar,
@@ -12,6 +12,8 @@ module Calc.Typecheck.Helpers
     lookupGlobal,
     arrangeDataTypes,
     calculateMonomorphisedTypes,
+  lookupConstructor,
+  matchConstructorTypesToArgs
   )
 where
 
@@ -138,6 +140,14 @@ identifiersFromPattern pat@(PTuple _ p ps) ty@(TContainer _ tyItems) = do
     (throwError $ PatternMismatch ty pat)
   allIdents <- zipWithM identifiersFromPattern (p : NE.toList ps) (NE.toList tyItems)
   pure $ mconcat allIdents
+identifiersFromPattern (PConstructor ann constructor ps) (TConstructor _ _ tyArgs) = do
+  (_dataTypeName, dataTypeVars, dataTypeArgs) <-
+    lookupConstructor ann constructor
+
+  let filtered = matchConstructorTypesToArgs dataTypeVars tyArgs dataTypeArgs
+
+  allIdents <- zipWithM identifiersFromPattern ps filtered
+  pure $ mconcat allIdents
 identifiersFromPattern pat ty =
   throwError $ PatternMismatch ty pat
 
@@ -203,3 +213,32 @@ calculateMonomorphisedTypes typeVars fnArgTys argTys fallbacks = do
 
 flipMap :: (Hashable v) => HM.HashMap k v -> HM.HashMap v k
 flipMap = HM.fromList . fmap (\(k, v) -> (v, k)) . HM.toList
+
+
+lookupConstructor ::
+  ann ->
+  Constructor ->
+  TypecheckM ann (DataName, [TypeVar], [Type ann])
+lookupConstructor ann constructor = do
+  result <- asks (M.lookup constructor . tceDataTypes)
+  case result of
+    (Just (TCDataType dataType vars args)) ->
+      pure (dataType, vars, args)
+    Nothing ->
+      throwError $ ConstructorNotFound ann constructor
+
+
+
+matchConstructorTypesToArgs :: [TypeVar] -> [Type ann] -> [Type ann] -> [Type ann]
+matchConstructorTypesToArgs dataTypeVars tyArgs dataTypeArgs =
+  let pairs = M.fromList (zip dataTypeVars tyArgs)
+      filteredTyArgs =
+        ( \case
+            TVar _ var -> case M.lookup var pairs of
+              Just ty -> ty
+              Nothing -> error "cannot find"
+            otherTy -> otherTy
+        )
+          <$> dataTypeArgs
+   in filteredTyArgs
+

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

@@ -345,6 +345,24 @@ checkPattern ty@(TContainer _ tyItems) pat@(PTuple _ p ps) = do
   pHead <- checkPattern (NE.head tyItems) p
   pTail <- zipWithM checkPattern (NE.tail tyItems) (NE.toList ps)
   pure (PTuple ty pHead (NE.fromList pTail))
+checkPattern (TConstructor _ tyDataName tyArgs) (PConstructor ann constructor patArgs) = do
+  (dataTypeName, dataTypeVars, dataTypeArgs) <-
+    lookupConstructor ann constructor
+
+  unless (tyDataName == dataTypeName) $
+      error "wrong"
+
+  let filtered = matchConstructorTypesToArgs dataTypeVars tyArgs dataTypeArgs
+
+  typedArgs <- zipWithM checkPattern filtered patArgs
+
+  let fallbackTypes = M.fromList (zip dataTypeVars tyArgs)
+
+  monomorphisedArgs <-
+    calculateMonomorphisedTypes dataTypeVars dataTypeArgs (getOuterPatternAnnotation <$> typedArgs) fallbackTypes
+
+  let ty = TConstructor ann dataTypeName (snd <$> monomorphisedArgs)
+  pure (PConstructor ty constructor typedArgs)
 checkPattern ty pat = throwError $ PatternMismatch ty pat
 
 checkTuple ::
@@ -378,19 +396,6 @@ checkTuple Nothing ann fstExpr restExpr = do
           )
   pure $ ETuple typ typedFst typedRest
 
-matchConstructorTypesToArgs :: [TypeVar] -> [Type ann] -> [Type ann] -> [Type ann]
-matchConstructorTypesToArgs dataTypeVars tyArgs dataTypeArgs =
-  let pairs = M.fromList (zip dataTypeVars tyArgs)
-      filteredTyArgs =
-        ( \case
-            TVar _ var -> case M.lookup var pairs of
-              Just ty -> ty
-              Nothing -> error "cannot find"
-            otherTy -> otherTy
-        )
-          <$> dataTypeArgs
-   in filteredTyArgs
-
 checkConstructor :: Maybe (DataName, [Type ann]) -> ann -> Constructor -> [Expr ann] -> TypecheckM ann (Expr (Type ann))
 checkConstructor maybeTy ann constructor args = do
   (dataTypeName, dataTypeVars, dataTypeArgs) <-
@@ -435,18 +440,6 @@ checkLet maybeReturnTy ann pat expr rest = do
     Left patternMatchError -> throwError (PatternMatchError patternMatchError)
   pure $ ELet (getOuterAnnotation typedRest $> ann) typedPat typedExpr typedRest
 
-lookupConstructor ::
-  ann ->
-  Constructor ->
-  TypecheckM ann (DataName, [TypeVar], [Type ann])
-lookupConstructor ann constructor = do
-  result <- asks (M.lookup constructor . tceDataTypes)
-  case result of
-    (Just (TCDataType dataType vars args)) ->
-      pure (dataType, vars, args)
-    Nothing ->
-      throwError $ ConstructorNotFound ann constructor
-
 checkMatch :: Maybe (Type ann) -> ann -> Expr ann -> NE.NonEmpty (Pattern ann, Expr ann) -> TypecheckM ann (Expr (Type ann))
 checkMatch maybeTy ann matchExpr pats = do
   elabExpr <- infer matchExpr

wasm-calc11/src/Calc/Wasm/FromExpr/Expr.hs

@@ -190,7 +190,22 @@ fromExpr (EPrim (ty, _) prim) =
   WPrim <$> fromPrim ty prim
 fromExpr (EMatch _ expr pats) =
   fromMatch expr pats
-fromExpr (EConstructor {}) = error "fromExpr EConstructor"
+fromExpr (EConstructor (ty,_) _constructor args) = do
+  -- TODO: add the constructor number in
+  wasmType <- liftEither $ scalarFromType ty
+  index <- addLocal Nothing wasmType
+  let allItems = zip [0..] args
+      tupleLength = memorySizeForType ty
+      allocate = WAllocate (fromIntegral tupleLength)
+      offsetList = getOffsetList ty
+  WSet index allocate
+    <$> traverse
+      ( \(i, item) ->
+          (,,) (offsetList !! i)
+            <$> liftEither (scalarFromType (fst $ getOuterAnnotation item))
+            <*> fromExpr item
+      )
+      allItems
 fromExpr (EBlock (_, Just _) _) = do
   error "found drops on block"
 fromExpr (EBlock _ expr) = do

wasm-calc11/src/Calc/Wasm/FromExpr/Helpers.hs

@@ -209,7 +209,7 @@ scalarFromType (TVar _ _) =
   pure Pointer -- all polymorphic variables are Pointer
 scalarFromType (TUnificationVar {}) =
   pure Pointer
-scalarFromType (TConstructor {}) = error "scalarFromType"
+scalarFromType (TConstructor {}) = pure Pointer -- maybe enums will become I8 in future, but for now, it's all pointers
 
 genericArgName :: TypeVar -> Identifier
 genericArgName generic =

wasm-calc11/test/Test/Wasm/WasmSpec.hs

@@ -390,7 +390,7 @@ spec = do
               )-}
             ]
 
-      describe "From expressions" $ do
+      fdescribe "From expressions" $ do
         traverse_ testWithInterpreter testVals
 
       describe "Deallocations for expressions" $ do