diff --git a/src/Core/Examples.hs b/src/Core/Examples.hs index 0b741e9..f9f4468 100644 --- a/src/Core/Examples.hs +++ b/src/Core/Examples.hs @@ -4,12 +4,7 @@ Description : Core examples (may eventually be unit tests) -} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE OverloadedStrings #-} -module Core.Examples - ( fac3 - , sumList - , constDivZero - , idCase - ) where +module Core.Examples 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 diff --git a/src/GM.hs b/src/GM.hs index d5ad9f6..065cb08 100644 --- a/src/GM.hs +++ b/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] diff --git a/tst/GMSpec.hs b/tst/GMSpec.hs index dd5957a..cc5faf1 100644 --- a/tst/GMSpec.hs +++ b/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) + +