From b118808cc403afff9b771e7c84ee865f66825c92 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Madeleine=20Sydney=20=C5=9Alaga?= Date: Thu, 3 Sep 2026 15:19:16 -0600 Subject: [PATCH] --- src/Gyehoek/Driver.hs | 10 +- src/Gyehoek/Options.hs | 5 + src/Gyehoek/Sexp/Grammar.hs | 1 + test/Gyehoek/Test/CPS/Eval.hs | 106 ++++++++++++--------- test/Gyehoek/Test/CPS/Stackify.hs | 151 +++++++++++++++--------------- test/Gyehoek/Test/CPS/Syntax.hs | 4 +- test/Gyehoek/Test/Golden.hs | 3 +- test/Gyehoek/Test/Stack/VM.hs | 3 +- 8 files changed, 158 insertions(+), 125 deletions(-) diff --git a/src/Gyehoek/Driver.hs b/src/Gyehoek/Driver.hs index 6523d5a..e7d6f2c 100644 --- a/src/Gyehoek/Driver.hs +++ b/src/Gyehoek/Driver.hs @@ -1,5 +1,5 @@ module Gyehoek.Driver - (main, lower_e2e, convert_e2e, parse_e2e, readScm, eval_e2e) + (main, lower_e2e, convert_e2e, parse_e2e, readScm, eval_e2e, eval_cps_e2e) where import Gyehoek.Options @@ -163,3 +163,11 @@ eval_e2e :: FilePath -> IO (List Obj) eval_e2e fp = runJalmotIO . runFileSystem . runGenSym $ do stk <- stackifyProgram <=< closeProgram <=< convertProgram <=< readScm $ fp eval stk + +eval_cps_e2e :: FilePath -> IO Text +eval_cps_e2e fp = runJalmotIO . runFileSystem . runGenSym $ + readScm fp + >>= convertProgram + -- >>= closeProgram + >>= CPS.evalProgram + >>= pure . S.encodeOrShowData' S.dataIso diff --git a/src/Gyehoek/Options.hs b/src/Gyehoek/Options.hs index 9363d5b..11002d5 100644 --- a/src/Gyehoek/Options.hs +++ b/src/Gyehoek/Options.hs @@ -32,6 +32,7 @@ data Options = MkOptions , dumpHoisted :: Bool , dumpContified :: Bool , traceStackified :: Bool + , noColour :: Bool , runtime :: Maybe Runtime , inspectWasm :: Bool , output :: FilePath @@ -66,6 +67,10 @@ parser = do dumpHoisted <- switch (long "dump-hoisted") dumpContified <- switch (long "dump-contified") traceStackified <- switch (long "trace-stackified") + noColour <- switch . fold $ + [ long "no-colour" + , long "no-color" + ] inspectWasm <- switch $ long "inspect-wasm" <> short 'p' runtime <- option runtimeReader . fold $ [ long "runtime" diff --git a/src/Gyehoek/Sexp/Grammar.hs b/src/Gyehoek/Sexp/Grammar.hs index 95aa2ef..034b833 100644 --- a/src/Gyehoek/Sexp/Grammar.hs +++ b/src/Gyehoek/Sexp/Grammar.hs @@ -15,6 +15,7 @@ module Gyehoek.Sexp.Grammar , encodeDataTest , encodeDataTestColour , encodeOrShow' + , encodeOrShowData' , decodeDataWith , encodeDataWith' , decodeTest diff --git a/test/Gyehoek/Test/CPS/Eval.hs b/test/Gyehoek/Test/CPS/Eval.hs index 79d5b8e..17508a5 100644 --- a/test/Gyehoek/Test/CPS/Eval.hs +++ b/test/Gyehoek/Test/CPS/Eval.hs @@ -5,53 +5,69 @@ 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) -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" + 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) diff --git a/test/Gyehoek/Test/CPS/Stackify.hs b/test/Gyehoek/Test/CPS/Stackify.hs index 16b0323..75e826b 100644 --- a/test/Gyehoek/Test/CPS/Stackify.hs +++ b/test/Gyehoek/Test/CPS/Stackify.hs @@ -10,86 +10,87 @@ import Gyehoek.GenSym (runGenSym) import Effectful import Gyehoek.Prelude import Gyehoek.Jalmot +import Test.Tasty.ExpectedFailure (expectFail, ignoreTestBecause) -test_stackify = - [ trivialReturn - , tailCall - , prim - , condition - , procedure - ] +-- test_stackify = +-- [ trivialReturn +-- , tailCall +-- , prim +-- , condition +-- , procedure +-- ] -evalsTo :: HasCallStack => List Obj -> Sut.Program -> Assertion -evalsTo rs e = runJalmotUnsafe (Stk.eval e') @?= rs - where - e' = e & Sut.stackifyProgram & runGenSym & runPureEff +-- evalsTo :: HasCallStack => List Obj -> Sut.Program -> Assertion +-- evalsTo rs e = runJalmotUnsafe (Stk.eval e') @?= rs +-- where +-- e' = e & Sut.stackifyProgram & runGenSym & runPureEff -trivialReturn = testGroup "trivial return" - [ testCase "return int" do - evalsTo [ObjImm (ImmInt 4)] - [cps|(λ (ktail) (continue ktail 4))|] - , testCase "return bool" do - evalsTo [ObjImm (ImmBool True)] - [cps|(λ (ktail) (continue ktail #t))|] - evalsTo [ObjImm (ImmBool False)] - [cps|(λ (ktail) (continue ktail #f))|] - ] +-- trivialReturn = testGroup "trivial return" +-- [ testCase "return int" do +-- evalsTo [ObjImm (ImmInt 4)] +-- [cps|(λ (ktail) (continue ktail 4))|] +-- , testCase "return bool" do +-- evalsTo [ObjImm (ImmBool True)] +-- [cps|(λ (ktail) (continue ktail #t))|] +-- evalsTo [ObjImm (ImmBool False)] +-- [cps|(λ (ktail) (continue ktail #f))|] +-- ] -tailCall = testGroup "tail call" - [ testCase "square" do - evalsTo [ObjImm (ImmInt 16)] [cps| - (λ (ktail0) - (letrec ((square (λ (x ktail) - (prim (* x x) - (κ (x0) (continue ktail x0)))))) - (square 4 halt))) - |] - ] +-- tailCall = testGroup "tail call" +-- [ testCase "square" do +-- evalsTo [ObjImm (ImmInt 16)] [cps| +-- (λ (ktail0) +-- (letrec ((square (λ (x ktail) +-- (prim (* x x) +-- (κ (x0) (continue ktail x0)))))) +-- (square 4 halt))) +-- |] +-- ] -prim = testGroup "prim" - [ testCase "multiply" do - evalsTo [ObjImm (ImmInt 20)] - [cps|(λ (ktail0) - (prim (* 4 5) - (κ (x) (continue ktail0 x))))|] - , testCase "add" do - evalsTo [ObjImm (ImmInt 9)] - [cps|(λ (ktail0) - (prim (+ 4 5) - (κ (x) (continue ktail0 x))))|] - -- , testGroup "call/cc" - -- [ testCase "trivial" do - -- evalsTo [ObjImm (ImmInt 123)] - -- [cps|(letrec ((f (λ (cc ktail) (continue cc 123)))) - -- (prim (call/cc f)))|] - -- ] - ] +-- prim = testGroup "prim" +-- [ testCase "multiply" do +-- evalsTo [ObjImm (ImmInt 20)] +-- [cps|(λ (ktail0) +-- (prim (* 4 5) +-- (κ (x) (continue ktail0 x))))|] +-- , testCase "add" do +-- evalsTo [ObjImm (ImmInt 9)] +-- [cps|(λ (ktail0) +-- (prim (+ 4 5) +-- (κ (x) (continue ktail0 x))))|] +-- -- , testGroup "call/cc" +-- -- [ testCase "trivial" do +-- -- evalsTo [ObjImm (ImmInt 123)] +-- -- [cps|(letrec ((f (λ (cc ktail) (continue cc 123)))) +-- -- (prim (call/cc f)))|] +-- -- ] +-- ] -condition = testCase "if" do - evalsTo [ObjImm (ImmInt 123)] - [cps|(λ (ktail0) - (if #t (continue ktail0 123) (continue ktail0 456)))|] - evalsTo [ObjImm (ImmInt 456)] - [cps|(λ (ktail0) - (if #f (continue ktail0 123) (continue ktail0 456)))|] +-- condition = testCase "if" do +-- evalsTo [ObjImm (ImmInt 123)] +-- [cps|(λ (ktail0) +-- (if #t (continue ktail0 123) (continue ktail0 456)))|] +-- evalsTo [ObjImm (ImmInt 456)] +-- [cps|(λ (ktail0) +-- (if #f (continue ktail0 123) (continue ktail0 456)))|] -procedure = testGroup "procedure" - [ testCase "factorial" do - evalsTo [ObjImm (ImmInt 720)] - [cps|(λ (ktail0) - (letrec ((fac (λ (n ktail) - (prim (zero? n) - (κ (x0) - (if x0 - (continue ktail 1) - (prim (- n 1) - (κ (x1) - (letrec ((fac-k0 - (κ (x2) - (prim (* n x2) - (κ (x3) - (continue ktail x3)))))) - (fac x1 fac-k0)))))))))) - (fac 6 halt)))|] - ] +-- procedure = testGroup "procedure" +-- [ testCase "factorial" do +-- evalsTo [ObjImm (ImmInt 720)] +-- [cps|(λ (ktail0) +-- (letrec ((fac (λ (n ktail) +-- (prim (zero? n) +-- (κ (x0) +-- (if x0 +-- (continue ktail 1) +-- (prim (- n 1) +-- (κ (x1) +-- (letrec ((fac-k0 +-- (κ (x2) +-- (prim (* n x2) +-- (κ (x3) +-- (continue ktail x3)))))) +-- (fac x1 fac-k0)))))))))) +-- (fac 6 halt)))|] +-- ] diff --git a/test/Gyehoek/Test/CPS/Syntax.hs b/test/Gyehoek/Test/CPS/Syntax.hs index d33f83c..c67ab06 100644 --- a/test/Gyehoek/Test/CPS/Syntax.hs +++ b/test/Gyehoek/Test/CPS/Syntax.hs @@ -46,9 +46,9 @@ qq = testGroup "parser" , testCase "application" do assertEqual "" (Sut.ExpApply (Sut.ValVar "f") [Sut.ValVar "x",Sut.ValVar "y"] - "k") + (Sut.KexpVar "k")) [cps|(f x y k)|] assertEqual "" (Sut.ExpApply (Sut.ValVar "f") - [] "k") + [] (Sut.KexpVar "k")) [cps|(f k)|] ] diff --git a/test/Gyehoek/Test/Golden.hs b/test/Gyehoek/Test/Golden.hs index 8850f68..b82b65d 100644 --- a/test/Gyehoek/Test/Golden.hs +++ b/test/Gyehoek/Test/Golden.hs @@ -40,7 +40,8 @@ test_root = do testGroup "execution" <$> sequenceA [ ignoreTestBecause "wasm codegen is on the backburner" <$> wasmTests tests - , stackifyTests tests + , ignoreTestBecause "i'm killing myself" + <$> stackifyTests tests ] maybeBroken name broken = applyWhen (name `elem` broken) expectFail diff --git a/test/Gyehoek/Test/Stack/VM.hs b/test/Gyehoek/Test/Stack/VM.hs index e87b0b4..02bbc93 100644 --- a/test/Gyehoek/Test/Stack/VM.hs +++ b/test/Gyehoek/Test/Stack/VM.hs @@ -8,12 +8,13 @@ import Gyehoek.Stack.VM qualified as Sut import Data.List (List) import Gyehoek.Jalmot import Gyehoek.Prelude (i) +import Test.Tasty.ExpectedFailure (expectFail, ignoreTestBecause) evalsTo :: List Obj -> Program -> Assertion evalsTo rs p = runJalmotUnsafe (Sut.eval p) @?= rs -test_root = testGroup "stack machine" +test_root = ignoreTestBecause "i'm super-killing myself" $ testGroup "stack machine" [ testCase "immediate halt" do evalsTo [] [stkP| (define $start