tasty-discover

gyehoek.cabal

@@ -103,11 +103,12 @@ library
   default-language: GHC2024
 
 test-suite test
-  import:             ghcstuffs, ghcstuffs-dev
-  type:               exitcode-stdio-1.0
-  hs-source-dirs:     test
-  main-is:            Main.hs
-  build-tool-depends: tasty-discover:tasty-discover
+  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
@@ -116,7 +117,6 @@ test-suite test
     Gyehoek.Test.Scheme.Syntax
     Gyehoek.Test.Sexp
     Gyehoek.Test.Stack.VM
-    Root
 
   build-depends:
     , base
@@ -135,4 +135,4 @@ test-suite test
     , tasty-silver
     , text
 
-  default-language:   GHC2024
+  default-language: GHC2024

src/Gyehoek/CPS/Close.hs

@@ -13,8 +13,9 @@ 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 so we don't have to
-    -- explicitly substitute recursive calls.
+    -- but we're reusing the lambda binding for the sake of recursive
+    -- reverences.
+    -- 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,16 +23,18 @@ 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 . ValImm $ case l of
-  LitInt n -> ImmInt n
-  LitBool b -> ImmBool b
-  _ -> _
+convert (Scm.ExpLit l) k = k $ ValLit l
 
 -- special case: call/cc is desugared during cps-conversion...
 convert (Scm.ExpPrim (PrimCallCC withcc)) k = do
@@ -110,7 +112,10 @@ convertLambda bs m = do
 
 convertProgram :: forall es. (GenSym :> es) => Scm.Program -> Eff es Program
 convertProgram p =
-  MkProgram <$> telescope (convert @es) (p ^.. each . _Left) (pure . Halt)
+  MkProgram <$> telescope (convert @es) (p ^.. each . _Left) \exps ->
+    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,15 +60,13 @@ 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 (ValImm imm) =
-  pure $ case imm of
-    ImmInt n -> [expr|
+lowerVal g (ValLit l) =
+  pure $ case l of
+    LitInt n -> [expr|
       (i32.const #{n})
       ##{makeSmallFixnum}
     |]
-    ImmBool b -> [expr|
+    LitBool b -> [expr|
       (i32.const #{b'})
       ref.i31
     |]

src/Gyehoek/CPS/Stackify.hs

@@ -87,6 +87,8 @@ 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,6 +63,7 @@ import Gyehoek.Prelude hiding (op)
 
 data Val
   = ValImm Imm
+  | ValLit Lit
   | ValVar Name
   deriving (Show, Generic, Data, Eq)
 
@@ -172,6 +173,7 @@ 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 -- exports instances
+  , module Data.Generics.Labels
   , module Data.String.Interpolate
   , Text
   , List

test/Main.hs

@@ -1,7 +1,8 @@
+{-# 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
@@ -9,10 +10,19 @@ import Test.Tasty.Silver.Interactive (defaultMain)
 -- import qualified Gyehoek.Test.Stack.VM
 -- import qualified Gyehoek.Test.CPS.Stackify
 -- import qualified Gyehoek.Test.CPS.Eval
-import qualified Root
 
 
-main :: IO ()
-main = do
-  discoveredTests <- Root.tests
-  defaultMain discoveredTests
+-- 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
+--   ]
+

test/Root.hs

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