Merge remote-tracking branch 'origin/master' into add-tsparse-quiet-flag

.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/fused-effects"]
+	path = vendor/fused-effects
+	url = https://github.com/robrix/fused-effects.git

.licenses/semantic/cabal/MonadRandom.txt

@@ -0,0 +1,42 @@
+---
+type: cabal
+name: MonadRandom
+version: 0.5.1.1
+summary: Random-number generation monad.
+homepage: 
+license: bsd-3-clause
+---
+Copyright (c) 2016, Brent Yorgey
+
+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 Brent Yorgey 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.
+
+Previous versions of this package were distributed under the simple
+permissive license used on the Haskell Wiki; see OLD-LICENSE for
+details.

.licenses/semantic/cabal/fused-effects.txt

@@ -0,0 +1,38 @@
+---
+type: cabal
+name: fused-effects
+version: 0.1.0.0
+summary: 'A fast, flexible, fused effect system, à la Effect Handlers in Scope, Monad Transformers and Modular Algebraic Effects: What Binds Them Together, and Fusion for Free—Efficient Algebraic Effect Handlers.'
+homepage: https://github.com/robrix/fused-effects
+license: bsd-3-clause
+---
+Copyright (c) 2018, Rob Rix and Patrick Thomson
+
+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

@@ -41,14 +41,16 @@ library
                      , Control.Abstract.Evaluator
                      , Control.Abstract.Heap
                      , Control.Abstract.Hole
-                     , Control.Abstract.Matching
                      , Control.Abstract.Modules
                      , Control.Abstract.Primitive
                      , Control.Abstract.PythonPackage
                      , Control.Abstract.Roots
                      , Control.Abstract.ScopeGraph
                      , Control.Abstract.Value
-                     -- Rewriting
+                     -- Effects
+                     , Control.Effect.Interpose
+                     -- Matching and rewriting DSLs
+                     , Control.Matching
                      , Control.Rewriting
                      -- Datatypes for abstract interpretation
                      , Data.Abstract.Address.Hole
@@ -186,6 +188,7 @@ library
                      , Reprinting.Typeset
                      , Reprinting.Pipeline
                      -- High-level flow & operational functionality (logging, stats, etc.)
+                     , Semantic.Analysis
                      , Semantic.AST
                      , Semantic.CLI
                      , Semantic.Config
@@ -230,11 +233,11 @@ library
                      , deepseq
                      , directory
                      , directory-tree
-                     , effects
                      , fastsum
                      , filepath
                      , free
                      , freer-cofreer
+                     , fused-effects
                      , ghc-prim
                      , gitrev
                      , Glob
@@ -359,10 +362,10 @@ test-suite test
                      , bifunctors
                      , bytestring
                      , containers
-                     , effects
                      , fastsum
                      , filepath
                      , free
+                     , fused-effects
                      , Glob
                      , hashable
                      , haskell-tree-sitter
@@ -413,9 +416,9 @@ test-suite parse-examples
   build-depends:       base
                      , bytestring
                      , directory
-                     , effects
                      , fastsum
                      , filepath
+                     , fused-effects
                      , Glob
                      , hspec >= 2.4.1
                      , hspec-core

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))
+              -> Evaluator term address value m (Set (ValueRef address))
-consultOracle configuration = fromMaybe mempty . cacheLookup configuration <$> ask
+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 m a
-           -> Evaluator term address value effects 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 m (ValueRef address)
-                     -> Evaluator term address value effects (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)
+isolateCache :: (Member (State (Cache term address)) sig, Member (State (Heap address value)) sig, Carrier sig m)
-             => Evaluator term address value effects a
+             => Evaluator term address value m a
-             -> Evaluator term address value effects (Cache term address, Heap address value)
+             -> 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
+cachingTerms :: ( Member (Env address) sig
-                , Member NonDet effects
+                , Member NonDet sig
-                , Member (Reader (Cache term address)) effects
+                , Member (Reader (Cache term address)) sig
-                , Member (Reader (Live address)) effects
+                , Member (Reader (Live address)) sig
-                , Member (State (Cache term address)) effects
+                , 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,37 +76,40 @@ cachingTerms recur0 recur term = do
       values <- consultOracle c
       cachingConfiguration c values (recur0 recur term)
 
-convergingModules :: ( AbstractValue term address value effects
+convergingModules :: ( AbstractValue term address value m
-                     , Effects effects
                      , Eq value
-                     , Member (Env address) effects
+                     , Member (Env address) sig
-                     , Member Fresh effects
+                     , Member Fresh sig
-                     , Member NonDet effects
+                     , Member NonDet sig
-                     , Member (Reader (Cache term address)) effects
+                     , Member (Reader (Cache term address)) sig
-                     , Member (Reader (Live address)) effects
+                     , Member (Reader (Live address)) sig
-                     , Member (Reader ModuleInfo) effects
+                     , Member (Reader ModuleInfo) sig
-                     , Member (Reader Span) effects
+                     , Member (Reader Span) sig
-                     , Member (Resumable (BaseError (EnvironmentError address))) effects
+                     , Member (Resumable (BaseError (EnvironmentError address))) sig
-                     , Member (State (Cache term address)) effects
+                     , Member (State (Cache term address)) sig
-                     , Member (State (Heap address value)) effects
+                     , Member (State (Heap address value)) sig
                      , Ord address
                      , Ord term
+                     , Carrier sig m
+                     , Effect sig
                      )
-                  => Open (Module term -> Evaluator term address value effects address)
+                  => (Module (Either prelude term) -> Evaluator term address value (AltC Maybe (Eff m)) address)
-convergingModules recur m = do
+                  -> (Module (Either prelude term) -> Evaluator term address value m address)
-  c <- getConfiguration (moduleBody m)
+convergingModules recur m@(Module _ (Left _)) = raiseHandler runNonDet (recur m) >>= maybeM empty
+convergingModules recur m@(Module _ (Right term)) = do
+  c <- getConfiguration term
   heap <- getHeap
   -- Convergence here is predicated upon an Eq instance, not α-equivalence
   (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)))
+      withOracle prevCache (raiseHandler runNonDet (recur m)))
   address =<< maybe empty scatter (cacheLookup c cache)
 
 -- | Iterate a monadic action starting from some initial seed until the results converge.
@@ -124,21 +128,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
+  = raiseHandler (runState  lowerBound)
-  . runReader lowerBound
+  . raiseHandler (runReader lowerBound)
-  . runNonDet
+  . 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 m a
-           -> Evaluator term address value effects 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 m (ValueRef address)
-                     -> Evaluator term address value effects (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
+isolateCache :: (Member (State (Cache term address value)) sig, Carrier sig m)
-             => Evaluator term address value effects a
+             => Evaluator term address value m a
-             -> Evaluator term address value effects (Cache term address value)
+             -> 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 NonDet sig
-                , Member (Reader (Cache term address value)) effects
+                , Member (Reader (Cache term address value)) sig
-                , Member (Reader (Live address)) effects
+                , Member (Reader (Live address)) sig
-                , Member (State (Cache term address value)) effects
+                , Member (State (Cache term address value)) sig
-                , Member (Env address) effects
+                , Member (Env address) sig
-                , Member (State (Heap address value)) effects
+                , 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,35 +76,38 @@ 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 Fresh sig
-                     , Member NonDet effects
+                     , Member NonDet sig
-                     , Member (Reader (Cache term address value)) effects
+                     , Member (Reader (Cache term address value)) sig
-                     , Member (Reader (Live address)) effects
+                     , Member (Reader (Live address)) sig
-                     , Member (Reader ModuleInfo) effects
+                     , Member (Reader ModuleInfo) sig
-                     , Member (Reader Span) effects
+                     , Member (Reader Span) sig
-                     , Member (Resumable (BaseError (EnvironmentError address))) effects
+                     , Member (Resumable (BaseError (EnvironmentError address))) sig
-                     , Member (State (Cache term address value)) effects
+                     , Member (State (Cache term address value)) sig
-                     , Member (Env address) effects
+                     , Member (Env address) sig
-                     , Member (State (Heap address value)) effects
+                     , Member (State (Heap address value)) sig
-                     , Effects effects
+                     , Carrier sig m
+                     , Effect sig
                      )
-                  => Open (Module term -> Evaluator term address value effects address)
+                  => (Module (Either prelude term) -> Evaluator term address value (AltC Maybe (Eff m)) address)
-convergingModules recur m = do
+                  -> (Module (Either prelude term) -> Evaluator term address value m address)
-  c <- getConfiguration (moduleBody m)
+convergingModules recur m@(Module _ (Left _)) = raiseHandler runNonDet (recur m) >>= maybeM empty
+convergingModules recur m@(Module _ (Right term)) = do
+  c <- getConfiguration term
   -- Convergence here is predicated upon an Eq instance, not α-equivalence
   cache <- converge lowerBound (\ prevCache -> isolateCache $ 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)))
+      withOracle prevCache (raiseHandler runNonDet (recur m)))
   address =<< maybe empty scatter (cacheLookup c cache)
 
 -- | Iterate a monadic action starting from some initial seed until the results converge.
@@ -122,21 +126,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
+  = raiseHandler (runState  lowerBound)
-  . runReader lowerBound
+  . raiseHandler (runReader lowerBound)
-  . runNonDet
+  . 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 :: Carrier sig m => Evaluator term address value (ReaderC (Live address) (Eff m)) a -> Evaluator term address value m a
-providingLiveSet = runReader lowerBound
+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 :: (Member (State (Dead term)) sig, Carrier sig m, Ord term) => term -> Evaluator term address value m ()
-revive t = modify' (Dead . delete t . unDead)
+revive t = modify (Dead . delete t . unDead)
 
 -- | Compute the set of all subterms recursively.
 subterms :: (Ord term, Recursive term, Foldable (Base term)) => term -> Dead term
 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 :: (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
+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,8 @@ module Analysis.Abstract.Graph
 
 import           Algebra.Graph.Export.Dot hiding (vertexName)
 import           Control.Abstract hiding (Function(..))
+import           Control.Effect.Carrier
+import           Control.Effect.Sum
 import           Data.Abstract.Address.Hole
 import           Data.Abstract.Address.Located
 import           Data.Abstract.BaseError
@@ -62,22 +64,23 @@ style = (defaultStyle (T.encodeUtf8Builder . vertexIdentifier))
 
 
 -- | Add vertices to the graph for evaluated identifiers.
-graphingTerms :: ( Member (Reader ModuleInfo) effects
+graphingTerms :: ( Member (Reader ModuleInfo) sig
-                 , Member (Reader Span) effects
+                 , Member (Reader Span) sig
-                 , Member (Env (Hole context (Located address))) effects
+                 , Member (Env (Hole context (Located address))) sig
-                 , Member (State (Graph ControlFlowVertex)) effects
+                 , Member (State (Graph ControlFlowVertex)) sig
-                 , Member (State (Map (Hole context (Located address)) ControlFlowVertex)) effects
+                 , Member (State (Map (Hole context (Located address)) ControlFlowVertex)) sig
-                 , Member (Resumable (BaseError (EnvironmentError (Hole context (Located address))))) effects
+                 , Member (Resumable (BaseError (EnvironmentError (Hole context (Located address))))) sig
-                 , AbstractValue term (Hole context (Located address)) value effects
+                 , AbstractValue term (Hole context (Located address)) value m
-                 , Member (Reader ControlFlowVertex) effects
+                 , 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 +103,120 @@ 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
+graphingPackages :: ( Member (Reader PackageInfo) sig
-                    , Member (State (Graph ControlFlowVertex)) effects
+                    , Member (State (Graph ControlFlowVertex)) sig
-                    , Member (Reader ControlFlowVertex) effects
+                    , 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
+graphingModules :: ( Member (Modules address) sig
-                .  ( Member (Modules address) effects
+                   , Member (Reader ModuleInfo) sig
-                   , Member (Reader ModuleInfo) effects
+                   , Member (State (Graph ControlFlowVertex)) sig
-                   , Member (State (Graph ControlFlowVertex)) effects
+                   , Member (Reader ControlFlowVertex) sig
-                   , Member (Reader ControlFlowVertex) effects
+                   , Carrier sig m
-                   , PureEffects effects
                    )
-                => Open (Module term -> Evaluator term address value effects a)
+                => (Module body -> Evaluator term address value (EavesdropC address (Eff m)) a)
+                -> (Module body -> 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
+    eavesdrop (recur m) $ \case
-      Load path -> includeModule path
+      Load   path _ -> includeModule path
-      Lookup path -> includeModule path
+      Lookup path _ -> includeModule path
-      _ -> pure ())
+      _             -> pure ()
-      (recur m)
   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
+graphingModuleInfo :: ( Member (Modules address) sig
-                   .  ( Member (Modules address) effects
+                      , Member (Reader ModuleInfo) sig
-                      , Member (Reader ModuleInfo) effects
+                      , Member (State (Graph ModuleInfo)) sig
-                      , Member (State (Graph ModuleInfo)) effects
+                      , Carrier sig m
-                      , PureEffects effects
                       )
-                   => Open (Module term -> Evaluator term address value effects a)
+                   => (Module body -> Evaluator term address value (EavesdropC address (Eff m)) a)
+                   -> (Module body -> Evaluator term address value m a)
 graphingModuleInfo recur m = do
   appendGraph (vertex (moduleInfo m))
-  eavesdrop @(Modules address) (\ eff -> case eff of
+  eavesdrop (recur m) $ \case
-    Load path -> currentModule >>= appendGraph . (`connect` vertex (ModuleInfo path)) . vertex
+    Load   path _ -> currentModule >>= appendGraph . (`connect` vertex (ModuleInfo path)) . vertex
-    Lookup path -> currentModule >>= appendGraph . (`connect` vertex (ModuleInfo path)) . vertex
+    Lookup path _ -> currentModule >>= appendGraph . (`connect` vertex (ModuleInfo path)) . vertex
-    _ -> pure ())
+    _             -> pure ()
-    (recur m)
+
+eavesdrop :: (Carrier sig m, Member (Modules address) sig)
+          => Evaluator term address value (EavesdropC address (Eff m)) a
+          -> (forall x . Modules address (Eff m) (Eff m x) -> Evaluator term address value m ())
+          -> Evaluator term address value m a
+eavesdrop m f = raiseHandler (runEavesdropC (runEvaluator . f) . interpret) m
+
+newtype EavesdropC address m a = EavesdropC ((forall x . Modules address m (m x) -> m ()) -> m a)
+
+runEavesdropC :: (forall x . Modules address m (m x) -> m ()) -> EavesdropC address m a -> m a
+runEavesdropC f (EavesdropC m) = m f
+
+instance (Carrier sig m, Member (Modules address) sig, Applicative m) => Carrier sig (EavesdropC address m) where
+  ret a = EavesdropC (const (ret a))
+  eff op
+    | Just eff <- prj op = EavesdropC (\ handler -> let eff' = handlePure (runEavesdropC handler) eff in handler eff' *> send eff')
+    | otherwise          = EavesdropC (\ handler -> eff (handlePure (runEavesdropC handler) op))
+
 
 -- | Add an edge from the current package to the passed vertex.
-packageInclusion :: ( Member (Reader PackageInfo) effects
+packageInclusion :: ( Member (Reader PackageInfo) sig
-                    , Member (State (Graph ControlFlowVertex)) effects
+                    , 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
+moduleInclusion :: ( Member (Reader ModuleInfo) sig
-                   , Member (State (Graph ControlFlowVertex)) effects
+                   , 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
+variableDefinition :: ( Member (State (Graph ControlFlowVertex)) sig
-                      , Member (Reader ControlFlowVertex) effects
+                      , 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 :: (Member (State (Graph v)) sig, Carrier sig m, Monad m) => Graph v -> m ()
-appendGraph = modify' . (<>)
+appendGraph = modify . (<>)
 
 
-graphing :: Effects effects
+graphing :: (Carrier sig m, Effect sig)
-         => 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)
+         => Evaluator term address value (StateC (Map address ControlFlowVertex) (Eff
-graphing = runState mempty . fmap snd . runState lowerBound
+                                         (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
+tracingTerms :: ( Member (Env address) sig
-                , Member (State (Heap address value)) effects
+                , Member (State (Heap address value)) sig
-                , Member (Writer (trace (Configuration term address value))) effects
+                , 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 :: (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
+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.hs

@@ -10,4 +10,5 @@ import Control.Abstract.Hole as X
 import Control.Abstract.Modules as X
 import Control.Abstract.Primitive as X
 import Control.Abstract.Roots as X
+import Control.Abstract.ScopeGraph as X
 import Control.Abstract.Value as X

src/Control/Abstract/Context.hs

@@ -12,9 +12,9 @@ module Control.Abstract.Context
 , withCurrentCallStack
 ) where
 
-import Control.Monad.Effect
+import Control.Effect
-import Control.Monad.Effect.Reader
+import Control.Effect.Reader
-import Control.Monad.Effect.State
+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 :: (Member (State Span) sig, Carrier sig m, Monad m) => Span -> m a -> m a
-modifyChildSpan span m = raiseEff (lowerEff m >>= (\a -> modify' (const span) >> pure a))
+modifyChildSpan span m = m <* put span
 
 -- | Run an action with locally-replaced 'ModuleInfo' & 'Span' derived from the passed 'SrcLoc'.
-withCurrentSrcLoc :: (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 :: (Member (Env address) sig, Carrier sig m) => Evaluator term address value m (EvalContext address)
-getEvalContext = send GetCtx
+getEvalContext = send (GetCtx ret)
 
 -- | Retrieve the current environment
-getEnv :: Member (Env address) effects
+getEnv :: (Member (Env address) sig, Carrier sig m)
-       => Evaluator term address value effects (Environment address)
+       => 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 :: (Member (Env address) sig, Carrier sig m) => EvalContext address -> Evaluator term address value m ()
-putEvalContext = send . PutCtx
+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 m a
-                -> Evaluator term address value effects 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 :: (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)
+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 :: (Member (Env address) sig, Carrier sig m) => Name -> Evaluator term address value m (Maybe address)
-lookupEnv name = send (Lookup name)
+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 :: (Member (Env address) sig, Carrier sig m) => Name -> address -> Evaluator term address value m ()
-bind name addr = send (Bind name addr)
+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 :: 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 = send . Locally @_ @_ @address . lowerEff
+locally m = send (Locally @address m ret)
 
-close :: Member (Env address) effects => Set Name -> Evaluator term address value effects (Environment address)
+close :: (Member (Env address) sig, Carrier sig m) => Set Name -> Evaluator term address value m (Environment address)
-close = send . Close
+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
+lookupOrAlloc :: ( Member (Allocator address) sig
-                 , Member (Env address) effects
+                 , 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
+letrec :: ( Member (Allocator address) sig
-          , Member (Deref value) effects
+          , Member (Deref value) sig
-          , Member (Env address) effects
+          , Member (Env address) sig
-          , Member (State (Heap address value)) effects
+          , Member (State (Heap address value)) sig
           , Ord address
+          , Carrier sig m
           )
        => Name
-       -> Evaluator term address value effects value
+       -> Evaluator term address value m value
-       -> Evaluator term address value effects (value, address)
+       -> 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
+letrec' :: ( Member (Allocator address) sig
-           , Member (Env address) effects
+           , Member (Env address) sig
+           , Carrier sig m
            )
         => Name
-        -> (address -> Evaluator term address value effects a)
+        -> (address -> Evaluator term address value m a)
-        -> Evaluator term address value effects 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
+variable :: ( Member (Env address) sig
-            , Member (Reader ModuleInfo) effects
+            , Member (Reader ModuleInfo) sig
-            , Member (Reader Span) effects
+            , Member (Reader Span) sig
-            , Member (Resumable (BaseError (EnvironmentError address))) effects
+            , 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
+data Env address m k
-  Lookup :: Name            -> Env address m (Maybe address)
+  = Lookup Name (Maybe address -> k)
-  Bind   :: Name -> address -> Env address m ()
+  | Bind Name address k
-  Close  :: Set Name        -> Env address m (Environment address)
+  | Close (Set Name) (Environment address -> k)
-  Locally :: m a            -> Env address m a
+  | forall a . Locally (m a) (a -> k)
-  GetCtx ::                    Env address m (EvalContext address)
+  | GetCtx (EvalContext address -> k)
-  PutCtx :: EvalContext address -> Env address m ()
+  | PutCtx (EvalContext address) k
-  Export :: Name -> Name -> Maybe address -> Env address m ()
+  | 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)
+  handle state handler (Lookup name k) = Lookup name (handler . (<$ state) . k)
-  handleState c dist (Request (Bind name addr) k) = Request (Bind name addr) (dist . (<$ c) . k)
+  handle state handler (Bind name addr k) = Bind name addr (handler . (<$ state) $ k)
-  handleState c dist (Request (Close names) k) = Request (Close names) (dist . (<$ c) . k)
+  handle state handler (Close names k) = Close names (handler . (<$ state) . k)
-  handleState c dist (Request (Locally action) k) = Request (Locally (dist (action <$ c))) (dist . fmap k)
+  handle state handler (Locally action k) = Locally (handler (action <$ state)) (handler . fmap k)
-  handleState c dist (Request GetCtx k) = Request GetCtx (dist . (<$ c) . k)
+  handle state handler (GetCtx k) = GetCtx (handler . (<$ state) . k)
-  handleState c dist (Request (PutCtx e) k) = Request (PutCtx e) (dist . (<$ c) . k)
+  handle state handler (PutCtx e k) = PutCtx e (handler . (<$ state) $ k)
-  handleState c dist (Request (Export name alias addr) k) = Request (Export name alias addr) (dist . (<$ c) . 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 (EnvC address (Eff m)) a
-       -> Evaluator term address value effects (Bindings address, a)
+       -> Evaluator term address value m (Bindings address, a)
-runEnv initial = fmap (filterEnv . fmap (first (Env.head . ctxEnvironment))) . runState lowerBound . runState initial . reinterpret2 handleEnv
+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,48 @@ 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
+newtype EnvC address m a = EnvC { runEnvC :: Eff (StateC (EvalContext address) (Eff (StateC (Exports address) m))) a }
-          => 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)
 
-freeVariableError :: ( Member (Reader ModuleInfo) effects
+instance (Carrier sig m, Effect sig) => Carrier (Env address :+: sig) (EnvC address m) where
-                     , Member (Reader Span) effects
+  ret = EnvC . ret
-                     , Member (Resumable (BaseError (EnvironmentError address))) effects
+  eff = EnvC . handleSum (eff . R . R . handleCoercible) (\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)
+runEnvironmentError :: (Carrier sig m, Effect sig)
-                    => m address value (Resumable (BaseError (EnvironmentError address)) ': effects) a
+                    => Evaluator term address value (ResumableC (BaseError (EnvironmentError address)) (Eff m)) a
-                    -> m address value effects (Either (SomeExc (BaseError (EnvironmentError address))) a)
+                    -> Evaluator term address value m (Either (SomeError (BaseError (EnvironmentError address))) a)
-runEnvironmentError = runResumable
+runEnvironmentError = raiseHandler runResumable
 
-runEnvironmentErrorWith :: (Effectful (m address value), Effects effects)
+runEnvironmentErrorWith :: Carrier sig m
-                        => (forall resume . BaseError (EnvironmentError address) resume -> m address value effects resume)
+                        => (forall resume . BaseError (EnvironmentError address) resume -> Evaluator term address value m resume)
-                        -> m address value (Resumable (BaseError (EnvironmentError address)) ': effects) a
+                        -> Evaluator term address value (ResumableWithC (BaseError (EnvironmentError address)) (Eff m)) a
-                        -> m address value effects a
+                        -> Evaluator term address value m a
-runEnvironmentErrorWith = runResumableWith
+runEnvironmentErrorWith f = raiseHandler $ runResumableWith (runEvaluator . f)
 
-throwEnvironmentError :: ( Member (Resumable (BaseError (EnvironmentError address))) effects
+throwEnvironmentError :: ( Member (Resumable (BaseError (EnvironmentError address))) sig
-                         , Member (Reader ModuleInfo) effects
+                         , Member (Reader ModuleInfo) sig
-                         , Member (Reader Span) effects
+                         , 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.Effect           as X
-import Control.Monad.Effect.Fresh     as X
+import Control.Effect.Carrier
-import Control.Monad.Effect.Exception as X
+import Control.Effect.Error     as X
-import qualified Control.Monad.Effect.Internal as Eff
+import Control.Effect.Fresh     as X
-import Control.Monad.Effect.NonDet    as X
+import Control.Effect.NonDet    as X
-import Control.Monad.Effect.Reader    as X
+import Control.Effect.Reader    as X
-import Control.Monad.Effect.Resumable as X
+import Control.Effect.Resumable as X
-import Control.Monad.Effect.State     as X
+import Control.Effect.State     as X
-import Control.Monad.Effect.Trace     as X
+import Control.Effect.Trace     as X
-import Prologue hiding (MonadError(..))
+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 }
+newtype Evaluator term address value m a = Evaluator { runEvaluator :: Eff m a }
-  deriving (Applicative, Effectful, Functor, Monad)
+  deriving (Applicative, Functor, Monad)
 
-deriving instance Member NonDet effects => Alternative (Evaluator term address value effects)
+deriving instance (Member NonDet sig, Carrier sig m) => Alternative (Evaluator term address value m)
-deriving instance Member (Lift IO) effects => MonadIO (Evaluator term address value effects)
+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 :: (Member (Error (Return address)) sig, Carrier sig m) => Evaluator term address value m address -> Evaluator term address value m address
-catchReturn = Eff.raiseHandler (handleError (\ (Return addr) -> pure addr))
+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 :: (Carrier sig m, Effect sig) => Evaluator term address value (ErrorC (Return address) (Eff m)) address -> Evaluator term address value m address
-runReturn = Eff.raiseHandler (fmap (either unReturn id) . runError)
+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
+throwAbort :: forall term address sig m value a
-           => Evaluator term address value effects 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 :: (Carrier sig m, Effect sig) => Evaluator term address value (ErrorC (LoopControl address) (Eff m)) address -> Evaluator term address value m address
-runLoopControl = Eff.raiseHandler (fmap (either unLoopControl id) . runError)
+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 :: (Member (State (Heap address value)) sig, Carrier sig m) => (Heap address value -> Heap address value) -> Evaluator term address value m ()
-modifyHeap = modify'
+modifyHeap = modify
 
-box :: ( Member (Allocator address) effects
+box :: ( Member (Allocator address) sig
-       , Member (Deref value) effects
+       , Member (Deref value) sig
-       , Member Fresh effects
+       , Member Fresh sig
-       , Member (State (Heap address value)) effects
+       , 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 :: (Member (Allocator address) sig, Carrier sig m) => Name -> Evaluator term address value m address
-alloc = send . Alloc
+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
+deref :: ( Member (Deref value) sig
-         , Member (Reader ModuleInfo) effects
+         , Member (Reader ModuleInfo) sig
-         , Member (Reader Span) effects
+         , Member (Reader Span) sig
-         , Member (Resumable (BaseError (AddressError address value))) effects
+         , Member (Resumable (BaseError (AddressError address value))) sig
-         , Member (State (Heap address value)) effects
+         , Member (State (Heap address value)) sig
          , Ord address
+         , Carrier sig m
          )
       => address
-      -> Evaluator term address value effects value
+      -> Evaluator term address value m value
-deref addr = gets (heapLookup addr) >>= maybeM (throwAddressError (UnallocatedAddress addr)) >>= send . DerefCell >>= maybeM (throwAddressError (UninitializedAddress addr))
+deref addr = gets (heapLookup addr) >>= maybeM (throwAddressError (UnallocatedAddress addr)) >>= send . flip DerefCell ret >>= maybeM (throwAddressError (UninitializedAddress addr))
 
 
 -- | Write a value to the given address in the 'Allocator'.
-assign :: ( Member (Deref value) effects
+assign :: ( Member (Deref value) sig
-          , Member (State (Heap address value)) effects
+          , 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
+data Allocator address (m :: * -> *) k
-  Alloc   :: Name    -> Allocator address m address
+  = Alloc Name (address -> k)
+  deriving (Functor)
 
-data Deref value (m :: * -> *) return where
+instance HFunctor (Allocator address) where
-  DerefCell  :: Set value          -> Deref value m (Maybe value)
+  hmap _ (Alloc name k) = Alloc name k
-  AssignCell :: value -> Set value -> Deref value m (Set value)
-
-instance PureEffect (Allocator address)
 
 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)
+  handle state handler (DerefCell        cell k) = DerefCell        cell (handler . (<$ state) . k)
-  handleState c dist (Request (AssignCell value cell) k) = Request (AssignCell  value cell) (dist . (<$ c) . 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
+throwAddressError :: ( Member (Resumable (BaseError (AddressError address body))) sig
-                     , Member (Reader ModuleInfo) effects
+                     , Member (Reader ModuleInfo) sig
-                     , Member (Reader Span) effects
+                     , 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
+runAddressError :: (Carrier sig m, Effect sig)
-                => Evaluator term address value (Resumable (BaseError (AddressError address value)) ': effects) a
+                => Evaluator term address value (ResumableC (BaseError (AddressError address value)) (Eff m)) a
-                -> Evaluator term address value effects (Either (SomeExc (BaseError (AddressError address value))) a)
+                -> Evaluator term address value m (Either (SomeError (BaseError (AddressError address value))) a)
-runAddressError = runResumable
+runAddressError = raiseHandler runResumable
 
-runAddressErrorWith :: Effects effects
+runAddressErrorWith :: Carrier sig m
-                    => (forall resume . (BaseError (AddressError address value)) resume -> Evaluator term address value effects resume)
+                    => (forall resume . (BaseError (AddressError address value)) resume -> Evaluator term address value m resume)
-                    -> Evaluator term address value (Resumable (BaseError (AddressError address value)) ': effects) a
+                    -> Evaluator term address value (ResumableWithC (BaseError (AddressError address value)) (Eff m)) a
-                    -> Evaluator term address value effects a
+                    -> Evaluator term address value m a
-runAddressErrorWith = runResumableWith
+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,74 @@ 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 :: (Member (Modules address) sig, Carrier sig m) => ModulePath -> Evaluator term address value m (Maybe (ModuleResult address))
-lookupModule = sendModules . Lookup
+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 :: (Member (Modules address) sig, Carrier sig m) => [FilePath] -> Evaluator term address value m (Maybe ModulePath)
-resolve = sendModules . Resolve
+resolve = sendModules . flip Resolve ret
 
-listModulesInDir :: Member (Modules address) effects => FilePath -> Evaluator term address value effects [ModulePath]
+listModulesInDir :: (Member (Modules address) sig, Carrier sig m) => FilePath -> Evaluator term address value m [ModulePath]
-listModulesInDir = sendModules . List
+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 :: (Member (Modules address) sig, Carrier sig m) => ModulePath -> Evaluator term address value m (ModuleResult address)
-load path = sendModules (Load path)
+load path = sendModules (Load path ret)
 
 
-data Modules address (m :: * -> *) return where
+data Modules address (m :: * -> *) k
-  Load    :: ModulePath -> Modules address m (ModuleResult address)
+  = Load    ModulePath (ModuleResult address -> k)
-  Lookup  :: ModulePath -> Modules address m (Maybe (ModuleResult address))
+  | Lookup  ModulePath (Maybe (ModuleResult address) -> k)
-  Resolve :: [FilePath] -> Modules address m (Maybe ModulePath)
+  | Resolve [FilePath] (Maybe ModulePath -> k)
-  List    :: FilePath   -> Modules address m [ModulePath]
+  | 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)
+  handle state handler (Load    path  k) = Load    path  (handler . (<$ state) . k)
-  handleState c dist (Request (Lookup path) k) = Request (Lookup path) (dist . (<$ c) . k)
+  handle state handler (Lookup  path  k) = Lookup  path  (handler . (<$ state) . k)
-  handleState c dist (Request (Resolve paths) k) = Request (Resolve paths) (dist . (<$ c) . k)
+  handle state handler (Resolve paths k) = Resolve paths (handler . (<$ state) . k)
-  handleState c dist (Request (List path) k) = Request (List path) (dist . (<$ c) . 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
+runModules :: ( Member (Reader (ModuleTable (NonEmpty (Module (ModuleResult address))))) sig
-              , Member (Resumable (BaseError (LoadError address))) effects
+              , Member (Resumable (BaseError (LoadError address))) sig
-              , PureEffects effects
+              , Carrier sig m
               )
            => Set ModulePath
-           -> Evaluator term address value (Modules address ': effects) a
+           -> Evaluator term address value (ModulesC address (Eff m)) a
-           -> Evaluator term address value effects a
+           -> Evaluator term address value m a
-runModules paths = interpret $ \case
+runModules paths = raiseHandler $ flip runModulesC paths . interpret
-  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))
 
-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 -> handleSum (eff . handleReader paths runModulesC) (\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) op)
+
+askModuleTable :: (Member (Reader (ModuleTable (NonEmpty (Module (ModuleResult address))))) sig, Carrier sig m) => m (ModuleTable (NonEmpty (Module (ModuleResult address))))
 askModuleTable = ask
 
 
@@ -112,20 +129,20 @@ instance Eq1 (LoadError address) where
 instance NFData1 (LoadError address) where
   liftRnf _ (ModuleNotFoundError p) = rnf p
 
-runLoadError :: Effects effects
+runLoadError :: (Carrier sig m, Effect sig)
-             => Evaluator term address value (Resumable (BaseError (LoadError address)) ': effects) a
+             => Evaluator term address value (ResumableC (BaseError (LoadError address)) (Eff m)) a
-             -> Evaluator term address value effects (Either (SomeExc (BaseError (LoadError address))) a)
+             -> Evaluator term address value m (Either (SomeError (BaseError (LoadError address))) a)
-runLoadError = runResumable
+runLoadError = raiseHandler runResumable
 
-runLoadErrorWith :: Effects effects
+runLoadErrorWith :: Carrier sig m
-                 => (forall resume . (BaseError (LoadError address)) resume -> Evaluator term address value effects resume)
+                 => (forall resume . (BaseError (LoadError address)) resume -> Evaluator term address value m resume)
-                 -> Evaluator term address value (Resumable (BaseError (LoadError address)) ': effects) a
+                 -> Evaluator term address value (ResumableWithC (BaseError (LoadError address)) (Eff m)) a
-                 -> Evaluator term address value effects a
+                 -> Evaluator term address value m a
-runLoadErrorWith = runResumableWith
+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 +167,22 @@ instance NFData1 ResolutionError where
     NotFoundError p ps l -> rnf p `seq` rnf ps `seq` rnf l
     GoImportError p      -> rnf p
 
-runResolutionError :: Effects effects
+runResolutionError :: (Carrier sig m, Effect sig)
-                   => Evaluator term address value (Resumable (BaseError ResolutionError) ': effects) a
+                   => Evaluator term address value (ResumableC (BaseError ResolutionError) (Eff m)) a
-                   -> Evaluator term address value effects (Either (SomeExc (BaseError ResolutionError)) a)
+                   -> Evaluator term address value m (Either (SomeError (BaseError ResolutionError)) a)
-runResolutionError = runResumable
+runResolutionError = raiseHandler runResumable
 
-runResolutionErrorWith :: Effects effects
+runResolutionErrorWith :: Carrier sig m
-                       => (forall resume . (BaseError ResolutionError) resume -> Evaluator term address value effects resume)
+                       => (forall resume . (BaseError ResolutionError) resume -> Evaluator term address value m resume)
-                       -> Evaluator term address value (Resumable (BaseError ResolutionError) ': effects) a
+                       -> Evaluator term address value (ResumableWithC (BaseError ResolutionError) (Eff m)) a
-                       -> Evaluator term address value effects a
+                       -> Evaluator term address value m a
-runResolutionErrorWith = runResumableWith
+runResolutionErrorWith f = raiseHandler $ runResumableWith (runEvaluator . f)
 
-throwResolutionError :: ( Member (Reader ModuleInfo) effects
+throwResolutionError :: ( Member (Reader ModuleInfo) sig
-                        , Member (Reader Span) effects
+                        , Member (Reader Span) sig
-                        , Member (Resumable (BaseError ResolutionError)) effects
+                        , 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 (Allocator address) sig
-          , Member (Deref value) effects
+          , Member (Deref value) sig
-          , Member (Env address) effects
+          , Member (Env address) sig
-          , Member (Reader ModuleInfo) effects
+          , Member (Reader ModuleInfo) sig
-          , Member (Reader Span) effects
+          , Member (Reader Span) sig
-          , Member (State (Heap address value)) effects
+          , Member (State (Heap address value)) sig
+          , Carrier sig m
           , Ord address
           )
        => Name
-       -> Evaluator term address value effects value
+       -> Evaluator term address value m value
-       -> Evaluator term address value effects ()
+       -> 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 (Allocator address) sig
-               , Member (Deref value) effects
+               , Member (Deref value) sig
-               , Member (Env address) effects
+               , Member (Env address) sig
-               , Member (Reader ModuleInfo) effects
+               , Member (Reader ModuleInfo) sig
-               , Member (Reader Span) effects
+               , Member (Reader Span) sig
-               , Member (State (Heap address value)) effects
+               , Member (State (Heap address value)) sig
                , Ord address
                )
             => Name
             -> [address]
-            -> Evaluator term address value effects a
+            -> Evaluator term address value m a
-            -> Evaluator term address value effects ()
+            -> 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 (Allocator address) sig
-                   , Member (Deref value) effects
+                   , Member (Deref value) sig
-                   , Member (Env address) effects
+                   , Member (Env address) sig
-                   , Member (Reader ModuleInfo) effects
+                   , Member (Reader ModuleInfo) sig
-                   , Member (Reader Span) effects
+                   , Member (Reader Span) sig
-                   , Member (State (Heap address value)) effects
+                   , Member (State (Heap address value)) sig
                    , Ord address
                    )
                 => Name
-                -> Evaluator term address value effects a
+                -> Evaluator term address value m a
-                -> Evaluator term address value effects ()
+                -> 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,11 +1,12 @@
-{-# LANGUAGE GADTs, LambdaCase, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE 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           Control.Effect.Carrier
+import           Control.Effect.Sum
 import           Data.Abstract.Evaluatable
 import           Data.Abstract.Name (name)
 import           Data.Abstract.Path (stripQuotes)
@@ -16,35 +17,66 @@ import           Prologue
 data Strategy = Unknown | Packages [Text] | FindPackages [Text]
   deriving (Show, Eq)
 
-runPythonPackaging :: forall effects term address a. (
+runPythonPackaging :: ( Carrier sig m
-                      Eff.PureEffects effects
                       , Ord address
                       , Show address
                       , Show term
-                      , Member Trace effects
+                      , Member Trace sig
-                      , Member (Boolean (Value term address)) effects
+                      , Member (Boolean (Value term address)) sig
-                      , Member (State (Heap address (Value term address))) effects
+                      , Member (State (Heap address (Value term address))) sig
-                      , Member (Resumable (BaseError (AddressError address (Value term address)))) effects
+                      , Member (Resumable (BaseError (AddressError address (Value term address)))) sig
-                      , Member (Resumable (BaseError (ValueError term address))) effects
+                      , Member (Resumable (BaseError (ValueError term address))) sig
-                      , Member Fresh effects
+                      , Member Fresh sig
-                      , Member (State Strategy) effects
+                      , Member (State Strategy) sig
-                      , Member (Allocator address) effects
+                      , Member (Allocator address) sig
-                      , Member (Deref (Value term address)) effects
+                      , Member (Deref (Value term address)) sig
-                      , Member (Env address) effects
+                      , Member (Env address) sig
-                      , Member (Eff.Exc (LoopControl address)) effects
+                      , Member (Error (LoopControl address)) sig
-                      , Member (Eff.Exc (Return address)) effects
+                      , Member (Error (Return address)) sig
-                      , Member (Eff.Reader ModuleInfo) effects
+                      , Member (Reader ModuleInfo) sig
-                      , Member (Eff.Reader PackageInfo) effects
+                      , Member (Reader PackageInfo) sig
-                      , Member (Eff.Reader Span) effects
+                      , Member (Reader Span) sig
-                      , Member (Function term address (Value term address)) effects)
+                      , Member (Function term address (Value term address)) sig
-                   => Evaluator term address (Value term address) effects a
+                      )
-                   -> Evaluator term address (Value term address) effects a
+                   => Evaluator term address (Value term address) (PythonPackagingC term address (Eff m)) a
-runPythonPackaging = Eff.interpose @(Function term address (Value term address)) $ \case
+                   -> Evaluator term address (Value term address) m a
-  Call callName super params -> do
+runPythonPackaging = raiseHandler (runPythonPackagingC . interpret)
+
+newtype PythonPackagingC term address m a = PythonPackagingC { runPythonPackagingC :: m a }
+
+wrap :: Evaluator term address (Value term address) m a -> PythonPackagingC term address (Eff m) a
+wrap = PythonPackagingC . runEvaluator
+
+instance ( Carrier sig m
+         , Member (Allocator address) sig
+         , Member (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 (Function term address (Value term address)) 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 (State Strategy) sig
+         , Member Trace sig
+         , Ord address
+         , Show address
+         , Show term
+         )
+      => Carrier sig (PythonPackagingC term address (Eff m)) where
+  ret = PythonPackagingC . ret
+  eff op
+    | Just e <- prj op = wrap $ case handleCoercible e of
+      Call callName super params k -> Evaluator . 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 bindings = foldr (uncurry Map.insert) lowerBound (zip paramNames params)
-        let asStrings address = (deref >=> asArray) address >>= traverse (deref >=> asString)
+            let asStrings = deref >=> asArray >=> traverse (deref >=> asString)
 
             case name' of
               Just n
@@ -61,5 +93,6 @@ runPythonPackaging = Eff.interpose @(Function term address (Value term address))
               _ -> pure ()
           _ -> pure ()
         call callName super params
-  Function name params body ->  function name params body
+      Function name params body k -> function name params body >>= Evaluator . k
-  BuiltIn b -> builtIn b
+      BuiltIn b k -> builtIn b >>= Evaluator . k
+    | otherwise        = PythonPackagingC (eff (handleCoercible 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,93 @@ import           Data.Span
 import           Prelude hiding (lookup)
 import           Prologue
 
-data ScopeEnv address (m :: * -> *) a where
+data ScopeEnv address (m :: * -> *) k
-    Lookup :: Reference -> ScopeEnv address m (Maybe address)
+  = Lookup Reference (Maybe address -> k)
-    Declare :: Declaration -> Span -> Maybe address -> ScopeEnv address m ()
+  | Declare Declaration Span (Maybe address) k
-    PutDeclarationScope :: Declaration -> address -> ScopeEnv address m ()
+  | PutDeclarationScope Declaration address k
-    Reference :: Reference -> Declaration -> ScopeEnv address m ()
+  | Reference Reference Declaration k
-    NewScope :: Map EdgeLabel [address] -> ScopeEnv address m address
+  | NewScope (Map EdgeLabel [address]) (address -> k)
-    CurrentScope :: ScopeEnv address m (Maybe address)
+  | CurrentScope (Maybe address -> k)
-    Local :: address -> m a -> ScopeEnv address m a
+  | forall a . Local address (m a) (a -> k)
-    AssociatedScope :: Declaration -> ScopeEnv address m (Maybe address)
+  | AssociatedScope Declaration (Maybe address -> k)
 
-lookup :: forall term address value effects. Member (ScopeEnv address) effects => Reference -> Evaluator term address value effects (Maybe address)
+deriving instance Functor (ScopeEnv address m)
-lookup = send . Lookup @address
 
-declare :: forall term address value effects. Member (ScopeEnv address) effects => Declaration -> Span -> Maybe address -> Evaluator term address value effects ()
+lookup :: (Member (ScopeEnv address) sig, Carrier sig m) => Reference -> Evaluator term address value m (Maybe address)
-declare = ((send .) .) . Declare @address
+lookup ref = sendScope (Lookup ref ret)
 
-putDeclarationScope :: forall term address value effects. Member (ScopeEnv address) effects => Declaration -> address -> Evaluator term address value effects ()
+declare :: (Member (ScopeEnv address) sig, Carrier sig m) => Declaration -> Span -> Maybe address -> Evaluator term address value m ()
-putDeclarationScope = (send .) . PutDeclarationScope @address
+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 ()
+putDeclarationScope :: (Member (ScopeEnv address) sig, Carrier sig m) => Declaration -> address -> Evaluator term address value m ()
-reference = (send .) . Reference @address
+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
+reference :: (Member (ScopeEnv address) sig, Carrier sig m) => Reference -> Declaration -> Evaluator term address value m ()
-newScope map = send (NewScope map)
+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)
+newScope :: (Member (ScopeEnv address) sig, Carrier sig m) => Map EdgeLabel [address]  -> Evaluator term address value m address
-currentScope = send CurrentScope
+newScope map = send (NewScope map ret)
 
-associatedScope :: forall term address value effects. Member (ScopeEnv address) effects => Declaration -> Evaluator term address value effects (Maybe address)
+currentScope :: (Member (ScopeEnv address) sig, Carrier sig m) => Evaluator term address value m (Maybe address)
-associatedScope = send . AssociatedScope
+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
+associatedScope :: (Member (ScopeEnv address) sig, Carrier sig m) => Declaration -> Evaluator term address value m (Maybe address)
-withScope scope action = send (Local scope (lowerEff action))
+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)
+  handle state handler = \case
-  handleState c dist (Request (Declare decl span assocScope) k) = Request (Declare decl span assocScope) (dist . (<$ c) . k)
+    Lookup ref                          k -> Lookup ref (handler . (<$ state) . k)
-  handleState c dist (Request (PutDeclarationScope decl assocScope) k) = Request (PutDeclarationScope decl assocScope) (dist . (<$ c) . k)
+    Declare decl span assocScope        k -> Declare decl span assocScope (handler (k <$ state))
-  handleState c dist (Request (Reference ref decl) k) = Request (Reference ref decl) (dist . (<$ c) . k)
+    PutDeclarationScope decl assocScope k -> PutDeclarationScope decl assocScope (handler (k <$ state))
-  handleState c dist (Request (NewScope edges) k)       = Request (NewScope edges) (dist . (<$ c) . k)
+    Reference ref decl                  k -> Reference ref decl (handler (k <$ state))
-  handleState c dist (Request CurrentScope k)         = Request CurrentScope (dist . (<$ c) . k)
+    NewScope edges                      k -> NewScope edges (handler . (<$ state) . k)
-  handleState c dist (Request (AssociatedScope decl) k)         = Request (AssociatedScope decl) (dist . (<$ c) . k)
+    CurrentScope                        k -> CurrentScope (handler . (<$ state) . k)
-  handleState c dist (Request (Local scope action) k) = Request (Local scope (dist (action <$ c))) (dist . fmap 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)
+runScopeEnv :: (Ord address, Member Fresh sig, Member (Allocator address) sig, Carrier sig m, Effect sig)
-            => Evaluator term address value (ScopeEnv address ': effects) a
+            => Evaluator term address value (ScopeEnvC address (Eff m)) a
-            -> Evaluator term address value effects (ScopeGraph address, a)
+            -> Evaluator term address value m (ScopeGraph address, a)
-runScopeEnv evaluator = runState lowerBound (reinterpret handleScopeEnv evaluator)
+runScopeEnv = raiseHandler $ runState lowerBound . runScopeEnvC . interpret
 
-handleScopeEnv :: forall term address value effects a. (Ord address, Member Fresh effects, Member (Allocator address) effects, Effects effects)
+newtype ScopeEnvC address m a = ScopeEnvC { runScopeEnvC :: Eff (StateC (ScopeGraph address) m) a }
-          => ScopeEnv address (Eff (ScopeEnv address ': effects)) a
+
-          -> Evaluator term address value (State (ScopeGraph address) ': effects) a
+instance (Ord address, Member Fresh sig, Member (Allocator address) sig, Carrier sig m, Effect sig) => Carrier (ScopeEnv address :+: sig) (ScopeEnvC address m) where
-handleScopeEnv = \case
+  ret = ScopeEnvC . ret
-    Lookup ref -> ScopeGraph.scopeOfRef ref <$> get
+  eff = ScopeEnvC . handleSum (eff . R . handleCoercible) (\case
-    Declare decl span scope -> modify @(ScopeGraph address) (ScopeGraph.declare decl span scope)
+    Lookup ref                     k -> gets (ScopeGraph.scopeOfRef ref) >>= runScopeEnvC . k
-    PutDeclarationScope decl scope -> modify @(ScopeGraph address) (ScopeGraph.insertDeclarationScope decl scope)
+    Declare decl span scope        k -> modify @(ScopeGraph address) (ScopeGraph.declare decl span scope) *> runScopeEnvC k
-    Reference ref decl -> modify @(ScopeGraph address) (ScopeGraph.reference ref decl)
+    PutDeclarationScope decl scope k -> modify @(ScopeGraph address) (ScopeGraph.insertDeclarationScope decl scope) *> runScopeEnvC k
-    NewScope edges -> do
+    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 <- alloc name
+      address <- runEvaluator (alloc name)
-        address <$ modify @(ScopeGraph address) (ScopeGraph.newScope address edges)
+      modify @(ScopeGraph address) (ScopeGraph.newScope address edges)
-    CurrentScope -> ScopeGraph.currentScope <$> get
+      runScopeEnvC (k address)
-    AssociatedScope decl -> ScopeGraph.associatedScope decl <$> get
+    CurrentScope                   k -> gets ScopeGraph.currentScope >>= runScopeEnvC . k
-    Local scope action -> do
+    AssociatedScope decl           k -> gets (ScopeGraph.associatedScope decl) >>= runScopeEnvC . k
-        prevScope <- ScopeGraph.currentScope <$> get
+    Local scope action             k -> do
+      prevScope <- gets ScopeGraph.currentScope
       modify @(ScopeGraph address) (\g -> g { ScopeGraph.currentScope = Just scope })
-        value <- reinterpret handleScopeEnv (raiseEff action)
+      value <- runScopeEnvC action
       modify @(ScopeGraph address) (\g -> g { ScopeGraph.currentScope = prevScope })
-        pure value
+      runScopeEnvC (k value))

src/Control/Abstract/Value.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE DeriveAnyClass, GADTs, KindSignatures, Rank2Types #-}
+{-# LANGUAGE DeriveAnyClass, GADTs, KindSignatures, LambdaCase, Rank2Types, TypeOperators #-}
 module Control.Abstract.Value
 ( AbstractValue(..)
 , AbstractIntro(..)
@@ -10,15 +10,20 @@ 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 +34,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 +44,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 +70,119 @@ 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 :: (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)
+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 :: (Member (Function term address value) sig, Carrier sig m) => BuiltIn -> Evaluator term address value m value
-builtIn = sendFunction . BuiltIn
+builtIn = sendFunction . flip BuiltIn ret
 
-call :: Member (Function term address value) effects => value -> address -> [address] -> Evaluator term address value effects address
+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)
+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
+data Function term address value (m :: * -> *) k
-  Function :: Maybe Name -> [Name] -> term -> Function term address value m value
+  = Function (Maybe Name) [Name] term (value -> k)
-  BuiltIn  :: BuiltIn -> Function term address value m value
+  | BuiltIn BuiltIn (value -> k)
-  Call     :: value -> address -> [address] -> Function term address value m address
+  | 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)
+  handle state handler (Function name params body k) = Function name params body (handler . (<$ state) . k)
-  handleState state handler (Request (BuiltIn builtIn)           k) = Request (BuiltIn builtIn)           (handler . (<$ state) . k)
+  handle state handler (BuiltIn builtIn           k) = 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 (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 :: (Member (Boolean value) sig, Carrier sig m) => Bool -> m value
-boolean = send . Boolean
+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 :: (Member (Boolean value) sig, Carrier sig m) => value -> m Bool
-asBool = send . AsBool
+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.
+data Boolean value (m :: * -> *) k
-disjunction :: Member (Boolean value) effects => Evaluator term address value effects value -> Evaluator term address value effects value -> Evaluator term address value effects value
+  = Boolean Bool (value -> k)
-disjunction (Evaluator a) (Evaluator b) = send (Disjunction a b)
+  | AsBool value (Bool -> k)
+  deriving (Functor)
 
-data Boolean value m result where
+instance HFunctor (Boolean value) where
-  Boolean     :: Bool  -> Boolean value m value
+  hmap _ = coerce
-  AsBool      :: value -> Boolean value m Bool
+  {-# INLINE hmap #-}
-  Disjunction :: m value -> m value -> Boolean value m value
+
+instance Effect (Boolean value) where
+  handle state handler = \case
+    Boolean b k -> Boolean b (handler . (<$ state) . k)
+    AsBool  v k -> AsBool  v (handler . (<$ state) . 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
+while :: (Member (While value) sig, Carrier sig m)
-  => Evaluator term address value effects value -- ^ Condition
+      => Evaluator term address value m value -- ^ Condition
-  -> Evaluator term address value effects value -- ^ Body
+      -> Evaluator term address value m value -- ^ Body
-  -> Evaluator term address value effects value
+      -> Evaluator term address value m value
-while (Evaluator cond) (Evaluator body) = send (While cond body)
+while cond body = send (While cond body ret)
 
 -- | Do-while loop, built on top of while.
-doWhile :: Member (While value) effects
+doWhile :: (Member (While value) sig, Carrier sig m)
-  => Evaluator term address value effects value -- ^ Body
+  => Evaluator term address value m value -- ^ Body
-  -> Evaluator term address value effects value -- ^ Condition
+  -> Evaluator term address value m value -- ^ Condition
-  -> Evaluator term address value effects value
+  -> 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)
+forLoop :: (Member (While value) sig, Member (Env address) sig, Carrier sig m)
-  => Evaluator term address value effects value -- ^ Initial statement
+  => Evaluator term address value m value -- ^ Initial statement
-  -> Evaluator term address value effects value -- ^ Condition
+  -> Evaluator term address value m value -- ^ Condition
-  -> Evaluator term address value effects value -- ^ Increment/stepper
+  -> Evaluator term address value m value -- ^ Increment/stepper
-  -> Evaluator term address value effects value -- ^ Body
+  -> Evaluator term address value m value -- ^ Body
-  -> Evaluator term address value effects value
+  -> Evaluator term address value m value
 forLoop initial cond step body =
   locally (initial *> while cond (body *> step))
 
-data While value m result where
+data While value m k
-  While :: m value -> m value -> While value m value
+  = While (m value) (m value) (value -> k)
+  deriving (Functor)
 
-instance PureEffect (While value) where
+instance HFunctor (While value) where
-  handle handler (Request (While cond body) k) = Request (While (handler cond) (handler body)) (handler . k)
+  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 +221,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 +281,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
+makeNamespace :: ( AbstractValue term address value m
-                 , Member (Deref value) effects
+                 , Member (Deref value) sig
-                 , Member (Env address) effects
+                 , Member (Env address) sig
-                 , Member (State (Heap address value)) effects
+                 , Member (State (Heap address value)) sig
+                 , Carrier sig m
                  , Ord address
                  )
               => Name
               -> address
               -> Maybe address
-              -> Evaluator term address value effects ()
+              -> Evaluator term address value m ()
-              -> Evaluator term address value effects value
+              -> 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 +306,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
+evaluateInScopedEnv :: ( AbstractValue term address value m
-                       , Member (Env address) effects
+                       , Member (Env address) sig
+                       , Carrier sig m
                        )
                     => address
-                    -> Evaluator term address value effects a
+                    -> Evaluator term address value m a
-                    -> Evaluator term address value effects a
+                    -> Evaluator term address value m a
 evaluateInScopedEnv receiver term = do
   scopedEnv <- scopedEnvironment receiver
   env <- maybeM getEnv scopedEnv
@@ -281,40 +320,43 @@ evaluateInScopedEnv receiver term = do
 
 
 -- | Evaluates a 'Value' returning the referenced value
-value :: ( AbstractValue term address value effects
+value :: ( AbstractValue term address value m
-         , Member (Deref value) effects
+         , Carrier sig m
-         , Member (Env address) effects
+         , Member (Deref value) sig
-         , Member (Reader ModuleInfo) effects
+         , Member (Env address) sig
-         , Member (Reader Span) effects
+         , Member (Reader ModuleInfo) sig
-         , Member (Resumable (BaseError (AddressError address value))) effects
+         , Member (Reader Span) sig
-         , Member (Resumable (BaseError (EnvironmentError address))) effects
+         , Member (Resumable (BaseError (AddressError address value))) sig
-         , Member (State (Heap address value)) effects
+         , 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
+address :: ( AbstractValue term address value m
-           , Member (Env address) effects
+           , Carrier sig m
-           , Member (Reader ModuleInfo) effects
+           , Member (Env address) sig
-           , Member (Reader Span) effects
+           , Member (Reader ModuleInfo) sig
-           , Member (Resumable (BaseError (EnvironmentError address))) effects
+           , 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
+rvalBox :: ( Member (Allocator address) sig
-           , Member (Deref value) effects
+           , Member (Deref value) sig
-           , Member Fresh effects
+           , Member Fresh sig
-           , Member (State (Heap address value)) effects
+           , 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/Effect/Interpose.hs

@@ -0,0 +1,49 @@
+{-# LANGUAGE ExistentialQuantification, RankNTypes, StandaloneDeriving, TypeOperators, UndecidableInstances #-}
+module Control.Effect.Interpose
+( Interpose(..)
+, interpose
+, runInterpose
+, InterposeC(..)
+, Listener(..)
+) where
+
+import Control.Effect.Carrier
+import Control.Effect.Internal
+import Control.Effect.Sum
+
+data Interpose eff m k
+  = forall a . Interpose (m a) (forall n x . eff n (n x) -> m x) (a -> k)
+
+deriving instance Functor (Interpose eff m)
+
+instance HFunctor (Interpose eff) where
+  hmap f (Interpose m h k) = Interpose (f m) (f . h) k
+
+-- | Respond to requests for some specific effect with a handler.
+--
+--   The intercepted effects are not re-sent in the surrounding context; thus, the innermost nested 'interpose' listening for an effect will win, and the effect’s own handler will not get the chance to service the request.
+--
+--   Note that since 'Interpose' lacks an 'Effect' instance, only “pure” effects, i.e. effects which can be handled inside other effects using 'hmap' alone, can be run within the 'runInterpose' scope. This includes @Reader@, but not e.g. @State@ or @Error@.
+interpose :: (Member (Interpose eff) sig, Carrier sig m)
+          => m a
+          -> (forall n x . eff n (n x) -> m x)
+          -> m a
+interpose m f = send (Interpose m f ret)
+
+
+-- | Run an 'Interpose' effect.
+runInterpose :: (Member eff sig, Carrier sig m, Monad m) => Eff (InterposeC eff m) a -> m a
+runInterpose = flip runInterposeC Nothing . interpret
+
+newtype InterposeC eff m a = InterposeC { runInterposeC :: Maybe (Listener eff m) -> m a }
+
+newtype Listener eff m = Listener { runListener :: forall n x . eff n (n x) -> m x }
+
+instance (Carrier sig m, Member eff sig, Monad m) => Carrier (Interpose eff :+: sig) (InterposeC eff m) where
+  ret a = InterposeC (const (ret a))
+  eff op = InterposeC (\ listener -> handleSum (algOther listener) (alg listener) op)
+    where alg listener (Interpose m h k) = runInterposeC m (Just (Listener (flip runInterposeC listener . h))) >>= flip runInterposeC listener . k
+          algOther listener op
+            | Just listener <- listener
+            , Just eff <- prj op = runListener listener eff
+            | otherwise          = eff (handleReader listener runInterposeC op)

src/Control/Matching.hs

@@ -1,6 +1,6 @@
 {-# LANGUAGE GADTs, TypeOperators #-}
 
-module Control.Abstract.Matching
+module Control.Matching
   ( Matcher
   , TermMatcher
   , target
@@ -9,6 +9,7 @@ module Control.Abstract.Matching
   , matchM
   , narrow
   , narrow'
+  , purely
   , succeeds
   , fails
   , runMatcher
@@ -71,6 +72,10 @@ target = Target
 ensure :: (t -> Bool) -> Matcher t ()
 ensure f = target >>= \c -> guard (f c)
 
+-- | Promote a pure function to a 'Matcher'.
+purely :: (a -> b) -> Matcher a b
+purely f = fmap f target
+
 -- | 'matchm' takes a modification function and a new matcher action the target parameter of which
 --   is the result of the modification function. If the modification function returns 'Just' when
 --   applied to the current 'target', the given matcher is executed with the result of that 'Just'

src/Control/Rewriting.hs

@@ -67,14 +67,14 @@ import Prologue hiding (apply, try)
 
 import           Control.Arrow
 import           Control.Category
-import           Control.Monad.Effect
+import           Control.Effect
-import           Control.Monad.Effect.Trace
+import           Control.Effect.Trace
 import           Data.Functor.Identity
 import           Data.Profunctor
 import qualified Data.Sum as Sum hiding (apply)
 import           Data.Text (pack)
 
-import Control.Abstract.Matching (Matcher, stepMatcher)
+import Control.Matching (Matcher, stepMatcher)
 import Data.History as History
 import Data.Term
 
@@ -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 LambdaCase, 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,26 @@ toMaybe (Partial _) = Nothing
 toMaybe (Total a)   = Just a
 
 
-relocate :: Evaluator term address1 value effects a -> Evaluator term address2 value effects a
+promoteA :: AllocatorC address m a -> AllocatorC (Hole context address) m a
-relocate = raiseEff . lowerEff
+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 = handleSum
+    (AllocatorC . eff . handleCoercible)
+    (\ (Alloc name k) -> Total <$> promoteA (eff (L (Alloc name ret))) >>= k)
 
 
-runAllocator :: PureEffects effects
+promoteD :: DerefC address value m a -> DerefC (Hole context address) value m a
-             => (forall x. Allocator address (Eff (Allocator address ': effects)) x -> Evaluator term address value effects x)
+promoteD = DerefC . runDerefC
-             -> 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)
 
-handleAllocator :: (forall x. Allocator address (Eff (Allocator address ': effects)) x -> Evaluator term address value effects x)
+instance (Carrier (Deref value :+: sig) (DerefC address value m), Carrier sig m, Monad m)
-                -> Allocator (Hole context address) (Eff (Allocator (Hole context address) ': effects)) a
+      => Carrier (Deref value :+: sig) (DerefC (Hole context address) value m) where
-                -> Evaluator term (Hole context address) value effects a
+  ret = promoteD . ret
-handleAllocator handler (Alloc name) = relocate (Total <$> handler (Alloc name))
+  eff = handleSum (DerefC . eff . handleCoercible) (\case
-
+    DerefCell        cell k -> promoteD (eff (L (DerefCell        cell ret))) >>= k
-runDeref :: PureEffects effects
+    AssignCell value cell k -> promoteD (eff (L (AssignCell value cell ret))) >>= k)
-         => (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))

src/Data/Abstract/Address/Located.hs

@@ -1,13 +1,11 @@
-{-# LANGUAGE GADTs, RankNTypes, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE LambdaCase, 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,29 @@ data Located address = Located
   deriving (Eq, Ord, Show)
 
 
-relocate :: Evaluator term address1 value effects a -> Evaluator term address2 value effects a
+promoteA :: AllocatorC address m a -> AllocatorC (Located address) m a
-relocate = raiseEff . lowerEff
+promoteA = AllocatorC . runAllocatorC
 
-
+instance ( Carrier (Allocator address :+: sig) (AllocatorC address m)
-runAllocator :: ( Member (Reader ModuleInfo) effects
+         , Carrier sig m
-                , Member (Reader PackageInfo) effects
+         , Member (Reader ModuleInfo) sig
-                , Member (Reader Span) effects
+         , Member (Reader PackageInfo) sig
-                , PureEffects effects
+         , Member (Reader Span) sig
+         , Monad m
          )
-             => (forall x. Allocator address (Eff (Allocator address ': effects)) x -> Evaluator term address value effects x)
+      => Carrier (Allocator (Located address) :+: sig) (AllocatorC (Located address) m) where
-             -> Evaluator term (Located address) value (Allocator (Located address) ': effects) a
+  ret = promoteA . ret
-             -> Evaluator term (Located address) value effects a
+  eff = handleSum
-runAllocator handler = interpret (handleAllocator handler)
+    (AllocatorC . eff . handleCoercible)
+    (\ (Alloc name k) -> Located <$> promoteA (eff (L (Alloc name ret))) <*> currentPackage <*> currentModule <*> pure name <*> ask >>= k)
 
-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
+promoteD :: DerefC address value m a -> DerefC (Located address) value m a
-         => (forall x. Deref value (Eff (Deref value ': effects)) x -> Evaluator term address value effects x)
+promoteD = DerefC . runDerefC
-         -> 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)
+instance (Carrier (Deref value :+: sig) (DerefC address value m), Carrier sig m, Monad m)
-            -> Deref value (Eff (Deref value ': effects)) a
+      => Carrier (Deref value :+: sig) (DerefC (Located address) value m) where
-            -> Evaluator term (Located address) value effects a
+  ret = promoteD . ret
-handleDeref handler (DerefCell        cell) = relocate (handler (DerefCell        cell))
+  eff = handleSum (DerefC . eff . handleCoercible) (\case
-handleDeref handler (AssignCell value cell) = relocate (handler (AssignCell value cell))
+    DerefCell        cell k -> promoteD (eff (L (DerefCell        cell ret))) >>= k
+    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 #-}
+{-# LANGUAGE LambdaCase, 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,15 @@ instance Show Monovariant where
   showsPrec d = showsUnaryWith showsPrec "Monovariant" d . unMonovariant
 
 
-runAllocator :: PureEffects effects
+instance Carrier sig m => Carrier (Allocator Monovariant :+: sig) (AllocatorC Monovariant m) where
-             => Evaluator term Monovariant value (Allocator Monovariant ': effects) a
+  ret = AllocatorC . ret
-             -> Evaluator term Monovariant value effects a
+  eff = AllocatorC . handleSum
-runAllocator = interpret handleAllocator
+    (eff . handleCoercible)
+    (\ (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
+instance (Ord value, Carrier sig m, Alternative m, Monad m) => Carrier (Deref value :+: sig) (DerefC Monovariant value m) where
-            , Ord value
+  ret = DerefC . ret
-            , PureEffects effects
+  eff = DerefC . handleSum (eff . handleCoercible) (\case
-            )
+    DerefCell        cell k -> traverse (foldMapA pure) (nonEmpty (toList cell)) >>= runDerefC . k
-         => Evaluator term Monovariant value (Deref value ': effects) a
+    AssignCell value cell k -> runDerefC (k (Set.insert value cell)))
-         -> 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)

src/Data/Abstract/Address/Precise.hs

@@ -1,13 +1,11 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving, GADTs, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving, LambdaCase, 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,15 @@ instance Show Precise where
   showsPrec d = showsUnaryWith showsPrec "Precise" d . unPrecise
 
 
-runAllocator :: ( Member Fresh effects
+instance (Member Fresh sig, Carrier sig m, Monad m) => Carrier (Allocator Precise :+: sig) (AllocatorC Precise m) where
-                , PureEffects effects
+  ret = AllocatorC . ret
-                )
+  eff = AllocatorC . handleSum
-             => Evaluator term Precise value (Allocator Precise ': effects) a
+    (eff . handleCoercible)
-             -> Evaluator term Precise value effects a
+    (\ (Alloc _ k) -> Precise <$> fresh >>= runAllocatorC . k)
-runAllocator = interpret handleAllocator
 
-handleAllocator :: Member Fresh effects => Allocator Precise (Eff (Allocator Precise ': effects)) a -> Evaluator term Precise value effects a
-handleAllocator (Alloc _) = Precise <$> fresh
 
-runDeref :: PureEffects effects
+instance Carrier sig m => Carrier (Deref value :+: sig) (DerefC Precise value m) where
-         => Evaluator term Precise value (Deref value ': effects) a
+  ret = DerefC . ret
-         -> Evaluator term Precise value effects a
+  eff = DerefC . handleSum (eff . handleCoercible) (\case
-runDeref = interpret handleDeref
+    DerefCell        cell k -> runDerefC (k (fst <$> Set.minView cell))
-
+    AssignCell value _    k -> runDerefC (k (Set.singleton value)))
-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)

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
+throwBaseError :: ( Member (Resumable (BaseError exc)) sig
-                  , Member (Reader M.ModuleInfo) effects
+                  , Member (Reader M.ModuleInfo) sig
-                  , Member (Reader S.Span) effects
+                  , 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,14 +2,9 @@
 module Data.Abstract.Evaluatable
 ( module X
 , Evaluatable(..)
-, ModuleEffects
-, ValueEffects
-, evaluate
 , traceResolve
 -- * Preludes
 , HasPrelude(..)
--- * Postludes
-, HasPostlude(..)
 -- * Effects
 , EvalError(..)
 , throwEvalError
@@ -28,18 +23,14 @@ import Control.Abstract.Evaluator as X hiding (LoopControl(..), Return(..), catc
 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 Data.Abstract.Declarations as X
 import Data.Abstract.Environment as X
 import Data.Abstract.BaseError as X
 import Data.Abstract.FreeVariables as X
 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)
 import Data.Semigroup.App
 import Data.Semigroup.Foldable
@@ -49,141 +40,67 @@ 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 (Allocator address) sig
-          , Member (Boolean value) effects
+          , Member (Boolean value) sig
-          , Member (While value) effects
+          , Member (While value) sig
-          , Member (Deref value) effects
+          , Member (Deref value) sig
-          , Member (ScopeEnv address) effects
+          , Member (ScopeEnv address) sig
-          , Member (Env address) effects
+          , Member (Env address) sig
-          , Member (Exc (LoopControl address)) effects
+          , Member (Error (LoopControl address)) sig
-          , Member (Exc (Return address)) effects
+          , Member (Error (Return address)) sig
-          , Member Fresh effects
+          , Member Fresh sig
-          , Member (Function term address value) effects
+          , Member (Function term address value) sig
-          , Member (Modules address) effects
+          , Member (Modules address) sig
-          , Member (Reader ModuleInfo) effects
+          , Member (Reader ModuleInfo) sig
-          , Member (Reader PackageInfo) effects
+          , Member (Reader PackageInfo) sig
-          , Member (Reader Span) effects
+          , Member (Reader Span) sig
-          , Member (State Span) effects
+          , Member (State Span) sig
-          , Member (Resumable (BaseError (AddressError address value))) effects
+          , Member (Resumable (BaseError (AddressError address value))) sig
-          , Member (Resumable (BaseError (EnvironmentError address))) effects
+          , Member (Resumable (BaseError (EnvironmentError address))) sig
-          , Member (Resumable (BaseError (UnspecializedError value))) effects
+          , Member (Resumable (BaseError (UnspecializedError value))) sig
-          , Member (Resumable (BaseError EvalError)) effects
+          , Member (Resumable (BaseError EvalError)) sig
-          , Member (Resumable (BaseError ResolutionError)) effects
+          , Member (Resumable (BaseError ResolutionError)) sig
-          , Member (State (Heap address value)) effects
+          , Member (State (Heap address value)) sig
-          , Member Trace effects
+          , Member Trace sig
           , Ord address
           )
-       => (term -> Evaluator term address value effects (ValueRef address))
+       => (term -> Evaluator term address value m (ValueRef address))
-       -> (constr term -> Evaluator term address value effects (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
+traceResolve :: (Show a, Show b, Member Trace sig, Carrier sig m) => a -> b -> Evaluator term address value m ()
-  =  Exc (LoopControl address)
-  ': Exc (Return address)
-  ': Env address
-  ': ScopeEnv address
-  ': Deref value
-  ': Allocator address
-  ': Reader ModuleInfo
-  ': rest
-
-type ValueEffects term address value rest
-  =  Function term address value
-  ': While value
-  ': Boolean value
-  ': rest
-
-evaluate :: ( AbstractValue term address value valueEffects
-            , Declarations term
-            , Effects effects
-            , 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
-            , Ord address
-            , Recursive term
-            , moduleEffects ~ ModuleEffects address value effects
-            , valueEffects ~ ValueEffects term address value moduleEffects
-            )
-         => 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)
-         -> [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
-    definePrelude lang
-    box unit
-  foldr (run preludeBinds) ask modules
-  where run preludeBinds m rest = do
-          evaluated <- coerce
-            (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
-          result <- evalTerm term
-          result <$ postlude lang)
-
-        evalTerm = fix (analyzeTerm ((. project) . eval)) >=> address
-
-        runInModule preludeBinds info
-          = runReader info
-          . runAllocDeref
-          . runScopeEnv
-          . runEnv (EvalContext Nothing (X.push (newEnv preludeBinds)))
-          . runReturn
-          . runLoopControl
-
-
-traceResolve :: (Show a, Show b, Member Trace effects) => a -> b -> Evaluator term address value effects ()
 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 (Allocator address) sig
-                   , Member (Deref value) effects
+                   , Member (Deref value) sig
-                   , Member (Env address) effects
+                   , Member (Env address) sig
-                   , Member Fresh effects
+                   , Member Fresh sig
-                   , Member (Function term address value) effects
+                   , Member (Function term address value) sig
-                   , Member (Reader ModuleInfo) effects
+                   , Member (Reader ModuleInfo) sig
-                   , Member (Reader Span) effects
+                   , Member (Reader Span) sig
-                   , Member (Resumable (BaseError (AddressError address value))) effects
+                   , Member (Resumable (BaseError (AddressError address value))) sig
-                   , Member (Resumable (BaseError (EnvironmentError address))) effects
+                   , Member (Resumable (BaseError (EnvironmentError address))) sig
-                   , Member (State (Heap address value)) effects
+                   , Member (State (Heap address value)) sig
-                   , Member Trace effects
+                   , Member Trace sig
                    , Ord address
                    )
                 => proxy language
-                -> Evaluator term address value effects ()
+                -> Evaluator term address value m ()
   definePrelude _ = pure ()
 
 instance HasPrelude 'Go
@@ -212,35 +129,6 @@ instance HasPrelude 'JavaScript where
     defineNamespace (name "console") $ do
       define (name "log") (builtIn Print)
 
--- Postludes
-
-class HasPostlude (language :: Language) where
-  postlude :: ( AbstractValue term address value effects
-              , 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
-              )
-           => proxy language
-           -> Evaluator term address value effects ()
-  postlude _ = pure ()
-
-instance HasPostlude 'Go
-instance HasPostlude 'Haskell
-instance HasPostlude 'Java
-instance HasPostlude 'PHP
-instance HasPostlude 'Python
-instance HasPostlude 'Ruby
-instance HasPostlude 'TypeScript
-
-instance HasPostlude 'JavaScript where
-  postlude _ = trace "JS postlude"
-
 
 -- Effects
 
@@ -281,18 +169,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 :: (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 = runResumable
+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 :: 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 = runResumableWith
+runEvalErrorWith f = raiseHandler $ runResumableWith (runEvaluator . f)
 
-throwEvalError :: ( Member (Reader ModuleInfo) effects
+throwEvalError :: ( Member (Reader ModuleInfo) sig
-                  , Member (Reader Span) effects
+                  , Member (Reader Span) sig
-                  , Member (Resumable (BaseError EvalError)) effects
+                  , 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 +204,25 @@ instance Eq1 (UnspecializedError a) where
 instance Show1 (UnspecializedError a) where
   liftShowsPrec _ _ = showsPrec
 
-runUnspecialized :: Effects effects
+runUnspecialized :: (Carrier sig m, Effect sig)
-                 => Evaluator term address value (Resumable (BaseError (UnspecializedError value)) ': effects) a
+                 => Evaluator term address value (ResumableC (BaseError (UnspecializedError value)) (Eff m)) a
-                 -> Evaluator term address value effects (Either (SomeExc (BaseError (UnspecializedError value))) a)
+                 -> Evaluator term address value m (Either (SomeError (BaseError (UnspecializedError value))) a)
-runUnspecialized = runResumable
+runUnspecialized = raiseHandler runResumable
 
-runUnspecializedWith :: Effects effects
+runUnspecializedWith :: Carrier sig m
-                     => (forall resume . BaseError (UnspecializedError value) resume -> Evaluator term address value effects resume)
+                     => (forall resume . BaseError (UnspecializedError value) resume -> Evaluator term address value m resume)
-                     -> Evaluator term address value (Resumable (BaseError (UnspecializedError value)) ': effects) a
+                     -> Evaluator term address value (ResumableWithC (BaseError (UnspecializedError value)) (Eff m)) a
-                     -> Evaluator term address value effects a
+                     -> Evaluator term address value m a
-runUnspecializedWith = runResumableWith
+runUnspecializedWith f = raiseHandler $ runResumableWith (runEvaluator . f)
 
-throwUnspecializedError :: ( Member (Resumable (BaseError (UnspecializedError value))) effects
+
-                           , Member (Reader ModuleInfo) effects
+throwUnspecializedError :: ( Member (Resumable (BaseError (UnspecializedError value))) sig
-                           , Member (Reader Span) effects
+                           , 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.Effect
-import           Control.Monad.Effect.Fresh
+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

@@ -1,4 +1,4 @@
-{-# LANGUAGE GADTs, LambdaCase, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE LambdaCase, TypeOperators, UndecidableInstances #-}
 module Data.Abstract.Value.Abstract
 ( Abstract (..)
 , runFunction
@@ -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,54 @@ data Abstract = Abstract
   deriving (Eq, Ord, Show)
 
 
-runFunction :: ( Member (Allocator address) effects
+instance ( Member (Allocator address) sig
-               , Member (Deref Abstract) effects
+         , Member (Deref Abstract) sig
-               , Member (Env address) effects
+         , Member (Env address) sig
-               , Member (Exc (Return address)) effects
+         , Member (Error (Return address)) sig
-               , Member Fresh effects
+         , Member Fresh sig
-               , Member (Reader ModuleInfo) effects
+         , Member (Reader ModuleInfo) sig
-               , Member (Reader Span) effects
+         , Member (Reader Span) sig
-               , Member (Resumable (BaseError (AddressError address Abstract))) effects
+         , Member (Resumable (BaseError (AddressError address Abstract))) sig
-               , Member (State (Heap address Abstract)) effects
+         , Member (State (Heap address Abstract)) sig
          , Ord address
-               , PureEffects effects
+         , Carrier sig m
          )
-            => (term -> Evaluator term address Abstract (Abstract.Function term address Abstract ': effects) address)
+      => Carrier (Abstract.Function term address Abstract :+: sig) (FunctionC term address Abstract (Eff m)) where
-            -> Evaluator term address Abstract (Function term address Abstract ': effects) a
+  ret = FunctionC . const . ret
-            -> Evaluator term address Abstract effects a
+  eff op = FunctionC (\ eval -> handleSum (eff . handleReader eval runFunctionC) (\case
-runFunction eval = interpret $ \case
+    Function _ params body k -> runEvaluator $ do
-  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)))
+      addr <- locally (bindAll env *> catchReturn (runFunction (Evaluator . eval) (Evaluator (eval body))))
-    deref addr
+      deref addr >>= Evaluator . flip runFunctionC eval . k
-  BuiltIn _ -> pure Abstract
+    BuiltIn _ k -> runFunctionC (k Abstract) eval
-  Call _ _ params -> do
+    Call _ _ params k -> runEvaluator $ do
       traverse_ deref params
-    box Abstract
+      box Abstract >>= Evaluator . flip runFunctionC eval . k) op)
 
-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 ::
+instance (Carrier sig m, Alternative m) => Carrier (Boolean Abstract :+: sig) (BooleanC Abstract m) where
-  ( Member (Allocator address) effects
+  ret = BooleanC . ret
-  , Member (Deref Abstract) effects
+  eff = BooleanC . handleSum (eff . handleCoercible) (\case
-  , Member (Abstract.Boolean Abstract) effects
+    Boolean _ k -> runBooleanC (k Abstract)
-  , Member NonDet effects
+    AsBool  _ k -> runBooleanC (k True) <|> runBooleanC (k False))
-  , Member (Env address) effects
+
-  , Member (Exc (Return address)) effects
+
-  , Member Fresh effects
+instance ( Member (Abstract.Boolean Abstract) sig
-  , Member (Reader ModuleInfo) effects
+         , Carrier sig m
-  , Member (Reader Span) effects
+         , Alternative m
-  , Member (Resumable (BaseError (AddressError address Abstract))) effects
+         , Monad m
-  , Member (State (Heap address Abstract)) effects
-  , Ord address
-  , PureEffects effects
          )
-  => Evaluator term address Abstract (While Abstract ': effects) a
+      => Carrier (While Abstract :+: sig) (WhileC Abstract m) where
-  -> Evaluator term address Abstract effects a
+  ret = WhileC . ret
-runWhile = interpret $ \case
+  eff = WhileC . handleSum
-  Abstract.While cond body -> do
+    (eff . handleCoercible)
-    cond' <- runWhile (raiseEff cond)
+    (\ (Abstract.While cond body k) -> do
-    ifthenelse cond' (runWhile (raiseEff body) *> empty) (pure unit)
+      cond' <- runWhileC cond
+      ifthenelse cond' (runWhileC body *> empty) (runWhileC (k unit)))
+
 
 instance Ord address => ValueRoots address Abstract where
   valueRoots = mempty
@@ -93,13 +84,14 @@ instance AbstractIntro Abstract where
   kvPair _ _ = Abstract
   null       = Abstract
 
-instance ( Member (Allocator address) effects
+instance ( Member (Allocator address) sig
-         , Member (Deref Abstract) effects
+         , Member (Deref Abstract) sig
-         , Member Fresh effects
+         , Member Fresh sig
-         , Member (State (Heap address Abstract)) effects
+         , 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,38 +55,37 @@ instance Ord address => ValueRoots address (Value term address) where
     | otherwise                  = mempty
 
 
-runFunction :: ( FreeVariables term
+instance ( FreeVariables term
-               , Member (Allocator address) effects
+         , Member (Allocator address) sig
-               , Member (Deref (Value term address)) effects
+         , Member (Deref (Value term address)) sig
-               , Member (Env address) effects
+         , Member (Env address) sig
-               , Member (Exc (Return address)) effects
+         , Member (Error (Return address)) sig
-               , Member Fresh effects
+         , Member Fresh sig
-               , Member (Reader ModuleInfo) effects
+         , Member (Reader ModuleInfo) sig
-               , Member (Reader PackageInfo) effects
+         , Member (Reader PackageInfo) sig
-               , Member (Reader Span) effects
+         , Member (Reader Span) sig
-               , Member (Resumable (BaseError (AddressError address (Value term address)))) effects
+         , Member (Resumable (BaseError (AddressError address (Value term address)))) sig
-               , Member (Resumable (BaseError (ValueError term address))) effects
+         , Member (Resumable (BaseError (ValueError term address))) sig
-               , Member (State (Heap address (Value term address))) effects
+         , Member (State (Heap address (Value term address))) sig
-               , Member Trace effects
+         , Member Trace sig
          , Ord address
-               , PureEffects effects
+         , Carrier sig m
          , Show address
          , Show term
          )
-            => (term -> Evaluator term address (Value term address) (Abstract.Function term address (Value term address) ': effects) address)
+      => Carrier (Abstract.Function term address (Value term address) :+: sig) (Abstract.FunctionC term address (Value term address) (Eff m)) where
-            -> Evaluator term address (Value term address) (Abstract.Function term address (Value term address) ': effects) a
+  ret = FunctionC . const . ret
-            -> Evaluator term address (Value term address) effects a
+  eff op = FunctionC (\ eval -> handleSum (eff . handleReader eval runFunctionC) (\case
-runFunction eval = interpret $ \case
+    Abstract.Function name params body k -> runEvaluator $ do
-  Abstract.Function name params body -> do
       packageInfo <- currentPackage
       moduleInfo <- currentModule
-    Closure packageInfo moduleInfo name params (Right body) <$> close (foldr Set.delete (freeVariables body) params)
+      Closure packageInfo moduleInfo name params (Right body) <$> close (foldr Set.delete (freeVariables body) params) >>= Evaluator . flip runFunctionC eval . k
-  Abstract.BuiltIn builtIn -> do
+    Abstract.BuiltIn builtIn k -> do
       packageInfo <- currentPackage
       moduleInfo <- currentModule
-    pure (Closure packageInfo moduleInfo Nothing [] (Left builtIn) lowerBound)
+      runFunctionC (k (Closure packageInfo moduleInfo Nothing [] (Left builtIn) lowerBound)) eval
-  Abstract.Call op self params -> do
+    Abstract.Call op self params k -> runEvaluator $ do
-    case op of
+      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
@@ -95,63 +94,59 @@ runFunction eval = interpret $ \case
           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)))
+            withEvalContext fnCtx (catchReturn (bindAll bindings *> runFunction (Evaluator . eval) (Evaluator (eval body))))
         _ -> throwValueError (CallError op) >>= box
+      Evaluator $ runFunctionC (k boxed) eval) op)
 
-runBoolean :: ( Member (Reader ModuleInfo) effects
+
-              , Member (Reader Span) effects
+instance ( Member (Reader ModuleInfo) sig
-              , Member (Resumable (BaseError (ValueError term address))) effects
+         , Member (Reader Span) sig
-              , PureEffects effects
+         , Member (Resumable (BaseError (ValueError term address))) sig
+         , Carrier sig m
+         , Monad m
          )
-           => Evaluator term address (Value term address) (Abstract.Boolean (Value term address) ': effects) a
+      => Carrier (Abstract.Boolean (Value term address) :+: sig) (BooleanC (Value term address) m) where
-           -> Evaluator term address (Value term address) effects a
+  ret = BooleanC . ret
-runBoolean = interpret $ \case
+  eff = BooleanC . handleSum (eff . handleCoercible) (\case
-  Abstract.Boolean b          -> pure $! Boolean b
+    Abstract.Boolean b          k -> runBooleanC . k $! Boolean b
-  Abstract.AsBool (Boolean b) -> pure b
+    Abstract.AsBool (Boolean b) k -> runBooleanC (k b)
-  Abstract.AsBool other       -> throwValueError $! BoolError other
+    Abstract.AsBool other       k -> throwBaseError (BoolError other) >>= runBooleanC . k)
-  Abstract.Disjunction a b    -> do
-    a' <- runBoolean (Evaluator a)
-    a'' <- runBoolean (asBool a')
-    if a'' then pure a' else runBoolean (Evaluator b)
 
 
-runWhile :: forall effects term address a .
+instance ( Carrier sig m
-  ( PureEffects effects
+         , Member (Deref (Value term address)) sig
-  , Member (Deref (Value term address)) effects
+         , Member (Abstract.Boolean (Value term address)) sig
-  , Member (Abstract.Boolean (Value term address)) effects
+         , Member (Error (LoopControl address)) sig
-  , Member (Exc (LoopControl address)) effects
+         , Member (Interpose (Resumable (BaseError (UnspecializedError (Value term address))))) sig
-  , Member (Reader ModuleInfo) effects
+         , Member (Reader ModuleInfo) sig
-  , Member (Reader Span) effects
+         , Member (Reader Span) sig
-  , Member (Resumable (BaseError (AddressError address (Value term address)))) effects
+         , Member (Resumable (BaseError (AddressError address (Value term address)))) sig
-  , Member (Resumable (BaseError (ValueError term address))) effects
+         , Member (State (Heap address (Value term address))) sig
-  , 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
+      => Carrier (Abstract.While (Value term address) :+: sig) (WhileC (Value term address) (Eff m)) where
-  -> Evaluator term address (Value term address) effects a
+  ret = WhileC . ret
-runWhile = interpret $ \case
+  eff = WhileC . handleSum (eff . handleCoercible) (\case
-  Abstract.While cond body -> loop $ \continue -> do
+    Abstract.While cond body k -> interpose @(Resumable (BaseError (UnspecializedError (Value term address)))) (runEvaluator (loop (\continue -> do
-    cond' <- runWhile (raiseEff cond)
+      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.
-    let body' = interpose @(Resumable (BaseError (UnspecializedError (Value term address))))
-          (\(Resumable (BaseError _ _ (UnspecializedError _))) -> throwAbort) $
-          runWhile (raiseEff body) *> continue
 
-    ifthenelse cond' body' (pure unit)
+      ifthenelse cond' (Evaluator (runWhileC body) *> continue) (pure Unit))))
+      (\(Resumable (BaseError _ _ (UnspecializedError _)) _) -> throwError (Abort @address))
+        >>= runWhileC . k)
     where
-    loop x = catchLoopControl (fix x) (\ control -> case control of
+      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)
+        Continue _  -> loop x
 
 
 instance AbstractHole (Value term address) where
@@ -171,15 +166,16 @@ instance (Show address, Show term) => AbstractIntro (Value term address) where
 
   null     = Null
 
-materializeEnvironment :: ( Member (Deref (Value term address)) effects
+materializeEnvironment :: ( Member (Deref (Value term address)) sig
-                          , Member (Reader ModuleInfo) effects
+                          , Member (Reader ModuleInfo) sig
-                          , Member (Reader Span) effects
+                          , Member (Reader Span) sig
-                          , Member (Resumable (BaseError (AddressError address (Value term address)))) effects
+                          , Member (Resumable (BaseError (AddressError address (Value term address)))) sig
-                          , Member (State (Heap address (Value term address))) effects
+                          , 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 +195,26 @@ materializeEnvironment val = do
         _ -> []
 
 -- | Construct a 'Value' wrapping the value arguments (if any).
-instance ( Member (Allocator address) effects
+instance ( Member (Allocator address) sig
-         , Member (Abstract.Boolean (Value term address)) effects
+         , Member (Abstract.Boolean (Value term address)) sig
-         , Member (Deref (Value term address)) effects
+         , Member (Deref (Value term address)) sig
-         , Member (Env address) effects
+         , Member (Env address) sig
-         , Member (Exc (LoopControl address)) effects
+         , Member (Error (LoopControl address)) sig
-         , Member (Exc (Return address)) effects
+         , Member (Error (Return address)) sig
-         , Member Fresh effects
+         , Member Fresh sig
-         , Member (Reader ModuleInfo) effects
+         , Member (Reader ModuleInfo) sig
-         , Member (Reader PackageInfo) effects
+         , Member (Reader PackageInfo) sig
-         , Member (Reader Span) effects
+         , Member (Reader Span) sig
-         , Member (Resumable (BaseError (ValueError term address))) effects
+         , Member (Resumable (BaseError (ValueError term address))) sig
-         , Member (Resumable (BaseError (AddressError address (Value term address)))) effects
+         , Member (Resumable (BaseError (AddressError address (Value term address)))) sig
-         , Member (State (Heap address (Value term address))) effects
+         , Member (State (Heap address (Value term address))) sig
-         , Member Trace effects
+         , 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 +279,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 +300,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 +391,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
+runValueError :: (Carrier sig m, Effect sig)
-              => Evaluator term address (Value term address) (Resumable (BaseError (ValueError term address)) ': effects) a
+              => Evaluator term address (Value term address) (ResumableC (BaseError (ValueError term address)) (Eff m)) a
-              -> Evaluator term address (Value term address) effects (Either (SomeExc (BaseError (ValueError term address))) a)
+              -> Evaluator term address (Value term address) m (Either (SomeError (BaseError (ValueError term address))) a)
-runValueError = runResumable
+runValueError = Evaluator . runResumable . runEvaluator
 
-runValueErrorWith :: Effects effects
+runValueErrorWith :: Carrier sig m
-                  => (forall resume . BaseError (ValueError term address) resume -> Evaluator term address (Value term address) effects resume)
+                  => (forall resume . BaseError (ValueError term address) resume -> Evaluator term address (Value term address) m resume)
-                  -> Evaluator term address (Value term address) (Resumable (BaseError (ValueError term address)) ': effects) a
+                  -> Evaluator term address (Value term address) (ResumableWithC (BaseError (ValueError term address)) (Eff m)) a
-                  -> Evaluator term address (Value term address) effects a
+                  -> Evaluator term address (Value term address) m a
-runValueErrorWith = runResumableWith
+runValueErrorWith f = Evaluator . runResumableWith (runEvaluator . f) . runEvaluator
 
-throwValueError :: ( Member (Resumable (BaseError (ValueError term address))) effects
+throwValueError :: ( Member (Resumable (BaseError (ValueError term address))) sig
-                   , Member (Reader ModuleInfo) effects
+                   , Member (Reader ModuleInfo) sig
-                   , Member (Reader Span) effects
+                   , 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

@@ -1,4 +1,4 @@
-{-# LANGUAGE GADTs, RankNTypes, TypeFamilies, TypeOperators, UndecidableInstances, LambdaCase #-}
+{-# LANGUAGE GADTs, LambdaCase, RankNTypes, TypeFamilies, TypeOperators, UndecidableInstances #-}
 module Data.Abstract.Value.Type
   ( Type (..)
   , TypeError (..)
@@ -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 :: (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 = runResumable
+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 :: 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 = runResumableWith
+runTypeErrorWith f = raiseHandler $ runResumableWith (runEvaluator . f)
 
-throwTypeError :: ( Member (Resumable (BaseError TypeError)) effects
+
-                  , Member (Reader ModuleInfo) effects
+throwTypeError :: ( Member (Resumable (BaseError TypeError)) sig
-                  , Member (Reader Span) effects
+                  , 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
+runTypeMap :: (Carrier sig m, Effect sig)
-              , Effects effects
+           => Evaluator term address Type (StateC TypeMap (Eff m)) a
-              )
+           -> Evaluator term address Type m a
-           => m (State TypeMap ': effects) a
+runTypeMap = raiseHandler $ fmap snd . runState emptyTypeMap
-           -> m effects a
-runTypeMap = raiseHandler (runState emptyTypeMap >=> pure . snd)
 
-runTypes :: ( Effectful m
+runTypes :: (Carrier sig m, Effect sig)
-            , Effects effects
+         => Evaluator term address Type (ResumableC (BaseError TypeError) (Eff
-            )
+                                        (StateC TypeMap (Eff
-         => m (Resumable (BaseError TypeError) ': State TypeMap ': effects) a
+                                        m)))) a
-         -> m effects (Either (SomeExc (BaseError TypeError)) a)
+         -> Evaluator term address Type m (Either (SomeError (BaseError TypeError)) a)
 runTypes = runTypeMap . runTypeError
 
-runTypesWith :: ( Effectful m
+runTypesWith :: (Carrier sig m, Effect sig)
-                , Effects effects
+             => (forall resume . (BaseError TypeError) resume -> Evaluator term address Type (StateC TypeMap (Eff m)) resume)
-                )
+             -> Evaluator term address Type (ResumableWithC (BaseError TypeError) (Eff
-             => (forall resume . (BaseError TypeError) resume -> m (State TypeMap ': effects) resume)
+                                            (StateC TypeMap (Eff
-             -> m (Resumable (BaseError TypeError) ': State TypeMap ': effects) a
+                                            m)))) a
-             -> m effects 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
+modifyTypeMap :: ( Member (State TypeMap) sig
-                 , Member (State TypeMap) effects
+                 , 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
+prune :: ( Member (State TypeMap) sig
-         , Monad (m effects)
+         , Carrier sig m
-         , Member (State TypeMap) effects
+         , Monad m
          )
       => Type
-      -> m effects Type
+      -> m Type
-prune (Var id) = Map.lookup id . unTypeMap <$> get >>= \case
+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
+occur :: ( Member (State TypeMap) sig
-         , Monad (m effects)
+         , Carrier sig m
-         , Member (State TypeMap) effects
+         , 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
+substitute :: ( Member (Reader ModuleInfo) sig
-              , Member (Reader Span) effects
+              , Member (Reader Span) sig
-              , Member (Resumable (BaseError TypeError)) effects
+              , Member (Resumable (BaseError TypeError)) sig
-              , Member (State TypeMap) effects
+              , 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
+unify :: ( Member (Reader ModuleInfo) sig
-         , Member (Reader Span) effects
+         , Member (Reader Span) sig
-         , Member (Resumable (BaseError TypeError)) effects
+         , Member (Resumable (BaseError TypeError)) sig
-         , Member (State TypeMap) effects
+         , 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,71 @@ instance Ord address => ValueRoots address Type where
   valueRoots _ = mempty
 
 
-runFunction :: ( Member (Allocator address) effects
+instance ( Member (Allocator address) sig
-               , Member (Deref Type) effects
+         , Member (Deref Type) sig
-               , Member (Env address) effects
+         , Member (Env address) sig
-               , Member (Exc (Return address)) effects
+         , Member (Error (Return address)) sig
-               , Member Fresh effects
+         , Member Fresh sig
-               , Member (Reader ModuleInfo) effects
+         , Member (Reader ModuleInfo) sig
-               , Member (Reader Span) effects
+         , Member (Reader Span) sig
-               , Member (Resumable (BaseError TypeError)) effects
+         , Member (Resumable (BaseError TypeError)) sig
-               , Member (Resumable (BaseError (AddressError address Type))) effects
+         , Member (Resumable (BaseError (AddressError address Type))) sig
-               , Member (State (Heap address Type)) effects
+         , Member (State (Heap address Type)) sig
-               , Member (State TypeMap) effects
+         , Member (State TypeMap) sig
          , Ord address
-               , PureEffects effects
+         , Carrier sig m
          )
-            => (term -> Evaluator term address Type (Abstract.Function term address Type ': effects) address)
+      => Carrier (Abstract.Function term address Type :+: sig) (FunctionC term address Type (Eff m)) where
-            -> Evaluator term address Type (Abstract.Function term address Type ': effects) a
+  ret = FunctionC . const . ret
-            -> Evaluator term address Type effects a
+  eff op = FunctionC (\ eval -> handleSum (eff . handleReader eval runFunctionC) (\case
-runFunction eval = interpret $ \case
+    Abstract.Function _ params body k -> runEvaluator $ do
-  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)
+      locally (catchReturn (bindAll env *> runFunction (Evaluator . eval) (Evaluator (eval body)))) >>= deref >>= Evaluator . flip runFunctionC eval . k . (zeroOrMoreProduct tvars :->)
-  Abstract.BuiltIn Print -> pure (String :-> Unit)
+    Abstract.BuiltIn Print k -> runFunctionC (k (String :-> Unit)) eval
-  Abstract.BuiltIn Show  -> pure (Object :-> String)
+    Abstract.BuiltIn Show  k -> runFunctionC (k (Object :-> String)) eval
-  Abstract.Call op _ params -> do
+    Abstract.Call op _ params k -> runEvaluator $ do
       tvar <- fresh
       paramTypes <- traverse deref params
       let needed = zeroOrMoreProduct paramTypes :-> Var tvar
       unified <- op `unify` needed
-    case unified of
+      boxed <- case unified of
         _ :-> ret -> box ret
         actual    -> throwTypeError (UnificationError needed actual) >>= box
+      Evaluator $ runFunctionC (k boxed) eval) op)
 
-runBoolean :: ( Member NonDet effects
+
-              , Member (Reader ModuleInfo) effects
+instance ( Member (Reader ModuleInfo) sig
-              , Member (Reader Span) effects
+         , Member (Reader Span) sig
-              , Member (Resumable (BaseError TypeError)) effects
+         , Member (Resumable (BaseError TypeError)) sig
-              , Member (State TypeMap) effects
+         , Member (State TypeMap) sig
-              , PureEffects effects
+         , Carrier sig m
+         , Alternative m
+         , Monad m
          )
-           => Evaluator term address Type (Abstract.Boolean Type ': effects) a
+      => Carrier (Abstract.Boolean Type :+: sig) (BooleanC Type m) where
-           -> Evaluator term address Type effects a
+  ret = BooleanC . ret
-runBoolean = interpret $ \case
+  eff = BooleanC . handleSum (eff . handleCoercible) (\case
-  Abstract.Boolean _         -> pure Bool
+    Abstract.Boolean _ k -> runBooleanC (k Bool)
-  Abstract.AsBool  t         -> unify t Bool *> (pure True <|> pure False)
+    Abstract.AsBool  t k -> unify t Bool *> (runBooleanC (k True) <|> runBooleanC (k False)))
-  Abstract.Disjunction t1 t2 -> (runBoolean (Evaluator t1) >>= unify Bool) <|> (runBoolean (Evaluator t2) >>= unify Bool)
 
 
-runWhile ::
+instance ( Member (Abstract.Boolean Type) sig
-  ( Member (Allocator address) effects
+         , Carrier sig m
-  , Member (Deref Type) effects
+         , Alternative m
-  , Member (Abstract.Boolean Type) effects
+         , Monad m
-  , 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
+      => Carrier (Abstract.While Type :+: sig) (WhileC Type m) where
-  -> Evaluator term address Type effects a
+  ret = WhileC . ret
-runWhile = interpret $ \case
+  eff = WhileC . handleSum
-  Abstract.While cond body -> do
+    (eff . handleCoercible)
-    cond' <- runWhile (raiseEff cond)
+    (\ (Abstract.While cond body k) -> do
-    ifthenelse cond' (runWhile (raiseEff body) *> empty) (pure unit)
+      cond' <- runWhileC cond
+      ifthenelse cond' (runWhileC body *> empty) (runWhileC (k unit)))
+
 
 instance AbstractHole Type where
   hole = Hole
@@ -322,18 +320,19 @@ instance AbstractIntro Type where
   null        = Null
 
 -- | Discard the value arguments (if any), constructing a 'Type' instead.
-instance ( Member (Allocator address) effects
+instance ( Member (Allocator address) sig
-         , Member (Deref Type) effects
+         , Member (Deref Type) sig
-         , Member Fresh effects
+         , Member Fresh sig
-         , Member (Reader ModuleInfo) effects
+         , Member (Reader ModuleInfo) sig
-         , Member (Reader Span) effects
+         , Member (Reader Span) sig
-         , Member (Resumable (BaseError (AddressError address Type))) effects
+         , Member (Resumable (BaseError (AddressError address Type))) sig
-         , Member (Resumable (BaseError TypeError)) effects
+         , Member (Resumable (BaseError TypeError)) sig
-         , Member (State (Heap address Type)) effects
+         , Member (State (Heap address Type)) sig
-         , Member (State TypeMap) effects
+         , 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.Effect
-import           Control.Monad.Effect.Exception
+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.Effect
-import           Control.Monad.Effect.State
+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.Effect
-import           Control.Monad.Effect.Exception
+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
@@ -249,7 +249,9 @@ instance Ord1 Or where liftCompare = genericLiftCompare
 instance Show1 Or where liftShowsPrec = genericLiftShowsPrec
 
 instance Evaluatable Or where
-  eval eval (Or a b) = disjunction (eval a >>= Abstract.value) (eval b >>= Abstract.value) >>= rvalBox
+  eval eval (Or a b) = do
+    a' <- eval a >>= Abstract.value
+    ifthenelse a' (rvalBox a') (eval b)
 
 data And a = And { lhs :: a, rhs :: a }
   deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1)

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
+resolveGoImport :: ( Member (Modules address) sig
-                   , Member (Reader ModuleInfo) effects
+                   , Member (Reader ModuleInfo) sig
-                   , Member (Reader Package.PackageInfo) effects
+                   , Member (Reader Package.PackageInfo) sig
-                   , Member (Reader Span) effects
+                   , Member (Reader Span) sig
-                   , Member (Resumable (BaseError ResolutionError)) effects
+                   , Member (Resumable (BaseError ResolutionError)) sig
-                   , Member Trace effects
+                   , 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.Effect
-import Control.Monad.Effect.Exception (Exc, throwError)
+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)
+defaultJSONPipeline :: (Member (Error TranslationError) sig, Carrier sig m, Monad m)
-  => ProcessT (Eff effs) Fragment Splice
+  => 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)
+beautifyingJSON :: (Member (Error TranslationError) sig, Carrier sig m, Monad m)
-  => JSONBeautyOpts -> ProcessT (Eff effs) Fragment Splice
+  => 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)
+minimizingJSON :: (Member (Error TranslationError) sig, Carrier sig m, Monad m)
-  => ProcessT (Eff effs) Fragment Splice
+  => 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
+resolvePHPName :: ( Member (Modules address) sig
-                  , Member (Reader ModuleInfo) effects
+                  , Member (Reader ModuleInfo) sig
-                  , Member (Reader Span) effects
+                  , Member (Reader Span) sig
-                  , Member (Resumable (BaseError ResolutionError)) effects
+                  , 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
+include :: ( AbstractValue term address value m
-           , Member (Deref value) effects
+           , Carrier sig m
-           , Member (Env address) effects
+           , Member (Deref value) sig
-           , Member (Modules address) effects
+           , Member (Env address) sig
-           , Member (Reader ModuleInfo) effects
+           , Member (Modules address) sig
-           , Member (Reader Span) effects
+           , Member (Reader ModuleInfo) sig
-           , Member (Resumable (BaseError (AddressError address value))) effects
+           , Member (Reader Span) sig
-           , Member (Resumable (BaseError ResolutionError)) effects
+           , Member (Resumable (BaseError (AddressError address value))) sig
-           , Member (Resumable (BaseError (EnvironmentError address))) effects
+           , Member (Resumable (BaseError ResolutionError)) sig
-           , Member (State (Heap address value)) effects
+           , Member (Resumable (BaseError (EnvironmentError address))) sig
-           , Member Trace effects
+           , 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))
+        -> (ModulePath -> Evaluator term address value m (ModuleResult address))
-        -> Evaluator term address value effects (ValueRef 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.Effect
-import Control.Monad.Effect.Exception (Exc, throwError)
+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
+resolvePythonModules :: ( Member (Modules address) sig
-                        , Member (Reader ModuleInfo) effects
+                        , Member (Reader ModuleInfo) sig
-                        , Member (Reader Span) effects
+                        , Member (Reader Span) sig
-                        , Member (Resumable (BaseError ResolutionError)) effects
+                        , Member (Resumable (BaseError ResolutionError)) sig
-                        , Member Trace effects
+                        , 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
+evalQualifiedImport :: ( AbstractValue term address value m
-                       , Member (Allocator address) effects
+                       , Carrier sig m
-                       , Member (Deref value) effects
+                       , Member (Allocator address) sig
-                       , Member (Env address) effects
+                       , Member (Deref value) sig
-                       , Member (Modules address) effects
+                       , Member (Env address) sig
-                       , Member (State (Heap address value)) effects
+                       , 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.Effect
-import Control.Monad.Effect.Exception (Exc, throwError)
+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
+resolveRubyName :: ( Member (Modules address) sig
-                   , Member (Reader ModuleInfo) effects
+                   , Member (Reader ModuleInfo) sig
-                   , Member (Reader Span) effects
+                   , Member (Reader Span) sig
-                   , Member (Resumable (BaseError ResolutionError)) effects
+                   , 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
+resolveRubyPath :: ( Member (Modules address) sig
-                   , Member (Reader ModuleInfo) effects
+                   , Member (Reader ModuleInfo) sig
-                   , Member (Reader Span) effects
+                   , Member (Reader Span) sig
-                   , Member (Resumable (BaseError ResolutionError)) effects
+                   , 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
+doRequire :: ( Member (Boolean value) sig
-             , Member (Modules address) effects
+             , 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
+doLoad :: ( Member (Boolean value) sig
-          , Member (Env address) effects
+          , Member (Env address) sig
-          , Member (Modules address) effects
+          , Member (Modules address) sig
-          , Member (Reader ModuleInfo) effects
+          , Member (Reader ModuleInfo) sig
-          , Member (Reader Span) effects
+          , Member (Reader Span) sig
-          , Member (Resumable (BaseError ResolutionError)) effects
+          , Member (Resumable (BaseError ResolutionError)) sig
-          , Member Trace effects
+          , 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
+resolveWithNodejsStrategy :: ( Member (Modules address) sig
-                             , Member (Reader M.ModuleInfo) effects
+                             , Member (Reader M.ModuleInfo) sig
-                             , Member (Reader PackageInfo) effects
+                             , Member (Reader PackageInfo) sig
-                             , Member (Reader Span) effects
+                             , Member (Reader Span) sig
-                             , Member (Resumable (BaseError ResolutionError)) effects
+                             , Member (Resumable (BaseError ResolutionError)) sig
-                             , Member Trace effects
+                             , 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
+resolveRelativePath :: ( Member (Modules address) sig
-                       , Member (Reader M.ModuleInfo) effects
+                       , Member (Reader M.ModuleInfo) sig
-                       , Member (Reader PackageInfo) effects
+                       , Member (Reader PackageInfo) sig
-                       , Member (Reader Span) effects
+                       , Member (Reader Span) sig
-                       , Member (Resumable (BaseError ResolutionError)) effects
+                       , Member (Resumable (BaseError ResolutionError)) sig
-                       , Member Trace effects
+                       , 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
+resolveNonRelativePath :: ( Member (Modules address) sig
-                          , Member (Reader M.ModuleInfo) effects
+                          , Member (Reader M.ModuleInfo) sig
-                          , Member (Reader PackageInfo) effects
+                          , Member (Reader PackageInfo) sig
-                          , Member (Reader Span) effects
+                          , Member (Reader Span) sig
-                          , Member (Resumable (BaseError ResolutionError)) effects
+                          , Member (Resumable (BaseError ResolutionError)) sig
-                          , Member Trace effects
+                          , 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
+resolveModule :: ( Member (Modules address) sig
-                 , Member (Reader PackageInfo) effects
+                 , Member (Reader PackageInfo) sig
-                 , Member Trace effects
+                 , 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
+evalRequire :: ( AbstractValue term address value m
-               , Member (Allocator address) effects
+               , Member (Allocator address) sig
-               , Member (Deref value) effects
+               , Member (Deref value) sig
-               , Member (Env address) effects
+               , Member (Env address) sig
-               , Member (Modules address) effects
+               , Member (Modules address) sig
-               , Member (State (Heap address value)) effects
+               , 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/Matching/Core.hs

@@ -8,7 +8,7 @@ module Matching.Core
 
 import Prologue
 
-import           Control.Abstract.Matching
+import           Control.Matching
 import qualified Data.Syntax.Literal as Literal
 import           Data.Term
 

src/Parsing/Parser.hs

@@ -31,7 +31,7 @@ module Parsing.Parser
 import           Assigning.Assignment
 import qualified Assigning.Assignment.Deterministic as Deterministic
 import qualified CMarkGFM
-import           Data.Abstract.Evaluatable (HasPostlude, HasPrelude)
+import           Data.Abstract.Evaluatable (HasPrelude)
 import           Data.AST
 import           Data.Graph.ControlFlowVertex (VertexDeclaration')
 import           Data.Kind
@@ -73,7 +73,6 @@ data SomeAnalysisParser typeclasses ann where
                         , Apply (VertexDeclaration' (Sum fs)) fs
                         , Element Syntax.Identifier fs
                         , HasPrelude lang
-                        , HasPostlude lang
                         )
                      => Parser (Term (Sum fs) ann)
                      -> Proxy lang

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.Effect
-import           Control.Monad.Effect.Resource
+import           Control.Effect.Resource
-import           Control.Monad.Effect.Trace
+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 sig
-              , Member Resource effects
+              , Member Timeout sig
-              , Member Timeout effects
+              , Member Trace sig
-              , Member Trace effects
+              , 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.Effect
-import Control.Monad.Effect.Fresh
+import Control.Effect.Fresh
-import Control.Monad.Effect.Reader
+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 :: Eff (ReaderC (Graph vertex)
-runGraph = run . runFresh 0 . runReader mempty
+           (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 Fresh sig
-      , Member (Reader (Graph TermVertex)) effs
+      , Member (Reader (Graph TermVertex)) sig
+      , Carrier sig m
+      , Monad m
       )
-      => TermF syntax Location (Eff effs (Graph TermVertex))
+      => TermF syntax Location (m (Graph TermVertex))
-      -> Eff effs (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 Fresh sig
-        , Member (Reader (Graph DiffVertex)) effs
+        , Member (Reader (Graph DiffVertex)) sig
-        ) => f (Eff effs (Graph DiffVertex)) -> DiffVertexTerm -> Eff effs (Graph DiffVertex)
+        , 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           Control.Effect as Effect
-import qualified Control.Monad.Effect.Exception as Exc
+import           Control.Effect.Error as Effect
-import           Control.Monad.Effect.State
+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.Effect
-import           Control.Monad.Effect.Exception (Exc)
+import           Control.Effect.Error
-import qualified Control.Monad.Effect.Exception as Exc
+import           Control.Effect.State
-import           Control.Monad.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)))
+  (x:xs) -> when (x == c) (lift (modify (const xs)))
-  cs     -> lift (Exc.throwError (UnbalancedPair c cs))
+  cs     -> lift (throwError (UnbalancedPair c cs))

src/Semantic/AST.hs

@@ -7,12 +7,13 @@ module Semantic.AST
   , runASTParse
   ) where
 
-import Prologue hiding (catchError)
+import Prologue
 
 import Data.ByteString.Builder
 import Data.List (intersperse)
 
-import           Control.Monad.Effect.Exception
+import           Control.Effect
+import           Control.Effect.Error
 import           Data.AST
 import           Data.Blob
 import           Parsing.Parser
@@ -26,7 +27,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
@@ -35,12 +36,7 @@ astParseBlob blob@Blob{..}
 data ASTFormat = SExpression | JSON | Show | Quiet
   deriving (Show)
 
-runASTParse :: ( Member (Lift IO) effects
+runASTParse :: (Member Distribute sig, Member (Error SomeException) sig, Member Task sig, Carrier sig m, MonadIO m) => ASTFormat -> [Blob] -> m F.Builder
-               , Member Distribute effects
-               , Member (Exc SomeException) effects
-               , Member Task effects
-               )
-            => ASTFormat -> [Blob] -> Eff effects 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/Analysis.hs

@@ -0,0 +1,131 @@
+{-# LANGUAGE TypeFamilies, TypeOperators #-}
+module Semantic.Analysis
+( evaluate
+, evalTerm
+) where
+
+import Control.Abstract
+import Control.Effect.Interpose
+import Data.Abstract.Environment as Env
+import Data.Abstract.Evaluatable
+import Data.Abstract.Module
+import Data.Abstract.ModuleTable as ModuleTable
+import Data.Function
+import Prologue
+
+type ModuleC address value m
+  = 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 ValueC term address value m
+  = FunctionC term address value                                  (Eff
+  ( WhileC value                                                  (Eff
+  ( BooleanC value                                                (Eff
+  ( InterposeC (Resumable (BaseError (UnspecializedError value))) (Eff
+    m)))))))
+
+-- | Evaluate a list of modules with the prelude for the passed language available, and applying the passed function to every module.
+evaluate :: ( AbstractValue term address value (ValueC term address value inner)
+            , Carrier innerSig inner
+            , Carrier outerSig outer
+            , derefSig ~ (Deref value :+: allocatorSig)
+            , derefC ~ (DerefC address value (Eff allocatorC))
+            , Carrier derefSig derefC
+            , allocatorSig ~ (Allocator address :+: Reader ModuleInfo :+: outerSig)
+            , allocatorC ~ (AllocatorC address (Eff (ReaderC ModuleInfo (Eff outer))))
+            , Carrier allocatorSig allocatorC
+            , booleanC ~ BooleanC value (Eff (InterposeC (Resumable (BaseError (UnspecializedError value))) (Eff inner)))
+            , booleanSig ~ (Boolean value :+: Interpose (Resumable (BaseError (UnspecializedError value))) :+: innerSig)
+            , Carrier booleanSig booleanC
+            , whileC ~ WhileC value (Eff booleanC)
+            , whileSig ~ (While value :+: booleanSig)
+            , Carrier whileSig whileC
+            , functionC ~ FunctionC term address value (Eff whileC)
+            , functionSig ~ (Function term address value :+: whileSig)
+            , Carrier functionSig functionC
+            , Effect outerSig
+            , HasPrelude lang
+            , Member Fresh outerSig
+            , Member (Allocator address) innerSig
+            , Member (Deref value) innerSig
+            , Member (Env address) innerSig
+            , Member Fresh innerSig
+            , Member (Reader ModuleInfo) innerSig
+            , Member (Reader (ModuleTable (NonEmpty (Module (ModuleResult address))))) outerSig
+            , Member (Reader Span) innerSig
+            , Member (Resumable (BaseError (AddressError address value))) innerSig
+            , Member (Resumable (BaseError (EnvironmentError address))) innerSig
+            , Member (Resumable (BaseError (UnspecializedError value))) innerSig
+            , Member (State (Heap address value)) innerSig
+            , Member Trace innerSig
+            , Ord address
+            )
+         => proxy lang
+         -> (  (Module (Either (proxy lang) term) -> Evaluator term address value inner address)
+            -> (Module (Either (proxy lang) term) -> Evaluator term address value (ModuleC address value outer) address))
+         -> (term -> Evaluator term address value (ValueC term address value inner) address)
+         -> [Module term]
+         -> Evaluator term address value outer (ModuleTable (NonEmpty (Module (ModuleResult address))))
+evaluate lang perModule runTerm modules = do
+  let prelude = Module moduleInfoFromCallStack (Left lang)
+  (_, (preludeBinds, _)) <- evalModule lowerBound prelude
+  foldr (run preludeBinds . fmap Right) ask modules
+  where run prelude m rest = do
+          evaluated <- evalModule prelude 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
+
+        evalModule prelude m = runInModule (perModule (runValueEffects . moduleBody) m)
+          where runInModule
+                  = raiseHandler (runReader (moduleInfo m))
+                  . runAllocator
+                  . runDeref
+                  . runScopeEnv
+                  . runEnv (EvalContext Nothing (Env.push (newEnv prelude)))
+                  . runReturn
+                  . runLoopControl
+
+        runValueEffects = raiseHandler runInterpose . runBoolean . runWhile . runFunction runTerm . either ((*> box unit) . definePrelude) runTerm
+
+-- | Evaluate a term recursively, applying the passed function at every recursive position.
+--
+--   This calls out to the 'Evaluatable' instances, will be passed to 'runValueEffects', and can have other functions composed after it to e.g. intercept effects arising in the evaluation of the term.
+evalTerm :: ( Carrier sig m
+            , Declarations term
+            , Evaluatable (Base term)
+            , FreeVariables term
+            , AbstractValue term address value m
+            , Member (Allocator address) sig
+            , Member (Boolean value) sig
+            , Member (Deref value) 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 (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 (ScopeEnv address) sig
+            , Member (State (Heap address value)) sig
+            , Member (State Span) sig
+            , Member Trace sig
+            , Member (While value) sig
+            , Ord address
+            , Recursive term
+            )
+         => Open (Open (term -> Evaluator term address value m (ValueRef address)))
+         -> term -> Evaluator term address value m address
+evalTerm perTerm = fix (perTerm (\ ev -> eval ev . project)) >=> address

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)
+withParsedBlobPairs :: (Member Distribute sig, Member (Error SomeException) sig, Member Task sig, Member Telemetry sig, MonadIO m, Monoid output, Carrier sig m)
-                    => Decorate effs Location ann
+                    => Decorate m Location ann
-                    -> (forall syntax . CanDiff syntax => BlobPair -> Diff syntax ann ann -> Eff effs output)
+                    -> (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)
+withParsedBlobPair :: (Member Distribute sig, Member (Error SomeException) sig, Member Task sig, Carrier sig m, Monad m)
-                   => Decorate effs Location ann
+                   => 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,60 @@
-{-# 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
-import           Prologue hiding (MonadError (..))
 
 -- | 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 :: (Member Distribute sig, Traversable t, Carrier sig m, Applicative m) => t (m output) -> m (t output)
-distribute = fmap (withStrategy (parTraversable rseq)) <$> traverse (send . Distribute)
+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 :: Eff (DistributeC (Eff (LiftC IO))) a -> Eff (LiftC IO) a
-runDistribute = interpret (\ (Distribute task) -> liftIO (Async.runConcurrently (Async.Concurrently (runM (runDistribute task)))))
+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 . handleSum
+    (eff . handleCoercible)
+    (\ (Distribute task k) -> liftIO (Async.runConcurrently (Async.Concurrently (runM (runDistributeC task)))) >>= runDistributeC . k)

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,8 @@ 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.Analysis
 import           Semantic.Task as Task
 import           System.FilePath.Posix (takeDirectory, (</>))
 import           Text.Show.Pretty (ppShow)
@@ -66,11 +68,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
@@ -89,58 +91,60 @@ runCallGraph :: ( VertexDeclarationWithStrategy (VertexDeclarationStrategy synta
                 , Functor syntax
                 , Evaluatable syntax
                 , term ~ Term syntax Location
-                , FreeVariables term
+                , FreeVariables1 syntax
-                , Recursive term
                 , HasPrelude lang
-                , HasPostlude lang
+                , Member Trace sig
-                , Member Trace effs
+                , Carrier sig m
-                , Effects effs
+                , Effect sig
                 )
              => Proxy lang
              -> Bool
              -> [Module term]
              -> Package term
-             -> Eff effs (Graph ControlFlowVertex)
+             -> Eff m (Graph ControlFlowVertex)
-runCallGraph lang includePackages modules package = do
+runCallGraph lang includePackages modules package
-  let analyzeTerm = withTermSpans . graphingTerms . cachingTerms
+  = fmap (simplify . fst)
-      analyzeModule = (if includePackages then graphingPackages else id) . convergingModules . graphingModules
+  . runEvaluator
-      extractGraph (graph, _) = simplify graph
+  . graphing @_ @_ @_ @(Hole (Maybe Name) (Located Monovariant)) @Abstract
-      runGraphAnalysis
-        = graphing @_ @_ @(Maybe Name) @Monovariant
   . runHeap
   . caching
-        . runFresh 0
+  . raiseHandler runFresh
   . resumingLoadError
   . resumingUnspecialized
   . resumingEnvironmentError
   . resumingEvalError
   . resumingResolutionError
   . resumingAddressError
-        . runReader (packageInfo package)
+  . raiseHandler (runReader (packageInfo package))
-        . runReader (lowerBound @Span)
+  . raiseHandler (runReader (lowerBound @Span))
-        . runState (lowerBound @Span)
+  . raiseHandler (runState (lowerBound @Span))
-        . runReader (lowerBound @ControlFlowVertex)
+  . raiseHandler (runReader (lowerBound @ControlFlowVertex))
   . providingLiveSet
-        . runReader (lowerBound @(ModuleTable (NonEmpty (Module (ModuleResult (Hole (Maybe Name) (Located Monovariant)))))))
+  . runModuleTable
   . runModules (ModuleTable.modulePaths (packageModules package))
-      runAddressEffects
+  $ evaluate lang perModule perTerm modules
-        = Hole.runAllocator (Located.handleAllocator Monovariant.handleAllocator)
+  where perTerm = evalTerm (withTermSpans . graphingTerms . cachingTerms)
-        . Hole.runDeref (Located.handleDeref Monovariant.handleDeref)
+        perModule = (if includePackages then graphingPackages else id) . convergingModules . graphingModules
-  extractGraph <$> runEvaluator (runGraphAnalysis (evaluate lang analyzeModule analyzeTerm runAddressEffects (fmap (Abstract.runBoolean . Abstract.runWhile) . Abstract.runFunction) 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 sig
-                               , Member Trace effs
                                , 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))
 
@@ -148,15 +152,15 @@ runImportGraphToModules :: ( Declarations term
                            , Evaluatable (Base term)
                            , FreeVariables term
                            , HasPrelude lang
-                           , HasPostlude lang
+                           , Member Trace sig
-                           , Member Trace effs
                            , 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))
 
@@ -164,23 +168,22 @@ runImportGraph :: ( Declarations term
                   , Evaluatable (Base term)
                   , FreeVariables term
                   , HasPrelude lang
-                  , HasPostlude lang
+                  , Member Trace sig
-                  , Member Trace effs
                   , 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 =
+runImportGraph lang (package :: Package term) f
-  let analyzeModule = graphingModuleInfo
+  = fmap (fst >=> f)
-      extractGraph (graph, _) = graph >>= f
+  . runEvaluator @_ @_ @(Value _ (Hole (Maybe Name) Precise))
-      runImportGraphAnalysis
+  . raiseHandler (runState lowerBound)
-        = runState lowerBound
   . runHeap
-        . runFresh 0
+  . raiseHandler runFresh
   . resumingLoadError
   . resumingUnspecialized
   . resumingEnvironmentError
@@ -188,25 +191,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)
+  . raiseHandler (runReader (packageInfo package))
-        . runState (lowerBound @Span)
+  . raiseHandler (runState (lowerBound @Span))
-        . runReader (lowerBound @Span)
+  . raiseHandler (runReader (lowerBound @Span))
-      runAddressEffects
+  $ evaluate lang graphingModuleInfo (evalTerm id) (ModuleTable.toPairs (packageModules package) >>= toList . snd)
-        = 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)))
 
 
-runHeap :: Effects effects => Evaluator term address value (State (Heap address value) ': effects) a -> Evaluator term address value effects (Heap address value, a)
+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 = runState lowerBound
+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 +217,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 (Error SomeException) sig
-                   , Member Distribute effs
+                   , Member Distribute sig
-                   , Member Resolution effs
+                   , Member Resolution sig
-                   , Member Trace effs
+                   , Member Trace sig
-                   , Member Task effs
+                   , Member Task sig
-                   , Effects effs)
+                   , Carrier sig m
+                   , Effect sig
+                   )
                    => Parser term      -- ^ A parser.
                    -> Project          -- ^ Project to parse into a package.
-                   -> Eff effs (Package term)
+                   -> Eff m (Package term)
 parsePythonPackage parser project = do
   let runAnalysis = runEvaluator @_ @_ @(Value term (Hole (Maybe Name) Precise))
-        . runState PythonPackage.Unknown
+        . raiseHandler (runState PythonPackage.Unknown)
-        . runState (lowerBound @(Heap (Hole (Maybe Name) Precise) (Value term (Hole (Maybe Name) Precise))))
+        . raiseHandler (runState (lowerBound @(Heap (Hole (Maybe Name) Precise) (Value term (Hole (Maybe Name) Precise)))))
-        . runFresh 0
+        . raiseHandler runFresh
         . resumingLoadError
         . resumingUnspecialized
         . resumingEnvironmentError
@@ -249,19 +251,16 @@ 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)
+        . raiseHandler (runReader (PackageInfo (name "setup") lowerBound))
-        . runState (lowerBound @Span)
+        . raiseHandler (runState (lowerBound @Span))
-        . runReader (lowerBound @Span)
+        . raiseHandler (runReader (lowerBound @Span))
-      runAddressEffects
-        = Hole.runAllocator Precise.handleAllocator
-        . Hole.runDeref Precise.handleDeref
 
   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 (runPythonPackaging . evalTerm id) [ setupModule ])
     Nothing -> pure PythonPackage.Unknown
   case strat of
     PythonPackage.Unknown -> do
@@ -289,53 +288,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
+withTermSpans :: ( Member (Reader Span) sig
-                 , Member (State Span) effects -- last evaluated child's span
+                 , 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
+resumingResolutionError :: ( Member Trace sig
-                           , Effects effects
+                           , Carrier sig m
                            )
-                         => Evaluator term address value (Resumable (BaseError ResolutionError) ': effects) a
+                         => Evaluator term address value (ResumableWithC (BaseError ResolutionError) (Eff
-                         -> Evaluator term address value effects a
+                                                         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
+                     , Carrier sig m
-                     , Member Trace effects
+                     , Member Trace sig
                      , Ord address
                      )
-                  => Evaluator term address value (Resumable (BaseError (LoadError address)) ': effects) a
+                  => Evaluator term address value (ResumableWithC (BaseError (LoadError address)) (Eff
-                  -> Evaluator term address value effects a
+                                                  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
+resumingEvalError :: ( Carrier sig m
-                     , Member Fresh effects
+                     , Member Fresh sig
-                     , Member Trace effects
+                     , Member Trace sig
                      )
-                  => Evaluator term address value (Resumable (BaseError EvalError) ': effects) a
+                  => Evaluator term address value (ResumableWithC (BaseError EvalError) (Eff
-                  -> Evaluator term address value effects a
+                                                  m)) a
+                  -> Evaluator term address value m a
 resumingEvalError = runEvalErrorWith (\ baseError -> traceError "EvalError" baseError *> case baseErrorException baseError of
   DefaultExportError{}  -> pure ()
   ExportError{}         -> pure ()
@@ -345,32 +348,35 @@ resumingEvalError = runEvalErrorWith (\ baseError -> traceError "EvalError" base
   NoNameError           -> gensym)
 
 resumingUnspecialized :: ( AbstractHole value
-                         , Effects effects
+                         , Carrier sig m
-                         , Member Trace effects
+                         , Member Trace sig
                          )
-                      => Evaluator term address value (Resumable (BaseError (UnspecializedError value)) ': effects) a
+                      => Evaluator term address value (ResumableWithC (BaseError (UnspecializedError value)) (Eff
-                      -> Evaluator term address value effects a
+                                                      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
+                        , Carrier sig m
-                        , Member Trace effects
+                        , Member Trace sig
                         , Show address
                         )
-                     => Evaluator term address value (Resumable (BaseError (AddressError address value)) ': effects) a
+                     => Evaluator term address value (ResumableWithC (BaseError (AddressError address value)) (Eff
-                     -> Evaluator term address value effects a
+                                                     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
+resumingValueError :: ( Carrier sig m
-                      , Member Trace effects
+                      , 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) (ResumableWithC (BaseError (ValueError term address)) (Eff
-                   -> Evaluator term address (Value term address) effects a
+                                                                  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 +393,23 @@ resumingValueError = runValueErrorWith (\ baseError -> traceError "ValueError" b
   ArrayError{}      -> pure lowerBound
   ArithmeticError{} -> pure hole)
 
-resumingEnvironmentError :: ( Effects effects
+resumingEnvironmentError :: ( Carrier sig m
-                            , Member Trace effects
+                            , 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 (ResumableWithC (BaseError (EnvironmentError (Hole (Maybe Name) address))) (Eff
-                         -> Evaluator term (Hole (Maybe Name) address) value effects a
+                                                                             m)) a
-resumingEnvironmentError = runResumableWith (\ baseError -> traceError "EnvironmentError" baseError >> (\ (FreeVariable name) -> pure (Partial (Just name))) (baseErrorException baseError))
+                         -> 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
+resumingTypeError :: ( Carrier sig m
-                     , Member NonDet effects
+                     , Member NonDet sig
-                     , Member Trace effects
+                     , Member Trace sig
+                     , Effect sig
                      )
-                  => Evaluator term address Type (Resumable (BaseError TypeError) ': State TypeMap ': effects) a
+                  => Evaluator term address Type (ResumableWithC (BaseError TypeError) (Eff
-                  -> Evaluator term address Type effects a
+                                                 (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 +417,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,11 +42,12 @@ 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 .
+type Render m output
-  ( ConstructorName syntax
+  = forall syntax
+  .  ( ConstructorName syntax
      , HasDeclaration syntax
      , HasPackageDef syntax
      , Foldable syntax
@@ -52,17 +55,19 @@ type Render effs output = forall syntax .
      , Show1 syntax
      , ToJSONFields1 syntax
      )
-  => Blob -> Term syntax Location -> Eff effs output
+  => Blob
+  -> Term syntax Location
+  -> m output
 
-withParsedBlobs :: (Member Distribute effs, Member (Exc SomeException) effs, Member Task effs, Monoid output)
+withParsedBlobs :: (Member Distribute sig, Member (Error SomeException) sig, Member Task sig, Monad m, Monoid output, Carrier sig m)
-  => Render effs output -> [Blob] -> Eff effs output
+  => 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)
+withParsedBlobs' :: (Member Distribute sig, Member (Error SomeException) sig, Member Task sig, Monad m, Monoid output, Carrier sig m)
-  => (Blob -> String -> output) -> Render effs output -> [Blob] -> Eff effs output
+  => (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,8 @@ 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.Analysis
 import Semantic.Config (logOptionsFromConfig)
 import Semantic.Distribute
 import Semantic.Graph
@@ -41,15 +45,16 @@ import System.Console.Haskeline
 import System.Directory (createDirectoryIfMissing, getHomeDirectory)
 import System.FilePath
 
-data REPL (m :: * -> *) result where
+data REPL (m :: * -> *) k
-  Prompt :: REPL m (Maybe String)
+  = Prompt (Maybe String -> k)
-  Output :: String -> REPL m ()
+  | Output String k
+  deriving (Functor)
 
-prompt :: (Effectful m, Member REPL effects) => m effects (Maybe String)
+prompt :: (Member REPL sig, Carrier sig m) => m (Maybe String)
-prompt = send Prompt
+prompt = send (Prompt ret)
 
-output :: (Effectful m, Member REPL effects) => String -> m effects ()
+output :: (Member REPL sig, Carrier sig m) => String -> m ()
-output s = send (Output s)
+output s = send (Output s (ret ()))
 
 
 data Quit = Quit
@@ -58,16 +63,24 @@ 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)
+  handle state handler (Prompt k) = Prompt (handler . (<$ state) . k)
-  handleState state handler (Request (Output s) k) = Request (Output s) (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 :: (MonadIO m, Carrier sig m) => Prefs -> Settings IO -> Eff (REPLC m) a -> m a
-runREPL prefs settings = interpret $ \case
+runREPL prefs settings = flip runREPLC (prefs, settings) . interpret
-  Prompt   -> liftIO (runInputTWithPrefs prefs settings (getInputLine (cyan <> "repl: " <> plain)))
+
-  Output s -> liftIO (runInputTWithPrefs prefs settings (outputStrLn s))
+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 -> handleSum (eff . handleReader args runREPLC) (\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) op)
 
 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)
+    . raiseHandler (runReader (packageInfo package))
-    . runState (lowerBound @Span)
+    . raiseHandler (runState (lowerBound @Span))
-    . runReader (lowerBound @Span)
+    . raiseHandler (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
+    $ evaluate proxy id (evalTerm (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 :: (Carrier sig m, MonadIO m) => LogOptions -> Eff (TelemetryIgnoringStatC m) a -> m a
-runTelemetryIgnoringStat logOptions = interpret $ \case
+runTelemetryIgnoringStat logOptions = flip runTelemetryIgnoringStatC logOptions . interpret
-  WriteStat{} -> pure ()
+
-  WriteLog level message pairs -> do
+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 -> handleSum (eff . handleReader logOptions runTelemetryIgnoringStatC) (\case
+    WriteStat _                  k -> runTelemetryIgnoringStatC k 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) op)
 
-step :: ( Member (Env address) effects
+step :: ( Member (Env address) sig
-        , Member (Exc SomeException) effects
+        , Member (Error SomeException) sig
-        , Member REPL effects
+        , Member REPL sig
-        , Member (Reader ModuleInfo) effects
+        , Member (Reader ModuleInfo) sig
-        , Member (Reader Span) effects
+        , Member (Reader Span) sig
-        , Member (Reader Step) effects
+        , Member (Reader Step) sig
-        , Member (State [Breakpoint]) effects
+        , 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

@@ -1,15 +1,19 @@
-{-# LANGUAGE ConstraintKinds, GADTs, KindSignatures, ScopedTypeVariables, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE ConstraintKinds, GADTs, KindSignatures, LambdaCase, ScopedTypeVariables, TypeOperators, UndecidableInstances #-}
 module Semantic.Resolution
   ( 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)
+  TypeScript -> send (NodeJSResolution projectRootDir "types" projectExcludeDirs ret)
-  JavaScript -> send (NodeJSResolution projectRootDir "main" projectExcludeDirs)
+  JavaScript -> send (NodeJSResolution projectRootDir "main"  projectExcludeDirs ret)
-  _          -> send NoResolution
+  _          -> send (NoResolution ret)
 
-data Resolution (m :: * -> *) output where
+data Resolution (m :: * -> *) k
-  NodeJSResolution :: FilePath -> Text -> [FilePath] -> Resolution m (Map FilePath FilePath)
+  = NodeJSResolution FilePath Text [FilePath] (Map FilePath FilePath -> k)
-  NoResolution     ::                                   Resolution m (Map FilePath FilePath)
+  | 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)
+  handle state handler (NodeJSResolution path key paths k) = NodeJSResolution path key paths (handler . (<$ state) . k)
-  handleState c dist (Request NoResolution k) = Request NoResolution (dist . (<$ c) . k)
+  handle state handler (NoResolution k) = NoResolution (handler . (<$ state) . k)
 
-runResolution :: (Member Files effs, PureEffects effs) => Eff (Resolution ': effs) a -> Eff effs a
+runResolution :: (Member Files sig, Carrier sig m, Monad m) => Eff (ResolutionC m) a -> m a
-runResolution = interpret $ \ res -> case res of
+runResolution = runResolutionC . interpret
-  NodeJSResolution dir prop excludeDirs -> nodeJSResolutionMap dir prop excludeDirs
+
-  NoResolution                          -> pure Map.empty
+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 . handleSum (eff . handleCoercible) (\case
+    NodeJSResolution dir prop excludeDirs k -> nodeJSResolutionMap dir prop excludeDirs >>= runResolutionC . k
+    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.IO.Class
-import           Control.Monad.Effect.Exception
-import           Control.Monad.Effect.Reader
-import           Control.Monad.Effect.Resource
-import           Control.Monad.Effect.Trace
 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
+type TaskEff
-                    , Resolution
+  = Eff (TaskC
-                    , Files.Files
+  ( Eff (ResolutionC
-                    , Reader Config
+  ( Eff (Files.FilesC
-                    , Trace
+  ( Eff (ReaderC Config
-                    , Telemetry
+  ( Eff (TraceInTelemetryC
-                    , Exc SomeException
+  ( Eff (TelemetryC
-                    , Timeout
+  ( Eff (ErrorC SomeException
-                    , Resource
+  ( Eff (TimeoutC
-                    , Distribute
+  ( Eff (ResourceC
-                    , Lift IO
+  ( 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 :: (Member Task sig, Carrier sig m)
-parse parser = send . Parse parser
+      => 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 :: (Member Task sig, Carrier sig m)
-analyze interpret analysis = send (Analyze interpret analysis)
+        => (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 :: (Functor f, Member Task sig, Carrier sig m)
-decorate algebra = send . Decorate algebra
+         => 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 :: (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax, Member Task sig, Carrier sig m)
-diff terms = send (Semantic.Task.Diff terms)
+     => 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 :: (Member Task sig, Carrier sig m)
-render renderer = send . Render renderer
+       => 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 :: (Member Task sig, Carrier sig m)
-serialize format = send . Serialize format
+          => 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,80 @@ 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 :: (Member Telemetry sig, Carrier sig m, Monad m)
-runTraceInTelemetry = interpret (\ (Trace str) -> writeLog Debug str [])
+                    => 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 . handleSum
+    (eff . handleCoercible)
+    (\ (Trace str k) -> writeLog Debug str [] >> runTraceInTelemetryC k)
 
 
 -- | An effect describing high-level tasks to be performed.
-data Task (m :: * -> *) output where
+data Task (m :: * -> *) k
-  Parse     :: Parser term -> Blob -> Task m term
+  = forall term . Parse (Parser term) Blob (term -> k)
-  Analyze   :: (Analysis.Evaluator term address value effects a -> result) -> Analysis.Evaluator term address value effects a -> Task m result
+  | 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)
-  Decorate  :: Functor f => RAlgebra (TermF f Location) (Term f Location) field -> Term f Location -> Task m (Term f field)
+  | forall f field . Functor f => Decorate (RAlgebra (TermF f Location) (Term f Location) field) (Term f Location) (Term f field -> k)
-  Diff      :: (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax) => These (Term syntax ann) (Term syntax ann) -> Task m (Diff syntax ann ann)
+  | forall syntax ann . (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax) => Diff (These (Term syntax ann) (Term syntax ann)) (Diff syntax ann ann -> k)
-  Render    :: Renderer input output -> input -> Task m output
+  | forall input output . Render (Renderer input output) input (output -> k)
-  Serialize :: Format input -> input -> Task m Builder
+  | 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)
+  handle state handler (Parse parser blob k) = Parse parser blob (handler . (<$ state) . k)
-  handleState c dist (Request (Analyze run analysis) k) = Request (Analyze run analysis) (dist . (<$ c) . k)
+  handle state handler (Analyze run analysis k) = Analyze run analysis (handler . (<$ state) . k)
-  handleState c dist (Request (Decorate decorator term) k) = Request (Decorate decorator term) (dist . (<$ c) . k)
+  handle state handler (Decorate decorator term k) = Decorate decorator term (handler . (<$ state) . k)
-  handleState c dist (Request (Semantic.Task.Diff terms) k) = Request (Semantic.Task.Diff terms) (dist . (<$ c) . k)
+  handle state handler (Semantic.Task.Diff terms k) = Semantic.Task.Diff terms (handler . (<$ state) . k)
-  handleState c dist (Request (Render renderer input) k) = Request (Render renderer input) (dist . (<$ c) . k)
+  handle state handler (Render renderer input k) = Render renderer input (handler . (<$ state) . k)
-  handleState c dist (Request (Serialize format input) k) = Request (Serialize format input) (dist . (<$ c) . 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 :: ( Member (Error SomeException) sig
-runTaskF = interpret $ \ task -> case task of
+            , Member (Lift IO) sig
-  Parse parser blob -> runParser blob parser
+            , Member (Reader Config) sig
-  Analyze interpret analysis -> pure (interpret analysis)
+            , Member Resource sig
-  Decorate algebra term -> pure (decoratorWithAlgebra algebra term)
+            , Member Telemetry sig
-  Semantic.Task.Diff terms -> pure (diffTermPair terms)
+            , Member Timeout sig
-  Render renderer input -> pure (renderer input)
+            , Member Trace sig
-  Serialize format input -> do
+            , 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 . handleSum (eff . handleCoercible) (\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)
-    pure (runSerialize formatStyle format input)
+      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 +279,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 +306,20 @@ runParser blob@Blob{..} parser = case parser of
         runAssignment :: ( Apply Foldable syntaxes
                          , Apply Functor syntaxes
                          , Element Syntax.Error syntaxes
-                         , Member (Exc SomeException) effs
+                         , Member (Error SomeException) sig
-                         , Member (Lift IO) effs
+                         , Member (Lift IO) sig
-                         , Member (Reader Config) effs
+                         , Member (Reader Config) sig
-                         , Member Telemetry effs
+                         , Member Resource sig
-                         , Member Timeout effs
+                         , Member Telemetry sig
-                         , Member Trace effs
+                         , Member Timeout sig
-                         , Member Resource effs
+                         , Member Trace sig
-                         , PureEffects effs
+                         , 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.Effect
-import           Control.Monad.Effect.Exception
+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,71 @@ 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
+data Files (m :: * -> *) k
-  Read        :: Source out                                           -> Files m out
+  = forall a . Read (Source a)                                (a -> k)
-  ReadProject :: Maybe FilePath -> FilePath -> Language -> [FilePath] -> Files m Project
+  | ReadProject (Maybe FilePath) FilePath Language [FilePath] (Project -> k)
-  FindFiles   :: FilePath -> [String] -> [FilePath]                   -> Files m [FilePath]
+  | FindFiles FilePath [String] [FilePath]                    ([FilePath] -> k)
-  Write       :: Destination -> B.Builder                             -> Files m ()
+  | 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)
+  handle state handler (Read source k) = Read source (handler . (<$ state) . k)
-  handleState c dist (Request (ReadProject rootDir dir language excludeDirs) k) = Request (ReadProject rootDir dir language excludeDirs) (dist . (<$ c) . k)
+  handle state handler (ReadProject rootDir dir language excludeDirs k) = ReadProject rootDir dir language excludeDirs (handler . (<$ state) . k)
-  handleState c dist (Request (FindFiles dir exts paths) k) = Request (FindFiles dir exts paths) (dist . (<$ c) . k)
+  handle state handler (FindFiles dir exts paths k) = FindFiles dir exts paths (handler . (<$ state) . k)
-  handleState c dist (Request (Write destination builder) k) = Request (Write destination builder) (dist . (<$ c) . 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 :: (Member (Error SomeException) sig, MonadIO m, Carrier sig m) => Eff (FilesC m) a -> m a
-runFiles = interpret $ \ files -> case files of
+runFiles = runFilesC . interpret
-  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)
 
-readBlob :: Member Files effs => File -> Eff effs Blob
+newtype FilesC m a = FilesC { runFilesC :: m a }
-readBlob = send . Read . FromPath
+
+instance (Member (Error SomeException) sig, MonadIO m, Carrier sig m) => Carrier (Files :+: sig) (FilesC m) where
+  ret = FilesC . ret
+  eff = FilesC . handleSum (eff . handleCoercible) (\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 :: (Member Files sig, Carrier sig m, Applicative m) => Either (Handle 'IO.ReadMode) [File] -> m [Blob]
-readBlobs (Left handle) = send (Read (FromHandle handle))
+readBlobs (Left handle) = send (Read (FromHandle handle) ret)
-readBlobs (Right paths) = traverse (send . Read . FromPath) paths
+readBlobs (Right paths) = traverse (send . flip Read ret . FromPath) paths
 
 -- | A task which reads a list of pairs of 'Blob's from a 'Handle' or a list of pairs of 'FilePath's optionally paired with 'Language's.
-readBlobPairs :: Member Files effs => Either (Handle 'IO.ReadMode) [Both File] -> Eff effs [BlobPair]
+readBlobPairs :: (Member Files sig, Carrier sig m, Applicative m) => Either (Handle 'IO.ReadMode) [Both File] -> m [BlobPair]
-readBlobPairs (Left handle) = send (Read (FromPairHandle handle))
+readBlobPairs (Left handle) = send (Read (FromPairHandle handle) ret)
-readBlobPairs (Right paths) = traverse (send . Read . FromPathPair) paths
+readBlobPairs (Right paths) = traverse (send . flip Read ret . FromPathPair) paths
 
-readProject :: Member Files effs => Maybe FilePath -> FilePath -> Language -> [FilePath] -> Eff effs Project
+readProject :: (Member Files sig, Carrier sig m) => Maybe FilePath -> FilePath -> Language -> [FilePath] -> m Project
-readProject rootDir dir excludeDirs = send . ReadProject rootDir dir excludeDirs
+readProject rootDir dir lang excludeDirs = send (ReadProject rootDir dir lang excludeDirs ret)
 
-findFiles :: Member Files effs => FilePath -> [String] -> [FilePath] -> Eff effs [FilePath]
+findFiles :: (Member Files sig, Carrier sig m) => FilePath -> [String] -> [FilePath] -> m [FilePath]
-findFiles dir exts = send . FindFiles dir exts
+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 :: (Member Files sig, Carrier sig m) => Destination -> B.Builder -> m ()
-write dest = send . Write dest
+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

@@ -1,4 +1,4 @@
-{-# LANGUAGE GADTs, KindSignatures, RankNTypes, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE GADTs, KindSignatures, LambdaCase, RankNTypes, TypeOperators, UndecidableInstances #-}
 module Semantic.Telemetry
 (
   -- Async telemetry interface
@@ -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 :: (Member Telemetry sig, Carrier sig m) => Level -> String -> [(String, String)] -> m ()
-writeLog level message pairs = send (WriteLog level message pairs)
+writeLog level message pairs = send (WriteLog level message pairs (ret ()))
 
 -- | A task which writes a stat.
-writeStat :: Member Telemetry effs => Stat -> Eff effs ()
+writeStat :: (Member Telemetry sig, Carrier sig m) => Stat -> m ()
-writeStat stat = send (WriteStat stat)
+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
+data Telemetry (m :: * -> *) k
-  WriteStat :: Stat                                  -> Telemetry m ()
+  = WriteStat Stat k
-  WriteLog  :: Level -> String -> [(String, String)] -> Telemetry m ()
+  | 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)
+  handle state handler (WriteStat stat k) = WriteStat stat (handler (k <$ state))
-  handleState c dist (Request (WriteLog level message pairs) k) = Request (WriteLog level message pairs) (dist . (<$ c) . k)
+  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 :: (Carrier sig m, MonadIO m) => LogQueue -> StatQueue -> Eff (TelemetryC m) a -> m a
-runTelemetry logger statter = interpret (\ t -> case t of
+runTelemetry logger statter = flip runTelemetryC (logger, statter) . interpret
-  WriteStat stat -> queueStat statter stat
+
-  WriteLog level message pairs -> queueLogMessage logger level message pairs)
+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 -> handleSum (eff . handleReader queues runTelemetryC) (\case
+    WriteStat stat               k -> queueStat (snd queues) stat *> runTelemetryC k queues
+    WriteLog level message pairs k -> queueLogMessage (fst queues) level message pairs *> runTelemetryC k queues) op)
+
 
 -- | Run a 'Telemetry' effect by ignoring statting/logging.
-ignoreTelemetry :: PureEffects effs => Eff (Telemetry ': effs) a -> Eff effs a
+ignoreTelemetry :: Carrier sig m => Eff (IgnoreTelemetryC m) a -> m a
-ignoreTelemetry = interpret (\ t -> case t of
+ignoreTelemetry = runIgnoreTelemetryC . interpret
-  WriteStat{} -> pure ()
+
-  WriteLog{}  -> pure ())
+newtype IgnoreTelemetryC m a = IgnoreTelemetryC { runIgnoreTelemetryC :: m a }
+
+instance Carrier sig m => Carrier (Telemetry :+: sig) (IgnoreTelemetryC m) where
+  ret = IgnoreTelemetryC . ret
+  eff = handleSum (IgnoreTelemetryC . eff . handlePure runIgnoreTelemetryC) (\case
+    WriteStat _    k -> k
+    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,36 @@ 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 :: (Member Timeout sig, Carrier sig m) => Duration -> m output -> m (Maybe output)
-timeout n = send . Timeout n
+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
+data Timeout m k
-   Timeout :: Duration -> task output -> Timeout task (Maybe output)
+  = 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)
+runTimeout :: (Carrier sig m, MonadIO m)
-  => (forall x . Eff effects x -> IO x)
+           => (forall x . m x -> IO x)
-  -> Eff (Timeout ': effects) a
+           -> Eff (TimeoutC m) a
-  -> Eff effects a
+           -> m a
-runTimeout handler = interpret (\ (Timeout n task) -> liftIO (System.timeout (toMicroseconds n) (handler (runTimeout handler task))))
+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 -> handleSum
+    (eff . handlePure (runTimeoutC handler))
+    (\ (Timeout n task k) -> liftIO (System.timeout (toMicroseconds n) (handler (runTimeoutC handler task))) >>= runTimeoutC handler . k) 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,8 @@ import           Data.Project hiding (readFile)
 import           Data.Quieterm (quieterm)
 import           Data.Sum (weaken)
 import           Parsing.Parser
-import           Prologue hiding (weaken)
+import           Prologue
+import           Semantic.Analysis
 import           Semantic.Config
 import           Semantic.Graph
 import           Semantic.Task
@@ -36,9 +37,10 @@ import           System.FilePath.Posix (takeDirectory)
 
 justEvaluating
   = runM
-  . runPrintingTrace
+  . runEvaluator
+  . raiseHandler runTraceByPrinting
   . runHeap
-  . runFresh 0
+  . raiseHandler runFresh
   . fmap reassociate
   . runLoadError
   . runUnspecialized
@@ -49,10 +51,11 @@ justEvaluating
   . runValueError
 
 checking
-  = runM @_ @IO
+  = runM
-  . runPrintingTrace
+  . runEvaluator
-  . runState (lowerBound @(Heap Monovariant Type))
+  . raiseHandler runTraceByPrinting
-  . runFresh 0
+  . runHeap
+  . raiseHandler runFresh
   . caching
   . providingLiveSet
   . fmap reassociate
@@ -97,12 +100,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)
+       (raiseHandler (runReader (packageInfo package))
-       (runState (lowerBound @Span)
+       (raiseHandler (runState (lowerBound @Span))
-       (runReader (lowerBound @Span)
+       (raiseHandler (runReader (lowerBound @Span))
-       (evaluate proxy id withTermSpans (Precise.runAllocator . Precise.runDeref) (fmap (Concrete.runBoolean . Concrete.runWhile) . Concrete.runFunction) modules)))))))
+       (evaluate proxy id (evalTerm withTermSpans) modules)))))))
 
 evaluatePythonProjects proxy parser lang path = runTaskWithOptions debugOptions $ do
   project <- readProject Nothing path lang []
@@ -110,24 +113,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)
+       (raiseHandler (runReader (packageInfo package))
-       (runState (lowerBound @Span)
+       (raiseHandler (runState (lowerBound @Span))
-       (runReader (lowerBound @Span)
+       (raiseHandler (runReader (lowerBound @Span))
-       (evaluate proxy id withTermSpans (Precise.runAllocator . Precise.runDeref) (fmap (Concrete.runBoolean . Concrete.runWhile) . Concrete.runFunction) modules)))))))
+       (evaluate proxy id (evalTerm 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)
+  pure (id @(Evaluator _ Monovariant _ _ _)
-       (runState (lowerBound @Span)
+       (raiseHandler (runReader (packageInfo package))
-       (runReader (lowerBound @Span)
+       (raiseHandler (runState (lowerBound @Span))
-       (runReader (lowerBound @(ModuleTable (NonEmpty (Module (ModuleResult Monovariant)))))
+       (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 (evalTerm withTermSpans) modules)))))))
 
 
 parseFile :: Parser term -> FilePath -> IO term
@@ -136,10 +140,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
+mergeErrors :: Either (SomeError (Sum errs)) (Either (SomeError err) result) -> Either (SomeError (Sum (err ': errs))) result
-mergeExcs = either (\ (SomeExc sum) -> Left (SomeExc (weaken sum))) (either (\ (SomeExc exc) -> Left (SomeExc (inject exc))) Right)
+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 :: 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 = mergeExcs . mergeExcs . mergeExcs . mergeExcs . mergeExcs . mergeExcs . mergeExcs . Right
+reassociate = mergeErrors . mergeErrors . mergeErrors . mergeErrors . mergeErrors . mergeErrors . mergeErrors . Right
 
 {-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}

src/Semantic/Util/Rewriting.hs

@@ -9,7 +9,7 @@ import           Control.Category
 import qualified Data.ByteString.Char8 as BC
 import           Text.Show.Pretty (pPrint)
 
-import           Control.Abstract.Matching
+import           Control.Matching
 import           Control.Rewriting hiding (fromMatcher, target)
 import           Data.Blob
 import           Data.File

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
+  . runDeref @Val
-  . Precise.runAllocator
+  . runAllocator
   . (>>= deref . snd)
   . runEnv lowerBound
   . runReturn
   . runLoopControl
-  . Value.runBoolean
+  . runBoolean
-  . Value.runFunction coerce
+  . runFunction runSpecEff
 
-reassociate :: Either (SomeExc exc1) (Either (SomeExc exc2) (Either (SomeExc exc3) result)) -> Either (SomeExc (Sum '[exc3, exc2, exc1])) result
+reassociate :: Either (SomeError exc1) (Either (SomeError exc2) (Either (SomeError exc3) result)) -> Either (SomeError (Sum '[exc3, exc2, exc1])) result
-reassociate = mergeExcs . mergeExcs . mergeExcs . Right
+reassociate = mergeErrors . mergeErrors . mergeErrors . Right
 
 type Val = Value SpecEff Precise
 newtype SpecEff = SpecEff
-  { runSpecEff :: Eff '[ Function SpecEff Precise Val
+  { runSpecEff :: Evaluator SpecEff Precise Val (FunctionC SpecEff Precise Val
-                       , Boolean Val
+                 (Eff (BooleanC Val
-                       , Exc (LoopControl Precise)
+                 (Eff (ErrorC (LoopControl Precise)
-                       , Exc (Return Precise)
+                 (Eff (ErrorC (Return Precise)
-                       , Env Precise
+                 (Eff (EnvC Precise
-                       , Allocator Precise
+                 (Eff (AllocatorC Precise
-                       , Deref Val
+                 (Eff (DerefC Precise Val
-                       , Resumable (BaseError (AddressError Precise Val))
+                 (Eff (ResumableC (BaseError (AddressError Precise Val))
-                       , Resumable (BaseError (EnvironmentError Precise))
+                 (Eff (ResumableC (BaseError (EnvironmentError Precise))
-                       , Resumable (BaseError (ValueError SpecEff Precise))
+                 (Eff (ResumableC (BaseError (ValueError SpecEff Precise))
-                       , Reader Span
+                 (Eff (ReaderC Span
-                       , Reader ModuleInfo
+                 (Eff (ReaderC ModuleInfo
-                       , Reader PackageInfo
+                 (Eff (ReaderC PackageInfo
-                       , Fresh
+                 (Eff (FreshC
-                       , State (Heap Precise Val)
+                 (Eff (StateC (Heap Precise Val)
-                       , Trace
+                 (Eff (TraceByIgnoringC
-                       , Lift IO
+                 (Eff (LiftC IO)))))))))))))))))))))))))))))))))
-                       ] Precise
+                 Precise
   }
 
 instance Eq SpecEff where _ == _ = True

test/Control/Rewriting/Spec.hs

@@ -8,7 +8,7 @@ import qualified Data.ByteString as B
 import           Data.Either
 import           Data.Text (Text)
 
-import           Control.Abstract.Matching as Matching
+import           Control.Matching as Matching
 import           Control.Rewriting as Rewriting
 import           Data.History as History
 import qualified Data.Source as Source

test/Examples.hs

@@ -2,8 +2,7 @@ module Main (main) where
 
 import           Control.Exception (displayException)
 import           Control.Monad
-import           Control.Monad.Effect
+import           Control.Effect
-import           Control.Monad.Effect.Exception
 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/Matching/Go/Spec.hs

@@ -2,7 +2,7 @@
 
 module Matching.Go.Spec (spec) where
 
-import           Control.Abstract.Matching
+import           Control.Matching
 import           Data.Abstract.Module
 import           Data.List
 import           Data.Sum

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 Distribute sig
-                  , Member Task effs
+                  , 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
+type TestEvaluatingC term
-  = '[ Resumable (BaseError (ValueError term Precise))
+  = ResumableC (BaseError (ValueError term Precise)) (Eff
-     , Resumable (BaseError (AddressError Precise (Val term)))
+  ( ResumableC (BaseError (AddressError Precise (Val term))) (Eff
-     , Resumable (BaseError ResolutionError)
+  ( ResumableC (BaseError ResolutionError) (Eff
-     , Resumable (BaseError EvalError)
+  ( ResumableC (BaseError EvalError) (Eff
-     , Resumable (BaseError (EnvironmentError Precise))
+  ( ResumableC (BaseError (EnvironmentError Precise)) (Eff
-     , Resumable (BaseError (UnspecializedError (Val term)))
+  ( ResumableC (BaseError (UnspecializedError (Val term))) (Eff
-     , Resumable (BaseError (LoadError Precise))
+  ( ResumableC (BaseError (LoadError Precise)) (Eff
-     , Fresh
+  ( FreshC (Eff
-     , State (Heap Precise (Val term))
+  ( StateC (Heap Precise (Val term)) (Eff
-     , Trace
+  ( TraceByReturningC (Eff
-     , Lift IO
+  ( 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)))
+                   , Either (SomeError (Data.Sum.Sum (TestEvaluatingErrors term))) a
-                            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
+  . raiseHandler (runState heap)
-  . runState (lowerBound @Span)
+  . raiseHandler (runState (lowerBound @Span))
-  . runReader (lowerBound @Span)
+  . raiseHandler (runReader (lowerBound @Span))
-  . runReader (ModuleInfo "SpecHelper.hs")
+  . raiseHandler (runReader (ModuleInfo "SpecHelper.hs"))
   . runDeref
   $ materializeEnvironment ns
 

vendor/effects

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

vendor/fused-effects

@@ -0,0 +1 @@
+Subproject commit 5f11d009d486b4e7e1741d0d031f8818818856ea