src/Core/Examples.hs

@@ -4,12 +4,7 @@ Description : Core examples (may eventually be unit tests)
 -}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE OverloadedStrings #-}
-module Core.Examples
+module Core.Examples where
-    ( fac3
-    , sumList
-    , constDivZero
-    , idCase
-    ) where
 ----------------------------------------------------------------------------------
 import Core.Syntax
 import Core.TH
@@ -196,6 +191,32 @@ idCase = [coreProg|
             })
     |]
 
+-- NOTE: the GM primitive (==#) returns an untyped constructor with tag 1 for
+-- true, and 0 for false. See: GM.boxBool
+namedBoolCase :: Program'
+namedBoolCase = [coreProg|
+        {-# PackData True 1 0 #-}
+        {-# PackData False 0 0 #-}
+        main = case (==#) 1 1 of
+            { True -> 123
+            ; False -> 456
+            }
+    |]
+
+namedConsCase :: Program'
+namedConsCase = [coreProg|
+        {-# PackData Nil  0 0 #-}
+        {-# PackData Cons 1 2 #-}
+        Nil = Pack{0 0};
+        Cons = Pack{1 2};
+        foldr f z l = case l of
+            { Nil       -> z
+            ; Cons x xs -> f x (foldr f z xs)
+            };
+        list = Cons 1 (Cons 2 (Cons 3 Nil));
+        main = foldr (+#) 0 list
+    |]
+
 -- corePrelude :: Module Name
 -- corePrelude = Module (Just ("Prelude", [])) $
 --     -- non-primitive defs

src/GM.hs

@@ -662,7 +662,7 @@ buildInitialHeap (view programScDefs -> ss) = mapAccumL allocateSc mempty compil
 
         compileC _ (Case _ _) =
             error "GM compiler found a non-strict case expression, which should\
-                  \ have been floated by Core2Core.gmPrep. This is bad!"
+                  \ have been floated by Core2Core.gmPrep. This is a bug!"
 
         compileC _ _ = error "yet to be implemented!"
 
@@ -731,6 +731,10 @@ buildInitialHeap (view programScDefs -> ss) = mapAccumL allocateSc mempty compil
                 binds = (NameKey <$> as) `zip` [0..]
                 g' = binds ++ argOffset n g
                 c = compileE g' e
+        compileA _ (Alter _ as e) = error "GM.compileA found an untagged\
+                                          \ constructor, which should have\
+                                          \ been handled by Core2Core.gmPrep.\
+                                          \ This is a bug!"
 
         inlineOp1 :: Env -> Instr -> Expr' -> Code
         inlineOp1 g i a = compileE g a <> [i]

tst/GMSpec.hs

@@ -27,15 +27,22 @@ spec = do
             in coreRes `shouldBe` arithRes
 
     describe "test programs" $ do
-        it "fac 3" $ do
+        it "fac 3" $
             resultOf Ex.fac3 `shouldBe` Just (NNum 6)
 
-        it "sum [1,2,3]" $ do
+        it "sum [1,2,3]" $
             resultOf Ex.sumList `shouldBe` Just (NNum 6)
 
-        it "k 3 ((/#) 1 0)" $ do
+        it "k 3 ((/#) 1 0)" $
             resultOf Ex.constDivZero `shouldBe` Just (NNum 3)
 
-        it "id (case ... of { ... })" $ do
+        it "id (case ... of { ... })" $
             resultOf Ex.idCase `shouldBe` Just (NNum 5)
 
+        it "bool pattern matching with named constructors" $
+            resultOf Ex.namedBoolCase `shouldBe` Just (NNum 123)
+
+        it "list pattern matching with named constructors" $
+            resultOf Ex.namedConsCase `shouldBe` Just (NNum 6)
+
+