diff --git a/golden/callcc-trivial/exec b/golden/callcc-constant/exec similarity index 100% rename from golden/callcc-trivial/exec rename to golden/callcc-constant/exec diff --git a/golden/callcc-trivial/source.scm b/golden/callcc-constant/source.scm similarity index 100% rename from golden/callcc-trivial/source.scm rename to golden/callcc-constant/source.scm diff --git a/golden/callcc-discard/source.scm b/golden/callcc-discard/source.scm new file mode 100644 index 0000000..a7e9d9f --- /dev/null +++ b/golden/callcc-discard/source.scm @@ -0,0 +1 @@ +(call/cc (_) 1234) diff --git a/golden/callcc-nested1/source.scm b/golden/callcc-nested1/source.scm new file mode 100644 index 0000000..0247689 --- /dev/null +++ b/golden/callcc-nested1/source.scm @@ -0,0 +1,5 @@ +(call/cc + (λ (k1) + (call/cc + (λ (k2) + (k1 456))))) diff --git a/golden/callcc-nested2/exec b/golden/callcc-nested2/exec new file mode 100644 index 0000000..6901ce2 --- /dev/null +++ b/golden/callcc-nested2/exec @@ -0,0 +1,2 @@ +ret > ExitSuccess +out > 456 diff --git a/golden/callcc-nested2/source.scm b/golden/callcc-nested2/source.scm new file mode 100644 index 0000000..5ddd6ee --- /dev/null +++ b/golden/callcc-nested2/source.scm @@ -0,0 +1,5 @@ +(call/cc + (λ (k1) + (call/cc + (λ (k2) + (k2 456))))) diff --git a/gyehoek.cabal b/gyehoek.cabal index 1a16e8f..ea948a1 100644 --- a/gyehoek.cabal +++ b/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 diff --git a/src/Gyehoek/Driver.hs b/src/Gyehoek/Driver.hs index 788b07c..d3bd905 100644 --- a/src/Gyehoek/Driver.hs +++ b/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 () diff --git a/src/Gyehoek/Scheme/Syntax.hs b/src/Gyehoek/Scheme/Syntax.hs index d51a90c..c33de21 100644 --- a/src/Gyehoek/Scheme/Syntax.hs +++ b/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 diff --git a/src/Gyehoek/Stack/Syntax.hs b/src/Gyehoek/Stack/Syntax.hs index d024099..a4da1c0 100644 --- a/src/Gyehoek/Stack/Syntax.hs +++ b/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 diff --git a/test/Gyehoek/Test/Golden.hs b/test/Gyehoek/Test/Golden.hs index 658155e..b8fa33b 100644 --- a/test/Gyehoek/Test/Golden.hs +++ b/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 - , -}stackifyTests tests + [ ignoreTestBecause "wasm codegen is on the backburner" + <$> 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 - pure ( ExitSuccess - , T.unwords . fmap writeObj $ rs - , "" )) - [ Handler \(ErrorCall s) -> - pure (ExitFailure 1, "", T.pack s) - ] + catch @SomeException + (do rs <- Driver.eval_e2e scmfile + pure $!! ( ExitSuccess + , T.unwords . fmap writeObj $ rs + , "" )) + \e -> pure (ExitFailure 1, "", T.pack $ displayException e) in maybeBroken testname brokenStackifyTests $ goldenVsAction testname