remove CPS.ValLit

gyehoek.cabal

@@ -103,10 +103,11 @@ library
   default-language: GHC2024
 
 test-suite test
-  import:           ghcstuffs, ghcstuffs-dev
-  type:             exitcode-stdio-1.0
-  hs-source-dirs:   test
-  main-is:          Main.hs
+  import:             ghcstuffs, ghcstuffs-dev
+  type:               exitcode-stdio-1.0
+  hs-source-dirs:     test
+  main-is:            Main.hs
+  build-tool-depends: tasty-discover:tasty-discover
   other-modules:
     Gyehoek.Test.CPS.Eval
     Gyehoek.Test.CPS.Stackify
@@ -115,6 +116,7 @@ test-suite test
     Gyehoek.Test.Scheme.Syntax
     Gyehoek.Test.Sexp
     Gyehoek.Test.Stack.VM
+    Root
 
   build-depends:
     , base
@@ -133,4 +135,4 @@ test-suite test
     , tasty-silver
     , text
 
-  default-language: GHC2024
+  default-language:   GHC2024

src/Gyehoek/CPS/Close.hs

@@ -13,9 +13,8 @@ close = transformM \case
   ExpLetRec [(f, AbsLambda lam@(MkLambda bs kb m))] e -> do
     f_code <- gensym' @Name $ f ^. _Wrapped'. to (<> "-code")
     -- it would probably be most sane to generate a symbol for `env`,
-    -- but we're reusing the lambda binding for the sake of recursive
-    -- reverences.
-    -- env <- gensym' @Name "env"
+    -- but we're reusing the lambda binding so we don't have to
+    -- explicitly substitute recursive calls.
     let frees = freeWithBound' [f] lam
     let m' = ifoldr
              (\n x q -> [cps|(prim (env-ref #{f} #{n})

src/Gyehoek/CPS/Convert.hs

@@ -23,18 +23,16 @@ telescope f = Cont.runCont . traverse (Cont.cont . f)
 
 
 
-pattern Atomic e <-
-  e@( Scm.ExpLambda _ _
-  ; Scm.ExpVar _
-  ; Scm.ExpLit _ )
-
 -- | Transform an expression with a meta-continuation.
 convert
   :: forall es. (GenSym :> es)
   => Scm.Exp -> (Val -> Eff es Exp) -> Eff es Exp
 
 convert (Scm.ExpVar x) k = k $ ValVar x
-convert (Scm.ExpLit l) k = k $ ValLit l
+convert (Scm.ExpLit l) k = k . ValImm $ case l of
+  LitInt n -> ImmInt n
+  LitBool b -> ImmBool b
+  _ -> _
 
 -- special case: call/cc is desugared during cps-conversion...
 convert (Scm.ExpPrim (PrimCallCC withcc)) k = do
@@ -112,10 +110,7 @@ convertLambda bs m = do
 
 convertProgram :: forall es. (GenSym :> es) => Scm.Program -> Eff es Program
 convertProgram p =
-  MkProgram <$> telescope (convert @es) (p ^.. each . _Left) \exps ->
-    pure . Halt1 $ case NE.nonEmpty exps of
-      Nothing -> ValLit Void
-      Just es -> NE.last es
+  MkProgram <$> telescope (convert @es) (p ^.. each . _Left) (pure . Halt)
 
 convertExp :: forall es. (GenSym :> es) => Scm.Exp -> Eff es Exp
 convertExp e = convert e (pure . Halt1)

src/Gyehoek/CPS/Eval.hs

@@ -60,13 +60,15 @@ evalVal :: Env -> Val -> Obj
 evalVal g = \case
   ValVar x -> fromMaybe (error [i|unbound: #{x}|]) $ g ^?! #vars . at x
   ValImm x -> ObjImm x
-  ValLit l -> ObjImm $ case l of
-    LitInt n -> ImmInt n
-    LitBool b -> ImmBool b
 
 emptyEnv :: Env
 emptyEnv = MkEnv
   { vars = mempty
+  -- a kinda silly hack to make sure `halt` is handled correctly when
+  -- it appears as the tail continuation of an application. the
+  -- special case of `eval` responsible for `halt` only covers terms
+  -- of the form `(continue $halt xs …)`; other terms such as
+  -- `($some-fn xs $halt)` just see an undefined label `$halt`.
   , labels = H.singleton "halt"
     ( emptyEnv
     , AbsKappa' ["h0"] $ Halt [ValVar "h0"]

src/Gyehoek/CPS/Lower.hs

@@ -82,13 +82,13 @@ popArg n = [expr|
 
 lowerVal :: (HasCallStack, GenMod :> es) => Env -> Val -> Eff es Wasm.Expr
 
-lowerVal g (ValLit l) =
-  pure $ case l of
-    LitInt n -> [expr|
+lowerVal g (ValImm imm) =
+  pure $ case imm of
+    ImmInt n -> [expr|
       (i32.const #{n})
       ##{makeSmallFixnum}
     |]
-    LitBool b -> [expr|
+    ImmBool b -> [expr|
       (i32.const #{b'})
       ref.i31
     |]

src/Gyehoek/CPS/Stackify.hs

@@ -87,8 +87,6 @@ stackify _ e = error [i|unimplemented exp: #{e}|]
 
 stackifyVal :: Env -> Val -> Stk.Val
 stackifyVal g = \case
-  ValLit (LitInt n) -> Stk.ValImm (ImmInt n)
-  ValLit (LitBool b) -> Stk.ValImm (ImmBool b)
   ValImm imm -> Stk.ValImm imm
   ValVar v -> var g v
   v -> error [i|unimplemented val: #{v}|]

src/Gyehoek/CPS/Syntax.hs

@@ -63,7 +63,6 @@ import Gyehoek.Prelude hiding (op)
 
 data Val
   = ValImm Imm
-  | ValLit Lit
   | ValVar Name
   deriving (Show, Generic, Data, Eq)
 
@@ -173,7 +172,6 @@ instance Plated Exp where
 
 instance S.SexpIso Val where
   sexpIso = match
-    $ With (\lit -> lit . S.sexpIso)
     $ With (\imm -> imm . S.sexpIso)
     $ With (\var -> var . S.sexpIso)
     $ End

src/Gyehoek/Prelude.hs

@@ -1,7 +1,7 @@
 module Gyehoek.Prelude
   ( module Control.Lens
   , module Effectful
-  , module Data.Generics.Labels
+  , module Data.Generics.Labels -- exports instances
   , module Data.String.Interpolate
   , Text
   , List

test/Gyehoek/Test/CPS/Eval.hs

@@ -1,4 +1,4 @@
-module Gyehoek.Test.CPS.Eval (root) where
+module Gyehoek.Test.CPS.Eval where
 
 import Test.Tasty (TestTree, testGroup)
 import Test.Tasty.HUnit
@@ -8,9 +8,8 @@ import Gyehoek.CPS.Eval qualified as Sut
 import Data.List (List)
 
 
-root :: IO TestTree
-root = pure . testGroup "cps interpreter" $
-  [ prim
+test_cpsInterpreter = testGroup "cps interpreter" $
+  [ primitives
   , testCase "halt with constant" do
       evalsTo [ObjImm (ImmInt 123)] [cps|
         (continue halt 123)
@@ -39,7 +38,7 @@ root = pure . testGroup "cps interpreter" $
 evalsTo :: HasCallStack => List Obj -> Sut.Program -> Assertion
 evalsTo rs p = Sut.evalProgram p @?= rs
 
-prim = testGroup "primitives"
+primitives = testGroup "primitives"
   [ testGroup "arith"
     [ testCase "basic 1" do
         evalsTo [ObjImm (ImmInt 20)] [cps|

test/Gyehoek/Test/CPS/Stackify.hs

@@ -1,4 +1,4 @@
-module Gyehoek.Test.CPS.Stackify (root) where
+module Gyehoek.Test.CPS.Stackify where
 
 import Test.Tasty (TestTree, testGroup)
 import Test.Tasty.HUnit
@@ -10,8 +10,7 @@ import Gyehoek.GenSym (runGenSym)
 import Effectful
 
 
-root :: IO TestTree
-root = pure . testGroup "stackify" $
+test_stackify =
   [ trivialReturn
   , tailCall
   , prim

test/Gyehoek/Test/CPS/Syntax.hs

@@ -1,5 +1,5 @@
 {-# LANGUAGE OverloadedLists #-}
-module Gyehoek.Test.CPS.Syntax (root) where
+module Gyehoek.Test.CPS.Syntax where
 
 import Test.Tasty (TestTree, testGroup)
 import Test.Tasty.HUnit
@@ -8,14 +8,13 @@ import Gyehoek.CPS.Syntax (cps)
 import Gyehoek.CPS.Syntax qualified as Sut
 
 
-root :: IO TestTree
-root = pure . testGroup "cps syntax" $
-  [ qqTree
-  , freeTree
+test_root = testGroup "cps syntax"
+  [ free
+  , qq
   ]
 
-freeTree :: TestTree
-freeTree = testGroup "free"
+free :: TestTree
+free = testGroup "free"
   [ testCase "lambda" do
     Sut.free' @Sut.Lambda [cps|
       (lambda (x y z k1) (continue k1 x a b c y))
@@ -27,8 +26,8 @@ freeTree = testGroup "free"
         (continue x y k3))|] @=? ["k3"]
   ]
 
-qqTree :: TestTree
-qqTree = testGroup "parser"
+qq :: TestTree
+qq = testGroup "parser"
   [ testCase "lambda" do
       assertEqual "" (Sut.MkLambda ["x","y"] "ktail"
                (Sut.ExpContinue "ktail" [Sut.ValVar "x"]))

test/Gyehoek/Test/Golden.hs

@@ -1,4 +1,4 @@
-module Gyehoek.Test.Golden (root) where
+module Gyehoek.Test.Golden where
 
 import Test.Tasty (TestTree, testGroup)
 import Test.Tasty.Silver
@@ -31,8 +31,8 @@ brokenStackifyTests =
   -- , "callcc-nested1" -- requires closure-conversion
   -- ]
 
-root :: IO TestTree
-root = do
+test_root :: IO TestTree
+test_root = do
   all_cases <- listDirectory "golden"
   let tests = all_cases
             & fmap ("golden"</>)
@@ -43,6 +43,7 @@ root = do
     ]
 
 maybeBroken name broken = applyWhen (name `elem` broken) expectFail
+
 wasmTests :: List FilePath -> IO TestTree
 wasmTests files = do
   cmd <- getEnvDefault "GYEHOEK_RUNTIME"

test/Gyehoek/Test/Scheme/Syntax.hs

@@ -1,4 +1,4 @@
-module Gyehoek.Test.Scheme.Syntax (root) where
+module Gyehoek.Test.Scheme.Syntax where
 
 import Test.Tasty (TestTree, testGroup)
 import Test.Tasty.HUnit
@@ -7,8 +7,7 @@ import Gyehoek.Scheme.Syntax (scm)
 import Gyehoek.Scheme.Syntax qualified as Sut
 
 
-root :: IO TestTree
-root = pure . testGroup "scheme syntax" $
+test_root = testGroup "scheme syntax" $
   [ freeTree
   ]
 

test/Gyehoek/Test/Sexp.hs

@@ -1,10 +1,4 @@
-module Gyehoek.Test.Sexp
-  ( root
-  , EquivSexp(..)
-  , assertEquiv
-  , equivto
-  )
-  where
+module Gyehoek.Test.Sexp where
 
 import Test.Tasty (TestTree, testGroup)
 import Test.Tasty.HUnit
@@ -14,8 +8,7 @@ import Gyehoek.Sexp (sx, equivalent)
 import Data.Function (on)
 
 
-root :: IO TestTree
-root = pure . testGroup "sexp" $
+test_root = testGroup "sexp" $
   [ sxTree
   ]
 

test/Gyehoek/Test/Stack/VM.hs

@@ -1,4 +1,4 @@
-module Gyehoek.Test.Stack.VM (root) where
+module Gyehoek.Test.Stack.VM where
 
 import Test.Tasty (TestTree, testGroup)
 import Test.Tasty.HUnit
@@ -7,8 +7,7 @@ import Gyehoek.Stack.VM qualified as Sut
 import Data.List (List)
 
 
-root :: IO TestTree
-root = pure . testGroup "stack machine" $
+test_root = testGroup "stack machine" $
   [ lit_int
   , procedure
   , prims

test/Main.hs

@@ -1,27 +1,18 @@
 module Main (main) where
 
-import Test.Tasty (TestTree, testGroup)
+-- import Test.Tasty (TestTree, testGroup)
 import Test.Tasty.Silver.Interactive (defaultMain)
-import qualified Gyehoek.Test.Golden
-import qualified Gyehoek.Test.Sexp
-import qualified Gyehoek.Test.CPS.Syntax
-import qualified Gyehoek.Test.Scheme.Syntax
-import qualified Gyehoek.Test.Stack.VM
-import qualified Gyehoek.Test.CPS.Stackify
-import qualified Gyehoek.Test.CPS.Eval
+-- import qualified Gyehoek.Test.Golden
+-- import qualified Gyehoek.Test.Sexp
+-- import qualified Gyehoek.Test.CPS.Syntax
+-- import qualified Gyehoek.Test.Scheme.Syntax
+-- import qualified Gyehoek.Test.Stack.VM
+-- import qualified Gyehoek.Test.CPS.Stackify
+-- import qualified Gyehoek.Test.CPS.Eval
+import qualified Root
 
 
 main :: IO ()
-main = defaultMain =<< root
-
-root :: IO TestTree
-root = testGroup "test" <$> sequenceA
-  [ Gyehoek.Test.Golden.root
-  , Gyehoek.Test.Sexp.root
-  , Gyehoek.Test.CPS.Syntax.root
-  , Gyehoek.Test.Scheme.Syntax.root
-  , Gyehoek.Test.Stack.VM.root
-  , Gyehoek.Test.CPS.Stackify.root
-  , Gyehoek.Test.CPS.Eval.root
-  ]
-
+main = do
+  discoveredTests <- Root.tests
+  defaultMain discoveredTests

test/Root.hs

@@ -0,0 +1,6 @@
+{-# OPTIONS_GHC
+  -F -pgmF tasty-discover
+  -optF --no-main
+  -optF --generated-module=Root
+#-}
+module Root where