Resume defining LoopControl as using Exc.

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)

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)
                        )

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

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))

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))

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

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