diff --git a/rlp.cabal b/rlp.cabal index 00ed930..f604254 100644 --- a/rlp.cabal +++ b/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: - type: exitcode-stdio-1.0 - hs-source-dirs: tst - main-is: Main.hs - build-depends: - base ^>=4.18.0.0, - rlp + -- 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 + , QuickCheck + other-modules: Arith diff --git a/src/GM.hs b/src/GM.hs index fff856c..28bb6f6 100644 --- a/src/GM.hs +++ b/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 diff --git a/tst/Arith.hs b/tst/Arith.hs new file mode 100644 index 0000000..da55be1 --- /dev/null +++ b/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 + diff --git a/tst/Main.hs b/tst/Main.hs index 25344a2..3ddb275 100644 --- a/tst/Main.hs +++ b/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 +