1
1
mirror of https://github.com/github/semantic.git synced 2024-12-29 18:06:14 +03:00

Merge remote-tracking branch 'origin/master' into add-tsparse-quiet-flag

This commit is contained in:
Patrick Thomson 2018-10-30 15:53:02 -04:00
commit 5cac709075
87 changed files with 2567 additions and 1939 deletions

6
.gitmodules vendored
View File

@ -1,9 +1,6 @@
[submodule "vendor/hspec-expectations-pretty-diff"]
path = vendor/hspec-expectations-pretty-diff
url = https://github.com/rewinfrey/hspec-expectations-pretty-diff
[submodule "vendor/effects"]
path = vendor/effects
url = https://github.com/joshvera/effects.git
[submodule "vendor/haskell-tree-sitter"]
path = vendor/haskell-tree-sitter
url = https://github.com/tree-sitter/haskell-tree-sitter.git
@ -16,3 +13,6 @@
[submodule "vendor/semilattices"]
path = vendor/semilattices
url = https://github.com/robrix/semilattices.git
[submodule "vendor/fused-effects"]
path = vendor/fused-effects
url = https://github.com/robrix/fused-effects.git

View File

@ -0,0 +1,42 @@
---
type: cabal
name: MonadRandom
version: 0.5.1.1
summary: Random-number generation monad.
homepage:
license: bsd-3-clause
---
Copyright (c) 2016, Brent Yorgey
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above
copyright notice, this list of conditions and the following
disclaimer in the documentation and/or other materials provided
with the distribution.
* Neither the name of Brent Yorgey nor the names of other
contributors may be used to endorse or promote products derived
from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Previous versions of this package were distributed under the simple
permissive license used on the Haskell Wiki; see OLD-LICENSE for
details.

View File

@ -0,0 +1,38 @@
---
type: cabal
name: fused-effects
version: 0.1.0.0
summary: 'A fast, flexible, fused effect system, à la Effect Handlers in Scope, Monad Transformers and Modular Algebraic Effects: What Binds Them Together, and Fusion for Free—Efficient Algebraic Effect Handlers.'
homepage: https://github.com/robrix/fused-effects
license: bsd-3-clause
---
Copyright (c) 2018, Rob Rix and Patrick Thomson
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above
copyright notice, this list of conditions and the following
disclaimer in the documentation and/or other materials provided
with the distribution.
* Neither the name of Rob Rix nor the names of other
contributors may be used to endorse or promote products derived
from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

View File

@ -41,14 +41,16 @@ library
, Control.Abstract.Evaluator
, Control.Abstract.Heap
, Control.Abstract.Hole
, Control.Abstract.Matching
, Control.Abstract.Modules
, Control.Abstract.Primitive
, Control.Abstract.PythonPackage
, Control.Abstract.Roots
, Control.Abstract.ScopeGraph
, Control.Abstract.Value
-- Rewriting
-- Effects
, Control.Effect.Interpose
-- Matching and rewriting DSLs
, Control.Matching
, Control.Rewriting
-- Datatypes for abstract interpretation
, Data.Abstract.Address.Hole
@ -186,6 +188,7 @@ library
, Reprinting.Typeset
, Reprinting.Pipeline
-- High-level flow & operational functionality (logging, stats, etc.)
, Semantic.Analysis
, Semantic.AST
, Semantic.CLI
, Semantic.Config
@ -230,11 +233,11 @@ library
, deepseq
, directory
, directory-tree
, effects
, fastsum
, filepath
, free
, freer-cofreer
, fused-effects
, ghc-prim
, gitrev
, Glob
@ -359,10 +362,10 @@ test-suite test
, bifunctors
, bytestring
, containers
, effects
, fastsum
, filepath
, free
, fused-effects
, Glob
, hashable
, haskell-tree-sitter
@ -413,9 +416,9 @@ test-suite parse-examples
build-depends: base
, bytestring
, directory
, effects
, fastsum
, filepath
, fused-effects
, Glob
, hspec >= 2.4.1
, hspec-core

View File

@ -14,58 +14,59 @@ import Data.Map.Monoidal as Monoidal
import Prologue
-- | Look up the set of values for a given configuration in the in-cache.
consultOracle :: (Member (Reader (Cache term address)) effects, Ord address, Ord term)
consultOracle :: (Member (Reader (Cache term address)) sig, Carrier sig m, Ord address, Ord term)
=> Configuration term address
-> Evaluator term address value effects (Set (ValueRef address))
consultOracle configuration = fromMaybe mempty . cacheLookup configuration <$> ask
-> Evaluator term address value m (Set (ValueRef address))
consultOracle configuration = asks (fromMaybe mempty . cacheLookup configuration)
-- | Run an action with the given in-cache.
withOracle :: Member (Reader (Cache term address)) effects
withOracle :: (Member (Reader (Cache term address)) sig, Carrier sig m)
=> Cache term address
-> Evaluator term address value effects a
-> Evaluator term address value effects a
-> Evaluator term address value m a
-> Evaluator term address value m a
withOracle cache = local (const cache)
-- | Look up the set of values for a given configuration in the out-cache.
lookupCache :: (Member (State (Cache term address)) effects, Ord address, Ord term)
lookupCache :: (Member (State (Cache term address)) sig, Carrier sig m, Ord address, Ord term)
=> Configuration term address
-> Evaluator term address value effects (Maybe (Set (ValueRef address)))
-> Evaluator term address value m (Maybe (Set (ValueRef address)))
lookupCache configuration = cacheLookup configuration <$> get
-- | Run an action, caching its result and 'Heap' under the given configuration.
cachingConfiguration :: (Member (State (Cache term address)) effects, Ord address, Ord term)
cachingConfiguration :: (Member (State (Cache term address)) sig, Carrier sig m, Ord address, Ord term)
=> Configuration term address
-> Set (ValueRef address)
-> Evaluator term address value effects (ValueRef address)
-> Evaluator term address value effects (ValueRef address)
-> 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)) effects
putCache :: (Member (State (Cache term address)) sig, Carrier sig m)
=> Cache term address
-> Evaluator term address value effects ()
-> Evaluator term address value m ()
putCache = put
-- | Run an action starting from an empty out-cache, and return the out-cache afterwards.
isolateCache :: (Member (State (Cache term address)) effects, Member (State (Heap address value)) effects)
=> Evaluator term address value effects a
-> Evaluator term address value effects (Cache term address, Heap address value)
isolateCache :: (Member (State (Cache term address)) sig, Member (State (Heap address value)) sig, Carrier sig m)
=> Evaluator term address value m a
-> Evaluator term address value m (Cache term address, Heap address value)
isolateCache action = putCache lowerBound *> action *> ((,) <$> get <*> get)
-- | Analyze a term using the in-cache as an oracle & storing the results of the analysis in the out-cache.
cachingTerms :: ( Member (Env address) effects
, Member NonDet effects
, Member (Reader (Cache term address)) effects
, Member (Reader (Live address)) effects
, Member (State (Cache term address)) effects
cachingTerms :: ( Member (Env address) sig
, Member NonDet sig
, Member (Reader (Cache term address)) sig
, Member (Reader (Live address)) sig
, Member (State (Cache term address)) sig
, Carrier sig m
, Ord address
, Ord term
)
=> Open (Open (term -> Evaluator term address value effects (ValueRef address)))
=> Open (Open (term -> Evaluator term address value m (ValueRef address)))
cachingTerms recur0 recur term = do
c <- getConfiguration term
cached <- lookupCache c
@ -75,37 +76,40 @@ cachingTerms recur0 recur term = do
values <- consultOracle c
cachingConfiguration c values (recur0 recur term)
convergingModules :: ( AbstractValue term address value effects
, Effects effects
convergingModules :: ( AbstractValue term address value m
, Eq value
, Member (Env address) effects
, Member Fresh effects
, Member NonDet effects
, Member (Reader (Cache term address)) effects
, Member (Reader (Live address)) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (EnvironmentError address))) effects
, Member (State (Cache term address)) effects
, Member (State (Heap address value)) effects
, Member (Env address) sig
, Member Fresh sig
, Member NonDet sig
, Member (Reader (Cache term address)) sig
, Member (Reader (Live address)) sig
, Member (Reader ModuleInfo) sig
, Member (Reader Span) sig
, Member (Resumable (BaseError (EnvironmentError address))) sig
, Member (State (Cache term address)) sig
, Member (State (Heap address value)) sig
, Ord address
, Ord term
, Carrier sig m
, Effect sig
)
=> Open (Module term -> Evaluator term address value effects address)
convergingModules recur m = do
c <- getConfiguration (moduleBody m)
=> (Module (Either prelude term) -> Evaluator term address value (AltC Maybe (Eff m)) address)
-> (Module (Either prelude term) -> Evaluator term address value m address)
convergingModules recur m@(Module _ (Left _)) = raiseHandler runNonDet (recur m) >>= maybeM empty
convergingModules recur m@(Module _ (Right term)) = do
c <- getConfiguration term
heap <- getHeap
-- Convergence here is predicated upon an Eq instance, not α-equivalence
(cache, _) <- converge (lowerBound, heap) (\ (prevCache, _) -> isolateCache $ do
putEvalContext (configurationContext c)
-- We need to reset fresh generation so that this invocation converges.
resetFresh 0 $
resetFresh $
-- This is subtle: though the calling context supports nondeterminism, we want
-- to corral all the nondeterminism that happens in this @eval@ invocation, so
-- that it doesn't "leak" to the calling context and diverge (otherwise this
-- would never complete). We dont need to use the values, so we 'gather' the
-- nondeterministic values into @()@.
withOracle prevCache (gatherM (const ()) (recur m)))
withOracle prevCache (raiseHandler runNonDet (recur m)))
address =<< maybe empty scatter (cacheLookup c cache)
-- | Iterate a monadic action starting from some initial seed until the results converge.
@ -124,21 +128,68 @@ converge seed f = loop seed
loop x'
-- | Nondeterministically write each of a collection of stores & return their associated results.
scatter :: (Foldable t, Member NonDet effects) => t (ValueRef address) -> Evaluator term address value effects (ValueRef address)
scatter :: (Foldable t, Member NonDet sig, Carrier sig m) => t (ValueRef address) -> Evaluator term address value m (ValueRef address)
scatter = foldMapA pure
-- | Get the current 'Configuration' with a passed-in term.
getConfiguration :: (Member (Reader (Live address)) effects, Member (Env address) effects)
getConfiguration :: (Member (Reader (Live address)) sig, Member (Env address) sig, Carrier sig m)
=> term
-> Evaluator term address value effects (Configuration term address)
-> Evaluator term address value m (Configuration term address)
getConfiguration term = Configuration term <$> askRoots <*> getEvalContext
caching :: Effects effects => Evaluator term address value (NonDet ': Reader (Cache term address) ': State (Cache term address) ': effects) a -> Evaluator term address value effects (Cache term address, [a])
caching :: (Carrier sig m, Effect sig)
=> Evaluator term address value (AltC B (Eff
(ReaderC (Cache term address) (Eff
(StateC (Cache term address) (Eff
m)))))) a
-> Evaluator term address value m (Cache term address, [a])
caching
= runState lowerBound
. runReader lowerBound
. runNonDet
= raiseHandler (runState lowerBound)
. raiseHandler (runReader lowerBound)
. fmap toList
. raiseHandler runNonDet
data B a = E | L a | B (B a) (B a)
deriving (Functor)
instance Foldable B where
toList = flip go []
where go E rest = rest
go (L a) rest = a : rest
go (B a b) rest = go a (go b rest)
foldMap f = go
where go E = mempty
go (L a) = f a
go (B a b) = go a <> go b
null E = True
null _ = False
instance Traversable B where
traverse f = go
where go E = pure E
go (L a) = L <$> f a
go (B a b) = B <$> go a <*> go b
instance Applicative B where
pure = L
E <*> _ = E
L f <*> a = fmap f a
B l r <*> a = B (l <*> a) (r <*> a)
instance Alternative B where
empty = E
E <|> b = b
a <|> E = a
a <|> b = B a b
instance Monad B where
return = pure
E >>= _ = E
L a >>= f = f a
B l r >>= f = B (l >>= f) (r >>= f)
-- | A map of 'Configuration's to 'Set's of resulting values & 'Heap's.

View File

@ -14,58 +14,59 @@ import Data.Map.Monoidal as Monoidal
import Prologue
-- | Look up the set of values for a given configuration in the in-cache.
consultOracle :: (Cacheable term address value, Member (Reader (Cache term address value)) effects)
consultOracle :: (Cacheable term address value, Member (Reader (Cache term address value)) sig, Carrier sig m)
=> Configuration term address value
-> Evaluator term address value effects (Set (Cached address value))
-> Evaluator term address value m (Set (Cached address value))
consultOracle configuration = fromMaybe mempty . cacheLookup configuration <$> ask
-- | Run an action with the given in-cache.
withOracle :: Member (Reader (Cache term address value)) effects
withOracle :: (Member (Reader (Cache term address value)) sig, Carrier sig m)
=> Cache term address value
-> Evaluator term address value effects a
-> Evaluator term address value effects a
-> Evaluator term address value m a
-> Evaluator term address value m a
withOracle cache = local (const cache)
-- | Look up the set of values for a given configuration in the out-cache.
lookupCache :: (Cacheable term address value, Member (State (Cache term address value)) effects)
lookupCache :: (Cacheable term address value, Member (State (Cache term address value)) sig, Carrier sig m)
=> Configuration term address value
-> Evaluator term address value effects (Maybe (Set (Cached address value)))
-> Evaluator term address value m (Maybe (Set (Cached address value)))
lookupCache configuration = cacheLookup configuration <$> get
-- | Run an action, caching its result and 'Heap' under the given configuration.
cachingConfiguration :: (Cacheable term address value, Member (State (Cache term address value)) effects, Member (State (Heap address value)) effects)
cachingConfiguration :: (Cacheable term address value, Member (State (Cache term address value)) sig, Member (State (Heap address value)) sig, Carrier sig m)
=> Configuration term address value
-> Set (Cached address value)
-> Evaluator term address value effects (ValueRef address)
-> Evaluator term address value effects (ValueRef address)
-> 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)) effects
putCache :: (Member (State (Cache term address value)) sig, Carrier sig m)
=> Cache term address value
-> Evaluator term address value effects ()
-> Evaluator term address value m ()
putCache = put
-- | Run an action starting from an empty out-cache, and return the out-cache afterwards.
isolateCache :: Member (State (Cache term address value)) effects
=> Evaluator term address value effects a
-> Evaluator term address value effects (Cache term address value)
isolateCache :: (Member (State (Cache term address value)) sig, Carrier sig m)
=> Evaluator term address value m a
-> Evaluator term address value m (Cache term address value)
isolateCache action = putCache lowerBound *> action *> get
-- | Analyze a term using the in-cache as an oracle & storing the results of the analysis in the out-cache.
cachingTerms :: ( Cacheable term address value
, Member NonDet effects
, Member (Reader (Cache term address value)) effects
, Member (Reader (Live address)) effects
, Member (State (Cache term address value)) effects
, Member (Env address) effects
, Member (State (Heap address value)) effects
, Member NonDet sig
, Member (Reader (Cache term address value)) sig
, Member (Reader (Live address)) sig
, Member (State (Cache term address value)) sig
, Member (Env address) sig
, Member (State (Heap address value)) sig
, Carrier sig m
)
=> Open (Open (term -> Evaluator term address value effects (ValueRef address)))
=> Open (Open (term -> Evaluator term address value m (ValueRef address)))
cachingTerms recur0 recur term = do
c <- getConfiguration term
cached <- lookupCache c
@ -75,35 +76,38 @@ cachingTerms recur0 recur term = do
pairs <- consultOracle c
cachingConfiguration c pairs (recur0 recur term)
convergingModules :: ( AbstractValue term address value effects
convergingModules :: ( AbstractValue term address value m
, Cacheable term address value
, Member Fresh effects
, Member NonDet effects
, Member (Reader (Cache term address value)) effects
, Member (Reader (Live address)) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (EnvironmentError address))) effects
, Member (State (Cache term address value)) effects
, Member (Env address) effects
, Member (State (Heap address value)) effects
, Effects effects
, Member Fresh sig
, Member NonDet sig
, Member (Reader (Cache term address value)) sig
, Member (Reader (Live address)) sig
, Member (Reader ModuleInfo) sig
, Member (Reader Span) sig
, Member (Resumable (BaseError (EnvironmentError address))) sig
, Member (State (Cache term address value)) sig
, Member (Env address) sig
, Member (State (Heap address value)) sig
, Carrier sig m
, Effect sig
)
=> Open (Module term -> Evaluator term address value effects address)
convergingModules recur m = do
c <- getConfiguration (moduleBody m)
=> (Module (Either prelude term) -> Evaluator term address value (AltC Maybe (Eff m)) address)
-> (Module (Either prelude term) -> Evaluator term address value m address)
convergingModules recur m@(Module _ (Left _)) = raiseHandler runNonDet (recur m) >>= maybeM empty
convergingModules recur m@(Module _ (Right term)) = do
c <- getConfiguration term
-- Convergence here is predicated upon an Eq instance, not α-equivalence
cache <- converge lowerBound (\ prevCache -> isolateCache $ do
putHeap (configurationHeap c)
putEvalContext (configurationContext c)
-- We need to reset fresh generation so that this invocation converges.
resetFresh 0 $
resetFresh $
-- This is subtle: though the calling context supports nondeterminism, we want
-- to corral all the nondeterminism that happens in this @eval@ invocation, so
-- that it doesn't "leak" to the calling context and diverge (otherwise this
-- would never complete). We dont need to use the values, so we 'gather' the
-- nondeterministic values into @()@.
withOracle prevCache (gatherM (const ()) (recur m)))
withOracle prevCache (raiseHandler runNonDet (recur m)))
address =<< maybe empty scatter (cacheLookup c cache)
-- | Iterate a monadic action starting from some initial seed until the results converge.
@ -122,21 +126,26 @@ converge seed f = loop seed
loop x'
-- | Nondeterministically write each of a collection of stores & return their associated results.
scatter :: (Foldable t, Member NonDet effects, Member (State (Heap address value)) effects) => t (Cached address value) -> Evaluator term address value effects (ValueRef address)
scatter :: (Foldable t, Member NonDet sig, Member (State (Heap address value)) sig, Carrier sig m) => t (Cached address value) -> Evaluator term address value m (ValueRef address)
scatter = foldMapA (\ (Cached value heap') -> putHeap heap' $> value)
-- | Get the current 'Configuration' with a passed-in term.
getConfiguration :: (Member (Reader (Live address)) effects, Member (Env address) effects, Member (State (Heap address value)) effects)
getConfiguration :: (Member (Reader (Live address)) sig, Member (Env address) sig, Member (State (Heap address value)) sig, Carrier sig m)
=> term
-> Evaluator term address value effects (Configuration term address value)
-> Evaluator term address value m (Configuration term address value)
getConfiguration term = Configuration term <$> askRoots <*> getEvalContext <*> getHeap
caching :: Effects effects => Evaluator term address value (NonDet ': Reader (Cache term address value) ': State (Cache term address value) ': effects) a -> Evaluator term address value effects (Cache term address value, [a])
caching :: (Carrier sig m, Effect sig)
=> Evaluator term address value (AltC [] (Eff
(ReaderC (Cache term address value) (Eff
(StateC (Cache term address value) (Eff
m)))))) a
-> Evaluator term address value m (Cache term address value, [a])
caching
= runState lowerBound
. runReader lowerBound
. runNonDet
= raiseHandler (runState lowerBound)
. raiseHandler (runReader lowerBound)
. raiseHandler runNonDet
-- | A map of 'Configuration's to 'Set's of resulting values & 'Heap's.

View File

@ -1,4 +1,3 @@
{-# LANGUAGE TypeOperators #-}
module Analysis.Abstract.Collecting
( providingLiveSet
) where
@ -6,5 +5,5 @@ module Analysis.Abstract.Collecting
import Control.Abstract
import Prologue
providingLiveSet :: PureEffects effects => Evaluator term address value (Reader (Live address) ': effects) a -> Evaluator term address value effects a
providingLiveSet = runReader lowerBound
providingLiveSet :: Carrier sig m => Evaluator term address value (ReaderC (Live address) (Eff m)) a -> Evaluator term address value m a
providingLiveSet = raiseHandler (runReader lowerBound)

View File

@ -19,31 +19,33 @@ newtype Dead term = Dead { unDead :: Set term }
deriving instance Ord term => Reducer term (Dead term)
-- | Update the current 'Dead' set.
killAll :: Member (State (Dead term)) effects => Dead term -> Evaluator term address value effects ()
killAll :: (Member (State (Dead term)) sig, Carrier sig m) => Dead term -> Evaluator term address value m ()
killAll = put
-- | Revive a single term, removing it from the current 'Dead' set.
revive :: (Member (State (Dead term)) effects, Ord term) => term -> Evaluator term address value effects ()
revive t = modify' (Dead . delete t . unDead)
revive :: (Member (State (Dead term)) sig, Carrier sig m, Ord term) => term -> Evaluator term address value m ()
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
subterms term = term `cons` para (foldMap (uncurry cons)) term
revivingTerms :: ( Member (State (Dead term)) effects
revivingTerms :: ( Member (State (Dead term)) sig
, Ord term
, Carrier sig m
)
=> Open (Open (term -> Evaluator term address value effects a))
=> Open (Open (term -> Evaluator term address value m a))
revivingTerms recur0 recur term = revive term *> recur0 recur term
killingModules :: ( Foldable (Base term)
, Member (State (Dead term)) effects
, Member (State (Dead term)) sig
, Ord term
, Recursive term
, Carrier sig m
)
=> Open (Module term -> Evaluator term address value effects a)
=> Open (Module term -> Evaluator term address value m a)
killingModules recur m = killAll (subterms (moduleBody m)) *> recur m
providingDeadSet :: Effects effects => Evaluator term address value (State (Dead term) ': effects) a -> Evaluator term address value effects (Dead term, a)
providingDeadSet = runState lowerBound
providingDeadSet :: (Carrier sig m, Effect sig) => Evaluator term address value (StateC (Dead term) (Evaluator term address value m)) a -> Evaluator term address value m (Dead term, a)
providingDeadSet = runState lowerBound . runEvaluator

View File

@ -1,4 +1,4 @@
{-# LANGUAGE ScopedTypeVariables, TypeFamilies, TypeOperators #-}
{-# LANGUAGE LambdaCase, RankNTypes, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
module Analysis.Abstract.Graph
( Graph(..)
, ControlFlowVertex(..)
@ -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
@ -62,22 +64,23 @@ style = (defaultStyle (T.encodeUtf8Builder . vertexIdentifier))
-- | Add vertices to the graph for evaluated identifiers.
graphingTerms :: ( Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Env (Hole context (Located address))) effects
, Member (State (Graph ControlFlowVertex)) effects
, Member (State (Map (Hole context (Located address)) ControlFlowVertex)) effects
, Member (Resumable (BaseError (EnvironmentError (Hole context (Located address))))) effects
, AbstractValue term (Hole context (Located address)) value effects
, Member (Reader ControlFlowVertex) effects
graphingTerms :: ( Member (Reader ModuleInfo) sig
, Member (Reader Span) sig
, Member (Env (Hole context (Located address))) sig
, Member (State (Graph ControlFlowVertex)) sig
, Member (State (Map (Hole context (Located address)) ControlFlowVertex)) sig
, Member (Resumable (BaseError (EnvironmentError (Hole context (Located address))))) sig
, AbstractValue term (Hole context (Located address)) value m
, Member (Reader ControlFlowVertex) sig
, VertexDeclaration syntax
, Declarations1 syntax
, Ord address
, Ord context
, Foldable syntax
, term ~ Term syntax Location
, Carrier sig m
)
=> Open (Open (term -> Evaluator term (Hole context (Located address)) value effects (ValueRef (Hole context (Located address)))))
=> Open (Open (term -> Evaluator term (Hole context (Located address)) value m (ValueRef (Hole context (Located address)))))
graphingTerms recur0 recur term@(Term (In a syntax)) = do
definedInModule <- currentModule
case toVertex a definedInModule syntax of
@ -100,91 +103,120 @@ 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.
graphingPackages :: ( Member (Reader PackageInfo) effects
, Member (State (Graph ControlFlowVertex)) effects
, Member (Reader ControlFlowVertex) effects
graphingPackages :: ( Member (Reader PackageInfo) sig
, Member (State (Graph ControlFlowVertex)) sig
, Member (Reader ControlFlowVertex) sig
, Carrier sig m
, Monad m
)
=> Open (Module term -> Evaluator term address value effects a)
=> Open (Module term -> m a)
graphingPackages recur m =
let v = moduleVertex (moduleInfo m) in packageInclusion v *> local (const v) (recur m)
-- | Add vertices to the graph for imported modules.
graphingModules :: forall term address value effects a
. ( Member (Modules address) effects
, Member (Reader ModuleInfo) effects
, Member (State (Graph ControlFlowVertex)) effects
, Member (Reader ControlFlowVertex) effects
, PureEffects effects
graphingModules :: ( Member (Modules address) sig
, Member (Reader ModuleInfo) sig
, Member (State (Graph ControlFlowVertex)) sig
, Member (Reader ControlFlowVertex) sig
, Carrier sig m
)
=> Open (Module term -> Evaluator term address value effects a)
=> (Module body -> Evaluator term address value (EavesdropC address (Eff m)) a)
-> (Module body -> Evaluator term address value m a)
graphingModules recur m = do
let v = moduleVertex (moduleInfo m)
appendGraph (vertex v)
local (const v) $
eavesdrop @(Modules address) (\ m -> case m of
Load path -> includeModule path
Lookup path -> includeModule path
_ -> pure ())
(recur m)
eavesdrop (recur m) $ \case
Load path _ -> includeModule path
Lookup path _ -> includeModule path
_ -> pure ()
where
-- NB: path is null for Languages like Ruby that have module imports that require concrete value semantics.
includeModule path = let path' = if Prologue.null path then "unknown, concrete semantics required" else path
in moduleInclusion (moduleVertex (ModuleInfo path'))
{-# ANN graphingModules ("HLint: ignore Use ." :: String) #-}
-- | Add vertices to the graph for imported modules.
graphingModuleInfo :: forall term address value effects a
. ( Member (Modules address) effects
, Member (Reader ModuleInfo) effects
, Member (State (Graph ModuleInfo)) effects
, PureEffects effects
graphingModuleInfo :: ( Member (Modules address) sig
, Member (Reader ModuleInfo) sig
, Member (State (Graph ModuleInfo)) sig
, Carrier sig m
)
=> Open (Module term -> Evaluator term address value effects a)
=> (Module body -> Evaluator term address value (EavesdropC address (Eff m)) a)
-> (Module body -> Evaluator term address value m a)
graphingModuleInfo recur m = do
appendGraph (vertex (moduleInfo m))
eavesdrop @(Modules address) (\ eff -> case eff of
Load path -> currentModule >>= appendGraph . (`connect` vertex (ModuleInfo path)) . vertex
Lookup path -> currentModule >>= appendGraph . (`connect` vertex (ModuleInfo path)) . vertex
_ -> pure ())
(recur m)
eavesdrop (recur m) $ \case
Load path _ -> currentModule >>= appendGraph . (`connect` vertex (ModuleInfo path)) . vertex
Lookup path _ -> currentModule >>= appendGraph . (`connect` vertex (ModuleInfo path)) . vertex
_ -> pure ()
eavesdrop :: (Carrier sig m, Member (Modules address) sig)
=> Evaluator term address value (EavesdropC address (Eff m)) a
-> (forall x . Modules address (Eff m) (Eff m x) -> Evaluator term address value m ())
-> Evaluator term address value m a
eavesdrop m f = raiseHandler (runEavesdropC (runEvaluator . f) . interpret) m
newtype EavesdropC address m a = EavesdropC ((forall x . Modules address m (m x) -> m ()) -> m a)
runEavesdropC :: (forall x . Modules address m (m x) -> m ()) -> EavesdropC address m a -> m a
runEavesdropC f (EavesdropC m) = m f
instance (Carrier sig m, Member (Modules address) sig, Applicative m) => Carrier sig (EavesdropC address m) where
ret a = EavesdropC (const (ret a))
eff op
| Just eff <- prj op = EavesdropC (\ handler -> let eff' = handlePure (runEavesdropC handler) eff in handler eff' *> send eff')
| otherwise = EavesdropC (\ handler -> eff (handlePure (runEavesdropC handler) op))
-- | Add an edge from the current package to the passed vertex.
packageInclusion :: ( Member (Reader PackageInfo) effects
, Member (State (Graph ControlFlowVertex)) effects
packageInclusion :: ( Member (Reader PackageInfo) sig
, Member (State (Graph ControlFlowVertex)) sig
, Carrier sig m
, Monad m
)
=> ControlFlowVertex
-> Evaluator term address value effects ()
-> m ()
packageInclusion v = do
p <- currentPackage
appendGraph (vertex (packageVertex p) `connect` vertex v)
-- | Add an edge from the current module to the passed vertex.
moduleInclusion :: ( Member (Reader ModuleInfo) effects
, Member (State (Graph ControlFlowVertex)) effects
moduleInclusion :: ( Member (Reader ModuleInfo) sig
, Member (State (Graph ControlFlowVertex)) sig
, Carrier sig m
, Monad m
)
=> ControlFlowVertex
-> Evaluator term address value effects ()
-> m ()
moduleInclusion v = do
m <- currentModule
appendGraph (vertex (moduleVertex m) `connect` vertex v)
-- | Add an edge from the passed variable name to the context it originated within.
variableDefinition :: ( Member (State (Graph ControlFlowVertex)) effects
, Member (Reader ControlFlowVertex) effects
variableDefinition :: ( Member (State (Graph ControlFlowVertex)) sig
, Member (Reader ControlFlowVertex) sig
, Carrier sig m
, Monad m
)
=> ControlFlowVertex
-> Evaluator term (Hole context (Located address)) value effects ()
-> m ()
variableDefinition var = do
context <- ask
appendGraph $ vertex context `connect` vertex var
appendGraph (vertex context `connect` vertex var)
appendGraph :: Member (State (Graph v)) effects => Graph v -> Evaluator term address value effects ()
appendGraph = modify' . (<>)
appendGraph :: (Member (State (Graph v)) sig, Carrier sig m, Monad m) => Graph v -> m ()
appendGraph = modify . (<>)
graphing :: Effects effects
=> Evaluator term (Hole context (Located address)) value (State (Map (Hole context (Located address)) ControlFlowVertex) ': State (Graph ControlFlowVertex) ': effects) result -> Evaluator term (Hole context (Located address)) value effects (Graph ControlFlowVertex, result)
graphing = runState mempty . fmap snd . runState lowerBound
graphing :: (Carrier sig m, Effect sig)
=> Evaluator term address value (StateC (Map address ControlFlowVertex) (Eff
(StateC (Graph ControlFlowVertex) (Eff
m)))) result
-> Evaluator term address value m (Graph ControlFlowVertex, result)
graphing = raiseHandler $ runState mempty . fmap snd . runState lowerBound

View File

@ -5,33 +5,34 @@ module Analysis.Abstract.Tracing
) where
import Control.Abstract hiding (trace)
import Control.Monad.Effect.Writer
import Control.Effect.Writer
import Data.Abstract.Environment
import Data.Semigroup.Reducer as Reducer
-- | Trace analysis.
--
-- Instantiating @trace@ to @[]@ yields a linear trace analysis, while @Set@ yields a reachable state analysis.
tracingTerms :: ( Member (Env address) effects
, Member (State (Heap address value)) effects
, Member (Writer (trace (Configuration term address value))) effects
tracingTerms :: ( Member (Env address) sig
, Member (State (Heap address value)) sig
, Member (Writer (trace (Configuration term address value))) sig
, Carrier sig m
, Reducer (Configuration term address value) (trace (Configuration term address value))
)
=> trace (Configuration term address value)
-> Open (Open (term -> Evaluator term address value effects a))
-> Open (Open (term -> Evaluator term address value m a))
tracingTerms proxy recur0 recur term = getConfiguration term >>= trace . (`asTypeOf` proxy) . Reducer.unit >> recur0 recur term
trace :: Member (Writer (trace (Configuration term address value))) effects => trace (Configuration term address value) -> Evaluator term address value effects ()
trace :: (Member (Writer (trace (Configuration term address value))) sig, Carrier sig m) => trace (Configuration term address value) -> Evaluator term address value m ()
trace = tell
tracing :: (Monoid (trace (Configuration term address value)), Effects effects) => Evaluator term address value (Writer (trace (Configuration term address value)) ': effects) a -> Evaluator term address value effects (trace (Configuration term address value), a)
tracing = runWriter
tracing :: (Monoid (trace (Configuration term address value)), Carrier sig m, Effect sig) => Evaluator term address value (WriterC (trace (Configuration term address value)) (Evaluator term address value m)) a -> Evaluator term address value m (trace (Configuration term address value), a)
tracing = runWriter . runEvaluator
-- | Get the current 'Configuration' with a passed-in term.
getConfiguration :: (Member (Env address) effects, Member (State (Heap address value)) effects)
getConfiguration :: (Member (Env address) sig, Member (State (Heap address value)) sig, Carrier sig m)
=> term
-> Evaluator term address value effects (Configuration term address value)
-> Evaluator term address value m (Configuration term address value)
getConfiguration term = Configuration term <$> getEvalContext <*> getHeap
-- | A single point in a programs execution.

View File

@ -4,6 +4,7 @@ module Analysis.ConstructorName
) where
import Data.Sum
import GHC.Generics
import Prologue
-- | A typeclass to retrieve the name of the data constructor for a value.

View File

@ -97,6 +97,7 @@ module Assigning.Assignment
import Prologue
import Prelude hiding (fail)
import qualified Assigning.Assignment.Table as Table
import Control.Monad.Except (MonadError (..))
import Control.Monad.Free.Freer
import Data.AST
import Data.Error

View File

@ -10,4 +10,5 @@ import Control.Abstract.Hole as X
import Control.Abstract.Modules as X
import Control.Abstract.Primitive as X
import Control.Abstract.Roots as X
import Control.Abstract.ScopeGraph as X
import Control.Abstract.Value as X

View File

@ -12,9 +12,9 @@ module Control.Abstract.Context
, withCurrentCallStack
) where
import Control.Monad.Effect
import Control.Monad.Effect.Reader
import Control.Monad.Effect.State
import Control.Effect
import Control.Effect.Reader
import Control.Effect.State
import Data.Abstract.Module
import Data.Abstract.Package
import Data.Span
@ -22,38 +22,38 @@ import GHC.Stack
import Prologue
-- | Get the currently evaluating 'ModuleInfo'.
currentModule :: (Effectful m, Member (Reader ModuleInfo) effects) => m effects ModuleInfo
currentModule :: (Member (Reader ModuleInfo) sig, Carrier sig m) => m ModuleInfo
currentModule = ask
-- | Run an action with a locally-replaced 'ModuleInfo'.
withCurrentModule :: (Effectful m, Member (Reader ModuleInfo) effects) => ModuleInfo -> m effects a -> m effects a
withCurrentModule :: (Member (Reader ModuleInfo) sig, Carrier sig m) => ModuleInfo -> m a -> m a
withCurrentModule = local . const
-- | Get the currently evaluating 'PackageInfo'.
currentPackage :: (Effectful m, Member (Reader PackageInfo) effects) => m effects PackageInfo
currentPackage :: (Member (Reader PackageInfo) sig, Carrier sig m) => m PackageInfo
currentPackage = ask
-- | Run an action with a locally-replaced 'PackageInfo'.
withCurrentPackage :: (Effectful m, Member (Reader PackageInfo) effects) => PackageInfo -> m effects a -> m effects a
withCurrentPackage :: (Member (Reader PackageInfo) sig, Carrier sig m) => PackageInfo -> m a -> m a
withCurrentPackage = local . const
-- | Get the 'Span' of the currently-evaluating term (if any).
currentSpan :: (Effectful m, Member (Reader Span) effects) => m effects Span
currentSpan :: (Member (Reader Span) sig, Carrier sig m) => m Span
currentSpan = ask
-- | Run an action with a locally-replaced 'Span'.
withCurrentSpan :: (Effectful m, Member (Reader Span) effects) => Span -> m effects a -> m effects a
withCurrentSpan :: (Member (Reader Span) sig, Carrier sig m) => Span -> m a -> m a
withCurrentSpan = local . const
modifyChildSpan :: (Effectful m, Member (State Span) effects) => Span -> m effects a -> m effects a
modifyChildSpan span m = raiseEff (lowerEff m >>= (\a -> modify' (const span) >> pure a))
modifyChildSpan :: (Member (State Span) sig, Carrier sig m, Monad m) => Span -> m a -> m a
modifyChildSpan span m = m <* put span
-- | Run an action with locally-replaced 'ModuleInfo' & 'Span' derived from the passed 'SrcLoc'.
withCurrentSrcLoc :: (Effectful m, Member (Reader ModuleInfo) effects, Member (Reader Span) effects) => SrcLoc -> m effects a -> m effects a
withCurrentSrcLoc :: (Member (Reader ModuleInfo) sig, Member (Reader Span) sig, Carrier sig m) => SrcLoc -> m a -> m a
withCurrentSrcLoc loc = withCurrentModule (moduleInfoFromSrcLoc loc) . withCurrentSpan (spanFromSrcLoc loc)
-- | Run an action with locally replaced 'ModuleInfo' & 'Span' derived from the Haskell call stack.
--
-- This is suitable for contextualizing builtins & other functionality intended for use from client code but defined in Haskell source.
withCurrentCallStack :: (Effectful m, Member (Reader ModuleInfo) effects, Member (Reader Span) effects) => CallStack -> m effects a -> m effects a
withCurrentCallStack :: (Member (Reader ModuleInfo) sig, Member (Reader Span) sig, Carrier sig m) => CallStack -> m a -> m a
withCurrentCallStack = maybe id (withCurrentSrcLoc . snd) . listToMaybe . getCallStack

View File

@ -1,4 +1,4 @@
{-# LANGUAGE GADTs, LambdaCase, RankNTypes, ScopedTypeVariables, TypeOperators #-}
{-# LANGUAGE GADTs, LambdaCase, RankNTypes, ScopedTypeVariables, TypeOperators, UndecidableInstances #-}
module Control.Abstract.Environment
( Environment
, Exports
@ -19,6 +19,7 @@ module Control.Abstract.Environment
-- * Effects
, Env(..)
, runEnv
, EnvC(..)
, freeVariableError
, runEnvironmentError
, runEnvironmentErrorWith
@ -26,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
@ -36,22 +39,22 @@ import Data.Span
import Prologue
-- | Retrieve the current execution context
getEvalContext :: Member (Env address) effects => Evaluator term address value effects (EvalContext address)
getEvalContext = send GetCtx
getEvalContext :: (Member (Env address) sig, Carrier sig m) => Evaluator term address value m (EvalContext address)
getEvalContext = send (GetCtx ret)
-- | Retrieve the current environment
getEnv :: Member (Env address) effects
=> Evaluator term address value effects (Environment address)
getEnv :: (Member (Env address) sig, Carrier sig m)
=> Evaluator term address value m (Environment address)
getEnv = ctxEnvironment <$> getEvalContext
-- | Replace the execution context. This is only for use in Analysis.Abstract.Caching.
putEvalContext :: Member (Env address) effects => EvalContext address -> Evaluator term address value effects ()
putEvalContext = send . PutCtx
putEvalContext :: (Member (Env address) sig, Carrier sig m) => EvalContext address -> Evaluator term address value m ()
putEvalContext context = send (PutCtx context (ret ()))
withEvalContext :: Member (Env address) effects
withEvalContext :: (Member (Env address) sig, Carrier sig m)
=> EvalContext address
-> Evaluator term address value effects a
-> Evaluator term address value effects a
-> Evaluator term address value m a
-> Evaluator term address value m a
withEvalContext ctx comp = do
oldCtx <- getEvalContext
putEvalContext ctx
@ -60,49 +63,51 @@ withEvalContext ctx comp = do
pure value
-- | Add an export to the global export state.
export :: Member (Env address) effects => Name -> Name -> Maybe address -> Evaluator term address value effects ()
export name alias addr = send (Export name alias addr)
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 (ret ()))
-- | Look a 'Name' up in the current environment, trying the default environment if no value is found.
lookupEnv :: Member (Env address) effects => Name -> Evaluator term address value effects (Maybe address)
lookupEnv name = send (Lookup name)
lookupEnv :: (Member (Env address) sig, Carrier sig m) => Name -> Evaluator term address value m (Maybe address)
lookupEnv name = send (Lookup name ret)
-- | Bind a 'Name' to an address in the current scope.
bind :: Member (Env address) effects => Name -> address -> Evaluator term address value effects ()
bind name addr = send (Bind name addr)
bind :: (Member (Env address) sig, Carrier sig m) => Name -> address -> Evaluator term address value m ()
bind name addr = send (Bind name addr (ret ()))
-- | Bind all of the names from an 'Environment' in the current scope.
bindAll :: Member (Env address) effects => Bindings address -> Evaluator term address value effects ()
bindAll :: (Member (Env address) sig, Carrier sig m) => Bindings address -> Evaluator term address value m ()
bindAll = foldr ((>>) . uncurry bind) (pure ()) . Env.pairs
-- | Run an action in a new local scope.
locally :: forall term address value effects a . Member (Env address) effects => Evaluator term address value effects a -> Evaluator term address value effects a
locally = send . Locally @_ @_ @address . lowerEff
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 ret)
close :: Member (Env address) effects => Set Name -> Evaluator term address value effects (Environment address)
close = send . Close
close :: (Member (Env address) sig, Carrier sig m) => Set Name -> Evaluator term address value m (Environment address)
close fvs = send (Close fvs ret)
self :: Member (Env address) effects => Evaluator term address value effects (Maybe address)
self :: (Member (Env address) sig, Carrier sig m) => Evaluator term address value m (Maybe address)
self = ctxSelf <$> getEvalContext
-- | Look up or allocate an address for a 'Name'.
lookupOrAlloc :: ( Member (Allocator address) effects
, Member (Env address) effects
lookupOrAlloc :: ( Member (Allocator address) sig
, Member (Env address) sig
, Carrier sig m
)
=> Name
-> Evaluator term address value effects address
-> Evaluator term address value m address
lookupOrAlloc name = lookupEnv name >>= maybeM (alloc name)
letrec :: ( Member (Allocator address) effects
, Member (Deref value) effects
, Member (Env address) effects
, Member (State (Heap address value)) effects
letrec :: ( Member (Allocator address) sig
, Member (Deref value) sig
, Member (Env address) sig
, Member (State (Heap address value)) sig
, Ord address
, Carrier sig m
)
=> Name
-> Evaluator term address value effects value
-> Evaluator term address value effects (value, address)
-> Evaluator term address value m value
-> Evaluator term address value m (value, address)
letrec name body = do
addr <- lookupOrAlloc name
v <- locally (bind name addr *> body)
@ -110,55 +115,67 @@ letrec name body = do
pure (v, addr)
-- Lookup/alloc a name passing the address to a body evaluated in a new local environment.
letrec' :: ( Member (Allocator address) effects
, Member (Env address) effects
letrec' :: ( Member (Allocator address) sig
, Member (Env address) sig
, Carrier sig m
)
=> Name
-> (address -> Evaluator term address value effects a)
-> Evaluator term address value effects a
-> (address -> Evaluator term address value m a)
-> Evaluator term address value m a
letrec' name body = do
addr <- lookupOrAlloc name
v <- locally (body addr)
v <$ bind name addr
-- | Look up and dereference the given 'Name', throwing an exception for free variables.
variable :: ( Member (Env address) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (EnvironmentError address))) effects
variable :: ( Member (Env address) sig
, Member (Reader ModuleInfo) sig
, Member (Reader Span) sig
, Member (Resumable (BaseError (EnvironmentError address))) sig
, Carrier sig m
)
=> Name
-> Evaluator term address value effects address
-> Evaluator term address value m address
variable name = lookupEnv name >>= maybeM (freeVariableError name)
-- Effects
data Env address m return where
Lookup :: Name -> Env address m (Maybe address)
Bind :: Name -> address -> Env address m ()
Close :: Set Name -> Env address m (Environment address)
Locally :: m a -> Env address m a
GetCtx :: Env address m (EvalContext address)
PutCtx :: EvalContext address -> Env address m ()
Export :: Name -> Name -> Maybe address -> Env address m ()
data Env address m k
= Lookup Name (Maybe address -> k)
| Bind Name address k
| Close (Set Name) (Environment address -> k)
| forall a . Locally (m a) (a -> k)
| GetCtx (EvalContext address -> k)
| PutCtx (EvalContext address) k
| Export Name Name (Maybe address) k
deriving instance Functor (Env address m)
instance HFunctor (Env address) where
hmap _ (Lookup name k) = Lookup name k
hmap _ (Bind name addr k) = Bind name addr k
hmap _ (Close names k) = Close names k
hmap f (Locally m k) = Locally (f m) k
hmap _ (GetCtx k) = GetCtx k
hmap _ (PutCtx ctx k) = PutCtx ctx k
hmap _ (Export name alias addr k) = Export name alias addr k
instance PureEffect (Env address)
instance Effect (Env address) where
handleState c dist (Request (Lookup name) k) = Request (Lookup name) (dist . (<$ c) . k)
handleState c dist (Request (Bind name addr) k) = Request (Bind name addr) (dist . (<$ c) . k)
handleState c dist (Request (Close names) k) = Request (Close names) (dist . (<$ c) . k)
handleState c dist (Request (Locally action) k) = Request (Locally (dist (action <$ c))) (dist . fmap k)
handleState c dist (Request GetCtx k) = Request GetCtx (dist . (<$ c) . k)
handleState c dist (Request (PutCtx e) k) = Request (PutCtx e) (dist . (<$ c) . k)
handleState c dist (Request (Export name alias addr) k) = Request (Export name alias addr) (dist . (<$ c) . k)
handle state handler (Lookup name k) = Lookup name (handler . (<$ state) . k)
handle state handler (Bind name addr k) = Bind name addr (handler . (<$ state) $ k)
handle state handler (Close names k) = Close names (handler . (<$ state) . k)
handle state handler (Locally action k) = Locally (handler (action <$ state)) (handler . fmap k)
handle state handler (GetCtx k) = GetCtx (handler . (<$ state) . k)
handle state handler (PutCtx e k) = PutCtx e (handler . (<$ state) $ k)
handle state handler (Export name alias addr k) = Export name alias addr (handler . (<$ state) $ k)
-- | Runs a computation in the context of an existing environment.
-- New bindings created in the computation are returned.
runEnv :: Effects effects
runEnv :: (Carrier sig m, Effect sig)
=> EvalContext address
-> Evaluator term address value (Env address ': effects) a
-> Evaluator term address value effects (Bindings address, a)
runEnv initial = fmap (filterEnv . fmap (first (Env.head . ctxEnvironment))) . runState lowerBound . runState initial . reinterpret2 handleEnv
-> Evaluator term address value (EnvC address (Eff m)) a
-> Evaluator term address value m (Bindings address, a)
runEnv initial = raiseHandler $ fmap (filterEnv . fmap (first (Env.head . ctxEnvironment))) . runState lowerBound . runState initial . runEnvC . interpret
where -- TODO: If the set of exports is empty because no exports have been
-- defined, do we export all terms, or no terms? This behavior varies across
-- languages. We need better semantics rather than doing it ad-hoc.
@ -166,44 +183,48 @@ runEnv initial = fmap (filterEnv . fmap (first (Env.head . ctxEnvironment))) . r
| Exports.null ports = (binds, a)
| otherwise = (Exports.toBindings ports <> Env.aliasBindings (Exports.aliases ports) binds, a)
handleEnv :: forall term address value effects a . Effects effects
=> Env address (Eff (Env address ': effects)) a
-> Evaluator term address value (State (EvalContext address) ': State (Exports address) ': effects) a
handleEnv = \case
Lookup name -> Env.lookupEnv' name . ctxEnvironment <$> get
Bind name addr -> modify (\EvalContext{..} -> EvalContext ctxSelf (Env.insertEnv name addr ctxEnvironment))
Close names -> Env.intersect names . ctxEnvironment <$> get
Locally action -> do
modify' (\EvalContext{..} -> EvalContext ctxSelf (Env.push @address ctxEnvironment))
a <- reinterpret2 handleEnv (raiseEff action)
a <$ modify' (\EvalContext{..} -> EvalContext ctxSelf (Env.pop @address ctxEnvironment))
GetCtx -> get
PutCtx e -> put e
Export name alias addr -> modify (Exports.insert name alias addr)
newtype EnvC address m a = EnvC { runEnvC :: Eff (StateC (EvalContext address) (Eff (StateC (Exports address) m))) a }
freeVariableError :: ( Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (EnvironmentError address))) effects
instance (Carrier sig m, Effect sig) => Carrier (Env address :+: sig) (EnvC address m) where
ret = EnvC . ret
eff = EnvC . handleSum (eff . R . R . handleCoercible) (\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
Close names k -> gets (Env.intersect names . ctxEnvironment) >>= runEnvC . k
Locally action k -> do
modify (\EvalContext{..} -> EvalContext ctxSelf (Env.push @address ctxEnvironment))
a <- runEnvC action
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)
freeVariableError :: ( Member (Reader ModuleInfo) sig
, Member (Reader Span) sig
, Member (Resumable (BaseError (EnvironmentError address))) sig
, Carrier sig m
)
=> Name
-> Evaluator term address value effects address
-> Evaluator term address value m address
freeVariableError = throwEnvironmentError . FreeVariable
runEnvironmentError :: (Effectful (m address value), Effects effects)
=> m address value (Resumable (BaseError (EnvironmentError address)) ': effects) a
-> m address value effects (Either (SomeExc (BaseError (EnvironmentError address))) a)
runEnvironmentError = runResumable
runEnvironmentError :: (Carrier sig m, Effect sig)
=> Evaluator term address value (ResumableC (BaseError (EnvironmentError address)) (Eff m)) a
-> Evaluator term address value m (Either (SomeError (BaseError (EnvironmentError address))) a)
runEnvironmentError = raiseHandler runResumable
runEnvironmentErrorWith :: (Effectful (m address value), Effects effects)
=> (forall resume . BaseError (EnvironmentError address) resume -> m address value effects resume)
-> m address value (Resumable (BaseError (EnvironmentError address)) ': effects) a
-> m address value effects a
runEnvironmentErrorWith = runResumableWith
runEnvironmentErrorWith :: Carrier sig m
=> (forall resume . BaseError (EnvironmentError address) resume -> Evaluator term address value m resume)
-> Evaluator term address value (ResumableWithC (BaseError (EnvironmentError address)) (Eff m)) a
-> Evaluator term address value m a
runEnvironmentErrorWith f = raiseHandler $ runResumableWith (runEvaluator . f)
throwEnvironmentError :: ( Member (Resumable (BaseError (EnvironmentError address))) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
throwEnvironmentError :: ( Member (Resumable (BaseError (EnvironmentError address))) sig
, Member (Reader ModuleInfo) sig
, Member (Reader Span) sig
, Carrier sig m
)
=> EnvironmentError address resume
-> Evaluator term address value effects resume
-> Evaluator term address value m resume
throwEnvironmentError = throwBaseError

View File

@ -1,6 +1,7 @@
{-# LANGUAGE GeneralizedNewtypeDeriving, TypeOperators, ScopedTypeVariables #-}
{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeOperators, UndecidableInstances #-}
module Control.Abstract.Evaluator
( Evaluator(..)
, raiseHandler
, Open
-- * Effects
, Return(..)
@ -16,27 +17,39 @@ module Control.Abstract.Evaluator
, module X
) where
import Control.Monad.Effect as X
import Control.Monad.Effect.Fresh as X
import Control.Monad.Effect.Exception as X
import qualified Control.Monad.Effect.Internal as Eff
import Control.Monad.Effect.NonDet as X
import Control.Monad.Effect.Reader as X
import Control.Monad.Effect.Resumable as X
import Control.Monad.Effect.State as X
import Control.Monad.Effect.Trace as X
import Prologue hiding (MonadError(..))
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
import Data.Coerce
-- | An 'Evaluator' is a thin wrapper around 'Eff' with (phantom) type parameters for the address, term, and value types.
--
-- These parameters enable us to constrain the types of effects using them s.t. we can avoid both ambiguous types when they arent mentioned outside of the context, and lengthy, redundant annotations on the use sites of functions employing these effects.
--
-- These effects will typically include the environment, heap, module table, etc. effects necessary for evaluation of modules and terms, but may also include any other effects so long as theyre eventually handled.
newtype Evaluator term address value effects a = Evaluator { runEvaluator :: Eff effects a }
deriving (Applicative, Effectful, Functor, Monad)
newtype Evaluator term address value m a = Evaluator { runEvaluator :: Eff m a }
deriving (Applicative, Functor, Monad)
deriving instance Member NonDet effects => Alternative (Evaluator term address value effects)
deriving instance Member (Lift IO) effects => MonadIO (Evaluator term address value effects)
deriving instance (Member NonDet sig, Carrier sig m) => Alternative (Evaluator term address value m)
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
ret = Evaluator . ret
eff = Evaluator . eff . handlePure runEvaluator
-- | Raise a handler on 'Eff's into a handler on 'Evaluator's.
raiseHandler :: (Eff m a -> Eff n b)
-> Evaluator term address value m a
-> Evaluator term address value n b
raiseHandler = coerce
-- | An open-recursive function.
@ -49,16 +62,16 @@ type Open a = a -> a
newtype Return address = Return { unReturn :: address }
deriving (Eq, Ord, Show)
earlyReturn :: Member (Exc (Return address)) effects
earlyReturn :: (Member (Error (Return address)) sig, Carrier sig m)
=> address
-> Evaluator term address value effects address
-> Evaluator term address value m address
earlyReturn = throwError . Return
catchReturn :: Member (Exc (Return address)) effects => Evaluator term address value effects address -> Evaluator term address value effects address
catchReturn = Eff.raiseHandler (handleError (\ (Return addr) -> pure addr))
catchReturn :: (Member (Error (Return address)) sig, Carrier sig m) => Evaluator term address value m address -> Evaluator term address value m address
catchReturn = flip catchError (\ (Return addr) -> pure addr)
runReturn :: Effects effects => Evaluator term address value (Exc (Return address) ': effects) address -> Evaluator term address value effects address
runReturn = Eff.raiseHandler (fmap (either unReturn id) . runError)
runReturn :: (Carrier sig m, Effect sig) => Evaluator term address value (ErrorC (Return address) (Eff m)) address -> Evaluator term address value m address
runReturn = raiseHandler $ fmap (either unReturn id) . runError
-- | Effects for control flow around loops (breaking and continuing).
@ -68,22 +81,23 @@ data LoopControl address
| Abort
deriving (Eq, Ord, Show)
throwBreak :: Member (Exc (LoopControl address)) effects
throwBreak :: (Member (Error (LoopControl address)) sig, Carrier sig m)
=> address
-> Evaluator term address value effects address
-> Evaluator term address value m address
throwBreak = throwError . Break
throwContinue :: Member (Exc (LoopControl address)) effects
throwContinue :: (Member (Error (LoopControl address)) sig, Carrier sig m)
=> address
-> Evaluator term address value effects address
-> Evaluator term address value m address
throwContinue = throwError . Continue
throwAbort :: forall term address effects value a . Member (Exc (LoopControl address)) effects
=> Evaluator term address value effects a
throwAbort :: forall term address sig m value a
. (Member (Error (LoopControl address)) sig, Carrier sig m)
=> Evaluator term address value m a
throwAbort = throwError (Abort @address)
catchLoopControl :: Member (Exc (LoopControl address)) effects => Evaluator term address value effects a -> (LoopControl address -> Evaluator term address value effects a) -> Evaluator term address value effects a
catchLoopControl :: (Member (Error (LoopControl address)) sig, Carrier sig m) => Evaluator term address value m a -> (LoopControl address -> Evaluator term address value m a) -> Evaluator term address value m a
catchLoopControl = catchError
runLoopControl :: Effects effects => Evaluator term address value (Exc (LoopControl address) ': effects) address -> Evaluator term address value effects address
runLoopControl = Eff.raiseHandler (fmap (either unLoopControl id) . runError)
runLoopControl :: (Carrier sig m, Effect sig) => Evaluator term address value (ErrorC (LoopControl address) (Eff m)) address -> Evaluator term address value m address
runLoopControl = raiseHandler $ fmap (either unLoopControl id) . runError

View File

@ -1,4 +1,4 @@
{-# LANGUAGE GADTs, KindSignatures, RankNTypes, TypeOperators, UndecidableInstances #-}
{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, KindSignatures, RankNTypes, TypeOperators, UndecidableInstances #-}
module Control.Abstract.Heap
( Heap
, Live
@ -13,7 +13,11 @@ module Control.Abstract.Heap
, gc
-- * Effects
, Allocator(..)
, runAllocator
, AllocatorC(..)
, Deref(..)
, runDeref
, DerefC(..)
, AddressError(..)
, runAddressError
, runAddressErrorWith
@ -21,6 +25,8 @@ module Control.Abstract.Heap
import Control.Abstract.Evaluator
import Control.Abstract.Roots
import Control.Applicative (Alternative)
import Control.Effect.Carrier
import Data.Abstract.BaseError
import Data.Abstract.Heap
import Data.Abstract.Live
@ -30,73 +36,77 @@ import Data.Span (Span)
import Prologue
-- | Retrieve the heap.
getHeap :: Member (State (Heap address value)) effects => Evaluator term address value effects (Heap address value)
getHeap :: (Member (State (Heap address value)) sig, Carrier sig m) => Evaluator term address value m (Heap address value)
getHeap = get
-- | Set the heap.
putHeap :: Member (State (Heap address value)) effects => Heap address value -> Evaluator term address value effects ()
putHeap :: (Member (State (Heap address value)) sig, Carrier sig m) => Heap address value -> Evaluator term address value m ()
putHeap = put
-- | Update the heap.
modifyHeap :: Member (State (Heap address value)) effects => (Heap address value -> Heap address value) -> Evaluator term address value effects ()
modifyHeap = modify'
modifyHeap :: (Member (State (Heap address value)) sig, Carrier sig m) => (Heap address value -> Heap address value) -> Evaluator term address value m ()
modifyHeap = modify
box :: ( Member (Allocator address) effects
, Member (Deref value) effects
, Member Fresh effects
, Member (State (Heap address value)) effects
box :: ( Member (Allocator address) sig
, Member (Deref value) sig
, Member Fresh sig
, Member (State (Heap address value)) sig
, Ord address
, Carrier sig m
)
=> value
-> Evaluator term address value effects address
-> Evaluator term address value m address
box val = do
name <- gensym
addr <- alloc name
assign addr val
pure addr
alloc :: Member (Allocator address) effects => Name -> Evaluator term address value effects address
alloc = send . Alloc
alloc :: (Member (Allocator address) sig, Carrier sig m) => Name -> Evaluator term address value m address
alloc = send . flip Alloc ret
dealloc :: (Member (State (Heap address value)) effects, Ord address) => address -> Evaluator term address value effects ()
dealloc :: (Member (State (Heap address value)) sig, Ord address, Carrier sig m) => address -> Evaluator term address value m ()
dealloc addr = modifyHeap (heapDelete addr)
-- | Dereference the given address in the heap, or fail if the address is uninitialized.
deref :: ( Member (Deref value) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (AddressError address value))) effects
, Member (State (Heap address value)) effects
deref :: ( Member (Deref value) sig
, Member (Reader ModuleInfo) sig
, Member (Reader Span) sig
, Member (Resumable (BaseError (AddressError address value))) sig
, Member (State (Heap address value)) sig
, Ord address
, Carrier sig m
)
=> address
-> Evaluator term address value effects value
deref addr = gets (heapLookup addr) >>= maybeM (throwAddressError (UnallocatedAddress addr)) >>= send . DerefCell >>= maybeM (throwAddressError (UninitializedAddress addr))
-> Evaluator term address value m value
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'.
assign :: ( Member (Deref value) effects
, Member (State (Heap address value)) effects
assign :: ( Member (Deref value) sig
, Member (State (Heap address value)) sig
, Ord address
, Carrier sig m
)
=> address
-> value
-> Evaluator term address value effects ()
-> Evaluator term address value m ()
assign addr value = do
heap <- getHeap
cell <- send (AssignCell value (fromMaybe lowerBound (heapLookup addr heap)))
cell <- send (AssignCell value (fromMaybe lowerBound (heapLookup addr heap)) ret)
putHeap (heapInit addr cell heap)
-- Garbage collection
-- | Collect any addresses in the heap not rooted in or reachable from the given 'Live' set.
gc :: ( Member (State (Heap address value)) effects
gc :: ( Member (State (Heap address value)) sig
, Ord address
, ValueRoots address value
, Carrier sig m
)
=> Live address -- ^ The set of addresses to consider rooted.
-> Evaluator term address value effects ()
-> Evaluator term address value m ()
gc roots = modifyHeap (heapRestrict <*> reachable roots)
-- | Compute the set of addresses reachable from a given root set in a given heap.
@ -116,23 +126,47 @@ reachable roots heap = go mempty roots
-- Effects
data Allocator address (m :: * -> *) return where
Alloc :: Name -> Allocator address m address
data Allocator address (m :: * -> *) k
= Alloc Name (address -> k)
deriving (Functor)
data Deref value (m :: * -> *) return where
DerefCell :: Set value -> Deref value m (Maybe value)
AssignCell :: value -> Set value -> Deref value m (Set value)
instance PureEffect (Allocator address)
instance HFunctor (Allocator address) where
hmap _ (Alloc name k) = Alloc name k
instance Effect (Allocator address) where
handleState c dist (Request (Alloc name) k) = Request (Alloc name) (dist . (<$ c) . k)
handle state handler (Alloc name k) = Alloc name (handler . (<$ state) . k)
instance PureEffect (Deref value)
runAllocator :: Carrier (Allocator address :+: sig) (AllocatorC address (Eff m))
=> Evaluator term address value (AllocatorC address (Eff m)) a
-> Evaluator term address value m a
runAllocator = raiseHandler $ runAllocatorC . interpret
newtype AllocatorC address m a = AllocatorC { runAllocatorC :: m a }
deriving (Alternative, Applicative, Functor, Monad)
data Deref value (m :: * -> *) k
= DerefCell (Set value) (Maybe value -> k)
| AssignCell value (Set value) (Set value -> k)
deriving (Functor)
instance HFunctor (Deref value) where
hmap _ (DerefCell cell k) = DerefCell cell k
hmap _ (AssignCell value cell k) = AssignCell value cell k
instance Effect (Deref value) where
handleState c dist (Request (DerefCell cell) k) = Request (DerefCell cell) (dist . (<$ c) . k)
handleState c dist (Request (AssignCell value cell) k) = Request (AssignCell value cell) (dist . (<$ c) . k)
handle state handler (DerefCell cell k) = DerefCell cell (handler . (<$ state) . k)
handle state handler (AssignCell value cell k) = AssignCell value cell (handler . (<$ state) . k)
runDeref :: Carrier (Deref value :+: sig) (DerefC address value (Eff m))
=> Evaluator term address value (DerefC address value (Eff m)) a
-> Evaluator term address value m a
runDeref = raiseHandler $ runDerefC . interpret
newtype DerefC address value m a = DerefC { runDerefC :: m a }
deriving (Alternative, Applicative, Functor, Monad)
data AddressError address value resume where
UnallocatedAddress :: address -> AddressError address value (Set value)
@ -155,21 +189,22 @@ instance Eq address => Eq1 (AddressError address value) where
liftEq _ (UnallocatedAddress a) (UnallocatedAddress b) = a == b
liftEq _ _ _ = False
throwAddressError :: ( Member (Resumable (BaseError (AddressError address body))) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
throwAddressError :: ( Member (Resumable (BaseError (AddressError address body))) sig
, Member (Reader ModuleInfo) sig
, Member (Reader Span) sig
, Carrier sig m
)
=> AddressError address body resume
-> Evaluator term address value effects resume
-> Evaluator term address value m resume
throwAddressError = throwBaseError
runAddressError :: Effects effects
=> Evaluator term address value (Resumable (BaseError (AddressError address value)) ': effects) a
-> Evaluator term address value effects (Either (SomeExc (BaseError (AddressError address value))) a)
runAddressError = runResumable
runAddressError :: (Carrier sig m, Effect sig)
=> Evaluator term address value (ResumableC (BaseError (AddressError address value)) (Eff m)) a
-> Evaluator term address value m (Either (SomeError (BaseError (AddressError address value))) a)
runAddressError = raiseHandler runResumable
runAddressErrorWith :: Effects effects
=> (forall resume . (BaseError (AddressError address value)) resume -> Evaluator term address value effects resume)
-> Evaluator term address value (Resumable (BaseError (AddressError address value)) ': effects) a
-> Evaluator term address value effects a
runAddressErrorWith = runResumableWith
runAddressErrorWith :: Carrier sig m
=> (forall resume . (BaseError (AddressError address value)) resume -> Evaluator term address value m resume)
-> Evaluator term address value (ResumableWithC (BaseError (AddressError address value)) (Eff m)) a
-> Evaluator term address value m a
runAddressErrorWith f = raiseHandler $ runResumableWith (runEvaluator . f)

View File

@ -1,4 +1,4 @@
{-# LANGUAGE GADTs, LambdaCase, KindSignatures, RankNTypes, ScopedTypeVariables, TypeOperators #-}
{-# LANGUAGE GADTs, LambdaCase, KindSignatures, RankNTypes, ScopedTypeVariables, TypeOperators, UndecidableInstances #-}
module Control.Abstract.Modules
( ModuleResult
, lookupModule
@ -20,10 +20,13 @@ 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
import Data.Abstract.ModuleTable as ModuleTable
import Data.Coerce
import Data.Language
import Data.Semigroup.Foldable (foldMap1)
import qualified Data.Set as Set
@ -35,60 +38,74 @@ import Data.Abstract.ScopeGraph
type ModuleResult address = (ScopeGraph address, (Bindings address, address))
-- | Retrieve an evaluated module, if any. @Nothing@ means weve never tried to load it, and @Just (env, value)@ indicates the result of a completed load.
lookupModule :: Member (Modules address) effects => ModulePath -> Evaluator term address value effects (Maybe (ModuleResult address))
lookupModule = sendModules . Lookup
lookupModule :: (Member (Modules address) sig, Carrier sig m) => ModulePath -> Evaluator term address value m (Maybe (ModuleResult address))
lookupModule = sendModules . flip Lookup ret
-- | Resolve a list of module paths to a possible module table entry.
resolve :: Member (Modules address) effects => [FilePath] -> Evaluator term address value effects (Maybe ModulePath)
resolve = sendModules . Resolve
resolve :: (Member (Modules address) sig, Carrier sig m) => [FilePath] -> Evaluator term address value m (Maybe ModulePath)
resolve = sendModules . flip Resolve ret
listModulesInDir :: Member (Modules address) effects => FilePath -> Evaluator term address value effects [ModulePath]
listModulesInDir = sendModules . List
listModulesInDir :: (Member (Modules address) sig, Carrier sig m) => FilePath -> Evaluator term address value m [ModulePath]
listModulesInDir = sendModules . flip List ret
-- | Require/import another module by name and return its environment and value.
--
-- Looks up the module's name in the cache of evaluated modules first, returns if found, otherwise loads/evaluates the module.
require :: Member (Modules address) effects => ModulePath -> Evaluator term address value effects (ModuleResult address)
require :: (Member (Modules address) sig, Carrier sig m) => ModulePath -> Evaluator term address value m (ModuleResult address)
require path = lookupModule path >>= maybeM (load path)
-- | Load another module by name and return its environment and value.
--
-- Always loads/evaluates.
load :: Member (Modules address) effects => ModulePath -> Evaluator term address value effects (ModuleResult address)
load path = sendModules (Load path)
load :: (Member (Modules address) sig, Carrier sig m) => ModulePath -> Evaluator term address value m (ModuleResult address)
load path = sendModules (Load path ret)
data Modules address (m :: * -> *) return where
Load :: ModulePath -> Modules address m (ModuleResult address)
Lookup :: ModulePath -> Modules address m (Maybe (ModuleResult address))
Resolve :: [FilePath] -> Modules address m (Maybe ModulePath)
List :: FilePath -> Modules address m [ModulePath]
data Modules address (m :: * -> *) k
= Load ModulePath (ModuleResult address -> k)
| Lookup ModulePath (Maybe (ModuleResult address) -> k)
| Resolve [FilePath] (Maybe ModulePath -> k)
| List FilePath ([ModulePath] -> k)
deriving (Functor)
instance HFunctor (Modules address) where
hmap _ = coerce
instance PureEffect (Modules address)
instance Effect (Modules address) where
handleState c dist (Request (Load path) k) = Request (Load path) (dist . (<$ c) . k)
handleState c dist (Request (Lookup path) k) = Request (Lookup path) (dist . (<$ c) . k)
handleState c dist (Request (Resolve paths) k) = Request (Resolve paths) (dist . (<$ c) . k)
handleState c dist (Request (List path) k) = Request (List path) (dist . (<$ c) . k)
handle state handler (Load path k) = Load path (handler . (<$ state) . k)
handle state handler (Lookup path k) = Lookup path (handler . (<$ state) . k)
handle state handler (Resolve paths k) = Resolve paths (handler . (<$ state) . k)
handle state handler (List path k) = List path (handler . (<$ state) . k)
sendModules :: Member (Modules address) effects => Modules address (Eff effects) return -> Evaluator term address value effects return
sendModules :: (Member (Modules address) sig, Carrier sig m) => Modules address (Evaluator term address value m) (Evaluator term address value m return) -> Evaluator term address value m return
sendModules = send
runModules :: ( Member (Reader (ModuleTable (NonEmpty (Module (ModuleResult address))))) effects
, Member (Resumable (BaseError (LoadError address))) effects
, PureEffects effects
runModules :: ( Member (Reader (ModuleTable (NonEmpty (Module (ModuleResult address))))) sig
, Member (Resumable (BaseError (LoadError address))) sig
, Carrier sig m
)
=> Set ModulePath
-> Evaluator term address value (Modules address ': effects) a
-> Evaluator term address value effects a
runModules paths = interpret $ \case
Load name -> fmap (runMerging . foldMap1 (Merging . moduleBody)) . ModuleTable.lookup name <$> askModuleTable >>= maybeM (throwLoadError (ModuleNotFoundError name))
Lookup path -> fmap (runMerging . foldMap1 (Merging . moduleBody)) . ModuleTable.lookup path <$> askModuleTable
Resolve names -> pure (find (`Set.member` paths) names)
List dir -> pure (filter ((dir ==) . takeDirectory) (toList paths))
-> Evaluator term address value (ModulesC address (Eff m)) a
-> Evaluator term address value m a
runModules paths = raiseHandler $ flip runModulesC paths . interpret
askModuleTable :: Member (Reader (ModuleTable (NonEmpty (Module (ModuleResult address))))) effects => Evaluator term address value effects (ModuleTable (NonEmpty (Module (ModuleResult address))))
newtype ModulesC address m a = ModulesC { runModulesC :: Set ModulePath -> m a }
instance ( Member (Reader (ModuleTable (NonEmpty (Module (ModuleResult address))))) sig
, Member (Resumable (BaseError (LoadError address))) sig
, Carrier sig m
, Monad m
)
=> Carrier (Modules address :+: sig) (ModulesC address m) where
ret = ModulesC . const . ret
eff op = ModulesC (\ paths -> handleSum (eff . handleReader paths runModulesC) (\case
Load name k -> askModuleTable >>= maybeM (throwLoadError (ModuleNotFoundError name)) . fmap (runMerging . foldMap1 (Merging . moduleBody)) . ModuleTable.lookup name >>= flip runModulesC paths . k
Lookup path k -> askModuleTable >>= flip runModulesC paths . k . fmap (runMerging . foldMap1 (Merging . moduleBody)) . ModuleTable.lookup path
Resolve names k -> runModulesC (k (find (`Set.member` paths) names)) paths
List dir k -> runModulesC (k (filter ((dir ==) . takeDirectory) (toList paths))) paths) op)
askModuleTable :: (Member (Reader (ModuleTable (NonEmpty (Module (ModuleResult address))))) sig, Carrier sig m) => m (ModuleTable (NonEmpty (Module (ModuleResult address))))
askModuleTable = ask
@ -112,20 +129,20 @@ instance Eq1 (LoadError address) where
instance NFData1 (LoadError address) where
liftRnf _ (ModuleNotFoundError p) = rnf p
runLoadError :: Effects effects
=> Evaluator term address value (Resumable (BaseError (LoadError address)) ': effects) a
-> Evaluator term address value effects (Either (SomeExc (BaseError (LoadError address))) a)
runLoadError = runResumable
runLoadError :: (Carrier sig m, Effect sig)
=> Evaluator term address value (ResumableC (BaseError (LoadError address)) (Eff m)) a
-> Evaluator term address value m (Either (SomeError (BaseError (LoadError address))) a)
runLoadError = raiseHandler runResumable
runLoadErrorWith :: Effects effects
=> (forall resume . (BaseError (LoadError address)) resume -> Evaluator term address value effects resume)
-> Evaluator term address value (Resumable (BaseError (LoadError address)) ': effects) a
-> Evaluator term address value effects a
runLoadErrorWith = runResumableWith
runLoadErrorWith :: Carrier sig m
=> (forall resume . (BaseError (LoadError address)) resume -> Evaluator term address value m resume)
-> Evaluator term address value (ResumableWithC (BaseError (LoadError address)) (Eff m)) a
-> Evaluator term address value m a
runLoadErrorWith f = raiseHandler $ runResumableWith (runEvaluator . f)
throwLoadError :: Member (Resumable (BaseError (LoadError address))) effects
throwLoadError :: (Member (Resumable (BaseError (LoadError address))) sig, Carrier sig m)
=> LoadError address resume
-> Evaluator term address value effects resume
-> m resume
throwLoadError err@(ModuleNotFoundError name) = throwResumable $ BaseError (ModuleInfo name) emptySpan err
@ -150,21 +167,22 @@ instance NFData1 ResolutionError where
NotFoundError p ps l -> rnf p `seq` rnf ps `seq` rnf l
GoImportError p -> rnf p
runResolutionError :: Effects effects
=> Evaluator term address value (Resumable (BaseError ResolutionError) ': effects) a
-> Evaluator term address value effects (Either (SomeExc (BaseError ResolutionError)) a)
runResolutionError = runResumable
runResolutionError :: (Carrier sig m, Effect sig)
=> Evaluator term address value (ResumableC (BaseError ResolutionError) (Eff m)) a
-> Evaluator term address value m (Either (SomeError (BaseError ResolutionError)) a)
runResolutionError = raiseHandler runResumable
runResolutionErrorWith :: Effects effects
=> (forall resume . (BaseError ResolutionError) resume -> Evaluator term address value effects resume)
-> Evaluator term address value (Resumable (BaseError ResolutionError) ': effects) a
-> Evaluator term address value effects a
runResolutionErrorWith = runResumableWith
runResolutionErrorWith :: Carrier sig m
=> (forall resume . (BaseError ResolutionError) resume -> Evaluator term address value m resume)
-> Evaluator term address value (ResumableWithC (BaseError ResolutionError) (Eff m)) a
-> Evaluator term address value m a
runResolutionErrorWith f = raiseHandler $ runResumableWith (runEvaluator . f)
throwResolutionError :: ( Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError ResolutionError)) effects
throwResolutionError :: ( Member (Reader ModuleInfo) sig
, Member (Reader Span) sig
, Member (Resumable (BaseError ResolutionError)) sig
, Carrier sig m
)
=> ResolutionError resume
-> Evaluator term address value effects resume
-> Evaluator term address value m resume
throwResolutionError = throwBaseError

View File

@ -14,53 +14,56 @@ import Data.Abstract.Name
import Prologue
define :: ( HasCallStack
, Member (Allocator address) effects
, Member (Deref value) effects
, Member (Env address) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (State (Heap address value)) effects
, Member (Allocator address) sig
, Member (Deref value) sig
, Member (Env address) sig
, Member (Reader ModuleInfo) sig
, Member (Reader Span) sig
, Member (State (Heap address value)) sig
, Carrier sig m
, Ord address
)
=> Name
-> Evaluator term address value effects value
-> Evaluator term address value effects ()
-> Evaluator term address value m value
-> Evaluator term address value m ()
define name def = withCurrentCallStack callStack $ do
addr <- alloc name
def >>= assign addr
bind name addr
defineClass :: ( AbstractValue term address value effects
defineClass :: ( AbstractValue term address value m
, Carrier sig m
, HasCallStack
, Member (Allocator address) effects
, Member (Deref value) effects
, Member (Env address) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (State (Heap address value)) effects
, Member (Allocator address) sig
, Member (Deref value) sig
, Member (Env address) sig
, Member (Reader ModuleInfo) sig
, Member (Reader Span) sig
, Member (State (Heap address value)) sig
, Ord address
)
=> Name
-> [address]
-> Evaluator term address value effects a
-> Evaluator term address value effects ()
-> Evaluator term address value m a
-> Evaluator term address value m ()
defineClass name superclasses body = define name $ do
binds <- Env.head <$> locally (body >> getEnv)
klass name superclasses binds
defineNamespace :: ( AbstractValue term address value effects
defineNamespace :: ( AbstractValue term address value m
, Carrier sig m
, HasCallStack
, Member (Allocator address) effects
, Member (Deref value) effects
, Member (Env address) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (State (Heap address value)) effects
, Member (Allocator address) sig
, Member (Deref value) sig
, Member (Env address) sig
, Member (Reader ModuleInfo) sig
, Member (Reader Span) sig
, Member (State (Heap address value)) sig
, Ord address
)
=> Name
-> Evaluator term address value effects a
-> Evaluator term address value effects ()
-> Evaluator term address value m a
-> Evaluator term address value m ()
defineNamespace name scope = define name $ do
binds <- Env.head <$> locally (scope >> getEnv)
namespace name Nothing binds

View File

@ -1,11 +1,12 @@
{-# LANGUAGE GADTs, LambdaCase, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Abstract.PythonPackage
( runPythonPackaging, Strategy(..) ) where
import Control.Abstract.Evaluator (LoopControl, Return)
import Control.Abstract.Heap (Allocator, Deref, deref)
import Control.Abstract.Value
import qualified Control.Monad.Effect as Eff
import Control.Effect.Carrier
import Control.Effect.Sum
import Data.Abstract.Evaluatable
import Data.Abstract.Name (name)
import Data.Abstract.Path (stripQuotes)
@ -16,50 +17,82 @@ import Prologue
data Strategy = Unknown | Packages [Text] | FindPackages [Text]
deriving (Show, Eq)
runPythonPackaging :: forall effects term address a. (
Eff.PureEffects effects
runPythonPackaging :: ( Carrier sig m
, Ord address
, Show address
, Show term
, Member Trace effects
, Member (Boolean (Value term address)) effects
, Member (State (Heap address (Value term address))) effects
, Member (Resumable (BaseError (AddressError address (Value term address)))) effects
, Member (Resumable (BaseError (ValueError term address))) effects
, Member Fresh effects
, Member (State Strategy) effects
, Member (Allocator address) effects
, Member (Deref (Value term address)) effects
, Member (Env address) effects
, Member (Eff.Exc (LoopControl address)) effects
, Member (Eff.Exc (Return address)) effects
, Member (Eff.Reader ModuleInfo) effects
, Member (Eff.Reader PackageInfo) effects
, Member (Eff.Reader Span) effects
, Member (Function term address (Value term address)) effects)
=> Evaluator term address (Value term address) effects a
-> Evaluator term address (Value term address) effects a
runPythonPackaging = Eff.interpose @(Function term address (Value term address)) $ \case
Call callName super params -> do
case callName of
Closure _ _ name' paramNames _ _ -> do
let bindings = foldr (\ (name, addr) rest -> Map.insert name addr rest) lowerBound (zip paramNames params)
let asStrings address = (deref >=> asArray) address >>= traverse (deref >=> asString)
, Member Trace sig
, Member (Boolean (Value term address)) sig
, Member (State (Heap address (Value term address))) sig
, Member (Resumable (BaseError (AddressError address (Value term address)))) sig
, Member (Resumable (BaseError (ValueError term address))) sig
, Member Fresh sig
, Member (State Strategy) sig
, Member (Allocator address) sig
, Member (Deref (Value term address)) sig
, Member (Env address) sig
, Member (Error (LoopControl address)) sig
, Member (Error (Return address)) sig
, Member (Reader ModuleInfo) sig
, Member (Reader PackageInfo) sig
, Member (Reader Span) sig
, Member (Function term address (Value term address)) sig
)
=> Evaluator term address (Value term address) (PythonPackagingC term address (Eff m)) a
-> Evaluator term address (Value term address) m a
runPythonPackaging = raiseHandler (runPythonPackagingC . interpret)
case name' of
Just n
| name "find_packages" == n -> do
as <- maybe (pure mempty) (fmap (fmap stripQuotes) . asStrings) (Map.lookup (name "exclude") bindings)
put (FindPackages as)
| name "setup" == n -> do
packageState <- get
if packageState == Unknown then do
as <- maybe (pure mempty) (fmap (fmap stripQuotes) . asStrings) (Map.lookup (name "packages") bindings)
put (Packages as)
else
pure ()
newtype PythonPackagingC term address m a = PythonPackagingC { runPythonPackagingC :: m a }
wrap :: Evaluator term address (Value term address) m a -> PythonPackagingC term address (Eff m) a
wrap = PythonPackagingC . runEvaluator
instance ( Carrier sig m
, Member (Allocator address) sig
, Member (Boolean (Value term address)) sig
, Member (Deref (Value term address)) sig
, Member (Env address) sig
, Member (Error (LoopControl address)) sig
, Member (Error (Return address)) sig
, Member Fresh sig
, Member (Function term address (Value term address)) sig
, Member (Reader ModuleInfo) sig
, Member (Reader PackageInfo) sig
, Member (Reader Span) sig
, Member (Resumable (BaseError (AddressError address (Value term address)))) sig
, Member (Resumable (BaseError (ValueError term address))) sig
, Member (State (Heap address (Value term address))) sig
, Member (State Strategy) sig
, Member Trace sig
, Ord address
, Show address
, Show term
)
=> Carrier sig (PythonPackagingC term address (Eff m)) where
ret = PythonPackagingC . ret
eff op
| Just e <- prj op = wrap $ case handleCoercible e of
Call callName super params k -> Evaluator . k =<< do
case callName of
Closure _ _ name' paramNames _ _ -> do
let bindings = foldr (uncurry Map.insert) lowerBound (zip paramNames params)
let asStrings = deref >=> asArray >=> traverse (deref >=> asString)
case name' of
Just n
| name "find_packages" == n -> do
as <- maybe (pure mempty) (fmap (fmap stripQuotes) . asStrings) (Map.lookup (name "exclude") bindings)
put (FindPackages as)
| name "setup" == n -> do
packageState <- get
if packageState == Unknown then do
as <- maybe (pure mempty) (fmap (fmap stripQuotes) . asStrings) (Map.lookup (name "packages") bindings)
put (Packages as)
else
pure ()
_ -> pure ()
_ -> pure ()
_ -> pure ()
call callName super params
Function name params body -> function name params body
BuiltIn b -> builtIn b
call callName super params
Function name params body k -> function name params body >>= Evaluator . k
BuiltIn b k -> builtIn b >>= Evaluator . k
| otherwise = PythonPackagingC (eff (handleCoercible op))

View File

@ -14,9 +14,9 @@ class ValueRoots address value where
valueRoots :: value -> Live address
-- | Retrieve the local 'Live' set.
askRoots :: Member (Reader (Live address)) effects => Evaluator term address value effects (Live address)
askRoots :: (Member (Reader (Live address)) sig, Carrier sig m) => Evaluator term address value m (Live address)
askRoots = ask
-- | Run a computation with the given 'Live' set added to the local root set.
extraRoots :: (Member (Reader (Live address)) effects, Ord address) => Live address -> Evaluator term address value effects a -> Evaluator term address value effects a
extraRoots :: (Member (Reader (Live address)) sig, Carrier sig m, Ord address) => Live address -> Evaluator term address value m a -> Evaluator term address value m a
extraRoots roots = local (<> roots)

View File

@ -1,6 +1,7 @@
{-# LANGUAGE GADTs, KindSignatures, LambdaCase, RankNTypes, ScopedTypeVariables, TypeOperators #-}
{-# LANGUAGE ExistentialQuantification, GADTs, KindSignatures, LambdaCase, RankNTypes, ScopedTypeVariables, TypeOperators, UndecidableInstances #-}
module Control.Abstract.ScopeGraph
( runScopeEnv
, ScopeEnvC(..)
, ScopeEnv
, lookup
, declare
@ -17,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
@ -24,75 +27,93 @@ import Data.Span
import Prelude hiding (lookup)
import Prologue
data ScopeEnv address (m :: * -> *) a where
Lookup :: Reference -> ScopeEnv address m (Maybe address)
Declare :: Declaration -> Span -> Maybe address -> ScopeEnv address m ()
PutDeclarationScope :: Declaration -> address -> ScopeEnv address m ()
Reference :: Reference -> Declaration -> ScopeEnv address m ()
NewScope :: Map EdgeLabel [address] -> ScopeEnv address m address
CurrentScope :: ScopeEnv address m (Maybe address)
Local :: address -> m a -> ScopeEnv address m a
AssociatedScope :: Declaration -> ScopeEnv address m (Maybe address)
data ScopeEnv address (m :: * -> *) k
= Lookup Reference (Maybe address -> k)
| Declare Declaration Span (Maybe address) k
| PutDeclarationScope Declaration address k
| Reference Reference Declaration k
| NewScope (Map EdgeLabel [address]) (address -> k)
| CurrentScope (Maybe address -> k)
| forall a . Local address (m a) (a -> k)
| AssociatedScope Declaration (Maybe address -> k)
lookup :: forall term address value effects. Member (ScopeEnv address) effects => Reference -> Evaluator term address value effects (Maybe address)
lookup = send . Lookup @address
deriving instance Functor (ScopeEnv address m)
declare :: forall term address value effects. Member (ScopeEnv address) effects => Declaration -> Span -> Maybe address -> Evaluator term address value effects ()
declare = ((send .) .) . Declare @address
lookup :: (Member (ScopeEnv address) sig, Carrier sig m) => Reference -> Evaluator term address value m (Maybe address)
lookup ref = sendScope (Lookup ref ret)
putDeclarationScope :: forall term address value effects. Member (ScopeEnv address) effects => Declaration -> address -> Evaluator term address value effects ()
putDeclarationScope = (send .) . PutDeclarationScope @address
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 (ret ()))
reference :: forall term address value effects. Member (ScopeEnv address) effects => Reference -> Declaration -> Evaluator term address value effects ()
reference = (send .) . Reference @address
putDeclarationScope :: (Member (ScopeEnv address) sig, Carrier sig m) => Declaration -> address -> Evaluator term address value m ()
putDeclarationScope decl addr = sendScope (PutDeclarationScope decl addr (ret ()))
newScope :: forall term address value effects. (Member (ScopeEnv address) effects) => Map EdgeLabel [address] -> Evaluator term address value effects address
newScope map = send (NewScope map)
reference :: (Member (ScopeEnv address) sig, Carrier sig m) => Reference -> Declaration -> Evaluator term address value m ()
reference ref decl = sendScope (Reference ref decl (ret ()))
currentScope :: forall term address value effects. Member (ScopeEnv address) effects => Evaluator term address value effects (Maybe address)
currentScope = send CurrentScope
newScope :: (Member (ScopeEnv address) sig, Carrier sig m) => Map EdgeLabel [address] -> Evaluator term address value m address
newScope map = send (NewScope map ret)
associatedScope :: forall term address value effects. Member (ScopeEnv address) effects => Declaration -> Evaluator term address value effects (Maybe address)
associatedScope = send . AssociatedScope
currentScope :: (Member (ScopeEnv address) sig, Carrier sig m) => Evaluator term address value m (Maybe address)
currentScope = send (CurrentScope ret)
withScope :: forall term address value effects a. Member (ScopeEnv address) effects => address -> Evaluator term address value effects a -> Evaluator term address value effects a
withScope scope action = send (Local scope (lowerEff action))
associatedScope :: (Member (ScopeEnv address) sig, Carrier sig m) => Declaration -> Evaluator term address value m (Maybe address)
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 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
instance HFunctor (ScopeEnv address) where
hmap f = \case
Lookup ref k -> Lookup ref k
Declare decl span assocScope k -> Declare decl span assocScope k
PutDeclarationScope decl assocScope k -> PutDeclarationScope decl assocScope k
Reference ref decl k -> Reference ref decl k
NewScope edges k -> NewScope edges k
CurrentScope k -> CurrentScope k
AssociatedScope decl k -> AssociatedScope decl k
Local scope action k -> Local scope (f action) k
instance PureEffect (ScopeEnv address)
instance Effect (ScopeEnv address) where
handleState c dist (Request (Lookup ref) k) = Request (Lookup ref) (dist . (<$ c) . k)
handleState c dist (Request (Declare decl span assocScope) k) = Request (Declare decl span assocScope) (dist . (<$ c) . k)
handleState c dist (Request (PutDeclarationScope decl assocScope) k) = Request (PutDeclarationScope decl assocScope) (dist . (<$ c) . k)
handleState c dist (Request (Reference ref decl) k) = Request (Reference ref decl) (dist . (<$ c) . k)
handleState c dist (Request (NewScope edges) k) = Request (NewScope edges) (dist . (<$ c) . k)
handleState c dist (Request CurrentScope k) = Request CurrentScope (dist . (<$ c) . k)
handleState c dist (Request (AssociatedScope decl) k) = Request (AssociatedScope decl) (dist . (<$ c) . k)
handleState c dist (Request (Local scope action) k) = Request (Local scope (dist (action <$ c))) (dist . fmap k)
handle state handler = \case
Lookup ref k -> Lookup ref (handler . (<$ state) . k)
Declare decl span assocScope k -> Declare decl span assocScope (handler (k <$ state))
PutDeclarationScope decl assocScope k -> PutDeclarationScope decl assocScope (handler (k <$ state))
Reference ref decl k -> Reference ref decl (handler (k <$ state))
NewScope edges k -> NewScope edges (handler . (<$ state) . k)
CurrentScope k -> CurrentScope (handler . (<$ state) . k)
AssociatedScope decl k -> AssociatedScope decl (handler . (<$ state) . k)
Local scope action k -> Local scope (handler (action <$ state)) (handler . fmap k)
runScopeEnv :: (Ord address, Effects effects, Member Fresh effects, Member (Allocator address) effects)
=> Evaluator term address value (ScopeEnv address ': effects) a
-> Evaluator term address value effects (ScopeGraph address, a)
runScopeEnv evaluator = runState lowerBound (reinterpret handleScopeEnv evaluator)
runScopeEnv :: (Ord address, Member Fresh sig, Member (Allocator address) sig, Carrier sig m, Effect sig)
=> Evaluator term address value (ScopeEnvC address (Eff m)) a
-> Evaluator term address value m (ScopeGraph address, a)
runScopeEnv = raiseHandler $ runState lowerBound . runScopeEnvC . interpret
handleScopeEnv :: forall term address value effects a. (Ord address, Member Fresh effects, Member (Allocator address) effects, Effects effects)
=> ScopeEnv address (Eff (ScopeEnv address ': effects)) a
-> Evaluator term address value (State (ScopeGraph address) ': effects) a
handleScopeEnv = \case
Lookup ref -> ScopeGraph.scopeOfRef ref <$> get
Declare decl span scope -> modify @(ScopeGraph address) (ScopeGraph.declare decl span scope)
PutDeclarationScope decl scope -> modify @(ScopeGraph address) (ScopeGraph.insertDeclarationScope decl scope)
Reference ref decl -> modify @(ScopeGraph address) (ScopeGraph.reference ref decl)
NewScope edges -> do
-- Take the edges and construct a new scope, update the current scope to the new scope
name <- gensym
address <- alloc name
address <$ modify @(ScopeGraph address) (ScopeGraph.newScope address edges)
CurrentScope -> ScopeGraph.currentScope <$> get
AssociatedScope decl -> ScopeGraph.associatedScope decl <$> get
Local scope action -> do
prevScope <- ScopeGraph.currentScope <$> get
modify @(ScopeGraph address) (\g -> g { ScopeGraph.currentScope = Just scope })
value <- reinterpret handleScopeEnv (raiseEff action)
modify @(ScopeGraph address) (\g -> g { ScopeGraph.currentScope = prevScope })
pure value
newtype ScopeEnvC address m a = ScopeEnvC { runScopeEnvC :: Eff (StateC (ScopeGraph address) m) a }
instance (Ord address, Member Fresh sig, Member (Allocator address) sig, Carrier sig m, Effect sig) => Carrier (ScopeEnv address :+: sig) (ScopeEnvC address m) where
ret = ScopeEnvC . ret
eff = ScopeEnvC . handleSum (eff . R . handleCoercible) (\case
Lookup ref k -> gets (ScopeGraph.scopeOfRef ref) >>= runScopeEnvC . k
Declare decl span scope k -> modify @(ScopeGraph address) (ScopeGraph.declare decl span scope) *> runScopeEnvC k
PutDeclarationScope decl scope k -> modify @(ScopeGraph address) (ScopeGraph.insertDeclarationScope decl scope) *> runScopeEnvC k
Reference ref decl k -> modify @(ScopeGraph address) (ScopeGraph.reference ref decl) *> runScopeEnvC k
NewScope edges k -> do
-- Take the edges and construct a new scope, update the current scope to the new scope
name <- gensym
address <- runEvaluator (alloc name)
modify @(ScopeGraph address) (ScopeGraph.newScope address edges)
runScopeEnvC (k address)
CurrentScope k -> gets ScopeGraph.currentScope >>= runScopeEnvC . k
AssociatedScope decl k -> gets (ScopeGraph.associatedScope decl) >>= runScopeEnvC . k
Local scope action k -> do
prevScope <- gets ScopeGraph.currentScope
modify @(ScopeGraph address) (\g -> g { ScopeGraph.currentScope = Just scope })
value <- runScopeEnvC action
modify @(ScopeGraph address) (\g -> g { ScopeGraph.currentScope = prevScope })
runScopeEnvC (k value))

View File

@ -1,4 +1,4 @@
{-# LANGUAGE DeriveAnyClass, GADTs, KindSignatures, Rank2Types #-}
{-# LANGUAGE DeriveAnyClass, GADTs, KindSignatures, LambdaCase, Rank2Types, TypeOperators #-}
module Control.Abstract.Value
( AbstractValue(..)
, AbstractIntro(..)
@ -10,15 +10,20 @@ module Control.Abstract.Value
, builtIn
, call
, Function(..)
, runFunction
, FunctionC(..)
, boolean
, asBool
, ifthenelse
, disjunction
, Boolean(..)
, runBoolean
, BooleanC(..)
, while
, doWhile
, forLoop
, While(..)
, runWhile
, WhileC(..)
, makeNamespace
, evaluateInScopedEnv
, address
@ -29,6 +34,8 @@ 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
import Data.Abstract.Module
@ -37,7 +44,7 @@ import Data.Abstract.Number as Number
import Data.Abstract.Ref
import Data.Scientific (Scientific)
import Data.Span
import Prologue hiding (TypeError, catchError)
import Prologue hiding (TypeError)
-- | This datum is passed into liftComparison to handle the fact that Ruby and PHP
-- have built-in generalized-comparison ("spaceship") operators. If you want to
@ -63,89 +70,119 @@ 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) effects => Maybe Name -> [Name] -> term -> Evaluator term address value effects value
function name params body = sendFunction (Function name params body)
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 ret)
data BuiltIn
= Print
| Show
deriving (Eq, Ord, Show, Generic, NFData)
builtIn :: Member (Function term address value) effects => BuiltIn -> Evaluator term address value effects value
builtIn = sendFunction . BuiltIn
builtIn :: (Member (Function term address value) sig, Carrier sig m) => BuiltIn -> Evaluator term address value m value
builtIn = sendFunction . flip BuiltIn ret
call :: Member (Function term address value) effects => value -> address -> [address] -> Evaluator term address value effects address
call fn self args = sendFunction (Call fn self args)
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 ret)
sendFunction :: Member (Function term address value) effects => Function term address value (Eff effects) a -> Evaluator term address value effects a
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
data Function term address value (m :: * -> *) result where
Function :: Maybe Name -> [Name] -> term -> Function term address value m value
BuiltIn :: BuiltIn -> Function term address value m value
Call :: value -> address -> [address] -> Function term address value m address
data Function term address value (m :: * -> *) k
= Function (Maybe Name) [Name] term (value -> k)
| BuiltIn BuiltIn (value -> k)
| Call value address [address] (address -> k)
deriving (Functor)
instance HFunctor (Function term address value) where
hmap _ = coerce
instance PureEffect (Function term address value)
instance Effect (Function term address value) where
handleState state handler (Request (Function name params body) k) = Request (Function name params body) (handler . (<$ state) . k)
handleState state handler (Request (BuiltIn builtIn) k) = Request (BuiltIn builtIn) (handler . (<$ state) . k)
handleState state handler (Request (Call fn self addrs) k) = Request (Call fn self addrs) (handler . (<$ state) . k)
handle state handler (Function name params body k) = Function name params body (handler . (<$ state) . k)
handle state handler (BuiltIn builtIn k) = BuiltIn builtIn (handler . (<$ state) . k)
handle state handler (Call fn self addrs k) = Call fn self addrs (handler . (<$ state) . k)
runFunction :: Carrier (Function term address value :+: sig) (FunctionC term address value (Eff m))
=> (term -> Evaluator term address value (FunctionC term address value (Eff m)) address)
-> Evaluator term address value (FunctionC term address value (Eff m)) a
-> Evaluator term address value m a
runFunction eval = raiseHandler (flip runFunctionC (runEvaluator . eval) . interpret)
newtype FunctionC term address value m a = FunctionC { runFunctionC :: (term -> Eff (FunctionC term address value m) address) -> m a }
-- | Construct a boolean value in the abstract domain.
boolean :: Member (Boolean value) effects => Bool -> Evaluator term address value effects value
boolean = send . Boolean
boolean :: (Member (Boolean value) sig, Carrier sig m) => Bool -> m value
boolean = send . flip Boolean ret
-- | Extract a 'Bool' from a given value.
asBool :: Member (Boolean value) effects => value -> Evaluator term address value effects Bool
asBool = send . AsBool
asBool :: (Member (Boolean value) sig, Carrier sig m) => value -> m Bool
asBool = send . flip AsBool ret
-- | Eliminate boolean values. TODO: s/boolean/truthy
ifthenelse :: Member (Boolean value) effects => value -> Evaluator term address value effects a -> Evaluator term address value effects a -> Evaluator term address value effects a
ifthenelse :: (Member (Boolean value) sig, Carrier sig m, Monad m) => value -> m a -> m a -> m a
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) effects => Evaluator term address value effects value -> Evaluator term address value effects value -> Evaluator term address value effects value
disjunction (Evaluator a) (Evaluator b) = send (Disjunction a b)
data Boolean value (m :: * -> *) k
= Boolean Bool (value -> k)
| AsBool value (Bool -> k)
deriving (Functor)
data Boolean value m result where
Boolean :: Bool -> Boolean value m value
AsBool :: value -> Boolean value m Bool
Disjunction :: m value -> m value -> Boolean value m value
instance HFunctor (Boolean value) where
hmap _ = coerce
{-# INLINE hmap #-}
instance Effect (Boolean value) where
handle state handler = \case
Boolean b k -> Boolean b (handler . (<$ state) . k)
AsBool v k -> AsBool v (handler . (<$ state) . k)
runBoolean :: Carrier (Boolean value :+: sig) (BooleanC value (Eff m))
=> Evaluator term address value (BooleanC value (Eff m)) a
-> Evaluator term address value m a
runBoolean = raiseHandler $ runBooleanC . interpret
newtype BooleanC value m a = BooleanC { runBooleanC :: m a }
instance PureEffect (Boolean value) where
handle handler (Request (Boolean b) k) = Request (Boolean b) (handler . k)
handle handler (Request (AsBool v) k) = Request (AsBool v) (handler . k)
handle handler (Request (Disjunction a b) k) = Request (Disjunction (handler a) (handler b)) (handler . k)
-- | The fundamental looping primitive, built on top of 'ifthenelse'.
while :: Member (While value) effects
=> Evaluator term address value effects value -- ^ Condition
-> Evaluator term address value effects value -- ^ Body
-> Evaluator term address value effects value
while (Evaluator cond) (Evaluator body) = send (While cond body)
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 ret)
-- | Do-while loop, built on top of while.
doWhile :: Member (While value) effects
=> Evaluator term address value effects value -- ^ Body
-> Evaluator term address value effects value -- ^ Condition
-> Evaluator term address value effects value
doWhile :: (Member (While value) sig, Carrier sig m)
=> Evaluator term address value m value -- ^ Body
-> Evaluator term address value m value -- ^ Condition
-> Evaluator term address value m value
doWhile body cond = body *> while cond body
-- | C-style for loops.
forLoop :: (Member (While value) effects, Member (Env address) effects)
=> Evaluator term address value effects value -- ^ Initial statement
-> Evaluator term address value effects value -- ^ Condition
-> Evaluator term address value effects value -- ^ Increment/stepper
-> Evaluator term address value effects value -- ^ Body
-> Evaluator term address value effects value
forLoop :: (Member (While value) sig, Member (Env address) sig, Carrier sig m)
=> Evaluator term address value m value -- ^ Initial statement
-> Evaluator term address value m value -- ^ Condition
-> Evaluator term address value m value -- ^ Increment/stepper
-> Evaluator term address value m value -- ^ Body
-> Evaluator term address value m value
forLoop initial cond step body =
locally (initial *> while cond (body *> step))
data While value m result where
While :: m value -> m value -> While value m value
data While value m k
= While (m value) (m value) (value -> k)
deriving (Functor)
instance PureEffect (While value) where
handle handler (Request (While cond body) k) = Request (While (handler cond) (handler body)) (handler . k)
instance HFunctor (While value) where
hmap f (While cond body k) = While (f cond) (f body) k
runWhile :: Carrier (While value :+: sig) (WhileC value (Eff m))
=> Evaluator term address value (WhileC value (Eff m)) a
-> Evaluator term address value m a
runWhile = raiseHandler $ runWhileC . interpret
newtype WhileC value m a = WhileC { runWhileC :: m a }
class Show value => AbstractIntro value where
@ -184,59 +221,59 @@ class Show value => AbstractIntro value where
-- | A 'Monad' abstracting the evaluation of (and under) binding constructs (functions, methods, etc).
--
-- This allows us to abstract the choice of whether to evaluate under binders for different value types.
class AbstractIntro value => AbstractValue term address value effects where
class AbstractIntro value => AbstractValue term address value carrier where
-- | Cast numbers to integers
castToInteger :: value -> Evaluator term address value effects value
castToInteger :: value -> Evaluator term address value carrier value
-- | Lift a unary operator over a 'Num' to a function on 'value's.
liftNumeric :: (forall a . Num a => a -> a)
-> (value -> Evaluator term address value effects value)
-> (value -> Evaluator term address value carrier value)
-- | Lift a pair of binary operators to a function on 'value's.
-- You usually pass the same operator as both arguments, except in the cases where
-- Haskell provides different functions for integral and fractional operations, such
-- as division, exponentiation, and modulus.
liftNumeric2 :: (forall a b. Number a -> Number b -> SomeNumber)
-> (value -> value -> Evaluator term address value effects value)
-> (value -> value -> Evaluator term address value carrier value)
-- | Lift a Comparator (usually wrapping a function like == or <=) to a function on values.
liftComparison :: Comparator -> (value -> value -> Evaluator term address value effects value)
liftComparison :: Comparator -> (value -> value -> Evaluator term address value carrier value)
-- | Lift a unary bitwise operator to values. This is usually 'complement'.
liftBitwise :: (forall a . Bits a => a -> a)
-> (value -> Evaluator term address value effects value)
-> (value -> Evaluator term address value carrier value)
-- | Lift a binary bitwise operator to values. The Integral constraint is
-- necessary to satisfy implementation details of Haskell left/right shift,
-- but it's fine, since these are only ever operating on integral values.
liftBitwise2 :: (forall a . (Integral a, Bits a) => a -> a -> a)
-> (value -> value -> Evaluator term address value effects value)
-> (value -> value -> Evaluator term address value carrier value)
unsignedRShift :: value -> value -> Evaluator term address value effects value
unsignedRShift :: value -> value -> Evaluator term address value carrier value
-- | Construct an N-ary tuple of multiple (possibly-disjoint) values
tuple :: [address] -> Evaluator term address value effects value
tuple :: [address] -> Evaluator term address value carrier value
-- | Construct an array of zero or more values.
array :: [address] -> Evaluator term address value effects value
array :: [address] -> Evaluator term address value carrier value
asArray :: value -> Evaluator term address value effects [address]
asArray :: value -> Evaluator term address value carrier [address]
-- | Extract the contents of a key-value pair as a tuple.
asPair :: value -> Evaluator term address value effects (value, value)
asPair :: value -> Evaluator term address value carrier (value, value)
-- | Extract a 'Text' from a given value.
asString :: value -> Evaluator term address value effects Text
asString :: value -> Evaluator term address value carrier Text
-- | @index x i@ computes @x[i]@, with zero-indexing.
index :: value -> value -> Evaluator term address value effects address
index :: value -> value -> Evaluator term address value carrier address
-- | Build a class value from a name and environment.
klass :: Name -- ^ The new class's identifier
-> [address] -- ^ A list of superclasses
-> Bindings address -- ^ The environment to capture
-> Evaluator term address value effects value
-> Evaluator term address value carrier value
-- | Build a namespace value from a name and environment stack
--
@ -244,23 +281,24 @@ class AbstractIntro value => AbstractValue term address value effects where
namespace :: Name -- ^ The namespace's identifier
-> Maybe address -- The ancestor of the namespace
-> Bindings address -- ^ The environment to mappend
-> Evaluator term address value effects value
-> Evaluator term address value carrier value
-- | Extract the environment from any scoped object (e.g. classes, namespaces, etc).
scopedEnvironment :: address -> Evaluator term address value effects (Maybe (Environment address))
scopedEnvironment :: address -> Evaluator term address value carrier (Maybe (Environment address))
makeNamespace :: ( AbstractValue term address value effects
, Member (Deref value) effects
, Member (Env address) effects
, Member (State (Heap address value)) effects
makeNamespace :: ( AbstractValue term address value m
, Member (Deref value) sig
, Member (Env address) sig
, Member (State (Heap address value)) sig
, Carrier sig m
, Ord address
)
=> Name
-> address
-> Maybe address
-> Evaluator term address value effects ()
-> Evaluator term address value effects value
-> Evaluator term address value m ()
-> Evaluator term address value m value
makeNamespace name addr super body = do
namespaceBinds <- Env.head <$> locally (body >> getEnv)
v <- namespace name super namespaceBinds
@ -268,12 +306,13 @@ makeNamespace name addr super body = do
-- | Evaluate a term within the context of the scoped environment of 'scopedEnvTerm'.
evaluateInScopedEnv :: ( AbstractValue term address value effects
, Member (Env address) effects
evaluateInScopedEnv :: ( AbstractValue term address value m
, Member (Env address) sig
, Carrier sig m
)
=> address
-> Evaluator term address value effects a
-> Evaluator term address value effects a
-> Evaluator term address value m a
-> Evaluator term address value m a
evaluateInScopedEnv receiver term = do
scopedEnv <- scopedEnvironment receiver
env <- maybeM getEnv scopedEnv
@ -281,40 +320,43 @@ evaluateInScopedEnv receiver term = do
-- | Evaluates a 'Value' returning the referenced value
value :: ( AbstractValue term address value effects
, Member (Deref value) effects
, Member (Env address) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (AddressError address value))) effects
, Member (Resumable (BaseError (EnvironmentError address))) effects
, Member (State (Heap address value)) effects
value :: ( AbstractValue term address value m
, Carrier sig m
, Member (Deref value) sig
, Member (Env address) sig
, Member (Reader ModuleInfo) sig
, Member (Reader Span) sig
, Member (Resumable (BaseError (AddressError address value))) sig
, Member (Resumable (BaseError (EnvironmentError address))) sig
, Member (State (Heap address value)) sig
, Ord address
)
=> ValueRef address
-> Evaluator term address value effects value
-> Evaluator term address value m value
value = deref <=< address
-- | Returns the address of a value referenced by a 'ValueRef'
address :: ( AbstractValue term address value effects
, Member (Env address) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (EnvironmentError address))) effects
address :: ( AbstractValue term address value m
, Carrier sig m
, Member (Env address) sig
, Member (Reader ModuleInfo) sig
, Member (Reader Span) sig
, Member (Resumable (BaseError (EnvironmentError address))) sig
)
=> ValueRef address
-> Evaluator term address value effects address
-> Evaluator term address value m address
address (LvalLocal var) = variable var
address (LvalMember ptr prop) = evaluateInScopedEnv ptr (variable prop)
address (Rval addr) = pure addr
-- | Convenience function for boxing a raw value and wrapping it in an Rval
rvalBox :: ( Member (Allocator address) effects
, Member (Deref value) effects
, Member Fresh effects
, Member (State (Heap address value)) effects
rvalBox :: ( Member (Allocator address) sig
, Member (Deref value) sig
, Member Fresh sig
, Member (State (Heap address value)) sig
, Carrier sig m
, Ord address
)
=> value
-> Evaluator term address value effects (ValueRef address)
-> Evaluator term address value m (ValueRef address)
rvalBox val = Rval <$> box val

View File

@ -0,0 +1,49 @@
{-# LANGUAGE ExistentialQuantification, RankNTypes, StandaloneDeriving, TypeOperators, UndecidableInstances #-}
module Control.Effect.Interpose
( Interpose(..)
, interpose
, runInterpose
, InterposeC(..)
, Listener(..)
) where
import Control.Effect.Carrier
import Control.Effect.Internal
import Control.Effect.Sum
data Interpose eff m k
= forall a . Interpose (m a) (forall n x . eff n (n x) -> m x) (a -> k)
deriving instance Functor (Interpose eff m)
instance HFunctor (Interpose eff) where
hmap f (Interpose m h k) = Interpose (f m) (f . h) k
-- | Respond to requests for some specific effect with a handler.
--
-- The intercepted effects are not re-sent in the surrounding context; thus, the innermost nested 'interpose' listening for an effect will win, and the effects own handler will not get the chance to service the request.
--
-- Note that since 'Interpose' lacks an 'Effect' instance, only “pure” effects, i.e. effects which can be handled inside other effects using 'hmap' alone, can be run within the 'runInterpose' scope. This includes @Reader@, but not e.g. @State@ or @Error@.
interpose :: (Member (Interpose eff) sig, Carrier sig m)
=> m a
-> (forall n x . eff n (n x) -> m x)
-> m a
interpose m f = send (Interpose m f ret)
-- | Run an 'Interpose' effect.
runInterpose :: (Member eff sig, Carrier sig m, Monad m) => Eff (InterposeC eff m) a -> m a
runInterpose = flip runInterposeC Nothing . interpret
newtype InterposeC eff m a = InterposeC { runInterposeC :: Maybe (Listener eff m) -> m a }
newtype Listener eff m = Listener { runListener :: forall n x . eff n (n x) -> m x }
instance (Carrier sig m, Member eff sig, Monad m) => Carrier (Interpose eff :+: sig) (InterposeC eff m) where
ret a = InterposeC (const (ret a))
eff op = InterposeC (\ listener -> handleSum (algOther listener) (alg listener) op)
where alg listener (Interpose m h k) = runInterposeC m (Just (Listener (flip runInterposeC listener . h))) >>= flip runInterposeC listener . k
algOther listener op
| Just listener <- listener
, Just eff <- prj op = runListener listener eff
| otherwise = eff (handleReader listener runInterposeC op)

View File

@ -1,6 +1,6 @@
{-# LANGUAGE GADTs, TypeOperators #-}
module Control.Abstract.Matching
module Control.Matching
( Matcher
, TermMatcher
, target
@ -9,6 +9,7 @@ module Control.Abstract.Matching
, matchM
, narrow
, narrow'
, purely
, succeeds
, fails
, runMatcher
@ -71,6 +72,10 @@ target = Target
ensure :: (t -> Bool) -> Matcher t ()
ensure f = target >>= \c -> guard (f c)
-- | Promote a pure function to a 'Matcher'.
purely :: (a -> b) -> Matcher a b
purely f = fmap f target
-- | 'matchm' takes a modification function and a new matcher action the target parameter of which
-- is the result of the modification function. If the modification function returns 'Just' when
-- applied to the current 'target', the given matcher is executed with the result of that 'Just'

View File

@ -67,14 +67,14 @@ import Prologue hiding (apply, try)
import Control.Arrow
import Control.Category
import Control.Monad.Effect
import Control.Monad.Effect.Trace
import Control.Effect
import Control.Effect.Trace
import Data.Functor.Identity
import Data.Profunctor
import qualified Data.Sum as Sum hiding (apply)
import Data.Text (pack)
import Control.Abstract.Matching (Matcher, stepMatcher)
import Control.Matching (Matcher, stepMatcher)
import Data.History as History
import Data.Term
@ -242,7 +242,7 @@ apply rule x = pure x >>> rule
-- @
-- tracing "rule fired" >>> someRule >>> tracing "rule completed"
-- @
tracing :: Member Trace effs => String -> RewriteM env (Eff effs) item
tracing :: (Member Trace sig, Carrier sig m, Functor m) => String -> RewriteM env m item
tracing s = id >>= (\t -> promote (t <$ trace s))
--

View File

@ -1,14 +1,12 @@
{-# LANGUAGE GADTs, RankNTypes, TypeOperators #-}
{-# LANGUAGE LambdaCase, TypeOperators, UndecidableInstances #-}
module Data.Abstract.Address.Hole
( Hole(..)
, toMaybe
, runAllocator
, handleAllocator
, runDeref
, handleDeref
) where
import Control.Abstract
import Control.Effect.Carrier
import Control.Effect.Sum
import Prologue
data Hole context a = Partial context | Total a
@ -22,29 +20,26 @@ toMaybe (Partial _) = Nothing
toMaybe (Total a) = Just a
relocate :: Evaluator term address1 value effects a -> Evaluator term address2 value effects a
relocate = raiseEff . lowerEff
promoteA :: AllocatorC address m a -> AllocatorC (Hole context address) m a
promoteA = AllocatorC . runAllocatorC
instance ( Carrier (Allocator address :+: sig) (AllocatorC address m)
, Carrier sig m
, Monad m
)
=> Carrier (Allocator (Hole context address) :+: sig) (AllocatorC (Hole context address) m) where
ret = promoteA . ret
eff = handleSum
(AllocatorC . eff . handleCoercible)
(\ (Alloc name k) -> Total <$> promoteA (eff (L (Alloc name ret))) >>= k)
runAllocator :: PureEffects effects
=> (forall x. Allocator address (Eff (Allocator address ': effects)) x -> Evaluator term address value effects x)
-> Evaluator term (Hole context address) value (Allocator (Hole context address) ': effects) a
-> Evaluator term (Hole context address) value effects a
runAllocator handler = interpret (handleAllocator handler)
promoteD :: DerefC address value m a -> DerefC (Hole context address) value m a
promoteD = DerefC . runDerefC
handleAllocator :: (forall x. Allocator address (Eff (Allocator address ': effects)) x -> Evaluator term address value effects x)
-> Allocator (Hole context address) (Eff (Allocator (Hole context address) ': effects)) a
-> Evaluator term (Hole context address) value effects a
handleAllocator handler (Alloc name) = relocate (Total <$> handler (Alloc name))
runDeref :: PureEffects effects
=> (forall x. Deref value (Eff (Deref value ': effects)) x -> Evaluator term address value effects x)
-> Evaluator term (Hole context address) value (Deref value ': effects) a
-> Evaluator term (Hole context address) value effects a
runDeref handler = interpret (handleDeref handler)
handleDeref :: (forall x. Deref value (Eff (Deref value ': effects)) x -> Evaluator term address value effects x)
-> Deref value (Eff (Deref value ': effects)) a
-> Evaluator term (Hole context address) value effects a
handleDeref handler (DerefCell cell) = relocate (handler (DerefCell cell))
handleDeref handler (AssignCell value cell) = relocate (handler (AssignCell value cell))
instance (Carrier (Deref value :+: sig) (DerefC address value m), Carrier sig m, Monad m)
=> Carrier (Deref value :+: sig) (DerefC (Hole context address) value m) where
ret = promoteD . ret
eff = handleSum (DerefC . eff . handleCoercible) (\case
DerefCell cell k -> promoteD (eff (L (DerefCell cell ret))) >>= k
AssignCell value cell k -> promoteD (eff (L (AssignCell value cell ret))) >>= k)

View File

@ -1,13 +1,11 @@
{-# LANGUAGE GADTs, RankNTypes, TypeOperators, UndecidableInstances #-}
{-# LANGUAGE LambdaCase, TypeOperators, UndecidableInstances #-}
module Data.Abstract.Address.Located
( Located(..)
, runAllocator
, handleAllocator
, runDeref
, handleDeref
) 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)
@ -22,37 +20,29 @@ data Located address = Located
deriving (Eq, Ord, Show)
relocate :: Evaluator term address1 value effects a -> Evaluator term address2 value effects a
relocate = raiseEff . lowerEff
promoteA :: AllocatorC address m a -> AllocatorC (Located address) m a
promoteA = AllocatorC . runAllocatorC
instance ( Carrier (Allocator address :+: sig) (AllocatorC address m)
, Carrier sig m
, Member (Reader ModuleInfo) sig
, Member (Reader PackageInfo) sig
, Member (Reader Span) sig
, Monad m
)
=> Carrier (Allocator (Located address) :+: sig) (AllocatorC (Located address) m) where
ret = promoteA . ret
eff = handleSum
(AllocatorC . eff . handleCoercible)
(\ (Alloc name k) -> Located <$> promoteA (eff (L (Alloc name ret))) <*> currentPackage <*> currentModule <*> pure name <*> ask >>= k)
runAllocator :: ( Member (Reader ModuleInfo) effects
, Member (Reader PackageInfo) effects
, Member (Reader Span) effects
, PureEffects effects
)
=> (forall x. Allocator address (Eff (Allocator address ': effects)) x -> Evaluator term address value effects x)
-> Evaluator term (Located address) value (Allocator (Located address) ': effects) a
-> Evaluator term (Located address) value effects a
runAllocator handler = interpret (handleAllocator handler)
promoteD :: DerefC address value m a -> DerefC (Located address) value m a
promoteD = DerefC . runDerefC
handleAllocator :: ( Member (Reader ModuleInfo) effects
, Member (Reader PackageInfo) effects
, Member (Reader Span) effects
)
=> (forall x. Allocator address (Eff (Allocator address ': effects)) x -> Evaluator term address value effects x)
-> Allocator (Located address) (Eff (Allocator (Located address) ': effects)) a
-> Evaluator term (Located address) value effects a
handleAllocator handler (Alloc name) = relocate (Located <$> handler (Alloc name) <*> currentPackage <*> currentModule <*> pure name <*> ask)
runDeref :: PureEffects effects
=> (forall x. Deref value (Eff (Deref value ': effects)) x -> Evaluator term address value effects x)
-> Evaluator term (Located address) value (Deref value ': effects) a
-> Evaluator term (Located address) value effects a
runDeref handler = interpret (handleDeref handler)
handleDeref :: (forall x. Deref value (Eff (Deref value ': effects)) x -> Evaluator term address value effects x)
-> Deref value (Eff (Deref value ': effects)) a
-> Evaluator term (Located address) value effects a
handleDeref handler (DerefCell cell) = relocate (handler (DerefCell cell))
handleDeref handler (AssignCell value cell) = relocate (handler (AssignCell value cell))
instance (Carrier (Deref value :+: sig) (DerefC address value m), Carrier sig m, Monad m)
=> Carrier (Deref value :+: sig) (DerefC (Located address) value m) where
ret = promoteD . ret
eff = handleSum (DerefC . eff . handleCoercible) (\case
DerefCell cell k -> promoteD (eff (L (DerefCell cell ret))) >>= k
AssignCell value cell k -> promoteD (eff (L (AssignCell value cell ret))) >>= k)

View File

@ -1,13 +1,11 @@
{-# LANGUAGE GADTs, TypeOperators, UndecidableInstances #-}
{-# LANGUAGE LambdaCase, TypeOperators, UndecidableInstances #-}
module Data.Abstract.Address.Monovariant
( Monovariant(..)
, runAllocator
, handleAllocator
, runDeref
, handleDeref
) where
import Control.Abstract
import Control.Effect.Carrier
import Control.Effect.Sum
import Data.Abstract.Name
import qualified Data.Set as Set
import Prologue
@ -20,26 +18,15 @@ instance Show Monovariant where
showsPrec d = showsUnaryWith showsPrec "Monovariant" d . unMonovariant
runAllocator :: PureEffects effects
=> Evaluator term Monovariant value (Allocator Monovariant ': effects) a
-> Evaluator term Monovariant value effects a
runAllocator = interpret handleAllocator
instance Carrier sig m => Carrier (Allocator Monovariant :+: sig) (AllocatorC Monovariant m) where
ret = AllocatorC . ret
eff = AllocatorC . handleSum
(eff . handleCoercible)
(\ (Alloc name k) -> runAllocatorC (k (Monovariant name)))
handleAllocator :: Allocator Monovariant (Eff (Allocator Monovariant ': effects)) a -> Evaluator term Monovariant value effects a
handleAllocator (Alloc name) = pure (Monovariant name)
runDeref :: ( Member NonDet effects
, Ord value
, PureEffects effects
)
=> Evaluator term Monovariant value (Deref value ': effects) a
-> Evaluator term Monovariant value effects a
runDeref = interpret handleDeref
handleDeref :: ( Member NonDet effects
, Ord value
)
=> Deref value (Eff (Deref value ': effects)) a
-> Evaluator term Monovariant value effects a
handleDeref (DerefCell cell) = traverse (foldMapA pure) (nonEmpty (toList cell))
handleDeref (AssignCell value cell) = pure (Set.insert value cell)
instance (Ord value, Carrier sig m, Alternative m, Monad m) => Carrier (Deref value :+: sig) (DerefC Monovariant value m) where
ret = DerefC . ret
eff = DerefC . handleSum (eff . handleCoercible) (\case
DerefCell cell k -> traverse (foldMapA pure) (nonEmpty (toList cell)) >>= runDerefC . k
AssignCell value cell k -> runDerefC (k (Set.insert value cell)))

View File

@ -1,13 +1,11 @@
{-# LANGUAGE GeneralizedNewtypeDeriving, GADTs, TypeOperators, UndecidableInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving, LambdaCase, TypeOperators, UndecidableInstances #-}
module Data.Abstract.Address.Precise
( Precise(..)
, runAllocator
, handleAllocator
, runDeref
, handleDeref
) where
import Control.Abstract
import Control.Effect.Carrier
import Control.Effect.Sum
import qualified Data.Set as Set
import Prologue
@ -19,21 +17,15 @@ instance Show Precise where
showsPrec d = showsUnaryWith showsPrec "Precise" d . unPrecise
runAllocator :: ( Member Fresh effects
, PureEffects effects
)
=> Evaluator term Precise value (Allocator Precise ': effects) a
-> Evaluator term Precise value effects a
runAllocator = interpret handleAllocator
instance (Member Fresh sig, Carrier sig m, Monad m) => Carrier (Allocator Precise :+: sig) (AllocatorC Precise m) where
ret = AllocatorC . ret
eff = AllocatorC . handleSum
(eff . handleCoercible)
(\ (Alloc _ k) -> Precise <$> fresh >>= runAllocatorC . k)
handleAllocator :: Member Fresh effects => Allocator Precise (Eff (Allocator Precise ': effects)) a -> Evaluator term Precise value effects a
handleAllocator (Alloc _) = Precise <$> fresh
runDeref :: PureEffects effects
=> Evaluator term Precise value (Deref value ': effects) a
-> Evaluator term Precise value effects a
runDeref = interpret handleDeref
handleDeref :: Deref value (Eff (Deref value ': effects)) a -> Evaluator term Precise value effects a
handleDeref (DerefCell cell) = pure (fst <$> Set.minView cell)
handleDeref (AssignCell value _) = pure (Set.singleton value)
instance Carrier sig m => Carrier (Deref value :+: sig) (DerefC Precise value m) where
ret = DerefC . ret
eff = DerefC . handleSum (eff . handleCoercible) (\case
DerefCell cell k -> runDerefC (k (fst <$> Set.minView cell))
AssignCell value _ k -> runDerefC (k (Set.singleton value)))

View File

@ -35,12 +35,14 @@ instance (NFData1 exc, NFData resume) => NFData (BaseError exc resume) where
instance (NFData1 exc) => NFData1 (BaseError exc) where
liftRnf rnf' (BaseError i s e) = rnf i `seq` rnf s `seq` liftRnf rnf' e
throwBaseError :: ( Member (Resumable (BaseError exc)) effects
, Member (Reader M.ModuleInfo) effects
, Member (Reader S.Span) effects
throwBaseError :: ( Member (Resumable (BaseError exc)) sig
, Member (Reader M.ModuleInfo) sig
, Member (Reader S.Span) sig
, Carrier sig m
, Monad m
)
=> exc resume
-> Evaluator term address value effects resume
-> m resume
throwBaseError err = do
moduleInfo <- currentModule
span <- currentSpan

View File

@ -2,14 +2,9 @@
module Data.Abstract.Evaluatable
( module X
, Evaluatable(..)
, ModuleEffects
, ValueEffects
, evaluate
, traceResolve
-- * Preludes
, HasPrelude(..)
-- * Postludes
, HasPostlude(..)
-- * Effects
, EvalError(..)
, throwEvalError
@ -28,18 +23,14 @@ import Control.Abstract.Evaluator as X hiding (LoopControl(..), Return(..), catc
import Control.Abstract.Heap as X hiding (runAddressError, runAddressErrorWith)
import Control.Abstract.Modules as X (Modules, ModuleResult, ResolutionError(..), load, lookupModule, listModulesInDir, require, resolve, throwResolutionError)
import Control.Abstract.Value as X hiding (Boolean(..), Function(..), While(..))
import Control.Abstract.ScopeGraph
import Data.Abstract.Declarations as X
import Data.Abstract.Environment as X
import Data.Abstract.BaseError as X
import Data.Abstract.FreeVariables as X
import Data.Abstract.Module
import Data.Abstract.ModuleTable as ModuleTable
import Data.Abstract.Name as X
import Data.Abstract.Ref as X
import Data.Coerce
import Data.Language
import Data.Function
import Data.Scientific (Scientific)
import Data.Semigroup.App
import Data.Semigroup.Foldable
@ -49,141 +40,67 @@ import Prologue
-- | The 'Evaluatable' class defines the necessary interface for a term to be evaluated. While a default definition of 'eval' is given, instances with computational content must implement 'eval' to perform their small-step operational semantics.
class (Show1 constr, Foldable constr) => Evaluatable constr where
eval :: ( AbstractValue term address value effects
eval :: ( AbstractValue term address value m
, Carrier sig m
, Declarations term
, FreeVariables term
, Member (Allocator address) effects
, Member (Boolean value) effects
, Member (While value) effects
, Member (Deref value) effects
, Member (ScopeEnv address) effects
, Member (Env address) effects
, Member (Exc (LoopControl address)) effects
, Member (Exc (Return address)) effects
, Member Fresh effects
, Member (Function term address value) effects
, Member (Modules address) effects
, Member (Reader ModuleInfo) effects
, Member (Reader PackageInfo) effects
, Member (Reader Span) effects
, Member (State Span) effects
, Member (Resumable (BaseError (AddressError address value))) effects
, Member (Resumable (BaseError (EnvironmentError address))) effects
, Member (Resumable (BaseError (UnspecializedError value))) effects
, Member (Resumable (BaseError EvalError)) effects
, Member (Resumable (BaseError ResolutionError)) effects
, Member (State (Heap address value)) effects
, Member Trace effects
, Member (Allocator address) sig
, Member (Boolean value) sig
, Member (While value) sig
, Member (Deref value) sig
, Member (ScopeEnv address) sig
, Member (Env address) sig
, Member (Error (LoopControl address)) sig
, Member (Error (Return address)) sig
, Member Fresh sig
, Member (Function term address value) sig
, Member (Modules address) sig
, Member (Reader ModuleInfo) sig
, Member (Reader PackageInfo) sig
, Member (Reader Span) sig
, Member (State Span) sig
, Member (Resumable (BaseError (AddressError address value))) sig
, Member (Resumable (BaseError (EnvironmentError address))) sig
, Member (Resumable (BaseError (UnspecializedError value))) sig
, Member (Resumable (BaseError EvalError)) sig
, Member (Resumable (BaseError ResolutionError)) sig
, Member (State (Heap address value)) sig
, Member Trace sig
, Ord address
)
=> (term -> Evaluator term address value effects (ValueRef address))
-> (constr term -> Evaluator term address value effects (ValueRef address))
=> (term -> Evaluator term address value m (ValueRef address))
-> (constr term -> Evaluator term address value m (ValueRef address))
eval recur expr = do
traverse_ recur expr
v <- throwUnspecializedError $ UnspecializedError ("Eval unspecialized for " <> liftShowsPrec (const (const id)) (const id) 0 expr "")
rvalBox v
type ModuleEffects address value rest
= Exc (LoopControl address)
': Exc (Return address)
': Env address
': ScopeEnv address
': Deref value
': Allocator address
': Reader ModuleInfo
': rest
type ValueEffects term address value rest
= Function term address value
': While value
': Boolean value
': rest
evaluate :: ( AbstractValue term address value valueEffects
, Declarations term
, Effects effects
, Evaluatable (Base term)
, FreeVariables term
, HasPostlude lang
, HasPrelude lang
, Member Fresh effects
, Member (Modules address) effects
, Member (Reader (ModuleTable (NonEmpty (Module (ModuleResult address))))) effects
, Member (Reader PackageInfo) effects
, Member (Reader Span) effects
, Member (State Span) effects
, Member (Resumable (BaseError (AddressError address value))) effects
, Member (Resumable (BaseError (EnvironmentError address))) effects
, Member (Resumable (BaseError EvalError)) effects
, Member (Resumable (BaseError ResolutionError)) effects
, Member (Resumable (BaseError (UnspecializedError value))) effects
, Member (State (Heap address value)) effects
, Member Trace effects
, Ord address
, Recursive term
, moduleEffects ~ ModuleEffects address value effects
, valueEffects ~ ValueEffects term address value moduleEffects
)
=> proxy lang
-> Open (Module term -> Evaluator term address value moduleEffects address)
-> Open (Open (term -> Evaluator term address value valueEffects (ValueRef address)))
-> (forall x . Evaluator term address value (Deref value ': Allocator address ': Reader ModuleInfo ': effects) x -> Evaluator term address value (Reader ModuleInfo ': effects) x)
-> (forall x . (term -> Evaluator term address value valueEffects address) -> Evaluator term address value valueEffects x -> Evaluator term address value moduleEffects x)
-> [Module term]
-> Evaluator term address value effects (ModuleTable (NonEmpty (Module (ModuleResult address))))
evaluate lang analyzeModule analyzeTerm runAllocDeref runValue modules = do
(_, (preludeBinds, _)) <- runInModule lowerBound moduleInfoFromCallStack . runValue evalTerm $ do
definePrelude lang
box unit
foldr (run preludeBinds) ask modules
where run preludeBinds m rest = do
evaluated <- coerce
(runInModule preludeBinds (moduleInfo m))
(analyzeModule (evalModuleBody . moduleBody)
m)
-- FIXME: this should be some sort of Monoidal insert à la the Heap to accommodate multiple Go files being part of the same module.
local (ModuleTable.insert (modulePath (moduleInfo m)) ((evaluated <$ m) :| [])) rest
evalModuleBody term = runValue evalTerm (do
result <- evalTerm term
result <$ postlude lang)
evalTerm = fix (analyzeTerm ((. project) . eval)) >=> address
runInModule preludeBinds info
= runReader info
. runAllocDeref
. runScopeEnv
. runEnv (EvalContext Nothing (X.push (newEnv preludeBinds)))
. runReturn
. runLoopControl
traceResolve :: (Show a, Show b, Member Trace effects) => a -> b -> Evaluator term address value effects ()
traceResolve :: (Show a, Show b, Member Trace sig, Carrier sig m) => a -> b -> Evaluator term address value m ()
traceResolve name path = trace ("resolved " <> show name <> " -> " <> show path)
-- Preludes
class HasPrelude (language :: Language) where
definePrelude :: ( AbstractValue term address value effects
definePrelude :: ( AbstractValue term address value m
, Carrier sig m
, HasCallStack
, Member (Allocator address) effects
, Member (Deref value) effects
, Member (Env address) effects
, Member Fresh effects
, Member (Function term address value) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (AddressError address value))) effects
, Member (Resumable (BaseError (EnvironmentError address))) effects
, Member (State (Heap address value)) effects
, Member Trace effects
, Member (Allocator address) sig
, Member (Deref value) sig
, Member (Env address) sig
, Member Fresh sig
, Member (Function term address value) sig
, Member (Reader ModuleInfo) sig
, Member (Reader Span) sig
, Member (Resumable (BaseError (AddressError address value))) sig
, Member (Resumable (BaseError (EnvironmentError address))) sig
, Member (State (Heap address value)) sig
, Member Trace sig
, Ord address
)
=> proxy language
-> Evaluator term address value effects ()
-> Evaluator term address value m ()
definePrelude _ = pure ()
instance HasPrelude 'Go
@ -212,35 +129,6 @@ instance HasPrelude 'JavaScript where
defineNamespace (name "console") $ do
define (name "log") (builtIn Print)
-- Postludes
class HasPostlude (language :: Language) where
postlude :: ( AbstractValue term address value effects
, HasCallStack
, Member (Allocator address) effects
, Member (Deref value) effects
, Member (Env address) effects
, Member Fresh effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (EnvironmentError address))) effects
, Member Trace effects
)
=> proxy language
-> Evaluator term address value effects ()
postlude _ = pure ()
instance HasPostlude 'Go
instance HasPostlude 'Haskell
instance HasPostlude 'Java
instance HasPostlude 'PHP
instance HasPostlude 'Python
instance HasPostlude 'Ruby
instance HasPostlude 'TypeScript
instance HasPostlude 'JavaScript where
postlude _ = trace "JS postlude"
-- Effects
@ -281,18 +169,19 @@ instance Eq1 EvalError where
instance Show1 EvalError where
liftShowsPrec _ _ = showsPrec
runEvalError :: Effects effects => Evaluator term address value (Resumable (BaseError EvalError) ': effects) a -> Evaluator term address value effects (Either (SomeExc (BaseError EvalError)) a)
runEvalError = runResumable
runEvalError :: (Carrier sig m, Effect sig) => Evaluator term address value (ResumableC (BaseError EvalError) (Eff m)) a -> Evaluator term address value m (Either (SomeError (BaseError EvalError)) a)
runEvalError = raiseHandler runResumable
runEvalErrorWith :: Effects effects => (forall resume . (BaseError EvalError) resume -> Evaluator term address value effects resume) -> Evaluator term address value (Resumable (BaseError EvalError) ': effects) a -> Evaluator term address value effects a
runEvalErrorWith = runResumableWith
runEvalErrorWith :: Carrier sig m => (forall resume . (BaseError EvalError) resume -> Evaluator term address value m resume) -> Evaluator term address value (ResumableWithC (BaseError EvalError) (Eff m)) a -> Evaluator term address value m a
runEvalErrorWith f = raiseHandler $ runResumableWith (runEvaluator . f)
throwEvalError :: ( Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError EvalError)) effects
throwEvalError :: ( Member (Reader ModuleInfo) sig
, Member (Reader Span) sig
, Member (Resumable (BaseError EvalError)) sig
, Carrier sig m
)
=> EvalError resume
-> Evaluator term address value effects resume
-> Evaluator term address value m resume
throwEvalError = throwBaseError
@ -315,23 +204,25 @@ instance Eq1 (UnspecializedError a) where
instance Show1 (UnspecializedError a) where
liftShowsPrec _ _ = showsPrec
runUnspecialized :: Effects effects
=> Evaluator term address value (Resumable (BaseError (UnspecializedError value)) ': effects) a
-> Evaluator term address value effects (Either (SomeExc (BaseError (UnspecializedError value))) a)
runUnspecialized = runResumable
runUnspecialized :: (Carrier sig m, Effect sig)
=> Evaluator term address value (ResumableC (BaseError (UnspecializedError value)) (Eff m)) a
-> Evaluator term address value m (Either (SomeError (BaseError (UnspecializedError value))) a)
runUnspecialized = raiseHandler runResumable
runUnspecializedWith :: Effects effects
=> (forall resume . BaseError (UnspecializedError value) resume -> Evaluator term address value effects resume)
-> Evaluator term address value (Resumable (BaseError (UnspecializedError value)) ': effects) a
-> Evaluator term address value effects a
runUnspecializedWith = runResumableWith
runUnspecializedWith :: Carrier sig m
=> (forall resume . BaseError (UnspecializedError value) resume -> Evaluator term address value m resume)
-> Evaluator term address value (ResumableWithC (BaseError (UnspecializedError value)) (Eff m)) a
-> Evaluator term address value m a
runUnspecializedWith f = raiseHandler $ runResumableWith (runEvaluator . f)
throwUnspecializedError :: ( Member (Resumable (BaseError (UnspecializedError value))) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
throwUnspecializedError :: ( Member (Resumable (BaseError (UnspecializedError value))) sig
, Member (Reader ModuleInfo) sig
, Member (Reader Span) sig
, Carrier sig m
)
=> UnspecializedError value resume
-> Evaluator term address value effects resume
-> Evaluator term address value m resume
throwUnspecializedError = throwBaseError

View File

@ -8,8 +8,8 @@ module Data.Abstract.Name
, formatName
) where
import Control.Monad.Effect
import Control.Monad.Effect.Fresh
import Control.Effect
import Control.Effect.Fresh
import Data.Aeson
import qualified Data.Char as Char
import Data.Text (Text)
@ -36,7 +36,7 @@ instance Primitive Name where
primType _ = Bytes
-- | Generate a fresh (unused) name for use in synthesized variables/closures/etc.
gensym :: (Functor (m effs), Member Fresh effs, Effectful m) => m effs Name
gensym :: (Member Fresh sig, Carrier sig m, Functor m) => m Name
gensym = I <$> fresh
-- | Construct a 'Name' from a 'Text'.

View File

@ -1,4 +1,4 @@
{-# LANGUAGE GADTs, LambdaCase, TypeOperators, UndecidableInstances #-}
{-# LANGUAGE LambdaCase, TypeOperators, UndecidableInstances #-}
module Data.Abstract.Value.Abstract
( Abstract (..)
, runFunction
@ -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
@ -15,65 +17,54 @@ data Abstract = Abstract
deriving (Eq, Ord, Show)
runFunction :: ( Member (Allocator address) effects
, Member (Deref Abstract) effects
, Member (Env address) effects
, Member (Exc (Return address)) effects
, Member Fresh effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (AddressError address Abstract))) effects
, Member (State (Heap address Abstract)) effects
, Ord address
, PureEffects effects
)
=> (term -> Evaluator term address Abstract (Abstract.Function term address Abstract ': effects) address)
-> Evaluator term address Abstract (Function term address Abstract ': effects) a
-> Evaluator term address Abstract effects a
runFunction eval = interpret $ \case
Function _ params body -> do
env <- foldr (\ name rest -> do
addr <- alloc name
assign addr Abstract
Env.insert name addr <$> rest) (pure lowerBound) params
addr <- locally (bindAll env *> catchReturn (runFunction eval (eval body)))
deref addr
BuiltIn _ -> pure Abstract
Call _ _ params -> do
traverse_ deref params
box Abstract
instance ( Member (Allocator address) sig
, Member (Deref Abstract) sig
, Member (Env address) sig
, Member (Error (Return address)) sig
, Member Fresh sig
, Member (Reader ModuleInfo) sig
, Member (Reader Span) sig
, Member (Resumable (BaseError (AddressError address Abstract))) sig
, Member (State (Heap address Abstract)) sig
, Ord address
, Carrier sig m
)
=> Carrier (Abstract.Function term address Abstract :+: sig) (FunctionC term address Abstract (Eff m)) where
ret = FunctionC . const . ret
eff op = FunctionC (\ eval -> handleSum (eff . handleReader eval runFunctionC) (\case
Function _ params body k -> runEvaluator $ do
env <- foldr (\ name rest -> do
addr <- alloc name
assign addr Abstract
Env.insert name addr <$> rest) (pure lowerBound) params
addr <- locally (bindAll env *> catchReturn (runFunction (Evaluator . eval) (Evaluator (eval body))))
deref addr >>= Evaluator . flip runFunctionC eval . k
BuiltIn _ k -> runFunctionC (k Abstract) eval
Call _ _ params k -> runEvaluator $ do
traverse_ deref params
box Abstract >>= Evaluator . flip runFunctionC eval . k) op)
runBoolean :: ( Member NonDet effects
, PureEffects effects
)
=> Evaluator term address Abstract (Boolean Abstract ': effects) a
-> Evaluator term address Abstract effects a
runBoolean = interpret $ \case
Boolean _ -> pure Abstract
AsBool _ -> pure True <|> pure False
Disjunction a b -> runBoolean (Evaluator (a <|> b))
runWhile ::
( Member (Allocator address) effects
, Member (Deref Abstract) effects
, Member (Abstract.Boolean Abstract) effects
, Member NonDet effects
, Member (Env address) effects
, Member (Exc (Return address)) effects
, Member Fresh effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (AddressError address Abstract))) effects
, Member (State (Heap address Abstract)) effects
, Ord address
, PureEffects effects
)
=> Evaluator term address Abstract (While Abstract ': effects) a
-> Evaluator term address Abstract effects a
runWhile = interpret $ \case
Abstract.While cond body -> do
cond' <- runWhile (raiseEff cond)
ifthenelse cond' (runWhile (raiseEff body) *> empty) (pure unit)
instance (Carrier sig m, Alternative m) => Carrier (Boolean Abstract :+: sig) (BooleanC Abstract m) where
ret = BooleanC . ret
eff = BooleanC . handleSum (eff . handleCoercible) (\case
Boolean _ k -> runBooleanC (k Abstract)
AsBool _ k -> runBooleanC (k True) <|> runBooleanC (k False))
instance ( Member (Abstract.Boolean Abstract) sig
, Carrier sig m
, Alternative m
, Monad m
)
=> Carrier (While Abstract :+: sig) (WhileC Abstract m) where
ret = WhileC . ret
eff = WhileC . handleSum
(eff . handleCoercible)
(\ (Abstract.While cond body k) -> do
cond' <- runWhileC cond
ifthenelse cond' (runWhileC body *> empty) (runWhileC (k unit)))
instance Ord address => ValueRoots address Abstract where
valueRoots = mempty
@ -93,13 +84,14 @@ instance AbstractIntro Abstract where
kvPair _ _ = Abstract
null = Abstract
instance ( Member (Allocator address) effects
, Member (Deref Abstract) effects
, Member Fresh effects
, Member (State (Heap address Abstract)) effects
instance ( Member (Allocator address) sig
, Member (Deref Abstract) sig
, Member Fresh sig
, Member (State (Heap address Abstract)) sig
, Ord address
, Carrier sig m
)
=> AbstractValue term address Abstract effects where
=> AbstractValue term address Abstract m where
array _ = pure Abstract
tuple _ = pure Abstract

View File

@ -2,9 +2,6 @@
module Data.Abstract.Value.Concrete
( Value (..)
, ValueError (..)
, runFunction
, runBoolean
, runWhile
, materializeEnvironment
, runValueError
, runValueErrorWith
@ -12,6 +9,9 @@ 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.Interpose
import Control.Effect.Sum
import Data.Abstract.BaseError
import Data.Abstract.Evaluatable (UnspecializedError(..))
import Data.Abstract.Environment (Environment, Bindings, EvalContext(..))
@ -26,7 +26,7 @@ import Data.Scientific.Exts
import qualified Data.Set as Set
import Data.Text (pack)
import Data.Word
import Prologue hiding (catchError)
import Prologue
data Value term address
= Closure PackageInfo ModuleInfo (Maybe Name) [Name] (Either BuiltIn term) (Environment address)
@ -55,103 +55,98 @@ instance Ord address => ValueRoots address (Value term address) where
| otherwise = mempty
runFunction :: ( FreeVariables term
, Member (Allocator address) effects
, Member (Deref (Value term address)) effects
, Member (Env address) effects
, Member (Exc (Return address)) effects
, Member Fresh effects
, Member (Reader ModuleInfo) effects
, Member (Reader PackageInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (AddressError address (Value term address)))) effects
, Member (Resumable (BaseError (ValueError term address))) effects
, Member (State (Heap address (Value term address))) effects
, Member Trace effects
, Ord address
, PureEffects effects
, Show address
, Show term
)
=> (term -> Evaluator term address (Value term address) (Abstract.Function term address (Value term address) ': effects) address)
-> Evaluator term address (Value term address) (Abstract.Function term address (Value term address) ': effects) a
-> Evaluator term address (Value term address) effects a
runFunction eval = interpret $ \case
Abstract.Function name params body -> do
packageInfo <- currentPackage
moduleInfo <- currentModule
Closure packageInfo moduleInfo name params (Right body) <$> close (foldr Set.delete (freeVariables body) params)
Abstract.BuiltIn builtIn -> do
packageInfo <- currentPackage
moduleInfo <- currentModule
pure (Closure packageInfo moduleInfo Nothing [] (Left builtIn) lowerBound)
Abstract.Call op self params -> do
case op of
Closure _ _ _ _ (Left Print) _ -> traverse (deref >=> trace . show) params *> box Unit
Closure _ _ _ _ (Left Show) _ -> deref self >>= box . String . pack . show
Closure packageInfo moduleInfo _ names (Right body) env -> do
-- Evaluate the bindings and body with the closures package/module info in scope in order to
-- charge them to the closure's origin.
withCurrentPackage packageInfo . withCurrentModule moduleInfo $ do
bindings <- foldr (\ (name, addr) rest -> Env.insert name addr <$> rest) (pure lowerBound) (zip names params)
let fnCtx = EvalContext (Just self) (Env.push env)
withEvalContext fnCtx (catchReturn (bindAll bindings *> runFunction eval (eval body)))
_ -> throwValueError (CallError op) >>= box
runBoolean :: ( Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (ValueError term address))) effects
, PureEffects effects
)
=> Evaluator term address (Value term address) (Abstract.Boolean (Value term address) ': effects) a
-> Evaluator term address (Value term address) effects a
runBoolean = interpret $ \case
Abstract.Boolean b -> pure $! Boolean b
Abstract.AsBool (Boolean b) -> pure b
Abstract.AsBool other -> throwValueError $! BoolError other
Abstract.Disjunction a b -> do
a' <- runBoolean (Evaluator a)
a'' <- runBoolean (asBool a')
if a'' then pure a' else runBoolean (Evaluator b)
instance ( FreeVariables term
, Member (Allocator address) sig
, Member (Deref (Value term address)) sig
, Member (Env address) sig
, Member (Error (Return address)) sig
, Member Fresh sig
, Member (Reader ModuleInfo) sig
, Member (Reader PackageInfo) sig
, Member (Reader Span) sig
, Member (Resumable (BaseError (AddressError address (Value term address)))) sig
, Member (Resumable (BaseError (ValueError term address))) sig
, Member (State (Heap address (Value term address))) sig
, Member Trace sig
, Ord address
, Carrier sig m
, Show address
, Show term
)
=> Carrier (Abstract.Function term address (Value term address) :+: sig) (Abstract.FunctionC term address (Value term address) (Eff m)) where
ret = FunctionC . const . ret
eff op = FunctionC (\ eval -> handleSum (eff . handleReader eval runFunctionC) (\case
Abstract.Function name params body k -> runEvaluator $ do
packageInfo <- currentPackage
moduleInfo <- currentModule
Closure packageInfo moduleInfo name params (Right body) <$> close (foldr Set.delete (freeVariables body) params) >>= Evaluator . flip runFunctionC eval . k
Abstract.BuiltIn builtIn k -> do
packageInfo <- currentPackage
moduleInfo <- currentModule
runFunctionC (k (Closure packageInfo moduleInfo Nothing [] (Left builtIn) lowerBound)) eval
Abstract.Call op self params k -> runEvaluator $ do
boxed <- case op of
Closure _ _ _ _ (Left Print) _ -> traverse (deref >=> trace . show) params *> box Unit
Closure _ _ _ _ (Left Show) _ -> deref self >>= box . String . pack . show
Closure packageInfo moduleInfo _ names (Right body) env -> do
-- Evaluate the bindings and body with the closures package/module info in scope in order to
-- charge them to the closure's origin.
withCurrentPackage packageInfo . withCurrentModule moduleInfo $ do
bindings <- foldr (\ (name, addr) rest -> Env.insert name addr <$> rest) (pure lowerBound) (zip names params)
let fnCtx = EvalContext (Just self) (Env.push env)
withEvalContext fnCtx (catchReturn (bindAll bindings *> runFunction (Evaluator . eval) (Evaluator (eval body))))
_ -> throwValueError (CallError op) >>= box
Evaluator $ runFunctionC (k boxed) eval) op)
runWhile :: forall effects term address a .
( PureEffects effects
, Member (Deref (Value term address)) effects
, Member (Abstract.Boolean (Value term address)) effects
, Member (Exc (LoopControl address)) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (AddressError address (Value term address)))) effects
, Member (Resumable (BaseError (ValueError term address))) effects
, Member (Resumable (BaseError (UnspecializedError (Value term address)))) effects
, Member (State (Heap address (Value term address))) effects
, Ord address
, Show address
, Show term
)
=> Evaluator term address (Value term address) (Abstract.While (Value term address) ': effects) a
-> Evaluator term address (Value term address) effects a
runWhile = interpret $ \case
Abstract.While cond body -> loop $ \continue -> do
cond' <- runWhile (raiseEff cond)
instance ( Member (Reader ModuleInfo) sig
, Member (Reader Span) sig
, Member (Resumable (BaseError (ValueError term address))) sig
, Carrier sig m
, Monad m
)
=> Carrier (Abstract.Boolean (Value term address) :+: sig) (BooleanC (Value term address) m) where
ret = BooleanC . ret
eff = BooleanC . handleSum (eff . handleCoercible) (\case
Abstract.Boolean b k -> runBooleanC . k $! Boolean b
Abstract.AsBool (Boolean b) k -> runBooleanC (k b)
Abstract.AsBool other k -> throwBaseError (BoolError other) >>= runBooleanC . k)
-- `interpose` is used to handle 'UnspecializedError's and abort out of the
-- loop, otherwise under concrete semantics we run the risk of the
-- conditional always being true and getting stuck in an infinite loop.
let body' = interpose @(Resumable (BaseError (UnspecializedError (Value term address))))
(\(Resumable (BaseError _ _ (UnspecializedError _))) -> throwAbort) $
runWhile (raiseEff body) *> continue
ifthenelse cond' body' (pure unit)
where
loop x = catchLoopControl (fix x) (\ control -> case control of
Break value -> deref value
Abort -> pure unit
-- FIXME: Figure out how to deal with this. Ruby treats this as the result
-- of the current block iteration, while PHP specifies a breakout level
-- and TypeScript appears to take a label.
Continue _ -> loop x)
instance ( Carrier sig m
, Member (Deref (Value term address)) sig
, Member (Abstract.Boolean (Value term address)) sig
, Member (Error (LoopControl address)) sig
, Member (Interpose (Resumable (BaseError (UnspecializedError (Value term address))))) sig
, Member (Reader ModuleInfo) sig
, Member (Reader Span) sig
, Member (Resumable (BaseError (AddressError address (Value term address)))) sig
, Member (State (Heap address (Value term address))) sig
, Ord address
, Show address
, Show term
)
=> Carrier (Abstract.While (Value term address) :+: sig) (WhileC (Value term address) (Eff m)) where
ret = WhileC . ret
eff = WhileC . handleSum (eff . handleCoercible) (\case
Abstract.While cond body k -> interpose @(Resumable (BaseError (UnspecializedError (Value term address)))) (runEvaluator (loop (\continue -> do
cond' <- Evaluator (runWhileC cond)
-- `interpose` is used to handle 'UnspecializedError's and abort out of the
-- loop, otherwise under concrete semantics we run the risk of the
-- conditional always being true and getting stuck in an infinite loop.
ifthenelse cond' (Evaluator (runWhileC body) *> continue) (pure Unit))))
(\(Resumable (BaseError _ _ (UnspecializedError _)) _) -> throwError (Abort @address))
>>= runWhileC . k)
where
loop x = catchLoopControl @address (fix x) $ \case
Break value -> deref value
Abort -> pure unit
-- FIXME: Figure out how to deal with this. Ruby treats this as the result
-- of the current block iteration, while PHP specifies a breakout level
-- and TypeScript appears to take a label.
Continue _ -> loop x
instance AbstractHole (Value term address) where
@ -171,15 +166,16 @@ instance (Show address, Show term) => AbstractIntro (Value term address) where
null = Null
materializeEnvironment :: ( Member (Deref (Value term address)) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (AddressError address (Value term address)))) effects
, Member (State (Heap address (Value term address))) effects
materializeEnvironment :: ( Member (Deref (Value term address)) sig
, Member (Reader ModuleInfo) sig
, Member (Reader Span) sig
, Member (Resumable (BaseError (AddressError address (Value term address)))) sig
, Member (State (Heap address (Value term address))) sig
, Ord address
, Carrier sig m
)
=> Value term address
-> Evaluator term address (Value term address) effects (Maybe (Environment address))
-> Evaluator term address (Value term address) m (Maybe (Environment address))
materializeEnvironment val = do
ancestors <- rec val
pure (Env.Environment <$> nonEmpty ancestors)
@ -199,25 +195,26 @@ materializeEnvironment val = do
_ -> []
-- | Construct a 'Value' wrapping the value arguments (if any).
instance ( Member (Allocator address) effects
, Member (Abstract.Boolean (Value term address)) effects
, Member (Deref (Value term address)) effects
, Member (Env address) effects
, Member (Exc (LoopControl address)) effects
, Member (Exc (Return address)) effects
, Member Fresh effects
, Member (Reader ModuleInfo) effects
, Member (Reader PackageInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (ValueError term address))) effects
, Member (Resumable (BaseError (AddressError address (Value term address)))) effects
, Member (State (Heap address (Value term address))) effects
, Member Trace effects
instance ( Member (Allocator address) sig
, Member (Abstract.Boolean (Value term address)) sig
, Member (Deref (Value term address)) sig
, Member (Env address) sig
, Member (Error (LoopControl address)) sig
, Member (Error (Return address)) sig
, Member Fresh sig
, Member (Reader ModuleInfo) sig
, Member (Reader PackageInfo) sig
, Member (Reader Span) sig
, Member (Resumable (BaseError (ValueError term address))) sig
, Member (Resumable (BaseError (AddressError address (Value term address)))) sig
, Member (State (Heap address (Value term address))) sig
, Member Trace sig
, Ord address
, Show address
, Show term
, Carrier sig m
)
=> AbstractValue term address (Value term address) effects where
=> AbstractValue term address (Value term address) m where
asPair val
| KVPair k v <- val = pure (k, v)
| otherwise = throwValueError $ KeyValueError val
@ -282,10 +279,9 @@ instance ( Member (Allocator address) effects
tentative x i j = attemptUnsafeArithmetic (x i j)
-- Dispatch whatever's contained inside a 'Number.SomeNumber' to its appropriate 'MonadValue' ctor
specialize :: ( AbstractValue term address (Value term address) effects
)
specialize :: AbstractValue term address (Value term address) m
=> Either ArithException Number.SomeNumber
-> Evaluator term address (Value term address) effects (Value term address)
-> Evaluator term address (Value term address) m (Value term address)
specialize (Left exc) = throwValueError (ArithmeticError exc)
specialize (Right (Number.SomeNumber (Number.Integer i))) = pure $ integer i
specialize (Right (Number.SomeNumber (Number.Ratio r))) = pure $ rational r
@ -304,7 +300,7 @@ instance ( Member (Allocator address) effects
where
-- Explicit type signature is necessary here because we're passing all sorts of things
-- to these comparison functions.
go :: (AbstractValue term address (Value term address) effects, Ord a) => a -> a -> Evaluator term address (Value term address) effects (Value term address)
go :: (AbstractValue term address (Value term address) m, Ord a) => a -> a -> Evaluator term address (Value term address) m (Value term address)
go l r = case comparator of
Concrete f -> boolean (f l r)
Generalized -> pure $ integer (orderingToInt (compare l r))
@ -395,21 +391,22 @@ deriving instance (Show address, Show term) => Show (ValueError term address res
instance (Show address, Show term) => Show1 (ValueError term address) where
liftShowsPrec _ _ = showsPrec
runValueError :: Effects effects
=> Evaluator term address (Value term address) (Resumable (BaseError (ValueError term address)) ': effects) a
-> Evaluator term address (Value term address) effects (Either (SomeExc (BaseError (ValueError term address))) a)
runValueError = runResumable
runValueError :: (Carrier sig m, Effect sig)
=> Evaluator term address (Value term address) (ResumableC (BaseError (ValueError term address)) (Eff m)) a
-> Evaluator term address (Value term address) m (Either (SomeError (BaseError (ValueError term address))) a)
runValueError = Evaluator . runResumable . runEvaluator
runValueErrorWith :: Effects effects
=> (forall resume . BaseError (ValueError term address) resume -> Evaluator term address (Value term address) effects resume)
-> Evaluator term address (Value term address) (Resumable (BaseError (ValueError term address)) ': effects) a
-> Evaluator term address (Value term address) effects a
runValueErrorWith = runResumableWith
runValueErrorWith :: Carrier sig m
=> (forall resume . BaseError (ValueError term address) resume -> Evaluator term address (Value term address) m resume)
-> Evaluator term address (Value term address) (ResumableWithC (BaseError (ValueError term address)) (Eff m)) a
-> Evaluator term address (Value term address) m a
runValueErrorWith f = Evaluator . runResumableWith (runEvaluator . f) . runEvaluator
throwValueError :: ( Member (Resumable (BaseError (ValueError term address))) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
throwValueError :: ( Member (Resumable (BaseError (ValueError term address))) sig
, Member (Reader ModuleInfo) sig
, Member (Reader Span) sig
, Carrier sig m
)
=> ValueError term address resume
-> Evaluator term address (Value term address) effects resume
-> Evaluator term address (Value term address) m resume
throwValueError = throwBaseError

View File

@ -1,4 +1,4 @@
{-# LANGUAGE GADTs, RankNTypes, TypeFamilies, TypeOperators, UndecidableInstances, LambdaCase #-}
{-# LANGUAGE GADTs, LambdaCase, RankNTypes, TypeFamilies, TypeOperators, UndecidableInstances #-}
module Data.Abstract.Value.Type
( Type (..)
, TypeError (..)
@ -13,7 +13,8 @@ module Data.Abstract.Value.Type
import qualified Control.Abstract as Abstract
import Control.Abstract hiding (Boolean(..), Function(..), While(..))
import Control.Monad.Effect.Internal (raiseHandler)
import Control.Effect.Carrier
import Control.Effect.Sum
import Data.Abstract.Environment as Env
import Data.Abstract.BaseError
import Data.Semigroup.Foldable (foldMap1)
@ -87,40 +88,41 @@ instance Ord1 TypeError where
instance Show1 TypeError where liftShowsPrec _ _ = showsPrec
runTypeError :: (Effectful m, Effects effects) => m (Resumable (BaseError TypeError) ': effects) a -> m effects (Either (SomeExc (BaseError TypeError)) a)
runTypeError = runResumable
runTypeError :: (Carrier sig m, Effect sig) => Evaluator term address value (ResumableC (BaseError TypeError) (Eff m)) a -> Evaluator term address value m (Either (SomeError (BaseError TypeError)) a)
runTypeError = raiseHandler runResumable
runTypeErrorWith :: (Effectful m, Effects effects) => (forall resume . (BaseError TypeError) resume -> m effects resume) -> m (Resumable (BaseError TypeError) ': effects) a -> m effects a
runTypeErrorWith = runResumableWith
runTypeErrorWith :: Carrier sig m => (forall resume . (BaseError TypeError) resume -> Evaluator term address value m resume) -> Evaluator term address value (ResumableWithC (BaseError TypeError) (Eff m)) a -> Evaluator term address value m a
runTypeErrorWith f = raiseHandler $ runResumableWith (runEvaluator . f)
throwTypeError :: ( Member (Resumable (BaseError TypeError)) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
throwTypeError :: ( Member (Resumable (BaseError TypeError)) sig
, Member (Reader ModuleInfo) sig
, Member (Reader Span) sig
, Carrier sig m
, Monad m
)
=> TypeError resume
-> Evaluator term address value effects resume
-> m resume
throwTypeError = throwBaseError
runTypeMap :: ( Effectful m
, Effects effects
)
=> m (State TypeMap ': effects) a
-> m effects a
runTypeMap = raiseHandler (runState emptyTypeMap >=> pure . snd)
runTypeMap :: (Carrier sig m, Effect sig)
=> Evaluator term address Type (StateC TypeMap (Eff m)) a
-> Evaluator term address Type m a
runTypeMap = raiseHandler $ fmap snd . runState emptyTypeMap
runTypes :: ( Effectful m
, Effects effects
)
=> m (Resumable (BaseError TypeError) ': State TypeMap ': effects) a
-> m effects (Either (SomeExc (BaseError TypeError)) a)
runTypes :: (Carrier sig m, Effect sig)
=> Evaluator term address Type (ResumableC (BaseError TypeError) (Eff
(StateC TypeMap (Eff
m)))) a
-> Evaluator term address Type m (Either (SomeError (BaseError TypeError)) a)
runTypes = runTypeMap . runTypeError
runTypesWith :: ( Effectful m
, Effects effects
)
=> (forall resume . (BaseError TypeError) resume -> m (State TypeMap ': effects) resume)
-> m (Resumable (BaseError TypeError) ': State TypeMap ': effects) a
-> m effects a
runTypesWith :: (Carrier sig m, Effect sig)
=> (forall resume . (BaseError TypeError) resume -> Evaluator term address Type (StateC TypeMap (Eff m)) resume)
-> Evaluator term address Type (ResumableWithC (BaseError TypeError) (Eff
(StateC TypeMap (Eff
m)))) a
-> Evaluator term address Type m a
runTypesWith with = runTypeMap . runTypeErrorWith with
-- TODO: change my name?
@ -129,21 +131,22 @@ newtype TypeMap = TypeMap { unTypeMap :: Map.Map TName Type }
emptyTypeMap :: TypeMap
emptyTypeMap = TypeMap Map.empty
modifyTypeMap :: ( Effectful m
, Member (State TypeMap) effects
modifyTypeMap :: ( Member (State TypeMap) sig
, Carrier sig m
, Monad m
)
=> (Map.Map TName Type -> Map.Map TName Type)
-> m effects ()
-> m ()
modifyTypeMap f = modify (TypeMap . f . unTypeMap)
-- | Prunes substituted type variables
prune :: ( Effectful m
, Monad (m effects)
, Member (State TypeMap) effects
prune :: ( Member (State TypeMap) sig
, Carrier sig m
, Monad m
)
=> Type
-> m effects Type
prune (Var id) = Map.lookup id . unTypeMap <$> get >>= \case
-> m Type
prune (Var id) = gets (Map.lookup id . unTypeMap) >>= \case
Just ty -> do
pruned <- prune ty
modifyTypeMap (Map.insert id pruned)
@ -153,13 +156,13 @@ prune ty = pure ty
-- | Checks whether a type variable name occurs within another type. This
-- function is used in 'substitute' to prevent unification of infinite types
occur :: ( Effectful m
, Monad (m effects)
, Member (State TypeMap) effects
occur :: ( Member (State TypeMap) sig
, Carrier sig m
, Monad m
)
=> TName
-> Type
-> m effects Bool
-> m Bool
occur id = prune >=> \case
Int -> pure False
Bool -> pure False
@ -184,14 +187,16 @@ occur id = prune >=> \case
eitherM f (a, b) = (||) <$> f a <*> f b
-- | Substitutes a type variable name for another type
substitute :: ( Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError TypeError)) effects
, Member (State TypeMap) effects
substitute :: ( Member (Reader ModuleInfo) sig
, Member (Reader Span) sig
, Member (Resumable (BaseError TypeError)) sig
, Member (State TypeMap) sig
, Carrier sig m
, Monad m
)
=> TName
-> Type
-> Evaluator term address value effects Type
-> m Type
substitute id ty = do
infiniteType <- occur id ty
ty <- if infiniteType
@ -201,14 +206,16 @@ substitute id ty = do
pure ty
-- | Unify two 'Type's.
unify :: ( Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError TypeError)) effects
, Member (State TypeMap) effects
unify :: ( Member (Reader ModuleInfo) sig
, Member (Reader Span) sig
, Member (Resumable (BaseError TypeError)) sig
, Member (State TypeMap) sig
, Carrier sig m
, Monad m
)
=> Type
-> Type
-> Evaluator term address value effects Type
-> m Type
unify a b = do
a' <- prune a
b' <- prune b
@ -230,80 +237,71 @@ instance Ord address => ValueRoots address Type where
valueRoots _ = mempty
runFunction :: ( Member (Allocator address) effects
, Member (Deref Type) effects
, Member (Env address) effects
, Member (Exc (Return address)) effects
, Member Fresh effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError TypeError)) effects
, Member (Resumable (BaseError (AddressError address Type))) effects
, Member (State (Heap address Type)) effects
, Member (State TypeMap) effects
, Ord address
, PureEffects effects
)
=> (term -> Evaluator term address Type (Abstract.Function term address Type ': effects) address)
-> Evaluator term address Type (Abstract.Function term address Type ': effects) a
-> Evaluator term address Type effects a
runFunction eval = interpret $ \case
Abstract.Function _ params body -> do
(env, tvars) <- foldr (\ name rest -> do
addr <- alloc name
tvar <- Var <$> fresh
assign addr tvar
bimap (Env.insert name addr) (tvar :) <$> rest) (pure (lowerBound, [])) params
(zeroOrMoreProduct tvars :->) <$> (locally (catchReturn (bindAll env *> runFunction eval (eval body))) >>= deref)
Abstract.BuiltIn Print -> pure (String :-> Unit)
Abstract.BuiltIn Show -> pure (Object :-> String)
Abstract.Call op _ params -> do
tvar <- fresh
paramTypes <- traverse deref params
let needed = zeroOrMoreProduct paramTypes :-> Var tvar
unified <- op `unify` needed
case unified of
_ :-> ret -> box ret
actual -> throwTypeError (UnificationError needed actual) >>= box
runBoolean :: ( Member NonDet effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError TypeError)) effects
, Member (State TypeMap) effects
, PureEffects effects
)
=> Evaluator term address Type (Abstract.Boolean Type ': effects) a
-> Evaluator term address Type effects a
runBoolean = interpret $ \case
Abstract.Boolean _ -> pure Bool
Abstract.AsBool t -> unify t Bool *> (pure True <|> pure False)
Abstract.Disjunction t1 t2 -> (runBoolean (Evaluator t1) >>= unify Bool) <|> (runBoolean (Evaluator t2) >>= unify Bool)
instance ( Member (Allocator address) sig
, Member (Deref Type) sig
, Member (Env address) sig
, Member (Error (Return address)) sig
, Member Fresh sig
, Member (Reader ModuleInfo) sig
, Member (Reader Span) sig
, Member (Resumable (BaseError TypeError)) sig
, Member (Resumable (BaseError (AddressError address Type))) sig
, Member (State (Heap address Type)) sig
, Member (State TypeMap) sig
, Ord address
, Carrier sig m
)
=> Carrier (Abstract.Function term address Type :+: sig) (FunctionC term address Type (Eff m)) where
ret = FunctionC . const . ret
eff op = FunctionC (\ eval -> handleSum (eff . handleReader eval runFunctionC) (\case
Abstract.Function _ params body k -> runEvaluator $ do
(env, tvars) <- foldr (\ name rest -> do
addr <- alloc name
tvar <- Var <$> fresh
assign addr tvar
bimap (Env.insert name addr) (tvar :) <$> rest) (pure (lowerBound, [])) params
locally (catchReturn (bindAll env *> runFunction (Evaluator . eval) (Evaluator (eval body)))) >>= deref >>= Evaluator . flip runFunctionC eval . k . (zeroOrMoreProduct tvars :->)
Abstract.BuiltIn Print k -> runFunctionC (k (String :-> Unit)) eval
Abstract.BuiltIn Show k -> runFunctionC (k (Object :-> String)) eval
Abstract.Call op _ params k -> runEvaluator $ do
tvar <- fresh
paramTypes <- traverse deref params
let needed = zeroOrMoreProduct paramTypes :-> Var tvar
unified <- op `unify` needed
boxed <- case unified of
_ :-> ret -> box ret
actual -> throwTypeError (UnificationError needed actual) >>= box
Evaluator $ runFunctionC (k boxed) eval) op)
runWhile ::
( Member (Allocator address) effects
, Member (Deref Type) effects
, Member (Abstract.Boolean Type) effects
, Member NonDet effects
, Member (Env address) effects
, Member (Exc (Return address)) effects
, Member Fresh effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError TypeError)) effects
, Member (Resumable (BaseError (AddressError address Type))) effects
, Member (State (Heap address Type)) effects
, Member (State TypeMap) effects
, Ord address
, PureEffects effects
)
=> Evaluator term address Type (Abstract.While Type ': effects) a
-> Evaluator term address Type effects a
runWhile = interpret $ \case
Abstract.While cond body -> do
cond' <- runWhile (raiseEff cond)
ifthenelse cond' (runWhile (raiseEff body) *> empty) (pure unit)
instance ( Member (Reader ModuleInfo) sig
, Member (Reader Span) sig
, Member (Resumable (BaseError TypeError)) sig
, Member (State TypeMap) sig
, Carrier sig m
, Alternative m
, Monad m
)
=> Carrier (Abstract.Boolean Type :+: sig) (BooleanC Type m) where
ret = BooleanC . ret
eff = BooleanC . handleSum (eff . handleCoercible) (\case
Abstract.Boolean _ k -> runBooleanC (k Bool)
Abstract.AsBool t k -> unify t Bool *> (runBooleanC (k True) <|> runBooleanC (k False)))
instance ( Member (Abstract.Boolean Type) sig
, Carrier sig m
, Alternative m
, Monad m
)
=> Carrier (Abstract.While Type :+: sig) (WhileC Type m) where
ret = WhileC . ret
eff = WhileC . handleSum
(eff . handleCoercible)
(\ (Abstract.While cond body k) -> do
cond' <- runWhileC cond
ifthenelse cond' (runWhileC body *> empty) (runWhileC (k unit)))
instance AbstractHole Type where
hole = Hole
@ -322,18 +320,19 @@ instance AbstractIntro Type where
null = Null
-- | Discard the value arguments (if any), constructing a 'Type' instead.
instance ( Member (Allocator address) effects
, Member (Deref Type) effects
, Member Fresh effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (AddressError address Type))) effects
, Member (Resumable (BaseError TypeError)) effects
, Member (State (Heap address Type)) effects
, Member (State TypeMap) effects
instance ( Member (Allocator address) sig
, Member (Deref Type) sig
, Member Fresh sig
, Member (Reader ModuleInfo) sig
, Member (Reader Span) sig
, Member (Resumable (BaseError (AddressError address Type))) sig
, Member (Resumable (BaseError TypeError)) sig
, Member (State (Heap address Type)) sig
, Member (State TypeMap) sig
, Ord address
, Carrier sig m
)
=> AbstractValue term address Type effects where
=> AbstractValue term address Type m where
array fields = do
var <- fresh
fieldTypes <- traverse deref fields

View File

@ -18,10 +18,10 @@ module Data.Blob
, pathKeyForBlobPair
) where
import Prologue hiding (throwError)
import Prologue
import Control.Monad.Effect
import Control.Monad.Effect.Exception
import Control.Effect
import Control.Effect.Error
import Data.Aeson
import qualified Data.ByteString.Lazy as BL
import Proto3.Suite
@ -67,7 +67,7 @@ decodeBlobs = fmap blobs <$> eitherDecode
newtype NoLanguageForBlob = NoLanguageForBlob FilePath
deriving (Eq, Exception, Ord, Show, Typeable)
noLanguageForBlob :: Member (Exc SomeException) effs => FilePath -> Eff effs a
noLanguageForBlob :: (Member (Error SomeException) sig, Carrier sig m) => FilePath -> m a
noLanguageForBlob blobPath = throwError (SomeException (NoLanguageForBlob blobPath))
-- | Represents a blobs suitable for diffing which can be either a blob to

View File

@ -20,8 +20,8 @@ import qualified Algebra.Graph.AdjacencyMap as A
import Algebra.Graph.Class (connect, overlay, vertex)
import qualified Algebra.Graph.Class as Class
import qualified Algebra.Graph.ToGraph as Class
import Control.Monad.Effect
import Control.Monad.Effect.State
import Control.Effect
import Control.Effect.State
import Data.Aeson
import qualified Data.Set as Set
@ -66,15 +66,15 @@ topologicalSort = go . Class.toAdjacencyMap . G.transpose . unGraph
. traverse_ visit
. A.vertexList
$ graph
where visit :: v -> Eff '[State (Visited v)] ()
where visit :: (Member (State (Visited v)) sig, Carrier sig m, Monad m) => v -> m ()
visit v = do
isMarked <- Set.member v . visitedVertices <$> get
if isMarked then
pure ()
else do
modify' (extendVisited (Set.insert v))
modify (extendVisited (Set.insert v))
traverse_ visit (Set.toList (A.postSet v graph))
modify' (extendOrder (v :))
modify (extendOrder (v :))
data Visited v = Visited { visitedVertices :: !(Set v), visitedOrder :: [v] }

View File

@ -30,7 +30,7 @@ import qualified Data.Syntax.Expression as Expression
import Data.Term
import qualified Data.Text as T
import GHC.Exts (fromList)
import Prologue hiding (packageName)
import Prologue
import Proto3.Suite
import qualified Proto3.Suite as PB
import qualified Proto3.Wire.Encode as Encode

View File

@ -12,6 +12,7 @@ import Data.Aeson
import qualified Data.Map as Map
import Data.Sum (Apply (..), Sum)
import qualified Data.Text as Text
import GHC.Generics
import Prologue
class ToJSONFields a where

View File

@ -6,7 +6,7 @@ module Data.Location
, Range(..)
) where
import Prologue (Generic (..), NFData (..))
import Prologue (Generic, NFData (..))
import Data.JSON.Fields
import Data.Range

View File

@ -15,10 +15,10 @@ module Data.Project (
) where
import Prelude hiding (readFile)
import Prologue hiding (throwError)
import Prologue
import Control.Monad.Effect
import Control.Monad.Effect.Exception
import Control.Effect
import Control.Effect.Error
import Data.Blob
import Data.File
import Data.Language
@ -77,10 +77,10 @@ newtype ProjectException
= FileNotFound FilePath
deriving (Show, Eq, Typeable, Exception)
readFile :: Member (Exc SomeException) effs
readFile :: (Member (Error SomeException) sig, Applicative m, Carrier sig m)
=> Project
-> File
-> Eff effs (Maybe Blob)
-> m (Maybe Blob)
readFile Project{..} f =
let p = filePath f
candidate = find (\b -> blobPath b == p) projectBlobs

View File

@ -2,7 +2,7 @@
{-# OPTIONS_GHC -Wno-missing-export-lists -Wno-redundant-constraints -fno-warn-orphans #-} -- For HasCallStack
module Data.Syntax where
import Data.Abstract.Evaluatable
import Data.Abstract.Evaluatable hiding (Empty, Error)
import Data.Aeson (ToJSON(..), object)
import Data.Char (toLower)
import Data.JSON.Fields

View File

@ -3,13 +3,13 @@
module Data.Syntax.Expression where
import Prelude hiding (null)
import Prologue hiding (Member, This, index, null)
import Prologue hiding (This, index, null)
import Data.Fixed
import Proto3.Suite.Class
import Control.Abstract.ScopeGraph as ScopeGraph
import Data.Abstract.Evaluatable as Abstract hiding (Member)
import Data.Abstract.Evaluatable as Abstract hiding (Member, Void)
import Data.Abstract.Number (liftIntegralFrac, liftReal, liftedExponent, liftedFloorDiv)
import Data.JSON.Fields
import qualified Data.Reprinting.Scope as Scope
@ -249,7 +249,9 @@ instance Ord1 Or where liftCompare = genericLiftCompare
instance Show1 Or where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Or where
eval eval (Or a b) = disjunction (eval a >>= Abstract.value) (eval b >>= Abstract.value) >>= rvalBox
eval eval (Or a b) = do
a' <- eval a >>= Abstract.value
ifthenelse a' (rvalBox a') (eval b)
data And a = And { lhs :: a, rhs :: a }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1)

View File

@ -2,7 +2,7 @@
{-# OPTIONS_GHC -Wno-missing-export-lists #-}
module Data.Syntax.Type where
import Data.Abstract.Evaluatable
import Data.Abstract.Evaluatable hiding (Void)
import Data.JSON.Fields
import Diffing.Algorithm
import Prelude hiding (Bool, Float, Int, Double)

View File

@ -18,6 +18,7 @@ import Control.Monad.Free.Freer
import Data.Diff
import Data.Sum
import Data.Term
import GHC.Generics
import Prologue
-- | A single step in a diffing algorithm, parameterized by the types of terms, diffs, and the result of the applicable algorithm.

View File

@ -56,15 +56,16 @@ importPath str = let path = stripQuotes str in ImportPath (T.unpack path) (pathT
defaultAlias :: ImportPath -> Name
defaultAlias = name . T.pack . takeFileName . unPath
resolveGoImport :: ( Member (Modules address) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Package.PackageInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError ResolutionError)) effects
, Member Trace effects
resolveGoImport :: ( Member (Modules address) sig
, Member (Reader ModuleInfo) sig
, Member (Reader Package.PackageInfo) sig
, Member (Reader Span) sig
, Member (Resumable (BaseError ResolutionError)) sig
, Member Trace sig
, Carrier sig m
)
=> ImportPath
-> Evaluator term address value effects [ModulePath]
-> Evaluator term address value m [ModulePath]
resolveGoImport (ImportPath path Unknown) = throwResolutionError $ GoImportError path
resolveGoImport (ImportPath path Relative) = do
ModuleInfo{..} <- currentModule

View File

@ -6,10 +6,10 @@ module Language.JSON.PrettyPrint
, minimizingJSON
) where
import Prologue hiding (throwError)
import Prologue
import Control.Monad.Effect
import Control.Monad.Effect.Exception (Exc, throwError)
import Control.Effect
import Control.Effect.Error
import Control.Monad.Trans (lift)
import Data.Machine
@ -19,8 +19,8 @@ import Data.Reprinting.Token
import Data.Reprinting.Scope
-- | Default printing pipeline for JSON.
defaultJSONPipeline :: (Member (Exc TranslationError) effs)
=> ProcessT (Eff effs) Fragment Splice
defaultJSONPipeline :: (Member (Error TranslationError) sig, Carrier sig m, Monad m)
=> ProcessT m Fragment Splice
defaultJSONPipeline
= printingJSON
~> beautifyingJSON defaultBeautyOpts
@ -56,8 +56,8 @@ defaultBeautyOpts :: JSONBeautyOpts
defaultBeautyOpts = JSONBeautyOpts 2 False
-- | Produce JSON with configurable whitespace and layout.
beautifyingJSON :: (Member (Exc TranslationError) effs)
=> JSONBeautyOpts -> ProcessT (Eff effs) Fragment Splice
beautifyingJSON :: (Member (Error TranslationError) sig, Carrier sig m, Monad m)
=> JSONBeautyOpts -> ProcessT m Fragment Splice
beautifyingJSON _ = repeatedly (await >>= step) where
step (Defer el cs) = lift (throwError (NoTranslation el cs))
step (Verbatim txt) = emit txt
@ -70,8 +70,8 @@ beautifyingJSON _ = repeatedly (await >>= step) where
_ -> emit txt
-- | Produce whitespace minimal JSON.
minimizingJSON :: (Member (Exc TranslationError) effs)
=> ProcessT (Eff effs) Fragment Splice
minimizingJSON :: (Member (Error TranslationError) sig, Carrier sig m, Monad m)
=> ProcessT m Fragment Splice
minimizingJSON = repeatedly (await >>= step) where
step (Defer el cs) = lift (throwError (NoTranslation el cs))
step (Verbatim txt) = emit txt

View File

@ -5,7 +5,7 @@ module Language.Java.Syntax where
import Data.Abstract.Evaluatable
import Data.JSON.Fields
import Diffing.Algorithm
import Prologue hiding (Constructor)
import Prologue
import Proto3.Suite.Class
newtype Import a = Import { imports :: [a]}

View File

@ -38,36 +38,38 @@ instance Evaluatable VariableName
-- file, the complete contents of the included file are treated as though it
-- were defined inside that function.
resolvePHPName :: ( Member (Modules address) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError ResolutionError)) effects
resolvePHPName :: ( Member (Modules address) sig
, Member (Reader ModuleInfo) sig
, Member (Reader Span) sig
, Member (Resumable (BaseError ResolutionError)) sig
, Carrier sig m
)
=> T.Text
-> Evaluator term address value effects ModulePath
-> Evaluator term address value m ModulePath
resolvePHPName n = do
modulePath <- resolve [name]
maybeM (throwResolutionError $ NotFoundError name [name] Language.PHP) modulePath
where name = toName n
toName = T.unpack . dropRelativePrefix . stripQuotes
include :: ( AbstractValue term address value effects
, Member (Deref value) effects
, Member (Env address) effects
, Member (Modules address) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (AddressError address value))) effects
, Member (Resumable (BaseError ResolutionError)) effects
, Member (Resumable (BaseError (EnvironmentError address))) effects
, Member (State (Heap address value)) effects
, Member Trace effects
include :: ( AbstractValue term address value m
, Carrier sig m
, Member (Deref value) sig
, Member (Env address) sig
, Member (Modules address) sig
, Member (Reader ModuleInfo) sig
, Member (Reader Span) sig
, Member (Resumable (BaseError (AddressError address value))) sig
, Member (Resumable (BaseError ResolutionError)) sig
, Member (Resumable (BaseError (EnvironmentError address))) sig
, Member (State (Heap address value)) sig
, Member Trace sig
, Ord address
)
=> (term -> Evaluator term address value effects (ValueRef address))
=> (term -> Evaluator term address value m (ValueRef address))
-> term
-> (ModulePath -> Evaluator term address value effects (ModuleResult address))
-> Evaluator term address value effects (ValueRef address)
-> (ModulePath -> Evaluator term address value m (ModuleResult address))
-> Evaluator term address value m (ValueRef address)
include eval pathTerm f = do
name <- eval pathTerm >>= Abstract.value >>= asString
path <- resolvePHPName name

View File

@ -2,8 +2,8 @@
module Language.Python.PrettyPrint ( printingPython ) where
import Control.Monad.Effect
import Control.Monad.Effect.Exception (Exc, throwError)
import Control.Effect
import Control.Effect.Error
import Control.Monad.Trans (lift)
import Data.Machine
@ -14,10 +14,10 @@ import Data.Reprinting.Scope
import Data.Reprinting.Operator
-- | Print Python syntax.
printingPython :: (Member (Exc TranslationError) effs) => ProcessT (Eff effs) Fragment Splice
printingPython :: (Member (Error TranslationError) sig, Carrier sig m, Monad m) => ProcessT m Fragment Splice
printingPython = repeatedly (await >>= step)
step :: (Member (Exc TranslationError) effs) => Fragment -> PlanT k Splice (Eff effs) ()
step :: (Member (Error TranslationError) sig, Carrier sig m, Monad m) => Fragment -> PlanT k Splice m ()
step (Verbatim txt) = emit txt
step (New _ _ txt) = emit txt
step (Defer el cs) = case (el, cs) of

View File

@ -65,14 +65,15 @@ relativeQualifiedName prefix paths = RelativeQualifiedName (T.unpack prefix) (Ju
-- Subsequent imports of `parent.two` or `parent.three` will execute
-- `parent/two/__init__.py` and
-- `parent/three/__init__.py` respectively.
resolvePythonModules :: ( Member (Modules address) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError ResolutionError)) effects
, Member Trace effects
resolvePythonModules :: ( Member (Modules address) sig
, Member (Reader ModuleInfo) sig
, Member (Reader Span) sig
, Member (Resumable (BaseError ResolutionError)) sig
, Member Trace sig
, Carrier sig m
)
=> QualifiedName
-> Evaluator term address value effects (NonEmpty ModulePath)
-> Evaluator term address value m (NonEmpty ModulePath)
resolvePythonModules q = do
relRootDir <- rootDir q <$> currentModule
for (moduleNames q) $ \name -> do
@ -155,15 +156,16 @@ instance Evaluatable Import where
-- Evaluate a qualified import
evalQualifiedImport :: ( AbstractValue term address value effects
, Member (Allocator address) effects
, Member (Deref value) effects
, Member (Env address) effects
, Member (Modules address) effects
, Member (State (Heap address value)) effects
evalQualifiedImport :: ( AbstractValue term address value m
, Carrier sig m
, Member (Allocator address) sig
, Member (Deref value) sig
, Member (Env address) sig
, Member (Modules address) sig
, Member (State (Heap address value)) sig
, Ord address
)
=> Name -> ModulePath -> Evaluator term address value effects value
=> Name -> ModulePath -> Evaluator term address value m value
evalQualifiedImport name path = letrec' name $ \addr -> do
unit <$ makeNamespace name addr Nothing (bindAll . fst . snd =<< require path)

View File

@ -2,8 +2,8 @@
module Language.Ruby.PrettyPrint ( printingRuby ) where
import Control.Monad.Effect
import Control.Monad.Effect.Exception (Exc, throwError)
import Control.Effect
import Control.Effect.Error
import Control.Monad.Trans (lift)
import Data.Machine
@ -14,10 +14,10 @@ import Data.Reprinting.Splice
import Data.Reprinting.Token as Token
-- | Print Ruby syntax.
printingRuby :: (Member (Exc TranslationError) effs) => ProcessT (Eff effs) Fragment Splice
printingRuby :: (Member (Error TranslationError) sig, Carrier sig m, Monad m) => ProcessT m Fragment Splice
printingRuby = repeatedly (await >>= step)
step :: (Member (Exc TranslationError) effs) => Fragment -> PlanT k Splice (Eff effs) ()
step :: (Member (Error TranslationError) sig, Carrier sig m, Monad m) => Fragment -> PlanT k Splice m ()
step (Verbatim txt) = emit txt
step (New _ _ txt) = emit txt
step (Defer el cs) = case (el, cs) of

View File

@ -22,13 +22,14 @@ import Reprinting.Tokenize
-- TODO: Fully sort out ruby require/load mechanics
--
-- require "json"
resolveRubyName :: ( Member (Modules address) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError ResolutionError)) effects
resolveRubyName :: ( Member (Modules address) sig
, Member (Reader ModuleInfo) sig
, Member (Reader Span) sig
, Member (Resumable (BaseError ResolutionError)) sig
, Carrier sig m
)
=> Text
-> Evaluator term address value effects M.ModulePath
-> Evaluator term address value m M.ModulePath
resolveRubyName name = do
let name' = cleanNameOrPath name
let paths = [name' <.> "rb"]
@ -36,13 +37,14 @@ resolveRubyName name = do
maybeM (throwResolutionError $ NotFoundError name' paths Language.Ruby) modulePath
-- load "/root/src/file.rb"
resolveRubyPath :: ( Member (Modules address) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError ResolutionError)) effects
resolveRubyPath :: ( Member (Modules address) sig
, Member (Reader ModuleInfo) sig
, Member (Reader Span) sig
, Member (Resumable (BaseError ResolutionError)) sig
, Carrier sig m
)
=> Text
-> Evaluator term address value effects M.ModulePath
-> Evaluator term address value m M.ModulePath
resolveRubyPath path = do
let name' = cleanNameOrPath path
modulePath <- resolve [name']
@ -91,11 +93,12 @@ instance Evaluatable Require where
bindAll importedEnv
rvalBox v -- Returns True if the file was loaded, False if it was already loaded. http://ruby-doc.org/core-2.5.0/Kernel.html#method-i-require
doRequire :: ( Member (Boolean value) effects
, Member (Modules address) effects
doRequire :: ( Member (Boolean value) sig
, Member (Modules address) sig
, Carrier sig m
)
=> M.ModulePath
-> Evaluator term address value effects (Bindings address, value)
-> Evaluator term address value m (Bindings address, value)
doRequire path = do
result <- lookupModule path
case result of
@ -119,17 +122,18 @@ instance Evaluatable Load where
shouldWrap <- eval wrap >>= value >>= asBool
rvalBox =<< doLoad path shouldWrap
doLoad :: ( Member (Boolean value) effects
, Member (Env address) effects
, Member (Modules address) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError ResolutionError)) effects
, Member Trace effects
doLoad :: ( Member (Boolean value) sig
, Member (Env address) sig
, Member (Modules address) sig
, Member (Reader ModuleInfo) sig
, Member (Reader Span) sig
, Member (Resumable (BaseError ResolutionError)) sig
, Member Trace sig
, Carrier sig m
)
=> Text
-> Bool
-> Evaluator term address value effects value
-> Evaluator term address value m value
doLoad path shouldWrap = do
path' <- resolveRubyPath path
traceResolve path path'

View File

@ -65,16 +65,17 @@ toName = name . T.pack . unPath
--
-- NB: TypeScript has a couple of different strategies, but the main one (and the
-- only one we support) mimics Node.js.
resolveWithNodejsStrategy :: ( Member (Modules address) effects
, Member (Reader M.ModuleInfo) effects
, Member (Reader PackageInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError ResolutionError)) effects
, Member Trace effects
resolveWithNodejsStrategy :: ( Member (Modules address) sig
, Member (Reader M.ModuleInfo) sig
, Member (Reader PackageInfo) sig
, Member (Reader Span) sig
, Member (Resumable (BaseError ResolutionError)) sig
, Member Trace sig
, Carrier sig m
)
=> ImportPath
-> [String]
-> Evaluator term address value effects M.ModulePath
-> Evaluator term address value m M.ModulePath
resolveWithNodejsStrategy (ImportPath path NonRelative) exts = resolveNonRelativePath path exts
resolveWithNodejsStrategy (ImportPath path _) exts = resolveRelativePath path exts
@ -85,16 +86,17 @@ resolveWithNodejsStrategy (ImportPath path _) exts = resolveRelativePa
-- /root/src/moduleB.ts
-- /root/src/moduleB/package.json (if it specifies a "types" property)
-- /root/src/moduleB/index.ts
resolveRelativePath :: ( Member (Modules address) effects
, Member (Reader M.ModuleInfo) effects
, Member (Reader PackageInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError ResolutionError)) effects
, Member Trace effects
resolveRelativePath :: ( Member (Modules address) sig
, Member (Reader M.ModuleInfo) sig
, Member (Reader PackageInfo) sig
, Member (Reader Span) sig
, Member (Resumable (BaseError ResolutionError)) sig
, Member Trace sig
, Carrier sig m
)
=> FilePath
-> [String]
-> Evaluator term address value effects M.ModulePath
-> Evaluator term address value m M.ModulePath
resolveRelativePath relImportPath exts = do
M.ModuleInfo{..} <- currentModule
let relRootDir = takeDirectory modulePath
@ -114,16 +116,17 @@ resolveRelativePath relImportPath exts = do
--
-- /root/node_modules/moduleB.ts, etc
-- /node_modules/moduleB.ts, etc
resolveNonRelativePath :: ( Member (Modules address) effects
, Member (Reader M.ModuleInfo) effects
, Member (Reader PackageInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError ResolutionError)) effects
, Member Trace effects
resolveNonRelativePath :: ( Member (Modules address) sig
, Member (Reader M.ModuleInfo) sig
, Member (Reader PackageInfo) sig
, Member (Reader Span) sig
, Member (Resumable (BaseError ResolutionError)) sig
, Member Trace sig
, Carrier sig m
)
=> FilePath
-> [String]
-> Evaluator term address value effects M.ModulePath
-> Evaluator term address value m M.ModulePath
resolveNonRelativePath name exts = do
M.ModuleInfo{..} <- currentModule
go "." modulePath mempty
@ -140,13 +143,14 @@ resolveNonRelativePath name exts = do
notFound xs = throwResolutionError $ NotFoundError name xs Language.TypeScript
-- | Resolve a module name to a ModulePath.
resolveModule :: ( Member (Modules address) effects
, Member (Reader PackageInfo) effects
, Member Trace effects
resolveModule :: ( Member (Modules address) sig
, Member (Reader PackageInfo) sig
, Member Trace sig
, Carrier sig m
)
=> FilePath -- ^ Module path used as directory to search in
-> [String] -- ^ File extensions to look for
-> Evaluator term address value effects (Either [FilePath] M.ModulePath)
-> Evaluator term address value m (Either [FilePath] M.ModulePath)
resolveModule path' exts = do
let path = makeRelative "." path'
PackageInfo{..} <- currentPackage
@ -163,16 +167,17 @@ typescriptExtensions = ["ts", "tsx", "d.ts"]
javascriptExtensions :: [String]
javascriptExtensions = ["js"]
evalRequire :: ( AbstractValue term address value effects
, Member (Allocator address) effects
, Member (Deref value) effects
, Member (Env address) effects
, Member (Modules address) effects
, Member (State (Heap address value)) effects
evalRequire :: ( AbstractValue term address value m
, Member (Allocator address) sig
, Member (Deref value) sig
, Member (Env address) sig
, Member (Modules address) sig
, Member (State (Heap address value)) sig
, Ord address
, Carrier sig m
)
=> M.ModulePath
-> Name
-> Evaluator term address value effects value
-> Evaluator term address value m value
evalRequire modulePath alias = letrec' alias $ \addr ->
unit <$ makeNamespace alias addr Nothing (bindAll . fst . snd =<< require modulePath)

View File

@ -8,7 +8,7 @@ module Matching.Core
import Prologue
import Control.Abstract.Matching
import Control.Matching
import qualified Data.Syntax.Literal as Literal
import Data.Term

View File

@ -31,7 +31,7 @@ module Parsing.Parser
import Assigning.Assignment
import qualified Assigning.Assignment.Deterministic as Deterministic
import qualified CMarkGFM
import Data.Abstract.Evaluatable (HasPostlude, HasPrelude)
import Data.Abstract.Evaluatable (HasPrelude)
import Data.AST
import Data.Graph.ControlFlowVertex (VertexDeclaration')
import Data.Kind
@ -73,7 +73,6 @@ data SomeAnalysisParser typeclasses ann where
, Apply (VertexDeclaration' (Sum fs)) fs
, Element Syntax.Identifier fs
, HasPrelude lang
, HasPostlude lang
)
=> Parser (Term (Sum fs) ann)
-> Proxy lang

View File

@ -8,9 +8,9 @@ import Prologue hiding (bracket)
import Control.Concurrent.Async
import qualified Control.Exception as Exc (bracket)
import Control.Monad.Effect
import Control.Monad.Effect.Resource
import Control.Monad.Effect.Trace
import Control.Effect
import Control.Effect.Resource
import Control.Effect.Trace
import Data.ByteString.Unsafe (unsafeUseAsCStringLen)
import Foreign
import Foreign.C.Types (CBool (..))
@ -57,16 +57,17 @@ runParser parser blobSource = unsafeUseAsCStringLen (sourceBytes blobSource) $
-- | Parse 'Source' with the given 'TS.Language' and return its AST.
-- Returns Nothing if the operation timed out.
parseToAST :: ( Bounded grammar
, Carrier sig m
, Enum grammar
, Member (Lift IO) effects
, Member Resource effects
, Member Timeout effects
, Member Trace effects
, Member Resource sig
, Member Timeout sig
, Member Trace sig
, MonadIO m
)
=> Duration
-> Ptr TS.Language
-> Blob
-> Eff effects (Maybe (AST [] grammar))
-> m (Maybe (AST [] grammar))
parseToAST parseTimeout language Blob{..} = bracket (liftIO TS.ts_parser_new) (liftIO . TS.ts_parser_delete) $ \ parser -> do
liftIO $ do
TS.ts_parser_halt_on_error parser (CBool 1)

View File

@ -26,7 +26,6 @@ import Data.Set as X (Set)
import Data.Sum as X (Sum, Element, Elements, (:<), (:<:), Apply (..), inject)
import Data.Text as X (Text)
import Data.These as X
import Data.Union as X
import Control.Exception as X hiding (Handler (..), assert, evaluate, throw, throwIO, throwTo)
@ -34,7 +33,6 @@ import Control.Exception as X hiding (Handler (..), assert, evaluate, throw, thr
import Control.Applicative as X
import Control.Arrow as X ((&&&), (***))
import Control.Monad as X hiding (fail, return)
import Control.Monad.Except as X (MonadError (..))
import Control.Monad.Fail as X (MonadFail (..))
import Control.Monad.IO.Class as X (MonadIO (..))
import Data.Algebra as X
@ -56,7 +54,7 @@ import Data.Traversable as X
import Data.Typeable as X (Typeable)
-- Generics
import GHC.Generics as X hiding (moduleName)
import GHC.Generics as X (Generic, Generic1)
import GHC.Stack as X
-- | Fold a collection by mapping each element onto an 'Alternative' action.

View File

@ -8,9 +8,9 @@ module Rendering.Graph
import Algebra.Graph.Export.Dot
import Analysis.ConstructorName
import Control.Monad.Effect
import Control.Monad.Effect.Fresh
import Control.Monad.Effect.Reader
import Control.Effect
import Control.Effect.Fresh
import Control.Effect.Reader
import Data.Diff
import Data.Graph
import Data.Graph.TermVertex
@ -25,8 +25,11 @@ import Prologue
renderTreeGraph :: (Ord vertex, Recursive t, ToTreeGraph vertex (Base t)) => t -> Graph vertex
renderTreeGraph = simplify . runGraph . cata toTreeGraph
runGraph :: Eff '[Reader (Graph vertex), Fresh] (Graph vertex) -> Graph vertex
runGraph = run . runFresh 0 . runReader mempty
runGraph :: Eff (ReaderC (Graph vertex)
(Eff (FreshC
(Eff VoidC)))) (Graph vertex)
-> Graph vertex
runGraph = run . runFresh . runReader mempty
-- | GraphViz styling for terms
termStyle :: (IsString string, Monoid string) => String -> Style TermVertex string
@ -48,7 +51,7 @@ diffStyle name = (defaultStyle (fromString . show . diffVertexId))
vertexAttributes (DiffVertex _ (Merged MergedTerm{..})) = [ "label" := fromString mergedTermName ]
class ToTreeGraph vertex t | t -> vertex where
toTreeGraph :: (Member Fresh effs, Member (Reader (Graph vertex)) effs) => t (Eff effs (Graph vertex)) -> Eff effs (Graph vertex)
toTreeGraph :: (Member Fresh sig, Member (Reader (Graph vertex)) sig, Carrier sig m, Monad m) => t (m (Graph vertex)) -> m (Graph vertex)
instance (ConstructorName syntax, Foldable syntax) =>
ToTreeGraph TermVertex (TermF syntax Location) where
@ -56,11 +59,13 @@ instance (ConstructorName syntax, Foldable syntax) =>
termAlgebra ::
( ConstructorName syntax
, Foldable syntax
, Member Fresh effs
, Member (Reader (Graph TermVertex)) effs
, Member Fresh sig
, Member (Reader (Graph TermVertex)) sig
, Carrier sig m
, Monad m
)
=> TermF syntax Location (Eff effs (Graph TermVertex))
-> Eff effs (Graph TermVertex)
=> TermF syntax Location (m (Graph TermVertex))
-> m (Graph TermVertex)
termAlgebra (In ann syntax) = do
i <- fresh
parent <- ask
@ -86,9 +91,11 @@ instance (ConstructorName syntax, Foldable syntax) =>
ann a = TermAnnotation (locationByteRange a) (locationSpan a)
diffAlgebra ::
( Foldable f
, Member Fresh effs
, Member (Reader (Graph DiffVertex)) effs
) => f (Eff effs (Graph DiffVertex)) -> DiffVertexTerm -> Eff effs (Graph DiffVertex)
, Member Fresh sig
, Member (Reader (Graph DiffVertex)) sig
, Carrier sig m
, Monad m
) => f (m (Graph DiffVertex)) -> DiffVertexTerm -> m (Graph DiffVertex)
diffAlgebra syntax a = do
i <- fresh
parent <- ask

View File

@ -103,9 +103,9 @@ module Reprinting.Pipeline
, runTranslating
) where
import Control.Monad.Effect as Effect
import qualified Control.Monad.Effect.Exception as Exc
import Control.Monad.Effect.State
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
@ -132,7 +132,7 @@ runReprinter :: Tokenize a
runReprinter src translating tree
= fmap go
. Effect.run
. Exc.runError
. Effect.runError
. fmap snd
. runState (mempty :: [Scope])
. foldT $ source (tokenizing src tree)
@ -156,7 +156,7 @@ runContextualizing :: Tokenize a
-> Either TranslationError [Fragment]
runContextualizing src tree
= Effect.run
. Exc.runError
. Effect.runError
. fmap snd
. runState (mempty :: [Scope])
. runT $ source (tokenizing src tree)
@ -169,7 +169,7 @@ runTranslating :: Tokenize a
-> Either TranslationError [Splice]
runTranslating src translating tree
= Effect.run
. Exc.runError
. Effect.runError
. fmap snd
. runState (mempty :: [Scope])
. runT $ source (tokenizing src tree)

View File

@ -6,10 +6,9 @@ module Reprinting.Translate
) where
import Control.Monad
import Control.Monad.Effect
import Control.Monad.Effect.Exception (Exc)
import qualified Control.Monad.Effect.Exception as Exc
import Control.Monad.Effect.State
import Control.Effect
import Control.Effect.Error
import Control.Effect.State
import Control.Monad.Trans
import Data.Machine
@ -19,7 +18,10 @@ import Data.Reprinting.Token
import Data.Reprinting.Scope
import qualified Data.Source as Source
type Translator = Eff '[State [Scope], Exc TranslationError]
type Translator
= Eff (StateC [Scope]
( Eff (ErrorC TranslationError
( Eff VoidC))))
contextualizing :: ProcessT Translator Token Fragment
contextualizing = repeatedly $ await >>= \case
@ -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)))
cs -> lift (Exc.throwError (UnbalancedPair c cs))
(x:xs) -> when (x == c) (lift (modify (const xs)))
cs -> lift (throwError (UnbalancedPair c cs))

View File

@ -7,12 +7,13 @@ module Semantic.AST
, runASTParse
) where
import Prologue hiding (catchError)
import Prologue
import Data.ByteString.Builder
import Data.List (intersperse)
import Control.Monad.Effect.Exception
import Control.Effect
import Control.Effect.Error
import Data.AST
import Data.Blob
import Parsing.Parser
@ -26,7 +27,7 @@ data SomeAST where
withSomeAST :: (forall grammar . Show grammar => AST [] grammar -> a) -> SomeAST -> a
withSomeAST f (SomeAST ast) = f ast
astParseBlob :: (Member (Exc SomeException) effs, Member Task effs) => Blob -> Eff effs SomeAST
astParseBlob :: (Member (Error SomeException) sig, Member Task sig, Carrier sig m, Functor m) => Blob -> m SomeAST
astParseBlob blob@Blob{..}
| Just (SomeASTParser parser) <- someASTParser blobLanguage = SomeAST <$> parse parser blob
| otherwise = noLanguageForBlob blobPath
@ -35,12 +36,7 @@ astParseBlob blob@Blob{..}
data ASTFormat = SExpression | JSON | Show | Quiet
deriving (Show)
runASTParse :: ( Member (Lift IO) effects
, Member Distribute effects
, Member (Exc SomeException) effects
, Member Task effects
)
=> ASTFormat -> [Blob] -> Eff effects F.Builder
runASTParse :: (Member Distribute sig, Member (Error SomeException) sig, Member Task sig, Carrier sig m, MonadIO m) => ASTFormat -> [Blob] -> m F.Builder
runASTParse SExpression = distributeFoldMap (astParseBlob >=> withSomeAST (serialize (F.SExpression F.ByShow)))
runASTParse Show = distributeFoldMap (astParseBlob >=> withSomeAST (serialize F.Show . fmap nodeSymbol))
runASTParse JSON = distributeFoldMap (\ blob -> astParseBlob blob >>= withSomeAST (render (renderJSONAST blob))) >=> serialize F.JSON

131
src/Semantic/Analysis.hs Normal file
View File

@ -0,0 +1,131 @@
{-# LANGUAGE TypeFamilies, TypeOperators #-}
module Semantic.Analysis
( evaluate
, evalTerm
) where
import Control.Abstract
import Control.Effect.Interpose
import Data.Abstract.Environment as Env
import Data.Abstract.Evaluatable
import Data.Abstract.Module
import Data.Abstract.ModuleTable as ModuleTable
import Data.Function
import Prologue
type ModuleC address value m
= ErrorC (LoopControl address) (Eff
( ErrorC (Return address) (Eff
( EnvC address (Eff
( ScopeEnvC address (Eff
( DerefC address value (Eff
( AllocatorC address (Eff
( ReaderC ModuleInfo (Eff
m)))))))))))))
type ValueC term address value m
= FunctionC term address value (Eff
( WhileC value (Eff
( BooleanC value (Eff
( InterposeC (Resumable (BaseError (UnspecializedError value))) (Eff
m)))))))
-- | Evaluate a list of modules with the prelude for the passed language available, and applying the passed function to every module.
evaluate :: ( AbstractValue term address value (ValueC term address value inner)
, Carrier innerSig inner
, Carrier outerSig outer
, derefSig ~ (Deref value :+: allocatorSig)
, derefC ~ (DerefC address value (Eff allocatorC))
, Carrier derefSig derefC
, allocatorSig ~ (Allocator address :+: Reader ModuleInfo :+: outerSig)
, allocatorC ~ (AllocatorC address (Eff (ReaderC ModuleInfo (Eff outer))))
, Carrier allocatorSig allocatorC
, booleanC ~ BooleanC value (Eff (InterposeC (Resumable (BaseError (UnspecializedError value))) (Eff inner)))
, booleanSig ~ (Boolean value :+: Interpose (Resumable (BaseError (UnspecializedError value))) :+: innerSig)
, Carrier booleanSig booleanC
, whileC ~ WhileC value (Eff booleanC)
, whileSig ~ (While value :+: booleanSig)
, Carrier whileSig whileC
, functionC ~ FunctionC term address value (Eff whileC)
, functionSig ~ (Function term address value :+: whileSig)
, Carrier functionSig functionC
, Effect outerSig
, HasPrelude lang
, Member Fresh outerSig
, Member (Allocator address) innerSig
, Member (Deref value) innerSig
, Member (Env address) innerSig
, Member Fresh innerSig
, Member (Reader ModuleInfo) innerSig
, Member (Reader (ModuleTable (NonEmpty (Module (ModuleResult address))))) outerSig
, Member (Reader Span) innerSig
, Member (Resumable (BaseError (AddressError address value))) innerSig
, Member (Resumable (BaseError (EnvironmentError address))) innerSig
, Member (Resumable (BaseError (UnspecializedError value))) innerSig
, Member (State (Heap address value)) innerSig
, Member Trace innerSig
, Ord address
)
=> proxy lang
-> ( (Module (Either (proxy lang) term) -> Evaluator term address value inner address)
-> (Module (Either (proxy lang) term) -> Evaluator term address value (ModuleC address value outer) address))
-> (term -> Evaluator term address value (ValueC term address value inner) address)
-> [Module term]
-> Evaluator term address value outer (ModuleTable (NonEmpty (Module (ModuleResult address))))
evaluate lang perModule runTerm modules = do
let prelude = Module moduleInfoFromCallStack (Left lang)
(_, (preludeBinds, _)) <- evalModule lowerBound prelude
foldr (run preludeBinds . fmap Right) ask modules
where run prelude m rest = do
evaluated <- evalModule prelude m
-- FIXME: this should be some sort of Monoidal insert à la the Heap to accommodate multiple Go files being part of the same module.
local (ModuleTable.insert (modulePath (moduleInfo m)) ((evaluated <$ m) :| [])) rest
evalModule prelude m = runInModule (perModule (runValueEffects . moduleBody) m)
where runInModule
= raiseHandler (runReader (moduleInfo m))
. runAllocator
. runDeref
. runScopeEnv
. runEnv (EvalContext Nothing (Env.push (newEnv prelude)))
. runReturn
. runLoopControl
runValueEffects = raiseHandler runInterpose . runBoolean . runWhile . runFunction runTerm . either ((*> box unit) . definePrelude) runTerm
-- | Evaluate a term recursively, applying the passed function at every recursive position.
--
-- This calls out to the 'Evaluatable' instances, will be passed to 'runValueEffects', and can have other functions composed after it to e.g. intercept effects arising in the evaluation of the term.
evalTerm :: ( Carrier sig m
, Declarations term
, Evaluatable (Base term)
, FreeVariables term
, AbstractValue term address value m
, Member (Allocator address) sig
, Member (Boolean value) sig
, Member (Deref value) sig
, Member (Env address) sig
, Member (Error (LoopControl address)) sig
, Member (Error (Return address)) sig
, Member Fresh sig
, Member (Function term address value) sig
, Member (Modules address) sig
, Member (Reader ModuleInfo) sig
, Member (Reader PackageInfo) sig
, Member (Reader Span) sig
, Member (Resumable (BaseError (AddressError address value))) sig
, Member (Resumable (BaseError (EnvironmentError address))) sig
, Member (Resumable (BaseError EvalError)) sig
, Member (Resumable (BaseError ResolutionError)) sig
, Member (Resumable (BaseError (UnspecializedError value))) sig
, Member (ScopeEnv address) sig
, Member (State (Heap address value)) sig
, Member (State Span) sig
, Member Trace sig
, Member (While value) sig
, Ord address
, Recursive term
)
=> Open (Open (term -> Evaluator term address value m (ValueRef address)))
-> term -> Evaluator term address value m address
evalTerm perTerm = fix (perTerm (\ ev -> eval ev . project)) >=> address

View File

@ -6,6 +6,8 @@ module Semantic.Diff
import Analysis.ConstructorName (ConstructorName)
import Analysis.Declaration (HasDeclaration, declarationAlgebra)
import Control.Effect
import Control.Monad.IO.Class
import Data.Blob
import Data.Diff
import Data.JSON.Fields
@ -14,7 +16,7 @@ import Data.Term
import Data.Graph.DiffVertex
import Diffing.Algorithm (Diffable)
import Parsing.Parser
import Prologue hiding (MonadError(..))
import Prologue
import Rendering.Graph
import Rendering.Renderer
import Semantic.Telemetry as Stat
@ -24,7 +26,7 @@ import Rendering.JSON (SomeJSON (..))
import qualified Rendering.JSON as JSON
-- | Using the specified renderer, diff a list of 'BlobPair's to produce a 'Builder' output.
runDiff :: (Member Distribute effs, Member (Exc SomeException) effs, Member (Lift IO) effs, Member Task effs, Member Telemetry effs) => DiffRenderer output -> [BlobPair] -> Eff effs Builder
runDiff :: (Member Distribute sig, Member (Error SomeException) sig, Member Task sig, Member Telemetry sig, MonadIO m, Carrier sig m) => DiffRenderer output -> [BlobPair] -> m Builder
runDiff ToCDiffRenderer = withParsedBlobPairs (decorate . declarationAlgebra) (render . renderToCDiff) >=> serialize JSON
runDiff JSONDiffRenderer = withParsedBlobPairs (const pure) (render . renderJSONDiff) >=> serialize JSON
runDiff JSONGraphDiffRenderer = withParsedBlobPairs (const pure) (render . renderAdjGraph) >=> serialize JSON
@ -40,28 +42,28 @@ data SomeTermPair typeclasses ann where
withSomeTermPair :: (forall syntax . ApplyAll typeclasses syntax => Join These (Term syntax ann) -> a) -> SomeTermPair typeclasses ann -> a
withSomeTermPair with (SomeTermPair terms) = with terms
diffBlobTOCPairs :: (Member Distribute effs, Member (Exc SomeException) effs, Member (Lift IO) effs, Member Task effs, Member Telemetry effs) => [BlobPair] -> Eff effs ([TOCSummary], [TOCSummary])
diffBlobTOCPairs :: (Member Distribute sig, Member (Error SomeException) sig, Member Task sig, Member Telemetry sig, MonadIO m, Carrier sig m) => [BlobPair] -> m ([TOCSummary], [TOCSummary])
diffBlobTOCPairs = withParsedBlobPairs (decorate . declarationAlgebra) (render . renderRPCToCDiff)
type CanDiff syntax = (ConstructorName syntax, Diffable syntax, Eq1 syntax, HasDeclaration syntax, Hashable1 syntax, Show1 syntax, ToJSONFields1 syntax, Traversable syntax)
type Decorate effs a b = forall syntax . CanDiff syntax => Blob -> Term syntax a -> Eff effs (Term syntax b)
type Decorate m a b = forall syntax . CanDiff syntax => Blob -> Term syntax a -> m (Term syntax b)
withParsedBlobPairs :: (Member Distribute effs, Member (Exc SomeException) effs, Member (Lift IO) effs, Member Task effs, Member Telemetry effs, Monoid output)
=> Decorate effs Location ann
-> (forall syntax . CanDiff syntax => BlobPair -> Diff syntax ann ann -> Eff effs output)
withParsedBlobPairs :: (Member Distribute sig, Member (Error SomeException) sig, Member Task sig, Member Telemetry sig, MonadIO m, Monoid output, Carrier sig m)
=> Decorate m Location ann
-> (forall syntax . CanDiff syntax => BlobPair -> Diff syntax ann ann -> m output)
-> [BlobPair]
-> Eff effs output
-> m output
withParsedBlobPairs decorate render = distributeFoldMap (\ blobs -> withParsedBlobPair decorate blobs >>= withSomeTermPair (diffTerms blobs >=> render blobs))
where diffTerms :: (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax, Member (Lift IO) effs, Member Task effs, Member Telemetry effs) => BlobPair -> Join These (Term syntax ann) -> Eff effs (Diff syntax ann ann)
where diffTerms :: (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax, Member Task sig, Member Telemetry sig, Carrier sig m, MonadIO m) => BlobPair -> Join These (Term syntax ann) -> m (Diff syntax ann ann)
diffTerms blobs terms = time "diff" languageTag $ do
diff <- diff (runJoin terms)
diff <$ writeStat (Stat.count "diff.nodes" (bilength diff) languageTag)
where languageTag = languageTagForBlobPair blobs
withParsedBlobPair :: (Member Distribute effs, Member (Exc SomeException) effs, Member Task effs)
=> Decorate effs Location ann
withParsedBlobPair :: (Member Distribute sig, Member (Error SomeException) sig, Member Task sig, Carrier sig m, Monad m)
=> Decorate m Location ann
-> BlobPair
-> Eff effs (SomeTermPair '[ConstructorName, Diffable, Eq1, HasDeclaration, Hashable1, Show1, ToJSONFields1, Traversable] ann)
-> m (SomeTermPair '[ConstructorName, Diffable, Eq1, HasDeclaration, Hashable1, Show1, ToJSONFields1, Traversable] ann)
withParsedBlobPair decorate blobs
| Just (SomeParser parser) <- someParser @'[ConstructorName, Diffable, Eq1, HasDeclaration, Hashable1, Show1, ToJSONFields1, Traversable] (languageForBlobPair blobs)
= SomeTermPair <$> distributeFor blobs (\ blob -> parse parser blob >>= decorate blob)

View File

@ -1,44 +1,60 @@
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ExistentialQuantification, TypeOperators, UndecidableInstances #-}
module Semantic.Distribute
( distribute
, distributeFor
, distributeFoldMap
, Distribute
, runDistribute
, DistributeC(..)
) where
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.Effect
import Prologue hiding (MonadError (..))
import Prologue
-- | Distribute a 'Traversable' container of tasks over the available cores (i.e. execute them concurrently), collecting their results.
--
-- This is a concurrent analogue of 'sequenceA'.
distribute :: (Member Distribute effs, Traversable t) => t (Eff effs output) -> Eff effs (t output)
distribute = fmap (withStrategy (parTraversable rseq)) <$> traverse (send . Distribute)
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 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.
--
-- This is a concurrent analogue of 'for' or 'traverse' (with the arguments flipped).
distributeFor :: (Member Distribute effs, Traversable t) => t a -> (a -> Eff effs output) -> Eff effs (t output)
distributeFor :: (Member Distribute sig, Traversable t, Carrier sig m, Applicative m) => t a -> (a -> m output) -> m (t output)
distributeFor inputs toTask = distribute (fmap toTask inputs)
-- | 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), combining the results 'Monoid'ally into a final value.
--
-- This is a concurrent analogue of 'foldMap'.
distributeFoldMap :: (Member Distribute effs, Monoid output, Traversable t) => (a -> Eff effs output) -> t a -> Eff effs output
distributeFoldMap :: (Member Distribute sig, Monoid output, Traversable t, Carrier sig m, Applicative m) => (a -> m output) -> t a -> m output
distributeFoldMap toTask inputs = fmap fold (distribute (fmap toTask inputs))
-- | Distribute effects run tasks concurrently.
newtype Distribute task output = Distribute (task output)
data Distribute m k
= forall a . Distribute (m a) (a -> k)
deriving instance Functor (Distribute m)
instance HFunctor Distribute where
hmap f (Distribute m k) = Distribute (f m) k
instance PureEffect Distribute
instance Effect Distribute where
handleState c dist (Request (Distribute task) k) = Request (Distribute (dist (task <$ c))) (dist . fmap k)
handle state handler (Distribute task k) = Distribute (handler (task <$ state)) (handler . fmap k)
-- | Evaluate a 'Distribute' effect concurrently.
runDistribute :: Eff '[Distribute, Lift IO] a -> Eff '[Lift IO] a
runDistribute = interpret (\ (Distribute task) -> liftIO (Async.runConcurrently (Async.Concurrently (runM (runDistribute task)))))
runDistribute :: Eff (DistributeC (Eff (LiftC IO))) a -> Eff (LiftC IO) a
runDistribute = runDistributeC . interpret
newtype DistributeC m a = DistributeC { runDistributeC :: m a }
instance Carrier (Distribute :+: Lift IO) (DistributeC (Eff (LiftC IO))) where
ret = DistributeC . ret
eff = DistributeC . handleSum
(eff . handleCoercible)
(\ (Distribute task k) -> liftIO (Async.runConcurrently (Async.Concurrently (runM (runDistributeC task)))) >>= runDistributeC . k)

View File

@ -10,6 +10,7 @@ module Semantic.Graph
, ControlFlowVertex
, style
, runHeap
, runModuleTable
, parsePackage
, parsePythonPackage
, withTermSpans
@ -42,7 +43,7 @@ import qualified Data.Abstract.ModuleTable as ModuleTable
import Data.Abstract.Package as Package
import Data.Abstract.Value.Abstract as Abstract
import Data.Abstract.Value.Concrete as Concrete
(Value, ValueError (..), runWhile, runBoolean, runFunction, runValueErrorWith)
(Value, ValueError (..), runValueErrorWith)
import Data.Abstract.Value.Type as Type
import Data.Blob
import Data.File
@ -57,7 +58,8 @@ import Data.Text (pack, unpack)
import Language.Haskell.HsColour
import Language.Haskell.HsColour.Colourise
import Parsing.Parser
import Prologue hiding (MonadError (..), TypeError (..))
import Prologue hiding (TypeError (..))
import Semantic.Analysis
import Semantic.Task as Task
import System.FilePath.Posix (takeDirectory, (</>))
import Text.Show.Pretty (ppShow)
@ -66,11 +68,11 @@ data GraphType = ImportGraph | CallGraph
type AnalysisClasses = '[ Declarations1, Eq1, Evaluatable, FreeVariables1, Foldable, Functor, Ord1, Show1 ]
runGraph :: forall effs. (Member Distribute effs, Member (Exc SomeException) effs, Member Resolution effs, Member Task effs, Member Trace effs, Effects effs)
runGraph :: (Member Distribute sig, Member (Error SomeException) sig, Member Resolution sig, Member Task sig, Member Trace sig, Carrier sig m, Effect sig)
=> GraphType
-> Bool
-> Project
-> Eff effs (Graph ControlFlowVertex)
-> Eff m (Graph ControlFlowVertex)
runGraph ImportGraph _ project
| SomeAnalysisParser parser (lang' :: Proxy lang) <- someAnalysisParser (Proxy :: Proxy AnalysisClasses) (projectLanguage project) = do
let parse = if projectLanguage project == Language.Python then parsePythonPackage parser else fmap (fmap snd) . parsePackage parser
@ -89,58 +91,60 @@ runCallGraph :: ( VertexDeclarationWithStrategy (VertexDeclarationStrategy synta
, Functor syntax
, Evaluatable syntax
, term ~ Term syntax Location
, FreeVariables term
, Recursive term
, FreeVariables1 syntax
, HasPrelude lang
, HasPostlude lang
, Member Trace effs
, Effects effs
, Member Trace sig
, Carrier sig m
, Effect sig
)
=> Proxy lang
-> Bool
-> [Module term]
-> Package term
-> Eff effs (Graph ControlFlowVertex)
runCallGraph lang includePackages modules package = do
let analyzeTerm = withTermSpans . graphingTerms . cachingTerms
analyzeModule = (if includePackages then graphingPackages else id) . convergingModules . graphingModules
extractGraph (graph, _) = simplify graph
runGraphAnalysis
= graphing @_ @_ @(Maybe Name) @Monovariant
. runHeap
. caching
. runFresh 0
. resumingLoadError
. resumingUnspecialized
. resumingEnvironmentError
. resumingEvalError
. resumingResolutionError
. resumingAddressError
. runReader (packageInfo package)
. runReader (lowerBound @Span)
. runState (lowerBound @Span)
. runReader (lowerBound @ControlFlowVertex)
. providingLiveSet
. runReader (lowerBound @(ModuleTable (NonEmpty (Module (ModuleResult (Hole (Maybe Name) (Located Monovariant)))))))
. runModules (ModuleTable.modulePaths (packageModules package))
runAddressEffects
= Hole.runAllocator (Located.handleAllocator Monovariant.handleAllocator)
. Hole.runDeref (Located.handleDeref Monovariant.handleDeref)
extractGraph <$> runEvaluator (runGraphAnalysis (evaluate lang analyzeModule analyzeTerm runAddressEffects (fmap (Abstract.runBoolean . Abstract.runWhile) . Abstract.runFunction) modules))
-> Eff m (Graph ControlFlowVertex)
runCallGraph lang includePackages modules package
= fmap (simplify . fst)
. runEvaluator
. graphing @_ @_ @_ @(Hole (Maybe Name) (Located Monovariant)) @Abstract
. runHeap
. caching
. raiseHandler runFresh
. resumingLoadError
. resumingUnspecialized
. resumingEnvironmentError
. resumingEvalError
. resumingResolutionError
. resumingAddressError
. raiseHandler (runReader (packageInfo package))
. raiseHandler (runReader (lowerBound @Span))
. raiseHandler (runState (lowerBound @Span))
. raiseHandler (runReader (lowerBound @ControlFlowVertex))
. providingLiveSet
. runModuleTable
. runModules (ModuleTable.modulePaths (packageModules package))
$ evaluate lang perModule perTerm modules
where perTerm = evalTerm (withTermSpans . graphingTerms . cachingTerms)
perModule = (if includePackages then graphingPackages else id) . convergingModules . graphingModules
runModuleTable :: Carrier sig m
=> Evaluator term address value (ReaderC (ModuleTable (NonEmpty (Module (ModuleResult address)))) (Eff m)) a
-> Evaluator term address value m a
runModuleTable = raiseHandler $ runReader lowerBound
runImportGraphToModuleInfos :: ( Declarations term
, Evaluatable (Base term)
, FreeVariables term
, HasPrelude lang
, HasPostlude lang
, Member Trace effs
, Member Trace sig
, Recursive term
, Effects effs
, Carrier sig m
, Show term
, Effect sig
)
=> Proxy lang
-> Package term
-> Eff effs (Graph ControlFlowVertex)
-> Eff m (Graph ControlFlowVertex)
runImportGraphToModuleInfos lang (package :: Package term) = runImportGraph lang package allModuleInfos
where allModuleInfos info = maybe (vertex (unknownModuleVertex info)) (foldMap (vertex . moduleVertex . moduleInfo)) (ModuleTable.lookup (modulePath info) (packageModules package))
@ -148,15 +152,15 @@ runImportGraphToModules :: ( Declarations term
, Evaluatable (Base term)
, FreeVariables term
, HasPrelude lang
, HasPostlude lang
, Member Trace effs
, Member Trace sig
, Recursive term
, Effects effs
, Carrier sig m
, Show term
, Effect sig
)
=> Proxy lang
-> Package term
-> Eff effs (Graph (Module term))
-> Eff m (Graph (Module term))
runImportGraphToModules lang (package :: Package term) = runImportGraph lang package resolveOrLowerBound
where resolveOrLowerBound info = maybe lowerBound (foldMap vertex) (ModuleTable.lookup (modulePath info) (packageModules package))
@ -164,49 +168,45 @@ runImportGraph :: ( Declarations term
, Evaluatable (Base term)
, FreeVariables term
, HasPrelude lang
, HasPostlude lang
, Member Trace effs
, Member Trace sig
, Recursive term
, Effects effs
, Carrier sig m
, Show term
, Effect sig
)
=> Proxy lang
-> Package term
-> (ModuleInfo -> Graph vertex)
-> Eff effs (Graph vertex)
runImportGraph lang (package :: Package term) f =
let analyzeModule = graphingModuleInfo
extractGraph (graph, _) = graph >>= f
runImportGraphAnalysis
= runState lowerBound
. runHeap
. runFresh 0
. resumingLoadError
. resumingUnspecialized
. resumingEnvironmentError
. resumingEvalError
. resumingResolutionError
. resumingAddressError
. resumingValueError
. runReader (lowerBound @(ModuleTable (NonEmpty (Module (ModuleResult (Hole (Maybe Name) Precise))))))
. runModules (ModuleTable.modulePaths (packageModules package))
. runReader (packageInfo package)
. runState (lowerBound @Span)
. runReader (lowerBound @Span)
runAddressEffects
= Hole.runAllocator Precise.handleAllocator
. Hole.runDeref Precise.handleDeref
in extractGraph <$> runEvaluator @_ @_ @(Value _ (Hole (Maybe Name) Precise)) (runImportGraphAnalysis (evaluate lang analyzeModule id runAddressEffects (fmap (Concrete.runBoolean . Concrete.runWhile) . Concrete.runFunction) (ModuleTable.toPairs (packageModules package) >>= toList . snd)))
-> Eff m (Graph vertex)
runImportGraph lang (package :: Package term) f
= fmap (fst >=> f)
. runEvaluator @_ @_ @(Value _ (Hole (Maybe Name) Precise))
. raiseHandler (runState lowerBound)
. runHeap
. raiseHandler runFresh
. resumingLoadError
. resumingUnspecialized
. resumingEnvironmentError
. resumingEvalError
. resumingResolutionError
. resumingAddressError
. resumingValueError
. runModuleTable
. runModules (ModuleTable.modulePaths (packageModules package))
. raiseHandler (runReader (packageInfo package))
. raiseHandler (runState (lowerBound @Span))
. raiseHandler (runReader (lowerBound @Span))
$ evaluate lang graphingModuleInfo (evalTerm id) (ModuleTable.toPairs (packageModules package) >>= toList . snd)
runHeap :: Effects effects => Evaluator term address value (State (Heap address value) ': effects) a -> Evaluator term address value effects (Heap address value, a)
runHeap = runState lowerBound
runHeap :: (Carrier sig m, Effect sig) => Evaluator term address value (StateC (Heap address value) (Eff m)) a -> Evaluator term address value m (Heap address value, a)
runHeap = raiseHandler (runState lowerBound)
-- | Parse a list of files into a 'Package'.
parsePackage :: (Member Distribute effs, Member (Exc SomeException) effs, Member Resolution effs, Member Task effs, Member Trace effs)
parsePackage :: (Member Distribute sig, Member (Error SomeException) sig, Member Resolution sig, Member Task sig, Member Trace sig, Carrier sig m, Monad m)
=> Parser term -- ^ A parser.
-> Project -- ^ Project to parse into a package.
-> Eff effs (Package (Blob, term))
-> m (Package (Blob, term))
parsePackage parser project = do
p <- parseModules parser project
resMap <- Task.resolutionMap project
@ -217,31 +217,33 @@ parsePackage parser project = do
n = name (projectName project)
-- | Parse all files in a project into 'Module's.
parseModules :: (Member Distribute effs, Member (Exc SomeException) effs, Member Task effs) => Parser term -> Project -> Eff effs [Module (Blob, term)]
parseModules :: (Member Distribute sig, Member (Error SomeException) sig, Member Task sig, Carrier sig m, Monad m) => Parser term -> Project -> m [Module (Blob, term)]
parseModules parser p@Project{..} = distributeFor (projectFiles p) (parseModule p parser)
-- | Parse a list of packages from a python project.
parsePythonPackage :: forall syntax effs term.
parsePythonPackage :: forall syntax sig m term.
( Declarations1 syntax
, Evaluatable syntax
, FreeVariables1 syntax
, Functor syntax
, term ~ Term syntax Location
, Member (Exc SomeException) effs
, Member Distribute effs
, Member Resolution effs
, Member Trace effs
, Member Task effs
, Effects effs)
=> Parser term -- ^ A parser.
-> Project -- ^ Project to parse into a package.
-> Eff effs (Package term)
, Member (Error SomeException) sig
, Member Distribute sig
, Member Resolution sig
, Member Trace sig
, Member Task sig
, Carrier sig m
, Effect sig
)
=> Parser term -- ^ A parser.
-> Project -- ^ Project to parse into a package.
-> Eff m (Package term)
parsePythonPackage parser project = do
let runAnalysis = runEvaluator @_ @_ @(Value term (Hole (Maybe Name) Precise))
. runState PythonPackage.Unknown
. runState (lowerBound @(Heap (Hole (Maybe Name) Precise) (Value term (Hole (Maybe Name) Precise))))
. runFresh 0
. raiseHandler (runState PythonPackage.Unknown)
. raiseHandler (runState (lowerBound @(Heap (Hole (Maybe Name) Precise) (Value term (Hole (Maybe Name) Precise)))))
. raiseHandler runFresh
. resumingLoadError
. resumingUnspecialized
. resumingEnvironmentError
@ -249,19 +251,16 @@ parsePythonPackage parser project = do
. resumingResolutionError
. resumingAddressError
. resumingValueError
. runReader (lowerBound @(ModuleTable (NonEmpty (Module (ModuleResult (Hole (Maybe Name) Precise))))))
. runModuleTable
. runModules lowerBound
. runReader (PackageInfo (name "setup") lowerBound)
. runState (lowerBound @Span)
. runReader (lowerBound @Span)
runAddressEffects
= Hole.runAllocator Precise.handleAllocator
. Hole.runDeref Precise.handleDeref
. raiseHandler (runReader (PackageInfo (name "setup") lowerBound))
. raiseHandler (runState (lowerBound @Span))
. raiseHandler (runReader (lowerBound @Span))
strat <- case find ((== (projectRootDir project </> "setup.py")) . filePath) (projectFiles project) of
Just setupFile -> do
setupModule <- fmap snd <$> parseModule project parser setupFile
fst <$> runAnalysis (evaluate (Proxy @'Language.Python) id id runAddressEffects (\ eval -> Concrete.runBoolean . Concrete.runWhile . Concrete.runFunction eval . runPythonPackaging) [ setupModule ])
fst <$> runAnalysis (evaluate (Proxy @'Language.Python) id (runPythonPackaging . evalTerm id) [ setupModule ])
Nothing -> pure PythonPackage.Unknown
case strat of
PythonPackage.Unknown -> do
@ -289,53 +288,57 @@ parsePythonPackage parser project = do
resMap <- Task.resolutionMap p
pure (Package.fromModules (name $ projectName p) modules resMap)
parseModule :: (Member (Exc SomeException) effs, Member Task effs)
parseModule :: (Member (Error SomeException) sig, Member Task sig, Carrier sig m, Monad m)
=> Project
-> Parser term
-> File
-> Eff effs (Module (Blob, term))
-> m (Module (Blob, term))
parseModule proj parser file = do
mBlob <- readFile proj file
case mBlob of
Just blob -> moduleForBlob (Just (projectRootDir proj)) blob . (,) blob <$> parse parser blob
Nothing -> throwError (SomeException (FileNotFound (filePath file)))
withTermSpans :: ( Member (Reader Span) effects
, Member (State Span) effects -- last evaluated child's span
withTermSpans :: ( Member (Reader Span) sig
, Member (State Span) sig -- last evaluated child's span
, Recursive term
, Carrier sig m
, Base term ~ TermF syntax Location
)
=> Open (Open (term -> Evaluator term address value effects a))
=> Open (Open (term -> Evaluator term address value m a))
withTermSpans recur0 recur term = let
span = locationSpan (termFAnnotation (project term))
updatedSpanAlg = withCurrentSpan span (recur0 recur term)
in modifyChildSpan span updatedSpanAlg
resumingResolutionError :: ( Member Trace effects
, Effects effects
resumingResolutionError :: ( Member Trace sig
, Carrier sig m
)
=> Evaluator term address value (Resumable (BaseError ResolutionError) ': effects) a
-> Evaluator term address value effects a
=> Evaluator term address value (ResumableWithC (BaseError ResolutionError) (Eff
m)) a
-> Evaluator term address value m a
resumingResolutionError = runResolutionErrorWith (\ baseError -> traceError "ResolutionError" baseError *> case baseErrorException baseError of
NotFoundError nameToResolve _ _ -> pure nameToResolve
GoImportError pathToResolve -> pure [pathToResolve])
resumingLoadError :: ( AbstractHole address
, Effects effects
, Member Trace effects
, Carrier sig m
, Member Trace sig
, Ord address
)
=> Evaluator term address value (Resumable (BaseError (LoadError address)) ': effects) a
-> Evaluator term address value effects a
=> Evaluator term address value (ResumableWithC (BaseError (LoadError address)) (Eff
m)) a
-> Evaluator term address value m a
resumingLoadError = runLoadErrorWith (\ baseError -> traceError "LoadError" baseError *> case baseErrorException baseError of
ModuleNotFoundError _ -> pure (lowerBound, (lowerBound, hole)))
resumingEvalError :: ( Effects effects
, Member Fresh effects
, Member Trace effects
resumingEvalError :: ( Carrier sig m
, Member Fresh sig
, Member Trace sig
)
=> Evaluator term address value (Resumable (BaseError EvalError) ': effects) a
-> Evaluator term address value effects a
=> Evaluator term address value (ResumableWithC (BaseError EvalError) (Eff
m)) a
-> Evaluator term address value m a
resumingEvalError = runEvalErrorWith (\ baseError -> traceError "EvalError" baseError *> case baseErrorException baseError of
DefaultExportError{} -> pure ()
ExportError{} -> pure ()
@ -345,32 +348,35 @@ resumingEvalError = runEvalErrorWith (\ baseError -> traceError "EvalError" base
NoNameError -> gensym)
resumingUnspecialized :: ( AbstractHole value
, Effects effects
, Member Trace effects
, Carrier sig m
, Member Trace sig
)
=> Evaluator term address value (Resumable (BaseError (UnspecializedError value)) ': effects) a
-> Evaluator term address value effects a
=> Evaluator term address value (ResumableWithC (BaseError (UnspecializedError value)) (Eff
m)) a
-> Evaluator term address value m a
resumingUnspecialized = runUnspecializedWith (\ baseError -> traceError "UnspecializedError" baseError *> case baseErrorException baseError of
UnspecializedError _ -> pure hole)
resumingAddressError :: ( AbstractHole value
, Effects effects
, Member Trace effects
, Carrier sig m
, Member Trace sig
, Show address
)
=> Evaluator term address value (Resumable (BaseError (AddressError address value)) ': effects) a
-> Evaluator term address value effects a
=> Evaluator term address value (ResumableWithC (BaseError (AddressError address value)) (Eff
m)) a
-> Evaluator term address value m a
resumingAddressError = runAddressErrorWith $ \ baseError -> traceError "AddressError" baseError *> case baseErrorException baseError of
UnallocatedAddress _ -> pure lowerBound
UninitializedAddress _ -> pure hole
resumingValueError :: ( Effects effects
, Member Trace effects
resumingValueError :: ( Carrier sig m
, Member Trace sig
, Show address
, Show term
)
=> Evaluator term address (Value term address) (Resumable (BaseError (ValueError term address)) ': effects) a
-> Evaluator term address (Value term address) effects a
=> Evaluator term address (Value term address) (ResumableWithC (BaseError (ValueError term address)) (Eff
m)) a
-> Evaluator term address (Value term address) m a
resumingValueError = runValueErrorWith (\ baseError -> traceError "ValueError" baseError *> case baseErrorException baseError of
CallError val -> pure val
StringError val -> pure (pack (prettyShow val))
@ -387,19 +393,23 @@ resumingValueError = runValueErrorWith (\ baseError -> traceError "ValueError" b
ArrayError{} -> pure lowerBound
ArithmeticError{} -> pure hole)
resumingEnvironmentError :: ( Effects effects
, Member Trace effects
resumingEnvironmentError :: ( Carrier sig m
, Member Trace sig
)
=> Evaluator term (Hole (Maybe Name) address) value (Resumable (BaseError (EnvironmentError (Hole (Maybe Name) address))) ': effects) a
-> Evaluator term (Hole (Maybe Name) address) value effects a
resumingEnvironmentError = runResumableWith (\ baseError -> traceError "EnvironmentError" baseError >> (\ (FreeVariable name) -> pure (Partial (Just name))) (baseErrorException baseError))
=> Evaluator term (Hole (Maybe Name) address) value (ResumableWithC (BaseError (EnvironmentError (Hole (Maybe Name) address))) (Eff
m)) a
-> Evaluator term (Hole (Maybe Name) address) value m a
resumingEnvironmentError = runEnvironmentErrorWith (\ baseError -> traceError "EnvironmentError" baseError >> (\ (FreeVariable name) -> pure (Partial (Just name))) (baseErrorException baseError))
resumingTypeError :: ( Effects effects
, Member NonDet effects
, Member Trace effects
resumingTypeError :: ( Carrier sig m
, Member NonDet sig
, Member Trace sig
, Effect sig
)
=> Evaluator term address Type (Resumable (BaseError TypeError) ': State TypeMap ': effects) a
-> Evaluator term address Type effects a
=> Evaluator term address Type (ResumableWithC (BaseError TypeError) (Eff
(StateC TypeMap (Eff
m)))) a
-> Evaluator term address Type m a
resumingTypeError = runTypesWith (\ baseError -> traceError "TypeError" baseError *> case baseErrorException baseError of
UnificationError l r -> pure l <|> pure r
InfiniteType _ r -> pure r)
@ -407,5 +417,5 @@ resumingTypeError = runTypesWith (\ baseError -> traceError "TypeError" baseErro
prettyShow :: Show a => a -> String
prettyShow = hscolour TTY defaultColourPrefs False False "" False . ppShow
traceError :: (Member Trace effects, Show (exc resume)) => String -> BaseError exc resume -> Evaluator term address value effects ()
traceError :: (Member Trace sig, Show (exc resume), Carrier sig m) => String -> BaseError exc resume -> Evaluator term address value m ()
traceError prefix baseError = trace $ prefix <> ": " <> prettyShow baseError

View File

@ -5,7 +5,7 @@ module Semantic.IO
) where
import Prelude hiding (readFile)
import Prologue hiding (MonadError (..), fail)
import Prologue
import System.Directory (doesDirectoryExist)
import System.Directory.Tree (AnchoredDirTree (..))
@ -16,7 +16,7 @@ isDirectory :: MonadIO m => FilePath -> m Bool
isDirectory path = liftIO (doesDirectoryExist path)
-- Recursively find files in a directory.
findFilesInDir :: forall m. MonadIO m => FilePath -> [String] -> [FilePath] -> m [FilePath]
findFilesInDir :: MonadIO m => FilePath -> [String] -> [FilePath] -> m [FilePath]
findFilesInDir path exts excludeDirs = do
_:/dir <- liftIO $ Tree.build path
pure $ (onlyFiles . Tree.filterDir (withExtensions exts) . Tree.filterDir (notIn excludeDirs)) dir

View File

@ -4,7 +4,9 @@ module Semantic.Parse ( runParse, runParse', parseSomeBlob ) where
import Analysis.ConstructorName (ConstructorName)
import Analysis.Declaration (HasDeclaration, declarationAlgebra)
import Analysis.PackageDef (HasPackageDef)
import Control.Monad.Effect.Exception
import Control.Effect
import Control.Effect.Error
import Control.Monad.IO.Class
import Data.Blob
import Data.Either
import Data.ByteString.Builder (stringUtf8)
@ -14,7 +16,7 @@ import Data.Quieterm
import Data.Location
import Data.Term
import Parsing.Parser
import Prologue hiding (MonadError (..))
import Prologue
import Rendering.Graph
import Rendering.JSON (SomeJSON (..))
import qualified Rendering.JSON as JSON
@ -23,7 +25,7 @@ import Semantic.Task
import Serializing.Format
-- | Using the specified renderer, parse a list of 'Blob's to produce a 'Builder' output.
runParse :: (Member Distribute effs, Member (Exc SomeException) effs, Member Task effs, Member (Lift IO) effs) => TermRenderer output -> [Blob] -> Eff effs Builder
runParse :: (Member Distribute sig, Member (Error SomeException) sig, Member Task sig, Carrier sig m, MonadIO m) => TermRenderer output -> [Blob] -> m Builder
runParse JSONTermRenderer = withParsedBlobs' renderJSONError (render . renderJSONTerm) >=> serialize JSON
runParse JSONGraphTermRenderer = withParsedBlobs' renderJSONError (render . renderAdjGraph) >=> serialize JSON
where renderAdjGraph :: (Recursive t, ToTreeGraph TermVertex (Base t)) => Blob -> t -> JSON.JSON "trees" SomeJSON
@ -40,29 +42,32 @@ runParse QuietTermRenderer = distributeFoldMap $ \blob ->
in stringUtf8 (status <> "\t" <> show blobLanguage <> "\t" <> blobPath <> "\t" <> show duration <> " ms\n")
-- | For testing and running parse-examples.
runParse' :: (Member (Exc SomeException) effs, Member Task effs) => Blob -> Eff effs Builder
runParse' :: (Member (Error SomeException) sig, Member Task sig, Monad m, Carrier sig m) => Blob -> m Builder
runParse' blob = parseSomeBlob blob >>= withSomeTerm (serialize Show . quieterm)
type Render effs output = forall syntax .
( ConstructorName syntax
, HasDeclaration syntax
, HasPackageDef syntax
, Foldable syntax
, Functor syntax
, Show1 syntax
, ToJSONFields1 syntax
)
=> Blob -> Term syntax Location -> Eff effs output
type Render m output
= forall syntax
. ( ConstructorName syntax
, HasDeclaration syntax
, HasPackageDef syntax
, Foldable syntax
, Functor syntax
, Show1 syntax
, ToJSONFields1 syntax
)
=> Blob
-> Term syntax Location
-> m output
withParsedBlobs :: (Member Distribute effs, Member (Exc SomeException) effs, Member Task effs, Monoid output)
=> Render effs output -> [Blob] -> Eff effs output
withParsedBlobs :: (Member Distribute sig, Member (Error SomeException) sig, Member Task sig, Monad m, Monoid output, Carrier sig m)
=> Render m output -> [Blob] -> m output
withParsedBlobs render = distributeFoldMap $ \blob -> parseSomeBlob blob >>= withSomeTerm (render blob)
withParsedBlobs' :: (Member Distribute effs, Member (Exc SomeException) effs, Member Task effs, Monoid output)
=> (Blob -> String -> output) -> Render effs output -> [Blob] -> Eff effs output
withParsedBlobs' :: (Member Distribute sig, Member (Error SomeException) sig, Member Task sig, Monad m, Monoid output, Carrier sig m)
=> (Blob -> String -> output) -> Render m output -> [Blob] -> m output
withParsedBlobs' onError render = distributeFoldMap $ \blob ->
(parseSomeBlob blob >>= withSomeTerm (render blob)) `catchError` \(SomeException e) ->
pure (onError blob (show e))
parseSomeBlob :: (Member (Exc SomeException) effs, Member Task effs) => Blob -> Eff effs (SomeTerm '[ConstructorName, Foldable, Functor, HasDeclaration, HasPackageDef, Show1, ToJSONFields1] Location)
parseSomeBlob :: (Member (Error SomeException) sig, Member Task sig, Carrier sig m) => Blob -> m (SomeTerm '[ConstructorName, Foldable, Functor, HasDeclaration, HasPackageDef, Show1, ToJSONFields1] Location)
parseSomeBlob blob@Blob{..} = maybe (noLanguageForBlob blobPath) (`parse` blob) (someParser blobLanguage)

View File

@ -1,11 +1,13 @@
{-# LANGUAGE GADTs, KindSignatures, LambdaCase, TypeOperators #-}
{-# LANGUAGE GADTs, KindSignatures, LambdaCase, TypeOperators, UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-missing-signatures #-}
module Semantic.REPL
( rubyREPL
) where
import Control.Abstract hiding (Continue, List, string)
import Control.Monad.Effect.Resource
import Control.Effect.Carrier
import Control.Effect.Resource
import Control.Effect.Sum
import Data.Abstract.Address.Precise as Precise
import Data.Abstract.Environment as Env
import Data.Abstract.Evaluatable hiding (string)
@ -14,6 +16,7 @@ import Data.Abstract.ModuleTable as ModuleTable
import Data.Abstract.Package
import Data.Abstract.Value.Concrete as Concrete
import Data.Blob (Blob(..))
import Data.Coerce
import Data.Error (showExcerpt)
import Data.File (File (..), readBlobFromFile)
import Data.Graph (topologicalSort)
@ -26,7 +29,8 @@ import qualified Data.Time.Clock.POSIX as Time (getCurrentTime)
import qualified Data.Time.LocalTime as LocalTime
import Numeric (readDec)
import Parsing.Parser (rubyParser)
import Prologue hiding (throwError)
import Prologue
import Semantic.Analysis
import Semantic.Config (logOptionsFromConfig)
import Semantic.Distribute
import Semantic.Graph
@ -41,15 +45,16 @@ import System.Console.Haskeline
import System.Directory (createDirectoryIfMissing, getHomeDirectory)
import System.FilePath
data REPL (m :: * -> *) result where
Prompt :: REPL m (Maybe String)
Output :: String -> REPL m ()
data REPL (m :: * -> *) k
= Prompt (Maybe String -> k)
| Output String k
deriving (Functor)
prompt :: (Effectful m, Member REPL effects) => m effects (Maybe String)
prompt = send Prompt
prompt :: (Member REPL sig, Carrier sig m) => m (Maybe String)
prompt = send (Prompt ret)
output :: (Effectful m, Member REPL effects) => String -> m effects ()
output s = send (Output s)
output :: (Member REPL sig, Carrier sig m) => String -> m ()
output s = send (Output s (ret ()))
data Quit = Quit
@ -58,16 +63,24 @@ data Quit = Quit
instance Exception Quit
instance PureEffect REPL
instance HFunctor REPL where
hmap _ = coerce
instance Effect REPL where
handleState state handler (Request Prompt k) = Request Prompt (handler . (<$ state) . k)
handleState state handler (Request (Output s) k) = Request (Output s) (handler . (<$ state) . k)
handle state handler (Prompt k) = Prompt (handler . (<$ state) . k)
handle state handler (Output s k) = Output s (handler (k <$ state))
runREPL :: (Effectful m, MonadIO (m effects), PureEffects effects) => Prefs -> Settings IO -> m (REPL ': effects) a -> m effects a
runREPL prefs settings = interpret $ \case
Prompt -> liftIO (runInputTWithPrefs prefs settings (getInputLine (cyan <> "repl: " <> plain)))
Output s -> liftIO (runInputTWithPrefs prefs settings (outputStrLn s))
runREPL :: (MonadIO m, Carrier sig m) => Prefs -> Settings IO -> Eff (REPLC m) a -> m a
runREPL prefs settings = flip runREPLC (prefs, settings) . interpret
newtype REPLC m a = REPLC { runREPLC :: (Prefs, Settings IO) -> m a }
instance (Carrier sig m, MonadIO m) => Carrier (REPL :+: sig) (REPLC m) where
ret = REPLC . const . ret
eff op = REPLC (\ args -> handleSum (eff . handleReader args runREPLC) (\case
Prompt k -> liftIO (uncurry runInputTWithPrefs args (getInputLine (cyan <> "repl: " <> plain))) >>= flip runREPLC args . k
Output s k -> liftIO (uncurry runInputTWithPrefs args (outputStrLn s)) *> runREPLC k args) op)
rubyREPL = repl (Proxy @'Language.Ruby) rubyParser
@ -89,10 +102,11 @@ repl proxy parser paths = defaultConfig debugOptions >>= \ config -> runM . runD
. fmap snd
. runState ([] @Breakpoint)
. runReader Step
. runEvaluator
. id @(Evaluator _ Precise (Value _ Precise) _ _)
. runPrintingTrace
. raiseHandler runTraceByPrinting
. runHeap
. runFresh 0
. raiseHandler runFresh
. fmap reassociate
. runLoadError
. runUnspecialized
@ -101,35 +115,43 @@ repl proxy parser paths = defaultConfig debugOptions >>= \ config -> runM . runD
. runResolutionError
. runAddressError
. runValueError
. runReader (lowerBound @(ModuleTable (NonEmpty (Module (ModuleResult Precise)))))
. runModuleTable
. runModules (ModuleTable.modulePaths (packageModules (snd <$> package)))
. runReader (packageInfo package)
. runState (lowerBound @Span)
. runReader (lowerBound @Span)
$ evaluate proxy id (withTermSpans . step (fmap (\ (x:|_) -> moduleBody x) <$> ModuleTable.toPairs (packageModules (fst <$> package)))) (Precise.runAllocator . Precise.runDeref) (fmap (Concrete.runBoolean . Concrete.runWhile) . Concrete.runFunction) modules
. raiseHandler (runReader (packageInfo package))
. raiseHandler (runState (lowerBound @Span))
. raiseHandler (runReader (lowerBound @Span))
$ evaluate proxy id (evalTerm (withTermSpans . step (fmap (\ (x:|_) -> moduleBody x) <$> ModuleTable.toPairs (packageModules (fst <$> package))))) modules
-- TODO: REPL for typechecking/abstract semantics
-- TODO: drive the flow from within the REPL instead of from without
runTelemetryIgnoringStat :: (Effectful m, MonadIO (m effects), PureEffects effects) => LogOptions -> m (Telemetry : effects) a -> m effects a
runTelemetryIgnoringStat logOptions = interpret $ \case
WriteStat{} -> pure ()
WriteLog level message pairs -> do
time <- liftIO Time.getCurrentTime
zonedTime <- liftIO (LocalTime.utcToLocalZonedTime time)
writeLogMessage logOptions (Message level message pairs zonedTime)
runTelemetryIgnoringStat :: (Carrier sig m, MonadIO m) => LogOptions -> Eff (TelemetryIgnoringStatC m) a -> m a
runTelemetryIgnoringStat logOptions = flip runTelemetryIgnoringStatC logOptions . interpret
step :: ( Member (Env address) effects
, Member (Exc SomeException) effects
, Member REPL effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Reader Step) effects
, Member (State [Breakpoint]) effects
newtype TelemetryIgnoringStatC m a = TelemetryIgnoringStatC { runTelemetryIgnoringStatC :: LogOptions -> m a }
instance (Carrier sig m, MonadIO m) => Carrier (Telemetry :+: sig) (TelemetryIgnoringStatC m) where
ret = TelemetryIgnoringStatC . const . ret
eff op = TelemetryIgnoringStatC (\ logOptions -> handleSum (eff . handleReader logOptions runTelemetryIgnoringStatC) (\case
WriteStat _ k -> runTelemetryIgnoringStatC k logOptions
WriteLog level message pairs k -> do
time <- liftIO Time.getCurrentTime
zonedTime <- liftIO (LocalTime.utcToLocalZonedTime time)
writeLogMessage logOptions (Message level message pairs zonedTime)
runTelemetryIgnoringStatC k logOptions) op)
step :: ( Member (Env address) sig
, Member (Error SomeException) sig
, Member REPL sig
, Member (Reader ModuleInfo) sig
, Member (Reader Span) sig
, Member (Reader Step) sig
, Member (State [Breakpoint]) sig
, Show address
, Carrier sig m
)
=> [(ModulePath, Blob)]
-> Open (Open (term -> Evaluator term address value effects a))
-> Open (Open (term -> Evaluator term address value m a))
step blobs recur0 recur term = do
break <- shouldBreak
if break then do
@ -157,7 +179,7 @@ step blobs recur0 recur term = do
runCommand run [":step"] = local (const Step) run
runCommand run [":continue"] = local (const Continue) run
runCommand run [":break", s]
| [(i, "")] <- readDec s = modify' (OnLine i :) >> runCommands run
| [(i, "")] <- readDec s = modify (OnLine i :) >> runCommands run
-- TODO: :show breakpoints
-- TODO: :delete breakpoints
runCommand run [":list"] = list >> runCommands run
@ -189,7 +211,7 @@ data Step
-- TODO: StepLocal/StepModule
shouldBreak :: (Member (State [Breakpoint]) effects, Member (Reader Span) effects, Member (Reader Step) effects) => Evaluator term address value effects Bool
shouldBreak :: (Member (State [Breakpoint]) sig, Member (Reader Span) sig, Member (Reader Step) sig, Carrier sig m) => Evaluator term address value m Bool
shouldBreak = do
step <- ask
case step of

View File

@ -1,15 +1,19 @@
{-# LANGUAGE ConstraintKinds, GADTs, KindSignatures, ScopedTypeVariables, TypeOperators, UndecidableInstances #-}
{-# LANGUAGE ConstraintKinds, GADTs, KindSignatures, LambdaCase, ScopedTypeVariables, TypeOperators, UndecidableInstances #-}
module Semantic.Resolution
( Resolution (..)
, nodeJSResolutionMap
, resolutionMap
, runResolution
, ResolutionC(..)
) where
import Control.Monad.Effect
import Control.Effect
import Control.Effect.Carrier
import Control.Effect.Sum
import Data.Aeson
import Data.Aeson.Types (parseMaybe)
import Data.Blob
import Data.Coerce
import Data.File
import Data.Project
import qualified Data.Map as Map
@ -20,7 +24,7 @@ import Semantic.Task.Files
import System.FilePath.Posix
nodeJSResolutionMap :: Member Files effs => FilePath -> Text -> [FilePath] -> Eff effs (Map FilePath FilePath)
nodeJSResolutionMap :: (Member Files sig, Carrier sig m, Monad m) => FilePath -> Text -> [FilePath] -> m (Map FilePath FilePath)
nodeJSResolutionMap rootDir prop excludeDirs = do
files <- findFiles rootDir [".json"] excludeDirs
let packageFiles = file <$> filter ((==) "package.json" . takeFileName) files
@ -35,22 +39,31 @@ nodeJSResolutionMap rootDir prop excludeDirs = do
where relPkgDotJSONPath = makeRelative rootDir path
relEntryPath x = takeDirectory relPkgDotJSONPath </> x
resolutionMap :: Member Resolution effs => Project -> Eff effs (Map FilePath FilePath)
resolutionMap :: (Member Resolution sig, Carrier sig m) => Project -> m (Map FilePath FilePath)
resolutionMap Project{..} = case projectLanguage of
TypeScript -> send (NodeJSResolution projectRootDir "types" projectExcludeDirs)
JavaScript -> send (NodeJSResolution projectRootDir "main" projectExcludeDirs)
_ -> send NoResolution
TypeScript -> send (NodeJSResolution projectRootDir "types" projectExcludeDirs ret)
JavaScript -> send (NodeJSResolution projectRootDir "main" projectExcludeDirs ret)
_ -> send (NoResolution ret)
data Resolution (m :: * -> *) output where
NodeJSResolution :: FilePath -> Text -> [FilePath] -> Resolution m (Map FilePath FilePath)
NoResolution :: Resolution m (Map FilePath FilePath)
data Resolution (m :: * -> *) k
= NodeJSResolution FilePath Text [FilePath] (Map FilePath FilePath -> k)
| NoResolution (Map FilePath FilePath -> k)
deriving (Functor)
instance HFunctor Resolution where
hmap _ = coerce
instance PureEffect Resolution
instance Effect Resolution where
handleState c dist (Request (NodeJSResolution path key paths) k) = Request (NodeJSResolution path key paths) (dist . (<$ c) . k)
handleState c dist (Request NoResolution k) = Request NoResolution (dist . (<$ c) . k)
handle state handler (NodeJSResolution path key paths k) = NodeJSResolution path key paths (handler . (<$ state) . k)
handle state handler (NoResolution k) = NoResolution (handler . (<$ state) . k)
runResolution :: (Member Files effs, PureEffects effs) => Eff (Resolution ': effs) a -> Eff effs a
runResolution = interpret $ \ res -> case res of
NodeJSResolution dir prop excludeDirs -> nodeJSResolutionMap dir prop excludeDirs
NoResolution -> pure Map.empty
runResolution :: (Member Files sig, Carrier sig m, Monad m) => Eff (ResolutionC m) a -> m a
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
ret = ResolutionC . ret
eff = ResolutionC . handleSum (eff . handleCoercible) (\case
NodeJSResolution dir prop excludeDirs k -> nodeJSResolutionMap dir prop excludeDirs >>= runResolutionC . k
NoResolution k -> runResolutionC (k Map.empty))

View File

@ -1,4 +1,4 @@
{-# LANGUAGE ConstraintKinds, GADTs, KindSignatures, ScopedTypeVariables, TypeOperators #-}
{-# LANGUAGE ConstraintKinds, ExistentialQuantification, GADTs, KindSignatures, LambdaCase, ScopedTypeVariables, StandaloneDeriving, TypeOperators, UndecidableInstances #-}
module Semantic.Task
( Task
, TaskEff
@ -47,7 +47,7 @@ module Semantic.Task
-- * Re-exports
, Distribute
, Eff
, Exc
, Error
, Lift
, throwError
, SomeException(..)
@ -58,15 +58,19 @@ import Analysis.Decorator (decoratorWithAlgebra)
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.Effect
import Control.Monad.Effect.Exception
import Control.Monad.Effect.Reader
import Control.Monad.Effect.Resource
import Control.Monad.Effect.Trace
import Control.Monad.IO.Class
import Data.Blob
import Data.Bool
import Data.ByteString.Builder
import Data.Coerce
import Data.Diff
import Data.Duration
import qualified Data.Error as Error
@ -81,7 +85,7 @@ import Diffing.Interpreter
import Parsing.CMark
import Parsing.Parser
import Parsing.TreeSitter
import Prologue hiding (MonadError (..), project)
import Prologue hiding (project)
import Semantic.Config
import Semantic.Distribute
import qualified Semantic.Task.Files as Files
@ -92,62 +96,88 @@ import Serializing.Format hiding (Options)
import System.Exit (die)
-- | A high-level task producing some result, e.g. parsing, diffing, rendering. 'Task's can also specify explicit concurrency via 'distribute', 'distributeFor', and 'distributeFoldMap'
type TaskEff = Eff '[ Task
, Resolution
, Files.Files
, Reader Config
, Trace
, Telemetry
, Exc SomeException
, Timeout
, Resource
, Distribute
, Lift IO
]
type TaskEff
= Eff (TaskC
( Eff (ResolutionC
( Eff (Files.FilesC
( Eff (ReaderC Config
( Eff (TraceInTelemetryC
( Eff (TelemetryC
( Eff (ErrorC SomeException
( Eff (TimeoutC
( Eff (ResourceC
( Eff (DistributeC
( Eff (LiftC IO)))))))))))))))))))))
-- | A function to render terms or diffs.
type Renderer i o = i -> o
-- | A task which parses a 'Blob' with the given 'Parser'.
parse :: Member Task effs => Parser term -> Blob -> Eff effs term
parse parser = send . Parse parser
parse :: (Member Task sig, Carrier sig m)
=> Parser term
-> Blob
-> m term
parse parser blob = send (Parse parser blob ret)
-- | A task running some 'Analysis.Evaluator' to completion.
analyze :: Member Task effs => (Analysis.Evaluator term address value effects a -> result) -> Analysis.Evaluator term address value effects a -> Eff effs result
analyze interpret analysis = send (Analyze interpret analysis)
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 ret)
-- | A task which decorates a 'Term' with values computed using the supplied 'RAlgebra' function.
decorate :: (Functor f, Member Task effs) => RAlgebra (TermF f Location) (Term f Location) field -> Term f Location -> Eff effs (Term f field)
decorate algebra = send . Decorate algebra
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 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 effs) => These (Term syntax ann) (Term syntax ann) -> Eff effs (Diff syntax ann ann)
diff terms = send (Semantic.Task.Diff terms)
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 ret)
-- | A task which renders some input using the supplied 'Renderer' function.
render :: Member Task effs => Renderer input output -> input -> Eff effs output
render renderer = send . Render renderer
render :: (Member Task sig, Carrier sig m)
=> Renderer input output
-> input
-> m output
render renderer input = send (Render renderer input ret)
serialize :: Member Task effs => Format input -> input -> Eff effs Builder
serialize format = send . Serialize format
serialize :: (Member Task sig, Carrier sig m)
=> Format input
-> input
-> m Builder
serialize format input = send (Serialize format input ret)
-- | Execute a 'Task' with the 'defaultOptions', yielding its result value in 'IO'.
--
-- > runTask = runTaskWithOptions defaultOptions
runTask :: TaskEff a -> IO a
runTask :: TaskEff a
-> IO a
runTask = runTaskWithOptions defaultOptions
-- | Execute a 'TaskEff' with the passed 'Options', yielding its result value in 'IO'.
runTaskWithOptions :: Options -> TaskEff a -> IO a
runTaskWithOptions :: Options
-> TaskEff a
-> IO a
runTaskWithOptions opts task = withOptions opts (\ config logger statter -> runTaskWithConfig config logger statter task) >>= either (die . displayException) pure
withOptions :: Options -> (Config -> LogQueue -> StatQueue -> IO a) -> IO a
withOptions :: Options
-> (Config -> LogQueue -> StatQueue -> IO a)
-> IO a
withOptions options with = do
config <- defaultConfig options
withTelemetry config (\ (TelemetryQueues logger statter _) -> with config logger statter)
-- | Execute a 'TaskEff' yielding its result value in 'IO'.
runTaskWithConfig :: Config -> LogQueue -> StatQueue -> TaskEff a -> IO (Either SomeException a)
runTaskWithConfig :: Config
-> LogQueue
-> StatQueue
-> TaskEff a
-> IO (Either SomeException a)
runTaskWithConfig options logger statter task = do
(result, stat) <- withTiming "run" [] $ do
let run :: TaskEff a -> IO (Either SomeException a)
@ -167,43 +197,80 @@ runTaskWithConfig options logger statter task = do
queueStat statter stat
pure result
runTraceInTelemetry :: (Member Telemetry effects, PureEffects effects) => Eff (Trace ': effects) a -> Eff effects a
runTraceInTelemetry = interpret (\ (Trace str) -> writeLog Debug str [])
runTraceInTelemetry :: (Member Telemetry sig, Carrier sig m, Monad m)
=> Eff (TraceInTelemetryC m) a
-> m a
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
ret = TraceInTelemetryC . ret
eff = TraceInTelemetryC . handleSum
(eff . handleCoercible)
(\ (Trace str k) -> writeLog Debug str [] >> runTraceInTelemetryC k)
-- | An effect describing high-level tasks to be performed.
data Task (m :: * -> *) output where
Parse :: Parser term -> Blob -> Task m term
Analyze :: (Analysis.Evaluator term address value effects a -> result) -> Analysis.Evaluator term address value effects a -> Task m result
Decorate :: Functor f => RAlgebra (TermF f Location) (Term f Location) field -> Term f Location -> Task m (Term f field)
Diff :: (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax) => These (Term syntax ann) (Term syntax ann) -> Task m (Diff syntax ann ann)
Render :: Renderer input output -> input -> Task m output
Serialize :: Format input -> input -> Task m Builder
data Task (m :: * -> *) k
= forall term . Parse (Parser term) Blob (term -> k)
| forall term address value m a result . Analyze (Analysis.Evaluator term address value m a -> result) (Analysis.Evaluator term address value m a) (result -> k)
| forall f field . Functor f => Decorate (RAlgebra (TermF f Location) (Term f Location) field) (Term f Location) (Term f field -> k)
| forall syntax ann . (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax) => Diff (These (Term syntax ann) (Term syntax ann)) (Diff syntax ann ann -> k)
| forall input output . Render (Renderer input output) input (output -> k)
| forall input . Serialize (Format input) input (Builder -> k)
deriving instance Functor (Task m)
instance HFunctor Task where
hmap _ = coerce
instance PureEffect Task
instance Effect Task where
handleState c dist (Request (Parse parser blob) k) = Request (Parse parser blob) (dist . (<$ c) . k)
handleState c dist (Request (Analyze run analysis) k) = Request (Analyze run analysis) (dist . (<$ c) . k)
handleState c dist (Request (Decorate decorator term) k) = Request (Decorate decorator term) (dist . (<$ c) . k)
handleState c dist (Request (Semantic.Task.Diff terms) k) = Request (Semantic.Task.Diff terms) (dist . (<$ c) . k)
handleState c dist (Request (Render renderer input) k) = Request (Render renderer input) (dist . (<$ c) . k)
handleState c dist (Request (Serialize format input) k) = Request (Serialize format input) (dist . (<$ c) . k)
handle state handler (Parse parser blob k) = Parse parser blob (handler . (<$ state) . k)
handle state handler (Analyze run analysis k) = Analyze run analysis (handler . (<$ state) . k)
handle state handler (Decorate decorator term k) = Decorate decorator term (handler . (<$ state) . k)
handle state handler (Semantic.Task.Diff terms k) = Semantic.Task.Diff terms (handler . (<$ state) . k)
handle state handler (Render renderer input k) = Render renderer input (handler . (<$ state) . k)
handle state handler (Serialize format input k) = Serialize format input (handler . (<$ state) . k)
-- | Run a 'Task' effect by performing the actions in 'IO'.
runTaskF :: (Member (Exc SomeException) effs, Member (Lift IO) effs, Member (Reader Config) effs, Member Resource effs, Member Telemetry effs, Member Timeout effs, Member Trace effs, PureEffects effs) => Eff (Task ': effs) a -> Eff effs a
runTaskF = interpret $ \ task -> case task of
Parse parser blob -> runParser blob parser
Analyze interpret analysis -> pure (interpret analysis)
Decorate algebra term -> pure (decoratorWithAlgebra algebra term)
Semantic.Task.Diff terms -> pure (diffTermPair terms)
Render renderer input -> pure (renderer input)
Serialize format input -> do
formatStyle <- asks (bool Plain Colourful . configIsTerminal)
pure (runSerialize formatStyle format input)
runTaskF :: ( 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
)
=> Eff (TaskC m) a
-> m a
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
ret = TaskC . ret
eff = TaskC . handleSum (eff . handleCoercible) (\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))
Semantic.Task.Diff terms k -> runTaskC (k (diffTermPair terms))
Render renderer input k -> runTaskC (k (renderer input))
Serialize format input k -> do
formatStyle <- asks (bool Plain Colourful . configIsTerminal)
runTaskC (k (runSerialize formatStyle format input)))
-- | Log an 'Error.Error' at the specified 'Level'.
logError :: Member Telemetry effs => Config -> Level -> Blob -> Error.Error String -> [(String, String)] -> Eff effs ()
logError :: (Member Telemetry sig, Carrier sig m)
=> Config
-> Level
-> Blob
-> Error.Error String
-> [(String, String)]
-> m ()
logError Config{..} level blob err = writeLog level (Error.formatError configLogPrintSource configIsTerminal blob err)
data ParserCancelled = ParserTimedOut FilePath Language | AssignmentTimedOut FilePath Language
@ -212,7 +279,10 @@ data ParserCancelled = ParserTimedOut FilePath Language | AssignmentTimedOut Fil
instance Exception ParserCancelled
-- | Parse a 'Blob' in 'IO'.
runParser :: (Member (Exc SomeException) effs, Member (Lift IO) effs, Member (Reader Config) effs, Member Resource effs, Member Telemetry effs, Member Timeout effs, Member Trace effs, PureEffects effs) => Blob -> Parser term -> Eff effs term
runParser :: (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)
=> Blob
-> Parser term
-> m term
runParser blob@Blob{..} parser = case parser of
ASTParser language ->
time "parse.tree_sitter_ast_parse" languageTag $ do
@ -236,19 +306,20 @@ runParser blob@Blob{..} parser = case parser of
runAssignment :: ( Apply Foldable syntaxes
, Apply Functor syntaxes
, Element Syntax.Error syntaxes
, Member (Exc SomeException) effs
, Member (Lift IO) effs
, Member (Reader Config) effs
, Member Telemetry effs
, Member Timeout effs
, Member Trace effs
, Member Resource effs
, PureEffects effs
, 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
)
=> (Source -> assignment (Term (Sum syntaxes) Assignment.Location) -> ast -> Either (Error.Error String) (Term (Sum syntaxes) Assignment.Location))
-> Parser ast
-> assignment (Term (Sum syntaxes) Assignment.Location)
-> Eff effs (Term (Sum syntaxes) Assignment.Location)
-> m (Term (Sum syntaxes) Assignment.Location)
runAssignment assign parser assignment = do
config <- ask
let blobFields = ("path", if configLogPrintSource config then blobPath else "<filtered>") : languageTag

View File

@ -1,4 +1,4 @@
{-# LANGUAGE GADTs, KindSignatures, TypeOperators #-}
{-# LANGUAGE ExistentialQuantification, GADTs, LambdaCase, KindSignatures, TypeOperators, UndecidableInstances #-}
module Semantic.Task.Files
( Files
@ -12,18 +12,23 @@ module Semantic.Task.Files
, findFiles
, write
, Handle (..)
, FilesC(..)
) where
import Control.Monad.Effect
import Control.Monad.Effect.Exception
import Control.Effect
import Control.Effect.Carrier
import Control.Effect.Error
import Control.Effect.Sum
import Control.Exception as Exc
import qualified Data.ByteString.Builder as B
import Data.Blob
import Data.Coerce
import Data.File
import Data.Handle
import Data.Language
import Data.Project hiding (readFile)
import Prelude hiding (readFile)
import Prologue hiding (MonadError (..), fail)
import Prologue
import Semantic.IO
import qualified System.IO as IO
@ -36,50 +41,71 @@ data Source blob where
data Destination = ToPath FilePath | ToHandle (Handle 'IO.WriteMode)
-- | An effect to read/write 'Blob's from 'Handle's or 'FilePath's.
data Files (m :: * -> *) out where
Read :: Source out -> Files m out
ReadProject :: Maybe FilePath -> FilePath -> Language -> [FilePath] -> Files m Project
FindFiles :: FilePath -> [String] -> [FilePath] -> Files m [FilePath]
Write :: Destination -> B.Builder -> Files m ()
data Files (m :: * -> *) k
= forall a . Read (Source a) (a -> k)
| ReadProject (Maybe FilePath) FilePath Language [FilePath] (Project -> k)
| FindFiles FilePath [String] [FilePath] ([FilePath] -> k)
| Write Destination B.Builder k
deriving instance Functor (Files m)
instance HFunctor Files where
hmap _ = coerce
instance PureEffect Files
instance Effect Files where
handleState c dist (Request (Read source) k) = Request (Read source) (dist . (<$ c) . k)
handleState c dist (Request (ReadProject rootDir dir language excludeDirs) k) = Request (ReadProject rootDir dir language excludeDirs) (dist . (<$ c) . k)
handleState c dist (Request (FindFiles dir exts paths) k) = Request (FindFiles dir exts paths) (dist . (<$ c) . k)
handleState c dist (Request (Write destination builder) k) = Request (Write destination builder) (dist . (<$ c) . k)
handle state handler (Read source k) = Read source (handler . (<$ state) . k)
handle state handler (ReadProject rootDir dir language excludeDirs k) = ReadProject rootDir dir language excludeDirs (handler . (<$ state) . k)
handle state handler (FindFiles dir exts paths k) = FindFiles dir exts paths (handler . (<$ state) . k)
handle state handler (Write destination builder k) = Write destination builder (handler (k <$ state))
-- | Run a 'Files' effect in 'IO'.
runFiles :: (Member (Exc SomeException) effs, Member (Lift IO) effs, PureEffects effs) => Eff (Files ': effs) a -> Eff effs a
runFiles = interpret $ \ files -> case files of
Read (FromPath path) -> rethrowing (readBlobFromFile' path)
Read (FromHandle handle) -> rethrowing (readBlobsFromHandle handle)
Read (FromPathPair paths) -> rethrowing (runBothWith readFilePair paths)
Read (FromPairHandle handle) -> rethrowing (readBlobPairsFromHandle handle)
ReadProject rootDir dir language excludeDirs -> rethrowing (readProjectFromPaths rootDir dir language excludeDirs)
FindFiles dir exts excludeDirs -> rethrowing (findFilesInDir dir exts excludeDirs)
Write (ToPath path) builder -> liftIO (IO.withBinaryFile path IO.WriteMode (`B.hPutBuilder` builder))
Write (ToHandle (WriteHandle handle)) builder -> liftIO (B.hPutBuilder handle builder)
runFiles :: (Member (Error SomeException) sig, MonadIO m, Carrier sig m) => Eff (FilesC m) a -> m a
runFiles = runFilesC . interpret
readBlob :: Member Files effs => File -> Eff effs Blob
readBlob = send . Read . FromPath
newtype FilesC m a = FilesC { runFilesC :: m a }
instance (Member (Error SomeException) sig, MonadIO m, Carrier sig m) => Carrier (Files :+: sig) (FilesC m) where
ret = FilesC . ret
eff = FilesC . handleSum (eff . handleCoercible) (\case
Read (FromPath path) k -> (readBlobFromFile' 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
Read (FromPairHandle handle) k -> (readBlobPairsFromHandle handle `catchIO` (throwError . toException @SomeException)) >>= runFilesC . k
ReadProject rootDir dir language excludeDirs k -> (readProjectFromPaths rootDir dir language excludeDirs `catchIO` (throwError . toException @SomeException)) >>= runFilesC . k
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)
readBlob :: (Member Files sig, Carrier sig m) => File -> m Blob
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 effs => Either (Handle 'IO.ReadMode) [File] -> Eff effs [Blob]
readBlobs (Left handle) = send (Read (FromHandle handle))
readBlobs (Right paths) = traverse (send . Read . FromPath) paths
readBlobs :: (Member Files sig, Carrier sig m, Applicative m) => Either (Handle 'IO.ReadMode) [File] -> m [Blob]
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 effs => Either (Handle 'IO.ReadMode) [Both File] -> Eff effs [BlobPair]
readBlobPairs (Left handle) = send (Read (FromPairHandle handle))
readBlobPairs (Right paths) = traverse (send . Read . FromPathPair) paths
readBlobPairs :: (Member Files sig, Carrier sig m, Applicative m) => Either (Handle 'IO.ReadMode) [Both File] -> m [BlobPair]
readBlobPairs (Left handle) = send (Read (FromPairHandle handle) ret)
readBlobPairs (Right paths) = traverse (send . flip Read ret . FromPathPair) paths
readProject :: Member Files effs => Maybe FilePath -> FilePath -> Language -> [FilePath] -> Eff effs Project
readProject rootDir dir excludeDirs = send . ReadProject rootDir dir excludeDirs
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 ret)
findFiles :: Member Files effs => FilePath -> [String] -> [FilePath] -> Eff effs [FilePath]
findFiles dir exts = send . FindFiles dir exts
findFiles :: (Member Files sig, Carrier sig m) => FilePath -> [String] -> [FilePath] -> m [FilePath]
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 effs => Destination -> B.Builder -> Eff effs ()
write dest = send . Write dest
write :: (Member Files sig, Carrier sig m) => Destination -> B.Builder -> m ()
write dest builder = send (Write dest builder (ret ()))
-- | 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

View File

@ -1,4 +1,4 @@
{-# LANGUAGE GADTs, KindSignatures, RankNTypes, TypeOperators, UndecidableInstances #-}
{-# LANGUAGE GADTs, KindSignatures, LambdaCase, RankNTypes, TypeOperators, UndecidableInstances #-}
module Semantic.Telemetry
(
-- Async telemetry interface
@ -45,12 +45,17 @@ module Semantic.Telemetry
, time'
, Telemetry(..)
, runTelemetry
, TelemetryC(..)
, ignoreTelemetry
, IgnoreTelemetryC(..)
) where
import Control.Effect
import Control.Effect.Carrier
import Control.Effect.Sum
import Control.Exception
import Control.Monad.Effect
import Control.Monad.IO.Class
import Data.Coerce
import qualified Data.Time.Clock.POSIX as Time (getCurrentTime)
import qualified Data.Time.LocalTime as LocalTime
import Network.HTTP.Client
@ -115,41 +120,57 @@ queueStat q = liftIO . writeAsyncQueue q
-- Eff interface
-- | A task which logs a message at a specific log level to stderr.
writeLog :: Member Telemetry effs => Level -> String -> [(String, String)] -> Eff effs ()
writeLog level message pairs = send (WriteLog level message pairs)
writeLog :: (Member Telemetry sig, Carrier sig m) => Level -> String -> [(String, String)] -> m ()
writeLog level message pairs = send (WriteLog level message pairs (ret ()))
-- | A task which writes a stat.
writeStat :: Member Telemetry effs => Stat -> Eff effs ()
writeStat stat = send (WriteStat stat)
writeStat :: (Member Telemetry sig, Carrier sig m) => Stat -> m ()
writeStat stat = send (WriteStat stat (ret ()))
-- | A task which measures and stats the timing of another task.
time :: (Member (Lift IO) effs, Member Telemetry effs) => String -> [(String, String)] -> Eff effs output -> Eff effs output
time :: (Member Telemetry sig, Carrier sig m, MonadIO m) => String -> [(String, String)] -> m output -> m output
time statName tags task = do
(a, stat) <- withTiming statName tags task
a <$ writeStat stat
-- | A task which measures and returns the timing of another task.
time' :: (Member (Lift IO) effs) => Eff effs output -> Eff effs (output, Double)
time' :: MonadIO m => m output -> m (output, Double)
time' = withTiming'
-- | Statting and logging effects.
data Telemetry (m :: * -> *) output where
WriteStat :: Stat -> Telemetry m ()
WriteLog :: Level -> String -> [(String, String)] -> Telemetry m ()
data Telemetry (m :: * -> *) k
= WriteStat Stat k
| WriteLog Level String [(String, String)] k
deriving (Functor)
instance HFunctor Telemetry where
hmap _ = coerce
instance PureEffect Telemetry
instance Effect Telemetry where
handleState c dist (Request (WriteStat stat) k) = Request (WriteStat stat) (dist . (<$ c) . k)
handleState c dist (Request (WriteLog level message pairs) k) = Request (WriteLog level message pairs) (dist . (<$ c) . k)
handle state handler (WriteStat stat k) = WriteStat stat (handler (k <$ state))
handle state handler (WriteLog level message pairs k) = WriteLog level message pairs (handler (k <$ state))
-- | Run a 'Telemetry' effect by expecting a 'Reader' of 'Queue's to write stats and logs to.
runTelemetry :: (Member (Lift IO) effects, PureEffects effects) => LogQueue -> StatQueue -> Eff (Telemetry ': effects) a -> Eff effects a
runTelemetry logger statter = interpret (\ t -> case t of
WriteStat stat -> queueStat statter stat
WriteLog level message pairs -> queueLogMessage logger level message pairs)
runTelemetry :: (Carrier sig m, MonadIO m) => LogQueue -> StatQueue -> Eff (TelemetryC m) a -> m a
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
ret = TelemetryC . const . ret
eff op = TelemetryC (\ queues -> handleSum (eff . handleReader queues runTelemetryC) (\case
WriteStat stat k -> queueStat (snd queues) stat *> runTelemetryC k queues
WriteLog level message pairs k -> queueLogMessage (fst queues) level message pairs *> runTelemetryC k queues) op)
-- | Run a 'Telemetry' effect by ignoring statting/logging.
ignoreTelemetry :: PureEffects effs => Eff (Telemetry ': effs) a -> Eff effs a
ignoreTelemetry = interpret (\ t -> case t of
WriteStat{} -> pure ()
WriteLog{} -> pure ())
ignoreTelemetry :: Carrier sig m => Eff (IgnoreTelemetryC m) a -> m a
ignoreTelemetry = runIgnoreTelemetryC . interpret
newtype IgnoreTelemetryC m a = IgnoreTelemetryC { runIgnoreTelemetryC :: m a }
instance Carrier sig m => Carrier (Telemetry :+: sig) (IgnoreTelemetryC m) where
ret = IgnoreTelemetryC . ret
eff = handleSum (IgnoreTelemetryC . eff . handlePure runIgnoreTelemetryC) (\case
WriteStat _ k -> k
WriteLog _ _ _ k -> k)

View File

@ -1,12 +1,15 @@
{-# LANGUAGE TypeOperators, GADTs, RankNTypes #-}
{-# LANGUAGE ExistentialQuantification, TypeOperators, RankNTypes, UndecidableInstances #-}
module Semantic.Timeout
( timeout
, Timeout
, runTimeout
, TimeoutC(..)
, Duration(..)
) where
import Control.Monad.Effect
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
@ -14,21 +17,36 @@ import qualified System.Timeout as System
-- | Run an action with a timeout. Returns 'Nothing' when no result is available
-- within the specified duration. Uses 'System.Timeout.timeout' so all caveats
-- about not operating over FFI boundaries apply.
timeout :: (Member Timeout effs) => Duration -> Eff effs output -> Eff effs (Maybe output)
timeout n = send . Timeout n
timeout :: (Member Timeout sig, Carrier sig m) => Duration -> m output -> m (Maybe output)
timeout n = send . flip (Timeout n) ret
-- | 'Timeout' effects run other effects, aborting them if they exceed the
-- specified duration.
data Timeout task output where
Timeout :: Duration -> task output -> Timeout task (Maybe output)
data Timeout m k
= forall a . Timeout Duration (m a) (Maybe a -> k)
deriving instance Functor (Timeout m)
instance HFunctor Timeout where
hmap f (Timeout n task k) = Timeout n (f task) k
instance PureEffect Timeout
instance Effect Timeout where
handleState c dist (Request (Timeout n task) k) = Request (Timeout n (dist (task <$ c))) (dist . maybe (k Nothing <$ c) (fmap (k . Just)))
handle state handler (Timeout n task k) = Timeout n (handler (task <$ state)) (handler . maybe (k Nothing <$ state) (fmap (k . Just)))
-- | Evaulate a 'Timeoute' effect.
runTimeout :: (Member (Lift IO) effects, PureEffects effects)
=> (forall x . Eff effects x -> IO x)
-> Eff (Timeout ': effects) a
-> Eff effects a
runTimeout handler = interpret (\ (Timeout n task) -> liftIO (System.timeout (toMicroseconds n) (handler (runTimeout handler task))))
runTimeout :: (Carrier sig m, MonadIO m)
=> (forall x . m x -> IO x)
-> Eff (TimeoutC m) a
-> m a
runTimeout handler = runTimeoutC handler . interpret
newtype TimeoutC m a = TimeoutC ((forall x . m x -> IO x) -> m a)
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
ret a = TimeoutC (const (ret a))
eff op = TimeoutC (\ handler -> handleSum
(eff . handlePure (runTimeoutC handler))
(\ (Timeout n task k) -> liftIO (System.timeout (toMicroseconds n) (handler (runTimeoutC handler task))) >>= runTimeoutC handler . k) op)

View File

@ -8,7 +8,7 @@ import Analysis.Abstract.Caching.FlowSensitive
import Analysis.Abstract.Collecting
import Control.Abstract
import Control.Exception (displayException)
import Control.Monad.Effect.Trace (runPrintingTrace)
import Control.Effect.Trace (runTraceByPrinting)
import Data.Abstract.Address.Monovariant as Monovariant
import Data.Abstract.Address.Precise as Precise
import Data.Abstract.Evaluatable
@ -26,7 +26,8 @@ import Data.Project hiding (readFile)
import Data.Quieterm (quieterm)
import Data.Sum (weaken)
import Parsing.Parser
import Prologue hiding (weaken)
import Prologue
import Semantic.Analysis
import Semantic.Config
import Semantic.Graph
import Semantic.Task
@ -36,9 +37,10 @@ import System.FilePath.Posix (takeDirectory)
justEvaluating
= runM
. runPrintingTrace
. runEvaluator
. raiseHandler runTraceByPrinting
. runHeap
. runFresh 0
. raiseHandler runFresh
. fmap reassociate
. runLoadError
. runUnspecialized
@ -49,10 +51,11 @@ justEvaluating
. runValueError
checking
= runM @_ @IO
. runPrintingTrace
. runState (lowerBound @(Heap Monovariant Type))
. runFresh 0
= runM
. runEvaluator
. raiseHandler runTraceByPrinting
. runHeap
. raiseHandler runFresh
. caching
. providingLiveSet
. fmap reassociate
@ -97,12 +100,12 @@ evaluateProject' (TaskConfig config logger statter) proxy parser paths = either
modules <- topologicalSort <$> runImportGraphToModules proxy package
trace $ "evaluating with load order: " <> show (map (modulePath . moduleInfo) modules)
pure (id @(Evaluator _ Precise (Value _ Precise) _ _)
(runReader (lowerBound @(ModuleTable (NonEmpty (Module (ModuleResult Precise)))))
(runModuleTable
(runModules (ModuleTable.modulePaths (packageModules package))
(runReader (packageInfo package)
(runState (lowerBound @Span)
(runReader (lowerBound @Span)
(evaluate proxy id withTermSpans (Precise.runAllocator . Precise.runDeref) (fmap (Concrete.runBoolean . Concrete.runWhile) . Concrete.runFunction) modules)))))))
(raiseHandler (runReader (packageInfo package))
(raiseHandler (runState (lowerBound @Span))
(raiseHandler (runReader (lowerBound @Span))
(evaluate proxy id (evalTerm withTermSpans) modules)))))))
evaluatePythonProjects proxy parser lang path = runTaskWithOptions debugOptions $ do
project <- readProject Nothing path lang []
@ -110,24 +113,25 @@ evaluatePythonProjects proxy parser lang path = runTaskWithOptions debugOptions
modules <- topologicalSort <$> runImportGraphToModules proxy package
trace $ "evaluating with load order: " <> show (map (modulePath . moduleInfo) modules)
pure (id @(Evaluator _ Precise (Value _ Precise) _ _)
(runReader (lowerBound @(ModuleTable (NonEmpty (Module (ModuleResult Precise)))))
(runModuleTable
(runModules (ModuleTable.modulePaths (packageModules package))
(runReader (packageInfo package)
(runState (lowerBound @Span)
(runReader (lowerBound @Span)
(evaluate proxy id withTermSpans (Precise.runAllocator . Precise.runDeref) (fmap (Concrete.runBoolean . Concrete.runWhile) . Concrete.runFunction) modules)))))))
(raiseHandler (runReader (packageInfo package))
(raiseHandler (runState (lowerBound @Span))
(raiseHandler (runReader (lowerBound @Span))
(evaluate proxy id (evalTerm withTermSpans) modules)))))))
evaluateProjectWithCaching proxy parser path = runTaskWithOptions debugOptions $ do
project <- readProject Nothing path (Language.reflect proxy) []
package <- fmap (quieterm . snd) <$> parsePackage parser project
modules <- topologicalSort <$> runImportGraphToModules proxy package
pure (runReader (packageInfo package)
(runState (lowerBound @Span)
(runReader (lowerBound @Span)
(runReader (lowerBound @(ModuleTable (NonEmpty (Module (ModuleResult Monovariant)))))
pure (id @(Evaluator _ Monovariant _ _ _)
(raiseHandler (runReader (packageInfo package))
(raiseHandler (runState (lowerBound @Span))
(raiseHandler (runReader (lowerBound @Span))
(runModuleTable
(runModules (ModuleTable.modulePaths (packageModules package))
(evaluate proxy id withTermSpans (Monovariant.runAllocator . Monovariant.runDeref) (fmap (Type.runBoolean . Type.runWhile) . Type.runFunction) modules))))))
(evaluate proxy id (evalTerm withTermSpans) modules)))))))
parseFile :: Parser term -> FilePath -> IO term
@ -136,10 +140,10 @@ parseFile parser = runTask . (parse parser <=< readBlob . file)
blob :: FilePath -> IO Blob
blob = runTask . readBlob . file
mergeExcs :: Either (SomeExc (Sum excs)) (Either (SomeExc exc) result) -> Either (SomeExc (Sum (exc ': excs))) result
mergeExcs = either (\ (SomeExc sum) -> Left (SomeExc (weaken sum))) (either (\ (SomeExc exc) -> Left (SomeExc (inject exc))) Right)
mergeErrors :: Either (SomeError (Sum errs)) (Either (SomeError err) result) -> Either (SomeError (Sum (err ': errs))) result
mergeErrors = either (\ (SomeError sum) -> Left (SomeError (weaken sum))) (either (\ (SomeError err) -> Left (SomeError (inject err))) Right)
reassociate :: Either (SomeExc exc1) (Either (SomeExc exc2) (Either (SomeExc exc3) (Either (SomeExc exc4) (Either (SomeExc exc5) (Either (SomeExc exc6) (Either (SomeExc exc7) result)))))) -> Either (SomeExc (Sum '[exc7, exc6, exc5, exc4, exc3, exc2, exc1])) result
reassociate = mergeExcs . mergeExcs . mergeExcs . mergeExcs . mergeExcs . mergeExcs . mergeExcs . Right
reassociate :: Either (SomeError err1) (Either (SomeError err2) (Either (SomeError err3) (Either (SomeError err4) (Either (SomeError err5) (Either (SomeError err6) (Either (SomeError err7) result)))))) -> Either (SomeError (Sum '[err7, err6, err5, err4, err3, err2, err1])) result
reassociate = mergeErrors . mergeErrors . mergeErrors . mergeErrors . mergeErrors . mergeErrors . mergeErrors . Right
{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}

View File

@ -9,7 +9,7 @@ import Control.Category
import qualified Data.ByteString.Char8 as BC
import Text.Show.Pretty (pPrint)
import Control.Abstract.Matching
import Control.Matching
import Control.Rewriting hiding (fromMatcher, target)
import Data.Blob
import Data.File

View File

@ -6,7 +6,7 @@ import qualified Data.Abstract.ModuleTable as ModuleTable
import Data.Abstract.Number as Number
import Data.Abstract.Value.Concrete as Value
import Data.AST
import Control.Monad.Effect (SomeExc(..))
import Control.Effect.Resumable (SomeError(..))
import Data.List.NonEmpty (NonEmpty(..))
import Data.Sum
import qualified Language.Ruby.Assignment as Ruby
@ -36,7 +36,7 @@ spec config = parallel $ do
it "evaluates load with wrapper" $ do
(_, (_, res)) <- evaluate ["load-wrap.rb", "foo.rb"]
res `shouldBe` Left (SomeExc (inject @(BaseError (EnvironmentError Precise)) (BaseError (ModuleInfo "load-wrap.rb") emptySpan (FreeVariable "foo"))))
res `shouldBe` Left (SomeError (inject @(BaseError (EnvironmentError Precise)) (BaseError (ModuleInfo "load-wrap.rb") emptySpan (FreeVariable "foo"))))
it "evaluates subclass" $ do
(_, (heap, res)) <- evaluate ["subclass.rb"]

View File

@ -38,7 +38,7 @@ spec config = parallel $ do
it "fails exporting symbols not defined in the module" $ do
(_, (_, res)) <- evaluate ["bad-export.ts", "pip.ts", "a.ts", "foo.ts"]
res `shouldBe` Left (SomeExc (inject @(BaseError EvalError) (BaseError (ModuleInfo "foo.ts") emptySpan (ExportError "foo.ts" (name "pip")))))
res `shouldBe` Left (SomeError (inject @(BaseError EvalError) (BaseError (ModuleInfo "foo.ts") emptySpan (ExportError "foo.ts" (name "pip")))))
it "evaluates early return statements" $ do
(_, (heap, res)) <- evaluate ["early-return.ts"]

View File

@ -27,7 +27,7 @@ spec = parallel $ do
it "calls functions" $ do
(_, expected) <- evaluate $ do
identity <- function Nothing [name "x"] (coerce (variable (name "x")))
identity <- function Nothing [name "x"] (SpecEff (variable (name "x")))
recv <- box unit
addr <- box (integer 123)
call identity recv [addr]
@ -35,48 +35,49 @@ spec = parallel $ do
evaluate
= runM
. runIgnoringTrace
. runTraceByIgnoring
. runState (lowerBound @(Heap Precise Val))
. runFresh 0
. runFresh
. runReader (PackageInfo (name "test") mempty)
. runReader (ModuleInfo "test/Control/Abstract/Evaluator/Spec.hs")
. runReader (lowerBound @Span)
. runEvaluator
. fmap reassociate
. runValueError
. runEnvironmentError
. runAddressError
. Precise.runDeref @_ @_ @Val
. Precise.runAllocator
. runDeref @Val
. runAllocator
. (>>= deref . snd)
. runEnv lowerBound
. runReturn
. runLoopControl
. Value.runBoolean
. Value.runFunction coerce
. runBoolean
. runFunction runSpecEff
reassociate :: Either (SomeExc exc1) (Either (SomeExc exc2) (Either (SomeExc exc3) result)) -> Either (SomeExc (Sum '[exc3, exc2, exc1])) result
reassociate = mergeExcs . mergeExcs . mergeExcs . Right
reassociate :: Either (SomeError exc1) (Either (SomeError exc2) (Either (SomeError exc3) result)) -> Either (SomeError (Sum '[exc3, exc2, exc1])) result
reassociate = mergeErrors . mergeErrors . mergeErrors . Right
type Val = Value SpecEff Precise
newtype SpecEff = SpecEff
{ runSpecEff :: Eff '[ Function SpecEff Precise Val
, Boolean Val
, Exc (LoopControl Precise)
, Exc (Return Precise)
, Env Precise
, Allocator Precise
, Deref Val
, Resumable (BaseError (AddressError Precise Val))
, Resumable (BaseError (EnvironmentError Precise))
, Resumable (BaseError (ValueError SpecEff Precise))
, Reader Span
, Reader ModuleInfo
, Reader PackageInfo
, Fresh
, State (Heap Precise Val)
, Trace
, Lift IO
] Precise
{ runSpecEff :: Evaluator SpecEff Precise Val (FunctionC SpecEff Precise Val
(Eff (BooleanC Val
(Eff (ErrorC (LoopControl Precise)
(Eff (ErrorC (Return Precise)
(Eff (EnvC Precise
(Eff (AllocatorC Precise
(Eff (DerefC Precise Val
(Eff (ResumableC (BaseError (AddressError Precise Val))
(Eff (ResumableC (BaseError (EnvironmentError Precise))
(Eff (ResumableC (BaseError (ValueError SpecEff Precise))
(Eff (ReaderC Span
(Eff (ReaderC ModuleInfo
(Eff (ReaderC PackageInfo
(Eff (FreshC
(Eff (StateC (Heap Precise Val)
(Eff (TraceByIgnoringC
(Eff (LiftC IO)))))))))))))))))))))))))))))))))
Precise
}
instance Eq SpecEff where _ == _ = True

View File

@ -8,7 +8,7 @@ import qualified Data.ByteString as B
import Data.Either
import Data.Text (Text)
import Control.Abstract.Matching as Matching
import Control.Matching as Matching
import Control.Rewriting as Rewriting
import Data.History as History
import qualified Data.Source as Source

View File

@ -2,8 +2,7 @@ module Main (main) where
import Control.Exception (displayException)
import Control.Monad
import Control.Monad.Effect
import Control.Monad.Effect.Exception
import Control.Effect
import qualified Data.ByteString as B
import Data.ByteString.Builder
import qualified Data.ByteString.Char8 as BC
@ -100,7 +99,7 @@ languages =
-- , ("php", ".php") -- TODO: No parse-examples in tree-sitter yet
]
parseFilePath :: (Member (Exc SomeException) effs, Member Task effs, Member Files effs) => FilePath -> Eff effs Bool
parseFilePath :: (Member (Error SomeException) sig, Member Task sig, Member Files sig, Carrier sig m, Monad m) => FilePath -> m Bool
parseFilePath path = readBlob (file path) >>= runParse' >>= const (pure True)
languagesDir :: FilePath

View File

@ -2,7 +2,7 @@
module Matching.Go.Spec (spec) where
import Control.Abstract.Matching
import Control.Matching
import Data.Abstract.Module
import Data.List
import Data.Sum

View File

@ -2,6 +2,7 @@
module Rendering.TOC.Spec (spec) where
import Analysis.Declaration
import Control.Effect
import Data.Aeson hiding (defaultOptions)
import Data.Bifunctor
import Data.Bifunctor.Join
@ -16,7 +17,6 @@ import Data.Sum
import Data.Term
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8)
import Data.Union hiding (forAll)
import Diffing.Algorithm
import Diffing.Interpreter
import Prelude
@ -231,10 +231,12 @@ diffWithParser :: ( Eq1 syntax
, Diffable syntax
, HasDeclaration syntax
, Hashable1 syntax
, Member Distribute effs
, Member Task effs
, Member Distribute sig
, Member Task sig
, Carrier sig m
, Monad m
)
=> Parser (Term syntax Location)
-> BlobPair
-> Eff effs (Diff syntax (Maybe Declaration) (Maybe Declaration))
-> m (Diff syntax (Maybe Declaration) (Maybe Declaration))
diffWithParser parser blobs = distributeFor blobs (\ blob -> parse parser blob >>= decorate (declarationAlgebra blob)) >>= SpecHelpers.diff . runJoin

View File

@ -19,7 +19,7 @@ module SpecHelpers
import Control.Abstract
import Control.Arrow ((&&&))
import Control.Monad.Effect.Trace as X (runIgnoringTrace, runReturningTrace)
import Control.Effect.Trace as X (runTraceByIgnoring, runTraceByReturning)
import Control.Monad ((>=>))
import Data.Abstract.Address.Precise as X
import Data.Abstract.Environment as Env
@ -97,19 +97,18 @@ readFilePair :: Both FilePath -> IO BlobPair
readFilePair paths = let paths' = fmap file paths in
runBothWith F.readFilePair paths'
type TestEvaluatingEffects term
= '[ Resumable (BaseError (ValueError term Precise))
, Resumable (BaseError (AddressError Precise (Val term)))
, Resumable (BaseError ResolutionError)
, Resumable (BaseError EvalError)
, Resumable (BaseError (EnvironmentError Precise))
, Resumable (BaseError (UnspecializedError (Val term)))
, Resumable (BaseError (LoadError Precise))
, Fresh
, State (Heap Precise (Val term))
, Trace
, Lift IO
]
type TestEvaluatingC term
= ResumableC (BaseError (ValueError term Precise)) (Eff
( ResumableC (BaseError (AddressError Precise (Val term))) (Eff
( ResumableC (BaseError ResolutionError) (Eff
( ResumableC (BaseError EvalError) (Eff
( ResumableC (BaseError (EnvironmentError Precise)) (Eff
( ResumableC (BaseError (UnspecializedError (Val term))) (Eff
( ResumableC (BaseError (LoadError Precise)) (Eff
( FreshC (Eff
( StateC (Heap Precise (Val term)) (Eff
( TraceByReturningC (Eff
( LiftC IO))))))))))))))))))))
type TestEvaluatingErrors term
= '[ BaseError (ValueError term Precise)
, BaseError (AddressError Precise (Val term))
@ -119,19 +118,19 @@ type TestEvaluatingErrors term
, BaseError (UnspecializedError (Val term))
, BaseError (LoadError Precise)
]
testEvaluating :: Evaluator term Precise (Val term) (TestEvaluatingEffects term) (Span, a)
testEvaluating :: Evaluator term Precise (Val term) (TestEvaluatingC term) (Span, a)
-> IO
( [String]
, ( Heap Precise (Val term)
, Either (SomeExc (Data.Sum.Sum (TestEvaluatingErrors term)))
a
, Either (SomeError (Data.Sum.Sum (TestEvaluatingErrors term))) a
)
)
testEvaluating
= runM
. runReturningTrace
. runTraceByReturning
. runState lowerBound
. runFresh 0
. runFresh
. runEvaluator
. fmap reassociate
. runLoadError
. runUnspecialized
@ -139,7 +138,7 @@ testEvaluating
. runEvalError
. runResolutionError
. runAddressError
. runValueError @_ @_ @Precise
. runValueError @_ @_ @_ @Precise
. fmap snd
type Val term = Value term Precise
@ -157,12 +156,13 @@ namespaceScope :: Heap Precise (Value term Precise)
namespaceScope heap ns@(Namespace _ _ _)
= either (const Nothing) (snd . snd)
. run
. runFresh 0
. runFresh
. runEvaluator
. runAddressError
. runState heap
. runState (lowerBound @Span)
. runReader (lowerBound @Span)
. runReader (ModuleInfo "SpecHelper.hs")
. raiseHandler (runState heap)
. raiseHandler (runState (lowerBound @Span))
. raiseHandler (runReader (lowerBound @Span))
. raiseHandler (runReader (ModuleInfo "SpecHelper.hs"))
. runDeref
$ materializeEnvironment ns

1
vendor/effects vendored

@ -1 +0,0 @@
Subproject commit 9616e462c58645b0017cbc66858e7123cdf77611

1
vendor/fused-effects vendored Submodule

@ -0,0 +1 @@
Subproject commit 5f11d009d486b4e7e1741d0d031f8818818856ea