Merge branch 'master' into scope-graph-indexer

.licenses/semantic/cabal/basement.txt

@@ -1,7 +1,7 @@
 ---
 type: cabal
 name: basement
-version: 0.0.8
+version: 0.0.10
 summary: Foundation scrap box of array & string
 homepage: https://github.com/haskell-foundation/foundation
 license: bsd-3-clause

.licenses/semantic/cabal/cereal.txt

@@ -1,7 +1,7 @@
 ---
 type: cabal
 name: cereal
-version: 0.5.7.0
+version: 0.5.8.0
 summary: A binary serialization library
 homepage: https://github.com/GaloisInc/cereal
 license: bsd-3-clause

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

@@ -1,7 +1,7 @@
 ---
 type: cabal
 name: fused-effects
-version: 0.1.2.1
+version: 0.2.0.1
 summary: A fast, flexible, fused effect system.
 homepage: https://github.com/robrix/fused-effects
 license: bsd-3-clause
@@ -34,4 +34,4 @@ 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.
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

.licenses/semantic/cabal/haskeline.txt

@@ -1,7 +1,7 @@
 ---
 type: cabal
 name: haskeline
-version: 0.7.4.3
+version: 0.7.5.0
 summary: A command-line interface for user input, written in Haskell.
 homepage: https://github.com/judah/haskeline
 license: bsd-2-clause

.licenses/semantic/cabal/parser-combinators.txt

@@ -1,7 +1,7 @@
 ---
 type: cabal
 name: parser-combinators
-version: 1.0.0
+version: 1.0.1
 summary: Lightweight package providing commonly useful parser combinators
 homepage: https://github.com/mrkkrp/parser-combinators
 license: bsd-3-clause

.licenses/semantic/cabal/recursion-schemes.txt

@@ -1,7 +1,7 @@
 ---
 type: cabal
 name: recursion-schemes
-version: '5.1'
+version: 5.1.1
 summary: Generalized bananas, lenses and barbed wire
 homepage: https://github.com/ekmett/recursion-schemes/
 license: bsd-2-clause

.licenses/semantic/cabal/semigroupoids.txt

@@ -1,7 +1,7 @@
 ---
 type: cabal
 name: semigroupoids
-version: 5.3.1
+version: 5.3.2
 summary: 'Semigroupoids: Category sans id'
 homepage: https://github.com/ekmett/semigroupoids
 license: bsd-2-clause

.licenses/semantic/cabal/swagger2.txt

@@ -1,7 +1,7 @@
 ---
 type: cabal
 name: swagger2
-version: 2.3.1
+version: 2.3.1.1
 summary: Swagger 2.0 data model
 homepage: https://github.com/GetShopTV/swagger2
 license: bsd-3-clause

.licenses/semantic/cabal/these.txt

@@ -1,7 +1,7 @@
 ---
 type: cabal
 name: these
-version: 0.7.5
+version: 0.7.6
 summary: An either-or-both data type & a generalized 'zip with padding' typeclass
 homepage: https://github.com/isomorphism/these
 license: bsd-3-clause

.licenses/semantic/cabal/vector-builder.txt

@@ -1,7 +1,7 @@
 ---
 type: cabal
 name: vector-builder
-version: 0.3.6
+version: 0.3.7.2
 summary: Vector builder
 homepage: https://github.com/nikita-volkov/vector-builder
 license: mit

semantic.cabal

@@ -239,7 +239,7 @@ library
                      -- API
                      , Semantic.Api
                      , Semantic.Api.Diffs
-                     , Semantic.Api.Helpers
+                     , Semantic.Api.Bridge
                      , Semantic.Api.LegacyTypes
                      , Semantic.Api.Symbols
                      , Semantic.Api.Terms

src/Analysis/Abstract/Caching/FlowInsensitive.hs

@@ -54,14 +54,14 @@ 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 NonDet sig
+cachingTerms :: ( Member (Reader (Cache term address value)) sig
-                , Member (Reader (Cache term address value)) sig
                 , Member (Reader (Live address)) sig
                 , Member (State (Cache term address value)) sig
                 , Carrier sig m
                 , Ord address
                 , Ord term
                 , Ord value
+                , Alternative m
                 )
              => Open (term -> Evaluator term address value m value)
 cachingTerms recur term = do
@@ -75,7 +75,6 @@ cachingTerms recur term = do
 
 convergingModules :: ( Eq value
                      , Member Fresh sig
-                     , Member NonDet sig
                      , Member (Reader (Cache term address value)) sig
                      , Member (Reader (Live address)) sig
                      , Member (State (Cache term address value)) sig
@@ -83,9 +82,9 @@ convergingModules :: ( Eq value
                      , Ord address
                      , Ord term
                      , Carrier sig m
-                     , Effect sig
+                     , Alternative m
                      )
-                  => (Module (Either prelude term) -> Evaluator term address value (AltC Maybe (Eff m)) value)
+                  => (Module (Either prelude term) -> Evaluator term address value (NonDetC m) value)
                   -> (Module (Either prelude term) -> Evaluator term address value m value)
 convergingModules recur m@(Module _ (Left _)) = raiseHandler runNonDet (recur m) >>= maybeM empty
 convergingModules recur m@(Module _ (Right term)) = do
@@ -100,7 +99,7 @@ convergingModules recur m@(Module _ (Right term)) = do
     -- 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 (raiseHandler runNonDet (recur m)))
+      withOracle prevCache (raiseHandler (runNonDet @Maybe) (recur m)))
   maybe empty scatter (cacheLookup c cache)
 
 -- | Iterate a monadic action starting from some initial seed until the results converge.
@@ -119,7 +118,7 @@ converge seed f = loop seed
             loop x'
 
 -- | Nondeterministically write each of a collection of stores & return their associated results.
-scatter :: (Foldable t, Member NonDet sig, Carrier sig m) => t value -> Evaluator term address value m value
+scatter :: (Foldable t, Carrier sig m, Alternative m) => t value -> Evaluator term address value m value
 scatter = foldMapA pure
 
 -- | Get the current 'Configuration' with a passed-in term.
@@ -129,16 +128,16 @@ getConfiguration :: (Member (Reader (Live address)) sig, Carrier sig m)
 getConfiguration term = Configuration term <$> askRoots
 
 
-caching :: (Carrier sig m, Effect sig)
+caching :: Carrier sig m
-        => Evaluator term address value (AltC B (Eff
+        => Evaluator term address value (NonDetC
-                                        (ReaderC (Cache term address value) (Eff
+                                        (ReaderC (Cache term address value)
-                                        (StateC (Cache term address value) (Eff
+                                        (StateC (Cache term address value)
-                                        m)))))) a
+                                        m))) a
         -> Evaluator term address value m (Cache term address value, [a])
 caching
   = raiseHandler (runState  lowerBound)
   . raiseHandler (runReader lowerBound)
-  . fmap toList
+  . fmap (toList @B)
   . raiseHandler runNonDet
 
 data B a = E | L a | B (B a) (B a)

src/Analysis/Abstract/Caching/FlowSensitive.hs

@@ -56,12 +56,12 @@ 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 sig
                 , Member (Reader (Cache term address value)) sig
                 , Member (Reader (Live address)) sig
                 , Member (State (Cache term address value)) sig
                 , Member (State (Heap address address value)) sig
                 , Carrier sig m
+                , Alternative m
                 )
              => Open (term -> Evaluator term address value m value)
 cachingTerms recur term = do
@@ -75,15 +75,14 @@ cachingTerms recur term = do
 
 convergingModules :: ( Cacheable term address value
                      , Member Fresh sig
-                     , Member NonDet sig
                      , Member (Reader (Cache term address value)) sig
                      , Member (Reader (Live address)) sig
                      , Member (State (Cache term address value)) sig
                      , Member (State (Heap address address value)) sig
                      , Carrier sig m
-                     , Effect sig
+                     , Alternative m
                      )
-                  => (Module (Either prelude term) -> Evaluator term address value (AltC Maybe (Eff m)) value)
+                  => (Module (Either prelude term) -> Evaluator term address value (NonDetC m) value)
                   -> (Module (Either prelude term) -> Evaluator term address value m value)
 convergingModules recur m@(Module _ (Left _)) = raiseHandler runNonDet (recur m) >>= maybeM empty
 convergingModules recur m@(Module _ (Right term)) = do
@@ -98,7 +97,7 @@ convergingModules recur m@(Module _ (Right term)) = do
     -- 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 (raiseHandler runNonDet (recur m)))
+      withOracle prevCache (raiseHandler (runNonDet @Maybe) (recur m)))
   maybe empty scatter (cacheLookup c cache)
 
 -- | Iterate a monadic action starting from some initial seed until the results converge.
@@ -117,7 +116,7 @@ converge seed f = loop seed
             loop x'
 
 -- | Nondeterministically write each of a collection of stores & return their associated results.
-scatter :: (Foldable t, Member NonDet sig, Member (State (Heap address address value)) sig, Carrier sig m) => t (Cached address value) -> Evaluator term address value m value
+scatter :: (Foldable t, Member (State (Heap address address value)) sig, Alternative m, Carrier sig m) => t (Cached address value) -> Evaluator term address value m value
 scatter = foldMapA (\ (Cached value heap') -> putHeap heap' $> value)
 
 -- | Get the current 'Configuration' with a passed-in term.
@@ -127,11 +126,11 @@ getConfiguration :: (Member (Reader (Live address)) sig, Member (State (Heap add
 getConfiguration term = Configuration term <$> askRoots <*> getHeap
 
 
-caching :: (Carrier sig m, Effect sig)
+caching :: Monad m
-        => Evaluator term address value (AltC [] (Eff
+        => Evaluator term address value ( NonDetC
-                                        (ReaderC (Cache term address value) (Eff
+                                        (ReaderC (Cache term address value)
-                                        (StateC (Cache term address value) (Eff
+                                        (StateC (Cache term address value)
-                                        m)))))) a
+                                        m))) a
         -> Evaluator term address value m (Cache term address value, [a])
 caching
   = raiseHandler (runState  lowerBound)

src/Analysis/Abstract/Collecting.hs

@@ -5,5 +5,5 @@ module Analysis.Abstract.Collecting
 import Control.Abstract
 import Prologue
 
-providingLiveSet :: Carrier sig m => Evaluator term address value (ReaderC (Live address) (Eff m)) a -> Evaluator term address value m a
+providingLiveSet :: Evaluator term address value (ReaderC (Live address) m) a -> Evaluator term address value m a
 providingLiveSet = raiseHandler (runReader lowerBound)

src/Analysis/Abstract/Dead.hs

@@ -32,20 +32,21 @@ subterms term = term `cons` para (foldMap (uncurry cons)) term
 
 
 revivingTerms :: ( Member (State (Dead term)) sig
-                 , Ord term
+                , Ord term
-                 , Carrier sig m
+                , Carrier sig m
-                 )
+                )
               => Open (term -> Evaluator term address value m a)
 revivingTerms recur term = revive term *> recur term
 
 killingModules :: ( Foldable (Base term)
-                  , Member (State (Dead term)) sig
+                 , Member (State (Dead term)) sig
-                  , Ord term
+                 , Ord term
-                  , Recursive term
+                 , Recursive term
-                  , Carrier sig m
+                 , Carrier sig m
-                  )
+                 )
                => Open (Module term -> Evaluator term address value m a)
 killingModules recur m = killAll (subterms (moduleBody m)) *> recur m
 
-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 :: Evaluator term address value (StateC (Dead term) (Evaluator term address value m)) a
+                 -> Evaluator term address value m (Dead term, a)
 providingDeadSet = runState lowerBound . runEvaluator

src/Analysis/Abstract/Graph.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE LambdaCase, RankNTypes, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE DerivingVia, LambdaCase, RankNTypes, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
 module Analysis.Abstract.Graph
 ( Graph(..)
 , ControlFlowVertex(..)
@@ -106,20 +106,18 @@ graphingPackages :: ( Member (Reader PackageInfo) sig
                     , Member (State (Graph ControlFlowVertex)) sig
                     , Member (Reader ControlFlowVertex) sig
                     , Carrier sig m
-                    , Monad m
                     )
                  => 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 :: ( Member (Modules address value) sig
+graphingModules :: ( Member (Reader ModuleInfo) sig
-                   , Member (Reader ModuleInfo) sig
                    , Member (State (Graph ControlFlowVertex)) sig
                    , Member (Reader ControlFlowVertex) sig
                    , Carrier sig m
                    )
-                => (Module body -> Evaluator term address value (EavesdropC address value (Eff m)) a)
+                => (Module body -> Evaluator term address value (EavesdropC address value m) a)
                 -> (Module body -> Evaluator term address value m a)
 graphingModules recur m = do
   let v = moduleVertex (moduleInfo m)
@@ -135,12 +133,11 @@ graphingModules recur m = do
       in moduleInclusion (moduleVertex (ModuleInfo path'))
 
 -- | Add vertices to the graph for imported modules.
-graphingModuleInfo :: ( Member (Modules address value) sig
+graphingModuleInfo :: ( Member (Reader ModuleInfo) sig
-                      , Member (Reader ModuleInfo) sig
                       , Member (State (Graph ModuleInfo)) sig
                       , Carrier sig m
                       )
-                   => (Module body -> Evaluator term address value (EavesdropC address value (Eff m)) a)
+                   => (Module body -> Evaluator term address value (EavesdropC address value m) a)
                    -> (Module body -> Evaluator term address value m a)
 graphingModuleInfo recur m = do
   appendGraph (vertex (moduleInfo m))
@@ -149,19 +146,18 @@ graphingModuleInfo recur m = do
     Lookup path _ -> currentModule >>= appendGraph . (`connect` vertex (ModuleInfo path)) . vertex
     _             -> pure ()
 
-eavesdrop :: (Carrier sig m, Member (Modules address value) sig)
+eavesdrop :: Evaluator term address value (EavesdropC address value m) a
-          => Evaluator term address value (EavesdropC address value (Eff m)) a
+          -> (forall x . Modules address value m (m x) -> Evaluator term address value m ())
-          -> (forall x . Modules address value (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
+eavesdrop m f = raiseHandler (runEavesdropC (runEvaluator . f)) m
 
 newtype EavesdropC address value m a = EavesdropC ((forall x . Modules address value m (m x) -> m ()) -> m a)
+  deriving (Alternative, Applicative, Functor, Monad) via (ReaderC (forall x . Modules address value m (m x) -> m ()) m)
 
 runEavesdropC :: (forall x . Modules address value m (m x) -> m ()) -> EavesdropC address value m a -> m a
 runEavesdropC f (EavesdropC m) = m f
 
 instance (Carrier sig m, Member (Modules address value) sig, Applicative m) => Carrier sig (EavesdropC address value 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))
@@ -170,7 +166,6 @@ instance (Carrier sig m, Member (Modules address value) sig, Applicative m) => C
 packageInclusion :: ( Member (Reader PackageInfo) sig
                     , Member (State (Graph ControlFlowVertex)) sig
                     , Carrier sig m
-                    , Monad m
                     )
                  => ControlFlowVertex
                  -> m ()
@@ -182,7 +177,6 @@ packageInclusion v = do
 moduleInclusion :: ( Member (Reader ModuleInfo) sig
                    , Member (State (Graph ControlFlowVertex)) sig
                    , Carrier sig m
-                   , Monad m
                    )
                 => ControlFlowVertex
                 -> m ()
@@ -194,7 +188,6 @@ moduleInclusion v = do
 variableDefinition :: ( Member (State (Graph ControlFlowVertex)) sig
                       , Member (Reader ControlFlowVertex) sig
                       , Carrier sig m
-                      , Monad m
                       )
                    => ControlFlowVertex
                    -> m ()
@@ -202,13 +195,13 @@ variableDefinition var = do
   context <- ask
   appendGraph (vertex context `connect` vertex var)
 
-appendGraph :: (Member (State (Graph v)) sig, Carrier sig m, Monad m) => Graph v -> m ()
+appendGraph :: (Member (State (Graph v)) sig, Carrier sig m) => Graph v -> m ()
 appendGraph = modify . (<>)
 
 
-graphing :: (Carrier sig m, Effect sig)
+graphing :: Carrier sig m
-         => Evaluator term address value (StateC (Map (Slot address) ControlFlowVertex) (Eff
+         => Evaluator term address value (StateC (Map (Slot address) ControlFlowVertex)
-                                         (StateC (Graph ControlFlowVertex) (Eff
+                                         (StateC (Graph ControlFlowVertex)
-                                         m)))) result
+                                         m)) result
          -> Evaluator term address value m (Graph ControlFlowVertex, result)
 graphing = raiseHandler $ runState mempty . fmap snd . runState lowerBound

src/Analysis/Abstract/Tracing.hs

@@ -12,18 +12,24 @@ import Data.Semigroup.Reducer as Reducer
 --
 --   Instantiating @trace@ to @[]@ yields a linear trace analysis, while @Set@ yields a reachable state analysis.
 tracingTerms :: ( Member (State (Heap address address value)) sig
-                , Member (Writer (trace (Configuration term address value))) sig
+               , Member (Writer (trace (Configuration term address value))) sig
-                , Carrier sig m
+               , Carrier sig m
-                , Reducer (Configuration term address value) (trace (Configuration term address value))
+               , Reducer (Configuration term address value) (trace (Configuration term address value))
-                )
+               )
              => trace (Configuration term address value)
              -> Open (term -> Evaluator term address value m a)
 tracingTerms proxy recur term = getConfiguration term >>= trace . (`asTypeOf` proxy) . Reducer.unit >> recur term
 
-trace :: (Member (Writer (trace (Configuration term address value))) sig, Carrier sig m) => trace (Configuration term address value) -> Evaluator term address value m ()
+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)), 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 :: (Monoid (trace (Configuration term address value)))
+        => Evaluator term address value (WriterC (trace (Configuration term address value)) (Evaluator term address value m)) a
+        -> Evaluator term address value m (trace (Configuration term address value), a)
 tracing = runWriter . runEvaluator
 
 

src/Control/Abstract/Context.hs

@@ -45,7 +45,7 @@ currentSpan = ask
 withCurrentSpan :: (Member (Reader Span) sig, Carrier sig m) => Span -> m a -> m a
 withCurrentSpan = local . const
 
-modifyChildSpan :: (Member (State Span) sig, Carrier sig m, Monad m) => Span -> m a -> m a
+modifyChildSpan :: (Member (State Span) sig, Carrier sig m) => Span -> m a -> m a
 modifyChildSpan span m = m <* put span
 
 -- | Run an action with locally-replaced 'ModuleInfo' & 'Span' derived from the passed 'SrcLoc'.

src/Control/Abstract/Evaluator.hs

@@ -29,24 +29,19 @@ import Control.Effect.Trace as X
 import Control.Monad.IO.Class
 import Data.Coerce
 
--- | An 'Evaluator' is a thin wrapper around 'Eff' with (phantom) type parameters for the address, term, and value types.
+-- | An 'Evaluator' is a thin wrapper around a monad 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 m a = Evaluator { runEvaluator :: Eff m a }
+newtype Evaluator term address value m a = Evaluator { runEvaluator :: m a }
-  deriving (Applicative, Functor, Monad)
+  deriving (Alternative, Applicative, Functor, Monad, MonadIO)
-
-deriving instance (Member NonDet sig, Carrier sig m) => Alternative (Evaluator term address value m)
-deriving instance (Member (Lift IO) sig, Carrier sig m) => MonadIO (Evaluator term address value m)
 
 instance Carrier sig m => Carrier sig (Evaluator term address value m) where
-  ret = Evaluator . ret
+  eff = Evaluator . eff . handleCoercible
-  eff = Evaluator . eff . handlePure runEvaluator
 
-
+-- | Raise a handler on monads into a handler on 'Evaluator's over those monads.
--- | Raise a handler on 'Eff's into a handler on 'Evaluator's.
+raiseHandler :: (m a -> n b)
-raiseHandler :: (Eff m a -> Eff n b)
              -> Evaluator term address value m a
              -> Evaluator term address value n b
 raiseHandler = coerce
@@ -69,10 +64,14 @@ earlyReturn :: ( Member (Error (Return value)) sig
             -> Evaluator term address value m value
 earlyReturn = throwError . Return
 
-catchReturn :: (Member (Error (Return value)) sig, Carrier sig m) => Evaluator term address value m value -> Evaluator term address value m value
+catchReturn :: (Member (Error (Return value)) sig, Carrier sig m)
+            => Evaluator term address value m value
+            -> Evaluator term address value m value
 catchReturn = flip catchError (\ (Return value) -> pure value)
 
-runReturn :: (Carrier sig m, Effect sig) => Evaluator term address value (ErrorC (Return value) (Eff m)) value -> Evaluator term address value m value
+runReturn :: Carrier sig m
+          => Evaluator term address value (ErrorC (Return value) m) value
+          -> Evaluator term address value m value
 runReturn = raiseHandler $ fmap (either unReturn id) . runError
 
 
@@ -105,7 +104,7 @@ catchLoopControl :: ( Member (Error (LoopControl value)) sig
                  -> Evaluator term address value m a
 catchLoopControl = catchError
 
-runLoopControl :: (Carrier sig m, Effect sig)
+runLoopControl :: Carrier sig m
-               => Evaluator term address value (ErrorC (LoopControl value) (Eff m)) value
+               => Evaluator term address value (ErrorC (LoopControl value) m) value
                -> Evaluator term address value m value
 runLoopControl = raiseHandler $ fmap (either unLoopControl id) . runError

src/Control/Abstract/Heap.hs

@@ -222,7 +222,7 @@ deref :: ( Member (Deref value) sig
 deref slot@Slot{..} = do
   maybeSlotValue <- gets (Heap.getSlotValue slot)
   slotValue <- maybeM (throwAddressError (UnallocatedSlot slot)) maybeSlotValue
-  eff <- send $ DerefCell slotValue ret
+  eff <- send $ DerefCell slotValue pure
   maybeM (throwAddressError $ UninitializedSlot slot) eff
 
 putSlotDeclarationScope :: ( Member (State (Heap address address value)) sig
@@ -375,7 +375,7 @@ assign :: ( Member (Deref value) sig
        -> Evaluator term address value m ()
 assign addr value = do
   heap <- getHeap
-  cell <- send (AssignCell value (fromMaybe lowerBound (Heap.getSlotValue addr heap)) ret)
+  cell <- send (AssignCell value (fromMaybe lowerBound (Heap.getSlotValue addr heap)) pure)
   putHeap (Heap.setSlot addr cell heap)
 
 dealloc :: ( Carrier sig m
@@ -431,10 +431,9 @@ instance Effect (Deref value) where
   handle state handler (DerefCell        cell k) = DerefCell        cell (handler . (<$ state) . k)
   handle state handler (AssignCell value cell k) = AssignCell value cell (handler . (<$ state) . k)
 
-runDeref :: Carrier (Deref value :+: sig) (DerefC address value (Eff m))
+runDeref :: Evaluator term address value (DerefC address value m) a
-         => Evaluator term address value (DerefC address value (Eff m)) a
          -> Evaluator term address value m a
-runDeref = raiseHandler $ runDerefC . interpret
+runDeref = raiseHandler runDerefC
 
 newtype DerefC address value m a = DerefC { runDerefC :: m a }
   deriving (Alternative, Applicative, Functor, Monad)
@@ -481,14 +480,12 @@ throwHeapError  :: ( Member (Resumable (BaseError (HeapError address))) sig
                 -> Evaluator term address value m resume
 throwHeapError = throwBaseError
 
-runHeapError :: (Carrier sig m, Effect sig)
+runHeapError :: Evaluator term address value (ResumableC (BaseError (HeapError address)) m) a
-                => Evaluator term address value (ResumableC (BaseError (HeapError address)) (Eff m)) a
+             -> Evaluator term address value m (Either (SomeError (BaseError (HeapError address))) a)
-                -> Evaluator term address value m (Either (SomeError (BaseError (HeapError address))) a)
 runHeapError = raiseHandler runResumable
 
-runHeapErrorWith :: Carrier sig m
+runHeapErrorWith :: (forall resume. (BaseError (HeapError address)) resume -> Evaluator term address value m resume)
-                 => (forall resume. (BaseError (HeapError address)) resume -> Evaluator term address value m resume)
+                 -> Evaluator term address value (ResumableWithC (BaseError (HeapError address)) m) a
-                 -> Evaluator term address value (ResumableWithC (BaseError (HeapError address)) (Eff m)) a
                  -> Evaluator term address value m a
 runHeapErrorWith f = raiseHandler $ runResumableWith (runEvaluator . f)
 
@@ -522,13 +519,11 @@ throwAddressError :: ( Member (Resumable (BaseError (AddressError address body))
                   -> Evaluator term address value m resume
 throwAddressError = throwBaseError
 
-runAddressError :: (Carrier sig m, Effect sig)
+runAddressError :: Evaluator term address value (ResumableC (BaseError (AddressError address value)) m) a
-                => Evaluator term address value (ResumableC (BaseError (AddressError address value)) (Eff m)) a
                 -> Evaluator term address value m (Either (SomeError (BaseError (AddressError address value))) a)
 runAddressError = raiseHandler runResumable
 
-runAddressErrorWith :: Carrier sig m
+runAddressErrorWith :: (forall resume . (BaseError (AddressError address value)) resume -> Evaluator term address value m resume)
-                    => (forall resume . (BaseError (AddressError address value)) resume -> Evaluator term address value m resume)
+                    -> Evaluator term address value (ResumableWithC (BaseError (AddressError address value)) m) a
-                    -> Evaluator term address value (ResumableWithC (BaseError (AddressError address value)) (Eff m)) a
                     -> Evaluator term address value m a
 runAddressErrorWith f = raiseHandler $ runResumableWith (runEvaluator . f)

src/Control/Abstract/Modules.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE GADTs, LambdaCase, KindSignatures, RankNTypes, ScopedTypeVariables, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, KindSignatures, RankNTypes, ScopedTypeVariables, TypeOperators, UndecidableInstances #-}
 module Control.Abstract.Modules
 ( ModuleResult
 , lookupModule
@@ -36,14 +36,14 @@ type ModuleResult address value = ((address, address), value)
 
 -- | 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 value) sig, Carrier sig m) => ModulePath -> Evaluator term address value m (Maybe (ModuleResult address value))
-lookupModule = sendModules . flip Lookup ret
+lookupModule = sendModules . flip Lookup pure
 
 -- | Resolve a list of module paths to a possible module table entry.
 resolve :: (Member (Modules address value) sig, Carrier sig m) => [FilePath] -> Evaluator term address value m (Maybe ModulePath)
-resolve = sendModules . flip Resolve ret
+resolve = sendModules . flip Resolve pure
 
 listModulesInDir :: (Member (Modules address value) sig, Carrier sig m) => FilePath -> Evaluator term address value m [ModulePath]
-listModulesInDir = sendModules . flip List ret
+listModulesInDir = sendModules . flip List pure
 
 
 -- | Require/import another module by name and return its environment and value.
@@ -56,7 +56,7 @@ require path = lookupModule path >>= maybeM (load path)
 --
 -- Always loads/evaluates.
 load :: (Member (Modules address value) sig, Carrier sig m) => ModulePath -> Evaluator term address value m (ModuleResult address value)
-load path = sendModules (Load path ret)
+load path = sendModules (Load path pure)
 
 
 data Modules address value (m :: * -> *) k
@@ -82,29 +82,27 @@ sendModules :: ( Member (Modules address value) sig
             -> Evaluator term address value m return
 sendModules = send
 
-runModules :: ( Member (Reader (ModuleTable (Module (ModuleResult address value)))) sig
+runModules :: Set ModulePath
-              , Member (Resumable (BaseError (LoadError address value))) sig
+           -> Evaluator term address value (ModulesC address value m) a
-              , Carrier sig m
-              )
-           => Set ModulePath
-           -> Evaluator term address value (ModulesC address value (Eff m)) a
            -> Evaluator term address value m a
-runModules paths = raiseHandler $ flip runModulesC paths . interpret
+runModules paths = raiseHandler (runReader paths . runModulesC)
 
-newtype ModulesC address value m a = ModulesC { runModulesC :: Set ModulePath -> m a }
+newtype ModulesC address value m a = ModulesC { runModulesC :: ReaderC (Set ModulePath) m a }
+  deriving (Alternative, Applicative, Functor, Monad, MonadIO)
 
 instance ( Member (Reader (ModuleTable (Module (ModuleResult address value)))) sig
          , Member (Resumable (BaseError (LoadError address value))) sig
          , Carrier sig m
-         , Monad m
          )
       => Carrier (Modules address value :+: sig) (ModulesC address value m) where
-  ret = ModulesC . const . ret
+  eff (L op) = do
-  eff op = ModulesC (\ paths -> handleSum (eff . handleReader paths runModulesC) (\case
+    paths <- ModulesC ask
-    Load    name  k -> askModuleTable >>= maybeM (throwLoadError (ModuleNotFoundError name)) . fmap moduleBody . ModuleTable.lookup name >>= flip runModulesC paths . k
+    case op of
-    Lookup  path  k -> askModuleTable >>= flip runModulesC paths . k . fmap moduleBody . ModuleTable.lookup path
+      Load    name  k -> askModuleTable >>= maybeM (throwLoadError (ModuleNotFoundError name)) . fmap moduleBody . ModuleTable.lookup name >>= k
-    Resolve names k -> runModulesC (k (find (`Set.member` paths) names)) paths
+      Lookup  path  k -> askModuleTable >>= k . fmap moduleBody . ModuleTable.lookup path
-    List    dir   k -> runModulesC (k (filter ((dir ==) . takeDirectory) (toList paths))) paths) op)
+      Resolve names k -> k (find (`Set.member` paths) names)
+      List    dir   k -> k (filter ((dir ==) . takeDirectory) (toList paths))
+  eff (R other) = ModulesC (eff (R (handleCoercible other)))
 
 askModuleTable :: (Member (Reader (ModuleTable (Module (ModuleResult address value)))) sig, Carrier sig m) => m (ModuleTable (Module (ModuleResult address value)))
 askModuleTable = ask
@@ -124,14 +122,12 @@ instance Eq1 (LoadError address value) where
 instance NFData1 (LoadError address value) where
   liftRnf _ (ModuleNotFoundError p) = rnf p
 
-runLoadError :: (Carrier sig m, Effect sig)
+runLoadError :: Evaluator term address value (ResumableC (BaseError (LoadError address value)) m) a
-             => Evaluator term address value (ResumableC (BaseError (LoadError address value)) (Eff m)) a
              -> Evaluator term address value m (Either (SomeError (BaseError (LoadError address value))) a)
 runLoadError = raiseHandler runResumable
 
-runLoadErrorWith :: Carrier sig m
+runLoadErrorWith :: (forall resume . (BaseError (LoadError address value)) resume -> Evaluator term address value m resume)
-                 => (forall resume . (BaseError (LoadError address value)) resume -> Evaluator term address value m resume)
+                 -> Evaluator term address value (ResumableWithC (BaseError (LoadError address value)) m) a
-                 -> Evaluator term address value (ResumableWithC (BaseError (LoadError address value)) (Eff m)) a
                  -> Evaluator term address value m a
 runLoadErrorWith f = raiseHandler $ runResumableWith (runEvaluator . f)
 
@@ -162,14 +158,12 @@ instance NFData1 ResolutionError where
     NotFoundError p ps l -> rnf p `seq` rnf ps `seq` rnf l
     GoImportError p      -> rnf p
 
-runResolutionError :: (Carrier sig m, Effect sig)
+runResolutionError :: Evaluator term address value (ResumableC (BaseError ResolutionError) m) a
-                   => Evaluator term address value (ResumableC (BaseError ResolutionError) (Eff m)) a
                    -> Evaluator term address value m (Either (SomeError (BaseError ResolutionError)) a)
 runResolutionError = raiseHandler runResumable
 
-runResolutionErrorWith :: Carrier sig m
+runResolutionErrorWith :: (forall resume . (BaseError ResolutionError) resume -> Evaluator term address value m resume)
-                       => (forall resume . (BaseError ResolutionError) resume -> Evaluator term address value m resume)
+                       -> Evaluator term address value (ResumableWithC (BaseError ResolutionError) m) a
-                       -> Evaluator term address value (ResumableWithC (BaseError ResolutionError) (Eff m)) a
                        -> Evaluator term address value m a
 runResolutionErrorWith f = raiseHandler $ runResumableWith (runEvaluator . f)
 

src/Control/Abstract/PythonPackage.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving, UndecidableInstances #-}
 module Control.Abstract.PythonPackage
 ( runPythonPackaging, Strategy(..) ) where
 
@@ -14,19 +14,15 @@ import           Prologue
 data Strategy = Unknown | Packages [Text] | FindPackages [Text]
   deriving (Show, Eq)
 
-runPythonPackaging :: ( Carrier sig m
+runPythonPackaging :: Evaluator term address (Value term address) (PythonPackagingC term address m) a
-                      , Member (Abstract.String (Value term address)) sig
-                      , Member (Abstract.Array (Value term address)) sig
-                      , Member (State Strategy) sig
-                      , Member (Function term address (Value term address)) sig)
-                   => Evaluator term address (Value term address) (PythonPackagingC term address (Eff m)) a
                    -> Evaluator term address (Value term address) m a
-runPythonPackaging = raiseHandler (runPythonPackagingC . interpret)
+runPythonPackaging = raiseHandler runPythonPackagingC
 
 
 newtype PythonPackagingC term address m a = PythonPackagingC { runPythonPackagingC :: m a }
+  deriving (Applicative, Functor, Monad)
 
-wrap :: Evaluator term address (Value term address) m a -> PythonPackagingC term address (Eff m) a
+wrap :: Evaluator term address (Value term address) m a -> PythonPackagingC term address m a
 wrap = PythonPackagingC . runEvaluator
 
 instance ( Carrier sig m
@@ -35,8 +31,7 @@ instance ( Carrier sig m
          , Member (Abstract.String (Value term address)) sig
          , Member (Abstract.Array (Value term address)) sig
          )
-      => Carrier sig (PythonPackagingC term address (Eff m)) where
+      => Carrier sig (PythonPackagingC term address m) where
-  ret = PythonPackagingC . ret
   eff op
     | Just e <- prj op = wrap $ case handleCoercible e of
       Call callName params k -> Evaluator . k =<< do
@@ -61,4 +56,4 @@ instance ( Carrier sig m
       Function name params body scope k -> function name params body scope >>= Evaluator . k
       BuiltIn n b k -> builtIn n b >>= Evaluator . k
       Bind obj value k -> bindThis obj value >>= Evaluator . k
-    | otherwise        = PythonPackagingC (eff (handleCoercible op))
+    | otherwise = PythonPackagingC . eff $ handleCoercible op

src/Control/Abstract/ScopeGraph.hs

@@ -355,7 +355,7 @@ instance NFData return => NFData (ScopeError address return) where
   rnf = liftRnf rnf
 
 alloc :: (Member (Allocator address) sig, Carrier sig m) => Name -> Evaluator term address value m address
-alloc = send . flip Alloc ret
+alloc = send . flip Alloc pure
 
 data Allocator address (m :: * -> *) k
   = Alloc Name (address -> k)
@@ -367,22 +367,18 @@ instance HFunctor (Allocator address) where
 instance Effect (Allocator address) where
   handle state handler (Alloc name k) = Alloc name (handler . (<$ state) . k)
 
-runAllocator :: Carrier (Allocator address :+: sig) (AllocatorC address (Eff m))
+runAllocator :: Evaluator term address value (AllocatorC address m) a
-             => Evaluator term address value (AllocatorC address (Eff m)) a
              -> Evaluator term address value m a
-runAllocator = raiseHandler $ runAllocatorC . interpret
+runAllocator = raiseHandler runAllocatorC
 
 newtype AllocatorC address m a = AllocatorC { runAllocatorC :: m a }
   deriving (Alternative, Applicative, Functor, Monad)
 
-
+runScopeErrorWith :: (forall resume . BaseError (ScopeError address) resume -> Evaluator term address value m resume)
-runScopeErrorWith :: Carrier sig m
+                  -> Evaluator term address value (ResumableWithC (BaseError (ScopeError address)) m) a
-                  => (forall resume . BaseError (ScopeError address) resume -> Evaluator term address value m resume)
-                  -> Evaluator term address value (ResumableWithC (BaseError (ScopeError address)) (Eff m)) a
                   -> Evaluator term address value m a
 runScopeErrorWith f = raiseHandler $ runResumableWith (runEvaluator . f)
 
-runScopeError :: (Carrier sig m, Effect sig)
+runScopeError :: Evaluator term address value (ResumableC (BaseError (ScopeError address)) m) a
-              => Evaluator term address value (ResumableC (BaseError (ScopeError address)) (Eff m)) a
               -> Evaluator term address value m (Either (SomeError (BaseError (ScopeError address))) a)
 runScopeError = raiseHandler runResumable

src/Control/Abstract/Value.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE DeriveAnyClass, GADTs, KindSignatures, LambdaCase, Rank2Types, ScopedTypeVariables, TypeOperators #-}
+{-# LANGUAGE DeriveAnyClass, DerivingStrategies, GADTs, GeneralizedNewtypeDeriving, KindSignatures, LambdaCase, Rank2Types, ScopedTypeVariables, TypeOperators #-}
 module Control.Abstract.Value
 ( AbstractValue(..)
 , AbstractIntro(..)
@@ -105,7 +105,7 @@ data Comparator
 -- In the concrete domain, introductions & eliminations respectively construct & pattern match against values, while in abstract domains they respectively construct & project finite sets of discrete observations of abstract values. For example, an abstract domain modelling integers as a sign (-, 0, or +) would introduce abstract values by mapping integers to their sign and eliminate them by mapping signs back to some canonical integer, e.g. - -> -1, 0 -> 0, + -> 1.
 
 function :: (Member (Function term address value) sig, Carrier sig m) => Name -> [Name] -> term -> address -> Evaluator term address value m value
-function name params body scope = sendFunction (Function name params body scope ret)
+function name params body scope = sendFunction (Function name params body scope pure)
 
 data BuiltIn
   = Print
@@ -113,16 +113,16 @@ data BuiltIn
   deriving (Eq, Ord, Show, Generic, NFData)
 
 builtIn :: (Member (Function term address value) sig, Carrier sig m) => address -> BuiltIn -> Evaluator term address value m value
-builtIn address = sendFunction . flip (BuiltIn address) ret
+builtIn address = sendFunction . flip (BuiltIn address) pure
 
 call :: (Member (Function term address value) sig, Carrier sig m) => value -> [value] -> Evaluator term address value m value
-call fn args = sendFunction (Call fn args ret)
+call fn args = sendFunction (Call fn args pure)
 
 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
 
 bindThis :: (Member (Function term address value) sig, Carrier sig m) => value -> value -> Evaluator term address value m value
-bindThis this that = sendFunction (Bind this that ret)
+bindThis this that = sendFunction (Bind this that pure)
 
 data Function term address value (m :: * -> *) k
   = Function Name [Name] term address (value -> k) -- ^ A function is parameterized by its name, parameter names, body, parent scope, and returns a ValueRef.
@@ -138,25 +138,24 @@ instance Effect (Function term address value) where
   handle state handler = coerce . fmap (handler . (<$ state))
 
 
-runFunction :: Carrier (Function term address value :+: sig) (FunctionC term address value (Eff m))
+runFunction :: (term -> Evaluator term address value (FunctionC term address value m) value)
-            => (term -> Evaluator term address value (FunctionC term address value (Eff m)) value)
+            -> Evaluator term address value (FunctionC term address value m) a
-            -> 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)
+runFunction eval = raiseHandler (runReader (runEvaluator . eval) . runFunctionC)
-
-newtype FunctionC term address value m a = FunctionC { runFunctionC :: (term -> Eff (FunctionC term address value m) value) -> m a }
 
+newtype FunctionC term address value m a = FunctionC { runFunctionC :: ReaderC (term -> FunctionC term address value m value) m a }
+  deriving newtype (Alternative, Applicative, Functor, Monad)
 
 -- | Construct a boolean value in the abstract domain.
 boolean :: (Member (Boolean value) sig, Carrier sig m) => Bool -> m value
-boolean = send . flip Boolean ret
+boolean = send . flip Boolean pure
 
 -- | Extract a 'Bool' from a given value.
 asBool :: (Member (Boolean value) sig, Carrier sig m) => value -> m Bool
-asBool = send . flip AsBool ret
+asBool = send . flip AsBool pure
 
 -- | Eliminate boolean values. TODO: s/boolean/truthy
-ifthenelse :: (Member (Boolean value) sig, Carrier sig m, Monad m) => value -> m a -> m a -> m a
+ifthenelse :: (Member (Boolean value) sig, Carrier sig m) => value -> m a -> m a -> m a
 ifthenelse v t e = asBool v >>= \ c -> if c then t else e
 
 data Boolean value (m :: * -> *) k
@@ -173,12 +172,13 @@ instance Effect (Boolean value) where
     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))
+runBoolean :: Evaluator term address value (BooleanC value m) a
-           => Evaluator term address value (BooleanC value (Eff m)) a
            -> Evaluator term address value m a
-runBoolean = raiseHandler $ runBooleanC . interpret
+runBoolean = raiseHandler runBooleanC
 
 newtype BooleanC value m a = BooleanC { runBooleanC :: m a }
+  deriving stock Functor
+  deriving newtype (Alternative, Applicative, Monad)
 
 
 -- | The fundamental looping primitive, built on top of 'ifthenelse'.
@@ -186,7 +186,7 @@ while :: (Member (While value) sig, Carrier sig m)
       => Evaluator term address value m value -- ^ Condition
       -> Evaluator term address value m value -- ^ Body
       -> Evaluator term address value m value
-while cond body = send (While cond body ret)
+while cond body = send (While cond body pure)
 
 -- | Do-while loop, built on top of while.
 doWhile :: (Member (While value) sig, Carrier sig m)
@@ -223,21 +223,21 @@ data While value m k
 instance HFunctor (While value) where
   hmap f (While cond body k) = While (f cond) (f body) k
 
-runWhile :: Carrier (While value :+: sig) (WhileC value (Eff m))
+runWhile :: Evaluator term address value (WhileC value m) a
-         => Evaluator term address value (WhileC value (Eff m)) a
          -> Evaluator term address value m a
-runWhile = raiseHandler $ runWhileC . interpret
+runWhile = raiseHandler runWhileC
 
 newtype WhileC value m a = WhileC { runWhileC :: m a }
-
+  deriving stock Functor
+  deriving newtype (Alternative, Applicative, Monad)
 
 -- | Construct an abstract unit value.
 unit :: (Carrier sig m, Member (Unit value) sig) => Evaluator term address value m value
-unit = send (Unit ret)
+unit = send (Unit pure)
 
 newtype Unit value (m :: * -> *) k
   = Unit (value -> k)
-  deriving (Functor)
+  deriving stock Functor
 
 instance HFunctor (Unit value) where
   hmap _ = coerce
@@ -246,21 +246,21 @@ instance HFunctor (Unit value) where
 instance Effect (Unit value) where
   handle state handler (Unit k) = Unit (handler . (<$ state) . k)
 
-runUnit :: Carrier (Unit value :+: sig) (UnitC value (Eff m))
+runUnit :: Evaluator term address value (UnitC value m) a
-        => Evaluator term address value (UnitC value (Eff m)) a
         -> Evaluator term address value m a
-runUnit = raiseHandler $ runUnitC . interpret
+runUnit = raiseHandler runUnitC
 
 newtype UnitC value m a = UnitC { runUnitC :: m a }
-
+  deriving stock Functor
+  deriving newtype (Alternative, Applicative, Monad)
 
 -- | Construct a String value in the abstract domain.
 string :: (Member (String value) sig, Carrier sig m) => Text -> m value
-string t = send (String t ret)
+string t = send (String t pure)
 
 -- | Extract 'Text' from a given value.
 asString :: (Member (String value) sig, Carrier sig m) => value -> m Text
-asString v = send (AsString v ret)
+asString v = send (AsString v pure)
 
 data String value (m :: * -> *) k
   = String Text (value -> k)
@@ -276,31 +276,32 @@ instance Effect (String value) where
   handle state handler (AsString v k) = AsString v (handler . (<$ state) . k)
 
 newtype StringC value m a = StringC { runStringC :: m a }
+  deriving stock Functor
+  deriving newtype (Alternative, Applicative, Monad)
 
-runString :: Carrier (String value :+: sig) (StringC value (Eff m))
+runString :: Evaluator term address value (StringC value m) a
-          => Evaluator term address value (StringC value (Eff m)) a
           -> Evaluator term address value m a
-runString = raiseHandler $ runStringC . interpret
+runString = raiseHandler runStringC
 
 
 -- | Construct an abstract integral value.
 integer :: (Member (Numeric value) sig, Carrier sig m) => Integer -> m value
-integer t = send (Integer t ret)
+integer t = send (Integer t pure)
 
 -- | Construct a floating-point value.
 float :: (Member (Numeric value) sig, Carrier sig m) => Scientific -> m value
-float t = send (Float t ret)
+float t = send (Float t pure)
 
 -- | Construct a rational value.
 rational :: (Member (Numeric value) sig, Carrier sig m) => Rational -> m value
-rational t = send (Rational t ret)
+rational t = send (Rational t pure)
 
 -- | Lift a unary operator over a 'Num' to a function on 'value's.
 liftNumeric  :: (Member (Numeric value) sig, Carrier sig m)
              => (forall a . Num a => a -> a)
              -> value
              -> m value
-liftNumeric t v = send (LiftNumeric t v ret)
+liftNumeric t v = send (LiftNumeric t v pure)
 
 -- | 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
@@ -311,7 +312,7 @@ liftNumeric2 :: (Member (Numeric value) sig, Carrier sig m)
              -> value
              -> value
              -> m value
-liftNumeric2 t v1 v2 = send (LiftNumeric2 t v1 v2 ret)
+liftNumeric2 t v1 v2 = send (LiftNumeric2 t v1 v2 pure)
 
 data Numeric value (m :: * -> *) k
   = Integer Integer (value -> k)
@@ -329,23 +330,24 @@ instance Effect (Numeric value) where
   handle state handler = coerce . fmap (handler . (<$ state))
 
 newtype NumericC value m a = NumericC { runNumericC :: m a }
+  deriving stock Functor
+  deriving newtype (Alternative, Applicative, Monad)
 
-runNumeric :: Carrier (Numeric value :+: sig) (NumericC value (Eff m))
+runNumeric :: Evaluator term address value (NumericC value m) a
-           => Evaluator term address value (NumericC value (Eff m)) a
            -> Evaluator term address value m a
-runNumeric = raiseHandler $ runNumericC . interpret
+runNumeric = raiseHandler runNumericC
 
 
 -- | Cast numbers to integers
 castToInteger :: (Member (Bitwise value) sig, Carrier sig m) => value -> m value
-castToInteger t = send (CastToInteger t ret)
+castToInteger t = send (CastToInteger t pure)
 
 -- | Lift a unary bitwise operator to values. This is usually 'complement'.
 liftBitwise :: (Member (Bitwise value) sig, Carrier sig m)
             => (forall a . Bits a => a -> a)
             -> value
             -> m value
-liftBitwise t v = send (LiftBitwise t v ret)
+liftBitwise t v = send (LiftBitwise t v pure)
 
 -- | Lift a binary bitwise operator to values. The Integral constraint is
 --   necessary to satisfy implementation details of Haskell left/right shift,
@@ -355,13 +357,13 @@ liftBitwise2 :: (Member (Bitwise value) sig, Carrier sig m)
              -> value
              -> value
              -> m value
-liftBitwise2 t v1 v2 = send (LiftBitwise2 t v1 v2 ret)
+liftBitwise2 t v1 v2 = send (LiftBitwise2 t v1 v2 pure)
 
 unsignedRShift :: (Member (Bitwise value) sig, Carrier sig m)
                => value
                -> value
                -> m value
-unsignedRShift v1 v2 = send (UnsignedRShift v1 v2 ret)
+unsignedRShift v1 v2 = send (UnsignedRShift v1 v2 pure)
 
 data Bitwise value (m :: * -> *) k
   = CastToInteger value (value -> k)
@@ -377,26 +379,26 @@ instance HFunctor (Bitwise value) where
 instance Effect (Bitwise value) where
   handle state handler = coerce . fmap (handler . (<$ state))
 
-runBitwise :: Carrier (Bitwise value :+: sig) (BitwiseC value (Eff m))
+runBitwise :: Evaluator term address value (BitwiseC value m) a
-           => Evaluator term address value (BitwiseC value (Eff m)) a
            -> Evaluator term address value m a
-runBitwise = raiseHandler $ runBitwiseC . interpret
+runBitwise = raiseHandler runBitwiseC
 
 newtype BitwiseC value m a = BitwiseC { runBitwiseC :: m a }
-
+  deriving stock Functor
+  deriving newtype (Alternative, Applicative, Monad)
 
 object :: (Member (Object address value) sig, Carrier sig m) => address -> m value
-object address = send (Object address ret)
+object address = send (Object address pure)
 
 -- | Extract the environment from any scoped object (e.g. classes, namespaces, etc).
 scopedEnvironment :: (Member (Object address value) sig, Carrier sig m) => value -> m (Maybe address)
-scopedEnvironment value = send (ScopedEnvironment value ret)
+scopedEnvironment value = send (ScopedEnvironment value pure)
 
 -- | Build a class value from a name and environment.
 -- declaration is the new class's identifier
 -- address is the environment to capture
 klass :: (Member (Object address value) sig, Carrier sig m) => Declaration -> address -> m value
-klass d a = send (Klass d a ret)
+klass d a = send (Klass d a pure)
 
 data Object address value (m :: * -> *) k
   = Object address (value -> k)
@@ -412,18 +414,19 @@ instance Effect (Object address value) where
     handle state handler = coerce . fmap (handler . (<$ state))
 
 newtype ObjectC address value m a = ObjectC { runObjectC :: m a }
+  deriving stock Functor
+  deriving newtype (Alternative, Applicative, Monad)
 
-runObject :: Carrier (Object address value :+: sig) (ObjectC address value (Eff m))
+runObject :: Evaluator term address value (ObjectC address value m) a
-           => Evaluator term address value (ObjectC address value (Eff m)) a
+          -> Evaluator term address value m a
-           -> Evaluator term address value m a
+runObject = raiseHandler runObjectC
-runObject = raiseHandler $ runObjectC . interpret
 
 -- | Construct an array of zero or more values.
 array :: (Member (Array value) sig, Carrier sig m) => [value] -> m value
-array v = send (Array v ret)
+array v = send (Array v pure)
 
 asArray :: (Member (Array value) sig, Carrier sig m) => value -> m [value]
-asArray v = send (AsArray v ret)
+asArray v = send (AsArray v pure)
 
 data Array value (m :: * -> *) k
   = Array [value] (value -> k)
@@ -438,19 +441,20 @@ instance Effect (Array value) where
     handle state handler = coerce . fmap (handler . (<$ state))
 
 newtype ArrayC value m a = ArrayC { runArrayC :: m a }
+  deriving stock Functor
+  deriving newtype (Alternative, Applicative, Monad)
 
-runArray :: Carrier (Array value :+: sig) (ArrayC value (Eff m))
+runArray :: Evaluator term address value (ArrayC value m) a
-           => Evaluator term address value (ArrayC value (Eff m)) a
+         -> Evaluator term address value m a
-           -> Evaluator term address value m a
+runArray = raiseHandler runArrayC
-runArray = raiseHandler $ runArrayC . interpret
 
 -- | Construct a hash out of pairs.
 hash :: (Member (Hash value) sig, Carrier sig m) => [(value, value)] -> m value
-hash v = send (Hash v ret)
+hash v = send (Hash v pure)
 
 -- | Construct a key-value pair for use in a hash.
 kvPair :: (Member (Hash value) sig, Carrier sig m) => value -> value -> m value
-kvPair v1 v2 = send (KvPair v1 v2 ret)
+kvPair v1 v2 = send (KvPair v1 v2 pure)
 
 data Hash value (m :: * -> *) k
   = Hash [(value, value)] (value -> k)
@@ -465,11 +469,12 @@ instance Effect (Hash value) where
     handle state handler = coerce . fmap (handler . (<$ state))
 
 newtype HashC value m a = HashC { runHashC :: m a }
+  deriving stock Functor
+  deriving newtype (Alternative, Applicative, Monad)
 
-runHash :: Carrier (Hash value :+: sig) (HashC value (Eff m))
+runHash :: Evaluator term address value (HashC value m) a
-           => Evaluator term address value (HashC value (Eff m)) a
+        -> Evaluator term address value m a
-           -> Evaluator term address value m a
+runHash = raiseHandler runHashC
-runHash = raiseHandler $ runHashC . interpret
 
 class Show value => AbstractIntro value where
   -- | Construct the nil/null datatype.

src/Control/Effect/Catch.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE DeriveFunctor, ExistentialQuantification, FlexibleContexts, FlexibleInstances, LambdaCase,
+{-# LANGUAGE DeriveFunctor, ExistentialQuantification, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving,
              MultiParamTypeClasses, RankNTypes, StandaloneDeriving, TypeOperators, UndecidableInstances #-}
 
 -- | An effect that enables catching exceptions thrown from
@@ -11,7 +11,7 @@ module Control.Effect.Catch
   ) where
 
 import           Control.Effect.Carrier
-import           Control.Effect.Internal
+import           Control.Effect.Reader
 import           Control.Effect.Sum
 import qualified Control.Exception as Exc
 import           Control.Monad.IO.Class
@@ -37,26 +37,25 @@ catch :: (Member Catch sig, Carrier sig m, Exc.Exception e)
         => m a
         -> (e -> m a)
         -> m a
-catch go cleanup = send (CatchIO go cleanup ret)
+catch go cleanup = send (CatchIO go cleanup pure)
 
-runCatch :: (Carrier sig m, MonadIO m)
-         => (forall x . m x -> IO x)
-         -> Eff (CatchC m) a
-         -> m a
-runCatch handler = runCatchC handler . interpret
 
-newtype CatchC m a = CatchC ((forall x . m x -> IO x) -> m a)
+-- | Evaulate a 'Catch' effect.
+runCatch :: (forall x . m x -> IO x)
+           -> CatchC m a
+           -> m a
+runCatch handler = runReader (Handler handler) . runCatchC
 
-runCatchC :: (forall x . m x -> IO x) -> CatchC m a -> m a
+newtype Handler m = Handler (forall x . m x -> IO x)
-runCatchC handler (CatchC m) = m handler
+
+runHandler :: Handler m -> CatchC m a -> IO a
+runHandler h@(Handler handler) = handler . runReader h . runCatchC
+
+newtype CatchC m a = CatchC { runCatchC :: ReaderC (Handler m) m a }
+  deriving (Functor, Applicative, Monad, MonadIO)
 
 instance (Carrier sig m, MonadIO m) => Carrier (Catch :+: sig) (CatchC m) where
-  ret a = CatchC (const (ret a))
+  eff (L (CatchIO act cleanup k)) = do
-  eff op = CatchC (\ handler -> handleSum
+    handler <- CatchC ask
-    (eff . handlePure (runCatchC handler))
+    liftIO (Exc.catch (runHandler handler act) (runHandler handler . cleanup)) >>= k
-    (\case
+  eff (R other) = CatchC (eff (R (handleCoercible other)))
-        CatchIO go cleanup k -> liftIO (Exc.catch
-                                         (handler (runCatchC handler go))
-                                         (handler . runCatchC handler . cleanup))
-                                >>= runCatchC handler . k
-    ) op)

src/Control/Effect/Interpose.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE ExistentialQuantification, RankNTypes, StandaloneDeriving, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE ExistentialQuantification, GeneralizedNewtypeDeriving, RankNTypes, StandaloneDeriving, TypeOperators, UndecidableInstances #-}
 module Control.Effect.Interpose
 ( Interpose(..)
 , interpose
@@ -7,8 +7,9 @@ module Control.Effect.Interpose
 , Listener(..)
 ) where
 
+import Control.Applicative
 import Control.Effect.Carrier
-import Control.Effect.Internal
+import Control.Effect.Reader
 import Control.Effect.Sum
 
 data Interpose eff m k
@@ -28,22 +29,28 @@ 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)
+interpose m f = send (Interpose m f pure)
 
 
 -- | Run an 'Interpose' effect.
-runInterpose :: (Member eff sig, Carrier sig m, Monad m) => Eff (InterposeC eff m) a -> m a
+runInterpose :: InterposeC eff m a -> m a
-runInterpose = flip runInterposeC Nothing . interpret
+runInterpose = runReader Nothing . runInterposeC
 
-newtype InterposeC eff m a = InterposeC { runInterposeC :: Maybe (Listener eff m) -> m a }
+newtype InterposeC eff m a = InterposeC { runInterposeC :: ReaderC (Maybe (Listener eff (InterposeC eff m))) m a }
+  deriving (Alternative, Applicative, Functor, Monad)
 
-newtype Listener eff m = Listener { runListener :: forall n x . eff n (n x) -> m x }
+newtype Listener eff m = Listener (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
+-- TODO: Document the implementation of this, as it is extremely subtle.
-  ret a = InterposeC (const (ret a))
+
-  eff op = InterposeC (\ listener -> handleSum (algOther listener) (alg listener) op)
+runListener :: Listener eff (InterposeC eff m) -> eff (InterposeC eff m) (InterposeC eff m a) -> InterposeC eff m a
-    where alg listener (Interpose m h k) = runInterposeC m (Just (Listener (flip runInterposeC listener . h))) >>= flip runInterposeC listener . k
+runListener (Listener listen) = listen
-          algOther listener op
+
-            | Just listener <- listener
+instance (Carrier sig m, Member eff sig) => Carrier (Interpose eff :+: sig) (InterposeC eff m) where
-            , Just eff <- prj op = runListener listener eff
+  eff (L (Interpose m h k)) =
-            | otherwise          = eff (handleReader listener runInterposeC op)
+    InterposeC (local (const (Just (Listener h))) (runInterposeC m)) >>= k
+  eff (R other) = do
+    listener <- InterposeC ask
+    case (listener, prj other) of
+      (Just listener, Just eff) -> runListener listener eff
+      _                         -> InterposeC (eff (R (handleCoercible other)))

src/Control/Effect/REPL.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE KindSignatures, LambdaCase, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving, KindSignatures, TypeOperators, UndecidableInstances #-}
 
 module Control.Effect.REPL
   ( REPL (..)
@@ -13,6 +13,7 @@ import Prologue
 import Control.Effect
 import Control.Effect.Carrier
 import Control.Effect.Sum
+import Control.Effect.Reader
 import System.Console.Haskeline
 import qualified Data.Text as T
 
@@ -29,21 +30,25 @@ instance Effect REPL where
   handle state handler (Output s k) = Output s (handler (k <$ state))
 
 prompt :: (Member REPL sig, Carrier sig m) => Text -> m (Maybe Text)
-prompt p = send (Prompt p ret)
+prompt p = send (Prompt p pure)
 
 output :: (Member REPL sig, Carrier sig m) => Text -> m ()
-output s = send (Output s (ret ()))
+output s = send (Output s (pure ()))
 
-runREPL :: (MonadIO m, Carrier sig m) => Prefs -> Settings IO -> Eff (REPLC m) a -> m a
+runREPL :: Prefs -> Settings IO -> REPLC m a -> m a
-runREPL prefs settings = flip runREPLC (prefs, settings) . interpret
+runREPL prefs settings = runReader (prefs, settings) . runREPLC
 
-newtype REPLC m a = REPLC { runREPLC :: (Prefs, Settings IO) -> m a }
+newtype REPLC m a = REPLC { runREPLC :: ReaderC (Prefs, Settings IO) m a }
+  deriving (Functor, Applicative, Monad, MonadIO)
 
 instance (Carrier sig m, MonadIO m) => Carrier (REPL :+: sig) (REPLC m) where
-  ret = REPLC . const . ret
+  eff (L op) = do
-  eff op = REPLC (\ args -> handleSum (eff . handleReader args runREPLC) (\case
+    args <- REPLC ask
-    Prompt p k -> liftIO (uncurry runInputTWithPrefs args (fmap (fmap T.pack) (getInputLine (cyan <> T.unpack p <> plain)))) >>= flip runREPLC args . k
+    case op of
-    Output s k -> liftIO (uncurry runInputTWithPrefs args (outputStrLn (T.unpack s))) *> runREPLC k args) op)
+      Prompt p k -> liftIO (uncurry runInputTWithPrefs args (fmap (fmap T.pack) (getInputLine (cyan <> T.unpack p <> plain)))) >>= k
+      Output s k -> liftIO (uncurry runInputTWithPrefs args (outputStrLn (T.unpack s))) *> k
+  eff (R other) = REPLC (eff (R (handleCoercible other)))
+
 
 cyan :: String
 cyan = "\ESC[1;36m\STX"

src/Data/Abstract/Address/Hole.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE LambdaCase, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE TypeOperators, UndecidableInstances #-}
 module Data.Abstract.Address.Hole
 ( Hole(..)
 , toMaybe
@@ -28,18 +28,16 @@ instance ( Carrier (Allocator address :+: sig) (AllocatorC address m)
          , Monad m
          )
       => Carrier (Allocator (Hole context address) :+: sig) (AllocatorC (Hole context address) m) where
-  ret = promoteA . ret
+  eff (R other) = AllocatorC . eff . handleCoercible $ other
-  eff = handleSum
+  eff (L (Alloc name k)) = Total <$> promoteA (eff (L (Alloc name pure))) >>= k
-    (AllocatorC . eff . handleCoercible)
-    (\ (Alloc name k) -> Total <$> promoteA (eff (L (Alloc name ret))) >>= k)
 
 
 promoteD :: DerefC address value m a -> DerefC (Hole context address) value m a
 promoteD = DerefC . runDerefC
 
-instance (Carrier (Deref value :+: sig) (DerefC address value m), Carrier sig m, Monad m)
+instance (Carrier (Deref value :+: sig) (DerefC address value m), Carrier sig m)
       => Carrier (Deref value :+: sig) (DerefC (Hole context address) value m) where
-  ret = promoteD . ret
+  eff (R other) = DerefC . eff . handleCoercible $ other
-  eff = handleSum (DerefC . eff . handleCoercible) (\case
+  eff (L op) = case op of
-    DerefCell        cell k -> promoteD (eff (L (DerefCell        cell ret))) >>= k
+    DerefCell        cell k -> promoteD (eff (L (DerefCell        cell pure))) >>= k
-    AssignCell value cell k -> promoteD (eff (L (AssignCell value cell ret))) >>= k)
+    AssignCell value cell k -> promoteD (eff (L (AssignCell value cell pure))) >>= k

src/Data/Abstract/Address/Monovariant.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE LambdaCase, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE TypeOperators, UndecidableInstances #-}
 module Data.Abstract.Address.Monovariant
 ( Monovariant(..)
 ) where
@@ -19,14 +19,10 @@ instance Show Monovariant where
 
 
 instance Carrier sig m => Carrier (Allocator Monovariant :+: sig) (AllocatorC Monovariant m) where
-  ret = AllocatorC . ret
+  eff (L (Alloc name k)) = k (Monovariant name)
-  eff = AllocatorC . handleSum
+  eff (R other) = AllocatorC . eff . handleCoercible $ other
-    (eff . handleCoercible)
-    (\ (Alloc name k) -> runAllocatorC (k (Monovariant name)))
-
 
 instance (Ord value, Carrier sig m, Alternative m, Monad m) => Carrier (Deref value :+: sig) (DerefC Monovariant value m) where
-  ret = DerefC . ret
+  eff (L (DerefCell cell k)) = traverse (foldMapA pure) (nonEmpty (toList cell)) >>= k
-  eff = DerefC . handleSum (eff . handleCoercible) (\case
+  eff (L (AssignCell value cell k)) = k (Set.insert value cell)
-    DerefCell        cell k -> traverse (foldMapA pure) (nonEmpty (toList cell)) >>= runDerefC . k
+  eff (R other) = DerefC . eff . handleCoercible $ other
-    AssignCell value cell k -> runDerefC (k (Set.insert value cell)))

src/Data/Abstract/Address/Precise.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving, LambdaCase, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving, TypeOperators, UndecidableInstances #-}
 module Data.Abstract.Address.Precise
 ( Precise(..)
 ) where
@@ -18,15 +18,13 @@ instance Show Precise where
   showsPrec d = showsUnaryWith showsPrec "Precise" d . unPrecise
 
 
-instance (Member Fresh sig, Carrier sig m, Monad m) => Carrier (Allocator Precise :+: sig) (AllocatorC Precise m) where
+instance (Member Fresh sig, Carrier sig m) => Carrier (Allocator Precise :+: sig) (AllocatorC Precise m) where
-  ret = AllocatorC . ret
+  eff (R other) = AllocatorC . eff . handleCoercible $ other
-  eff = AllocatorC . handleSum
+  eff (L (Alloc _ k)) = Precise <$> fresh >>= k
-    (eff . handleCoercible)
-    (\ (Alloc _ k) -> Precise <$> fresh >>= runAllocatorC . k)
 
 
 instance Carrier sig m => Carrier (Deref value :+: sig) (DerefC Precise value m) where
-  ret = DerefC . ret
+  eff (R other) = DerefC . eff . handleCoercible $ other
-  eff = DerefC . handleSum (eff . handleCoercible) (\case
+  eff (L op) = case op of
-    DerefCell        cell k -> runDerefC (k (fst <$> Set.minView cell))
+    DerefCell        cell k -> k (fst <$> Set.minView cell)
-    AssignCell value _    k -> runDerefC (k (Set.singleton value)))
+    AssignCell value _    k -> k (Set.singleton value)

src/Data/Abstract/BaseError.hs

@@ -39,7 +39,6 @@ throwBaseError :: ( Member (Resumable (BaseError exc)) sig
                   , Member (Reader M.ModuleInfo) sig
                   , Member (Reader S.Span) sig
                   , Carrier sig m
-                  , Monad m
                   )
                 => exc resume
                 -> m resume

src/Data/Abstract/Evaluatable.hs

@@ -258,10 +258,13 @@ instance (Eq term, Eq value) => Eq1 (EvalError term address value) where
 instance (Show term, Show value) => Show1 (EvalError term address value) where
   liftShowsPrec _ _ = showsPrec
 
-runEvalError :: (Carrier sig m, Effect sig) => Evaluator term address value (ResumableC (BaseError (EvalError term address value)) (Eff m)) a -> Evaluator term address value m (Either (SomeError (BaseError (EvalError term address value))) a)
+runEvalError :: Evaluator term address value (ResumableC (BaseError (EvalError term address value)) m) a
+             -> Evaluator term address value m (Either (SomeError (BaseError (EvalError term address value))) a)
 runEvalError = raiseHandler runResumable
 
-runEvalErrorWith :: Carrier sig m => (forall resume . (BaseError (EvalError term address value)) resume -> Evaluator term address value m resume) -> Evaluator term address value (ResumableWithC (BaseError (EvalError term address value)) (Eff m)) a -> Evaluator term address value m a
+runEvalErrorWith :: (forall resume . (BaseError (EvalError term address value)) resume -> Evaluator term address value m resume)
+                 -> Evaluator term address value (ResumableWithC (BaseError (EvalError term address value)) m) a
+                 -> Evaluator term address value m a
 runEvalErrorWith f = raiseHandler $ runResumableWith (runEvaluator . f)
 
 throwEvalError :: ( Member (Reader ModuleInfo) sig
@@ -297,14 +300,12 @@ instance Eq1 (UnspecializedError address value) where
 instance Show1 (UnspecializedError address value) where
   liftShowsPrec _ _ = showsPrec
 
-runUnspecialized :: (Carrier sig m, Effect sig)
+runUnspecialized :: Evaluator term address value (ResumableC (BaseError (UnspecializedError address value)) m) a
-                 => Evaluator term address value (ResumableC (BaseError (UnspecializedError address value)) (Eff m)) a
                  -> Evaluator term address value m (Either (SomeError (BaseError (UnspecializedError address value))) a)
 runUnspecialized = raiseHandler runResumable
 
-runUnspecializedWith :: Carrier sig m
+runUnspecializedWith :: (forall resume . BaseError (UnspecializedError address value) resume -> Evaluator term address value m resume)
-                     => (forall resume . BaseError (UnspecializedError address value) resume -> Evaluator term address value m resume)
+                     -> Evaluator term address value (ResumableWithC (BaseError (UnspecializedError address value)) m) a
-                     -> Evaluator term address value (ResumableWithC (BaseError (UnspecializedError address value)) (Eff m)) a
                      -> Evaluator term address value m a
 runUnspecializedWith f = raiseHandler $ runResumableWith (runEvaluator . f)
 

src/Data/Abstract/Name.hs

@@ -24,7 +24,7 @@ data Name
   deriving (Eq, Ord, Generic, NFData)
 
 -- | Generate a fresh (unused) name for use in synthesized variables/closures/etc.
-gensym :: (Member Fresh sig, Carrier sig m, Functor m) => m Name
+gensym :: (Member Fresh sig, Carrier sig m) => m Name
 gensym = I <$> fresh
 
 -- | Construct a 'Name' from a 'Text'.

src/Data/Abstract/Value/Abstract.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE LambdaCase, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE TypeOperators, UndecidableInstances #-}
 module Data.Abstract.Value.Abstract
 ( Abstract (..)
 , runFunction
@@ -38,100 +38,95 @@ instance ( Member (Allocator address) sig
          , Show address
          , Carrier sig m
          )
-      => Carrier (Abstract.Function term address Abstract :+: sig) (FunctionC term address Abstract (Eff m)) where
+      => Carrier (Abstract.Function term address Abstract :+: sig) (FunctionC term address Abstract m) where
-  ret = FunctionC . const . ret
+  eff (R other) = FunctionC . eff . R . handleCoercible $ other
-  eff op = FunctionC (\ eval -> handleSum (eff . handleReader eval runFunctionC) (\case
+  eff (L op) = runEvaluator $ do
-    Function _ params body scope k -> runEvaluator $ do
+    eval <- Evaluator . FunctionC $ ask
-      currentScope' <- currentScope
+    case op of
-      currentFrame' <- currentFrame
+      Function _ params body scope k -> do
-      let frameLinks = Map.singleton Lexical (Map.singleton currentScope' currentFrame')
+        currentScope' <- currentScope
-      frame <- newFrame scope frameLinks
+        currentFrame' <- currentFrame
-      res <- withScopeAndFrame frame $ do
+        let frameLinks = Map.singleton Lexical (Map.singleton currentScope' currentFrame')
-        for_ params $ \param -> do
+        frame <- newFrame scope frameLinks
-          slot <- lookupSlot (Declaration param)
+        res <- withScopeAndFrame frame $ do
-          assign slot Abstract
+          for_ params $ \param -> do
-        catchReturn (runFunction (Evaluator . eval) (Evaluator (eval body)))
+            slot <- lookupSlot (Declaration param)
-      Evaluator $ runFunctionC (k res) eval
+            assign slot Abstract
-    BuiltIn _ _ k -> runFunctionC (k Abstract) eval
+          catchReturn (Evaluator (eval body))
-    Bind _ _ k -> runFunctionC (k Abstract) eval
+        Evaluator (k res)
-    Call _ _ k -> runFunctionC (k Abstract) eval) op)
+      BuiltIn _ _ k -> Evaluator (k Abstract)
+      Bind _ _ k -> Evaluator (k Abstract)
+      Call _ _ k -> Evaluator (k Abstract)
 
 
 instance (Carrier sig m, Alternative m) => Carrier (Boolean Abstract :+: sig) (BooleanC Abstract m) where
-  ret = BooleanC . ret
+  eff (L (Boolean _ k)) = k Abstract
-  eff = BooleanC . handleSum (eff . handleCoercible) (\case
+  eff (L (AsBool  _ k)) = k True <|> k False
-    Boolean _ k -> runBooleanC (k Abstract)
+  eff (R other)         = BooleanC . eff . handleCoercible $ other
-    AsBool  _ k -> runBooleanC (k True) <|> runBooleanC (k False))
 
 
 instance ( Member (Abstract.Boolean Abstract) sig
          , Carrier sig m
          , Alternative m
-         , Monad m
          )
       => Carrier (While Abstract :+: sig) (WhileC Abstract m) where
-  ret = WhileC . ret
+  eff (R other) = WhileC . eff . handleCoercible $ other
-  eff = WhileC . handleSum
+  eff (L (Abstract.While cond body k)) = do
-    (eff . handleCoercible)
+    cond' <- cond
-    (\ (Abstract.While cond body k) -> do
+    ifthenelse cond' (body *> empty) (k Abstract)
-      cond' <- runWhileC cond
-      ifthenelse cond' (runWhileC body *> empty) (runWhileC (k Abstract)))
-
 
 instance Carrier sig m
       => Carrier (Unit Abstract :+: sig) (UnitC Abstract m) where
-  ret = UnitC . ret
+  eff (R other) = UnitC . eff . handleCoercible $ other
-  eff = UnitC . handleSum
+  eff (L (Abstract.Unit k)) = k Abstract
-    (eff . handleCoercible)
-    (\ (Abstract.Unit k) -> runUnitC (k Abstract))
 
 instance Carrier sig m
       => Carrier (Abstract.String Abstract :+: sig) (StringC Abstract m) where
-  ret = StringC . ret
+  eff (R other) = StringC . eff . handleCoercible $ other
-  eff = StringC . handleSum (eff . handleCoercible) (\case
+  eff (L op) = case op of
-    Abstract.String _ k -> runStringC (k Abstract)
+    Abstract.String _ k -> k Abstract
-    AsString        _ k -> runStringC (k ""))
+    AsString        _ k -> k ""
 
 instance Carrier sig m
       => Carrier (Numeric Abstract :+: sig) (NumericC Abstract m) where
-  ret = NumericC . ret
+  eff (R other) = NumericC . eff . handleCoercible $ other
-  eff = NumericC . handleSum (eff . handleCoercible) (\case
+  eff (L op) = case op of
-    Integer _ k -> runNumericC (k Abstract)
+    Integer _ k -> k Abstract
-    Float _ k -> runNumericC (k Abstract)
+    Float _ k -> k Abstract
-    Rational _ k -> runNumericC (k Abstract)
+    Rational _ k -> k Abstract
-    LiftNumeric _ _ k -> runNumericC (k Abstract)
+    LiftNumeric _ _ k -> k Abstract
-    LiftNumeric2 _ _ _ k -> runNumericC (k Abstract))
+    LiftNumeric2 _ _ _ k -> k Abstract
 
 instance Carrier sig m
       => Carrier (Bitwise Abstract :+: sig) (BitwiseC Abstract m) where
-  ret = BitwiseC . ret
+  eff (R other) = BitwiseC . eff . handleCoercible $ other
-  eff = BitwiseC . handleSum (eff . handleCoercible) (\case
+  eff (L op) = case op of
-    CastToInteger _ k -> runBitwiseC (k Abstract)
+    CastToInteger _ k -> k Abstract
-    LiftBitwise _ _ k -> runBitwiseC (k Abstract)
+    LiftBitwise _ _ k -> k Abstract
-    LiftBitwise2 _ _ _ k -> runBitwiseC (k Abstract)
+    LiftBitwise2 _ _ _ k -> k Abstract
-    UnsignedRShift _ _ k -> runBitwiseC (k Abstract))
+    UnsignedRShift _ _ k -> k Abstract
 
 instance Carrier sig m
       => Carrier (Object address Abstract :+: sig) (ObjectC address Abstract m) where
-  ret = ObjectC . ret
+  eff (R other) = ObjectC . eff . handleCoercible $ other
-  eff = ObjectC . handleSum (eff . handleCoercible) (\case
+  eff (L op) = case op of
-    Object _ k -> runObjectC (k Abstract)
+    Object _ k -> k Abstract
-    ScopedEnvironment _ k -> runObjectC (k Nothing)
+    ScopedEnvironment _ k -> k Nothing
-    Klass _ _ k -> runObjectC (k Abstract))
+    Klass _ _ k -> k Abstract
 
 instance Carrier sig m
       => Carrier (Array Abstract :+: sig) (ArrayC Abstract m) where
-  ret = ArrayC . ret
+  eff (R other) = ArrayC . eff . handleCoercible $ other
-  eff = ArrayC . handleSum (eff . handleCoercible) (\case
+  eff (L op) = case op of
-    Array _ k -> runArrayC (k Abstract)
+    Array _ k -> k Abstract
-    AsArray _ k -> runArrayC (k []))
+    AsArray _ k -> k []
 
 instance Carrier sig m
       => Carrier (Hash Abstract :+: sig) (HashC Abstract m) where
-  ret = HashC . ret
+  eff (R other) = HashC . eff . handleCoercible $ other
-  eff = HashC . handleSum (eff . handleCoercible) (\case
+  eff (L op) = case op of
-    Hash _ k -> runHashC (k Abstract)
+    Hash _ k -> k Abstract
-    KvPair _ _ k -> runHashC (k Abstract))
+    KvPair _ _ k -> k Abstract
 
 
 instance Ord address => ValueRoots address Abstract where
@@ -143,7 +138,7 @@ instance AbstractHole Abstract where
 instance AbstractIntro Abstract where
   null       = Abstract
 
-instance AbstractValue term address Abstract m where
+instance Applicative m => AbstractValue term address Abstract m where
   tuple _ = pure Abstract
 
   namespace _ _ = pure Abstract

src/Data/Abstract/Value/Concrete.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE DeriveAnyClass, GADTs, RankNTypes, TypeOperators, UndecidableInstances, LambdaCase, ScopedTypeVariables #-}
+{-# LANGUAGE DeriveAnyClass, GADTs, LambdaCase, RankNTypes, TypeOperators, UndecidableInstances, ScopedTypeVariables #-}
 module Data.Abstract.Value.Concrete
   ( Value (..)
   , ValueError (..)
@@ -26,6 +26,7 @@ import Data.Text (pack)
 import Data.Word
 import Prologue
 import qualified Data.Map.Strict as Map
+import Debug.Trace (traceM)
 
 data Value term address
     -- TODO: Split Closure up into a separate data type.                                                  Scope   Frame
@@ -77,47 +78,48 @@ instance ( FreeVariables term
          , Show address
          , Show term
          )
-      => Carrier (Abstract.Function term address (Value term address) :+: sig) (Abstract.FunctionC term address (Value term address) (Eff m)) where
+      => Carrier (Abstract.Function term address (Value term address) :+: sig) (Abstract.FunctionC term address (Value term address) m) where
-  ret = FunctionC . const . ret
+  eff (R other) = FunctionC . eff . R . handleCoercible $ other
-  eff op =
+  eff (L op) = runEvaluator $ do
+    eval <- Evaluator . FunctionC $ ask
     let closure maybeName params body scope = do
           packageInfo <- currentPackage
           moduleInfo <- currentModule
           Closure packageInfo moduleInfo maybeName Nothing params body scope <$> currentFrame
 
-    in FunctionC (\ eval -> handleSum (eff . handleReader eval runFunctionC) (\case
+    case op of
-    Abstract.Function name params body scope k -> runEvaluator $ do
+      Abstract.Function name params body scope k -> do
-      val <- closure (Just name) params (Right body) scope
+        val <- closure (Just name) params (Right body) scope
-      Evaluator $ runFunctionC (k val) eval
+        Evaluator (k val)
-    Abstract.BuiltIn associatedScope builtIn k -> runEvaluator $ do
+      Abstract.BuiltIn associatedScope builtIn k -> do
-      val <- closure Nothing [] (Left builtIn) associatedScope
+        val <- closure Nothing [] (Left builtIn) associatedScope
-      Evaluator $ runFunctionC (k val) eval
+        Evaluator (k val)
-    Abstract.Bind obj@Object{} (Closure packageInfo moduleInfo name _ names body scope parentFrame) k ->
+      Abstract.Bind obj@Object{} (Closure packageInfo moduleInfo name _ names body scope parentFrame) k ->
-      runFunctionC (k (Closure packageInfo moduleInfo name (Just obj) names body scope parentFrame)) eval
+        Evaluator (k (Closure packageInfo moduleInfo name (Just obj) names body scope parentFrame))
-    Abstract.Bind _ value k -> runFunctionC (k value) eval
+      Abstract.Bind _ value k -> Evaluator (k value)
-    Abstract.Call op params k -> runEvaluator $ do
+      Abstract.Call op params k -> do
-      boxed <- case op of
+        boxed <- case op of
-        Closure _ _ _ _ _ (Left Print) _ _ -> traverse (trace . show) params $> Unit
+          Closure _ _ _ _ _ (Left Print) _ _ -> traverse (trace . show) params $> Unit
-        Closure _ _ _ _ _ (Left Show) _ _ -> pure . String . pack $ show params
+          Closure _ _ _ _ _ (Left Show) _ _ -> pure . String . pack $ show params
-        Closure packageInfo moduleInfo _ maybeSelf names (Right body) associatedScope parentFrame -> do
+          Closure packageInfo moduleInfo _ maybeSelf names (Right body) associatedScope parentFrame -> do
-          -- Evaluate the bindings and body with the closure’s package/module info in scope in order to
+            -- Evaluate the bindings and body with the closure’s package/module info in scope in order to
-          -- charge them to the closure's origin.
+            -- charge them to the closure's origin.
-          withCurrentPackage packageInfo . withCurrentModule moduleInfo $ do
+            withCurrentPackage packageInfo . withCurrentModule moduleInfo $ do
-            parentScope <- scopeLookup parentFrame
+              parentScope <- scopeLookup parentFrame
-            let frameEdges = Map.singleton Lexical (Map.singleton parentScope parentFrame)
+              let frameEdges = Map.singleton Lexical (Map.singleton parentScope parentFrame)
-            frameAddress <- newFrame associatedScope frameEdges
+              frameAddress <- newFrame associatedScope frameEdges
-            withScopeAndFrame frameAddress $ do
+              withScopeAndFrame frameAddress $ do
-              case maybeSelf of
+                case maybeSelf of
-                Just object -> do
+                  Just object -> do
-                  maybeSlot <- maybeLookupDeclaration (Declaration __self)
+                    maybeSlot <- maybeLookupDeclaration (Declaration __self)
-                  maybe (pure ()) (`assign` object) maybeSlot
+                    maybe (pure ()) (`assign` object) maybeSlot
-                Nothing -> pure ()
+                  Nothing -> pure ()
-              for_ (zip names params) $ \(name, param) -> do
+                for_ (zip names params) $ \(name, param) -> do
-                slot <- lookupSlot (Declaration name)
+                  slot <- lookupSlot (Declaration name)
-                assign slot param
+                  assign slot param
-              catchReturn (runFunction (Evaluator . eval) (Evaluator (eval body)))
+                catchReturn (Evaluator (eval body))
-        _ -> throwValueError (CallError op)
+          _ -> throwValueError (CallError op)
-      Evaluator $ runFunctionC (k boxed) eval) op)
+        Evaluator (k boxed)
 
 instance ( Member (Reader ModuleInfo) sig
          , Member (Reader Span) sig
@@ -126,49 +128,78 @@ instance ( Member (Reader ModuleInfo) sig
          , Monad m
          )
       => Carrier (Abstract.Boolean (Value term address) :+: sig) (BooleanC (Value term address) m) where
-  ret = BooleanC . ret
+  eff (R other) = BooleanC . eff . handleCoercible $ other
-  eff = BooleanC . handleSum (eff . handleCoercible) (\case
+  eff (L op) = case op of
-    Abstract.Boolean b          k -> runBooleanC . k $! Boolean b
+    Abstract.Boolean b          k -> k $! Boolean b
-    Abstract.AsBool (Boolean b) k -> runBooleanC (k b)
+    Abstract.AsBool (Boolean b) k -> k b
-    Abstract.AsBool other       k -> throwBaseError (BoolError other) >>= runBooleanC . k)
+    Abstract.AsBool other       k -> throwBaseError (BoolError other) >>= k
-
 
 instance ( Carrier sig m
          , Member (Abstract.Boolean (Value term address)) sig
          , Member (Error (LoopControl (Value term address))) sig
          , Member (Interpose (Resumable (BaseError (UnspecializedError address (Value term address))))) sig
          )
-      => Carrier (Abstract.While (Value term address) :+: sig) (WhileC (Value term address) (Eff m)) where
+      => Carrier (Abstract.While (Value term address) :+: sig) (WhileC (Value term address) m) where
-  ret = WhileC . ret
+  eff (R other) = WhileC . eff . handleCoercible $ other
-  eff = WhileC . handleSum (eff . handleCoercible) (\case
+  eff (L (Abstract.While cond body k)) = do
-    Abstract.While cond body k -> interpose @(Resumable (BaseError (UnspecializedError address (Value term address)))) (runEvaluator (loop (\continue -> do
+
-      cond' <- Evaluator (runWhileC cond)
+    let loop x = catchError x $ \case
+          Break value -> pure 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
+
+    interpose @(Resumable (BaseError (UnspecializedError address (Value term address)))) (loop (do
+      cond' <- cond
 
       -- `interpose` is used to handle 'UnspecializedError's and abort out of the
       -- loop, otherwise under concrete semantics we run the risk of the
       -- conditional always being true and getting stuck in an infinite loop.
-
+      ifthenelse cond' (body *> throwError (Continue @(Value term address) Unit)) (pure Unit)))
-      ifthenelse cond' (Evaluator (runWhileC body) *> continue) (pure Unit))))
       (\case
-        Resumable (BaseError _ _ (UnspecializedError _))    _ -> throwError (Abort @(Value term address))
+        Resumable (BaseError _ _ (UnspecializedError _))    _ -> traceM "unspecialized" *> throwError (Abort @(Value term address))
-        Resumable (BaseError _ _ (RefUnspecializedError _)) _ -> throwError (Abort @(Value term address)))
+        Resumable (BaseError _ _ (RefUnspecializedError _)) _ -> traceM "refun" *> throwError (Abort @(Value term address))) >>= k
-        >>= runWhileC . k)
+
-    where
+
-      loop x = catchLoopControl (fix x) $ \case
+
-        Break value -> pure value
+  --   Abstract.While cond body k -> interpose @(Resumable (BaseError (UnspecializedError address (Value term address)))) (runEvaluator (loop (\continue -> do      cond' <- Evaluator (runWhileC cond)
-        Abort -> pure Unit
+
-        -- FIXME: Figure out how to deal with this. Ruby treats this as the result
+  --     -- `interpose` is used to handle 'UnspecializedError's and abort out of the
-        -- of the current block iteration, while PHP specifies a breakout level
+  --     -- loop, otherwise under concrete semantics we run the risk of the
-        -- and TypeScript appears to take a label.
+  --     -- conditional always being true and getting stuck in an infinite loop.
-        Continue _  -> loop x
+
+  --     ifthenelse cond' (Evaluator (runWhileC body) *> continue) (pure Unit))))
+  --     (
+  --       >>= runWhileC . k)
+  --   where
+  --     loop x = catchLoopControl (fix x) $ \case
+  --       Break value -> pure 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
+
+    -- case op of
+    --   Abstract.While cond body k -> interpose @(Resumable (BaseError (UnspecializedError address (Value term address)))) (runEvaluator (loop (\continue -> do
+    --     cond' <- Evaluator (runWhileC cond)
+
+    --     -- `interpose` is used to handle 'UnspecializedError's and abort out of the
+    --     -- loop, otherwise under concrete semantics we run the risk of the
+    --     -- conditional always being true and getting stuck in an infinite loop.
+
+    --     ifthenelse cond' (Evaluator (runWhileC body) *> continue) (pure Unit)
+    --     case _ of
+    --       Resumable (BaseError _ _ (UnspecializedError _))    _ -> throwError (Abort @(Value term address)) >>= k
+    --       Resumable (BaseError _ _ (RefUnspecializedError _)) _ -> throwError (Abort @(Value term address))) >>= k
 
 
 instance Carrier sig m
       => Carrier (Abstract.Unit (Value term address) :+: sig) (UnitC (Value term address) m) where
-  ret = UnitC . ret
+  eff (R other) = UnitC . eff . handleCoercible $ other
-  eff = UnitC . handleSum
+  eff (L (Abstract.Unit k )) = k Unit
-    (eff . handleCoercible)
-    (\ (Abstract.Unit k) -> runUnitC (k Unit))
 
 instance ( Member (Reader ModuleInfo) sig
          , Member (Reader Span) sig
@@ -177,11 +208,11 @@ instance ( Member (Reader ModuleInfo) sig
          , Monad m
          )
       => Carrier (Abstract.String (Value term address) :+: sig) (StringC (Value term address) m) where
-  ret = StringC . ret
+  eff (R other) = StringC . eff . handleCoercible $ other
-  eff = StringC . handleSum (eff . handleCoercible) (\case
+  eff (L op) = case op of
-    Abstract.String   t          k -> runStringC (k (String t))
+    Abstract.String   t          k -> k (String t)
-    Abstract.AsString (String t) k -> runStringC (k t)
+    Abstract.AsString (String t) k -> k t
-    Abstract.AsString other      k -> throwBaseError (StringError other) >>= runStringC . k)
+    Abstract.AsString other      k -> throwBaseError (StringError other) >>= k
 
 instance ( Member (Reader ModuleInfo) sig
          , Member (Reader Span) sig
@@ -190,17 +221,17 @@ instance ( Member (Reader ModuleInfo) sig
          , Monad m
          )
       => Carrier (Abstract.Numeric (Value term address) :+: sig) (NumericC (Value term address) m) where
-  ret = NumericC . ret
+  eff (R other) = NumericC . eff . handleCoercible $ other
-  eff = NumericC . handleSum (eff . handleCoercible) (\case
+  eff (L op) = case op of
-    Abstract.Integer  t k -> runNumericC (k (Integer (Number.Integer t)))
+    Abstract.Integer  t k -> k (Integer (Number.Integer t))
-    Abstract.Float    t k -> runNumericC (k (Float (Number.Decimal t)))
+    Abstract.Float    t k -> k (Float (Number.Decimal t))
-    Abstract.Rational t k -> runNumericC (k (Rational (Number.Ratio t)))
+    Abstract.Rational t k -> k (Rational (Number.Ratio t))
-    Abstract.LiftNumeric f arg k -> runNumericC . k =<< case arg of
+    Abstract.LiftNumeric f arg k -> k =<< case arg of
       Integer (Number.Integer i) -> pure $ Integer (Number.Integer (f i))
       Float (Number.Decimal d)   -> pure $ Float (Number.Decimal (f d))
       Rational (Number.Ratio r)  -> pure $ Rational (Number.Ratio (f r))
       other                      -> throwBaseError (NumericError other)
-    Abstract.LiftNumeric2 f left right k -> runNumericC . k =<< case (left, right) of
+    Abstract.LiftNumeric2 f left right k -> k =<< case (left, right) of
       (Integer  i, Integer j)  -> attemptUnsafeArithmetic (f i j) & specialize
       (Integer  i, Rational j) -> attemptUnsafeArithmetic (f i j) & specialize
       (Integer  i, Float j)    -> attemptUnsafeArithmetic (f i j) & specialize
@@ -210,21 +241,20 @@ instance ( Member (Reader ModuleInfo) sig
       (Float    i, Integer j)  -> attemptUnsafeArithmetic (f i j) & specialize
       (Float    i, Rational j) -> attemptUnsafeArithmetic (f i j) & specialize
       (Float    i, Float j)    -> attemptUnsafeArithmetic (f i j) & specialize
-      _                        -> throwBaseError (Numeric2Error left right))
+      _                        -> throwBaseError (Numeric2Error left right)
 
 -- Dispatch whatever's contained inside a 'Number.SomeNumber' to its appropriate 'MonadValue' ctor
 specialize :: ( Member (Reader ModuleInfo) sig
               , Member (Reader Span) sig
               , Member (Resumable (BaseError (ValueError term address))) sig
               , Carrier sig m
-              , Monad m
               )
            => Either ArithException Number.SomeNumber
            -> m (Value term address)
 specialize (Left exc) = throwBaseError (ArithmeticError exc)
 specialize (Right (Number.SomeNumber (Number.Integer t))) = pure (Integer (Number.Integer t))
-specialize (Right (Number.SomeNumber (Number.Decimal t)))   = pure (Float (Number.Decimal t))
+specialize (Right (Number.SomeNumber (Number.Decimal t))) = pure (Float (Number.Decimal t))
-specialize (Right (Number.SomeNumber (Number.Ratio t))) = pure (Rational (Number.Ratio t))
+specialize (Right (Number.SomeNumber (Number.Ratio t)))   = pure (Rational (Number.Ratio t))
 
 
 instance ( Member (Reader ModuleInfo) sig
@@ -234,32 +264,31 @@ instance ( Member (Reader ModuleInfo) sig
          , Monad m
          )
       => Carrier (Abstract.Bitwise (Value term address) :+: sig) (BitwiseC (Value term address) m) where
-  ret = BitwiseC . ret
+  eff (R other) = BitwiseC . eff . handleCoercible $ other
-  eff = BitwiseC . handleSum (eff . handleCoercible) (\case
+  eff (L op) = case op of
-    CastToInteger (Integer (Number.Integer i)) k -> runBitwiseC (k (Integer (Number.Integer i)))
+    CastToInteger (Integer (Number.Integer i)) k -> k (Integer (Number.Integer i))
-    CastToInteger (Float (Number.Decimal i)) k -> runBitwiseC (k (Integer (Number.Integer (coefficient (normalize i)))))
+    CastToInteger (Float (Number.Decimal i)) k -> k (Integer (Number.Integer (coefficient (normalize i))))
-    CastToInteger i k -> throwBaseError (NumericError i) >>= runBitwiseC . k
+    CastToInteger i k -> throwBaseError (NumericError i) >>= k
-    LiftBitwise operator (Integer (Number.Integer i)) k -> runBitwiseC . k . Integer . Number.Integer . operator $ i
+    LiftBitwise operator (Integer (Number.Integer i)) k -> k . Integer . Number.Integer . operator $ i
-    LiftBitwise _ other k -> throwBaseError (BitwiseError other) >>= runBitwiseC . k
+    LiftBitwise _ other k -> throwBaseError (BitwiseError other) >>= k
-    LiftBitwise2 operator (Integer (Number.Integer i)) (Integer (Number.Integer j)) k -> runBitwiseC . k . Integer . Number.Integer $ operator i j
+    LiftBitwise2 operator (Integer (Number.Integer i)) (Integer (Number.Integer j)) k -> k . Integer . Number.Integer $ operator i j
-    LiftBitwise2 _ left right k -> throwBaseError (Bitwise2Error left right) >>= runBitwiseC . k
+    LiftBitwise2 _ left right k -> throwBaseError (Bitwise2Error left right) >>= k
-    UnsignedRShift (Integer (Number.Integer i)) (Integer (Number.Integer j)) k | i >= 0 -> runBitwiseC . k . Integer . Number.Integer $ ourShift (fromIntegral i) (fromIntegral j)
+    UnsignedRShift (Integer (Number.Integer i)) (Integer (Number.Integer j)) k | i >= 0 -> k . Integer . Number.Integer $ ourShift (fromIntegral i) (fromIntegral j)
-    UnsignedRShift left right k -> throwBaseError (Bitwise2Error left right) >>= runBitwiseC . k)
+    UnsignedRShift left right k -> throwBaseError (Bitwise2Error left right) >>= k
 
 ourShift :: Word64 -> Int -> Integer
 ourShift a b = toInteger (shiftR a b)
 
 
 instance Carrier sig m => Carrier (Abstract.Object address (Value term address) :+: sig) (ObjectC address (Value term address) m) where
-  ret = ObjectC . ret
+  eff (R other) = ObjectC . eff . handleCoercible $ other
-  eff = ObjectC . handleSum (eff . handleCoercible) (\case
+  eff (L op) = case op of
-    Abstract.Object address k -> runObjectC (k (Object address))
+    Abstract.Object address k -> k (Object address)
-    Abstract.ScopedEnvironment (Object address) k -> runObjectC (k (Just address))
+    Abstract.ScopedEnvironment (Object address) k -> k (Just address)
-    Abstract.ScopedEnvironment (Class _ _ address) k -> runObjectC (k (Just address))
+    Abstract.ScopedEnvironment (Class _ _ address) k -> k (Just address)
-    Abstract.ScopedEnvironment (Namespace _ address) k -> runObjectC (k (Just address))
+    Abstract.ScopedEnvironment (Namespace _ address) k -> k (Just address)
-    Abstract.ScopedEnvironment _ k -> runObjectC (k Nothing)
+    Abstract.ScopedEnvironment _ k -> k Nothing
-    Abstract.Klass n frame k -> runObjectC (k (Class n mempty frame))
+    Abstract.Klass n frame k -> k (Class n mempty frame)
-    )
 
 instance ( Member (Reader ModuleInfo) sig
        , Member (Reader Span) sig
@@ -268,17 +297,17 @@ instance ( Member (Reader ModuleInfo) sig
        , Monad m
        )
       => Carrier (Abstract.Array (Value term address) :+: sig) (ArrayC (Value term address) m) where
-  ret = ArrayC . ret
+  eff (R other) = ArrayC . eff . handleCoercible $ other
-  eff = ArrayC . handleSum (eff . handleCoercible) (\case
+  eff (L op) = case op of
-    Abstract.Array t k -> runArrayC (k (Array t))
+    Abstract.Array t k -> k (Array t)
-    Abstract.AsArray (Array addresses) k -> runArrayC (k addresses)
+    Abstract.AsArray (Array addresses) k -> k addresses
-    Abstract.AsArray val k -> throwBaseError (ArrayError val) >>= runArrayC . k)
+    Abstract.AsArray val k -> throwBaseError (ArrayError val) >>= k
 
 instance ( Carrier sig m ) => Carrier (Abstract.Hash (Value term address) :+: sig) (HashC (Value term address) m) where
-  ret = HashC . ret
+  eff (R other) = HashC . eff . handleCoercible $ other
-  eff = HashC . handleSum (eff . handleCoercible) (\case
+  eff (L op) = case op of
-    Abstract.Hash t k -> runHashC (k ((Hash . map (uncurry KVPair)) t))
+    Abstract.Hash t k -> k ((Hash . map (uncurry KVPair)) t)
-    Abstract.KvPair t v k -> runHashC (k (KVPair t v)))
+    Abstract.KvPair t v k -> k (KVPair t v)
 
 
 instance AbstractHole (Value term address) where
@@ -391,14 +420,12 @@ deriving instance (Show address, Show term) => Show (ValueError term address res
 instance (Show address, Show term) => Show1 (ValueError term address) where
   liftShowsPrec _ _ = showsPrec
 
-runValueError :: (Carrier sig m, Effect sig)
+runValueError :: Evaluator term address (Value term address) (ResumableC (BaseError (ValueError term address)) m) a
-              => Evaluator term address (Value term address) (ResumableC (BaseError (ValueError term address)) (Eff m)) a
               -> Evaluator term address (Value term address) m (Either (SomeError (BaseError (ValueError term address))) a)
 runValueError = Evaluator . runResumable . runEvaluator
 
-runValueErrorWith :: Carrier sig m
+runValueErrorWith :: (forall resume . BaseError (ValueError term address) resume -> Evaluator term address (Value term address) m resume)
-                  => (forall resume . BaseError (ValueError term address) resume -> Evaluator term address (Value term address) m resume)
+                  -> Evaluator term address (Value term address) (ResumableWithC (BaseError (ValueError term address)) m) a
-                  -> Evaluator term address (Value term address) (ResumableWithC (BaseError (ValueError term address)) (Eff m)) a
                   -> Evaluator term address (Value term address) m a
 runValueErrorWith f = Evaluator . runResumableWith (runEvaluator . f) . runEvaluator
 

src/Data/Abstract/Value/Type.hs

@@ -87,10 +87,13 @@ instance Ord1  TypeError where
 
 instance Show1 TypeError where liftShowsPrec _ _ = showsPrec
 
-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 :: Evaluator term address value (ResumableC (BaseError TypeError) m) a
+             -> Evaluator term address value m (Either (SomeError (BaseError TypeError)) a)
 runTypeError = raiseHandler runResumable
 
-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 :: (forall resume . (BaseError TypeError) resume -> Evaluator term address value m resume)
+                 -> Evaluator term address value (ResumableWithC (BaseError TypeError) m) a
+                 -> Evaluator term address value m a
 runTypeErrorWith f = raiseHandler $ runResumableWith (runEvaluator . f)
 
 
@@ -98,29 +101,27 @@ throwTypeError :: ( Member (Resumable (BaseError TypeError)) sig
                   , Member (Reader ModuleInfo) sig
                   , Member (Reader Span) sig
                   , Carrier sig m
-                  , Monad m
                   )
                => TypeError resume
                -> m resume
 throwTypeError = throwBaseError
 
-runTypeMap :: (Carrier sig m, Effect sig)
+runTypeMap :: Carrier sig m
-           => Evaluator term address Type (StateC TypeMap (Eff m)) a
+           => Evaluator term address Type (StateC TypeMap m) a
            -> Evaluator term address Type m a
 runTypeMap = raiseHandler $ fmap snd . runState emptyTypeMap
 
-runTypes :: (Carrier sig m, Effect sig)
+runTypes :: Carrier sig m
-         => Evaluator term address Type (ResumableC (BaseError TypeError) (Eff
+         => Evaluator term address Type (ResumableC (BaseError TypeError)
-                                        (StateC TypeMap (Eff
+                                         (StateC TypeMap m)) a
-                                        m)))) a
          -> Evaluator term address Type m (Either (SomeError (BaseError TypeError)) a)
 runTypes = runTypeMap . runTypeError
 
-runTypesWith :: (Carrier sig m, Effect sig)
+runTypesWith :: Carrier sig m
-             => (forall resume . (BaseError TypeError) resume -> Evaluator term address Type (StateC TypeMap (Eff m)) resume)
+             => (forall resume . (BaseError TypeError) resume -> Evaluator term address Type (StateC TypeMap m) resume)
-             -> Evaluator term address Type (ResumableWithC (BaseError TypeError) (Eff
+             -> Evaluator term address Type (ResumableWithC (BaseError TypeError)
-                                            (StateC TypeMap (Eff
+                                            (StateC TypeMap
-                                            m)))) a
+                                            m)) a
              -> Evaluator term address Type m a
 runTypesWith with = runTypeMap . runTypeErrorWith with
 
@@ -132,7 +133,6 @@ emptyTypeMap = TypeMap Map.empty
 
 modifyTypeMap :: ( Member (State TypeMap) sig
                  , Carrier sig m
-                 , Monad m
                  )
               => (Map.Map TName Type -> Map.Map TName Type)
               -> m ()
@@ -141,7 +141,6 @@ modifyTypeMap f = modify (TypeMap . f . unTypeMap)
 -- | Prunes substituted type variables
 prune :: ( Member (State TypeMap) sig
          , Carrier sig m
-         , Monad m
          )
       => Type
       -> m Type
@@ -157,7 +156,6 @@ prune ty = pure ty
 --   function is used in 'substitute' to prevent unification of infinite types
 occur :: ( Member (State TypeMap) sig
          , Carrier sig m
-         , Monad m
          )
       => TName
       -> Type
@@ -189,7 +187,6 @@ substitute :: ( Member (Reader ModuleInfo) sig
               , Member (Resumable (BaseError TypeError)) sig
               , Member (State TypeMap) sig
               , Carrier sig m
-              , Monad m
               )
            => TName
            -> Type
@@ -208,7 +205,6 @@ unify :: ( Member (Reader ModuleInfo) sig
          , Member (Resumable (BaseError TypeError)) sig
          , Member (State TypeMap) sig
          , Carrier sig m
-         , Monad m
          )
       => Type
       -> Type
@@ -256,35 +252,38 @@ instance ( Member (Allocator address) sig
          , Show address
          , Carrier sig m
          )
-      => Carrier (Abstract.Function term address Type :+: sig) (FunctionC term address Type (Eff m)) where
+      => Carrier (Abstract.Function term address Type :+: sig) (FunctionC term address Type m) where
-  ret = FunctionC . const . ret
+  eff (R other) = FunctionC (eff (R (handleCoercible other)))
-  eff op = FunctionC (\ eval -> handleSum (eff . handleReader eval runFunctionC) (\case
+  eff (L op) = runEvaluator $ do
-    Abstract.Function _ params body scope k -> runEvaluator $ do
+    eval <- Evaluator . FunctionC $ ask
-      currentScope' <- currentScope
+    case op of
-      currentFrame' <- currentFrame
+      Abstract.Function _ params body scope k -> do
-      let frameLinks = Map.singleton Lexical (Map.singleton currentScope' currentFrame')
+        currentScope' <- currentScope
-      frame <- newFrame scope frameLinks
+        currentFrame' <- currentFrame
-      res <- withScopeAndFrame frame $ do
+        let frameLinks = Map.singleton Lexical (Map.singleton currentScope' currentFrame')
-        tvars <- foldr (\ param rest -> do
+        frame <- newFrame scope frameLinks
-          tvar <- Var <$> fresh
+        res <- withScopeAndFrame frame $ do
-          slot <- lookupSlot (Declaration param)
+          tvars <- foldr (\ param rest -> do
-          assign slot tvar
+            tvar <- Var <$> fresh
-          (tvar :) <$> rest) (pure []) params
+            slot <- lookupSlot (Declaration param)
-        -- TODO: We may still want to represent this as a closure and not a function type
+            assign slot tvar
-        (zeroOrMoreProduct tvars :->) <$> catchReturn (runFunction (Evaluator . eval) (Evaluator (eval body)))
+            (tvar :) <$> rest) (pure []) params
-      Evaluator (runFunctionC (k res) eval)
+          -- TODO: We may still want to represent this as a closure and not a function type
+          (zeroOrMoreProduct tvars :->) <$> catchReturn (Evaluator (eval body))
+        Evaluator (k res)
+
+      Abstract.BuiltIn _ Print k -> Evaluator $ k (String :-> Unit)
+      Abstract.BuiltIn _ Show  k -> Evaluator $ k (Object :-> String)
+      Abstract.Bind _ value k -> Evaluator $ k value
+      Abstract.Call op paramTypes k -> do
+        tvar <- fresh
+        let needed = zeroOrMoreProduct paramTypes :-> Var tvar
+        unified <- op `unify` needed
+        boxed <- case unified of
+          _ :-> ret -> pure ret
+          actual    -> throwTypeError (UnificationError needed actual)
+        Evaluator (k boxed)
 
-    Abstract.BuiltIn _ Print k -> runFunctionC (k (String :-> Unit)) eval
-    Abstract.BuiltIn _ Show  k -> runFunctionC (k (Object :-> String)) eval
-    Abstract.Bind _ value k -> runFunctionC (k value) eval
-    Abstract.Call op paramTypes k -> runEvaluator $ do
-      tvar <- fresh
-      let needed = zeroOrMoreProduct paramTypes :-> Var tvar
-      unified <- op `unify` needed
-      boxed <- case unified of
-        _ :-> ret -> pure ret
-        actual    -> throwTypeError (UnificationError needed actual)
-      Evaluator $ runFunctionC (k boxed) eval) op)
 
 
 instance ( Member (Reader ModuleInfo) sig
@@ -293,35 +292,29 @@ instance ( Member (Reader ModuleInfo) sig
          , Member (State TypeMap) sig
          , Carrier sig m
          , Alternative m
-         , Monad m
          )
       => Carrier (Abstract.Boolean Type :+: sig) (BooleanC Type m) where
-  ret = BooleanC . ret
+  eff (R other) = BooleanC . eff . handleCoercible $ other
-  eff = BooleanC . handleSum (eff . handleCoercible) (\case
+  eff (L (Abstract.Boolean _ k)) = k Bool
-    Abstract.Boolean _ k -> runBooleanC (k Bool)
+  eff (L (Abstract.AsBool t k))  = unify t Bool *> (k True <|> k False)
-    Abstract.AsBool  t k -> unify t Bool *> (runBooleanC (k True) <|> runBooleanC (k False)))
+
 
 
 instance ( Member (Abstract.Boolean Type) sig
          , Carrier sig m
          , Alternative m
-         , Monad m
          )
       => Carrier (Abstract.While Type :+: sig) (WhileC Type m) where
-  ret = WhileC . ret
+  eff (R other) = WhileC . eff . handleCoercible $ other
-  eff = WhileC . handleSum
+  eff (L (Abstract.While cond body k)) = do
-    (eff . handleCoercible)
+    cond' <- cond
-    (\ (Abstract.While cond body k) -> do
+    ifthenelse cond' (body *> empty) (k Unit)
-      cond' <- runWhileC cond
-      ifthenelse cond' (runWhileC body *> empty) (runWhileC (k Unit)))
 
 
 instance Carrier sig m
       => Carrier (Abstract.Unit Type :+: sig) (UnitC Type m) where
-  ret = UnitC . ret
+  eff (R other) = UnitC . eff . handleCoercible $ other
-  eff = UnitC . handleSum
+  eff (L (Abstract.Unit k)) = k Unit
-    (eff . handleCoercible)
-    (\ (Abstract.Unit k) -> runUnitC (k Unit))
 
 instance ( Member (Reader ModuleInfo) sig
          , Member (Reader Span) sig
@@ -329,13 +322,11 @@ instance ( Member (Reader ModuleInfo) sig
          , Member (State TypeMap) sig
          , Carrier sig m
          , Alternative m
-         , Monad m
          )
       => Carrier (Abstract.String Type :+: sig) (StringC Type m) where
-  ret = StringC . ret
+  eff (R other) = StringC . eff . handleCoercible $ other
-  eff = StringC . handleSum (eff . handleCoercible) (\case
+  eff (L (Abstract.String _ k)) = k String
-    Abstract.String   _ k -> runStringC (k String)
+  eff (L (Abstract.AsString t k)) = unify t String *> k ""
-    Abstract.AsString t k -> unify t String *> runStringC (k ""))
 
 instance ( Member (Reader ModuleInfo) sig
          , Member (Reader Span) sig
@@ -345,16 +336,16 @@ instance ( Member (Reader ModuleInfo) sig
          , Monad m
          )
       => Carrier (Abstract.Numeric Type :+: sig) (NumericC Type m) where
-  ret = NumericC . ret
+  eff (R other) = NumericC . eff . handleCoercible $ other
-  eff = NumericC . handleSum (eff . handleCoercible) (\case
+  eff (L op) = case op of
-    Abstract.Integer _ k -> runNumericC (k Int)
+    Abstract.Integer _ k -> k Int
-    Abstract.Float _ k -> runNumericC (k Float)
+    Abstract.Float _ k -> k Float
-    Abstract.Rational _ k -> runNumericC (k Rational)
+    Abstract.Rational _ k -> k Rational
-    Abstract.LiftNumeric _ t k -> unify (Int :+ Float :+ Rational) t >>= runNumericC . k
+    Abstract.LiftNumeric _ t k -> unify (Int :+ Float :+ Rational) t >>= k
     Abstract.LiftNumeric2 _ left right k -> case (left, right) of
-      (Float, Int) -> runNumericC (k Float)
+      (Float, Int) -> k Float
-      (Int, Float) -> runNumericC (k Float)
+      (Int, Float) -> k Float
-      _            -> unify left right >>= runNumericC . k)
+      _            -> unify left right >>= k
 
 instance ( Member (Reader ModuleInfo) sig
          , Member (Reader Span) sig
@@ -364,19 +355,19 @@ instance ( Member (Reader ModuleInfo) sig
          , Monad m
          )
       => Carrier (Abstract.Bitwise Type :+: sig) (BitwiseC Type m) where
-  ret = BitwiseC . ret
+  eff (R other) = BitwiseC . eff . handleCoercible $ other
-  eff = BitwiseC . handleSum (eff . handleCoercible) (\case
+  eff (L op) = case op of
-    CastToInteger t k -> unify t (Int :+ Float :+ Rational) >> runBitwiseC (k Int)
+    CastToInteger t k -> unify t (Int :+ Float :+ Rational) *> k Int
-    LiftBitwise _ t k -> unify t Int >>= runBitwiseC . k
+    LiftBitwise _ t k -> unify t Int >>= k
-    LiftBitwise2 _ t1 t2 k -> unify Int t1 >>= unify t2 >>= runBitwiseC . k
+    LiftBitwise2 _ t1 t2 k -> unify Int t1 >>= unify t2 >>= k
-    UnsignedRShift t1 t2 k -> unify Int t2 *> unify Int t1 >>= runBitwiseC . k)
+    UnsignedRShift t1 t2 k -> unify Int t2 *> unify Int t1 >>= k
 
 instance ( Carrier sig m ) => Carrier (Abstract.Object address Type :+: sig) (ObjectC address Type m) where
-  ret = ObjectC . ret
+  eff (R other) = ObjectC . eff . handleCoercible $ other
-  eff = ObjectC . handleSum (eff . handleCoercible) (\case
+  eff (L op) = case op of
-    Abstract.Object _ k -> runObjectC (k Object)
+    Abstract.Object _ k -> k Object
-    Abstract.ScopedEnvironment _ k -> runObjectC (k Nothing)
+    Abstract.ScopedEnvironment _ k -> k Nothing
-    Abstract.Klass _ _ k -> runObjectC (k Object))
+    Abstract.Klass _ _ k -> k Object
 
 instance ( Member Fresh sig
          , Member (Reader ModuleInfo) sig
@@ -387,21 +378,19 @@ instance ( Member Fresh sig
          , Monad m
          )
       => Carrier (Abstract.Array Type :+: sig) (ArrayC Type m) where
-  ret = ArrayC . ret
+  eff (R other) = ArrayC . eff . handleCoercible $ other
-  eff = ArrayC . handleSum (eff . handleCoercible) (\case
+  eff (L (Abstract.Array fieldTypes k)) = do
-    Abstract.Array fieldTypes k -> do
+    var <- fresh
-          var <- fresh
+    fieldType <- foldr (\ t1 -> (unify t1 =<<)) (pure (Var var)) fieldTypes
-          fieldType <- foldr (\ t1 -> (unify t1 =<<)) (pure (Var var)) fieldTypes
+    k (Array fieldType)
-          runArrayC (k (Array fieldType))
+  eff (L (Abstract.AsArray t k)) = do
-    Abstract.AsArray t k -> do
+    field <- fresh
-          field <- fresh
+    unify t (Array (Var field)) >> k mempty
-          unify t (Array (Var field)) >> runArrayC (k mempty))
 
 instance ( Carrier sig m ) => Carrier (Abstract.Hash Type :+: sig) (HashC Type m) where
-  ret = HashC . ret
+  eff (R other) = HashC . eff . handleCoercible $ other
-  eff = HashC . handleSum (eff . handleCoercible) (\case
+  eff (L (Abstract.Hash t k)) = k (Hash t)
-    Abstract.Hash t k -> runHashC (k (Hash t))
+  eff (L (Abstract.KvPair t1 t2 k)) = k (t1 :* t2)
-    Abstract.KvPair t1 t2 k -> runHashC (k (t1 :* t2)))
 
 
 instance AbstractHole Type where

src/Data/Graph.hs

@@ -49,7 +49,7 @@ topologicalSort = go . Class.toAdjacencyMap . G.transpose . unGraph
           . traverse_ visit
           . A.vertexList
           $ graph
-          where visit :: (Member (State (Visited v)) sig, Carrier sig m, Monad m) => v -> m ()
+          where visit :: (Member (State (Visited v)) sig, Carrier sig m) => v -> m ()
                 visit v = do
                   isMarked <- Set.member v . visitedVertices <$> get
                   if isMarked then

src/Data/Project.hs

@@ -58,7 +58,7 @@ newtype ProjectException
   = FileNotFound FilePath
     deriving (Show, Eq, Typeable, Exception)
 
-readFile :: (Member (Error SomeException) sig, Applicative m, Carrier sig m)
+readFile :: (Member (Error SomeException) sig, Carrier sig m)
          => Project
          -> File
          -> m (Maybe Blob)

src/Diffing/Algorithm.hs

@@ -47,13 +47,10 @@ instance Effect (Diff term1 term2 diff) where
   handle state handler = coerce . fmap (handler . (<$ state))
 
 
-newtype Algorithm term1 term2 diff m a = Algorithm { runAlgorithm :: Eff m a }
+newtype Algorithm term1 term2 diff m a = Algorithm { runAlgorithm :: m a }
-  deriving (Applicative, Functor, Monad)
+  deriving (Applicative, Alternative, Functor, Monad)
-
-deriving instance (Carrier sig m, Member NonDet sig) => Alternative (Algorithm term1 term2 diff m)
 
 instance Carrier sig m => Carrier sig (Algorithm term1 term2 diff m) where
-  ret = Algorithm . ret
   eff = Algorithm . eff . handleCoercible
 
 
@@ -61,7 +58,7 @@ instance Carrier sig m => Carrier sig (Algorithm term1 term2 diff m) where
 
 -- | Diff two terms without specifying the algorithm to be used.
 diff :: (Carrier sig m, Member (Diff term1 term2 diff) sig) => term1 -> term2 -> m diff
-diff a1 a2 = send (Diff a1 a2 ret)
+diff a1 a2 = send (Diff a1 a2 pure)
 
 -- | Diff a These of terms without specifying the algorithm to be used.
 diffThese :: (Carrier sig m, Member (Diff term1 term2 diff) sig) => These term1 term2 -> Algorithm term1 term2 diff m diff
@@ -76,30 +73,30 @@ diffMaybe _         _         = pure Nothing
 
 -- | Diff two terms linearly.
 linearly :: (Carrier sig m, Member (Diff term1 term2 diff) sig) => term1 -> term2 -> Algorithm term1 term2 diff m diff
-linearly f1 f2 = send (Linear f1 f2 ret)
+linearly f1 f2 = send (Linear f1 f2 pure)
 
 -- | Diff two terms using RWS.
 byRWS :: (Carrier sig m, Member (Diff term1 term2 diff) sig) => [term1] -> [term2] -> Algorithm term1 term2 diff m [diff]
-byRWS as1 as2 = send (RWS as1 as2 ret)
+byRWS as1 as2 = send (RWS as1 as2 pure)
 
 -- | Delete a term.
 byDeleting :: (Carrier sig m, Member (Diff term1 term2 diff) sig) => term1 -> Algorithm term1 term2 diff m diff
-byDeleting a1 = sendDiff (Delete a1 ret)
+byDeleting a1 = sendDiff (Delete a1 pure)
 
 -- | Insert a term.
 byInserting :: (Carrier sig m, Member (Diff term1 term2 diff) sig) => term2 -> Algorithm term1 term2 diff m diff
-byInserting a2 = sendDiff (Insert a2 ret)
+byInserting a2 = sendDiff (Insert a2 pure)
 
 -- | Replace one term with another.
 byReplacing :: (Carrier sig m, Member (Diff term1 term2 diff) sig) => term1 -> term2 -> Algorithm term1 term2 diff m diff
-byReplacing a1 a2 = send (Replace a1 a2 ret)
+byReplacing a1 a2 = send (Replace a1 a2 pure)
 
-sendDiff :: (Carrier sig m, Member (Diff term1 term2 diff) sig) => Diff term1 term2 diff (Eff m) (Eff m a) -> Algorithm term1 term2 diff m a
+sendDiff :: (Carrier sig m, Member (Diff term1 term2 diff) sig) => Diff term1 term2 diff m (m a) -> Algorithm term1 term2 diff m a
 sendDiff = Algorithm . send
 
 
 -- | Diff two terms based on their 'Diffable' instances, performing substructural comparisons iff the initial comparison fails.
-algorithmForTerms :: (Carrier sig m, Diffable syntax, Member (Diff (Term syntax ann1) (Term syntax ann2) (Diff.Diff syntax ann1 ann2)) sig, Member NonDet sig)
+algorithmForTerms :: (Carrier sig m, Diffable syntax, Member (Diff (Term syntax ann1) (Term syntax ann2) (Diff.Diff syntax ann1 ann2)) sig, Member NonDet sig, Alternative m)
                   => Term syntax ann1
                   -> Term syntax ann2
                   -> Algorithm (Term syntax ann1) (Term syntax ann2) (Diff.Diff syntax ann1 ann2) m (Diff.Diff syntax ann1 ann2)
@@ -142,12 +139,12 @@ instance Alternative Equivalence where
 -- | A type class for determining what algorithm to use for diffing two terms.
 class Diffable f where
   -- | Construct an algorithm to diff a pair of @f@s populated with disjoint terms.
-  algorithmFor :: (Carrier sig m, Member (Diff term1 term2 diff) sig, Member NonDet sig)
+  algorithmFor :: (Alternative m, Carrier sig m, Member (Diff term1 term2 diff) sig, Member NonDet sig)
                => f term1
                -> f term2
                -> Algorithm term1 term2 diff m (f diff)
   default
-    algorithmFor :: (Carrier sig m, Generic1 f, GDiffable (Rep1 f), Member (Diff term1 term2 diff) sig, Member NonDet sig)
+    algorithmFor :: (Alternative m, Carrier sig m, Generic1 f, GDiffable (Rep1 f), Member (Diff term1 term2 diff) sig, Member NonDet sig)
                  => f term1
                  -> f term2
                  -> Algorithm term1 term2 diff m (f diff)
@@ -190,7 +187,7 @@ class Diffable f where
   default comparableTo :: (Generic1 f, GDiffable (Rep1 f)) => f term1 -> f term2 -> Bool
   comparableTo = genericComparableTo
 
-genericAlgorithmFor :: (Carrier sig m, Generic1 f, GDiffable (Rep1 f), Member (Diff term1 term2 diff) sig, Member NonDet sig)
+genericAlgorithmFor :: (Alternative m, Carrier sig m, Generic1 f, GDiffable (Rep1 f), Member (Diff term1 term2 diff) sig, Member NonDet sig)
                     => f term1
                     -> f term2
                     -> Algorithm term1 term2 diff m (f diff)
@@ -238,7 +235,7 @@ instance Diffable NonEmpty where
 
 -- | A generic type class for diffing two terms defined by the Generic1 interface.
 class GDiffable f where
-  galgorithmFor :: (Carrier sig m, Member (Diff term1 term2 diff) sig, Member NonDet sig) => f term1 -> f term2 -> Algorithm term1 term2 diff m (f diff)
+  galgorithmFor :: (Alternative m, Carrier sig m, Member (Diff term1 term2 diff) sig, Member NonDet sig) => f term1 -> f term2 -> Algorithm term1 term2 diff m (f diff)
 
   gtryAlignWith :: Alternative g => (These a1 a2 -> g b) -> f a1 -> f a2 -> g (f b)
 

src/Diffing/Interpreter.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE LambdaCase, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving, TypeOperators, UndecidableInstances #-}
 module Diffing.Interpreter
 ( diffTerms
 , diffTermPair
@@ -7,6 +7,7 @@ module Diffing.Interpreter
 
 import Control.Effect
 import Control.Effect.Carrier
+import Control.Effect.Cull
 import Control.Effect.NonDet
 import Control.Effect.Sum
 import qualified Data.Diff as Diff
@@ -36,18 +37,18 @@ diffTermPair = these Diff.deleting Diff.inserting diffTerms
 
 
 -- | Run an 'Algorithm' to completion in an 'Alternative' context using the supplied comparability & equivalence relations.
-runDiff :: (Alternative m, Carrier sig m, Diffable syntax, Eq1 syntax, Member NonDet sig, Monad m, Traversable syntax)
+runDiff :: Algorithm
-        => Algorithm
              (Term syntax (FeatureVector, ann))
              (Term syntax (FeatureVector, ann))
              (Diff.Diff syntax (FeatureVector, ann) (FeatureVector, ann))
              (DiffC (Term syntax (FeatureVector, ann)) (Term syntax (FeatureVector, ann)) (Diff.Diff syntax (FeatureVector, ann) (FeatureVector, ann)) m)
              result
         -> m result
-runDiff = runDiffC . interpret . runAlgorithm
+runDiff = runDiffC . runAlgorithm
 
 
 newtype DiffC term1 term2 diff m a = DiffC { runDiffC :: m a }
+  deriving (Alternative, Applicative, Functor, Monad, MonadIO)
 
 instance ( Alternative m
          , Carrier sig m
@@ -60,11 +61,11 @@ instance ( Alternative m
       => Carrier
         (Diff (Term syntax (FeatureVector, ann)) (Term syntax (FeatureVector, ann)) (Diff.Diff syntax (FeatureVector, ann) (FeatureVector, ann)) :+: sig)
         (DiffC (Term syntax (FeatureVector, ann)) (Term syntax (FeatureVector, ann)) (Diff.Diff syntax (FeatureVector, ann) (FeatureVector, ann)) m) where
-  ret = DiffC . ret
+  eff (L op) = case op of
-  eff = DiffC . handleSum (eff . handleCoercible) (\case
+    Diff t1 t2 k -> runDiff (algorithmForTerms t1 t2) <|> pure (Diff.replacing t1 t2) >>= k
-    Diff t1 t2 k -> runDiff (algorithmForTerms t1 t2) <|> pure (Diff.replacing t1 t2) >>= runDiffC . k
+    Linear (Term (In ann1 f1)) (Term (In ann2 f2)) k -> Diff.merge (ann1, ann2) <$> tryAlignWith (runDiff . diffThese) f1 f2 >>= k
-    Linear (Term (In ann1 f1)) (Term (In ann2 f2)) k -> Diff.merge (ann1, ann2) <$> tryAlignWith (runDiff . diffThese) f1 f2 >>= runDiffC . k
+    RWS as bs k -> traverse (runDiff . diffThese) (rws comparableTerms equivalentTerms as bs) >>= k
-    RWS as bs k -> traverse (runDiff . diffThese) (rws comparableTerms equivalentTerms as bs) >>= runDiffC . k
+    Delete a k -> k (Diff.deleting a)
-    Delete a k -> runDiffC (k (Diff.deleting a))
+    Insert b k -> k (Diff.inserting b)
-    Insert b k -> runDiffC (k (Diff.inserting b))
+    Replace a b k -> k (Diff.replacing a b)
-    Replace a b k -> runDiffC (k (Diff.replacing a b)))
+  eff (R other) = DiffC . eff . handleCoercible $ other

src/Language/JSON/PrettyPrint.hs

@@ -19,7 +19,7 @@ import Data.Reprinting.Token
 import Data.Reprinting.Scope
 
 -- | Default printing pipeline for JSON.
-defaultJSONPipeline :: (Member (Error TranslationError) sig, Carrier sig m, Monad m)
+defaultJSONPipeline :: (Member (Error TranslationError) sig, Carrier sig m)
   => ProcessT m Fragment Splice
 defaultJSONPipeline
   = printingJSON
@@ -56,7 +56,7 @@ defaultBeautyOpts :: JSONBeautyOpts
 defaultBeautyOpts = JSONBeautyOpts 2 False
 
 -- | Produce JSON with configurable whitespace and layout.
-beautifyingJSON :: (Member (Error TranslationError) sig, Carrier sig m, Monad m)
+beautifyingJSON :: (Member (Error TranslationError) sig, Carrier sig m)
   => JSONBeautyOpts -> ProcessT m Fragment Splice
 beautifyingJSON _ = repeatedly (await >>= step) where
   step (Defer el cs)   = lift (throwError (NoTranslation el cs))
@@ -70,7 +70,7 @@ beautifyingJSON _ = repeatedly (await >>= step) where
     _                    -> emit txt
 
 -- | Produce whitespace minimal JSON.
-minimizingJSON :: (Member (Error TranslationError) sig, Carrier sig m, Monad m)
+minimizingJSON :: (Member (Error TranslationError) sig, Carrier sig m)
   => ProcessT m Fragment Splice
 minimizingJSON = repeatedly (await >>= step) where
   step (Defer el cs)  = lift (throwError (NoTranslation el cs))

src/Language/Python/PrettyPrint.hs

@@ -14,10 +14,10 @@ import Data.Reprinting.Scope
 import Data.Reprinting.Operator
 
 -- | Print Python syntax.
-printingPython :: (Member (Error TranslationError) sig, Carrier sig m, Monad m) => ProcessT m Fragment Splice
+printingPython :: (Member (Error TranslationError) sig, Carrier sig m) => ProcessT m Fragment Splice
 printingPython = repeatedly (await >>= step)
 
-step :: (Member (Error TranslationError) sig, Carrier sig m, Monad m) => Fragment -> PlanT k Splice m ()
+step :: (Member (Error TranslationError) sig, Carrier sig 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/PrettyPrint.hs

@@ -14,10 +14,10 @@ import Data.Reprinting.Splice
 import Data.Reprinting.Token as Token
 
 -- | Print Ruby syntax.
-printingRuby :: (Member (Error TranslationError) sig, Carrier sig m, Monad m) => ProcessT m Fragment Splice
+printingRuby :: (Member (Error TranslationError) sig, Carrier sig m) => ProcessT m Fragment Splice
 printingRuby = repeatedly (await >>= step)
 
-step :: (Member (Error TranslationError) sig, Carrier sig m, Monad m) => Fragment -> PlanT k Splice m ()
+step :: (Member (Error TranslationError) sig, Carrier sig 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/Rendering/Graph.hs

@@ -18,7 +18,7 @@ import Data.Patch
 import Data.String (IsString (..))
 import Data.Term
 import Prologue
-import Semantic.Api.Helpers
+import Semantic.Api.Bridge
 import Semantic.Api.V1.CodeAnalysisPB
 
 import qualified Data.Text as T
@@ -27,9 +27,8 @@ import qualified Data.Text as T
 renderTreeGraph :: (Ord vertex, Recursive t, ToTreeGraph vertex (Base t)) => t -> Graph vertex
 renderTreeGraph = simplify . runGraph . cata toTreeGraph
 
-runGraph :: Eff (ReaderC (Graph vertex)
+runGraph :: ReaderC (Graph vertex)
-           (Eff (FreshC
+           (FreshC VoidC) (Graph vertex)
-           (Eff VoidC)))) (Graph vertex)
          -> Graph vertex
 runGraph = run . runFresh . runReader mempty
 
@@ -54,7 +53,7 @@ diffStyle name = (defaultStyle (fromString . show . diffVertexId))
         vertexAttributes _ = []
 
 class ToTreeGraph vertex t | t -> vertex where
-  toTreeGraph :: (Member Fresh sig, Member (Reader (Graph vertex)) sig, Carrier sig m, Monad m) => t (m (Graph vertex)) -> m (Graph vertex)
+  toTreeGraph :: (Member Fresh sig, Member (Reader (Graph vertex)) sig, Carrier sig m) => t (m (Graph vertex)) -> m (Graph vertex)
 
 instance (ConstructorName syntax, Foldable syntax) =>
   ToTreeGraph TermVertex (TermF syntax Location) where
@@ -65,14 +64,13 @@ instance (ConstructorName syntax, Foldable syntax) =>
       , Member Fresh sig
       , Member (Reader (Graph TermVertex)) sig
       , Carrier sig m
-      , Monad m
       )
       => TermF syntax Location (m (Graph TermVertex))
       -> m (Graph TermVertex)
     termAlgebra (In ann syntax) = do
       i <- fresh
       parent <- ask
-      let root = vertex (TermVertex (fromIntegral i) (T.pack (constructorName syntax)) (spanToSpan (locationSpan ann)))
+      let root = vertex $ TermVertex (fromIntegral i) (T.pack (constructorName syntax)) (converting #? locationSpan ann)
       subGraph <- foldl' (\acc x -> overlay <$> acc <*> local (const root) x) (pure mempty) syntax
       pure (parent `connect` root `overlay` subGraph)
 
@@ -91,13 +89,12 @@ instance (ConstructorName syntax, Foldable syntax) =>
       graph <- local (const replace) (overlay <$> diffAlgebra t1 (Deleted (Just (DeletedTerm beforeName beforeSpan))) <*> diffAlgebra t2 (Inserted (Just (InsertedTerm afterName afterSpan))))
       pure (parent `connect` replace `overlay` graph)
     where
-      ann a = spanToSpan (locationSpan a)
+      ann a = converting #? locationSpan a
       diffAlgebra ::
         ( Foldable f
         , Member Fresh sig
         , Member (Reader (Graph DiffTreeVertex)) sig
         , Carrier sig m
-        , Monad m
         ) => f (m (Graph DiffTreeVertex)) -> DiffTreeVertexDiffTerm -> m (Graph DiffTreeVertex)
       diffAlgebra syntax a = do
         i <- fresh

src/Reprinting/Translate.hs

@@ -19,9 +19,8 @@ import           Data.Reprinting.Scope
 import qualified Data.Source as Source
 
 type Translator
-  = Eff (StateC [Scope]
+  = StateC [Scope]
-  ( Eff (ErrorC TranslationError
+  ( ErrorC TranslationError VoidC)
-  ( Eff VoidC))))
 
 contextualizing :: ProcessT Translator Token Fragment
 contextualizing = repeatedly $ await >>= \case

src/Semantic/AST.hs

@@ -27,7 +27,7 @@ data SomeAST where
 withSomeAST :: (forall grammar . Show grammar => AST [] grammar -> a) -> SomeAST -> a
 withSomeAST f (SomeAST ast) = f ast
 
-astParseBlob :: (Member (Error SomeException) sig, Member Task sig, Carrier sig m, Functor m) => Blob -> m SomeAST
+astParseBlob :: (Member (Error SomeException) sig, Member Task sig, Carrier sig m) => Blob -> m SomeAST
 astParseBlob blob@Blob{..}
   | Just (SomeASTParser parser) <- someASTParser blobLanguage = SomeAST <$> parse parser blob
   | otherwise = noLanguageForBlob blobPath

src/Semantic/Analysis.hs

@@ -17,36 +17,36 @@ import Prologue
 import qualified Data.Map.Strict as Map
 
 type ModuleC address value m
-  = ErrorC (LoopControl value)     (Eff
+  = ErrorC (LoopControl value)
-  ( ErrorC (Return value)          (Eff
+  ( ErrorC (Return value)
-  ( ReaderC (CurrentScope address) (Eff
+  ( ReaderC (CurrentScope address)
-  ( ReaderC (CurrentFrame address) (Eff
+  ( ReaderC (CurrentFrame address)
-  ( DerefC address value           (Eff
+  ( DerefC address value
-  ( AllocatorC address             (Eff
+  ( AllocatorC address
-  ( ReaderC ModuleInfo             (Eff
+  ( ReaderC ModuleInfo
-    m)))))))))))))
+    m))))))
 
 type DomainC term address value m
-  = FunctionC term address value                                          (Eff
+  = FunctionC term address value
-  ( WhileC value                                                          (Eff
+  ( WhileC value
-  ( BooleanC value                                                        (Eff
+  ( BooleanC value
-  ( StringC value                                                         (Eff
+  ( StringC value
-  ( NumericC value                                                        (Eff
+  ( NumericC value
-  ( BitwiseC value                                                        (Eff
+  ( BitwiseC value
-  ( ObjectC address value                                                 (Eff
+  ( ObjectC address value
-  ( ArrayC value                                                          (Eff
+  ( ArrayC value
-  ( HashC value                                                          (Eff
+  ( HashC value
-  ( UnitC value                                                           (Eff
+  ( UnitC value
-  ( InterposeC (Resumable (BaseError (UnspecializedError address value))) (Eff
+  ( InterposeC (Resumable (BaseError (UnspecializedError address value)))
-    m)))))))))))))))))))))
+    m))))))))))
 
 -- | Evaluate a list of modules with the prelude for the passed language available, and applying the passed function to every module.
 evaluate :: ( Carrier outerSig outer
             , derefSig ~ (Deref value :+: allocatorSig)
-            , derefC ~ (DerefC address value (Eff allocatorC))
+            , derefC ~ (DerefC address value allocatorC)
             , Carrier derefSig derefC
             , allocatorSig ~ (Allocator address :+: Reader ModuleInfo :+: outerSig)
-            , allocatorC ~ (AllocatorC address (Eff (ReaderC ModuleInfo (Eff outer))))
+            , allocatorC ~ (AllocatorC address (ReaderC ModuleInfo outer))
             , Carrier allocatorSig allocatorC
             , Effect outerSig
             , Member Fresh outerSig
@@ -86,35 +86,25 @@ evaluate lang runModule modules = do
                   . runModule
 
 runDomainEffects :: ( AbstractValue term address value (DomainC term address value m)
-                    , Carrier sig m
+                    , unitC ~ UnitC value (InterposeC (Resumable (BaseError (UnspecializedError address value))) m)
-                    , unitC ~ UnitC value (Eff (InterposeC (Resumable (BaseError (UnspecializedError address value))) (Eff m)))
                     , unitSig ~ (Unit value :+: Interpose (Resumable (BaseError (UnspecializedError address value))) :+: sig)
-                    , Carrier unitSig unitC
+                    , hashC ~ HashC value unitC
-                    , hashC ~ HashC value (Eff unitC)
                     , hashSig ~ (Abstract.Hash value :+: unitSig)
-                    , Carrier hashSig hashC
+                    , arrayC ~ ArrayC value hashC
-                    , arrayC ~ ArrayC value (Eff hashC)
                     , arraySig ~ (Abstract.Array value :+: hashSig)
-                    , Carrier arraySig arrayC
+                    , objectC ~ ObjectC address value arrayC
-                    , objectC ~ ObjectC address value (Eff arrayC)
                     , objectSig ~ (Abstract.Object address value :+: arraySig)
-                    , Carrier objectSig objectC
+                    , bitwiseC ~ BitwiseC value objectC
-                    , bitwiseC ~ BitwiseC value (Eff objectC)
                     , bitwiseSig ~ (Abstract.Bitwise value :+: objectSig)
-                    , Carrier bitwiseSig bitwiseC
+                    , numericC ~ NumericC value bitwiseC
-                    , numericC ~ NumericC value (Eff bitwiseC)
                     , numericSig ~ (Abstract.Numeric value :+: bitwiseSig)
-                    , Carrier numericSig numericC
+                    , stringC ~ StringC value numericC
-                    , stringC ~ StringC value (Eff numericC)
                     , stringSig ~ (Abstract.String value :+: numericSig)
-                    , Carrier stringSig stringC
+                    , booleanC ~ BooleanC value stringC
-                    , booleanC ~ BooleanC value (Eff stringC)
                     , booleanSig ~ (Boolean value :+: stringSig)
-                    , Carrier booleanSig booleanC
+                    , whileC ~ WhileC value booleanC
-                    , whileC ~ WhileC value (Eff booleanC)
                     , whileSig ~ (While value :+: booleanSig)
-                    , Carrier whileSig whileC
+                    , functionC ~ FunctionC term address value whileC
-                    , functionC ~ FunctionC term address value (Eff whileC)
                     , functionSig ~ (Function term address value :+: whileSig)
                     , Carrier functionSig functionC
                     , HasPrelude lang
@@ -128,7 +118,6 @@ runDomainEffects :: ( AbstractValue term address value (DomainC term address val
                     , Member (Resumable (BaseError (AddressError address value))) sig
                     , Member (Resumable (BaseError (HeapError address))) sig
                     , Member (Resumable (BaseError (ScopeError address))) sig
-                    , Member (Resumable (BaseError (UnspecializedError address value))) sig
                     , Member (State (Heap address address value)) sig
                     , Member (State (ScopeGraph address)) sig
                     , Member Trace sig

src/Semantic/Api/Bridge.hs

@@ -0,0 +1,114 @@
+{-# LANGUAGE FunctionalDependencies, LambdaCase #-}
+module Semantic.Api.Bridge
+  ( APIBridge (..)
+  , APIConvert (..)
+  , (#?)
+  ) where
+
+import           Control.Lens
+import qualified Data.Blob as Data
+import qualified Data.Language as Data
+import           Data.Source (fromText, toText)
+import qualified Data.Span as Data
+import qualified Data.Text as T
+import qualified Semantic.Api.LegacyTypes as Legacy
+import qualified Semantic.Api.V1.CodeAnalysisPB as API
+
+-- | An @APIBridge x y@ instance describes an isomorphism between @x@ and @y@.
+-- This is suitable for types such as 'Pos' which are representationally equivalent
+-- in their API, legacy, and native forms. All 'Lens' laws apply.
+--
+-- Foreign to native: @x^.bridging@
+-- Native to foreign: @bridging # x@
+-- Native to 'Just' foreign: @bridging #? x@.
+-- 'Maybe' foreign to 'Maybe' native: @x >>= preview bridging@
+class APIBridge api native | api -> native where
+  bridging :: Iso' api native
+
+-- | An @APIConvert x y@ instance describes a partial isomorphism between @x@ and @y@.
+-- This is suitable for types containing nested records therein, such as 'Span'.
+-- (The isomorphism must be partial, given that a protobuf record can have Nothing
+-- for all its fields, which means we cannot convert to a native format.)
+--
+-- Foreign to native: this is a type error, unless the native is a Monoid
+-- Foreign to 'Maybe' native: @x^?converting@
+-- Native to foreign: @converting # x@
+-- Native to 'Just' foreign: @converting #? x@
+class APIConvert api native | api -> native where
+  converting :: Prism' api native
+
+-- | A helper function for turning 'bridging' around and
+-- extracting 'Just' values from it.
+(#?) :: AReview t s -> s -> Maybe t
+rev #? item = item ^? re rev
+infixr 8 #?
+
+instance APIBridge Legacy.Position Data.Pos where
+  bridging = iso fromAPI toAPI where
+    toAPI Data.Pos{..}          = Legacy.Position posLine posColumn
+    fromAPI Legacy.Position{..} = Data.Pos line column
+
+instance APIBridge API.Position Data.Pos where
+  bridging = iso fromAPI toAPI where
+    toAPI Data.Pos{..}          = API.Position (fromIntegral posLine) (fromIntegral posColumn)
+    fromAPI API.Position{..}    = Data.Pos (fromIntegral line) (fromIntegral column)
+
+instance APIConvert API.Span Data.Span where
+  converting = prism' toAPI fromAPI where
+    toAPI Data.Span{..} = API.Span (bridging #? spanStart) (bridging #? spanEnd)
+    fromAPI API.Span{..} = Data.Span <$> (start >>= preview bridging) <*> (end >>= preview bridging)
+
+instance APIConvert Legacy.Span Data.Span where
+  converting = prism' toAPI fromAPI where
+    toAPI Data.Span{..} = Legacy.Span (bridging #? spanStart) (bridging #? spanEnd)
+    fromAPI Legacy.Span {..} = Data.Span <$> (start >>= preview bridging) <*> (end >>= preview bridging)
+
+instance APIBridge API.Language Data.Language where
+  bridging = iso apiLanguageToLanguage languageToApiLanguage where
+    languageToApiLanguage :: Data.Language -> API.Language
+    languageToApiLanguage = \case
+      Data.Unknown -> API.Unknown
+      Data.Go -> API.Go
+      Data.Haskell -> API.Haskell
+      Data.Java -> API.Java
+      Data.JavaScript -> API.Javascript
+      Data.JSON -> API.Json
+      Data.JSX -> API.Jsx
+      Data.Markdown -> API.Markdown
+      Data.Python -> API.Python
+      Data.Ruby -> API.Ruby
+      Data.TypeScript -> API.Typescript
+      Data.PHP -> API.Php
+
+    apiLanguageToLanguage :: API.Language -> Data.Language
+    apiLanguageToLanguage = \case
+      API.Unknown -> Data.Unknown
+      API.Go -> Data.Go
+      API.Haskell -> Data.Haskell
+      API.Java -> Data.Java
+      API.Javascript -> Data.JavaScript
+      API.Json -> Data.JSON
+      API.Jsx -> Data.JSX
+      API.Markdown -> Data.Markdown
+      API.Python -> Data.Python
+      API.Ruby -> Data.Ruby
+      API.Typescript -> Data.TypeScript
+      API.Php -> Data.PHP
+
+instance APIBridge API.Blob Data.Blob where
+  bridging = iso apiBlobToBlob blobToApiBlob where
+    blobToApiBlob Data.Blob{..} = API.Blob (toText blobSource) (T.pack blobPath) (bridging # blobLanguage)
+    apiBlobToBlob API.Blob{..} = Data.Blob (fromText content) (T.unpack path) (language ^. bridging)
+
+
+instance APIConvert API.BlobPair Data.BlobPair where
+  converting = prism' blobPairToApiBlobPair apiBlobPairToBlobPair where
+
+    apiBlobPairToBlobPair (API.BlobPair (Just before) (Just after)) = Just $ Data.Diffing (before^.bridging) (after^.bridging)
+    apiBlobPairToBlobPair (API.BlobPair (Just before) Nothing) = Just $ Data.Deleting (before^.bridging)
+    apiBlobPairToBlobPair (API.BlobPair Nothing (Just after)) = Just $ Data.Inserting (after^.bridging)
+    apiBlobPairToBlobPair _ = Nothing
+
+    blobPairToApiBlobPair (Data.Diffing before after) = API.BlobPair (bridging #? before) (bridging #? after)
+    blobPairToApiBlobPair (Data.Inserting after)      = API.BlobPair Nothing (bridging #? after)
+    blobPairToApiBlobPair (Data.Deleting before)      = API.BlobPair (bridging #? before) Nothing

src/Semantic/Api/Diffs.hs

@@ -16,6 +16,7 @@ import           Analysis.TOCSummary (HasDeclaration)
 import           Control.Effect
 import           Control.Effect.Error
 import           Control.Exception
+import           Control.Lens
 import           Control.Monad.IO.Class
 import           Data.Blob
 import           Data.ByteString.Builder
@@ -33,7 +34,7 @@ import           Prologue
 import           Rendering.Graph
 import           Rendering.JSON hiding (JSON)
 import qualified Rendering.JSON
-import           Semantic.Api.Helpers
+import           Semantic.Api.Bridge
 import           Semantic.Api.V1.CodeAnalysisPB hiding (Blob, BlobPair, Language(..))
 import           Semantic.Task as Task
 import           Semantic.Telemetry as Stat
@@ -75,7 +76,7 @@ diffGraph blobs = DiffTreeGraphResponse . V.fromList . toList <$> distributeFor
         pure (DiffTreeFileGraph path lang mempty mempty (V.fromList [ParseError (T.pack (show e))]))
       where
         path = T.pack $ pathForBlobPair blobPair
-        lang = languageToApiLanguage $ languageForBlobPair blobPair
+        lang = bridging # languageForBlobPair blobPair
 
         render :: (Foldable syntax, Functor syntax, ConstructorName syntax, Applicative m) => BlobPair -> Diff syntax Location Location -> m DiffTreeFileGraph
         render _ diff =
@@ -124,7 +125,7 @@ diffTerms blobs terms = time "diff" languageTag $ do
   diff <$ writeStat (Stat.count "diff.nodes" (bilength diff) languageTag)
   where languageTag = languageTagForBlobPair blobs
 
-doParse :: (Member (Error SomeException) sig, Member Distribute sig, Member Task sig, Carrier sig m, Monad m)
+doParse :: (Member (Error SomeException) sig, Member Distribute sig, Member Task sig, Carrier sig m)
   => BlobPair -> Decorate m Location ann -> m (SomeTermPair TermPairConstraints ann)
 doParse blobPair decorate = case languageForBlobPair blobPair of
   Go         -> SomeTermPair <$> distributeFor blobPair (\ blob -> parse goParser blob >>= decorate blob)

src/Semantic/Api/Helpers.hs

@@ -1,88 +0,0 @@
-{-# LANGUAGE LambdaCase #-}
-module Semantic.Api.Helpers
-  ( spanToSpan
-  , spanToLegacySpan
-  , toChangeType
-  , languageToApiLanguage
-  , apiSpanToSpan
-  , apiLanguageToLanguage
-  , apiBlobsToBlobs
-  , apiBlobToBlob
-  , apiBlobPairsToBlobPairs
-  , apiBlobPairToBlobPair
-  ) where
-
-import qualified Data.Blob as Data
-import qualified Data.Language as Data
-import           Data.Source (fromText)
-import qualified Data.Span as Data
-import qualified Data.Text as T
-import qualified Data.Vector as V
-import qualified Semantic.Api.LegacyTypes as Legacy
-import qualified Semantic.Api.V1.CodeAnalysisPB as API
-
-spanToSpan :: Data.Span -> Maybe API.Span
-spanToSpan Data.Span{..} = Just $ API.Span (toPos spanStart) (toPos spanEnd)
-  where toPos Data.Pos{..} = Just $ API.Position (fromIntegral posLine) (fromIntegral posColumn)
-
-spanToLegacySpan :: Data.Span -> Maybe Legacy.Span
-spanToLegacySpan Data.Span{..} = Just $ Legacy.Span (toPos spanStart) (toPos spanEnd)
-  where toPos Data.Pos{..} = Just $ Legacy.Position posLine posColumn
-
-apiSpanToSpan :: Maybe API.Span -> Data.Span
-apiSpanToSpan (Just API.Span{..}) = Data.Span (toPos start) (toPos end)
-  where toPos (Just API.Position{..}) = Data.Pos (fromIntegral line) (fromIntegral column)
-        toPos Nothing = Data.Pos 1 1
-apiSpanToSpan Nothing = Data.emptySpan
-
-toChangeType :: T.Text -> API.ChangeType
-toChangeType = \case
-  "added" -> API.Added
-  "modified" -> API.Modified
-  "removed" -> API.Removed
-  _ -> API.None
-
-languageToApiLanguage :: Data.Language -> API.Language
-languageToApiLanguage = \case
-  Data.Unknown -> API.Unknown
-  Data.Go -> API.Go
-  Data.Haskell -> API.Haskell
-  Data.Java -> API.Java
-  Data.JavaScript -> API.Javascript
-  Data.JSON -> API.Json
-  Data.JSX -> API.Jsx
-  Data.Markdown -> API.Markdown
-  Data.Python -> API.Python
-  Data.Ruby -> API.Ruby
-  Data.TypeScript -> API.Typescript
-  Data.PHP -> API.Php
-
-apiLanguageToLanguage :: API.Language -> Data.Language
-apiLanguageToLanguage = \case
-  API.Unknown -> Data.Unknown
-  API.Go -> Data.Go
-  API.Haskell -> Data.Haskell
-  API.Java -> Data.Java
-  API.Javascript -> Data.JavaScript
-  API.Json -> Data.JSON
-  API.Jsx -> Data.JSX
-  API.Markdown -> Data.Markdown
-  API.Python -> Data.Python
-  API.Ruby -> Data.Ruby
-  API.Typescript -> Data.TypeScript
-  API.Php -> Data.PHP
-
-apiBlobsToBlobs :: V.Vector API.Blob -> [Data.Blob]
-apiBlobsToBlobs = V.toList . fmap apiBlobToBlob
-
-apiBlobToBlob :: API.Blob -> Data.Blob
-apiBlobToBlob API.Blob{..} = Data.Blob (fromText content) (T.unpack path) (apiLanguageToLanguage language)
-
-apiBlobPairsToBlobPairs :: V.Vector API.BlobPair -> [Data.BlobPair]
-apiBlobPairsToBlobPairs = V.toList . fmap apiBlobPairToBlobPair
-
-apiBlobPairToBlobPair :: API.BlobPair -> Data.BlobPair
-apiBlobPairToBlobPair (API.BlobPair (Just before) (Just after)) = Data.Diffing (apiBlobToBlob before) (apiBlobToBlob after)
-apiBlobPairToBlobPair (API.BlobPair (Just before) Nothing) = Data.Deleting (apiBlobToBlob before)
-apiBlobPairToBlobPair (API.BlobPair Nothing (Just after)) = Data.Inserting (apiBlobToBlob after)
-apiBlobPairToBlobPair _ = Prelude.error "Expected BlobPair to have either 'before' and/or 'after'."

src/Semantic/Api/Symbols.hs

@@ -10,6 +10,7 @@ import Prelude hiding (span)
 import           Control.Effect
 import           Control.Effect.Error
 import           Control.Exception
+import           Control.Lens
 import           Data.Blob
 import           Data.ByteString.Builder
 import           Data.Location
@@ -20,7 +21,7 @@ import qualified Data.Vector as V
 import           Data.Text (pack)
 import           Parsing.Parser
 import           Prologue
-import           Semantic.Api.Helpers
+import           Semantic.Api.Bridge
 import qualified Semantic.Api.LegacyTypes as Legacy
 import           Semantic.Api.Terms (ParseEffects, doParse)
 import           Semantic.Api.V1.CodeAnalysisPB hiding (Blob)
@@ -32,7 +33,7 @@ import           Tags.Tagging
 legacyParseSymbols :: (Member Distribute sig, ParseEffects sig m, Traversable t) => t Blob -> m Legacy.ParseTreeSymbolResponse
 legacyParseSymbols blobs = Legacy.ParseTreeSymbolResponse <$> distributeFoldMap go blobs
   where
-    go :: (Member (Error SomeException) sig, Member Task sig, Carrier sig m, Monad m) => Blob -> m [Legacy.File]
+    go :: (Member (Error SomeException) sig, Member Task sig, Carrier sig m) => Blob -> m [Legacy.File]
     go blob@Blob{..} = (doParse blob >>= withSomeTerm (renderToSymbols blob)) `catchError` (\(SomeException _) -> pure (pure emptyFile))
       where emptyFile = Legacy.File (pack blobPath) (pack (show blobLanguage)) []
 
@@ -48,7 +49,7 @@ legacyParseSymbols blobs = Legacy.ParseTreeSymbolResponse <$> distributeFoldMap
       { symbolName = name
       , symbolKind = kind
       , symbolLine = fromMaybe mempty line
-      , symbolSpan = spanToLegacySpan span
+      , symbolSpan = converting #? span
       }
 
 parseSymbolsBuilder :: (Member Distribute sig, ParseEffects sig m, Traversable t) => t Blob -> m Builder
@@ -57,16 +58,16 @@ parseSymbolsBuilder blobs = parseSymbols blobs >>= serialize JSON
 parseSymbols :: (Member Distribute sig, ParseEffects sig m, Traversable t) => t Blob -> m ParseTreeSymbolResponse
 parseSymbols blobs = ParseTreeSymbolResponse . V.fromList . toList <$> distributeFor blobs go
   where
-    go :: (Member (Error SomeException) sig, Member Task sig, Carrier sig m, Monad m) => Blob -> m File
+    go :: (Member (Error SomeException) sig, Member Task sig, Carrier sig m) => Blob -> m File
     go blob@Blob{..} = (doParse blob >>= withSomeTerm (renderToSymbols blob)) `catchError` (\(SomeException e) -> pure $ errorFile (show e))
       where
-        errorFile e = File (pack blobPath) (languageToApiLanguage blobLanguage) mempty (V.fromList [ParseError (T.pack e)])
+        errorFile e = File (pack blobPath) (bridging # blobLanguage) mempty (V.fromList [ParseError (T.pack e)])
 
         renderToSymbols :: (IsTaggable f, Applicative m) => Blob -> Term f Location -> m File
         renderToSymbols blob@Blob{..} term = pure $ either (errorFile . show) (tagsToFile blob) (runTagging blob term)
 
         tagsToFile :: Blob -> [Tag] -> File
-        tagsToFile Blob{..} tags = File (pack blobPath) (languageToApiLanguage blobLanguage) (V.fromList (fmap tagToSymbol tags)) mempty
+        tagsToFile Blob{..} tags = File (pack blobPath) (bridging # blobLanguage) (V.fromList (fmap tagToSymbol tags)) mempty
 
         tagToSymbol :: Tag -> Symbol
         tagToSymbol Tag{..}
@@ -74,6 +75,6 @@ parseSymbols blobs = ParseTreeSymbolResponse . V.fromList . toList <$> distribut
           { symbol = name
           , kind = kind
           , line = fromMaybe mempty line
-          , span = spanToSpan span
+          , span = converting #? span
           , docs = fmap Docstring docs
           }

src/Semantic/Api/TOCSummaries.hs

@@ -1,8 +1,9 @@
-{-# LANGUAGE GADTs, TypeOperators, DerivingStrategies #-}
+{-# LANGUAGE GADTs, TypeOperators, DerivingStrategies, LambdaCase #-}
 module Semantic.Api.TOCSummaries (diffSummary, legacyDiffSummary, diffSummaryBuilder) where
 
 import           Analysis.TOCSummary (Declaration, declarationAlgebra)
 import           Control.Effect.Error
+import           Control.Lens
 import           Data.Aeson
 import           Data.Blob
 import           Data.ByteString.Builder
@@ -13,7 +14,7 @@ import qualified Data.Text as T
 import qualified Data.Vector as V
 import           Rendering.TOC
 import           Semantic.Api.Diffs
-import           Semantic.Api.Helpers
+import           Semantic.Api.Bridge
 import           Semantic.Api.V1.CodeAnalysisPB hiding (Blob, BlobPair)
 import           Semantic.Task as Task
 import           Serializing.Format
@@ -42,16 +43,22 @@ diffSummary blobs = DiffTreeTOCResponse . V.fromList <$> distributeFor blobs go
       `catchError` \(SomeException e) ->
         pure $ TOCSummaryFile path lang mempty (V.fromList [TOCSummaryError (T.pack (show e)) Nothing])
       where path = T.pack $ pathKeyForBlobPair blobPair
-            lang = languageToApiLanguage $ languageForBlobPair blobPair
+            lang = bridging # languageForBlobPair blobPair
 
     render :: (Foldable syntax, Functor syntax, Applicative m) => BlobPair -> Diff syntax (Maybe Declaration) (Maybe Declaration) -> m TOCSummaryFile
     render blobPair diff = pure $ foldr go (TOCSummaryFile path lang mempty mempty) (diffTOC diff)
       where
         path = T.pack $ pathKeyForBlobPair blobPair
-        lang = languageToApiLanguage $ languageForBlobPair blobPair
+        lang = bridging # languageForBlobPair blobPair
+
+        toChangeType = \case
+          "added" -> Added
+          "modified" -> Modified
+          "removed" -> Removed
+          _ -> None
 
         go :: TOCSummary -> TOCSummaryFile -> TOCSummaryFile
         go TOCSummary{..} TOCSummaryFile{..}
-          = TOCSummaryFile path language (V.cons (TOCSummaryChange summaryCategoryName summaryTermName (spanToSpan summarySpan) (toChangeType summaryChangeType)) changes) errors
+          = TOCSummaryFile path language (V.cons (TOCSummaryChange summaryCategoryName summaryTermName (converting #? summarySpan) (toChangeType summaryChangeType)) changes) errors
         go ErrorSummary{..} TOCSummaryFile{..}
-          = TOCSummaryFile path language changes (V.cons (TOCSummaryError errorText (spanToSpan errorSpan)) errors)
+          = TOCSummaryFile path language changes (V.cons (TOCSummaryError errorText (converting #? errorSpan)) errors)

src/Semantic/Api/Terms.hs

@@ -17,6 +17,7 @@ module Semantic.Api.Terms
 import           Analysis.ConstructorName (ConstructorName)
 import           Control.Effect
 import           Control.Effect.Error
+import           Control.Lens
 import           Control.Monad
 import           Control.Monad.IO.Class
 import           Data.Abstract.Declarations
@@ -36,7 +37,7 @@ import           Prologue
 import           Rendering.Graph
 import           Rendering.JSON hiding (JSON)
 import qualified Rendering.JSON
-import           Semantic.Api.Helpers
+import           Semantic.Api.Bridge
 import           Semantic.Api.V1.CodeAnalysisPB hiding (Blob, Language (..))
 import           Semantic.Task
 import           Serializing.Format hiding (JSON)
@@ -52,7 +53,7 @@ termGraph blobs = ParseTreeGraphResponse . V.fromList . toList <$> distributeFor
         pure (ParseTreeFileGraph path lang mempty mempty (V.fromList [ParseError (T.pack (show e))]))
       where
         path = T.pack $ blobPath blob
-        lang = languageToApiLanguage $ blobLanguage blob
+        lang = bridging # blobLanguage blob
 
         render :: (Foldable syntax, Functor syntax, ConstructorName syntax) => Term syntax Location -> ParseTreeFileGraph
         render t = let graph = renderTreeGraph t
@@ -101,7 +102,7 @@ quietTerm blob = showTiming blob <$> time' ( (doParse blob >>= withSomeTerm (fma
       in stringUtf8 (status <> "\t" <> show blobLanguage <> "\t" <> blobPath <> "\t" <> show duration <> " ms\n")
 
 
-type ParseEffects sig m = (Member (Error SomeException) sig, Member Task sig, Carrier sig m, Monad m)
+type ParseEffects sig m = (Member (Error SomeException) sig, Member Task sig, Carrier sig m)
 
 type TermConstraints =
  '[ Taggable

src/Semantic/Distribute.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE ExistentialQuantification, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE ExistentialQuantification, GeneralizedNewtypeDeriving, TypeOperators, UndecidableInstances #-}
 module Semantic.Distribute
 ( distribute
 , distributeFor
@@ -18,19 +18,19 @@ import           Prologue
 -- | Distribute a 'Traversable' container of tasks over the available cores (i.e. execute them concurrently), collecting their results.
 --
 --   This is a concurrent analogue of 'sequenceA'.
-distribute :: (Member Distribute sig, Traversable t, Carrier sig m, Applicative m) => t (m output) -> m (t output)
+distribute :: (Member Distribute sig, Traversable t, Carrier sig m) => t (m output) -> m (t output)
-distribute = fmap (withStrategy (parTraversable rseq)) <$> traverse (send . flip Distribute ret)
+distribute = fmap (withStrategy (parTraversable rseq)) <$> traverse (send . flip Distribute pure)
 
 -- | 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 sig, Traversable t, Carrier sig m, Applicative m) => t a -> (a -> m output) -> m (t output)
+distributeFor :: (Member Distribute sig, Traversable t, Carrier sig 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 sig, Monoid output, Traversable t, Carrier sig m, Applicative m) => (a -> m output) -> t a -> m output
+distributeFoldMap :: (Member Distribute sig, Monoid output, Traversable t, Carrier sig m) => (a -> m output) -> t a -> m output
 distributeFoldMap toTask inputs = fmap fold (distribute (fmap toTask inputs))
 
 
@@ -48,13 +48,12 @@ instance Effect Distribute where
 
 
 -- | Evaluate a 'Distribute' effect concurrently.
-runDistribute :: Eff (DistributeC (Eff (LiftC IO))) a -> Eff (LiftC IO) a
+runDistribute :: DistributeC (LiftC IO) a -> LiftC IO a
-runDistribute = runDistributeC . interpret
+runDistribute = runDistributeC
 
 newtype DistributeC m a = DistributeC { runDistributeC :: m a }
+  deriving (Functor, Applicative, Monad, MonadIO)
 
-instance Carrier (Distribute :+: Lift IO) (DistributeC (Eff (LiftC IO))) where
+instance Carrier (Distribute :+: Lift IO) (DistributeC (LiftC IO)) where
-  ret = DistributeC . ret
+  eff (L (Distribute task k)) = liftIO (Async.runConcurrently (Async.Concurrently (runM . runDistributeC $ task))) >>= k
-  eff = DistributeC . handleSum
+  eff (R other) = DistributeC (eff (handleCoercible other))
-    (eff . handleCoercible)
-    (\ (Distribute task k) -> liftIO (Async.runConcurrently (Async.Concurrently (runM (runDistributeC task)))) >>= runDistributeC . k)

src/Semantic/Graph.hs

@@ -82,7 +82,7 @@ runGraph :: ( Member Distribute sig
          => GraphType
          -> Bool
          -> Project
-         -> Eff m (Graph ControlFlowVertex)
+         -> 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
@@ -112,7 +112,7 @@ runCallGraph :: ( VertexDeclarationWithStrategy (VertexDeclarationStrategy synta
              -> Bool
              -> [Module term]
              -> Package term
-             -> Eff m (Graph ControlFlowVertex)
+             -> m (Graph ControlFlowVertex)
 runCallGraph lang includePackages modules package
   = fmap (simplify . fst)
   . runEvaluator
@@ -140,8 +140,7 @@ runCallGraph lang includePackages modules package
         perModule = (if includePackages then graphingPackages else id) . convergingModules . graphingModules $ runDomainEffects perTerm
 
 
-runModuleTable :: Carrier sig m
+runModuleTable :: Evaluator term address value (ReaderC (ModuleTable (Module (ModuleResult address value))) m) a
-               => Evaluator term address value (ReaderC (ModuleTable (Module (ModuleResult address value))) (Eff m)) a
                -> Evaluator term address value m a
 runModuleTable = raiseHandler $ runReader lowerBound
 
@@ -159,7 +158,7 @@ runImportGraphToModuleInfos :: ( Declarations term
                                )
                             => Proxy lang
                             -> Package term
-                            -> Eff m (Graph ControlFlowVertex)
+                            -> m (Graph ControlFlowVertex)
 runImportGraphToModuleInfos lang (package :: Package term) = runImportGraph lang package allModuleInfos
   where allModuleInfos info = vertex (maybe (unknownModuleVertex info) (moduleVertex . moduleInfo) (ModuleTable.lookup (modulePath info) (packageModules package)))
 
@@ -177,7 +176,7 @@ runImportGraphToModules :: ( Declarations term
                            )
                         => Proxy lang
                         -> Package term
-                        -> Eff m (Graph (Module term))
+                        -> m (Graph (Module term))
 runImportGraphToModules lang (package :: Package term) = runImportGraph lang package resolveOrLowerBound
   where resolveOrLowerBound info = maybe lowerBound vertex (ModuleTable.lookup (modulePath info) (packageModules package))
 
@@ -196,7 +195,7 @@ runImportGraph :: ( AccessControls term
                => Proxy lang
                -> Package term
                -> (ModuleInfo -> Graph vertex)
-               -> Eff m (Graph vertex)
+               -> m (Graph vertex)
 runImportGraph lang (package :: Package term) f
   = fmap (fst >=> f)
   . runEvaluator @_ @_ @(Value _ (Hole (Maybe Name) Precise))
@@ -220,18 +219,17 @@ runImportGraph lang (package :: Package term) f
   . runAllocator
   $ evaluate lang (graphingModuleInfo (runDomainEffects (evalTerm id))) (snd <$> ModuleTable.toPairs (packageModules package))
 
-runHeap :: (Carrier sig m, Effect sig)
+runHeap :: Evaluator term address value (StateC (Heap address address value) m) a
-        => Evaluator term address value (StateC (Heap address address value) (Eff m)) a
         -> Evaluator term address value m (Heap address address value, a)
 runHeap = raiseHandler (runState lowerBound)
 
-runScopeGraph :: (Carrier sig m, Effect sig, Ord address)
+runScopeGraph :: Ord address
-        => Evaluator term address value (StateC (ScopeGraph address) (Eff m)) a
+              => Evaluator term address value (StateC (ScopeGraph address) m) a
-        -> Evaluator term address value m (ScopeGraph address, a)
+              -> Evaluator term address value m (ScopeGraph address, a)
 runScopeGraph = raiseHandler (runState lowerBound)
 
 -- | Parse a list of files into a 'Package'.
-parsePackage :: (Member Distribute sig, Member (Error SomeException) sig, Member Resolution sig, Member Task sig, Member Trace sig, Carrier sig m, Monad m)
+parsePackage :: (Member Distribute sig, Member (Error SomeException) sig, Member Resolution sig, Member Task sig, Member Trace sig, Carrier sig m)
              => Parser term -- ^ A parser.
              -> Project     -- ^ Project to parse into a package.
              -> m (Package (Blob, term))
@@ -245,7 +243,7 @@ parsePackage parser project = do
     n = Data.Abstract.Evaluatable.name (projectName project) -- TODO: Confirm this is the right `name`.
 
 -- | Parse all files in a project into 'Module's.
-parseModules :: (Member Distribute sig, Member (Error SomeException) sig, Member Task sig, Carrier sig m, Monad m) => Parser term -> Project -> m [Module (Blob, term)]
+parseModules :: (Member Distribute sig, Member (Error SomeException) sig, Member Task sig, Carrier sig m) => Parser term -> Project -> m [Module (Blob, term)]
 parseModules parser p@Project{..} = distributeFor (projectFiles p) (parseModule p parser)
 
 
@@ -267,7 +265,7 @@ parsePythonPackage :: forall syntax sig m term.
                    )
                    => Parser term      -- ^ A parser.
                    -> Project          -- ^ Project to parse into a package.
-                   -> Eff m (Package term)
+                   -> m (Package term)
 parsePythonPackage parser project = do
   let runAnalysis = runEvaluator @_ @_ @(Value term (Hole (Maybe Name) Precise))
         . raiseHandler (runState PythonPackage.Unknown)
@@ -321,7 +319,7 @@ parsePythonPackage parser project = do
         resMap <- Task.resolutionMap p
         pure (Package.fromModules (Data.Abstract.Evaluatable.name $ projectName p) modules resMap) -- TODO: Confirm this is the right `name`.
 
-parseModule :: (Member (Error SomeException) sig, Member Task sig, Carrier sig m, Monad m)
+parseModule :: (Member (Error SomeException) sig, Member Task sig, Carrier sig m)
             => Project
             -> Parser term
             -> File
@@ -347,19 +345,20 @@ withTermSpans recur term = let
 resumingResolutionError :: ( Member Trace sig
                            , Carrier sig m
                            )
-                         => Evaluator term address value (ResumableWithC (BaseError ResolutionError) (Eff
+                         => Evaluator term address value (ResumableWithC (BaseError ResolutionError) m) a
-                                                         m)) a
                          -> Evaluator term address value m a
-resumingResolutionError = runResolutionErrorWith (\ baseError -> traceError "ResolutionError" baseError *> case baseErrorException baseError of
+resumingResolutionError = runResolutionErrorWith $ \ baseError -> do
-  NotFoundError nameToResolve _ _ -> pure  nameToResolve
+  traceError "ResolutionError" baseError
-  GoImportError pathToResolve     -> pure [pathToResolve])
+  case baseErrorException baseError of
+    NotFoundError nameToResolve _ _ -> pure nameToResolve
+    GoImportError pathToResolve     -> pure [pathToResolve]
 
 resumingLoadError :: ( Carrier sig m
                      , Member Trace sig
                      , AbstractHole value
                      , AbstractHole address
                      )
-                  => Evaluator term address value (ResumableWithC (BaseError (LoadError address value)) (Eff m)) a
+                  => Evaluator term address value (ResumableWithC (BaseError (LoadError address value)) m) a
                   -> Evaluator term address value m a
 resumingLoadError = runLoadErrorWith (\ baseError -> traceError "LoadError" baseError *> case baseErrorException baseError of
   ModuleNotFoundError _ -> pure ((hole, hole), hole))
@@ -372,8 +371,7 @@ resumingEvalError :: ( Carrier sig m
                      , AbstractHole address
                      , AbstractHole value
                      )
-                  => Evaluator term address value (ResumableWithC (BaseError (EvalError term address value)) (Eff
+                  => Evaluator term address value (ResumableWithC (BaseError (EvalError term address value)) m) a
-                                                  m)) a
                   -> Evaluator term address value m a
 resumingEvalError = runEvalErrorWith (\ baseError -> traceError "EvalError" baseError *> case baseErrorException baseError of
   AccessControlError{}  -> pure hole
@@ -393,8 +391,7 @@ resumingUnspecialized :: ( AbstractHole address
                          , Carrier sig m
                          , Member Trace sig
                          )
-                      => Evaluator term address value (ResumableWithC (BaseError (UnspecializedError address value)) (Eff
+                      => Evaluator term address value (ResumableWithC (BaseError (UnspecializedError address value)) m) a
-                                                      m)) a
                       -> Evaluator term address value m a
 resumingUnspecialized = runUnspecializedWith (\ baseError -> traceError "UnspecializedError" baseError *> case baseErrorException baseError of
   UnspecializedError _ -> pure hole
@@ -405,20 +402,20 @@ resumingAddressError :: ( AbstractHole value
                         , Member Trace sig
                         , Show address
                         )
-                     => Evaluator term address value (ResumableWithC (BaseError (AddressError address value)) (Eff
+                     => Evaluator term address value (ResumableWithC (BaseError (AddressError address value)) m) a
-                                                     m)) a
                      -> Evaluator term address value m a
-resumingAddressError = runAddressErrorWith $ \ baseError -> traceError "AddressError" baseError *> case baseErrorException baseError of
+resumingAddressError = runAddressErrorWith $ \ baseError -> do
-  UnallocatedSlot   _ -> pure lowerBound
+  traceError "AddressError" baseError
-  UninitializedSlot _ -> pure hole
+  case baseErrorException baseError of
+    UnallocatedSlot   _ -> pure lowerBound
+    UninitializedSlot _ -> pure hole
 
 resumingValueError :: ( Carrier sig m
                       , Member Trace sig
                       , Show address
                       , Show term
                       )
-                   => Evaluator term address (Value term address) (ResumableWithC (BaseError (ValueError term address)) (Eff
+                   => Evaluator term address (Value term address) (ResumableWithC (BaseError (ValueError term address)) m) a
-                                                                  m)) a
                    -> Evaluator term address (Value term address) m a
 resumingValueError = runValueErrorWith (\ baseError -> traceError "ValueError" baseError *> case baseErrorException baseError of
   CallError{}       -> pure hole
@@ -440,7 +437,7 @@ resumingHeapError :: ( Carrier sig m
                      , Member Trace sig
                      , Show address
                      )
-                  => Evaluator term address value (ResumableWithC (BaseError (HeapError address)) (Eff m)) a
+                  => Evaluator term address value (ResumableWithC (BaseError (HeapError address)) m) a
                   -> Evaluator term address value m a
 resumingHeapError = runHeapErrorWith (\ baseError -> traceError "ScopeError" baseError *> case baseErrorException baseError of
     CurrentFrameError -> pure hole
@@ -458,7 +455,7 @@ resumingScopeError :: ( Carrier sig m
                      , AbstractHole (Info address)
                      , AbstractHole address
                      )
-                    => Evaluator term address value (ResumableWithC (BaseError (ScopeError address)) (Eff m)) a
+                    => Evaluator term address value (ResumableWithC (BaseError (ScopeError address)) m) a
                     -> Evaluator term address value m a
 resumingScopeError = runScopeErrorWith (\ baseError -> traceError "ScopeError" baseError *> case baseErrorException baseError of
   ScopeError _ _ -> pure hole
@@ -470,13 +467,13 @@ resumingScopeError = runScopeErrorWith (\ baseError -> traceError "ScopeError" b
   DeclarationByNameError _ -> pure hole)
 
 resumingTypeError :: ( Carrier sig m
-                     , Member NonDet sig
                      , Member Trace sig
                      , Effect sig
+                     , Alternative m
                      )
-                  => Evaluator term address Type (ResumableWithC (BaseError TypeError) (Eff
+                  => Evaluator term address Type (ResumableWithC (BaseError TypeError)
-                                                 (StateC TypeMap (Eff
+                                                 (StateC TypeMap
-                                                 m)))) a
+                                                 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

src/Semantic/REPL.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE GADTs, LambdaCase, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, TypeOperators, UndecidableInstances #-}
 {-# OPTIONS_GHC -Wno-missing-signatures #-}
 module Semantic.REPL
 ( rubyREPL
@@ -100,20 +100,23 @@ repl proxy parser paths =
 -- TODO: drive the flow from within the REPL instead of from without
 
 
-runTelemetryIgnoringStat :: (Carrier sig m, MonadIO m) => LogOptions -> Eff (TelemetryIgnoringStatC m) a -> m a
+runTelemetryIgnoringStat :: LogOptions -> TelemetryIgnoringStatC m a -> m a
-runTelemetryIgnoringStat logOptions = flip runTelemetryIgnoringStatC logOptions . interpret
+runTelemetryIgnoringStat logOptions = runReader logOptions . runTelemetryIgnoringStatC
 
-newtype TelemetryIgnoringStatC m a = TelemetryIgnoringStatC { runTelemetryIgnoringStatC :: LogOptions -> m a }
+newtype TelemetryIgnoringStatC m a = TelemetryIgnoringStatC { runTelemetryIgnoringStatC :: ReaderC LogOptions m a }
+  deriving (Applicative, Functor, Monad, MonadIO)
 
 instance (Carrier sig m, MonadIO m) => Carrier (Telemetry :+: sig) (TelemetryIgnoringStatC m) where
-  ret = TelemetryIgnoringStatC . const . ret
+  eff (R other) = TelemetryIgnoringStatC . eff . R . handleCoercible $ other
-  eff op = TelemetryIgnoringStatC (\ logOptions -> handleSum (eff . handleReader logOptions runTelemetryIgnoringStatC) (\case
+  eff (L op) = do
-    WriteStat _                  k -> runTelemetryIgnoringStatC k logOptions
+    logOptions <- TelemetryIgnoringStatC ask
-    WriteLog level message pairs k -> do
+    case op of
-      time <- liftIO Time.getCurrentTime
+      WriteStat _                  k -> k
-      zonedTime <- liftIO (LocalTime.utcToLocalZonedTime time)
+      WriteLog level message pairs k -> do
-      writeLogMessage logOptions (Message level message pairs zonedTime)
+        time <- liftIO Time.getCurrentTime
-      runTelemetryIgnoringStatC k logOptions) op)
+        zonedTime <- liftIO (LocalTime.utcToLocalZonedTime time)
+        writeLogMessage logOptions (Message level message pairs zonedTime)
+        k
 
 step :: ( Member (Error SomeException) sig
         , Member REPL sig

src/Semantic/Resolution.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE ConstraintKinds, GADTs, KindSignatures, LambdaCase, ScopedTypeVariables, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE ConstraintKinds, GADTs, GeneralizedNewtypeDeriving, KindSignatures, ScopedTypeVariables, TypeOperators, UndecidableInstances #-}
 module Semantic.Resolution
   ( Resolution (..)
   , nodeJSResolutionMap
@@ -24,7 +24,7 @@ import           Semantic.Task.Files
 import           System.FilePath.Posix
 
 
-nodeJSResolutionMap :: (Member Files sig, Carrier sig m, Monad m) => FilePath -> Text -> [FilePath] -> m (Map FilePath FilePath)
+nodeJSResolutionMap :: (Member Files sig, Carrier sig 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
@@ -41,9 +41,9 @@ nodeJSResolutionMap rootDir prop excludeDirs = do
 
 resolutionMap :: (Member Resolution sig, Carrier sig m) => Project -> m (Map FilePath FilePath)
 resolutionMap Project{..} = case projectLanguage of
-  TypeScript -> send (NodeJSResolution projectRootDir "types" projectExcludeDirs ret)
+  TypeScript -> send (NodeJSResolution projectRootDir "types" projectExcludeDirs pure)
-  JavaScript -> send (NodeJSResolution projectRootDir "main"  projectExcludeDirs ret)
+  JavaScript -> send (NodeJSResolution projectRootDir "main"  projectExcludeDirs pure)
-  _          -> send (NoResolution ret)
+  _          -> send (NoResolution pure)
 
 data Resolution (m :: * -> *) k
   = NodeJSResolution FilePath Text [FilePath] (Map FilePath FilePath -> k)
@@ -57,13 +57,14 @@ instance Effect Resolution where
   handle state handler (NodeJSResolution path key paths k) = NodeJSResolution path key paths (handler . (<$ state) . k)
   handle state handler (NoResolution k) = NoResolution (handler . (<$ state) . k)
 
-runResolution :: (Member Files sig, Carrier sig m, Monad m) => Eff (ResolutionC m) a -> m a
+runResolution :: ResolutionC m a -> m a
-runResolution = runResolutionC . interpret
+runResolution = runResolutionC
 
 newtype ResolutionC m a = ResolutionC { runResolutionC :: m a }
+  deriving (Applicative, Functor, Monad, MonadIO)
 
-instance (Member Files sig, Carrier sig m, Monad m) => Carrier (Resolution :+: sig) (ResolutionC m) where
+instance (Member Files sig, Carrier sig m) => Carrier (Resolution :+: sig) (ResolutionC m) where
-  ret = ResolutionC . ret
+  eff (R other) = ResolutionC . eff . handleCoercible $ other
-  eff = ResolutionC . handleSum (eff . handleCoercible) (\case
+  eff (L op) = case op of
-    NodeJSResolution dir prop excludeDirs k -> nodeJSResolutionMap dir prop excludeDirs >>= runResolutionC . k
+    NodeJSResolution dir prop excludeDirs k -> nodeJSResolutionMap dir prop excludeDirs >>= k
-    NoResolution                          k -> runResolutionC (k Map.empty))
+    NoResolution                          k -> k Map.empty

src/Semantic/Task.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE ConstraintKinds, ExistentialQuantification, GADTs, KindSignatures, LambdaCase, ScopedTypeVariables, StandaloneDeriving, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE ConstraintKinds, ExistentialQuantification, GADTs, GeneralizedNewtypeDeriving, KindSignatures, ScopedTypeVariables, StandaloneDeriving, TypeOperators, UndecidableInstances #-}
 module Semantic.Task
 ( Task
 , TaskEff
@@ -47,7 +47,6 @@ module Semantic.Task
 , ParserCancelled(..)
 -- * Re-exports
 , Distribute
-, Eff
 , Error
 , Lift
 , throwError
@@ -95,17 +94,17 @@ import           Serializing.Format hiding (Options)
 
 -- | 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 (TaskC
+  = TaskC
-  ( Eff (ResolutionC
+  ( ResolutionC
-  ( Eff (Files.FilesC
+  ( Files.FilesC
-  ( Eff (ReaderC TaskSession
+  ( ReaderC TaskSession
-  ( Eff (TraceInTelemetryC
+  ( TraceInTelemetryC
-  ( Eff (TelemetryC
+  ( TelemetryC
-  ( Eff (ErrorC SomeException
+  ( ErrorC SomeException
-  ( Eff (TimeoutC
+  ( TimeoutC
-  ( Eff (ResourceC
+  ( ResourceC
-  ( Eff (DistributeC
+  ( DistributeC
-  ( Eff (LiftC IO)))))))))))))))))))))
+  ( LiftC IO))))))))))
 
 -- | A function to render terms or diffs.
 type Renderer i o = i -> o
@@ -115,40 +114,40 @@ parse :: (Member Task sig, Carrier sig m)
       => Parser term
       -> Blob
       -> m term
-parse parser blob = send (Parse parser blob ret)
+parse parser blob = send (Parse parser blob pure)
 
 -- | A task running some 'Analysis.Evaluator' to completion.
 analyze :: (Member Task sig, Carrier sig m)
         => (Analysis.Evaluator term address value m a -> result)
         -> Analysis.Evaluator term address value m a
         -> m result
-analyze interpret analysis = send (Analyze interpret analysis ret)
+analyze interpret analysis = send (Analyze interpret analysis pure)
 
 -- | A task which decorates a 'Term' with values computed using the supplied 'RAlgebra' function.
 decorate :: (Functor f, Member Task sig, Carrier sig m)
          => RAlgebra (TermF f Location) (Term f Location) field
          -> Term f Location
          -> m (Term f field)
-decorate algebra term = send (Decorate algebra term ret)
+decorate algebra term = send (Decorate algebra term pure)
 
 -- | A task which diffs a pair of terms using the supplied 'Differ' function.
 diff :: (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax, Member Task sig, Carrier sig m)
      => These (Term syntax ann) (Term syntax ann)
      -> m (Diff syntax ann ann)
-diff terms = send (Semantic.Task.Diff terms ret)
+diff terms = send (Semantic.Task.Diff terms pure)
 
 -- | A task which renders some input using the supplied 'Renderer' function.
 render :: (Member Task sig, Carrier sig m)
        => Renderer input output
        -> input
        -> m output
-render renderer input = send (Render renderer input ret)
+render renderer input = send (Render renderer input pure)
 
 serialize :: (Member Task sig, Carrier sig m)
           => Format input
           -> input
           -> m Builder
-serialize format input = send (Serialize format input ret)
+serialize format input = send (Serialize format input pure)
 
 data TaskSession
   = TaskSession
@@ -191,18 +190,16 @@ withOptions options with = do
   config <- defaultConfig options
   withTelemetry config (\ (TelemetryQueues logger statter _) -> with config logger statter)
 
-runTraceInTelemetry :: (Member Telemetry sig, Carrier sig m, Monad m)
+runTraceInTelemetry :: TraceInTelemetryC m a
-                    => Eff (TraceInTelemetryC m) a
                     -> m a
-runTraceInTelemetry = runTraceInTelemetryC . interpret
+runTraceInTelemetry = runTraceInTelemetryC
 
 newtype TraceInTelemetryC m a = TraceInTelemetryC { runTraceInTelemetryC :: m a }
+  deriving (Applicative, Functor, Monad, MonadIO)
 
-instance (Member Telemetry sig, Carrier sig m, Monad m) => Carrier (Trace :+: sig) (TraceInTelemetryC m) where
+instance (Member Telemetry sig, Carrier sig m) => Carrier (Trace :+: sig) (TraceInTelemetryC m) where
-  ret = TraceInTelemetryC . ret
+  eff (R other) = TraceInTelemetryC . eff . handleCoercible $ other
-  eff = TraceInTelemetryC . handleSum
+  eff (L (Trace str k)) = writeLog Debug str [] >> k
-    (eff . handleCoercible)
-    (\ (Trace str k) -> writeLog Debug str [] >> runTraceInTelemetryC k)
 
 
 -- | An effect describing high-level tasks to be performed.
@@ -228,33 +225,23 @@ instance Effect Task where
   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 (Error SomeException) sig
+runTaskF :: TaskC m a -> m a
-            , Member (Lift IO) sig
+runTaskF = runTaskC
-            , Member (Reader TaskSession) sig
-            , Member Resource sig
-            , Member Telemetry sig
-            , Member Timeout sig
-            , Member Trace sig
-            , Carrier sig m
-            , MonadIO m
-            )
-         => Eff (TaskC m) a
-         -> m a
-runTaskF = runTaskC . interpret
 
 newtype TaskC m a = TaskC { runTaskC :: m a }
+  deriving (Applicative, Functor, Monad, MonadIO)
 
 instance (Member (Error SomeException) sig, Member (Lift IO) sig, Member (Reader TaskSession) 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 (R other) = TaskC . eff . handleCoercible $ other
-  eff = TaskC . handleSum (eff . handleCoercible) (\case
+  eff (L op) = case op of
-    Parse parser blob k -> runParser blob parser >>= runTaskC . k
+    Parse parser blob k -> runParser blob parser >>= k
-    Analyze interpret analysis k -> runTaskC (k (interpret analysis))
+    Analyze interpret analysis k -> k . interpret $ analysis
-    Decorate algebra term k -> runTaskC (k (decoratorWithAlgebra algebra term))
+    Decorate algebra term k -> k (decoratorWithAlgebra algebra term)
-    Semantic.Task.Diff terms k -> runTaskC (k (diffTermPair terms))
+    Semantic.Task.Diff terms k -> k (diffTermPair terms)
-    Render renderer input k -> runTaskC (k (renderer input))
+    Render renderer input k -> k (renderer input)
     Serialize format input k -> do
       formatStyle <- asks (bool Plain Colourful . configIsTerminal . config)
-      runTaskC (k (runSerialize formatStyle format input)))
+      k (runSerialize formatStyle format input)
 
 
 -- | Log an 'Error.Error' at the specified 'Level'.

src/Semantic/Task/Files.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE ExistentialQuantification, GADTs, LambdaCase, KindSignatures, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE ExistentialQuantification, GADTs, GeneralizedNewtypeDeriving, KindSignatures, TypeOperators, UndecidableInstances #-}
 
 module Semantic.Task.Files
   ( Files
@@ -59,46 +59,47 @@ instance Effect Files where
   handle state handler (Write destination builder k) = Write destination builder (handler (k <$ state))
 
 -- | Run a 'Files' effect in 'IO'.
-runFiles :: (Member (Error SomeException) sig, MonadIO m, Carrier sig m) => Eff (FilesC m) a -> m a
+runFiles :: FilesC m a -> m a
-runFiles = runFilesC . interpret
+runFiles = runFilesC
 
 newtype FilesC m a = FilesC { runFilesC :: m a }
+  deriving (Functor, Applicative, Monad, MonadIO)
 
 instance (Member (Error SomeException) sig, MonadIO m, Carrier sig m) => Carrier (Files :+: sig) (FilesC m) where
-  ret = FilesC . ret
+  eff (L op) = case op of
-  eff = FilesC . handleSum (eff . handleCoercible) (\case
+    Read (FromPath path) k -> (readBlobFromFile' path `catchIO` (throwError . toException @SomeException)) >>= k
-    Read (FromPath path) k -> (readBlobFromFile' path `catchIO` (throwError . toException @SomeException)) >>= runFilesC . k
+    Read (FromHandle handle) k -> (readBlobsFromHandle handle  `catchIO` (throwError . toException @SomeException)) >>= k
-    Read (FromHandle handle) k -> (readBlobsFromHandle handle  `catchIO` (throwError . toException @SomeException)) >>= runFilesC . k
+    Read (FromPathPair paths) k -> (runBothWith readFilePair paths `catchIO` (throwError . toException @SomeException)) >>= k
-    Read (FromPathPair paths) k -> (runBothWith readFilePair paths `catchIO` (throwError . toException @SomeException)) >>= runFilesC . k
+    Read (FromPairHandle handle) k -> (readBlobPairsFromHandle handle `catchIO` (throwError . toException @SomeException)) >>= 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)) >>= 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)) >>= 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)) >> 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) >> k
-    Write (ToHandle (WriteHandle handle)) builder k -> liftIO (B.hPutBuilder handle builder) >> runFilesC k)
+  eff (R other) = FilesC (eff (handleCoercible other))
 
 
 readBlob :: (Member Files sig, Carrier sig m) => File -> m Blob
-readBlob file = send (Read (FromPath file) ret)
+readBlob file = send (Read (FromPath file) pure)
 
 -- | A task which reads a list of 'Blob's from a 'Handle' or a list of 'FilePath's optionally paired with 'Language's.
-readBlobs :: (Member Files sig, Carrier sig m, Applicative m) => Either (Handle 'IO.ReadMode) [File] -> m [Blob]
+readBlobs :: (Member Files sig, Carrier sig m) => Either (Handle 'IO.ReadMode) [File] -> m [Blob]
-readBlobs (Left handle) = send (Read (FromHandle handle) ret)
+readBlobs (Left handle) = send (Read (FromHandle handle) pure)
-readBlobs (Right paths) = traverse (send . flip Read ret . FromPath) paths
+readBlobs (Right paths) = traverse (send . flip Read pure . FromPath) paths
 
 -- | A task which reads a list of pairs of 'Blob's from a 'Handle' or a list of pairs of 'FilePath's optionally paired with 'Language's.
-readBlobPairs :: (Member Files sig, Carrier sig m, Applicative m) => Either (Handle 'IO.ReadMode) [Both File] -> m [BlobPair]
+readBlobPairs :: (Member Files sig, Carrier sig m) => Either (Handle 'IO.ReadMode) [Both File] -> m [BlobPair]
-readBlobPairs (Left handle) = send (Read (FromPairHandle handle) ret)
+readBlobPairs (Left handle) = send (Read (FromPairHandle handle) pure)
-readBlobPairs (Right paths) = traverse (send . flip Read ret . FromPathPair) paths
+readBlobPairs (Right paths) = traverse (send . flip Read pure . FromPathPair) paths
 
 readProject :: (Member Files sig, Carrier sig m) => Maybe FilePath -> FilePath -> Language -> [FilePath] -> m Project
-readProject rootDir dir lang excludeDirs = send (ReadProject rootDir dir lang excludeDirs ret)
+readProject rootDir dir lang excludeDirs = send (ReadProject rootDir dir lang excludeDirs pure)
 
 findFiles :: (Member Files sig, Carrier sig m) => FilePath -> [String] -> [FilePath] -> m [FilePath]
-findFiles dir exts paths = send (FindFiles dir exts paths ret)
+findFiles dir exts paths = send (FindFiles dir exts paths pure)
 
 -- | A task which writes a 'B.Builder' to a 'Handle' or a 'FilePath'.
 write :: (Member Files sig, Carrier sig m) => Destination -> B.Builder -> m ()
-write dest builder = send (Write dest builder (ret ()))
+write dest builder = send (Write dest builder (pure ()))
 
 
 -- | Generalize 'Exc.catch' to other 'MonadIO' contexts for the handler and result.

src/Semantic/Telemetry.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE GADTs, KindSignatures, LambdaCase, RankNTypes, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE DerivingStrategies, GADTs, GeneralizedNewtypeDeriving, KindSignatures, RankNTypes, TypeOperators, UndecidableInstances #-}
 module Semantic.Telemetry
 (
   -- Async telemetry interface
@@ -52,6 +52,7 @@ module Semantic.Telemetry
 
 import           Control.Effect
 import           Control.Effect.Carrier
+import           Control.Effect.Reader
 import           Control.Effect.Sum
 import           Control.Exception
 import           Control.Monad.IO.Class
@@ -121,11 +122,11 @@ queueStat q = liftIO . writeAsyncQueue q
 
 -- | A task which logs a message at a specific log level to stderr.
 writeLog :: (Member Telemetry sig, Carrier sig m) => Level -> String -> [(String, String)] -> m ()
-writeLog level message pairs = send (WriteLog level message pairs (ret ()))
+writeLog level message pairs = send (WriteLog level message pairs (pure ()))
 
 -- | A task which writes a stat.
 writeStat :: (Member Telemetry sig, Carrier sig m) => Stat -> m ()
-writeStat stat = send (WriteStat stat (ret ()))
+writeStat stat = send (WriteStat stat (pure ()))
 
 -- | A task which measures and stats the timing of another task.
 time :: (Member Telemetry sig, Carrier sig m, MonadIO m) => String -> [(String, String)] -> m output -> m output
@@ -151,26 +152,28 @@ instance Effect Telemetry where
   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 :: (Carrier sig m, MonadIO m) => LogQueue -> StatQueue -> Eff (TelemetryC m) a -> m a
+runTelemetry :: LogQueue -> StatQueue -> TelemetryC m a -> m a
-runTelemetry logger statter = flip runTelemetryC (logger, statter) . interpret
+runTelemetry logger statter = runReader (logger, statter) . runTelemetryC
 
-newtype TelemetryC m a = TelemetryC { runTelemetryC :: (LogQueue, StatQueue) -> m a }
+newtype TelemetryC m a = TelemetryC { runTelemetryC :: ReaderC (LogQueue, StatQueue) m a }
+  deriving (Applicative, Functor, Monad, MonadIO)
 
 instance (Carrier sig m, MonadIO m) => Carrier (Telemetry :+: sig) (TelemetryC m) where
-  ret = TelemetryC . const . ret
+  eff (L op) = do
-  eff op = TelemetryC (\ queues -> handleSum (eff . handleReader queues runTelemetryC) (\case
+    queues <- TelemetryC ask
-    WriteStat stat               k -> queueStat (snd queues) stat *> runTelemetryC k queues
+    case op of
-    WriteLog level message pairs k -> queueLogMessage (fst queues) level message pairs *> runTelemetryC k queues) op)
+      WriteStat stat k               -> queueStat (snd queues) stat *> k
-
+      WriteLog level message pairs k -> queueLogMessage (fst queues) level message pairs *> k
+  eff (R other) = TelemetryC (eff (R (handleCoercible other)))
 
 -- | Run a 'Telemetry' effect by ignoring statting/logging.
-ignoreTelemetry :: Carrier sig m => Eff (IgnoreTelemetryC m) a -> m a
+ignoreTelemetry :: IgnoreTelemetryC m a -> m a
-ignoreTelemetry = runIgnoreTelemetryC . interpret
+ignoreTelemetry = runIgnoreTelemetryC
 
 newtype IgnoreTelemetryC m a = IgnoreTelemetryC { runIgnoreTelemetryC :: m a }
+  deriving (Applicative, Functor, Monad)
 
 instance Carrier sig m => Carrier (Telemetry :+: sig) (IgnoreTelemetryC m) where
-  ret = IgnoreTelemetryC . ret
+  eff (R other) = IgnoreTelemetryC . eff . handleCoercible $ other
-  eff = handleSum (IgnoreTelemetryC . eff . handlePure runIgnoreTelemetryC) (\case
+  eff (L (WriteStat _ k))    = k
-    WriteStat _    k -> k
+  eff (L (WriteLog _ _ _ k)) = k
-    WriteLog _ _ _ k -> k)

src/Semantic/Timeout.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE ExistentialQuantification, TypeOperators, RankNTypes, UndecidableInstances #-}
+{-# LANGUAGE ExistentialQuantification, GeneralizedNewtypeDeriving, TypeOperators, RankNTypes, UndecidableInstances #-}
 module Semantic.Timeout
 ( timeout
 , Timeout
@@ -9,6 +9,7 @@ module Semantic.Timeout
 
 import           Control.Effect
 import           Control.Effect.Carrier
+import           Control.Effect.Reader
 import           Control.Effect.Sum
 import           Control.Monad.IO.Class
 import           Data.Duration
@@ -18,7 +19,7 @@ import qualified System.Timeout as System
 -- within the specified duration. Uses 'System.Timeout.timeout' so all caveats
 -- about not operating over FFI boundaries apply.
 timeout :: (Member Timeout sig, Carrier sig m) => Duration -> m output -> m (Maybe output)
-timeout n = send . flip (Timeout n) ret
+timeout n = send . flip (Timeout n) pure
 
 -- | 'Timeout' effects run other effects, aborting them if they exceed the
 -- specified duration.
@@ -33,20 +34,22 @@ instance HFunctor Timeout where
 instance Effect Timeout where
   handle state handler (Timeout n task k) = Timeout n (handler (task <$ state)) (handler . maybe (k Nothing <$ state) (fmap (k . Just)))
 
--- | Evaulate a 'Timeoute' effect.
+-- | Evaulate a 'Timeout' effect.
-runTimeout :: (Carrier sig m, MonadIO m)
+runTimeout :: (forall x . m x -> IO x)
-           => (forall x . m x -> IO x)
+           -> TimeoutC m a
-           -> Eff (TimeoutC m) a
            -> m a
-runTimeout handler = runTimeoutC handler . interpret
+runTimeout handler = runReader (Handler handler) . runTimeoutC
 
-newtype TimeoutC m a = TimeoutC ((forall x . m x -> IO x) -> m a)
+newtype Handler m = Handler (forall x . m x -> IO x)
 
-runTimeoutC :: (forall x . m x -> IO x) -> TimeoutC m a -> m a
+runHandler :: Handler m -> TimeoutC m a -> IO a
-runTimeoutC f (TimeoutC m) = m f
+runHandler h@(Handler handler) = handler . runReader h . runTimeoutC
+
+newtype TimeoutC m a = TimeoutC { runTimeoutC :: ReaderC (Handler m) m a }
+  deriving (Functor, Applicative, Monad, MonadIO)
 
 instance (Carrier sig m, MonadIO m) => Carrier (Timeout :+: sig) (TimeoutC m) where
-  ret a = TimeoutC (const (ret a))
+  eff (L (Timeout n task k)) = do
-  eff op = TimeoutC (\ handler -> handleSum
+    handler <- TimeoutC ask
-    (eff . handlePure (runTimeoutC handler))
+    liftIO (System.timeout (toMicroseconds n) (runHandler handler task)) >>= k
-    (\ (Timeout n task k) -> liftIO (System.timeout (toMicroseconds n) (handler (runTimeoutC handler task))) >>= runTimeoutC handler . k) op)
+  eff (R other) = TimeoutC (eff (R (handleCoercible other)))

src/Semantic/Util.hs

@@ -58,40 +58,30 @@ justEvaluating :: Evaluator
                         (Value term Precise)
                         (ResumableC
                            (BaseError (ValueError term Precise))
-                           (Eff
                               (ResumableC
                                  (BaseError (AddressError Precise (Value term Precise)))
-                                 (Eff
                                     (ResumableC
                                        (BaseError ResolutionError)
-                                       (Eff
                                           (ResumableC
                                              (BaseError
                                                 (EvalError term Precise (Value term Precise)))
-                                             (Eff
                                                 (ResumableC
                                                    (BaseError (HeapError Precise))
-                                                   (Eff
                                                       (ResumableC
                                                          (BaseError (ScopeError Precise))
-                                                         (Eff
                                                             (ResumableC
                                                                (BaseError
                                                                   (UnspecializedError
                                                                      Precise (Value term Precise)))
-                                                               (Eff
                                                                   (ResumableC
                                                                      (BaseError
                                                                         (LoadError
                                                                            Precise
                                                                            (Value term Precise)))
-                                                                     (Eff
                                                                         (FreshC
-                                                                           (Eff
                                                                               (StateC
                                                                                  (ScopeGraph
                                                                                     Precise)
-                                                                                 (Eff
                                                                                     (StateC
                                                                                        (Heap
                                                                                           Precise
@@ -99,11 +89,9 @@ justEvaluating :: Evaluator
                                                                                           (Value
                                                                                              term
                                                                                              Precise))
-                                                                                       (Eff
                                                                                           (TraceByPrintingC
-                                                                                             (Eff
                                                                                                 (LiftC
-                                                                                                   IO)))))))))))))))))))))))))
+                                                                                                   IO)))))))))))))
                         result
                       -> IO
                            (Heap Precise Precise (Value term Precise),
@@ -148,18 +136,18 @@ justEvaluatingCatchingErrors :: ( hole ~ Hole (Maybe Name) Precise
        value
        (ResumableWithC
           (BaseError (ValueError term hole))
-          (Eff (ResumableWithC (BaseError (AddressError hole value))
+          (ResumableWithC (BaseError (AddressError hole value))
-          (Eff (ResumableWithC (BaseError ResolutionError)
+          (ResumableWithC (BaseError ResolutionError)
-          (Eff (ResumableWithC (BaseError (EvalError term hole value))
+          (ResumableWithC (BaseError (EvalError term hole value))
-          (Eff (ResumableWithC (BaseError (HeapError hole))
+          (ResumableWithC (BaseError (HeapError hole))
-          (Eff (ResumableWithC (BaseError (ScopeError hole))
+          (ResumableWithC (BaseError (ScopeError hole))
-          (Eff (ResumableWithC (BaseError (UnspecializedError hole value))
+          (ResumableWithC (BaseError (UnspecializedError hole value))
-          (Eff (ResumableWithC (BaseError (LoadError hole value))
+          (ResumableWithC (BaseError (LoadError hole value))
-          (Eff (FreshC
+          (FreshC
-          (Eff (StateC (ScopeGraph hole)
+          (StateC (ScopeGraph hole)
-          (Eff (StateC (Heap hole hole (Concrete.Value (Quieterm (Sum lang) Location) (Hole (Maybe Name) Precise)))
+          (StateC (Heap hole hole (Concrete.Value (Quieterm (Sum lang) Location) (Hole (Maybe Name) Precise)))
-          (Eff (TraceByPrintingC
+          (TraceByPrintingC
-          (Eff (LiftC IO))))))))))))))))))))))))) a
+          (LiftC IO))))))))))))) a
      -> IO (Heap hole hole value, (ScopeGraph hole, a))
 justEvaluatingCatchingErrors
   = runM
@@ -185,84 +173,66 @@ checking
        (ResumableC
           (BaseError
              Type.TypeError)
-          (Eff
              (StateC
                 Type.TypeMap
-                (Eff
                    (ResumableC
                       (BaseError
                          (AddressError
                             Monovariant
                             Type.Type))
-                      (Eff
                          (ResumableC
                             (BaseError
                                (EvalError
                                   term
                                   Monovariant
                                   Type.Type))
-                            (Eff
                                (ResumableC
                                   (BaseError
                                      ResolutionError)
-                                  (Eff
                                      (ResumableC
                                         (BaseError
                                            (HeapError
                                               Monovariant))
-                                        (Eff
                                            (ResumableC
                                               (BaseError
                                                  (ScopeError
                                                     Monovariant))
-                                              (Eff
                                                  (ResumableC
                                                     (BaseError
                                                        (UnspecializedError
                                                           Monovariant
                                                           Type.Type))
-                                                    (Eff
                                                        (ResumableC
                                                           (BaseError
                                                              (LoadError
                                                                 Monovariant
                                                                 Type.Type))
-                                                          (Eff
                                                              (ReaderC
                                                                 (Live
                                                                    Monovariant)
-                                                                (Eff
+                                                                   (NonDetC
-                                                                   (AltC
-                                                                      []
-                                                                      (Eff
                                                                          (ReaderC
                                                                             (Cache
                                                                                term
                                                                                Monovariant
                                                                                Type.Type)
-                                                                            (Eff
                                                                                (StateC
                                                                                   (Cache
                                                                                      term
                                                                                      Monovariant
                                                                                      Type.Type)
-                                                                                  (Eff
                                                                                      (FreshC
-                                                                                        (Eff
                                                                                            (StateC
                                                                                               (ScopeGraph
                                                                                                  Monovariant)
-                                                                                              (Eff
                                                                                                  (StateC
                                                                                                     (Heap
                                                                                                        Monovariant
                                                                                                        Monovariant
                                                                                                        Type.Type)
-                                                                                                    (Eff
                                                                                                        (TraceByPrintingC
-                                                                                                          (Eff
                                                                                                              (LiftC
-                                                                                                                IO)))))))))))))))))))))))))))))))))))
+                                                                                                                IO))))))))))))))))))
        result
      -> IO
           (Heap
@@ -567,17 +537,18 @@ callGraphRubyProject :: [FilePath] -> IO (Graph ControlFlowVertex, [Module ()])
 callGraphRubyProject = callGraphProject rubyParser (Proxy @'Language.Ruby)
 
 type EvalEffects qterm err = ResumableC (BaseError err)
-                         (Eff (ResumableC (BaseError (AddressError Precise (Value qterm Precise)))
+                         (ResumableC (BaseError (AddressError Precise (Value qterm Precise)))
-                         (Eff (ResumableC (BaseError ResolutionError)
+                         (ResumableC (BaseError ResolutionError)
-                         (Eff (ResumableC (BaseError (EvalError qterm Precise (Value qterm Precise)))
+                         (ResumableC (BaseError (EvalError qterm Precise (Value qterm Precise)))
-                         (Eff (ResumableC (BaseError (HeapError Precise))
+                         (ResumableC (BaseError (HeapError Precise))
-                         (Eff (ResumableC (BaseError (ScopeError Precise))
+                         (ResumableC (BaseError (ScopeError Precise))
-                         (Eff (ResumableC (BaseError (UnspecializedError Precise (Value qterm Precise)))
+                         (ResumableC (BaseError (UnspecializedError Precise (Value qterm Precise)))
-                         (Eff (ResumableC (BaseError (LoadError Precise (Value qterm Precise)))
+                         (ResumableC (BaseError (LoadError Precise (Value qterm Precise)))
-                         (Eff (FreshC (Eff (StateC (ScopeGraph Precise)
+                         (FreshC
-                         (Eff (StateC (Heap Precise Precise (Value qterm Precise))
+                         (StateC (ScopeGraph Precise)
-                         (Eff (TraceByPrintingC
+                         (StateC (Heap Precise Precise (Value qterm Precise))
-                         (Eff (LiftC IO))))))))))))))))))))))))
+                         (TraceByPrintingC
+                         (LiftC IO))))))))))))
 
 type LanguageSyntax lang syntax = ( Language.SLanguage lang
                                   , HasPrelude lang
@@ -646,18 +617,18 @@ evaluateProjectForScopeGraph :: ( term ~ Term (Sum syntax) Location
                              -> IO (Evaluator qterm address
                                     (Value qterm address)
                                     (ResumableWithC (BaseError (ValueError qterm address))
-                               (Eff (ResumableWithC (BaseError (AddressError address (Value qterm address)))
+                               (ResumableWithC (BaseError (AddressError address (Value qterm address)))
-                               (Eff (ResumableWithC (BaseError ResolutionError)
+                               (ResumableWithC (BaseError ResolutionError)
-                               (Eff (ResumableWithC (BaseError (EvalError qterm address (Value qterm address)))
+                               (ResumableWithC (BaseError (EvalError qterm address (Value qterm address)))
-                               (Eff (ResumableWithC (BaseError (HeapError address))
+                               (ResumableWithC (BaseError (HeapError address))
-                               (Eff (ResumableWithC (BaseError (ScopeError address))
+                               (ResumableWithC (BaseError (ScopeError address))
-                               (Eff (ResumableWithC (BaseError (UnspecializedError address (Value qterm address)))
+                               (ResumableWithC (BaseError (UnspecializedError address (Value qterm address)))
-                               (Eff (ResumableWithC (BaseError (LoadError address (Value qterm address)))
+                               (ResumableWithC (BaseError (LoadError address (Value qterm address)))
-                               (Eff (FreshC
+                               (FreshC
-                               (Eff (StateC (ScopeGraph address)
+                               (StateC (ScopeGraph address)
-                               (Eff (StateC (Heap address address (Value qterm address))
+                               (StateC (Heap address address (Value qterm address))
-                               (Eff (TraceByPrintingC
+                               (TraceByPrintingC
-                               (Eff (LiftC IO)))))))))))))))))))))))))
+                               (LiftC IO)))))))))))))
                              (ModuleTable (Module
                                 (ModuleResult address (Value qterm address)))))
 evaluateProjectForScopeGraph proxy parser project = runTask' $ do
@@ -681,22 +652,23 @@ evaluateProjectWithCaching :: ( term ~ Term (Sum syntax) Location
                           -> FilePath
                           -> IO (Evaluator qterm Monovariant Type
                                   (ResumableC (BaseError Type.TypeError)
-                                  (Eff (StateC TypeMap
+                                  (StateC TypeMap
-                                  (Eff (ResumableC (BaseError (AddressError Monovariant Type))
+                                  (ResumableC (BaseError (AddressError Monovariant Type))
-                                  (Eff (ResumableC (BaseError (EvalError qterm Monovariant Type))
+                                  (ResumableC (BaseError (EvalError qterm Monovariant Type))
-                                  (Eff (ResumableC (BaseError ResolutionError)
+                                  (ResumableC (BaseError ResolutionError)
-                                  (Eff (ResumableC (BaseError (HeapError Monovariant))
+                                  (ResumableC (BaseError (HeapError Monovariant))
-                                  (Eff (ResumableC (BaseError (ScopeError Monovariant))
+                                  (ResumableC (BaseError (ScopeError Monovariant))
-                                  (Eff (ResumableC (BaseError (UnspecializedError Monovariant Type))
+                                  (ResumableC (BaseError (UnspecializedError Monovariant Type))
-                                  (Eff (ResumableC (BaseError (LoadError Monovariant Type))
+                                  (ResumableC (BaseError (LoadError Monovariant Type))
-                                  (Eff (ReaderC (Live Monovariant)
+                                  (ReaderC (Live Monovariant)
-                                  (Eff (AltC []
+                                  (NonDetC
-                                  (Eff (ReaderC (Analysis.Abstract.Caching.FlowSensitive.Cache (Data.Quieterm.Quieterm (Sum syntax) Data.Location.Location) Monovariant Type)
+                                  (ReaderC (Analysis.Abstract.Caching.FlowSensitive.Cache (Data.Quieterm.Quieterm (Sum syntax) Data.Location.Location) Monovariant Type)
-                                  (Eff (StateC (Analysis.Abstract.Caching.FlowSensitive.Cache (Data.Quieterm.Quieterm (Sum syntax) Data.Location.Location) Monovariant Type)
+                                  (StateC (Analysis.Abstract.Caching.FlowSensitive.Cache (Data.Quieterm.Quieterm (Sum syntax) Data.Location.Location) Monovariant Type)
-                                  (Eff (FreshC
+                                  (FreshC
-                                  (Eff (StateC (ScopeGraph Monovariant)
+                                  (StateC (ScopeGraph Monovariant)
-                                  (Eff (StateC (Heap Monovariant Monovariant Type)
+                                  (StateC (Heap Monovariant Monovariant Type)
-                                  (Eff (TraceByPrintingC (Eff (LiftC IO)))))))))))))))))))))))))))))))))))
+                                  (TraceByPrintingC
+                                   (LiftC IO))))))))))))))))))
                                  (ModuleTable (Module (ModuleResult Monovariant Type))))
 evaluateProjectWithCaching proxy parser path = runTask' $ do
   project <- readProject Nothing path (Language.reflect proxy) []

src/Tags/Tagging.hs

@@ -38,9 +38,8 @@ runTagging blob tree
 type ContextToken = (Text, Maybe Range)
 
 type Contextualizer
-  = Eff (StateC [ContextToken]
+  = StateC [ContextToken]
-  ( Eff (ErrorC TranslationError
+  ( ErrorC TranslationError VoidC)
-  ( Eff VoidC))))
 
 contextualizing :: Blob -> Machine.ProcessT Contextualizer Token Tag
 contextualizing Blob{..} = repeatedly $ await >>= \case

test/Control/Abstract/Evaluator/Spec.hs

@@ -69,7 +69,7 @@ evaluate
         . runValueError
         . runAddressError
         . runEvalError
-        . runDeref @Val
+        . runDeref @SpecEff
         . runAllocator
         . runReturn
         . runLoopControl
@@ -85,29 +85,29 @@ reassociate = mergeErrors . mergeErrors . mergeErrors . mergeErrors . mergeError
 type Val = Value SpecEff Precise
 newtype SpecEff = SpecEff
   { runSpecEff :: Evaluator SpecEff Precise Val (FunctionC SpecEff Precise Val
-                 (Eff (BooleanC Val
+                 (BooleanC Val
-                 (Eff (NumericC Val
+                 (NumericC Val
-                 (Eff (ErrorC (LoopControl Val)
+                 (ErrorC (LoopControl Val)
-                 (Eff (ErrorC (Return Val)
+                 (ErrorC (Return Val)
-                 (Eff (AllocatorC Precise
+                 (AllocatorC Precise
-                 (Eff (DerefC Precise Val
+                 (DerefC Precise Val
-                 (Eff (ResumableC (BaseError (EvalError SpecEff Precise Val))
+                 (ResumableC (BaseError (EvalError SpecEff Precise Val))
-                 (Eff (ResumableC (BaseError (AddressError Precise Val))
+                 (ResumableC (BaseError (AddressError Precise Val))
-                 (Eff (ResumableC (BaseError (ValueError SpecEff Precise))
+                 (ResumableC (BaseError (ValueError SpecEff Precise))
-                 (Eff (ResumableC (BaseError (HeapError Precise))
+                 (ResumableC (BaseError (HeapError Precise))
-                 (Eff (ResumableC (BaseError (ScopeError Precise))
+                 (ResumableC (BaseError (ScopeError Precise))
-                 (Eff (ReaderC (CurrentFrame Precise)
+                 (ReaderC (CurrentFrame Precise)
-                 (Eff (ReaderC (CurrentScope Precise)
+                 (ReaderC (CurrentScope Precise)
-                 (Eff (AllocatorC Precise
+                 (AllocatorC Precise
-                 (Eff (ReaderC Span
+                 (ReaderC Span
-                 (Eff (StateC Span
+                 (StateC Span
-                 (Eff (ReaderC ModuleInfo
+                 (ReaderC ModuleInfo
-                 (Eff (ReaderC PackageInfo
+                 (ReaderC PackageInfo
-                 (Eff (FreshC
+                 (FreshC
-                 (Eff (StateC (Heap Precise Precise Val)
+                 (StateC (Heap Precise Precise Val)
-                 (Eff (StateC (ScopeGraph Precise)
+                 (StateC (ScopeGraph Precise)
-                 (Eff (TraceByIgnoringC
+                 (TraceByIgnoringC
-                 (Eff (LiftC IO)))))))))))))))))))))))))))))))))))))))))))))))
+                 (LiftC IO))))))))))))))))))))))))
                  Val
   }
 

test/SpecHelpers.hs

@@ -117,19 +117,19 @@ runTaskOrDie :: TaskEff a -> IO a
 runTaskOrDie task = runTaskWithOptions defaultOptions { optionsLogLevel = Nothing } task >>= either (die . displayException) pure
 
 type TestEvaluatingC term
-  = ResumableC (BaseError (AddressError Precise (Val term))) (Eff
+  = ResumableC (BaseError (AddressError Precise (Val term)))
-  ( ResumableC (BaseError (ValueError term Precise)) (Eff
+  ( ResumableC (BaseError (ValueError term Precise))
-  ( ResumableC (BaseError ResolutionError) (Eff
+  ( ResumableC (BaseError ResolutionError)
-  ( ResumableC (BaseError (EvalError term Precise (Val term))) (Eff
+  ( ResumableC (BaseError (EvalError term Precise (Val term)))
-  ( ResumableC (BaseError (HeapError Precise)) (Eff
+  ( ResumableC (BaseError (HeapError Precise))
-  ( ResumableC (BaseError (ScopeError Precise)) (Eff
+  ( ResumableC (BaseError (ScopeError Precise))
-  ( ResumableC (BaseError (UnspecializedError Precise (Val term))) (Eff
+  ( ResumableC (BaseError (UnspecializedError Precise (Val term)))
-  ( ResumableC (BaseError (LoadError Precise (Val term))) (Eff
+  ( ResumableC (BaseError (LoadError Precise (Val term)))
-  ( StateC (Heap Precise Precise (Val term)) (Eff
+  ( StateC (Heap Precise Precise (Val term))
-  ( StateC (ScopeGraph Precise) (Eff
+  ( StateC (ScopeGraph Precise)
-  ( FreshC (Eff
+  ( FreshC
-  ( TraceByIgnoringC (Eff
+  ( TraceByIgnoringC
-  ( LiftC IO))))))))))))))))))))))))
+  ( LiftC IO))))))))))))
 type TestEvaluatingErrors term
   = '[ BaseError (AddressError Precise (Val term))
      , BaseError (ValueError term Precise)

vendor/fused-effects

@@ -1 +1 @@
-Subproject commit f7e6b37ab92a001b080f7749d3cc45ac3214f699
+Subproject commit 17b0a846aa50fd0dea157624c031a550d8edd469