github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2025-01-03 04:51:57 +03:00
Code Issues Projects Releases Wiki Activity

Bump higher-order-effects.

Browse Source
This commit is contained in:
Rob Rix 2018-10-22 10:26:15 -04:00
parent a7f59e55bc
commit 034e2469ff
40 changed files with 273 additions and 192 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
src/Analysis/Abstract/Caching/FlowInsensitive.hs
View File

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

4
src/Analysis/Abstract/Caching/FlowSensitive.hs
View File

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

2
src/Analysis/Abstract/Dead.hs
View File

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

10
src/Analysis/Abstract/Graph.hs
View File

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

1
src/Analysis/Abstract/Tracing.hs
View File

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

4
src/Control/Abstract/Context.hs
View File

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

30
src/Control/Abstract/Environment.hs
View File

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

12
src/Control/Abstract/Evaluator.hs
View File

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

9
src/Control/Abstract/Heap.hs
View File

@ -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)

22
src/Control/Abstract/Modules.hs
View File

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

8
src/Control/Abstract/PythonPackage.hs
View File

@ -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))

42
src/Control/Abstract/ScopeGraph.hs
View File

@ -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)

15
src/Control/Abstract/Value.hs
View File

@ -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)

14
src/Control/Effect/Resource.hs
View File

@ -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))

3
src/Control/Rewriting.hs
View File

@ -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)

16
src/Data/Abstract/Address/Hole.hs
View File

@ -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)

16
src/Data/Abstract/Address/Located.hs
View File

@ -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)

16
src/Data/Abstract/Address/Monovariant.hs
View File

@ -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))

16
src/Data/Abstract/Address/Precise.hs
View File

@ -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))

1
src/Data/Abstract/Name.hs
View File

@ -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)

24
src/Data/Abstract/Value/Abstract.hs
View File

@ -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))

28
src/Data/Abstract/Value/Concrete.hs
View File

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

26
src/Data/Abstract/Value/Type.hs
View File

@ -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))

1
src/Data/Graph.hs
View File

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

1
src/Data/Project.hs
View File

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

1
src/Language/JSON/PrettyPrint.hs
View File

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

1
src/Language/Python/PrettyPrint.hs
View File

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

1
src/Language/Ruby/PrettyPrint.hs
View File

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

3
src/Parsing/TreeSitter.hs
View File

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

2
src/Rendering/Graph.hs
View File

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

2
src/Reprinting/Pipeline.hs
View File

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

6
src/Reprinting/Translate.hs
View File

@ -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))

8
src/Semantic/Distribute.hs
View File

@ -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))

36
src/Semantic/IO.hs
View File

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

1
src/Semantic/Parse.hs
View File

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

16
src/Semantic/Resolution.hs
View File

@ -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)

27
src/Semantic/Task.hs
View File

@ -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))

24
src/Semantic/Telemetry.hs
View File

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

10
src/Semantic/Timeout.hs
View File

@ -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)

2
vendor/higher-order-effects vendored

@ -1 +1 @@
Subproject commit 58d709bf6017ec79de9a25b20b784103b0a506ba
Subproject commit 37930eaf171de50579fda9168936cc1dc2d767cf