tests

rlp.cabal

@@ -22,10 +22,10 @@ library
                     , TI
                     , GM
                     , Compiler.RLPC
+                    , Core.Syntax
 
     other-modules:    Data.Heap
                     , Data.Pretty
-                    , Core.Syntax
                     , Core.Parse
                     , Core.TH
                     , Core.Examples
@@ -70,12 +70,12 @@ executable rlpc
 test-suite rlp-test
     import:           warnings
     default-language: GHC2021
-    -- other-modules:
-    -- other-extensions:
+    -- import: deps, test-deps
     type: exitcode-stdio-1.0
     hs-source-dirs: tst
     main-is: Main.hs
-    build-depends:
-        base ^>=4.18.0.0,
-        rlp
+    build-depends: base ^>=4.18.0.0
+                 , rlp
+                 , QuickCheck
+    other-modules: Arith
 

src/GM.hs

@@ -7,6 +7,8 @@ Description : The G-Machine
 {-# LANGUAGE OverloadedStrings #-}
 module GM
     ( hdbgProg
+    , evalProg
+    , Node(..)
     )
     where
 ----------------------------------------------------------------------------------
@@ -89,6 +91,15 @@ pure []
 
 ----------------------------------------------------------------------------------
 
+evalProg :: Program -> Maybe (Node, Stats)
+evalProg p = res <&> (,sts)
+    where
+        final = eval (compile p) & last
+        h = final ^. gmHeap
+        sts = final ^. gmStats
+        resAddr = final ^. gmStack ^? _head
+        res = resAddr >>= flip hLookup h
+
 hdbgProg :: Program -> Handle -> IO (Node, Stats)
 hdbgProg p hio = do
     (renderOut . showState) `traverse_` states

tst/Arith.hs

@@ -0,0 +1,85 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+module Arith
+    ( runTestsArith
+    ) where
+----------------------------------------------------------------------------------
+import Data.Functor.Classes             (eq1)
+import Core.Syntax
+import GM
+import Test.QuickCheck
+----------------------------------------------------------------------------------
+
+-- does not support division because there are few things i'd hate more than
+-- trying to catch divide-by-zero exceptions in pure code
+data ArithExpr = IntA Int
+               | NegateA ArithExpr
+               -- to test Evals
+               | IdA ArithExpr
+               | ArithExpr :+ ArithExpr
+               | ArithExpr :* ArithExpr
+               | 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
+
+instance Arbitrary ArithExpr where
+    arbitrary = gen 4
+        where
+            gen :: Int -> Gen ArithExpr
+            gen n
+                | n > 0 = oneof
+                    -- i don't feel like dealing with zero at the moment
+                    [ IntA <$> int
+                    , NegateA <$> arbitrary
+                    -- , IdA <$> arbitrary
+                    , b (:+)
+                    , b (:-)
+                    , b (:*)
+                    ]
+                | otherwise = IntA <$> int
+                where
+                    b f = liftA2 f s s
+                    s = gen (n `div` 2)
+                    int = chooseInt (minBound,maxBound)
+
+prop_ArithExprEqCoreExpr :: ArithExpr -> Bool
+prop_ArithExprEqCoreExpr e = arithResult `eq1` coreResult
+    where
+        arithResult = Just (evalA e)
+        coreResult  = evalCore (toCore e)
+
+toCore :: ArithExpr -> Program
+toCore expr = Program
+        [ ScDef "id" ["x"] $ Var "x"
+        , ScDef "main" [] $ go expr
+        ]
+    where
+        go :: ArithExpr -> Expr
+        go (IntA n)    = IntE n
+        go (NegateA e) = "negate#" :$ go e
+        go (IdA e)     = "id" :$ go e
+        go (a :+ b)  = f "+#" a b
+        go (a :- b)  = f "-#" a b
+        go (a :* b)  = f "*#" a b
+
+        f n a b = n :$ go a :$ go b
+
+evalCore :: Program -> Maybe Int
+evalCore p = do
+    a <- fst <$> evalProg p
+    case a of
+        (NNum n) -> Just n
+        _        -> Nothing
+
+pure []
+
+runTestsArith :: IO Bool
+runTestsArith = $quickCheckAll
+

tst/Main.hs

@@ -1,5 +1,18 @@
 module Main (main) where
 ----------------------------------------------------------------------------------
+import Control.Monad
+import System.Exit
+import Test.QuickCheck
+import Arith
+----------------------------------------------------------------------------------
+
+runTests :: IO Bool
+runTests = runTestsArith
 
 main :: IO ()
-main = putStrLn "Test suite not yet implemented."
+main = do
+    good <- runTests
+    if good
+    then exitSuccess
+    else exitFailure
+