remove CPS.ValLit

gyehoek.cabal

@@ -107,8 +107,7 @@ test-suite test
   type:               exitcode-stdio-1.0
   hs-source-dirs:     test
   main-is:            Main.hs
-  build-tool-depends:
+  build-tool-depends: tasty-discover:tasty-discover
-    tasty-discover:tasty-discover
   other-modules:
     Gyehoek.Test.CPS.Eval
     Gyehoek.Test.CPS.Stackify
@@ -117,6 +116,7 @@ test-suite test
     Gyehoek.Test.Scheme.Syntax
     Gyehoek.Test.Sexp
     Gyehoek.Test.Stack.VM
+    Root
 
   build-depends:
     , base

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
+    -- but we're reusing the lambda binding so we don't have to
-    -- reverences.
+    -- explicitly substitute recursive calls.
-    -- env <- gensym' @Name "env"
     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 ->
+  MkProgram <$> telescope (convert @es) (p ^.. each . _Left) (pure . Halt)
-    pure . Halt1 $ case NE.nonEmpty exps of
-      Nothing -> ValLit Void
-      Just es -> NE.last es
 
 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) =
+lowerVal g (ValImm imm) =
-  pure $ case l of
+  pure $ case imm of
-    LitInt n -> [expr|
+    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/Main.hs

@@ -1,8 +1,7 @@
-{-# OPTIONS_GHC -F -pgmF tasty-discover #-}
 module Main (main) where
 
 -- import Test.Tasty (TestTree, testGroup)
--- import Test.Tasty.Silver.Interactive (defaultMain)
+import Test.Tasty.Silver.Interactive (defaultMain)
 -- import qualified Gyehoek.Test.Golden
 -- import qualified Gyehoek.Test.Sexp
 -- import qualified Gyehoek.Test.CPS.Syntax
@@ -10,19 +9,10 @@ module Main (main) where
 -- import qualified Gyehoek.Test.Stack.VM
 -- import qualified Gyehoek.Test.CPS.Stackify
 -- import qualified Gyehoek.Test.CPS.Eval
+import qualified Root
 
 
--- main :: IO ()
+main :: IO ()
--- main = defaultMain =<< root
+main = do
-
+  discoveredTests <- Root.tests
--- root :: IO TestTree
+  defaultMain discoveredTests
--- 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
---   ]
-

test/Root.hs

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