Bump higher-order-effects.

src/Analysis/Abstract/Caching/FlowInsensitive.hs

@@ -40,9 +40,9 @@ cachingConfiguration :: (Member (State (Cache term address)) sig, Carrier sig m,
                      -> Evaluator term address value m (ValueRef address)
                      -> Evaluator term address value m (ValueRef address)
 cachingConfiguration configuration values action = do
-  modify' (cacheSet configuration values)
+  modify (cacheSet configuration values)
   result <- action
-  result <$ modify' (cacheInsert configuration result)
+  result <$ modify (cacheInsert configuration result)
 
 putCache :: (Member (State (Cache term address)) sig, Carrier sig m)
          => Cache term address

src/Analysis/Abstract/Caching/FlowSensitive.hs

@@ -40,9 +40,9 @@ cachingConfiguration :: (Cacheable term address value, Member (State (Cache term
                      -> Evaluator term address value m (ValueRef address)
                      -> Evaluator term address value m (ValueRef address)
 cachingConfiguration configuration values action = do
-  modify' (cacheSet configuration values)
+  modify (cacheSet configuration values)
   result <- Cached <$> action <*> getHeap
-  cachedValue result <$ modify' (cacheInsert configuration result)
+  cachedValue result <$ modify (cacheInsert configuration result)
 
 putCache :: (Member (State (Cache term address value)) sig, Carrier sig m)
          => Cache term address value

src/Analysis/Abstract/Dead.hs

@@ -24,7 +24,7 @@ killAll = put
 
 -- | Revive a single term, removing it from the current 'Dead' set.
 revive :: (Member (State (Dead term)) sig, Carrier sig m, Ord term) => term -> Evaluator term address value m ()
-revive t = modify' (Dead . delete t . unDead)
+revive t = modify (Dead . delete t . unDead)
 
 -- | Compute the set of all subterms recursively.
 subterms :: (Ord term, Recursive term, Foldable (Base term)) => term -> Dead term

src/Analysis/Abstract/Graph.hs

@@ -18,6 +18,8 @@ module Analysis.Abstract.Graph
 
 import           Algebra.Graph.Export.Dot hiding (vertexName)
 import           Control.Abstract hiding (Function(..))
+import           Control.Effect.Carrier
+import           Control.Effect.Sum
 import           Data.Abstract.Address.Hole
 import           Data.Abstract.Address.Located
 import           Data.Abstract.BaseError
@@ -101,7 +103,7 @@ graphingTerms recur0 recur term@(Term (In a syntax)) = do
       local (const v) $ do
         valRef <- recur0 recur term
         addr <- Control.Abstract.address valRef
-        modify' (Map.insert addr v)
+        modify (Map.insert addr v)
         pure valRef
 
 -- | Add vertices to the graph for evaluated modules and the packages containing them.
@@ -164,11 +166,11 @@ runEavesdropC :: (forall x . eff m (m x) -> m ()) -> EavesdropC eff m a -> m a
 runEavesdropC f (EavesdropC m) = m f
 
 instance (Carrier sig m, HFunctor eff, Member eff sig, Applicative m) => Carrier sig (EavesdropC eff m) where
-  gen a = EavesdropC (const (gen a))
+  ret a = EavesdropC (const (ret a))
-  alg op
+  eff op
     | Just m <- prj op = case m of
       eff -> EavesdropC (\ handler -> let eff' = handlePure (runEavesdropC handler) eff in handler eff' *> send eff')
-    | otherwise        = EavesdropC (\ handler -> alg (handlePure (runEavesdropC handler) op))
+    | otherwise        = EavesdropC (\ handler -> eff (handlePure (runEavesdropC handler) op))
 
 -- | Add an edge from the current package to the passed vertex.
 packageInclusion :: ( Member (Reader PackageInfo) sig

src/Analysis/Abstract/Tracing.hs

@@ -5,6 +5,7 @@ module Analysis.Abstract.Tracing
 ) where
 
 import Control.Abstract hiding (trace)
+import Control.Effect.Writer
 import Data.Abstract.Environment
 import Data.Semigroup.Reducer as Reducer
 

src/Control/Abstract/Context.hs

@@ -13,6 +13,8 @@ module Control.Abstract.Context
 ) where
 
 import Control.Effect
+import Control.Effect.Reader
+import Control.Effect.State
 import Data.Abstract.Module
 import Data.Abstract.Package
 import Data.Span
@@ -44,7 +46,7 @@ withCurrentSpan :: (Member (Reader Span) sig, Carrier sig m) => Span -> m a -> m
 withCurrentSpan = local . const
 
 modifyChildSpan :: (Member (State Span) sig, Carrier sig m, Monad m) => Span -> m a -> m a
-modifyChildSpan span m = m >>= \a -> modify' (const span) >> pure a
+modifyChildSpan span m = m <* put span
 
 -- | Run an action with locally-replaced 'ModuleInfo' & 'Span' derived from the passed 'SrcLoc'.
 withCurrentSrcLoc :: (Member (Reader ModuleInfo) sig, Member (Reader Span) sig, Carrier sig m) => SrcLoc -> m a -> m a

src/Control/Abstract/Environment.hs

@@ -27,6 +27,8 @@ module Control.Abstract.Environment
 
 import Control.Abstract.Evaluator
 import Control.Abstract.Heap
+import Control.Effect.Carrier
+import Control.Effect.Sum
 import Data.Abstract.BaseError
 import Data.Abstract.Environment (Bindings, Environment, EvalContext(..), EnvironmentError(..))
 import qualified Data.Abstract.Environment as Env
@@ -38,7 +40,7 @@ import Prologue
 
 -- | Retrieve the current execution context
 getEvalContext :: (Member (Env address) sig, Carrier sig m) => Evaluator term address value m (EvalContext address)
-getEvalContext = send (GetCtx gen)
+getEvalContext = send (GetCtx ret)
 
 -- | Retrieve the current environment
 getEnv :: (Member (Env address) sig, Carrier sig m)
@@ -47,7 +49,7 @@ getEnv = ctxEnvironment <$> getEvalContext
 
 -- | Replace the execution context. This is only for use in Analysis.Abstract.Caching.
 putEvalContext :: (Member (Env address) sig, Carrier sig m) => EvalContext address -> Evaluator term address value m ()
-putEvalContext context = send (PutCtx context (gen ()))
+putEvalContext context = send (PutCtx context (ret ()))
 
 withEvalContext :: (Member (Env address) sig, Carrier sig m)
                 => EvalContext address
@@ -62,16 +64,16 @@ withEvalContext ctx comp = do
 
 -- | Add an export to the global export state.
 export :: (Member (Env address) sig, Carrier sig m) => Name -> Name -> Maybe address -> Evaluator term address value m ()
-export name alias addr = send (Export name alias addr (gen ()))
+export name alias addr = send (Export name alias addr (ret ()))
 
 
 -- | Look a 'Name' up in the current environment, trying the default environment if no value is found.
 lookupEnv :: (Member (Env address) sig, Carrier sig m) => Name -> Evaluator term address value m (Maybe address)
-lookupEnv name = send (Lookup name gen)
+lookupEnv name = send (Lookup name ret)
 
 -- | Bind a 'Name' to an address in the current scope.
 bind :: (Member (Env address) sig, Carrier sig m) => Name -> address -> Evaluator term address value m ()
-bind name addr = send (Bind name addr (gen ()))
+bind name addr = send (Bind name addr (ret ()))
 
 -- | Bind all of the names from an 'Environment' in the current scope.
 bindAll :: (Member (Env address) sig, Carrier sig m) => Bindings address -> Evaluator term address value m ()
@@ -79,10 +81,10 @@ bindAll = foldr ((>>) . uncurry bind) (pure ()) . Env.pairs
 
 -- | Run an action in a new local scope.
 locally :: forall term address value sig m a . (Member (Env address) sig, Carrier sig m) => Evaluator term address value m a -> Evaluator term address value m a
-locally m = send (Locally @address m gen)
+locally m = send (Locally @address m ret)
 
 close :: (Member (Env address) sig, Carrier sig m) => Set Name -> Evaluator term address value m (Environment address)
-close fvs = send (Close fvs gen)
+close fvs = send (Close fvs ret)
 
 self :: (Member (Env address) sig, Carrier sig m) => Evaluator term address value m (Maybe address)
 self = ctxSelf <$> getEvalContext
@@ -187,20 +189,20 @@ runEnv initial = fmap (filterEnv . fmap (first (Env.head . ctxEnvironment))) . r
 newtype EnvC m a = EnvC { runEnvC :: m a }
 
 instance (Carrier (State (EvalContext address) :+: State (Exports address) :+: sig) m, HFunctor sig) => Carrier (Env address :+: sig) (EnvC (Evaluator term address value m)) where
-  gen = EnvC . gen
+  ret = EnvC . ret
-  alg = EnvC . (algE \/ (alg . R . R . handlePure runEnvC))
+  eff = EnvC . (alg \/ (eff . R . R . handlePure runEnvC))
-    where algE = \case
+    where alg = \case
             Lookup name k -> gets (Env.lookupEnv' name . ctxEnvironment) >>= runEnvC . k
-            Bind name addr k -> modify' (\EvalContext{..} -> EvalContext ctxSelf (Env.insertEnv name addr ctxEnvironment)) >> runEnvC k
+            Bind name addr k -> modify (\EvalContext{..} -> EvalContext ctxSelf (Env.insertEnv name addr ctxEnvironment)) >> runEnvC k
             Close names k -> gets (Env.intersect names . ctxEnvironment) >>= runEnvC . k
             Locally action k -> do
-              modify' (\EvalContext{..} -> EvalContext ctxSelf (Env.push @address ctxEnvironment))
+              modify (\EvalContext{..} -> EvalContext ctxSelf (Env.push @address ctxEnvironment))
               a <- runEnvC action
-              modify' (\EvalContext{..} -> EvalContext ctxSelf (Env.pop @address ctxEnvironment))
+              modify (\EvalContext{..} -> EvalContext ctxSelf (Env.pop @address ctxEnvironment))
               runEnvC (k a)
             GetCtx k -> get >>= runEnvC . k
             PutCtx e k -> put e >> runEnvC k
-            Export name alias addr k -> modify' (Exports.insert name alias addr) >> runEnvC k
+            Export name alias addr k -> modify (Exports.insert name alias addr) >> runEnvC k
 
 freeVariableError :: ( Member (Reader ModuleInfo) sig
                      , Member (Reader Span) sig

src/Control/Abstract/Evaluator.hs

@@ -17,6 +17,14 @@ module Control.Abstract.Evaluator
   ) where
 
 import Control.Effect           as X
+import Control.Effect.Carrier
+import Control.Effect.Error     as X
+import Control.Effect.Fresh     as X
+import Control.Effect.NonDet    as X
+import Control.Effect.Reader    as X
+import Control.Effect.Resumable as X
+import Control.Effect.State     as X
+import Control.Effect.Trace     as X
 import Control.Monad.IO.Class
 
 -- | An 'Evaluator' is a thin wrapper around 'Eff' with (phantom) type parameters for the address, term, and value types.
@@ -31,8 +39,8 @@ deriving instance (Member NonDet sig, Carrier sig m) => Alternative (Evaluator t
 deriving instance (Member (Lift IO) sig, Carrier sig m) => MonadIO (Evaluator term address value m)
 
 instance Carrier sig m => Carrier sig (Evaluator term address value m) where
-  gen = Evaluator . gen
+  ret = Evaluator . ret
-  alg = Evaluator . alg . handlePure runEvaluator
+  eff = Evaluator . eff . handlePure runEvaluator
 
 
 -- | An open-recursive function.

src/Control/Abstract/Heap.hs

@@ -25,6 +25,7 @@ module Control.Abstract.Heap
 
 import Control.Abstract.Evaluator
 import Control.Abstract.Roots
+import Control.Effect.Carrier
 import Data.Abstract.BaseError
 import Data.Abstract.Heap
 import Data.Abstract.Live
@@ -43,7 +44,7 @@ putHeap = put
 
 -- | Update the heap.
 modifyHeap :: (Member (State (Heap address value)) sig, Carrier sig m) => (Heap address value -> Heap address value) -> Evaluator term address value m ()
-modifyHeap = modify'
+modifyHeap = modify
 
 box :: ( Member (Allocator address) sig
        , Member (Deref value) sig
@@ -61,7 +62,7 @@ box val = do
   pure addr
 
 alloc :: (Member (Allocator address) sig, Carrier sig m) => Name -> Evaluator term address value m address
-alloc = send . flip Alloc gen
+alloc = send . flip Alloc ret
 
 dealloc :: (Member (State (Heap address value)) sig, Ord address, Carrier sig m) => address -> Evaluator term address value m ()
 dealloc addr = modifyHeap (heapDelete addr)
@@ -77,7 +78,7 @@ deref :: ( Member (Deref value) sig
          )
       => address
       -> Evaluator term address value m value
-deref addr = gets (heapLookup addr) >>= maybeM (throwAddressError (UnallocatedAddress addr)) >>= send . flip DerefCell gen >>= maybeM (throwAddressError (UninitializedAddress addr))
+deref addr = gets (heapLookup addr) >>= maybeM (throwAddressError (UnallocatedAddress addr)) >>= send . flip DerefCell ret >>= maybeM (throwAddressError (UninitializedAddress addr))
 
 
 -- | Write a value to the given address in the 'Allocator'.
@@ -91,7 +92,7 @@ assign :: ( Member (Deref value) sig
        -> Evaluator term address value m ()
 assign addr value = do
   heap <- getHeap
-  cell <- send (AssignCell value (fromMaybe lowerBound (heapLookup addr heap)) gen)
+  cell <- send (AssignCell value (fromMaybe lowerBound (heapLookup addr heap)) ret)
   putHeap (heapInit addr cell heap)
 
 

src/Control/Abstract/Modules.hs

@@ -20,6 +20,8 @@ module Control.Abstract.Modules
 ) where
 
 import Control.Abstract.Evaluator
+import Control.Effect.Carrier
+import Control.Effect.Sum
 import Data.Abstract.Environment
 import Data.Abstract.BaseError
 import Data.Abstract.Module
@@ -37,14 +39,14 @@ type ModuleResult address = (ScopeGraph address, (Bindings address, address))
 
 -- | Retrieve an evaluated module, if any. @Nothing@ means we’ve never tried to load it, and @Just (env, value)@ indicates the result of a completed load.
 lookupModule :: (Member (Modules address) sig, Carrier sig m) => ModulePath -> Evaluator term address value m (Maybe (ModuleResult address))
-lookupModule = sendModules . flip Lookup gen
+lookupModule = sendModules . flip Lookup ret
 
 -- | Resolve a list of module paths to a possible module table entry.
 resolve :: (Member (Modules address) sig, Carrier sig m) => [FilePath] -> Evaluator term address value m (Maybe ModulePath)
-resolve = sendModules . flip Resolve gen
+resolve = sendModules . flip Resolve ret
 
 listModulesInDir :: (Member (Modules address) sig, Carrier sig m) => FilePath -> Evaluator term address value m [ModulePath]
-listModulesInDir = sendModules . flip List gen
+listModulesInDir = sendModules . flip List ret
 
 
 -- | Require/import another module by name and return its environment and value.
@@ -57,7 +59,7 @@ require path = lookupModule path >>= maybeM (load path)
 --
 -- Always loads/evaluates.
 load :: (Member (Modules address) sig, Carrier sig m) => ModulePath -> Evaluator term address value m (ModuleResult address)
-load path = sendModules (Load path gen)
+load path = sendModules (Load path ret)
 
 
 data Modules address (m :: * -> *) k
@@ -96,12 +98,12 @@ instance ( Member (Reader (ModuleTable (NonEmpty (Module (ModuleResult address))
          , Carrier sig m
          )
       => Carrier (Modules address :+: sig) (ModulesC (Evaluator term address value m)) where
-  gen = ModulesC . const . gen
+  ret = ModulesC . const . ret
-  alg op = ModulesC (\ paths -> (algM paths \/ (alg . handlePure (flip runModulesC paths))) op)
+  eff op = ModulesC (\ paths -> (alg paths \/ (eff . handlePure (flip runModulesC paths))) op)
-    where algM paths (Load    name  k) = askModuleTable >>= maybeM (throwLoadError (ModuleNotFoundError name)) . fmap (runMerging . foldMap1 (Merging . moduleBody)) . ModuleTable.lookup name >>= flip runModulesC paths . k
+    where alg paths (Load    name  k) = askModuleTable >>= maybeM (throwLoadError (ModuleNotFoundError name)) . fmap (runMerging . foldMap1 (Merging . moduleBody)) . ModuleTable.lookup name >>= flip runModulesC paths . k
-          algM paths (Lookup  path  k) = askModuleTable >>= flip runModulesC paths . k . fmap (runMerging . foldMap1 (Merging . moduleBody)) . ModuleTable.lookup path
+          alg paths (Lookup  path  k) = askModuleTable >>= flip runModulesC paths . k . fmap (runMerging . foldMap1 (Merging . moduleBody)) . ModuleTable.lookup path
-          algM paths (Resolve names k) = runModulesC (k (find (`Set.member` paths) names)) paths
+          alg paths (Resolve names k) = runModulesC (k (find (`Set.member` paths) names)) paths
-          algM paths (List    dir   k) = runModulesC (k (filter ((dir ==) . takeDirectory) (toList paths))) paths
+          alg paths (List    dir   k) = runModulesC (k (filter ((dir ==) . takeDirectory) (toList paths))) paths
 
 askModuleTable :: (Member (Reader (ModuleTable (NonEmpty (Module (ModuleResult address))))) sig, Carrier sig m) => Evaluator term address value m (ModuleTable (NonEmpty (Module (ModuleResult address))))
 askModuleTable = ask

src/Control/Abstract/PythonPackage.hs

@@ -5,6 +5,8 @@ module Control.Abstract.PythonPackage
 import           Control.Abstract.Evaluator (LoopControl, Return)
 import           Control.Abstract.Heap (Allocator, Deref, deref)
 import           Control.Abstract.Value
+import           Control.Effect.Carrier
+import           Control.Effect.Sum
 import           Data.Abstract.Evaluatable
 import           Data.Abstract.Name (name)
 import           Data.Abstract.Path (stripQuotes)
@@ -77,7 +79,7 @@ runInterposeC :: (forall x . eff m (m x) -> m x) -> InterposeC eff m a -> m a
 runInterposeC f (InterposeC m) = m f
 
 instance (Member eff sig, HFunctor eff, Carrier sig m) => Carrier sig (InterposeC eff m) where
-  gen a = InterposeC (const (gen a))
+  ret a = InterposeC (const (ret a))
-  alg op
+  eff op
     | Just e <- prj op = InterposeC (\ handler -> handler (handlePure (runInterposeC handler) e))
-    | otherwise        = InterposeC (\ handler -> alg (handlePure (runInterposeC handler) op))
+    | otherwise        = InterposeC (\ handler -> eff (handlePure (runInterposeC handler) op))

src/Control/Abstract/ScopeGraph.hs

@@ -18,6 +18,8 @@ module Control.Abstract.ScopeGraph
 
 import           Control.Abstract.Evaluator hiding (Local)
 import           Control.Abstract.Heap
+import           Control.Effect.Carrier
+import           Control.Effect.Sum
 import           Data.Abstract.Name
 import           Data.Abstract.ScopeGraph (Declaration (..), EdgeLabel, Reference, ScopeGraph)
 import qualified Data.Abstract.ScopeGraph as ScopeGraph
@@ -38,28 +40,28 @@ data ScopeEnv address (m :: * -> *) k
 deriving instance Functor (ScopeEnv address m)
 
 lookup :: (Member (ScopeEnv address) sig, Carrier sig m) => Reference -> Evaluator term address value m (Maybe address)
-lookup ref = sendScope (Lookup ref gen)
+lookup ref = sendScope (Lookup ref ret)
 
 declare :: (Member (ScopeEnv address) sig, Carrier sig m) => Declaration -> Span -> Maybe address -> Evaluator term address value m ()
-declare decl span addr = sendScope (Declare decl span addr (gen ()))
+declare decl span addr = sendScope (Declare decl span addr (ret ()))
 
 putDeclarationScope :: (Member (ScopeEnv address) sig, Carrier sig m) => Declaration -> address -> Evaluator term address value m ()
-putDeclarationScope decl addr = sendScope (PutDeclarationScope decl addr (gen ()))
+putDeclarationScope decl addr = sendScope (PutDeclarationScope decl addr (ret ()))
 
 reference :: (Member (ScopeEnv address) sig, Carrier sig m) => Reference -> Declaration -> Evaluator term address value m ()
-reference ref decl = sendScope (Reference ref decl (gen ()))
+reference ref decl = sendScope (Reference ref decl (ret ()))
 
 newScope :: (Member (ScopeEnv address) sig, Carrier sig m) => Map EdgeLabel [address]  -> Evaluator term address value m address
-newScope map = send (NewScope map gen)
+newScope map = send (NewScope map ret)
 
 currentScope :: (Member (ScopeEnv address) sig, Carrier sig m) => Evaluator term address value m (Maybe address)
-currentScope = send (CurrentScope gen)
+currentScope = send (CurrentScope ret)
 
 associatedScope :: (Member (ScopeEnv address) sig, Carrier sig m) => Declaration -> Evaluator term address value m (Maybe address)
-associatedScope = send . flip AssociatedScope gen
+associatedScope = send . flip AssociatedScope ret
 
 withScope :: (Member (ScopeEnv address) sig, Carrier sig m) => address -> Evaluator term address value m a -> Evaluator term address value m a
-withScope scope action = send (Local scope action gen)
+withScope scope action = send (Local scope action ret)
 
 sendScope :: (Member (ScopeEnv address) sig, Carrier sig m) => ScopeEnv address (Evaluator term address value m) (Evaluator term address value m a) -> Evaluator term address value m a
 sendScope = send
@@ -95,23 +97,23 @@ runScopeEnv = runState lowerBound . runEvaluator . runScopeEnvC . interpret . ru
 newtype ScopeEnvC m a = ScopeEnvC { runScopeEnvC :: m a }
 
 instance (Ord address, Member Fresh sig, Member (Allocator address) sig, Carrier (State (ScopeGraph address) :+: sig) m, Effect sig) => Carrier (ScopeEnv address :+: sig) (ScopeEnvC (Evaluator term address value m)) where
-  gen = ScopeEnvC . gen
+  ret = ScopeEnvC . ret
-  alg = ScopeEnvC . (algS \/ (alg . R . handlePure runScopeEnvC))
+  eff = ScopeEnvC . (alg \/ (eff . R . handlePure runScopeEnvC))
-    where algS (Lookup ref k) = gets (ScopeGraph.scopeOfRef ref) >>= runScopeEnvC . k
+    where alg (Lookup ref k) = gets (ScopeGraph.scopeOfRef ref) >>= runScopeEnvC . k
-          algS (Declare decl span scope k) = modify' @(ScopeGraph address) (ScopeGraph.declare decl span scope) *> runScopeEnvC k
+          alg (Declare decl span scope k) = modify @(ScopeGraph address) (ScopeGraph.declare decl span scope) *> runScopeEnvC k
-          algS (PutDeclarationScope decl scope k) = modify' @(ScopeGraph address) (ScopeGraph.insertDeclarationScope decl scope) *> runScopeEnvC k
+          alg (PutDeclarationScope decl scope k) = modify @(ScopeGraph address) (ScopeGraph.insertDeclarationScope decl scope) *> runScopeEnvC k
-          algS (Reference ref decl k) = modify' @(ScopeGraph address) (ScopeGraph.reference ref decl) *> runScopeEnvC k
+          alg (Reference ref decl k) = modify @(ScopeGraph address) (ScopeGraph.reference ref decl) *> runScopeEnvC k
-          algS (NewScope edges k) = do
+          alg (NewScope edges k) = do
             -- Take the edges and construct a new scope, update the current scope to the new scope
             name <- gensym
             address <- alloc name
-            modify' @(ScopeGraph address) (ScopeGraph.newScope address edges)
+            modify @(ScopeGraph address) (ScopeGraph.newScope address edges)
             runScopeEnvC (k address)
-          algS (CurrentScope k) = gets ScopeGraph.currentScope >>= runScopeEnvC . k
+          alg (CurrentScope k) = gets ScopeGraph.currentScope >>= runScopeEnvC . k
-          algS (AssociatedScope decl k) = gets (ScopeGraph.associatedScope decl) >>= runScopeEnvC . k
+          alg (AssociatedScope decl k) = gets (ScopeGraph.associatedScope decl) >>= runScopeEnvC . k
-          algS (Local scope action k) = do
+          alg (Local scope action k) = do
             prevScope <- gets ScopeGraph.currentScope
-            modify' @(ScopeGraph address) (\g -> g { ScopeGraph.currentScope = Just scope })
+            modify @(ScopeGraph address) (\g -> g { ScopeGraph.currentScope = Just scope })
             value <- runScopeEnvC action
             modify @(ScopeGraph address) (\g -> g { ScopeGraph.currentScope = prevScope })
             runScopeEnvC (k value)

src/Control/Abstract/Value.hs

@@ -35,6 +35,7 @@ module Control.Abstract.Value
 import Control.Abstract.Environment
 import Control.Abstract.Evaluator
 import Control.Abstract.Heap
+import Control.Effect.Carrier
 import Data.Coerce
 import Data.Abstract.BaseError
 import Data.Abstract.Environment as Env
@@ -71,7 +72,7 @@ data Comparator
 -- In the concrete domain, introductions & eliminations respectively construct & pattern match against values, while in abstract domains they respectively construct & project finite sets of discrete observations of abstract values. For example, an abstract domain modelling integers as a sign (-, 0, or +) would introduce abstract values by mapping integers to their sign and eliminate them by mapping signs back to some canonical integer, e.g. - -> -1, 0 -> 0, + -> 1.
 
 function :: (Member (Function term address value) sig, Carrier sig m) => Maybe Name -> [Name] -> term -> Evaluator term address value m value
-function name params body = sendFunction (Function name params body gen)
+function name params body = sendFunction (Function name params body ret)
 
 data BuiltIn
   = Print
@@ -79,10 +80,10 @@ data BuiltIn
   deriving (Eq, Ord, Show, Generic, NFData)
 
 builtIn :: (Member (Function term address value) sig, Carrier sig m) => BuiltIn -> Evaluator term address value m value
-builtIn = sendFunction . flip BuiltIn gen
+builtIn = sendFunction . flip BuiltIn ret
 
 call :: (Member (Function term address value) sig, Carrier sig m) => value -> address -> [address] -> Evaluator term address value m address
-call fn self args = sendFunction (Call fn self args gen)
+call fn self args = sendFunction (Call fn self args ret)
 
 sendFunction :: (Member (Function term address value) sig, Carrier sig m) => Function term address value (Evaluator term address value m) (Evaluator term address value m a) -> Evaluator term address value m a
 sendFunction = send
@@ -114,11 +115,11 @@ newtype FunctionC term address value m a = FunctionC { runFunctionC :: (term ->
 
 -- | Construct a boolean value in the abstract domain.
 boolean :: (Member (Boolean value) sig, Carrier sig m) => Bool -> Evaluator term address value m value
-boolean = send . flip Boolean gen
+boolean = send . flip Boolean ret
 
 -- | Extract a 'Bool' from a given value.
 asBool :: (Member (Boolean value) sig, Carrier sig m) => value -> Evaluator term address value m Bool
-asBool = send . flip AsBool gen
+asBool = send . flip AsBool ret
 
 -- | Eliminate boolean values. TODO: s/boolean/truthy
 ifthenelse :: (Member (Boolean value) sig, Carrier sig m) => value -> Evaluator term address value m a -> Evaluator term address value m a -> Evaluator term address value m a
@@ -126,7 +127,7 @@ ifthenelse v t e = asBool v >>= \ c -> if c then t else e
 
 -- | Compute the disjunction (boolean or) of two computed values. This should have short-circuiting semantics where applicable.
 disjunction :: (Member (Boolean value) sig, Carrier sig m) => Evaluator term address value m value -> Evaluator term address value m value -> Evaluator term address value m value
-disjunction a b = send (Disjunction a b gen)
+disjunction a b = send (Disjunction a b ret)
 
 data Boolean value m k
   = Boolean Bool (value -> k)
@@ -153,7 +154,7 @@ while :: (Member (While value) sig, Carrier sig m)
       => Evaluator term address value m value -- ^ Condition
       -> Evaluator term address value m value -- ^ Body
       -> Evaluator term address value m value
-while cond body = send (While cond body gen)
+while cond body = send (While cond body ret)
 
 -- | Do-while loop, built on top of while.
 doWhile :: (Member (While value) sig, Carrier sig m)

src/Control/Effect/Resource.hs

@@ -6,7 +6,9 @@ module Control.Effect.Resource
 , ResourceC(..)
 ) where
 
-import           Control.Effect hiding (bracket)
+import           Control.Effect
+import           Control.Effect.Carrier
+import           Control.Effect.Sum
 import qualified Control.Exception as Exc
 import           Control.Monad.IO.Class
 
@@ -26,7 +28,7 @@ bracket :: (Member Resource sig, Carrier sig m)
         -> (resource -> m any)
         -> (resource -> m a)
         -> m a
-bracket acquire release use = send (Resource acquire release use gen)
+bracket acquire release use = send (Resource acquire release use ret)
 
 
 runResource :: (Carrier sig m, MonadIO m)
@@ -41,10 +43,10 @@ runResourceC :: (forall x . m x -> IO x) -> ResourceC m a -> m a
 runResourceC handler (ResourceC m) = m handler
 
 instance (Carrier sig m, MonadIO m) => Carrier (Resource :+: sig) (ResourceC m) where
-  gen a = ResourceC (const (gen a))
+  ret a = ResourceC (const (ret a))
-  alg op = ResourceC (\ handler -> (algR handler \/ alg . handlePure (runResourceC handler)) op)
+  eff op = ResourceC (\ handler -> (alg handler \/ eff . handlePure (runResourceC handler)) op)
-    where algR :: MonadIO m => (forall x . m x -> IO x) -> Resource (ResourceC m) (ResourceC m a) -> m a
+    where alg :: MonadIO m => (forall x . m x -> IO x) -> Resource (ResourceC m) (ResourceC m a) -> m a
-          algR handler (Resource acquire release use k) = liftIO (Exc.bracket
+          alg handler (Resource acquire release use k) = liftIO (Exc.bracket
             (handler (runResourceC handler acquire))
             (handler . runResourceC handler . release)
             (handler . runResourceC handler . use))

src/Control/Rewriting.hs

@@ -67,7 +67,8 @@ import Prologue hiding (apply, try)
 
 import           Control.Arrow
 import           Control.Category
-import           Control.Effect hiding (Local)
+import           Control.Effect
+import           Control.Effect.Trace
 import           Data.Functor.Identity
 import           Data.Profunctor
 import qualified Data.Sum as Sum hiding (apply)

src/Data/Abstract/Address/Hole.hs

@@ -5,6 +5,8 @@ module Data.Abstract.Address.Hole
 ) where
 
 import Control.Abstract
+import Control.Effect.Carrier
+import Control.Effect.Sum
 import Prologue
 
 data Hole context a = Partial context | Total a
@@ -29,14 +31,14 @@ instance ( Carrier (Allocator address :+: sig) (AllocatorC (Evaluator term addre
          , Carrier sig m
          )
       => Carrier (Allocator (Hole context address) :+: sig) (AllocatorC (Evaluator term (Hole context address) value m)) where
-  gen = AllocatorC . promote . gen
+  ret = AllocatorC . promote . ret
-  alg = AllocatorC . (algA \/ (alg . handlePure runAllocatorC))
+  eff = AllocatorC . (alg \/ (eff . handlePure runAllocatorC))
-    where algA (Alloc name k) = promote (Total <$> runAllocatorC (alg (L (Alloc name gen))) >>= demote . runAllocatorC . k)
+    where alg (Alloc name k) = promote (Total <$> runAllocatorC (eff (L (Alloc name ret))) >>= demote . runAllocatorC . k)
 
 
 instance (Carrier (Deref value :+: sig) (DerefC (Evaluator term address value m)), Carrier sig m)
       => Carrier (Deref value :+: sig) (DerefC (Evaluator term (Hole context address) value m)) where
-  gen = DerefC . promote . gen
+  ret = DerefC . promote . ret
-  alg = DerefC . (algD \/ (alg . handlePure runDerefC))
+  eff = DerefC . (alg \/ (eff . handlePure runDerefC))
-    where algD (DerefCell cell k) = promote (runDerefC (alg (L (DerefCell cell gen))) >>= demote . runDerefC . k)
+    where alg (DerefCell cell k) = promote (runDerefC (eff (L (DerefCell cell ret))) >>= demote . runDerefC . k)
-          algD (AssignCell value cell k) = promote (runDerefC (alg (L (AssignCell value cell gen))) >>= demote . runDerefC . k)
+          alg (AssignCell value cell k) = promote (runDerefC (eff (L (AssignCell value cell ret))) >>= demote . runDerefC . k)

src/Data/Abstract/Address/Located.hs

@@ -4,6 +4,8 @@ module Data.Abstract.Address.Located
 ) where
 
 import Control.Abstract
+import Control.Effect.Carrier
+import Control.Effect.Sum
 import Data.Abstract.Module (ModuleInfo)
 import Data.Abstract.Name
 import Data.Abstract.Package (PackageInfo)
@@ -32,14 +34,14 @@ instance ( Carrier (Allocator address :+: sig) (AllocatorC (Evaluator term addre
          , Member (Reader Span) sig
          )
       => Carrier (Allocator (Located address) :+: sig) (AllocatorC (Evaluator term (Located address) value m)) where
-  gen = AllocatorC . promote . gen
+  ret = AllocatorC . promote . ret
-  alg = AllocatorC . (algA \/ (alg . handlePure runAllocatorC))
+  eff = AllocatorC . (alg \/ (eff . handlePure runAllocatorC))
-    where algA (Alloc name k) = promote (Located <$> runAllocatorC (alg (L (Alloc name gen))) <*> currentPackage <*> currentModule <*> pure name <*> ask >>= demote . runAllocatorC . k)
+    where alg (Alloc name k) = promote (Located <$> runAllocatorC (eff (L (Alloc name ret))) <*> currentPackage <*> currentModule <*> pure name <*> ask >>= demote . runAllocatorC . k)
 
 
 instance (Carrier (Deref value :+: sig) (DerefC (Evaluator term address value m)), Carrier sig m)
       => Carrier (Deref value :+: sig) (DerefC (Evaluator term (Located address) value m)) where
-  gen = DerefC . promote . gen
+  ret = DerefC . promote . ret
-  alg = DerefC . (algD \/ (alg . handlePure runDerefC))
+  eff = DerefC . (alg \/ (eff . handlePure runDerefC))
-    where algD (DerefCell cell k) = promote (runDerefC (alg (L (DerefCell cell gen))) >>= demote . runDerefC . k)
+    where alg (DerefCell cell k) = promote (runDerefC (eff (L (DerefCell cell ret))) >>= demote . runDerefC . k)
-          algD (AssignCell value cell k) = promote (runDerefC (alg (L (AssignCell value cell gen))) >>= demote . runDerefC . k)
+          alg (AssignCell value cell k) = promote (runDerefC (eff (L (AssignCell value cell ret))) >>= demote . runDerefC . k)

src/Data/Abstract/Address/Monovariant.hs

@@ -4,6 +4,8 @@ module Data.Abstract.Address.Monovariant
 ) where
 
 import Control.Abstract
+import Control.Effect.Carrier
+import Control.Effect.Sum
 import Data.Abstract.Name
 import qualified Data.Set as Set
 import Prologue
@@ -17,13 +19,13 @@ instance Show Monovariant where
 
 
 instance Carrier sig m => Carrier (Allocator Monovariant :+: sig) (AllocatorC (Evaluator term Monovariant value m)) where
-  gen = AllocatorC . gen
+  ret = AllocatorC . ret
-  alg = AllocatorC . (algA \/ (alg . handlePure runAllocatorC))
+  eff = AllocatorC . (alg \/ (eff . handlePure runAllocatorC))
-    where algA (Alloc name k) = runAllocatorC (k (Monovariant name))
+    where alg (Alloc name k) = runAllocatorC (k (Monovariant name))
 
 
 instance (Member NonDet sig, Ord value, Carrier sig m) => Carrier (Deref value :+: sig) (DerefC (Evaluator term Monovariant value m)) where
-  gen = DerefC . gen
+  ret = DerefC . ret
-  alg = DerefC . (algD \/ (alg . handlePure runDerefC))
+  eff = DerefC . (alg \/ (eff . handlePure runDerefC))
-    where algD (DerefCell cell k) = traverse (foldMapA pure) (nonEmpty (toList cell)) >>= runDerefC . k
+    where alg (DerefCell cell k) = traverse (foldMapA pure) (nonEmpty (toList cell)) >>= runDerefC . k
-          algD (AssignCell value cell k) = runDerefC (k (Set.insert value cell))
+          alg (AssignCell value cell k) = runDerefC (k (Set.insert value cell))

src/Data/Abstract/Address/Precise.hs

@@ -4,6 +4,8 @@ module Data.Abstract.Address.Precise
 ) where
 
 import Control.Abstract
+import Control.Effect.Carrier
+import Control.Effect.Sum
 import qualified Data.Set as Set
 import Prologue
 
@@ -16,13 +18,13 @@ instance Show Precise where
 
 
 instance (Member Fresh sig, Carrier sig m) => Carrier (Allocator Precise :+: sig) (AllocatorC (Evaluator term Precise value m)) where
-  gen = AllocatorC . gen
+  ret = AllocatorC . ret
-  alg = AllocatorC . (algA \/ (alg . handlePure runAllocatorC))
+  eff = AllocatorC . (alg \/ (eff . handlePure runAllocatorC))
-    where algA (Alloc _ k) = Precise <$> fresh >>= runAllocatorC . k
+    where alg (Alloc _ k) = Precise <$> fresh >>= runAllocatorC . k
 
 
 instance Carrier sig m => Carrier (Deref value :+: sig) (DerefC (Evaluator term Precise value m)) where
-  gen = DerefC . gen
+  ret = DerefC . ret
-  alg = DerefC . (algD \/ (alg . handlePure runDerefC))
+  eff = DerefC . (alg \/ (eff . handlePure runDerefC))
-    where algD (DerefCell cell k) = runDerefC (k (fst <$> Set.minView cell))
+    where alg (DerefCell cell k) = runDerefC (k (fst <$> Set.minView cell))
-          algD (AssignCell value _ k) = runDerefC (k (Set.singleton value))
+          alg (AssignCell value _ k) = runDerefC (k (Set.singleton value))

src/Data/Abstract/Name.hs

@@ -9,6 +9,7 @@ module Data.Abstract.Name
 ) where
 
 import           Control.Effect
+import           Control.Effect.Fresh
 import           Data.Aeson
 import qualified Data.Char as Char
 import           Data.Text (Text)

src/Data/Abstract/Value/Abstract.hs

@@ -7,6 +7,8 @@ module Data.Abstract.Value.Abstract
 ) where
 
 import Control.Abstract as Abstract
+import Control.Effect.Carrier
+import Control.Effect.Sum
 import Data.Abstract.BaseError
 import Data.Abstract.Environment as Env
 import Prologue
@@ -28,9 +30,9 @@ instance ( Member (Allocator address) sig
          , Carrier sig m
          )
       => Carrier (Abstract.Function term address Abstract :+: sig) (FunctionC term address Abstract (Evaluator term address Abstract m)) where
-  gen = FunctionC . const . gen
+  ret = FunctionC . const . ret
-  alg op = FunctionC (\ eval -> (algF eval \/ (alg . handlePure (flip runFunctionC eval))) op)
+  eff op = FunctionC (\ eval -> (alg eval \/ (eff . handlePure (flip runFunctionC eval))) op)
-    where algF eval = \case
+    where alg eval = \case
             Function _ params body k -> do
               env <- foldr (\ name rest -> do
                 addr <- alloc name
@@ -45,11 +47,11 @@ instance ( Member (Allocator address) sig
 
 
 instance (Carrier sig m, Member NonDet sig) => Carrier (Boolean Abstract :+: sig) (BooleanC (Evaluator term address Abstract m)) where
-  gen = BooleanC . gen
+  ret = BooleanC . ret
-  alg = BooleanC . (algB \/ (alg . handlePure runBooleanC))
+  eff = BooleanC . (alg \/ (eff . handlePure runBooleanC))
-    where algB (Boolean _ k) = runBooleanC (k Abstract)
+    where alg (Boolean _ k) = runBooleanC (k Abstract)
-          algB (AsBool _ k) = runBooleanC (k True) <|> runBooleanC (k False)
+          alg (AsBool _ k) = runBooleanC (k True) <|> runBooleanC (k False)
-          algB (Disjunction a b k) = (runBooleanC a <|> runBooleanC b) >>= runBooleanC . k
+          alg (Disjunction a b k) = (runBooleanC a <|> runBooleanC b) >>= runBooleanC . k
 
 
 instance ( Member (Abstract.Boolean Abstract) sig
@@ -57,9 +59,9 @@ instance ( Member (Abstract.Boolean Abstract) sig
          , Carrier sig m
          )
       => Carrier (While Abstract :+: sig) (WhileC (Evaluator term address Abstract m)) where
-  gen = WhileC . gen
+  ret = WhileC . ret
-  alg = WhileC . (algW \/ (alg . handlePure runWhileC))
+  eff = WhileC . (alg \/ (eff . handlePure runWhileC))
-    where algW (Abstract.While cond body k) = do
+    where alg (Abstract.While cond body k) = do
             cond' <- runWhileC cond
             ifthenelse cond' (runWhileC body *> empty) (runWhileC (k unit))
 

src/Data/Abstract/Value/Concrete.hs

@@ -9,6 +9,8 @@ module Data.Abstract.Value.Concrete
 
 import qualified Control.Abstract as Abstract
 import Control.Abstract hiding (Boolean(..), Function(..), While(..))
+import Control.Effect.Carrier
+import Control.Effect.Sum
 import Data.Abstract.BaseError
 import Data.Abstract.Evaluatable (UnspecializedError(..))
 import Data.Abstract.Environment (Environment, Bindings, EvalContext(..))
@@ -71,9 +73,9 @@ instance ( FreeVariables term
          , Show term
          )
       => Carrier (Abstract.Function term address (Value term address) :+: sig) (Abstract.FunctionC term address (Value term address) (Evaluator term address (Value term address) m)) where
-  gen = FunctionC . const . gen
+  ret = FunctionC . const . ret
-  alg op = FunctionC (\ eval -> (algF eval \/ (alg . handlePure (flip runFunctionC eval))) op)
+  eff op = FunctionC (\ eval -> (alg eval \/ (eff . handlePure (flip runFunctionC eval))) op)
-    where algF eval = \case
+    where alg eval = \case
             Abstract.Function name params body k -> do
               packageInfo <- currentPackage
               moduleInfo <- currentModule
@@ -103,10 +105,10 @@ instance ( Member (Reader ModuleInfo) sig
          , Carrier sig m
          )
       => Carrier (Abstract.Boolean (Value term address) :+: sig) (BooleanC (Evaluator term address (Value term address) m)) where
-  gen = BooleanC . gen
+  ret = BooleanC . ret
-  alg = BooleanC . (algB \/ (alg . handlePure runBooleanC))
+  eff = BooleanC . (alg \/ (eff . handlePure runBooleanC))
-    where algB :: Abstract.Boolean (Value term address) (BooleanC (Evaluator term address (Value term address) m)) (BooleanC (Evaluator term address (Value term address) m) a) -> Evaluator term address (Value term address) m a
+    where alg :: Abstract.Boolean (Value term address) (BooleanC (Evaluator term address (Value term address) m)) (BooleanC (Evaluator term address (Value term address) m) a) -> Evaluator term address (Value term address) m a
-          algB = \case
+          alg = \case
             Abstract.Boolean b          k -> runBooleanC . k $! Boolean b
             Abstract.AsBool (Boolean b) k -> runBooleanC (k b)
             Abstract.AsBool other       k -> (throwValueError $! BoolError other) >>= runBooleanC . k
@@ -134,9 +136,9 @@ instance ( Member (Reader ModuleInfo) sig
 --          , Show term
 --          )
 --       => Carrier (Abstract.While (Value term address) :+: sig) (WhileC (Evaluator term address (Value term address) (InterposeC (Resumable (BaseError (UnspecializedError (Value term address)))) (Evaluator term address (Value term address) m)))) where
---   gen = WhileC . gen
+--   ret = WhileC . ret
---   alg = WhileC . (algW \/ (alg . handlePure runWhileC))
+--   eff = WhileC . (alg \/ (eff . handlePure runWhileC))
---     where algW = \case
+--     where alg = \case
 --             Abstract.While cond body k -> interpose @(Resumable (BaseError (UnspecializedError (Value term address))))
 --                   (\(Resumable (BaseError _ _ (UnspecializedError _)) k) -> throwAbort) (runEvaluator (loop (\continue -> do
 --               cond' <- runWhileC cond
@@ -168,10 +170,10 @@ runInterposeC :: (forall x . eff m (m x) -> m x) -> InterposeC eff m a -> m a
 runInterposeC f (InterposeC m) = m f
 
 instance (Member eff sig, HFunctor eff, Carrier sig m) => Carrier sig (InterposeC eff m) where
-  gen a = InterposeC (const (gen a))
+  ret a = InterposeC (const (ret a))
-  alg op
+  eff op
     | Just e <- prj op = InterposeC (\ handler -> handler (handlePure (runInterposeC handler) e))
-    | otherwise        = InterposeC (\ handler -> alg (handlePure (runInterposeC handler) op))
+    | otherwise        = InterposeC (\ handler -> eff (handlePure (runInterposeC handler) op))
 
 
 instance AbstractHole (Value term address) where

src/Data/Abstract/Value/Type.hs

@@ -13,6 +13,8 @@ module Data.Abstract.Value.Type
 
 import qualified Control.Abstract as Abstract
 import Control.Abstract hiding (Boolean(..), Function(..), While(..))
+import Control.Effect.Carrier
+import Control.Effect.Sum
 import Data.Abstract.Environment as Env
 import Data.Abstract.BaseError
 import Data.Semigroup.Foldable (foldMap1)
@@ -134,7 +136,7 @@ modifyTypeMap :: ( Member (State TypeMap) sig
                  )
               => (Map.Map TName Type -> Map.Map TName Type)
               -> m ()
-modifyTypeMap f = modify' (TypeMap . f . unTypeMap)
+modifyTypeMap f = modify (TypeMap . f . unTypeMap)
 
 -- | Prunes substituted type variables
 prune :: ( Member (State TypeMap) sig
@@ -247,9 +249,9 @@ instance ( Member (Allocator address) sig
          , Carrier sig m
          )
       => Carrier (Abstract.Function term address Type :+: sig) (FunctionC term address Type (Evaluator term address Type m)) where
-  gen = FunctionC . const . gen
+  ret = FunctionC . const . ret
-  alg op = FunctionC (\ eval -> (algF eval \/ (alg . handlePure (flip runFunctionC eval))) op)
+  eff op = FunctionC (\ eval -> (alg eval \/ (eff . handlePure (flip runFunctionC eval))) op)
-    where algF eval = \case
+    where alg eval = \case
             Abstract.Function _ params body k -> do
               (env, tvars) <- foldr (\ name rest -> do
                 addr <- alloc name
@@ -278,11 +280,11 @@ instance ( Member NonDet sig
          , Carrier sig m
          )
       => Carrier (Abstract.Boolean Type :+: sig) (BooleanC (Evaluator term address Type m)) where
-  gen = BooleanC . gen
+  ret = BooleanC . ret
-  alg = BooleanC . (algB \/ (alg . handlePure runBooleanC))
+  eff = BooleanC . (alg \/ (eff . handlePure runBooleanC))
-    where algB (Abstract.Boolean _ k) = runBooleanC (k Bool)
+    where alg (Abstract.Boolean _ k) = runBooleanC (k Bool)
-          algB (Abstract.AsBool t k) = unify t Bool *> (runBooleanC (k True) <|> runBooleanC (k False))
+          alg (Abstract.AsBool t k) = unify t Bool *> (runBooleanC (k True) <|> runBooleanC (k False))
-          algB (Abstract.Disjunction t1 t2 k) = ((runBooleanC t1 >>= unify Bool) <|> (runBooleanC t2 >>= unify Bool) >>= runBooleanC . k)
+          alg (Abstract.Disjunction t1 t2 k) = ((runBooleanC t1 >>= unify Bool) <|> (runBooleanC t2 >>= unify Bool) >>= runBooleanC . k)
 
 
 instance ( Member (Abstract.Boolean Type) sig
@@ -290,9 +292,9 @@ instance ( Member (Abstract.Boolean Type) sig
          , Carrier sig m
          )
       => Carrier (Abstract.While Type :+: sig) (WhileC (Evaluator term address Type m)) where
-  gen = WhileC . gen
+  ret = WhileC . ret
-  alg = WhileC . (algW \/ (alg . handlePure runWhileC))
+  eff = WhileC . (alg \/ (eff . handlePure runWhileC))
-    where algW (Abstract.While cond body k) = do
+    where alg (Abstract.While cond body k) = do
             cond' <- runWhileC cond
             ifthenelse cond' (runWhileC body *> empty) (runWhileC (k unit))
 

src/Data/Graph.hs

@@ -21,6 +21,7 @@ import           Algebra.Graph.Class (connect, overlay, vertex)
 import qualified Algebra.Graph.Class as Class
 import qualified Algebra.Graph.ToGraph as Class
 import           Control.Effect
+import           Control.Effect.State
 import           Data.Aeson
 import qualified Data.Set as Set
 

src/Data/Project.hs

@@ -20,6 +20,7 @@ import Prelude hiding (readFile)
 import Prologue hiding (throwError)
 
 import           Control.Effect
+import           Control.Effect.Error
 import           Data.Blob
 import           Data.Language
 import qualified Data.Text as T

src/Language/JSON/PrettyPrint.hs

@@ -9,6 +9,7 @@ module Language.JSON.PrettyPrint
 import Prologue hiding (throwError)
 
 import Control.Effect
+import Control.Effect.Error
 import Control.Monad.Trans (lift)
 import Data.Machine
 

src/Language/Python/PrettyPrint.hs

@@ -3,6 +3,7 @@
 module Language.Python.PrettyPrint ( printingPython ) where
 
 import Control.Effect
+import Control.Effect.Error
 import Control.Monad.Trans (lift)
 import Data.Machine
 

src/Language/Ruby/PrettyPrint.hs

@@ -3,6 +3,7 @@
 module Language.Ruby.PrettyPrint ( printingRuby ) where
 
 import Control.Effect
+import Control.Effect.Error
 import Control.Monad.Trans (lift)
 import Data.Machine
 

src/Parsing/TreeSitter.hs

@@ -8,8 +8,9 @@ import Prologue hiding (bracket)
 
 import           Control.Concurrent.Async
 import qualified Control.Exception as Exc (bracket)
-import           Control.Effect hiding (bracket)
+import           Control.Effect
 import           Control.Effect.Resource
+import           Control.Effect.Trace
 import           Control.Monad.IO.Class
 import           Data.ByteString.Unsafe (unsafeUseAsCStringLen)
 import           Foreign

src/Rendering/Graph.hs

@@ -9,6 +9,8 @@ module Rendering.Graph
 import Algebra.Graph.Export.Dot
 import Analysis.ConstructorName
 import Control.Effect
+import Control.Effect.Fresh
+import Control.Effect.Reader
 import Data.Diff
 import Data.Graph
 import Data.Graph.TermVertex

src/Reprinting/Pipeline.hs

@@ -104,6 +104,8 @@ module Reprinting.Pipeline
   ) where
 
 import           Control.Effect as Effect
+import           Control.Effect.Error as Effect
+import           Control.Effect.State as Effect
 import           Data.Machine hiding (Source)
 import           Data.Machine.Runner
 import           Data.Text.Prettyprint.Doc

src/Reprinting/Translate.hs

@@ -7,6 +7,8 @@ module Reprinting.Translate
 
 import           Control.Monad
 import           Control.Effect
+import           Control.Effect.Error
+import           Control.Effect.State
 import           Control.Monad.Trans
 import           Data.Machine
 
@@ -34,8 +36,8 @@ contextualizing = repeatedly $ await >>= \case
 
 enterScope, exitScope :: Scope -> PlanT k Fragment Translator ()
 
-enterScope c = lift (modify' (c :))
+enterScope c = lift (modify (c :))
 
 exitScope c = lift get >>= \case
-  (x:xs) -> when (x == c) (lift (modify' (const xs)))
+  (x:xs) -> when (x == c) (lift (modify (const xs)))
   cs     -> lift (throwError (UnbalancedPair c cs))

src/Semantic/Distribute.hs

@@ -10,6 +10,8 @@ module Semantic.Distribute
 
 import qualified Control.Concurrent.Async as Async
 import           Control.Effect
+import           Control.Effect.Carrier
+import           Control.Effect.Sum
 import           Control.Parallel.Strategies
 import           Control.Monad.IO.Class
 import           Prologue hiding (MonadError (..))
@@ -18,7 +20,7 @@ import           Prologue hiding (MonadError (..))
 --
 --   This is a concurrent analogue of 'sequenceA'.
 distribute :: (Member Distribute sig, Traversable t, Carrier sig m, Applicative m) => t (m output) -> m (t output)
-distribute = fmap (withStrategy (parTraversable rseq)) <$> traverse (send . flip Distribute gen)
+distribute = fmap (withStrategy (parTraversable rseq)) <$> traverse (send . flip Distribute ret)
 
 -- | Distribute the application of a function to each element of a 'Traversable' container of inputs over the available cores (i.e. perform the function concurrently for each element), collecting the results.
 --
@@ -53,5 +55,5 @@ runDistribute = runDistributeC . interpret
 newtype DistributeC m a = DistributeC { runDistributeC :: m a }
 
 instance Carrier (Distribute :+: Lift IO) (DistributeC (Eff (LiftC IO))) where
-  gen = DistributeC . gen
+  ret = DistributeC . ret
-  alg = DistributeC . ((\ (Distribute task k) -> liftIO (Async.runConcurrently (Async.Concurrently (runM (runDistributeC task)))) >>= runDistributeC . k) \/ (alg . handlePure runDistributeC))
+  eff = DistributeC . ((\ (Distribute task k) -> liftIO (Async.runConcurrently (Async.Concurrently (runM (runDistributeC task)))) >>= runDistributeC . k) \/ (eff . handlePure runDistributeC))

src/Semantic/IO.hs

@@ -35,6 +35,10 @@ module Semantic.IO
 ) where
 
 import           Control.Effect
+import           Control.Effect.Carrier
+import           Control.Effect.Error
+import           Control.Effect.Sum
+import qualified Control.Exception as Exc
 import           Control.Monad.IO.Class
 import           Data.Aeson
 import           Data.Blob
@@ -160,27 +164,27 @@ noLanguageForBlob blobPath = throwError (SomeException (NoLanguageForBlob blobPa
 
 
 readBlob :: (Member Files sig, Carrier sig m) => File -> m Blob
-readBlob file = send (Read (FromPath file) gen)
+readBlob file = send (Read (FromPath file) ret)
 
 -- | A task which reads a list of 'Blob's from a 'Handle' or a list of 'FilePath's optionally paired with 'Language's.
 readBlobs :: (Member Files sig, Carrier sig m, Applicative m) => Either (Handle 'IO.ReadMode) [File] -> m [Blob]
-readBlobs (Left handle) = send (Read (FromHandle handle) gen)
+readBlobs (Left handle) = send (Read (FromHandle handle) ret)
-readBlobs (Right paths) = traverse (send . flip Read gen . FromPath) paths
+readBlobs (Right paths) = traverse (send . flip Read ret . FromPath) paths
 
 -- | A task which reads a list of pairs of 'Blob's from a 'Handle' or a list of pairs of 'FilePath's optionally paired with 'Language's.
 readBlobPairs :: (Member Files sig, Carrier sig m, Applicative m) => Either (Handle 'IO.ReadMode) [Both File] -> m [BlobPair]
-readBlobPairs (Left handle) = send (Read (FromPairHandle handle) gen)
+readBlobPairs (Left handle) = send (Read (FromPairHandle handle) ret)
-readBlobPairs (Right paths) = traverse (send . flip Read gen . FromPathPair) paths
+readBlobPairs (Right paths) = traverse (send . flip Read ret . FromPathPair) paths
 
 readProject :: (Member Files sig, Carrier sig m) => Maybe FilePath -> FilePath -> Language -> [FilePath] -> m Project
-readProject rootDir dir lang excludeDirs = send (ReadProject rootDir dir lang excludeDirs gen)
+readProject rootDir dir lang excludeDirs = send (ReadProject rootDir dir lang excludeDirs ret)
 
 findFiles :: (Member Files sig, Carrier sig m) => FilePath -> [String] -> [FilePath] -> m [FilePath]
-findFiles dir exts paths = send (FindFiles dir exts paths gen)
+findFiles dir exts paths = send (FindFiles dir exts paths ret)
 
 -- | A task which writes a 'B.Builder' to a 'Handle' or a 'FilePath'.
 write :: (Member Files sig, Carrier sig m) => Destination -> B.Builder -> m ()
-write dest builder = send (Write dest builder (gen ()))
+write dest builder = send (Write dest builder (ret ()))
 
 data Handle mode where
   ReadHandle  :: IO.Handle -> Handle 'IO.ReadMode
@@ -238,9 +242,9 @@ runFiles = runFilesC . interpret
 newtype FilesC m a = FilesC { runFilesC :: m a }
 
 instance (Member (Error SomeException) sig, MonadIO m, Carrier sig m) => Carrier (Files :+: sig) (FilesC m) where
-  gen = FilesC . gen
+  ret = FilesC . ret
-  alg = FilesC . (algF \/ (alg . handlePure runFilesC))
+  eff = FilesC . (alg \/ (eff . handlePure runFilesC))
-    where algF = \case
+    where alg = \case
             Read (FromPath path) k -> (readBlobFromPath path `catchIO` (throwError . toException @SomeException)) >>= runFilesC . k
             Read (FromHandle handle) k -> (readBlobsFromHandle handle  `catchIO` (throwError . toException @SomeException)) >>= runFilesC . k
             Read (FromPathPair paths) k -> (runBothWith readFilePair paths `catchIO` (throwError . toException @SomeException)) >>= runFilesC . k
@@ -249,3 +253,13 @@ instance (Member (Error SomeException) sig, MonadIO m, Carrier sig m) => Carrier
             FindFiles dir exts excludeDirs k -> (findFilesInDir dir exts excludeDirs `catchIO` (throwError . toException @SomeException)) >>= runFilesC . k
             Write (ToPath path) builder k -> liftIO (IO.withBinaryFile path IO.WriteMode (`B.hPutBuilder` builder)) >> runFilesC k
             Write (ToHandle (WriteHandle handle)) builder k -> liftIO (B.hPutBuilder handle builder) >> runFilesC k
+
+
+-- | Generalize 'Exc.catch' to other 'MonadIO' contexts for the handler and result.
+catchIO :: ( Exc.Exception exc
+           , MonadIO m
+           )
+        => IO a
+        -> (exc -> m a)
+        -> m a
+catchIO m handler = liftIO (Exc.try m) >>= either handler pure

src/Semantic/Parse.hs

@@ -5,6 +5,7 @@ import           Analysis.ConstructorName (ConstructorName)
 import           Analysis.Declaration (HasDeclaration, declarationAlgebra)
 import           Analysis.PackageDef (HasPackageDef)
 import           Control.Effect
+import           Control.Effect.Error
 import           Control.Monad.IO.Class
 import           Data.Blob
 import           Data.Either

src/Semantic/Resolution.hs

@@ -8,6 +8,8 @@ module Semantic.Resolution
   ) where
 
 import           Control.Effect
+import           Control.Effect.Carrier
+import           Control.Effect.Sum
 import           Data.Aeson
 import           Data.Aeson.Types (parseMaybe)
 import           Data.Blob
@@ -38,9 +40,9 @@ nodeJSResolutionMap rootDir prop excludeDirs = do
 
 resolutionMap :: (Member Resolution sig, Carrier sig m) => Project -> m (Map FilePath FilePath)
 resolutionMap Project{..} = case projectLanguage of
-  TypeScript -> send (NodeJSResolution projectRootDir "types" projectExcludeDirs gen)
+  TypeScript -> send (NodeJSResolution projectRootDir "types" projectExcludeDirs ret)
-  JavaScript -> send (NodeJSResolution projectRootDir "main"  projectExcludeDirs gen)
+  JavaScript -> send (NodeJSResolution projectRootDir "main"  projectExcludeDirs ret)
-  _          -> send (NoResolution gen)
+  _          -> send (NoResolution ret)
 
 data Resolution (m :: * -> *) k
   = NodeJSResolution FilePath Text [FilePath] (Map FilePath FilePath -> k)
@@ -60,7 +62,7 @@ runResolution = runResolutionC . interpret
 newtype ResolutionC m a = ResolutionC { runResolutionC :: m a }
 
 instance (Member Files sig, Carrier sig m, Monad m) => Carrier (Resolution :+: sig) (ResolutionC m) where
-  gen = ResolutionC . gen
+  ret = ResolutionC . ret
-  alg = ResolutionC . (algR \/ (alg . handlePure runResolutionC))
+  eff = ResolutionC . (alg \/ (eff . handlePure runResolutionC))
-    where algR (NodeJSResolution dir prop excludeDirs k) = nodeJSResolutionMap dir prop excludeDirs >>= runResolutionC . k
+    where alg (NodeJSResolution dir prop excludeDirs k) = nodeJSResolutionMap dir prop excludeDirs >>= runResolutionC . k
-          algR (NoResolution k) = runResolutionC (k Map.empty)
+          alg (NoResolution k) = runResolutionC (k Map.empty)

src/Semantic/Task.hs

@@ -58,7 +58,12 @@ import qualified Assigning.Assignment as Assignment
 import qualified Assigning.Assignment.Deterministic as Deterministic
 import qualified Control.Abstract as Analysis
 import           Control.Effect
+import           Control.Effect.Carrier
+import           Control.Effect.Error
+import           Control.Effect.Reader
 import           Control.Effect.Resource
+import           Control.Effect.Sum
+import           Control.Effect.Trace
 import           Control.Monad
 import           Control.Monad.IO.Class
 import           Data.Blob
@@ -111,40 +116,40 @@ parse :: (Member Task sig, Carrier sig m)
       => Parser term
       -> Blob
       -> m term
-parse parser blob = send (Parse parser blob gen)
+parse parser blob = send (Parse parser blob ret)
 
 -- | A task running some 'Analysis.Evaluator' to completion.
 analyze :: (Member Task sig, Carrier sig m)
         => (Analysis.Evaluator term address value m a -> result)
         -> Analysis.Evaluator term address value m a
         -> m result
-analyze interpret analysis = send (Analyze interpret analysis gen)
+analyze interpret analysis = send (Analyze interpret analysis ret)
 
 -- | A task which decorates a 'Term' with values computed using the supplied 'RAlgebra' function.
 decorate :: (Functor f, Member Task sig, Carrier sig m)
          => RAlgebra (TermF f Location) (Term f Location) field
          -> Term f Location
          -> m (Term f field)
-decorate algebra term = send (Decorate algebra term gen)
+decorate algebra term = send (Decorate algebra term ret)
 
 -- | A task which diffs a pair of terms using the supplied 'Differ' function.
 diff :: (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax, Member Task sig, Carrier sig m)
      => These (Term syntax ann) (Term syntax ann)
      -> m (Diff syntax ann ann)
-diff terms = send (Semantic.Task.Diff terms gen)
+diff terms = send (Semantic.Task.Diff terms ret)
 
 -- | A task which renders some input using the supplied 'Renderer' function.
 render :: (Member Task sig, Carrier sig m)
        => Renderer input output
        -> input
        -> m output
-render renderer input = send (Render renderer input gen)
+render renderer input = send (Render renderer input ret)
 
 serialize :: (Member Task sig, Carrier sig m)
           => Format input
           -> input
           -> m Builder
-serialize format input = send (Serialize format input gen)
+serialize format input = send (Serialize format input ret)
 
 -- | Execute a 'Task' with the 'defaultOptions', yielding its result value in 'IO'.
 --
@@ -199,8 +204,8 @@ runTraceInTelemetry = runTraceInTelemetryC . interpret
 newtype TraceInTelemetryC m a = TraceInTelemetryC { runTraceInTelemetryC :: m a }
 
 instance (Member Telemetry sig, Carrier sig m, Monad m) => Carrier (Trace :+: sig) (TraceInTelemetryC m) where
-  gen = TraceInTelemetryC . gen
+  ret = TraceInTelemetryC . ret
-  alg = TraceInTelemetryC . ((\ (Trace str k) -> writeLog Debug str [] >> runTraceInTelemetryC k) \/ (alg . handlePure runTraceInTelemetryC))
+  eff = TraceInTelemetryC . ((\ (Trace str k) -> writeLog Debug str [] >> runTraceInTelemetryC k) \/ (eff . handlePure runTraceInTelemetryC))
 
 
 -- | An effect describing high-level tasks to be performed.
@@ -243,9 +248,9 @@ runTaskF = runTaskC . interpret
 newtype TaskC m a = TaskC { runTaskC :: m a }
 
 instance (Member (Error SomeException) sig, Member (Lift IO) sig, Member (Reader Config) sig, Member Resource sig, Member Telemetry sig, Member Timeout sig, Member Trace sig, Carrier sig m, MonadIO m) => Carrier (Task :+: sig) (TaskC m) where
-  gen = TaskC . gen
+  ret = TaskC . ret
-  alg = TaskC . (algT \/ (alg . handlePure runTaskC))
+  eff = TaskC . (alg \/ (eff . handlePure runTaskC))
-    where algT = \case
+    where alg = \case
             Parse parser blob k -> runParser blob parser >>= runTaskC . k
             Analyze interpret analysis k -> runTaskC (k (interpret analysis))
             Decorate algebra term k -> runTaskC (k (decoratorWithAlgebra algebra term))

src/Semantic/Telemetry.hs

@@ -50,7 +50,9 @@ module Semantic.Telemetry
 , IgnoreTelemetryC(..)
 ) where
 
-import           Control.Effect hiding (bracket)
+import           Control.Effect
+import           Control.Effect.Carrier
+import           Control.Effect.Sum
 import           Control.Exception
 import           Control.Monad.IO.Class
 import           Data.Coerce
@@ -119,11 +121,11 @@ queueStat q = liftIO . writeAsyncQueue q
 
 -- | A task which logs a message at a specific log level to stderr.
 writeLog :: (Member Telemetry sig, Carrier sig m) => Level -> String -> [(String, String)] -> m ()
-writeLog level message pairs = send (WriteLog level message pairs (gen ()))
+writeLog level message pairs = send (WriteLog level message pairs (ret ()))
 
 -- | A task which writes a stat.
 writeStat :: (Member Telemetry sig, Carrier sig m) => Stat -> m ()
-writeStat stat = send (WriteStat stat (gen ()))
+writeStat stat = send (WriteStat stat (ret ()))
 
 -- | A task which measures and stats the timing of another task.
 time :: (Member Telemetry sig, Carrier sig m, MonadIO m) => String -> [(String, String)] -> m output -> m output
@@ -155,10 +157,10 @@ runTelemetry logger statter = flip runTelemetryC (logger, statter) . interpret
 newtype TelemetryC m a = TelemetryC { runTelemetryC :: (LogQueue, StatQueue) -> m a }
 
 instance (Carrier sig m, MonadIO m) => Carrier (Telemetry :+: sig) (TelemetryC m) where
-  gen = TelemetryC . const . gen
+  ret = TelemetryC . const . ret
-  alg op = TelemetryC (\ queues -> (algT queues \/ (alg . handlePure (flip runTelemetryC queues))) op)
+  eff op = TelemetryC (\ queues -> (alg queues \/ (eff . handlePure (flip runTelemetryC queues))) op)
-    where algT queues (WriteStat stat k) = queueStat (snd queues) stat *> runTelemetryC k queues
+    where alg queues (WriteStat stat k) = queueStat (snd queues) stat *> runTelemetryC k queues
-          algT queues (WriteLog level message pairs k) = queueLogMessage (fst queues) level message pairs *> runTelemetryC k queues
+          alg queues (WriteLog level message pairs k) = queueLogMessage (fst queues) level message pairs *> runTelemetryC k queues
 
 
 -- | Run a 'Telemetry' effect by ignoring statting/logging.
@@ -168,7 +170,7 @@ ignoreTelemetry = runIgnoreTelemetryC . interpret
 newtype IgnoreTelemetryC m a = IgnoreTelemetryC { runIgnoreTelemetryC :: m a }
 
 instance Carrier sig m => Carrier (Telemetry :+: sig) (IgnoreTelemetryC m) where
-  gen = IgnoreTelemetryC . gen
+  ret = IgnoreTelemetryC . ret
-  alg = algT \/ (IgnoreTelemetryC . alg . handlePure runIgnoreTelemetryC)
+  eff = alg \/ (IgnoreTelemetryC . eff . handlePure runIgnoreTelemetryC)
-    where algT (WriteStat _ k) = k
+    where alg (WriteStat _ k) = k
-          algT (WriteLog _ _ _ k) = k
+          alg (WriteLog _ _ _ k) = k

src/Semantic/Timeout.hs

@@ -8,6 +8,8 @@ module Semantic.Timeout
 ) where
 
 import           Control.Effect
+import           Control.Effect.Carrier
+import           Control.Effect.Sum
 import           Control.Monad.IO.Class
 import           Data.Duration
 import qualified System.Timeout as System
@@ -16,7 +18,7 @@ import qualified System.Timeout as System
 -- within the specified duration. Uses 'System.Timeout.timeout' so all caveats
 -- about not operating over FFI boundaries apply.
 timeout :: (Member Timeout sig, Carrier sig m) => Duration -> m output -> m (Maybe output)
-timeout n = send . flip (Timeout n) gen
+timeout n = send . flip (Timeout n) ret
 
 -- | 'Timeout' effects run other effects, aborting them if they exceed the
 -- specified duration.
@@ -45,8 +47,8 @@ runTimeoutC :: (forall x . m x -> IO x) -> TimeoutC m a -> m a
 runTimeoutC f (TimeoutC m) = m f
 
 instance (Carrier sig m, MonadIO m) => Carrier (Timeout :+: sig) (TimeoutC m) where
-  gen a = TimeoutC (const (gen a))
+  ret a = TimeoutC (const (ret a))
-  alg op = TimeoutC (\ handler ->
+  eff op = TimeoutC (\ handler ->
     ((\ (Timeout n task k) -> liftIO (System.timeout (toMicroseconds n) (handler (runTimeoutC handler task))) >>= runTimeoutC handler . k)
-    \/ (alg . handlePure (runTimeoutC handler)))
+    \/ (eff . handlePure (runTimeoutC handler)))
       op)

vendor/higher-order-effects

@@ -1 +1 @@
-Subproject commit 58d709bf6017ec79de9a25b20b784103b0a506ba
+Subproject commit 37930eaf171de50579fda9168936cc1dc2d767cf