Clean up a bunch of algebras.

src/Control/Abstract/Modules.hs

@@ -99,7 +99,7 @@ instance ( Member (Reader (ModuleTable (NonEmpty (Module (ModuleResult address))
          )
       => Carrier (Modules address :+: sig) (ModulesC address m) where
   ret = ModulesC . const . ret
-  eff op = ModulesC (\ paths -> (alg paths \/ (eff . handlePure (flip runModulesC paths))) op)
+  eff op = ModulesC (\ paths -> (alg paths \/ eff . handleReader paths runModulesC) op)
     where alg paths (Load    name  k) = askModuleTable >>= maybeM (throwLoadError (ModuleNotFoundError name)) . fmap (runMerging . foldMap1 (Merging . moduleBody)) . ModuleTable.lookup name >>= flip runModulesC paths . k
           alg paths (Lookup  path  k) = askModuleTable >>= flip runModulesC paths . k . fmap (runMerging . foldMap1 (Merging . moduleBody)) . ModuleTable.lookup path
           alg paths (Resolve names k) = runModulesC (k (find (`Set.member` paths) names)) paths

src/Data/Abstract/Address/Hole.hs

@@ -40,13 +40,13 @@ instance ( Carrier (Allocator address :+: sig) (AllocatorC address m)
          )
       => Carrier (Allocator (Hole context address) :+: sig) (AllocatorC (Hole context address) m) where
   ret = demoteA . ret
-  eff = alg \/ AllocatorC . eff . handlePure runAllocatorC
+  eff = alg \/ AllocatorC . eff . handleCoercible
     where alg (Alloc name k) = Total <$> promoteA (eff (L (Alloc name ret))) >>= k
 
 
 instance (Carrier (Deref value :+: sig) (DerefC address value m), Carrier sig m, Monad m)
       => Carrier (Deref value :+: sig) (DerefC (Hole context address) value m) where
   ret = demoteD . ret
-  eff = alg \/ DerefC . eff . handlePure runDerefC
+  eff = alg \/ DerefC . eff . handleCoercible
     where alg (DerefCell cell k) = promoteD (eff (L (DerefCell cell ret))) >>= k
           alg (AssignCell value cell k) = promoteD (eff (L (AssignCell value cell ret))) >>= k

src/Data/Abstract/Address/Located.hs

@@ -43,13 +43,13 @@ instance ( Carrier (Allocator address :+: sig) (AllocatorC address m)
          )
       => Carrier (Allocator (Located address) :+: sig) (AllocatorC (Located address) m) where
   ret = demoteA . ret
-  eff = alg \/ AllocatorC . eff . handlePure runAllocatorC
+  eff = alg \/ AllocatorC . eff . handleCoercible
     where alg (Alloc name k) = Located <$> promoteA (eff (L (Alloc name ret))) <*> currentPackage <*> currentModule <*> pure name <*> ask >>= k
 
 
 instance (Carrier (Deref value :+: sig) (DerefC address value m), Carrier sig m, Monad m)
       => Carrier (Deref value :+: sig) (DerefC (Located address) value m) where
   ret = demoteD . ret
-  eff = alg \/ DerefC . eff . handlePure runDerefC
+  eff = alg \/ DerefC . eff . handleCoercible
     where alg (DerefCell cell k) = promoteD (eff (L (DerefCell cell ret))) >>= k
           alg (AssignCell value cell k) = promoteD (eff (L (AssignCell value cell ret))) >>= k

src/Data/Abstract/Address/Monovariant.hs

@@ -20,12 +20,12 @@ instance Show Monovariant where
 
 instance Carrier sig m => Carrier (Allocator Monovariant :+: sig) (AllocatorC Monovariant m) where
   ret = AllocatorC . ret
-  eff = AllocatorC . (alg \/ (eff . handlePure runAllocatorC))
+  eff = AllocatorC . (alg \/ eff . handleCoercible)
     where alg (Alloc name k) = runAllocatorC (k (Monovariant name))
 
 
 instance (Ord value, Carrier sig m, Alternative m, Monad m) => Carrier (Deref value :+: sig) (DerefC Monovariant value m) where
   ret = DerefC . ret
-  eff = DerefC . (alg \/ (eff . handlePure runDerefC))
+  eff = DerefC . (alg \/ eff . handleCoercible)
     where alg (DerefCell cell k) = traverse (foldMapA pure) (nonEmpty (toList cell)) >>= runDerefC . k
           alg (AssignCell value cell k) = runDerefC (k (Set.insert value cell))

src/Data/Abstract/Address/Precise.hs

@@ -19,12 +19,12 @@ instance Show Precise where
 
 instance (Member Fresh sig, Carrier sig m, Monad m) => Carrier (Allocator Precise :+: sig) (AllocatorC Precise m) where
   ret = AllocatorC . ret
-  eff = AllocatorC . (alg \/ (eff . handlePure runAllocatorC))
+  eff = AllocatorC . (alg \/ eff . handleCoercible)
     where alg (Alloc _ k) = Precise <$> fresh >>= runAllocatorC . k
 
 
 instance Carrier sig m => Carrier (Deref value :+: sig) (DerefC Precise value m) where
   ret = DerefC . ret
-  eff = DerefC . (alg \/ (eff . handlePure runDerefC))
+  eff = DerefC . (alg \/ eff . handleCoercible)
     where alg (DerefCell cell k) = runDerefC (k (fst <$> Set.minView cell))
           alg (AssignCell value _ k) = runDerefC (k (Set.singleton value))

src/Data/Abstract/Value/Abstract.hs

@@ -31,7 +31,7 @@ instance ( Member (Allocator address) sig
          )
       => Carrier (Abstract.Function term address Abstract :+: sig) (FunctionC term address Abstract (Evaluator term address Abstract m)) where
   ret = FunctionC . const . ret
-  eff op = FunctionC (\ eval -> (alg eval \/ (eff . handlePure (flip runFunctionC eval))) op)
+  eff op = FunctionC (\ eval -> (alg eval \/ eff . handleReader eval runFunctionC) op)
     where alg eval = \case
             Function _ params body k -> do
               env <- foldr (\ name rest -> do
@@ -48,7 +48,7 @@ instance ( Member (Allocator address) sig
 
 instance (Carrier sig m, Alternative m, Monad m) => Carrier (Boolean Abstract :+: sig) (BooleanC Abstract m) where
   ret = BooleanC . ret
-  eff = BooleanC . (alg \/ eff . handlePure runBooleanC)
+  eff = BooleanC . (alg \/ eff . handleCoercible)
     where alg (Boolean _ k) = runBooleanC (k Abstract)
           alg (AsBool _ k) = runBooleanC (k True) <|> runBooleanC (k False)
           alg (Disjunction a b k) = (runBooleanC a <|> runBooleanC b) >>= runBooleanC . k
@@ -61,7 +61,7 @@ instance ( Member (Abstract.Boolean Abstract) sig
          )
       => Carrier (While Abstract :+: sig) (WhileC Abstract m) where
   ret = WhileC . ret
-  eff = WhileC . (alg \/ eff . handlePure runWhileC)
+  eff = WhileC . (alg \/ eff . handleCoercible)
     where alg (Abstract.While cond body k) = do
             cond' <- runWhileC cond
             ifthenelse cond' (runWhileC body *> empty) (runWhileC (k unit))

src/Data/Abstract/Value/Concrete.hs

@@ -74,7 +74,7 @@ instance ( FreeVariables term
          )
       => Carrier (Abstract.Function term address (Value term address) :+: sig) (Abstract.FunctionC term address (Value term address) (Evaluator term address (Value term address) m)) where
   ret = FunctionC . const . ret
-  eff op = FunctionC (\ eval -> (alg eval \/ (eff . handlePure (flip runFunctionC eval))) op)
+  eff op = FunctionC (\ eval -> (alg eval \/ eff . handleReader eval runFunctionC) op)
     where alg eval = \case
             Abstract.Function name params body k -> do
               packageInfo <- currentPackage
@@ -107,7 +107,7 @@ instance ( Member (Reader ModuleInfo) sig
          )
       => Carrier (Abstract.Boolean (Value term address) :+: sig) (BooleanC (Value term address) m) where
   ret = BooleanC . ret
-  eff = BooleanC . (alg \/ (eff . handlePure runBooleanC))
+  eff = BooleanC . (alg \/ eff . handleCoercible)
     where alg :: Abstract.Boolean (Value term address) (BooleanC (Value term address) m) (BooleanC (Value term address) m a) -> m a
           alg = \case
             Abstract.Boolean b          k -> runBooleanC . k $! Boolean b
@@ -140,7 +140,7 @@ instance ( Member (Reader ModuleInfo) sig
 --          )
 --       => Carrier (Abstract.While (Value term address) :+: sig) (WhileC (Value term address) (Eff (InterposeC (Resumable (BaseError (UnspecializedError (Value term address)))) m))) where
 --   ret = WhileC . ret
---   eff = WhileC . (alg \/ (eff . handlePure runWhileC))
+--   eff = WhileC . (alg \/ eff . handleCoercible)
 --     where alg = \case
 --             Abstract.While cond body k -> interpose @(Resumable (BaseError (UnspecializedError (Value term address))))
 --                   (\(Resumable (BaseError _ _ (UnspecializedError _)) k) -> throwAbort) (runEvaluator (loop (\continue -> do

src/Data/Abstract/Value/Type.hs

@@ -253,7 +253,7 @@ instance ( Member (Allocator address) sig
          )
       => Carrier (Abstract.Function term address Type :+: sig) (FunctionC term address Type (Evaluator term address Type m)) where
   ret = FunctionC . const . ret
-  eff op = FunctionC (\ eval -> (alg eval \/ (eff . handlePure (flip runFunctionC eval))) op)
+  eff op = FunctionC (\ eval -> (alg eval \/ eff . handleReader eval runFunctionC) op)
     where alg eval = \case
             Abstract.Function _ params body k -> do
               (env, tvars) <- foldr (\ name rest -> do
@@ -285,7 +285,7 @@ instance ( Member (Reader ModuleInfo) sig
          )
       => Carrier (Abstract.Boolean Type :+: sig) (BooleanC Type m) where
   ret = BooleanC . ret
-  eff = BooleanC . (alg \/ (eff . handlePure runBooleanC))
+  eff = BooleanC . (alg \/ eff . handleCoercible)
     where alg (Abstract.Boolean _ k) = runBooleanC (k Bool)
           alg (Abstract.AsBool t k) = unify t Bool *> (runBooleanC (k True) <|> runBooleanC (k False))
           alg (Abstract.Disjunction t1 t2 k) = ((runBooleanC t1 >>= unify Bool) <|> (runBooleanC t2 >>= unify Bool) >>= runBooleanC . k)
@@ -298,7 +298,7 @@ instance ( Member (Abstract.Boolean Type) sig
          )
       => Carrier (Abstract.While Type :+: sig) (WhileC Type m) where
   ret = WhileC . ret
-  eff = WhileC . (alg \/ (eff . handlePure runWhileC))
+  eff = WhileC . (alg \/ eff . handleCoercible)
     where alg (Abstract.While cond body k) = do
             cond' <- runWhileC cond
             ifthenelse cond' (runWhileC body *> empty) (runWhileC (k unit))

src/Semantic/Distribute.hs

@@ -56,4 +56,4 @@ newtype DistributeC m a = DistributeC { runDistributeC :: m a }
 
 instance Carrier (Distribute :+: Lift IO) (DistributeC (Eff (LiftC IO))) where
   ret = DistributeC . ret
-  eff = DistributeC . ((\ (Distribute task k) -> liftIO (Async.runConcurrently (Async.Concurrently (runM (runDistributeC task)))) >>= runDistributeC . k) \/ (eff . handlePure runDistributeC))
+  eff = DistributeC . ((\ (Distribute task k) -> liftIO (Async.runConcurrently (Async.Concurrently (runM (runDistributeC task)))) >>= runDistributeC . k) \/ eff . handleCoercible)

src/Semantic/IO.hs

@@ -243,7 +243,7 @@ newtype FilesC m a = FilesC { runFilesC :: m a }
 
 instance (Member (Error SomeException) sig, MonadIO m, Carrier sig m) => Carrier (Files :+: sig) (FilesC m) where
   ret = FilesC . ret
-  eff = FilesC . (alg \/ (eff . handlePure runFilesC))
+  eff = FilesC . (alg \/ eff . handleCoercible)
     where alg = \case
             Read (FromPath path) k -> (readBlobFromPath path `catchIO` (throwError . toException @SomeException)) >>= runFilesC . k
             Read (FromHandle handle) k -> (readBlobsFromHandle handle  `catchIO` (throwError . toException @SomeException)) >>= runFilesC . k

src/Semantic/Resolution.hs

@@ -63,6 +63,6 @@ newtype ResolutionC m a = ResolutionC { runResolutionC :: m a }
 
 instance (Member Files sig, Carrier sig m, Monad m) => Carrier (Resolution :+: sig) (ResolutionC m) where
   ret = ResolutionC . ret
-  eff = ResolutionC . (alg \/ (eff . handlePure runResolutionC))
+  eff = ResolutionC . (alg \/ eff . handleCoercible)
     where alg (NodeJSResolution dir prop excludeDirs k) = nodeJSResolutionMap dir prop excludeDirs >>= runResolutionC . k
           alg (NoResolution k) = runResolutionC (k Map.empty)

src/Semantic/Task.hs

@@ -205,7 +205,7 @@ newtype TraceInTelemetryC m a = TraceInTelemetryC { runTraceInTelemetryC :: m a
 
 instance (Member Telemetry sig, Carrier sig m, Monad m) => Carrier (Trace :+: sig) (TraceInTelemetryC m) where
   ret = TraceInTelemetryC . ret
-  eff = TraceInTelemetryC . ((\ (Trace str k) -> writeLog Debug str [] >> runTraceInTelemetryC k) \/ (eff . handlePure runTraceInTelemetryC))
+  eff = TraceInTelemetryC . ((\ (Trace str k) -> writeLog Debug str [] >> runTraceInTelemetryC k) \/ eff . handleCoercible)
 
 
 -- | An effect describing high-level tasks to be performed.
@@ -249,7 +249,7 @@ newtype TaskC m a = TaskC { runTaskC :: m a }
 
 instance (Member (Error SomeException) sig, Member (Lift IO) sig, Member (Reader Config) sig, Member Resource sig, Member Telemetry sig, Member Timeout sig, Member Trace sig, Carrier sig m, MonadIO m) => Carrier (Task :+: sig) (TaskC m) where
   ret = TaskC . ret
-  eff = TaskC . (alg \/ (eff . handlePure runTaskC))
+  eff = TaskC . (alg \/ eff . handleCoercible)
     where alg = \case
             Parse parser blob k -> runParser blob parser >>= runTaskC . k
             Analyze interpret analysis k -> runTaskC (k (interpret analysis))

src/Semantic/Telemetry.hs

@@ -158,7 +158,7 @@ newtype TelemetryC m a = TelemetryC { runTelemetryC :: (LogQueue, StatQueue) ->
 
 instance (Carrier sig m, MonadIO m) => Carrier (Telemetry :+: sig) (TelemetryC m) where
   ret = TelemetryC . const . ret
-  eff op = TelemetryC (\ queues -> (alg queues \/ (eff . handlePure (flip runTelemetryC queues))) op)
+  eff op = TelemetryC (\ queues -> (alg queues \/ eff . handleReader queues runTelemetryC) op)
     where alg queues (WriteStat stat k) = queueStat (snd queues) stat *> runTelemetryC k queues
           alg queues (WriteLog level message pairs k) = queueLogMessage (fst queues) level message pairs *> runTelemetryC k queues