Merge remote-tracking branch 'origin/master' into lts-13.9-bump

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

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
-                , Member (Reader (Cache term address value)) sig
+cachingTerms :: ( 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)
-        => Evaluator term address value (AltC B (Eff
-                                        (ReaderC (Cache term address value) (Eff
-                                        (StateC (Cache term address value) (Eff
-                                        m)))))) a
+caching :: Carrier sig m
+        => Evaluator term address value (NonDetC
+                                        (ReaderC (Cache term address value)
+                                        (StateC (Cache term address value)
+                                        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)
-        => Evaluator term address value (AltC [] (Eff
-                                        (ReaderC (Cache term address value) (Eff
-                                        (StateC (Cache term address value) (Eff
-                                        m)))))) a
+caching :: Monad m
+        => Evaluator term address value ( NonDetC
+                                        (ReaderC (Cache term address value)
+                                        (StateC (Cache term address value)
+                                        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
-                 , Carrier sig m
-                 )
+                , Ord term
+                , 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
-                  , Ord term
-                  , Recursive term
-                  , Carrier sig m
-                  )
+                 , Member (State (Dead term)) sig
+                 , Ord term
+                 , Recursive term
+                 , 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
-                   , Member (Reader ModuleInfo) sig
+graphingModules :: ( 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
-                      , Member (Reader ModuleInfo) sig
+graphingModuleInfo :: ( 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)
-          => Evaluator term address value (EavesdropC address value (Eff m)) a
-          -> (forall x . Modules address value (Eff m) (Eff m x) -> Evaluator term address value m ())
+eavesdrop :: Evaluator term address value (EavesdropC address value m) a
+          -> (forall x . Modules address value m (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)
-         => Evaluator term address value (StateC (Map (Slot address) ControlFlowVertex) (Eff
-                                         (StateC (Graph ControlFlowVertex) (Eff
-                                         m)))) result
+graphing :: Carrier sig m
+         => Evaluator term address value (StateC (Map (Slot address) ControlFlowVertex)
+                                         (StateC (Graph ControlFlowVertex)
+                                         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
-                , Carrier sig m
-                , Reducer (Configuration term address value) (trace (Configuration term address value))
-                )
+               , Member (Writer (trace (Configuration term address value))) sig
+               , Carrier sig m
+               , Reducer (Configuration term address value) (trace (Configuration term address value))
+               )
              => trace (Configuration term address value)
              -> Open (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 }
-  deriving (Applicative, Functor, Monad)
-
-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)
+newtype Evaluator term address value m a = Evaluator { runEvaluator :: m a }
+  deriving (Alternative, Applicative, Functor, Monad, MonadIO)
 
 instance Carrier sig m => Carrier sig (Evaluator term address value m) where
-  ret = Evaluator . ret
-  eff = Evaluator . eff . handlePure runEvaluator
+  eff = Evaluator . eff . handleCoercible
 
-
--- | Raise a handler on 'Eff's into a handler on 'Evaluator's.
-raiseHandler :: (Eff m a -> Eff n b)
+-- | Raise a handler on monads into a handler on 'Evaluator's over those monads.
+raiseHandler :: (m a -> 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)
-               => Evaluator term address value (ErrorC (LoopControl value) (Eff m)) value
+runLoopControl :: Carrier sig m
+               => 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))
-         => Evaluator term address value (DerefC address value (Eff m)) a
+runDeref :: Evaluator term address value (DerefC address value 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)
-                => Evaluator term address value (ResumableC (BaseError (HeapError address)) (Eff m)) a
-                -> Evaluator term address value m (Either (SomeError (BaseError (HeapError address))) a)
+runHeapError :: Evaluator term address value (ResumableC (BaseError (HeapError address)) m) a
+             -> Evaluator term address value m (Either (SomeError (BaseError (HeapError address))) a)
 runHeapError = raiseHandler runResumable
 
-runHeapErrorWith :: Carrier sig m
-                 => (forall resume. (BaseError (HeapError address)) resume -> Evaluator term address value m resume)
-                 -> Evaluator term address value (ResumableWithC (BaseError (HeapError address)) (Eff m)) a
+runHeapErrorWith :: (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 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)
-                => Evaluator term address value (ResumableC (BaseError (AddressError address value)) (Eff m)) a
+runAddressError :: Evaluator term address value (ResumableC (BaseError (AddressError address value)) m) a
                 -> Evaluator term address value m (Either (SomeError (BaseError (AddressError address value))) a)
 runAddressError = raiseHandler runResumable
 
-runAddressErrorWith :: Carrier sig m
-                    => (forall resume . (BaseError (AddressError address value)) resume -> Evaluator term address value m resume)
-                    -> Evaluator term address value (ResumableWithC (BaseError (AddressError address value)) (Eff m)) a
+runAddressErrorWith :: (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 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
-              , Member (Resumable (BaseError (LoadError address value))) sig
-              , Carrier sig m
-              )
-           => Set ModulePath
-           -> Evaluator term address value (ModulesC address value (Eff m)) a
+runModules :: Set ModulePath
+           -> Evaluator term address value (ModulesC address value 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 op = ModulesC (\ paths -> handleSum (eff . handleReader paths runModulesC) (\case
-    Load    name  k -> askModuleTable >>= maybeM (throwLoadError (ModuleNotFoundError name)) . fmap moduleBody . ModuleTable.lookup name >>= flip runModulesC paths . k
-    Lookup  path  k -> askModuleTable >>= flip runModulesC paths . k . fmap moduleBody . ModuleTable.lookup path
-    Resolve names k -> runModulesC (k (find (`Set.member` paths) names)) paths
-    List    dir   k -> runModulesC (k (filter ((dir ==) . takeDirectory) (toList paths))) paths) op)
+  eff (L op) = do
+    paths <- ModulesC ask
+    case op of
+      Load    name  k -> askModuleTable >>= maybeM (throwLoadError (ModuleNotFoundError name)) . fmap moduleBody . ModuleTable.lookup name >>= k
+      Lookup  path  k -> askModuleTable >>= k . fmap moduleBody . ModuleTable.lookup path
+      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)
-             => Evaluator term address value (ResumableC (BaseError (LoadError address value)) (Eff m)) a
+runLoadError :: Evaluator term address value (ResumableC (BaseError (LoadError address value)) m) a
              -> Evaluator term address value m (Either (SomeError (BaseError (LoadError address value))) a)
 runLoadError = raiseHandler runResumable
 
-runLoadErrorWith :: Carrier sig m
-                 => (forall resume . (BaseError (LoadError address value)) resume -> Evaluator term address value m resume)
-                 -> Evaluator term address value (ResumableWithC (BaseError (LoadError address value)) (Eff m)) a
+runLoadErrorWith :: (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 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)
-                   => Evaluator term address value (ResumableC (BaseError ResolutionError) (Eff m)) a
+runResolutionError :: Evaluator term address value (ResumableC (BaseError ResolutionError) m) a
                    -> Evaluator term address value m (Either (SomeError (BaseError ResolutionError)) a)
 runResolutionError = raiseHandler runResumable
 
-runResolutionErrorWith :: Carrier sig m
-                       => (forall resume . (BaseError ResolutionError) resume -> Evaluator term address value m resume)
-                       -> Evaluator term address value (ResumableWithC (BaseError ResolutionError) (Eff m)) a
+runResolutionErrorWith :: (forall resume . (BaseError ResolutionError) resume -> Evaluator term address value m resume)
+                       -> Evaluator term address value (ResumableWithC (BaseError ResolutionError) 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
-                      , 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
+runPythonPackaging :: Evaluator term address (Value term address) (PythonPackagingC term address 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
-  ret = PythonPackagingC . ret
+      => Carrier sig (PythonPackagingC term address m) where
   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))
-             => Evaluator term address value (AllocatorC address (Eff m)) a
+runAllocator :: Evaluator term address value (AllocatorC address 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 :: Carrier sig m
-                  => (forall resume . BaseError (ScopeError address) resume -> Evaluator term address value m resume)
-                  -> Evaluator term address value (ResumableWithC (BaseError (ScopeError address)) (Eff m)) a
+runScopeErrorWith :: (forall resume . BaseError (ScopeError address) resume -> Evaluator term address value m resume)
+                  -> Evaluator term address value (ResumableWithC (BaseError (ScopeError address)) m) a
                   -> Evaluator term address value m a
 runScopeErrorWith f = raiseHandler $ runResumableWith (runEvaluator . f)
 
-runScopeError :: (Carrier sig m, Effect sig)
-              => Evaluator term address value (ResumableC (BaseError (ScopeError address)) (Eff m)) a
+runScopeError :: Evaluator term address value (ResumableC (BaseError (ScopeError address)) 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))
-            => (term -> Evaluator term address value (FunctionC term address value (Eff m)) value)
-            -> Evaluator term address value (FunctionC term address value (Eff m)) a
+runFunction :: (term -> Evaluator term address value (FunctionC term address value m) value)
+            -> Evaluator term address value (FunctionC term address value m) a
             -> Evaluator term address value m a
-runFunction eval = raiseHandler (flip runFunctionC (runEvaluator . eval) . interpret)
-
-newtype FunctionC term address value m a = FunctionC { runFunctionC :: (term -> Eff (FunctionC term address value m) value) -> m a }
+runFunction eval = raiseHandler (runReader (runEvaluator . eval) . runFunctionC)
 
+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))
-           => Evaluator term address value (BooleanC value (Eff m)) a
+runBoolean :: Evaluator term address value (BooleanC value 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))
-         => Evaluator term address value (WhileC value (Eff m)) a
+runWhile :: Evaluator term address value (WhileC value 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))
-        => Evaluator term address value (UnitC value (Eff m)) a
+runUnit :: Evaluator term address value (UnitC value 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))
-          => Evaluator term address value (StringC value (Eff m)) a
+runString :: Evaluator term address value (StringC value 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))
-           => Evaluator term address value (NumericC value (Eff m)) a
+runNumeric :: Evaluator term address value (NumericC value 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))
-           => Evaluator term address value (BitwiseC value (Eff m)) a
+runBitwise :: Evaluator term address value (BitwiseC value 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))
-           => Evaluator term address value (ObjectC address value (Eff m)) a
-           -> Evaluator term address value m a
-runObject = raiseHandler $ runObjectC . interpret
+runObject :: Evaluator term address value (ObjectC address value m) a
+          -> Evaluator term address value m a
+runObject = raiseHandler runObjectC
 
 -- | 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))
-           => Evaluator term address value (ArrayC value (Eff m)) a
-           -> Evaluator term address value m a
-runArray = raiseHandler $ runArrayC . interpret
+runArray :: Evaluator term address value (ArrayC value m) a
+         -> Evaluator term address value m a
+runArray = raiseHandler runArrayC
 
 -- | 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))
-           => Evaluator term address value (HashC value (Eff m)) a
-           -> Evaluator term address value m a
-runHash = raiseHandler $ runHashC . interpret
+runHash :: Evaluator term address value (HashC value m) a
+        -> Evaluator term address value m a
+runHash = raiseHandler runHashC
 
 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
-runCatchC handler (CatchC m) = m handler
+newtype Handler m = Handler (forall x . m x -> IO x)
+
+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 op = CatchC (\ handler -> handleSum
-    (eff . handlePure (runCatchC handler))
-    (\case
-        CatchIO go cleanup k -> liftIO (Exc.catch
-                                         (handler (runCatchC handler go))
-                                         (handler . runCatchC handler . cleanup))
-                                >>= runCatchC handler . k
-    ) op)
+  eff (L (CatchIO act cleanup k)) = do
+    handler <- CatchC ask
+    liftIO (Exc.catch (runHandler handler act) (runHandler handler . cleanup)) >>= k
+  eff (R other) = CatchC (eff (R (handleCoercible other)))

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 = flip runInterposeC Nothing . interpret
+runInterpose :: InterposeC eff m a -> m a
+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
-  ret a = InterposeC (const (ret a))
-  eff op = InterposeC (\ listener -> handleSum (algOther listener) (alg listener) op)
-    where alg listener (Interpose m h k) = runInterposeC m (Just (Listener (flip runInterposeC listener . h))) >>= flip runInterposeC listener . k
-          algOther listener op
-            | Just listener <- listener
-            , Just eff <- prj op = runListener listener eff
-            | otherwise          = eff (handleReader listener runInterposeC op)
+-- TODO: Document the implementation of this, as it is extremely subtle.
+
+runListener :: Listener eff (InterposeC eff m) -> eff (InterposeC eff m) (InterposeC eff m a) -> InterposeC eff m a
+runListener (Listener listen) = listen
+
+instance (Carrier sig m, Member eff sig) => Carrier (Interpose eff :+: sig) (InterposeC eff m) where
+  eff (L (Interpose m h k)) =
+    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 = flip runREPLC (prefs, settings) . interpret
+runREPL :: Prefs -> Settings IO -> REPLC m a -> m a
+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 op = REPLC (\ args -> handleSum (eff . handleReader args runREPLC) (\case
-    Prompt p k -> liftIO (uncurry runInputTWithPrefs args (fmap (fmap T.pack) (getInputLine (cyan <> T.unpack p <> plain)))) >>= flip runREPLC args . k
-    Output s k -> liftIO (uncurry runInputTWithPrefs args (outputStrLn (T.unpack s))) *> runREPLC k args) op)
+  eff (L op) = do
+    args <- REPLC ask
+    case op of
+      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 = handleSum
-    (AllocatorC . eff . handleCoercible)
-    (\ (Alloc name k) -> Total <$> promoteA (eff (L (Alloc name ret))) >>= k)
+  eff (R other) = AllocatorC . eff . handleCoercible $ other
+  eff (L (Alloc name k)) = Total <$> promoteA (eff (L (Alloc name pure))) >>= 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 = handleSum (DerefC . eff . handleCoercible) (\case
-    DerefCell        cell k -> promoteD (eff (L (DerefCell        cell ret))) >>= k
-    AssignCell value cell k -> promoteD (eff (L (AssignCell value cell ret))) >>= k)
+  eff (R other) = DerefC . eff . handleCoercible $ other
+  eff (L op) = case op of
+    DerefCell        cell k -> promoteD (eff (L (DerefCell        cell pure))) >>= 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 = AllocatorC . handleSum
-    (eff . handleCoercible)
-    (\ (Alloc name k) -> runAllocatorC (k (Monovariant name)))
-
+  eff (L (Alloc name k)) = k (Monovariant name)
+  eff (R other) = AllocatorC . eff . handleCoercible $ other
 
 instance (Ord value, Carrier sig m, Alternative m, Monad m) => Carrier (Deref value :+: sig) (DerefC Monovariant value m) where
-  ret = DerefC . ret
-  eff = DerefC . handleSum (eff . handleCoercible) (\case
-    DerefCell        cell k -> traverse (foldMapA pure) (nonEmpty (toList cell)) >>= runDerefC . k
-    AssignCell value cell k -> runDerefC (k (Set.insert value cell)))
+  eff (L (DerefCell cell k)) = traverse (foldMapA pure) (nonEmpty (toList cell)) >>= k
+  eff (L (AssignCell value cell k)) = k (Set.insert value cell)
+  eff (R other) = DerefC . eff . handleCoercible $ other

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
-  ret = AllocatorC . ret
-  eff = AllocatorC . handleSum
-    (eff . handleCoercible)
-    (\ (Alloc _ k) -> Precise <$> fresh >>= runAllocatorC . k)
+instance (Member Fresh sig, Carrier sig m) => Carrier (Allocator Precise :+: sig) (AllocatorC Precise m) where
+  eff (R other) = AllocatorC . eff . handleCoercible $ other
+  eff (L (Alloc _ k)) = Precise <$> fresh >>= k
 
 
 instance Carrier sig m => Carrier (Deref value :+: sig) (DerefC Precise value m) where
-  ret = DerefC . ret
-  eff = DerefC . handleSum (eff . handleCoercible) (\case
-    DerefCell        cell k -> runDerefC (k (fst <$> Set.minView cell))
-    AssignCell value _    k -> runDerefC (k (Set.singleton value)))
+  eff (R other) = DerefC . eff . handleCoercible $ other
+  eff (L op) = case op of
+    DerefCell        cell k -> k (fst <$> Set.minView cell)
+    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

@@ -30,7 +30,7 @@ import Data.Abstract.Declarations as X
 import Data.Abstract.FreeVariables as X
 import Data.Abstract.Module
 import Data.Abstract.Name as X
-import qualified Data.Abstract.ScopeGraph as ScopeGraph 
+import qualified Data.Abstract.ScopeGraph as ScopeGraph
 import Data.Abstract.ScopeGraph (Relation(..))
 import Data.Abstract.AccessControls.Class as X
 import Data.Language
@@ -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)
-                 => Evaluator term address value (ResumableC (BaseError (UnspecializedError address value)) (Eff m)) a
+runUnspecialized :: Evaluator term address value (ResumableC (BaseError (UnspecializedError address value)) m) a
                  -> Evaluator term address value m (Either (SomeError (BaseError (UnspecializedError address value))) a)
 runUnspecialized = raiseHandler runResumable
 
-runUnspecializedWith :: Carrier sig m
-                     => (forall resume . BaseError (UnspecializedError address value) resume -> Evaluator term address value m resume)
-                     -> Evaluator term address value (ResumableWithC (BaseError (UnspecializedError address value)) (Eff m)) a
+runUnspecializedWith :: (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 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
-  ret = FunctionC . const . ret
-  eff op = FunctionC (\ eval -> handleSum (eff . handleReader eval runFunctionC) (\case
-    Function _ params body scope k -> runEvaluator $ do
-      currentScope' <- currentScope
-      currentFrame' <- currentFrame
-      let frameLinks = Map.singleton Lexical (Map.singleton currentScope' currentFrame')
-      frame <- newFrame scope frameLinks
-      res <- withScopeAndFrame frame $ do
-        for_ params $ \param -> do
-          slot <- lookupSlot (Declaration param)
-          assign slot Abstract
-        catchReturn (runFunction (Evaluator . eval) (Evaluator (eval body)))
-      Evaluator $ runFunctionC (k res) eval
-    BuiltIn _ _ k -> runFunctionC (k Abstract) eval
-    Bind _ _ k -> runFunctionC (k Abstract) eval
-    Call _ _ k -> runFunctionC (k Abstract) eval) op)
+      => Carrier (Abstract.Function term address Abstract :+: sig) (FunctionC term address Abstract m) where
+  eff (R other) = FunctionC . eff . R . handleCoercible $ other
+  eff (L op) = runEvaluator $ do
+    eval <- Evaluator . FunctionC $ ask
+    case op of
+      Function _ params body scope k -> do
+        currentScope' <- currentScope
+        currentFrame' <- currentFrame
+        let frameLinks = Map.singleton Lexical (Map.singleton currentScope' currentFrame')
+        frame <- newFrame scope frameLinks
+        res <- withScopeAndFrame frame $ do
+          for_ params $ \param -> do
+            slot <- lookupSlot (Declaration param)
+            assign slot Abstract
+          catchReturn (Evaluator (eval body))
+        Evaluator (k res)
+      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 = BooleanC . handleSum (eff . handleCoercible) (\case
-    Boolean _ k -> runBooleanC (k Abstract)
-    AsBool  _ k -> runBooleanC (k True) <|> runBooleanC (k False))
+  eff (L (Boolean _ k)) = k Abstract
+  eff (L (AsBool  _ k)) = k True <|> k False
+  eff (R other)         = BooleanC . eff . handleCoercible $ other
 
 
 instance ( Member (Abstract.Boolean Abstract) sig
          , Carrier sig m
          , Alternative m
-         , Monad m
          )
       => Carrier (While Abstract :+: sig) (WhileC Abstract m) where
-  ret = WhileC . ret
-  eff = WhileC . handleSum
-    (eff . handleCoercible)
-    (\ (Abstract.While cond body k) -> do
-      cond' <- runWhileC cond
-      ifthenelse cond' (runWhileC body *> empty) (runWhileC (k Abstract)))
-
+  eff (R other) = WhileC . eff . handleCoercible $ other
+  eff (L (Abstract.While cond body k)) = do
+    cond' <- cond
+    ifthenelse cond' (body *> empty) (k Abstract)
 
 instance Carrier sig m
       => Carrier (Unit Abstract :+: sig) (UnitC Abstract m) where
-  ret = UnitC . ret
-  eff = UnitC . handleSum
-    (eff . handleCoercible)
-    (\ (Abstract.Unit k) -> runUnitC (k Abstract))
+  eff (R other) = UnitC . eff . handleCoercible $ other
+  eff (L (Abstract.Unit k)) = k Abstract
 
 instance Carrier sig m
       => Carrier (Abstract.String Abstract :+: sig) (StringC Abstract m) where
-  ret = StringC . ret
-  eff = StringC . handleSum (eff . handleCoercible) (\case
-    Abstract.String _ k -> runStringC (k Abstract)
-    AsString        _ k -> runStringC (k ""))
+  eff (R other) = StringC . eff . handleCoercible $ other
+  eff (L op) = case op of
+    Abstract.String _ k -> k Abstract
+    AsString        _ k -> k ""
 
 instance Carrier sig m
       => Carrier (Numeric Abstract :+: sig) (NumericC Abstract m) where
-  ret = NumericC . ret
-  eff = NumericC . handleSum (eff . handleCoercible) (\case
-    Integer _ k -> runNumericC (k Abstract)
-    Float _ k -> runNumericC (k Abstract)
-    Rational _ k -> runNumericC (k Abstract)
-    LiftNumeric _ _ k -> runNumericC (k Abstract)
-    LiftNumeric2 _ _ _ k -> runNumericC (k Abstract))
+  eff (R other) = NumericC . eff . handleCoercible $ other
+  eff (L op) = case op of
+    Integer _ k -> k Abstract
+    Float _ k -> k Abstract
+    Rational _ k -> k Abstract
+    LiftNumeric _ _ k -> k Abstract
+    LiftNumeric2 _ _ _ k -> k Abstract
 
 instance Carrier sig m
       => Carrier (Bitwise Abstract :+: sig) (BitwiseC Abstract m) where
-  ret = BitwiseC . ret
-  eff = BitwiseC . handleSum (eff . handleCoercible) (\case
-    CastToInteger _ k -> runBitwiseC (k Abstract)
-    LiftBitwise _ _ k -> runBitwiseC (k Abstract)
-    LiftBitwise2 _ _ _ k -> runBitwiseC (k Abstract)
-    UnsignedRShift _ _ k -> runBitwiseC (k Abstract))
+  eff (R other) = BitwiseC . eff . handleCoercible $ other
+  eff (L op) = case op of
+    CastToInteger _ k -> k Abstract
+    LiftBitwise _ _ k -> k Abstract
+    LiftBitwise2 _ _ _ k -> k Abstract
+    UnsignedRShift _ _ k -> k Abstract
 
 instance Carrier sig m
       => Carrier (Object address Abstract :+: sig) (ObjectC address Abstract m) where
-  ret = ObjectC . ret
-  eff = ObjectC . handleSum (eff . handleCoercible) (\case
-    Object _ k -> runObjectC (k Abstract)
-    ScopedEnvironment _ k -> runObjectC (k Nothing)
-    Klass _ _ k -> runObjectC (k Abstract))
+  eff (R other) = ObjectC . eff . handleCoercible $ other
+  eff (L op) = case op of
+    Object _ k -> k Abstract
+    ScopedEnvironment _ k -> k Nothing
+    Klass _ _ k -> k Abstract
 
 instance Carrier sig m
       => Carrier (Array Abstract :+: sig) (ArrayC Abstract m) where
-  ret = ArrayC . ret
-  eff = ArrayC . handleSum (eff . handleCoercible) (\case
-    Array _ k -> runArrayC (k Abstract)
-    AsArray _ k -> runArrayC (k []))
+  eff (R other) = ArrayC . eff . handleCoercible $ other
+  eff (L op) = case op of
+    Array _ k -> k Abstract
+    AsArray _ k -> k []
 
 instance Carrier sig m
       => Carrier (Hash Abstract :+: sig) (HashC Abstract m) where
-  ret = HashC . ret
-  eff = HashC . handleSum (eff . handleCoercible) (\case
-    Hash _ k -> runHashC (k Abstract)
-    KvPair _ _ k -> runHashC (k Abstract))
+  eff (R other) = HashC . eff . handleCoercible $ other
+  eff (L op) = case op of
+    Hash _ k -> 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
-  ret = FunctionC . const . ret
-  eff op =
+      => Carrier (Abstract.Function term address (Value term address) :+: sig) (Abstract.FunctionC term address (Value term address) m) where
+  eff (R other) = FunctionC . eff . R . handleCoercible $ other
+  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
-    Abstract.Function name params body scope k -> runEvaluator $ do
-      val <- closure (Just name) params (Right body) scope
-      Evaluator $ runFunctionC (k val) eval
-    Abstract.BuiltIn associatedScope builtIn k -> runEvaluator $ do
-      val <- closure Nothing [] (Left builtIn) associatedScope
-      Evaluator $ runFunctionC (k val) eval
-    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
-    Abstract.Bind _ value k -> runFunctionC (k value) eval
-    Abstract.Call op params k -> runEvaluator $ do
-      boxed <- case op of
-        Closure _ _ _ _ _ (Left Print) _ _ -> traverse (trace . show) params $> Unit
-        Closure _ _ _ _ _ (Left Show) _ _ -> pure . String . pack $ show params
-        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
-          -- charge them to the closure's origin.
-          withCurrentPackage packageInfo . withCurrentModule moduleInfo $ do
-            parentScope <- scopeLookup parentFrame
-            let frameEdges = Map.singleton Lexical (Map.singleton parentScope parentFrame)
-            frameAddress <- newFrame associatedScope frameEdges
-            withScopeAndFrame frameAddress $ do
-              case maybeSelf of
-                Just object -> do
-                  maybeSlot <- maybeLookupDeclaration (Declaration __self)
-                  maybe (pure ()) (`assign` object) maybeSlot
-                Nothing -> pure ()
-              for_ (zip names params) $ \(name, param) -> do
-                slot <- lookupSlot (Declaration name)
-                assign slot param
-              catchReturn (runFunction (Evaluator . eval) (Evaluator (eval body)))
-        _ -> throwValueError (CallError op)
-      Evaluator $ runFunctionC (k boxed) eval) op)
+    case op of
+      Abstract.Function name params body scope k -> do
+        val <- closure (Just name) params (Right body) scope
+        Evaluator (k val)
+      Abstract.BuiltIn associatedScope builtIn k -> do
+        val <- closure Nothing [] (Left builtIn) associatedScope
+        Evaluator (k val)
+      Abstract.Bind obj@Object{} (Closure packageInfo moduleInfo name _ names body scope parentFrame) k ->
+        Evaluator (k (Closure packageInfo moduleInfo name (Just obj) names body scope parentFrame))
+      Abstract.Bind _ value k -> Evaluator (k value)
+      Abstract.Call op params k -> do
+        boxed <- case op of
+          Closure _ _ _ _ _ (Left Print) _ _ -> traverse (trace . show) params $> Unit
+          Closure _ _ _ _ _ (Left Show) _ _ -> pure . String . pack $ show params
+          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
+            -- charge them to the closure's origin.
+            withCurrentPackage packageInfo . withCurrentModule moduleInfo $ do
+              parentScope <- scopeLookup parentFrame
+              let frameEdges = Map.singleton Lexical (Map.singleton parentScope parentFrame)
+              frameAddress <- newFrame associatedScope frameEdges
+              withScopeAndFrame frameAddress $ do
+                case maybeSelf of
+                  Just object -> do
+                    maybeSlot <- maybeLookupDeclaration (Declaration __self)
+                    maybe (pure ()) (`assign` object) maybeSlot
+                  Nothing -> pure ()
+                for_ (zip names params) $ \(name, param) -> do
+                  slot <- lookupSlot (Declaration name)
+                  assign slot param
+                catchReturn (Evaluator (eval body))
+          _ -> throwValueError (CallError 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 = BooleanC . handleSum (eff . handleCoercible) (\case
-    Abstract.Boolean b          k -> runBooleanC . k $! Boolean b
-    Abstract.AsBool (Boolean b) k -> runBooleanC (k b)
-    Abstract.AsBool other       k -> throwBaseError (BoolError other) >>= runBooleanC . k)
-
+  eff (R other) = BooleanC . eff . handleCoercible $ other
+  eff (L op) = case op of
+    Abstract.Boolean b          k -> k $! Boolean b
+    Abstract.AsBool (Boolean b) k -> k b
+    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
-  ret = WhileC . ret
-  eff = WhileC . handleSum (eff . handleCoercible) (\case
-    Abstract.While cond body k -> interpose @(Resumable (BaseError (UnspecializedError address (Value term address)))) (runEvaluator (loop (\continue -> do
-      cond' <- Evaluator (runWhileC cond)
+      => Carrier (Abstract.While (Value term address) :+: sig) (WhileC (Value term address) m) where
+  eff (R other) = WhileC . eff . handleCoercible $ other
+  eff (L (Abstract.While cond body k)) = do
+
+    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' (Evaluator (runWhileC body) *> continue) (pure Unit))))
+      ifthenelse cond' (body *> throwError (Continue @(Value term address) Unit)) (pure Unit)))
       (\case
-        Resumable (BaseError _ _ (UnspecializedError _))    _ -> throwError (Abort @(Value term address))
-        Resumable (BaseError _ _ (RefUnspecializedError _)) _ -> throwError (Abort @(Value term address)))
-        >>= 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
+        Resumable (BaseError _ _ (UnspecializedError _))    _ -> traceM "unspecialized" *> throwError (Abort @(Value term address))
+        Resumable (BaseError _ _ (RefUnspecializedError _)) _ -> traceM "refun" *> throwError (Abort @(Value term address))) >>= k
+
+
+
+  --   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))))
+  --     (
+  --       >>= 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 = UnitC . handleSum
-    (eff . handleCoercible)
-    (\ (Abstract.Unit k) -> runUnitC (k Unit))
+  eff (R other) = UnitC . eff . handleCoercible $ other
+  eff (L (Abstract.Unit k )) = 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 = StringC . handleSum (eff . handleCoercible) (\case
-    Abstract.String   t          k -> runStringC (k (String t))
-    Abstract.AsString (String t) k -> runStringC (k t)
-    Abstract.AsString other      k -> throwBaseError (StringError other) >>= runStringC . k)
+  eff (R other) = StringC . eff . handleCoercible $ other
+  eff (L op) = case op of
+    Abstract.String   t          k -> k (String t)
+    Abstract.AsString (String t) k -> k t
+    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 = NumericC . handleSum (eff . handleCoercible) (\case
-    Abstract.Integer  t k -> runNumericC (k (Integer (Number.Integer t)))
-    Abstract.Float    t k -> runNumericC (k (Float (Number.Decimal t)))
-    Abstract.Rational t k -> runNumericC (k (Rational (Number.Ratio t)))
-    Abstract.LiftNumeric f arg k -> runNumericC . k =<< case arg of
+  eff (R other) = NumericC . eff . handleCoercible $ other
+  eff (L op) = case op of
+    Abstract.Integer  t k -> k (Integer (Number.Integer t))
+    Abstract.Float    t k -> k (Float (Number.Decimal t))
+    Abstract.Rational t k -> k (Rational (Number.Ratio t))
+    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.Ratio t))) = pure (Rational (Number.Ratio 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))
 
 
 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 = BitwiseC . handleSum (eff . handleCoercible) (\case
-    CastToInteger (Integer (Number.Integer i)) k -> runBitwiseC (k (Integer (Number.Integer i)))
-    CastToInteger (Float (Number.Decimal i)) k -> runBitwiseC (k (Integer (Number.Integer (coefficient (normalize i)))))
-    CastToInteger i k -> throwBaseError (NumericError i) >>= runBitwiseC . k
-    LiftBitwise operator (Integer (Number.Integer i)) k -> runBitwiseC . k . Integer . Number.Integer . operator $ i
-    LiftBitwise _ other k -> throwBaseError (BitwiseError other) >>= runBitwiseC . k
-    LiftBitwise2 operator (Integer (Number.Integer i)) (Integer (Number.Integer j)) k -> runBitwiseC . k . Integer . Number.Integer $ operator i j
-    LiftBitwise2 _ left right k -> throwBaseError (Bitwise2Error left right) >>= runBitwiseC . k
-    UnsignedRShift (Integer (Number.Integer i)) (Integer (Number.Integer j)) k | i >= 0 -> runBitwiseC . k . Integer . Number.Integer $ ourShift (fromIntegral i) (fromIntegral j)
-    UnsignedRShift left right k -> throwBaseError (Bitwise2Error left right) >>= runBitwiseC . k)
+  eff (R other) = BitwiseC . eff . handleCoercible $ other
+  eff (L op) = case op of
+    CastToInteger (Integer (Number.Integer i)) k -> k (Integer (Number.Integer i))
+    CastToInteger (Float (Number.Decimal i)) k -> k (Integer (Number.Integer (coefficient (normalize i))))
+    CastToInteger i k -> throwBaseError (NumericError i) >>= k
+    LiftBitwise operator (Integer (Number.Integer i)) k -> k . Integer . Number.Integer . operator $ i
+    LiftBitwise _ other k -> throwBaseError (BitwiseError other) >>= k
+    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) >>= k
+    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) >>= 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 = ObjectC . handleSum (eff . handleCoercible) (\case
-    Abstract.Object address k -> runObjectC (k (Object address))
-    Abstract.ScopedEnvironment (Object address) k -> runObjectC (k (Just address))
-    Abstract.ScopedEnvironment (Class _ _ address) k -> runObjectC (k (Just address))
-    Abstract.ScopedEnvironment (Namespace _ address) k -> runObjectC (k (Just address))
-    Abstract.ScopedEnvironment _ k -> runObjectC (k Nothing)
-    Abstract.Klass n frame k -> runObjectC (k (Class n mempty frame))
-    )
+  eff (R other) = ObjectC . eff . handleCoercible $ other
+  eff (L op) = case op of
+    Abstract.Object address k -> k (Object address)
+    Abstract.ScopedEnvironment (Object address) k -> k (Just address)
+    Abstract.ScopedEnvironment (Class _ _ address) k -> k (Just address)
+    Abstract.ScopedEnvironment (Namespace _ address) k -> k (Just address)
+    Abstract.ScopedEnvironment _ k -> k Nothing
+    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 = ArrayC . handleSum (eff . handleCoercible) (\case
-    Abstract.Array t k -> runArrayC (k (Array t))
-    Abstract.AsArray (Array addresses) k -> runArrayC (k addresses)
-    Abstract.AsArray val k -> throwBaseError (ArrayError val) >>= runArrayC . k)
+  eff (R other) = ArrayC . eff . handleCoercible $ other
+  eff (L op) = case op of
+    Abstract.Array t k -> k (Array t)
+    Abstract.AsArray (Array addresses) k -> k addresses
+    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 = HashC . handleSum (eff . handleCoercible) (\case
-    Abstract.Hash t k -> runHashC (k ((Hash . map (uncurry KVPair)) t))
-    Abstract.KvPair t v k -> runHashC (k (KVPair t v)))
+  eff (R other) = HashC . eff . handleCoercible $ other
+  eff (L op) = case op of
+    Abstract.Hash t k -> k ((Hash . map (uncurry KVPair)) t)
+    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)
-              => Evaluator term address (Value term address) (ResumableC (BaseError (ValueError term address)) (Eff m)) a
+runValueError :: Evaluator term address (Value term address) (ResumableC (BaseError (ValueError term address)) m) a
               -> Evaluator term address (Value term address) m (Either (SomeError (BaseError (ValueError term address))) a)
 runValueError = Evaluator . runResumable . runEvaluator
 
-runValueErrorWith :: Carrier sig m
-                  => (forall resume . BaseError (ValueError term address) resume -> Evaluator term address (Value term address) m resume)
-                  -> Evaluator term address (Value term address) (ResumableWithC (BaseError (ValueError term address)) (Eff m)) a
+runValueErrorWith :: (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) 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)
-           => Evaluator term address Type (StateC TypeMap (Eff m)) a
+runTypeMap :: Carrier sig m
+           => 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)
-         => Evaluator term address Type (ResumableC (BaseError TypeError) (Eff
-                                        (StateC TypeMap (Eff
-                                        m)))) a
+runTypes :: Carrier sig m
+         => Evaluator term address Type (ResumableC (BaseError TypeError)
+                                         (StateC TypeMap m)) a
          -> Evaluator term address Type m (Either (SomeError (BaseError TypeError)) a)
 runTypes = runTypeMap . runTypeError
 
-runTypesWith :: (Carrier sig m, Effect sig)
-             => (forall resume . (BaseError TypeError) resume -> Evaluator term address Type (StateC TypeMap (Eff m)) resume)
-             -> Evaluator term address Type (ResumableWithC (BaseError TypeError) (Eff
-                                            (StateC TypeMap (Eff
-                                            m)))) a
+runTypesWith :: Carrier sig m
+             => (forall resume . (BaseError TypeError) resume -> Evaluator term address Type (StateC TypeMap m) resume)
+             -> Evaluator term address Type (ResumableWithC (BaseError TypeError)
+                                            (StateC TypeMap
+                                            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
-  ret = FunctionC . const . ret
-  eff op = FunctionC (\ eval -> handleSum (eff . handleReader eval runFunctionC) (\case
-    Abstract.Function _ params body scope k -> runEvaluator $ do
-      currentScope' <- currentScope
-      currentFrame' <- currentFrame
-      let frameLinks = Map.singleton Lexical (Map.singleton currentScope' currentFrame')
-      frame <- newFrame scope frameLinks
-      res <- withScopeAndFrame frame $ do
-        tvars <- foldr (\ param rest -> do
-          tvar <- Var <$> fresh
-          slot <- lookupSlot (Declaration param)
-          assign slot tvar
-          (tvar :) <$> rest) (pure []) params
-        -- TODO: We may still want to represent this as a closure and not a function type
-        (zeroOrMoreProduct tvars :->) <$> catchReturn (runFunction (Evaluator . eval) (Evaluator (eval body)))
-      Evaluator (runFunctionC (k res) eval)
+      => Carrier (Abstract.Function term address Type :+: sig) (FunctionC term address Type m) where
+  eff (R other) = FunctionC (eff (R (handleCoercible other)))
+  eff (L op) = runEvaluator $ do
+    eval <- Evaluator . FunctionC $ ask
+    case op of
+      Abstract.Function _ params body scope k -> do
+        currentScope' <- currentScope
+        currentFrame' <- currentFrame
+        let frameLinks = Map.singleton Lexical (Map.singleton currentScope' currentFrame')
+        frame <- newFrame scope frameLinks
+        res <- withScopeAndFrame frame $ do
+          tvars <- foldr (\ param rest -> do
+            tvar <- Var <$> fresh
+            slot <- lookupSlot (Declaration param)
+            assign slot tvar
+            (tvar :) <$> rest) (pure []) params
+          -- 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 = BooleanC . handleSum (eff . handleCoercible) (\case
-    Abstract.Boolean _ k -> runBooleanC (k Bool)
-    Abstract.AsBool  t k -> unify t Bool *> (runBooleanC (k True) <|> runBooleanC (k False)))
+  eff (R other) = BooleanC . eff . handleCoercible $ other
+  eff (L (Abstract.Boolean _ k)) = k Bool
+  eff (L (Abstract.AsBool t k))  = unify t Bool *> (k True <|> 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 = WhileC . handleSum
-    (eff . handleCoercible)
-    (\ (Abstract.While cond body k) -> do
-      cond' <- runWhileC cond
-      ifthenelse cond' (runWhileC body *> empty) (runWhileC (k Unit)))
+  eff (R other) = WhileC . eff . handleCoercible $ other
+  eff (L (Abstract.While cond body k)) = do
+    cond' <- cond
+    ifthenelse cond' (body *> empty) (k Unit)
 
 
 instance Carrier sig m
       => Carrier (Abstract.Unit Type :+: sig) (UnitC Type m) where
-  ret = UnitC . ret
-  eff = UnitC . handleSum
-    (eff . handleCoercible)
-    (\ (Abstract.Unit k) -> runUnitC (k Unit))
+  eff (R other) = UnitC . eff . handleCoercible $ other
+  eff (L (Abstract.Unit k)) = 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 = StringC . handleSum (eff . handleCoercible) (\case
-    Abstract.String   _ k -> runStringC (k String)
-    Abstract.AsString t k -> unify t String *> runStringC (k ""))
+  eff (R other) = StringC . eff . handleCoercible $ other
+  eff (L (Abstract.String _ k)) = k String
+  eff (L (Abstract.AsString t k)) = unify t String *> 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 = NumericC . handleSum (eff . handleCoercible) (\case
-    Abstract.Integer _ k -> runNumericC (k Int)
-    Abstract.Float _ k -> runNumericC (k Float)
-    Abstract.Rational _ k -> runNumericC (k Rational)
-    Abstract.LiftNumeric _ t k -> unify (Int :+ Float :+ Rational) t >>= runNumericC . k
+  eff (R other) = NumericC . eff . handleCoercible $ other
+  eff (L op) = case op of
+    Abstract.Integer _ k -> k Int
+    Abstract.Float _ k -> k Float
+    Abstract.Rational _ k -> k Rational
+    Abstract.LiftNumeric _ t k -> unify (Int :+ Float :+ Rational) t >>= k
     Abstract.LiftNumeric2 _ left right k -> case (left, right) of
-      (Float, Int) -> runNumericC (k Float)
-      (Int, Float) -> runNumericC (k Float)
-      _            -> unify left right >>= runNumericC . k)
+      (Float, Int) -> k Float
+      (Int, Float) -> k Float
+      _            -> 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 = BitwiseC . handleSum (eff . handleCoercible) (\case
-    CastToInteger t k -> unify t (Int :+ Float :+ Rational) >> runBitwiseC (k Int)
-    LiftBitwise _ t k -> unify t Int >>= runBitwiseC . k
-    LiftBitwise2 _ t1 t2 k -> unify Int t1 >>= unify t2 >>= runBitwiseC . k
-    UnsignedRShift t1 t2 k -> unify Int t2 *> unify Int t1 >>= runBitwiseC . k)
+  eff (R other) = BitwiseC . eff . handleCoercible $ other
+  eff (L op) = case op of
+    CastToInteger t k -> unify t (Int :+ Float :+ Rational) *> k Int
+    LiftBitwise _ t k -> unify t Int >>= k
+    LiftBitwise2 _ t1 t2 k -> unify Int t1 >>= unify t2 >>= 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 = ObjectC . handleSum (eff . handleCoercible) (\case
-    Abstract.Object _ k -> runObjectC (k Object)
-    Abstract.ScopedEnvironment _ k -> runObjectC (k Nothing)
-    Abstract.Klass _ _ k -> runObjectC (k Object))
+  eff (R other) = ObjectC . eff . handleCoercible $ other
+  eff (L op) = case op of
+    Abstract.Object _ k -> k Object
+    Abstract.ScopedEnvironment _ k -> k Nothing
+    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 = ArrayC . handleSum (eff . handleCoercible) (\case
-    Abstract.Array fieldTypes k -> do
-          var <- fresh
-          fieldType <- foldr (\ t1 -> (unify t1 =<<)) (pure (Var var)) fieldTypes
-          runArrayC (k (Array fieldType))
-    Abstract.AsArray t k -> do
-          field <- fresh
-          unify t (Array (Var field)) >> runArrayC (k mempty))
+  eff (R other) = ArrayC . eff . handleCoercible $ other
+  eff (L (Abstract.Array fieldTypes k)) = do
+    var <- fresh
+    fieldType <- foldr (\ t1 -> (unify t1 =<<)) (pure (Var var)) fieldTypes
+    k (Array fieldType)
+  eff (L (Abstract.AsArray t k)) = do
+    field <- fresh
+    unify t (Array (Var field)) >> k mempty
 
 instance ( Carrier sig m ) => Carrier (Abstract.Hash Type :+: sig) (HashC Type m) where
-  ret = HashC . ret
-  eff = HashC . handleSum (eff . handleCoercible) (\case
-    Abstract.Hash t k -> runHashC (k (Hash t))
-    Abstract.KvPair t1 t2 k -> runHashC (k (t1 :* t2)))
+  eff (R other) = HashC . eff . handleCoercible $ other
+  eff (L (Abstract.Hash t k)) = k (Hash t)
+  eff (L (Abstract.KvPair t1 t2 k)) = k (t1 :* t2)
 
 
 instance AbstractHole Type where

src/Data/Blob.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveAnyClass, ExplicitNamespaces, PatternSynonyms #-}
 module Data.Blob
 ( Blob(..)
 , Blobs(..)
@@ -6,11 +6,11 @@ module Data.Blob
 , nullBlob
 , sourceBlob
 , noLanguageForBlob
-, BlobPair
-, These(..)
-, blobPairDiffing
-, blobPairInserting
-, blobPairDeleting
+, type BlobPair
+, pattern Diffing
+, pattern Inserting
+, pattern Deleting
+, maybeBlobPair
 , decodeBlobPairs
 , languageForBlobPair
 , languageTagForBlobPair
@@ -75,33 +75,42 @@ instance FromJSON BlobPair where
     before <- o .:? "before"
     after <- o .:? "after"
     case (before, after) of
-      (Just b, Just a)  -> pure $ Join (These b a)
-      (Just b, Nothing) -> pure $ Join (This b)
-      (Nothing, Just a) -> pure $ Join (That a)
+      (Just b, Just a)  -> pure $ Diffing b a
+      (Just b, Nothing) -> pure $ Deleting b
+      (Nothing, Just a) -> pure $ Inserting a
       _                 -> Prelude.fail "Expected object with 'before' and/or 'after' keys only"
 
-blobPairDiffing :: Blob -> Blob -> BlobPair
-blobPairDiffing a b = Join (These a b)
+pattern Diffing :: Blob -> Blob -> BlobPair
+pattern Diffing a b = Join (These a b)
 
-blobPairInserting :: Blob -> BlobPair
-blobPairInserting = Join . That
+pattern Inserting :: Blob -> BlobPair
+pattern Inserting a = Join (That a)
 
-blobPairDeleting :: Blob -> BlobPair
-blobPairDeleting = Join . This
+pattern Deleting :: Blob -> BlobPair
+pattern Deleting b = Join (This b)
+
+{-# COMPLETE Diffing, Inserting, Deleting #-}
+
+maybeBlobPair :: MonadFail m => Maybe Blob -> Maybe Blob -> m BlobPair
+maybeBlobPair a b = case (a, b) of
+  (Just a, Nothing) -> pure (Deleting a)
+  (Nothing, Just b) -> pure (Inserting b)
+  (Just a, Just b)  -> pure (Diffing a b)
+  _                 -> Prologue.fail "expected file pair with content on at least one side"
 
 languageForBlobPair :: BlobPair -> Language
-languageForBlobPair (Join (This Blob{..})) = blobLanguage
-languageForBlobPair (Join (That Blob{..})) = blobLanguage
-languageForBlobPair (Join (These a b))
+languageForBlobPair (Deleting Blob{..})  = blobLanguage
+languageForBlobPair (Inserting Blob{..}) = blobLanguage
+languageForBlobPair (Diffing a b)
   | blobLanguage a == Unknown || blobLanguage b == Unknown
     = Unknown
   | otherwise
     = blobLanguage b
 
 pathForBlobPair :: BlobPair -> FilePath
-pathForBlobPair (Join (This Blob{..}))    = blobPath
-pathForBlobPair (Join (That Blob{..}))    = blobPath
-pathForBlobPair (Join (These _ Blob{..})) = blobPath
+pathForBlobPair (Deleting Blob{..})  = blobPath
+pathForBlobPair (Inserting Blob{..}) = blobPath
+pathForBlobPair (Diffing _ Blob{..}) = blobPath
 
 languageTagForBlobPair :: BlobPair -> [(String, String)]
 languageTagForBlobPair pair = showLanguage (languageForBlobPair pair)

src/Data/File.hs

@@ -8,7 +8,6 @@ module Data.File
   , readBlobFromFile'
   , readBlobsFromDir
   , readFilePair
-  , maybeThese
   ) where
 
 import Prologue
@@ -56,11 +55,7 @@ readBlobsFromDir path = do
   pure (catMaybes blobs)
 
 readFilePair :: forall m. (MonadFail m, MonadIO m) => File -> File -> m BlobPair
-readFilePair a b = Join <$> join (maybeThese <$> readBlobFromFile a <*> readBlobFromFile b)
-
-maybeThese :: MonadFail m => Maybe a -> Maybe b -> m (These a b)
-maybeThese a b = case (a, b) of
-  (Just a, Nothing) -> pure (This a)
-  (Nothing, Just b) -> pure (That b)
-  (Just a, Just b)  -> pure (These a b)
-  _                 -> Prologue.fail "expected file pair with content on at least one side"
+readFilePair a b = do
+  before <- readBlobFromFile a
+  after  <- readBlobFromFile b
+  maybeBlobPair before after

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 }
-  deriving (Applicative, Functor, Monad)
-
-deriving instance (Carrier sig m, Member NonDet sig) => Alternative (Algorithm term1 term2 diff m)
+newtype Algorithm term1 term2 diff m a = Algorithm { runAlgorithm :: m a }
+  deriving (Applicative, Alternative, Functor, Monad)
 
 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)
-        => Algorithm
+runDiff :: 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 = DiffC . handleSum (eff . handleCoercible) (\case
-    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 >>= runDiffC . k
-    RWS as bs k -> traverse (runDiff . diffThese) (rws comparableTerms equivalentTerms as bs) >>= runDiffC . k
-    Delete a k -> runDiffC (k (Diff.deleting a))
-    Insert b k -> runDiffC (k (Diff.inserting b))
-    Replace a b k -> runDiffC (k (Diff.replacing a b)))
+  eff (L op) = case op of
+    Diff t1 t2 k -> runDiff (algorithmForTerms t1 t2) <|> pure (Diff.replacing t1 t2) >>= k
+    Linear (Term (In ann1 f1)) (Term (In ann2 f2)) k -> Diff.merge (ann1, ann2) <$> tryAlignWith (runDiff . diffThese) f1 f2 >>= k
+    RWS as bs k -> traverse (runDiff . diffThese) (rws comparableTerms equivalentTerms as bs) >>= k
+    Delete a k -> k (Diff.deleting a)
+    Insert b k -> k (Diff.inserting b)
+    Replace a b k -> 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/MiniPython/Assignment.hs

@@ -110,7 +110,7 @@ binaryOperator = makeTerm' <$> symbol BinaryOperator <*> children (infixTerm exp
   ])
 
 identifier :: Assignment Term
-identifier = makeTerm <$> (symbol Identifier <|> symbol Identifier' <|> symbol DottedName) <*> (Syntax.Identifier . name <$> source)
+identifier = makeTerm <$> (symbol Identifier <|> symbol DottedName) <*> (Syntax.Identifier . name <$> source)
 
 integer :: Assignment Term
 integer = makeTerm <$> symbol Integer <*> (Literal.Integer <$> source)

src/Language/Python/Assignment.hs

@@ -375,7 +375,7 @@ yield :: Assignment Term
 yield = makeTerm <$> symbol Yield <*> (Statement.Yield <$> children (term ( expression <|> emptyTerm )))
 
 identifier :: Assignment Term
-identifier = makeTerm <$> (symbol Identifier <|> symbol Identifier' <|> symbol DottedName) <*> (Syntax.Identifier . name <$> source)
+identifier = makeTerm <$> (symbol Identifier <|> symbol DottedName) <*> (Syntax.Identifier . name <$> source)
 
 set :: Assignment Term
 set = makeTerm <$> symbol Set <*> children (Literal.Set <$> manyTerm expression)
@@ -414,7 +414,7 @@ import' =   makeTerm'' <$> symbol ImportStatement <*> children (manyTerm (aliase
     -- `import a`
     plainImport = makeTerm <$> symbol DottedName <*> children (Python.Syntax.QualifiedImport  <$> NonEmpty.some1 identifier)
     -- `from a import foo `
-    importSymbol = makeNameAliasPair <$> (symbol Identifier <|> symbol Identifier' <|> symbol DottedName) <*> (mkIdentifier <$> location <*> source)
+    importSymbol = makeNameAliasPair <$> (symbol Identifier <|> symbol DottedName) <*> (mkIdentifier <$> location <*> source)
     -- `from a import foo as bar`
     aliasImportSymbol = makeTerm <$> symbol AliasedImport <*> children (Python.Syntax.Alias <$> identifier <*> identifier)
     -- `from a import *`
@@ -424,7 +424,7 @@ import' =   makeTerm'' <$> symbol ImportStatement <*> children (manyTerm (aliase
     importDottedName = symbol DottedName *> children (qualifiedName <$> NonEmpty.some1 identifierSource)
     importRelative = symbol RelativeImport *> children (relativeQualifiedName <$> importPrefix <*> ((symbol DottedName *> children (many identifierSource)) <|> pure []))
     importPrefix = symbol ImportPrefix *> source
-    identifierSource = (symbol Identifier <|> symbol Identifier') *> source
+    identifierSource = symbol Identifier *> source
 
     makeNameAliasPair location alias = makeTerm location (Python.Syntax.Alias alias alias)
     mkIdentifier location source = makeTerm location (Syntax.Identifier (name source))

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)
-           (Eff (FreshC
-           (Eff VoidC)))) (Graph vertex)
+runGraph :: ReaderC (Graph vertex)
+           (FreshC 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]
-  ( Eff (ErrorC TranslationError
-  ( Eff VoidC))))
+  = StateC [Scope]
+  ( ErrorC TranslationError 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 (Return value)          (Eff
-  ( ReaderC (CurrentScope address) (Eff
-  ( ReaderC (CurrentFrame address) (Eff
-  ( DerefC address value           (Eff
-  ( AllocatorC address             (Eff
-  ( ReaderC ModuleInfo             (Eff
-    m)))))))))))))
+  = ErrorC (LoopControl value)
+  ( ErrorC (Return value)
+  ( ReaderC (CurrentScope address)
+  ( ReaderC (CurrentFrame address)
+  ( DerefC address value
+  ( AllocatorC address
+  ( ReaderC ModuleInfo
+    m))))))
 
 type DomainC term address value m
-  = FunctionC term address value                                          (Eff
-  ( WhileC value                                                          (Eff
-  ( BooleanC value                                                        (Eff
-  ( StringC value                                                         (Eff
-  ( NumericC value                                                        (Eff
-  ( BitwiseC value                                                        (Eff
-  ( ObjectC address value                                                 (Eff
-  ( ArrayC value                                                          (Eff
-  ( HashC value                                                          (Eff
-  ( UnitC value                                                           (Eff
-  ( InterposeC (Resumable (BaseError (UnspecializedError address value))) (Eff
-    m)))))))))))))))))))))
+  = FunctionC term address value
+  ( WhileC value
+  ( BooleanC value
+  ( StringC value
+  ( NumericC value
+  ( BitwiseC value
+  ( ObjectC address value
+  ( ArrayC value
+  ( HashC value
+  ( UnitC value
+  ( InterposeC (Resumable (BaseError (UnspecializedError address value)))
+    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 (Eff (InterposeC (Resumable (BaseError (UnspecializedError address value))) (Eff m)))
+                    , unitC ~ UnitC value (InterposeC (Resumable (BaseError (UnspecializedError address value))) m)
                     , unitSig ~ (Unit value :+: Interpose (Resumable (BaseError (UnspecializedError address value))) :+: sig)
-                    , Carrier unitSig unitC
-                    , hashC ~ HashC value (Eff unitC)
+                    , hashC ~ HashC value unitC
                     , hashSig ~ (Abstract.Hash value :+: unitSig)
-                    , Carrier hashSig hashC
-                    , arrayC ~ ArrayC value (Eff hashC)
+                    , arrayC ~ ArrayC value hashC
                     , arraySig ~ (Abstract.Array value :+: hashSig)
-                    , Carrier arraySig arrayC
-                    , objectC ~ ObjectC address value (Eff arrayC)
+                    , objectC ~ ObjectC address value arrayC
                     , objectSig ~ (Abstract.Object address value :+: arraySig)
-                    , Carrier objectSig objectC
-                    , bitwiseC ~ BitwiseC value (Eff objectC)
+                    , bitwiseC ~ BitwiseC value objectC
                     , bitwiseSig ~ (Abstract.Bitwise value :+: objectSig)
-                    , Carrier bitwiseSig bitwiseC
-                    , numericC ~ NumericC value (Eff bitwiseC)
+                    , numericC ~ NumericC value bitwiseC
                     , numericSig ~ (Abstract.Numeric value :+: bitwiseSig)
-                    , Carrier numericSig numericC
-                    , stringC ~ StringC value (Eff numericC)
+                    , stringC ~ StringC value numericC
                     , stringSig ~ (Abstract.String value :+: numericSig)
-                    , Carrier stringSig stringC
-                    , booleanC ~ BooleanC value (Eff stringC)
+                    , booleanC ~ BooleanC value stringC
                     , booleanSig ~ (Boolean value :+: stringSig)
-                    , Carrier booleanSig booleanC
-                    , whileC ~ WhileC value (Eff booleanC)
+                    , whileC ~ WhileC value booleanC
                     , whileSig ~ (While value :+: booleanSig)
-                    , Carrier whileSig whileC
-                    , functionC ~ FunctionC term address value (Eff whileC)
+                    , functionC ~ FunctionC term address value 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,83 +0,0 @@
-{-# LANGUAGE LambdaCase #-}
-module Semantic.Api.Helpers
-  ( spanToSpan
-  , spanToLegacySpan
-  , toChangeType
-  , languageToApiLanguage
-  , apiLanguageToLanguage
-  , apiBlobsToBlobs
-  , apiBlobToBlob
-  , apiBlobPairsToBlobPairs
-  , apiBlobPairToBlobPair
-  ) where
-
-import           Data.Bifunctor.Join
-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           Data.These
-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
-
-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)) = Join (These (apiBlobToBlob before) (apiBlobToBlob after))
-apiBlobPairToBlobPair (API.BlobPair (Just before) Nothing) = Join (This (apiBlobToBlob before))
-apiBlobPairToBlobPair (API.BlobPair Nothing (Just after)) = Join (That (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/Api/V1/CodeAnalysisPB.hs

@@ -3,6 +3,7 @@
 {-# OPTIONS_GHC -Wno-unused-imports -Wno-missing-export-lists #-}
 module Semantic.Api.V1.CodeAnalysisPB where
 
+import Control.DeepSeq
 import Data.Aeson
 import Data.ByteString (ByteString)
 import Data.Int
@@ -16,7 +17,7 @@ import Proto3.Wire (at, oneof)
 data PingRequest = PingRequest
   { service :: Text
   } deriving stock (Eq, Ord, Show, Generic)
-    deriving anyclass (Named, FromJSON, ToJSON)
+    deriving anyclass (Named, FromJSON, ToJSON, NFData)
 
 instance Message PingRequest where
   encodeMessage _ PingRequest{..} = mconcat
@@ -32,7 +33,7 @@ data PingResponse = PingResponse
   , timestamp :: Text
   , sha :: Text
   } deriving stock (Eq, Ord, Show, Generic)
-    deriving anyclass (Named, FromJSON, ToJSON)
+    deriving anyclass (Named, FromJSON, ToJSON, NFData)
 
 instance Message PingResponse where
   encodeMessage _ PingResponse{..} = mconcat
@@ -51,7 +52,7 @@ instance Message PingResponse where
 data ParseTreeRequest = ParseTreeRequest
   { blobs :: Vector Blob
   } deriving stock (Eq, Ord, Show, Generic)
-    deriving anyclass (Named, FromJSON, ToJSON)
+    deriving anyclass (Named, FromJSON, ToJSON, NFData)
 
 instance Message ParseTreeRequest where
   encodeMessage _ ParseTreeRequest{..} = mconcat
@@ -64,7 +65,7 @@ instance Message ParseTreeRequest where
 data ParseTreeSymbolResponse = ParseTreeSymbolResponse
   { files :: Vector File
   } deriving stock (Eq, Ord, Show, Generic)
-    deriving anyclass (Named, FromJSON, ToJSON)
+    deriving anyclass (Named, FromJSON, ToJSON, NFData)
 
 instance Message ParseTreeSymbolResponse where
   encodeMessage _ ParseTreeSymbolResponse{..} = mconcat
@@ -77,7 +78,7 @@ instance Message ParseTreeSymbolResponse where
 data ParseTreeGraphResponse = ParseTreeGraphResponse
   { files :: Vector ParseTreeFileGraph
   } deriving stock (Eq, Ord, Show, Generic)
-    deriving anyclass (Named, FromJSON, ToJSON)
+    deriving anyclass (Named, FromJSON, ToJSON, NFData)
 
 instance Message ParseTreeGraphResponse where
   encodeMessage _ ParseTreeGraphResponse{..} = mconcat
@@ -94,7 +95,7 @@ data ParseTreeFileGraph = ParseTreeFileGraph
   , edges :: Vector TermEdge
   , errors :: Vector ParseError
   } deriving stock (Eq, Ord, Show, Generic)
-    deriving anyclass (Named, FromJSON, ToJSON)
+    deriving anyclass (Named, FromJSON, ToJSON, NFData)
 
 instance Message ParseTreeFileGraph where
   encodeMessage _ ParseTreeFileGraph{..} = mconcat
@@ -116,7 +117,7 @@ data TermEdge = TermEdge
   { source :: Int64
   , target :: Int64
   } deriving stock (Eq, Ord, Show, Generic)
-    deriving anyclass (Named, FromJSON, ToJSON)
+    deriving anyclass (Named, FromJSON, ToJSON, NFData)
 
 instance Message TermEdge where
   encodeMessage _ TermEdge{..} = mconcat
@@ -133,7 +134,7 @@ data TermVertex = TermVertex
   , term :: Text
   , span :: Maybe Span
   } deriving stock (Eq, Ord, Show, Generic)
-    deriving anyclass (Named, FromJSON, ToJSON)
+    deriving anyclass (Named, FromJSON, ToJSON, NFData)
 
 instance Message TermVertex where
   encodeMessage _ TermVertex{..} = mconcat
@@ -150,7 +151,7 @@ instance Message TermVertex where
 data ParseError = ParseError
   { error :: Text
   } deriving stock (Eq, Ord, Show, Generic)
-    deriving anyclass (Named, FromJSON, ToJSON)
+    deriving anyclass (Named, FromJSON, ToJSON, NFData)
 
 instance Message ParseError where
   encodeMessage _ ParseError{..} = mconcat
@@ -163,7 +164,7 @@ instance Message ParseError where
 data DiffTreeRequest = DiffTreeRequest
   { blobs :: Vector BlobPair
   } deriving stock (Eq, Ord, Show, Generic)
-    deriving anyclass (Named, FromJSON, ToJSON)
+    deriving anyclass (Named, FromJSON, ToJSON, NFData)
 
 instance Message DiffTreeRequest where
   encodeMessage _ DiffTreeRequest{..} = mconcat
@@ -176,7 +177,7 @@ instance Message DiffTreeRequest where
 data DiffTreeTOCResponse = DiffTreeTOCResponse
   { files :: Vector TOCSummaryFile
   } deriving stock (Eq, Ord, Show, Generic)
-    deriving anyclass (Named, FromJSON, ToJSON)
+    deriving anyclass (Named, FromJSON, ToJSON, NFData)
 
 instance Message DiffTreeTOCResponse where
   encodeMessage _ DiffTreeTOCResponse{..} = mconcat
@@ -192,7 +193,7 @@ data TOCSummaryFile = TOCSummaryFile
   , changes :: Vector TOCSummaryChange
   , errors :: Vector TOCSummaryError
   } deriving stock (Eq, Ord, Show, Generic)
-    deriving anyclass (Named, FromJSON, ToJSON)
+    deriving anyclass (Named, FromJSON, ToJSON, NFData)
 
 instance Message TOCSummaryFile where
   encodeMessage _ TOCSummaryFile{..} = mconcat
@@ -214,7 +215,7 @@ data TOCSummaryChange = TOCSummaryChange
   , span :: Maybe Span
   , changeType :: ChangeType
   } deriving stock (Eq, Ord, Show, Generic)
-    deriving anyclass (Named, FromJSON, ToJSON)
+    deriving anyclass (Named, FromJSON, ToJSON, NFData)
 
 instance Message TOCSummaryChange where
   encodeMessage _ TOCSummaryChange{..} = mconcat
@@ -234,7 +235,7 @@ data TOCSummaryError = TOCSummaryError
   { error :: Text
   , span :: Maybe Span
   } deriving stock (Eq, Ord, Show, Generic)
-    deriving anyclass (Named, FromJSON, ToJSON)
+    deriving anyclass (Named, FromJSON, ToJSON, NFData)
 
 instance Message TOCSummaryError where
   encodeMessage _ TOCSummaryError{..} = mconcat
@@ -249,7 +250,7 @@ instance Message TOCSummaryError where
 data DiffTreeGraphResponse = DiffTreeGraphResponse
   { files :: Vector DiffTreeFileGraph
   } deriving stock (Eq, Ord, Show, Generic)
-    deriving anyclass (Named, FromJSON, ToJSON)
+    deriving anyclass (Named, FromJSON, ToJSON, NFData)
 
 instance Message DiffTreeGraphResponse where
   encodeMessage _ DiffTreeGraphResponse{..} = mconcat
@@ -266,7 +267,7 @@ data DiffTreeFileGraph = DiffTreeFileGraph
   , edges :: Vector DiffTreeEdge
   , errors :: Vector ParseError
   } deriving stock (Eq, Ord, Show, Generic)
-    deriving anyclass (Named, FromJSON, ToJSON)
+    deriving anyclass (Named, FromJSON, ToJSON, NFData)
 
 instance Message DiffTreeFileGraph where
   encodeMessage _ DiffTreeFileGraph{..} = mconcat
@@ -288,7 +289,7 @@ data DiffTreeEdge = DiffTreeEdge
   { source :: Int64
   , target :: Int64
   } deriving stock (Eq, Ord, Show, Generic)
-    deriving anyclass (Named, FromJSON, ToJSON)
+    deriving anyclass (Named, FromJSON, ToJSON, NFData)
 
 instance Message DiffTreeEdge where
   encodeMessage _ DiffTreeEdge{..} = mconcat
@@ -306,13 +307,13 @@ data DiffTreeVertexDiffTerm
   | Replaced { replaced :: Maybe ReplacedTerm }
   | Merged { merged :: Maybe MergedTerm }
   deriving stock (Eq, Ord, Show, Generic)
-  deriving anyclass (Message, Named, FromJSON, ToJSON)
+  deriving anyclass (Message, Named, FromJSON, ToJSON, NFData)
 
 data DiffTreeVertex = DiffTreeVertex
   { diffVertexId :: Int64
   , diffTerm :: Maybe DiffTreeVertexDiffTerm
   } deriving stock (Eq, Ord, Show, Generic)
-    deriving anyclass (Named, FromJSON, ToJSON)
+    deriving anyclass (Named, FromJSON, ToJSON, NFData)
 
 instance Message DiffTreeVertex where
   encodeMessage _ DiffTreeVertex{..} = mconcat
@@ -339,7 +340,7 @@ data DeletedTerm = DeletedTerm
   { term :: Text
   , span :: Maybe Span
   } deriving stock (Eq, Ord, Show, Generic)
-    deriving anyclass (Named, FromJSON, ToJSON)
+    deriving anyclass (Named, FromJSON, ToJSON, NFData)
 
 instance Message DeletedTerm where
   encodeMessage _ DeletedTerm{..} = mconcat
@@ -355,7 +356,7 @@ data InsertedTerm = InsertedTerm
   { term :: Text
   , span :: Maybe Span
   } deriving stock (Eq, Ord, Show, Generic)
-    deriving anyclass (Named, FromJSON, ToJSON)
+    deriving anyclass (Named, FromJSON, ToJSON, NFData)
 
 instance Message InsertedTerm where
   encodeMessage _ InsertedTerm{..} = mconcat
@@ -373,7 +374,7 @@ data ReplacedTerm = ReplacedTerm
   , afterTerm :: Text
   , afterSpan :: Maybe Span
   } deriving stock (Eq, Ord, Show, Generic)
-    deriving anyclass (Named, FromJSON, ToJSON)
+    deriving anyclass (Named, FromJSON, ToJSON, NFData)
 
 instance Message ReplacedTerm where
   encodeMessage _ ReplacedTerm{..} = mconcat
@@ -394,7 +395,7 @@ data MergedTerm = MergedTerm
   , beforeSpan :: Maybe Span
   , afterSpan :: Maybe Span
   } deriving stock (Eq, Ord, Show, Generic)
-    deriving anyclass (Named, FromJSON, ToJSON)
+    deriving anyclass (Named, FromJSON, ToJSON, NFData)
 
 instance Message MergedTerm where
   encodeMessage _ MergedTerm{..} = mconcat
@@ -413,7 +414,7 @@ data Blob = Blob
   , path :: Text
   , language :: Language
   } deriving stock (Eq, Ord, Show, Generic)
-    deriving anyclass (Named, FromJSON, ToJSON)
+    deriving anyclass (Named, FromJSON, ToJSON, NFData)
 
 instance Message Blob where
   encodeMessage _ Blob{..} = mconcat
@@ -431,7 +432,7 @@ data BlobPair = BlobPair
   { before :: Maybe Blob
   , after :: Maybe Blob
   } deriving stock (Eq, Ord, Show, Generic)
-    deriving anyclass (Named, FromJSON, ToJSON)
+    deriving anyclass (Named, FromJSON, ToJSON, NFData)
 
 instance Message BlobPair where
   encodeMessage _ BlobPair{..} = mconcat
@@ -449,7 +450,7 @@ data File = File
   , symbols :: Vector Symbol
   , errors :: Vector ParseError
   } deriving stock (Eq, Ord, Show, Generic)
-    deriving anyclass (Named, FromJSON, ToJSON)
+    deriving anyclass (Named, FromJSON, ToJSON, NFData)
 
 instance Message File where
   encodeMessage _ File{..} = mconcat
@@ -472,7 +473,7 @@ data Symbol = Symbol
   , span :: Maybe Span
   , docs :: Maybe Docstring
   } deriving stock (Eq, Ord, Show, Generic)
-    deriving anyclass (Named, FromJSON, ToJSON)
+    deriving anyclass (Named, FromJSON, ToJSON, NFData)
 
 instance Message Symbol where
   encodeMessage _ Symbol{..} = mconcat
@@ -493,7 +494,7 @@ instance Message Symbol where
 data Docstring = Docstring
   { docstring :: Text
   } deriving stock (Eq, Ord, Show, Generic)
-    deriving anyclass (Named, FromJSON, ToJSON)
+    deriving anyclass (Named, FromJSON, ToJSON, NFData)
 
 instance Message Docstring where
   encodeMessage _ Docstring{..} = mconcat
@@ -507,7 +508,7 @@ data Position = Position
   { line :: Int64
   , column :: Int64
   } deriving stock (Eq, Ord, Show, Generic)
-    deriving anyclass (Named, FromJSON, ToJSON)
+    deriving anyclass (Named, FromJSON, ToJSON, NFData)
 
 instance Message Position where
   encodeMessage _ Position{..} = mconcat
@@ -523,7 +524,7 @@ data Span = Span
   { start :: Maybe Position
   , end :: Maybe Position
   } deriving stock (Eq, Ord, Show, Generic)
-    deriving anyclass (Named, FromJSON, ToJSON)
+    deriving anyclass (Named, FromJSON, ToJSON, NFData)
 
 instance Message Span where
   encodeMessage _ Span{..} = mconcat
@@ -541,7 +542,7 @@ data ChangeType
   | Removed
   | Modified
   deriving stock (Eq, Ord, Show, Enum, Bounded, Generic)
-  deriving anyclass (Named, MessageField, FromJSON, ToJSON)
+  deriving anyclass (Named, MessageField, FromJSON, ToJSON, NFData)
   deriving Primitive via PrimitiveEnum ChangeType
 instance HasDefault ChangeType where def = None
 
@@ -559,6 +560,6 @@ data Language
   | Typescript
   | Php
   deriving stock (Eq, Ord, Show, Enum, Bounded, Generic)
-  deriving anyclass (Named, MessageField, FromJSON, ToJSON)
+  deriving anyclass (Named, MessageField, FromJSON, ToJSON, NFData)
   deriving Primitive via PrimitiveEnum Language
 instance HasDefault Language where def = Unknown

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 = fmap (withStrategy (parTraversable rseq)) <$> traverse (send . flip Distribute ret)
+distribute :: (Member Distribute sig, Traversable t, Carrier sig m) => t (m output) -> m (t output)
+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 = runDistributeC . interpret
+runDistribute :: DistributeC (LiftC IO) a -> LiftC IO a
+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
-  ret = DistributeC . ret
-  eff = DistributeC . handleSum
-    (eff . handleCoercible)
-    (\ (Distribute task k) -> liftIO (Async.runConcurrently (Async.Concurrently (runM (runDistributeC task)))) >>= runDistributeC . k)
+instance Carrier (Distribute :+: Lift IO) (DistributeC (LiftC IO)) where
+  eff (L (Distribute task k)) = liftIO (Async.runConcurrently (Async.Concurrently (runM . runDistributeC $ task))) >>= k
+  eff (R other) = DistributeC (eff (handleCoercible other))

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
-               => Evaluator term address value (ReaderC (ModuleTable (Module (ModuleResult address value))) (Eff m)) a
+runModuleTable :: Evaluator term address value (ReaderC (ModuleTable (Module (ModuleResult address value))) 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)
-        => Evaluator term address value (StateC (Heap address address value) (Eff m)) a
+runHeap :: Evaluator term address value (StateC (Heap address address value) m) a
         -> Evaluator term address value m (Heap address address value, a)
 runHeap = raiseHandler (runState lowerBound)
 
-runScopeGraph :: (Carrier sig m, Effect sig, Ord address)
-        => Evaluator term address value (StateC (ScopeGraph address) (Eff m)) a
-        -> Evaluator term address value m (ScopeGraph address, a)
+runScopeGraph :: Ord address
+              => Evaluator term address value (StateC (ScopeGraph address) m) 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
-                                                         m)) a
+                         => Evaluator term address value (ResumableWithC (BaseError ResolutionError) m) a
                          -> Evaluator term address value m a
-resumingResolutionError = runResolutionErrorWith (\ baseError -> traceError "ResolutionError" baseError *> case baseErrorException baseError of
-  NotFoundError nameToResolve _ _ -> pure  nameToResolve
-  GoImportError pathToResolve     -> pure [pathToResolve])
+resumingResolutionError = runResolutionErrorWith $ \ baseError -> do
+  traceError "ResolutionError" baseError
+  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
-                                                  m)) a
+                  => Evaluator term address value (ResumableWithC (BaseError (EvalError term address value)) 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
-                                                      m)) a
+                      => Evaluator term address value (ResumableWithC (BaseError (UnspecializedError address value)) 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
-                                                     m)) a
+                     => Evaluator term address value (ResumableWithC (BaseError (AddressError address value)) m) a
                      -> Evaluator term address value m a
-resumingAddressError = runAddressErrorWith $ \ baseError -> traceError "AddressError" baseError *> case baseErrorException baseError of
-  UnallocatedSlot   _ -> pure lowerBound
-  UninitializedSlot _ -> pure hole
+resumingAddressError = runAddressErrorWith $ \ baseError -> do
+  traceError "AddressError" baseError
+  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
-                                                                  m)) a
+                   => Evaluator term address (Value term address) (ResumableWithC (BaseError (ValueError term address)) 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
-                                                 (StateC TypeMap (Eff
-                                                 m)))) a
+                  => Evaluator term address Type (ResumableWithC (BaseError TypeError)
+                                                 (StateC TypeMap
+                                                 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 = flip runTelemetryIgnoringStatC logOptions . interpret
+runTelemetryIgnoringStat :: LogOptions -> TelemetryIgnoringStatC m a -> m a
+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 op = TelemetryIgnoringStatC (\ logOptions -> handleSum (eff . handleReader logOptions runTelemetryIgnoringStatC) (\case
-    WriteStat _                  k -> runTelemetryIgnoringStatC k logOptions
-    WriteLog level message pairs k -> do
-      time <- liftIO Time.getCurrentTime
-      zonedTime <- liftIO (LocalTime.utcToLocalZonedTime time)
-      writeLogMessage logOptions (Message level message pairs zonedTime)
-      runTelemetryIgnoringStatC k logOptions) op)
+  eff (R other) = TelemetryIgnoringStatC . eff . R . handleCoercible $ other
+  eff (L op) = do
+    logOptions <- TelemetryIgnoringStatC ask
+    case op of
+      WriteStat _                  k -> k
+      WriteLog level message pairs k -> do
+        time <- liftIO Time.getCurrentTime
+        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)
-  JavaScript -> send (NodeJSResolution projectRootDir "main"  projectExcludeDirs ret)
-  _          -> send (NoResolution ret)
+  TypeScript -> send (NodeJSResolution projectRootDir "types" projectExcludeDirs pure)
+  JavaScript -> send (NodeJSResolution projectRootDir "main"  projectExcludeDirs pure)
+  _          -> 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 = runResolutionC . interpret
+runResolution :: ResolutionC m a -> m a
+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
-  ret = ResolutionC . ret
-  eff = ResolutionC . handleSum (eff . handleCoercible) (\case
-    NodeJSResolution dir prop excludeDirs k -> nodeJSResolutionMap dir prop excludeDirs >>= runResolutionC . k
-    NoResolution                          k -> runResolutionC (k Map.empty))
+instance (Member Files sig, Carrier sig m) => Carrier (Resolution :+: sig) (ResolutionC m) where
+  eff (R other) = ResolutionC . eff . handleCoercible $ other
+  eff (L op) = case op of
+    NodeJSResolution dir prop excludeDirs k -> nodeJSResolutionMap dir prop excludeDirs >>= k
+    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
-  ( Eff (ResolutionC
-  ( Eff (Files.FilesC
-  ( Eff (ReaderC TaskSession
-  ( Eff (TraceInTelemetryC
-  ( Eff (TelemetryC
-  ( Eff (ErrorC SomeException
-  ( Eff (TimeoutC
-  ( Eff (ResourceC
-  ( Eff (DistributeC
-  ( Eff (LiftC IO)))))))))))))))))))))
+  = TaskC
+  ( ResolutionC
+  ( Files.FilesC
+  ( ReaderC TaskSession
+  ( TraceInTelemetryC
+  ( TelemetryC
+  ( ErrorC SomeException
+  ( TimeoutC
+  ( ResourceC
+  ( DistributeC
+  ( 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)
-                    => Eff (TraceInTelemetryC m) a
+runTraceInTelemetry :: 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
-  ret = TraceInTelemetryC . ret
-  eff = TraceInTelemetryC . handleSum
-    (eff . handleCoercible)
-    (\ (Trace str k) -> writeLog Debug str [] >> runTraceInTelemetryC k)
+instance (Member Telemetry sig, Carrier sig m) => Carrier (Trace :+: sig) (TraceInTelemetryC m) where
+  eff (R other) = TraceInTelemetryC . eff . handleCoercible $ other
+  eff (L (Trace str k)) = writeLog Debug str [] >> 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
-            , 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
-            )
-         => Eff (TaskC m) a
-         -> m a
-runTaskF = runTaskC . interpret
+runTaskF :: TaskC m a -> m a
+runTaskF = runTaskC
 
 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 = TaskC . handleSum (eff . handleCoercible) (\case
-    Parse parser blob k -> runParser blob parser >>= runTaskC . k
-    Analyze interpret analysis k -> runTaskC (k (interpret analysis))
-    Decorate algebra term k -> runTaskC (k (decoratorWithAlgebra algebra term))
-    Semantic.Task.Diff terms k -> runTaskC (k (diffTermPair terms))
-    Render renderer input k -> runTaskC (k (renderer input))
+  eff (R other) = TaskC . eff . handleCoercible $ other
+  eff (L op) = case op of
+    Parse parser blob k -> runParser blob parser >>= k
+    Analyze interpret analysis k -> k . interpret $ analysis
+    Decorate algebra term k -> k (decoratorWithAlgebra algebra term)
+    Semantic.Task.Diff terms k -> k (diffTermPair terms)
+    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 = runFilesC . interpret
+runFiles :: FilesC m a -> m a
+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 = FilesC . handleSum (eff . handleCoercible) (\case
-    Read (FromPath path) k -> (readBlobFromFile' path `catchIO` (throwError . toException @SomeException)) >>= runFilesC . k
-    Read (FromHandle handle) k -> (readBlobsFromHandle handle  `catchIO` (throwError . toException @SomeException)) >>= runFilesC . k
-    Read (FromPathPair paths) k -> (runBothWith readFilePair paths `catchIO` (throwError . toException @SomeException)) >>= runFilesC . k
-    Read (FromPairHandle handle) k -> (readBlobPairsFromHandle handle `catchIO` (throwError . toException @SomeException)) >>= runFilesC . k
-    ReadProject rootDir dir language excludeDirs k -> (readProjectFromPaths rootDir dir language excludeDirs `catchIO` (throwError . toException @SomeException)) >>= runFilesC . k
-    FindFiles dir exts excludeDirs k -> (findFilesInDir dir exts excludeDirs `catchIO` (throwError . toException @SomeException)) >>= runFilesC . k
-    Write (ToPath path) builder k -> liftIO (IO.withBinaryFile path IO.WriteMode (`B.hPutBuilder` builder)) >> runFilesC k
-    Write (ToHandle (WriteHandle handle)) builder k -> liftIO (B.hPutBuilder handle builder) >> runFilesC k)
+  eff (L op) = case op of
+    Read (FromPath path) k -> (readBlobFromFile' path `catchIO` (throwError . toException @SomeException)) >>= k
+    Read (FromHandle handle) k -> (readBlobsFromHandle handle  `catchIO` (throwError . toException @SomeException)) >>= k
+    Read (FromPathPair paths) k -> (runBothWith readFilePair paths `catchIO` (throwError . toException @SomeException)) >>= k
+    Read (FromPairHandle handle) k -> (readBlobPairsFromHandle handle `catchIO` (throwError . toException @SomeException)) >>= k
+    ReadProject rootDir dir language excludeDirs k -> (readProjectFromPaths rootDir dir language excludeDirs `catchIO` (throwError . toException @SomeException)) >>= k
+    FindFiles dir exts excludeDirs k -> (findFilesInDir dir exts excludeDirs `catchIO` (throwError . toException @SomeException)) >>= k
+    Write (ToPath path) builder k -> liftIO (IO.withBinaryFile path IO.WriteMode (`B.hPutBuilder` builder)) >> k
+    Write (ToHandle (WriteHandle handle)) builder k -> liftIO (B.hPutBuilder handle builder) >> 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 (Left handle) = send (Read (FromHandle handle) ret)
-readBlobs (Right paths) = traverse (send . flip Read ret . FromPath) paths
+readBlobs :: (Member Files sig, Carrier sig m) => Either (Handle 'IO.ReadMode) [File] -> m [Blob]
+readBlobs (Left handle) = send (Read (FromHandle handle) pure)
+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 (Left handle) = send (Read (FromPairHandle handle) ret)
-readBlobPairs (Right paths) = traverse (send . flip Read ret . FromPathPair) paths
+readBlobPairs :: (Member Files sig, Carrier sig m) => Either (Handle 'IO.ReadMode) [Both File] -> m [BlobPair]
+readBlobPairs (Left handle) = send (Read (FromPairHandle handle) pure)
+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 logger statter = flip runTelemetryC (logger, statter) . interpret
+runTelemetry :: LogQueue -> StatQueue -> TelemetryC m a -> m a
+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 op = TelemetryC (\ queues -> handleSum (eff . handleReader queues runTelemetryC) (\case
-    WriteStat stat               k -> queueStat (snd queues) stat *> runTelemetryC k queues
-    WriteLog level message pairs k -> queueLogMessage (fst queues) level message pairs *> runTelemetryC k queues) op)
-
+  eff (L op) = do
+    queues <- TelemetryC ask
+    case op of
+      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 = runIgnoreTelemetryC . interpret
+ignoreTelemetry :: IgnoreTelemetryC m a -> m a
+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 = handleSum (IgnoreTelemetryC . eff . handlePure runIgnoreTelemetryC) (\case
-    WriteStat _    k -> k
-    WriteLog _ _ _ k -> k)
+  eff (R other) = IgnoreTelemetryC . eff . handleCoercible $ other
+  eff (L (WriteStat _ k))    = k
+  eff (L (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.
-runTimeout :: (Carrier sig m, MonadIO m)
-           => (forall x . m x -> IO x)
-           -> Eff (TimeoutC m) a
+-- | Evaulate a 'Timeout' effect.
+runTimeout :: (forall x . m x -> IO x)
+           -> 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
-runTimeoutC f (TimeoutC m) = m f
+runHandler :: Handler m -> TimeoutC m a -> IO a
+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 op = TimeoutC (\ handler -> handleSum
-    (eff . handlePure (runTimeoutC handler))
-    (\ (Timeout n task k) -> liftIO (System.timeout (toMicroseconds n) (handler (runTimeoutC handler task))) >>= runTimeoutC handler . k) op)
+  eff (L (Timeout n task k)) = do
+    handler <- TimeoutC ask
+    liftIO (System.timeout (toMicroseconds n) (runHandler handler task)) >>= k
+  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))
-          (Eff (ResumableWithC (BaseError ResolutionError)
-          (Eff (ResumableWithC (BaseError (EvalError term hole value))
-          (Eff (ResumableWithC (BaseError (HeapError hole))
-          (Eff (ResumableWithC (BaseError (ScopeError hole))
-          (Eff (ResumableWithC (BaseError (UnspecializedError hole value))
-          (Eff (ResumableWithC (BaseError (LoadError hole value))
-          (Eff (FreshC
-          (Eff (StateC (ScopeGraph hole)
-          (Eff (StateC (Heap hole hole (Concrete.Value (Quieterm (Sum lang) Location) (Hole (Maybe Name) Precise)))
-          (Eff (TraceByPrintingC
-          (Eff (LiftC IO))))))))))))))))))))))))) a
+          (ResumableWithC (BaseError (AddressError hole value))
+          (ResumableWithC (BaseError ResolutionError)
+          (ResumableWithC (BaseError (EvalError term hole value))
+          (ResumableWithC (BaseError (HeapError hole))
+          (ResumableWithC (BaseError (ScopeError hole))
+          (ResumableWithC (BaseError (UnspecializedError hole value))
+          (ResumableWithC (BaseError (LoadError hole value))
+          (FreshC
+          (StateC (ScopeGraph hole)
+          (StateC (Heap hole hole (Concrete.Value (Quieterm (Sum lang) Location) (Hole (Maybe Name) Precise)))
+          (TraceByPrintingC
+          (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
-                                                                   (AltC
-                                                                      []
-                                                                      (Eff
+                                                                   (NonDetC
                                                                          (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
@@ -564,17 +534,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)))
-                         (Eff (ResumableC (BaseError ResolutionError)
-                         (Eff (ResumableC (BaseError (EvalError qterm Precise (Value qterm Precise)))
-                         (Eff (ResumableC (BaseError (HeapError Precise))
-                         (Eff (ResumableC (BaseError (ScopeError Precise))
-                         (Eff (ResumableC (BaseError (UnspecializedError Precise (Value qterm Precise)))
-                         (Eff (ResumableC (BaseError (LoadError Precise (Value qterm Precise)))
-                         (Eff (FreshC (Eff (StateC (ScopeGraph Precise)
-                         (Eff (StateC (Heap Precise Precise (Value qterm Precise))
-                         (Eff (TraceByPrintingC
-                         (Eff (LiftC IO))))))))))))))))))))))))
+                         (ResumableC (BaseError (AddressError Precise (Value qterm Precise)))
+                         (ResumableC (BaseError ResolutionError)
+                         (ResumableC (BaseError (EvalError qterm Precise (Value qterm Precise)))
+                         (ResumableC (BaseError (HeapError Precise))
+                         (ResumableC (BaseError (ScopeError Precise))
+                         (ResumableC (BaseError (UnspecializedError Precise (Value qterm Precise)))
+                         (ResumableC (BaseError (LoadError Precise (Value qterm Precise)))
+                         (FreshC
+                         (StateC (ScopeGraph Precise)
+                         (StateC (Heap Precise Precise (Value qterm Precise))
+                         (TraceByPrintingC
+                         (LiftC IO))))))))))))
 
 type LanguageSyntax lang syntax = ( Language.SLanguage lang
                                   , HasPrelude lang
@@ -643,18 +614,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)))
-                               (Eff (ResumableWithC (BaseError ResolutionError)
-                               (Eff (ResumableWithC (BaseError (EvalError qterm address (Value qterm address)))
-                               (Eff (ResumableWithC (BaseError (HeapError address))
-                               (Eff (ResumableWithC (BaseError (ScopeError address))
-                               (Eff (ResumableWithC (BaseError (UnspecializedError address (Value qterm address)))
-                               (Eff (ResumableWithC (BaseError (LoadError address (Value qterm address)))
-                               (Eff (FreshC
-                               (Eff (StateC (ScopeGraph address)
-                               (Eff (StateC (Heap address address (Value qterm address))
-                               (Eff (TraceByPrintingC
-                               (Eff (LiftC IO)))))))))))))))))))))))))
+                               (ResumableWithC (BaseError (AddressError address (Value qterm address)))
+                               (ResumableWithC (BaseError ResolutionError)
+                               (ResumableWithC (BaseError (EvalError qterm address (Value qterm address)))
+                               (ResumableWithC (BaseError (HeapError address))
+                               (ResumableWithC (BaseError (ScopeError address))
+                               (ResumableWithC (BaseError (UnspecializedError address (Value qterm address)))
+                               (ResumableWithC (BaseError (LoadError address (Value qterm address)))
+                               (FreshC
+                               (StateC (ScopeGraph address)
+                               (StateC (Heap address address (Value qterm address))
+                               (TraceByPrintingC
+                               (LiftC IO)))))))))))))
                              (ModuleTable (Module
                                 (ModuleResult address (Value qterm address)))))
 evaluateProjectForScopeGraph proxy parser project = runTask' $ do
@@ -678,22 +649,23 @@ evaluateProjectWithCaching :: ( term ~ Term (Sum syntax) Location
                           -> FilePath
                           -> IO (Evaluator qterm Monovariant Type
                                   (ResumableC (BaseError Type.TypeError)
-                                  (Eff (StateC TypeMap
-                                  (Eff (ResumableC (BaseError (AddressError Monovariant Type))
-                                  (Eff (ResumableC (BaseError (EvalError qterm Monovariant Type))
-                                  (Eff (ResumableC (BaseError ResolutionError)
-                                  (Eff (ResumableC (BaseError (HeapError Monovariant))
-                                  (Eff (ResumableC (BaseError (ScopeError Monovariant))
-                                  (Eff (ResumableC (BaseError (UnspecializedError Monovariant Type))
-                                  (Eff (ResumableC (BaseError (LoadError Monovariant Type))
-                                  (Eff (ReaderC (Live Monovariant)
-                                  (Eff (AltC []
-                                  (Eff (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)
-                                  (Eff (FreshC
-                                  (Eff (StateC (ScopeGraph Monovariant)
-                                  (Eff (StateC (Heap Monovariant Monovariant Type)
-                                  (Eff (TraceByPrintingC (Eff (LiftC IO)))))))))))))))))))))))))))))))))))
+                                  (StateC TypeMap
+                                  (ResumableC (BaseError (AddressError Monovariant Type))
+                                  (ResumableC (BaseError (EvalError qterm Monovariant Type))
+                                  (ResumableC (BaseError ResolutionError)
+                                  (ResumableC (BaseError (HeapError Monovariant))
+                                  (ResumableC (BaseError (ScopeError Monovariant))
+                                  (ResumableC (BaseError (UnspecializedError Monovariant Type))
+                                  (ResumableC (BaseError (LoadError Monovariant Type))
+                                  (ReaderC (Live Monovariant)
+                                  (NonDetC
+                                  (ReaderC (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)
+                                  (FreshC
+                                  (StateC (ScopeGraph Monovariant)
+                                  (StateC (Heap Monovariant Monovariant Type)
+                                  (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]
-  ( Eff (ErrorC TranslationError
-  ( Eff VoidC))))
+  = StateC [ContextToken]
+  ( ErrorC TranslationError 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
-                 (Eff (NumericC Val
-                 (Eff (ErrorC (LoopControl Val)
-                 (Eff (ErrorC (Return Val)
-                 (Eff (AllocatorC Precise
-                 (Eff (DerefC Precise Val
-                 (Eff (ResumableC (BaseError (EvalError SpecEff Precise Val))
-                 (Eff (ResumableC (BaseError (AddressError Precise Val))
-                 (Eff (ResumableC (BaseError (ValueError SpecEff Precise))
-                 (Eff (ResumableC (BaseError (HeapError Precise))
-                 (Eff (ResumableC (BaseError (ScopeError Precise))
-                 (Eff (ReaderC (CurrentFrame Precise)
-                 (Eff (ReaderC (CurrentScope Precise)
-                 (Eff (AllocatorC Precise
-                 (Eff (ReaderC Span
-                 (Eff (StateC Span
-                 (Eff (ReaderC ModuleInfo
-                 (Eff (ReaderC PackageInfo
-                 (Eff (FreshC
-                 (Eff (StateC (Heap Precise Precise Val)
-                 (Eff (StateC (ScopeGraph Precise)
-                 (Eff (TraceByIgnoringC
-                 (Eff (LiftC IO)))))))))))))))))))))))))))))))))))))))))))))))
+                 (BooleanC Val
+                 (NumericC Val
+                 (ErrorC (LoopControl Val)
+                 (ErrorC (Return Val)
+                 (AllocatorC Precise
+                 (DerefC Precise Val
+                 (ResumableC (BaseError (EvalError SpecEff Precise Val))
+                 (ResumableC (BaseError (AddressError Precise Val))
+                 (ResumableC (BaseError (ValueError SpecEff Precise))
+                 (ResumableC (BaseError (HeapError Precise))
+                 (ResumableC (BaseError (ScopeError Precise))
+                 (ReaderC (CurrentFrame Precise)
+                 (ReaderC (CurrentScope Precise)
+                 (AllocatorC Precise
+                 (ReaderC Span
+                 (StateC Span
+                 (ReaderC ModuleInfo
+                 (ReaderC PackageInfo
+                 (FreshC
+                 (StateC (Heap Precise Precise Val)
+                 (StateC (ScopeGraph Precise)
+                 (TraceByIgnoringC
+                 (LiftC IO))))))))))))))))))))))))
                  Val
   }
 

test/Data/Functor/Listable.hs

@@ -570,7 +570,7 @@ instance Listable Span where
 instance Listable Blob where
   tiers = cons3 Blob
 
-instance Listable (Join These Blob) where
+instance Listable BlobPair where
   tiers = liftTiers tiers
 
 instance Listable Source where

test/Semantic/IO/Spec.hs

@@ -38,34 +38,34 @@ spec = parallel $ do
       putStrLn "step 1"
       blobs <- blobsFromFilePath "test/fixtures/cli/diff.json"
       putStrLn "done"
-      blobs `shouldBe` [blobPairDiffing a b]
+      blobs `shouldBe` [Diffing a b]
 
     it "returns blobs when there's no before" $ do
       blobs <- blobsFromFilePath "test/fixtures/cli/diff-no-before.json"
-      blobs `shouldBe` [blobPairInserting b]
+      blobs `shouldBe` [Inserting b]
 
     it "returns blobs when there's null before" $ do
       blobs <- blobsFromFilePath "test/fixtures/cli/diff-null-before.json"
-      blobs `shouldBe` [blobPairInserting b]
+      blobs `shouldBe` [Inserting b]
 
     it "returns blobs when there's no after" $ do
       blobs <- blobsFromFilePath "test/fixtures/cli/diff-no-after.json"
-      blobs `shouldBe` [blobPairDeleting a]
+      blobs `shouldBe` [Deleting a]
 
     it "returns blobs when there's null after" $ do
       blobs <- blobsFromFilePath "test/fixtures/cli/diff-null-after.json"
-      blobs `shouldBe` [blobPairDeleting a]
+      blobs `shouldBe` [Deleting a]
 
 
     it "returns blobs for unsupported language" $ do
       h <- openFileForReading "test/fixtures/cli/diff-unsupported-language.json"
       blobs <- readBlobPairsFromHandle h
       let b' = sourceBlob "test.kt" Unknown "fun main(args: Array<String>) {\nprintln(\"hi\")\n}\n"
-      blobs `shouldBe` [blobPairInserting b']
+      blobs `shouldBe` [Inserting b']
 
     it "detects language based on filepath for empty language" $ do
       blobs <- blobsFromFilePath "test/fixtures/cli/diff-empty-language.json"
-      blobs `shouldBe` [blobPairDiffing a b]
+      blobs `shouldBe` [Diffing a b]
 
     it "throws on blank input" $ do
       h <- openFileForReading "test/fixtures/cli/blank.json"

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 (ValueError term Precise)) (Eff
-  ( ResumableC (BaseError ResolutionError) (Eff
-  ( ResumableC (BaseError (EvalError term Precise (Val term))) (Eff
-  ( ResumableC (BaseError (HeapError Precise)) (Eff
-  ( ResumableC (BaseError (ScopeError Precise)) (Eff
-  ( ResumableC (BaseError (UnspecializedError Precise (Val term))) (Eff
-  ( ResumableC (BaseError (LoadError Precise (Val term))) (Eff
-  ( StateC (Heap Precise Precise (Val term)) (Eff
-  ( StateC (ScopeGraph Precise) (Eff
-  ( FreshC (Eff
-  ( TraceByIgnoringC (Eff
-  ( LiftC IO))))))))))))))))))))))))
+  = ResumableC (BaseError (AddressError Precise (Val term)))
+  ( ResumableC (BaseError (ValueError term Precise))
+  ( ResumableC (BaseError ResolutionError)
+  ( ResumableC (BaseError (EvalError term Precise (Val term)))
+  ( ResumableC (BaseError (HeapError Precise))
+  ( ResumableC (BaseError (ScopeError Precise))
+  ( ResumableC (BaseError (UnspecializedError Precise (Val term)))
+  ( ResumableC (BaseError (LoadError Precise (Val term)))
+  ( StateC (Heap Precise Precise (Val term))
+  ( StateC (ScopeGraph Precise)
+  ( FreshC
+  ( TraceByIgnoringC
+  ( 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

vendor/haskell-tree-sitter

@@ -1 +1 @@
-Subproject commit de469907a0fcd4d522a880c985e533e7849ff8b5
+Subproject commit 53dbe815fd85726484294833dfaece544d5f423d