Merge branch 'master' into fix-benchmarks

semantic.cabal

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

src/Analysis/Abstract/Caching/FlowInsensitive.hs

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

src/Analysis/Abstract/Caching/FlowSensitive.hs

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

src/Analysis/Abstract/Tracing.hs

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

src/Control/Abstract/Configuration.hs

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

src/Control/Abstract/Context.hs

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

src/Control/Abstract/Heap.hs

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

src/Control/Abstract/Modules.hs

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

src/Control/Abstract/ScopeGraph.hs

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

src/Data/Abstract/Cache.hs

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

src/Data/Abstract/Configuration.hs

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

src/Data/Abstract/Evaluatable.hs

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

src/Data/Abstract/ScopeGraph.hs

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

src/Data/Syntax/Declaration.hs

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

src/Data/Syntax/Expression.hs

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

src/Data/Syntax/Statement.hs

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

src/Language/Go/Assignment.hs

@@ -267,10 +267,10 @@ floatLiteral :: Assignment Term
 floatLiteral = makeTerm <$> symbol FloatLiteral <*> (Literal.Float <$> source)
 
 identifier :: Assignment Term
-identifier =  makeTerm <$> (symbol Identifier <|> symbol Identifier') <*> (Syntax.Identifier . name <$> source)
+identifier =  makeTerm <$> (symbol Identifier <|> symbol Identifier' <|> symbol Identifier'') <*> (Syntax.Identifier . name <$> source)
 
 identifier' :: Assignment Name
-identifier' =  (symbol Identifier <|> symbol Identifier') *> (name <$> source)
+identifier' =  (symbol Identifier <|> symbol Identifier' <|> symbol Identifier'') *> (name <$> source)
 
 imaginaryLiteral :: Assignment Term
 imaginaryLiteral = makeTerm <$> symbol ImaginaryLiteral <*> (Literal.Complex <$> source)

src/Language/Go/Syntax.hs

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

src/Language/PHP/Syntax.hs

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

src/Language/Python/Syntax.hs

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

src/Language/Ruby/Assignment.hs

@@ -163,6 +163,7 @@ expressionChoices =
   , heredoc
   , identifier
   , if'
+  , then'
   , lambda
   , literal
   , method
@@ -270,7 +271,7 @@ literal =
       (children (inject . Literal.String <$> some (interpolation <|> escapeSequence)) <|> inject . Literal.TextElement <$> source)
 
     symbol' :: Assignment Term
-    symbol' = makeTerm' <$> (symbol Symbol <|> symbol Symbol' <|> symbol BareSymbol) <*>
+    symbol' = makeTerm' <$> (symbol Symbol <|> symbol Symbol' <|> symbol Symbol'' <|> symbol BareSymbol) <*>
       (children (inject . Literal.Symbol <$> some interpolation) <|> inject . Literal.SymbolElement <$> source)
 
 interpolation :: Assignment Term
@@ -363,14 +364,17 @@ undef = makeTerm <$> symbol Undef <*> children (Expression.Call [] <$> name' <*>
   where name' = makeTerm <$> location <*> (Syntax.Identifier . name <$> source)
 
 if' :: Assignment Term
-if' =   ifElsif If
+if' = ifElsif If
     <|> makeTerm <$> symbol IfModifier <*> children (flip Statement.If <$> expression <*> expression <*> emptyTerm)
   where
     ifElsif s = makeTerm <$> symbol s <*> children (Statement.If <$> expression <*> expressions' <*> (elsif' <|> else' <|> emptyTerm))
-    expressions' = makeTerm <$> location <*> manyTermsTill expression (void (symbol Else) <|> void (symbol Elsif) <|> eof)
     elsif' = postContextualize comment (ifElsif Elsif)
+    expressions' = makeTerm <$> location <*> manyTermsTill expression (void (symbol Else) <|> void (symbol Elsif) <|> eof)
     else' = postContextualize comment (symbol Else *> children expressions)
 
+then' :: Assignment Term
+then' = postContextualize comment (symbol Then *> children expressions)
+
 unless :: Assignment Term
 unless =   makeTerm <$> symbol Unless         <*> children      (Statement.If <$> invert expression <*> expressions' <*> (else' <|> emptyTerm))
        <|> makeTerm <$> symbol UnlessModifier <*> children (flip Statement.If <$> expression <*> invert expression <*> emptyTerm)
@@ -505,17 +509,17 @@ unary = symbol Unary >>= \ location ->
   <|> makeTerm location . Expression.Not <$> children ( symbol AnonBang *> expression )
   <|> makeTerm location . Expression.Not <$> children ( symbol AnonNot *> expression )
   <|> makeTerm location <$> children (Expression.Call [] <$> (makeTerm <$> symbol AnonDefinedQuestion <*> (Syntax.Identifier . name <$> source)) <*> some expression <*> emptyTerm)
-  <|> makeTerm location . Expression.Negate <$> children ( symbol AnonMinus' *> expression )
+  <|> makeTerm location . Expression.Negate <$> children ( (symbol AnonMinus <|> symbol AnonMinus' <|> symbol AnonMinus'') *> expression )
   <|> children ( symbol AnonPlus *> expression )
 
 -- TODO: Distinguish `===` from `==` ?
 binary :: Assignment Term
 binary = makeTerm' <$> symbol Binary <*> children (infixTerm expression expression
   [ (inject .) . Expression.Plus              <$ symbol AnonPlus
-  , (inject .) . Expression.Minus             <$ symbol AnonMinus'
-  , (inject .) . Expression.Times             <$ symbol AnonStar'
+  , (inject .) . Expression.Minus             <$ (symbol AnonMinus <|> symbol AnonMinus' <|> symbol AnonMinus'')
+  , (inject .) . Expression.Times             <$ (symbol AnonStar <|> symbol AnonStar')
   , (inject .) . Expression.Power             <$ symbol AnonStarStar
-  , (inject .) . Expression.DividedBy         <$ symbol AnonSlash
+  , (inject .) . Expression.DividedBy         <$ (symbol AnonSlash <|> symbol AnonSlash' <|> symbol AnonSlash'')
   , (inject .) . Expression.Modulo            <$ symbol AnonPercent
   , (inject .) . Expression.And               <$ symbol AnonAmpersandAmpersand
   , (inject .) . Ruby.Syntax.LowPrecedenceAnd <$ symbol AnonAnd
@@ -530,7 +534,7 @@ binary = makeTerm' <$> symbol Binary <*> children (infixTerm expression expressi
   -- for this situation.
   , (inject .) . Expression.Equal            <$ (symbol AnonEqualEqual <|> symbol AnonEqualEqualEqual)
   , (inject .) . invert Expression.Equal     <$ symbol AnonBangEqual
-  , (inject .) . Expression.LShift           <$ symbol AnonLAngleLAngle
+  , (inject .) . Expression.LShift           <$ (symbol AnonLAngleLAngle <|> symbol AnonLAngleLAngle')
   , (inject .) . Expression.RShift           <$ symbol AnonRAngleRAngle
   , (inject .) . Expression.Comparison       <$ symbol AnonLAngleEqualRAngle
   , (inject .) . Expression.LessThan         <$ symbol AnonLAngle

src/Language/Ruby/Syntax.hs

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

src/Language/TypeScript/Assignment.hs

@@ -382,7 +382,7 @@ false :: Assignment Term
 false = makeTerm <$> symbol Grammar.False <*> (Literal.false <$ rawSource)
 
 identifier :: Assignment Term
-identifier = makeTerm <$> (symbol Identifier <|> symbol Identifier') <*> (Syntax.Identifier . name <$> source)
+identifier = makeTerm <$> (symbol Identifier <|> symbol Identifier' <|> symbol Identifier'') <*> (Syntax.Identifier . name <$> source)
 
 class' :: Assignment Term
 class' = makeClass <$> symbol Class <*> children ((,,,,) <$> manyTerm decorator <*> term typeIdentifier <*> (symbol TypeParameters *> children (manyTerm typeParameter') <|> pure []) <*> (classHeritage' <|> pure []) <*> classBodyStatements)
@@ -515,7 +515,7 @@ typeAnnotation' :: Assignment Term
 typeAnnotation' = makeTerm <$> symbol TypeAnnotation <*> children (TypeScript.Syntax.Annotation <$> term ty)
 
 typeParameter' :: Assignment Term
-typeParameter' = makeTerm <$> symbol Grammar.TypeParameter <*> children (TypeScript.Syntax.TypeParameter <$> term identifier <*> term (constraint <|> emptyTerm) <*> term (defaultType <|> emptyTerm))
+typeParameter' = makeTerm <$> symbol Grammar.TypeParameter <*> children (TypeScript.Syntax.TypeParameter <$> term typeIdentifier <*> term (constraint <|> emptyTerm) <*> term (defaultType <|> emptyTerm))
 
 defaultType :: Assignment Term
 defaultType = makeTerm <$> symbol Grammar.DefaultType <*> children (TypeScript.Syntax.DefaultType <$> term ty)
@@ -593,7 +593,7 @@ typeQuery :: Assignment Term
 typeQuery = makeTerm <$> symbol Grammar.TypeQuery <*> children (TypeScript.Syntax.TypeQuery <$> term (identifier <|> nestedIdentifier))
 
 indexTypeQuery :: Assignment Term
-indexTypeQuery = makeTerm <$> symbol Grammar.IndexTypeQuery <*> children (TypeScript.Syntax.IndexTypeQuery <$> term (typeIdentifier <|> nestedIdentifier))
+indexTypeQuery = makeTerm <$> symbol Grammar.IndexTypeQuery <*> children (TypeScript.Syntax.IndexTypeQuery <$> term (typeIdentifier <|> nestedTypeIdentifier))
 
 thisType :: Assignment Term
 thisType = makeTerm <$> symbol Grammar.ThisType <*> (TypeScript.Syntax.ThisType <$> source)
@@ -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))
@@ -725,7 +725,7 @@ importStatement =   makeImportTerm <$> symbol Grammar.ImportStatement <*> childr
     makeImportTerm loc ([x], from) = makeImportTerm1 loc from x
     makeImportTerm loc (xs, from) = makeTerm loc $ fmap (makeImportTerm1 loc from) xs
     importSymbol = symbol Grammar.ImportSpecifier *> children (makeNameAliasPair <$> rawIdentifier <*> ((Just <$> rawIdentifier) <|> pure Nothing))
-    rawIdentifier = (symbol Identifier <|> symbol Identifier') *> (name <$> source)
+    rawIdentifier = (symbol Identifier <|> symbol Identifier' <|> symbol Identifier'') *> (name <$> source)
     makeNameAliasPair from (Just alias) = (from, alias)
     makeNameAliasPair from Nothing = (from, from)
 
@@ -784,7 +784,7 @@ exportStatement = makeTerm <$> symbol Grammar.ExportStatement <*> children (flip
                  <|> symbol Grammar.ExportSpecifier *> children (makeNameAliasPair <$> rawIdentifier <*> pure Nothing)
     makeNameAliasPair from (Just alias) = TypeScript.Syntax.Alias from alias
     makeNameAliasPair from Nothing = TypeScript.Syntax.Alias from from
-    rawIdentifier = (symbol Identifier <|> symbol Identifier') *> (name <$> source)
+    rawIdentifier = (symbol Identifier <|> symbol Identifier' <|> symbol Identifier'') *> (name <$> source)
     -- TODO: Need to validate that inline comments are still handled with this change in assigning to Path and not a Term.
     fromClause = symbol Grammar.String *> (TypeScript.Resolution.importPath <$> source)
 
@@ -860,7 +860,7 @@ variableDeclarator =
   where
     makeVarDecl loc (subject, annotations, value) = makeTerm loc (Statement.Assignment [annotations] subject value)
 
-    requireCall = symbol CallExpression *> children ((symbol Identifier <|> symbol Identifier') *> do
+    requireCall = symbol CallExpression *> children ((symbol Identifier <|> symbol Identifier' <|> symbol Identifier'') *> do
       s <- source
       guard (s == "require")
       symbol Arguments *> children (symbol Grammar.String *> (TypeScript.Resolution.importPath <$> source))

src/Language/TypeScript/Resolution.hs

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

src/Language/TypeScript/Syntax/TypeScript.hs

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

src/Semantic/Graph.hs

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

src/Semantic/REPL.hs

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

src/Semantic/Util.hs

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

test/Analysis/Go/Spec.hs

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

test/Analysis/PHP/Spec.hs

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

test/Analysis/Python/Spec.hs

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

test/Analysis/Ruby/Spec.hs

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

test/Analysis/TypeScript/Spec.hs

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

test/Rendering/TOC/Spec.hs

@@ -152,7 +152,7 @@ spec = parallel $ do
     it "produces JSON output if there are parse errors" $ do
       blobs <- blobsForPaths (both "ruby/toc/methods.A.rb" "ruby/toc/methods.X.rb")
       output <- runTaskWithOptions (defaultOptions { optionsLogLevel = Nothing }) (runDiff ToCDiffRenderer [blobs])
-      runBuilder output `shouldBe` ("{\"changes\":{\"test/fixtures/ruby/toc/methods.A.rb -> test/fixtures/ruby/toc/methods.X.rb\":[{\"span\":{\"start\":[1,1],\"end\":[2,4]},\"category\":\"Method\",\"term\":\"bar\",\"changeType\":\"removed\"},{\"span\":{\"start\":[4,1],\"end\":[5,4]},\"category\":\"Method\",\"term\":\"baz\",\"changeType\":\"removed\"}]},\"errors\":{\"test/fixtures/ruby/toc/methods.A.rb -> test/fixtures/ruby/toc/methods.X.rb\":[{\"span\":{\"start\":[1,1],\"end\":[3,1]},\"error\":\"expected end of input nodes, but got ParseError\",\"language\":\"Ruby\"}]}}\n" :: ByteString)
+      runBuilder output `shouldBe` ("{\"changes\":{\"test/fixtures/ruby/toc/methods.A.rb -> test/fixtures/ruby/toc/methods.X.rb\":[{\"span\":{\"start\":[1,1],\"end\":[2,4]},\"category\":\"Method\",\"term\":\"bar\",\"changeType\":\"removed\"},{\"span\":{\"start\":[4,1],\"end\":[5,4]},\"category\":\"Method\",\"term\":\"baz\",\"changeType\":\"removed\"}]},\"errors\":{\"test/fixtures/ruby/toc/methods.A.rb -> test/fixtures/ruby/toc/methods.X.rb\":[{\"span\":{\"start\":[1,1],\"end\":[2,3]},\"error\":\"expected end of input nodes, but got ParseError\",\"language\":\"Ruby\"}]}}\n" :: ByteString)
 
     it "ignores anonymous functions" $ do
       blobs <- blobsForPaths (both "ruby/toc/lambda.A.rb" "ruby/toc/lambda.B.rb")

test/SpecHelpers.hs

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

test/fixtures/ruby/corpus/if.diffA-B.txt

@@ -18,5 +18,6 @@
 {+(If
   {+(Send
     {+(Identifier)+})+}
-  {+(Statements)+}
+  {+(Statements
+    {+(Statements)+})+}
   {+(Empty)+})+})

test/fixtures/ruby/corpus/if.diffB-A.txt

@@ -18,5 +18,6 @@
 {-(If
   {-(Send
     {-(Identifier)-})-}
-  {-(Statements)-}
+  {-(Statements
+    {-(Statements)-})-}
   {-(Empty)-})-})

test/fixtures/ruby/corpus/if.parseB.txt

@@ -7,5 +7,6 @@
   (If
     (Send
       (Identifier))
-    (Statements)
+    (Statements
+      (Statements))
     (Empty)))

test/fixtures/ruby/corpus/unless.diffA-B.txt

@@ -14,5 +14,6 @@
   {+(Not
     {+(Send
       {+(Identifier)+})+})+}
-  {+(Statements)+}
+  {+(Statements
+    {+(Statements)+})+}
   {+(Empty)+})+})

test/fixtures/ruby/corpus/unless.diffB-A.txt

@@ -14,5 +14,6 @@
   {-(Not
     {-(Send
       {-(Identifier)-})-})-}
-  {-(Statements)-}
+  {-(Statements
+    {-(Statements)-})-}
   {-(Empty)-})-})

test/fixtures/ruby/corpus/unless.parseB.txt

@@ -9,5 +9,6 @@
     (Not
       (Send
         (Identifier)))
-    (Statements)
+    (Statements
+      (Statements))
     (Empty)))

test/fixtures/ruby/corpus/when-else.B.rb

@@ -1,6 +1,8 @@
 case foo
 when bar
   baz
+when x
+when y
 else
   qoz
 end

test/fixtures/ruby/corpus/when-else.diffA-B.txt

@@ -3,23 +3,33 @@
     (Send
       (Identifier))
     (Statements
+    {+(Pattern
+      {+(Statements
+        {+(Send
+          {+(Identifier)+})+})+}
+      {+(Statements
+        {+(Send
+          {+(Identifier)+})+})+})+}
       (Pattern
         (Statements
           (Send
           { (Identifier)
           ->(Identifier) }))
-        (Statements
+        (Statements))
+    {+(Pattern
+      {+(Statements
         {+(Send
-          {+(Identifier)+})+}
-        {+(Send
-          {+(Identifier)+})+}
-        {-(Pattern
-          {-(Statements
-            {-(Send
-              {-(Identifier)-})-}
-            {-(Send
-              {-(Identifier)-})-})-}
-          {-(Statements
-            {-(Send
-              {-(Identifier)-})-}
-            {-(Statements)-})-})-})))))
+          {+(Identifier)+})+})+}
+      {+(Statements)+})+}
+    {+(Send
+      {+(Identifier)+})+}
+    {-(Pattern
+      {-(Statements
+        {-(Send
+          {-(Identifier)-})-}
+        {-(Send
+          {-(Identifier)-})-})-}
+      {-(Statements
+        {-(Send
+          {-(Identifier)-})-})-})-}
+    {-(Statements)-})))

test/fixtures/ruby/corpus/when-else.diffB-A.txt

@@ -3,23 +3,30 @@
     (Send
       (Identifier))
     (Statements
+    {+(Pattern
+      {+(Statements
+        {+(Send
+          {+(Identifier)+})+})+}
+      {+(Statements)+})+}
       (Pattern
         (Statements
           (Send
-          { (Identifier)
-          ->(Identifier) }))
+            (Identifier))
+        {+(Send
+          {+(Identifier)+})+})
         (Statements
-        {+(Pattern
-          {+(Statements
-            {+(Send
-              {+(Identifier)+})+}
-            {+(Send
-              {+(Identifier)+})+})+}
-          {+(Statements
-            {+(Send
-              {+(Identifier)+})+}
-            {+(Statements)+})+})+}
+          (Send
+            (Identifier))))
+    {+(Statements)+}
+    {-(Pattern
+      {-(Statements
         {-(Send
-          {-(Identifier)-})-}
+          {-(Identifier)-})-})-}
+      {-(Statements)-})-}
+    {-(Pattern
+      {-(Statements
         {-(Send
-          {-(Identifier)-})-})))))
+          {-(Identifier)-})-})-}
+      {-(Statements)-})-}
+    {-(Send
+      {-(Identifier)-})-})))

test/fixtures/ruby/corpus/when-else.parseA.txt

@@ -7,14 +7,14 @@
         (Statements
           (Send
             (Identifier)))
+        (Statements))
+      (Pattern
         (Statements
-          (Pattern
-            (Statements
-              (Send
-                (Identifier))
-              (Send
-                (Identifier)))
-            (Statements
-              (Send
-                (Identifier))
-              (Statements))))))))
+          (Send
+            (Identifier))
+          (Send
+            (Identifier)))
+        (Statements
+          (Send
+            (Identifier))))
+      (Statements))))

test/fixtures/ruby/corpus/when-else.parseB.txt

@@ -9,6 +9,16 @@
             (Identifier)))
         (Statements
           (Send
-            (Identifier))
+            (Identifier))))
+      (Pattern
+        (Statements
           (Send
-            (Identifier)))))))
+            (Identifier)))
+        (Statements))
+      (Pattern
+        (Statements
+          (Send
+            (Identifier)))
+        (Statements))
+      (Send
+        (Identifier)))))

test/fixtures/ruby/corpus/when.diffA-B.txt

@@ -8,17 +8,17 @@
           (Send
             (Identifier)))
         (Statements
+        {+(Send
+          {+(Identifier)+})+}))
+    {+(Pattern
+      {+(Statements
         {+(Send
           {+(Identifier)+})+}
-        {+(Pattern
-          {+(Statements
-            {+(Send
-              {+(Identifier)+})+}
-            {+(Send
-              {+(Identifier)+})+})+}
-          {+(Statements
-            {+(Send
-              {+(Identifier)+})+})+})+}))))
+        {+(Send
+          {+(Identifier)+})+})+}
+      {+(Statements)+})+}
+    {+(Send
+      {+(Identifier)+})+}))
 {-(Match
   {-(Empty)-}
   {-(Statements

test/fixtures/ruby/corpus/when.diffB-A.txt

@@ -8,17 +8,17 @@
           (Send
             (Identifier)))
         (Statements
+        {-(Send
+          {-(Identifier)-})-}))
+    {-(Pattern
+      {-(Statements
         {-(Send
           {-(Identifier)-})-}
-        {-(Pattern
-          {-(Statements
-            {-(Send
-              {-(Identifier)-})-}
-            {-(Send
-              {-(Identifier)-})-})-}
-          {-(Statements
-            {-(Send
-              {-(Identifier)-})-})-})-}))))
+        {-(Send
+          {-(Identifier)-})-})-}
+      {-(Statements)-})-}
+    {-(Send
+      {-(Identifier)-})-}))
 {+(Match
   {+(Empty)+}
   {+(Statements

test/fixtures/ruby/corpus/when.parseB.txt

@@ -7,15 +7,15 @@
         (Statements
           (Send
             (Identifier)))
+        (Statements
+          (Send
+            (Identifier))))
+      (Pattern
         (Statements
           (Send
             (Identifier))
-          (Pattern
-            (Statements
-              (Send
-                (Identifier))
-              (Send
-                (Identifier)))
-            (Statements
-              (Send
-                (Identifier)))))))))
+          (Send
+            (Identifier)))
+        (Statements))
+      (Send
+        (Identifier)))))

test/fixtures/typescript/corpus/class.diffA-B.txt

@@ -1,8 +1,8 @@
 (Statements
   (Class
     (TypeParameter
-    { (Identifier)
-    ->(Identifier) }
+    { (TypeIdentifier)
+    ->(TypeIdentifier) }
       (Empty)
       (Empty))
   { (TypeIdentifier)

test/fixtures/typescript/corpus/class.diffB-A.txt

@@ -1,8 +1,8 @@
 (Statements
   (Class
     (TypeParameter
-    { (Identifier)
-    ->(Identifier) }
+    { (TypeIdentifier)
+    ->(TypeIdentifier) }
       (Empty)
       (Empty))
   { (TypeIdentifier)

test/fixtures/typescript/corpus/class.parseA.txt

@@ -1,7 +1,7 @@
 (Statements
   (Class
     (TypeParameter
-      (Identifier)
+      (TypeIdentifier)
       (Empty)
       (Empty))
     (TypeIdentifier)

test/fixtures/typescript/corpus/class.parseB.txt

@@ -1,7 +1,7 @@
 (Statements
   (Class
     (TypeParameter
-      (Identifier)
+      (TypeIdentifier)
       (Empty)
       (Empty))
     (TypeIdentifier)

test/fixtures/typescript/corpus/function.diffA-B.txt

@@ -5,7 +5,7 @@
     {+(TypeIdentifier)+})+}
   {-(TypeParameters
     {-(TypeParameter
-      {-(Identifier)-}
+      {-(TypeIdentifier)-}
       {-(Empty)-}
       {-(Empty)-})-})-}
   {-(Annotation

test/fixtures/typescript/corpus/function.diffB-A.txt

@@ -2,7 +2,7 @@
   (Function
   {+(TypeParameters
     {+(TypeParameter
-      {+(Identifier)+}
+      {+(TypeIdentifier)+}
       {+(Empty)+}
       {+(Empty)+})+})+}
   {+(Annotation

test/fixtures/typescript/corpus/function.parseA.txt

@@ -2,7 +2,7 @@
   (Function
     (TypeParameters
       (TypeParameter
-        (Identifier)
+        (TypeIdentifier)
         (Empty)
         (Empty)))
     (Annotation

test/fixtures/typescript/corpus/interface.diffA-B.txt

@@ -3,7 +3,7 @@
   {+(Empty)+}
   {-(TypeParameters
     {-(TypeParameter
-      {-(Identifier)-}
+      {-(TypeIdentifier)-}
       {-(Empty)-}
       {-(Empty)-})-})-}
   { (TypeIdentifier)

test/fixtures/typescript/corpus/interface.diffB-A.txt

@@ -2,7 +2,7 @@
   (InterfaceDeclaration
   {+(TypeParameters
     {+(TypeParameter
-      {+(Identifier)+}
+      {+(TypeIdentifier)+}
       {+(Empty)+}
       {+(Empty)+})+})+}
   {-(Empty)-}

test/fixtures/typescript/corpus/interface.parseA.txt

@@ -2,7 +2,7 @@
   (InterfaceDeclaration
     (TypeParameters
       (TypeParameter
-        (Identifier)
+        (TypeIdentifier)
         (Empty)
         (Empty)))
     (TypeIdentifier)

vendor/haskell-tree-sitter

@@ -1 +1 @@
-Subproject commit 75f9ddd2deb992d944a8485fe9b0cc7c84911c31
+Subproject commit 09ff8a81cd92a696939eb82e0c33111bde3f0376