diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index 02e59ac56..360b875e2 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, LambdaCase, KindSignatures, RankNTypes, TypeOperators #-} +{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, LambdaCase, TypeOperators #-} module Control.Abstract.Evaluator ( Evaluator(..) -- * Effects @@ -54,33 +54,23 @@ runReturn = Eff.raiseHandler (fmap (either unReturn id) . runError) -- | Effects for control flow around loops (breaking and continuing). -data LoopControl address (m :: * -> *) resume where - Break :: address -> LoopControl address m address - Continue :: address -> LoopControl address m address +data LoopControl address + = Break { unLoopControl :: address } + | Continue { unLoopControl :: address } + deriving (Eq, Ord, Show) -instance Effect (LoopControl address) where - handleState c dist (Request (Break value) k) = Request (Break value) (dist . (<$ c) . k) - handleState c dist (Request (Continue value) k) = Request (Continue value) (dist . (<$ c) . k) - -throwBreak :: Member (LoopControl address) effects +throwBreak :: Member (Exc (LoopControl address)) effects => address -> Evaluator address value effects address -throwBreak = send . Break +throwBreak = throwError . Break -throwContinue :: Member (LoopControl address) effects +throwContinue :: Member (Exc (LoopControl address)) effects => address -> Evaluator address value effects address -throwContinue = send . Continue +throwContinue = throwError . Continue -catchLoopControl :: (Member (LoopControl address) effects, Effectful (m address value)) => m address value effects a -> (forall x . LoopControl address (Eff effects) x -> m address value effects a) -> m address value effects a -catchLoopControl action handler = Eff.raiseHandler (interpose (\ control _ -> Eff.lowerEff (handler control))) action +catchLoopControl :: (Member (Exc (LoopControl address)) effects, Effectful (m address value)) => m address value effects a -> (LoopControl address -> m address value effects a) -> m address value effects a +catchLoopControl = catchError -runLoopControl :: (Effectful (m address value), Effects effects) => m address value (LoopControl address ': effects) address -> m address value effects address -runLoopControl = Eff.raiseHandler go . (`catchLoopControl` (\ control -> case control of - Break address -> Eff.raiseEff (pure address) - Continue address -> Eff.raiseEff (pure address))) - where go :: Effects effects => Eff (LoopControl address ': effects) a -> Eff effects a - go (Eff.Return a) = pure a - go (Effect (Break a) k) = go (k a) - go (Effect (Continue a) k) = go (k a) - go (Other u k) = liftHandler go u k +runLoopControl :: (Effectful (m address value), Effects effects) => m address value (Exc (LoopControl address) ': effects) address -> m address value effects address +runLoopControl = Eff.raiseHandler (fmap (either unLoopControl id) . runError) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index c79a1d2d5..b7b5effa1 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -48,8 +48,8 @@ class Show1 constr => Evaluatable constr where , FreeVariables term , Member (Allocator address value) effects , Member (Env address) effects + , Member (Exc (LoopControl address)) effects , Member (Exc (Return address)) effects - , Member (LoopControl address) effects , Member (Modules address value) effects , Member (Reader ModuleInfo) effects , Member (Reader PackageInfo) effects @@ -88,7 +88,7 @@ evaluatePackageWith :: forall proxy lang address term value inner inner' inner'' , Recursive term , Reducer value (Cell address value) , ValueRoots address value - , inner ~ (LoopControl address ': Exc (Return address) ': Env address ': Allocator address value ': inner') + , inner ~ (Exc (LoopControl address) ': Exc (Return address) ': Env address ': Allocator address value ': inner') , inner' ~ (Reader ModuleInfo ': inner'') , inner'' ~ (Modules address value ': Reader Span ': Reader PackageInfo ': outer) ) diff --git a/src/Data/Abstract/Value.hs b/src/Data/Abstract/Value.hs index 5b1cf34b4..b7dd8a912 100644 --- a/src/Data/Abstract/Value.hs +++ b/src/Data/Abstract/Value.hs @@ -102,12 +102,12 @@ instance Show address => AbstractIntro (Value address body) where instance ( Coercible body (Eff effects) , Member (Allocator address (Value address body)) effects , Member (Env address) effects + , Member (Exc (LoopControl address)) effects + , Member (Exc (Return address)) effects , Member Fresh effects - , Member (LoopControl address) effects , Member (Reader ModuleInfo) effects , Member (Reader PackageInfo) effects , Member (Resumable (ValueError address body)) effects - , Member (Exc (Return address)) effects , Show address ) => AbstractValue address (Value address body) effects where diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index ea588bd9a..bb18e9786 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -70,7 +70,7 @@ runGraph graphType includePackages project -- | The full list of effects in flight during the evaluation of terms. This, and other @newtype@s like it, are necessary to type 'Value', since the bodies of closures embed evaluators. This would otherwise require cycles in the effect list (i.e. references to @effects@ within @effects@ itself), which the typechecker forbids. newtype GraphEff address a = GraphEff - { runGraphEff :: Eff '[ LoopControl address + { runGraphEff :: Eff '[ Exc (LoopControl address) , Exc (Return address) , Env address , Allocator address (Value address (GraphEff address)) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 9001dfda6..fc2da7a07 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -42,7 +42,7 @@ justEvaluating . runValueError newtype UtilEff address a = UtilEff - { runUtilEff :: Eff '[ LoopControl address + { runUtilEff :: Eff '[ Exc (LoopControl address) , Exc (Return address) , Env address , Allocator address (Value address (UtilEff address)) diff --git a/test/Control/Abstract/Evaluator/Spec.hs b/test/Control/Abstract/Evaluator/Spec.hs index 14e00c6a5..be2787b7e 100644 --- a/test/Control/Abstract/Evaluator/Spec.hs +++ b/test/Control/Abstract/Evaluator/Spec.hs @@ -48,7 +48,7 @@ reassociate = mergeExcs . mergeExcs . mergeExcs . Right type Val = Value Precise SpecEff newtype SpecEff a = SpecEff - { runSpecEff :: Eff '[ LoopControl Precise + { runSpecEff :: Eff '[ Exc (LoopControl Precise) , Exc (Return Precise) , Env Precise , Allocator Precise Val diff --git a/test/SpecHelpers.hs b/test/SpecHelpers.hs index 0aaaee695..131de4576 100644 --- a/test/SpecHelpers.hs +++ b/test/SpecHelpers.hs @@ -126,7 +126,7 @@ testEvaluating type Val = Value Precise TestEff newtype TestEff a = TestEff - { runTestEff :: Eff '[ LoopControl Precise + { runTestEff :: Eff '[ Exc (LoopControl Precise) , Exc (Return Precise) , Env Precise , Allocator Precise Val