ughhh evaluate cps

2026-09-05 20:22:07 -06:00
parent ba5dc401d9
commit 9f37d10e4f
12 changed files with 340 additions and 145 deletions
@@ -5,53 +5,72 @@ import Test.Tasty.HUnit
 import Gyehoek.CPS.Syntax (cps, Obj(..), Hob(..), Imm(..))
 import Gyehoek.CPS.Eval qualified as Sut
 import Data.List (List)
-import Test.Tasty.ExpectedFailure (ignoreTestBecause)
+import Test.Tasty.ExpectedFailure (ignoreTestBecause, expectFail)
+import System.Directory (listDirectory)
+import Test.Tasty.Silver
+import System.FilePath
+import Control.Exception
+import qualified Gyehoek.Driver as Driver
+import Control.DeepSeq (($!!))
+import System.Exit (ExitCode(..))
+import qualified Data.Text as T
+import Data.Function (applyWhen)
+import Gyehoek.Prelude


-test_cpsInterpreter =
-  ignoreTestBecause "i forgorrrr" $
-  testGroup "cps interpreter" $
-  [ primitives
-  , testCase "halt with constant" do
-      evalsTo [ObjImm (ImmInt 123)] [cps|
-        (continue halt 123)
-      |]
-  , testCase "identity cont" do
-      evalsTo [ObjImm (ImmInt 154)] [cps|
-        (letrec ((id (κ (x)
-                       (continue halt x))))
-          (continue id 154))
-      |]
-  , testCase "identity function" do
-      evalsTo [ObjImm (ImmInt 456)] [cps|
-        (letrec ((id (λ (x ktail)
-                       (continue ktail x))))
-          (id 456 halt))
-      |]
-  , testCase "square" do
-      evalsTo [ObjImm (ImmInt 81)] [cps|
-        (letrec ((square (λ (x ktail)
-                           (prim (* x x)
-                             (κ (r) (continue ktail r))))))
-          (square 9 halt))
-      |]
-  ]
+brokenEvalTests :: List String
+brokenEvalTests =
+  []
+  -- [ "adder"
+  -- , "apply2"
+  -- , "apply-twice"
+  -- , "arith"
+  -- , "begin-1"
+  -- , "callcc-constant"
+  -- , "callcc-discard"
+  -- , "callcc-early-exit-1"
+  -- , "callcc-early-exit-2"
+  -- , "callcc-early-exit-3"
+  -- , "callcc-early-exit-4"
+  -- , "callcc-early-exit-5"
+  -- , "callcc-early-exit-6"
+  -- , "callcc-nested-1"
+  -- , "callcc-nested-2"
+  -- , "complicated-1"
+  -- , "cons-1"
+  -- , "factorial"
+  -- , "false"
+  -- , "fn-of-fn"
+  -- , "if-false"
+  -- , "if-number"
+  -- , "if-true"
+  -- , "lambda"
+  -- , "letrec-fn"
+  -- , "let-fn"
+  -- , "lit-int"
+  -- , "square"
+  -- , "true"
+  -- ]

-evalsTo :: HasCallStack => List Obj -> Sut.Exp -> Assertion
-evalsTo rs e = Sut.evalExp e @?= rs
+test_eval :: IO TestTree
+test_eval = do
+  cs <- listDirectory "golden/exec"
+      <&> fmap ("golden/exec" </>)
+  pure $ testGroup "cps interpreter" $ cpsCase <$> cs

-primitives = testGroup "primitives"
-  [ testGroup "arith"
-    [ testCase "basic 1" do
-        evalsTo [ObjImm (ImmInt 20)] [cps|
-          (prim (* 4 5)
-            (κ (x) (continue halt x)))
-          |]
-    , testCase "basic 2" do
-        evalsTo [ObjImm (ImmInt 35)] [cps|
-          (prim (* 2 16)
-            (κ (x) (prim (+ x 3)
-                      (κ (r) (continue halt r)))))
-          |]
-    ]
-  ]
+maybeBroken name broken = applyWhen (name `elem` broken) expectFail
+
+cpsCase :: FilePath -> TestTree
+cpsCase test =
+  maybeBroken testName brokenEvalTests $
+    goldenVsAction testName resultFile action printProcResult
+  where
+    testName = takeFileName test
+    resultFile = test </> "exec"
+    sourceFile = test </> "source.scm"
+    action = catch @SomeException
+      (do r <- Driver.eval_cps_e2e sourceFile
+          pure $!! ( ExitSuccess
+                   , r
+                   , "" ))
+      \e -> pure (ExitFailure 1, "", T.pack $ displayException e)