Merge pull request #2224 from github/higher-order-effects

Higher-order effects

.gitmodules

@@ -1,9 +1,6 @@
 [submodule "vendor/hspec-expectations-pretty-diff"]
 	path = vendor/hspec-expectations-pretty-diff
 	url = https://github.com/rewinfrey/hspec-expectations-pretty-diff
-[submodule "vendor/effects"]
-	path = vendor/effects
-	url = https://github.com/joshvera/effects.git
 [submodule "vendor/haskell-tree-sitter"]
 	path = vendor/haskell-tree-sitter
 	url = https://github.com/tree-sitter/haskell-tree-sitter.git
@@ -16,3 +13,6 @@
 [submodule "vendor/semilattices"]
 	path = vendor/semilattices
 	url = https://github.com/robrix/semilattices.git
+[submodule "vendor/higher-order-effects"]
+	path = vendor/higher-order-effects
+	url = https://github.com/robrix/higher-order-effects.git

.licenses/semantic/cabal/higher-order-effects.txt

@@ -0,0 +1,38 @@
+---
+type: cabal
+name: higher-order-effects
+version: 0.1.0.0
+summary: Semilattices
+homepage: https://github.com/robrix/higher-order-effects
+license: bsd-3-clause
+---
+Copyright (c) 2018, Rob Rix
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Rob Rix nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

semantic.cabal

@@ -230,7 +230,6 @@ library
                      , deepseq
                      , directory
                      , directory-tree
-                     , effects
                      , fastsum
                      , filepath
                      , free
@@ -240,6 +239,7 @@ library
                      , Glob
                      , hashable
                      , haskeline
+                     , higher-order-effects
                      , hscolour
                      , http-client
                      , http-client-tls
@@ -359,13 +359,13 @@ test-suite test
                      , bifunctors
                      , bytestring
                      , containers
-                     , effects
                      , fastsum
                      , filepath
                      , free
                      , Glob
                      , hashable
                      , haskell-tree-sitter
+                     , higher-order-effects
                      , hspec >= 2.4.1
                      , hspec-core
                      , hspec-expectations-pretty-diff
@@ -413,10 +413,10 @@ test-suite parse-examples
   build-depends:       base
                      , bytestring
                      , directory
-                     , effects
                      , fastsum
                      , filepath
                      , Glob
+                     , higher-order-effects
                      , hspec >= 2.4.1
                      , hspec-core
                      , hspec-expectations-pretty-diff

src/Analysis/Abstract/Caching/FlowInsensitive.hs

@@ -14,58 +14,59 @@ import Data.Map.Monoidal as Monoidal
 import Prologue
 
 -- | Look up the set of values for a given configuration in the in-cache.
-consultOracle :: (Member (Reader (Cache term address)) effects, Ord address, Ord term)
+consultOracle :: (Member (Reader (Cache term address)) sig, Carrier sig m, Ord address, Ord term)
               => Configuration term address
-              -> Evaluator term address value effects (Set (ValueRef address))
-consultOracle configuration = fromMaybe mempty . cacheLookup configuration <$> ask
+              -> Evaluator term address value m (Set (ValueRef address))
+consultOracle configuration = asks (fromMaybe mempty . cacheLookup configuration)
 
 -- | Run an action with the given in-cache.
-withOracle :: Member (Reader (Cache term address)) effects
+withOracle :: (Member (Reader (Cache term address)) sig, Carrier sig m)
            => Cache term address
-           -> Evaluator term address value effects a
-           -> Evaluator term address value effects a
+           -> Evaluator term address value m a
+           -> Evaluator term address value m a
 withOracle cache = local (const cache)
 
 
 -- | Look up the set of values for a given configuration in the out-cache.
-lookupCache :: (Member (State (Cache term address)) effects, Ord address, Ord term)
+lookupCache :: (Member (State (Cache term address)) sig, Carrier sig m, Ord address, Ord term)
             => Configuration term address
-            -> Evaluator term address value effects (Maybe (Set (ValueRef address)))
+            -> Evaluator term address value m (Maybe (Set (ValueRef address)))
 lookupCache configuration = cacheLookup configuration <$> get
 
 -- | Run an action, caching its result and 'Heap' under the given configuration.
-cachingConfiguration :: (Member (State (Cache term address)) effects, Ord address, Ord term)
+cachingConfiguration :: (Member (State (Cache term address)) sig, Carrier sig m, Ord address, Ord term)
                      => Configuration term address
                      -> Set (ValueRef address)
-                     -> Evaluator term address value effects (ValueRef address)
-                     -> Evaluator term address value effects (ValueRef address)
+                     -> 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)) effects
+putCache :: (Member (State (Cache term address)) sig, Carrier sig m)
          => Cache term address
-         -> Evaluator term address value effects ()
+         -> Evaluator term address value m ()
 putCache = put
 
 -- | Run an action starting from an empty out-cache, and return the out-cache afterwards.
-isolateCache :: (Member (State (Cache term address)) effects, Member (State (Heap address value)) effects)
-             => Evaluator term address value effects a
-             -> Evaluator term address value effects (Cache term address, Heap address value)
+isolateCache :: (Member (State (Cache term address)) sig, Member (State (Heap address value)) sig, Carrier sig m)
+             => Evaluator term address value m a
+             -> Evaluator term address value m (Cache term address, Heap address value)
 isolateCache action = putCache lowerBound *> action *> ((,) <$> get <*> get)
 
 
 -- | Analyze a term using the in-cache as an oracle & storing the results of the analysis in the out-cache.
-cachingTerms :: ( Member (Env address) effects
-                , Member NonDet effects
-                , Member (Reader (Cache term address)) effects
-                , Member (Reader (Live address)) effects
-                , Member (State (Cache term address)) effects
+cachingTerms :: ( Member (Env address) sig
+                , Member NonDet sig
+                , Member (Reader (Cache term address)) sig
+                , Member (Reader (Live address)) sig
+                , Member (State (Cache term address)) sig
+                , Carrier sig m
                 , Ord address
                 , Ord term
                 )
-             => Open (Open (term -> Evaluator term address value effects (ValueRef address)))
+             => Open (Open (term -> Evaluator term address value m (ValueRef address)))
 cachingTerms recur0 recur term = do
   c <- getConfiguration term
   cached <- lookupCache c
@@ -75,23 +76,23 @@ cachingTerms recur0 recur term = do
       values <- consultOracle c
       cachingConfiguration c values (recur0 recur term)
 
-convergingModules :: ( AbstractValue term address value effects
-                     , Effects effects
+convergingModules :: ( AbstractValue term address value m
                      , Eq value
-                     , Member (Env address) effects
-                     , Member Fresh effects
-                     , Member NonDet effects
-                     , Member (Reader (Cache term address)) effects
-                     , Member (Reader (Live address)) effects
-                     , Member (Reader ModuleInfo) effects
-                     , Member (Reader Span) effects
-                     , Member (Resumable (BaseError (EnvironmentError address))) effects
-                     , Member (State (Cache term address)) effects
-                     , Member (State (Heap address value)) effects
+                     , Member (Env address) sig
+                     , Member Fresh sig
+                     , Member NonDet sig
+                     , Member (Reader (Cache term address)) sig
+                     , Member (Reader (Live address)) sig
+                     , Member (Reader ModuleInfo) sig
+                     , Member (Reader Span) sig
+                     , Member (Resumable (BaseError (EnvironmentError address))) sig
+                     , Member (State (Cache term address)) sig
+                     , Member (State (Heap address value)) sig
                      , Ord address
                      , Ord term
+                     , Carrier sig m
                      )
-                  => Open (Module term -> Evaluator term address value effects address)
+                  => Open (Module term -> Evaluator term address value m address)
 convergingModules recur m = do
   c <- getConfiguration (moduleBody m)
   heap <- getHeap
@@ -99,13 +100,14 @@ convergingModules recur m = do
   (cache, _) <- converge (lowerBound, heap) (\ (prevCache, _) -> isolateCache $ do
     putEvalContext (configurationContext c)
     -- We need to reset fresh generation so that this invocation converges.
-    resetFresh 0 $
+    resetFresh $
     -- This is subtle: though the calling context supports nondeterminism, we want
     -- to corral all the nondeterminism that happens in this @eval@ invocation, so
     -- that it doesn't "leak" to the calling context and diverge (otherwise this
     -- would never complete). We don’t need to use the values, so we 'gather' the
     -- nondeterministic values into @()@.
-      withOracle prevCache (gatherM (const ()) (recur m)))
+    -- FIXME: do we actually need to gather here after all??
+      withOracle prevCache (recur m))
   address =<< maybe empty scatter (cacheLookup c cache)
 
 -- | Iterate a monadic action starting from some initial seed until the results converge.
@@ -124,21 +126,68 @@ converge seed f = loop seed
             loop x'
 
 -- | Nondeterministically write each of a collection of stores & return their associated results.
-scatter :: (Foldable t, Member NonDet effects) => t (ValueRef address) -> Evaluator term address value effects (ValueRef address)
+scatter :: (Foldable t, Member NonDet sig, Carrier sig m) => t (ValueRef address) -> Evaluator term address value m (ValueRef address)
 scatter = foldMapA pure
 
 -- | Get the current 'Configuration' with a passed-in term.
-getConfiguration :: (Member (Reader (Live address)) effects, Member (Env address) effects)
+getConfiguration :: (Member (Reader (Live address)) sig, Member (Env address) sig, Carrier sig m)
                  => term
-                 -> Evaluator term address value effects (Configuration term address)
+                 -> Evaluator term address value m (Configuration term address)
 getConfiguration term = Configuration term <$> askRoots <*> getEvalContext
 
 
-caching :: Effects effects => Evaluator term address value (NonDet ': Reader (Cache term address) ': State (Cache term address) ': effects) a -> Evaluator term address value effects (Cache term address, [a])
+caching :: (Carrier sig m, Effect sig)
+        => Evaluator term address value (AltC B (Eff
+                                        (ReaderC (Cache term address) (Eff
+                                        (StateC (Cache term address) (Eff
+                                        m)))))) a
+        -> Evaluator term address value m (Cache term address, [a])
 caching
-  = runState lowerBound
-  . runReader lowerBound
-  . runNonDet
+  = raiseHandler (runState  lowerBound)
+  . raiseHandler (runReader lowerBound)
+  . fmap toList
+  . raiseHandler runNonDet
+
+data B a = E | L a | B (B a) (B a)
+  deriving (Functor)
+
+instance Foldable B where
+  toList = flip go []
+    where go E       rest = rest
+          go (L a)   rest = a : rest
+          go (B a b) rest = go a (go b rest)
+
+  foldMap f = go
+    where go E       = mempty
+          go (L a)   = f a
+          go (B a b) = go a <> go b
+
+  null E = True
+  null _ = False
+
+instance Traversable B where
+  traverse f = go
+    where go E       = pure E
+          go (L a)   = L <$> f a
+          go (B a b) = B <$> go a <*> go b
+
+instance Applicative B where
+  pure = L
+  E     <*> _ = E
+  L f   <*> a = fmap f a
+  B l r <*> a = B (l <*> a) (r <*> a)
+
+instance Alternative B where
+  empty = E
+  E <|> b = b
+  a <|> E = a
+  a <|> b = B a b
+
+instance Monad B where
+  return = pure
+  E     >>= _ = E
+  L a   >>= f = f a
+  B l r >>= f = B (l >>= f) (r >>= f)
 
 
 -- | A map of 'Configuration's to 'Set's of resulting values & 'Heap's.

src/Analysis/Abstract/Caching/FlowSensitive.hs

@@ -14,58 +14,59 @@ import Data.Map.Monoidal as Monoidal
 import Prologue
 
 -- | Look up the set of values for a given configuration in the in-cache.
-consultOracle :: (Cacheable term address value, Member (Reader (Cache term address value)) effects)
+consultOracle :: (Cacheable term address value, Member (Reader (Cache term address value)) sig, Carrier sig m)
               => Configuration term address value
-              -> Evaluator term address value effects (Set (Cached address value))
+              -> Evaluator term address value m (Set (Cached address value))
 consultOracle configuration = fromMaybe mempty . cacheLookup configuration <$> ask
 
 -- | Run an action with the given in-cache.
-withOracle :: Member (Reader (Cache term address value)) effects
+withOracle :: (Member (Reader (Cache term address value)) sig, Carrier sig m)
            => Cache term address value
-           -> Evaluator term address value effects a
-           -> Evaluator term address value effects a
+           -> Evaluator term address value m a
+           -> Evaluator term address value m a
 withOracle cache = local (const cache)
 
 
 -- | Look up the set of values for a given configuration in the out-cache.
-lookupCache :: (Cacheable term address value, Member (State (Cache term address value)) effects)
+lookupCache :: (Cacheable term address value, Member (State (Cache term address value)) sig, Carrier sig m)
             => Configuration term address value
-            -> Evaluator term address value effects (Maybe (Set (Cached address value)))
+            -> Evaluator term address value m (Maybe (Set (Cached address value)))
 lookupCache configuration = cacheLookup configuration <$> get
 
 -- | Run an action, caching its result and 'Heap' under the given configuration.
-cachingConfiguration :: (Cacheable term address value, Member (State (Cache term address value)) effects, Member (State (Heap address value)) effects)
+cachingConfiguration :: (Cacheable term address value, Member (State (Cache term address value)) sig, Member (State (Heap address value)) sig, Carrier sig m)
                      => Configuration term address value
                      -> Set (Cached address value)
-                     -> Evaluator term address value effects (ValueRef address)
-                     -> Evaluator term address value effects (ValueRef address)
+                     -> 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)) effects
+putCache :: (Member (State (Cache term address value)) sig, Carrier sig m)
          => Cache term address value
-         -> Evaluator term address value effects ()
+         -> Evaluator term address value m ()
 putCache = put
 
 -- | Run an action starting from an empty out-cache, and return the out-cache afterwards.
-isolateCache :: Member (State (Cache term address value)) effects
-             => Evaluator term address value effects a
-             -> Evaluator term address value effects (Cache term address value)
+isolateCache :: (Member (State (Cache term address value)) sig, Carrier sig m)
+             => Evaluator term address value m a
+             -> Evaluator term address value m (Cache term address value)
 isolateCache action = putCache lowerBound *> action *> get
 
 
 -- | Analyze a term using the in-cache as an oracle & storing the results of the analysis in the out-cache.
 cachingTerms :: ( Cacheable term address value
-                , Member NonDet effects
-                , Member (Reader (Cache term address value)) effects
-                , Member (Reader (Live address)) effects
-                , Member (State (Cache term address value)) effects
-                , Member (Env address) effects
-                , Member (State (Heap address value)) effects
+                , Member NonDet sig
+                , Member (Reader (Cache term address value)) sig
+                , Member (Reader (Live address)) sig
+                , Member (State (Cache term address value)) sig
+                , Member (Env address) sig
+                , Member (State (Heap address value)) sig
+                , Carrier sig m
                 )
-             => Open (Open (term -> Evaluator term address value effects (ValueRef address)))
+             => Open (Open (term -> Evaluator term address value m (ValueRef address)))
 cachingTerms recur0 recur term = do
   c <- getConfiguration term
   cached <- lookupCache c
@@ -75,21 +76,21 @@ cachingTerms recur0 recur term = do
       pairs <- consultOracle c
       cachingConfiguration c pairs (recur0 recur term)
 
-convergingModules :: ( AbstractValue term address value effects
+convergingModules :: ( AbstractValue term address value m
                      , Cacheable term address value
-                     , Member Fresh effects
-                     , Member NonDet effects
-                     , Member (Reader (Cache term address value)) effects
-                     , Member (Reader (Live address)) effects
-                     , Member (Reader ModuleInfo) effects
-                     , Member (Reader Span) effects
-                     , Member (Resumable (BaseError (EnvironmentError address))) effects
-                     , Member (State (Cache term address value)) effects
-                     , Member (Env address) effects
-                     , Member (State (Heap address value)) effects
-                     , Effects effects
+                     , Member Fresh sig
+                     , Member NonDet sig
+                     , Member (Reader (Cache term address value)) sig
+                     , Member (Reader (Live address)) sig
+                     , Member (Reader ModuleInfo) sig
+                     , Member (Reader Span) sig
+                     , Member (Resumable (BaseError (EnvironmentError address))) sig
+                     , Member (State (Cache term address value)) sig
+                     , Member (Env address) sig
+                     , Member (State (Heap address value)) sig
+                     , Carrier sig m
                      )
-                  => Open (Module term -> Evaluator term address value effects address)
+                  => Open (Module term -> Evaluator term address value m address)
 convergingModules recur m = do
   c <- getConfiguration (moduleBody m)
   -- Convergence here is predicated upon an Eq instance, not α-equivalence
@@ -97,13 +98,14 @@ convergingModules recur m = do
     putHeap        (configurationHeap    c)
     putEvalContext (configurationContext c)
     -- We need to reset fresh generation so that this invocation converges.
-    resetFresh 0 $
+    resetFresh $
     -- This is subtle: though the calling context supports nondeterminism, we want
     -- to corral all the nondeterminism that happens in this @eval@ invocation, so
     -- that it doesn't "leak" to the calling context and diverge (otherwise this
     -- would never complete). We don’t need to use the values, so we 'gather' the
     -- nondeterministic values into @()@.
-      withOracle prevCache (gatherM (const ()) (recur m)))
+    -- FIXME: do we actually need to gather here?
+      withOracle prevCache (recur m))
   address =<< maybe empty scatter (cacheLookup c cache)
 
 -- | Iterate a monadic action starting from some initial seed until the results converge.
@@ -122,21 +124,26 @@ converge seed f = loop seed
             loop x'
 
 -- | Nondeterministically write each of a collection of stores & return their associated results.
-scatter :: (Foldable t, Member NonDet effects, Member (State (Heap address value)) effects) => t (Cached address value) -> Evaluator term address value effects (ValueRef address)
+scatter :: (Foldable t, Member NonDet sig, Member (State (Heap address value)) sig, Carrier sig m) => t (Cached address value) -> Evaluator term address value m (ValueRef address)
 scatter = foldMapA (\ (Cached value heap') -> putHeap heap' $> value)
 
 -- | Get the current 'Configuration' with a passed-in term.
-getConfiguration :: (Member (Reader (Live address)) effects, Member (Env address) effects, Member (State (Heap address value)) effects)
+getConfiguration :: (Member (Reader (Live address)) sig, Member (Env address) sig, Member (State (Heap address value)) sig, Carrier sig m)
                  => term
-                 -> Evaluator term address value effects (Configuration term address value)
+                 -> Evaluator term address value m (Configuration term address value)
 getConfiguration term = Configuration term <$> askRoots <*> getEvalContext <*> getHeap
 
 
-caching :: Effects effects => Evaluator term address value (NonDet ': Reader (Cache term address value) ': State (Cache term address value) ': effects) a -> Evaluator term address value effects (Cache term address value, [a])
+caching :: (Carrier sig m, Effect sig)
+        => Evaluator term address value (AltC [] (Eff
+                                        (ReaderC (Cache term address value) (Eff
+                                        (StateC (Cache term address value) (Eff
+                                        m)))))) a
+        -> Evaluator term address value m (Cache term address value, [a])
 caching
-  = runState lowerBound
-  . runReader lowerBound
-  . runNonDet
+  = raiseHandler (runState  lowerBound)
+  . raiseHandler (runReader lowerBound)
+  . raiseHandler runNonDet
 
 
 -- | A map of 'Configuration's to 'Set's of resulting values & 'Heap's.

src/Analysis/Abstract/Collecting.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE TypeOperators #-}
 module Analysis.Abstract.Collecting
 ( providingLiveSet
 ) where
@@ -6,5 +5,5 @@ module Analysis.Abstract.Collecting
 import Control.Abstract
 import Prologue
 
-providingLiveSet :: PureEffects effects => Evaluator term address value (Reader (Live address) ': effects) a -> Evaluator term address value effects a
-providingLiveSet = runReader lowerBound
+providingLiveSet :: Carrier sig m => Evaluator term address value (ReaderC (Live address) (Eff m)) a -> Evaluator term address value m a
+providingLiveSet = raiseHandler (runReader lowerBound)

src/Analysis/Abstract/Dead.hs

@@ -19,31 +19,33 @@ newtype Dead term = Dead { unDead :: Set term }
 deriving instance Ord term => Reducer term (Dead term)
 
 -- | Update the current 'Dead' set.
-killAll :: Member (State (Dead term)) effects => Dead term -> Evaluator term address value effects ()
+killAll :: (Member (State (Dead term)) sig, Carrier sig m) => Dead term -> Evaluator term address value m ()
 killAll = put
 
 -- | Revive a single term, removing it from the current 'Dead' set.
-revive :: (Member (State (Dead term)) effects, Ord term) => term -> Evaluator term address value effects ()
-revive t = modify' (Dead . delete t . unDead)
+revive :: (Member (State (Dead term)) sig, Carrier sig m, Ord term) => term -> Evaluator term address value m ()
+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
 subterms term = term `cons` para (foldMap (uncurry cons)) term
 
 
-revivingTerms :: ( Member (State (Dead term)) effects
+revivingTerms :: ( Member (State (Dead term)) sig
                  , Ord term
+                 , Carrier sig m
                  )
-              => Open (Open (term -> Evaluator term address value effects a))
+              => Open (Open (term -> Evaluator term address value m a))
 revivingTerms recur0 recur term = revive term *> recur0 recur term
 
 killingModules :: ( Foldable (Base term)
-                  , Member (State (Dead term)) effects
+                  , Member (State (Dead term)) sig
                   , Ord term
                   , Recursive term
+                  , Carrier sig m
                   )
-               => Open (Module term -> Evaluator term address value effects a)
+               => Open (Module term -> Evaluator term address value m a)
 killingModules recur m = killAll (subterms (moduleBody m)) *> recur m
 
-providingDeadSet :: Effects effects => Evaluator term address value (State (Dead term) ': effects) a -> Evaluator term address value effects (Dead term, a)
-providingDeadSet = runState lowerBound
+providingDeadSet :: (Carrier sig m, Effect sig) => Evaluator term address value (StateC (Dead term) (Evaluator term address value m)) a -> Evaluator term address value m (Dead term, a)
+providingDeadSet = runState lowerBound . runEvaluator

src/Analysis/Abstract/Graph.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE ScopedTypeVariables, TypeFamilies, TypeOperators #-}
+{-# LANGUAGE LambdaCase, RankNTypes, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
 module Analysis.Abstract.Graph
 ( Graph(..)
 , ControlFlowVertex(..)
@@ -18,6 +18,7 @@ module Analysis.Abstract.Graph
 
 import           Algebra.Graph.Export.Dot hiding (vertexName)
 import           Control.Abstract hiding (Function(..))
+import           Control.Effect.Eavesdrop
 import           Data.Abstract.Address.Hole
 import           Data.Abstract.Address.Located
 import           Data.Abstract.BaseError
@@ -62,22 +63,23 @@ style = (defaultStyle (T.encodeUtf8Builder . vertexIdentifier))
 
 
 -- | Add vertices to the graph for evaluated identifiers.
-graphingTerms :: ( Member (Reader ModuleInfo) effects
-                 , Member (Reader Span) effects
-                 , Member (Env (Hole context (Located address))) effects
-                 , Member (State (Graph ControlFlowVertex)) effects
-                 , Member (State (Map (Hole context (Located address)) ControlFlowVertex)) effects
-                 , Member (Resumable (BaseError (EnvironmentError (Hole context (Located address))))) effects
-                 , AbstractValue term (Hole context (Located address)) value effects
-                 , Member (Reader ControlFlowVertex) effects
+graphingTerms :: ( Member (Reader ModuleInfo) sig
+                 , Member (Reader Span) sig
+                 , Member (Env (Hole context (Located address))) sig
+                 , Member (State (Graph ControlFlowVertex)) sig
+                 , Member (State (Map (Hole context (Located address)) ControlFlowVertex)) sig
+                 , Member (Resumable (BaseError (EnvironmentError (Hole context (Located address))))) sig
+                 , AbstractValue term (Hole context (Located address)) value m
+                 , Member (Reader ControlFlowVertex) sig
                  , VertexDeclaration syntax
                  , Declarations1 syntax
                  , Ord address
                  , Ord context
                  , Foldable syntax
                  , term ~ Term syntax Location
+                 , Carrier sig m
                  )
-              => Open (Open (term -> Evaluator term (Hole context (Located address)) value effects (ValueRef (Hole context (Located address)))))
+              => Open (Open (term -> Evaluator term (Hole context (Located address)) value m (ValueRef (Hole context (Located address)))))
 graphingTerms recur0 recur term@(Term (In a syntax)) = do
   definedInModule <- currentModule
   case toVertex a definedInModule syntax of
@@ -100,91 +102,102 @@ 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.
-graphingPackages :: ( Member (Reader PackageInfo) effects
-                    , Member (State (Graph ControlFlowVertex)) effects
-                    , Member (Reader ControlFlowVertex) effects
+graphingPackages :: ( Member (Reader PackageInfo) sig
+                    , Member (State (Graph ControlFlowVertex)) sig
+                    , Member (Reader ControlFlowVertex) sig
+                    , Carrier sig m
+                    , Monad m
                     )
-                 => Open (Module term -> Evaluator term address value effects a)
+                 => Open (Module term -> m a)
 graphingPackages recur m =
   let v = moduleVertex (moduleInfo m) in packageInclusion v *> local (const v) (recur m)
 
 -- | Add vertices to the graph for imported modules.
-graphingModules :: forall term address value effects a
-                .  ( Member (Modules address) effects
-                   , Member (Reader ModuleInfo) effects
-                   , Member (State (Graph ControlFlowVertex)) effects
-                   , Member (Reader ControlFlowVertex) effects
-                   , PureEffects effects
+graphingModules :: forall term address value m sig a
+                .  ( Member (Eavesdrop (Modules address)) sig
+                   , Member (Reader ModuleInfo) sig
+                   , Member (State (Graph ControlFlowVertex)) sig
+                   , Member (Reader ControlFlowVertex) sig
+                   , Carrier sig m
                    )
-                => Open (Module term -> Evaluator term address value effects a)
+                => Open (Module term -> Evaluator term address value m a)
 graphingModules recur m = do
   let v = moduleVertex (moduleInfo m)
   appendGraph (vertex v)
   local (const v) $
-    eavesdrop @(Modules address) (\ m -> case m of
-      Load path -> includeModule path
-      Lookup path -> includeModule path
-      _ -> pure ())
-      (recur m)
+    eavesdrop @(Modules address) (recur m) $ \case
+      Load   path _ -> includeModule path
+      Lookup path _ -> includeModule path
+      _             -> pure ()
   where
     -- NB: path is null for Languages like Ruby that have module imports that require concrete value semantics.
     includeModule path = let path' = if Prologue.null path then "unknown, concrete semantics required" else path
       in moduleInclusion (moduleVertex (ModuleInfo path'))
 
+{-# ANN graphingModules ("HLint: ignore Use ." :: String) #-}
+
 -- | Add vertices to the graph for imported modules.
-graphingModuleInfo :: forall term address value effects a
-                   .  ( Member (Modules address) effects
-                      , Member (Reader ModuleInfo) effects
-                      , Member (State (Graph ModuleInfo)) effects
-                      , PureEffects effects
+graphingModuleInfo :: forall term address value m sig a
+                   .  ( Member (Eavesdrop (Modules address)) sig
+                      , Member (Reader ModuleInfo) sig
+                      , Member (State (Graph ModuleInfo)) sig
+                      , Carrier sig m
                       )
-                   => Open (Module term -> Evaluator term address value effects a)
+                   => Open (Module term -> Evaluator term address value m a)
 graphingModuleInfo recur m = do
   appendGraph (vertex (moduleInfo m))
-  eavesdrop @(Modules address) (\ eff -> case eff of
-    Load path -> currentModule >>= appendGraph . (`connect` vertex (ModuleInfo path)) . vertex
-    Lookup path -> currentModule >>= appendGraph . (`connect` vertex (ModuleInfo path)) . vertex
-    _ -> pure ())
-    (recur m)
+  eavesdrop @(Modules address) (recur m) $ \case
+    Load   path _ -> currentModule >>= appendGraph . (`connect` vertex (ModuleInfo path)) . vertex
+    Lookup path _ -> currentModule >>= appendGraph . (`connect` vertex (ModuleInfo path)) . vertex
+    _             -> pure ()
 
 -- | Add an edge from the current package to the passed vertex.
-packageInclusion :: ( Member (Reader PackageInfo) effects
-                    , Member (State (Graph ControlFlowVertex)) effects
+packageInclusion :: ( Member (Reader PackageInfo) sig
+                    , Member (State (Graph ControlFlowVertex)) sig
+                    , Carrier sig m
+                    , Monad m
                     )
                  => ControlFlowVertex
-                 -> Evaluator term address value effects ()
+                 -> m ()
 packageInclusion v = do
   p <- currentPackage
   appendGraph (vertex (packageVertex p) `connect` vertex v)
 
 -- | Add an edge from the current module to the passed vertex.
-moduleInclusion :: ( Member (Reader ModuleInfo) effects
-                   , Member (State (Graph ControlFlowVertex)) effects
+moduleInclusion :: ( Member (Reader ModuleInfo) sig
+                   , Member (State (Graph ControlFlowVertex)) sig
+                   , Carrier sig m
+                   , Monad m
                    )
                 => ControlFlowVertex
-                -> Evaluator term address value effects ()
+                -> m ()
 moduleInclusion v = do
   m <- currentModule
   appendGraph (vertex (moduleVertex m) `connect` vertex v)
 
 -- | Add an edge from the passed variable name to the context it originated within.
-variableDefinition :: ( Member (State (Graph ControlFlowVertex)) effects
-                      , Member (Reader ControlFlowVertex) effects
+variableDefinition :: ( Member (State (Graph ControlFlowVertex)) sig
+                      , Member (Reader ControlFlowVertex) sig
+                      , Carrier sig m
+                      , Monad m
                       )
                    => ControlFlowVertex
-                   -> Evaluator term (Hole context (Located address)) value effects ()
+                   -> m ()
 variableDefinition var = do
   context <- ask
-  appendGraph $ vertex context `connect` vertex var
+  appendGraph (vertex context `connect` vertex var)
 
-appendGraph :: Member (State (Graph v)) effects => Graph v -> Evaluator term address value effects ()
-appendGraph = modify' . (<>)
+appendGraph :: (Member (State (Graph v)) sig, Carrier sig m, Monad m) => Graph v -> m ()
+appendGraph = modify . (<>)
 
 
-graphing :: Effects effects
-         => Evaluator term (Hole context (Located address)) value (State (Map (Hole context (Located address)) ControlFlowVertex) ': State (Graph ControlFlowVertex) ': effects) result -> Evaluator term (Hole context (Located address)) value effects (Graph ControlFlowVertex, result)
-graphing = runState mempty . fmap snd . runState lowerBound
+graphing :: (Carrier sig m, Effect sig)
+         => Evaluator term address value (StateC (Map address ControlFlowVertex) (Eff
+                                         (StateC (Graph ControlFlowVertex) (Eff
+                                         m)))) result
+         -> Evaluator term address value m (Graph ControlFlowVertex, result)
+graphing = raiseHandler $ runState mempty . fmap snd . runState lowerBound

src/Analysis/Abstract/Tracing.hs

@@ -5,33 +5,34 @@ module Analysis.Abstract.Tracing
 ) where
 
 import Control.Abstract hiding (trace)
-import Control.Monad.Effect.Writer
+import Control.Effect.Writer
 import Data.Abstract.Environment
 import Data.Semigroup.Reducer as Reducer
 
 -- | Trace analysis.
 --
 --   Instantiating @trace@ to @[]@ yields a linear trace analysis, while @Set@ yields a reachable state analysis.
-tracingTerms :: ( Member (Env address) effects
-                , Member (State (Heap address value)) effects
-                , Member (Writer (trace (Configuration term address value))) effects
+tracingTerms :: ( Member (Env address) sig
+                , Member (State (Heap address value)) sig
+                , Member (Writer (trace (Configuration term address value))) sig
+                , Carrier sig m
                 , Reducer (Configuration term address value) (trace (Configuration term address value))
                 )
              => trace (Configuration term address value)
-             -> Open (Open (term -> Evaluator term address value effects a))
+             -> Open (Open (term -> Evaluator term address value m a))
 tracingTerms proxy recur0 recur term = getConfiguration term >>= trace . (`asTypeOf` proxy) . Reducer.unit >> recur0 recur term
 
-trace :: Member (Writer (trace (Configuration term address value))) effects => trace (Configuration term address value) -> Evaluator term address value effects ()
+trace :: (Member (Writer (trace (Configuration term address value))) sig, Carrier sig m) => trace (Configuration term address value) -> Evaluator term address value m ()
 trace = tell
 
-tracing :: (Monoid (trace (Configuration term address value)), Effects effects) => Evaluator term address value (Writer (trace (Configuration term address value)) ': effects) a -> Evaluator term address value effects (trace (Configuration term address value), a)
-tracing = runWriter
+tracing :: (Monoid (trace (Configuration term address value)), Carrier sig m, Effect sig) => Evaluator term address value (WriterC (trace (Configuration term address value)) (Evaluator term address value m)) a -> Evaluator term address value m (trace (Configuration term address value), a)
+tracing = runWriter . runEvaluator
 
 
 -- | Get the current 'Configuration' with a passed-in term.
-getConfiguration :: (Member (Env address) effects, Member (State (Heap address value)) effects)
+getConfiguration :: (Member (Env address) sig, Member (State (Heap address value)) sig, Carrier sig m)
                  => term
-                 -> Evaluator term address value effects (Configuration term address value)
+                 -> Evaluator term address value m (Configuration term address value)
 getConfiguration term = Configuration term <$> getEvalContext <*> getHeap
 
 -- | A single point in a program’s execution.

src/Analysis/ConstructorName.hs

@@ -4,6 +4,7 @@ module Analysis.ConstructorName
 ) where
 
 import Data.Sum
+import GHC.Generics
 import Prologue
 
 -- | A typeclass to retrieve the name of the data constructor for a value.

src/Assigning/Assignment.hs

@@ -97,6 +97,7 @@ module Assigning.Assignment
 import Prologue
 import Prelude hiding (fail)
 import qualified Assigning.Assignment.Table as Table
+import Control.Monad.Except (MonadError (..))
 import Control.Monad.Free.Freer
 import Data.AST
 import Data.Error

src/Control/Abstract/Context.hs

@@ -12,9 +12,9 @@ module Control.Abstract.Context
 , withCurrentCallStack
 ) where
 
-import Control.Monad.Effect
-import Control.Monad.Effect.Reader
-import Control.Monad.Effect.State
+import Control.Effect
+import Control.Effect.Reader
+import Control.Effect.State
 import Data.Abstract.Module
 import Data.Abstract.Package
 import Data.Span
@@ -22,38 +22,38 @@ import GHC.Stack
 import Prologue
 
 -- | Get the currently evaluating 'ModuleInfo'.
-currentModule :: (Effectful m, Member (Reader ModuleInfo) effects) => m effects ModuleInfo
+currentModule :: (Member (Reader ModuleInfo) sig, Carrier sig m) => m ModuleInfo
 currentModule = ask
 
 -- | Run an action with a locally-replaced 'ModuleInfo'.
-withCurrentModule :: (Effectful m, Member (Reader ModuleInfo) effects) => ModuleInfo -> m effects a -> m effects a
+withCurrentModule :: (Member (Reader ModuleInfo) sig, Carrier sig m) => ModuleInfo -> m a -> m a
 withCurrentModule = local . const
 
 -- | Get the currently evaluating 'PackageInfo'.
-currentPackage :: (Effectful m, Member (Reader PackageInfo) effects) => m effects PackageInfo
+currentPackage :: (Member (Reader PackageInfo) sig, Carrier sig m) => m PackageInfo
 currentPackage = ask
 
 -- | Run an action with a locally-replaced 'PackageInfo'.
-withCurrentPackage :: (Effectful m, Member (Reader PackageInfo) effects) => PackageInfo -> m effects a -> m effects a
+withCurrentPackage :: (Member (Reader PackageInfo) sig, Carrier sig m) => PackageInfo -> m a -> m a
 withCurrentPackage = local . const
 
 -- | Get the 'Span' of the currently-evaluating term (if any).
-currentSpan :: (Effectful m, Member (Reader Span) effects) => m effects Span
+currentSpan :: (Member (Reader Span) sig, Carrier sig m) => m Span
 currentSpan = ask
 
 -- | Run an action with a locally-replaced 'Span'.
-withCurrentSpan :: (Effectful m, Member (Reader Span) effects) => Span -> m effects a -> m effects a
+withCurrentSpan :: (Member (Reader Span) sig, Carrier sig m) => Span -> m a -> m a
 withCurrentSpan = local . const
 
-modifyChildSpan :: (Effectful m, Member (State Span) effects) => Span -> m effects a -> m effects a
-modifyChildSpan span m = raiseEff (lowerEff m >>= (\a -> modify' (const span) >> pure a))
+modifyChildSpan :: (Member (State Span) sig, Carrier sig m, Monad m) => Span -> m a -> m a
+modifyChildSpan span m = m <* put span
 
 -- | Run an action with locally-replaced 'ModuleInfo' & 'Span' derived from the passed 'SrcLoc'.
-withCurrentSrcLoc :: (Effectful m, Member (Reader ModuleInfo) effects, Member (Reader Span) effects) => SrcLoc -> m effects a -> m effects a
+withCurrentSrcLoc :: (Member (Reader ModuleInfo) sig, Member (Reader Span) sig, Carrier sig m) => SrcLoc -> m a -> m a
 withCurrentSrcLoc loc = withCurrentModule (moduleInfoFromSrcLoc loc) . withCurrentSpan (spanFromSrcLoc loc)
 
 -- | Run an action with locally replaced 'ModuleInfo' & 'Span' derived from the Haskell call stack.
 --
 --   This is suitable for contextualizing builtins & other functionality intended for use from client code but defined in Haskell source.
-withCurrentCallStack :: (Effectful m, Member (Reader ModuleInfo) effects, Member (Reader Span) effects) => CallStack -> m effects a -> m effects a
+withCurrentCallStack :: (Member (Reader ModuleInfo) sig, Member (Reader Span) sig, Carrier sig m) => CallStack -> m a -> m a
 withCurrentCallStack = maybe id (withCurrentSrcLoc . snd) . listToMaybe . getCallStack

src/Control/Abstract/Environment.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE GADTs, LambdaCase, RankNTypes, ScopedTypeVariables, TypeOperators #-}
+{-# LANGUAGE GADTs, LambdaCase, RankNTypes, ScopedTypeVariables, TypeOperators, UndecidableInstances #-}
 module Control.Abstract.Environment
 ( Environment
 , Exports
@@ -19,6 +19,7 @@ module Control.Abstract.Environment
 -- * Effects
 , Env(..)
 , runEnv
+, EnvC(..)
 , freeVariableError
 , runEnvironmentError
 , runEnvironmentErrorWith
@@ -26,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
@@ -36,22 +39,22 @@ import Data.Span
 import Prologue
 
 -- | Retrieve the current execution context
-getEvalContext :: Member (Env address) effects => Evaluator term address value effects (EvalContext address)
-getEvalContext = send GetCtx
+getEvalContext :: (Member (Env address) sig, Carrier sig m) => Evaluator term address value m (EvalContext address)
+getEvalContext = send (GetCtx ret)
 
 -- | Retrieve the current environment
-getEnv :: Member (Env address) effects
-       => Evaluator term address value effects (Environment address)
+getEnv :: (Member (Env address) sig, Carrier sig m)
+       => Evaluator term address value m (Environment address)
 getEnv = ctxEnvironment <$> getEvalContext
 
 -- | Replace the execution context. This is only for use in Analysis.Abstract.Caching.
-putEvalContext :: Member (Env address) effects => EvalContext address -> Evaluator term address value effects ()
-putEvalContext = send . PutCtx
+putEvalContext :: (Member (Env address) sig, Carrier sig m) => EvalContext address -> Evaluator term address value m ()
+putEvalContext context = send (PutCtx context (ret ()))
 
-withEvalContext :: Member (Env address) effects
+withEvalContext :: (Member (Env address) sig, Carrier sig m)
                 => EvalContext address
-                -> Evaluator term address value effects a
-                -> Evaluator term address value effects a
+                -> Evaluator term address value m a
+                -> Evaluator term address value m a
 withEvalContext ctx comp = do
   oldCtx <- getEvalContext
   putEvalContext ctx
@@ -60,49 +63,51 @@ withEvalContext ctx comp = do
   pure value
 
 -- | Add an export to the global export state.
-export :: Member (Env address) effects => Name -> Name -> Maybe address -> Evaluator term address value effects ()
-export name alias addr = send (Export name alias addr)
+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 (ret ()))
 
 
 -- | Look a 'Name' up in the current environment, trying the default environment if no value is found.
-lookupEnv :: Member (Env address) effects => Name -> Evaluator term address value effects (Maybe address)
-lookupEnv name = send (Lookup name)
+lookupEnv :: (Member (Env address) sig, Carrier sig m) => Name -> Evaluator term address value m (Maybe address)
+lookupEnv name = send (Lookup name ret)
 
 -- | Bind a 'Name' to an address in the current scope.
-bind :: Member (Env address) effects => Name -> address -> Evaluator term address value effects ()
-bind name addr = send (Bind name addr)
+bind :: (Member (Env address) sig, Carrier sig m) => Name -> address -> Evaluator term address value m ()
+bind name addr = send (Bind name addr (ret ()))
 
 -- | Bind all of the names from an 'Environment' in the current scope.
-bindAll :: Member (Env address) effects => Bindings address -> Evaluator term address value effects ()
+bindAll :: (Member (Env address) sig, Carrier sig m) => Bindings address -> Evaluator term address value m ()
 bindAll = foldr ((>>) . uncurry bind) (pure ()) . Env.pairs
 
 -- | Run an action in a new local scope.
-locally :: forall term address value effects a . Member (Env address) effects => Evaluator term address value effects a -> Evaluator term address value effects a
-locally = send . Locally @_ @_ @address . lowerEff
+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 ret)
 
-close :: Member (Env address) effects => Set Name -> Evaluator term address value effects (Environment address)
-close = send . Close
+close :: (Member (Env address) sig, Carrier sig m) => Set Name -> Evaluator term address value m (Environment address)
+close fvs = send (Close fvs ret)
 
-self :: Member (Env address) effects => Evaluator term address value effects (Maybe address)
+self :: (Member (Env address) sig, Carrier sig m) => Evaluator term address value m (Maybe address)
 self = ctxSelf <$> getEvalContext
 
 -- | Look up or allocate an address for a 'Name'.
-lookupOrAlloc :: ( Member (Allocator address) effects
-                 , Member (Env address) effects
+lookupOrAlloc :: ( Member (Allocator address) sig
+                 , Member (Env address) sig
+                 , Carrier sig m
                  )
               => Name
-              -> Evaluator term address value effects address
+              -> Evaluator term address value m address
 lookupOrAlloc name = lookupEnv name >>= maybeM (alloc name)
 
-letrec :: ( Member (Allocator address) effects
-          , Member (Deref value) effects
-          , Member (Env address) effects
-          , Member (State (Heap address value)) effects
+letrec :: ( Member (Allocator address) sig
+          , Member (Deref value) sig
+          , Member (Env address) sig
+          , Member (State (Heap address value)) sig
           , Ord address
+          , Carrier sig m
           )
        => Name
-       -> Evaluator term address value effects value
-       -> Evaluator term address value effects (value, address)
+       -> Evaluator term address value m value
+       -> Evaluator term address value m (value, address)
 letrec name body = do
   addr <- lookupOrAlloc name
   v <- locally (bind name addr *> body)
@@ -110,55 +115,67 @@ letrec name body = do
   pure (v, addr)
 
 -- Lookup/alloc a name passing the address to a body evaluated in a new local environment.
-letrec' :: ( Member (Allocator address) effects
-           , Member (Env address) effects
+letrec' :: ( Member (Allocator address) sig
+           , Member (Env address) sig
+           , Carrier sig m
            )
         => Name
-        -> (address -> Evaluator term address value effects a)
-        -> Evaluator term address value effects a
+        -> (address -> Evaluator term address value m a)
+        -> Evaluator term address value m a
 letrec' name body = do
   addr <- lookupOrAlloc name
   v <- locally (body addr)
   v <$ bind name addr
 
 -- | Look up and dereference the given 'Name', throwing an exception for free variables.
-variable :: ( Member (Env address) effects
-            , Member (Reader ModuleInfo) effects
-            , Member (Reader Span) effects
-            , Member (Resumable (BaseError (EnvironmentError address))) effects
+variable :: ( Member (Env address) sig
+            , Member (Reader ModuleInfo) sig
+            , Member (Reader Span) sig
+            , Member (Resumable (BaseError (EnvironmentError address))) sig
+            , Carrier sig m
             )
          => Name
-         -> Evaluator term address value effects address
+         -> Evaluator term address value m address
 variable name = lookupEnv name >>= maybeM (freeVariableError name)
 
 -- Effects
 
-data Env address m return where
-  Lookup :: Name            -> Env address m (Maybe address)
-  Bind   :: Name -> address -> Env address m ()
-  Close  :: Set Name        -> Env address m (Environment address)
-  Locally :: m a            -> Env address m a
-  GetCtx ::                    Env address m (EvalContext address)
-  PutCtx :: EvalContext address -> Env address m ()
-  Export :: Name -> Name -> Maybe address -> Env address m ()
+data Env address m k
+  = Lookup Name (Maybe address -> k)
+  | Bind Name address k
+  | Close (Set Name) (Environment address -> k)
+  | forall a . Locally (m a) (a -> k)
+  | GetCtx (EvalContext address -> k)
+  | PutCtx (EvalContext address) k
+  | Export Name Name (Maybe address) k
+
+deriving instance Functor (Env address m)
+
+instance HFunctor (Env address) where
+  hmap _ (Lookup name k) = Lookup name k
+  hmap _ (Bind name addr k) = Bind name addr k
+  hmap _ (Close names k) = Close names k
+  hmap f (Locally m k) = Locally (f m) k
+  hmap _ (GetCtx k) = GetCtx k
+  hmap _ (PutCtx ctx k) = PutCtx ctx k
+  hmap _ (Export name alias addr k) = Export name alias addr k
 
-instance PureEffect (Env address)
 instance Effect (Env address) where
-  handleState c dist (Request (Lookup name) k) = Request (Lookup name) (dist . (<$ c) . k)
-  handleState c dist (Request (Bind name addr) k) = Request (Bind name addr) (dist . (<$ c) . k)
-  handleState c dist (Request (Close names) k) = Request (Close names) (dist . (<$ c) . k)
-  handleState c dist (Request (Locally action) k) = Request (Locally (dist (action <$ c))) (dist . fmap k)
-  handleState c dist (Request GetCtx k) = Request GetCtx (dist . (<$ c) . k)
-  handleState c dist (Request (PutCtx e) k) = Request (PutCtx e) (dist . (<$ c) . k)
-  handleState c dist (Request (Export name alias addr) k) = Request (Export name alias addr) (dist . (<$ c) . k)
+  handle state handler (Lookup name k) = Lookup name (handler . (<$ state) . k)
+  handle state handler (Bind name addr k) = Bind name addr (handler . (<$ state) $ k)
+  handle state handler (Close names k) = Close names (handler . (<$ state) . k)
+  handle state handler (Locally action k) = Locally (handler (action <$ state)) (handler . fmap k)
+  handle state handler (GetCtx k) = GetCtx (handler . (<$ state) . k)
+  handle state handler (PutCtx e k) = PutCtx e (handler . (<$ state) $ k)
+  handle state handler (Export name alias addr k) = Export name alias addr (handler . (<$ state) $ k)
 
 -- | Runs a computation in the context of an existing environment.
 --   New bindings created in the computation are returned.
-runEnv :: Effects effects
+runEnv :: (Carrier sig m, Effect sig)
        => EvalContext address
-       -> Evaluator term address value (Env address ': effects) a
-       -> Evaluator term address value effects (Bindings address, a)
-runEnv initial = fmap (filterEnv . fmap (first (Env.head . ctxEnvironment))) . runState lowerBound . runState initial . reinterpret2 handleEnv
+       -> Evaluator term address value (EnvC address (Eff m)) a
+       -> Evaluator term address value m (Bindings address, a)
+runEnv initial = raiseHandler $ fmap (filterEnv . fmap (first (Env.head . ctxEnvironment))) . runState lowerBound . runState initial . runEnvC . interpret
   where -- TODO: If the set of exports is empty because no exports have been
         -- defined, do we export all terms, or no terms? This behavior varies across
         -- languages. We need better semantics rather than doing it ad-hoc.
@@ -166,44 +183,49 @@ runEnv initial = fmap (filterEnv . fmap (first (Env.head . ctxEnvironment))) . r
           | Exports.null ports = (binds, a)
           | otherwise          = (Exports.toBindings ports <> Env.aliasBindings (Exports.aliases ports) binds, a)
 
-handleEnv :: forall term address value effects a . Effects effects
-          => Env address (Eff (Env address ': effects)) a
-          -> Evaluator term address value (State (EvalContext address) ': State (Exports address) ': effects) a
-handleEnv = \case
-  Lookup name -> Env.lookupEnv' name . ctxEnvironment <$> get
-  Bind name addr -> modify (\EvalContext{..} -> EvalContext ctxSelf (Env.insertEnv name addr ctxEnvironment))
-  Close names -> Env.intersect names . ctxEnvironment <$> get
-  Locally action -> do
-    modify' (\EvalContext{..} -> EvalContext ctxSelf (Env.push @address ctxEnvironment))
-    a <- reinterpret2 handleEnv (raiseEff action)
-    a <$ modify' (\EvalContext{..} -> EvalContext ctxSelf (Env.pop @address ctxEnvironment))
-  GetCtx -> get
-  PutCtx e -> put e
-  Export name alias addr -> modify (Exports.insert name alias addr)
+newtype EnvC address m a = EnvC { runEnvC :: Eff (StateC (EvalContext address) (Eff (StateC (Exports address) m))) a }
 
-freeVariableError :: ( Member (Reader ModuleInfo) effects
-                     , Member (Reader Span) effects
-                     , Member (Resumable (BaseError (EnvironmentError address))) effects
+instance (Carrier sig m, Effect sig) => Carrier (Env address :+: sig) (EnvC address m) where
+  ret = EnvC . ret
+  eff = EnvC . (alg \/ eff . R . R . handleCoercible)
+    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
+            Close names k -> gets (Env.intersect names . ctxEnvironment) >>= runEnvC . k
+            Locally action k -> do
+              modify (\EvalContext{..} -> EvalContext ctxSelf (Env.push @address ctxEnvironment))
+              a <- runEnvC action
+              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
+
+freeVariableError :: ( Member (Reader ModuleInfo) sig
+                     , Member (Reader Span) sig
+                     , Member (Resumable (BaseError (EnvironmentError address))) sig
+                     , Carrier sig m
                      )
                   => Name
-                  -> Evaluator term address value effects address
+                  -> Evaluator term address value m address
 freeVariableError = throwEnvironmentError . FreeVariable
 
-runEnvironmentError :: (Effectful (m address value), Effects effects)
-                    => m address value (Resumable (BaseError (EnvironmentError address)) ': effects) a
-                    -> m address value effects (Either (SomeExc (BaseError (EnvironmentError address))) a)
-runEnvironmentError = runResumable
+runEnvironmentError :: (Carrier sig m, Effect sig)
+                    => Evaluator term address value (ResumableC (BaseError (EnvironmentError address)) (Eff m)) a
+                    -> Evaluator term address value m (Either (SomeError (BaseError (EnvironmentError address))) a)
+runEnvironmentError = raiseHandler runResumable
 
-runEnvironmentErrorWith :: (Effectful (m address value), Effects effects)
-                        => (forall resume . BaseError (EnvironmentError address) resume -> m address value effects resume)
-                        -> m address value (Resumable (BaseError (EnvironmentError address)) ': effects) a
-                        -> m address value effects a
-runEnvironmentErrorWith = runResumableWith
+runEnvironmentErrorWith :: Carrier sig m
+                        => (forall resume . BaseError (EnvironmentError address) resume -> Evaluator term address value m resume)
+                        -> Evaluator term address value (ResumableWithC (BaseError (EnvironmentError address)) (Eff m)) a
+                        -> Evaluator term address value m a
+runEnvironmentErrorWith f = raiseHandler $ runResumableWith (runEvaluator . f)
 
-throwEnvironmentError :: ( Member (Resumable (BaseError (EnvironmentError address))) effects
-                         , Member (Reader ModuleInfo) effects
-                         , Member (Reader Span) effects
+throwEnvironmentError :: ( Member (Resumable (BaseError (EnvironmentError address))) sig
+                         , Member (Reader ModuleInfo) sig
+                         , Member (Reader Span) sig
+                         , Carrier sig m
                          )
                       => EnvironmentError address resume
-                      -> Evaluator term address value effects resume
+                      -> Evaluator term address value m resume
 throwEnvironmentError = throwBaseError

src/Control/Abstract/Evaluator.hs

@@ -1,6 +1,7 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving, TypeOperators, ScopedTypeVariables #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeOperators, UndecidableInstances #-}
 module Control.Abstract.Evaluator
   ( Evaluator(..)
+  , raiseHandler
   , Open
   -- * Effects
   , Return(..)
@@ -16,27 +17,39 @@ module Control.Abstract.Evaluator
   , module X
   ) where
 
-import Control.Monad.Effect           as X
-import Control.Monad.Effect.Fresh     as X
-import Control.Monad.Effect.Exception as X
-import qualified Control.Monad.Effect.Internal as Eff
-import Control.Monad.Effect.NonDet    as X
-import Control.Monad.Effect.Reader    as X
-import Control.Monad.Effect.Resumable as X
-import Control.Monad.Effect.State     as X
-import Control.Monad.Effect.Trace     as X
-import Prologue hiding (MonadError(..))
+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
+import Data.Coerce
 
 -- | An 'Evaluator' is a thin wrapper around 'Eff' with (phantom) type parameters for the address, term, and value types.
 --
 --   These parameters enable us to constrain the types of effects using them s.t. we can avoid both ambiguous types when they aren’t mentioned outside of the context, and lengthy, redundant annotations on the use sites of functions employing these effects.
 --
 --   These effects will typically include the environment, heap, module table, etc. effects necessary for evaluation of modules and terms, but may also include any other effects so long as they’re eventually handled.
-newtype Evaluator term address value effects a = Evaluator { runEvaluator :: Eff effects a }
-  deriving (Applicative, Effectful, Functor, Monad)
+newtype Evaluator term address value m a = Evaluator { runEvaluator :: Eff m a }
+  deriving (Applicative, Functor, Monad)
 
-deriving instance Member NonDet effects => Alternative (Evaluator term address value effects)
-deriving instance Member (Lift IO) effects => MonadIO (Evaluator term address value effects)
+deriving instance (Member NonDet sig, Carrier sig m) => Alternative (Evaluator term address value m)
+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
+  ret = Evaluator . ret
+  eff = Evaluator . eff . handlePure runEvaluator
+
+
+-- | Raise a handler on 'Eff's into a handler on 'Evaluator's.
+raiseHandler :: (Eff m a -> Eff n b)
+             -> Evaluator term address value m a
+             -> Evaluator term address value n b
+raiseHandler = coerce
 
 
 -- | An open-recursive function.
@@ -49,16 +62,16 @@ type Open a = a -> a
 newtype Return address = Return { unReturn :: address }
   deriving (Eq, Ord, Show)
 
-earlyReturn :: Member (Exc (Return address)) effects
+earlyReturn :: (Member (Error (Return address)) sig, Carrier sig m)
             => address
-            -> Evaluator term address value effects address
+            -> Evaluator term address value m address
 earlyReturn = throwError . Return
 
-catchReturn :: Member (Exc (Return address)) effects => Evaluator term address value effects address -> Evaluator term address value effects address
-catchReturn = Eff.raiseHandler (handleError (\ (Return addr) -> pure addr))
+catchReturn :: (Member (Error (Return address)) sig, Carrier sig m) => Evaluator term address value m address -> Evaluator term address value m address
+catchReturn = flip catchError (\ (Return addr) -> pure addr)
 
-runReturn :: Effects effects => Evaluator term address value (Exc (Return address) ': effects) address -> Evaluator term address value effects address
-runReturn = Eff.raiseHandler (fmap (either unReturn id) . runError)
+runReturn :: (Carrier sig m, Effect sig) => Evaluator term address value (ErrorC (Return address) (Eff m)) address -> Evaluator term address value m address
+runReturn = raiseHandler $ fmap (either unReturn id) . runError
 
 
 -- | Effects for control flow around loops (breaking and continuing).
@@ -68,22 +81,23 @@ data LoopControl address
   | Abort
   deriving (Eq, Ord, Show)
 
-throwBreak :: Member (Exc (LoopControl address)) effects
+throwBreak :: (Member (Error (LoopControl address)) sig, Carrier sig m)
            => address
-           -> Evaluator term address value effects address
+           -> Evaluator term address value m address
 throwBreak = throwError . Break
 
-throwContinue :: Member (Exc (LoopControl address)) effects
+throwContinue :: (Member (Error (LoopControl address)) sig, Carrier sig m)
               => address
-              -> Evaluator term address value effects address
+              -> Evaluator term address value m address
 throwContinue = throwError . Continue
 
-throwAbort :: forall term address effects value a . Member (Exc (LoopControl address)) effects
-           => Evaluator term address value effects a
+throwAbort :: forall term address sig m value a
+           .  (Member (Error (LoopControl address)) sig, Carrier sig m)
+           => Evaluator term address value m a
 throwAbort = throwError (Abort @address)
 
-catchLoopControl :: Member (Exc (LoopControl address)) effects => Evaluator term address value effects a -> (LoopControl address -> Evaluator term address value effects a) -> Evaluator term address value effects a
+catchLoopControl :: (Member (Error (LoopControl address)) sig, Carrier sig m) => Evaluator term address value m a -> (LoopControl address -> Evaluator term address value m a) -> Evaluator term address value m a
 catchLoopControl = catchError
 
-runLoopControl :: Effects effects => Evaluator term address value (Exc (LoopControl address) ': effects) address -> Evaluator term address value effects address
-runLoopControl = Eff.raiseHandler (fmap (either unLoopControl id) . runError)
+runLoopControl :: (Carrier sig m, Effect sig) => Evaluator term address value (ErrorC (LoopControl address) (Eff m)) address -> Evaluator term address value m address
+runLoopControl = raiseHandler $ fmap (either unLoopControl id) . runError

src/Control/Abstract/Heap.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE GADTs, KindSignatures, RankNTypes, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, KindSignatures, RankNTypes, TypeOperators, UndecidableInstances #-}
 module Control.Abstract.Heap
 ( Heap
 , Live
@@ -13,7 +13,11 @@ module Control.Abstract.Heap
 , gc
 -- * Effects
 , Allocator(..)
+, runAllocator
+, AllocatorC(..)
 , Deref(..)
+, runDeref
+, DerefC(..)
 , AddressError(..)
 , runAddressError
 , runAddressErrorWith
@@ -21,6 +25,8 @@ module Control.Abstract.Heap
 
 import Control.Abstract.Evaluator
 import Control.Abstract.Roots
+import Control.Applicative (Alternative)
+import Control.Effect.Carrier
 import Data.Abstract.BaseError
 import Data.Abstract.Heap
 import Data.Abstract.Live
@@ -30,73 +36,77 @@ import Data.Span (Span)
 import Prologue
 
 -- | Retrieve the heap.
-getHeap :: Member (State (Heap address value)) effects => Evaluator term address value effects (Heap address value)
+getHeap :: (Member (State (Heap address value)) sig, Carrier sig m) => Evaluator term address value m (Heap address value)
 getHeap = get
 
 -- | Set the heap.
-putHeap :: Member (State (Heap address value)) effects => Heap address value -> Evaluator term address value effects ()
+putHeap :: (Member (State (Heap address value)) sig, Carrier sig m) => Heap address value -> Evaluator term address value m ()
 putHeap = put
 
 -- | Update the heap.
-modifyHeap :: Member (State (Heap address value)) effects => (Heap address value -> Heap address value) -> Evaluator term address value effects ()
-modifyHeap = modify'
+modifyHeap :: (Member (State (Heap address value)) sig, Carrier sig m) => (Heap address value -> Heap address value) -> Evaluator term address value m ()
+modifyHeap = modify
 
-box :: ( Member (Allocator address) effects
-       , Member (Deref value) effects
-       , Member Fresh effects
-       , Member (State (Heap address value)) effects
+box :: ( Member (Allocator address) sig
+       , Member (Deref value) sig
+       , Member Fresh sig
+       , Member (State (Heap address value)) sig
        , Ord address
+       , Carrier sig m
        )
     => value
-    -> Evaluator term address value effects address
+    -> Evaluator term address value m address
 box val = do
   name <- gensym
   addr <- alloc name
   assign addr val
   pure addr
 
-alloc :: Member (Allocator address) effects => Name -> Evaluator term address value effects address
-alloc = send . Alloc
+alloc :: (Member (Allocator address) sig, Carrier sig m) => Name -> Evaluator term address value m address
+alloc = send . flip Alloc ret
 
-dealloc :: (Member (State (Heap address value)) effects, Ord address) => address -> Evaluator term address value effects ()
+dealloc :: (Member (State (Heap address value)) sig, Ord address, Carrier sig m) => address -> Evaluator term address value m ()
 dealloc addr = modifyHeap (heapDelete addr)
 
 -- | Dereference the given address in the heap, or fail if the address is uninitialized.
-deref :: ( Member (Deref value) effects
-         , Member (Reader ModuleInfo) effects
-         , Member (Reader Span) effects
-         , Member (Resumable (BaseError (AddressError address value))) effects
-         , Member (State (Heap address value)) effects
+deref :: ( Member (Deref value) sig
+         , Member (Reader ModuleInfo) sig
+         , Member (Reader Span) sig
+         , Member (Resumable (BaseError (AddressError address value))) sig
+         , Member (State (Heap address value)) sig
          , Ord address
+         , Carrier sig m
          )
       => address
-      -> Evaluator term address value effects value
-deref addr = gets (heapLookup addr) >>= maybeM (throwAddressError (UnallocatedAddress addr)) >>= send . DerefCell >>= maybeM (throwAddressError (UninitializedAddress addr))
+      -> Evaluator term address value m value
+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'.
-assign :: ( Member (Deref value) effects
-          , Member (State (Heap address value)) effects
+assign :: ( Member (Deref value) sig
+          , Member (State (Heap address value)) sig
           , Ord address
+          , Carrier sig m
           )
        => address
        -> value
-       -> Evaluator term address value effects ()
+       -> Evaluator term address value m ()
 assign addr value = do
   heap <- getHeap
-  cell <- send (AssignCell value (fromMaybe lowerBound (heapLookup addr heap)))
+  cell <- send (AssignCell value (fromMaybe lowerBound (heapLookup addr heap)) ret)
   putHeap (heapInit addr cell heap)
 
 
 -- Garbage collection
 
 -- | Collect any addresses in the heap not rooted in or reachable from the given 'Live' set.
-gc :: ( Member (State (Heap address value)) effects
+gc :: ( Member (State (Heap address value)) sig
       , Ord address
       , ValueRoots address value
+      , Carrier sig m
       )
    => Live address                       -- ^ The set of addresses to consider rooted.
-   -> Evaluator term address value effects ()
+   -> Evaluator term address value m ()
 gc roots = modifyHeap (heapRestrict <*> reachable roots)
 
 -- | Compute the set of addresses reachable from a given root set in a given heap.
@@ -116,23 +126,47 @@ reachable roots heap = go mempty roots
 
 -- Effects
 
-data Allocator address (m :: * -> *) return where
-  Alloc   :: Name    -> Allocator address m address
+data Allocator address (m :: * -> *) k
+  = Alloc Name (address -> k)
+  deriving (Functor)
 
-data Deref value (m :: * -> *) return where
-  DerefCell  :: Set value          -> Deref value m (Maybe value)
-  AssignCell :: value -> Set value -> Deref value m (Set value)
-
-instance PureEffect (Allocator address)
+instance HFunctor (Allocator address) where
+  hmap _ (Alloc name k) = Alloc name k
 
 instance Effect (Allocator address) where
-  handleState c dist (Request (Alloc name) k) = Request (Alloc name) (dist . (<$ c) . k)
+  handle state handler (Alloc name k) = Alloc name (handler . (<$ state) . k)
 
-instance PureEffect (Deref value)
+runAllocator :: Carrier (Allocator address :+: sig) (AllocatorC address (Eff m))
+             => Evaluator term address value (AllocatorC address (Eff m)) a
+             -> Evaluator term address value m a
+runAllocator = raiseHandler $ runAllocatorC . interpret
+
+newtype AllocatorC address m a = AllocatorC { runAllocatorC :: m a }
+  deriving (Alternative, Applicative, Functor, Monad)
+
+
+data Deref value (m :: * -> *) k
+  = DerefCell        (Set value) (Maybe value -> k)
+  | AssignCell value (Set value) (Set value   -> k)
+  deriving (Functor)
+
+instance HFunctor (Deref value) where
+  hmap _ (DerefCell        cell k) = DerefCell        cell k
+  hmap _ (AssignCell value cell k) = AssignCell value cell k
 
 instance Effect (Deref value) where
-  handleState c dist (Request (DerefCell cell) k) = Request (DerefCell cell) (dist . (<$ c) . k)
-  handleState c dist (Request (AssignCell value cell) k) = Request (AssignCell  value cell) (dist . (<$ c) . k)
+  handle state handler (DerefCell        cell k) = DerefCell        cell (handler . (<$ state) . k)
+  handle state handler (AssignCell value cell k) = AssignCell value cell (handler . (<$ state) . k)
+
+runDeref :: Carrier (Deref value :+: sig) (DerefC address value (Eff m))
+         => Evaluator term address value (DerefC address value (Eff m)) a
+         -> Evaluator term address value m a
+runDeref = raiseHandler $ runDerefC . interpret
+
+newtype DerefC address value m a = DerefC { runDerefC :: m a }
+  deriving (Alternative, Applicative, Functor, Monad)
+
+
 
 data AddressError address value resume where
   UnallocatedAddress   :: address -> AddressError address value (Set value)
@@ -155,21 +189,22 @@ instance Eq address => Eq1 (AddressError address value) where
   liftEq _ (UnallocatedAddress a)   (UnallocatedAddress b)   = a == b
   liftEq _ _                        _                        = False
 
-throwAddressError :: ( Member (Resumable (BaseError (AddressError address body))) effects
-                     , Member (Reader ModuleInfo) effects
-                     , Member (Reader Span) effects
+throwAddressError :: ( Member (Resumable (BaseError (AddressError address body))) sig
+                     , Member (Reader ModuleInfo) sig
+                     , Member (Reader Span) sig
+                     , Carrier sig m
                      )
                   => AddressError address body resume
-                  -> Evaluator term address value effects resume
+                  -> Evaluator term address value m resume
 throwAddressError = throwBaseError
 
-runAddressError :: Effects effects
-                => Evaluator term address value (Resumable (BaseError (AddressError address value)) ': effects) a
-                -> Evaluator term address value effects (Either (SomeExc (BaseError (AddressError address value))) a)
-runAddressError = runResumable
+runAddressError :: (Carrier sig m, Effect sig)
+                => Evaluator term address value (ResumableC (BaseError (AddressError address value)) (Eff m)) a
+                -> Evaluator term address value m (Either (SomeError (BaseError (AddressError address value))) a)
+runAddressError = raiseHandler runResumable
 
-runAddressErrorWith :: Effects effects
-                    => (forall resume . (BaseError (AddressError address value)) resume -> Evaluator term address value effects resume)
-                    -> Evaluator term address value (Resumable (BaseError (AddressError address value)) ': effects) a
-                    -> Evaluator term address value effects a
-runAddressErrorWith = runResumableWith
+runAddressErrorWith :: Carrier sig m
+                    => (forall resume . (BaseError (AddressError address value)) resume -> Evaluator term address value m resume)
+                    -> Evaluator term address value (ResumableWithC (BaseError (AddressError address value)) (Eff m)) a
+                    -> Evaluator term address value m a
+runAddressErrorWith f = raiseHandler $ runResumableWith (runEvaluator . f)

src/Control/Abstract/Modules.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE GADTs, LambdaCase, KindSignatures, RankNTypes, ScopedTypeVariables, TypeOperators #-}
+{-# LANGUAGE GADTs, LambdaCase, KindSignatures, RankNTypes, ScopedTypeVariables, TypeOperators, UndecidableInstances #-}
 module Control.Abstract.Modules
 ( ModuleResult
 , lookupModule
@@ -20,10 +20,13 @@ 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
 import Data.Abstract.ModuleTable as ModuleTable
+import Data.Coerce
 import Data.Language
 import Data.Semigroup.Foldable (foldMap1)
 import qualified Data.Set as Set
@@ -35,60 +38,75 @@ import Data.Abstract.ScopeGraph
 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) effects => ModulePath -> Evaluator term address value effects (Maybe (ModuleResult address))
-lookupModule = sendModules . Lookup
+lookupModule :: (Member (Modules address) sig, Carrier sig m) => ModulePath -> Evaluator term address value m (Maybe (ModuleResult address))
+lookupModule = sendModules . flip Lookup ret
 
 -- | Resolve a list of module paths to a possible module table entry.
-resolve :: Member (Modules address) effects => [FilePath] -> Evaluator term address value effects (Maybe ModulePath)
-resolve = sendModules . Resolve
+resolve :: (Member (Modules address) sig, Carrier sig m) => [FilePath] -> Evaluator term address value m (Maybe ModulePath)
+resolve = sendModules . flip Resolve ret
 
-listModulesInDir :: Member (Modules address) effects => FilePath -> Evaluator term address value effects [ModulePath]
-listModulesInDir = sendModules . List
+listModulesInDir :: (Member (Modules address) sig, Carrier sig m) => FilePath -> Evaluator term address value m [ModulePath]
+listModulesInDir = sendModules . flip List ret
 
 
 -- | Require/import another module by name and return its environment and value.
 --
 -- Looks up the module's name in the cache of evaluated modules first, returns if found, otherwise loads/evaluates the module.
-require :: Member (Modules address) effects => ModulePath -> Evaluator term address value effects (ModuleResult address)
+require :: (Member (Modules address) sig, Carrier sig m) => ModulePath -> Evaluator term address value m (ModuleResult address)
 require path = lookupModule path >>= maybeM (load path)
 
 -- | Load another module by name and return its environment and value.
 --
 -- Always loads/evaluates.
-load :: Member (Modules address) effects => ModulePath -> Evaluator term address value effects (ModuleResult address)
-load path = sendModules (Load path)
+load :: (Member (Modules address) sig, Carrier sig m) => ModulePath -> Evaluator term address value m (ModuleResult address)
+load path = sendModules (Load path ret)
 
 
-data Modules address (m :: * -> *) return where
-  Load    :: ModulePath -> Modules address m (ModuleResult address)
-  Lookup  :: ModulePath -> Modules address m (Maybe (ModuleResult address))
-  Resolve :: [FilePath] -> Modules address m (Maybe ModulePath)
-  List    :: FilePath   -> Modules address m [ModulePath]
+data Modules address (m :: * -> *) k
+  = Load    ModulePath (ModuleResult address -> k)
+  | Lookup  ModulePath (Maybe (ModuleResult address) -> k)
+  | Resolve [FilePath] (Maybe ModulePath -> k)
+  | List    FilePath   ([ModulePath] -> k)
+  deriving (Functor)
+
+instance HFunctor (Modules address) where
+  hmap _ = coerce
 
-instance PureEffect (Modules address)
 instance Effect (Modules address) where
-  handleState c dist (Request (Load path) k) = Request (Load path) (dist . (<$ c) . k)
-  handleState c dist (Request (Lookup path) k) = Request (Lookup path) (dist . (<$ c) . k)
-  handleState c dist (Request (Resolve paths) k) = Request (Resolve paths) (dist . (<$ c) . k)
-  handleState c dist (Request (List path) k) = Request (List path) (dist . (<$ c) . k)
+  handle state handler (Load    path  k) = Load    path  (handler . (<$ state) . k)
+  handle state handler (Lookup  path  k) = Lookup  path  (handler . (<$ state) . k)
+  handle state handler (Resolve paths k) = Resolve paths (handler . (<$ state) . k)
+  handle state handler (List    path  k) = List    path  (handler . (<$ state) . k)
 
-sendModules :: Member (Modules address) effects => Modules address (Eff effects) return -> Evaluator term address value effects return
+sendModules :: (Member (Modules address) sig, Carrier sig m) => Modules address (Evaluator term address value m) (Evaluator term address value m return) -> Evaluator term address value m return
 sendModules = send
 
-runModules :: ( Member (Reader (ModuleTable (NonEmpty (Module (ModuleResult address))))) effects
-              , Member (Resumable (BaseError (LoadError address))) effects
-              , PureEffects effects
+runModules :: ( Member (Reader (ModuleTable (NonEmpty (Module (ModuleResult address))))) sig
+              , Member (Resumable (BaseError (LoadError address))) sig
+              , Carrier sig m
               )
            => Set ModulePath
-           -> Evaluator term address value (Modules address ': effects) a
-           -> Evaluator term address value effects a
-runModules paths = interpret $ \case
-  Load   name   -> fmap (runMerging . foldMap1 (Merging . moduleBody)) . ModuleTable.lookup name <$> askModuleTable >>= maybeM (throwLoadError (ModuleNotFoundError name))
-  Lookup path   -> fmap (runMerging . foldMap1 (Merging . moduleBody)) . ModuleTable.lookup path <$> askModuleTable
-  Resolve names -> pure (find (`Set.member` paths) names)
-  List dir      -> pure (filter ((dir ==) . takeDirectory) (toList paths))
+           -> Evaluator term address value (ModulesC address (Eff m)) a
+           -> Evaluator term address value m a
+runModules paths = raiseHandler $ flip runModulesC paths . interpret
 
-askModuleTable :: Member (Reader (ModuleTable (NonEmpty (Module (ModuleResult address))))) effects => Evaluator term address value effects (ModuleTable (NonEmpty (Module (ModuleResult address))))
+newtype ModulesC address m a = ModulesC { runModulesC :: Set ModulePath -> m a }
+
+instance ( Member (Reader (ModuleTable (NonEmpty (Module (ModuleResult address))))) sig
+         , Member (Resumable (BaseError (LoadError address))) sig
+         , Carrier sig m
+         , Monad m
+         )
+      => Carrier (Modules address :+: sig) (ModulesC address m) where
+  ret = ModulesC . const . ret
+  eff op = ModulesC (\ paths -> (alg paths \/ eff . handleReader paths runModulesC) op)
+    where alg paths = \case
+            Load    name  k -> askModuleTable >>= maybeM (throwLoadError (ModuleNotFoundError name)) . fmap (runMerging . foldMap1 (Merging . moduleBody)) . ModuleTable.lookup name >>= flip runModulesC paths . k
+            Lookup  path  k -> askModuleTable >>= flip runModulesC paths . k . fmap (runMerging . foldMap1 (Merging . moduleBody)) . ModuleTable.lookup path
+            Resolve names k -> runModulesC (k (find (`Set.member` paths) names)) paths
+            List    dir   k -> runModulesC (k (filter ((dir ==) . takeDirectory) (toList paths))) paths
+
+askModuleTable :: (Member (Reader (ModuleTable (NonEmpty (Module (ModuleResult address))))) sig, Carrier sig m) => m (ModuleTable (NonEmpty (Module (ModuleResult address))))
 askModuleTable = ask
 
 
@@ -112,20 +130,20 @@ instance Eq1 (LoadError address) where
 instance NFData1 (LoadError address) where
   liftRnf _ (ModuleNotFoundError p) = rnf p
 
-runLoadError :: Effects effects
-             => Evaluator term address value (Resumable (BaseError (LoadError address)) ': effects) a
-             -> Evaluator term address value effects (Either (SomeExc (BaseError (LoadError address))) a)
-runLoadError = runResumable
+runLoadError :: (Carrier sig m, Effect sig)
+             => Evaluator term address value (ResumableC (BaseError (LoadError address)) (Eff m)) a
+             -> Evaluator term address value m (Either (SomeError (BaseError (LoadError address))) a)
+runLoadError = raiseHandler runResumable
 
-runLoadErrorWith :: Effects effects
-                 => (forall resume . (BaseError (LoadError address)) resume -> Evaluator term address value effects resume)
-                 -> Evaluator term address value (Resumable (BaseError (LoadError address)) ': effects) a
-                 -> Evaluator term address value effects a
-runLoadErrorWith = runResumableWith
+runLoadErrorWith :: Carrier sig m
+                 => (forall resume . (BaseError (LoadError address)) resume -> Evaluator term address value m resume)
+                 -> Evaluator term address value (ResumableWithC (BaseError (LoadError address)) (Eff m)) a
+                 -> Evaluator term address value m a
+runLoadErrorWith f = raiseHandler $ runResumableWith (runEvaluator . f)
 
-throwLoadError :: Member (Resumable (BaseError (LoadError address))) effects
+throwLoadError :: (Member (Resumable (BaseError (LoadError address))) sig, Carrier sig m)
                => LoadError address resume
-               -> Evaluator term address value effects resume
+               -> m resume
 throwLoadError err@(ModuleNotFoundError name) = throwResumable $ BaseError (ModuleInfo name) emptySpan err
 
 
@@ -150,21 +168,22 @@ instance NFData1 ResolutionError where
     NotFoundError p ps l -> rnf p `seq` rnf ps `seq` rnf l
     GoImportError p      -> rnf p
 
-runResolutionError :: Effects effects
-                   => Evaluator term address value (Resumable (BaseError ResolutionError) ': effects) a
-                   -> Evaluator term address value effects (Either (SomeExc (BaseError ResolutionError)) a)
-runResolutionError = runResumable
+runResolutionError :: (Carrier sig m, Effect sig)
+                   => Evaluator term address value (ResumableC (BaseError ResolutionError) (Eff m)) a
+                   -> Evaluator term address value m (Either (SomeError (BaseError ResolutionError)) a)
+runResolutionError = raiseHandler runResumable
 
-runResolutionErrorWith :: Effects effects
-                       => (forall resume . (BaseError ResolutionError) resume -> Evaluator term address value effects resume)
-                       -> Evaluator term address value (Resumable (BaseError ResolutionError) ': effects) a
-                       -> Evaluator term address value effects a
-runResolutionErrorWith = runResumableWith
+runResolutionErrorWith :: Carrier sig m
+                       => (forall resume . (BaseError ResolutionError) resume -> Evaluator term address value m resume)
+                       -> Evaluator term address value (ResumableWithC (BaseError ResolutionError) (Eff m)) a
+                       -> Evaluator term address value m a
+runResolutionErrorWith f = raiseHandler $ runResumableWith (runEvaluator . f)
 
-throwResolutionError :: ( Member (Reader ModuleInfo) effects
-                        , Member (Reader Span) effects
-                        , Member (Resumable (BaseError ResolutionError)) effects
+throwResolutionError :: ( Member (Reader ModuleInfo) sig
+                        , Member (Reader Span) sig
+                        , Member (Resumable (BaseError ResolutionError)) sig
+                        , Carrier sig m
                         )
                      => ResolutionError resume
-                     -> Evaluator term address value effects resume
+                     -> Evaluator term address value m resume
 throwResolutionError = throwBaseError

src/Control/Abstract/Primitive.hs

@@ -14,53 +14,56 @@ import Data.Abstract.Name
 import Prologue
 
 define :: ( HasCallStack
-          , Member (Allocator address) effects
-          , Member (Deref value) effects
-          , Member (Env address) effects
-          , Member (Reader ModuleInfo) effects
-          , Member (Reader Span) effects
-          , Member (State (Heap address value)) effects
+          , Member (Allocator address) sig
+          , Member (Deref value) sig
+          , Member (Env address) sig
+          , Member (Reader ModuleInfo) sig
+          , Member (Reader Span) sig
+          , Member (State (Heap address value)) sig
+          , Carrier sig m
           , Ord address
           )
        => Name
-       -> Evaluator term address value effects value
-       -> Evaluator term address value effects ()
+       -> Evaluator term address value m value
+       -> Evaluator term address value m ()
 define name def = withCurrentCallStack callStack $ do
   addr <- alloc name
   def >>= assign addr
   bind name addr
 
-defineClass :: ( AbstractValue term address value effects
+defineClass :: ( AbstractValue term address value m
+               , Carrier sig m
                , HasCallStack
-               , Member (Allocator address) effects
-               , Member (Deref value) effects
-               , Member (Env address) effects
-               , Member (Reader ModuleInfo) effects
-               , Member (Reader Span) effects
-               , Member (State (Heap address value)) effects
+               , Member (Allocator address) sig
+               , Member (Deref value) sig
+               , Member (Env address) sig
+               , Member (Reader ModuleInfo) sig
+               , Member (Reader Span) sig
+               , Member (State (Heap address value)) sig
                , Ord address
                )
             => Name
             -> [address]
-            -> Evaluator term address value effects a
-            -> Evaluator term address value effects ()
+            -> Evaluator term address value m a
+            -> Evaluator term address value m ()
 defineClass name superclasses body = define name $ do
   binds <- Env.head <$> locally (body >> getEnv)
   klass name superclasses binds
 
-defineNamespace :: ( AbstractValue term address value effects
+defineNamespace :: ( AbstractValue term address value m
+                   , Carrier sig m
                    , HasCallStack
-                   , Member (Allocator address) effects
-                   , Member (Deref value) effects
-                   , Member (Env address) effects
-                   , Member (Reader ModuleInfo) effects
-                   , Member (Reader Span) effects
-                   , Member (State (Heap address value)) effects
+                   , Member (Allocator address) sig
+                   , Member (Deref value) sig
+                   , Member (Env address) sig
+                   , Member (Reader ModuleInfo) sig
+                   , Member (Reader Span) sig
+                   , Member (State (Heap address value)) sig
                    , Ord address
                    )
                 => Name
-                -> Evaluator term address value effects a
-                -> Evaluator term address value effects ()
+                -> Evaluator term address value m a
+                -> Evaluator term address value m ()
 defineNamespace name scope = define name $ do
   binds <- Env.head <$> locally (scope >> getEnv)
   namespace name Nothing binds

src/Control/Abstract/PythonPackage.hs

@@ -1,12 +1,13 @@
-{-# LANGUAGE GADTs, LambdaCase, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE GADTs, LambdaCase, RankNTypes, TypeFamilies, TypeOperators, UndecidableInstances #-}
 module Control.Abstract.PythonPackage
 ( runPythonPackaging, Strategy(..) ) where
 
 import           Control.Abstract.Evaluator (LoopControl, Return)
 import           Control.Abstract.Heap (Allocator, Deref, deref)
 import           Control.Abstract.Value
-import qualified Control.Monad.Effect as Eff
-import           Data.Abstract.Evaluatable
+import           Control.Effect.Carrier
+import           Control.Effect.Sum
+import           Data.Abstract.Evaluatable hiding (InterposeC)
 import           Data.Abstract.Name (name)
 import           Data.Abstract.Path (stripQuotes)
 import           Data.Abstract.Value.Concrete (Value (..), ValueError (..))
@@ -16,35 +17,36 @@ import           Prologue
 data Strategy = Unknown | Packages [Text] | FindPackages [Text]
   deriving (Show, Eq)
 
-runPythonPackaging :: forall effects term address a. (
-                      Eff.PureEffects effects
+runPythonPackaging :: ( Carrier sig m
                       , Ord address
                       , Show address
                       , Show term
-                      , Member Trace effects
-                      , Member (Boolean (Value term address)) effects
-                      , Member (State (Heap address (Value term address))) effects
-                      , Member (Resumable (BaseError (AddressError address (Value term address)))) effects
-                      , Member (Resumable (BaseError (ValueError term address))) effects
-                      , Member Fresh effects
-                      , Member (State Strategy) effects
-                      , Member (Allocator address) effects
-                      , Member (Deref (Value term address)) effects
-                      , Member (Env address) effects
-                      , Member (Eff.Exc (LoopControl address)) effects
-                      , Member (Eff.Exc (Return address)) effects
-                      , Member (Eff.Reader ModuleInfo) effects
-                      , Member (Eff.Reader PackageInfo) effects
-                      , Member (Eff.Reader Span) effects
-                      , Member (Function term address (Value term address)) effects)
-                   => Evaluator term address (Value term address) effects a
-                   -> Evaluator term address (Value term address) effects a
-runPythonPackaging = Eff.interpose @(Function term address (Value term address)) $ \case
-  Call callName super params -> do
+                      , Member Trace sig
+                      , Member (Boolean (Value term address)) sig
+                      , Member (State (Heap address (Value term address))) sig
+                      , Member (Resumable (BaseError (AddressError address (Value term address)))) sig
+                      , Member (Resumable (BaseError (ValueError term address))) sig
+                      , Member Fresh sig
+                      , Member (State Strategy) sig
+                      , Member (Allocator address) sig
+                      , Member (Deref (Value term address)) sig
+                      , Member (Env address) sig
+                      , Member (Error (LoopControl address)) sig
+                      , Member (Error (Return address)) sig
+                      , Member (Reader ModuleInfo) sig
+                      , Member (Reader PackageInfo) sig
+                      , Member (Reader Span) sig
+                      , Member (Function term address (Value term address)) sig
+                      )
+                   => Evaluator term address (Value term address) (InterposeC (Function term address (Value term address))
+                     (Evaluator term address (Value term address) m)) a
+                   -> Evaluator term address (Value term address) m a
+runPythonPackaging = interpose (\case
+  Call callName super params k -> k =<< do
     case callName of
       Closure _ _ name' paramNames _ _ -> do
-        let bindings = foldr (\ (name, addr) rest -> Map.insert name addr rest) lowerBound (zip paramNames params)
-        let asStrings address = (deref >=> asArray) address >>= traverse (deref >=> asString)
+        let bindings = foldr (uncurry Map.insert) lowerBound (zip paramNames params)
+        let asStrings = deref >=> asArray >=> traverse (deref >=> asString)
 
         case name' of
           Just n
@@ -61,5 +63,23 @@ runPythonPackaging = Eff.interpose @(Function term address (Value term address))
           _ -> pure ()
       _ -> pure ()
     call callName super params
-  Function name params body ->  function name params body
-  BuiltIn b -> builtIn b
+  Function name params body k -> function name params body >>= k
+  BuiltIn b k -> builtIn b >>= k)
+  . runEvaluator
+
+interpose :: (Member eff sig, HFunctor eff, Carrier sig m)
+          => (forall v. eff m (m v) -> m v)
+          -> Eff (InterposeC eff m) a
+          -> m a
+interpose handler = runInterposeC handler . interpret
+
+newtype InterposeC eff m a = InterposeC ((forall x . eff m (m x) -> m x) -> m a)
+
+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
+  ret a = InterposeC (const (ret a))
+  eff op
+    | Just e <- prj op = InterposeC (\ handler -> handler (handlePure (runInterposeC handler) e))
+    | otherwise        = InterposeC (\ handler -> eff (handlePure (runInterposeC handler) op))

src/Control/Abstract/Roots.hs

@@ -14,9 +14,9 @@ class ValueRoots address value where
   valueRoots :: value -> Live address
 
 -- | Retrieve the local 'Live' set.
-askRoots :: Member (Reader (Live address)) effects => Evaluator term address value effects (Live address)
+askRoots :: (Member (Reader (Live address)) sig, Carrier sig m) => Evaluator term address value m (Live address)
 askRoots = ask
 
 -- | Run a computation with the given 'Live' set added to the local root set.
-extraRoots :: (Member (Reader (Live address)) effects, Ord address) => Live address -> Evaluator term address value effects a -> Evaluator term address value effects a
+extraRoots :: (Member (Reader (Live address)) sig, Carrier sig m, Ord address) => Live address -> Evaluator term address value m a -> Evaluator term address value m a
 extraRoots roots = local (<> roots)

src/Control/Abstract/ScopeGraph.hs

@@ -1,6 +1,7 @@
-{-# LANGUAGE GADTs, KindSignatures, LambdaCase, RankNTypes, ScopedTypeVariables, TypeOperators #-}
+{-# LANGUAGE ExistentialQuantification, GADTs, KindSignatures, LambdaCase, RankNTypes, ScopedTypeVariables, TypeOperators, UndecidableInstances #-}
 module Control.Abstract.ScopeGraph
   ( runScopeEnv
+  , ScopeEnvC(..)
   , ScopeEnv
   , lookup
   , declare
@@ -17,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
@@ -24,75 +27,94 @@ import           Data.Span
 import           Prelude hiding (lookup)
 import           Prologue
 
-data ScopeEnv address (m :: * -> *) a where
-    Lookup :: Reference -> ScopeEnv address m (Maybe address)
-    Declare :: Declaration -> Span -> Maybe address -> ScopeEnv address m ()
-    PutDeclarationScope :: Declaration -> address -> ScopeEnv address m ()
-    Reference :: Reference -> Declaration -> ScopeEnv address m ()
-    NewScope :: Map EdgeLabel [address] -> ScopeEnv address m address
-    CurrentScope :: ScopeEnv address m (Maybe address)
-    Local :: address -> m a -> ScopeEnv address m a
-    AssociatedScope :: Declaration -> ScopeEnv address m (Maybe address)
+data ScopeEnv address (m :: * -> *) k
+  = Lookup Reference (Maybe address -> k)
+  | Declare Declaration Span (Maybe address) k
+  | PutDeclarationScope Declaration address k
+  | Reference Reference Declaration k
+  | NewScope (Map EdgeLabel [address]) (address -> k)
+  | CurrentScope (Maybe address -> k)
+  | forall a . Local address (m a) (a -> k)
+  | AssociatedScope Declaration (Maybe address -> k)
 
-lookup :: forall term address value effects. Member (ScopeEnv address) effects => Reference -> Evaluator term address value effects (Maybe address)
-lookup = send . Lookup @address
+deriving instance Functor (ScopeEnv address m)
 
-declare :: forall term address value effects. Member (ScopeEnv address) effects => Declaration -> Span -> Maybe address -> Evaluator term address value effects ()
-declare = ((send .) .) . Declare @address
+lookup :: (Member (ScopeEnv address) sig, Carrier sig m) => Reference -> Evaluator term address value m (Maybe address)
+lookup ref = sendScope (Lookup ref ret)
 
-putDeclarationScope :: forall term address value effects. Member (ScopeEnv address) effects => Declaration -> address -> Evaluator term address value effects ()
-putDeclarationScope = (send .) . PutDeclarationScope @address
+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 (ret ()))
 
-reference :: forall term address value effects. Member (ScopeEnv address) effects => Reference -> Declaration -> Evaluator term address value effects ()
-reference = (send .) . Reference @address
+putDeclarationScope :: (Member (ScopeEnv address) sig, Carrier sig m) => Declaration -> address -> Evaluator term address value m ()
+putDeclarationScope decl addr = sendScope (PutDeclarationScope decl addr (ret ()))
 
-newScope :: forall term address value effects. (Member (ScopeEnv address) effects) => Map EdgeLabel [address]  -> Evaluator term address value effects address
-newScope map = send (NewScope map)
+reference :: (Member (ScopeEnv address) sig, Carrier sig m) => Reference -> Declaration -> Evaluator term address value m ()
+reference ref decl = sendScope (Reference ref decl (ret ()))
 
-currentScope :: forall term address value effects. Member (ScopeEnv address) effects => Evaluator term address value effects (Maybe address)
-currentScope = send CurrentScope
+newScope :: (Member (ScopeEnv address) sig, Carrier sig m) => Map EdgeLabel [address]  -> Evaluator term address value m address
+newScope map = send (NewScope map ret)
 
-associatedScope :: forall term address value effects. Member (ScopeEnv address) effects => Declaration -> Evaluator term address value effects (Maybe address)
-associatedScope = send . AssociatedScope
+currentScope :: (Member (ScopeEnv address) sig, Carrier sig m) => Evaluator term address value m (Maybe address)
+currentScope = send (CurrentScope ret)
 
-withScope :: forall term address value effects a. Member (ScopeEnv address) effects => address -> Evaluator term address value effects a -> Evaluator term address value effects a
-withScope scope action = send (Local scope (lowerEff action))
+associatedScope :: (Member (ScopeEnv address) sig, Carrier sig m) => Declaration -> Evaluator term address value m (Maybe address)
+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 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
+
+instance HFunctor (ScopeEnv address) where
+  hmap f = \case
+    Lookup ref                          k -> Lookup ref k
+    Declare decl span assocScope        k -> Declare decl span assocScope k
+    PutDeclarationScope decl assocScope k -> PutDeclarationScope decl assocScope k
+    Reference ref decl                  k -> Reference ref decl k
+    NewScope edges                      k -> NewScope edges k
+    CurrentScope                        k -> CurrentScope k
+    AssociatedScope decl                k -> AssociatedScope decl k
+    Local scope action                  k -> Local scope (f action) k
 
-instance PureEffect (ScopeEnv address)
 instance Effect (ScopeEnv address) where
-  handleState c dist (Request (Lookup ref) k)         = Request (Lookup ref) (dist . (<$ c) . k)
-  handleState c dist (Request (Declare decl span assocScope) k) = Request (Declare decl span assocScope) (dist . (<$ c) . k)
-  handleState c dist (Request (PutDeclarationScope decl assocScope) k) = Request (PutDeclarationScope decl assocScope) (dist . (<$ c) . k)
-  handleState c dist (Request (Reference ref decl) k) = Request (Reference ref decl) (dist . (<$ c) . k)
-  handleState c dist (Request (NewScope edges) k)       = Request (NewScope edges) (dist . (<$ c) . k)
-  handleState c dist (Request CurrentScope k)         = Request CurrentScope (dist . (<$ c) . k)
-  handleState c dist (Request (AssociatedScope decl) k)         = Request (AssociatedScope decl) (dist . (<$ c) . k)
-  handleState c dist (Request (Local scope action) k) = Request (Local scope (dist (action <$ c))) (dist . fmap k)
+  handle state handler = \case
+    Lookup ref                          k -> Lookup ref (handler . (<$ state) . k)
+    Declare decl span assocScope        k -> Declare decl span assocScope (handler (k <$ state))
+    PutDeclarationScope decl assocScope k -> PutDeclarationScope decl assocScope (handler (k <$ state))
+    Reference ref decl                  k -> Reference ref decl (handler (k <$ state))
+    NewScope edges                      k -> NewScope edges (handler . (<$ state) . k)
+    CurrentScope                        k -> CurrentScope (handler . (<$ state) . k)
+    AssociatedScope decl                k -> AssociatedScope decl (handler . (<$ state) . k)
+    Local scope action                  k -> Local scope (handler (action <$ state)) (handler . fmap k)
 
 
-runScopeEnv :: (Ord address, Effects effects, Member Fresh effects, Member (Allocator address) effects)
-            => Evaluator term address value (ScopeEnv address ': effects) a
-            -> Evaluator term address value effects (ScopeGraph address, a)
-runScopeEnv evaluator = runState lowerBound (reinterpret handleScopeEnv evaluator)
+runScopeEnv :: (Ord address, Member Fresh sig, Member (Allocator address) sig, Carrier sig m, Effect sig)
+            => Evaluator term address value (ScopeEnvC address (Eff m)) a
+            -> Evaluator term address value m (ScopeGraph address, a)
+runScopeEnv = raiseHandler $ runState lowerBound . runScopeEnvC . interpret
 
-handleScopeEnv :: forall term address value effects a. (Ord address, Member Fresh effects, Member (Allocator address) effects, Effects effects)
-          => ScopeEnv address (Eff (ScopeEnv address ': effects)) a
-          -> Evaluator term address value (State (ScopeGraph address) ': effects) a
-handleScopeEnv = \case
-    Lookup ref -> ScopeGraph.scopeOfRef ref <$> get
-    Declare decl span scope -> modify @(ScopeGraph address) (ScopeGraph.declare decl span scope)
-    PutDeclarationScope decl scope -> modify @(ScopeGraph address) (ScopeGraph.insertDeclarationScope decl scope)
-    Reference ref decl -> modify @(ScopeGraph address) (ScopeGraph.reference ref decl)
-    NewScope edges -> do
-        -- Take the edges and construct a new scope, update the current scope to the new scope
-        name <- gensym
-        address <- alloc name
-        address <$ modify @(ScopeGraph address) (ScopeGraph.newScope address edges)
-    CurrentScope -> ScopeGraph.currentScope <$> get
-    AssociatedScope decl -> ScopeGraph.associatedScope decl <$> get
-    Local scope action -> do
-        prevScope <- ScopeGraph.currentScope <$> get
-        modify @(ScopeGraph address) (\g -> g { ScopeGraph.currentScope = Just scope })
-        value <- reinterpret handleScopeEnv (raiseEff action)
-        modify @(ScopeGraph address) (\g -> g { ScopeGraph.currentScope = prevScope })
-        pure value
+newtype ScopeEnvC address m a = ScopeEnvC { runScopeEnvC :: Eff (StateC (ScopeGraph address) m) a }
+
+instance (Ord address, Member Fresh sig, Member (Allocator address) sig, Carrier sig m, Effect sig) => Carrier (ScopeEnv address :+: sig) (ScopeEnvC address m) where
+  ret = ScopeEnvC . ret
+  eff = ScopeEnvC . (alg \/ eff . R . handleCoercible)
+    where alg = \case
+            Lookup ref                     k -> gets (ScopeGraph.scopeOfRef ref) >>= runScopeEnvC . k
+            Declare decl span scope        k -> modify @(ScopeGraph address) (ScopeGraph.declare decl span scope) *> runScopeEnvC k
+            PutDeclarationScope decl scope k -> modify @(ScopeGraph address) (ScopeGraph.insertDeclarationScope decl scope) *> runScopeEnvC k
+            Reference ref decl             k -> modify @(ScopeGraph address) (ScopeGraph.reference ref decl) *> runScopeEnvC k
+            NewScope edges                 k -> do
+              -- Take the edges and construct a new scope, update the current scope to the new scope
+              name <- gensym
+              address <- runEvaluator (alloc name)
+              modify @(ScopeGraph address) (ScopeGraph.newScope address edges)
+              runScopeEnvC (k address)
+            CurrentScope                   k -> gets ScopeGraph.currentScope >>= runScopeEnvC . k
+            AssociatedScope decl           k -> gets (ScopeGraph.associatedScope decl) >>= runScopeEnvC . k
+            Local scope action             k -> do
+              prevScope <- gets ScopeGraph.currentScope
+              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

@@ -1,4 +1,4 @@
-{-# LANGUAGE DeriveAnyClass, GADTs, KindSignatures, Rank2Types #-}
+{-# LANGUAGE DeriveAnyClass, GADTs, KindSignatures, Rank2Types, TypeOperators #-}
 module Control.Abstract.Value
 ( AbstractValue(..)
 , AbstractIntro(..)
@@ -10,15 +10,21 @@ module Control.Abstract.Value
 , builtIn
 , call
 , Function(..)
+, runFunction
+, FunctionC(..)
 , boolean
 , asBool
 , ifthenelse
 , disjunction
 , Boolean(..)
+, runBoolean
+, BooleanC(..)
 , while
 , doWhile
 , forLoop
 , While(..)
+, runWhile
+, WhileC(..)
 , makeNamespace
 , evaluateInScopedEnv
 , address
@@ -29,6 +35,8 @@ 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
 import Data.Abstract.Module
@@ -37,7 +45,7 @@ import Data.Abstract.Number as Number
 import Data.Abstract.Ref
 import Data.Scientific (Scientific)
 import Data.Span
-import Prologue hiding (TypeError, catchError)
+import Prologue hiding (TypeError)
 
 -- | This datum is passed into liftComparison to handle the fact that Ruby and PHP
 --   have built-in generalized-comparison ("spaceship") operators. If you want to
@@ -63,89 +71,120 @@ 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) effects => Maybe Name -> [Name] -> term -> Evaluator term address value effects value
-function name params body = sendFunction (Function name params body)
+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 ret)
 
 data BuiltIn
   = Print
   | Show
   deriving (Eq, Ord, Show, Generic, NFData)
 
-builtIn :: Member (Function term address value) effects => BuiltIn -> Evaluator term address value effects value
-builtIn = sendFunction . BuiltIn
+builtIn :: (Member (Function term address value) sig, Carrier sig m) => BuiltIn -> Evaluator term address value m value
+builtIn = sendFunction . flip BuiltIn ret
 
-call :: Member (Function term address value) effects => value -> address -> [address] -> Evaluator term address value effects address
-call fn self args = sendFunction (Call fn self args)
+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 ret)
 
-sendFunction :: Member (Function term address value) effects => Function term address value (Eff effects) a -> Evaluator term address value effects a
+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
 
-data Function term address value (m :: * -> *) result where
-  Function :: Maybe Name -> [Name] -> term -> Function term address value m value
-  BuiltIn  :: BuiltIn -> Function term address value m value
-  Call     :: value -> address -> [address] -> Function term address value m address
+data Function term address value (m :: * -> *) k
+  = Function (Maybe Name) [Name] term (value -> k)
+  | BuiltIn BuiltIn (value -> k)
+  | Call value address [address] (address -> k)
+  deriving (Functor)
+
+instance HFunctor (Function term address value) where
+  hmap _ = coerce
 
-instance PureEffect (Function term address value)
 instance Effect (Function term address value) where
-  handleState state handler (Request (Function name params body) k) = Request (Function name params body) (handler . (<$ state) . k)
-  handleState state handler (Request (BuiltIn builtIn)           k) = Request (BuiltIn builtIn)           (handler . (<$ state) . k)
-  handleState state handler (Request (Call fn self addrs)        k) = Request (Call fn self addrs)        (handler . (<$ state) . k)
+  handle state handler (Function name params body k) = Function name params body (handler . (<$ state) . k)
+  handle state handler (BuiltIn builtIn           k) = BuiltIn builtIn           (handler . (<$ state) . k)
+  handle state handler (Call fn self addrs        k) = Call fn self addrs        (handler . (<$ state) . k)
+
+
+runFunction :: Carrier (Function term address value :+: sig) (FunctionC term address value (Eff m))
+            => (term -> Evaluator term address value (FunctionC term address value (Eff m)) address)
+            -> Evaluator term address value (FunctionC term address value (Eff m)) a
+            -> Evaluator term address value m a
+runFunction eval = raiseHandler (flip runFunctionC (runEvaluator . eval) . interpret)
+
+newtype FunctionC term address value m a = FunctionC { runFunctionC :: (term -> Eff (FunctionC term address value m) address) -> m a }
+
 
 -- | Construct a boolean value in the abstract domain.
-boolean :: Member (Boolean value) effects => Bool -> Evaluator term address value effects value
-boolean = send . Boolean
+boolean :: (Member (Boolean value) sig, Carrier sig m) => Bool -> m value
+boolean = send . flip Boolean ret
 
 -- | Extract a 'Bool' from a given value.
-asBool :: Member (Boolean value) effects => value -> Evaluator term address value effects Bool
-asBool = send . AsBool
+asBool :: (Member (Boolean value) sig, Carrier sig m) => value -> m Bool
+asBool = send . flip AsBool ret
 
 -- | Eliminate boolean values. TODO: s/boolean/truthy
-ifthenelse :: Member (Boolean value) effects => value -> Evaluator term address value effects a -> Evaluator term address value effects a -> Evaluator term address value effects a
+ifthenelse :: (Member (Boolean value) sig, Carrier sig m, Monad m) => value -> m a -> m a -> m a
 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) effects => Evaluator term address value effects value -> Evaluator term address value effects value -> Evaluator term address value effects value
-disjunction (Evaluator a) (Evaluator b) = send (Disjunction a b)
+disjunction :: (Member (Boolean value) sig, Carrier sig m) => m value -> m value -> m value
+disjunction a b = send (Disjunction a b ret)
 
-data Boolean value m result where
-  Boolean     :: Bool  -> Boolean value m value
-  AsBool      :: value -> Boolean value m Bool
-  Disjunction :: m value -> m value -> Boolean value m value
+data Boolean value m k
+  = Boolean Bool (value -> k)
+  | AsBool value (Bool -> k)
+  | Disjunction (m value) (m value) (value -> k)
+  deriving (Functor)
+
+instance HFunctor (Boolean value) where
+  hmap _ (Boolean b        k) = Boolean b k
+  hmap _ (AsBool v         k) = AsBool v  k
+  hmap f (Disjunction a b  k) = Disjunction (f a) (f b) k
+
+runBoolean :: Carrier (Boolean value :+: sig) (BooleanC value (Eff m))
+           => Evaluator term address value (BooleanC value (Eff m)) a
+           -> Evaluator term address value m a
+runBoolean = raiseHandler $ runBooleanC . interpret
+
+newtype BooleanC value m a = BooleanC { runBooleanC :: m a }
 
-instance PureEffect (Boolean value) where
-  handle handler (Request (Boolean b)        k) = Request (Boolean b) (handler . k)
-  handle handler (Request (AsBool v)         k) = Request (AsBool v)  (handler . k)
-  handle handler (Request (Disjunction a b)  k) = Request (Disjunction (handler a) (handler b))  (handler . k)
 
 -- | The fundamental looping primitive, built on top of 'ifthenelse'.
-while :: Member (While value) effects
-  => Evaluator term address value effects value -- ^ Condition
-  -> Evaluator term address value effects value -- ^ Body
-  -> Evaluator term address value effects value
-while (Evaluator cond) (Evaluator body) = send (While cond body)
+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 ret)
 
 -- | Do-while loop, built on top of while.
-doWhile :: Member (While value) effects
-  => Evaluator term address value effects value -- ^ Body
-  -> Evaluator term address value effects value -- ^ Condition
-  -> Evaluator term address value effects value
+doWhile :: (Member (While value) sig, Carrier sig m)
+  => Evaluator term address value m value -- ^ Body
+  -> Evaluator term address value m value -- ^ Condition
+  -> Evaluator term address value m value
 doWhile body cond = body *> while cond body
 
 -- | C-style for loops.
-forLoop :: (Member (While value) effects, Member (Env address) effects)
-  => Evaluator term address value effects value -- ^ Initial statement
-  -> Evaluator term address value effects value -- ^ Condition
-  -> Evaluator term address value effects value -- ^ Increment/stepper
-  -> Evaluator term address value effects value -- ^ Body
-  -> Evaluator term address value effects value
+forLoop :: (Member (While value) sig, Member (Env address) sig, Carrier sig m)
+  => Evaluator term address value m value -- ^ Initial statement
+  -> Evaluator term address value m value -- ^ Condition
+  -> Evaluator term address value m value -- ^ Increment/stepper
+  -> Evaluator term address value m value -- ^ Body
+  -> Evaluator term address value m value
 forLoop initial cond step body =
   locally (initial *> while cond (body *> step))
 
-data While value m result where
-  While :: m value -> m value -> While value m value
+data While value m k
+  = While (m value) (m value) (value -> k)
+  deriving (Functor)
 
-instance PureEffect (While value) where
-  handle handler (Request (While cond body) k) = Request (While (handler cond) (handler body)) (handler . k)
+instance HFunctor (While value) where
+  hmap f (While cond body k) = While (f cond) (f body) k
+
+
+runWhile :: Carrier (While value :+: sig) (WhileC value (Eff m))
+         => Evaluator term address value (WhileC value (Eff m)) a
+         -> Evaluator term address value m a
+runWhile = raiseHandler $ runWhileC . interpret
+
+newtype WhileC value m a = WhileC { runWhileC :: m a }
 
 
 class Show value => AbstractIntro value where
@@ -184,59 +223,59 @@ class Show value => AbstractIntro value where
 -- | A 'Monad' abstracting the evaluation of (and under) binding constructs (functions, methods, etc).
 --
 --   This allows us to abstract the choice of whether to evaluate under binders for different value types.
-class AbstractIntro value => AbstractValue term address value effects where
+class AbstractIntro value => AbstractValue term address value carrier where
   -- | Cast numbers to integers
-  castToInteger :: value -> Evaluator term address value effects value
+  castToInteger :: value -> Evaluator term address value carrier value
 
 
   -- | Lift a unary operator over a 'Num' to a function on 'value's.
   liftNumeric  :: (forall a . Num a => a -> a)
-               -> (value -> Evaluator term address value effects value)
+               -> (value -> Evaluator term address value carrier value)
 
   -- | Lift a pair of binary operators to a function on 'value's.
   --   You usually pass the same operator as both arguments, except in the cases where
   --   Haskell provides different functions for integral and fractional operations, such
   --   as division, exponentiation, and modulus.
   liftNumeric2 :: (forall a b. Number a -> Number b -> SomeNumber)
-               -> (value -> value -> Evaluator term address value effects value)
+               -> (value -> value -> Evaluator term address value carrier value)
 
   -- | Lift a Comparator (usually wrapping a function like == or <=) to a function on values.
-  liftComparison :: Comparator -> (value -> value -> Evaluator term address value effects value)
+  liftComparison :: Comparator -> (value -> value -> Evaluator term address value carrier value)
 
   -- | Lift a unary bitwise operator to values. This is usually 'complement'.
   liftBitwise :: (forall a . Bits a => a -> a)
-              -> (value -> Evaluator term address value effects value)
+              -> (value -> Evaluator term address value carrier value)
 
   -- | Lift a binary bitwise operator to values. The Integral constraint is
   --   necessary to satisfy implementation details of Haskell left/right shift,
   --   but it's fine, since these are only ever operating on integral values.
   liftBitwise2 :: (forall a . (Integral a, Bits a) => a -> a -> a)
-               -> (value -> value -> Evaluator term address value effects value)
+               -> (value -> value -> Evaluator term address value carrier value)
 
-  unsignedRShift :: value -> value -> Evaluator term address value effects value
+  unsignedRShift :: value -> value -> Evaluator term address value carrier value
 
   -- | Construct an N-ary tuple of multiple (possibly-disjoint) values
-  tuple :: [address] -> Evaluator term address value effects value
+  tuple :: [address] -> Evaluator term address value carrier value
 
   -- | Construct an array of zero or more values.
-  array :: [address] -> Evaluator term address value effects value
+  array :: [address] -> Evaluator term address value carrier value
 
-  asArray :: value -> Evaluator term address value effects [address]
+  asArray :: value -> Evaluator term address value carrier [address]
 
   -- | Extract the contents of a key-value pair as a tuple.
-  asPair :: value -> Evaluator term address value effects (value, value)
+  asPair :: value -> Evaluator term address value carrier (value, value)
 
   -- | Extract a 'Text' from a given value.
-  asString :: value -> Evaluator term address value effects Text
+  asString :: value -> Evaluator term address value carrier Text
 
   -- | @index x i@ computes @x[i]@, with zero-indexing.
-  index :: value -> value -> Evaluator term address value effects address
+  index :: value -> value -> Evaluator term address value carrier address
 
   -- | Build a class value from a name and environment.
   klass :: Name             -- ^ The new class's identifier
         -> [address]        -- ^ A list of superclasses
         -> Bindings address -- ^ The environment to capture
-        -> Evaluator term address value effects value
+        -> Evaluator term address value carrier value
 
   -- | Build a namespace value from a name and environment stack
   --
@@ -244,23 +283,24 @@ class AbstractIntro value => AbstractValue term address value effects where
   namespace :: Name                 -- ^ The namespace's identifier
             -> Maybe address        -- The ancestor of the namespace
             -> Bindings address     -- ^ The environment to mappend
-            -> Evaluator term address value effects value
+            -> Evaluator term address value carrier value
 
   -- | Extract the environment from any scoped object (e.g. classes, namespaces, etc).
-  scopedEnvironment :: address -> Evaluator term address value effects (Maybe (Environment address))
+  scopedEnvironment :: address -> Evaluator term address value carrier (Maybe (Environment address))
 
 
-makeNamespace :: ( AbstractValue term address value effects
-                 , Member (Deref value) effects
-                 , Member (Env address) effects
-                 , Member (State (Heap address value)) effects
+makeNamespace :: ( AbstractValue term address value m
+                 , Member (Deref value) sig
+                 , Member (Env address) sig
+                 , Member (State (Heap address value)) sig
+                 , Carrier sig m
                  , Ord address
                  )
               => Name
               -> address
               -> Maybe address
-              -> Evaluator term address value effects ()
-              -> Evaluator term address value effects value
+              -> Evaluator term address value m ()
+              -> Evaluator term address value m value
 makeNamespace name addr super body = do
   namespaceBinds <- Env.head <$> locally (body >> getEnv)
   v <- namespace name super namespaceBinds
@@ -268,12 +308,13 @@ makeNamespace name addr super body = do
 
 
 -- | Evaluate a term within the context of the scoped environment of 'scopedEnvTerm'.
-evaluateInScopedEnv :: ( AbstractValue term address value effects
-                       , Member (Env address) effects
+evaluateInScopedEnv :: ( AbstractValue term address value m
+                       , Member (Env address) sig
+                       , Carrier sig m
                        )
                     => address
-                    -> Evaluator term address value effects a
-                    -> Evaluator term address value effects a
+                    -> Evaluator term address value m a
+                    -> Evaluator term address value m a
 evaluateInScopedEnv receiver term = do
   scopedEnv <- scopedEnvironment receiver
   env <- maybeM getEnv scopedEnv
@@ -281,40 +322,43 @@ evaluateInScopedEnv receiver term = do
 
 
 -- | Evaluates a 'Value' returning the referenced value
-value :: ( AbstractValue term address value effects
-         , Member (Deref value) effects
-         , Member (Env address) effects
-         , Member (Reader ModuleInfo) effects
-         , Member (Reader Span) effects
-         , Member (Resumable (BaseError (AddressError address value))) effects
-         , Member (Resumable (BaseError (EnvironmentError address))) effects
-         , Member (State (Heap address value)) effects
+value :: ( AbstractValue term address value m
+         , Carrier sig m
+         , Member (Deref value) sig
+         , Member (Env address) sig
+         , Member (Reader ModuleInfo) sig
+         , Member (Reader Span) sig
+         , Member (Resumable (BaseError (AddressError address value))) sig
+         , Member (Resumable (BaseError (EnvironmentError address))) sig
+         , Member (State (Heap address value)) sig
          , Ord address
          )
       => ValueRef address
-      -> Evaluator term address value effects value
+      -> Evaluator term address value m value
 value = deref <=< address
 
 -- | Returns the address of a value referenced by a 'ValueRef'
-address :: ( AbstractValue term address value effects
-           , Member (Env address) effects
-           , Member (Reader ModuleInfo) effects
-           , Member (Reader Span) effects
-           , Member (Resumable (BaseError (EnvironmentError address))) effects
+address :: ( AbstractValue term address value m
+           , Carrier sig m
+           , Member (Env address) sig
+           , Member (Reader ModuleInfo) sig
+           , Member (Reader Span) sig
+           , Member (Resumable (BaseError (EnvironmentError address))) sig
            )
         => ValueRef address
-        -> Evaluator term address value effects address
+        -> Evaluator term address value m address
 address (LvalLocal var)       = variable var
 address (LvalMember ptr prop) = evaluateInScopedEnv ptr (variable prop)
 address (Rval addr)           = pure addr
 
 -- | Convenience function for boxing a raw value and wrapping it in an Rval
-rvalBox :: ( Member (Allocator address) effects
-           , Member (Deref value) effects
-           , Member Fresh effects
-           , Member (State (Heap address value)) effects
+rvalBox :: ( Member (Allocator address) sig
+           , Member (Deref value) sig
+           , Member Fresh sig
+           , Member (State (Heap address value)) sig
+           , Carrier sig m
            , Ord address
            )
         => value
-        -> Evaluator term address value effects (ValueRef address)
+        -> Evaluator term address value m (ValueRef address)
 rvalBox val = Rval <$> box val

src/Control/Rewriting.hs

@@ -67,8 +67,8 @@ import Prologue hiding (apply, try)
 
 import           Control.Arrow
 import           Control.Category
-import           Control.Monad.Effect
-import           Control.Monad.Effect.Trace
+import           Control.Effect
+import           Control.Effect.Trace
 import           Data.Functor.Identity
 import           Data.Profunctor
 import qualified Data.Sum as Sum hiding (apply)
@@ -242,7 +242,7 @@ apply rule x = pure x >>> rule
 -- @
 --  tracing "rule fired" >>> someRule >>> tracing "rule completed"
 -- @
-tracing :: Member Trace effs => String -> RewriteM env (Eff effs) item
+tracing :: (Member Trace sig, Carrier sig m, Functor m) => String -> RewriteM env m item
 tracing s = id >>= (\t -> promote (t <$ trace s))
 
 --

src/Data/Abstract/Address/Hole.hs

@@ -1,14 +1,12 @@
-{-# LANGUAGE GADTs, RankNTypes, TypeOperators #-}
+{-# LANGUAGE TypeOperators, UndecidableInstances #-}
 module Data.Abstract.Address.Hole
 ( Hole(..)
 , toMaybe
-, runAllocator
-, handleAllocator
-, runDeref
-, handleDeref
 ) where
 
 import Control.Abstract
+import Control.Effect.Carrier
+import Control.Effect.Sum
 import Prologue
 
 data Hole context a = Partial context | Total a
@@ -22,29 +20,25 @@ toMaybe (Partial _) = Nothing
 toMaybe (Total a)   = Just a
 
 
-relocate :: Evaluator term address1 value effects a -> Evaluator term address2 value effects a
-relocate = raiseEff . lowerEff
+promoteA :: AllocatorC address m a -> AllocatorC (Hole context address) m a
+promoteA = AllocatorC . runAllocatorC
+
+instance ( Carrier (Allocator address :+: sig) (AllocatorC address m)
+         , Carrier sig m
+         , Monad m
+         )
+      => Carrier (Allocator (Hole context address) :+: sig) (AllocatorC (Hole context address) m) where
+  ret = promoteA . ret
+  eff = alg \/ AllocatorC . eff . handleCoercible
+    where alg (Alloc name k) = Total <$> promoteA (eff (L (Alloc name ret))) >>= k
 
 
-runAllocator :: PureEffects effects
-             => (forall x. Allocator address (Eff (Allocator address ': effects)) x -> Evaluator term address value effects x)
-             -> Evaluator term (Hole context address) value (Allocator (Hole context address) ': effects) a
-             -> Evaluator term (Hole context address) value effects a
-runAllocator handler = interpret (handleAllocator handler)
+promoteD :: DerefC address value m a -> DerefC (Hole context address) value m a
+promoteD = DerefC . runDerefC
 
-handleAllocator :: (forall x. Allocator address (Eff (Allocator address ': effects)) x -> Evaluator term address value effects x)
-                -> Allocator (Hole context address) (Eff (Allocator (Hole context address) ': effects)) a
-                -> Evaluator term (Hole context address) value effects a
-handleAllocator handler (Alloc name) = relocate (Total <$> handler (Alloc name))
-
-runDeref :: PureEffects effects
-         => (forall x. Deref value (Eff (Deref value ': effects)) x -> Evaluator term address value effects x)
-         -> Evaluator term (Hole context address) value (Deref value ': effects) a
-         -> Evaluator term (Hole context address) value effects a
-runDeref handler = interpret (handleDeref handler)
-
-handleDeref :: (forall x. Deref value (Eff (Deref value ': effects)) x -> Evaluator term address value effects x)
-            -> Deref value (Eff (Deref value ': effects)) a
-            -> Evaluator term (Hole context address) value effects a
-handleDeref handler (DerefCell        cell) = relocate (handler (DerefCell        cell))
-handleDeref handler (AssignCell value cell) = relocate (handler (AssignCell value cell))
+instance (Carrier (Deref value :+: sig) (DerefC address value m), Carrier sig m, Monad m)
+      => Carrier (Deref value :+: sig) (DerefC (Hole context address) value m) where
+  ret = promoteD . ret
+  eff = alg \/ DerefC . eff . handleCoercible
+    where alg (DerefCell cell k) = promoteD (eff (L (DerefCell cell ret))) >>= k
+          alg (AssignCell value cell k) = promoteD (eff (L (AssignCell value cell ret))) >>= k

src/Data/Abstract/Address/Located.hs

@@ -1,13 +1,11 @@
-{-# LANGUAGE GADTs, RankNTypes, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE TypeOperators, UndecidableInstances #-}
 module Data.Abstract.Address.Located
 ( Located(..)
-, runAllocator
-, handleAllocator
-, runDeref
-, handleDeref
 ) 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)
@@ -22,37 +20,28 @@ data Located address = Located
   deriving (Eq, Ord, Show)
 
 
-relocate :: Evaluator term address1 value effects a -> Evaluator term address2 value effects a
-relocate = raiseEff . lowerEff
+promoteA :: AllocatorC address m a -> AllocatorC (Located address) m a
+promoteA = AllocatorC . runAllocatorC
+
+instance ( Carrier (Allocator address :+: sig) (AllocatorC address m)
+         , Carrier sig m
+         , Member (Reader ModuleInfo) sig
+         , Member (Reader PackageInfo) sig
+         , Member (Reader Span) sig
+         , Monad m
+         )
+      => Carrier (Allocator (Located address) :+: sig) (AllocatorC (Located address) m) where
+  ret = promoteA . ret
+  eff = alg \/ AllocatorC . eff . handleCoercible
+    where alg (Alloc name k) = Located <$> promoteA (eff (L (Alloc name ret))) <*> currentPackage <*> currentModule <*> pure name <*> ask >>= k
 
 
-runAllocator :: ( Member (Reader ModuleInfo) effects
-                , Member (Reader PackageInfo) effects
-                , Member (Reader Span) effects
-                , PureEffects effects
-                )
-             => (forall x. Allocator address (Eff (Allocator address ': effects)) x -> Evaluator term address value effects x)
-             -> Evaluator term (Located address) value (Allocator (Located address) ': effects) a
-             -> Evaluator term (Located address) value effects a
-runAllocator handler = interpret (handleAllocator handler)
+promoteD :: DerefC address value m a -> DerefC (Located address) value m a
+promoteD = DerefC . runDerefC
 
-handleAllocator :: ( Member (Reader ModuleInfo) effects
-                   , Member (Reader PackageInfo) effects
-                   , Member (Reader Span) effects
-                   )
-                => (forall x. Allocator address (Eff (Allocator address ': effects)) x -> Evaluator term address value effects x)
-                -> Allocator (Located address) (Eff (Allocator (Located address) ': effects)) a
-                -> Evaluator term (Located address) value effects a
-handleAllocator handler (Alloc name) = relocate (Located <$> handler (Alloc name) <*> currentPackage <*> currentModule <*> pure name <*> ask)
-
-runDeref :: PureEffects effects
-         => (forall x. Deref value (Eff (Deref value ': effects)) x -> Evaluator term address value effects x)
-         -> Evaluator term (Located address) value (Deref value ': effects) a
-         -> Evaluator term (Located address) value effects a
-runDeref handler = interpret (handleDeref handler)
-
-handleDeref :: (forall x. Deref value (Eff (Deref value ': effects)) x -> Evaluator term address value effects x)
-            -> Deref value (Eff (Deref value ': effects)) a
-            -> Evaluator term (Located address) value effects a
-handleDeref handler (DerefCell        cell) = relocate (handler (DerefCell        cell))
-handleDeref handler (AssignCell value cell) = relocate (handler (AssignCell value cell))
+instance (Carrier (Deref value :+: sig) (DerefC address value m), Carrier sig m, Monad m)
+      => Carrier (Deref value :+: sig) (DerefC (Located address) value m) where
+  ret = promoteD . ret
+  eff = alg \/ DerefC . eff . handleCoercible
+    where alg (DerefCell cell k) = promoteD (eff (L (DerefCell cell ret))) >>= k
+          alg (AssignCell value cell k) = promoteD (eff (L (AssignCell value cell ret))) >>= k

src/Data/Abstract/Address/Monovariant.hs

@@ -1,13 +1,11 @@
 {-# LANGUAGE GADTs, TypeOperators, UndecidableInstances #-}
 module Data.Abstract.Address.Monovariant
 ( Monovariant(..)
-, runAllocator
-, handleAllocator
-, runDeref
-, handleDeref
 ) where
 
 import Control.Abstract
+import Control.Effect.Carrier
+import Control.Effect.Sum
 import Data.Abstract.Name
 import qualified Data.Set as Set
 import Prologue
@@ -20,26 +18,14 @@ instance Show Monovariant where
   showsPrec d = showsUnaryWith showsPrec "Monovariant" d . unMonovariant
 
 
-runAllocator :: PureEffects effects
-             => Evaluator term Monovariant value (Allocator Monovariant ': effects) a
-             -> Evaluator term Monovariant value effects a
-runAllocator = interpret handleAllocator
+instance Carrier sig m => Carrier (Allocator Monovariant :+: sig) (AllocatorC Monovariant m) where
+  ret = AllocatorC . ret
+  eff = AllocatorC . (alg \/ eff . handleCoercible)
+    where alg (Alloc name k) = runAllocatorC (k (Monovariant name))
 
-handleAllocator :: Allocator Monovariant (Eff (Allocator Monovariant ': effects)) a -> Evaluator term Monovariant value effects a
-handleAllocator (Alloc name) = pure (Monovariant name)
 
-runDeref :: ( Member NonDet effects
-            , Ord value
-            , PureEffects effects
-            )
-         => Evaluator term Monovariant value (Deref value ': effects) a
-         -> Evaluator term Monovariant value effects a
-runDeref = interpret handleDeref
-
-handleDeref :: ( Member NonDet effects
-               , Ord value
-               )
-            => Deref value (Eff (Deref value ': effects)) a
-            -> Evaluator term Monovariant value effects a
-handleDeref (DerefCell        cell) = traverse (foldMapA pure) (nonEmpty (toList cell))
-handleDeref (AssignCell value cell) = pure (Set.insert value cell)
+instance (Ord value, Carrier sig m, Alternative m, Monad m) => Carrier (Deref value :+: sig) (DerefC Monovariant value m) where
+  ret = DerefC . ret
+  eff = DerefC . (alg \/ eff . handleCoercible)
+    where alg (DerefCell cell k) = traverse (foldMapA pure) (nonEmpty (toList cell)) >>= runDerefC . k
+          alg (AssignCell value cell k) = runDerefC (k (Set.insert value cell))

src/Data/Abstract/Address/Precise.hs

@@ -1,13 +1,11 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving, GADTs, TypeOperators, UndecidableInstances #-}
 module Data.Abstract.Address.Precise
 ( Precise(..)
-, runAllocator
-, handleAllocator
-, runDeref
-, handleDeref
 ) where
 
 import Control.Abstract
+import Control.Effect.Carrier
+import Control.Effect.Sum
 import qualified Data.Set as Set
 import Prologue
 
@@ -19,21 +17,14 @@ instance Show Precise where
   showsPrec d = showsUnaryWith showsPrec "Precise" d . unPrecise
 
 
-runAllocator :: ( Member Fresh effects
-                , PureEffects effects
-                )
-             => Evaluator term Precise value (Allocator Precise ': effects) a
-             -> Evaluator term Precise value effects a
-runAllocator = interpret handleAllocator
+instance (Member Fresh sig, Carrier sig m, Monad m) => Carrier (Allocator Precise :+: sig) (AllocatorC Precise m) where
+  ret = AllocatorC . ret
+  eff = AllocatorC . (alg \/ eff . handleCoercible)
+    where alg (Alloc _ k) = Precise <$> fresh >>= runAllocatorC . k
 
-handleAllocator :: Member Fresh effects => Allocator Precise (Eff (Allocator Precise ': effects)) a -> Evaluator term Precise value effects a
-handleAllocator (Alloc _) = Precise <$> fresh
 
-runDeref :: PureEffects effects
-         => Evaluator term Precise value (Deref value ': effects) a
-         -> Evaluator term Precise value effects a
-runDeref = interpret handleDeref
-
-handleDeref :: Deref value (Eff (Deref value ': effects)) a -> Evaluator term Precise value effects a
-handleDeref (DerefCell        cell) = pure (fst <$> Set.minView cell)
-handleDeref (AssignCell value _)    = pure (Set.singleton value)
+instance Carrier sig m => Carrier (Deref value :+: sig) (DerefC Precise value m) where
+  ret = DerefC . ret
+  eff = DerefC . (alg \/ eff . handleCoercible)
+    where alg (DerefCell cell k) = runDerefC (k (fst <$> Set.minView cell))
+          alg (AssignCell value _ k) = runDerefC (k (Set.singleton value))

src/Data/Abstract/BaseError.hs

@@ -35,12 +35,14 @@ instance (NFData1 exc, NFData resume) => NFData (BaseError exc resume) where
 instance (NFData1 exc) => NFData1 (BaseError exc) where
   liftRnf rnf' (BaseError i s e) = rnf i `seq` rnf s `seq` liftRnf rnf' e
 
-throwBaseError :: ( Member (Resumable (BaseError exc)) effects
-                  , Member (Reader M.ModuleInfo) effects
-                  , Member (Reader S.Span) effects
+throwBaseError :: ( Member (Resumable (BaseError exc)) sig
+                  , Member (Reader M.ModuleInfo) sig
+                  , Member (Reader S.Span) sig
+                  , Carrier sig m
+                  , Monad m
                   )
                 => exc resume
-                -> Evaluator term address value effects resume
+                -> m resume
 throwBaseError err = do
   moduleInfo <- currentModule
   span <- currentSpan

src/Data/Abstract/Evaluatable.hs

@@ -2,8 +2,8 @@
 module Data.Abstract.Evaluatable
 ( module X
 , Evaluatable(..)
-, ModuleEffects
-, ValueEffects
+, ModuleC
+, ValueC
 , evaluate
 , traceResolve
 -- * Preludes
@@ -29,6 +29,8 @@ import Control.Abstract.Heap as X hiding (runAddressError, runAddressErrorWith)
 import Control.Abstract.Modules as X (Modules, ModuleResult, ResolutionError(..), load, lookupModule, listModulesInDir, require, resolve, throwResolutionError)
 import Control.Abstract.Value as X hiding (Boolean(..), Function(..), While(..))
 import Control.Abstract.ScopeGraph
+import Control.Effect.Eavesdrop
+import Control.Effect.Interpose
 import Data.Abstract.Declarations as X
 import Data.Abstract.Environment as X
 import Data.Abstract.BaseError as X
@@ -37,7 +39,6 @@ import Data.Abstract.Module
 import Data.Abstract.ModuleTable as ModuleTable
 import Data.Abstract.Name as X
 import Data.Abstract.Ref as X
-import Data.Coerce
 import Data.Language
 import Data.Function
 import Data.Scientific (Scientific)
@@ -49,141 +50,157 @@ import Prologue
 
 -- | The 'Evaluatable' class defines the necessary interface for a term to be evaluated. While a default definition of 'eval' is given, instances with computational content must implement 'eval' to perform their small-step operational semantics.
 class (Show1 constr, Foldable constr) => Evaluatable constr where
-  eval :: ( AbstractValue term address value effects
+  eval :: ( AbstractValue term address value m
+          , Carrier sig m
           , Declarations term
           , FreeVariables term
-          , Member (Allocator address) effects
-          , Member (Boolean value) effects
-          , Member (While value) effects
-          , Member (Deref value) effects
-          , Member (ScopeEnv address) effects
-          , Member (Env address) effects
-          , Member (Exc (LoopControl address)) effects
-          , Member (Exc (Return address)) effects
-          , Member Fresh effects
-          , Member (Function term address value) effects
-          , Member (Modules address) effects
-          , Member (Reader ModuleInfo) effects
-          , Member (Reader PackageInfo) effects
-          , Member (Reader Span) effects
-          , Member (State Span) effects
-          , Member (Resumable (BaseError (AddressError address value))) effects
-          , Member (Resumable (BaseError (EnvironmentError address))) effects
-          , Member (Resumable (BaseError (UnspecializedError value))) effects
-          , Member (Resumable (BaseError EvalError)) effects
-          , Member (Resumable (BaseError ResolutionError)) effects
-          , Member (State (Heap address value)) effects
-          , Member Trace effects
+          , Member (Allocator address) sig
+          , Member (Boolean value) sig
+          , Member (While value) sig
+          , Member (Deref value) sig
+          , Member (ScopeEnv address) sig
+          , Member (Env address) sig
+          , Member (Error (LoopControl address)) sig
+          , Member (Error (Return address)) sig
+          , Member Fresh sig
+          , Member (Function term address value) sig
+          , Member (Modules address) sig
+          , Member (Reader ModuleInfo) sig
+          , Member (Reader PackageInfo) sig
+          , Member (Reader Span) sig
+          , Member (State Span) sig
+          , Member (Resumable (BaseError (AddressError address value))) sig
+          , Member (Resumable (BaseError (EnvironmentError address))) sig
+          , Member (Resumable (BaseError (UnspecializedError value))) sig
+          , Member (Resumable (BaseError EvalError)) sig
+          , Member (Resumable (BaseError ResolutionError)) sig
+          , Member (State (Heap address value)) sig
+          , Member Trace sig
           , Ord address
           )
-       => (term -> Evaluator term address value effects (ValueRef address))
-       -> (constr term -> Evaluator term address value effects (ValueRef address))
+       => (term -> Evaluator term address value m (ValueRef address))
+       -> (constr term -> Evaluator term address value m (ValueRef address))
   eval recur expr = do
     traverse_ recur expr
     v <- throwUnspecializedError $ UnspecializedError ("Eval unspecialized for " <> liftShowsPrec (const (const id)) (const id) 0 expr "")
     rvalBox v
 
 
-type ModuleEffects address value rest
-  =  Exc (LoopControl address)
-  ': Exc (Return address)
-  ': Env address
-  ': ScopeEnv address
-  ': Deref value
-  ': Allocator address
-  ': Reader ModuleInfo
-  ': rest
+type ModuleC address value m
+  = EavesdropC (Modules address)                                  (Eff
+  ( InterposeC (Resumable (BaseError (UnspecializedError value))) (Eff
+  ( ErrorC (LoopControl address)                                  (Eff
+  ( ErrorC (Return address)                                       (Eff
+  ( EnvC address                                                  (Eff
+  ( ScopeEnvC address                                             (Eff
+  ( DerefC address value                                          (Eff
+  ( AllocatorC address                                            (Eff
+  ( ReaderC ModuleInfo                                            (Eff
+    m)))))))))))))))))
 
-type ValueEffects term address value rest
-  =  Function term address value
-  ': While value
-  ': Boolean value
-  ': rest
+type ValueC term address value m
+  = FunctionC term address value (Eff
+  ( WhileC value                 (Eff
+  ( BooleanC value               (Eff
+    m)))))
 
-evaluate :: ( AbstractValue term address value valueEffects
+evaluate :: ( AbstractValue term address value valueC
+            , Carrier sig c
+            , allocatorC ~ AllocatorC address (Eff (ReaderC ModuleInfo (Eff c)))
+            , Carrier (Allocator address :+: Reader ModuleInfo :+: sig) allocatorC
+            , Carrier (Deref value :+: Allocator address :+: Reader ModuleInfo :+: sig) (DerefC address value (Eff allocatorC))
+            , booleanC ~ BooleanC value (Eff moduleC)
+            , Carrier (Boolean value :+: moduleSig) booleanC
+            , whileC ~ WhileC value (Eff booleanC)
+            , moduleSig ~ (Eavesdrop (Modules address) :+: Interpose (Resumable (BaseError (UnspecializedError value))) :+: Error (LoopControl address) :+: Error (Return address) :+: Env address :+: ScopeEnv address :+: Deref value :+: Allocator address :+: Reader ModuleInfo :+: sig)
+            , Carrier (While value :+: Boolean value :+: moduleSig) whileC
+            , Carrier (Function term address value :+: While value :+: Boolean value :+: moduleSig) valueC
             , Declarations term
-            , Effects effects
+            , Effect sig
             , Evaluatable (Base term)
             , FreeVariables term
             , HasPostlude lang
             , HasPrelude lang
-            , Member Fresh effects
-            , Member (Modules address) effects
-            , Member (Reader (ModuleTable (NonEmpty (Module (ModuleResult address))))) effects
-            , Member (Reader PackageInfo) effects
-            , Member (Reader Span) effects
-            , Member (State Span) effects
-            , Member (Resumable (BaseError (AddressError address value))) effects
-            , Member (Resumable (BaseError (EnvironmentError address))) effects
-            , Member (Resumable (BaseError EvalError)) effects
-            , Member (Resumable (BaseError ResolutionError)) effects
-            , Member (Resumable (BaseError (UnspecializedError value))) effects
-            , Member (State (Heap address value)) effects
-            , Member Trace effects
+            , Member Fresh sig
+            , Member (Modules address) sig
+            , Member (Reader (ModuleTable (NonEmpty (Module (ModuleResult address))))) sig
+            , Member (Reader PackageInfo) sig
+            , Member (Reader Span) sig
+            , Member (State Span) sig
+            , Member (Resumable (BaseError (AddressError address value))) sig
+            , Member (Resumable (BaseError (EnvironmentError address))) sig
+            , Member (Resumable (BaseError EvalError)) sig
+            , Member (Resumable (BaseError ResolutionError)) sig
+            , Member (Resumable (BaseError (UnspecializedError value))) sig
+            , Member (State (Heap address value)) sig
+            , Member Trace sig
             , Ord address
             , Recursive term
-            , moduleEffects ~ ModuleEffects address value effects
-            , valueEffects ~ ValueEffects term address value moduleEffects
+            , moduleC ~ ModuleC address value c
+            , valueC ~ ValueC term address value moduleC
             )
          => proxy lang
-         -> Open (Module term -> Evaluator term address value moduleEffects address)
-         -> Open (Open (term -> Evaluator term address value valueEffects (ValueRef address)))
-         -> (forall x . Evaluator term address value (Deref value ': Allocator address ': Reader ModuleInfo ': effects) x -> Evaluator term address value (Reader ModuleInfo ': effects) x)
-         -> (forall x . (term -> Evaluator term address value valueEffects address) -> Evaluator term address value valueEffects x -> Evaluator term address value moduleEffects x)
+         -> Open (Module term -> Evaluator term address value moduleC address)
+         -> Open (Open (term -> Evaluator term address value valueC (ValueRef address)))
          -> [Module term]
-         -> Evaluator term address value effects (ModuleTable (NonEmpty (Module (ModuleResult address))))
-evaluate lang analyzeModule analyzeTerm runAllocDeref runValue modules = do
-  (_, (preludeBinds, _)) <- runInModule lowerBound moduleInfoFromCallStack . runValue evalTerm $ do
+         -> Evaluator term address value c (ModuleTable (NonEmpty (Module (ModuleResult address))))
+evaluate lang analyzeModule analyzeTerm modules = do
+  (_, (preludeBinds, _)) <- runInModule lowerBound moduleInfoFromCallStack . runValue $ do
     definePrelude lang
     box unit
   foldr (run preludeBinds) ask modules
   where run preludeBinds m rest = do
-          evaluated <- coerce
-            (runInModule preludeBinds (moduleInfo m))
+          evaluated <- runInModule preludeBinds (moduleInfo m)
             (analyzeModule (evalModuleBody . moduleBody)
             m)
           -- FIXME: this should be some sort of Monoidal insert à la the Heap to accommodate multiple Go files being part of the same module.
           local (ModuleTable.insert (modulePath (moduleInfo m)) ((evaluated <$ m) :| [])) rest
 
-        evalModuleBody term = runValue evalTerm (do
+        evalModuleBody term = runValue (do
           result <- evalTerm term
           result <$ postlude lang)
 
         evalTerm = fix (analyzeTerm ((. project) . eval)) >=> address
 
+        runValue = runBoolean . runWhile . runFunction evalTerm
+
         runInModule preludeBinds info
-          = runReader info
-          . runAllocDeref
+          = raiseHandler (runReader info)
+          . runAllocator
+          . runDeref
           . runScopeEnv
           . runEnv (EvalContext Nothing (X.push (newEnv preludeBinds)))
           . runReturn
           . runLoopControl
+          . raiseHandler runInterpose
+          . raiseHandler runEavesdrop
 
 
-traceResolve :: (Show a, Show b, Member Trace effects) => a -> b -> Evaluator term address value effects ()
+traceResolve :: (Show a, Show b, Member Trace sig, Carrier sig m) => a -> b -> Evaluator term address value m ()
 traceResolve name path = trace ("resolved " <> show name <> " -> " <> show path)
 
 
 -- Preludes
 
 class HasPrelude (language :: Language) where
-  definePrelude :: ( AbstractValue term address value effects
+  definePrelude :: ( AbstractValue term address value m
+                   , Carrier sig m
                    , HasCallStack
-                   , Member (Allocator address) effects
-                   , Member (Deref value) effects
-                   , Member (Env address) effects
-                   , Member Fresh effects
-                   , Member (Function term address value) effects
-                   , Member (Reader ModuleInfo) effects
-                   , Member (Reader Span) effects
-                   , Member (Resumable (BaseError (AddressError address value))) effects
-                   , Member (Resumable (BaseError (EnvironmentError address))) effects
-                   , Member (State (Heap address value)) effects
-                   , Member Trace effects
+                   , Member (Allocator address) sig
+                   , Member (Deref value) sig
+                   , Member (Env address) sig
+                   , Member Fresh sig
+                   , Member (Function term address value) sig
+                   , Member (Reader ModuleInfo) sig
+                   , Member (Reader Span) sig
+                   , Member (Resumable (BaseError (AddressError address value))) sig
+                   , Member (Resumable (BaseError (EnvironmentError address))) sig
+                   , Member (State (Heap address value)) sig
+                   , Member Trace sig
                    , Ord address
                    )
                 => proxy language
-                -> Evaluator term address value effects ()
+                -> Evaluator term address value m ()
   definePrelude _ = pure ()
 
 instance HasPrelude 'Go
@@ -215,19 +232,20 @@ instance HasPrelude 'JavaScript where
 -- Postludes
 
 class HasPostlude (language :: Language) where
-  postlude :: ( AbstractValue term address value effects
+  postlude :: ( AbstractValue term address value m
+              , Carrier sig m
               , HasCallStack
-              , Member (Allocator address) effects
-              , Member (Deref value) effects
-              , Member (Env address) effects
-              , Member Fresh effects
-              , Member (Reader ModuleInfo) effects
-              , Member (Reader Span) effects
-              , Member (Resumable (BaseError (EnvironmentError address))) effects
-              , Member Trace effects
+              , Member (Allocator address) sig
+              , Member (Deref value) sig
+              , Member (Env address) sig
+              , Member Fresh sig
+              , Member (Reader ModuleInfo) sig
+              , Member (Reader Span) sig
+              , Member (Resumable (BaseError (EnvironmentError address))) sig
+              , Member Trace sig
               )
            => proxy language
-           -> Evaluator term address value effects ()
+           -> Evaluator term address value m ()
   postlude _ = pure ()
 
 instance HasPostlude 'Go
@@ -281,18 +299,19 @@ instance Eq1 EvalError where
 instance Show1 EvalError where
   liftShowsPrec _ _ = showsPrec
 
-runEvalError :: Effects effects => Evaluator term address value (Resumable (BaseError EvalError) ': effects) a -> Evaluator term address value effects (Either (SomeExc (BaseError EvalError)) a)
-runEvalError = runResumable
+runEvalError :: (Carrier sig m, Effect sig) => Evaluator term address value (ResumableC (BaseError EvalError) (Eff m)) a -> Evaluator term address value m (Either (SomeError (BaseError EvalError)) a)
+runEvalError = raiseHandler runResumable
 
-runEvalErrorWith :: Effects effects => (forall resume . (BaseError EvalError) resume -> Evaluator term address value effects resume) -> Evaluator term address value (Resumable (BaseError EvalError) ': effects) a -> Evaluator term address value effects a
-runEvalErrorWith = runResumableWith
+runEvalErrorWith :: Carrier sig m => (forall resume . (BaseError EvalError) resume -> Evaluator term address value m resume) -> Evaluator term address value (ResumableWithC (BaseError EvalError) (Eff m)) a -> Evaluator term address value m a
+runEvalErrorWith f = raiseHandler $ runResumableWith (runEvaluator . f)
 
-throwEvalError :: ( Member (Reader ModuleInfo) effects
-                  , Member (Reader Span) effects
-                  , Member (Resumable (BaseError EvalError)) effects
+throwEvalError :: ( Member (Reader ModuleInfo) sig
+                  , Member (Reader Span) sig
+                  , Member (Resumable (BaseError EvalError)) sig
+                  , Carrier sig m
                   )
                => EvalError resume
-               -> Evaluator term address value effects resume
+               -> Evaluator term address value m resume
 throwEvalError = throwBaseError
 
 
@@ -315,23 +334,25 @@ instance Eq1 (UnspecializedError a) where
 instance Show1 (UnspecializedError a) where
   liftShowsPrec _ _ = showsPrec
 
-runUnspecialized :: Effects effects
-                 => Evaluator term address value (Resumable (BaseError (UnspecializedError value)) ': effects) a
-                 -> Evaluator term address value effects (Either (SomeExc (BaseError (UnspecializedError value))) a)
-runUnspecialized = runResumable
+runUnspecialized :: (Carrier sig m, Effect sig)
+                 => Evaluator term address value (ResumableC (BaseError (UnspecializedError value)) (Eff m)) a
+                 -> Evaluator term address value m (Either (SomeError (BaseError (UnspecializedError value))) a)
+runUnspecialized = raiseHandler runResumable
 
-runUnspecializedWith :: Effects effects
-                     => (forall resume . BaseError (UnspecializedError value) resume -> Evaluator term address value effects resume)
-                     -> Evaluator term address value (Resumable (BaseError (UnspecializedError value)) ': effects) a
-                     -> Evaluator term address value effects a
-runUnspecializedWith = runResumableWith
+runUnspecializedWith :: Carrier sig m
+                     => (forall resume . BaseError (UnspecializedError value) resume -> Evaluator term address value m resume)
+                     -> Evaluator term address value (ResumableWithC (BaseError (UnspecializedError value)) (Eff m)) a
+                     -> Evaluator term address value m a
+runUnspecializedWith f = raiseHandler $ runResumableWith (runEvaluator . f)
 
-throwUnspecializedError :: ( Member (Resumable (BaseError (UnspecializedError value))) effects
-                           , Member (Reader ModuleInfo) effects
-                           , Member (Reader Span) effects
+
+throwUnspecializedError :: ( Member (Resumable (BaseError (UnspecializedError value))) sig
+                           , Member (Reader ModuleInfo) sig
+                           , Member (Reader Span) sig
+                           , Carrier sig m
                            )
                         => UnspecializedError value resume
-                        -> Evaluator term address value effects resume
+                        -> Evaluator term address value m resume
 throwUnspecializedError = throwBaseError
 
 

src/Data/Abstract/Name.hs

@@ -8,8 +8,8 @@ module Data.Abstract.Name
 , formatName
 ) where
 
-import           Control.Monad.Effect
-import           Control.Monad.Effect.Fresh
+import           Control.Effect
+import           Control.Effect.Fresh
 import           Data.Aeson
 import qualified Data.Char as Char
 import           Data.Text (Text)
@@ -36,7 +36,7 @@ instance Primitive Name where
   primType _ = Bytes
 
 -- | Generate a fresh (unused) name for use in synthesized variables/closures/etc.
-gensym :: (Functor (m effs), Member Fresh effs, Effectful m) => m effs Name
+gensym :: (Member Fresh sig, Carrier sig m, Functor m) => m Name
 gensym = I <$> fresh
 
 -- | Construct a 'Name' from a '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
@@ -15,65 +17,55 @@ data Abstract = Abstract
   deriving (Eq, Ord, Show)
 
 
-runFunction :: ( Member (Allocator address) effects
-               , Member (Deref Abstract) effects
-               , Member (Env address) effects
-               , Member (Exc (Return address)) effects
-               , Member Fresh effects
-               , Member (Reader ModuleInfo) effects
-               , Member (Reader Span) effects
-               , Member (Resumable (BaseError (AddressError address Abstract))) effects
-               , Member (State (Heap address Abstract)) effects
-               , Ord address
-               , PureEffects effects
-               )
-            => (term -> Evaluator term address Abstract (Abstract.Function term address Abstract ': effects) address)
-            -> Evaluator term address Abstract (Function term address Abstract ': effects) a
-            -> Evaluator term address Abstract effects a
-runFunction eval = interpret $ \case
-  Function _ params body -> do
-    env <- foldr (\ name rest -> do
-      addr <- alloc name
-      assign addr Abstract
-      Env.insert name addr <$> rest) (pure lowerBound) params
-    addr <- locally (bindAll env *> catchReturn (runFunction eval (eval body)))
-    deref addr
-  BuiltIn _ -> pure Abstract
-  Call _ _ params -> do
-    traverse_ deref params
-    box Abstract
+instance ( Member (Allocator address) sig
+         , Member (Deref Abstract) sig
+         , Member (Env address) sig
+         , Member (Error (Return address)) sig
+         , Member Fresh sig
+         , Member (Reader ModuleInfo) sig
+         , Member (Reader Span) sig
+         , Member (Resumable (BaseError (AddressError address Abstract))) sig
+         , Member (State (Heap address Abstract)) sig
+         , Ord address
+         , Carrier sig m
+         )
+      => Carrier (Abstract.Function term address Abstract :+: sig) (FunctionC term address Abstract (Eff m)) where
+  ret = FunctionC . const . ret
+  eff op = FunctionC (\ eval -> (alg eval \/ eff . handleReader eval runFunctionC) op)
+    where alg eval = \case
+            Function _ params body k -> runEvaluator $ do
+              env <- foldr (\ name rest -> do
+                addr <- alloc name
+                assign addr Abstract
+                Env.insert name addr <$> rest) (pure lowerBound) params
+              addr <- locally (bindAll env *> catchReturn (runFunction (Evaluator . eval) (Evaluator (eval body))))
+              deref addr >>= Evaluator . flip runFunctionC eval . k
+            BuiltIn _ k -> runFunctionC (k Abstract) eval
+            Call _ _ params k -> runEvaluator $ do
+              traverse_ deref params
+              box Abstract >>= Evaluator . flip runFunctionC eval . k
 
-runBoolean :: ( Member NonDet effects
-              , PureEffects effects
-              )
-           => Evaluator term address Abstract (Boolean Abstract ': effects) a
-           -> Evaluator term address Abstract effects a
-runBoolean = interpret $ \case
-  Boolean _       -> pure Abstract
-  AsBool  _       -> pure True <|> pure False
-  Disjunction a b -> runBoolean (Evaluator (a <|> b))
 
-runWhile ::
-  ( Member (Allocator address) effects
-  , Member (Deref Abstract) effects
-  , Member (Abstract.Boolean Abstract) effects
-  , Member NonDet effects
-  , Member (Env address) effects
-  , Member (Exc (Return address)) effects
-  , Member Fresh effects
-  , Member (Reader ModuleInfo) effects
-  , Member (Reader Span) effects
-  , Member (Resumable (BaseError (AddressError address Abstract))) effects
-  , Member (State (Heap address Abstract)) effects
-  , Ord address
-  , PureEffects effects
-  )
-  => Evaluator term address Abstract (While Abstract ': effects) a
-  -> Evaluator term address Abstract effects a
-runWhile = interpret $ \case
-  Abstract.While cond body -> do
-    cond' <- runWhile (raiseEff cond)
-    ifthenelse cond' (runWhile (raiseEff body) *> empty) (pure unit)
+instance (Carrier sig m, Alternative m, Monad m) => Carrier (Boolean Abstract :+: sig) (BooleanC Abstract m) where
+  ret = BooleanC . ret
+  eff = BooleanC . (alg \/ eff . handleCoercible)
+    where alg (Boolean _ k) = runBooleanC (k Abstract)
+          alg (AsBool _ k) = runBooleanC (k True) <|> runBooleanC (k False)
+          alg (Disjunction a b k) = (runBooleanC a <|> runBooleanC b) >>= runBooleanC . k
+
+
+instance ( Member (Abstract.Boolean Abstract) sig
+         , Carrier sig m
+         , Alternative m
+         , Monad m
+         )
+      => Carrier (While Abstract :+: sig) (WhileC Abstract m) where
+  ret = WhileC . ret
+  eff = WhileC . (alg \/ eff . handleCoercible)
+    where alg (Abstract.While cond body k) = do
+            cond' <- runWhileC cond
+            ifthenelse cond' (runWhileC body *> empty) (runWhileC (k unit))
+
 
 instance Ord address => ValueRoots address Abstract where
   valueRoots = mempty
@@ -93,13 +85,14 @@ instance AbstractIntro Abstract where
   kvPair _ _ = Abstract
   null       = Abstract
 
-instance ( Member (Allocator address) effects
-         , Member (Deref Abstract) effects
-         , Member Fresh effects
-         , Member (State (Heap address Abstract)) effects
+instance ( Member (Allocator address) sig
+         , Member (Deref Abstract) sig
+         , Member Fresh sig
+         , Member (State (Heap address Abstract)) sig
          , Ord address
+         , Carrier sig m
          )
-      => AbstractValue term address Abstract effects where
+      => AbstractValue term address Abstract m where
   array _ = pure Abstract
 
   tuple _ = pure Abstract

src/Data/Abstract/Value/Concrete.hs

@@ -2,9 +2,6 @@
 module Data.Abstract.Value.Concrete
   ( Value (..)
   , ValueError (..)
-  , runFunction
-  , runBoolean
-  , runWhile
   , materializeEnvironment
   , runValueError
   , runValueErrorWith
@@ -12,6 +9,9 @@ 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.Interpose
+import Control.Effect.Sum
 import Data.Abstract.BaseError
 import Data.Abstract.Evaluatable (UnspecializedError(..))
 import Data.Abstract.Environment (Environment, Bindings, EvalContext(..))
@@ -26,7 +26,7 @@ import Data.Scientific.Exts
 import qualified Data.Set as Set
 import Data.Text (pack)
 import Data.Word
-import Prologue hiding (catchError)
+import Prologue
 
 data Value term address
   = Closure PackageInfo ModuleInfo (Maybe Name) [Name] (Either BuiltIn term) (Environment address)
@@ -55,103 +55,111 @@ instance Ord address => ValueRoots address (Value term address) where
     | otherwise                  = mempty
 
 
-runFunction :: ( FreeVariables term
-               , Member (Allocator address) effects
-               , Member (Deref (Value term address)) effects
-               , Member (Env address) effects
-               , Member (Exc (Return address)) effects
-               , Member Fresh effects
-               , Member (Reader ModuleInfo) effects
-               , Member (Reader PackageInfo) effects
-               , Member (Reader Span) effects
-               , Member (Resumable (BaseError (AddressError address (Value term address)))) effects
-               , Member (Resumable (BaseError (ValueError term address))) effects
-               , Member (State (Heap address (Value term address))) effects
-               , Member Trace effects
-               , Ord address
-               , PureEffects effects
-               , Show address
-               , Show term
-               )
-            => (term -> Evaluator term address (Value term address) (Abstract.Function term address (Value term address) ': effects) address)
-            -> Evaluator term address (Value term address) (Abstract.Function term address (Value term address) ': effects) a
-            -> Evaluator term address (Value term address) effects a
-runFunction eval = interpret $ \case
-  Abstract.Function name params body -> do
-    packageInfo <- currentPackage
-    moduleInfo <- currentModule
-    Closure packageInfo moduleInfo name params (Right body) <$> close (foldr Set.delete (freeVariables body) params)
-  Abstract.BuiltIn builtIn -> do
-    packageInfo <- currentPackage
-    moduleInfo <- currentModule
-    pure (Closure packageInfo moduleInfo Nothing [] (Left builtIn) lowerBound)
-  Abstract.Call op self params -> do
-    case op of
-      Closure _ _ _ _ (Left Print) _ -> traverse (deref >=> trace . show) params *> box Unit
-      Closure _ _ _ _ (Left Show) _ -> deref self >>= box . String . pack . show
-      Closure packageInfo moduleInfo _ names (Right body) env -> do
-        -- Evaluate the bindings and body with the closure’s package/module info in scope in order to
-        -- charge them to the closure's origin.
-        withCurrentPackage packageInfo . withCurrentModule moduleInfo $ do
-          bindings <- foldr (\ (name, addr) rest -> Env.insert name addr <$> rest) (pure lowerBound) (zip names params)
-          let fnCtx = EvalContext (Just self) (Env.push env)
-          withEvalContext fnCtx (catchReturn (bindAll bindings *> runFunction eval (eval body)))
-      _ -> throwValueError (CallError op) >>= box
-
-runBoolean :: ( Member (Reader ModuleInfo) effects
-              , Member (Reader Span) effects
-              , Member (Resumable (BaseError (ValueError term address))) effects
-              , PureEffects effects
-              )
-           => Evaluator term address (Value term address) (Abstract.Boolean (Value term address) ': effects) a
-           -> Evaluator term address (Value term address) effects a
-runBoolean = interpret $ \case
-  Abstract.Boolean b          -> pure $! Boolean b
-  Abstract.AsBool (Boolean b) -> pure b
-  Abstract.AsBool other       -> throwValueError $! BoolError other
-  Abstract.Disjunction a b    -> do
-    a' <- runBoolean (Evaluator a)
-    a'' <- runBoolean (asBool a')
-    if a'' then pure a' else runBoolean (Evaluator b)
+instance ( FreeVariables term
+         , Member (Allocator address) sig
+         , Member (Deref (Value term address)) sig
+         , Member (Env address) sig
+         , Member (Error (Return address)) sig
+         , Member Fresh sig
+         , Member (Reader ModuleInfo) sig
+         , Member (Reader PackageInfo) sig
+         , Member (Reader Span) sig
+         , Member (Resumable (BaseError (AddressError address (Value term address)))) sig
+         , Member (Resumable (BaseError (ValueError term address))) sig
+         , Member (State (Heap address (Value term address))) sig
+         , Member Trace sig
+         , Ord address
+         , Carrier sig m
+         , Show address
+         , Show term
+         )
+      => Carrier (Abstract.Function term address (Value term address) :+: sig) (Abstract.FunctionC term address (Value term address) (Eff m)) where
+  ret = FunctionC . const . ret
+  eff op = FunctionC (\ eval -> (alg eval \/ eff . handleReader eval runFunctionC) op)
+    where alg eval = \case
+            Abstract.Function name params body k -> runEvaluator $ do
+              packageInfo <- currentPackage
+              moduleInfo <- currentModule
+              Closure packageInfo moduleInfo name params (Right body) <$> close (foldr Set.delete (freeVariables body) params) >>= Evaluator . flip runFunctionC eval . k
+            Abstract.BuiltIn builtIn k -> do
+              packageInfo <- currentPackage
+              moduleInfo <- currentModule
+              runFunctionC (k (Closure packageInfo moduleInfo Nothing [] (Left builtIn) lowerBound)) eval
+            Abstract.Call op self params k -> runEvaluator $ do
+              boxed <- case op of
+                Closure _ _ _ _ (Left Print) _ -> traverse (deref >=> trace . show) params *> box Unit
+                Closure _ _ _ _ (Left Show) _ -> deref self >>= box . String . pack . show
+                Closure packageInfo moduleInfo _ names (Right body) env -> do
+                  -- Evaluate the bindings and body with the closure’s package/module info in scope in order to
+                  -- charge them to the closure's origin.
+                  withCurrentPackage packageInfo . withCurrentModule moduleInfo $ do
+                    bindings <- foldr (\ (name, addr) rest -> Env.insert name addr <$> rest) (pure lowerBound) (zip names params)
+                    let fnCtx = EvalContext (Just self) (Env.push env)
+                    withEvalContext fnCtx (catchReturn (bindAll bindings *> runFunction (Evaluator . eval) (Evaluator (eval body))))
+                _ -> throwValueError (CallError op) >>= box
+              Evaluator $ runFunctionC (k boxed) eval
 
 
-runWhile :: forall effects term address a .
-  ( PureEffects effects
-  , Member (Deref (Value term address)) effects
-  , Member (Abstract.Boolean (Value term address)) effects
-  , Member (Exc (LoopControl address)) effects
-  , Member (Reader ModuleInfo) effects
-  , Member (Reader Span) effects
-  , Member (Resumable (BaseError (AddressError address (Value term address)))) effects
-  , Member (Resumable (BaseError (ValueError term address))) effects
-  , Member (Resumable (BaseError (UnspecializedError (Value term address)))) effects
-  , Member (State (Heap address (Value term address))) effects
-  , Ord address
-  , Show address
-  , Show term
-  )
-  => Evaluator term address (Value term address) (Abstract.While (Value term address) ': effects) a
-  -> Evaluator term address (Value term address) effects a
-runWhile = interpret $ \case
-  Abstract.While cond body -> loop $ \continue -> do
-    cond' <- runWhile (raiseEff cond)
+instance ( Member (Reader ModuleInfo) sig
+         , Member (Reader Span) sig
+         , Member (Resumable (BaseError (ValueError term address))) sig
+         , Carrier sig m
+         , Monad m
+         )
+      => Carrier (Abstract.Boolean (Value term address) :+: sig) (BooleanC (Value term address) m) where
+  ret = BooleanC . ret
+  eff = BooleanC . (alg \/ eff . handleCoercible)
+    where alg :: Abstract.Boolean (Value term address) (BooleanC (Value term address) m) (BooleanC (Value term address) m a) -> m a
+          alg = \case
+            Abstract.Boolean b          k -> runBooleanC . k $! Boolean b
+            Abstract.AsBool (Boolean b) k -> runBooleanC (k b)
+            Abstract.AsBool other       k -> throwBaseError (BoolError other) >>= runBooleanC . k
+            Abstract.Disjunction a b    k -> do
+              a' <- runBooleanC a
+              a'' <- case a' of
+                Boolean b -> pure b
+                other     -> throwBaseError (BoolError other)
+              if a'' then
+                runBooleanC (k a')
+              else
+                runBooleanC b >>= runBooleanC . k
 
-    -- `interpose` is used to handle 'UnspecializedError's and abort out of the
-    -- loop, otherwise under concrete semantics we run the risk of the
-    -- conditional always being true and getting stuck in an infinite loop.
-    let body' = interpose @(Resumable (BaseError (UnspecializedError (Value term address))))
-          (\(Resumable (BaseError _ _ (UnspecializedError _))) -> throwAbort) $
-          runWhile (raiseEff body) *> continue
 
-    ifthenelse cond' body' (pure unit)
-  where
-    loop x = catchLoopControl (fix x) (\ control -> case control of
-      Break value -> deref value
-      Abort -> pure unit
-      -- FIXME: Figure out how to deal with this. Ruby treats this as the result
-      -- of the current block iteration, while PHP specifies a breakout level
-      -- and TypeScript appears to take a label.
-      Continue _  -> loop x)
+instance ( Carrier sig m
+         , Member (Deref (Value term address)) sig
+         , Member (Abstract.Boolean (Value term address)) sig
+         , Member (Error (LoopControl address)) sig
+         , Member (Interpose (Resumable (BaseError (UnspecializedError (Value term address))))) sig
+         , Member (Reader ModuleInfo) sig
+         , Member (Reader Span) sig
+         , Member (Resumable (BaseError (AddressError address (Value term address)))) sig
+         , Member (State (Heap address (Value term address))) sig
+         , Ord address
+         , Show address
+         , Show term
+         )
+      => Carrier (Abstract.While (Value term address) :+: sig) (WhileC (Value term address) (Eff m)) where
+  ret = WhileC . ret
+  eff = WhileC . (alg \/ eff . handleCoercible)
+    where alg = \case
+            Abstract.While cond body k -> interpose @(Resumable (BaseError (UnspecializedError (Value term address)))) (runEvaluator (loop (\continue -> do
+              cond' <- Evaluator (runWhileC cond)
+
+              -- `interpose` is used to handle 'UnspecializedError's and abort out of the
+              -- loop, otherwise under concrete semantics we run the risk of the
+              -- conditional always being true and getting stuck in an infinite loop.
+
+              ifthenelse cond' (Evaluator (runWhileC body) *> continue) (pure Unit))))
+              (\(Resumable (BaseError _ _ (UnspecializedError _)) _) -> throwError (Abort @address))
+                >>= runWhileC . k
+            where
+              loop x = catchLoopControl @address (fix x) $ \case
+                Break value -> deref value
+                Abort -> pure unit
+                -- FIXME: Figure out how to deal with this. Ruby treats this as the result
+                -- of the current block iteration, while PHP specifies a breakout level
+                -- and TypeScript appears to take a label.
+                Continue _  -> loop x
 
 
 instance AbstractHole (Value term address) where
@@ -171,15 +179,16 @@ instance (Show address, Show term) => AbstractIntro (Value term address) where
 
   null     = Null
 
-materializeEnvironment :: ( Member (Deref (Value term address)) effects
-                          , Member (Reader ModuleInfo) effects
-                          , Member (Reader Span) effects
-                          , Member (Resumable (BaseError (AddressError address (Value term address)))) effects
-                          , Member (State (Heap address (Value term address))) effects
+materializeEnvironment :: ( Member (Deref (Value term address)) sig
+                          , Member (Reader ModuleInfo) sig
+                          , Member (Reader Span) sig
+                          , Member (Resumable (BaseError (AddressError address (Value term address)))) sig
+                          , Member (State (Heap address (Value term address))) sig
                           , Ord address
+                          , Carrier sig m
                           )
                        => Value term address
-                       -> Evaluator term address (Value term address) effects (Maybe (Environment address))
+                       -> Evaluator term address (Value term address) m (Maybe (Environment address))
 materializeEnvironment val = do
   ancestors <- rec val
   pure (Env.Environment <$> nonEmpty ancestors)
@@ -199,25 +208,26 @@ materializeEnvironment val = do
         _ -> []
 
 -- | Construct a 'Value' wrapping the value arguments (if any).
-instance ( Member (Allocator address) effects
-         , Member (Abstract.Boolean (Value term address)) effects
-         , Member (Deref (Value term address)) effects
-         , Member (Env address) effects
-         , Member (Exc (LoopControl address)) effects
-         , Member (Exc (Return address)) effects
-         , Member Fresh effects
-         , Member (Reader ModuleInfo) effects
-         , Member (Reader PackageInfo) effects
-         , Member (Reader Span) effects
-         , Member (Resumable (BaseError (ValueError term address))) effects
-         , Member (Resumable (BaseError (AddressError address (Value term address)))) effects
-         , Member (State (Heap address (Value term address))) effects
-         , Member Trace effects
+instance ( Member (Allocator address) sig
+         , Member (Abstract.Boolean (Value term address)) sig
+         , Member (Deref (Value term address)) sig
+         , Member (Env address) sig
+         , Member (Error (LoopControl address)) sig
+         , Member (Error (Return address)) sig
+         , Member Fresh sig
+         , Member (Reader ModuleInfo) sig
+         , Member (Reader PackageInfo) sig
+         , Member (Reader Span) sig
+         , Member (Resumable (BaseError (ValueError term address))) sig
+         , Member (Resumable (BaseError (AddressError address (Value term address)))) sig
+         , Member (State (Heap address (Value term address))) sig
+         , Member Trace sig
          , Ord address
          , Show address
          , Show term
+         , Carrier sig m
          )
-      => AbstractValue term address (Value term address) effects where
+      => AbstractValue term address (Value term address) m where
   asPair val
     | KVPair k v <- val = pure (k, v)
     | otherwise = throwValueError $ KeyValueError val
@@ -282,10 +292,9 @@ instance ( Member (Allocator address) effects
         tentative x i j = attemptUnsafeArithmetic (x i j)
 
         -- Dispatch whatever's contained inside a 'Number.SomeNumber' to its appropriate 'MonadValue' ctor
-        specialize :: ( AbstractValue term address (Value term address) effects
-                      )
+        specialize :: AbstractValue term address (Value term address) m
                    => Either ArithException Number.SomeNumber
-                   -> Evaluator term address (Value term address) effects (Value term address)
+                   -> Evaluator term address (Value term address) m (Value term address)
         specialize (Left exc) = throwValueError (ArithmeticError exc)
         specialize (Right (Number.SomeNumber (Number.Integer i))) = pure $ integer i
         specialize (Right (Number.SomeNumber (Number.Ratio r)))   = pure $ rational r
@@ -304,7 +313,7 @@ instance ( Member (Allocator address) effects
       where
         -- Explicit type signature is necessary here because we're passing all sorts of things
         -- to these comparison functions.
-        go :: (AbstractValue term address (Value term address) effects, Ord a) => a -> a -> Evaluator term address (Value term address) effects (Value term address)
+        go :: (AbstractValue term address (Value term address) m, Ord a) => a -> a -> Evaluator term address (Value term address) m (Value term address)
         go l r = case comparator of
           Concrete f  -> boolean (f l r)
           Generalized -> pure $ integer (orderingToInt (compare l r))
@@ -395,21 +404,22 @@ deriving instance (Show address, Show term) => Show (ValueError term address res
 instance (Show address, Show term) => Show1 (ValueError term address) where
   liftShowsPrec _ _ = showsPrec
 
-runValueError :: Effects effects
-              => Evaluator term address (Value term address) (Resumable (BaseError (ValueError term address)) ': effects) a
-              -> Evaluator term address (Value term address) effects (Either (SomeExc (BaseError (ValueError term address))) a)
-runValueError = runResumable
+runValueError :: (Carrier sig m, Effect sig)
+              => Evaluator term address (Value term address) (ResumableC (BaseError (ValueError term address)) (Eff m)) a
+              -> Evaluator term address (Value term address) m (Either (SomeError (BaseError (ValueError term address))) a)
+runValueError = Evaluator . runResumable . runEvaluator
 
-runValueErrorWith :: Effects effects
-                  => (forall resume . BaseError (ValueError term address) resume -> Evaluator term address (Value term address) effects resume)
-                  -> Evaluator term address (Value term address) (Resumable (BaseError (ValueError term address)) ': effects) a
-                  -> Evaluator term address (Value term address) effects a
-runValueErrorWith = runResumableWith
+runValueErrorWith :: Carrier sig m
+                  => (forall resume . BaseError (ValueError term address) resume -> Evaluator term address (Value term address) m resume)
+                  -> Evaluator term address (Value term address) (ResumableWithC (BaseError (ValueError term address)) (Eff m)) a
+                  -> Evaluator term address (Value term address) m a
+runValueErrorWith f = Evaluator . runResumableWith (runEvaluator . f) . runEvaluator
 
-throwValueError :: ( Member (Resumable (BaseError (ValueError term address))) effects
-                   , Member (Reader ModuleInfo) effects
-                   , Member (Reader Span) effects
+throwValueError :: ( Member (Resumable (BaseError (ValueError term address))) sig
+                   , Member (Reader ModuleInfo) sig
+                   , Member (Reader Span) sig
+                   , Carrier sig m
                    )
                 => ValueError term address resume
-                -> Evaluator term address (Value term address) effects resume
+                -> Evaluator term address (Value term address) m resume
 throwValueError = throwBaseError

src/Data/Abstract/Value/Type.hs

@@ -13,7 +13,8 @@ module Data.Abstract.Value.Type
 
 import qualified Control.Abstract as Abstract
 import Control.Abstract hiding (Boolean(..), Function(..), While(..))
-import Control.Monad.Effect.Internal (raiseHandler)
+import Control.Effect.Carrier
+import Control.Effect.Sum
 import Data.Abstract.Environment as Env
 import Data.Abstract.BaseError
 import Data.Semigroup.Foldable (foldMap1)
@@ -87,40 +88,41 @@ instance Ord1  TypeError where
 
 instance Show1 TypeError where liftShowsPrec _ _ = showsPrec
 
-runTypeError :: (Effectful m, Effects effects) => m (Resumable (BaseError TypeError) ': effects) a -> m effects (Either (SomeExc (BaseError TypeError)) a)
-runTypeError = runResumable
+runTypeError :: (Carrier sig m, Effect sig) => Evaluator term address value (ResumableC (BaseError TypeError) (Eff m)) a -> Evaluator term address value m (Either (SomeError (BaseError TypeError)) a)
+runTypeError = raiseHandler runResumable
 
-runTypeErrorWith :: (Effectful m, Effects effects) => (forall resume . (BaseError TypeError) resume -> m effects resume) -> m (Resumable (BaseError TypeError) ': effects) a -> m effects a
-runTypeErrorWith = runResumableWith
+runTypeErrorWith :: Carrier sig m => (forall resume . (BaseError TypeError) resume -> Evaluator term address value m resume) -> Evaluator term address value (ResumableWithC (BaseError TypeError) (Eff m)) a -> Evaluator term address value m a
+runTypeErrorWith f = raiseHandler $ runResumableWith (runEvaluator . f)
 
-throwTypeError :: ( Member (Resumable (BaseError TypeError)) effects
-                  , Member (Reader ModuleInfo) effects
-                  , Member (Reader Span) effects
+
+throwTypeError :: ( Member (Resumable (BaseError TypeError)) sig
+                  , Member (Reader ModuleInfo) sig
+                  , Member (Reader Span) sig
+                  , Carrier sig m
+                  , Monad m
                   )
                => TypeError resume
-               -> Evaluator term address value effects resume
+               -> m resume
 throwTypeError = throwBaseError
 
-runTypeMap :: ( Effectful m
-              , Effects effects
-              )
-           => m (State TypeMap ': effects) a
-           -> m effects a
-runTypeMap = raiseHandler (runState emptyTypeMap >=> pure . snd)
+runTypeMap :: (Carrier sig m, Effect sig)
+           => Evaluator term address Type (StateC TypeMap (Eff m)) a
+           -> Evaluator term address Type m a
+runTypeMap = raiseHandler $ fmap snd . runState emptyTypeMap
 
-runTypes :: ( Effectful m
-            , Effects effects
-            )
-         => m (Resumable (BaseError TypeError) ': State TypeMap ': effects) a
-         -> m effects (Either (SomeExc (BaseError TypeError)) a)
+runTypes :: (Carrier sig m, Effect sig)
+         => Evaluator term address Type (ResumableC (BaseError TypeError) (Eff
+                                        (StateC TypeMap (Eff
+                                        m)))) a
+         -> Evaluator term address Type m (Either (SomeError (BaseError TypeError)) a)
 runTypes = runTypeMap . runTypeError
 
-runTypesWith :: ( Effectful m
-                , Effects effects
-                )
-             => (forall resume . (BaseError TypeError) resume -> m (State TypeMap ': effects) resume)
-             -> m (Resumable (BaseError TypeError) ': State TypeMap ': effects) a
-             -> m effects a
+runTypesWith :: (Carrier sig m, Effect sig)
+             => (forall resume . (BaseError TypeError) resume -> Evaluator term address Type (StateC TypeMap (Eff m)) resume)
+             -> Evaluator term address Type (ResumableWithC (BaseError TypeError) (Eff
+                                            (StateC TypeMap (Eff
+                                            m)))) a
+             -> Evaluator term address Type m a
 runTypesWith with = runTypeMap . runTypeErrorWith with
 
 -- TODO: change my name?
@@ -129,21 +131,22 @@ newtype TypeMap = TypeMap { unTypeMap :: Map.Map TName Type }
 emptyTypeMap :: TypeMap
 emptyTypeMap = TypeMap Map.empty
 
-modifyTypeMap :: ( Effectful m
-                 , Member (State TypeMap) effects
+modifyTypeMap :: ( Member (State TypeMap) sig
+                 , Carrier sig m
+                 , Monad m
                  )
               => (Map.Map TName Type -> Map.Map TName Type)
-              -> m effects ()
+              -> m ()
 modifyTypeMap f = modify (TypeMap . f . unTypeMap)
 
 -- | Prunes substituted type variables
-prune :: ( Effectful m
-         , Monad (m effects)
-         , Member (State TypeMap) effects
+prune :: ( Member (State TypeMap) sig
+         , Carrier sig m
+         , Monad m
          )
       => Type
-      -> m effects Type
-prune (Var id) = Map.lookup id . unTypeMap <$> get >>= \case
+      -> m Type
+prune (Var id) = gets (Map.lookup id . unTypeMap) >>= \case
                     Just ty -> do
                       pruned <- prune ty
                       modifyTypeMap (Map.insert id pruned)
@@ -153,13 +156,13 @@ prune ty = pure ty
 
 -- | Checks whether a type variable name occurs within another type. This
 --   function is used in 'substitute' to prevent unification of infinite types
-occur :: ( Effectful m
-         , Monad (m effects)
-         , Member (State TypeMap) effects
+occur :: ( Member (State TypeMap) sig
+         , Carrier sig m
+         , Monad m
          )
       => TName
       -> Type
-      -> m effects Bool
+      -> m Bool
 occur id = prune >=> \case
   Int -> pure False
   Bool -> pure False
@@ -184,14 +187,16 @@ occur id = prune >=> \case
     eitherM f (a, b) = (||) <$> f a <*> f b
 
 -- | Substitutes a type variable name for another type
-substitute :: ( Member (Reader ModuleInfo) effects
-              , Member (Reader Span) effects
-              , Member (Resumable (BaseError TypeError)) effects
-              , Member (State TypeMap) effects
+substitute :: ( Member (Reader ModuleInfo) sig
+              , Member (Reader Span) sig
+              , Member (Resumable (BaseError TypeError)) sig
+              , Member (State TypeMap) sig
+              , Carrier sig m
+              , Monad m
               )
            => TName
            -> Type
-           -> Evaluator term address value effects Type
+           -> m Type
 substitute id ty = do
   infiniteType <- occur id ty
   ty <- if infiniteType
@@ -201,14 +206,16 @@ substitute id ty = do
   pure ty
 
 -- | Unify two 'Type's.
-unify :: ( Member (Reader ModuleInfo) effects
-         , Member (Reader Span) effects
-         , Member (Resumable (BaseError TypeError)) effects
-         , Member (State TypeMap) effects
+unify :: ( Member (Reader ModuleInfo) sig
+         , Member (Reader Span) sig
+         , Member (Resumable (BaseError TypeError)) sig
+         , Member (State TypeMap) sig
+         , Carrier sig m
+         , Monad m
          )
       => Type
       -> Type
-      -> Evaluator term address value effects Type
+      -> m Type
 unify a b = do
   a' <- prune a
   b' <- prune b
@@ -230,80 +237,72 @@ instance Ord address => ValueRoots address Type where
   valueRoots _ = mempty
 
 
-runFunction :: ( Member (Allocator address) effects
-               , Member (Deref Type) effects
-               , Member (Env address) effects
-               , Member (Exc (Return address)) effects
-               , Member Fresh effects
-               , Member (Reader ModuleInfo) effects
-               , Member (Reader Span) effects
-               , Member (Resumable (BaseError TypeError)) effects
-               , Member (Resumable (BaseError (AddressError address Type))) effects
-               , Member (State (Heap address Type)) effects
-               , Member (State TypeMap) effects
-               , Ord address
-               , PureEffects effects
-               )
-            => (term -> Evaluator term address Type (Abstract.Function term address Type ': effects) address)
-            -> Evaluator term address Type (Abstract.Function term address Type ': effects) a
-            -> Evaluator term address Type effects a
-runFunction eval = interpret $ \case
-  Abstract.Function _ params body -> do
-    (env, tvars) <- foldr (\ name rest -> do
-      addr <- alloc name
-      tvar <- Var <$> fresh
-      assign addr tvar
-      bimap (Env.insert name addr) (tvar :) <$> rest) (pure (lowerBound, [])) params
-    (zeroOrMoreProduct tvars :->) <$> (locally (catchReturn (bindAll env *> runFunction eval (eval body))) >>= deref)
-  Abstract.BuiltIn Print -> pure (String :-> Unit)
-  Abstract.BuiltIn Show  -> pure (Object :-> String)
-  Abstract.Call op _ params -> do
-    tvar <- fresh
-    paramTypes <- traverse deref params
-    let needed = zeroOrMoreProduct paramTypes :-> Var tvar
-    unified <- op `unify` needed
-    case unified of
-      _ :-> ret -> box ret
-      actual    -> throwTypeError (UnificationError needed actual) >>= box
-
-runBoolean :: ( Member NonDet effects
-              , Member (Reader ModuleInfo) effects
-              , Member (Reader Span) effects
-              , Member (Resumable (BaseError TypeError)) effects
-              , Member (State TypeMap) effects
-              , PureEffects effects
-              )
-           => Evaluator term address Type (Abstract.Boolean Type ': effects) a
-           -> Evaluator term address Type effects a
-runBoolean = interpret $ \case
-  Abstract.Boolean _         -> pure Bool
-  Abstract.AsBool  t         -> unify t Bool *> (pure True <|> pure False)
-  Abstract.Disjunction t1 t2 -> (runBoolean (Evaluator t1) >>= unify Bool) <|> (runBoolean (Evaluator t2) >>= unify Bool)
+instance ( Member (Allocator address) sig
+         , Member (Deref Type) sig
+         , Member (Env address) sig
+         , Member (Error (Return address)) sig
+         , Member Fresh sig
+         , Member (Reader ModuleInfo) sig
+         , Member (Reader Span) sig
+         , Member (Resumable (BaseError TypeError)) sig
+         , Member (Resumable (BaseError (AddressError address Type))) sig
+         , Member (State (Heap address Type)) sig
+         , Member (State TypeMap) sig
+         , Ord address
+         , Carrier sig m
+         )
+      => Carrier (Abstract.Function term address Type :+: sig) (FunctionC term address Type (Eff m)) where
+  ret = FunctionC . const . ret
+  eff op = FunctionC (\ eval -> (alg eval \/ eff . handleReader eval runFunctionC) op)
+    where alg eval = \case
+            Abstract.Function _ params body k -> runEvaluator $ do
+              (env, tvars) <- foldr (\ name rest -> do
+                addr <- alloc name
+                tvar <- Var <$> fresh
+                assign addr tvar
+                bimap (Env.insert name addr) (tvar :) <$> rest) (pure (lowerBound, [])) params
+              locally (catchReturn (bindAll env *> runFunction (Evaluator . eval) (Evaluator (eval body)))) >>= deref >>= Evaluator . flip runFunctionC eval . k . (zeroOrMoreProduct tvars :->)
+            Abstract.BuiltIn Print k -> runFunctionC (k (String :-> Unit)) eval
+            Abstract.BuiltIn Show  k -> runFunctionC (k (Object :-> String)) eval
+            Abstract.Call op _ params k -> runEvaluator $ do
+              tvar <- fresh
+              paramTypes <- traverse deref params
+              let needed = zeroOrMoreProduct paramTypes :-> Var tvar
+              unified <- op `unify` needed
+              boxed <- case unified of
+                _ :-> ret -> box ret
+                actual    -> throwTypeError (UnificationError needed actual) >>= box
+              Evaluator $ runFunctionC (k boxed) eval
 
 
-runWhile ::
-  ( Member (Allocator address) effects
-  , Member (Deref Type) effects
-  , Member (Abstract.Boolean Type) effects
-  , Member NonDet effects
-  , Member (Env address) effects
-  , Member (Exc (Return address)) effects
-  , Member Fresh effects
-  , Member (Reader ModuleInfo) effects
-  , Member (Reader Span) effects
-  , Member (Resumable (BaseError TypeError)) effects
-  , Member (Resumable (BaseError (AddressError address Type))) effects
-  , Member (State (Heap address Type)) effects
-  , Member (State TypeMap) effects
-  , Ord address
-  , PureEffects effects
-  )
-  => Evaluator term address Type (Abstract.While Type ': effects) a
-  -> Evaluator term address Type effects a
-runWhile = interpret $ \case
-  Abstract.While cond body -> do
-    cond' <- runWhile (raiseEff cond)
-    ifthenelse cond' (runWhile (raiseEff body) *> empty) (pure unit)
+instance ( Member (Reader ModuleInfo) sig
+         , Member (Reader Span) sig
+         , Member (Resumable (BaseError TypeError)) sig
+         , Member (State TypeMap) sig
+         , Carrier sig m
+         , Alternative m
+         , Monad m
+         )
+      => Carrier (Abstract.Boolean Type :+: sig) (BooleanC Type m) where
+  ret = BooleanC . ret
+  eff = BooleanC . (alg \/ eff . handleCoercible)
+    where alg (Abstract.Boolean _ k) = runBooleanC (k Bool)
+          alg (Abstract.AsBool t k) = unify t Bool *> (runBooleanC (k True) <|> runBooleanC (k False))
+          alg (Abstract.Disjunction t1 t2 k) = (runBooleanC t1 >>= unify Bool) <|> (runBooleanC t2 >>= unify Bool) >>= runBooleanC . k
+
+
+instance ( Member (Abstract.Boolean Type) sig
+         , Carrier sig m
+         , Alternative m
+         , Monad m
+         )
+      => Carrier (Abstract.While Type :+: sig) (WhileC Type m) where
+  ret = WhileC . ret
+  eff = WhileC . (alg \/ eff . handleCoercible)
+    where alg (Abstract.While cond body k) = do
+            cond' <- runWhileC cond
+            ifthenelse cond' (runWhileC body *> empty) (runWhileC (k unit))
+
 
 instance AbstractHole Type where
   hole = Hole
@@ -322,18 +321,19 @@ instance AbstractIntro Type where
   null        = Null
 
 -- | Discard the value arguments (if any), constructing a 'Type' instead.
-instance ( Member (Allocator address) effects
-         , Member (Deref Type) effects
-         , Member Fresh effects
-         , Member (Reader ModuleInfo) effects
-         , Member (Reader Span) effects
-         , Member (Resumable (BaseError (AddressError address Type))) effects
-         , Member (Resumable (BaseError TypeError)) effects
-         , Member (State (Heap address Type)) effects
-         , Member (State TypeMap) effects
+instance ( Member (Allocator address) sig
+         , Member (Deref Type) sig
+         , Member Fresh sig
+         , Member (Reader ModuleInfo) sig
+         , Member (Reader Span) sig
+         , Member (Resumable (BaseError (AddressError address Type))) sig
+         , Member (Resumable (BaseError TypeError)) sig
+         , Member (State (Heap address Type)) sig
+         , Member (State TypeMap) sig
          , Ord address
+         , Carrier sig m
          )
-      => AbstractValue term address Type effects where
+      => AbstractValue term address Type m where
   array fields = do
     var <- fresh
     fieldTypes <- traverse deref fields

src/Data/Blob.hs

@@ -18,10 +18,10 @@ module Data.Blob
 , pathKeyForBlobPair
 ) where
 
-import Prologue hiding (throwError)
+import Prologue
 
-import           Control.Monad.Effect
-import           Control.Monad.Effect.Exception
+import           Control.Effect
+import           Control.Effect.Error
 import           Data.Aeson
 import qualified Data.ByteString.Lazy as BL
 import           Proto3.Suite
@@ -67,7 +67,7 @@ decodeBlobs = fmap blobs <$> eitherDecode
 newtype NoLanguageForBlob = NoLanguageForBlob FilePath
   deriving (Eq, Exception, Ord, Show, Typeable)
 
-noLanguageForBlob :: Member (Exc SomeException) effs => FilePath -> Eff effs a
+noLanguageForBlob :: (Member (Error SomeException) sig, Carrier sig m) => FilePath -> m a
 noLanguageForBlob blobPath = throwError (SomeException (NoLanguageForBlob blobPath))
 
 -- | Represents a blobs suitable for diffing which can be either a blob to

src/Data/Graph.hs

@@ -20,8 +20,8 @@ import qualified Algebra.Graph.AdjacencyMap as A
 import           Algebra.Graph.Class (connect, overlay, vertex)
 import qualified Algebra.Graph.Class as Class
 import qualified Algebra.Graph.ToGraph as Class
-import           Control.Monad.Effect
-import           Control.Monad.Effect.State
+import           Control.Effect
+import           Control.Effect.State
 import           Data.Aeson
 import qualified Data.Set as Set
 
@@ -66,15 +66,15 @@ topologicalSort = go . Class.toAdjacencyMap . G.transpose . unGraph
           . traverse_ visit
           . A.vertexList
           $ graph
-          where visit :: v -> Eff '[State (Visited v)] ()
+          where visit :: (Member (State (Visited v)) sig, Carrier sig m, Monad m) => v -> m ()
                 visit v = do
                   isMarked <- Set.member v . visitedVertices <$> get
                   if isMarked then
                     pure ()
                   else do
-                    modify' (extendVisited (Set.insert v))
+                    modify (extendVisited (Set.insert v))
                     traverse_ visit (Set.toList (A.postSet v graph))
-                    modify' (extendOrder (v :))
+                    modify (extendOrder (v :))
 
 data Visited v = Visited { visitedVertices :: !(Set v), visitedOrder :: [v] }
 

src/Data/Graph/ControlFlowVertex.hs

@@ -30,7 +30,7 @@ import qualified Data.Syntax.Expression as Expression
 import           Data.Term
 import qualified Data.Text as T
 import           GHC.Exts (fromList)
-import           Prologue hiding (packageName)
+import           Prologue
 import           Proto3.Suite
 import qualified Proto3.Suite as PB
 import qualified Proto3.Wire.Encode as Encode

src/Data/JSON/Fields.hs

@@ -12,6 +12,7 @@ import           Data.Aeson
 import qualified Data.Map as Map
 import           Data.Sum (Apply (..), Sum)
 import qualified Data.Text as Text
+import           GHC.Generics
 import           Prologue
 
 class ToJSONFields a where

src/Data/Location.hs

@@ -6,7 +6,7 @@ module Data.Location
   , Range(..)
   ) where
 
-import Prologue (Generic (..), NFData (..))
+import Prologue (Generic, NFData (..))
 
 import Data.JSON.Fields
 import Data.Range

src/Data/Project.hs

@@ -15,10 +15,10 @@ module Data.Project (
   ) where
 
 import Prelude hiding (readFile)
-import Prologue hiding (throwError)
+import Prologue
 
-import           Control.Monad.Effect
-import           Control.Monad.Effect.Exception
+import           Control.Effect
+import           Control.Effect.Error
 import           Data.Blob
 import           Data.File
 import           Data.Language
@@ -77,10 +77,10 @@ newtype ProjectException
   = FileNotFound FilePath
     deriving (Show, Eq, Typeable, Exception)
 
-readFile :: Member (Exc SomeException) effs
+readFile :: (Member (Error SomeException) sig, Applicative m, Carrier sig m)
          => Project
          -> File
-         -> Eff effs (Maybe Blob)
+         -> m (Maybe Blob)
 readFile Project{..} f =
   let p         = filePath f
       candidate = find (\b -> blobPath b == p) projectBlobs

src/Data/Syntax.hs

@@ -2,7 +2,7 @@
 {-# OPTIONS_GHC -Wno-missing-export-lists -Wno-redundant-constraints -fno-warn-orphans #-} -- For HasCallStack
 module Data.Syntax where
 
-import Data.Abstract.Evaluatable
+import Data.Abstract.Evaluatable hiding (Empty, Error)
 import Data.Aeson (ToJSON(..), object)
 import Data.Char (toLower)
 import Data.JSON.Fields

src/Data/Syntax/Expression.hs

@@ -3,13 +3,13 @@
 module Data.Syntax.Expression where
 
 import Prelude hiding (null)
-import Prologue hiding (Member, This, index, null)
+import Prologue hiding (This, index, null)
 
 import Data.Fixed
 import Proto3.Suite.Class
 
 import           Control.Abstract.ScopeGraph as ScopeGraph
-import           Data.Abstract.Evaluatable as Abstract hiding (Member)
+import           Data.Abstract.Evaluatable as Abstract hiding (Member, Void)
 import           Data.Abstract.Number (liftIntegralFrac, liftReal, liftedExponent, liftedFloorDiv)
 import           Data.JSON.Fields
 import qualified Data.Reprinting.Scope as Scope

src/Data/Syntax/Type.hs

@@ -2,7 +2,7 @@
 {-# OPTIONS_GHC -Wno-missing-export-lists #-}
 module Data.Syntax.Type where
 
-import Data.Abstract.Evaluatable
+import Data.Abstract.Evaluatable hiding (Void)
 import Data.JSON.Fields
 import Diffing.Algorithm
 import Prelude hiding (Bool, Float, Int, Double)

src/Diffing/Algorithm.hs

@@ -18,6 +18,7 @@ import Control.Monad.Free.Freer
 import Data.Diff
 import Data.Sum
 import Data.Term
+import GHC.Generics
 import Prologue
 
 -- | A single step in a diffing algorithm, parameterized by the types of terms, diffs, and the result of the applicable algorithm.

src/Language/Go/Syntax.hs

@@ -56,15 +56,16 @@ importPath str = let path = stripQuotes str in ImportPath (T.unpack path) (pathT
 defaultAlias :: ImportPath -> Name
 defaultAlias = name . T.pack . takeFileName . unPath
 
-resolveGoImport :: ( Member (Modules address) effects
-                   , Member (Reader ModuleInfo) effects
-                   , Member (Reader Package.PackageInfo) effects
-                   , Member (Reader Span) effects
-                   , Member (Resumable (BaseError ResolutionError)) effects
-                   , Member Trace effects
+resolveGoImport :: ( Member (Modules address) sig
+                   , Member (Reader ModuleInfo) sig
+                   , Member (Reader Package.PackageInfo) sig
+                   , Member (Reader Span) sig
+                   , Member (Resumable (BaseError ResolutionError)) sig
+                   , Member Trace sig
+                   , Carrier sig m
                    )
                 => ImportPath
-                -> Evaluator term address value effects [ModulePath]
+                -> Evaluator term address value m [ModulePath]
 resolveGoImport (ImportPath path Unknown) = throwResolutionError $ GoImportError path
 resolveGoImport (ImportPath path Relative) = do
   ModuleInfo{..} <- currentModule

src/Language/JSON/PrettyPrint.hs

@@ -6,10 +6,10 @@ module Language.JSON.PrettyPrint
   , minimizingJSON
   ) where
 
-import Prologue hiding (throwError)
+import Prologue
 
-import Control.Monad.Effect
-import Control.Monad.Effect.Exception (Exc, throwError)
+import Control.Effect
+import Control.Effect.Error
 import Control.Monad.Trans (lift)
 import Data.Machine
 
@@ -19,8 +19,8 @@ import Data.Reprinting.Token
 import Data.Reprinting.Scope
 
 -- | Default printing pipeline for JSON.
-defaultJSONPipeline :: (Member (Exc TranslationError) effs)
-  => ProcessT (Eff effs) Fragment Splice
+defaultJSONPipeline :: (Member (Error TranslationError) sig, Carrier sig m, Monad m)
+  => ProcessT m Fragment Splice
 defaultJSONPipeline
   = printingJSON
   ~> beautifyingJSON defaultBeautyOpts
@@ -56,8 +56,8 @@ defaultBeautyOpts :: JSONBeautyOpts
 defaultBeautyOpts = JSONBeautyOpts 2 False
 
 -- | Produce JSON with configurable whitespace and layout.
-beautifyingJSON :: (Member (Exc TranslationError) effs)
-  => JSONBeautyOpts -> ProcessT (Eff effs) Fragment Splice
+beautifyingJSON :: (Member (Error TranslationError) sig, Carrier sig m, Monad m)
+  => JSONBeautyOpts -> ProcessT m Fragment Splice
 beautifyingJSON _ = repeatedly (await >>= step) where
   step (Defer el cs)   = lift (throwError (NoTranslation el cs))
   step (Verbatim txt)  = emit txt
@@ -70,8 +70,8 @@ beautifyingJSON _ = repeatedly (await >>= step) where
     _                    -> emit txt
 
 -- | Produce whitespace minimal JSON.
-minimizingJSON :: (Member (Exc TranslationError) effs)
-  => ProcessT (Eff effs) Fragment Splice
+minimizingJSON :: (Member (Error TranslationError) sig, Carrier sig m, Monad m)
+  => ProcessT m Fragment Splice
 minimizingJSON = repeatedly (await >>= step) where
   step (Defer el cs)  = lift (throwError (NoTranslation el cs))
   step (Verbatim txt) = emit txt

src/Language/Java/Syntax.hs

@@ -5,7 +5,7 @@ module Language.Java.Syntax where
 import Data.Abstract.Evaluatable
 import Data.JSON.Fields
 import Diffing.Algorithm
-import Prologue hiding (Constructor)
+import Prologue
 import Proto3.Suite.Class
 
 newtype Import a = Import { imports :: [a]}

src/Language/PHP/Syntax.hs

@@ -38,36 +38,38 @@ instance Evaluatable VariableName
 -- file, the complete contents of the included file are treated as though it
 -- were defined inside that function.
 
-resolvePHPName :: ( Member (Modules address) effects
-                  , Member (Reader ModuleInfo) effects
-                  , Member (Reader Span) effects
-                  , Member (Resumable (BaseError ResolutionError)) effects
+resolvePHPName :: ( Member (Modules address) sig
+                  , Member (Reader ModuleInfo) sig
+                  , Member (Reader Span) sig
+                  , Member (Resumable (BaseError ResolutionError)) sig
+                  , Carrier sig m
                   )
                => T.Text
-               -> Evaluator term address value effects ModulePath
+               -> Evaluator term address value m ModulePath
 resolvePHPName n = do
   modulePath <- resolve [name]
   maybeM (throwResolutionError $ NotFoundError name [name] Language.PHP) modulePath
   where name = toName n
         toName = T.unpack . dropRelativePrefix . stripQuotes
 
-include :: ( AbstractValue term address value effects
-           , Member (Deref value) effects
-           , Member (Env address) effects
-           , Member (Modules address) effects
-           , Member (Reader ModuleInfo) effects
-           , Member (Reader Span) effects
-           , Member (Resumable (BaseError (AddressError address value))) effects
-           , Member (Resumable (BaseError ResolutionError)) effects
-           , Member (Resumable (BaseError (EnvironmentError address))) effects
-           , Member (State (Heap address value)) effects
-           , Member Trace effects
+include :: ( AbstractValue term address value m
+           , Carrier sig m
+           , Member (Deref value) sig
+           , Member (Env address) sig
+           , Member (Modules address) sig
+           , Member (Reader ModuleInfo) sig
+           , Member (Reader Span) sig
+           , Member (Resumable (BaseError (AddressError address value))) sig
+           , Member (Resumable (BaseError ResolutionError)) sig
+           , Member (Resumable (BaseError (EnvironmentError address))) sig
+           , Member (State (Heap address value)) sig
+           , Member Trace sig
            , Ord address
            )
-        => (term -> Evaluator term address value effects (ValueRef address))
+        => (term -> Evaluator term address value m (ValueRef address))
         -> term
-        -> (ModulePath -> Evaluator term address value effects (ModuleResult address))
-        -> Evaluator term address value effects (ValueRef address)
+        -> (ModulePath -> Evaluator term address value m (ModuleResult address))
+        -> Evaluator term address value m (ValueRef address)
 include eval pathTerm f = do
   name <- eval pathTerm >>= Abstract.value >>= asString
   path <- resolvePHPName name

src/Language/Python/PrettyPrint.hs

@@ -2,8 +2,8 @@
 
 module Language.Python.PrettyPrint ( printingPython ) where
 
-import Control.Monad.Effect
-import Control.Monad.Effect.Exception (Exc, throwError)
+import Control.Effect
+import Control.Effect.Error
 import Control.Monad.Trans (lift)
 import Data.Machine
 
@@ -14,10 +14,10 @@ import Data.Reprinting.Scope
 import Data.Reprinting.Operator
 
 -- | Print Python syntax.
-printingPython :: (Member (Exc TranslationError) effs) => ProcessT (Eff effs) Fragment Splice
+printingPython :: (Member (Error TranslationError) sig, Carrier sig m, Monad m) => ProcessT m Fragment Splice
 printingPython = repeatedly (await >>= step)
 
-step :: (Member (Exc TranslationError) effs) => Fragment -> PlanT k Splice (Eff effs) ()
+step :: (Member (Error TranslationError) sig, Carrier sig m, Monad m) => Fragment -> PlanT k Splice m ()
 step (Verbatim txt) = emit txt
 step (New _ _ txt)  = emit txt
 step (Defer el cs)  = case (el, cs) of

src/Language/Python/Syntax.hs

@@ -65,14 +65,15 @@ relativeQualifiedName prefix paths = RelativeQualifiedName (T.unpack prefix) (Ju
 -- Subsequent imports of `parent.two` or `parent.three` will execute
 --     `parent/two/__init__.py` and
 --     `parent/three/__init__.py` respectively.
-resolvePythonModules :: ( Member (Modules address) effects
-                        , Member (Reader ModuleInfo) effects
-                        , Member (Reader Span) effects
-                        , Member (Resumable (BaseError ResolutionError)) effects
-                        , Member Trace effects
+resolvePythonModules :: ( Member (Modules address) sig
+                        , Member (Reader ModuleInfo) sig
+                        , Member (Reader Span) sig
+                        , Member (Resumable (BaseError ResolutionError)) sig
+                        , Member Trace sig
+                        , Carrier sig m
                         )
                      => QualifiedName
-                     -> Evaluator term address value effects (NonEmpty ModulePath)
+                     -> Evaluator term address value m (NonEmpty ModulePath)
 resolvePythonModules q = do
   relRootDir <- rootDir q <$> currentModule
   for (moduleNames q) $ \name -> do
@@ -155,15 +156,16 @@ instance Evaluatable Import where
 
 
 -- Evaluate a qualified import
-evalQualifiedImport :: ( AbstractValue term address value effects
-                       , Member (Allocator address) effects
-                       , Member (Deref value) effects
-                       , Member (Env address) effects
-                       , Member (Modules address) effects
-                       , Member (State (Heap address value)) effects
+evalQualifiedImport :: ( AbstractValue term address value m
+                       , Carrier sig m
+                       , Member (Allocator address) sig
+                       , Member (Deref value) sig
+                       , Member (Env address) sig
+                       , Member (Modules address) sig
+                       , Member (State (Heap address value)) sig
                        , Ord address
                        )
-                    => Name -> ModulePath -> Evaluator term address value effects value
+                    => Name -> ModulePath -> Evaluator term address value m value
 evalQualifiedImport name path = letrec' name $ \addr -> do
   unit <$ makeNamespace name addr Nothing (bindAll . fst . snd =<< require path)
 

src/Language/Ruby/PrettyPrint.hs

@@ -2,8 +2,8 @@
 
 module Language.Ruby.PrettyPrint ( printingRuby ) where
 
-import Control.Monad.Effect
-import Control.Monad.Effect.Exception (Exc, throwError)
+import Control.Effect
+import Control.Effect.Error
 import Control.Monad.Trans (lift)
 import Data.Machine
 
@@ -14,10 +14,10 @@ import Data.Reprinting.Splice
 import Data.Reprinting.Token as Token
 
 -- | Print Ruby syntax.
-printingRuby :: (Member (Exc TranslationError) effs) => ProcessT (Eff effs) Fragment Splice
+printingRuby :: (Member (Error TranslationError) sig, Carrier sig m, Monad m) => ProcessT m Fragment Splice
 printingRuby = repeatedly (await >>= step)
 
-step :: (Member (Exc TranslationError) effs) => Fragment -> PlanT k Splice (Eff effs) ()
+step :: (Member (Error TranslationError) sig, Carrier sig m, Monad m) => Fragment -> PlanT k Splice m ()
 step (Verbatim txt) = emit txt
 step (New _ _ txt)  = emit txt
 step (Defer el cs)  = case (el, cs) of

src/Language/Ruby/Syntax.hs

@@ -22,13 +22,14 @@ import           Reprinting.Tokenize
 -- TODO: Fully sort out ruby require/load mechanics
 --
 -- require "json"
-resolveRubyName :: ( Member (Modules address) effects
-                   , Member (Reader ModuleInfo) effects
-                   , Member (Reader Span) effects
-                   , Member (Resumable (BaseError ResolutionError)) effects
+resolveRubyName :: ( Member (Modules address) sig
+                   , Member (Reader ModuleInfo) sig
+                   , Member (Reader Span) sig
+                   , Member (Resumable (BaseError ResolutionError)) sig
+                   , Carrier sig m
                    )
                 => Text
-                -> Evaluator term address value effects M.ModulePath
+                -> Evaluator term address value m M.ModulePath
 resolveRubyName name = do
   let name' = cleanNameOrPath name
   let paths = [name' <.> "rb"]
@@ -36,13 +37,14 @@ resolveRubyName name = do
   maybeM (throwResolutionError $ NotFoundError name' paths Language.Ruby) modulePath
 
 -- load "/root/src/file.rb"
-resolveRubyPath :: ( Member (Modules address) effects
-                   , Member (Reader ModuleInfo) effects
-                   , Member (Reader Span) effects
-                   , Member (Resumable (BaseError ResolutionError)) effects
+resolveRubyPath :: ( Member (Modules address) sig
+                   , Member (Reader ModuleInfo) sig
+                   , Member (Reader Span) sig
+                   , Member (Resumable (BaseError ResolutionError)) sig
+                   , Carrier sig m
                    )
                 => Text
-                -> Evaluator term address value effects M.ModulePath
+                -> Evaluator term address value m M.ModulePath
 resolveRubyPath path = do
   let name' = cleanNameOrPath path
   modulePath <- resolve [name']
@@ -91,11 +93,12 @@ instance Evaluatable Require where
     bindAll importedEnv
     rvalBox v -- Returns True if the file was loaded, False if it was already loaded. http://ruby-doc.org/core-2.5.0/Kernel.html#method-i-require
 
-doRequire :: ( Member (Boolean value) effects
-             , Member (Modules address) effects
+doRequire :: ( Member (Boolean value) sig
+             , Member (Modules address) sig
+             , Carrier sig m
              )
           => M.ModulePath
-          -> Evaluator term address value effects (Bindings address, value)
+          -> Evaluator term address value m (Bindings address, value)
 doRequire path = do
   result <- lookupModule path
   case result of
@@ -119,17 +122,18 @@ instance Evaluatable Load where
     shouldWrap <- eval wrap >>= value >>= asBool
     rvalBox =<< doLoad path shouldWrap
 
-doLoad :: ( Member (Boolean value) effects
-          , Member (Env address) effects
-          , Member (Modules address) effects
-          , Member (Reader ModuleInfo) effects
-          , Member (Reader Span) effects
-          , Member (Resumable (BaseError ResolutionError)) effects
-          , Member Trace effects
+doLoad :: ( Member (Boolean value) sig
+          , Member (Env address) sig
+          , Member (Modules address) sig
+          , Member (Reader ModuleInfo) sig
+          , Member (Reader Span) sig
+          , Member (Resumable (BaseError ResolutionError)) sig
+          , Member Trace sig
+          , Carrier sig m
           )
        => Text
        -> Bool
-       -> Evaluator term address value effects value
+       -> Evaluator term address value m value
 doLoad path shouldWrap = do
   path' <- resolveRubyPath path
   traceResolve path path'

src/Language/TypeScript/Resolution.hs

@@ -65,16 +65,17 @@ toName = name . T.pack . unPath
 --
 -- NB: TypeScript has a couple of different strategies, but the main one (and the
 -- only one we support) mimics Node.js.
-resolveWithNodejsStrategy :: ( Member (Modules address) effects
-                             , Member (Reader M.ModuleInfo) effects
-                             , Member (Reader PackageInfo) effects
-                             , Member (Reader Span) effects
-                             , Member (Resumable (BaseError ResolutionError)) effects
-                             , Member Trace effects
+resolveWithNodejsStrategy :: ( Member (Modules address) sig
+                             , Member (Reader M.ModuleInfo) sig
+                             , Member (Reader PackageInfo) sig
+                             , Member (Reader Span) sig
+                             , Member (Resumable (BaseError ResolutionError)) sig
+                             , Member Trace sig
+                             , Carrier sig m
                              )
                           => ImportPath
                           -> [String]
-                          -> Evaluator term address value effects M.ModulePath
+                          -> Evaluator term address value m M.ModulePath
 resolveWithNodejsStrategy (ImportPath path NonRelative) exts = resolveNonRelativePath path exts
 resolveWithNodejsStrategy (ImportPath path _)    exts        = resolveRelativePath path exts
 
@@ -85,16 +86,17 @@ resolveWithNodejsStrategy (ImportPath path _)    exts        = resolveRelativePa
 -- /root/src/moduleB.ts
 -- /root/src/moduleB/package.json (if it specifies a "types" property)
 -- /root/src/moduleB/index.ts
-resolveRelativePath :: ( Member (Modules address) effects
-                       , Member (Reader M.ModuleInfo) effects
-                       , Member (Reader PackageInfo) effects
-                       , Member (Reader Span) effects
-                       , Member (Resumable (BaseError ResolutionError)) effects
-                       , Member Trace effects
+resolveRelativePath :: ( Member (Modules address) sig
+                       , Member (Reader M.ModuleInfo) sig
+                       , Member (Reader PackageInfo) sig
+                       , Member (Reader Span) sig
+                       , Member (Resumable (BaseError ResolutionError)) sig
+                       , Member Trace sig
+                       , Carrier sig m
                        )
                     => FilePath
                     -> [String]
-                    -> Evaluator term address value effects M.ModulePath
+                    -> Evaluator term address value m M.ModulePath
 resolveRelativePath relImportPath exts = do
   M.ModuleInfo{..} <- currentModule
   let relRootDir = takeDirectory modulePath
@@ -114,16 +116,17 @@ resolveRelativePath relImportPath exts = do
 --
 -- /root/node_modules/moduleB.ts, etc
 -- /node_modules/moduleB.ts, etc
-resolveNonRelativePath :: ( Member (Modules address) effects
-                          , Member (Reader M.ModuleInfo) effects
-                          , Member (Reader PackageInfo) effects
-                          , Member (Reader Span) effects
-                          , Member (Resumable (BaseError ResolutionError)) effects
-                          , Member Trace effects
+resolveNonRelativePath :: ( Member (Modules address) sig
+                          , Member (Reader M.ModuleInfo) sig
+                          , Member (Reader PackageInfo) sig
+                          , Member (Reader Span) sig
+                          , Member (Resumable (BaseError ResolutionError)) sig
+                          , Member Trace sig
+                          , Carrier sig m
                           )
                        => FilePath
                        -> [String]
-                       -> Evaluator term address value effects M.ModulePath
+                       -> Evaluator term address value m M.ModulePath
 resolveNonRelativePath name exts = do
   M.ModuleInfo{..} <- currentModule
   go "." modulePath mempty
@@ -140,13 +143,14 @@ resolveNonRelativePath name exts = do
     notFound xs = throwResolutionError $ NotFoundError name xs Language.TypeScript
 
 -- | Resolve a module name to a ModulePath.
-resolveModule :: ( Member (Modules address) effects
-                 , Member (Reader PackageInfo) effects
-                 , Member Trace effects
+resolveModule :: ( Member (Modules address) sig
+                 , Member (Reader PackageInfo) sig
+                 , Member Trace sig
+                 , Carrier sig m
                  )
               => FilePath -- ^ Module path used as directory to search in
               -> [String] -- ^ File extensions to look for
-              -> Evaluator term address value effects (Either [FilePath] M.ModulePath)
+              -> Evaluator term address value m (Either [FilePath] M.ModulePath)
 resolveModule path' exts = do
   let path = makeRelative "." path'
   PackageInfo{..} <- currentPackage
@@ -163,16 +167,17 @@ typescriptExtensions = ["ts", "tsx", "d.ts"]
 javascriptExtensions :: [String]
 javascriptExtensions = ["js"]
 
-evalRequire :: ( AbstractValue term address value effects
-               , Member (Allocator address) effects
-               , Member (Deref value) effects
-               , Member (Env address) effects
-               , Member (Modules address) effects
-               , Member (State (Heap address value)) effects
+evalRequire :: ( AbstractValue term address value m
+               , Member (Allocator address) sig
+               , Member (Deref value) sig
+               , Member (Env address) sig
+               , Member (Modules address) sig
+               , Member (State (Heap address value)) sig
                , Ord address
+               , Carrier sig m
                )
             => M.ModulePath
             -> Name
-            -> Evaluator term address value effects value
+            -> Evaluator term address value m value
 evalRequire modulePath alias = letrec' alias $ \addr ->
   unit <$ makeNamespace alias addr Nothing (bindAll . fst . snd =<< require modulePath)

src/Parsing/TreeSitter.hs

@@ -8,9 +8,9 @@ import Prologue hiding (bracket)
 
 import           Control.Concurrent.Async
 import qualified Control.Exception as Exc (bracket)
-import           Control.Monad.Effect
-import           Control.Monad.Effect.Resource
-import           Control.Monad.Effect.Trace
+import           Control.Effect
+import           Control.Effect.Resource
+import           Control.Effect.Trace
 import           Data.ByteString.Unsafe (unsafeUseAsCStringLen)
 import           Foreign
 import           Foreign.C.Types (CBool (..))
@@ -57,16 +57,17 @@ runParser parser blobSource  = unsafeUseAsCStringLen (sourceBytes blobSource) $
 -- | Parse 'Source' with the given 'TS.Language' and return its AST.
 -- Returns Nothing if the operation timed out.
 parseToAST :: ( Bounded grammar
+              , Carrier sig m
               , Enum grammar
-              , Member (Lift IO) effects
-              , Member Resource effects
-              , Member Timeout effects
-              , Member Trace effects
+              , Member Resource sig
+              , Member Timeout sig
+              , Member Trace sig
+              , MonadIO m
               )
            => Duration
            -> Ptr TS.Language
            -> Blob
-           -> Eff effects (Maybe (AST [] grammar))
+           -> m (Maybe (AST [] grammar))
 parseToAST parseTimeout language Blob{..} = bracket (liftIO TS.ts_parser_new) (liftIO . TS.ts_parser_delete) $ \ parser -> do
   liftIO $ do
     TS.ts_parser_halt_on_error parser (CBool 1)

src/Prologue.hs

@@ -26,7 +26,6 @@ import Data.Set as X (Set)
 import Data.Sum as X (Sum, Element, Elements, (:<), (:<:), Apply (..), inject)
 import Data.Text as X (Text)
 import Data.These as X
-import Data.Union as X
 
 import Control.Exception as X hiding (Handler (..), assert, evaluate, throw, throwIO, throwTo)
 
@@ -34,7 +33,6 @@ import Control.Exception as X hiding (Handler (..), assert, evaluate, throw, thr
 import Control.Applicative as X
 import Control.Arrow as X ((&&&), (***))
 import Control.Monad as X hiding (fail, return)
-import Control.Monad.Except as X (MonadError (..))
 import Control.Monad.Fail as X (MonadFail (..))
 import Control.Monad.IO.Class as X (MonadIO (..))
 import Data.Algebra as X
@@ -56,7 +54,7 @@ import Data.Traversable as X
 import Data.Typeable as X (Typeable)
 
 -- Generics
-import GHC.Generics as X hiding (moduleName)
+import GHC.Generics as X (Generic, Generic1)
 import GHC.Stack as X
 
 -- | Fold a collection by mapping each element onto an 'Alternative' action.

src/Rendering/Graph.hs

@@ -8,9 +8,9 @@ module Rendering.Graph
 
 import Algebra.Graph.Export.Dot
 import Analysis.ConstructorName
-import Control.Monad.Effect
-import Control.Monad.Effect.Fresh
-import Control.Monad.Effect.Reader
+import Control.Effect
+import Control.Effect.Fresh
+import Control.Effect.Reader
 import Data.Diff
 import Data.Graph
 import Data.Graph.TermVertex
@@ -25,8 +25,11 @@ import Prologue
 renderTreeGraph :: (Ord vertex, Recursive t, ToTreeGraph vertex (Base t)) => t -> Graph vertex
 renderTreeGraph = simplify . runGraph . cata toTreeGraph
 
-runGraph :: Eff '[Reader (Graph vertex), Fresh] (Graph vertex) -> Graph vertex
-runGraph = run . runFresh 0 . runReader mempty
+runGraph :: Eff (ReaderC (Graph vertex)
+           (Eff (FreshC
+           (Eff VoidC)))) (Graph vertex)
+         -> Graph vertex
+runGraph = run . runFresh . runReader mempty
 
 -- | GraphViz styling for terms
 termStyle :: (IsString string, Monoid string) => String -> Style TermVertex string
@@ -48,7 +51,7 @@ diffStyle name = (defaultStyle (fromString . show . diffVertexId))
         vertexAttributes (DiffVertex _ (Merged MergedTerm{..}))     = [ "label" := fromString mergedTermName ]
 
 class ToTreeGraph vertex t | t -> vertex where
-  toTreeGraph :: (Member Fresh effs, Member (Reader (Graph vertex)) effs) => t (Eff effs (Graph vertex)) -> Eff effs (Graph vertex)
+  toTreeGraph :: (Member Fresh sig, Member (Reader (Graph vertex)) sig, Carrier sig m, Monad m) => t (m (Graph vertex)) -> m (Graph vertex)
 
 instance (ConstructorName syntax, Foldable syntax) =>
   ToTreeGraph TermVertex (TermF syntax Location) where
@@ -56,11 +59,13 @@ instance (ConstructorName syntax, Foldable syntax) =>
     termAlgebra ::
       ( ConstructorName syntax
       , Foldable syntax
-      , Member Fresh effs
-      , Member (Reader (Graph TermVertex)) effs
+      , Member Fresh sig
+      , Member (Reader (Graph TermVertex)) sig
+      , Carrier sig m
+      , Monad m
       )
-      => TermF syntax Location (Eff effs (Graph TermVertex))
-      -> Eff effs (Graph TermVertex)
+      => TermF syntax Location (m (Graph TermVertex))
+      -> m (Graph TermVertex)
     termAlgebra (In ann syntax) = do
       i <- fresh
       parent <- ask
@@ -86,9 +91,11 @@ instance (ConstructorName syntax, Foldable syntax) =>
       ann a = TermAnnotation (locationByteRange a) (locationSpan a)
       diffAlgebra ::
         ( Foldable f
-        , Member Fresh effs
-        , Member (Reader (Graph DiffVertex)) effs
-        ) => f (Eff effs (Graph DiffVertex)) -> DiffVertexTerm -> Eff effs (Graph DiffVertex)
+        , Member Fresh sig
+        , Member (Reader (Graph DiffVertex)) sig
+        , Carrier sig m
+        , Monad m
+        ) => f (m (Graph DiffVertex)) -> DiffVertexTerm -> m (Graph DiffVertex)
       diffAlgebra syntax a = do
         i <- fresh
         parent <- ask

src/Reprinting/Pipeline.hs

@@ -103,9 +103,9 @@ module Reprinting.Pipeline
   , runTranslating
   ) where
 
-import           Control.Monad.Effect as Effect
-import qualified Control.Monad.Effect.Exception as Exc
-import           Control.Monad.Effect.State
+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
@@ -132,7 +132,7 @@ runReprinter :: Tokenize a
 runReprinter src translating tree
   = fmap go
   . Effect.run
-  . Exc.runError
+  . Effect.runError
   . fmap snd
   . runState (mempty :: [Scope])
   . foldT $ source (tokenizing src tree)
@@ -156,7 +156,7 @@ runContextualizing :: Tokenize a
   -> Either TranslationError [Fragment]
 runContextualizing src tree
   = Effect.run
-  . Exc.runError
+  . Effect.runError
   . fmap snd
   . runState (mempty :: [Scope])
   . runT $ source (tokenizing src tree)
@@ -169,7 +169,7 @@ runTranslating :: Tokenize a
   -> Either TranslationError [Splice]
 runTranslating src translating tree
   = Effect.run
-  . Exc.runError
+  . Effect.runError
   . fmap snd
   . runState (mempty :: [Scope])
   . runT $ source (tokenizing src tree)

src/Reprinting/Translate.hs

@@ -6,10 +6,9 @@ module Reprinting.Translate
   ) where
 
 import           Control.Monad
-import           Control.Monad.Effect
-import           Control.Monad.Effect.Exception (Exc)
-import qualified Control.Monad.Effect.Exception as Exc
-import           Control.Monad.Effect.State
+import           Control.Effect
+import           Control.Effect.Error
+import           Control.Effect.State
 import           Control.Monad.Trans
 import           Data.Machine
 
@@ -19,7 +18,10 @@ import           Data.Reprinting.Token
 import           Data.Reprinting.Scope
 import qualified Data.Source as Source
 
-type Translator = Eff '[State [Scope], Exc TranslationError]
+type Translator
+  = Eff (StateC [Scope]
+  ( Eff (ErrorC TranslationError
+  ( Eff VoidC))))
 
 contextualizing :: ProcessT Translator Token Fragment
 contextualizing = repeatedly $ await >>= \case
@@ -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)))
-  cs     -> lift (Exc.throwError (UnbalancedPair c cs))
+  (x:xs) -> when (x == c) (lift (modify (const xs)))
+  cs     -> lift (throwError (UnbalancedPair c cs))

src/Semantic/AST.hs

@@ -7,10 +7,12 @@ module Semantic.AST
   , runASTParse
   ) where
 
+import Control.Effect
+import Control.Monad
 import Data.AST
 import Data.Blob
 import Parsing.Parser
-import Prologue hiding (MonadError(..))
+import Prologue
 import Rendering.JSON (renderJSONAST)
 import Semantic.Task
 import qualified Serializing.Format as F
@@ -21,7 +23,7 @@ data SomeAST where
 withSomeAST :: (forall grammar . Show grammar => AST [] grammar -> a) -> SomeAST -> a
 withSomeAST f (SomeAST ast) = f ast
 
-astParseBlob :: (Member (Exc SomeException) effs, Member Task effs) => Blob -> Eff effs SomeAST
+astParseBlob :: (Member (Error SomeException) sig, Member Task sig, Carrier sig m, Functor m) => Blob -> m SomeAST
 astParseBlob blob@Blob{..}
   | Just (SomeASTParser parser) <- someASTParser blobLanguage = SomeAST <$> parse parser blob
   | otherwise = noLanguageForBlob blobPath
@@ -30,7 +32,7 @@ astParseBlob blob@Blob{..}
 data ASTFormat = SExpression | JSON | Show
   deriving (Show)
 
-runASTParse :: (Member Distribute effects, Member (Exc SomeException) effects, Member Task effects) => ASTFormat -> [Blob] -> Eff effects F.Builder
+runASTParse :: (Member Distribute sig, Member (Error SomeException) sig, Member Task sig, Carrier sig m, Monad m) => ASTFormat -> [Blob] -> m F.Builder
 runASTParse SExpression = distributeFoldMap (astParseBlob >=> withSomeAST (serialize (F.SExpression F.ByShow)))
 runASTParse Show        = distributeFoldMap (astParseBlob >=> withSomeAST (serialize F.Show . fmap nodeSymbol))
 runASTParse JSON        = distributeFoldMap (\ blob -> astParseBlob blob >>= withSomeAST (render (renderJSONAST blob))) >=> serialize F.JSON

src/Semantic/Diff.hs

@@ -6,6 +6,8 @@ module Semantic.Diff
 
 import Analysis.ConstructorName (ConstructorName)
 import Analysis.Declaration (HasDeclaration, declarationAlgebra)
+import Control.Effect
+import Control.Monad.IO.Class
 import Data.Blob
 import Data.Diff
 import Data.JSON.Fields
@@ -14,7 +16,7 @@ import Data.Term
 import Data.Graph.DiffVertex
 import Diffing.Algorithm (Diffable)
 import Parsing.Parser
-import Prologue hiding (MonadError(..))
+import Prologue
 import Rendering.Graph
 import Rendering.Renderer
 import Semantic.Telemetry as Stat
@@ -24,7 +26,7 @@ import Rendering.JSON (SomeJSON (..))
 import qualified Rendering.JSON as JSON
 
 -- | Using the specified renderer, diff a list of 'BlobPair's to produce a 'Builder' output.
-runDiff :: (Member Distribute effs, Member (Exc SomeException) effs, Member (Lift IO) effs, Member Task effs, Member Telemetry effs) => DiffRenderer output -> [BlobPair] -> Eff effs Builder
+runDiff :: (Member Distribute sig, Member (Error SomeException) sig, Member Task sig, Member Telemetry sig, MonadIO m, Carrier sig m) => DiffRenderer output -> [BlobPair] -> m Builder
 runDiff ToCDiffRenderer         = withParsedBlobPairs (decorate . declarationAlgebra) (render . renderToCDiff) >=> serialize JSON
 runDiff JSONDiffRenderer        = withParsedBlobPairs (const pure) (render . renderJSONDiff) >=> serialize JSON
 runDiff JSONGraphDiffRenderer   = withParsedBlobPairs (const pure) (render . renderAdjGraph) >=> serialize JSON
@@ -40,28 +42,28 @@ data SomeTermPair typeclasses ann where
 withSomeTermPair :: (forall syntax . ApplyAll typeclasses syntax => Join These (Term syntax ann) -> a) -> SomeTermPair typeclasses ann -> a
 withSomeTermPair with (SomeTermPair terms) = with terms
 
-diffBlobTOCPairs :: (Member Distribute effs, Member (Exc SomeException) effs, Member (Lift IO) effs, Member Task effs, Member Telemetry effs) => [BlobPair] -> Eff effs ([TOCSummary], [TOCSummary])
+diffBlobTOCPairs :: (Member Distribute sig, Member (Error SomeException) sig, Member Task sig, Member Telemetry sig, MonadIO m, Carrier sig m) => [BlobPair] -> m ([TOCSummary], [TOCSummary])
 diffBlobTOCPairs = withParsedBlobPairs (decorate . declarationAlgebra) (render . renderRPCToCDiff)
 
 type CanDiff syntax = (ConstructorName syntax, Diffable syntax, Eq1 syntax, HasDeclaration syntax, Hashable1 syntax, Show1 syntax, ToJSONFields1 syntax, Traversable syntax)
-type Decorate effs a b = forall syntax . CanDiff syntax => Blob -> Term syntax a -> Eff effs (Term syntax b)
+type Decorate m a b = forall syntax . CanDiff syntax => Blob -> Term syntax a -> m (Term syntax b)
 
-withParsedBlobPairs :: (Member Distribute effs, Member (Exc SomeException) effs, Member (Lift IO) effs, Member Task effs, Member Telemetry effs, Monoid output)
-                    => Decorate effs Location ann
-                    -> (forall syntax . CanDiff syntax => BlobPair -> Diff syntax ann ann -> Eff effs output)
+withParsedBlobPairs :: (Member Distribute sig, Member (Error SomeException) sig, Member Task sig, Member Telemetry sig, MonadIO m, Monoid output, Carrier sig m)
+                    => Decorate m Location ann
+                    -> (forall syntax . CanDiff syntax => BlobPair -> Diff syntax ann ann -> m output)
                     -> [BlobPair]
-                    -> Eff effs output
+                    -> m output
 withParsedBlobPairs decorate render = distributeFoldMap (\ blobs -> withParsedBlobPair decorate blobs >>= withSomeTermPair (diffTerms blobs >=> render blobs))
-  where diffTerms :: (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax, Member (Lift IO) effs, Member Task effs, Member Telemetry effs) => BlobPair -> Join These (Term syntax ann) -> Eff effs (Diff syntax ann ann)
+  where diffTerms :: (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax, Member Task sig, Member Telemetry sig, Carrier sig m, MonadIO m) => BlobPair -> Join These (Term syntax ann) -> m (Diff syntax ann ann)
         diffTerms blobs terms = time "diff" languageTag $ do
           diff <- diff (runJoin terms)
           diff <$ writeStat (Stat.count "diff.nodes" (bilength diff) languageTag)
           where languageTag = languageTagForBlobPair blobs
 
-withParsedBlobPair :: (Member Distribute effs, Member (Exc SomeException) effs, Member Task effs)
-                   => Decorate effs Location ann
+withParsedBlobPair :: (Member Distribute sig, Member (Error SomeException) sig, Member Task sig, Carrier sig m, Monad m)
+                   => Decorate m Location ann
                    -> BlobPair
-                   -> Eff effs (SomeTermPair '[ConstructorName, Diffable, Eq1, HasDeclaration, Hashable1, Show1, ToJSONFields1, Traversable] ann)
+                   -> m (SomeTermPair '[ConstructorName, Diffable, Eq1, HasDeclaration, Hashable1, Show1, ToJSONFields1, Traversable] ann)
 withParsedBlobPair decorate blobs
   | Just (SomeParser parser) <- someParser @'[ConstructorName, Diffable, Eq1, HasDeclaration, Hashable1, Show1, ToJSONFields1, Traversable] (languageForBlobPair blobs)
     = SomeTermPair <$> distributeFor blobs (\ blob -> parse parser blob >>= decorate blob)

src/Semantic/Distribute.hs

@@ -1,44 +1,58 @@
-{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE ExistentialQuantification, TypeOperators, UndecidableInstances #-}
 module Semantic.Distribute
 ( distribute
 , distributeFor
 , distributeFoldMap
 , Distribute
 , runDistribute
+, DistributeC(..)
 ) where
 
 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.Effect
-import           Prologue hiding (MonadError (..))
+import           Prologue
 
 -- | Distribute a 'Traversable' container of tasks over the available cores (i.e. execute them concurrently), collecting their results.
 --
 --   This is a concurrent analogue of 'sequenceA'.
-distribute :: (Member Distribute effs, Traversable t) => t (Eff effs output) -> Eff effs (t output)
-distribute = fmap (withStrategy (parTraversable rseq)) <$> traverse (send . Distribute)
+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 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.
 --
 --   This is a concurrent analogue of 'for' or 'traverse' (with the arguments flipped).
-distributeFor :: (Member Distribute effs, Traversable t) => t a -> (a -> Eff effs output) -> Eff effs (t output)
+distributeFor :: (Member Distribute sig, Traversable t, Carrier sig m, Applicative m) => t a -> (a -> m output) -> m (t output)
 distributeFor inputs toTask = distribute (fmap toTask inputs)
 
 -- | 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), combining the results 'Monoid'ally into a final value.
 --
 --   This is a concurrent analogue of 'foldMap'.
-distributeFoldMap :: (Member Distribute effs, Monoid output, Traversable t) => (a -> Eff effs output) -> t a -> Eff effs output
+distributeFoldMap :: (Member Distribute sig, Monoid output, Traversable t, Carrier sig m, Applicative m) => (a -> m output) -> t a -> m output
 distributeFoldMap toTask inputs = fmap fold (distribute (fmap toTask inputs))
 
 
 -- | Distribute effects run tasks concurrently.
-newtype Distribute task output = Distribute (task output)
+data Distribute m k
+  = forall a . Distribute (m a) (a -> k)
+
+deriving instance Functor (Distribute m)
+
+instance HFunctor Distribute where
+  hmap f (Distribute m k) = Distribute (f m) k
 
-instance PureEffect Distribute
 instance Effect Distribute where
-  handleState c dist (Request (Distribute task) k) = Request (Distribute (dist (task <$ c))) (dist . fmap k)
+  handle state handler (Distribute task k) = Distribute (handler (task <$ state)) (handler . fmap k)
 
 
 -- | Evaluate a 'Distribute' effect concurrently.
-runDistribute :: Eff '[Distribute, Lift IO] a -> Eff '[Lift IO] a
-runDistribute = interpret (\ (Distribute task) -> liftIO (Async.runConcurrently (Async.Concurrently (runM (runDistribute task)))))
+runDistribute :: Eff (DistributeC (Eff (LiftC IO))) a -> Eff (LiftC IO) a
+runDistribute = runDistributeC . interpret
+
+newtype DistributeC m a = DistributeC { runDistributeC :: m a }
+
+instance Carrier (Distribute :+: Lift IO) (DistributeC (Eff (LiftC IO))) where
+  ret = DistributeC . ret
+  eff = DistributeC . ((\ (Distribute task k) -> liftIO (Async.runConcurrently (Async.Concurrently (runM (runDistributeC task)))) >>= runDistributeC . k) \/ eff . handleCoercible)

src/Semantic/Graph.hs

@@ -10,6 +10,7 @@ module Semantic.Graph
 , ControlFlowVertex
 , style
 , runHeap
+, runModuleTable
 , parsePackage
 , parsePythonPackage
 , withTermSpans
@@ -42,7 +43,7 @@ import qualified Data.Abstract.ModuleTable as ModuleTable
 import           Data.Abstract.Package as Package
 import           Data.Abstract.Value.Abstract as Abstract
 import           Data.Abstract.Value.Concrete as Concrete
-    (Value, ValueError (..), runWhile, runBoolean, runFunction, runValueErrorWith)
+    (Value, ValueError (..), runValueErrorWith)
 import           Data.Abstract.Value.Type as Type
 import           Data.Blob
 import           Data.File
@@ -57,7 +58,7 @@ import           Data.Text (pack, unpack)
 import           Language.Haskell.HsColour
 import           Language.Haskell.HsColour.Colourise
 import           Parsing.Parser
-import           Prologue hiding (MonadError (..), TypeError (..))
+import           Prologue hiding (TypeError (..))
 import           Semantic.Task as Task
 import           System.FilePath.Posix (takeDirectory, (</>))
 import           Text.Show.Pretty (ppShow)
@@ -66,11 +67,11 @@ data GraphType = ImportGraph | CallGraph
 
 type AnalysisClasses = '[ Declarations1, Eq1, Evaluatable, FreeVariables1, Foldable, Functor, Ord1, Show1 ]
 
-runGraph :: forall effs. (Member Distribute effs, Member (Exc SomeException) effs, Member Resolution effs, Member Task effs, Member Trace effs, Effects effs)
+runGraph :: (Member Distribute sig, Member (Error SomeException) sig, Member Resolution sig, Member Task sig, Member Trace sig, Carrier sig m, Effect sig)
          => GraphType
          -> Bool
          -> Project
-         -> Eff effs (Graph ControlFlowVertex)
+         -> Eff m (Graph ControlFlowVertex)
 runGraph ImportGraph _ project
   | SomeAnalysisParser parser (lang' :: Proxy lang) <- someAnalysisParser (Proxy :: Proxy AnalysisClasses) (projectLanguage project) = do
     let parse = if projectLanguage project == Language.Python then parsePythonPackage parser else fmap (fmap snd) . parsePackage parser
@@ -93,54 +94,58 @@ runCallGraph :: ( VertexDeclarationWithStrategy (VertexDeclarationStrategy synta
                 , Recursive term
                 , HasPrelude lang
                 , HasPostlude lang
-                , Member Trace effs
-                , Effects effs
+                , Member Trace sig
+                , Carrier sig m
+                , Effect sig
                 )
              => Proxy lang
              -> Bool
              -> [Module term]
              -> Package term
-             -> Eff effs (Graph ControlFlowVertex)
+             -> Eff m (Graph ControlFlowVertex)
 runCallGraph lang includePackages modules package = do
   let analyzeTerm = withTermSpans . graphingTerms . cachingTerms
       analyzeModule = (if includePackages then graphingPackages else id) . convergingModules . graphingModules
       extractGraph (graph, _) = simplify graph
       runGraphAnalysis
-        = graphing @_ @_ @(Maybe Name) @Monovariant
+        = graphing @_ @_ @_ @(Hole (Maybe Name) (Located Monovariant)) @Abstract
         . runHeap
         . caching
-        . runFresh 0
+        . raiseHandler runFresh
         . resumingLoadError
         . resumingUnspecialized
         . resumingEnvironmentError
         . resumingEvalError
         . resumingResolutionError
         . resumingAddressError
-        . runReader (packageInfo package)
-        . runReader (lowerBound @Span)
-        . runState (lowerBound @Span)
-        . runReader (lowerBound @ControlFlowVertex)
+        . raiseHandler (runReader (packageInfo package))
+        . raiseHandler (runReader (lowerBound @Span))
+        . raiseHandler (runState (lowerBound @Span))
+        . raiseHandler (runReader (lowerBound @ControlFlowVertex))
         . providingLiveSet
-        . runReader (lowerBound @(ModuleTable (NonEmpty (Module (ModuleResult (Hole (Maybe Name) (Located Monovariant)))))))
+        . runModuleTable
         . runModules (ModuleTable.modulePaths (packageModules package))
-      runAddressEffects
-        = Hole.runAllocator (Located.handleAllocator Monovariant.handleAllocator)
-        . Hole.runDeref (Located.handleDeref Monovariant.handleDeref)
-  extractGraph <$> runEvaluator (runGraphAnalysis (evaluate lang analyzeModule analyzeTerm runAddressEffects (fmap (Abstract.runBoolean . Abstract.runWhile) . Abstract.runFunction) modules))
+  extractGraph <$> runEvaluator (runGraphAnalysis (evaluate lang analyzeModule analyzeTerm modules))
+
+runModuleTable :: Carrier sig m
+               => Evaluator term address value (ReaderC (ModuleTable (NonEmpty (Module (ModuleResult address)))) (Eff m)) a
+               -> Evaluator term address value m a
+runModuleTable = raiseHandler $ runReader lowerBound
 
 runImportGraphToModuleInfos :: ( Declarations term
                                , Evaluatable (Base term)
                                , FreeVariables term
                                , HasPrelude lang
                                , HasPostlude lang
-                               , Member Trace effs
+                               , Member Trace sig
                                , Recursive term
-                               , Effects effs
+                               , Carrier sig m
                                , Show term
+                               , Effect sig
                                )
                             => Proxy lang
                             -> Package term
-                            -> Eff effs (Graph ControlFlowVertex)
+                            -> Eff m (Graph ControlFlowVertex)
 runImportGraphToModuleInfos lang (package :: Package term) = runImportGraph lang package allModuleInfos
   where allModuleInfos info = maybe (vertex (unknownModuleVertex info)) (foldMap (vertex . moduleVertex . moduleInfo)) (ModuleTable.lookup (modulePath info) (packageModules package))
 
@@ -149,14 +154,15 @@ runImportGraphToModules :: ( Declarations term
                            , FreeVariables term
                            , HasPrelude lang
                            , HasPostlude lang
-                           , Member Trace effs
+                           , Member Trace sig
                            , Recursive term
-                           , Effects effs
+                           , Carrier sig m
                            , Show term
+                           , Effect sig
                            )
                         => Proxy lang
                         -> Package term
-                        -> Eff effs (Graph (Module term))
+                        -> Eff m (Graph (Module term))
 runImportGraphToModules lang (package :: Package term) = runImportGraph lang package resolveOrLowerBound
   where resolveOrLowerBound info = maybe lowerBound (foldMap vertex) (ModuleTable.lookup (modulePath info) (packageModules package))
 
@@ -165,22 +171,23 @@ runImportGraph :: ( Declarations term
                   , FreeVariables term
                   , HasPrelude lang
                   , HasPostlude lang
-                  , Member Trace effs
+                  , Member Trace sig
                   , Recursive term
-                  , Effects effs
+                  , Carrier sig m
                   , Show term
+                  , Effect sig
                   )
                => Proxy lang
                -> Package term
                -> (ModuleInfo -> Graph vertex)
-               -> Eff effs (Graph vertex)
+               -> Eff m (Graph vertex)
 runImportGraph lang (package :: Package term) f =
   let analyzeModule = graphingModuleInfo
       extractGraph (graph, _) = graph >>= f
       runImportGraphAnalysis
-        = runState lowerBound
+        = raiseHandler (runState lowerBound)
         . runHeap
-        . runFresh 0
+        . raiseHandler runFresh
         . resumingLoadError
         . resumingUnspecialized
         . resumingEnvironmentError
@@ -188,25 +195,22 @@ runImportGraph lang (package :: Package term) f =
         . resumingResolutionError
         . resumingAddressError
         . resumingValueError
-        . runReader (lowerBound @(ModuleTable (NonEmpty (Module (ModuleResult (Hole (Maybe Name) Precise))))))
+        . runModuleTable
         . runModules (ModuleTable.modulePaths (packageModules package))
-        . runReader (packageInfo package)
-        . runState (lowerBound @Span)
-        . runReader (lowerBound @Span)
-      runAddressEffects
-        = Hole.runAllocator Precise.handleAllocator
-        . Hole.runDeref Precise.handleDeref
-  in extractGraph <$> runEvaluator @_ @_ @(Value _ (Hole (Maybe Name) Precise)) (runImportGraphAnalysis (evaluate lang analyzeModule id runAddressEffects (fmap (Concrete.runBoolean . Concrete.runWhile) . Concrete.runFunction) (ModuleTable.toPairs (packageModules package) >>= toList . snd)))
+        . raiseHandler (runReader (packageInfo package))
+        . raiseHandler (runState (lowerBound @Span))
+        . raiseHandler (runReader (lowerBound @Span))
+  in extractGraph <$> runEvaluator @_ @_ @(Value _ (Hole (Maybe Name) Precise)) (runImportGraphAnalysis (evaluate lang analyzeModule id (ModuleTable.toPairs (packageModules package) >>= toList . snd)))
 
 
-runHeap :: Effects effects => Evaluator term address value (State (Heap address value) ': effects) a -> Evaluator term address value effects (Heap address value, a)
-runHeap = runState lowerBound
+runHeap :: (Carrier sig m, Effect sig) => Evaluator term address value (StateC (Heap address value) (Eff m)) a -> Evaluator term address value m (Heap address value, a)
+runHeap = raiseHandler (runState lowerBound)
 
 -- | Parse a list of files into a 'Package'.
-parsePackage :: (Member Distribute effs, Member (Exc SomeException) effs, Member Resolution effs, Member Task effs, Member Trace effs)
+parsePackage :: (Member Distribute sig, Member (Error SomeException) sig, Member Resolution sig, Member Task sig, Member Trace sig, Carrier sig m, Monad m)
              => Parser term -- ^ A parser.
              -> Project     -- ^ Project to parse into a package.
-             -> Eff effs (Package (Blob, term))
+             -> m (Package (Blob, term))
 parsePackage parser project = do
   p <- parseModules parser project
   resMap <- Task.resolutionMap project
@@ -217,31 +221,33 @@ parsePackage parser project = do
     n = name (projectName project)
 
 -- | Parse all files in a project into 'Module's.
-parseModules :: (Member Distribute effs, Member (Exc SomeException) effs, Member Task effs) => Parser term -> Project -> Eff effs [Module (Blob, term)]
+parseModules :: (Member Distribute sig, Member (Error SomeException) sig, Member Task sig, Carrier sig m, Monad m) => Parser term -> Project -> m [Module (Blob, term)]
 parseModules parser p@Project{..} = distributeFor (projectFiles p) (parseModule p parser)
 
 
 -- | Parse a list of packages from a python project.
-parsePythonPackage :: forall syntax effs term.
+parsePythonPackage :: forall syntax sig m term.
                    ( Declarations1 syntax
                    , Evaluatable syntax
                    , FreeVariables1 syntax
                    , Functor syntax
                    , term ~ Term syntax Location
-                   , Member (Exc SomeException) effs
-                   , Member Distribute effs
-                   , Member Resolution effs
-                   , Member Trace effs
-                   , Member Task effs
-                   , Effects effs)
-                   => Parser term       -- ^ A parser.
-                   -> Project           -- ^ Project to parse into a package.
-                   -> Eff effs (Package term)
+                   , Member (Error SomeException) sig
+                   , Member Distribute sig
+                   , Member Resolution sig
+                   , Member Trace sig
+                   , Member Task sig
+                   , Carrier sig m
+                   , Effect sig
+                   )
+                   => Parser term      -- ^ A parser.
+                   -> Project          -- ^ Project to parse into a package.
+                   -> Eff m (Package term)
 parsePythonPackage parser project = do
   let runAnalysis = runEvaluator @_ @_ @(Value term (Hole (Maybe Name) Precise))
-        . runState PythonPackage.Unknown
-        . runState (lowerBound @(Heap (Hole (Maybe Name) Precise) (Value term (Hole (Maybe Name) Precise))))
-        . runFresh 0
+        . raiseHandler (runState PythonPackage.Unknown)
+        . raiseHandler (runState (lowerBound @(Heap (Hole (Maybe Name) Precise) (Value term (Hole (Maybe Name) Precise)))))
+        . raiseHandler runFresh
         . resumingLoadError
         . resumingUnspecialized
         . resumingEnvironmentError
@@ -249,19 +255,17 @@ parsePythonPackage parser project = do
         . resumingResolutionError
         . resumingAddressError
         . resumingValueError
-        . runReader (lowerBound @(ModuleTable (NonEmpty (Module (ModuleResult (Hole (Maybe Name) Precise))))))
+        . runModuleTable
         . runModules lowerBound
-        . runReader (PackageInfo (name "setup") lowerBound)
-        . runState (lowerBound @Span)
-        . runReader (lowerBound @Span)
-      runAddressEffects
-        = Hole.runAllocator Precise.handleAllocator
-        . Hole.runDeref Precise.handleDeref
+        . raiseHandler (runReader (PackageInfo (name "setup") lowerBound))
+        . raiseHandler (runState (lowerBound @Span))
+        . raiseHandler (runReader (lowerBound @Span))
 
   strat <- case find ((== (projectRootDir project </> "setup.py")) . filePath) (projectFiles project) of
     Just setupFile -> do
       setupModule <- fmap snd <$> parseModule project parser setupFile
-      fst <$> runAnalysis (evaluate (Proxy @'Language.Python) id id runAddressEffects (\ eval -> Concrete.runBoolean . Concrete.runWhile . Concrete.runFunction eval . runPythonPackaging) [ setupModule ])
+      fst <$> runAnalysis (evaluate (Proxy @'Language.Python) id id [ setupModule ])
+      -- FIXME: what are we gonna do about runPythonPackaging
     Nothing -> pure PythonPackage.Unknown
   case strat of
     PythonPackage.Unknown -> do
@@ -289,53 +293,57 @@ parsePythonPackage parser project = do
         resMap <- Task.resolutionMap p
         pure (Package.fromModules (name $ projectName p) modules resMap)
 
-parseModule :: (Member (Exc SomeException) effs, Member Task effs)
+parseModule :: (Member (Error SomeException) sig, Member Task sig, Carrier sig m, Monad m)
             => Project
             -> Parser term
             -> File
-            -> Eff effs (Module (Blob, term))
+            -> m (Module (Blob, term))
 parseModule proj parser file = do
   mBlob <- readFile proj file
   case mBlob of
     Just blob -> moduleForBlob (Just (projectRootDir proj)) blob . (,) blob <$> parse parser blob
     Nothing   -> throwError (SomeException (FileNotFound (filePath file)))
 
-withTermSpans :: ( Member (Reader Span) effects
-                 , Member (State Span) effects -- last evaluated child's span
+withTermSpans :: ( Member (Reader Span) sig
+                 , Member (State Span) sig -- last evaluated child's span
                  , Recursive term
+                 , Carrier sig m
                  , Base term ~ TermF syntax Location
                  )
-              => Open (Open (term -> Evaluator term address value effects a))
+              => Open (Open (term -> Evaluator term address value m a))
 withTermSpans recur0 recur term = let
   span = locationSpan (termFAnnotation (project term))
   updatedSpanAlg = withCurrentSpan span (recur0 recur term)
   in modifyChildSpan span updatedSpanAlg
 
-resumingResolutionError :: ( Member Trace effects
-                           , Effects effects
+resumingResolutionError :: ( Member Trace sig
+                           , Carrier sig m
                            )
-                         => Evaluator term address value (Resumable (BaseError ResolutionError) ': effects) a
-                         -> Evaluator term address value effects a
+                         => Evaluator term address value (ResumableWithC (BaseError ResolutionError) (Eff
+                                                         m)) a
+                         -> Evaluator term address value m a
 resumingResolutionError = runResolutionErrorWith (\ baseError -> traceError "ResolutionError" baseError *> case baseErrorException baseError of
   NotFoundError nameToResolve _ _ -> pure  nameToResolve
   GoImportError pathToResolve     -> pure [pathToResolve])
 
 resumingLoadError :: ( AbstractHole address
-                     , Effects effects
-                     , Member Trace effects
+                     , Carrier sig m
+                     , Member Trace sig
                      , Ord address
                      )
-                  => Evaluator term address value (Resumable (BaseError (LoadError address)) ': effects) a
-                  -> Evaluator term address value effects a
+                  => Evaluator term address value (ResumableWithC (BaseError (LoadError address)) (Eff
+                                                  m)) a
+                  -> Evaluator term address value m a
 resumingLoadError = runLoadErrorWith (\ baseError -> traceError "LoadError" baseError *> case baseErrorException baseError of
   ModuleNotFoundError _ -> pure (lowerBound, (lowerBound, hole)))
 
-resumingEvalError :: ( Effects effects
-                     , Member Fresh effects
-                     , Member Trace effects
+resumingEvalError :: ( Carrier sig m
+                     , Member Fresh sig
+                     , Member Trace sig
                      )
-                  => Evaluator term address value (Resumable (BaseError EvalError) ': effects) a
-                  -> Evaluator term address value effects a
+                  => Evaluator term address value (ResumableWithC (BaseError EvalError) (Eff
+                                                  m)) a
+                  -> Evaluator term address value m a
 resumingEvalError = runEvalErrorWith (\ baseError -> traceError "EvalError" baseError *> case baseErrorException baseError of
   DefaultExportError{}  -> pure ()
   ExportError{}         -> pure ()
@@ -345,32 +353,35 @@ resumingEvalError = runEvalErrorWith (\ baseError -> traceError "EvalError" base
   NoNameError           -> gensym)
 
 resumingUnspecialized :: ( AbstractHole value
-                         , Effects effects
-                         , Member Trace effects
+                         , Carrier sig m
+                         , Member Trace sig
                          )
-                      => Evaluator term address value (Resumable (BaseError (UnspecializedError value)) ': effects) a
-                      -> Evaluator term address value effects a
+                      => Evaluator term address value (ResumableWithC (BaseError (UnspecializedError value)) (Eff
+                                                      m)) a
+                      -> Evaluator term address value m a
 resumingUnspecialized = runUnspecializedWith (\ baseError -> traceError "UnspecializedError" baseError *> case baseErrorException baseError of
   UnspecializedError _ -> pure hole)
 
 resumingAddressError :: ( AbstractHole value
-                        , Effects effects
-                        , Member Trace effects
+                        , Carrier sig m
+                        , Member Trace sig
                         , Show address
                         )
-                     => Evaluator term address value (Resumable (BaseError (AddressError address value)) ': effects) a
-                     -> Evaluator term address value effects a
+                     => Evaluator term address value (ResumableWithC (BaseError (AddressError address value)) (Eff
+                                                     m)) a
+                     -> Evaluator term address value m a
 resumingAddressError = runAddressErrorWith $ \ baseError -> traceError "AddressError" baseError *> case baseErrorException baseError of
   UnallocatedAddress   _ -> pure lowerBound
   UninitializedAddress _ -> pure hole
 
-resumingValueError :: ( Effects effects
-                      , Member Trace effects
+resumingValueError :: ( Carrier sig m
+                      , Member Trace sig
                       , Show address
                       , Show term
                       )
-                   => Evaluator term address (Value term address) (Resumable (BaseError (ValueError term address)) ': effects) a
-                   -> Evaluator term address (Value term address) effects a
+                   => Evaluator term address (Value term address) (ResumableWithC (BaseError (ValueError term address)) (Eff
+                                                                  m)) a
+                   -> Evaluator term address (Value term address) m a
 resumingValueError = runValueErrorWith (\ baseError -> traceError "ValueError" baseError *> case baseErrorException baseError of
   CallError val     -> pure val
   StringError val   -> pure (pack (prettyShow val))
@@ -387,19 +398,23 @@ resumingValueError = runValueErrorWith (\ baseError -> traceError "ValueError" b
   ArrayError{}      -> pure lowerBound
   ArithmeticError{} -> pure hole)
 
-resumingEnvironmentError :: ( Effects effects
-                            , Member Trace effects
+resumingEnvironmentError :: ( Carrier sig m
+                            , Member Trace sig
                             )
-                         => Evaluator term (Hole (Maybe Name) address) value (Resumable (BaseError (EnvironmentError (Hole (Maybe Name) address))) ': effects) a
-                         -> Evaluator term (Hole (Maybe Name) address) value effects a
-resumingEnvironmentError = runResumableWith (\ baseError -> traceError "EnvironmentError" baseError >> (\ (FreeVariable name) -> pure (Partial (Just name))) (baseErrorException baseError))
+                         => Evaluator term (Hole (Maybe Name) address) value (ResumableWithC (BaseError (EnvironmentError (Hole (Maybe Name) address))) (Eff
+                                                                             m)) a
+                         -> Evaluator term (Hole (Maybe Name) address) value m a
+resumingEnvironmentError = runEnvironmentErrorWith (\ baseError -> traceError "EnvironmentError" baseError >> (\ (FreeVariable name) -> pure (Partial (Just name))) (baseErrorException baseError))
 
-resumingTypeError :: ( Effects effects
-                     , Member NonDet effects
-                     , Member Trace effects
+resumingTypeError :: ( Carrier sig m
+                     , Member NonDet sig
+                     , Member Trace sig
+                     , Effect sig
                      )
-                  => Evaluator term address Type (Resumable (BaseError TypeError) ': State TypeMap ': effects) a
-                  -> Evaluator term address Type effects a
+                  => Evaluator term address Type (ResumableWithC (BaseError TypeError) (Eff
+                                                 (StateC TypeMap (Eff
+                                                 m)))) a
+                  -> Evaluator term address Type m a
 resumingTypeError = runTypesWith (\ baseError -> traceError "TypeError" baseError *> case baseErrorException baseError of
   UnificationError l r -> pure l <|> pure r
   InfiniteType _ r     -> pure r)
@@ -407,5 +422,5 @@ resumingTypeError = runTypesWith (\ baseError -> traceError "TypeError" baseErro
 prettyShow :: Show a => a -> String
 prettyShow = hscolour TTY defaultColourPrefs False False "" False . ppShow
 
-traceError :: (Member Trace effects, Show (exc resume)) => String -> BaseError exc resume -> Evaluator term address value effects ()
+traceError :: (Member Trace sig, Show (exc resume), Carrier sig m) => String -> BaseError exc resume -> Evaluator term address value m ()
 traceError prefix baseError = trace $ prefix <> ": " <> prettyShow baseError

src/Semantic/IO.hs

@@ -5,7 +5,7 @@ module Semantic.IO
   ) where
 
 import Prelude hiding (readFile)
-import Prologue hiding (MonadError (..), fail)
+import Prologue
 
 import           System.Directory (doesDirectoryExist)
 import           System.Directory.Tree (AnchoredDirTree (..))
@@ -16,7 +16,7 @@ isDirectory :: MonadIO m => FilePath -> m Bool
 isDirectory path = liftIO (doesDirectoryExist path)
 
 -- Recursively find files in a directory.
-findFilesInDir :: forall m. MonadIO m => FilePath -> [String] -> [FilePath] -> m [FilePath]
+findFilesInDir :: MonadIO m => FilePath -> [String] -> [FilePath] -> m [FilePath]
 findFilesInDir path exts excludeDirs = do
   _:/dir <- liftIO $ Tree.build path
   pure $ (onlyFiles . Tree.filterDir (withExtensions exts) . Tree.filterDir (notIn excludeDirs)) dir

src/Semantic/Parse.hs

@@ -4,7 +4,9 @@ module Semantic.Parse ( runParse, runParse', parseSomeBlob ) where
 import           Analysis.ConstructorName (ConstructorName)
 import           Analysis.Declaration (HasDeclaration, declarationAlgebra)
 import           Analysis.PackageDef (HasPackageDef)
-import           Control.Monad.Effect.Exception
+import           Control.Effect
+import           Control.Effect.Error
+import           Control.Monad.IO.Class
 import           Data.Blob
 import           Data.Either
 import           Data.ByteString.Builder (stringUtf8)
@@ -14,7 +16,7 @@ import           Data.Quieterm
 import           Data.Location
 import           Data.Term
 import           Parsing.Parser
-import           Prologue hiding (MonadError (..))
+import           Prologue
 import           Rendering.Graph
 import           Rendering.JSON (SomeJSON (..))
 import qualified Rendering.JSON as JSON
@@ -23,7 +25,7 @@ import           Semantic.Task
 import           Serializing.Format
 
 -- | Using the specified renderer, parse a list of 'Blob's to produce a 'Builder' output.
-runParse :: (Member Distribute effs, Member (Exc SomeException) effs, Member Task effs, Member (Lift IO) effs) => TermRenderer output -> [Blob] -> Eff effs Builder
+runParse :: (Member Distribute sig, Member (Error SomeException) sig, Member Task sig, Carrier sig m, MonadIO m) => TermRenderer output -> [Blob] -> m Builder
 runParse JSONTermRenderer             = withParsedBlobs' renderJSONError (render . renderJSONTerm) >=> serialize JSON
 runParse JSONGraphTermRenderer        = withParsedBlobs' renderJSONError (render . renderAdjGraph) >=> serialize JSON
   where renderAdjGraph :: (Recursive t, ToTreeGraph TermVertex (Base t)) => Blob -> t -> JSON.JSON "trees" SomeJSON
@@ -40,29 +42,32 @@ runParse QuietTermRenderer            = distributeFoldMap $ \blob ->
       in stringUtf8 (status <> "\t" <> show blobLanguage <> "\t" <> blobPath <> "\t" <> show duration <> " ms\n")
 
 -- | For testing and running parse-examples.
-runParse' :: (Member (Exc SomeException) effs, Member Task effs) => Blob -> Eff effs Builder
+runParse' :: (Member (Error SomeException) sig, Member Task sig, Monad m, Carrier sig m) => Blob -> m Builder
 runParse' blob = parseSomeBlob blob >>= withSomeTerm (serialize Show . quieterm)
 
-type Render effs output = forall syntax .
-  ( ConstructorName syntax
-  , HasDeclaration syntax
-  , HasPackageDef syntax
-  , Foldable syntax
-  , Functor syntax
-  , Show1 syntax
-  , ToJSONFields1 syntax
-  )
-  => Blob -> Term syntax Location -> Eff effs output
+type Render m output
+  = forall syntax
+  .  ( ConstructorName syntax
+     , HasDeclaration syntax
+     , HasPackageDef syntax
+     , Foldable syntax
+     , Functor syntax
+     , Show1 syntax
+     , ToJSONFields1 syntax
+     )
+  => Blob
+  -> Term syntax Location
+  -> m output
 
-withParsedBlobs :: (Member Distribute effs, Member (Exc SomeException) effs, Member Task effs, Monoid output)
-  => Render effs output -> [Blob] -> Eff effs output
+withParsedBlobs :: (Member Distribute sig, Member (Error SomeException) sig, Member Task sig, Monad m, Monoid output, Carrier sig m)
+  => Render m output -> [Blob] -> m output
 withParsedBlobs render = distributeFoldMap $ \blob -> parseSomeBlob blob >>= withSomeTerm (render blob)
 
-withParsedBlobs' :: (Member Distribute effs, Member (Exc SomeException) effs, Member Task effs, Monoid output)
-  => (Blob -> String -> output) -> Render effs output -> [Blob] -> Eff effs output
+withParsedBlobs' :: (Member Distribute sig, Member (Error SomeException) sig, Member Task sig, Monad m, Monoid output, Carrier sig m)
+  => (Blob -> String -> output) -> Render m output -> [Blob] -> m output
 withParsedBlobs' onError render = distributeFoldMap $ \blob ->
   (parseSomeBlob blob >>= withSomeTerm (render blob)) `catchError` \(SomeException e) ->
     pure (onError blob (show e))
 
-parseSomeBlob :: (Member (Exc SomeException) effs, Member Task effs) => Blob -> Eff effs (SomeTerm '[ConstructorName, Foldable, Functor, HasDeclaration, HasPackageDef, Show1, ToJSONFields1] Location)
+parseSomeBlob :: (Member (Error SomeException) sig, Member Task sig, Carrier sig m) => Blob -> m (SomeTerm '[ConstructorName, Foldable, Functor, HasDeclaration, HasPackageDef, Show1, ToJSONFields1] Location)
 parseSomeBlob blob@Blob{..} = maybe (noLanguageForBlob blobPath) (`parse` blob) (someParser blobLanguage)

src/Semantic/REPL.hs

@@ -1,11 +1,13 @@
-{-# LANGUAGE GADTs, KindSignatures, LambdaCase, TypeOperators #-}
+{-# LANGUAGE GADTs, KindSignatures, LambdaCase, TypeOperators, UndecidableInstances #-}
 {-# OPTIONS_GHC -Wno-missing-signatures #-}
 module Semantic.REPL
 ( rubyREPL
 ) where
 
 import Control.Abstract hiding (Continue, List, string)
-import Control.Monad.Effect.Resource
+import Control.Effect.Carrier
+import Control.Effect.Resource
+import Control.Effect.Sum
 import Data.Abstract.Address.Precise as Precise
 import Data.Abstract.Environment as Env
 import Data.Abstract.Evaluatable hiding (string)
@@ -14,6 +16,7 @@ import Data.Abstract.ModuleTable as ModuleTable
 import Data.Abstract.Package
 import Data.Abstract.Value.Concrete as Concrete
 import Data.Blob (Blob(..))
+import Data.Coerce
 import Data.Error (showExcerpt)
 import Data.File (File (..), readBlobFromFile)
 import Data.Graph (topologicalSort)
@@ -26,7 +29,7 @@ import qualified Data.Time.Clock.POSIX as Time (getCurrentTime)
 import qualified Data.Time.LocalTime as LocalTime
 import Numeric (readDec)
 import Parsing.Parser (rubyParser)
-import Prologue hiding (throwError)
+import Prologue
 import Semantic.Config (logOptionsFromConfig)
 import Semantic.Distribute
 import Semantic.Graph
@@ -41,15 +44,16 @@ import System.Console.Haskeline
 import System.Directory (createDirectoryIfMissing, getHomeDirectory)
 import System.FilePath
 
-data REPL (m :: * -> *) result where
-  Prompt :: REPL m (Maybe String)
-  Output :: String -> REPL m ()
+data REPL (m :: * -> *) k
+  = Prompt (Maybe String -> k)
+  | Output String k
+  deriving (Functor)
 
-prompt :: (Effectful m, Member REPL effects) => m effects (Maybe String)
-prompt = send Prompt
+prompt :: (Member REPL sig, Carrier sig m) => m (Maybe String)
+prompt = send (Prompt ret)
 
-output :: (Effectful m, Member REPL effects) => String -> m effects ()
-output s = send (Output s)
+output :: (Member REPL sig, Carrier sig m) => String -> m ()
+output s = send (Output s (ret ()))
 
 
 data Quit = Quit
@@ -58,16 +62,25 @@ data Quit = Quit
 instance Exception Quit
 
 
-instance PureEffect REPL
+instance HFunctor REPL where
+  hmap _ = coerce
+
 instance Effect REPL where
-  handleState state handler (Request Prompt k) = Request Prompt (handler . (<$ state) . k)
-  handleState state handler (Request (Output s) k) = Request (Output s) (handler . (<$ state) . k)
+  handle state handler (Prompt k) = Prompt (handler . (<$ state) . k)
+  handle state handler (Output s k) = Output s (handler (k <$ state))
 
 
-runREPL :: (Effectful m, MonadIO (m effects), PureEffects effects) => Prefs -> Settings IO -> m (REPL ': effects) a -> m effects a
-runREPL prefs settings = interpret $ \case
-  Prompt   -> liftIO (runInputTWithPrefs prefs settings (getInputLine (cyan <> "repl: " <> plain)))
-  Output s -> liftIO (runInputTWithPrefs prefs settings (outputStrLn s))
+runREPL :: (MonadIO m, Carrier sig m) => Prefs -> Settings IO -> Eff (REPLC m) a -> m a
+runREPL prefs settings = flip runREPLC (prefs, settings) . interpret
+
+newtype REPLC m a = REPLC { runREPLC :: (Prefs, Settings IO) -> m a }
+
+instance (Carrier sig m, MonadIO m) => Carrier (REPL :+: sig) (REPLC m) where
+  ret = REPLC . const . ret
+  eff op = REPLC (\ args -> (alg args \/ eff . handleReader args runREPLC) op)
+    where alg args = \case
+            Prompt   k -> liftIO (uncurry runInputTWithPrefs args (getInputLine (cyan <> "repl: " <> plain))) >>= flip runREPLC args . k
+            Output s k -> liftIO (uncurry runInputTWithPrefs args (outputStrLn s)) *> runREPLC k args
 
 rubyREPL = repl (Proxy @'Language.Ruby) rubyParser
 
@@ -89,10 +102,11 @@ repl proxy parser paths = defaultConfig debugOptions >>= \ config -> runM . runD
     . fmap snd
     . runState ([] @Breakpoint)
     . runReader Step
+    . runEvaluator
     . id @(Evaluator _ Precise (Value _ Precise) _ _)
-    . runPrintingTrace
+    . raiseHandler runTraceByPrinting
     . runHeap
-    . runFresh 0
+    . raiseHandler runFresh
     . fmap reassociate
     . runLoadError
     . runUnspecialized
@@ -101,35 +115,43 @@ repl proxy parser paths = defaultConfig debugOptions >>= \ config -> runM . runD
     . runResolutionError
     . runAddressError
     . runValueError
-    . runReader (lowerBound @(ModuleTable (NonEmpty (Module (ModuleResult Precise)))))
+    . runModuleTable
     . runModules (ModuleTable.modulePaths (packageModules (snd <$> package)))
-    . runReader (packageInfo package)
-    . runState (lowerBound @Span)
-    . runReader (lowerBound @Span)
-    $ evaluate proxy id (withTermSpans . step (fmap (\ (x:|_) -> moduleBody x) <$> ModuleTable.toPairs (packageModules (fst <$> package)))) (Precise.runAllocator . Precise.runDeref) (fmap (Concrete.runBoolean . Concrete.runWhile) . Concrete.runFunction) modules
+    . raiseHandler (runReader (packageInfo package))
+    . raiseHandler (runState (lowerBound @Span))
+    . raiseHandler (runReader (lowerBound @Span))
+    $ evaluate proxy id (withTermSpans . step (fmap (\ (x:|_) -> moduleBody x) <$> ModuleTable.toPairs (packageModules (fst <$> package)))) modules
 
 -- TODO: REPL for typechecking/abstract semantics
 -- TODO: drive the flow from within the REPL instead of from without
 
-runTelemetryIgnoringStat :: (Effectful m, MonadIO (m effects), PureEffects effects) => LogOptions -> m (Telemetry : effects) a -> m effects a
-runTelemetryIgnoringStat logOptions = interpret $ \case
-  WriteStat{} -> pure ()
-  WriteLog level message pairs -> do
-    time <- liftIO Time.getCurrentTime
-    zonedTime <- liftIO (LocalTime.utcToLocalZonedTime time)
-    writeLogMessage logOptions (Message level message pairs zonedTime)
+runTelemetryIgnoringStat :: (Carrier sig m, MonadIO m) => LogOptions -> Eff (TelemetryIgnoringStatC m) a -> m a
+runTelemetryIgnoringStat logOptions = flip runTelemetryIgnoringStatC logOptions . interpret
 
-step :: ( Member (Env address) effects
-        , Member (Exc SomeException) effects
-        , Member REPL effects
-        , Member (Reader ModuleInfo) effects
-        , Member (Reader Span) effects
-        , Member (Reader Step) effects
-        , Member (State [Breakpoint]) effects
+newtype TelemetryIgnoringStatC m a = TelemetryIgnoringStatC { runTelemetryIgnoringStatC :: LogOptions -> m a }
+
+instance (Carrier sig m, MonadIO m) => Carrier (Telemetry :+: sig) (TelemetryIgnoringStatC m) where
+  ret = TelemetryIgnoringStatC . const . ret
+  eff op = TelemetryIgnoringStatC (\ logOptions -> (algT logOptions \/ eff . handleReader logOptions runTelemetryIgnoringStatC) op)
+    where algT logOptions (WriteStat _ k) = runTelemetryIgnoringStatC k logOptions
+          algT logOptions (WriteLog level message pairs k) = do
+            time <- liftIO Time.getCurrentTime
+            zonedTime <- liftIO (LocalTime.utcToLocalZonedTime time)
+            writeLogMessage logOptions (Message level message pairs zonedTime)
+            runTelemetryIgnoringStatC k logOptions
+
+step :: ( Member (Env address) sig
+        , Member (Error SomeException) sig
+        , Member REPL sig
+        , Member (Reader ModuleInfo) sig
+        , Member (Reader Span) sig
+        , Member (Reader Step) sig
+        , Member (State [Breakpoint]) sig
         , Show address
+        , Carrier sig m
         )
      => [(ModulePath, Blob)]
-     -> Open (Open (term -> Evaluator term address value effects a))
+     -> Open (Open (term -> Evaluator term address value m a))
 step blobs recur0 recur term = do
   break <- shouldBreak
   if break then do
@@ -157,7 +179,7 @@ step blobs recur0 recur term = do
         runCommand run [":step"]     = local (const Step) run
         runCommand run [":continue"] = local (const Continue) run
         runCommand run [":break", s]
-          | [(i, "")] <- readDec s = modify' (OnLine i :) >> runCommands run
+          | [(i, "")] <- readDec s = modify (OnLine i :) >> runCommands run
         -- TODO: :show breakpoints
         -- TODO: :delete breakpoints
         runCommand run [":list"] = list >> runCommands run
@@ -189,7 +211,7 @@ data Step
 
 -- TODO: StepLocal/StepModule
 
-shouldBreak :: (Member (State [Breakpoint]) effects, Member (Reader Span) effects, Member (Reader Step) effects) => Evaluator term address value effects Bool
+shouldBreak :: (Member (State [Breakpoint]) sig, Member (Reader Span) sig, Member (Reader Step) sig, Carrier sig m) => Evaluator term address value m Bool
 shouldBreak = do
   step <- ask
   case step of

src/Semantic/Resolution.hs

@@ -4,12 +4,16 @@ module Semantic.Resolution
   , nodeJSResolutionMap
   , resolutionMap
   , runResolution
+  , ResolutionC(..)
   ) where
 
-import           Control.Monad.Effect
+import           Control.Effect
+import           Control.Effect.Carrier
+import           Control.Effect.Sum
 import           Data.Aeson
 import           Data.Aeson.Types (parseMaybe)
 import           Data.Blob
+import           Data.Coerce
 import           Data.File
 import           Data.Project
 import qualified Data.Map as Map
@@ -20,7 +24,7 @@ import           Semantic.Task.Files
 import           System.FilePath.Posix
 
 
-nodeJSResolutionMap :: Member Files effs => FilePath -> Text -> [FilePath] -> Eff effs (Map FilePath FilePath)
+nodeJSResolutionMap :: (Member Files sig, Carrier sig m, Monad m) => FilePath -> Text -> [FilePath] -> m (Map FilePath FilePath)
 nodeJSResolutionMap rootDir prop excludeDirs = do
   files <- findFiles rootDir [".json"] excludeDirs
   let packageFiles = file <$> filter ((==) "package.json" . takeFileName) files
@@ -35,22 +39,31 @@ nodeJSResolutionMap rootDir prop excludeDirs = do
       where relPkgDotJSONPath = makeRelative rootDir path
             relEntryPath x = takeDirectory relPkgDotJSONPath </> x
 
-resolutionMap :: Member Resolution effs => Project -> Eff effs (Map FilePath FilePath)
+resolutionMap :: (Member Resolution sig, Carrier sig m) => Project -> m (Map FilePath FilePath)
 resolutionMap Project{..} = case projectLanguage of
-  TypeScript -> send (NodeJSResolution projectRootDir "types" projectExcludeDirs)
-  JavaScript -> send (NodeJSResolution projectRootDir "main" projectExcludeDirs)
-  _          -> send NoResolution
+  TypeScript -> send (NodeJSResolution projectRootDir "types" projectExcludeDirs ret)
+  JavaScript -> send (NodeJSResolution projectRootDir "main"  projectExcludeDirs ret)
+  _          -> send (NoResolution ret)
 
-data Resolution (m :: * -> *) output where
-  NodeJSResolution :: FilePath -> Text -> [FilePath] -> Resolution m (Map FilePath FilePath)
-  NoResolution     ::                                   Resolution m (Map FilePath FilePath)
+data Resolution (m :: * -> *) k
+  = NodeJSResolution FilePath Text [FilePath] (Map FilePath FilePath -> k)
+  | NoResolution                              (Map FilePath FilePath -> k)
+  deriving (Functor)
+
+instance HFunctor Resolution where
+  hmap _ = coerce
 
-instance PureEffect Resolution
 instance Effect Resolution where
-  handleState c dist (Request (NodeJSResolution path key paths) k) = Request (NodeJSResolution path key paths) (dist . (<$ c) . k)
-  handleState c dist (Request NoResolution k) = Request NoResolution (dist . (<$ c) . k)
+  handle state handler (NodeJSResolution path key paths k) = NodeJSResolution path key paths (handler . (<$ state) . k)
+  handle state handler (NoResolution k) = NoResolution (handler . (<$ state) . k)
 
-runResolution :: (Member Files effs, PureEffects effs) => Eff (Resolution ': effs) a -> Eff effs a
-runResolution = interpret $ \ res -> case res of
-  NodeJSResolution dir prop excludeDirs -> nodeJSResolutionMap dir prop excludeDirs
-  NoResolution                          -> pure Map.empty
+runResolution :: (Member Files sig, Carrier sig m, Monad m) => Eff (ResolutionC m) a -> m a
+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
+  ret = ResolutionC . ret
+  eff = ResolutionC . (alg \/ eff . handleCoercible)
+    where alg (NodeJSResolution dir prop excludeDirs k) = nodeJSResolutionMap dir prop excludeDirs >>= runResolutionC . k
+          alg (NoResolution k) = runResolutionC (k Map.empty)

src/Semantic/Task.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE ConstraintKinds, GADTs, KindSignatures, ScopedTypeVariables, TypeOperators #-}
+{-# LANGUAGE ConstraintKinds, ExistentialQuantification, GADTs, KindSignatures, LambdaCase, ScopedTypeVariables, StandaloneDeriving, TypeOperators, UndecidableInstances #-}
 module Semantic.Task
 ( Task
 , TaskEff
@@ -47,7 +47,7 @@ module Semantic.Task
 -- * Re-exports
 , Distribute
 , Eff
-, Exc
+, Error
 , Lift
 , throwError
 , SomeException(..)
@@ -58,15 +58,19 @@ import           Analysis.Decorator (decoratorWithAlgebra)
 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.Effect
-import           Control.Monad.Effect.Exception
-import           Control.Monad.Effect.Reader
-import           Control.Monad.Effect.Resource
-import           Control.Monad.Effect.Trace
+import           Control.Monad.IO.Class
 import           Data.Blob
 import           Data.Bool
 import           Data.ByteString.Builder
+import           Data.Coerce
 import           Data.Diff
 import           Data.Duration
 import qualified Data.Error as Error
@@ -81,7 +85,7 @@ import           Diffing.Interpreter
 import           Parsing.CMark
 import           Parsing.Parser
 import           Parsing.TreeSitter
-import           Prologue hiding (MonadError (..), project)
+import           Prologue hiding (project)
 import           Semantic.Config
 import           Semantic.Distribute
 import qualified Semantic.Task.Files as Files
@@ -92,62 +96,88 @@ import           Serializing.Format hiding (Options)
 import           System.Exit (die)
 
 -- | A high-level task producing some result, e.g. parsing, diffing, rendering. 'Task's can also specify explicit concurrency via 'distribute', 'distributeFor', and 'distributeFoldMap'
-type TaskEff = Eff '[ Task
-                    , Resolution
-                    , Files.Files
-                    , Reader Config
-                    , Trace
-                    , Telemetry
-                    , Exc SomeException
-                    , Timeout
-                    , Resource
-                    , Distribute
-                    , Lift IO
-                    ]
+type TaskEff
+  = Eff (TaskC
+  ( Eff (ResolutionC
+  ( Eff (Files.FilesC
+  ( Eff (ReaderC Config
+  ( Eff (TraceInTelemetryC
+  ( Eff (TelemetryC
+  ( Eff (ErrorC SomeException
+  ( Eff (TimeoutC
+  ( Eff (ResourceC
+  ( Eff (DistributeC
+  ( Eff (LiftC IO)))))))))))))))))))))
 
 -- | A function to render terms or diffs.
 type Renderer i o = i -> o
 
 -- | A task which parses a 'Blob' with the given 'Parser'.
-parse :: Member Task effs => Parser term -> Blob -> Eff effs term
-parse parser = send . Parse parser
+parse :: (Member Task sig, Carrier sig m)
+      => Parser term
+      -> Blob
+      -> m term
+parse parser blob = send (Parse parser blob ret)
 
 -- | A task running some 'Analysis.Evaluator' to completion.
-analyze :: Member Task effs => (Analysis.Evaluator term address value effects a -> result) -> Analysis.Evaluator term address value effects a -> Eff effs result
-analyze interpret analysis = send (Analyze interpret analysis)
+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 ret)
 
 -- | A task which decorates a 'Term' with values computed using the supplied 'RAlgebra' function.
-decorate :: (Functor f, Member Task effs) => RAlgebra (TermF f Location) (Term f Location) field -> Term f Location -> Eff effs (Term f field)
-decorate algebra = send . Decorate algebra
+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 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 effs) => These (Term syntax ann) (Term syntax ann) -> Eff effs (Diff syntax ann ann)
-diff terms = send (Semantic.Task.Diff terms)
+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 ret)
 
 -- | A task which renders some input using the supplied 'Renderer' function.
-render :: Member Task effs => Renderer input output -> input -> Eff effs output
-render renderer = send . Render renderer
+render :: (Member Task sig, Carrier sig m)
+       => Renderer input output
+       -> input
+       -> m output
+render renderer input = send (Render renderer input ret)
 
-serialize :: Member Task effs => Format input -> input -> Eff effs Builder
-serialize format = send . Serialize format
+serialize :: (Member Task sig, Carrier sig m)
+          => Format input
+          -> input
+          -> m Builder
+serialize format input = send (Serialize format input ret)
 
 -- | Execute a 'Task' with the 'defaultOptions', yielding its result value in 'IO'.
 --
 -- > runTask = runTaskWithOptions defaultOptions
-runTask :: TaskEff a -> IO a
+runTask :: TaskEff a
+        -> IO a
 runTask = runTaskWithOptions defaultOptions
 
 -- | Execute a 'TaskEff' with the passed 'Options', yielding its result value in 'IO'.
-runTaskWithOptions :: Options -> TaskEff a -> IO a
+runTaskWithOptions :: Options
+                   -> TaskEff a
+                   -> IO a
 runTaskWithOptions opts task = withOptions opts (\ config logger statter -> runTaskWithConfig config logger statter task) >>= either (die . displayException) pure
 
-withOptions :: Options -> (Config -> LogQueue -> StatQueue -> IO a) -> IO a
+withOptions :: Options
+            -> (Config -> LogQueue -> StatQueue -> IO a)
+            -> IO a
 withOptions options with = do
   config <- defaultConfig options
   withTelemetry config (\ (TelemetryQueues logger statter _) -> with config logger statter)
 
 -- | Execute a 'TaskEff' yielding its result value in 'IO'.
-runTaskWithConfig :: Config -> LogQueue -> StatQueue -> TaskEff a -> IO (Either SomeException a)
+runTaskWithConfig :: Config
+                  -> LogQueue
+                  -> StatQueue
+                  -> TaskEff a
+                  -> IO (Either SomeException a)
 runTaskWithConfig options logger statter task = do
   (result, stat) <- withTiming "run" [] $ do
     let run :: TaskEff a -> IO (Either SomeException a)
@@ -167,43 +197,79 @@ runTaskWithConfig options logger statter task = do
   queueStat statter stat
   pure result
 
-runTraceInTelemetry :: (Member Telemetry effects, PureEffects effects) => Eff (Trace ': effects) a -> Eff effects a
-runTraceInTelemetry = interpret (\ (Trace str) -> writeLog Debug str [])
+runTraceInTelemetry :: (Member Telemetry sig, Carrier sig m, Monad m)
+                    => Eff (TraceInTelemetryC m) a
+                    -> m a
+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
+  ret = TraceInTelemetryC . ret
+  eff = TraceInTelemetryC . ((\ (Trace str k) -> writeLog Debug str [] >> runTraceInTelemetryC k) \/ eff . handleCoercible)
 
 
 -- | An effect describing high-level tasks to be performed.
-data Task (m :: * -> *) output where
-  Parse     :: Parser term -> Blob -> Task m term
-  Analyze   :: (Analysis.Evaluator term address value effects a -> result) -> Analysis.Evaluator term address value effects a -> Task m result
-  Decorate  :: Functor f => RAlgebra (TermF f Location) (Term f Location) field -> Term f Location -> Task m (Term f field)
-  Diff      :: (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax) => These (Term syntax ann) (Term syntax ann) -> Task m (Diff syntax ann ann)
-  Render    :: Renderer input output -> input -> Task m output
-  Serialize :: Format input -> input -> Task m Builder
+data Task (m :: * -> *) k
+  = forall term . Parse (Parser term) Blob (term -> k)
+  | forall term address value m a result . Analyze (Analysis.Evaluator term address value m a -> result) (Analysis.Evaluator term address value m a) (result -> k)
+  | forall f field . Functor f => Decorate (RAlgebra (TermF f Location) (Term f Location) field) (Term f Location) (Term f field -> k)
+  | forall syntax ann . (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax) => Diff (These (Term syntax ann) (Term syntax ann)) (Diff syntax ann ann -> k)
+  | forall input output . Render (Renderer input output) input (output -> k)
+  | forall input . Serialize (Format input) input (Builder -> k)
+
+deriving instance Functor (Task m)
+
+instance HFunctor Task where
+  hmap _ = coerce
 
-instance PureEffect Task
 instance Effect Task where
-  handleState c dist (Request (Parse parser blob) k) = Request (Parse parser blob) (dist . (<$ c) . k)
-  handleState c dist (Request (Analyze run analysis) k) = Request (Analyze run analysis) (dist . (<$ c) . k)
-  handleState c dist (Request (Decorate decorator term) k) = Request (Decorate decorator term) (dist . (<$ c) . k)
-  handleState c dist (Request (Semantic.Task.Diff terms) k) = Request (Semantic.Task.Diff terms) (dist . (<$ c) . k)
-  handleState c dist (Request (Render renderer input) k) = Request (Render renderer input) (dist . (<$ c) . k)
-  handleState c dist (Request (Serialize format input) k) = Request (Serialize format input) (dist . (<$ c) . k)
+  handle state handler (Parse parser blob k) = Parse parser blob (handler . (<$ state) . k)
+  handle state handler (Analyze run analysis k) = Analyze run analysis (handler . (<$ state) . k)
+  handle state handler (Decorate decorator term k) = Decorate decorator term (handler . (<$ state) . k)
+  handle state handler (Semantic.Task.Diff terms k) = Semantic.Task.Diff terms (handler . (<$ state) . k)
+  handle state handler (Render renderer input k) = Render renderer input (handler . (<$ state) . k)
+  handle state handler (Serialize format input k) = Serialize format input (handler . (<$ state) . k)
 
 -- | Run a 'Task' effect by performing the actions in 'IO'.
-runTaskF :: (Member (Exc SomeException) effs, Member (Lift IO) effs, Member (Reader Config) effs, Member Resource effs, Member Telemetry effs, Member Timeout effs, Member Trace effs, PureEffects effs) => Eff (Task ': effs) a -> Eff effs a
-runTaskF = interpret $ \ task -> case task of
-  Parse parser blob -> runParser blob parser
-  Analyze interpret analysis -> pure (interpret analysis)
-  Decorate algebra term -> pure (decoratorWithAlgebra algebra term)
-  Semantic.Task.Diff terms -> pure (diffTermPair terms)
-  Render renderer input -> pure (renderer input)
-  Serialize format input -> do
-    formatStyle <- asks (bool Plain Colourful . configIsTerminal)
-    pure (runSerialize formatStyle format input)
+runTaskF :: ( 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
+            )
+         => Eff (TaskC m) a
+         -> m a
+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
+  ret = TaskC . ret
+  eff = TaskC . (alg \/ eff . handleCoercible)
+    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))
+            Semantic.Task.Diff terms k -> runTaskC (k (diffTermPair terms))
+            Render renderer input k -> runTaskC (k (renderer input))
+            Serialize format input k -> do
+              formatStyle <- asks (bool Plain Colourful . configIsTerminal)
+              runTaskC (k (runSerialize formatStyle format input))
 
 
 -- | Log an 'Error.Error' at the specified 'Level'.
-logError :: Member Telemetry effs => Config -> Level -> Blob -> Error.Error String -> [(String, String)] -> Eff effs ()
+logError :: (Member Telemetry sig, Carrier sig m)
+         => Config
+         -> Level
+         -> Blob
+         -> Error.Error String
+         -> [(String, String)]
+         -> m ()
 logError Config{..} level blob err = writeLog level (Error.formatError configLogPrintSource configIsTerminal blob err)
 
 data ParserCancelled = ParserTimedOut FilePath Language | AssignmentTimedOut FilePath Language
@@ -212,7 +278,10 @@ data ParserCancelled = ParserTimedOut FilePath Language | AssignmentTimedOut Fil
 instance Exception ParserCancelled
 
 -- | Parse a 'Blob' in 'IO'.
-runParser :: (Member (Exc SomeException) effs, Member (Lift IO) effs, Member (Reader Config) effs, Member Resource effs, Member Telemetry effs, Member Timeout effs, Member Trace effs, PureEffects effs) => Blob -> Parser term -> Eff effs term
+runParser :: (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)
+          => Blob
+          -> Parser term
+          -> m term
 runParser blob@Blob{..} parser = case parser of
   ASTParser language ->
     time "parse.tree_sitter_ast_parse" languageTag $ do
@@ -236,19 +305,20 @@ runParser blob@Blob{..} parser = case parser of
         runAssignment :: ( Apply Foldable syntaxes
                          , Apply Functor syntaxes
                          , Element Syntax.Error syntaxes
-                         , Member (Exc SomeException) effs
-                         , Member (Lift IO) effs
-                         , Member (Reader Config) effs
-                         , Member Telemetry effs
-                         , Member Timeout effs
-                         , Member Trace effs
-                         , Member Resource effs
-                         , PureEffects effs
+                         , 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
                          )
                       => (Source -> assignment (Term (Sum syntaxes) Assignment.Location) -> ast -> Either (Error.Error String) (Term (Sum syntaxes) Assignment.Location))
                       -> Parser ast
                       -> assignment (Term (Sum syntaxes) Assignment.Location)
-                      -> Eff effs (Term (Sum syntaxes) Assignment.Location)
+                      -> m (Term (Sum syntaxes) Assignment.Location)
         runAssignment assign parser assignment = do
           config <- ask
           let blobFields = ("path", if configLogPrintSource config then blobPath else "<filtered>") : languageTag

src/Semantic/Task/Files.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE GADTs, KindSignatures, TypeOperators #-}
+{-# LANGUAGE ExistentialQuantification, GADTs, LambdaCase, KindSignatures, TypeOperators, UndecidableInstances #-}
 
 module Semantic.Task.Files
   ( Files
@@ -12,18 +12,23 @@ module Semantic.Task.Files
   , findFiles
   , write
   , Handle (..)
+  , FilesC(..)
   ) where
 
-import           Control.Monad.Effect
-import           Control.Monad.Effect.Exception
+import           Control.Effect
+import           Control.Effect.Carrier
+import           Control.Effect.Error
+import           Control.Effect.Sum
+import           Control.Exception as Exc
 import qualified Data.ByteString.Builder as B
 import           Data.Blob
+import           Data.Coerce
 import           Data.File
 import           Data.Handle
 import           Data.Language
 import           Data.Project hiding (readFile)
 import           Prelude hiding (readFile)
-import           Prologue hiding (MonadError (..), fail)
+import           Prologue
 import           Semantic.IO
 import qualified System.IO as IO
 
@@ -36,50 +41,72 @@ data Source blob where
 data Destination = ToPath FilePath | ToHandle (Handle 'IO.WriteMode)
 
 -- | An effect to read/write 'Blob's from 'Handle's or 'FilePath's.
-data Files (m :: * -> *) out where
-  Read        :: Source out                                           -> Files m out
-  ReadProject :: Maybe FilePath -> FilePath -> Language -> [FilePath] -> Files m Project
-  FindFiles   :: FilePath -> [String] -> [FilePath]                   -> Files m [FilePath]
-  Write       :: Destination -> B.Builder                             -> Files m ()
+data Files (m :: * -> *) k
+  = forall a . Read (Source a)                                (a -> k)
+  | ReadProject (Maybe FilePath) FilePath Language [FilePath] (Project -> k)
+  | FindFiles FilePath [String] [FilePath]                    ([FilePath] -> k)
+  | Write Destination B.Builder                               k
+
+deriving instance Functor (Files m)
+
+instance HFunctor Files where
+  hmap _ = coerce
 
-instance PureEffect Files
 instance Effect Files where
-  handleState c dist (Request (Read source) k) = Request (Read source) (dist . (<$ c) . k)
-  handleState c dist (Request (ReadProject rootDir dir language excludeDirs) k) = Request (ReadProject rootDir dir language excludeDirs) (dist . (<$ c) . k)
-  handleState c dist (Request (FindFiles dir exts paths) k) = Request (FindFiles dir exts paths) (dist . (<$ c) . k)
-  handleState c dist (Request (Write destination builder) k) = Request (Write destination builder) (dist . (<$ c) . k)
+  handle state handler (Read source k) = Read source (handler . (<$ state) . k)
+  handle state handler (ReadProject rootDir dir language excludeDirs k) = ReadProject rootDir dir language excludeDirs (handler . (<$ state) . k)
+  handle state handler (FindFiles dir exts paths k) = FindFiles dir exts paths (handler . (<$ state) . k)
+  handle state handler (Write destination builder k) = Write destination builder (handler (k <$ state))
 
 -- | Run a 'Files' effect in 'IO'.
-runFiles :: (Member (Exc SomeException) effs, Member (Lift IO) effs, PureEffects effs) => Eff (Files ': effs) a -> Eff effs a
-runFiles = interpret $ \ files -> case files of
-  Read (FromPath path)         -> rethrowing (readBlobFromFile' path)
-  Read (FromHandle handle)     -> rethrowing (readBlobsFromHandle handle)
-  Read (FromPathPair paths)    -> rethrowing (runBothWith readFilePair paths)
-  Read (FromPairHandle handle) -> rethrowing (readBlobPairsFromHandle handle)
-  ReadProject rootDir dir language excludeDirs -> rethrowing (readProjectFromPaths rootDir dir language excludeDirs)
-  FindFiles dir exts excludeDirs -> rethrowing (findFilesInDir dir exts excludeDirs)
-  Write (ToPath path)                   builder -> liftIO (IO.withBinaryFile path IO.WriteMode (`B.hPutBuilder` builder))
-  Write (ToHandle (WriteHandle handle)) builder -> liftIO (B.hPutBuilder handle builder)
+runFiles :: (Member (Error SomeException) sig, MonadIO m, Carrier sig m) => Eff (FilesC m) a -> m a
+runFiles = runFilesC . interpret
 
-readBlob :: Member Files effs => File -> Eff effs Blob
-readBlob = send . Read . FromPath
+newtype FilesC m a = FilesC { runFilesC :: m a }
+
+instance (Member (Error SomeException) sig, MonadIO m, Carrier sig m) => Carrier (Files :+: sig) (FilesC m) where
+  ret = FilesC . ret
+  eff = FilesC . (alg \/ eff . handleCoercible)
+    where alg = \case
+            Read (FromPath path) k -> (readBlobFromFile' 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
+            Read (FromPairHandle handle) k -> (readBlobPairsFromHandle handle `catchIO` (throwError . toException @SomeException)) >>= runFilesC . k
+            ReadProject rootDir dir language excludeDirs k -> (readProjectFromPaths rootDir dir language excludeDirs `catchIO` (throwError . toException @SomeException)) >>= runFilesC . k
+            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
+
+
+readBlob :: (Member Files sig, Carrier sig m) => File -> m Blob
+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 effs => Either (Handle 'IO.ReadMode) [File] -> Eff effs [Blob]
-readBlobs (Left handle) = send (Read (FromHandle handle))
-readBlobs (Right paths) = traverse (send . Read . FromPath) paths
+readBlobs :: (Member Files sig, Carrier sig m, Applicative m) => Either (Handle 'IO.ReadMode) [File] -> m [Blob]
+readBlobs (Left handle) = send (Read (FromHandle handle) ret)
+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 effs => Either (Handle 'IO.ReadMode) [Both File] -> Eff effs [BlobPair]
-readBlobPairs (Left handle) = send (Read (FromPairHandle handle))
-readBlobPairs (Right paths) = traverse (send . Read . FromPathPair) paths
+readBlobPairs :: (Member Files sig, Carrier sig m, Applicative m) => Either (Handle 'IO.ReadMode) [Both File] -> m [BlobPair]
+readBlobPairs (Left handle) = send (Read (FromPairHandle handle) ret)
+readBlobPairs (Right paths) = traverse (send . flip Read ret . FromPathPair) paths
 
-readProject :: Member Files effs => Maybe FilePath -> FilePath -> Language -> [FilePath] -> Eff effs Project
-readProject rootDir dir excludeDirs = send . ReadProject rootDir dir excludeDirs
+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 ret)
 
-findFiles :: Member Files effs => FilePath -> [String] -> [FilePath] -> Eff effs [FilePath]
-findFiles dir exts = send . FindFiles dir exts
+findFiles :: (Member Files sig, Carrier sig m) => FilePath -> [String] -> [FilePath] -> m [FilePath]
+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 effs => Destination -> B.Builder -> Eff effs ()
-write dest = send . Write dest
+write :: (Member Files sig, Carrier sig m) => Destination -> B.Builder -> m ()
+write dest builder = send (Write dest builder (ret ()))
+
+
+-- | 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/Telemetry.hs

@@ -45,12 +45,17 @@ module Semantic.Telemetry
 , time'
 , Telemetry(..)
 , runTelemetry
+, TelemetryC(..)
 , ignoreTelemetry
+, IgnoreTelemetryC(..)
 ) where
 
+import           Control.Effect
+import           Control.Effect.Carrier
+import           Control.Effect.Sum
 import           Control.Exception
-import           Control.Monad.Effect
 import           Control.Monad.IO.Class
+import           Data.Coerce
 import qualified Data.Time.Clock.POSIX as Time (getCurrentTime)
 import qualified Data.Time.LocalTime as LocalTime
 import           Network.HTTP.Client
@@ -115,41 +120,57 @@ queueStat q = liftIO . writeAsyncQueue q
 -- Eff interface
 
 -- | A task which logs a message at a specific log level to stderr.
-writeLog :: Member Telemetry effs => Level -> String -> [(String, String)] -> Eff effs ()
-writeLog level message pairs = send (WriteLog level message pairs)
+writeLog :: (Member Telemetry sig, Carrier sig m) => Level -> String -> [(String, String)] -> m ()
+writeLog level message pairs = send (WriteLog level message pairs (ret ()))
 
 -- | A task which writes a stat.
-writeStat :: Member Telemetry effs => Stat -> Eff effs ()
-writeStat stat = send (WriteStat stat)
+writeStat :: (Member Telemetry sig, Carrier sig m) => Stat -> m ()
+writeStat stat = send (WriteStat stat (ret ()))
 
 -- | A task which measures and stats the timing of another task.
-time :: (Member (Lift IO) effs, Member Telemetry effs) => String -> [(String, String)] -> Eff effs output -> Eff effs output
+time :: (Member Telemetry sig, Carrier sig m, MonadIO m) => String -> [(String, String)] -> m output -> m output
 time statName tags task = do
   (a, stat) <- withTiming statName tags task
   a <$ writeStat stat
 
 -- | A task which measures and returns the timing of another task.
-time' :: (Member (Lift IO) effs) => Eff effs output -> Eff effs (output, Double)
+time' :: MonadIO m => m output -> m (output, Double)
 time' = withTiming'
 
 -- | Statting and logging effects.
-data Telemetry (m :: * -> *) output where
-  WriteStat :: Stat                                  -> Telemetry m ()
-  WriteLog  :: Level -> String -> [(String, String)] -> Telemetry m ()
+data Telemetry (m :: * -> *) k
+  = WriteStat Stat k
+  | WriteLog Level String [(String, String)] k
+  deriving (Functor)
+
+instance HFunctor Telemetry where
+  hmap _ = coerce
 
-instance PureEffect Telemetry
 instance Effect Telemetry where
-  handleState c dist (Request (WriteStat stat) k) = Request (WriteStat stat) (dist . (<$ c) . k)
-  handleState c dist (Request (WriteLog level message pairs) k) = Request (WriteLog level message pairs) (dist . (<$ c) . k)
+  handle state handler (WriteStat stat k) = WriteStat stat (handler (k <$ state))
+  handle state handler (WriteLog level message pairs k) = WriteLog level message pairs (handler (k <$ state))
 
 -- | Run a 'Telemetry' effect by expecting a 'Reader' of 'Queue's to write stats and logs to.
-runTelemetry :: (Member (Lift IO) effects, PureEffects effects) => LogQueue -> StatQueue -> Eff (Telemetry ': effects) a -> Eff effects a
-runTelemetry logger statter = interpret (\ t -> case t of
-  WriteStat stat -> queueStat statter stat
-  WriteLog level message pairs -> queueLogMessage logger level message pairs)
+runTelemetry :: (Carrier sig m, MonadIO m) => LogQueue -> StatQueue -> Eff (TelemetryC m) a -> m a
+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
+  ret = TelemetryC . const . ret
+  eff op = TelemetryC (\ queues -> (alg queues \/ eff . handleReader queues runTelemetryC) op)
+    where alg queues (WriteStat stat k) = queueStat (snd queues) stat *> 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.
-ignoreTelemetry :: PureEffects effs => Eff (Telemetry ': effs) a -> Eff effs a
-ignoreTelemetry = interpret (\ t -> case t of
-  WriteStat{} -> pure ()
-  WriteLog{}  -> pure ())
+ignoreTelemetry :: Carrier sig m => Eff (IgnoreTelemetryC m) a -> m a
+ignoreTelemetry = runIgnoreTelemetryC . interpret
+
+newtype IgnoreTelemetryC m a = IgnoreTelemetryC { runIgnoreTelemetryC :: m a }
+
+instance Carrier sig m => Carrier (Telemetry :+: sig) (IgnoreTelemetryC m) where
+  ret = IgnoreTelemetryC . ret
+  eff = alg \/ (IgnoreTelemetryC . eff . handlePure runIgnoreTelemetryC)
+    where alg (WriteStat _ k) = k
+          alg (WriteLog _ _ _ k) = k

src/Semantic/Timeout.hs

@@ -1,12 +1,15 @@
-{-# LANGUAGE TypeOperators, GADTs, RankNTypes #-}
+{-# LANGUAGE ExistentialQuantification, TypeOperators, RankNTypes, UndecidableInstances #-}
 module Semantic.Timeout
 ( timeout
 , Timeout
 , runTimeout
+, TimeoutC(..)
 , Duration(..)
 ) where
 
-import           Control.Monad.Effect
+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
@@ -14,21 +17,37 @@ import qualified System.Timeout as System
 -- | Run an action with a timeout. Returns 'Nothing' when no result is available
 -- within the specified duration. Uses 'System.Timeout.timeout' so all caveats
 -- about not operating over FFI boundaries apply.
-timeout :: (Member Timeout effs) => Duration -> Eff effs output -> Eff effs (Maybe output)
-timeout n = send . Timeout n
+timeout :: (Member Timeout sig, Carrier sig m) => Duration -> m output -> m (Maybe output)
+timeout n = send . flip (Timeout n) ret
 
 -- | 'Timeout' effects run other effects, aborting them if they exceed the
 -- specified duration.
-data Timeout task output where
-   Timeout :: Duration -> task output -> Timeout task (Maybe output)
+data Timeout m k
+  = forall a . Timeout Duration (m a) (Maybe a -> k)
+
+deriving instance Functor (Timeout m)
+
+instance HFunctor Timeout where
+  hmap f (Timeout n task k) = Timeout n (f task) k
 
-instance PureEffect Timeout
 instance Effect Timeout where
-  handleState c dist (Request (Timeout n task) k) = Request (Timeout n (dist (task <$ c))) (dist . maybe (k Nothing <$ c) (fmap (k . Just)))
+  handle state handler (Timeout n task k) = Timeout n (handler (task <$ state)) (handler . maybe (k Nothing <$ state) (fmap (k . Just)))
 
 -- | Evaulate a 'Timeoute' effect.
-runTimeout :: (Member (Lift IO) effects, PureEffects effects)
-  => (forall x . Eff effects x -> IO x)
-  -> Eff (Timeout ': effects) a
-  -> Eff effects a
-runTimeout handler = interpret (\ (Timeout n task) -> liftIO (System.timeout (toMicroseconds n) (handler (runTimeout handler task))))
+runTimeout :: (Carrier sig m, MonadIO m)
+           => (forall x . m x -> IO x)
+           -> Eff (TimeoutC m) a
+           -> m a
+runTimeout handler = runTimeoutC handler . interpret
+
+newtype TimeoutC m a = TimeoutC ((forall x . m x -> IO x) -> m a)
+
+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
+  ret a = TimeoutC (const (ret a))
+  eff op = TimeoutC (\ handler ->
+    ((\ (Timeout n task k) -> liftIO (System.timeout (toMicroseconds n) (handler (runTimeoutC handler task))) >>= runTimeoutC handler . k)
+    \/ (eff . handlePure (runTimeoutC handler)))
+      op)

src/Semantic/Util.hs

@@ -8,7 +8,7 @@ import           Analysis.Abstract.Caching.FlowSensitive
 import           Analysis.Abstract.Collecting
 import           Control.Abstract
 import           Control.Exception (displayException)
-import           Control.Monad.Effect.Trace (runPrintingTrace)
+import           Control.Effect.Trace (runTraceByPrinting)
 import           Data.Abstract.Address.Monovariant as Monovariant
 import           Data.Abstract.Address.Precise as Precise
 import           Data.Abstract.Evaluatable
@@ -26,7 +26,7 @@ import           Data.Project hiding (readFile)
 import           Data.Quieterm (quieterm)
 import           Data.Sum (weaken)
 import           Parsing.Parser
-import           Prologue hiding (weaken)
+import           Prologue
 import           Semantic.Config
 import           Semantic.Graph
 import           Semantic.Task
@@ -36,9 +36,10 @@ import           System.FilePath.Posix (takeDirectory)
 
 justEvaluating
   = runM
-  . runPrintingTrace
+  . runEvaluator
+  . raiseHandler runTraceByPrinting
   . runHeap
-  . runFresh 0
+  . raiseHandler runFresh
   . fmap reassociate
   . runLoadError
   . runUnspecialized
@@ -49,10 +50,11 @@ justEvaluating
   . runValueError
 
 checking
-  = runM @_ @IO
-  . runPrintingTrace
-  . runState (lowerBound @(Heap Monovariant Type))
-  . runFresh 0
+  = runM
+  . runEvaluator
+  . raiseHandler runTraceByPrinting
+  . runHeap
+  . raiseHandler runFresh
   . caching
   . providingLiveSet
   . fmap reassociate
@@ -97,12 +99,12 @@ evaluateProject' (TaskConfig config logger statter) proxy parser paths = either
   modules <- topologicalSort <$> runImportGraphToModules proxy package
   trace $ "evaluating with load order: " <> show (map (modulePath . moduleInfo) modules)
   pure (id @(Evaluator _ Precise (Value _ Precise) _ _)
-       (runReader (lowerBound @(ModuleTable (NonEmpty (Module (ModuleResult Precise)))))
+       (runModuleTable
        (runModules (ModuleTable.modulePaths (packageModules package))
-       (runReader (packageInfo package)
-       (runState (lowerBound @Span)
-       (runReader (lowerBound @Span)
-       (evaluate proxy id withTermSpans (Precise.runAllocator . Precise.runDeref) (fmap (Concrete.runBoolean . Concrete.runWhile) . Concrete.runFunction) modules)))))))
+       (raiseHandler (runReader (packageInfo package))
+       (raiseHandler (runState (lowerBound @Span))
+       (raiseHandler (runReader (lowerBound @Span))
+       (evaluate proxy id withTermSpans modules)))))))
 
 evaluatePythonProjects proxy parser lang path = runTaskWithOptions debugOptions $ do
   project <- readProject Nothing path lang []
@@ -110,24 +112,25 @@ evaluatePythonProjects proxy parser lang path = runTaskWithOptions debugOptions
   modules <- topologicalSort <$> runImportGraphToModules proxy package
   trace $ "evaluating with load order: " <> show (map (modulePath . moduleInfo) modules)
   pure (id @(Evaluator _ Precise (Value _ Precise) _ _)
-       (runReader (lowerBound @(ModuleTable (NonEmpty (Module (ModuleResult Precise)))))
+       (runModuleTable
        (runModules (ModuleTable.modulePaths (packageModules package))
-       (runReader (packageInfo package)
-       (runState (lowerBound @Span)
-       (runReader (lowerBound @Span)
-       (evaluate proxy id withTermSpans (Precise.runAllocator . Precise.runDeref) (fmap (Concrete.runBoolean . Concrete.runWhile) . Concrete.runFunction) modules)))))))
+       (raiseHandler (runReader (packageInfo package))
+       (raiseHandler (runState (lowerBound @Span))
+       (raiseHandler (runReader (lowerBound @Span))
+       (evaluate proxy id withTermSpans modules)))))))
 
 
 evaluateProjectWithCaching proxy parser path = runTaskWithOptions debugOptions $ do
   project <- readProject Nothing path (Language.reflect proxy) []
   package <- fmap (quieterm . snd) <$> parsePackage parser project
   modules <- topologicalSort <$> runImportGraphToModules proxy package
-  pure (runReader (packageInfo package)
-       (runState (lowerBound @Span)
-       (runReader (lowerBound @Span)
-       (runReader (lowerBound @(ModuleTable (NonEmpty (Module (ModuleResult Monovariant)))))
+  pure (id @(Evaluator _ Monovariant _ _ _)
+       (raiseHandler (runReader (packageInfo package))
+       (raiseHandler (runState (lowerBound @Span))
+       (raiseHandler (runReader (lowerBound @Span))
+       (runModuleTable
        (runModules (ModuleTable.modulePaths (packageModules package))
-       (evaluate proxy id withTermSpans (Monovariant.runAllocator . Monovariant.runDeref) (fmap (Type.runBoolean . Type.runWhile) . Type.runFunction) modules))))))
+       (evaluate proxy id withTermSpans modules)))))))
 
 
 parseFile :: Parser term -> FilePath -> IO term
@@ -136,10 +139,10 @@ parseFile parser = runTask . (parse parser <=< readBlob . file)
 blob :: FilePath -> IO Blob
 blob = runTask . readBlob . file
 
-mergeExcs :: Either (SomeExc (Sum excs)) (Either (SomeExc exc) result) -> Either (SomeExc (Sum (exc ': excs))) result
-mergeExcs = either (\ (SomeExc sum) -> Left (SomeExc (weaken sum))) (either (\ (SomeExc exc) -> Left (SomeExc (inject exc))) Right)
+mergeErrors :: Either (SomeError (Sum errs)) (Either (SomeError err) result) -> Either (SomeError (Sum (err ': errs))) result
+mergeErrors = either (\ (SomeError sum) -> Left (SomeError (weaken sum))) (either (\ (SomeError err) -> Left (SomeError (inject err))) Right)
 
-reassociate :: Either (SomeExc exc1) (Either (SomeExc exc2) (Either (SomeExc exc3) (Either (SomeExc exc4) (Either (SomeExc exc5) (Either (SomeExc exc6) (Either (SomeExc exc7) result)))))) -> Either (SomeExc (Sum '[exc7, exc6, exc5, exc4, exc3, exc2, exc1])) result
-reassociate = mergeExcs . mergeExcs . mergeExcs . mergeExcs . mergeExcs . mergeExcs . mergeExcs . Right
+reassociate :: Either (SomeError err1) (Either (SomeError err2) (Either (SomeError err3) (Either (SomeError err4) (Either (SomeError err5) (Either (SomeError err6) (Either (SomeError err7) result)))))) -> Either (SomeError (Sum '[err7, err6, err5, err4, err3, err2, err1])) result
+reassociate = mergeErrors . mergeErrors . mergeErrors . mergeErrors . mergeErrors . mergeErrors . mergeErrors . Right
 
 {-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}

test/Analysis/Ruby/Spec.hs

@@ -6,7 +6,7 @@ import qualified Data.Abstract.ModuleTable as ModuleTable
 import Data.Abstract.Number as Number
 import Data.Abstract.Value.Concrete as Value
 import Data.AST
-import Control.Monad.Effect (SomeExc(..))
+import Control.Effect.Resumable (SomeError(..))
 import Data.List.NonEmpty (NonEmpty(..))
 import Data.Sum
 import qualified Language.Ruby.Assignment as Ruby
@@ -36,7 +36,7 @@ spec config = parallel $ do
 
     it "evaluates load with wrapper" $ do
       (_, (_, res)) <- evaluate ["load-wrap.rb", "foo.rb"]
-      res `shouldBe` Left (SomeExc (inject @(BaseError (EnvironmentError Precise)) (BaseError (ModuleInfo "load-wrap.rb") emptySpan (FreeVariable "foo"))))
+      res `shouldBe` Left (SomeError (inject @(BaseError (EnvironmentError Precise)) (BaseError (ModuleInfo "load-wrap.rb") emptySpan (FreeVariable "foo"))))
 
     it "evaluates subclass" $ do
       (_, (heap, res)) <- evaluate ["subclass.rb"]

test/Analysis/TypeScript/Spec.hs

@@ -38,7 +38,7 @@ spec config = parallel $ do
 
     it "fails exporting symbols not defined in the module" $ do
       (_, (_, res)) <- evaluate ["bad-export.ts", "pip.ts", "a.ts", "foo.ts"]
-      res `shouldBe` Left (SomeExc (inject @(BaseError EvalError) (BaseError (ModuleInfo "foo.ts") emptySpan (ExportError "foo.ts" (name "pip")))))
+      res `shouldBe` Left (SomeError (inject @(BaseError EvalError) (BaseError (ModuleInfo "foo.ts") emptySpan (ExportError "foo.ts" (name "pip")))))
 
     it "evaluates early return statements" $ do
       (_, (heap, res)) <- evaluate ["early-return.ts"]

test/Control/Abstract/Evaluator/Spec.hs

@@ -27,7 +27,7 @@ spec = parallel $ do
 
   it "calls functions" $ do
     (_, expected) <- evaluate $ do
-      identity <- function Nothing [name "x"] (coerce (variable (name "x")))
+      identity <- function Nothing [name "x"] (SpecEff (variable (name "x")))
       recv <- box unit
       addr <- box (integer 123)
       call identity recv [addr]
@@ -35,48 +35,49 @@ spec = parallel $ do
 
 evaluate
   = runM
-  . runIgnoringTrace
+  . runTraceByIgnoring
   . runState (lowerBound @(Heap Precise Val))
-  . runFresh 0
+  . runFresh
   . runReader (PackageInfo (name "test") mempty)
   . runReader (ModuleInfo "test/Control/Abstract/Evaluator/Spec.hs")
   . runReader (lowerBound @Span)
+  . runEvaluator
   . fmap reassociate
   . runValueError
   . runEnvironmentError
   . runAddressError
-  . Precise.runDeref @_ @_ @Val
-  . Precise.runAllocator
+  . runDeref @Val
+  . runAllocator
   . (>>= deref . snd)
   . runEnv lowerBound
   . runReturn
   . runLoopControl
-  . Value.runBoolean
-  . Value.runFunction coerce
+  . runBoolean
+  . runFunction runSpecEff
 
-reassociate :: Either (SomeExc exc1) (Either (SomeExc exc2) (Either (SomeExc exc3) result)) -> Either (SomeExc (Sum '[exc3, exc2, exc1])) result
-reassociate = mergeExcs . mergeExcs . mergeExcs . Right
+reassociate :: Either (SomeError exc1) (Either (SomeError exc2) (Either (SomeError exc3) result)) -> Either (SomeError (Sum '[exc3, exc2, exc1])) result
+reassociate = mergeErrors . mergeErrors . mergeErrors . Right
 
 type Val = Value SpecEff Precise
 newtype SpecEff = SpecEff
-  { runSpecEff :: Eff '[ Function SpecEff Precise Val
-                       , Boolean Val
-                       , Exc (LoopControl Precise)
-                       , Exc (Return Precise)
-                       , Env Precise
-                       , Allocator Precise
-                       , Deref Val
-                       , Resumable (BaseError (AddressError Precise Val))
-                       , Resumable (BaseError (EnvironmentError Precise))
-                       , Resumable (BaseError (ValueError SpecEff Precise))
-                       , Reader Span
-                       , Reader ModuleInfo
-                       , Reader PackageInfo
-                       , Fresh
-                       , State (Heap Precise Val)
-                       , Trace
-                       , Lift IO
-                       ] Precise
+  { runSpecEff :: Evaluator SpecEff Precise Val (FunctionC SpecEff Precise Val
+                 (Eff (BooleanC Val
+                 (Eff (ErrorC (LoopControl Precise)
+                 (Eff (ErrorC (Return Precise)
+                 (Eff (EnvC Precise
+                 (Eff (AllocatorC Precise
+                 (Eff (DerefC Precise Val
+                 (Eff (ResumableC (BaseError (AddressError Precise Val))
+                 (Eff (ResumableC (BaseError (EnvironmentError Precise))
+                 (Eff (ResumableC (BaseError (ValueError SpecEff Precise))
+                 (Eff (ReaderC Span
+                 (Eff (ReaderC ModuleInfo
+                 (Eff (ReaderC PackageInfo
+                 (Eff (FreshC
+                 (Eff (StateC (Heap Precise Val)
+                 (Eff (TraceByIgnoringC
+                 (Eff (LiftC IO)))))))))))))))))))))))))))))))))
+                 Precise
   }
 
 instance Eq SpecEff where _ == _ = True

test/Examples.hs

@@ -2,8 +2,7 @@ module Main (main) where
 
 import           Control.Exception (displayException)
 import           Control.Monad
-import           Control.Monad.Effect
-import           Control.Monad.Effect.Exception
+import           Control.Effect
 import qualified Data.ByteString as B
 import           Data.ByteString.Builder
 import qualified Data.ByteString.Char8 as BC
@@ -100,7 +99,7 @@ languages =
   -- , ("php", ".php") -- TODO: No parse-examples in tree-sitter yet
   ]
 
-parseFilePath :: (Member (Exc SomeException) effs, Member Task effs, Member Files effs) => FilePath -> Eff effs Bool
+parseFilePath :: (Member (Error SomeException) sig, Member Task sig, Member Files sig, Carrier sig m, Monad m) => FilePath -> m Bool
 parseFilePath path = readBlob (file path) >>= runParse' >>= const (pure True)
 
 languagesDir :: FilePath

test/Rendering/TOC/Spec.hs

@@ -2,6 +2,7 @@
 module Rendering.TOC.Spec (spec) where
 
 import Analysis.Declaration
+import Control.Effect
 import Data.Aeson hiding (defaultOptions)
 import Data.Bifunctor
 import Data.Bifunctor.Join
@@ -16,7 +17,6 @@ import Data.Sum
 import Data.Term
 import Data.Text (Text)
 import Data.Text.Encoding (encodeUtf8)
-import Data.Union hiding (forAll)
 import Diffing.Algorithm
 import Diffing.Interpreter
 import Prelude
@@ -231,10 +231,12 @@ diffWithParser :: ( Eq1 syntax
                   , Diffable syntax
                   , HasDeclaration syntax
                   , Hashable1 syntax
-                  , Member Distribute effs
-                  , Member Task effs
+                  , Member Distribute sig
+                  , Member Task sig
+                  , Carrier sig m
+                  , Monad m
                   )
                => Parser (Term syntax Location)
                -> BlobPair
-               -> Eff effs (Diff syntax (Maybe Declaration) (Maybe Declaration))
+               -> m (Diff syntax (Maybe Declaration) (Maybe Declaration))
 diffWithParser parser blobs = distributeFor blobs (\ blob -> parse parser blob >>= decorate (declarationAlgebra blob)) >>= SpecHelpers.diff . runJoin

test/SpecHelpers.hs

@@ -19,7 +19,7 @@ module SpecHelpers
 
 import Control.Abstract
 import Control.Arrow ((&&&))
-import Control.Monad.Effect.Trace as X (runIgnoringTrace, runReturningTrace)
+import Control.Effect.Trace as X (runTraceByIgnoring, runTraceByReturning)
 import Control.Monad ((>=>))
 import Data.Abstract.Address.Precise as X
 import Data.Abstract.Environment as Env
@@ -97,19 +97,18 @@ readFilePair :: Both FilePath -> IO BlobPair
 readFilePair paths = let paths' = fmap file paths in
                      runBothWith F.readFilePair paths'
 
-type TestEvaluatingEffects term
-  = '[ Resumable (BaseError (ValueError term Precise))
-     , Resumable (BaseError (AddressError Precise (Val term)))
-     , Resumable (BaseError ResolutionError)
-     , Resumable (BaseError EvalError)
-     , Resumable (BaseError (EnvironmentError Precise))
-     , Resumable (BaseError (UnspecializedError (Val term)))
-     , Resumable (BaseError (LoadError Precise))
-     , Fresh
-     , State (Heap Precise (Val term))
-     , Trace
-     , Lift IO
-     ]
+type TestEvaluatingC term
+  = ResumableC (BaseError (ValueError term Precise)) (Eff
+  ( ResumableC (BaseError (AddressError Precise (Val term))) (Eff
+  ( ResumableC (BaseError ResolutionError) (Eff
+  ( ResumableC (BaseError EvalError) (Eff
+  ( ResumableC (BaseError (EnvironmentError Precise)) (Eff
+  ( ResumableC (BaseError (UnspecializedError (Val term))) (Eff
+  ( ResumableC (BaseError (LoadError Precise)) (Eff
+  ( FreshC (Eff
+  ( StateC (Heap Precise (Val term)) (Eff
+  ( TraceByReturningC (Eff
+  ( LiftC IO))))))))))))))))))))
 type TestEvaluatingErrors term
   = '[ BaseError (ValueError term Precise)
      , BaseError (AddressError Precise (Val term))
@@ -119,19 +118,19 @@ type TestEvaluatingErrors term
      , BaseError (UnspecializedError (Val term))
      , BaseError (LoadError Precise)
      ]
-testEvaluating :: Evaluator term Precise (Val term) (TestEvaluatingEffects term) (Span, a)
+testEvaluating :: Evaluator term Precise (Val term) (TestEvaluatingC term) (Span, a)
                -> IO
                  ( [String]
                  , ( Heap Precise (Val term)
-                   , Either (SomeExc (Data.Sum.Sum (TestEvaluatingErrors term)))
-                            a
+                   , Either (SomeError (Data.Sum.Sum (TestEvaluatingErrors term))) a
                    )
                  )
 testEvaluating
   = runM
-  . runReturningTrace
+  . runTraceByReturning
   . runState lowerBound
-  . runFresh 0
+  . runFresh
+  . runEvaluator
   . fmap reassociate
   . runLoadError
   . runUnspecialized
@@ -139,7 +138,7 @@ testEvaluating
   . runEvalError
   . runResolutionError
   . runAddressError
-  . runValueError @_ @_ @Precise
+  . runValueError @_ @_ @_ @Precise
   . fmap snd
 
 type Val term = Value term Precise
@@ -157,12 +156,13 @@ namespaceScope :: Heap Precise (Value term Precise)
 namespaceScope heap ns@(Namespace _ _ _)
   = either (const Nothing) (snd . snd)
   . run
-  . runFresh 0
+  . runFresh
+  . runEvaluator
   . runAddressError
-  . runState heap
-  . runState (lowerBound @Span)
-  . runReader (lowerBound @Span)
-  . runReader (ModuleInfo "SpecHelper.hs")
+  . raiseHandler (runState heap)
+  . raiseHandler (runState (lowerBound @Span))
+  . raiseHandler (runReader (lowerBound @Span))
+  . raiseHandler (runReader (ModuleInfo "SpecHelper.hs"))
   . runDeref
   $ materializeEnvironment ns
 

vendor/effects

@@ -1 +0,0 @@
-Subproject commit 9616e462c58645b0017cbc66858e7123cdf77611

vendor/higher-order-effects

@@ -0,0 +1 @@
+Subproject commit 9678e1d5325392a23b57a47ddc7a52a5250fb304