examples/constDivZero.hs

@@ -0,0 +1,3 @@
+k x y = x;
+main = k 3 ((/#) 1 0);
+

examples/factorial.hs

@@ -0,0 +1,7 @@
+fac n = case (==#) n 0 of
+    { 1 -> 1
+    ; 0 -> (*#) n (fac ((-#) n 1))
+    };
+
+main = fac 3;
+

examples/sumList.hs

@@ -0,0 +1,9 @@
+nil = Pack{0 0};
+cons x y = Pack{1 2} x y;
+list = cons 1 (cons 2 (cons 3 nil));
+sum l = case l of
+    { 0      -> 0
+    ; 1 x xs -> (+#) x (sum xs)
+    };
+main = sum list;
+

rlp.cabal

@@ -23,13 +23,13 @@ library
                     , GM
                     , Compiler.RLPC
                     , Core.Syntax
+                    , Core.Examples
                     , Core.Utils
+                    , Core.TH
 
     other-modules:    Data.Heap
                     , Data.Pretty
                     , Core.Parse
-                    , Core.TH
-                    , Core.Examples
                     , Core.Lex
                     , Control.Monad.Errorful
                     , Core2Core
@@ -83,5 +83,8 @@ test-suite rlp-test
     build-depends: base ^>=4.18.0.0
                  , rlp
                  , QuickCheck
+                 , hspec            ==2.*
     other-modules: Arith
+                 , GMSpec
+    build-tool-depends: hspec-discover:hspec-discover
 

src/Core/Examples.hs

@@ -4,7 +4,11 @@ Description : Core examples (may eventually be unit tests)
 -}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE OverloadedStrings #-}
-module Core.Examples where
+module Core.Examples
+    ( fac3
+    , sumList
+    , constDivZero
+    ) where
 ----------------------------------------------------------------------------------
 import Core.Syntax
 import Core.TH
@@ -12,6 +16,7 @@ import Core.TH
 
 -- TODO: my shitty lexer isn't inserting semicolons
 
+letrecExample :: Program'
 letrecExample = [coreProg|
     pair x y f = f x y;
 
@@ -27,18 +32,22 @@ letrecExample = [coreProg|
     main = f 3 4;
 |]
 
+idExample :: Program'
 idExample = [coreProg|
     main = id 3;
 |]
 
+indExample1 :: Program'
 indExample1 = [coreProg|
     main = twice twice id 3;
 |]
 
+indExample2 :: Program'
 indExample2 = [coreProg|
     main = twice twice twice id 3;
 |]
 
+indExample3 :: Program'
 indExample3 = [coreProg|
     main = letrec
         { x = 2
@@ -49,51 +58,63 @@ indExample3 = [coreProg|
     g a b = a;
 |]
 
+negExample1 :: Program'
 negExample1 = [coreProg|
     main = negate# (id 3);
 |]
 
+negExample2 :: Program'
 negExample2 = [coreProg|
     main = negate# 3;
 |]
 
+negExample3 :: Program'
 negExample3 = [coreProg|
     main = twice negate# 3;
 |]
 
+arithExample1 :: Program'
 arithExample1 = [coreProg|
     main = (+#) 3 (negate# 2);
 |]
 
+arithExample2 :: Program'
 arithExample2 = [coreProg|
     main = negate# ((+#) 2 ((*#) 5 3));
 |]
 
+ifExample1 :: Program'
 ifExample1 = [coreProg|
     main = if# True 2 3;
 |]
 
+ifExample2 :: Program'
 ifExample2 = [coreProg|
     main = if# (id True) 2 3;
 |]
 
+facExample :: Program'
 facExample = [coreProg|
     fac n = if# ((==#) n 0) 1 ((*#) n (fac ((-#) n 1)));
     main = fac 3;
 |]
 
+pairExample1 :: Program'
 pairExample1 = [coreProg|
     main = fst (snd (fst (MkPair (MkPair 1 (MkPair 2 3)) 4)));
 |]
 
+pairExample2 :: Program'
 pairExample2 = [coreProg|
     main = (if# False fst snd) (MkPair 2 3);
 |]
 
+listExample1 :: Program'
 listExample1 = [coreProg|
     main = caseList# (Cons 2 Nil) 3 k;
 |]
 
+listExample2 :: Program'
 listExample2 = [coreProg|
     cc f x xs = Cons (f x) (map f xs);
     map f l = caseList# l Nil (cc f);
@@ -101,6 +122,7 @@ listExample2 = [coreProg|
     main = map negate# list;
 |]
 
+listExample3 :: Program'
 listExample3 = [coreProg|
     cc f z x xs = f x (foldr f z xs);
     foldr f z l = caseList# l z (cc f z);
@@ -108,6 +130,7 @@ listExample3 = [coreProg|
     main = foldr (+#) 0 list;
 |]
 
+simple1 :: Program'
 simple1 = [coreProg|
     k a b = a;
     s f g x = f x (g x);
@@ -115,6 +138,7 @@ simple1 = [coreProg|
     main = s k k 3;
 |]
 
+caseBool1 :: Program'
 caseBool1 = [coreProg|
     _if c x y = case c of
         { 1 -> x
@@ -127,7 +151,8 @@ caseBool1 = [coreProg|
     main = _if false ((+#) 2 3) ((*#) 4 5);
 |]
 
-factorialGM = [coreProg|
+fac3 :: Program'
+fac3 = [coreProg|
     fac n = case (==#) n 0 of
         { 1 -> 1
         ; 0 -> (*#) n (fac ((-#) n 1))
@@ -136,6 +161,26 @@ factorialGM = [coreProg|
     main = fac 3;
 |]
 
+-- TODO: paramaterised examples? eg. sumList could take a haskell list of ints
+-- as an input, translate it to a rl' list, and run the example on that?
+sumList :: Program'
+sumList = [coreProg|
+        nil = Pack{0 0};
+        cons x y = Pack{1 2} x y;
+        list = cons 1 (cons 2 (cons 3 nil));
+        sum l = case l of
+            { 0      -> 0
+            ; 1 x xs -> (+#) x (sum xs)
+            };
+        main = sum list;
+    |]
+
+constDivZero :: Program'
+constDivZero = [coreProg|
+        k x y = x;
+        main = k 3 ((/#) 1 0);
+    |]
+
 corePrelude :: Module Name
 corePrelude = Module (Just ("Prelude", [])) $
     -- non-primitive defs

src/GM.hs

@@ -9,6 +9,10 @@ module GM
     ( hdbgProg
     , evalProg
     , Node(..)
+    , gmEvalProg
+    , finalStateOf
+    , resultOf
+    , resultOfExpr
     )
     where
 ----------------------------------------------------------------------------------
@@ -701,12 +705,12 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs
                 compileBinder (_ := v, a) = compileC g' v <> [Update a]
 
         -- special cases for prim functions; essentially inlining
-        compileE g ("negate#" :$ a)  = compileE g a <>                 [Neg]
-        compileE g ("+#" :$ a :$ b)  = compileE g b <> compileE g a <> [Add]
-        compileE g ("-#" :$ a :$ b)  = compileE g b <> compileE g a <> [Sub]
-        compileE g ("*#" :$ a :$ b)  = compileE g b <> compileE g a <> [Mul]
-        compileE g ("/#" :$ a :$ b)  = compileE g b <> compileE g a <> [Div]
-        compileE g ("==#" :$ a :$ b) = compileE g b <> compileE g a <> [Equals]
+        compileE g ("negate#" :$ a)  = inlineOp1 g Neg    a
+        compileE g ("+#" :$ a :$ b)  = inlineOp2 g Add    a b
+        compileE g ("-#" :$ a :$ b)  = inlineOp2 g Sub    a b
+        compileE g ("*#" :$ a :$ b)  = inlineOp2 g Mul    a b
+        compileE g ("/#" :$ a :$ b)  = inlineOp2 g Div    a b
+        compileE g ("==#" :$ a :$ b) = inlineOp2 g Equals a b
 
         compileE g (Case e as) = compileE g e <> [CaseJump (compileD g as)]
 
@@ -723,6 +727,13 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs
                 g' = binds ++ argOffset n g
                 c = compileE g' e
 
+        inlineOp1 :: Env -> Instr -> Expr' -> Code
+        inlineOp1 g i a = compileE g a <> [i]
+
+        inlineOp2 :: Env -> Instr -> Expr' -> Expr' -> Code
+        inlineOp2 g i a b = compileE g b <> compileE g' a <> [i]
+            where g' = argOffset 1 g
+
         -- | offset each address in the environment by n
         argOffset :: Int -> Env -> Env
         argOffset n = each . _2 %~ (+n)
@@ -850,7 +861,7 @@ showNodeAtP p st a = case hLookup a h of
             name = case lookup a (swap <$> g) of
                 Just (NameKey n)     -> n
                 Just (ConstrKey t n) -> idPack t n
-                _                     -> errTxtInvalidAddress
+                _                    -> errTxtInvalidAddress
     -- TODO: left-associativity
     Just (NAp f x)       -> pprec $ showNodeAtP (p+1) st f
                                 <+> showNodeAtP (p+1) st x
@@ -945,4 +956,26 @@ sweepNodes st = st & gmHeap %~ thread (f <$> addresses h)
 thread :: [a -> a] -> (a -> a)
 thread = appEndo . foldMap Endo
 
---}
+----------------------------------------------------------------------------------
+
+gmEvalProg :: Program' -> GmState
+gmEvalProg p = compile p & eval & last
+
+finalStateOf :: (GmState -> r) -> Program' -> r
+finalStateOf f = f . gmEvalProg
+
+resultOf :: Program' -> Maybe Node
+resultOf p = do
+    a <- res
+    n <- hLookup a h
+    pure n
+    where
+        res = st ^? gmStack . _head
+        st = gmEvalProg p
+        h = st ^. gmHeap
+
+resultOfExpr :: Expr' -> Maybe Node
+resultOfExpr e = resultOf $ Program
+    [ ScDef "main" [] e
+    ]
+

tst/Arith.hs

@@ -1,7 +1,8 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell #-}
 module Arith
-    ( runTestsArith
+    ( evalCore
+    , evalArith
     ) where
 ----------------------------------------------------------------------------------
 import Data.Functor.Classes             (eq1)
@@ -27,16 +28,16 @@ data ArithExpr = IntA Int
                | ArithExpr ::- ArithExpr
                deriving Show
 
-evalA :: ArithExpr -> Int
-evalA (IntA n)    = n
-evalA (IdA  e)    = evalA e
-evalA (NegateA a) = negate (evalA a)
-evalA (a :+ b)    = evalA a + evalA b
-evalA (a :* b)    = evalA a * evalA b
-evalA (a :- b)    = evalA a - evalA b
-evalA (a ::+ b)   = evalA a + evalA b
-evalA (a ::* b)   = evalA a * evalA b
-evalA (a ::- b)   = evalA a - evalA b
+evalArith :: ArithExpr -> Int
+evalArith (IntA n)    = n
+evalArith (IdA  e)    = evalArith e
+evalArith (NegateA a) = negate (evalArith a)
+evalArith (a :+ b)    = evalArith a + evalArith b
+evalArith (a :* b)    = evalArith a * evalArith b
+evalArith (a :- b)    = evalArith a - evalArith b
+evalArith (a ::+ b)   = evalArith a + evalArith b
+evalArith (a ::* b)   = evalArith a * evalArith b
+evalArith (a ::- b)   = evalArith a - evalArith b
 
 instance Arbitrary ArithExpr where
     arbitrary = gen 4
@@ -62,11 +63,11 @@ instance Arbitrary ArithExpr where
                     -- int = chooseInt (minBound,maxBound)
                     int = chooseInt (-500,500)
 
-prop_ArithExprEqCoreExpr :: ArithExpr -> Bool
-prop_ArithExprEqCoreExpr e = arithResult `eq1` coreResult
-    where
-        arithResult = Just (evalA e)
-        coreResult  = evalCore (toCore e)
+-- prop_ArithExprEqCoreExpr :: ArithExpr -> Bool
+-- prop_ArithExprEqCoreExpr e = arithResult `eq1` coreResult
+--     where
+--         arithResult = Just (evalArith e)
+--         coreResult  = evalCore (toCore e)
 
 toCore :: ArithExpr -> Program'
 toCore expr = Program
@@ -87,15 +88,18 @@ toCore expr = Program
 
         f n a b = n :$ go a :$ go b
 
-evalCore :: Program' -> Maybe Int
-evalCore p = do
+evalProgram :: Program' -> Maybe Int
+evalProgram p = do
     a <- fst <$> evalProg p
     case a of
         (NNum n) -> Just n
         _        -> Nothing
 
-pure []
+evalCore :: ArithExpr -> Maybe Int
+evalCore = evalProgram . toCore
 
-runTestsArith :: IO Bool
-runTestsArith = $quickCheckAll
+-- pure []
+
+-- runTestsArith :: IO Bool
+-- runTestsArith = $quickCheckAll
 

tst/GMSpec.hs

@@ -0,0 +1,38 @@
+{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}
+module GMSpec
+    ( spec
+    )
+    where
+----------------------------------------------------------------------------------
+import Test.Hspec
+import Arith
+import Test.QuickCheck
+import GM                   (Node(..), resultOf, resultOfExpr)
+import Core.TH
+import Core.Examples        qualified as Ex
+----------------------------------------------------------------------------------
+
+spec :: Spec
+spec = do
+    it "should correctly evaluate 3-2 with inlining" $ do
+        resultOf [coreProg|main = (-#) 3 2;|] `shouldBe` Just (NNum 1)
+
+    it "should correctly evaluate 3-2 without inlining" $ do
+        resultOf [coreProg|id x = x; main = (id (-#)) 3 2;|] `shouldBe` Just (NNum 1)
+
+    it "should correctly evaluate arbitrary arithmetic" $ do
+        property $ \e ->
+            let arithRes = Just (evalArith e)
+                coreRes  = evalCore e
+            in coreRes `shouldBe` arithRes
+
+    describe "test programs" $ do
+        it "fac 3" $ do
+            resultOf Ex.fac3 `shouldBe` Just (NNum 6)
+
+        it "sum [1,2,3]" $ do
+            resultOf Ex.sumList `shouldBe` Just (NNum 6)
+
+        it "k 3 ((/#) 1 0)" $ do
+            resultOf Ex.constDivZero `shouldBe` Just (NNum 3)
+

tst/Main.hs

@@ -1,18 +1 @@
-module Main (main) where
-----------------------------------------------------------------------------------
-import Control.Monad
-import System.Exit
-import Test.QuickCheck
-import Arith
-----------------------------------------------------------------------------------
-
-runTests :: IO Bool
-runTests = runTestsArith
-
-main :: IO ()
-main = do
-    good <- runTests
-    if good
-    then exitSuccess
-    else exitFailure
-
+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}