Fix up handleState implementations

src/Control/Abstract/Environment.hs

@@ -71,13 +71,13 @@ data Env address m return where
   Export :: Name -> Name -> Maybe address -> Env address m ()
 
 instance Effect (Env address) where
-  handleState c dist (Request (Lookup name) k) = Request (Lookup name) (dist . (<$ c) . k)
-  handleState c dist (Request (Bind name addr) k) = Request (Bind name addr) (dist . (<$ c) . k)
-  handleState c dist (Request (Close names) k) = Request (Close names) (dist . (<$ c) . k)
-  handleState c dist (Request (Locally action) k) = Request (Locally (dist (action <$ c))) (dist . fmap k)
-  handleState c dist (Request GetEnv k) = Request GetEnv (dist . (<$ c) . k)
-  handleState c dist (Request (PutEnv e) k) = Request (PutEnv e) (dist . (<$ c) . k)
-  handleState c dist (Request (Export name alias addr) k) = Request (Export name alias addr) (dist . (<$ c) . k)
+  handleState c dist (Request (Lookup name) k) = Request (Lookup name) (\result -> dist (pure result <$ c) k)
+  handleState c dist (Request (Bind name addr) k) = Request (Bind name addr) (\result -> dist (pure result <$ c) k)
+  handleState c dist (Request (Close names) k) = Request (Close names) (\result -> dist (pure result <$ c) k)
+  handleState c dist (Request (Locally action) k) = Request (Locally (dist (action <$ c) k)) pure
+  handleState c dist (Request GetEnv k) = Request GetEnv (\result -> dist (pure result <$ c) k)
+  handleState c dist (Request (PutEnv e) k) = Request (PutEnv e) (\result -> dist (pure result <$ c) k)
+  handleState c dist (Request (Export name alias addr) k) = Request (Export name alias addr) (\result -> dist (pure result <$ c) k)
 
 runEnv :: Effects effects
        => Environment address

src/Control/Abstract/Heap.hs

@@ -175,10 +175,10 @@ runAllocator = interpret $ \ eff -> case eff of
   GC roots -> modifyHeap (heapRestrict <*> reachable roots)
 
 instance Effect (Allocator address value) where
-  handleState c dist (Request (Alloc name) k) = Request (Alloc name) (dist . (<$ c) . k)
-  handleState c dist (Request (Deref addr) k) = Request (Deref addr) (dist . (<$ c) . k)
-  handleState c dist (Request (Assign addr value) k) = Request (Assign addr value) (dist . (<$ c) . k)
-  handleState c dist (Request (GC roots) k) = Request (GC roots) (dist . (<$ c) . k)
+  handleState c dist (Request (Alloc name) k) = Request (Alloc name) (\result -> dist (pure result <$ c) k)
+  handleState c dist (Request (Deref addr) k) = Request (Deref addr) (\result -> dist (pure result <$ c) k)
+  handleState c dist (Request (Assign addr value) k) = Request (Assign addr value) (\result -> dist (pure result <$ c) k)
+  handleState c dist (Request (GC roots) k) = Request (GC roots) (\result -> dist (pure result <$ c) k)
 
 
 data AddressError address value resume where

src/Control/Abstract/Modules.hs

@@ -59,10 +59,10 @@ data Modules address (m :: * -> *) return where
   List    :: FilePath   -> Modules address m [ModulePath]
 
 instance Effect (Modules address) where
-  handleState c dist (Request (Load path) k) = Request (Load path) (dist . (<$ c) . k)
-  handleState c dist (Request (Lookup path) k) = Request (Lookup path) (dist . (<$ c) . k)
-  handleState c dist (Request (Resolve paths) k) = Request (Resolve paths) (dist . (<$ c) . k)
-  handleState c dist (Request (List path) k) = Request (List path) (dist . (<$ c) . k)
+  handleState c dist (Request (Load path) k) = Request (Load path) (\result -> dist (pure result <$ c) k)
+  handleState c dist (Request (Lookup path) k) = Request (Lookup path) (\result -> dist (pure result <$ c) k)
+  handleState c dist (Request (Resolve paths) k) = Request (Resolve paths) (\result -> dist (pure result <$ c) k)
+  handleState c dist (Request (List path) k) = Request (List path) (\result -> dist (pure result <$ c) k)
 
 sendModules :: Member (Modules address) effects => Modules address (Eff effects) return -> Evaluator address value effects return
 sendModules = send

src/Semantic/Distribute.hs

@@ -36,7 +36,7 @@ distributeFoldMap toTask inputs = fmap fold (distribute (fmap toTask inputs))
 newtype Distribute task output = Distribute (task output)
 
 instance Effect Distribute where
-  handleState c dist (Request (Distribute task) k) = Request (Distribute (dist (task <$ c))) (dist . fmap k)
+  handleState c dist (Request (Distribute task) k) = Request (Distribute (dist (task <$ c) k)) pure
 
 
 -- | Evaluate a 'Distribute' effect concurrently.

src/Semantic/IO.hs

@@ -221,10 +221,10 @@ data Files (m :: * -> *) out where
   Write       :: Destination -> B.Builder                             -> Files m ()
 
 instance Effect Files where
-  handleState c dist (Request (Read source) k) = Request (Read source) (dist . (<$ c) . k)
-  handleState c dist (Request (ReadProject rootDir dir language excludeDirs) k) = Request (ReadProject rootDir dir language excludeDirs) (dist . (<$ c) . k)
-  handleState c dist (Request (FindFiles dir exts paths) k) = Request (FindFiles dir exts paths) (dist . (<$ c) . k)
-  handleState c dist (Request (Write destination builder) k) = Request (Write destination builder) (dist . (<$ c) . k)
+  handleState c dist (Request (Read source) k) = Request (Read source) (\result -> dist (pure result <$ c) k)
+  handleState c dist (Request (ReadProject rootDir dir language excludeDirs) k) = Request (ReadProject rootDir dir language excludeDirs) (\result -> dist (pure result <$ c) k)
+  handleState c dist (Request (FindFiles dir exts paths) k) = Request (FindFiles dir exts paths) (\result -> dist (pure result <$ c) k)
+  handleState c dist (Request (Write destination builder) k) = Request (Write destination builder) (\result -> dist (pure result <$ c) k)
 
 -- | Run a 'Files' effect in 'IO'.
 runFiles :: (Member (Exc SomeException) effs, Member (Lift IO) effs, Effects effs) => Eff (Files ': effs) a -> Eff effs a

src/Semantic/Resolution.hs

@@ -40,8 +40,8 @@ data Resolution (m :: * -> *) output where
   NoResolution     ::                                   Resolution m (Map FilePath FilePath)
 
 instance Effect Resolution where
-  handleState c dist (Request (NodeJSResolution path key paths) k) = Request (NodeJSResolution path key paths) (dist . (<$ c) . k)
-  handleState c dist (Request NoResolution k) = Request NoResolution (dist . (<$ c) . k)
+  handleState c dist (Request (NodeJSResolution path key paths) k) = Request (NodeJSResolution path key paths) (\result -> dist (pure result <$ c) k)
+  handleState c dist (Request NoResolution k) = Request NoResolution (\result -> dist (pure result <$ c) k)
 
 runResolution :: (Member Files effs, Effects effs) => Eff (Resolution ': effs) a -> Eff effs a
 runResolution = interpret $ \ res -> case res of

src/Semantic/Task.hs

@@ -168,12 +168,12 @@ data Task (m :: * -> *) output where
   Serialize :: Format input -> input -> Task m Builder
 
 instance Effect Task where
-  handleState c dist (Request (Parse parser blob) k) = Request (Parse parser blob) (dist . (<$ c) . k)
-  handleState c dist (Request (Analyze run analysis) k) = Request (Analyze run analysis) (dist . (<$ c) . k)
-  handleState c dist (Request (Decorate decorator term) k) = Request (Decorate decorator term) (dist . (<$ c) . k)
-  handleState c dist (Request (Semantic.Task.Diff terms) k) = Request (Semantic.Task.Diff terms) (dist . (<$ c) . k)
-  handleState c dist (Request (Render renderer input) k) = Request (Render renderer input) (dist . (<$ c) . k)
-  handleState c dist (Request (Serialize format input) k) = Request (Serialize format input) (dist . (<$ c) . k)
+  handleState c dist (Request (Parse parser blob) k) = Request (Parse parser blob) (\result -> dist (pure result <$ c) k)
+  handleState c dist (Request (Analyze run analysis) k) = Request (Analyze run analysis) (\result -> dist (pure result <$ c) k)
+  handleState c dist (Request (Decorate decorator term) k) = Request (Decorate decorator term) (\result -> dist (pure result <$ c) k)
+  handleState c dist (Request (Semantic.Task.Diff terms) k) = Request (Semantic.Task.Diff terms) (\result -> dist (pure result <$ c) k)
+  handleState c dist (Request (Render renderer input) k) = Request (Render renderer input) (\result -> dist (pure result <$ c) k)
+  handleState c dist (Request (Serialize format input) k) = Request (Serialize format input) (\result -> dist (pure result <$ c) k)
 
 -- | Run a 'Task' effect by performing the actions in 'IO'.
 runTaskF :: (Member (Exc SomeException) effs, Member (Lift IO) effs, Member (Reader Config) effs, Member Telemetry effs, Member Trace effs, Effects effs) => Eff (Task ': effs) a -> Eff effs a

src/Semantic/Telemetry.hs

@@ -134,8 +134,8 @@ data Telemetry (m :: * -> *) output where
   WriteLog  :: Level -> String -> [(String, String)] -> Telemetry m ()
 
 instance Effect Telemetry where
-  handleState c dist (Request (WriteStat stat) k) = Request (WriteStat stat) (dist . (<$ c) . k)
-  handleState c dist (Request (WriteLog level message pairs) k) = Request (WriteLog level message pairs) (dist . (<$ c) . k)
+  handleState c dist (Request (WriteStat stat) k) = Request (WriteStat stat) (\result -> dist (pure result <$ c) k)
+  handleState c dist (Request (WriteLog level message pairs) k) = Request (WriteLog level message pairs) (\result -> dist (pure result <$ c) k)
 
 -- | Run a 'Telemetry' effect by expecting a 'Reader' of 'Queue's to write stats and logs to.
 runTelemetry :: (Member (Lift IO) effects, Effects effects) => LogQueue -> StatQueue -> Eff (Telemetry ': effects) a -> Eff effects a