enable some working tests

golden/apply-twice/exec

@@ -0,0 +1,2 @@
+ret > ExitSuccess
+out > 17

golden/apply2/exec

@@ -0,0 +1,2 @@
+ret > ExitSuccess
+out > 10

golden/callcc-constant/exec

@@ -0,0 +1,2 @@
+ret > ExitSuccess
+out > 123

golden/callcc-constant/source.scm

@@ -0,0 +1 @@
+(call/cc (λ (cc) (cc 123)))

golden/callcc-discard/exec

@@ -0,0 +1,2 @@
+ret > ExitSuccess
+out > 1234

golden/callcc-discard/source.scm

@@ -0,0 +1 @@
+(call/cc (λ (_) 1234))

golden/callcc-nested1/source.scm

@@ -0,0 +1,5 @@
+(call/cc
+ (λ (k1)
+   (call/cc
+    (λ (k2)
+      (k1 456)))))

golden/callcc-nested2/exec

@@ -0,0 +1,2 @@
+ret > ExitSuccess
+out > 456

golden/callcc-nested2/source.scm

@@ -0,0 +1,5 @@
+(call/cc
+ (λ (k1)
+   (call/cc
+    (λ (k2)
+      (k2 456)))))

gyehoek.cabal

@@ -71,6 +71,7 @@ library
     , binary
     , bytestring
     , containers
+    , deepseq
     , effectful
     , effectful-core
     , effectful-plugin
@@ -112,6 +113,7 @@ test-suite test
 
   build-depends:
     , base
+    , deepseq
     , directory
     , effectful
     , filepath
@@ -119,11 +121,11 @@ test-suite test
     , gyehoek
     , lens
     , process-extras
-    , text
     , sexp-grammar
     , tasty
+    , tasty-expected-failure
     , tasty-hunit
     , tasty-silver
-    , tasty-expected-failure
+    , text
 
   default-language: GHC2024

src/Gyehoek/CPS/Convert.hs

@@ -42,6 +42,22 @@ convert
 convert (Scm.ExpVar x) k = k $ ValVar x
 convert (Scm.ExpLit l) k = k $ ValLit l
 
+-- special case: call/cc is desugared during cps-conversion...
+convert (Scm.ExpPrim (PrimCallCC withcc)) k = do
+  convert withcc \withcc' -> do
+    cc <- gensym' @Name "cc"
+    r <- gensym' "r"
+    m <- k $ ValVar r
+    ccish <- gensym' @Name "cc-ish"
+    x <- gensym' @Name "x"
+    pure [cps|
+      (letrec ((#{cc} (κ (#{r}) #{m})))
+        (letrec ((#{ccish} (λ (#{x} _) (continue #{cc} #{x}))))
+          (#{withcc'} #{ccish} #{cc})))
+    |]
+
+-- ...while all other prims are left as-is for later stages to
+-- handle..
 convert (Scm.ExpPrim p) k =
   telescope (convert @es) p \p' -> do
     r <- gensym' "r"

src/Gyehoek/CPS/Stackify.hs

@@ -14,13 +14,10 @@ import Effectful.Writer.Static.Shared
 import Control.Lens
 import Data.String.Interpolate
 import Gyehoek.Stack.Syntax (Imm(..))
-import Data.HashSet (HashSet)
-import qualified Data.HashSet as HS
 import GHC.Generics (Generic)
 import Data.Foldable
 import Data.HashMap.Strict (HashMap)
 import qualified Data.HashMap.Strict as H
-import Data.HashSet.Lens (hashMap)
 import Data.List (List)
 import GHC.Exts (IsList(fromList))
 
@@ -31,7 +28,9 @@ runStackify :: Eff (Stackify : es) a -> Eff es (a, Stk.Program)
 runStackify = runWriter
 
 live :: Free a => Env -> a -> List Name
-live g e = free' e & filter \x -> x `H.member` g.bound && x /= g.returnLabel
+live g e = free' e & filter \x ->
+  x `H.member` g.bound
+  && not (x `elem` g.contStack)
 
 stackify
   :: (GenSym :> es, Stackify :> es)
@@ -52,7 +51,7 @@ stackify g (ExpLetRec [(f, AbsLambda' xs k m)] e) = do
   lam_body <- gensym' "lambda-body"
   m' <- stackify (g & #bound .~ H.fromList vs
                     & #bound . at f ?~ Stk.ValLabel lam_body
-                    & #returnLabel .~ k) m
+                    & #contStack %~ (k:)) m
   tell [Stk.MkBlock lam_body xs . toList $ m']
   stackify (g & #bound . at f ?~ Stk.ValLabel lam_body) e
 
@@ -63,21 +62,22 @@ stackify g (ExpIf c t f) = do
 
 stackify g (ExpApply f xs ktail) = do
   pure $
-    [ Stk.PushCont (Stk.ValLabel k) ]
+    [ Stk.PushCont k ]
     <> fromList [ Stk.Push (Stk.ValReg l) | l <- ls ]
     <> [ Stk.Call (stackifyVal g f) (stackifyVal g <$> xs) ]
   where
-    k = case var g ktail of
+    k = var g ktail
-      Stk.ValLabel x -> x
+    ls = fold $ (k ^? #ValImm . #ImmLabel)
-      x -> error [i|expected a label, got #{x} (i guess)|]
+      >>= \klbl -> g ^. #liveness . at klbl
-    ls = fold $ g ^. #liveness . at k
 
 -- this probably won't work for call/cc, for cps-converted code it'll
 -- be fine i think. notice how, instead of calling `var g k`, we just
 -- assume it's the return continuation on top of the stack.
 stackify g (ExpContinue k xs) = do
   ktail <- gensym' $ k ^. _Wrapped'
-  pure [ Stk.PopCont ktail
+  pure $
+    fromList [ Stk.PopCont "_" | _ <- takeWhile (/= k) g.contStack ]
+    <> [ Stk.PopCont ktail
        , Stk.Call (Stk.ValReg ktail) (stackifyVal g <$> xs)
        ]
 
@@ -106,16 +106,16 @@ bindReg x = (x, Stk.ValReg x)
 
 data Env = MkEnv
   { bound :: HashMap Name Stk.Val
-  , returnLabel :: Name
   -- | for each locally-bound continuation @k@, @liveness@ has an
   -- entry @(k,ls)@ where @ls@ is the sequence of registers @k@
   -- expects to find saved on the stack.
   , liveness :: HashMap Name (List Name)
+  , contStack :: List Name
   }
   deriving (Show, Generic)
 
 emptyEnv :: Env
-emptyEnv = MkEnv mempty "halt" mempty
+emptyEnv = MkEnv mempty mempty ["halt"]
 
 
 

src/Gyehoek/CPS/Syntax.hs

@@ -42,6 +42,7 @@ import Gyehoek.Sexp qualified
 import Gyehoek.Scheme.Syntax (Name (..), Prim(..), primSexpIso, Lit(..), pattern Void, getName)
 import Data.List (List)
 import GHC.Generics (Generic)
+import Data.Generics.Labels ()
 import Language.SexpGrammar.Generic
 import Control.Category
 import Control.Lens hiding (op)
@@ -79,7 +80,10 @@ data Abs
   | AbsLambda Lambda
   deriving (Show, Generic, Data, Eq)
 
+pattern AbsKappa' :: [Name] -> Exp -> Abs
 pattern AbsKappa' xs e = AbsKappa (MkKappa xs e)
+
+pattern AbsLambda' :: [Name] -> Name -> Exp -> Abs
 pattern AbsLambda' xs e ktail = AbsLambda (MkLambda xs e ktail)
 
 data Exp

src/Gyehoek/Driver.hs

@@ -34,6 +34,7 @@ import Gyehoek.Stack.VM (eval, writeObj, Obj)
 import qualified Data.Text as T
 import Data.List (List)
 import Gyehoek.Stack.Syntax (encodeProgram)
+import Effectful.Exception
 
 
 main :: IO ()

src/Gyehoek/GenSym.hs

@@ -8,7 +8,6 @@ import Effectful.Dispatch.Dynamic
 import Effectful
 import Data.String (IsString(fromString))
 import Data.Text (Text)
-import qualified Data.Text.Short as ST
 
 
 class Gen a where

src/Gyehoek/Scheme/Syntax.hs

@@ -34,16 +34,16 @@ import Data.List (List)
 import Language.SexpGrammar
   ( SexpIso(..), list, el, rest, sym, symbol )
 import Language.SexpGrammar qualified as Sexp
-import Language.Sexp.Located qualified as S
 import Language.SexpGrammar.Generic
 import Effectful
 import GHC.Generics (Generic)
 import Prelude hiding ((.), id)
 import Control.Category
 import Data.List.NonEmpty (NonEmpty)
-import Gyehoek.Sexp qualified
+import Gyehoek.Sexp qualified as GS
 import Gyehoek.GenSym (Gen)
 import Control.Lens
+import Data.Generics.Labels ()
 import Data.String (IsString)
 import Data.Hashable (Hashable)
 import Data.Data (Data)
@@ -57,12 +57,13 @@ import Effectful.FileSystem (runFileSystem)
 import qualified Effectful.FileSystem.IO as FS
 import qualified Data.Text.Encoding as T
 import qualified Effectful.FileSystem.IO.ByteString as FB
+import Control.DeepSeq (NFData)
 
 
 newtype Name = MkName { inner :: Text }
   deriving newtype (Show, Eq, Ord, IsString, Gen, Hashable)
   deriving stock (Generic, Data)
-  deriving anyclass (Wrapped)
+  deriving anyclass (Wrapped, NFData)
 
 instance Prefixed Name where
   prefixed (MkName s) = _Wrapped' . prefixed @Text s . from _Wrapped'
@@ -85,8 +86,10 @@ data Prim e
   | PrimZeroP e
   | PrimNewline
   | PrimMakeClosure { code :: e, env :: List e }
-  | PriEnvRef e Int
+  | PrimEnvRef e Int
-  deriving (Show, Generic, Functor, Foldable, Traversable, Data, Eq)
+  | PrimCallCC e
+  deriving stock (Show, Generic, Functor, Foldable, Traversable, Data, Eq)
+  deriving anyclass (NFData)
 
 instance Each (Prim e) (Prim e') e e'
 
@@ -96,7 +99,8 @@ data Lit
   | LitBool Bool
   | LitString Text
   | LitQuote Sexp
-  deriving (Show, Generic, Data, Eq)
+  deriving stock (Show, Generic, Data, Eq)
+  deriving anyclass (NFData)
 
 pattern Void :: Lit
 pattern Void = LitNil
@@ -104,7 +108,8 @@ pattern Void = LitNil
 data Def
   = DefConstant Name Exp
   | DefProcedure Name (List Name) (List Exp)
-  deriving (Show, Generic, Data)
+  deriving stock (Show, Generic, Data)
+  deriving anyclass (NFData)
 
 data Exp
   = ExpLet (NonEmpty (Name, Exp)) Exp
@@ -116,24 +121,28 @@ data Exp
   | ExpLambda (List Name) Exp
   | ExpVar Name
   | ExpApply Exp (List Exp)
-  deriving (Show, Generic, Data)
+  deriving stock (Show, Generic, Data)
+  deriving anyclass (NFData)
 
 data Sexp
   = SexpCons Sexp Sexp
   | SexpSymbol Text
   | SexpLit Lit
-  deriving (Show, Generic, Data, Eq)
+  deriving stock (Show, Generic, Data, Eq)
+  deriving anyclass (NFData)
 
 data CommandOrDef
   = Command Exp
   | Definition Def
   | Begin (List CommandOrDef)
-  deriving (Show, Generic, Data)
+  deriving stock (Show, Generic, Data)
+  deriving anyclass (NFData)
 
 data Program = MkProgram
   { commandsAndDefs :: List CommandOrDef
   }
-  deriving (Show, Generic, Data)
+  deriving stock (Show, Generic, Data)
+  deriving anyclass (NFData)
 
 instance Each Program Program (Either Exp Def) (Either Exp Def) where
   each = #commandsAndDefs . each . go
@@ -156,29 +165,29 @@ instance SexpIso Name where
 
 primSexpIso :: (Text -> Text) -> Sexp.SexpGrammar a -> Sexp.SexpGrammar (Prim a)
 primSexpIso namefn a = match
-    $ With (. binop "+")
+    $ With (. ht2 "+")
-    $ With (. binop "-")
+    $ With (. ht2 "-")
-    $ With (. binop "*")
+    $ With (. ht2 "*")
-    $ With (. binop "/")
+    $ With (. ht2 "/")
-    $ With (. binop "cons")
+    $ With (. ht2 "cons")
-    $ With (. unop "car")
+    $ With (. ht1 "car")
-    $ With (. unop "cdr")
+    $ With (. ht1 "cdr")
-    $ With (. unop "immediate?")
+    $ With (. ht1 "immediate?")
-    $ With (. unop "cons?")
+    $ With (. ht1 "cons?")
-    $ With (. unop "integer?")
+    $ With (. ht1 "integer?")
-    $ With (. unop "write")
+    $ With (. ht1 "write")
-    $ With (. unop "zero?")
+    $ With (. ht1 "zero?")
     $ With (. nullop "newline")
-    $ With (. mkclosure)
+    $ With (. ht1' "make-closure")
-    $ With (. envref)
+    $ With (. GS.headTagged2 (namefn "env-ref") a Sexp.int)
+    $ With (. ht1 "call/cc")
     $ End
     where
       idn s = el (sym (namefn s))
       nullop s = list $ idn s
-      unop s = list $ idn s >>> el a
+      ht1 s = GS.headTagged1 (namefn s) a
-      binop s = list $ idn s >>> el a >>> el a
+      ht2 s = GS.headTagged2 (namefn s) a a
-      mkclosure = list $ idn "make-closure" >>> el a >>> rest a
+      ht1' s = GS.headTagged1' (namefn s) a a
-      envref = list $ idn "env-ref" >>> el a >>> el Sexp.int
 
 instance SexpIso a => SexpIso (Prim a) where
   -- sexpIso = primSexpIso ("prim:"<>) sexpIso
@@ -188,14 +197,14 @@ instance SexpIso Lit where
   sexpIso = match
     $ With (. sexpIso)
     $ With (. sym "nil")
-    $ With (. Gyehoek.Sexp.schemeBool)
+    $ With (. GS.schemeBool)
     $ With (. sexpIso)
-    $ With (. Gyehoek.Sexp.prefixSugar "quote" Sexp.Quote sexpIso)
+    $ With (. GS.prefixSugar "quote" Sexp.Quote sexpIso)
     $ End
 
 instance SexpIso Sexp where
   sexpIso = match
-    $ With (\conss -> conss . Gyehoek.Sexp.todo)
+    $ With (\conss -> conss . GS.todo)
     $ With (\s -> s . symbol)
     $ With (\lit -> lit . sexpIso)
     $ End
@@ -212,8 +221,8 @@ instance SexpIso Def where
   
 instance SexpIso Exp where
   sexpIso = match
-    $ With (. Gyehoek.Sexp.let_ "let" sexpIso sexpIso sexpIso)
+    $ With (. GS.let_ "let" sexpIso sexpIso sexpIso)
-    $ With (. Gyehoek.Sexp.let_ "letrec" sexpIso sexpIso sexpIso)
+    $ With (. GS.let_ "letrec" sexpIso sexpIso sexpIso)
     $ With (. sexpIso)
     $ With (\bgn -> bgn . list (el (sym "begin") >>> rest sexpIso))
     $ With (. if_)
@@ -225,7 +234,7 @@ instance SexpIso Exp where
     where
       if_ = list $ el (sym "if") >>> el sexpIso >>> el sexpIso >>> el sexpIso
       lam = list
-        ( el Gyehoek.Sexp.lambdaKeyword
+        ( el GS.lambdaKeyword
           >>> el (sexpIso @(List Name))
           >>> el sexpIso )
 
@@ -242,7 +251,7 @@ instance SexpIso CommandOrDef where
 -- utilities
 
 scm :: QuasiQuoter
-scm = Gyehoek.Sexp.makeSx [|| Gyehoek.Sexp.fromSexp @Exp ||]
+scm = GS.makeSx [|| GS.fromSexp @Exp ||]
 
 free :: Exp -> HashSet Name
 free = cata \case
@@ -278,9 +287,8 @@ hGetContents h = T.decodeUtf8 <$> FB.hGetContents h
 readProgram :: IOE :> es => FilePath -> Eff es Program
 readProgram fp = runFileSystem $
   FS.withFile fp FS.ReadMode $ \h ->
-    Gyehoek.Sexp.parseSexps @CommandOrDef (fileName fp) <$> hGetContents h
+    GS.parseSexps @CommandOrDef (fileName fp) <$> hGetContents h
      >>= either error (pure . MkProgram)
 
-readExp :: IOE :> es => FilePath -> Eff es Program
+readExp :: IOE :> es => FilePath -> Eff es Exp
-readExp fp = readProgram fp <&>
+readExp fp = readProgram fp <&> (^?! #commandsAndDefs . _head . #Command)
-  (^?! (#commandsAndDefs . _head . _Comm))

src/Gyehoek/Sexp.hs

@@ -25,8 +25,6 @@ module Gyehoek.Sexp
   , lambdaKeyword
   , encodePrettyWith
   , encodePretty
-  , UglySexpIso(..)
-  , AsSexpIso(..)
   , SpliceSexp(..)
   , parseSexpsWithPos
   , parseSexpWithPos
@@ -56,41 +54,26 @@ import Data.Text (Text)
 import Language.SexpGrammar as Sexp hiding (toSexp, List, encode, decode, encodeWith, decodeWith, iso, encodePrettyWith, encodePretty, fromSexp)
 import Language.SexpGrammar qualified as Sexp
 import Language.Sexp qualified as S
-import Language.SexpGrammar.Generic
 import Data.InvertibleGrammar.Base qualified as IGB
 import Data.InvertibleGrammar qualified as IG
 import Data.InvertibleGrammar.Base ((:-)((:-)))
 import Data.List.NonEmpty (NonEmpty ((:|)))
-import Data.List.NonEmpty qualified as NE
 import Data.List (List, groupBy)
 import Data.Text.Encoding
-import Data.Either (either)
 import GHC.Generics (Generic)
 import Control.Lens hiding (para)
-import Data.Generics.Labels
-import System.Process
-import GHC.IO.Unsafe (unsafePerformIO)
-import qualified Data.Text.IO as TIO
 import Control.Monad (join)
 import qualified Language.Sexp.Located as SL
-import Data.Void (absurd, Void)
+import Data.Void (absurd)
-import Data.Coerce (coerce)
-import qualified Data.Map
 import Language.Haskell.TH.Quote
-import Language.Haskell.TH (Quote, location, Loc (..), ExpQ, varE, mkName, listE, Exp, appE, conE, Q, Code, unTypeCode)
+import Language.Haskell.TH (Quote, location, Loc (..), ExpQ, varE, mkName, listE, Exp, appE, Q, Code, unTypeCode)
 import qualified Data.Text as T
 import qualified Control.Category
 import Data.Data (Data (..), Typeable, cast)
 import Language.Haskell.TH.Syntax (lift, Lift, liftData)
-import GHC.IsList (fromList)
+import Data.Functor.Foldable (cata)
-import Data.Functor.Foldable (cata, para, embed)
-import Data.Functor.Classes (Show1(..))
 import Data.Vector (Vector)
 import Numeric.Natural (Natural)
-import Data.Maybe (fromMaybe)
-import Control.Applicative (Alternative((<|>)))
-import Debug.Pretty.Simple
-import qualified Data.Vector as V
 import qualified Data.Vector.Strict
 import Data.Function (on)
 import Data.String (IsString (fromString))
@@ -199,11 +182,6 @@ let_ kw name rhs e = list (el (sym kw) >>> el bindings >>> el e)
 data DotList a = MkDotList (NonEmpty a) a
   deriving (Show, Generic)
 
-dotlist :: (forall t. Grammar Position (Sexp :- t) (a :- t)) -> _
-dotlist x = list $ rest $ coproduct
-  [ x >>> _
-  ]
-
 -- | Define a sexp representation as either (⟨name⟩ ⟨e⟩) or '⟨e⟩.
 prefixSugar
   :: Text -> Prefix
@@ -217,7 +195,7 @@ prefixSugar name prefix e = coproduct
   ]
 
 todo :: Grammar p (Sexp :- t) t'
-todo = (IGB.Flip $ IGB.PartialIso absurd f) >>> IGB.PartialIso absurd g
+todo = IGB.Flip (IGB.PartialIso absurd f) >>> IGB.PartialIso absurd g
   where
     f _ = Left $ unexpected "todo"
     g _ = Left $ unexpected "todo"
@@ -280,31 +258,6 @@ headTagged2 s g1 g2 = list $ el (sym s) >>> el g1 >>> el g2
 
 
 
-class UglySexpIso a where
-  uglySexpIso :: SexpGrammar a
-
-newtype AsSexpIso a = AsSexpIso a
-newtype AsUglySexpIso a = AsUglySexpIso a
-
-asSexpIso :: Grammar p (a :- t) (AsSexpIso a :- t)
-asSexpIso = Sexp.iso AsSexpIso (\(AsSexpIso x) -> x)
-
-instance UglySexpIso a => SexpIso (AsUglySexpIso a) where
-  sexpIso = uglySexpIso @a >>> Sexp.iso coerce coerce
-
-instance SexpIso a => UglySexpIso (AsSexpIso a) where
-  uglySexpIso = sexpIso >>> Sexp.iso (\x -> AsSexpIso x) (\(AsSexpIso x) -> x)
-
--- why not work
--- deriving via AsSexpIso Text instance UglySexpIso Text
-
-instance UglySexpIso Text where uglySexpIso = sexpIso
-instance UglySexpIso Integer where uglySexpIso = sexpIso
-instance UglySexpIso Int where uglySexpIso = sexpIso
-instance UglySexpIso Bool where uglySexpIso = sexpIso
-instance UglySexpIso Double where uglySexpIso = sexpIso
-instance UglySexpIso () where uglySexpIso = sexpIso
-
 instance SexpIso Sexp where
   sexpIso = Control.Category.id
 
@@ -334,8 +287,11 @@ toSexp = either error id . Sexp.toSexp sexpIso
 toSexps :: (Foldable f, SexpIso a) => f a -> List Sexp
 toSexps = foldMap \x -> [toSexp x]
 
+pattern Unquote :: Text -> Sexp
 pattern Unquote x =
   SL.Modified Hash (SL.BraceList [SL.Symbol x])
+
+pattern UnquoteSplicing :: Text -> Sexp
 pattern UnquoteSplicing x =
   SL.Modified Hash (SL.Modified Hash (SL.BraceList [SL.Symbol x]))
 

src/Gyehoek/Stack/Syntax.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE TemplateHaskellQuotes #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE DeriveAnyClass #-}
 module Gyehoek.Stack.Syntax
   ( Program(..)
   , Block(..)
@@ -32,6 +33,7 @@ import Effectful
 import Gyehoek.Scheme.Syntax (Name(..), Lit(..), Prim(..))
 import GHC.Exts (IsList(..))
 import Data.List (intersperse)
+import Control.DeepSeq (NFData)
 
 
 newtype Program = MkProgram
@@ -39,6 +41,7 @@ newtype Program = MkProgram
   }
   deriving stock (Show, Generic, Data)
   deriving newtype (Semigroup, Monoid)
+  deriving anyclass (NFData)
 
 instance IsList Program where
   type Item Program = Block
@@ -51,6 +54,7 @@ data Block = MkBlock
   , code :: List Instr
   }
   deriving stock (Show, Generic, Data)
+  deriving anyclass (NFData)
 
 instance Each Block Block Instr Instr where
   each = #code . each
@@ -64,11 +68,13 @@ data Instr
   | Call Val (List Val)
   | If Val (List Instr) (List Instr)
   deriving stock (Show, Generic, Data)
+  deriving anyclass (NFData)
 
 data Val
   = ValReg Name
   | ValImm Imm
   deriving stock (Show, Generic, Data, Eq)
+  deriving anyclass (NFData)
 
 pattern ValLabel :: Name -> Val
 pattern ValLabel x = ValImm (ImmLabel x)
@@ -78,10 +84,12 @@ data Imm
   | ImmBool Bool
   | ImmLabel Name
   deriving stock (Show, Generic, Data, Eq)
+  deriving anyclass (NFData)
 
 data Obj
   = ObjImm Imm
-  deriving (Show, Generic, Data, Eq)
+  deriving stock (Show, Generic, Data, Eq)
+  deriving anyclass (NFData)
 
 
 --- sexp work

test/Gyehoek/Test/CPS/Stackify.hs

@@ -8,7 +8,6 @@ import Data.List (List)
 import Gyehoek.CPS.Syntax (cps)
 import Gyehoek.GenSym (runGenSym)
 import Effectful
-import Test.Tasty.ExpectedFailure (expectFail)
 
 
 root :: IO TestTree
@@ -54,6 +53,12 @@ prim = testGroup "prim"
       evalsTo [ObjImm (ImmInt 9)]
         [cps|(prim (+ 4 5)
                (κ (x) (continue halt 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

test/Gyehoek/Test/CPS/Syntax.hs

@@ -3,12 +3,9 @@ module Gyehoek.Test.CPS.Syntax (root) where
 
 import Test.Tasty (TestTree, testGroup)
 import Test.Tasty.HUnit
-import Language.Sexp.Located qualified as SL
 import Language.SexpGrammar ()
 import Gyehoek.CPS.Syntax (cps)
 import Gyehoek.CPS.Syntax qualified as Sut
-import Data.Function (on)
-import Gyehoek.Test.Sexp (equivto)
 
 
 root :: IO TestTree

test/Gyehoek/Test/Golden.hs

@@ -10,30 +10,24 @@ import System.Directory
 import Data.Function
 import System.Environment.Blank (getEnvDefault)
 import qualified System.Process.Text as PT
-import Control.Exception (catches, ErrorCall(..), Handler(..))
+import Control.Exception (catch, Exception (displayException))
 import Gyehoek.Stack.VM (writeObj)
 import Data.Text qualified as T
 import System.Exit (ExitCode(..))
-import Test.Tasty.ExpectedFailure (expectFail)
+import Test.Tasty.ExpectedFailure (expectFail, ignoreTestBecause)
+import Control.DeepSeq (($!!))
 
 
 brokenWasmTests :: List String
 brokenWasmTests =
-  [ "adder"
+  [
-  , "apply-twice"
-  , "square"
-  , "fn-of-fn"
-  , "let-fn"
-  , "apply2"
-  , "factorial"
   ]
 
 brokenStackifyTests :: List String
 brokenStackifyTests =
-  [ "apply-twice"
+  [ "adder"
-  , "adder"
-  , "apply2"
   , "let-fn"
+  , "callcc-nested1" -- requires closure-conversion
   ]
 
 root :: IO TestTree
@@ -42,7 +36,8 @@ root = do
   let tests = all_cases
             & fmap ("golden"</>)
   testGroup "golden" <$> sequenceA
-    [ wasmTests tests
+    [ ignoreTestBecause "wasm codegen is on the backburner"
+      <$> wasmTests tests
     , stackifyTests tests
     ]
 
@@ -72,13 +67,12 @@ stackifyTests files = do
         scmfile = test </> "source.scm"
         resultfile = test </> "exec"
         action =
-          catches (do rs <- Driver.eval_e2e scmfile
+          catch @SomeException
-                      pure ( ExitSuccess
+            (do rs <- Driver.eval_e2e scmfile
-                           , T.unwords . fmap writeObj $ rs
+                pure $!! ( ExitSuccess
-                           , "" ))
+                     , T.unwords . fmap writeObj $ rs
-            [ Handler \(ErrorCall s) ->
+                     , "" ))
-                pure (ExitFailure 1, "", T.pack s)
+            \e -> pure (ExitFailure 1, "", T.pack $ displayException e)
-            ]
     in maybeBroken testname brokenStackifyTests $
      goldenVsAction
        testname

test/Gyehoek/Test/Stack/VM.hs

@@ -5,8 +5,6 @@ import Test.Tasty.HUnit
 import Gyehoek.Stack.Syntax
 import Gyehoek.Stack.VM qualified as Sut
 import Data.List (List)
-import Control.Lens
-import Data.Generics.Labels
 
 
 root :: IO TestTree
@@ -31,8 +29,6 @@ lit_int = testCase "lit int" do
       ]
     ]
 
-vlb = ValImm . ImmLabel
-
 procedure = testGroup "procedure"
   [ testCase "return constant" do
       evalsTo [ObjImm (ImmInt 123)]
@@ -66,7 +62,7 @@ procedure = testGroup "procedure"
           ]
         ]
   , testCase "factorial" do
-      let fac =
+      let fac n =
             [ MkBlock "fac" ["n"]
               [ Prim "x0" $ PrimZeroP (ValReg "n")
               , If (ValReg "x0")
@@ -85,17 +81,12 @@ procedure = testGroup "procedure"
               , PopCont "ktail"
               , Call (ValReg "ktail") [ValReg "x3"]
               ]
+            , MkBlock "main" []
+              [ Call (ValLabel "fac") [ValImm (ImmInt n)]
+              ]
             ]
-      evalsTo [ObjImm (ImmInt 1)] $
+      evalsTo [ObjImm (ImmInt 1)] $ fac 0
-        [ MkBlock "main" []
+      evalsTo [ObjImm (ImmInt 720)] $ fac 6
-          [ Call (ValLabel "fac") [ValImm (ImmInt 0)]
-          ]
-        ] ++ fac
-      evalsTo [ObjImm (ImmInt 720)] $
-        [ MkBlock "main" []
-          [ Call (ValLabel "fac") [ValImm (ImmInt 6)]
-          ]
-        ] ++ fac
   ]
 
 prims = testGroup "prims"