diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index 4f896168d..5ffcb4be3 100644 --- a/src/Control/Abstract/Environment.hs +++ b/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) (\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) + 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) runEnv :: Effects effects => Environment address diff --git a/src/Control/Abstract/Heap.hs b/src/Control/Abstract/Heap.hs index 64e26112c..16cfcab93 100644 --- a/src/Control/Abstract/Heap.hs +++ b/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) (\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) + 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) data AddressError address value resume where diff --git a/src/Control/Abstract/Modules.hs b/src/Control/Abstract/Modules.hs index 73a07af88..7a31dbd3f 100644 --- a/src/Control/Abstract/Modules.hs +++ b/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) (\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) + 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) sendModules :: Member (Modules address) effects => Modules address (Eff effects) return -> Evaluator address value effects return sendModules = send diff --git a/src/Semantic/Distribute.hs b/src/Semantic/Distribute.hs index 0b19c8854..69b162606 100644 --- a/src/Semantic/Distribute.hs +++ b/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) k)) pure + handleState c dist (Request (Distribute task) k) = Request (Distribute (dist (task <$ c))) (dist . fmap k) -- | Evaluate a 'Distribute' effect concurrently. diff --git a/src/Semantic/IO.hs b/src/Semantic/IO.hs index 00f01465c..445f294de 100644 --- a/src/Semantic/IO.hs +++ b/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) (\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) + 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) -- | Run a 'Files' effect in 'IO'. runFiles :: (Member (Exc SomeException) effs, Member (Lift IO) effs, Effects effs) => Eff (Files ': effs) a -> Eff effs a diff --git a/src/Semantic/Resolution.hs b/src/Semantic/Resolution.hs index 2db36cea6..62ed86246 100644 --- a/src/Semantic/Resolution.hs +++ b/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) (\result -> dist (pure result <$ c) k) - handleState c dist (Request NoResolution k) = Request NoResolution (\result -> dist (pure result <$ c) k) + 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) runResolution :: (Member Files effs, Effects effs) => Eff (Resolution ': effs) a -> Eff effs a runResolution = interpret $ \ res -> case res of diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 41b8d2345..83d07483c 100644 --- a/src/Semantic/Task.hs +++ b/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) (\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) + 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) -- | 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 diff --git a/src/Semantic/Telemetry.hs b/src/Semantic/Telemetry.hs index 5ff47466c..e42152619 100644 --- a/src/Semantic/Telemetry.hs +++ b/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) (\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) + 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) -- | 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