superfuck
This commit is contained in:
@@ -0,0 +1,2 @@
|
||||
(let ((p (cons 123 456)))
|
||||
(cons (cdr p) (car p)))
|
||||
@@ -31,7 +31,6 @@ close1 = \case
|
||||
(each . _2)
|
||||
(freeWithBound' boundNames')
|
||||
& nub
|
||||
pTraceShowM frees
|
||||
env_cont_l <- gensym' @Name "env-cont"
|
||||
e_l <- gensym' @Name "letrec-body-cont"
|
||||
bs' <- for bs \(f,ab) -> do
|
||||
|
||||
@@ -49,12 +49,15 @@ convert (Scm.ExpLit l) k = k . one . ValImm $ case l of
|
||||
convert (Scm.ExpPrim p) k =
|
||||
telescope (convert1 @es) p \p' -> do
|
||||
r_l <- gensym' "r"
|
||||
k_l <- gensym' @Name "prim-k"
|
||||
-- k_l <- gensym' @Name "prim-k"
|
||||
m <- k [ValVar r_l]
|
||||
pure [cps|
|
||||
(letrec ((#{k_l} (κ (#{r_l}) #{m})))
|
||||
(prim #{p'} #{k_l}))
|
||||
(prim #{p'} (κ (#{r_l}) #{m}))
|
||||
|]
|
||||
-- pure [cps|
|
||||
-- (letrec ((#{k_l} (κ (#{r_l}) #{m})))
|
||||
-- (prim #{p'} #{k_l}))
|
||||
-- |]
|
||||
|
||||
convert (Scm.ExpLambda xs e) k = do
|
||||
f <- gensym' "lambda-body"
|
||||
|
||||
+203
-118
@@ -1,12 +1,16 @@
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE OverloadedLists #-}
|
||||
module Gyehoek.CPS.Eval
|
||||
( evalProgram
|
||||
, module Gyehoek.CPS.Syntax
|
||||
, evalExp
|
||||
, eGrammar
|
||||
) where
|
||||
|
||||
import Gyehoek.CPS.Syntax hiding (Hob(..), Obj(..))
|
||||
import Gyehoek.Sexp qualified as S
|
||||
import Control.Lens
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Text.Show.Functions ()
|
||||
@@ -18,150 +22,231 @@ import Control.Monad.Cont qualified as Cont
|
||||
import Gyehoek.Sexp qualified as S
|
||||
import GHC.Generics (Generically(..))
|
||||
import Gyehoek.Sexp ((:-)(..))
|
||||
import Data.List (nub, mapAccumR)
|
||||
import Data.HashSet.Lens (setOf)
|
||||
import Data.IntMap.Strict (IntMap)
|
||||
import Data.IntMap.Strict qualified as IM
|
||||
import Data.Monoid
|
||||
|
||||
|
||||
data Env = MkEnv
|
||||
{ store :: HashMap Name Obj
|
||||
}
|
||||
deriving stock (Show, Generic, Data, Eq)
|
||||
deriving (Semigroup, Monoid)
|
||||
via Generically Env
|
||||
newtype Loc = MkLoc { getLoc :: Int }
|
||||
deriving stock (Generic, Data)
|
||||
deriving newtype (Show, Eq, Ord, Enum)
|
||||
|
||||
emptyEnv = MkEnv
|
||||
{ store = mempty
|
||||
data Store = MkStore
|
||||
{ nextLoc :: Loc
|
||||
, heap :: IntMap E
|
||||
}
|
||||
deriving stock (Show, Generic, Data)
|
||||
|
||||
emptyStore :: Store
|
||||
emptyStore = MkStore
|
||||
{ nextLoc = 0
|
||||
, heap = mempty
|
||||
}
|
||||
|
||||
|
||||
newtype Env = MkEnv { getEnv :: HashMap Name Loc }
|
||||
deriving stock (Show, Generic, Data)
|
||||
deriving newtype (Semigroup, Monoid)
|
||||
|
||||
data Obj
|
||||
= ObjImm Imm
|
||||
| ObjHob Hob
|
||||
deriving stock (Show, Generic, Data, Eq)
|
||||
emptyEnv :: Env
|
||||
emptyEnv = mempty
|
||||
|
||||
-- | a heap object.
|
||||
data Hob
|
||||
= HobClosure { code :: Abs, env :: Env}
|
||||
-- should a continuation have a label, or an Obj?
|
||||
| HobPair Obj Obj
|
||||
deriving stock (Show, Generic, Data, Eq)
|
||||
type instance Index Env = Name
|
||||
type instance IxValue Env = Loc
|
||||
|
||||
instance S.DatumIso Obj where
|
||||
datumIso = S.match
|
||||
$ S.With (S.datumIso @Imm >>>)
|
||||
$ S.With (S.datumIso @Hob >>>)
|
||||
$ S.End
|
||||
instance Ixed Env where ix j = #getEnv . ix j
|
||||
instance At Env where at j = #getEnv . at j
|
||||
|
||||
instance S.DatumIso Hob where
|
||||
datumIso = S.match
|
||||
$ S.With (closure >>>)
|
||||
$ S.With (conspair >>>)
|
||||
$ S.End
|
||||
where
|
||||
conspair = S.dottedList (S.el S.datumIso) S.datumIso
|
||||
-- closures can be printed, but not parsed.
|
||||
closure :: S.G (S.Datum :- t) (Env :- Abs :- t)
|
||||
closure = S.Flip $ S.PartialIso
|
||||
(\(_:-_:-t) -> S.Unreadable [i|\#<procedure>|] :- t)
|
||||
(const . Left $ mempty)
|
||||
update :: Loc -> E -> Store -> Store
|
||||
update (MkLoc loc) v = #heap %~ IM.alter f loc
|
||||
where
|
||||
f (Just _) = Just v
|
||||
f Nothing = error "segfault lol"
|
||||
|
||||
updates :: Foldable f => f (Loc, E) -> Store -> Store
|
||||
updates = alaf Endo foldMap (uncurry update)
|
||||
|
||||
fetch :: Loc -> Store -> E
|
||||
fetch (MkLoc loc) st = st ^?! #heap . ix loc
|
||||
|
||||
new :: Store -> (Store, Loc)
|
||||
new st = (st & #nextLoc %~ succ, st.nextLoc)
|
||||
|
||||
new' :: E -> Store -> (Store, Loc)
|
||||
new' e st = (update l e st', l)
|
||||
where
|
||||
(st',l) = new st
|
||||
|
||||
news' :: Traversable t => t E -> Store -> (Store, Loc)
|
||||
news' es st = mapAccumR _ st es
|
||||
where
|
||||
(st',l) = new st
|
||||
|
||||
var :: HasCallStack => Env -> Name -> Loc
|
||||
var g x = g ^?! ix x
|
||||
|
||||
type CmdCont = Store -> Answer
|
||||
type ExpCont = List E -> CmdCont
|
||||
|
||||
data Answer
|
||||
= AnswerValues Store (List E)
|
||||
| AnswerError Text
|
||||
deriving (Show, Generic, Data)
|
||||
|
||||
data Mutability
|
||||
= Mut
|
||||
| NoMut
|
||||
deriving (Show, Generic, Data, Eq)
|
||||
|
||||
wrong :: Text -> CmdCont
|
||||
wrong = const . AnswerError
|
||||
|
||||
single :: (E -> CmdCont) -> ExpCont
|
||||
single k = \case
|
||||
[x] -> k x
|
||||
_ -> wrong "wrong number of return values"
|
||||
|
||||
send :: E -> ExpCont -> CmdCont
|
||||
send e k = k [e]
|
||||
|
||||
-- | Continue with the value located at a given 'Loc'.
|
||||
hold :: Loc -> ExpCont -> CmdCont
|
||||
hold loc k st = send (fetch loc st) k st
|
||||
|
||||
tievals :: Traversable t => t E -> (t Loc -> CmdCont) -> CmdCont
|
||||
tievals es f st0 = f ls stn
|
||||
where
|
||||
(stn,ls) = mapAccumR (flip new') st0 es
|
||||
|
||||
bind :: Name -> Loc -> Env
|
||||
bind k = MkEnv . H.singleton k
|
||||
|
||||
extends :: Foldable f => f (Name, Loc) -> Env -> Env
|
||||
extends xs g = g <> foldMap (uncurry bind) xs
|
||||
|
||||
|
||||
|
||||
err :: Jalmot :> es => Text -> Eff es a
|
||||
err = throwError . VMError
|
||||
-- | The denotation of an expressed value.
|
||||
data E
|
||||
= ESymbol Text
|
||||
| ECharacter Char
|
||||
| EInteger Int
|
||||
| EBool Bool
|
||||
| EUndefined
|
||||
| EUnspecified
|
||||
| ENull
|
||||
| EPair Loc Loc Mutability
|
||||
| EVec (List Loc) Mutability
|
||||
| EString (List Loc) Mutability
|
||||
| EProcedure Loc Procedure
|
||||
deriving stock (Show, Generic, Data)
|
||||
|
||||
eval1 :: Jalmot :> es => Env -> Exp -> Eff es Obj
|
||||
eval1 g e = eval g e >>= \case
|
||||
[r] -> pure r
|
||||
rs -> err [i|expected one value, but got #{rs}|]
|
||||
type Procedure = List E -> DynPoints -> ExpCont -> CmdCont
|
||||
|
||||
pure1 :: Applicative f => a -> f (List a)
|
||||
pure1 = pure . (:[])
|
||||
|
||||
eval
|
||||
:: Jalmot :> es
|
||||
=> Env -> Exp
|
||||
-> Eff es (List Obj)
|
||||
|
||||
eval g (ExpLetRec bs e) = eval g' e
|
||||
eGrammar :: Store -> S.DatumGrammar E
|
||||
eGrammar st = S.partialOsi (const . Left $ mempty) go
|
||||
where
|
||||
g' = g <> foldMap
|
||||
(\(f,ab) -> mempty & #store . at f ?~
|
||||
ObjHob (HobClosure ab g'))
|
||||
bs
|
||||
gofetch x = go $ fetch x st
|
||||
go = \case
|
||||
ESymbol s -> S.Symbol s
|
||||
ECharacter c -> S.Character c
|
||||
EInteger n -> S.Number (fromIntegral n)
|
||||
EBool b -> S.Boolean b
|
||||
EUndefined -> S.Unreadable "#<undefined>"
|
||||
EUnspecified -> S.Unreadable "#<unspecified>"
|
||||
ENull -> S.List []
|
||||
EPair car cdr _mut -> S.DotList [gofetch car] (gofetch cdr)
|
||||
EVec xs _mut -> S.Vector . fmap gofetch $ xs
|
||||
EString xs _mut -> S.String _
|
||||
|
||||
eval g (Halt rs) = traverse (evalVal g) rs
|
||||
data DynPoints = MkDynPoints
|
||||
deriving (Generic, Data)
|
||||
|
||||
eval g (ExpContinue k xs) =
|
||||
case k of
|
||||
ValVar x -> continueWith g (KexpVar x) xs
|
||||
|
||||
|
||||
eval g (ExpApply f xs ktail) = do
|
||||
f' <- evalVal g f
|
||||
xs' <- traverse (evalVal g) xs
|
||||
ktail' <- evalKexp g ktail
|
||||
case f' of
|
||||
ObjHob (HobClosure {code,env}) -> eval env' e
|
||||
where
|
||||
MkAbs bxs bktail e = code
|
||||
env' = env
|
||||
& #store <>~ H.fromList (zip bxs xs')
|
||||
& maybe id (\b -> #store . at b ?~ ktail') bktail
|
||||
-- 뻘짓이어라
|
||||
telescope
|
||||
:: Traversable t
|
||||
=> (a -> (b -> r) -> r)
|
||||
-> t a -> (t b -> r) -> r
|
||||
telescope f = Cont.runCont . traverse (Cont.cont . f)
|
||||
|
||||
eval g (ExpPrim p k) = traverse (evalVal g) p >>= \case
|
||||
PrimAdd x y -> arith2 (+) x y
|
||||
PrimMul x y -> arith2 (*) x y
|
||||
PrimSub x y -> arith2 (-) x y
|
||||
PrimDiv x y -> arith2 div x y
|
||||
|
||||
|
||||
procedure :: Env -> Procedure -> (E -> CmdCont) -> CmdCont
|
||||
procedure = _
|
||||
|
||||
evalVal :: Env -> Val -> ExpCont -> CmdCont
|
||||
evalVal g (ValVar x) k = hold (var g x) $ single \case
|
||||
EUndefined -> wrong "undefined variable"
|
||||
e -> send e k
|
||||
|
||||
evalVal1 :: Env -> Val -> (E -> CmdCont) -> CmdCont
|
||||
evalVal1 g v k = evalVal g v (single k)
|
||||
|
||||
evalKexp :: Env -> Kexp -> ExpCont -> CmdCont
|
||||
|
||||
evalKexp g (KexpVar x) k = evalVal g (ValVar x) k
|
||||
|
||||
evalKexp g (KexpKappa kap) k = evalAbs g (AbsKappa kap) k
|
||||
|
||||
evalAbs :: Env -> Abs -> ExpCont -> CmdCont
|
||||
evalAbs g (MkAbs formals mtail e) k st = send ab k st'
|
||||
where
|
||||
arith2 f (ObjImm (ImmInt x)) (ObjImm (ImmInt y)) =
|
||||
pure1 . ObjImm . ImmInt $ f x y
|
||||
(st',l) = new' EUnspecified st
|
||||
ab = EProcedure l \args dps k' ->
|
||||
tievals args \argLocs ->
|
||||
let argEnv = zip (formals ++ foldMap (:[]) mtail) argLocs
|
||||
g' = g <> foldMap (uncurry bind) argEnv
|
||||
in eval g' dps e k'
|
||||
|
||||
eval g e = err [i|unimplemented exp: #{S.encodeOrShow' @Text S.datumIso e}|]
|
||||
eval :: Env -> DynPoints -> Exp -> ExpCont -> CmdCont
|
||||
|
||||
continueWith :: Jalmot :> es => Env -> Kexp -> List Val -> Eff es (List Obj)
|
||||
continueWith g kexp xs = do
|
||||
xs' <- traverse (evalVal g) xs
|
||||
evalKexp g kexp >>= \case
|
||||
ObjImm (ImmLabel "halt") -> traverse (evalVal g) xs
|
||||
ObjHob (HobClosure {code,env}) -> eval env' e
|
||||
where
|
||||
MkAbs bxs bktail e = code
|
||||
env' = env & #store <>~ H.fromList (zip bxs xs')
|
||||
eval g dps (ExpLetRec bs e) k = \st0 ->
|
||||
let
|
||||
rhss = bs ^.. each . _2
|
||||
(st',ls) = mapAccumR (\st _ -> new st) st0 bs
|
||||
g' = g & extends (zip (bs ^.. each . _1) ls)
|
||||
f :: List E -> CmdCont
|
||||
f = \rhss' -> eval g' dps e k . updates (zip ls rhss')
|
||||
in telescope (\ab -> evalAbs g' ab . single) rhss f st'
|
||||
|
||||
evalKexp :: Jalmot :> es => Env -> Kexp -> Eff es Obj
|
||||
evalKexp g = \case
|
||||
KexpVar x -> var g x
|
||||
KexpKappa kap -> pure . ObjHob $ HobClosure (AbsKappa kap) g
|
||||
eval g dps (ExpJump f xs ktail) k =
|
||||
telescope (evalVal1 g) (f:|xs) \(f':|xs') ->
|
||||
telescope (\ke -> evalKexp g ke . single) (ktail ^.. each) \ktail' ->
|
||||
case f' of
|
||||
EProcedure _loc fp -> fp xs' dps k
|
||||
_ -> wrong "bad procedure"
|
||||
|
||||
evalVal
|
||||
:: Jalmot :> es
|
||||
=> Env -> Val
|
||||
-> Eff es Obj
|
||||
evalVal g (ValImm imm) = pure $ ObjImm imm
|
||||
evalVal g (ValVar x) = var g x
|
||||
eval g dps (ExpContinue f xs) k =
|
||||
telescope (evalVal1 g) (f:|xs) \(f':|xs') ->
|
||||
case f' of
|
||||
EProcedure _loc fp -> fp xs' dps k
|
||||
_ -> wrong "bad procedure"
|
||||
|
||||
var :: Jalmot :> es => Env -> Name -> Eff es Obj
|
||||
var _ "halt" = pure . ObjImm . ImmLabel $ "halt"
|
||||
var g x = case g ^. #store . at x of
|
||||
Just o -> pure o
|
||||
Nothing -> err [i|unbound var #{x}|]
|
||||
eval g dps (ExpApply f xs ktail) k =
|
||||
telescope (evalVal1 g) (f:|xs) \(f':|xs') ->
|
||||
evalKexp g ktail . single $ \ktail' ->
|
||||
case f' of
|
||||
EProcedure _loc fp -> fp (xs' ++ [ktail']) dps k
|
||||
_ -> wrong "bad procedure"
|
||||
|
||||
evalExp :: Jalmot :> es => Exp -> Eff es (List Obj)
|
||||
evalExp e = eval emptyEnv e
|
||||
|
||||
|
||||
evalProgram :: Jalmot :> es => Program -> Eff es (List Obj)
|
||||
evalProgram (MkProgram lam) = evalExp [cps|
|
||||
(letrec ((start #{lam}))
|
||||
(start halt))
|
||||
|]
|
||||
prim_halt :: Procedure
|
||||
prim_halt xs _dps _k st = AnswerValues st xs
|
||||
|
||||
p :: Program
|
||||
p = [cps|
|
||||
(λ (ktail)
|
||||
(continue ktail 123))
|
||||
|]
|
||||
setup :: (Env -> CmdCont) -> CmdCont
|
||||
setup k = tievals (defs ^.. each) _
|
||||
where
|
||||
defs :: HashMap Name E
|
||||
defs =
|
||||
[ ("halt", EProcedure _ prim_halt)
|
||||
]
|
||||
|
||||
e1 :: Exp
|
||||
e1 = [cps|
|
||||
(continue $halt 123)
|
||||
|]
|
||||
evalExp :: Jalmot :> es => Exp -> Eff es _
|
||||
evalExp e = _
|
||||
|
||||
evalProgram :: Jalmot :> es => Program -> Eff es (List E)
|
||||
evalProgram (MkProgram lam) = _
|
||||
|
||||
@@ -45,6 +45,8 @@ module Gyehoek.CPS.Syntax
|
||||
, pattern MkAbs
|
||||
, _MkAbs
|
||||
, unhoist
|
||||
, pattern ExpJump
|
||||
, _ExpJump
|
||||
)
|
||||
where
|
||||
|
||||
@@ -146,6 +148,20 @@ pattern MkAbs xs ktail body <- (view _MkAbs -> (xs,ktail,body))
|
||||
|
||||
{-# COMPLETE MkAbs #-}
|
||||
|
||||
_ExpJump :: Prism' Exp (Val, List Val, Maybe Kexp)
|
||||
_ExpJump = prism'
|
||||
(\(f,xs,ktail) -> case ktail of
|
||||
Just k -> ExpApply f xs k
|
||||
Nothing -> ExpContinue f xs)
|
||||
\case
|
||||
ExpApply f xs ktail -> Just (f,xs,Just ktail)
|
||||
ExpContinue f xs -> Just (f,xs,Nothing)
|
||||
_ -> Nothing
|
||||
|
||||
pattern ExpJump :: Val -> List Val -> Maybe Kexp -> Exp
|
||||
pattern ExpJump f xs ktail <- (preview _ExpJump -> Just (f,xs,ktail))
|
||||
where ExpJump f xs ktail = review _ExpJump (f,xs,ktail)
|
||||
|
||||
data Exp
|
||||
= ExpPrim (Prim Val) Kexp
|
||||
| ExpLetRec { binders :: List (Name, Abs), body :: Exp }
|
||||
|
||||
+14
-3
@@ -1,5 +1,5 @@
|
||||
module Gyehoek.Driver
|
||||
(main, lower_e2e, convert_e2e, parse_e2e, readScm, eval_e2e, eval_cps_e2e)
|
||||
(main, lower_e2e, convert_e2e, parse_e2e, readScm, eval_e2e, eval_cps_e2e, eval_cps2_e2e)
|
||||
where
|
||||
|
||||
import Gyehoek.Options
|
||||
@@ -123,10 +123,10 @@ driver opts = do
|
||||
S.writeDatum cps
|
||||
closedCps <- closeProgram cps
|
||||
when opts.dumpClosed do
|
||||
S.writeData closedCps
|
||||
S.writeDatum closedCps
|
||||
hoistedCps <- hoistProgram closedCps
|
||||
when opts.dumpHoisted do
|
||||
S.writeData hoistedCps
|
||||
S.writeDatum hoistedCps
|
||||
-- contifiedCps <- contifyProgram hoistedCps
|
||||
-- when opts.dumpContified do
|
||||
-- hPutStrLn FS.stdout =<< S.encodeWith S.datumIso contifiedCps
|
||||
@@ -137,6 +137,9 @@ driver opts = do
|
||||
(eval >=> fmap writeObj
|
||||
>>> T.unwords
|
||||
>>> hPutStrLn FS.stdout)
|
||||
when (rt_is #HigherOrderCPS) do
|
||||
CPS.evalProgram cps
|
||||
>>= S.writeData
|
||||
when (rt_is #CPS) do
|
||||
CPS.evalProgram closedCps
|
||||
>>= S.writeData
|
||||
@@ -166,6 +169,14 @@ eval_e2e fp = runJalmotIO . runFileSystem . runGenSym $ do
|
||||
|
||||
eval_cps_e2e :: FilePath -> IO Text
|
||||
eval_cps_e2e fp = runJalmotIO . runFileSystem . runGenSym $
|
||||
readScm fp
|
||||
>>= convertProgram
|
||||
>>= closeProgram
|
||||
>>= CPS.evalProgram
|
||||
>>= pure . S.encodeOrShowData' S.dataIso
|
||||
|
||||
eval_cps2_e2e :: FilePath -> IO Text
|
||||
eval_cps2_e2e fp = runJalmotIO . runFileSystem . runGenSym $
|
||||
readScm fp
|
||||
>>= convertProgram
|
||||
-- >>= closeProgram
|
||||
|
||||
@@ -13,7 +13,7 @@ import Data.Foldable
|
||||
import Gyehoek.Prelude hiding (argument)
|
||||
|
||||
|
||||
data Runtime = Stackify | Wasm | CPS
|
||||
data Runtime = Stackify | Wasm | CPS | HigherOrderCPS
|
||||
deriving (Show, Generic, Eq)
|
||||
|
||||
data Language
|
||||
@@ -55,6 +55,7 @@ runtimeReader = maybeReader \case
|
||||
"stackify" -> Just (Just Stackify)
|
||||
"wasm" -> Just (Just Wasm)
|
||||
"cps" -> Just (Just CPS)
|
||||
("cps2";"higher-order-cps") -> Just (Just CPS)
|
||||
"none" -> Just Nothing
|
||||
_ -> Nothing
|
||||
|
||||
@@ -75,9 +76,9 @@ parser = do
|
||||
runtime <- option runtimeReader . fold $
|
||||
[ long "runtime"
|
||||
, short 'R'
|
||||
, value (Just CPS)
|
||||
, value (Just HigherOrderCPS)
|
||||
, completeWith runtimeValues
|
||||
, showDefaultWith $ const "cps"
|
||||
, showDefaultWith $ const "higher-order-cps"
|
||||
, metavar "RUNTIME"
|
||||
]
|
||||
sourceLanguage <- option languageReader . fold $
|
||||
|
||||
@@ -132,7 +132,7 @@ encodeOrShow' g x = fromString $
|
||||
|
||||
encodeOrShow :: (IsString s, Show a) => DatumGrammar a -> a -> s
|
||||
encodeOrShow g x = fromString $
|
||||
case runPureEff . runJalmot . encodeWith' g $ x of
|
||||
case runPureEff . runJalmot . encodeWith g $ x of
|
||||
Left _ -> show x
|
||||
Right t -> T.unpack t
|
||||
|
||||
|
||||
@@ -56,12 +56,15 @@ test_eval :: IO TestTree
|
||||
test_eval = do
|
||||
cs <- listDirectory "golden/exec"
|
||||
<&> fmap ("golden/exec" </>)
|
||||
pure $ testGroup "cps interpreter" $ cpsCase <$> cs
|
||||
pure $ testGroup "cps interpreter"
|
||||
[ testGroup "higher-order" $ cpsCase Driver.eval_cps2_e2e <$> cs
|
||||
, testGroup "first-order" $ cpsCase Driver.eval_cps_e2e <$> cs
|
||||
]
|
||||
|
||||
maybeBroken name broken = applyWhen (name `elem` broken) expectFail
|
||||
|
||||
cpsCase :: FilePath -> TestTree
|
||||
cpsCase test =
|
||||
cpsCase :: (FilePath -> IO Text) -> FilePath -> TestTree
|
||||
cpsCase f test =
|
||||
maybeBroken testName brokenEvalTests $
|
||||
goldenVsAction testName resultFile action printProcResult
|
||||
where
|
||||
@@ -69,7 +72,7 @@ cpsCase test =
|
||||
resultFile = test </> "exec"
|
||||
sourceFile = test </> "source.scm"
|
||||
action = catch @SomeException
|
||||
(do r <- Driver.eval_cps_e2e sourceFile
|
||||
(do r <- f sourceFile
|
||||
pure $!! ( ExitSuccess
|
||||
, r
|
||||
, "" ))
|
||||
|
||||
Reference in New Issue
Block a user