From 034e2469ff0dad00313b8da43833195f0ad1ce7d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 22 Oct 2018 10:26:15 -0400 Subject: [PATCH] Bump higher-order-effects. --- .../Abstract/Caching/FlowInsensitive.hs | 4 +- .../Abstract/Caching/FlowSensitive.hs | 4 +- src/Analysis/Abstract/Dead.hs | 2 +- src/Analysis/Abstract/Graph.hs | 10 +++-- src/Analysis/Abstract/Tracing.hs | 1 + src/Control/Abstract/Context.hs | 4 +- src/Control/Abstract/Environment.hs | 30 ++++++------- src/Control/Abstract/Evaluator.hs | 12 +++++- src/Control/Abstract/Heap.hs | 9 ++-- src/Control/Abstract/Modules.hs | 22 +++++----- src/Control/Abstract/PythonPackage.hs | 8 ++-- src/Control/Abstract/ScopeGraph.hs | 42 ++++++++++--------- src/Control/Abstract/Value.hs | 15 +++---- src/Control/Effect/Resource.hs | 14 ++++--- src/Control/Rewriting.hs | 3 +- src/Data/Abstract/Address/Hole.hs | 16 +++---- src/Data/Abstract/Address/Located.hs | 16 +++---- src/Data/Abstract/Address/Monovariant.hs | 16 +++---- src/Data/Abstract/Address/Precise.hs | 16 +++---- src/Data/Abstract/Name.hs | 1 + src/Data/Abstract/Value/Abstract.hs | 24 ++++++----- src/Data/Abstract/Value/Concrete.hs | 28 +++++++------ src/Data/Abstract/Value/Type.hs | 26 ++++++------ src/Data/Graph.hs | 1 + src/Data/Project.hs | 1 + src/Language/JSON/PrettyPrint.hs | 1 + src/Language/Python/PrettyPrint.hs | 1 + src/Language/Ruby/PrettyPrint.hs | 1 + src/Parsing/TreeSitter.hs | 3 +- src/Rendering/Graph.hs | 2 + src/Reprinting/Pipeline.hs | 2 + src/Reprinting/Translate.hs | 6 ++- src/Semantic/Distribute.hs | 8 ++-- src/Semantic/IO.hs | 36 +++++++++++----- src/Semantic/Parse.hs | 1 + src/Semantic/Resolution.hs | 16 +++---- src/Semantic/Task.hs | 27 +++++++----- src/Semantic/Telemetry.hs | 24 ++++++----- src/Semantic/Timeout.hs | 10 +++-- vendor/higher-order-effects | 2 +- 40 files changed, 273 insertions(+), 192 deletions(-) diff --git a/src/Analysis/Abstract/Caching/FlowInsensitive.hs b/src/Analysis/Abstract/Caching/FlowInsensitive.hs index 91fe81a25..0d5c45f85 100644 --- a/src/Analysis/Abstract/Caching/FlowInsensitive.hs +++ b/src/Analysis/Abstract/Caching/FlowInsensitive.hs @@ -40,9 +40,9 @@ cachingConfiguration :: (Member (State (Cache term address)) sig, Carrier sig m, -> Evaluator term address value m (ValueRef address) -> Evaluator term address value m (ValueRef address) cachingConfiguration configuration values action = do - modify' (cacheSet configuration values) + modify (cacheSet configuration values) result <- action - result <$ modify' (cacheInsert configuration result) + result <$ modify (cacheInsert configuration result) putCache :: (Member (State (Cache term address)) sig, Carrier sig m) => Cache term address diff --git a/src/Analysis/Abstract/Caching/FlowSensitive.hs b/src/Analysis/Abstract/Caching/FlowSensitive.hs index 26a14c317..581c8b7b9 100644 --- a/src/Analysis/Abstract/Caching/FlowSensitive.hs +++ b/src/Analysis/Abstract/Caching/FlowSensitive.hs @@ -40,9 +40,9 @@ cachingConfiguration :: (Cacheable term address value, Member (State (Cache term -> Evaluator term address value m (ValueRef address) -> Evaluator term address value m (ValueRef address) cachingConfiguration configuration values action = do - modify' (cacheSet configuration values) + modify (cacheSet configuration values) result <- Cached <$> action <*> getHeap - cachedValue result <$ modify' (cacheInsert configuration result) + cachedValue result <$ modify (cacheInsert configuration result) putCache :: (Member (State (Cache term address value)) sig, Carrier sig m) => Cache term address value diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index 6351f0e10..799b5889d 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -24,7 +24,7 @@ killAll = put -- | Revive a single term, removing it from the current 'Dead' set. revive :: (Member (State (Dead term)) sig, Carrier sig m, Ord term) => term -> Evaluator term address value m () -revive t = modify' (Dead . delete t . unDead) +revive t = modify (Dead . delete t . unDead) -- | Compute the set of all subterms recursively. subterms :: (Ord term, Recursive term, Foldable (Base term)) => term -> Dead term diff --git a/src/Analysis/Abstract/Graph.hs b/src/Analysis/Abstract/Graph.hs index 5b5c26438..7ce334c85 100644 --- a/src/Analysis/Abstract/Graph.hs +++ b/src/Analysis/Abstract/Graph.hs @@ -18,6 +18,8 @@ module Analysis.Abstract.Graph import Algebra.Graph.Export.Dot hiding (vertexName) import Control.Abstract hiding (Function(..)) +import Control.Effect.Carrier +import Control.Effect.Sum import Data.Abstract.Address.Hole import Data.Abstract.Address.Located import Data.Abstract.BaseError @@ -101,7 +103,7 @@ graphingTerms recur0 recur term@(Term (In a syntax)) = do local (const v) $ do valRef <- recur0 recur term addr <- Control.Abstract.address valRef - modify' (Map.insert addr v) + modify (Map.insert addr v) pure valRef -- | Add vertices to the graph for evaluated modules and the packages containing them. @@ -164,11 +166,11 @@ runEavesdropC :: (forall x . eff m (m x) -> m ()) -> EavesdropC eff m a -> m a runEavesdropC f (EavesdropC m) = m f instance (Carrier sig m, HFunctor eff, Member eff sig, Applicative m) => Carrier sig (EavesdropC eff m) where - gen a = EavesdropC (const (gen a)) - alg op + ret a = EavesdropC (const (ret a)) + eff op | Just m <- prj op = case m of eff -> EavesdropC (\ handler -> let eff' = handlePure (runEavesdropC handler) eff in handler eff' *> send eff') - | otherwise = EavesdropC (\ handler -> alg (handlePure (runEavesdropC handler) op)) + | otherwise = EavesdropC (\ handler -> eff (handlePure (runEavesdropC handler) op)) -- | Add an edge from the current package to the passed vertex. packageInclusion :: ( Member (Reader PackageInfo) sig diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index 527d618ac..2d564b6b3 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -5,6 +5,7 @@ module Analysis.Abstract.Tracing ) where import Control.Abstract hiding (trace) +import Control.Effect.Writer import Data.Abstract.Environment import Data.Semigroup.Reducer as Reducer diff --git a/src/Control/Abstract/Context.hs b/src/Control/Abstract/Context.hs index c0e033b65..0195977e8 100644 --- a/src/Control/Abstract/Context.hs +++ b/src/Control/Abstract/Context.hs @@ -13,6 +13,8 @@ module Control.Abstract.Context ) where import Control.Effect +import Control.Effect.Reader +import Control.Effect.State import Data.Abstract.Module import Data.Abstract.Package import Data.Span @@ -44,7 +46,7 @@ withCurrentSpan :: (Member (Reader Span) sig, Carrier sig m) => Span -> m a -> m withCurrentSpan = local . const modifyChildSpan :: (Member (State Span) sig, Carrier sig m, Monad m) => Span -> m a -> m a -modifyChildSpan span m = m >>= \a -> modify' (const span) >> pure a +modifyChildSpan span m = m <* put span -- | Run an action with locally-replaced 'ModuleInfo' & 'Span' derived from the passed 'SrcLoc'. withCurrentSrcLoc :: (Member (Reader ModuleInfo) sig, Member (Reader Span) sig, Carrier sig m) => SrcLoc -> m a -> m a diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index 0f8aa286f..4b2d05ea3 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -27,6 +27,8 @@ module Control.Abstract.Environment import Control.Abstract.Evaluator import Control.Abstract.Heap +import Control.Effect.Carrier +import Control.Effect.Sum import Data.Abstract.BaseError import Data.Abstract.Environment (Bindings, Environment, EvalContext(..), EnvironmentError(..)) import qualified Data.Abstract.Environment as Env @@ -38,7 +40,7 @@ import Prologue -- | Retrieve the current execution context getEvalContext :: (Member (Env address) sig, Carrier sig m) => Evaluator term address value m (EvalContext address) -getEvalContext = send (GetCtx gen) +getEvalContext = send (GetCtx ret) -- | Retrieve the current environment getEnv :: (Member (Env address) sig, Carrier sig m) @@ -47,7 +49,7 @@ getEnv = ctxEnvironment <$> getEvalContext -- | Replace the execution context. This is only for use in Analysis.Abstract.Caching. putEvalContext :: (Member (Env address) sig, Carrier sig m) => EvalContext address -> Evaluator term address value m () -putEvalContext context = send (PutCtx context (gen ())) +putEvalContext context = send (PutCtx context (ret ())) withEvalContext :: (Member (Env address) sig, Carrier sig m) => EvalContext address @@ -62,16 +64,16 @@ withEvalContext ctx comp = do -- | Add an export to the global export state. export :: (Member (Env address) sig, Carrier sig m) => Name -> Name -> Maybe address -> Evaluator term address value m () -export name alias addr = send (Export name alias addr (gen ())) +export name alias addr = send (Export name alias addr (ret ())) -- | Look a 'Name' up in the current environment, trying the default environment if no value is found. lookupEnv :: (Member (Env address) sig, Carrier sig m) => Name -> Evaluator term address value m (Maybe address) -lookupEnv name = send (Lookup name gen) +lookupEnv name = send (Lookup name ret) -- | Bind a 'Name' to an address in the current scope. bind :: (Member (Env address) sig, Carrier sig m) => Name -> address -> Evaluator term address value m () -bind name addr = send (Bind name addr (gen ())) +bind name addr = send (Bind name addr (ret ())) -- | Bind all of the names from an 'Environment' in the current scope. bindAll :: (Member (Env address) sig, Carrier sig m) => Bindings address -> Evaluator term address value m () @@ -79,10 +81,10 @@ bindAll = foldr ((>>) . uncurry bind) (pure ()) . Env.pairs -- | Run an action in a new local scope. locally :: forall term address value sig m a . (Member (Env address) sig, Carrier sig m) => Evaluator term address value m a -> Evaluator term address value m a -locally m = send (Locally @address m gen) +locally m = send (Locally @address m ret) close :: (Member (Env address) sig, Carrier sig m) => Set Name -> Evaluator term address value m (Environment address) -close fvs = send (Close fvs gen) +close fvs = send (Close fvs ret) self :: (Member (Env address) sig, Carrier sig m) => Evaluator term address value m (Maybe address) self = ctxSelf <$> getEvalContext @@ -187,20 +189,20 @@ runEnv initial = fmap (filterEnv . fmap (first (Env.head . ctxEnvironment))) . r newtype EnvC m a = EnvC { runEnvC :: m a } instance (Carrier (State (EvalContext address) :+: State (Exports address) :+: sig) m, HFunctor sig) => Carrier (Env address :+: sig) (EnvC (Evaluator term address value m)) where - gen = EnvC . gen - alg = EnvC . (algE \/ (alg . R . R . handlePure runEnvC)) - where algE = \case + ret = EnvC . ret + eff = EnvC . (alg \/ (eff . R . R . handlePure runEnvC)) + where alg = \case Lookup name k -> gets (Env.lookupEnv' name . ctxEnvironment) >>= runEnvC . k - Bind name addr k -> modify' (\EvalContext{..} -> EvalContext ctxSelf (Env.insertEnv name addr ctxEnvironment)) >> runEnvC k + Bind name addr k -> modify (\EvalContext{..} -> EvalContext ctxSelf (Env.insertEnv name addr ctxEnvironment)) >> runEnvC k Close names k -> gets (Env.intersect names . ctxEnvironment) >>= runEnvC . k Locally action k -> do - modify' (\EvalContext{..} -> EvalContext ctxSelf (Env.push @address ctxEnvironment)) + modify (\EvalContext{..} -> EvalContext ctxSelf (Env.push @address ctxEnvironment)) a <- runEnvC action - modify' (\EvalContext{..} -> EvalContext ctxSelf (Env.pop @address ctxEnvironment)) + modify (\EvalContext{..} -> EvalContext ctxSelf (Env.pop @address ctxEnvironment)) runEnvC (k a) GetCtx k -> get >>= runEnvC . k PutCtx e k -> put e >> runEnvC k - Export name alias addr k -> modify' (Exports.insert name alias addr) >> runEnvC k + Export name alias addr k -> modify (Exports.insert name alias addr) >> runEnvC k freeVariableError :: ( Member (Reader ModuleInfo) sig , Member (Reader Span) sig diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index ba6eee0ab..2da7e2d78 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -17,6 +17,14 @@ module Control.Abstract.Evaluator ) where import Control.Effect as X +import Control.Effect.Carrier +import Control.Effect.Error as X +import Control.Effect.Fresh as X +import Control.Effect.NonDet as X +import Control.Effect.Reader as X +import Control.Effect.Resumable as X +import Control.Effect.State as X +import Control.Effect.Trace as X import Control.Monad.IO.Class -- | An 'Evaluator' is a thin wrapper around 'Eff' with (phantom) type parameters for the address, term, and value types. @@ -31,8 +39,8 @@ deriving instance (Member NonDet sig, Carrier sig m) => Alternative (Evaluator t deriving instance (Member (Lift IO) sig, Carrier sig m) => MonadIO (Evaluator term address value m) instance Carrier sig m => Carrier sig (Evaluator term address value m) where - gen = Evaluator . gen - alg = Evaluator . alg . handlePure runEvaluator + ret = Evaluator . ret + eff = Evaluator . eff . handlePure runEvaluator -- | An open-recursive function. diff --git a/src/Control/Abstract/Heap.hs b/src/Control/Abstract/Heap.hs index 2b3b1b155..342ac4f15 100644 --- a/src/Control/Abstract/Heap.hs +++ b/src/Control/Abstract/Heap.hs @@ -25,6 +25,7 @@ module Control.Abstract.Heap import Control.Abstract.Evaluator import Control.Abstract.Roots +import Control.Effect.Carrier import Data.Abstract.BaseError import Data.Abstract.Heap import Data.Abstract.Live @@ -43,7 +44,7 @@ putHeap = put -- | Update the heap. modifyHeap :: (Member (State (Heap address value)) sig, Carrier sig m) => (Heap address value -> Heap address value) -> Evaluator term address value m () -modifyHeap = modify' +modifyHeap = modify box :: ( Member (Allocator address) sig , Member (Deref value) sig @@ -61,7 +62,7 @@ box val = do pure addr alloc :: (Member (Allocator address) sig, Carrier sig m) => Name -> Evaluator term address value m address -alloc = send . flip Alloc gen +alloc = send . flip Alloc ret dealloc :: (Member (State (Heap address value)) sig, Ord address, Carrier sig m) => address -> Evaluator term address value m () dealloc addr = modifyHeap (heapDelete addr) @@ -77,7 +78,7 @@ deref :: ( Member (Deref value) sig ) => address -> Evaluator term address value m value -deref addr = gets (heapLookup addr) >>= maybeM (throwAddressError (UnallocatedAddress addr)) >>= send . flip DerefCell gen >>= maybeM (throwAddressError (UninitializedAddress addr)) +deref addr = gets (heapLookup addr) >>= maybeM (throwAddressError (UnallocatedAddress addr)) >>= send . flip DerefCell ret >>= maybeM (throwAddressError (UninitializedAddress addr)) -- | Write a value to the given address in the 'Allocator'. @@ -91,7 +92,7 @@ assign :: ( Member (Deref value) sig -> Evaluator term address value m () assign addr value = do heap <- getHeap - cell <- send (AssignCell value (fromMaybe lowerBound (heapLookup addr heap)) gen) + cell <- send (AssignCell value (fromMaybe lowerBound (heapLookup addr heap)) ret) putHeap (heapInit addr cell heap) diff --git a/src/Control/Abstract/Modules.hs b/src/Control/Abstract/Modules.hs index ec6567e08..a0a9cf8fb 100644 --- a/src/Control/Abstract/Modules.hs +++ b/src/Control/Abstract/Modules.hs @@ -20,6 +20,8 @@ module Control.Abstract.Modules ) where import Control.Abstract.Evaluator +import Control.Effect.Carrier +import Control.Effect.Sum import Data.Abstract.Environment import Data.Abstract.BaseError import Data.Abstract.Module @@ -37,14 +39,14 @@ type ModuleResult address = (ScopeGraph address, (Bindings address, address)) -- | 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) sig, Carrier sig m) => ModulePath -> Evaluator term address value m (Maybe (ModuleResult address)) -lookupModule = sendModules . flip Lookup gen +lookupModule = sendModules . flip Lookup ret -- | Resolve a list of module paths to a possible module table entry. resolve :: (Member (Modules address) sig, Carrier sig m) => [FilePath] -> Evaluator term address value m (Maybe ModulePath) -resolve = sendModules . flip Resolve gen +resolve = sendModules . flip Resolve ret listModulesInDir :: (Member (Modules address) sig, Carrier sig m) => FilePath -> Evaluator term address value m [ModulePath] -listModulesInDir = sendModules . flip List gen +listModulesInDir = sendModules . flip List ret -- | Require/import another module by name and return its environment and value. @@ -57,7 +59,7 @@ require path = lookupModule path >>= maybeM (load path) -- -- Always loads/evaluates. load :: (Member (Modules address) sig, Carrier sig m) => ModulePath -> Evaluator term address value m (ModuleResult address) -load path = sendModules (Load path gen) +load path = sendModules (Load path ret) data Modules address (m :: * -> *) k @@ -96,12 +98,12 @@ instance ( Member (Reader (ModuleTable (NonEmpty (Module (ModuleResult address)) , Carrier sig m ) => Carrier (Modules address :+: sig) (ModulesC (Evaluator term address value m)) where - gen = ModulesC . const . gen - alg op = ModulesC (\ paths -> (algM paths \/ (alg . handlePure (flip runModulesC paths))) op) - where algM paths (Load name k) = askModuleTable >>= maybeM (throwLoadError (ModuleNotFoundError name)) . fmap (runMerging . foldMap1 (Merging . moduleBody)) . ModuleTable.lookup name >>= flip runModulesC paths . k - algM paths (Lookup path k) = askModuleTable >>= flip runModulesC paths . k . fmap (runMerging . foldMap1 (Merging . moduleBody)) . ModuleTable.lookup path - algM paths (Resolve names k) = runModulesC (k (find (`Set.member` paths) names)) paths - algM paths (List dir k) = runModulesC (k (filter ((dir ==) . takeDirectory) (toList paths))) paths + ret = ModulesC . const . ret + eff op = ModulesC (\ paths -> (alg paths \/ (eff . handlePure (flip runModulesC paths))) 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 + alg paths (List dir k) = runModulesC (k (filter ((dir ==) . takeDirectory) (toList paths))) paths askModuleTable :: (Member (Reader (ModuleTable (NonEmpty (Module (ModuleResult address))))) sig, Carrier sig m) => Evaluator term address value m (ModuleTable (NonEmpty (Module (ModuleResult address)))) askModuleTable = ask diff --git a/src/Control/Abstract/PythonPackage.hs b/src/Control/Abstract/PythonPackage.hs index 32abdf1fe..9254f1b9d 100644 --- a/src/Control/Abstract/PythonPackage.hs +++ b/src/Control/Abstract/PythonPackage.hs @@ -5,6 +5,8 @@ module Control.Abstract.PythonPackage import Control.Abstract.Evaluator (LoopControl, Return) import Control.Abstract.Heap (Allocator, Deref, deref) import Control.Abstract.Value +import Control.Effect.Carrier +import Control.Effect.Sum import Data.Abstract.Evaluatable import Data.Abstract.Name (name) import Data.Abstract.Path (stripQuotes) @@ -77,7 +79,7 @@ runInterposeC :: (forall x . eff m (m x) -> m x) -> InterposeC eff m a -> m a runInterposeC f (InterposeC m) = m f instance (Member eff sig, HFunctor eff, Carrier sig m) => Carrier sig (InterposeC eff m) where - gen a = InterposeC (const (gen a)) - alg op + ret a = InterposeC (const (ret a)) + eff op | Just e <- prj op = InterposeC (\ handler -> handler (handlePure (runInterposeC handler) e)) - | otherwise = InterposeC (\ handler -> alg (handlePure (runInterposeC handler) op)) + | otherwise = InterposeC (\ handler -> eff (handlePure (runInterposeC handler) op)) diff --git a/src/Control/Abstract/ScopeGraph.hs b/src/Control/Abstract/ScopeGraph.hs index 8e809275b..e5c92624a 100644 --- a/src/Control/Abstract/ScopeGraph.hs +++ b/src/Control/Abstract/ScopeGraph.hs @@ -18,6 +18,8 @@ module Control.Abstract.ScopeGraph import Control.Abstract.Evaluator hiding (Local) import Control.Abstract.Heap +import Control.Effect.Carrier +import Control.Effect.Sum import Data.Abstract.Name import Data.Abstract.ScopeGraph (Declaration (..), EdgeLabel, Reference, ScopeGraph) import qualified Data.Abstract.ScopeGraph as ScopeGraph @@ -38,28 +40,28 @@ data ScopeEnv address (m :: * -> *) k deriving instance Functor (ScopeEnv address m) lookup :: (Member (ScopeEnv address) sig, Carrier sig m) => Reference -> Evaluator term address value m (Maybe address) -lookup ref = sendScope (Lookup ref gen) +lookup ref = sendScope (Lookup ref ret) declare :: (Member (ScopeEnv address) sig, Carrier sig m) => Declaration -> Span -> Maybe address -> Evaluator term address value m () -declare decl span addr = sendScope (Declare decl span addr (gen ())) +declare decl span addr = sendScope (Declare decl span addr (ret ())) putDeclarationScope :: (Member (ScopeEnv address) sig, Carrier sig m) => Declaration -> address -> Evaluator term address value m () -putDeclarationScope decl addr = sendScope (PutDeclarationScope decl addr (gen ())) +putDeclarationScope decl addr = sendScope (PutDeclarationScope decl addr (ret ())) reference :: (Member (ScopeEnv address) sig, Carrier sig m) => Reference -> Declaration -> Evaluator term address value m () -reference ref decl = sendScope (Reference ref decl (gen ())) +reference ref decl = sendScope (Reference ref decl (ret ())) newScope :: (Member (ScopeEnv address) sig, Carrier sig m) => Map EdgeLabel [address] -> Evaluator term address value m address -newScope map = send (NewScope map gen) +newScope map = send (NewScope map ret) currentScope :: (Member (ScopeEnv address) sig, Carrier sig m) => Evaluator term address value m (Maybe address) -currentScope = send (CurrentScope gen) +currentScope = send (CurrentScope ret) associatedScope :: (Member (ScopeEnv address) sig, Carrier sig m) => Declaration -> Evaluator term address value m (Maybe address) -associatedScope = send . flip AssociatedScope gen +associatedScope = send . flip AssociatedScope ret withScope :: (Member (ScopeEnv address) sig, Carrier sig m) => address -> Evaluator term address value m a -> Evaluator term address value m a -withScope scope action = send (Local scope action gen) +withScope scope action = send (Local scope action ret) sendScope :: (Member (ScopeEnv address) sig, Carrier sig m) => ScopeEnv address (Evaluator term address value m) (Evaluator term address value m a) -> Evaluator term address value m a sendScope = send @@ -95,23 +97,23 @@ runScopeEnv = runState lowerBound . runEvaluator . runScopeEnvC . interpret . ru newtype ScopeEnvC m a = ScopeEnvC { runScopeEnvC :: m a } instance (Ord address, Member Fresh sig, Member (Allocator address) sig, Carrier (State (ScopeGraph address) :+: sig) m, Effect sig) => Carrier (ScopeEnv address :+: sig) (ScopeEnvC (Evaluator term address value m)) where - gen = ScopeEnvC . gen - alg = ScopeEnvC . (algS \/ (alg . R . handlePure runScopeEnvC)) - where algS (Lookup ref k) = gets (ScopeGraph.scopeOfRef ref) >>= runScopeEnvC . k - algS (Declare decl span scope k) = modify' @(ScopeGraph address) (ScopeGraph.declare decl span scope) *> runScopeEnvC k - algS (PutDeclarationScope decl scope k) = modify' @(ScopeGraph address) (ScopeGraph.insertDeclarationScope decl scope) *> runScopeEnvC k - algS (Reference ref decl k) = modify' @(ScopeGraph address) (ScopeGraph.reference ref decl) *> runScopeEnvC k - algS (NewScope edges k) = do + ret = ScopeEnvC . ret + eff = ScopeEnvC . (alg \/ (eff . R . handlePure runScopeEnvC)) + where alg (Lookup ref k) = gets (ScopeGraph.scopeOfRef ref) >>= runScopeEnvC . k + alg (Declare decl span scope k) = modify @(ScopeGraph address) (ScopeGraph.declare decl span scope) *> runScopeEnvC k + alg (PutDeclarationScope decl scope k) = modify @(ScopeGraph address) (ScopeGraph.insertDeclarationScope decl scope) *> runScopeEnvC k + alg (Reference ref decl k) = modify @(ScopeGraph address) (ScopeGraph.reference ref decl) *> runScopeEnvC k + alg (NewScope edges k) = do -- Take the edges and construct a new scope, update the current scope to the new scope name <- gensym address <- alloc name - modify' @(ScopeGraph address) (ScopeGraph.newScope address edges) + modify @(ScopeGraph address) (ScopeGraph.newScope address edges) runScopeEnvC (k address) - algS (CurrentScope k) = gets ScopeGraph.currentScope >>= runScopeEnvC . k - algS (AssociatedScope decl k) = gets (ScopeGraph.associatedScope decl) >>= runScopeEnvC . k - algS (Local scope action k) = do + alg (CurrentScope k) = gets ScopeGraph.currentScope >>= runScopeEnvC . k + alg (AssociatedScope decl k) = gets (ScopeGraph.associatedScope decl) >>= runScopeEnvC . k + alg (Local scope action k) = do prevScope <- gets ScopeGraph.currentScope - modify' @(ScopeGraph address) (\g -> g { ScopeGraph.currentScope = Just scope }) + modify @(ScopeGraph address) (\g -> g { ScopeGraph.currentScope = Just scope }) value <- runScopeEnvC action modify @(ScopeGraph address) (\g -> g { ScopeGraph.currentScope = prevScope }) runScopeEnvC (k value) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 15b8702f0..ae85a84d3 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -35,6 +35,7 @@ module Control.Abstract.Value import Control.Abstract.Environment import Control.Abstract.Evaluator import Control.Abstract.Heap +import Control.Effect.Carrier import Data.Coerce import Data.Abstract.BaseError import Data.Abstract.Environment as Env @@ -71,7 +72,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) => Maybe Name -> [Name] -> term -> Evaluator term address value m value -function name params body = sendFunction (Function name params body gen) +function name params body = sendFunction (Function name params body ret) data BuiltIn = Print @@ -79,10 +80,10 @@ data BuiltIn deriving (Eq, Ord, Show, Generic, NFData) builtIn :: (Member (Function term address value) sig, Carrier sig m) => BuiltIn -> Evaluator term address value m value -builtIn = sendFunction . flip BuiltIn gen +builtIn = sendFunction . flip BuiltIn ret call :: (Member (Function term address value) sig, Carrier sig m) => value -> address -> [address] -> Evaluator term address value m address -call fn self args = sendFunction (Call fn self args gen) +call fn self args = sendFunction (Call fn self args ret) 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 @@ -114,11 +115,11 @@ newtype FunctionC term address value m a = FunctionC { runFunctionC :: (term -> -- | Construct a boolean value in the abstract domain. boolean :: (Member (Boolean value) sig, Carrier sig m) => Bool -> Evaluator term address value m value -boolean = send . flip Boolean gen +boolean = send . flip Boolean ret -- | Extract a 'Bool' from a given value. asBool :: (Member (Boolean value) sig, Carrier sig m) => value -> Evaluator term address value m Bool -asBool = send . flip AsBool gen +asBool = send . flip AsBool ret -- | Eliminate boolean values. TODO: s/boolean/truthy ifthenelse :: (Member (Boolean value) sig, Carrier sig m) => value -> Evaluator term address value m a -> Evaluator term address value m a -> Evaluator term address value m a @@ -126,7 +127,7 @@ ifthenelse v t e = asBool v >>= \ c -> if c then t else e -- | Compute the disjunction (boolean or) of two computed values. This should have short-circuiting semantics where applicable. disjunction :: (Member (Boolean value) sig, Carrier sig m) => Evaluator term address value m value -> Evaluator term address value m value -> Evaluator term address value m value -disjunction a b = send (Disjunction a b gen) +disjunction a b = send (Disjunction a b ret) data Boolean value m k = Boolean Bool (value -> k) @@ -153,7 +154,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 gen) +while cond body = send (While cond body ret) -- | Do-while loop, built on top of while. doWhile :: (Member (While value) sig, Carrier sig m) diff --git a/src/Control/Effect/Resource.hs b/src/Control/Effect/Resource.hs index 5e38f54cc..86f4e06f0 100644 --- a/src/Control/Effect/Resource.hs +++ b/src/Control/Effect/Resource.hs @@ -6,7 +6,9 @@ module Control.Effect.Resource , ResourceC(..) ) where -import Control.Effect hiding (bracket) +import Control.Effect +import Control.Effect.Carrier +import Control.Effect.Sum import qualified Control.Exception as Exc import Control.Monad.IO.Class @@ -26,7 +28,7 @@ bracket :: (Member Resource sig, Carrier sig m) -> (resource -> m any) -> (resource -> m a) -> m a -bracket acquire release use = send (Resource acquire release use gen) +bracket acquire release use = send (Resource acquire release use ret) runResource :: (Carrier sig m, MonadIO m) @@ -41,10 +43,10 @@ runResourceC :: (forall x . m x -> IO x) -> ResourceC m a -> m a runResourceC handler (ResourceC m) = m handler instance (Carrier sig m, MonadIO m) => Carrier (Resource :+: sig) (ResourceC m) where - gen a = ResourceC (const (gen a)) - alg op = ResourceC (\ handler -> (algR handler \/ alg . handlePure (runResourceC handler)) op) - where algR :: MonadIO m => (forall x . m x -> IO x) -> Resource (ResourceC m) (ResourceC m a) -> m a - algR handler (Resource acquire release use k) = liftIO (Exc.bracket + ret a = ResourceC (const (ret a)) + eff op = ResourceC (\ handler -> (alg handler \/ eff . handlePure (runResourceC handler)) op) + where alg :: MonadIO m => (forall x . m x -> IO x) -> Resource (ResourceC m) (ResourceC m a) -> m a + alg handler (Resource acquire release use k) = liftIO (Exc.bracket (handler (runResourceC handler acquire)) (handler . runResourceC handler . release) (handler . runResourceC handler . use)) diff --git a/src/Control/Rewriting.hs b/src/Control/Rewriting.hs index e8f7552d9..65ed12286 100644 --- a/src/Control/Rewriting.hs +++ b/src/Control/Rewriting.hs @@ -67,7 +67,8 @@ import Prologue hiding (apply, try) import Control.Arrow import Control.Category -import Control.Effect hiding (Local) +import Control.Effect +import Control.Effect.Trace import Data.Functor.Identity import Data.Profunctor import qualified Data.Sum as Sum hiding (apply) diff --git a/src/Data/Abstract/Address/Hole.hs b/src/Data/Abstract/Address/Hole.hs index 0e06c107a..11c5cc062 100644 --- a/src/Data/Abstract/Address/Hole.hs +++ b/src/Data/Abstract/Address/Hole.hs @@ -5,6 +5,8 @@ module Data.Abstract.Address.Hole ) where import Control.Abstract +import Control.Effect.Carrier +import Control.Effect.Sum import Prologue data Hole context a = Partial context | Total a @@ -29,14 +31,14 @@ instance ( Carrier (Allocator address :+: sig) (AllocatorC (Evaluator term addre , Carrier sig m ) => Carrier (Allocator (Hole context address) :+: sig) (AllocatorC (Evaluator term (Hole context address) value m)) where - gen = AllocatorC . promote . gen - alg = AllocatorC . (algA \/ (alg . handlePure runAllocatorC)) - where algA (Alloc name k) = promote (Total <$> runAllocatorC (alg (L (Alloc name gen))) >>= demote . runAllocatorC . k) + ret = AllocatorC . promote . ret + eff = AllocatorC . (alg \/ (eff . handlePure runAllocatorC)) + where alg (Alloc name k) = promote (Total <$> runAllocatorC (eff (L (Alloc name ret))) >>= demote . runAllocatorC . k) instance (Carrier (Deref value :+: sig) (DerefC (Evaluator term address value m)), Carrier sig m) => Carrier (Deref value :+: sig) (DerefC (Evaluator term (Hole context address) value m)) where - gen = DerefC . promote . gen - alg = DerefC . (algD \/ (alg . handlePure runDerefC)) - where algD (DerefCell cell k) = promote (runDerefC (alg (L (DerefCell cell gen))) >>= demote . runDerefC . k) - algD (AssignCell value cell k) = promote (runDerefC (alg (L (AssignCell value cell gen))) >>= demote . runDerefC . k) + ret = DerefC . promote . ret + eff = DerefC . (alg \/ (eff . handlePure runDerefC)) + where alg (DerefCell cell k) = promote (runDerefC (eff (L (DerefCell cell ret))) >>= demote . runDerefC . k) + alg (AssignCell value cell k) = promote (runDerefC (eff (L (AssignCell value cell ret))) >>= demote . runDerefC . k) diff --git a/src/Data/Abstract/Address/Located.hs b/src/Data/Abstract/Address/Located.hs index e1be7a329..44e5a6165 100644 --- a/src/Data/Abstract/Address/Located.hs +++ b/src/Data/Abstract/Address/Located.hs @@ -4,6 +4,8 @@ module Data.Abstract.Address.Located ) where import Control.Abstract +import Control.Effect.Carrier +import Control.Effect.Sum import Data.Abstract.Module (ModuleInfo) import Data.Abstract.Name import Data.Abstract.Package (PackageInfo) @@ -32,14 +34,14 @@ instance ( Carrier (Allocator address :+: sig) (AllocatorC (Evaluator term addre , Member (Reader Span) sig ) => Carrier (Allocator (Located address) :+: sig) (AllocatorC (Evaluator term (Located address) value m)) where - gen = AllocatorC . promote . gen - alg = AllocatorC . (algA \/ (alg . handlePure runAllocatorC)) - where algA (Alloc name k) = promote (Located <$> runAllocatorC (alg (L (Alloc name gen))) <*> currentPackage <*> currentModule <*> pure name <*> ask >>= demote . runAllocatorC . k) + ret = AllocatorC . promote . ret + eff = AllocatorC . (alg \/ (eff . handlePure runAllocatorC)) + where alg (Alloc name k) = promote (Located <$> runAllocatorC (eff (L (Alloc name ret))) <*> currentPackage <*> currentModule <*> pure name <*> ask >>= demote . runAllocatorC . k) instance (Carrier (Deref value :+: sig) (DerefC (Evaluator term address value m)), Carrier sig m) => Carrier (Deref value :+: sig) (DerefC (Evaluator term (Located address) value m)) where - gen = DerefC . promote . gen - alg = DerefC . (algD \/ (alg . handlePure runDerefC)) - where algD (DerefCell cell k) = promote (runDerefC (alg (L (DerefCell cell gen))) >>= demote . runDerefC . k) - algD (AssignCell value cell k) = promote (runDerefC (alg (L (AssignCell value cell gen))) >>= demote . runDerefC . k) + ret = DerefC . promote . ret + eff = DerefC . (alg \/ (eff . handlePure runDerefC)) + where alg (DerefCell cell k) = promote (runDerefC (eff (L (DerefCell cell ret))) >>= demote . runDerefC . k) + alg (AssignCell value cell k) = promote (runDerefC (eff (L (AssignCell value cell ret))) >>= demote . runDerefC . k) diff --git a/src/Data/Abstract/Address/Monovariant.hs b/src/Data/Abstract/Address/Monovariant.hs index 4d918b454..018d3b5bb 100644 --- a/src/Data/Abstract/Address/Monovariant.hs +++ b/src/Data/Abstract/Address/Monovariant.hs @@ -4,6 +4,8 @@ module Data.Abstract.Address.Monovariant ) where import Control.Abstract +import Control.Effect.Carrier +import Control.Effect.Sum import Data.Abstract.Name import qualified Data.Set as Set import Prologue @@ -17,13 +19,13 @@ instance Show Monovariant where instance Carrier sig m => Carrier (Allocator Monovariant :+: sig) (AllocatorC (Evaluator term Monovariant value m)) where - gen = AllocatorC . gen - alg = AllocatorC . (algA \/ (alg . handlePure runAllocatorC)) - where algA (Alloc name k) = runAllocatorC (k (Monovariant name)) + ret = AllocatorC . ret + eff = AllocatorC . (alg \/ (eff . handlePure runAllocatorC)) + where alg (Alloc name k) = runAllocatorC (k (Monovariant name)) instance (Member NonDet sig, Ord value, Carrier sig m) => Carrier (Deref value :+: sig) (DerefC (Evaluator term Monovariant value m)) where - gen = DerefC . gen - alg = DerefC . (algD \/ (alg . handlePure runDerefC)) - where algD (DerefCell cell k) = traverse (foldMapA pure) (nonEmpty (toList cell)) >>= runDerefC . k - algD (AssignCell value cell k) = runDerefC (k (Set.insert value cell)) + ret = DerefC . ret + eff = DerefC . (alg \/ (eff . handlePure runDerefC)) + where alg (DerefCell cell k) = traverse (foldMapA pure) (nonEmpty (toList cell)) >>= runDerefC . k + alg (AssignCell value cell k) = runDerefC (k (Set.insert value cell)) diff --git a/src/Data/Abstract/Address/Precise.hs b/src/Data/Abstract/Address/Precise.hs index 295cc03f6..fdbbd6d59 100644 --- a/src/Data/Abstract/Address/Precise.hs +++ b/src/Data/Abstract/Address/Precise.hs @@ -4,6 +4,8 @@ module Data.Abstract.Address.Precise ) where import Control.Abstract +import Control.Effect.Carrier +import Control.Effect.Sum import qualified Data.Set as Set import Prologue @@ -16,13 +18,13 @@ instance Show Precise where instance (Member Fresh sig, Carrier sig m) => Carrier (Allocator Precise :+: sig) (AllocatorC (Evaluator term Precise value m)) where - gen = AllocatorC . gen - alg = AllocatorC . (algA \/ (alg . handlePure runAllocatorC)) - where algA (Alloc _ k) = Precise <$> fresh >>= runAllocatorC . k + ret = AllocatorC . ret + eff = AllocatorC . (alg \/ (eff . handlePure runAllocatorC)) + where alg (Alloc _ k) = Precise <$> fresh >>= runAllocatorC . k instance Carrier sig m => Carrier (Deref value :+: sig) (DerefC (Evaluator term Precise value m)) where - gen = DerefC . gen - alg = DerefC . (algD \/ (alg . handlePure runDerefC)) - where algD (DerefCell cell k) = runDerefC (k (fst <$> Set.minView cell)) - algD (AssignCell value _ k) = runDerefC (k (Set.singleton value)) + ret = DerefC . ret + eff = DerefC . (alg \/ (eff . handlePure runDerefC)) + where alg (DerefCell cell k) = runDerefC (k (fst <$> Set.minView cell)) + alg (AssignCell value _ k) = runDerefC (k (Set.singleton value)) diff --git a/src/Data/Abstract/Name.hs b/src/Data/Abstract/Name.hs index f015f3ad1..a17ebed6d 100644 --- a/src/Data/Abstract/Name.hs +++ b/src/Data/Abstract/Name.hs @@ -9,6 +9,7 @@ module Data.Abstract.Name ) where import Control.Effect +import Control.Effect.Fresh import Data.Aeson import qualified Data.Char as Char import Data.Text (Text) diff --git a/src/Data/Abstract/Value/Abstract.hs b/src/Data/Abstract/Value/Abstract.hs index 18e7dfdb5..d0014bbb8 100644 --- a/src/Data/Abstract/Value/Abstract.hs +++ b/src/Data/Abstract/Value/Abstract.hs @@ -7,6 +7,8 @@ module Data.Abstract.Value.Abstract ) where import Control.Abstract as Abstract +import Control.Effect.Carrier +import Control.Effect.Sum import Data.Abstract.BaseError import Data.Abstract.Environment as Env import Prologue @@ -28,9 +30,9 @@ instance ( Member (Allocator address) sig , Carrier sig m ) => Carrier (Abstract.Function term address Abstract :+: sig) (FunctionC term address Abstract (Evaluator term address Abstract m)) where - gen = FunctionC . const . gen - alg op = FunctionC (\ eval -> (algF eval \/ (alg . handlePure (flip runFunctionC eval))) op) - where algF eval = \case + ret = FunctionC . const . ret + eff op = FunctionC (\ eval -> (alg eval \/ (eff . handlePure (flip runFunctionC eval))) op) + where alg eval = \case Function _ params body k -> do env <- foldr (\ name rest -> do addr <- alloc name @@ -45,11 +47,11 @@ instance ( Member (Allocator address) sig instance (Carrier sig m, Member NonDet sig) => Carrier (Boolean Abstract :+: sig) (BooleanC (Evaluator term address Abstract m)) where - gen = BooleanC . gen - alg = BooleanC . (algB \/ (alg . handlePure runBooleanC)) - where algB (Boolean _ k) = runBooleanC (k Abstract) - algB (AsBool _ k) = runBooleanC (k True) <|> runBooleanC (k False) - algB (Disjunction a b k) = (runBooleanC a <|> runBooleanC b) >>= runBooleanC . k + ret = BooleanC . ret + eff = BooleanC . (alg \/ (eff . handlePure runBooleanC)) + 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 instance ( Member (Abstract.Boolean Abstract) sig @@ -57,9 +59,9 @@ instance ( Member (Abstract.Boolean Abstract) sig , Carrier sig m ) => Carrier (While Abstract :+: sig) (WhileC (Evaluator term address Abstract m)) where - gen = WhileC . gen - alg = WhileC . (algW \/ (alg . handlePure runWhileC)) - where algW (Abstract.While cond body k) = do + ret = WhileC . ret + eff = WhileC . (alg \/ (eff . handlePure runWhileC)) + where alg (Abstract.While cond body k) = do cond' <- runWhileC cond ifthenelse cond' (runWhileC body *> empty) (runWhileC (k unit)) diff --git a/src/Data/Abstract/Value/Concrete.hs b/src/Data/Abstract/Value/Concrete.hs index 3818c885b..03f096375 100644 --- a/src/Data/Abstract/Value/Concrete.hs +++ b/src/Data/Abstract/Value/Concrete.hs @@ -9,6 +9,8 @@ module Data.Abstract.Value.Concrete import qualified Control.Abstract as Abstract import Control.Abstract hiding (Boolean(..), Function(..), While(..)) +import Control.Effect.Carrier +import Control.Effect.Sum import Data.Abstract.BaseError import Data.Abstract.Evaluatable (UnspecializedError(..)) import Data.Abstract.Environment (Environment, Bindings, EvalContext(..)) @@ -71,9 +73,9 @@ instance ( FreeVariables term , Show 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 - gen = FunctionC . const . gen - alg op = FunctionC (\ eval -> (algF eval \/ (alg . handlePure (flip runFunctionC eval))) op) - where algF eval = \case + ret = FunctionC . const . ret + eff op = FunctionC (\ eval -> (alg eval \/ (eff . handlePure (flip runFunctionC eval))) op) + where alg eval = \case Abstract.Function name params body k -> do packageInfo <- currentPackage moduleInfo <- currentModule @@ -103,10 +105,10 @@ instance ( Member (Reader ModuleInfo) sig , Carrier sig m ) => Carrier (Abstract.Boolean (Value term address) :+: sig) (BooleanC (Evaluator term address (Value term address) m)) where - gen = BooleanC . gen - alg = BooleanC . (algB \/ (alg . handlePure runBooleanC)) - where algB :: Abstract.Boolean (Value term address) (BooleanC (Evaluator term address (Value term address) m)) (BooleanC (Evaluator term address (Value term address) m) a) -> Evaluator term address (Value term address) m a - algB = \case + ret = BooleanC . ret + eff = BooleanC . (alg \/ (eff . handlePure runBooleanC)) + where alg :: Abstract.Boolean (Value term address) (BooleanC (Evaluator term address (Value term address) m)) (BooleanC (Evaluator term address (Value term address) m) a) -> Evaluator term address (Value term address) m a + alg = \case Abstract.Boolean b k -> runBooleanC . k $! Boolean b Abstract.AsBool (Boolean b) k -> runBooleanC (k b) Abstract.AsBool other k -> (throwValueError $! BoolError other) >>= runBooleanC . k @@ -134,9 +136,9 @@ instance ( Member (Reader ModuleInfo) sig -- , Show term -- ) -- => Carrier (Abstract.While (Value term address) :+: sig) (WhileC (Evaluator term address (Value term address) (InterposeC (Resumable (BaseError (UnspecializedError (Value term address)))) (Evaluator term address (Value term address) m)))) where --- gen = WhileC . gen --- alg = WhileC . (algW \/ (alg . handlePure runWhileC)) --- where algW = \case +-- ret = WhileC . ret +-- eff = WhileC . (alg \/ (eff . handlePure runWhileC)) +-- where alg = \case -- Abstract.While cond body k -> interpose @(Resumable (BaseError (UnspecializedError (Value term address)))) -- (\(Resumable (BaseError _ _ (UnspecializedError _)) k) -> throwAbort) (runEvaluator (loop (\continue -> do -- cond' <- runWhileC cond @@ -168,10 +170,10 @@ runInterposeC :: (forall x . eff m (m x) -> m x) -> InterposeC eff m a -> m a runInterposeC f (InterposeC m) = m f instance (Member eff sig, HFunctor eff, Carrier sig m) => Carrier sig (InterposeC eff m) where - gen a = InterposeC (const (gen a)) - alg op + ret a = InterposeC (const (ret a)) + eff op | Just e <- prj op = InterposeC (\ handler -> handler (handlePure (runInterposeC handler) e)) - | otherwise = InterposeC (\ handler -> alg (handlePure (runInterposeC handler) op)) + | otherwise = InterposeC (\ handler -> eff (handlePure (runInterposeC handler) op)) instance AbstractHole (Value term address) where diff --git a/src/Data/Abstract/Value/Type.hs b/src/Data/Abstract/Value/Type.hs index 79da739f9..3ca321fb0 100644 --- a/src/Data/Abstract/Value/Type.hs +++ b/src/Data/Abstract/Value/Type.hs @@ -13,6 +13,8 @@ module Data.Abstract.Value.Type import qualified Control.Abstract as Abstract import Control.Abstract hiding (Boolean(..), Function(..), While(..)) +import Control.Effect.Carrier +import Control.Effect.Sum import Data.Abstract.Environment as Env import Data.Abstract.BaseError import Data.Semigroup.Foldable (foldMap1) @@ -134,7 +136,7 @@ modifyTypeMap :: ( Member (State TypeMap) sig ) => (Map.Map TName Type -> Map.Map TName Type) -> m () -modifyTypeMap f = modify' (TypeMap . f . unTypeMap) +modifyTypeMap f = modify (TypeMap . f . unTypeMap) -- | Prunes substituted type variables prune :: ( Member (State TypeMap) sig @@ -247,9 +249,9 @@ instance ( Member (Allocator address) sig , Carrier sig m ) => Carrier (Abstract.Function term address Type :+: sig) (FunctionC term address Type (Evaluator term address Type m)) where - gen = FunctionC . const . gen - alg op = FunctionC (\ eval -> (algF eval \/ (alg . handlePure (flip runFunctionC eval))) op) - where algF eval = \case + ret = FunctionC . const . ret + eff op = FunctionC (\ eval -> (alg eval \/ (eff . handlePure (flip runFunctionC eval))) op) + where alg eval = \case Abstract.Function _ params body k -> do (env, tvars) <- foldr (\ name rest -> do addr <- alloc name @@ -278,11 +280,11 @@ instance ( Member NonDet sig , Carrier sig m ) => Carrier (Abstract.Boolean Type :+: sig) (BooleanC (Evaluator term address Type m)) where - gen = BooleanC . gen - alg = BooleanC . (algB \/ (alg . handlePure runBooleanC)) - where algB (Abstract.Boolean _ k) = runBooleanC (k Bool) - algB (Abstract.AsBool t k) = unify t Bool *> (runBooleanC (k True) <|> runBooleanC (k False)) - algB (Abstract.Disjunction t1 t2 k) = ((runBooleanC t1 >>= unify Bool) <|> (runBooleanC t2 >>= unify Bool) >>= runBooleanC . k) + ret = BooleanC . ret + eff = BooleanC . (alg \/ (eff . handlePure runBooleanC)) + 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) instance ( Member (Abstract.Boolean Type) sig @@ -290,9 +292,9 @@ instance ( Member (Abstract.Boolean Type) sig , Carrier sig m ) => Carrier (Abstract.While Type :+: sig) (WhileC (Evaluator term address Type m)) where - gen = WhileC . gen - alg = WhileC . (algW \/ (alg . handlePure runWhileC)) - where algW (Abstract.While cond body k) = do + ret = WhileC . ret + eff = WhileC . (alg \/ (eff . handlePure runWhileC)) + where alg (Abstract.While cond body k) = do cond' <- runWhileC cond ifthenelse cond' (runWhileC body *> empty) (runWhileC (k unit)) diff --git a/src/Data/Graph.hs b/src/Data/Graph.hs index 555cb5f3a..9bb53d220 100644 --- a/src/Data/Graph.hs +++ b/src/Data/Graph.hs @@ -21,6 +21,7 @@ import Algebra.Graph.Class (connect, overlay, vertex) import qualified Algebra.Graph.Class as Class import qualified Algebra.Graph.ToGraph as Class import Control.Effect +import Control.Effect.State import Data.Aeson import qualified Data.Set as Set diff --git a/src/Data/Project.hs b/src/Data/Project.hs index 8973ac048..cda0113cb 100644 --- a/src/Data/Project.hs +++ b/src/Data/Project.hs @@ -20,6 +20,7 @@ import Prelude hiding (readFile) import Prologue hiding (throwError) import Control.Effect +import Control.Effect.Error import Data.Blob import Data.Language import qualified Data.Text as T diff --git a/src/Language/JSON/PrettyPrint.hs b/src/Language/JSON/PrettyPrint.hs index 8598cac8a..764f25ee3 100644 --- a/src/Language/JSON/PrettyPrint.hs +++ b/src/Language/JSON/PrettyPrint.hs @@ -9,6 +9,7 @@ module Language.JSON.PrettyPrint import Prologue hiding (throwError) import Control.Effect +import Control.Effect.Error import Control.Monad.Trans (lift) import Data.Machine diff --git a/src/Language/Python/PrettyPrint.hs b/src/Language/Python/PrettyPrint.hs index 969fde256..b0bca195d 100644 --- a/src/Language/Python/PrettyPrint.hs +++ b/src/Language/Python/PrettyPrint.hs @@ -3,6 +3,7 @@ module Language.Python.PrettyPrint ( printingPython ) where import Control.Effect +import Control.Effect.Error import Control.Monad.Trans (lift) import Data.Machine diff --git a/src/Language/Ruby/PrettyPrint.hs b/src/Language/Ruby/PrettyPrint.hs index 73d717edb..1f943f5e3 100644 --- a/src/Language/Ruby/PrettyPrint.hs +++ b/src/Language/Ruby/PrettyPrint.hs @@ -3,6 +3,7 @@ module Language.Ruby.PrettyPrint ( printingRuby ) where import Control.Effect +import Control.Effect.Error import Control.Monad.Trans (lift) import Data.Machine diff --git a/src/Parsing/TreeSitter.hs b/src/Parsing/TreeSitter.hs index bfce4a0ce..308558f86 100644 --- a/src/Parsing/TreeSitter.hs +++ b/src/Parsing/TreeSitter.hs @@ -8,8 +8,9 @@ import Prologue hiding (bracket) import Control.Concurrent.Async import qualified Control.Exception as Exc (bracket) -import Control.Effect hiding (bracket) +import Control.Effect import Control.Effect.Resource +import Control.Effect.Trace import Control.Monad.IO.Class import Data.ByteString.Unsafe (unsafeUseAsCStringLen) import Foreign diff --git a/src/Rendering/Graph.hs b/src/Rendering/Graph.hs index 6869015eb..7a3c696fc 100644 --- a/src/Rendering/Graph.hs +++ b/src/Rendering/Graph.hs @@ -9,6 +9,8 @@ module Rendering.Graph import Algebra.Graph.Export.Dot import Analysis.ConstructorName import Control.Effect +import Control.Effect.Fresh +import Control.Effect.Reader import Data.Diff import Data.Graph import Data.Graph.TermVertex diff --git a/src/Reprinting/Pipeline.hs b/src/Reprinting/Pipeline.hs index 284e4f056..b28127b89 100644 --- a/src/Reprinting/Pipeline.hs +++ b/src/Reprinting/Pipeline.hs @@ -104,6 +104,8 @@ module Reprinting.Pipeline ) where import Control.Effect as Effect +import Control.Effect.Error as Effect +import Control.Effect.State as Effect import Data.Machine hiding (Source) import Data.Machine.Runner import Data.Text.Prettyprint.Doc diff --git a/src/Reprinting/Translate.hs b/src/Reprinting/Translate.hs index 99ff4de5f..9e9ff0c7c 100644 --- a/src/Reprinting/Translate.hs +++ b/src/Reprinting/Translate.hs @@ -7,6 +7,8 @@ module Reprinting.Translate import Control.Monad import Control.Effect +import Control.Effect.Error +import Control.Effect.State import Control.Monad.Trans import Data.Machine @@ -34,8 +36,8 @@ contextualizing = repeatedly $ await >>= \case enterScope, exitScope :: Scope -> PlanT k Fragment Translator () -enterScope c = lift (modify' (c :)) +enterScope c = lift (modify (c :)) exitScope c = lift get >>= \case - (x:xs) -> when (x == c) (lift (modify' (const xs))) + (x:xs) -> when (x == c) (lift (modify (const xs))) cs -> lift (throwError (UnbalancedPair c cs)) diff --git a/src/Semantic/Distribute.hs b/src/Semantic/Distribute.hs index d4174ec4e..d95266a13 100644 --- a/src/Semantic/Distribute.hs +++ b/src/Semantic/Distribute.hs @@ -10,6 +10,8 @@ module Semantic.Distribute import qualified Control.Concurrent.Async as Async import Control.Effect +import Control.Effect.Carrier +import Control.Effect.Sum import Control.Parallel.Strategies import Control.Monad.IO.Class import Prologue hiding (MonadError (..)) @@ -18,7 +20,7 @@ import Prologue hiding (MonadError (..)) -- -- 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 gen) +distribute = fmap (withStrategy (parTraversable rseq)) <$> traverse (send . flip Distribute ret) -- | 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. -- @@ -53,5 +55,5 @@ runDistribute = runDistributeC . interpret newtype DistributeC m a = DistributeC { runDistributeC :: m a } instance Carrier (Distribute :+: Lift IO) (DistributeC (Eff (LiftC IO))) where - gen = DistributeC . gen - alg = DistributeC . ((\ (Distribute task k) -> liftIO (Async.runConcurrently (Async.Concurrently (runM (runDistributeC task)))) >>= runDistributeC . k) \/ (alg . handlePure runDistributeC)) + ret = DistributeC . ret + eff = DistributeC . ((\ (Distribute task k) -> liftIO (Async.runConcurrently (Async.Concurrently (runM (runDistributeC task)))) >>= runDistributeC . k) \/ (eff . handlePure runDistributeC)) diff --git a/src/Semantic/IO.hs b/src/Semantic/IO.hs index 1b3b66581..fb2b1a392 100644 --- a/src/Semantic/IO.hs +++ b/src/Semantic/IO.hs @@ -35,6 +35,10 @@ module Semantic.IO ) where import Control.Effect +import Control.Effect.Carrier +import Control.Effect.Error +import Control.Effect.Sum +import qualified Control.Exception as Exc import Control.Monad.IO.Class import Data.Aeson import Data.Blob @@ -160,27 +164,27 @@ noLanguageForBlob blobPath = throwError (SomeException (NoLanguageForBlob blobPa readBlob :: (Member Files sig, Carrier sig m) => File -> m Blob -readBlob file = send (Read (FromPath file) gen) +readBlob file = send (Read (FromPath file) ret) -- | 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) gen) -readBlobs (Right paths) = traverse (send . flip Read gen . FromPath) paths +readBlobs (Left handle) = send (Read (FromHandle handle) ret) +readBlobs (Right paths) = traverse (send . flip Read ret . 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) gen) -readBlobPairs (Right paths) = traverse (send . flip Read gen . FromPathPair) paths +readBlobPairs (Left handle) = send (Read (FromPairHandle handle) ret) +readBlobPairs (Right paths) = traverse (send . flip Read ret . 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 gen) +readProject rootDir dir lang excludeDirs = send (ReadProject rootDir dir lang excludeDirs ret) findFiles :: (Member Files sig, Carrier sig m) => FilePath -> [String] -> [FilePath] -> m [FilePath] -findFiles dir exts paths = send (FindFiles dir exts paths gen) +findFiles dir exts paths = send (FindFiles dir exts paths ret) -- | 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 (gen ())) +write dest builder = send (Write dest builder (ret ())) data Handle mode where ReadHandle :: IO.Handle -> Handle 'IO.ReadMode @@ -238,9 +242,9 @@ runFiles = runFilesC . interpret newtype FilesC m a = FilesC { runFilesC :: m a } instance (Member (Error SomeException) sig, MonadIO m, Carrier sig m) => Carrier (Files :+: sig) (FilesC m) where - gen = FilesC . gen - alg = FilesC . (algF \/ (alg . handlePure runFilesC)) - where algF = \case + ret = FilesC . ret + eff = FilesC . (alg \/ (eff . handlePure runFilesC)) + 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 Read (FromPathPair paths) k -> (runBothWith readFilePair paths `catchIO` (throwError . toException @SomeException)) >>= runFilesC . k @@ -249,3 +253,13 @@ instance (Member (Error SomeException) sig, MonadIO m, Carrier sig m) => Carrier 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 + + +-- | Generalize 'Exc.catch' to other 'MonadIO' contexts for the handler and result. +catchIO :: ( Exc.Exception exc + , MonadIO m + ) + => IO a + -> (exc -> m a) + -> m a +catchIO m handler = liftIO (Exc.try m) >>= either handler pure diff --git a/src/Semantic/Parse.hs b/src/Semantic/Parse.hs index dafee7e8a..25bed7b53 100644 --- a/src/Semantic/Parse.hs +++ b/src/Semantic/Parse.hs @@ -5,6 +5,7 @@ import Analysis.ConstructorName (ConstructorName) import Analysis.Declaration (HasDeclaration, declarationAlgebra) import Analysis.PackageDef (HasPackageDef) import Control.Effect +import Control.Effect.Error import Control.Monad.IO.Class import Data.Blob import Data.Either diff --git a/src/Semantic/Resolution.hs b/src/Semantic/Resolution.hs index 367598669..c4707da4e 100644 --- a/src/Semantic/Resolution.hs +++ b/src/Semantic/Resolution.hs @@ -8,6 +8,8 @@ module Semantic.Resolution ) where import Control.Effect +import Control.Effect.Carrier +import Control.Effect.Sum import Data.Aeson import Data.Aeson.Types (parseMaybe) import Data.Blob @@ -38,9 +40,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 gen) - JavaScript -> send (NodeJSResolution projectRootDir "main" projectExcludeDirs gen) - _ -> send (NoResolution gen) + TypeScript -> send (NodeJSResolution projectRootDir "types" projectExcludeDirs ret) + JavaScript -> send (NodeJSResolution projectRootDir "main" projectExcludeDirs ret) + _ -> send (NoResolution ret) data Resolution (m :: * -> *) k = NodeJSResolution FilePath Text [FilePath] (Map FilePath FilePath -> k) @@ -60,7 +62,7 @@ runResolution = runResolutionC . interpret newtype ResolutionC m a = ResolutionC { runResolutionC :: m a } instance (Member Files sig, Carrier sig m, Monad m) => Carrier (Resolution :+: sig) (ResolutionC m) where - gen = ResolutionC . gen - alg = ResolutionC . (algR \/ (alg . handlePure runResolutionC)) - where algR (NodeJSResolution dir prop excludeDirs k) = nodeJSResolutionMap dir prop excludeDirs >>= runResolutionC . k - algR (NoResolution k) = runResolutionC (k Map.empty) + ret = ResolutionC . ret + eff = ResolutionC . (alg \/ (eff . handlePure runResolutionC)) + where alg (NodeJSResolution dir prop excludeDirs k) = nodeJSResolutionMap dir prop excludeDirs >>= runResolutionC . k + alg (NoResolution k) = runResolutionC (k Map.empty) diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index d0970cc76..20d6f9fd5 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -58,7 +58,12 @@ import qualified Assigning.Assignment as Assignment import qualified Assigning.Assignment.Deterministic as Deterministic import qualified Control.Abstract as Analysis import Control.Effect +import Control.Effect.Carrier +import Control.Effect.Error +import Control.Effect.Reader import Control.Effect.Resource +import Control.Effect.Sum +import Control.Effect.Trace import Control.Monad import Control.Monad.IO.Class import Data.Blob @@ -111,40 +116,40 @@ parse :: (Member Task sig, Carrier sig m) => Parser term -> Blob -> m term -parse parser blob = send (Parse parser blob gen) +parse parser blob = send (Parse parser blob ret) -- | 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 gen) +analyze interpret analysis = send (Analyze interpret analysis ret) -- | 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 gen) +decorate algebra term = send (Decorate algebra term ret) -- | 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 gen) +diff terms = send (Semantic.Task.Diff terms ret) -- | 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 gen) +render renderer input = send (Render renderer input ret) serialize :: (Member Task sig, Carrier sig m) => Format input -> input -> m Builder -serialize format input = send (Serialize format input gen) +serialize format input = send (Serialize format input ret) -- | Execute a 'Task' with the 'defaultOptions', yielding its result value in 'IO'. -- @@ -199,8 +204,8 @@ runTraceInTelemetry = runTraceInTelemetryC . interpret newtype TraceInTelemetryC m a = TraceInTelemetryC { runTraceInTelemetryC :: m a } instance (Member Telemetry sig, Carrier sig m, Monad m) => Carrier (Trace :+: sig) (TraceInTelemetryC m) where - gen = TraceInTelemetryC . gen - alg = TraceInTelemetryC . ((\ (Trace str k) -> writeLog Debug str [] >> runTraceInTelemetryC k) \/ (alg . handlePure runTraceInTelemetryC)) + ret = TraceInTelemetryC . ret + eff = TraceInTelemetryC . ((\ (Trace str k) -> writeLog Debug str [] >> runTraceInTelemetryC k) \/ (eff . handlePure runTraceInTelemetryC)) -- | An effect describing high-level tasks to be performed. @@ -243,9 +248,9 @@ runTaskF = runTaskC . interpret 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 - gen = TaskC . gen - alg = TaskC . (algT \/ (alg . handlePure runTaskC)) - where algT = \case + ret = TaskC . ret + eff = TaskC . (alg \/ (eff . handlePure runTaskC)) + where alg = \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)) diff --git a/src/Semantic/Telemetry.hs b/src/Semantic/Telemetry.hs index 41821c39a..fab89f3d5 100644 --- a/src/Semantic/Telemetry.hs +++ b/src/Semantic/Telemetry.hs @@ -50,7 +50,9 @@ module Semantic.Telemetry , IgnoreTelemetryC(..) ) where -import Control.Effect hiding (bracket) +import Control.Effect +import Control.Effect.Carrier +import Control.Effect.Sum import Control.Exception import Control.Monad.IO.Class import Data.Coerce @@ -119,11 +121,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 (gen ())) +writeLog level message pairs = send (WriteLog level message pairs (ret ())) -- | A task which writes a stat. writeStat :: (Member Telemetry sig, Carrier sig m) => Stat -> m () -writeStat stat = send (WriteStat stat (gen ())) +writeStat stat = send (WriteStat stat (ret ())) -- | 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 @@ -155,10 +157,10 @@ runTelemetry logger statter = flip runTelemetryC (logger, statter) . interpret newtype TelemetryC m a = TelemetryC { runTelemetryC :: (LogQueue, StatQueue) -> m a } instance (Carrier sig m, MonadIO m) => Carrier (Telemetry :+: sig) (TelemetryC m) where - gen = TelemetryC . const . gen - alg op = TelemetryC (\ queues -> (algT queues \/ (alg . handlePure (flip runTelemetryC queues))) op) - where algT queues (WriteStat stat k) = queueStat (snd queues) stat *> runTelemetryC k queues - algT queues (WriteLog level message pairs k) = queueLogMessage (fst queues) level message pairs *> runTelemetryC k queues + ret = TelemetryC . const . ret + eff op = TelemetryC (\ queues -> (alg queues \/ (eff . handlePure (flip runTelemetryC queues))) 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 -- | Run a 'Telemetry' effect by ignoring statting/logging. @@ -168,7 +170,7 @@ ignoreTelemetry = runIgnoreTelemetryC . interpret newtype IgnoreTelemetryC m a = IgnoreTelemetryC { runIgnoreTelemetryC :: m a } instance Carrier sig m => Carrier (Telemetry :+: sig) (IgnoreTelemetryC m) where - gen = IgnoreTelemetryC . gen - alg = algT \/ (IgnoreTelemetryC . alg . handlePure runIgnoreTelemetryC) - where algT (WriteStat _ k) = k - algT (WriteLog _ _ _ k) = k + ret = IgnoreTelemetryC . ret + eff = alg \/ (IgnoreTelemetryC . eff . handlePure runIgnoreTelemetryC) + where alg (WriteStat _ k) = k + alg (WriteLog _ _ _ k) = k diff --git a/src/Semantic/Timeout.hs b/src/Semantic/Timeout.hs index d9c84254b..c20768c1f 100644 --- a/src/Semantic/Timeout.hs +++ b/src/Semantic/Timeout.hs @@ -8,6 +8,8 @@ module Semantic.Timeout ) where import Control.Effect +import Control.Effect.Carrier +import Control.Effect.Sum import Control.Monad.IO.Class import Data.Duration import qualified System.Timeout as System @@ -16,7 +18,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) gen +timeout n = send . flip (Timeout n) ret -- | 'Timeout' effects run other effects, aborting them if they exceed the -- specified duration. @@ -45,8 +47,8 @@ runTimeoutC :: (forall x . m x -> IO x) -> TimeoutC m a -> m a runTimeoutC f (TimeoutC m) = m f instance (Carrier sig m, MonadIO m) => Carrier (Timeout :+: sig) (TimeoutC m) where - gen a = TimeoutC (const (gen a)) - alg op = TimeoutC (\ handler -> + ret a = TimeoutC (const (ret a)) + eff op = TimeoutC (\ handler -> ((\ (Timeout n task k) -> liftIO (System.timeout (toMicroseconds n) (handler (runTimeoutC handler task))) >>= runTimeoutC handler . k) - \/ (alg . handlePure (runTimeoutC handler))) + \/ (eff . handlePure (runTimeoutC handler))) op) diff --git a/vendor/higher-order-effects b/vendor/higher-order-effects index 58d709bf6..37930eaf1 160000 --- a/vendor/higher-order-effects +++ b/vendor/higher-order-effects @@ -1 +1 @@ -Subproject commit 58d709bf6017ec79de9a25b20b784103b0a506ba +Subproject commit 37930eaf171de50579fda9168936cc1dc2d767cf