github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-01 09:15:01 +03:00
Code Issues Projects Releases Wiki Activity

Merge branch 'master' into javascript-parse-examples

Browse Source
This commit is contained in:
Timothy Clem 2018-09-19 07:54:52 -07:00 committed by GitHub
commit 20ccdc19de
33 changed files with 792 additions and 175 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.licenses/semantic/cabal/mwc-random.txt
View File

@ -1,7 +1,7 @@
---
type: cabal
name: mwc-random
version: 0.13.6.0
version: 0.13.3.2
summary: Fast, high quality pseudo random number generation
homepage: https://github.com/bos/mwc-random
license: bsd-2-clause

8
semantic.cabal
View File

@ -19,7 +19,8 @@ library
hs-source-dirs: src
exposed-modules:
-- Analyses & term annotations
Analysis.Abstract.Caching
Analysis.Abstract.Caching.FlowInsensitive
, Analysis.Abstract.Caching.FlowSensitive
, Analysis.Abstract.Collecting
, Analysis.Abstract.Dead
, Analysis.Abstract.Graph
@ -35,7 +36,6 @@ library
, Assigning.Assignment.Table
-- Control structures & interfaces for abstract interpretation
, Control.Abstract
, Control.Abstract.Configuration
, Control.Abstract.Context
, Control.Abstract.Environment
, Control.Abstract.Evaluator
@ -46,6 +46,7 @@ library
, Control.Abstract.Primitive
, Control.Abstract.PythonPackage
, Control.Abstract.Roots
, Control.Abstract.ScopeGraph
, Control.Abstract.TermEvaluator
, Control.Abstract.Value
-- Datatypes for abstract interpretation
@ -54,8 +55,6 @@ library
, Data.Abstract.Address.Monovariant
, Data.Abstract.Address.Precise
, Data.Abstract.BaseError
, Data.Abstract.Cache
, Data.Abstract.Configuration
, Data.Abstract.Declarations
, Data.Abstract.Environment
, Data.Abstract.Evaluatable
@ -70,6 +69,7 @@ library
, Data.Abstract.Package
, Data.Abstract.Path
, Data.Abstract.Ref
, Data.Abstract.ScopeGraph
, Data.Abstract.Value.Abstract
, Data.Abstract.Value.Concrete
, Data.Abstract.Value.Type

173
src/Analysis/Abstract/Caching/FlowInsensitive.hs Normal file
View File

@ -0,0 +1,173 @@
{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, TypeOperators #-}
module Analysis.Abstract.Caching.FlowInsensitive
( cachingTerms
, convergingModules
, caching
) where
import Control.Abstract
import Data.Abstract.BaseError
import Data.Abstract.Environment
import Data.Abstract.Module
import Data.Abstract.Ref
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)
=> Configuration term address
-> TermEvaluator term address value effects (Set (ValueRef address))
consultOracle configuration = fromMaybe mempty . cacheLookup configuration <$> ask
-- | Run an action with the given in-cache.
withOracle :: Member (Reader (Cache term address)) effects
=> Cache term address
-> TermEvaluator term address value effects a
-> TermEvaluator term address value effects 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)
=> Configuration term address
-> TermEvaluator term address value effects (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)
=> Configuration term address
-> Set (ValueRef address)
-> TermEvaluator term address value effects (ValueRef address)
-> TermEvaluator term address value effects (ValueRef address)
cachingConfiguration configuration values action = do
modify' (cacheSet configuration values)
result <- action
result <$ modify' (cacheInsert configuration result)
putCache :: Member (State (Cache term address)) effects
=> Cache term address
-> TermEvaluator term address value effects ()
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)
=> TermEvaluator term address value effects a
-> TermEvaluator term address value effects (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 :: ( Corecursive term
, Member (Env address) effects
, Member NonDet effects
, Member (Reader (Cache term address)) effects
, Member (Reader (Live address)) effects
, Member (State (Cache term address)) effects
, Ord address
, Ord term
)
=> SubtermAlgebra (Base term) term (TermEvaluator term address value effects (ValueRef address))
-> SubtermAlgebra (Base term) term (TermEvaluator term address value effects (ValueRef address))
cachingTerms recur term = do
c <- getConfiguration (embedSubterm term)
cached <- lookupCache c
case cached of
Just values -> scatter values
Nothing -> do
values <- consultOracle c
cachingConfiguration c values (recur term)
convergingModules :: ( AbstractValue address value effects
, Effects effects
, 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
, Ord address
, Ord term
)
=> SubtermAlgebra Module term (TermEvaluator term address value effects address)
-> SubtermAlgebra Module term (TermEvaluator term address value effects address)
convergingModules recur m = do
c <- getConfiguration (subterm (moduleBody m))
heap <- TermEvaluator getHeap
-- Convergence here is predicated upon an Eq instance, not α-equivalence
(cache, _) <- converge (lowerBound, heap) (\ (prevCache, _) -> isolateCache $ do
TermEvaluator (putEvalContext (configurationContext c))
-- We need to reset fresh generation so that this invocation converges.
resetFresh 0 $
-- 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)))
TermEvaluator (address =<< runTermEvaluator (maybe empty scatter (cacheLookup c cache)))
-- | Iterate a monadic action starting from some initial seed until the results converge.
--
-- This applies the Kleene fixed-point theorem to finitize a monotone action. cf https://en.wikipedia.org/wiki/Kleene_fixed-point_theorem
converge :: (Eq a, Monad m)
=> a -- ^ An initial seed value to iterate from.
-> (a -> m a) -- ^ A monadic action to perform at each iteration, starting from the result of the previous iteration or from the seed value for the first iteration.
-> m a -- ^ A computation producing the least fixed point (the first value at which the actions converge).
converge seed f = loop seed
where loop x = do
x' <- f x
if x' == x then
pure x
else
loop x'
-- | Nondeterministically write each of a collection of stores & return their associated results.
scatter :: (Foldable t, Member NonDet effects) => t (ValueRef address) -> TermEvaluator term address value effects (ValueRef address)
scatter = foldMapA pure
-- | Get the current 'Configuration' with a passed-in term.
getConfiguration :: (Member (Reader (Live address)) effects, Member (Env address) effects)
=> term
-> TermEvaluator term address value effects (Configuration term address)
getConfiguration term = Configuration term <$> TermEvaluator askRoots <*> TermEvaluator getEvalContext
caching :: Effects effects => TermEvaluator term address value (NonDet ': Reader (Cache term address) ': State (Cache term address) ': effects) a -> TermEvaluator term address value effects (Cache term address, [a])
caching
= runState lowerBound
. runReader lowerBound
. runNonDet
-- | A map of 'Configuration's to 'Set's of resulting values & 'Heap's.
newtype Cache term address = Cache { unCache :: Monoidal.Map (Configuration term address) (Set (ValueRef address)) }
deriving (Eq, Lower, Monoid, Ord, Reducer (Configuration term address, ValueRef address), Semigroup)
-- | A single point in a program’s execution.
data Configuration term address = Configuration
{ configurationTerm :: term -- ^ The “instruction,” i.e. the current term to evaluate.
, configurationRoots :: Live address -- ^ The set of rooted addresses.
, configurationContext :: EvalContext address -- ^ The evaluation context in 'configurationTerm'.
}
deriving (Eq, Ord, Show)
-- | Look up the resulting value & 'Heap' for a given 'Configuration'.
cacheLookup :: (Ord address, Ord term) => Configuration term address -> Cache term address -> Maybe (Set (ValueRef address))
cacheLookup key = Monoidal.lookup key . unCache
-- | Set the resulting value & 'Heap' for a given 'Configuration', overwriting any previous entry.
cacheSet :: (Ord address, Ord term) => Configuration term address -> Set (ValueRef address) -> Cache term address -> Cache term address
cacheSet key value = Cache . Monoidal.insert key value . unCache
-- | Insert the resulting value & 'Heap' for a given 'Configuration', appending onto any previous entry.
cacheInsert :: (Ord address, Ord term) => Configuration term address -> ValueRef address -> Cache term address -> Cache term address
cacheInsert = curry cons
instance (Show term, Show address) => Show (Cache term address) where
showsPrec d = showsUnaryWith showsPrec "Cache" d . map (second toList) . Monoidal.pairs . unCache

51
src/Analysis/Abstract/Caching.hs → src/Analysis/Abstract/Caching/FlowSensitive.hs
View File

@ -1,17 +1,16 @@
{-# LANGUAGE GADTs, TypeOperators #-}
module Analysis.Abstract.Caching
{-# LANGUAGE ConstraintKinds, GADTs, GeneralizedNewtypeDeriving, TypeOperators #-}
module Analysis.Abstract.Caching.FlowSensitive
( cachingTerms
, convergingModules
, caching
) where
import Control.Abstract.Configuration
import Control.Abstract
import Data.Abstract.Cache
import Data.Abstract.BaseError
import Data.Abstract.Environment
import Data.Abstract.Module
import Data.Abstract.Ref
import Data.Map.Monoidal as Monoidal
import Prologue
-- | Look up the set of values for a given configuration in the in-cache.
@ -129,9 +128,53 @@ converge seed f = loop seed
scatter :: (Foldable t, Member NonDet effects, Member (State (Heap address value)) effects) => t (Cached address value) -> TermEvaluator term address value effects (ValueRef address)
scatter = foldMapA (\ (Cached value heap') -> TermEvaluator (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)
=> term
-> TermEvaluator term address value effects (Configuration term address value)
getConfiguration term = Configuration term <$> TermEvaluator askRoots <*> TermEvaluator getEvalContext <*> TermEvaluator getHeap
caching :: Effects effects => TermEvaluator term address value (NonDet ': Reader (Cache term address value) ': State (Cache term address value) ': effects) a -> TermEvaluator term address value effects (Cache term address value, [a])
caching
= runState lowerBound
. runReader lowerBound
. runNonDet
-- | A map of 'Configuration's to 'Set's of resulting values & 'Heap's.
newtype Cache term address value = Cache { unCache :: Monoidal.Map (Configuration term address value) (Set (Cached address value)) }
deriving (Eq, Lower, Monoid, Ord, Reducer (Configuration term address value, Cached address value), Semigroup)
-- | A single point in a program’s execution.
data Configuration term address value = Configuration
{ configurationTerm :: term -- ^ The “instruction,” i.e. the current term to evaluate.
, configurationRoots :: Live address -- ^ The set of rooted addresses.
, configurationContext :: EvalContext address -- ^ The evaluation context in 'configurationTerm'.
, configurationHeap :: Heap address value -- ^ The heap of values.
}
deriving (Eq, Ord, Show)
data Cached address value = Cached
{ cachedValue :: ValueRef address
, cachedHeap :: Heap address value
}
deriving (Eq, Ord, Show)
type Cacheable term address value = (Ord address, Ord term, Ord value)
-- | Look up the resulting value & 'Heap' for a given 'Configuration'.
cacheLookup :: Cacheable term address value => Configuration term address value -> Cache term address value -> Maybe (Set (Cached address value))
cacheLookup key = Monoidal.lookup key . unCache
-- | Set the resulting value & 'Heap' for a given 'Configuration', overwriting any previous entry.
cacheSet :: Cacheable term address value => Configuration term address value -> Set (Cached address value) -> Cache term address value -> Cache term address value
cacheSet key value = Cache . Monoidal.insert key value . unCache
-- | Insert the resulting value & 'Heap' for a given 'Configuration', appending onto any previous entry.
cacheInsert :: Cacheable term address value => Configuration term address value -> Cached address value -> Cache term address value -> Cache term address value
cacheInsert = curry cons
instance (Show term, Show address, Show value) => Show (Cache term address value) where
showsPrec d = showsUnaryWith showsPrec "Cache" d . map (second toList) . Monoidal.pairs . unCache

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

@ -4,9 +4,9 @@ module Analysis.Abstract.Tracing
, tracing
) where
import Control.Abstract.Configuration
import Control.Abstract hiding (trace)
import Control.Monad.Effect.Writer
import Data.Abstract.Environment
import Data.Semigroup.Reducer as Reducer
import Prologue
@ -14,7 +14,6 @@ import Prologue
--
-- Instantiating @trace@ to @[]@ yields a linear trace analysis, while @Set@ yields a reachable state analysis.
tracingTerms :: ( Corecursive term
, Member (Reader (Live address)) effects
, Member (Env address) effects
, Member (State (Heap address value)) effects
, Member (Writer (trace (Configuration term address value))) effects
@ -30,3 +29,18 @@ trace = tell
tracing :: (Monoid (trace (Configuration term address value)), Effects effects) => TermEvaluator term address value (Writer (trace (Configuration term address value)) ': effects) a -> TermEvaluator term address value effects (trace (Configuration term address value), a)
tracing = runWriter
-- | Get the current 'Configuration' with a passed-in term.
getConfiguration :: (Member (Env address) effects, Member (State (Heap address value)) effects)
=> term
-> TermEvaluator term address value effects (Configuration term address value)
getConfiguration term = Configuration term <$> TermEvaluator getEvalContext <*> TermEvaluator getHeap
-- | A single point in a program’s execution.
data Configuration term address value = Configuration
{ configurationTerm :: term -- ^ The “instruction,” i.e. the current term to evaluate.
, configurationContext :: EvalContext address -- ^ The evaluation context in 'configurationTerm'.
, configurationHeap :: Heap address value -- ^ The heap of values.
}
deriving (Eq, Ord, Show)

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

@ -1,15 +0,0 @@
module Control.Abstract.Configuration
( getConfiguration
) where
import Control.Abstract.Environment
import Control.Abstract.Heap
import Control.Abstract.Roots
import Control.Abstract.TermEvaluator
-- | 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)
=> term
-> TermEvaluator term address value effects (Configuration term address value)
getConfiguration term = Configuration term <$> TermEvaluator askRoots <*> TermEvaluator getEvalContext <*> TermEvaluator getHeap

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

@ -8,11 +8,13 @@ module Control.Abstract.Context
, Span
, currentSpan
, withCurrentSpan
, modifyChildSpan
, withCurrentCallStack
) where
import Control.Monad.Effect
import Control.Monad.Effect.Reader
import Control.Monad.Effect.State
import Data.Abstract.Module
import Data.Abstract.Package
import Data.Span
@ -43,6 +45,8 @@ currentSpan = ask
withCurrentSpan :: (Effectful m, Member (Reader Span) effects) => Span -> m effects a -> m effects 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))
-- | 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

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

@ -1,7 +1,6 @@
{-# LANGUAGE GADTs, KindSignatures, RankNTypes, TypeOperators, UndecidableInstances #-}
module Control.Abstract.Heap
( Heap
, Configuration(..)
, Live
, getHeap
, putHeap
@ -22,7 +21,6 @@ module Control.Abstract.Heap
import Control.Abstract.Evaluator
import Control.Abstract.Roots
import Data.Abstract.Configuration
import Data.Abstract.BaseError
import Data.Abstract.Heap
import Data.Abstract.Live

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

@ -30,8 +30,9 @@ import qualified Data.Set as Set
import Data.Span
import Prologue
import System.FilePath.Posix (takeDirectory)
import Data.Abstract.ScopeGraph
type ModuleResult address = (Bindings address, address)
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 address value effects (Maybe (ModuleResult address))
@ -94,7 +95,7 @@ askModuleTable = ask
newtype Merging address = Merging { runMerging :: ModuleResult address }
instance Semigroup (Merging address) where
Merging (binds1, _) <> Merging (binds2, addr) = Merging (binds1 <> binds2, addr)
Merging (_, (binds1, _)) <> Merging (graph2, (binds2, addr)) = Merging (graph2, (binds1 <> binds2, addr))
-- | An error thrown when loading a module from the list of provided modules. Indicates we weren't able to find a module with the given name.

98
src/Control/Abstract/ScopeGraph.hs Normal file
View File

@ -0,0 +1,98 @@
{-# LANGUAGE GADTs, KindSignatures, LambdaCase, RankNTypes, ScopedTypeVariables, TypeOperators #-}
module Control.Abstract.ScopeGraph
( runScopeEnv
, ScopeEnv
, lookup
, declare
, reference
, newScope
, Declaration(..)
, Reference(..)
, EdgeLabel(..)
, currentScope
, withScope
, associatedScope
, putDeclarationScope
) where
import Control.Abstract.Evaluator hiding (Local)
import Control.Abstract.Heap
import Data.Abstract.Name
import Data.Abstract.ScopeGraph (Declaration (..), EdgeLabel, Reference, ScopeGraph)
import qualified Data.Abstract.ScopeGraph as ScopeGraph
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)
lookup :: forall address value effects. Member (ScopeEnv address) effects => Reference -> Evaluator address value effects (Maybe address)
lookup = send . Lookup @address
declare :: forall address value effects. Member (ScopeEnv address) effects => Declaration -> Span -> Maybe address -> Evaluator address value effects ()
declare = ((send .) .) . Declare @address
putDeclarationScope :: forall address value effects. Member (ScopeEnv address) effects => Declaration -> address -> Evaluator address value effects ()
putDeclarationScope = (send .) . PutDeclarationScope @address
reference :: forall address value effects. Member (ScopeEnv address) effects => Reference -> Declaration -> Evaluator address value effects ()
reference = (send .) . Reference @address
newScope :: forall address value effects. (Member (ScopeEnv address) effects) => Map EdgeLabel [address] -> Evaluator address value effects address
newScope map = send (NewScope map)
currentScope :: forall address value effects. Member (ScopeEnv address) effects => Evaluator address value effects (Maybe address)
currentScope = send CurrentScope
associatedScope :: forall address value effects. Member (ScopeEnv address) effects => Declaration -> Evaluator address value effects (Maybe address)
associatedScope = send . AssociatedScope
withScope :: forall address value effects m a. (Effectful (m address value), Member (ScopeEnv address) effects) => address -> m address value effects a -> m address value effects a
withScope scope action = send (Local scope (lowerEff action))
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)
runScopeEnv :: (Ord address, Effects effects, Member Fresh effects, Member (Allocator address) effects)
=> Evaluator address value (ScopeEnv address ': effects) a
-> Evaluator address value effects (ScopeGraph address, a)
runScopeEnv evaluator = runState lowerBound (reinterpret handleScopeEnv evaluator)
handleScopeEnv :: forall address value effects a. (Ord address, Member Fresh effects, Member (Allocator address) effects, Effects effects)
=> ScopeEnv address (Eff (ScopeEnv address ': effects)) a
-> Evaluator 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

48
src/Data/Abstract/Cache.hs
View File

@ -1,48 +0,0 @@
{-# LANGUAGE ConstraintKinds, GeneralizedNewtypeDeriving, TypeFamilies #-}
module Data.Abstract.Cache
( Cache
, Cached (..)
, Cacheable
, cacheLookup
, cacheSet
, cacheInsert
, cacheKeys
) where
import Data.Abstract.Configuration
import Data.Abstract.Heap
import Data.Abstract.Ref
import Data.Map.Monoidal as Monoidal
import Prologue
-- | A map of 'Configuration's to 'Set's of resulting values & 'Heap's.
newtype Cache term address value = Cache { unCache :: Monoidal.Map (Configuration term address value) (Set (Cached address value)) }
deriving (Eq, Lower, Monoid, Ord, Reducer (Configuration term address value, Cached address value), Semigroup)
data Cached address value = Cached
{ cachedValue :: ValueRef address
, cachedHeap :: Heap address value
}
deriving (Eq, Ord, Show)
type Cacheable term address value = (Ord address, Ord term, Ord value)
-- | Look up the resulting value & 'Heap' for a given 'Configuration'.
cacheLookup :: Cacheable term address value => Configuration term address value -> Cache term address value -> Maybe (Set (Cached address value))
cacheLookup key = Monoidal.lookup key . unCache
-- | Set the resulting value & 'Heap' for a given 'Configuration', overwriting any previous entry.
cacheSet :: Cacheable term address value => Configuration term address value -> Set (Cached address value) -> Cache term address value -> Cache term address value
cacheSet key value = Cache . Monoidal.insert key value . unCache
-- | Insert the resulting value & 'Heap' for a given 'Configuration', appending onto any previous entry.
cacheInsert :: Cacheable term address value => Configuration term address value -> Cached address value -> Cache term address value -> Cache term address value
cacheInsert = curry cons
-- | Return all 'Configuration's in the provided cache.
cacheKeys :: Cache term address value -> [Configuration term address value]
cacheKeys = Monoidal.keys . unCache
instance (Show term, Show address, Show value) => Show (Cache term address value) where
showsPrec d = showsUnaryWith showsPrec "Cache" d . map (second toList) . Monoidal.pairs . unCache

14
src/Data/Abstract/Configuration.hs
View File

@ -1,14 +0,0 @@
module Data.Abstract.Configuration ( Configuration (..) ) where
import Data.Abstract.Environment
import Data.Abstract.Heap
import Data.Abstract.Live
-- | A single point in a program’s execution.
data Configuration term address value = Configuration
{ configurationTerm :: term -- ^ The “instruction,” i.e. the current term to evaluate.
, configurationRoots :: Live address -- ^ The set of rooted addresses.
, configurationContext :: EvalContext address -- ^ The evaluation context in 'configurationTerm'.
, configurationHeap :: Heap address value -- ^ The heap of values.
}
deriving (Eq, Ord, Show)

8
src/Data/Abstract/Evaluatable.hs
View File

@ -28,6 +28,7 @@ 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(..))
import Control.Abstract.ScopeGraph
import Data.Abstract.Declarations as X
import Data.Abstract.Environment as X
import Data.Abstract.BaseError as X
@ -53,6 +54,7 @@ class (Show1 constr, Foldable constr) => Evaluatable constr where
, Member (Allocator address) effects
, Member (Boolean value) effects
, Member (Deref value) effects
, Member (ScopeEnv address) effects
, Member (Env address) effects
, Member (Exc (LoopControl address)) effects
, Member (Exc (Return address)) effects
@ -62,6 +64,7 @@ class (Show1 constr, Foldable constr) => Evaluatable constr where
, 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
@ -82,6 +85,7 @@ type ModuleEffects address value rest
= Exc (LoopControl address)
': Exc (Return address)
': Env address
': ScopeEnv address
': Deref value
': Allocator address
': Reader ModuleInfo
@ -104,6 +108,7 @@ evaluate :: ( AbstractValue address value valueEffects
, 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
@ -124,7 +129,7 @@ evaluate :: ( AbstractValue address value valueEffects
-> [Module term]
-> TermEvaluator term address value effects (ModuleTable (NonEmpty (Module (ModuleResult address))))
evaluate lang analyzeModule analyzeTerm runAllocDeref runValue modules = do
(preludeBinds, _) <- TermEvaluator . runInModule lowerBound moduleInfoFromCallStack . runValue $ do
(_, (preludeBinds, _)) <- TermEvaluator . runInModule lowerBound moduleInfoFromCallStack . runValue $ do
definePrelude lang
box unit
foldr (run preludeBinds) ask modules
@ -143,6 +148,7 @@ evaluate lang analyzeModule analyzeTerm runAllocDeref runValue modules = do
runInModule preludeBinds info
= runReader info
. runAllocDeref
. runScopeEnv
. runEnv (EvalContext Nothing (X.push (newEnv preludeBinds)))
. runReturn
. runLoopControl

242
src/Data/Abstract/ScopeGraph.hs Normal file
View File

@ -0,0 +1,242 @@
{-# LANGUAGE GADTs #-}
module Data.Abstract.ScopeGraph
( ScopeGraph(..)
, Path
, pathDeclaration
, Reference(..)
, Declaration(..)
, EdgeLabel(..)
, Frame
, Heap
, frameLookup
, scopeLookup
, frameSlots
, frameLinks
, getSlot
, setSlot
, lookup
, scopeOfRef
, pathOfRef
, declare
, reference
, newScope
, associatedScope
, insertDeclarationScope
, newFrame
, initFrame
, insertFrame
, fillFrame
, deleteFrame
, heapSize
) where
import Data.Abstract.Name
import qualified Data.Map.Strict as Map
import Data.Span
import Prelude hiding (lookup)
import Prologue
data Scope scopeAddress = Scope {
edges :: Map EdgeLabel [scopeAddress] -- Maybe Map EdgeLabel [Path scope]?
, references :: Map Reference (Path scopeAddress)
, declarations :: Map Declaration (Span, Maybe scopeAddress)
} deriving (Eq, Show, Ord)
data ScopeGraph scope = ScopeGraph { graph :: Map scope (Scope scope), currentScope :: Maybe scope }
instance Ord scope => Lower (ScopeGraph scope) where
lowerBound = ScopeGraph mempty Nothing
deriving instance Eq address => Eq (ScopeGraph address)
deriving instance Show address => Show (ScopeGraph address)
deriving instance Ord address => Ord (ScopeGraph address)
data Path scope where
-- | Construct a direct path to a declaration.
DPath :: Declaration -> Path scope
-- | Construct an edge from a scope to another declaration path.
EPath :: EdgeLabel -> scope -> Path scope -> Path scope
deriving instance Eq scope => Eq (Path scope)
deriving instance Show scope => Show (Path scope)
deriving instance Ord scope => Ord (Path scope)
-- Returns the declaration of a path.
pathDeclaration :: Path scope -> Declaration
pathDeclaration (DPath d) = d
pathDeclaration (EPath _ _ p) = pathDeclaration p
-- Returns the reference paths of a scope in a scope graph.
pathsOfScope :: Ord scope => scope -> ScopeGraph scope -> Maybe (Map Reference (Path scope))
pathsOfScope scope = fmap references . Map.lookup scope . graph
-- Returns the declaration data of a scope in a scope graph.
ddataOfScope :: Ord scope => scope -> ScopeGraph scope -> Maybe (Map Declaration (Span, Maybe scope))
ddataOfScope scope = fmap declarations . Map.lookup scope . graph
-- Returns the edges of a scope in a scope graph.
linksOfScope :: Ord scope => scope -> ScopeGraph scope -> Maybe (Map EdgeLabel [scope])
linksOfScope scope = fmap edges . Map.lookup scope . graph
-- Lookup a scope in the scope graph.
lookupScope :: Ord scope => scope -> ScopeGraph scope -> Maybe (Scope scope)
lookupScope scope = Map.lookup scope . graph
-- Declare a declaration with a span and an associated scope in the scope graph.
declare :: Ord scope => Declaration -> Span -> Maybe scope -> ScopeGraph scope -> ScopeGraph scope
declare declaration ddata assocScope g@ScopeGraph{..} = fromMaybe g $ do
scopeKey <- currentScope
scope <- lookupScope scopeKey g
let newScope = scope { declarations = Map.insert declaration (ddata, assocScope) (declarations scope) }
pure $ g { graph = Map.insert scopeKey newScope graph }
-- | Add a reference to a declaration in the scope graph.
-- Returns the original scope graph if the declaration could not be found.
reference :: Ord scope => Reference -> Declaration -> ScopeGraph scope -> ScopeGraph scope
reference ref declaration g@ScopeGraph{..} = fromMaybe g $ do
currentAddress <- currentScope
currentScope' <- lookupScope currentAddress g
go currentAddress currentScope' currentAddress id
where
declDataOfScope address = do
dataMap <- ddataOfScope address g
Map.lookup declaration dataMap
go currentAddress currentScope address path =
case declDataOfScope address of
Just _ ->
let newScope = currentScope { references = Map.insert ref (path (DPath declaration)) (references currentScope) }
in Just (g { graph = Map.insert currentAddress newScope graph })
Nothing -> let
traverseEdges edge = do
linkMap <- linksOfScope address g
scopes <- Map.lookup edge linkMap
-- Return the first path to the declaration through the scopes.
getFirst (foldMap (First . ap (go currentAddress currentScope) ((path .) . EPath edge)) scopes)
in traverseEdges Import <|> traverseEdges Lexical
-- | Insert associate the given address to a declaration in the scope graph.
insertDeclarationScope :: Ord address => Declaration -> address -> ScopeGraph address -> ScopeGraph address
insertDeclarationScope decl address g@ScopeGraph{..} = fromMaybe g $ do
declScope <- scopeOfDeclaration decl g
scope <- lookupScope declScope g
(span, _) <- Map.lookup decl (declarations scope)
pure $ g { graph = Map.insert declScope (scope { declarations = Map.insert decl (span, Just address) (declarations scope) }) graph }
-- | Insert a new scope with the given address and edges into the scope graph.
newScope :: Ord address => address -> Map EdgeLabel [address] -> ScopeGraph address -> ScopeGraph address
newScope address edges g@ScopeGraph{..} = g { graph = Map.insert address newScope graph }
where
newScope = Scope edges mempty mempty
-- | Returns the scope of a reference in the scope graph.
scopeOfRef :: Ord scope => Reference -> ScopeGraph scope -> Maybe scope
scopeOfRef ref g@ScopeGraph{..} = go (Map.keys graph)
where
go (s : scopes') = fromMaybe (go scopes') $ do
pathMap <- pathsOfScope s g
_ <- Map.lookup ref pathMap
pure (Just s)
go [] = Nothing
-- | Returns the path of a reference in the scope graph.
pathOfRef :: (Ord scope) => Reference -> ScopeGraph scope -> Maybe (Path scope)
pathOfRef ref graph = do
scope <- scopeOfRef ref graph
pathsMap <- pathsOfScope scope graph
Map.lookup ref pathsMap
-- Returns the scope the declaration was declared in.
scopeOfDeclaration :: Ord scope => Declaration -> ScopeGraph scope -> Maybe scope
scopeOfDeclaration declaration g@ScopeGraph{..} = go (Map.keys graph)
where
go (s : scopes') = fromMaybe (go scopes') $ do
ddataMap <- ddataOfScope s g
_ <- Map.lookup declaration ddataMap
pure (Just s)
go [] = Nothing
-- | Returns the scope associated with a declaration (the child scope if any exists).
associatedScope :: Ord scope => Declaration -> ScopeGraph scope -> Maybe scope
associatedScope declaration g@ScopeGraph{..} = go (Map.keys graph)
where
go (s : scopes') = fromMaybe (go scopes') $ do
ddataMap <- ddataOfScope s g
(_, assocScope) <- Map.lookup declaration ddataMap
pure assocScope
go [] = Nothing
newtype Reference = Reference Name
deriving (Eq, Ord, Show)
newtype Declaration = Declaration Name
deriving (Eq, Ord, Show)
-- | The type of edge from a scope to its parent scopes.
-- Either a lexical edge or an import edge in the case of non-lexical edges.
data EdgeLabel = Lexical | Import
deriving (Eq, Ord, Show)
data Frame scopeAddress frameAddress value = Frame {
scopeAddress :: scopeAddress
, links :: Map EdgeLabel (Map scopeAddress frameAddress)
, slots :: Map Declaration value
}
newtype Heap scopeAddress frameAddress value = Heap { unHeap :: Map frameAddress (Frame scopeAddress frameAddress value) }
-- | Look up the frame for an 'address' in a 'Heap', if any.
frameLookup :: Ord address => address -> Heap scope address value -> Maybe (Frame scope address value)
frameLookup address = Map.lookup address . unHeap
-- | Look up the scope address for a given frame address.
scopeLookup :: Ord address => address -> Heap scope address value -> Maybe scope
scopeLookup address = fmap scopeAddress . frameLookup address
frameSlots :: Ord address => address -> Heap scope address value -> Maybe (Map Declaration value)
frameSlots address = fmap slots . frameLookup address
frameLinks :: Ord address => address -> Heap scope address value -> Maybe (Map EdgeLabel (Map scope address))
frameLinks address = fmap links . frameLookup address
getSlot :: Ord address => address -> Heap scope address value -> Declaration -> Maybe value
getSlot address heap declaration = do
slotMap <- frameSlots address heap
Map.lookup declaration slotMap
setSlot :: Ord address => address -> Declaration -> value -> Heap scope address value -> Heap scope address value
setSlot address declaration value heap =
case frameLookup address heap of
Just frame -> let slotMap = slots frame in
Heap $ Map.insert address (frame { slots = Map.insert declaration value slotMap }) (unHeap heap)
Nothing -> heap
lookup :: (Ord address, Ord scope) => Heap scope address value -> address -> Path scope -> Declaration -> Maybe scope
lookup heap address (DPath d) declaration = guard (d == declaration) >> scopeLookup address heap
lookup heap address (EPath label scope path) declaration = do
frame <- frameLookup address heap
scopeMap <- Map.lookup label (links frame)
nextAddress <- Map.lookup scope scopeMap
lookup heap nextAddress path declaration
newFrame :: (Ord address) => scope -> address -> Map EdgeLabel (Map scope address) -> Heap scope address value -> Heap scope address value
newFrame scope address links = insertFrame address (Frame scope links mempty)
initFrame :: (Ord address) => scope -> address -> Map EdgeLabel (Map scope address) -> Map Declaration value -> Heap scope address value -> Heap scope address value
initFrame scope address links slots = fillFrame address slots . newFrame scope address links
insertFrame :: Ord address => address -> Frame scope address value -> Heap scope address value -> Heap scope address value
insertFrame address frame = Heap . Map.insert address frame . unHeap
fillFrame :: Ord address => address -> Map Declaration value -> Heap scope address value -> Heap scope address value
fillFrame address slots heap =
case frameLookup address heap of
Just frame -> insertFrame address (frame { slots = slots }) heap
Nothing -> heap
deleteFrame :: Ord address => address -> Heap scope address value -> Heap scope address value
deleteFrame address = Heap . Map.delete address . unHeap
-- | The number of frames in the `Heap`.
heapSize :: Heap scope address value -> Int
heapSize = Map.size . unHeap

56
src/Data/Syntax/Declaration.hs
View File

@ -1,14 +1,16 @@
{-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses, ScopedTypeVariables, UndecidableInstances #-}
{-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses, ScopedTypeVariables, UndecidableInstances, TupleSections #-}
{-# OPTIONS_GHC -Wno-missing-export-lists #-}
module Data.Syntax.Declaration where
import qualified Data.Abstract.Environment as Env
import Data.Abstract.Evaluatable
import Control.Abstract.ScopeGraph
import Data.JSON.Fields
import qualified Data.Set as Set
import Diffing.Algorithm
import Prologue
import Proto3.Suite.Class
import qualified Data.Map.Strict as Map
import Reprinting.Tokenize
data Function a = Function { functionContext :: ![a], functionName :: !a, functionParameters :: ![a], functionBody :: !a }
@ -125,7 +127,18 @@ instance Show1 VariableDeclaration where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable VariableDeclaration where
eval (VariableDeclaration []) = rvalBox unit
eval (VariableDeclaration decs) = rvalBox =<< tuple =<< traverse subtermAddress decs
eval (VariableDeclaration decs) = do
addresses <- for decs $ \declaration -> do
name <- maybeM (throwEvalError NoNameError) (declaredName (subterm declaration))
(span, valueRef) <- do
ref <- subtermRef declaration
subtermSpan <- get @Span
pure (subtermSpan, ref)
declare (Declaration name) span Nothing -- TODO is it true that variable declarations never have an associated scope?
address valueRef
rvalBox =<< tuple addresses
instance Declarations a => Declarations (VariableDeclaration a) where
declaredName (VariableDeclaration vars) = case vars of
@ -158,7 +171,13 @@ instance Ord1 PublicFieldDefinition where liftCompare = genericLiftCompare
instance Show1 PublicFieldDefinition where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for PublicFieldDefinition
instance Evaluatable PublicFieldDefinition
instance Evaluatable PublicFieldDefinition where
eval PublicFieldDefinition{..} = do
span <- ask @Span
propertyName <- maybeM (throwEvalError NoNameError) (declaredName (subterm publicFieldPropertyName))
declare (Declaration propertyName) span Nothing
rvalBox unit
data Variable a = Variable { variableName :: !a, variableType :: !a, variableValue :: !a }
@ -187,13 +206,30 @@ instance Show1 Class where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Class where
eval Class{..} = do
name <- maybeM (throwEvalError NoNameError) (declaredName (subterm classIdentifier))
supers <- traverse subtermAddress classSuperclasses
(_, addr) <- letrec name $ do
void $ subtermValue classBody
classBinds <- Env.head <$> getEnv
klass name supers classBinds
bind name addr
pure (Rval addr)
span <- ask @Span
-- Run the action within the class's scope.
currentScope' <- currentScope
supers <- for classSuperclasses $ \superclass -> do
name <- maybeM (throwEvalError NoNameError) (declaredName (subterm superclass))
scope <- associatedScope (Declaration name)
(scope,) <$> subtermAddress superclass
let imports = (Import,) <$> (fmap pure . catMaybes $ fst <$> supers)
current = maybe mempty (fmap (Lexical, ) . pure . pure) currentScope'
edges = Map.fromList (imports <> current)
childScope <- newScope edges
declare (Declaration name) span (Just childScope)
withScope childScope $ do
(_, addr) <- letrec name $ do
void $ subtermValue classBody
classBinds <- Env.head <$> getEnv
klass name (snd <$> supers) classBinds
bind name addr
pure (Rval addr)
-- | A decorator in Python
data Decorator a = Decorator { decoratorIdentifier :: !a, decoratorParamaters :: ![a], decoratorBody :: !a }

32
src/Data/Syntax/Expression.hs
View File

@ -2,6 +2,7 @@
{-# OPTIONS_GHC -Wno-missing-export-lists #-}
module Data.Syntax.Expression where
import Control.Abstract.ScopeGraph as ScopeGraph
import Data.Abstract.Evaluatable hiding (Member)
import Data.Abstract.Number (liftIntegralFrac, liftReal, liftedExponent, liftedFloorDiv)
import Data.Bits
@ -424,7 +425,10 @@ instance Evaluatable Complement where
-- | Member Access (e.g. a.b)
data MemberAccess a = MemberAccess { lhs :: a, rhs :: Name }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1)
deriving (Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1)
instance Declarations1 MemberAccess where
liftDeclaredName _ MemberAccess{..} = Just rhs
instance Eq1 MemberAccess where liftEq = genericLiftEq
instance Ord1 MemberAccess where liftCompare = genericLiftCompare
@ -432,7 +436,17 @@ instance Show1 MemberAccess where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable MemberAccess where
eval (MemberAccess obj propName) = do
name <- maybeM (throwEvalError NoNameError) (declaredName (subterm obj))
reference (Reference name) (Declaration name)
childScope <- associatedScope (Declaration name)
ptr <- subtermAddress obj
case childScope of
Just childScope -> withScope childScope $ reference (Reference propName) (Declaration propName)
Nothing ->
-- TODO: Throw an ReferenceError because we can't find the associated child scope for `obj`.
pure ()
pure $! LvalMember ptr propName
-- | Subscript (e.g a[1])
@ -523,14 +537,26 @@ instance Evaluatable Await where
-- | An object constructor call in Javascript, Java, etc.
newtype New a = New { newSubject :: [a] }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1)
deriving (Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1)
instance Declarations1 New where
liftDeclaredName _ (New []) = Nothing
liftDeclaredName declaredName (New (subject : _)) = declaredName subject
instance Eq1 New where liftEq = genericLiftEq
instance Ord1 New where liftCompare = genericLiftCompare
instance Show1 New where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for New
instance Evaluatable New
instance Evaluatable New where
eval New{..} = do
case newSubject of
[] -> pure ()
(subject : _) -> do
name <- maybeM (throwEvalError NoNameError) (declaredName (subterm subject))
reference (Reference name) (Declaration name)
-- TODO: Traverse subterms and instantiate frames from the corresponding scope
rvalBox unit
-- | A cast expression to a specified type.
data Cast a = Cast { castSubject :: !a, castType :: !a }

28
src/Data/Syntax/Statement.hs
View File

@ -3,6 +3,8 @@
module Data.Syntax.Statement where
import Data.Abstract.Evaluatable
import Control.Abstract.ScopeGraph
import qualified Data.Map.Strict as Map
import Data.Aeson (ToJSON1 (..))
import Data.JSON.Fields
import Data.Semigroup.App
@ -27,7 +29,11 @@ instance Show1 Statements where liftShowsPrec = genericLiftShowsPrec
instance ToJSON1 Statements
instance Evaluatable Statements where
eval (Statements xs) = maybe (rvalBox unit) (runApp . foldMap1 (App . subtermRef)) (nonEmpty xs)
eval (Statements xs) = do
currentScope' <- currentScope
let edges = maybe mempty (Map.singleton Lexical . pure) currentScope'
scope <- newScope edges
withScope scope $ maybe (rvalBox unit) (runApp . foldMap1 (App . subtermRef)) (nonEmpty xs)
instance Tokenize Statements where
tokenize = imperative
@ -121,7 +127,10 @@ instance Evaluatable Let where
-- | Assignment to a variable or other lvalue.
data Assignment a = Assignment { assignmentContext :: ![a], assignmentTarget :: !a, assignmentValue :: !a }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1)
deriving (Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1)
instance Declarations1 Assignment where
liftDeclaredName declaredName Assignment{..} = declaredName assignmentTarget
instance Eq1 Assignment where liftEq = genericLiftEq
instance Ord1 Assignment where liftCompare = genericLiftCompare
@ -133,8 +142,19 @@ instance Evaluatable Assignment where
rhs <- subtermAddress assignmentValue
case lhs of
LvalLocal nam -> do
bind nam rhs
LvalLocal name -> do
case declaredName (subterm assignmentValue) of
Just rhsName -> do
assocScope <- associatedScope (Declaration rhsName)
case assocScope of
Just assocScope' -> do
objectScope <- newScope (Map.singleton Import [ assocScope' ])
putDeclarationScope (Declaration name) objectScope
Nothing -> pure ()
Nothing ->
-- The rhs wasn't assigned to a reference/declaration.
pure ()
bind name rhs
LvalMember _ _ ->
-- we don't yet support mutable object properties:
pure ()

4
src/Language/Go/Syntax.hs
View File

@ -93,7 +93,7 @@ instance Evaluatable Import where
paths <- resolveGoImport importPath
for_ paths $ \path -> do
traceResolve (unPath importPath) path
importedEnv <- fst <$> require path
importedEnv <- fst . snd <$> require path
bindAll importedEnv
rvalBox unit
@ -115,7 +115,7 @@ instance Evaluatable QualifiedImport where
void . letrec' alias $ \addr -> do
makeNamespace alias addr Nothing . for_ paths $ \p -> do
traceResolve (unPath importPath) p
importedEnv <- fst <$> require p
importedEnv <- fst . snd <$> require p
bindAll importedEnv
rvalBox unit

2
src/Language/PHP/Syntax.hs
View File

@ -71,7 +71,7 @@ include pathTerm f = do
name <- subtermValue pathTerm >>= asString
path <- resolvePHPName name
traceResolve name path
(importedEnv, v) <- f path
(_, (importedEnv, v)) <- f path
bindAll importedEnv
pure (Rval v)

6
src/Language/Python/Syntax.hs
View File

@ -145,7 +145,7 @@ instance Evaluatable Import where
-- Last module path is the one we want to import
let path = NonEmpty.last modulePaths
importedBinds <- fst <$> require path
importedBinds <- fst . snd <$> require path
bindAll (select importedBinds)
rvalBox unit
where
@ -165,7 +165,7 @@ evalQualifiedImport :: ( AbstractValue address value effects
)
=> Name -> ModulePath -> Evaluator address value effects value
evalQualifiedImport name path = letrec' name $ \addr -> do
unit <$ makeNamespace name addr Nothing (bindAll . fst =<< require path)
unit <$ makeNamespace name addr Nothing (bindAll . fst . snd =<< require path)
newtype QualifiedImport a = QualifiedImport { qualifiedImportFrom :: NonEmpty FilePath }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Named1, Ord, Show, ToJSONFields1, Traversable)
@ -218,7 +218,7 @@ instance Evaluatable QualifiedAliasedImport where
alias <- maybeM (throwEvalError NoNameError) (declaredName (subterm aliasTerm))
rvalBox =<< letrec' alias (\addr -> do
let path = NonEmpty.last modulePaths
unit <$ makeNamespace alias addr Nothing (void (bindAll . fst =<< require path)))
unit <$ makeNamespace alias addr Nothing (void (bindAll . fst . snd =<< require path)))
-- | Ellipsis (used in splice expressions and alternatively can be used as a fill in expression, like `undefined` in Haskell)
data Ellipsis a = Ellipsis

6
src/Language/Ruby/Syntax.hs
View File

@ -98,8 +98,8 @@ doRequire :: ( Member (Boolean value) effects
doRequire path = do
result <- lookupModule path
case result of
Nothing -> (,) . fst <$> load path <*> boolean True
Just (env, _) -> (env,) <$> boolean False
Nothing -> (,) . fst . snd <$> load path <*> boolean True
Just (_, (env, _)) -> (env,) <$> boolean False
data Load a = Load { loadPath :: a, loadWrap :: Maybe a }
@ -132,7 +132,7 @@ doLoad :: ( Member (Boolean value) effects
doLoad path shouldWrap = do
path' <- resolveRubyPath path
traceResolve path path'
importedEnv <- fst <$> load path'
importedEnv <- fst . snd <$> load path'
unless shouldWrap $ bindAll importedEnv
boolean Prelude.True -- load always returns true. http://ruby-doc.org/core-2.5.0/Kernel.html#method-i-load

2
src/Language/TypeScript/Assignment.hs
View File

@ -620,7 +620,7 @@ constructorTy :: Assignment Term
constructorTy = makeTerm <$> symbol ConstructorType <*> children (TypeScript.Syntax.Constructor <$> (fromMaybe <$> emptyTerm <*> optional (term typeParameters)) <*> formalParameters <*> term ty)
statementBlock :: Assignment Term
statementBlock = makeTerm <$> symbol StatementBlock <*> children (manyTerm statement)
statementBlock = makeTerm <$> symbol StatementBlock <*> children (Statement.Statements <$> manyTerm statement)
classBodyStatements :: Assignment Term
classBodyStatements = makeTerm'' <$> symbol ClassBody <*> children (contextualize' <$> Assignment.manyThrough comment (postContextualize' <$> (concat <$> many ((\as b -> as <> [b]) <$> manyTerm decorator <*> term (methodDefinition <|> publicFieldDefinition <|> methodSignature <|> indexSignature <|> abstractMethodSignature))) <*> many comment))

2
src/Language/TypeScript/Resolution.hs
View File

@ -175,4 +175,4 @@ evalRequire :: ( AbstractValue address value effects
-> Name
-> Evaluator address value effects value
evalRequire modulePath alias = letrec' alias $ \addr ->
unit <$ makeNamespace alias addr Nothing (bindAll . fst =<< require modulePath)
unit <$ makeNamespace alias addr Nothing (bindAll . fst . snd =<< require modulePath)

31
src/Language/TypeScript/Syntax/TypeScript.hs
View File

@ -10,6 +10,7 @@ import Proto3.Suite
import qualified Data.Abstract.Environment as Env
import Data.Abstract.Evaluatable
import Control.Abstract.ScopeGraph hiding (Import)
import Data.JSON.Fields
import Diffing.Algorithm
import Language.TypeScript.Resolution
@ -25,7 +26,7 @@ instance Show1 Import where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Import where
eval (Import symbols importPath) = do
modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions
importedBinds <- fst <$> require modulePath
importedBinds <- fst . snd <$> require modulePath
bindAll (renamed importedBinds)
rvalBox unit
where
@ -92,7 +93,7 @@ instance Show1 QualifiedExportFrom where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable QualifiedExportFrom where
eval (QualifiedExportFrom importPath exportSymbols) = do
modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions
importedBinds <- fst <$> require modulePath
importedBinds <- fst . snd <$> require modulePath
-- Look up addresses in importedEnv and insert the aliases with addresses into the exports.
for_ exportSymbols $ \Alias{..} -> do
let address = Env.lookup aliasValue importedBinds
@ -271,15 +272,24 @@ newtype PredefinedType a = PredefinedType { predefinedType :: T.Text }
instance Eq1 PredefinedType where liftEq = genericLiftEq
instance Ord1 PredefinedType where liftCompare = genericLiftCompare
instance Show1 PredefinedType where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for PredefinedType
instance Evaluatable PredefinedType
newtype TypeIdentifier a = TypeIdentifier { contents :: T.Text }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable)
deriving (Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable)
instance Declarations1 TypeIdentifier where
liftDeclaredName _ (TypeIdentifier identifier) = Just (name identifier)
instance Eq1 TypeIdentifier where liftEq = genericLiftEq
instance Ord1 TypeIdentifier where liftCompare = genericLiftCompare
instance Show1 TypeIdentifier where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable TypeIdentifier
-- TODO: TypeIdentifier shouldn't evaluate to an address in the heap?
instance Evaluatable TypeIdentifier where
eval TypeIdentifier{..} = do
-- Add a reference to the type identifier in the current scope.
reference (Reference (name contents)) (Declaration (name contents))
rvalBox unit
data NestedIdentifier a = NestedIdentifier { left :: !a, right :: !a }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable)
@ -343,12 +353,21 @@ instance Declarations a => Declarations (EnumDeclaration a) where
declaredName EnumDeclaration{..} = declaredName enumDeclarationIdentifier
newtype ExtendsClause a = ExtendsClause { extendsClauses :: [a] }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable)
deriving (Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable)
instance Declarations1 ExtendsClause where
liftDeclaredName _ (ExtendsClause []) = Nothing
liftDeclaredName declaredName (ExtendsClause (x : _)) = declaredName x
instance Eq1 ExtendsClause where liftEq = genericLiftEq
instance Ord1 ExtendsClause where liftCompare = genericLiftCompare
instance Show1 ExtendsClause where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ExtendsClause
-- TODO: ExtendsClause shouldn't evaluate to an address in the heap?
instance Evaluatable ExtendsClause where
eval ExtendsClause{..} = do
-- Evaluate subterms
traverse_ subtermRef extendsClauses
rvalBox unit
newtype ArrayType a = ArrayType { arrayType :: a }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable)

16
src/Semantic/Graph.hs
View File

@ -26,7 +26,7 @@ module Semantic.Graph
import Prelude hiding (readFile)
import Analysis.Abstract.Caching
import Analysis.Abstract.Caching.FlowInsensitive
import Analysis.Abstract.Collecting
import Analysis.Abstract.Graph as Graph
import Control.Abstract
@ -111,8 +111,8 @@ runCallGraph lang includePackages modules package = do
runGraphAnalysis
= runTermEvaluator @_ @(Hole (Maybe Name) (Located Monovariant)) @Abstract
. graphing @_ @_ @(Maybe Name) @Monovariant
. caching
. runState (lowerBound @(Heap (Hole (Maybe Name) (Located Monovariant)) Abstract))
. caching
. runFresh 0
. resumingLoadError
. resumingUnspecialized
@ -122,6 +122,7 @@ runCallGraph lang includePackages modules package = do
. 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)))))))
@ -192,6 +193,7 @@ runImportGraph lang (package :: Package term) f =
. runModules (ModuleTable.modulePaths (packageModules package))
. runTermEvaluator @_ @_ @(Value (Hole (Maybe Name) Precise) (ConcreteEff (Hole (Maybe Name) Precise) _))
. runReader (packageInfo package)
. runState lowerBound
. runReader lowerBound
runAddressEffects
= Hole.runAllocator Precise.handleAllocator
@ -200,6 +202,7 @@ runImportGraph lang (package :: Package term) f =
type ConcreteEffects address rest
= Reader Span
': State Span
': Reader PackageInfo
': Modules address
': Reader (ModuleTable (NonEmpty (Module (ModuleResult address))))
@ -273,6 +276,7 @@ parsePythonPackage parser project = do
. runModules lowerBound
. runTermEvaluator @_ @_ @(Value (Hole (Maybe Name) Precise) (ConcreteEff (Hole (Maybe Name) Precise) _))
. runReader (PackageInfo (name "setup") lowerBound)
. runState lowerBound
. runReader lowerBound
runAddressEffects
= Hole.runAllocator Precise.handleAllocator
@ -322,10 +326,13 @@ parseModule proj parser file = do
withTermSpans :: ( HasField fields Span
, Member (Reader Span) effects
, Member (State Span) effects -- last evaluated child's span
)
=> SubtermAlgebra (TermF syntax (Record fields)) term (TermEvaluator term address value effects a)
-> SubtermAlgebra (TermF syntax (Record fields)) term (TermEvaluator term address value effects a)
withTermSpans recur term = withCurrentSpan (getField (termFAnnotation term)) (recur term)
withTermSpans recur term = let
updatedSpanAlg = withCurrentSpan (getField (termFAnnotation term)) (recur term)
in modifyChildSpan (getField (termFAnnotation term)) updatedSpanAlg
resumingResolutionError :: ( Applicative (m effects)
, Effectful m
@ -343,11 +350,12 @@ resumingLoadError :: ( Applicative (m address value effects)
, Effectful (m address value)
, Effects effects
, Member Trace effects
, Ord address
)
=> m address value (Resumable (BaseError (LoadError address)) ': effects) a
-> m address value effects a
resumingLoadError = runLoadErrorWith (\ baseError -> traceError "LoadError" baseError *> case baseErrorException baseError of
ModuleNotFoundError _ -> pure (lowerBound, hole))
ModuleNotFoundError _ -> pure (lowerBound, (lowerBound, hole)))
resumingEvalError :: ( Applicative (m effects)
, Effectful m

1
src/Semantic/REPL.hs
View File

@ -104,6 +104,7 @@ repl proxy parser paths = defaultConfig debugOptions >>= \ config -> runM . runD
. runReader (lowerBound @(ModuleTable (NonEmpty (Module (ModuleResult Precise)))))
. raiseHandler (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) (Concrete.runBoolean . Concrete.runFunction coerce coerce) modules

11
src/Semantic/Util.hs
View File

@ -4,7 +4,7 @@ module Semantic.Util where
import Prelude hiding (id, (.), readFile)
import Analysis.Abstract.Caching
import Analysis.Abstract.Caching.FlowSensitive
import Analysis.Abstract.Collecting
import Control.Abstract
import Control.Category
@ -106,8 +106,9 @@ evaluateProject' (TaskConfig config logger statter) proxy parser paths = either
(runReader (lowerBound @(ModuleTable (NonEmpty (Module (ModuleResult Precise)))))
(raiseHandler (runModules (ModuleTable.modulePaths (packageModules package)))
(runReader (packageInfo package)
(runState (lowerBound @Span)
(runReader (lowerBound @Span)
(evaluate proxy id withTermSpans (Precise.runAllocator . Precise.runDeref) (Concrete.runBoolean . Concrete.runFunction coerce coerce) modules))))))
(evaluate proxy id withTermSpans (Precise.runAllocator . Precise.runDeref) (Concrete.runBoolean . Concrete.runFunction coerce coerce) modules)))))))
evaluatePythonProjects proxy parser lang path = runTaskWithOptions debugOptions $ do
project <- readProject Nothing path lang []
@ -118,8 +119,9 @@ evaluatePythonProjects proxy parser lang path = runTaskWithOptions debugOptions
(runReader (lowerBound @(ModuleTable (NonEmpty (Module (ModuleResult Precise)))))
(raiseHandler (runModules (ModuleTable.modulePaths (packageModules package)))
(runReader (packageInfo package)
(runState (lowerBound @Span)
(runReader (lowerBound @Span)
(evaluate proxy id withTermSpans (Precise.runAllocator . Precise.runDeref) (Concrete.runBoolean . Concrete.runFunction coerce coerce) modules))))))
(evaluate proxy id withTermSpans (Precise.runAllocator . Precise.runDeref) (Concrete.runBoolean . Concrete.runFunction coerce coerce) modules)))))))
evaluateProjectWithCaching proxy parser path = runTaskWithOptions debugOptions $ do
@ -127,10 +129,11 @@ evaluateProjectWithCaching proxy parser path = runTaskWithOptions debugOptions $
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)))))
(raiseHandler (runModules (ModuleTable.modulePaths (packageModules package)))
(evaluate proxy id withTermSpans (Monovariant.runAllocator . Monovariant.runDeref) (Type.runBoolean . Type.runFunction) modules)))))
(evaluate proxy id withTermSpans (Monovariant.runAllocator . Monovariant.runDeref) (Type.runBoolean . Type.runFunction) modules))))))
parseFile :: Parser term -> FilePath -> IO term

4
test/Analysis/Go/Spec.hs
View File

@ -14,7 +14,7 @@ spec config = parallel $ do
it "imports and wildcard imports" $ do
(_, (heap, res)) <- evaluate ["main.go", "foo/foo.go", "bar/bar.go", "bar/rab.go"]
case ModuleTable.lookup "main.go" <$> res of
Right (Just (Module _ (env, addr) :| [])) -> do
Right (Just (Module _ (_, (env, addr)) :| [])) -> do
Env.names env `shouldBe` [ "Bar", "Rab", "foo", "main" ]
(derefQName heap ("foo" :| []) env >>= deNamespace heap) `shouldBe` Just ("foo", ["New"])
other -> expectationFailure (show other)
@ -22,7 +22,7 @@ spec config = parallel $ do
it "imports with aliases (and side effects only)" $ do
(_, (heap, res)) <- evaluate ["main1.go", "foo/foo.go", "bar/bar.go", "bar/rab.go"]
case ModuleTable.lookup "main1.go" <$> res of
Right (Just (Module _ (env, addr) :| [])) -> do
Right (Just (Module _ (_, (env, addr)) :| [])) -> do
Env.names env `shouldBe` [ "f", "main" ]
(derefQName heap ("f" :| []) env >>= deNamespace heap) `shouldBe` Just ("f", ["New"])
other -> expectationFailure (show other)

6
test/Analysis/PHP/Spec.hs
View File

@ -15,7 +15,7 @@ spec config = parallel $ do
it "evaluates include and require" $ do
(_, (heap, res)) <- evaluate ["main.php", "foo.php", "bar.php"]
case ModuleTable.lookup "main.php" <$> res of
Right (Just (Module _ (env, addr) :| [])) -> do
Right (Just (Module _ (_, (env, addr)) :| [])) -> do
heapLookupAll addr heap `shouldBe` Just [unit]
Env.names env `shouldBe` [ "bar", "foo" ]
other -> expectationFailure (show other)
@ -23,7 +23,7 @@ spec config = parallel $ do
it "evaluates include_once and require_once" $ do
(_, (heap, res)) <- evaluate ["main_once.php", "foo.php", "bar.php"]
case ModuleTable.lookup "main_once.php" <$> res of
Right (Just (Module _ (env, addr) :| [])) -> do
Right (Just (Module _ (_, (env, addr)) :| [])) -> do
heapLookupAll addr heap `shouldBe` Just [unit]
Env.names env `shouldBe` [ "bar", "foo" ]
other -> expectationFailure (show other)
@ -31,7 +31,7 @@ spec config = parallel $ do
it "evaluates namespaces" $ do
(_, (heap, res)) <- evaluate ["namespaces.php"]
case ModuleTable.lookup "namespaces.php" <$> res of
Right (Just (Module _ (env, addr) :| [])) -> do
Right (Just (Module _ (_, (env, addr)) :| [])) -> do
Env.names env `shouldBe` [ "Foo", "NS1" ]
(derefQName heap ("NS1" :| []) env >>= deNamespace heap) `shouldBe` Just ("NS1", ["Sub1", "b", "c"])

12
test/Analysis/Python/Spec.hs
View File

@ -16,7 +16,7 @@ spec config = parallel $ do
it "imports" $ do
(_, (heap, res)) <- evaluate ["main.py", "a.py", "b/__init__.py", "b/c.py"]
case ModuleTable.lookup "main.py" <$> res of
Right (Just (Module _ (env, addr) :| [])) -> do
Right (Just (Module _ (_, (env, addr)) :| [])) -> do
Env.names env `shouldContain` [ "a", "b" ]
(derefQName heap ("a" :| []) env >>= deNamespace heap) `shouldBe` Just ("a", ["foo"])
@ -27,19 +27,19 @@ spec config = parallel $ do
it "imports with aliases" $ do
(_, (_, res)) <- evaluate ["main1.py", "a.py", "b/__init__.py", "b/c.py"]
case ModuleTable.lookup "main1.py" <$> res of
Right (Just (Module _ (env, addr) :| [])) -> Env.names env `shouldContain` [ "b", "e" ]
Right (Just (Module _ (_, (env, addr)) :| [])) -> Env.names env `shouldContain` [ "b", "e" ]
other -> expectationFailure (show other)
it "imports using 'from' syntax" $ do
(_, (_, res)) <- evaluate ["main2.py", "a.py", "b/__init__.py", "b/c.py"]
case ModuleTable.lookup "main2.py" <$> res of
Right (Just (Module _ (env, addr) :| [])) -> Env.names env `shouldContain` [ "bar", "foo" ]
Right (Just (Module _ (_, (env, addr)) :| [])) -> Env.names env `shouldContain` [ "bar", "foo" ]
other -> expectationFailure (show other)
it "imports with relative syntax" $ do
(_, (heap, res)) <- evaluate ["main3.py", "c/__init__.py", "c/utils.py"]
case ModuleTable.lookup "main3.py" <$> res of
Right (Just (Module _ (env, addr) :| [])) -> do
Right (Just (Module _ (_, (env, addr)) :| [])) -> do
Env.names env `shouldContain` [ "utils" ]
(derefQName heap ("utils" :| []) env >>= deNamespace heap) `shouldBe` Just ("utils", ["to_s"])
other -> expectationFailure (show other)
@ -47,13 +47,13 @@ spec config = parallel $ do
it "subclasses" $ do
(_, (heap, res)) <- evaluate ["subclass.py"]
case ModuleTable.lookup "subclass.py" <$> res of
Right (Just (Module _ (env, addr) :| [])) -> heapLookupAll addr heap `shouldBe` Just [String "\"bar\""]
Right (Just (Module _ (_, (env, addr)) :| [])) -> heapLookupAll addr heap `shouldBe` Just [String "\"bar\""]
other -> expectationFailure (show other)
it "handles multiple inheritance left-to-right" $ do
(_, (heap, res)) <- evaluate ["multiple_inheritance.py"]
case ModuleTable.lookup "multiple_inheritance.py" <$> res of
Right (Just (Module _ (env, addr) :| [])) -> heapLookupAll addr heap `shouldBe` Just [String "\"foo!\""]
Right (Just (Module _ (_, (env, addr)) :| [])) -> heapLookupAll addr heap `shouldBe` Just [String "\"foo!\""]
other -> expectationFailure (show other)
where

22
test/Analysis/Ruby/Spec.hs
View File

@ -21,7 +21,7 @@ spec config = parallel $ do
it "evaluates require_relative" $ do
(_, (heap, res)) <- evaluate ["main.rb", "foo.rb"]
case ModuleTable.lookup "main.rb" <$> res of
Right (Just (Module _ (env, addr) :| [])) -> do
Right (Just (Module _ (_, (env, addr)) :| [])) -> do
heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 1)]
Env.names env `shouldContain` [ "foo" ]
other -> expectationFailure (show other)
@ -29,7 +29,7 @@ spec config = parallel $ do
it "evaluates load" $ do
(_, (heap, res)) <- evaluate ["load.rb", "foo.rb"]
case ModuleTable.lookup "load.rb" <$> res of
Right (Just (Module _ (env, addr) :| [])) -> do
Right (Just (Module _ (_, (env, addr)) :| [])) -> do
heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 1)]
Env.names env `shouldContain` [ "foo" ]
other -> expectationFailure (show other)
@ -41,7 +41,7 @@ spec config = parallel $ do
it "evaluates subclass" $ do
(_, (heap, res)) <- evaluate ["subclass.rb"]
case ModuleTable.lookup "subclass.rb" <$> res of
Right (Just (Module _ (env, addr) :| [])) -> do
Right (Just (Module _ (_, (env, addr)) :| [])) -> do
heapLookupAll addr heap `shouldBe` Just [String "\"<bar>\""]
Env.names env `shouldContain` [ "Bar", "Foo" ]
@ -51,7 +51,7 @@ spec config = parallel $ do
it "evaluates modules" $ do
(_, (heap, res)) <- evaluate ["modules.rb"]
case ModuleTable.lookup "modules.rb" <$> res of
Right (Just (Module _ (env, addr) :| [])) -> do
Right (Just (Module _ (_, (env, addr)) :| [])) -> do
heapLookupAll addr heap `shouldBe` Just [String "\"<hello>\""]
Env.names env `shouldContain` [ "Bar" ]
other -> expectationFailure (show other)
@ -59,43 +59,43 @@ spec config = parallel $ do
it "handles break correctly" $ do
(_, (heap, res)) <- evaluate ["break.rb"]
case ModuleTable.lookup "break.rb" <$> res of
Right (Just (Module _ (env, addr) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 3)]
Right (Just (Module _ (_, (env, addr)) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 3)]
other -> expectationFailure (show other)
it "handles next correctly" $ do
(_, (heap, res)) <- evaluate ["next.rb"]
case ModuleTable.lookup "next.rb" <$> res of
Right (Just (Module _ (env, addr) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 8)]
Right (Just (Module _ (_, (env, addr)) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 8)]
other -> expectationFailure (show other)
it "calls functions with arguments" $ do
(_, (heap, res)) <- evaluate ["call.rb"]
case ModuleTable.lookup "call.rb" <$> res of
Right (Just (Module _ (env, addr) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 579)]
Right (Just (Module _ (_, (env, addr)) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 579)]
other -> expectationFailure (show other)
it "evaluates early return statements" $ do
(_, (heap, res)) <- evaluate ["early-return.rb"]
case ModuleTable.lookup "early-return.rb" <$> res of
Right (Just (Module _ (env, addr) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 123)]
Right (Just (Module _ (_, (env, addr)) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 123)]
other -> expectationFailure (show other)
it "has prelude" $ do
(_, (heap, res)) <- evaluate ["preluded.rb"]
case ModuleTable.lookup "preluded.rb" <$> res of
Right (Just (Module _ (env, addr) :| [])) -> heapLookupAll addr heap `shouldBe` Just [String "\"<foo>\""]
Right (Just (Module _ (_, (env, addr)) :| [])) -> heapLookupAll addr heap `shouldBe` Just [String "\"<foo>\""]
other -> expectationFailure (show other)
it "evaluates __LINE__" $ do
(_, (heap, res)) <- evaluate ["line.rb"]
case ModuleTable.lookup "line.rb" <$> res of
Right (Just (Module _ (env, addr) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 4)]
Right (Just (Module _ (_, (env, addr)) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 4)]
other -> expectationFailure (show other)
it "resolves builtins used in the prelude" $ do
(traces, (heap, res)) <- evaluate ["puts.rb"]
case ModuleTable.lookup "puts.rb" <$> res of
Right (Just (Module _ (env, addr) :| [])) -> do
Right (Just (Module _ (_, (env, addr)) :| [])) -> do
heapLookupAll addr heap `shouldBe` Just [Unit]
traces `shouldContain` [ "\"hello\"" ]
other -> expectationFailure (show other)

30
test/Analysis/TypeScript/Spec.hs
View File

@ -17,13 +17,13 @@ spec config = parallel $ do
it "imports with aliased symbols" $ do
(_, (_, res)) <- evaluate ["main.ts", "foo.ts", "a.ts", "foo/b.ts"]
case ModuleTable.lookup "main.ts" <$> res of
Right (Just (Module _ (env, _) :| [])) -> Env.names env `shouldBe` [ "bar", "quz" ]
Right (Just (Module _ (_, (env, _)) :| [])) -> Env.names env `shouldBe` [ "bar", "quz" ]
other -> expectationFailure (show other)
it "imports with qualified names" $ do
(_, (heap, res)) <- evaluate ["main1.ts", "foo.ts", "a.ts"]
case ModuleTable.lookup "main1.ts" <$> res of
Right (Just (Module _ (env, _) :| [])) -> do
Right (Just (Module _ (_, (env, _)) :| [])) -> do
Env.names env `shouldBe` [ "b", "z" ]
(derefQName heap ("b" :| []) env >>= deNamespace heap) `shouldBe` Just ("b", [ "baz", "foo" ])
@ -33,7 +33,7 @@ spec config = parallel $ do
it "side effect only imports" $ do
(_, (_, res)) <- evaluate ["main2.ts", "a.ts", "foo.ts"]
case ModuleTable.lookup "main2.ts" <$> res of
Right (Just (Module _ (env, _) :| [])) -> env `shouldBe` lowerBound
Right (Just (Module _ (_, (env, _)) :| [])) -> env `shouldBe` lowerBound
other -> expectationFailure (show other)
it "fails exporting symbols not defined in the module" $ do
@ -43,13 +43,13 @@ spec config = parallel $ do
it "evaluates early return statements" $ do
(_, (heap, res)) <- evaluate ["early-return.ts"]
case ModuleTable.lookup "early-return.ts" <$> res of
Right (Just (Module _ (_, addr) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Float (Number.Decimal 123.0)]
Right (Just (Module _ (_, (_, addr)) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Float (Number.Decimal 123.0)]
other -> expectationFailure (show other)
it "evaluates sequence expressions" $ do
(_, (heap, res)) <- evaluate ["sequence-expression.ts"]
case ModuleTable.lookup "sequence-expression.ts" <$> res of
Right (Just (Module _ (env, addr) :| [])) -> do
Right (Just (Module _ (_, (env, addr)) :| [])) -> do
Env.names env `shouldBe` [ "x" ]
(derefQName heap ("x" :| []) env) `shouldBe` Just (Value.Float (Number.Decimal 3.0))
other -> expectationFailure (show other)
@ -57,13 +57,13 @@ spec config = parallel $ do
it "evaluates void expressions" $ do
(_, (heap, res)) <- evaluate ["void.ts"]
case ModuleTable.lookup "void.ts" <$> res of
Right (Just (Module _ (_, addr) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Null]
Right (Just (Module _ (_, (_, addr)) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Null]
other -> expectationFailure (show other)
it "evaluates delete" $ do
(_, (heap, res)) <- evaluate ["delete.ts"]
case ModuleTable.lookup "delete.ts" <$> res of
Right (Just (Module _ (env, addr) :| [])) -> do
Right (Just (Module _ (_, (env, addr)) :| [])) -> do
heapLookupAll addr heap `shouldBe` Just [Unit]
(derefQName heap ("x" :| []) env) `shouldBe` Nothing
Env.names env `shouldBe` [ "x" ]
@ -72,7 +72,7 @@ spec config = parallel $ do
it "evaluates await" $ do
(_, (heap, res)) <- evaluate ["await.ts"]
case ModuleTable.lookup "await.ts" <$> res of
Right (Just (Module _ (env, addr) :| [])) -> do
Right (Just (Module _ (_, (env, addr)) :| [])) -> do
Env.names env `shouldBe` [ "f2" ]
(derefQName heap ("y" :| []) env) `shouldBe` Nothing
other -> expectationFailure (show other)
@ -80,41 +80,41 @@ spec config = parallel $ do
it "evaluates BOr statements" $ do
(_, (heap, res)) <- evaluate ["bor.ts"]
case ModuleTable.lookup "bor.ts" <$> res of
Right (Just (Module _ (_, addr) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 3)]
Right (Just (Module _ (_, (_, addr)) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 3)]
other -> expectationFailure (show other)
it "evaluates BAnd statements" $ do
(_, (heap, res)) <- evaluate ["band.ts"]
case ModuleTable.lookup "band.ts" <$> res of
Right (Just (Module _ (_, addr) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 0)]
Right (Just (Module _ (_, (_, addr)) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 0)]
other -> expectationFailure (show other)
it "evaluates BXOr statements" $ do
(_, (heap, res)) <- evaluate ["bxor.ts"]
case ModuleTable.lookup "bxor.ts" <$> res of
Right (Just (Module _ (_, addr) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 3)]
Right (Just (Module _ (_, (_, addr)) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 3)]
other -> expectationFailure (show other)
it "evaluates LShift statements" $ do
(_, (heap, res)) <- evaluate ["lshift.ts"]
case ModuleTable.lookup "lshift.ts" <$> res of
Right (Just (Module _ (_, addr) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 4)]
Right (Just (Module _ (_, (_, addr)) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 4)]
other -> expectationFailure (show other)
it "evaluates RShift statements" $ do
(_, (heap, res)) <- evaluate ["rshift.ts"]
case ModuleTable.lookup "rshift.ts" <$> res of
Right (Just (Module _ (_, addr) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 0)]
Right (Just (Module _ (_, (_, addr)) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 0)]
other -> expectationFailure (show other)
it "evaluates Complement statements" $ do
(_, (heap, res)) <- evaluate ["complement.ts"]
case ModuleTable.lookup "complement.ts" <$> res of
Right (Just (Module _ (_, addr) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer (-2))]
Right (Just (Module _ (_, (_, addr)) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer (-2))]
other -> expectationFailure (show other)
where
fixtures = "test/fixtures/typescript/analysis/"
evaluate = evalTypeScriptProject . map (fixtures <>)
evalTypeScriptProject = testEvaluating <=< evaluateProject' config (Proxy :: Proxy 'Language.TypeScript) typescriptParser
evalTypeScriptProject = testEvaluating <=< (evaluateProject' config (Proxy :: Proxy 'Language.TypeScript) typescriptParser)

8
test/SpecHelpers.hs
View File

@ -118,12 +118,12 @@ type TestEvaluatingErrors = '[ BaseError (ValueError Precise (ConcreteEff Precis
, BaseError (UnspecializedError Val)
, BaseError (LoadError Precise)
]
testEvaluating :: Evaluator Precise Val TestEvaluatingEffects (ModuleTable (NonEmpty (Module (ModuleResult Precise))))
testEvaluating :: Evaluator Precise Val TestEvaluatingEffects (Span, a)
-> IO
( [String]
, ( Heap Precise Val
, Either (SomeExc (Data.Sum.Sum TestEvaluatingErrors))
(ModuleTable (NonEmpty (Module (ModuleResult Precise))))
a
)
)
testEvaluating
@ -139,6 +139,7 @@ testEvaluating
. runResolutionError
. runAddressError
. runValueError @_ @Precise @(ConcreteEff Precise _)
. fmap snd
type Val = Value Precise (ConcreteEff Precise '[Trace, Lift IO])
@ -153,11 +154,12 @@ namespaceScope :: Heap Precise (Value Precise term)
-> Value Precise term
-> Maybe (Environment Precise)
namespaceScope heap ns@(Namespace _ _ _)
= either (const Nothing) snd
= either (const Nothing) (snd . snd)
. run
. runFresh 0
. runAddressError
. runState heap
. runState (lowerBound @Span)
. runReader (lowerBound @Span)
. runReader (ModuleInfo "SpecHelper.hs")
. runDeref