fix catching of exceptions in tests

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/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/Scheme/Syntax.hs

@@ -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'
@@ -87,7 +88,8 @@ data Prim e
   | PrimMakeClosure { code :: e, env :: List e }
   | PrimEnvRef e Int
   | PrimCallCC e
-  deriving (Show, Generic, Functor, Foldable, Traversable, Data, Eq)
+  deriving stock (Show, Generic, Functor, Foldable, Traversable, Data, Eq)
+  deriving anyclass (NFData)
 
 instance Each (Prim e) (Prim e') e e'
 
@@ -97,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
@@ -105,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
@@ -117,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

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/Golden.hs

@@ -10,11 +10,12 @@ 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 (catches, ErrorCall(..), Handler(..), catch, SomeException (SomeException), 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
@@ -36,8 +37,9 @@ root = do
   let tests = all_cases
             & fmap ("golden"</>)
   testGroup "golden" <$> sequenceA
-    [ {-wasmTests tests
+    [ ignoreTestBecause "wasm codegen is on the backburner"
-    , -}stackifyTests tests
+      <$> wasmTests tests
+    , stackifyTests tests
     ]
 
 maybeBroken name broken = applyWhen (name `elem` broken) expectFail
@@ -65,14 +67,19 @@ stackifyTests files = do
     let testname = takeFileName test
         scmfile = test </> "source.scm"
         resultfile = test </> "exec"
+        -- action = Driver.eval_e2e' scmfile >>= \case
+        --     Right rs ->
+        --       pure ( ExitSuccess
+        --            , T.unwords . fmap writeObj $ rs
+        --            , "" )
+        --     Left e -> pure (ExitFailure 1, "", T.pack $ displayException e)
         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