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:
commit
5cac709075
.gitmodules
.licenses/semantic/cabal
semantic.cabalsrc
Analysis
Abstract
ConstructorName.hsAssigning
Control
Abstract.hs
Abstract
Context.hsEnvironment.hsEvaluator.hsHeap.hsModules.hsPrimitive.hsPythonPackage.hsRoots.hsScopeGraph.hsValue.hs
Effect
Matching.hsRewriting.hsData
Abstract
Blob.hsGraph.hsGraph
JSON
Location.hsProject.hsSyntax.hsSyntax
Diffing
Language
Go
JSON
Java
PHP
Python
Ruby
TypeScript
Matching
Parsing
Prologue.hsRendering
Reprinting
Semantic
test
vendor
6
.gitmodules
vendored
6
.gitmodules
vendored
@ -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
|
||||
|
42
.licenses/semantic/cabal/MonadRandom.txt
Normal file
42
.licenses/semantic/cabal/MonadRandom.txt
Normal 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.
|
38
.licenses/semantic/cabal/fused-effects.txt
Normal file
38
.licenses/semantic/cabal/fused-effects.txt
Normal 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.
|
@ -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
|
||||
|
@ -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 don’t 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.
|
||||
|
@ -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 don’t 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.
|
||||
|
@ -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)
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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 program’s execution.
|
||||
|
@ -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.
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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 aren’t 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 they’re 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
|
||||
|
@ -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)
|
||||
|
@ -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 we’ve 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
|
||||
|
@ -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
|
||||
|
@ -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))
|
||||
|
@ -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)
|
||||
|
@ -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))
|
||||
|
@ -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
|
||||
|
49
src/Control/Effect/Interpose.hs
Normal file
49
src/Control/Effect/Interpose.hs
Normal 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 effect’s 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)
|
@ -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'
|
@ -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))
|
||||
|
||||
--
|
||||
|
@ -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)
|
||||
|
@ -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)
|
||||
|
@ -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)))
|
||||
|
@ -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)))
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
||||
|
||||
|
@ -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'.
|
||||
|
@ -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
|
||||
|
@ -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 closure’s 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 closure’s 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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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] }
|
||||
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -6,7 +6,7 @@ module Data.Location
|
||||
, Range(..)
|
||||
) where
|
||||
|
||||
import Prologue (Generic (..), NFData (..))
|
||||
import Prologue (Generic, NFData (..))
|
||||
|
||||
import Data.JSON.Fields
|
||||
import Data.Range
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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)
|
||||
|
@ -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)
|
||||
|
@ -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.
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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]}
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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)
|
||||
|
||||
|
@ -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
|
||||
|
@ -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'
|
||||
|
@ -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)
|
||||
|
@ -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
|
||||
|
||||
|
@ -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
|
||||
|
@ -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)
|
||||
|
@ -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.
|
||||
|
@ -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
|
||||
|
@ -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)
|
||||
|
@ -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))
|
||||
|
@ -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
131
src/Semantic/Analysis.hs
Normal 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
|
@ -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)
|
||||
|
@ -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)
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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)
|
||||
|
@ -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
|
||||
|
@ -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))
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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)
|
||||
|
@ -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)
|
||||
|
@ -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) #-}
|
||||
|
@ -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
|
||||
|
@ -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"]
|
||||
|
@ -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"]
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
vendor/effects
vendored
@ -1 +0,0 @@
|
||||
Subproject commit 9616e462c58645b0017cbc66858e7123cdf77611
|
1
vendor/fused-effects
vendored
Submodule
1
vendor/fused-effects
vendored
Submodule
@ -0,0 +1 @@
|
||||
Subproject commit 5f11d009d486b4e7e1741d0d031f8818818856ea
|
Loading…
Reference in New Issue
Block a user