Merge pull request #1696 from github/symbol-resolution

Symbol resolution

semantic.cabal

@@ -54,9 +54,11 @@ library
                      , Data.Abstract.FreeVariables
                      , Data.Abstract.Heap
                      , Data.Abstract.Live
+                     , Data.Abstract.Located
                      , Data.Abstract.Module
                      , Data.Abstract.ModuleTable
                      , Data.Abstract.Number
+                     , Data.Abstract.Origin
                      , Data.Abstract.Path
                      , Data.Abstract.Type
                      , Data.Abstract.Value

src/Analysis/Abstract/BadVariables.hs

@@ -11,20 +11,20 @@ import Prologue
 newtype BadVariables m (effects :: [* -> *]) a = BadVariables (m effects a)
   deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet)
 
-deriving instance MonadControl term (m effects)           => MonadControl term (BadVariables m effects)
+deriving instance MonadControl term (m effects)                    => MonadControl term (BadVariables m effects)
-deriving instance MonadEnvironment value (m effects)      => MonadEnvironment value (BadVariables m effects)
+deriving instance MonadEnvironment location value (m effects)      => MonadEnvironment location value (BadVariables m effects)
-deriving instance MonadHeap value (m effects)             => MonadHeap value (BadVariables m effects)
+deriving instance MonadHeap location value (m effects)             => MonadHeap location value (BadVariables m effects)
-deriving instance MonadModuleTable term value (m effects) => MonadModuleTable term value (BadVariables m effects)
+deriving instance MonadModuleTable location term value (m effects) => MonadModuleTable location term value (BadVariables m effects)
-deriving instance MonadEvaluator term value (m effects)   => MonadEvaluator term value (BadVariables m effects)
+deriving instance MonadEvaluator location term value (m effects)   => MonadEvaluator location term value (BadVariables m effects)
 
 instance ( Effectful m
          , Member (Resumable (EvalError value)) effects
          , Member (State [Name]) effects
-         , MonadAnalysis term value (m effects)
+         , MonadAnalysis location term value (m effects)
-         , MonadValue value (BadVariables m effects)
+         , MonadValue location value (BadVariables m effects)
          )
-      => MonadAnalysis term value (BadVariables m effects) where
+      => MonadAnalysis location term value (BadVariables m effects) where
-  type Effects term value (BadVariables m effects) = State [Name] ': Effects term value (m effects)
+  type Effects location term value (BadVariables m effects) = State [Name] ': Effects location term value (m effects)
 
   analyzeTerm eval term = resumeException @(EvalError value) (liftAnalyze analyzeTerm eval term) (
         \yield (FreeVariableError name) ->

src/Analysis/Abstract/Caching.hs

@@ -4,6 +4,7 @@ module Analysis.Abstract.Caching
 ) where
 
 import Control.Abstract.Analysis
+import Data.Abstract.Address
 import Data.Abstract.Cache
 import Data.Abstract.Configuration
 import Data.Abstract.Heap
@@ -11,50 +12,46 @@ import Data.Abstract.Module
 import Prologue
 
 -- | The effects necessary for caching analyses.
-type CachingEffects term value effects
+type CachingEffects location term value effects
-  = Fresh                        -- For 'MonadFresh'.
+  = NonDet                             -- For 'Alternative' and 'MonadNonDet'.
- ': NonDet                       -- For 'Alternative' and 'MonadNonDet'.
+ ': Reader (Cache location term value) -- The in-cache used as an oracle while converging on a result.
- ': Reader (CacheFor term value) -- The in-cache used as an oracle while converging on a result.
+ ': State  (Cache location term value) -- The out-cache used to record results in each iteration of convergence.
- ': State  (CacheFor term value) -- The out-cache used to record results in each iteration of convergence.
  ': effects
 
--- | The cache for term and abstract value types.
-type CacheFor term value = Cache (LocationFor value) term value
-
 -- | A (coinductively-)cached analysis suitable for guaranteeing termination of (suitably finitized) analyses over recursive programs.
 newtype Caching m (effects :: [* -> *]) a = Caching (m effects a)
   deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet)
 
-deriving instance MonadControl term (m effects)           => MonadControl term (Caching m effects)
+deriving instance MonadControl term (m effects)                    => MonadControl term (Caching m effects)
-deriving instance MonadEnvironment value (m effects)      => MonadEnvironment value (Caching m effects)
+deriving instance MonadEnvironment location value (m effects)      => MonadEnvironment location value (Caching m effects)
-deriving instance MonadHeap value (m effects)             => MonadHeap value (Caching m effects)
+deriving instance MonadHeap location value (m effects)             => MonadHeap location value (Caching m effects)
-deriving instance MonadModuleTable term value (m effects) => MonadModuleTable term value (Caching m effects)
+deriving instance MonadModuleTable location term value (m effects) => MonadModuleTable location term value (Caching m effects)
-deriving instance MonadEvaluator term value (m effects)   => MonadEvaluator term value (Caching m effects)
+deriving instance MonadEvaluator location term value (m effects)   => MonadEvaluator location term value (Caching m effects)
 
 -- | Functionality used to perform caching analysis. This is not exported, and exists primarily for organizational reasons.
-class MonadEvaluator term value m => MonadCaching term value m where
+class MonadEvaluator location term value m => MonadCaching location term value m where
   -- | Look up the set of values for a given configuration in the in-cache.
-  consultOracle :: ConfigurationFor term value -> m (Set (value, HeapFor value))
+  consultOracle :: Configuration location term value -> m (Set (value, Heap location value))
   -- | Run an action with the given in-cache.
-  withOracle :: CacheFor term value -> m a -> m a
+  withOracle :: Cache location term value -> m a -> m a
 
   -- | Look up the set of values for a given configuration in the out-cache.
-  lookupCache :: ConfigurationFor term value -> m (Maybe (Set (value, HeapFor value)))
+  lookupCache :: Configuration location term value -> m (Maybe (Set (value, Heap location value)))
   -- | Run an action, caching its result and 'Heap' under the given configuration.
-  caching :: ConfigurationFor term value -> Set (value, HeapFor value) -> m value -> m value
+  caching :: Configuration location term value -> Set (value, Heap location value) -> m value -> m value
 
   -- | Run an action starting from an empty out-cache, and return the out-cache afterwards.
-  isolateCache :: m a -> m (CacheFor term value)
+  isolateCache :: m a -> m (Cache location term value)
 
 instance ( Effectful m
-         , Members (CachingEffects term value '[]) effects
+         , Members (CachingEffects location term value '[]) effects
-         , MonadEvaluator term value (m effects)
+         , MonadEvaluator location term value (m effects)
-         , Ord (CellFor value)
+         , Ord (Cell location value)
-         , Ord (LocationFor value)
+         , Ord location
          , Ord term
          , Ord value
          )
-         => MonadCaching term value (Caching m effects) where
+         => MonadCaching location term value (Caching m effects) where
   consultOracle configuration = raise (fromMaybe mempty . cacheLookup configuration <$> ask)
   withOracle cache = raise . local (const cache) . lower
 
@@ -65,23 +62,23 @@ instance ( Effectful m
     raise (modify (cacheInsert configuration result))
     pure (fst result)
 
-  isolateCache action = raise (put (mempty :: CacheFor term value)) *> action *> raise get
+  isolateCache action = raise (put (mempty :: Cache location term value)) *> action *> raise get
 
 -- | This instance coinductively iterates the analysis of a term until the results converge.
 instance ( Corecursive term
          , Effectful m
-         , Members (CachingEffects term value '[]) effects
+         , Members (CachingEffects location term value '[]) effects
-         , MonadAnalysis term value (m effects)
+         , MonadAnalysis location term value (m effects)
          , MonadFresh (m effects)
          , MonadNonDet (m effects)
-         , Ord (CellFor value)
+         , Ord (Cell location value)
-         , Ord (LocationFor value)
+         , Ord location
          , Ord term
          , Ord value
          )
-         => MonadAnalysis term value (Caching m effects) where
+      => MonadAnalysis location term value (Caching m effects) where
   -- We require the 'CachingEffects' in addition to the underlying analysis’ 'Effects'.
-  type Effects term value (Caching m effects) = CachingEffects term value (Effects term value (m effects))
+  type Effects location term value (Caching m effects) = CachingEffects location term value (Effects location term value (m effects))
 
   -- Analyze a term using the in-cache as an oracle & storing the results of the analysis in the out-cache.
   analyzeTerm recur e = do
@@ -124,5 +121,5 @@ converge f = loop
             loop x'
 
 -- | Nondeterministically write each of a collection of stores & return their associated results.
-scatter :: (Alternative m, Foldable t, MonadEvaluator term value m) => t (a, Heap (LocationFor value) value) -> m a
+scatter :: (Alternative m, Foldable t, MonadEvaluator location term value m) => t (a, Heap location value) -> m a
 scatter = foldMapA (\ (value, heap') -> putHeap heap' $> value)

src/Analysis/Abstract/Collecting.hs

@@ -13,32 +13,32 @@ import Prologue
 newtype Collecting m (effects :: [* -> *]) a = Collecting (m effects a)
   deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet)
 
-deriving instance MonadControl term (m effects)           => MonadControl term (Collecting m effects)
+deriving instance MonadControl term (m effects)                    => MonadControl term (Collecting m effects)
-deriving instance MonadEnvironment value (m effects)      => MonadEnvironment value (Collecting m effects)
+deriving instance MonadEnvironment location value (m effects)      => MonadEnvironment location value (Collecting m effects)
-deriving instance MonadHeap value (m effects)             => MonadHeap value (Collecting m effects)
+deriving instance MonadHeap location value (m effects)             => MonadHeap location value (Collecting m effects)
-deriving instance MonadModuleTable term value (m effects) => MonadModuleTable term value (Collecting m effects)
+deriving instance MonadModuleTable location term value (m effects) => MonadModuleTable location term value (Collecting m effects)
 
 instance ( Effectful m
-         , Member (Reader (Live (LocationFor value) value)) effects
+         , Member (Reader (Live location value)) effects
-         , MonadEvaluator term value (m effects)
+         , MonadEvaluator location term value (m effects)
          )
-      => MonadEvaluator term value (Collecting m effects) where
+      => MonadEvaluator location term value (Collecting m effects) where
   getConfiguration term = Configuration term <$> askRoots <*> getEnv <*> getHeap
 
   askModuleStack = Collecting askModuleStack
 
 
 instance ( Effectful m
-         , Foldable (Cell (LocationFor value))
+         , Foldable (Cell location)
-         , Member (Reader (Live (LocationFor value) value)) effects
+         , Member (Reader (Live location value)) effects
-         , MonadAnalysis term value (m effects)
+         , MonadAnalysis location term value (m effects)
-         , Ord (LocationFor value)
+         , Ord location
-         , ValueRoots value
+         , ValueRoots location value
          )
-      => MonadAnalysis term value (Collecting m effects) where
+      => MonadAnalysis location term value (Collecting m effects) where
-  type Effects term value (Collecting m effects)
+  type Effects location term value (Collecting m effects)
-    = Reader (Live (LocationFor value) value)
+    = Reader (Live location value)
-   ': Effects term value (m effects)
+   ': Effects location term value (m effects)
 
   -- Small-step evaluation which garbage-collects any non-rooted addresses after evaluating each term.
   analyzeTerm recur term = do
@@ -51,32 +51,32 @@ instance ( Effectful m
 
 
 -- | Retrieve the local 'Live' set.
-askRoots :: (Effectful m, Member (Reader (Live (LocationFor value) value)) effects) => m effects (Live (LocationFor value) value)
+askRoots :: (Effectful m, Member (Reader (Live location value)) effects) => m effects (Live location value)
 askRoots = raise ask
 
 -- | Run a computation with the given 'Live' set added to the local root set.
--- extraRoots :: (Effectful m, Member (Reader (Live (LocationFor value) value)) effects, Ord (LocationFor value)) => Live (LocationFor value) value -> m effects a -> m effects a
+-- extraRoots :: (Effectful m, Member (Reader (Live location value)) effects, Ord location) => Live location value -> m effects a -> m effects a
 -- extraRoots roots = raise . local (<> roots) . lower
 
 
 -- | Collect any addresses in the heap not rooted in or reachable from the given 'Live' set.
-gc :: ( Ord (LocationFor value)
+gc :: ( Ord location
-      , Foldable (Cell (LocationFor value))
+      , Foldable (Cell location)
-      , ValueRoots value
+      , ValueRoots location value
       )
-   => LiveFor value -- ^ The set of addresses to consider rooted.
+   => Live location value -- ^ The set of addresses to consider rooted.
-   -> HeapFor value -- ^ A heap to collect unreachable addresses within.
+   -> Heap location value -- ^ A heap to collect unreachable addresses within.
-   -> HeapFor value -- ^ A garbage-collected heap.
+   -> Heap location value -- ^ A garbage-collected heap.
 gc roots heap = heapRestrict heap (reachable roots heap)
 
 -- | Compute the set of addresses reachable from a given root set in a given heap.
-reachable :: ( Ord (LocationFor value)
+reachable :: ( Ord location
-             , Foldable (Cell (LocationFor value))
+             , Foldable (Cell location)
-             , ValueRoots value
+             , ValueRoots location value
              )
-          => LiveFor value -- ^ The set of root addresses.
+          => Live location value -- ^ The set of root addresses.
-          -> HeapFor value -- ^ The heap to trace addresses through.
+          -> Heap location value -- ^ The heap to trace addresses through.
-          -> LiveFor value -- ^ The set of addresses reachable from the root set.
+          -> Live location value -- ^ The set of addresses reachable from the root set.
 reachable roots heap = go mempty roots
   where go seen set = case liveSplit set of
           Nothing -> seen

src/Analysis/Abstract/Dead.hs

@@ -13,11 +13,11 @@ import Prologue
 newtype DeadCode m (effects :: [* -> *]) a = DeadCode (m effects a)
   deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet)
 
-deriving instance MonadControl term (m effects)           => MonadControl term (DeadCode m effects)
+deriving instance MonadControl term (m effects)                    => MonadControl term (DeadCode m effects)
-deriving instance MonadEnvironment value (m effects)      => MonadEnvironment value (DeadCode m effects)
+deriving instance MonadEnvironment location value (m effects)      => MonadEnvironment location value (DeadCode m effects)
-deriving instance MonadHeap value (m effects)             => MonadHeap value (DeadCode m effects)
+deriving instance MonadHeap location value (m effects)             => MonadHeap location value (DeadCode m effects)
-deriving instance MonadModuleTable term value (m effects) => MonadModuleTable term value (DeadCode m effects)
+deriving instance MonadModuleTable location term value (m effects) => MonadModuleTable location term value (DeadCode m effects)
-deriving instance MonadEvaluator term value (m effects)   => MonadEvaluator term value (DeadCode m effects)
+deriving instance MonadEvaluator location term value (m effects)   => MonadEvaluator location term value (DeadCode m effects)
 
 -- | A set of “dead” (unreachable) terms.
 newtype Dead term = Dead { unDead :: Set term }
@@ -42,12 +42,12 @@ instance ( Corecursive term
          , Effectful m
          , Foldable (Base term)
          , Member (State (Dead term)) effects
-         , MonadAnalysis term value (m effects)
+         , MonadAnalysis location term value (m effects)
          , Ord term
          , Recursive term
          )
-         => MonadAnalysis term value (DeadCode m effects) where
+      => MonadAnalysis location term value (DeadCode m effects) where
-  type Effects term value (DeadCode m effects) = State (Dead term) ': Effects term value (m effects)
+  type Effects location term value (DeadCode m effects) = State (Dead term) ': Effects location term value (m effects)
 
   analyzeTerm recur term = do
     revive (embedSubterm term)

src/Analysis/Abstract/Evaluating.hs

@@ -6,80 +6,86 @@ module Analysis.Abstract.Evaluating
 
 import           Control.Abstract.Analysis
 import           Control.Monad.Effect
+import           Data.Abstract.Address
 import           Data.Abstract.Configuration
-import qualified Data.Abstract.Environment as Env
+import           Data.Abstract.Environment as Env
 import           Data.Abstract.Evaluatable
+import           Data.Abstract.Exports
+import           Data.Abstract.Heap
 import           Data.Abstract.Module
 import           Data.Abstract.ModuleTable
+import           Data.Abstract.Origin
 import qualified Data.IntMap as IntMap
 import           Lens.Micro
 import           Prelude hiding (fail)
 import           Prologue
 
 -- | An analysis evaluating @term@s to @value@s with a list of @effects@ using 'Evaluatable', and producing incremental results of type @a@.
-newtype Evaluating term value effects a = Evaluating (Eff effects a)
+newtype Evaluating location term value effects a = Evaluating (Eff effects a)
   deriving (Applicative, Functor, Effectful, Monad)
 
-deriving instance Member Fail   effects => MonadFail   (Evaluating term value effects)
+deriving instance Member Fail   effects => MonadFail   (Evaluating location term value effects)
-deriving instance Member Fresh  effects => MonadFresh  (Evaluating term value effects)
+deriving instance Member Fresh  effects => MonadFresh  (Evaluating location term value effects)
-deriving instance Member NonDet effects => Alternative (Evaluating term value effects)
+deriving instance Member NonDet effects => Alternative (Evaluating location term value effects)
-deriving instance Member NonDet effects => MonadNonDet (Evaluating term value effects)
+deriving instance Member NonDet effects => MonadNonDet (Evaluating location term value effects)
 
 -- | Effects necessary for evaluating (whether concrete or abstract).
-type EvaluatingEffects term value
+type EvaluatingEffects location term value
   = '[ Resumable (EvalError value)
      , Resumable (LoadError term value)
-     , Resumable (ValueExc value)
+     , Resumable (ValueExc location value)
      , Resumable (Unspecialized value)
-     , Fail                                -- Failure with an error message
+     , Fail                                         -- Failure with an error message
-     , Reader [Module term]                -- The stack of currently-evaluating modules.
+     , Fresh                                        -- For allocating new addresses and/or type variables.
-     , Reader (ModuleTable [Module term])  -- Cache of unevaluated modules
+     , Reader [Module term]                         -- The stack of currently-evaluating modules.
-     , Reader (EnvironmentFor value)       -- Default environment used as a fallback in lookupEnv
+     , Reader Origin                                -- The current term’s origin.
-     , State  (EvaluatingState term value) -- Environment, heap, modules, exports, and jumps.
+     , Reader (ModuleTable [Module term])           -- Cache of unevaluated modules
+     , Reader (Environment location value)          -- Default environment used as a fallback in lookupEnv
+     , State  (EvaluatingState location term value) -- Environment, heap, modules, exports, and jumps.
      ]
 
-data EvaluatingState term value = EvaluatingState
+data EvaluatingState location term value = EvaluatingState
-  { environment :: EnvironmentFor value
+  { environment :: Environment location value
-  , heap        :: HeapFor value
+  , heap        :: Heap location value
-  , modules     :: ModuleTable (EnvironmentFor value, value)
+  , modules     :: ModuleTable (Environment location value, value)
-  , exports     :: ExportsFor value
+  , exports     :: Exports location value
   , jumps       :: IntMap.IntMap term
   }
 
-deriving instance (Eq (CellFor value), Eq (LocationFor value), Eq term, Eq value) => Eq (EvaluatingState term value)
+deriving instance (Eq (Cell location value), Eq location, Eq term, Eq value) => Eq (EvaluatingState location term value)
-deriving instance (Ord (CellFor value), Ord (LocationFor value), Ord term, Ord value) => Ord (EvaluatingState term value)
+deriving instance (Ord (Cell location value), Ord location, Ord term, Ord value) => Ord (EvaluatingState location term value)
-deriving instance (Show (CellFor value), Show (LocationFor value), Show term, Show value) => Show (EvaluatingState term value)
+deriving instance (Show (Cell location value), Show location, Show term, Show value) => Show (EvaluatingState location term value)
 
-instance (Ord (LocationFor value), Semigroup (CellFor value)) => Semigroup (EvaluatingState term value) where
+instance (Ord location, Semigroup (Cell location value)) => Semigroup (EvaluatingState location term value) where
   EvaluatingState e1 h1 m1 x1 j1 <> EvaluatingState e2 h2 m2 x2 j2 = EvaluatingState (e1 <> e2) (h1 <> h2) (m1 <> m2) (x1 <> x2) (j1 <> j2)
 
-instance (Ord (LocationFor value), Semigroup (CellFor value)) => Monoid (EvaluatingState term value) where
+instance (Ord location, Semigroup (Cell location value)) => Monoid (EvaluatingState location term value) where
   mempty = EvaluatingState mempty mempty mempty mempty mempty
   mappend = (<>)
 
-_environment :: Lens' (EvaluatingState term value) (EnvironmentFor value)
+_environment :: Lens' (EvaluatingState location term value) (Environment location value)
 _environment = lens environment (\ s e -> s {environment = e})
 
-_heap :: Lens' (EvaluatingState term value) (HeapFor value)
+_heap :: Lens' (EvaluatingState location term value) (Heap location value)
 _heap = lens heap (\ s h -> s {heap = h})
 
-_modules :: Lens' (EvaluatingState term value) (ModuleTable (EnvironmentFor value, value))
+_modules :: Lens' (EvaluatingState location term value) (ModuleTable (Environment location value, value))
 _modules = lens modules (\ s m -> s {modules = m})
 
-_exports :: Lens' (EvaluatingState term value) (ExportsFor value)
+_exports :: Lens' (EvaluatingState location term value) (Exports location value)
 _exports = lens exports (\ s e -> s {exports = e})
 
-_jumps :: Lens' (EvaluatingState term value) (IntMap.IntMap term)
+_jumps :: Lens' (EvaluatingState location term value) (IntMap.IntMap term)
 _jumps = lens jumps (\ s j -> s {jumps = j})
 
 
-(.=) :: Member (State (EvaluatingState term value)) effects => ASetter (EvaluatingState term value) (EvaluatingState term value) a b -> b -> Evaluating term value effects ()
+(.=) :: Member (State (EvaluatingState location term value)) effects => ASetter (EvaluatingState location term value) (EvaluatingState location term value) a b -> b -> Evaluating location term value effects ()
 lens .= val = raise (modify' (lens .~ val))
 
-view :: Member (State (EvaluatingState term value)) effects => Getting a (EvaluatingState term value) a -> Evaluating term value effects a
+view :: Member (State (EvaluatingState location term value)) effects => Getting a (EvaluatingState location term value) a -> Evaluating location term value effects a
 view lens = raise (gets (^. lens))
 
-localEvaluatingState :: Member (State (EvaluatingState term value)) effects => Lens' (EvaluatingState term value) prj -> (prj -> prj) -> Evaluating term value effects a -> Evaluating term value effects a
+localEvaluatingState :: Member (State (EvaluatingState location term value)) effects => Lens' (EvaluatingState location term value) prj -> (prj -> prj) -> Evaluating location term value effects a -> Evaluating location term value effects a
 localEvaluatingState lens f action = do
   original <- view lens
   lens .= f original
@@ -87,7 +93,7 @@ localEvaluatingState lens f action = do
   v <$ lens .= original
 
 
-instance Members '[Fail, State (EvaluatingState term value)] effects => MonadControl term (Evaluating term value effects) where
+instance Members '[Fail, State (EvaluatingState location term value)] effects => MonadControl term (Evaluating location term value effects) where
   label term = do
     m <- view _jumps
     let i = IntMap.size m
@@ -96,10 +102,10 @@ instance Members '[Fail, State (EvaluatingState term value)] effects => MonadCon
 
   goto label = IntMap.lookup label <$> view _jumps >>= maybe (fail ("unknown label: " <> show label)) pure
 
-instance Members '[ State (EvaluatingState term value)
+instance Members '[ State (EvaluatingState location term value)
-                  , Reader (EnvironmentFor value)
+                  , Reader (Environment location value)
                   ] effects
-      => MonadEnvironment value (Evaluating term value effects) where
+      => MonadEnvironment location value (Evaluating location term value effects) where
   getEnv = view _environment
   putEnv = (_environment .=)
   withEnv s = localEvaluatingState _environment (const s)
@@ -116,31 +122,40 @@ instance Members '[ State (EvaluatingState term value)
     result <- a
     result <$ modifyEnv Env.pop
 
-instance Member (State (EvaluatingState term value)) effects => MonadHeap value (Evaluating term value effects) where
+instance Member (State (EvaluatingState location term value)) effects
+      => MonadHeap location value (Evaluating location term value effects) where
   getHeap = view _heap
   putHeap = (_heap .=)
 
-instance Members '[Reader (ModuleTable [Module term]), State (EvaluatingState term value)] effects => MonadModuleTable term value (Evaluating term value effects) where
+instance Members '[Reader (ModuleTable [Module term]), State (EvaluatingState location term value)] effects
+      => MonadModuleTable location term value (Evaluating location term value effects) where
   getModuleTable = view _modules
   putModuleTable = (_modules .=)
 
   askModuleTable = raise ask
   localModuleTable f a = raise (local f (lower a))
 
-instance Members (EvaluatingEffects term value) effects => MonadEvaluator term value (Evaluating term value effects) where
+instance Members (EvaluatingEffects location term value) effects
+      => MonadEvaluator location term value (Evaluating location term value effects) where
   getConfiguration term = Configuration term mempty <$> getEnv <*> getHeap
 
   askModuleStack = raise ask
 
-instance ( Members (EvaluatingEffects term value) effects
+instance ( Members (EvaluatingEffects location term value) effects
-         , MonadValue value (Evaluating term value effects)
+         , MonadValue location value (Evaluating location term value effects)
+         , HasOrigin (Base term)
          )
-         => MonadAnalysis term value (Evaluating term value effects) where
+      => MonadAnalysis location term value (Evaluating location term value effects) where
-  type Effects term value (Evaluating term value effects) = EvaluatingEffects term value
+  type Effects location term value (Evaluating location term value effects) = EvaluatingEffects location term value
 
-  analyzeTerm = id
+  analyzeTerm eval term = do
+    ms <- askModuleStack
+    pushOrigin (originFor ms term) (eval term)
 
   analyzeModule eval m = pushModule (subterm <$> m) (eval m)
 
-pushModule :: Member (Reader [Module term]) effects => Module term -> Evaluating term value effects a -> Evaluating term value effects a
+pushModule :: Member (Reader [Module term]) effects => Module term -> Evaluating location term value effects a -> Evaluating location term value effects a
 pushModule m = raise . local (m :) . lower
+
+pushOrigin :: Member (Reader Origin) effects => Origin -> Evaluating location term value effects a -> Evaluating location term value effects a
+pushOrigin o = raise . local (const o) . lower

src/Analysis/Abstract/ImportGraph.hs

@@ -26,20 +26,20 @@ renderImportGraph = export (defaultStyle friendlyName) . unImportGraph
 newtype ImportGraphing m (effects :: [* -> *]) a = ImportGraphing (m effects a)
   deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet)
 
-deriving instance MonadControl term (m effects)           => MonadControl term (ImportGraphing m effects)
+deriving instance MonadControl term (m effects)                    => MonadControl term (ImportGraphing m effects)
-deriving instance MonadEnvironment value (m effects)      => MonadEnvironment value (ImportGraphing m effects)
+deriving instance MonadEnvironment location value (m effects)      => MonadEnvironment location value (ImportGraphing m effects)
-deriving instance MonadHeap value (m effects)             => MonadHeap value (ImportGraphing m effects)
+deriving instance MonadHeap location value (m effects)             => MonadHeap location value (ImportGraphing m effects)
-deriving instance MonadModuleTable term value (m effects) => MonadModuleTable term value (ImportGraphing m effects)
+deriving instance MonadModuleTable location term value (m effects) => MonadModuleTable location term value (ImportGraphing m effects)
-deriving instance MonadEvaluator term value (m effects)   => MonadEvaluator term value (ImportGraphing m effects)
+deriving instance MonadEvaluator location term value (m effects)   => MonadEvaluator location term value (ImportGraphing m effects)
 
 
 instance ( Effectful m
          , Member (State ImportGraph) effects
-         , MonadAnalysis term value (m effects)
+         , MonadAnalysis location term value (m effects)
          , Member (Resumable (LoadError term value)) effects
          )
-         => MonadAnalysis term value (ImportGraphing m effects) where
+      => MonadAnalysis location term value (ImportGraphing m effects) where
-  type Effects term value (ImportGraphing m effects) = State ImportGraph ': Effects term value (m effects)
+  type Effects location term value (ImportGraphing m effects) = State ImportGraph ': Effects location term value (m effects)
 
   analyzeTerm eval term = resumeException
                             @(LoadError term value)
@@ -52,7 +52,7 @@ instance ( Effectful m
 
 insertVertexName :: (Effectful m
                    , Member (State ImportGraph) effects
-                   , MonadEvaluator term value (m effects))
+                   , MonadEvaluator location term value (m effects))
                  => NonEmpty ByteString
                  -> ImportGraphing m effects ()
 insertVertexName name = do

src/Analysis/Abstract/Quiet.hs

@@ -17,19 +17,19 @@ import Prologue
 newtype Quietly m (effects :: [* -> *]) a = Quietly (m effects a)
   deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet)
 
-deriving instance MonadControl term (m effects)           => MonadControl term (Quietly m effects)
+deriving instance MonadControl term (m effects)                    => MonadControl term (Quietly m effects)
-deriving instance MonadEnvironment value (m effects)      => MonadEnvironment value (Quietly m effects)
+deriving instance MonadEnvironment location value (m effects)      => MonadEnvironment location value (Quietly m effects)
-deriving instance MonadHeap value (m effects)             => MonadHeap value (Quietly m effects)
+deriving instance MonadHeap location value (m effects)             => MonadHeap location value (Quietly m effects)
-deriving instance MonadModuleTable term value (m effects) => MonadModuleTable term value (Quietly m effects)
+deriving instance MonadModuleTable location term value (m effects) => MonadModuleTable location term value (Quietly m effects)
-deriving instance MonadEvaluator term value (m effects)   => MonadEvaluator term value (Quietly m effects)
+deriving instance MonadEvaluator location term value (m effects)   => MonadEvaluator location term value (Quietly m effects)
 
 instance ( Effectful m
          , Member (Resumable (Unspecialized value)) effects
-         , MonadAnalysis term value (m effects)
+         , MonadAnalysis location term value (m effects)
-         , MonadValue value (Quietly m effects)
+         , MonadValue location value (Quietly m effects)
          )
-      => MonadAnalysis term value (Quietly m effects) where
+      => MonadAnalysis location term value (Quietly m effects) where
-  type Effects term value (Quietly m effects) = Effects term value (m effects)
+  type Effects location term value (Quietly m effects) = Effects location term value (m effects)
 
   analyzeTerm eval term = resumeException @(Unspecialized value) (liftAnalyze analyzeTerm eval term) (\yield (Unspecialized _) -> unit >>= yield)
 

src/Analysis/Abstract/Tracing.hs

@@ -5,6 +5,7 @@ module Analysis.Abstract.Tracing
 
 import Control.Abstract.Analysis
 import Control.Monad.Effect.Writer
+import Data.Abstract.Configuration
 import Data.Semigroup.Reducer as Reducer
 import Data.Union
 import Prologue
@@ -15,25 +16,25 @@ import Prologue
 newtype Tracing (trace :: * -> *) m (effects :: [* -> *]) a = Tracing (m effects a)
   deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet)
 
-deriving instance MonadControl term (m effects)           => MonadControl term (Tracing trace m effects)
+deriving instance MonadControl term (m effects)                    => MonadControl term (Tracing trace m effects)
-deriving instance MonadEnvironment value (m effects)      => MonadEnvironment value (Tracing trace m effects)
+deriving instance MonadEnvironment location value (m effects)      => MonadEnvironment location value (Tracing trace m effects)
-deriving instance MonadHeap value (m effects)             => MonadHeap value (Tracing trace m effects)
+deriving instance MonadHeap location value (m effects)             => MonadHeap location value (Tracing trace m effects)
-deriving instance MonadModuleTable term value (m effects) => MonadModuleTable term value (Tracing trace m effects)
+deriving instance MonadModuleTable location term value (m effects) => MonadModuleTable location term value (Tracing trace m effects)
-deriving instance MonadEvaluator term value (m effects)   => MonadEvaluator term value (Tracing trace m effects)
+deriving instance MonadEvaluator location term value (m effects)   => MonadEvaluator location term value (Tracing trace m effects)
 
 instance ( Corecursive term
          , Effectful m
-         , Member (Writer (trace (ConfigurationFor term value))) effects
+         , Member (Writer (trace (Configuration location term value))) effects
-         , MonadAnalysis term value (m effects)
+         , MonadAnalysis location term value (m effects)
-         , Ord (LocationFor value)
+         , Ord location
-         , Reducer (ConfigurationFor term value) (trace (ConfigurationFor term value))
+         , Reducer (Configuration location term value) (trace (Configuration location term value))
          )
-         => MonadAnalysis term value (Tracing trace m effects) where
+      => MonadAnalysis location term value (Tracing trace m effects) where
-  type Effects term value (Tracing trace m effects) = Writer (trace (ConfigurationFor term value)) ': Effects term value (m effects)
+  type Effects location term value (Tracing trace m effects) = Writer (trace (Configuration location term value)) ': Effects location term value (m effects)
 
   analyzeTerm recur term = do
     config <- getConfiguration (embedSubterm term)
-    raise (tell @(trace (ConfigurationFor term value)) (Reducer.unit config))
+    raise (tell @(trace (Configuration location term value)) (Reducer.unit config))
     liftAnalyze analyzeTerm recur term
 
   analyzeModule = liftAnalyze analyzeModule

src/Control/Abstract/Addressable.hs

@@ -1,39 +1,39 @@
-{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, UndecidableInstances #-}
+{-# LANGUAGE TypeFamilies, UndecidableInstances #-}
 module Control.Abstract.Addressable where
 
 import Control.Abstract.Evaluator
 import Control.Applicative
-import Control.Monad ((<=<))
+import Control.Effect.Fresh
 import Data.Abstract.Address
 import Data.Abstract.Environment (insert)
 import Data.Abstract.FreeVariables
-import Data.Abstract.Heap
 import Data.Semigroup.Reducer
 import Prelude hiding (fail)
 import Prologue
 
 -- | Defines 'alloc'ation and 'deref'erencing of 'Address'es in a Heap.
-class (Monad m, Ord l, l ~ LocationFor value, Reducer value (Cell l value)) => MonadAddressable l value m where
+class (MonadFresh m, Ord location) => MonadAddressable location m where
-  deref :: Address l value -> m value
+  derefCell :: Address location value -> Cell location value -> m value
 
-  alloc :: Name -> m (Address l value)
+  allocLoc :: Name -> m location
 
 -- | Look up or allocate an address for a 'Name'.
-lookupOrAlloc :: ( MonadAddressable (LocationFor value) value m
+lookupOrAlloc :: ( MonadAddressable location m
-                 , MonadEnvironment value m
+                 , MonadEnvironment location value m
                  )
-                 => Name
+              => Name
-                 -> m (Address (LocationFor value) value)
+              -> m (Address location value)
 lookupOrAlloc name = lookupEnv name >>= maybe (alloc name) pure
 
 
-letrec :: ( MonadAddressable (LocationFor value) value m
+letrec :: ( MonadAddressable location m
-          , MonadEnvironment value m
+          , MonadEnvironment location value m
-          , MonadHeap value m
+          , MonadHeap location value m
+          , Reducer value (Cell location value)
           )
        => Name
        -> m value
-       -> m (value, Address (LocationFor value) value)
+       -> m (value, Address location value)
 letrec name body = do
   addr <- lookupOrAlloc name
   v <- localEnv (insert name addr) body
@@ -41,11 +41,11 @@ letrec name body = do
   pure (v, addr)
 
 -- Lookup/alloc a name passing the address to a body evaluated in a new local environment.
-letrec' :: ( MonadAddressable (LocationFor value) value m
+letrec' :: ( MonadAddressable location m
-           , MonadEnvironment value m
+           , MonadEnvironment location value m
            )
         => Name
-        -> (Address (LocationFor value) value -> m value)
+        -> (Address location value -> m value)
         -> m value
 letrec' name body = do
   addr <- lookupOrAlloc name
@@ -55,22 +55,22 @@ letrec' name body = do
 -- Instances
 
 -- | 'Precise' locations are always 'alloc'ated a fresh 'Address', and 'deref'erence to the 'Latest' value written.
-instance (MonadFail m, LocationFor value ~ Precise, MonadHeap value m) => MonadAddressable Precise value m where
+instance (MonadFail m, MonadFresh m) => MonadAddressable Precise m where
-  deref = derefWith (maybeM uninitializedAddress . unLatest)
+  derefCell addr = maybeM (uninitializedAddress addr) . unLatest
-  alloc _ = do
+  allocLoc _ = Precise <$> fresh
-    -- Compute the next available address in the heap, then write an empty value into it.
-    addr <- fmap (Address . Precise . heapSize) getHeap
-    addr <$ modifyHeap (heapInit addr mempty)
 
 -- | 'Monovariant' locations 'alloc'ate one 'Address' per unique variable name, and 'deref'erence once per stored value, nondeterministically.
-instance (Alternative m, LocationFor value ~ Monovariant, MonadFail m, MonadHeap value m, Ord value) => MonadAddressable Monovariant value m where
+instance (Alternative m, MonadFresh m) => MonadAddressable Monovariant m where
-  deref = derefWith (foldMapA pure)
+  derefCell _ = foldMapA pure
-  alloc = pure . Address . Monovariant
+  allocLoc = pure . Monovariant
 
--- | Dereference the given 'Address' in the heap, using the supplied function to act on the cell, or failing if the address is uninitialized.
+-- | Dereference the given 'Address'in the heap, or fail if the address is uninitialized.
-derefWith :: (MonadFail m, MonadHeap value m, Ord (LocationFor value)) => (CellFor value -> m a) -> Address (LocationFor value) value -> m a
+deref :: (MonadFail m, MonadAddressable location m, MonadHeap location value m, Show location) => Address location value -> m value
-derefWith with = maybe uninitializedAddress with <=< lookupHeap
+deref addr = lookupHeap addr >>= maybe (uninitializedAddress addr) (derefCell addr)
+
+alloc :: MonadAddressable location m => Name -> m (Address location value)
+alloc = fmap Address . allocLoc
 
 -- | Fail with a message denoting an uninitialized address (i.e. one which was 'alloc'ated, but never 'assign'ed a value before being 'deref'erenced).
-uninitializedAddress :: MonadFail m => m a
+uninitializedAddress :: (MonadFail m, Show location) => Address location value -> m a
-uninitializedAddress = fail "uninitialized address"
+uninitializedAddress addr = fail $ "uninitialized address: " <> show addr

src/Control/Abstract/Analysis.hs

@@ -28,9 +28,9 @@ import Prologue
 -- | A 'Monad' in which one can evaluate some specific term type to some specific value type.
 --
 --   This typeclass is left intentionally unconstrained to avoid circular dependencies between it and other typeclasses.
-class MonadEvaluator term value m => MonadAnalysis term value m where
+class MonadEvaluator location term value m => MonadAnalysis location term value m where
   -- | The effects necessary to run the analysis. Analyses which are composed on top of (wrap) other analyses should include the inner analyses 'Effects' in their own list.
-  type family Effects term value m :: [* -> *]
+  type family Effects location term value m :: [* -> *]
 
   -- | Analyze a term using the semantics of the current analysis.
   analyzeTerm :: (Base term (Subterm term (outer value)) -> m value)
@@ -56,8 +56,8 @@ liftAnalyze analyze recur term = coerce (analyze (coerceWith (sym Coercion) . r
 --
 --   This enables us to refer to the analysis type as e.g. @Analysis1 (Analysis2 Evaluating) Term Value@ without explicitly mentioning its effects (which are inferred to be simply its 'Effects').
 runAnalysis :: ( Effectful m
-               , Effects term value (m effects) ~ effects
+               , Effects location term value (m effects) ~ effects
-               , MonadAnalysis term value (m effects)
+               , MonadAnalysis location term value (m effects)
                , RunEffects effects a
                )
             => m effects a

src/Control/Abstract/Evaluator.hs

@@ -15,25 +15,16 @@ module Control.Abstract.Evaluator
   , modifyModuleTable
   , MonadControl(..)
   , MonadThrow(..)
-  -- Type synonyms specialized for location types
-  , CellFor
-  , ConfigurationFor
-  , EnvironmentFor
-  , ExportsFor
-  , HeapFor
-  , LiveFor
-  , LocationFor
   ) where
 
 import Control.Effect
 import Control.Monad.Effect.Resumable
 import Data.Abstract.Address
 import Data.Abstract.Configuration
-import qualified Data.Abstract.Environment as Env
+import Data.Abstract.Environment as Env
-import qualified Data.Abstract.Exports as Export
+import Data.Abstract.Exports as Export
 import Data.Abstract.FreeVariables
 import Data.Abstract.Heap
-import Data.Abstract.Live
 import Data.Abstract.Module
 import Data.Abstract.ModuleTable
 import Data.Semigroup.Reducer
@@ -46,14 +37,14 @@ import Prologue hiding (throwError)
 --   - a heap mapping addresses to (possibly sets of) values
 --   - tables of modules available for import
 class ( MonadControl term m
-      , MonadEnvironment value m
+      , MonadEnvironment location value m
       , MonadFail m
-      , MonadModuleTable term value m
+      , MonadModuleTable location term value m
-      , MonadHeap value m
+      , MonadHeap location value m
       )
-      => MonadEvaluator term value m | m -> term, m -> value where
+      => MonadEvaluator location term value m | m -> location, m -> term, m -> value where
   -- | Get the current 'Configuration' with a passed-in term.
-  getConfiguration :: Ord (LocationFor value) => term -> m (ConfigurationFor term value)
+  getConfiguration :: Ord location => term -> m (Configuration location term value)
 
   -- | Retrieve the stack of modules currently being evaluated.
   --
@@ -62,100 +53,100 @@ class ( MonadControl term m
 
 
 -- | A 'Monad' abstracting local and global environments.
-class Monad m => MonadEnvironment value m | m -> value where
+class Monad m => MonadEnvironment location value m | m -> value, m -> location where
   -- | Retrieve the environment.
-  getEnv :: m (EnvironmentFor value)
+  getEnv :: m (Environment location value)
   -- | Set the environment.
-  putEnv :: EnvironmentFor value -> m ()
+  putEnv :: Environment location value -> m ()
   -- | Sets the environment for the lifetime of the given action.
-  withEnv :: EnvironmentFor value -> m a -> m a
+  withEnv :: Environment location value -> m a -> m a
 
   -- | Retrieve the default environment.
-  defaultEnvironment :: m (EnvironmentFor value)
+  defaultEnvironment :: m (Environment location value)
 
   -- | Set the default environment for the lifetime of an action.
   --   Usually only invoked in a top-level evaluation function.
-  withDefaultEnvironment :: EnvironmentFor value -> m a -> m a
+  withDefaultEnvironment :: Environment location value -> m a -> m a
 
   -- | Get the global export state.
-  getExports :: m (ExportsFor value)
+  getExports :: m (Exports location value)
   -- | Set the global export state.
-  putExports :: ExportsFor value -> m ()
+  putExports :: Exports location value -> m ()
   -- | Sets the global export state for the lifetime of the given action.
-  withExports :: ExportsFor value -> m a -> m a
+  withExports :: Exports location value -> m a -> m a
 
   -- | Run an action with a locally-modified environment.
-  localEnv :: (EnvironmentFor value -> EnvironmentFor value) -> m a -> m a
+  localEnv :: (Environment location value -> Environment location value) -> m a -> m a
 
   -- | Look a 'Name' up in the current environment, trying the default environment if no value is found.
-  lookupEnv :: Name -> m (Maybe (Address (LocationFor value) value))
+  lookupEnv :: Name -> m (Maybe (Address location value))
   lookupEnv name = (<|>) <$> (Env.lookup name <$> getEnv) <*> (Env.lookup name <$> defaultEnvironment)
 
   -- | Look up a 'Name' in the environment, running an action with the resolved address (if any).
-  lookupWith :: (Address (LocationFor value) value -> m value) -> Name -> m (Maybe value)
+  lookupWith :: (Address location value -> m value) -> Name -> m (Maybe value)
   lookupWith with name = do
     addr <- lookupEnv name
     maybe (pure Nothing) (fmap Just . with) addr
 
 -- | Run a computation in a new local environment.
-localize :: MonadEnvironment value m => m a -> m a
+localize :: MonadEnvironment location value m => m a -> m a
 localize = localEnv id
 
 -- | Update the global environment.
-modifyEnv :: MonadEnvironment value m => (EnvironmentFor value -> EnvironmentFor value) -> m ()
+modifyEnv :: MonadEnvironment location value m => (Environment location value -> Environment location value) -> m ()
 modifyEnv f = do
   env <- getEnv
   putEnv $! f env
 
 -- | Update the global export state.
-modifyExports :: MonadEnvironment value m => (ExportsFor value -> ExportsFor value) -> m ()
+modifyExports :: MonadEnvironment location value m => (Exports location value -> Exports location value) -> m ()
 modifyExports f = do
   exports <- getExports
   putExports $! f exports
 
 -- | Add an export to the global export state.
-addExport :: MonadEnvironment value m => Name -> Name -> Maybe (Address (LocationFor value) value) -> m ()
+addExport :: MonadEnvironment location value m => Name -> Name -> Maybe (Address location value) -> m ()
 addExport name alias = modifyExports . Export.insert name alias
 
 -- | Obtain an environment that is the composition of the current and default environments.
 --   Useful for debugging.
-fullEnvironment :: MonadEnvironment value m => m (EnvironmentFor value)
+fullEnvironment :: MonadEnvironment location value m => m (Environment location value)
 fullEnvironment = mappend <$> getEnv <*> defaultEnvironment
 
 -- | A 'Monad' abstracting a heap of values.
-class Monad m => MonadHeap value m | m -> value where
+class Monad m => MonadHeap location value m | m -> value, m -> location where
   -- | Retrieve the heap.
-  getHeap :: m (HeapFor value)
+  getHeap :: m (Heap location value)
   -- | Set the heap.
-  putHeap :: HeapFor value -> m ()
+  putHeap :: Heap location value -> m ()
 
 -- | Update the heap.
-modifyHeap :: MonadHeap value m => (HeapFor value -> HeapFor value) -> m ()
+modifyHeap :: MonadHeap location value m => (Heap location value -> Heap location value) -> m ()
 modifyHeap f = do
   s <- getHeap
   putHeap $! f s
 
 -- | Look up the cell for the given 'Address' in the 'Heap'.
-lookupHeap :: (MonadHeap value m, Ord (LocationFor value)) => Address (LocationFor value) value -> m (Maybe (CellFor value))
+lookupHeap :: (MonadHeap location value m, Ord location) => Address location value -> m (Maybe (Cell location value))
 lookupHeap = flip fmap getHeap . heapLookup
 
 -- | Write a value to the given 'Address' in the 'Store'.
-assign :: ( Ord (LocationFor value)
+assign :: ( Ord location
-          , MonadHeap value m
+          , MonadHeap location value m
-          , Reducer value (CellFor value)
+          , Reducer value (Cell location value)
           )
-       => Address (LocationFor value) value
+       => Address location value
        -> value
        -> m ()
 assign address = modifyHeap . heapInsert address
 
 
 -- | A 'Monad' abstracting tables of modules available for import.
-class Monad m => MonadModuleTable term value m | m -> term, m -> value where
+class Monad m => MonadModuleTable location term value m | m -> location, m -> term, m -> value where
   -- | Retrieve the table of evaluated modules.
-  getModuleTable :: m (ModuleTable (EnvironmentFor value, value))
+  getModuleTable :: m (ModuleTable (Environment location value, value))
   -- | Set the table of evaluated modules.
-  putModuleTable :: ModuleTable (EnvironmentFor value, value) -> m ()
+  putModuleTable :: ModuleTable (Environment location value, value) -> m ()
 
   -- | Retrieve the table of unevaluated modules.
   askModuleTable :: m (ModuleTable [Module term])
@@ -163,7 +154,7 @@ class Monad m => MonadModuleTable term value m | m -> term, m -> value where
   localModuleTable :: (ModuleTable [Module term] -> ModuleTable [Module term]) -> m a -> m a
 
 -- | Update the evaluated module table.
-modifyModuleTable :: MonadModuleTable term value m => (ModuleTable (EnvironmentFor value, value) -> ModuleTable (EnvironmentFor value, value)) -> m ()
+modifyModuleTable :: MonadModuleTable location term value m => (ModuleTable (Environment location value, value) -> ModuleTable (Environment location value, value)) -> m ()
 modifyModuleTable f = do
   table <- getModuleTable
   putModuleTable $! f table
@@ -185,25 +176,3 @@ class Monad m => MonadThrow exc m where
 
 instance (Effectful m, Members '[Resumable exc] effects, Monad (m effects)) => MonadThrow exc (m effects) where
   throwException = raise . throwError
-
-
--- | The cell for an abstract value type.
-type CellFor value = Cell (LocationFor value) value
-
--- | The configuration for term and abstract value types.
-type ConfigurationFor term value = Configuration (LocationFor value) term value
-
--- | The environment for an abstract value type.
-type EnvironmentFor value = Env.Environment (LocationFor value) value
-
--- | The exports for an abstract value type.
-type ExportsFor value = Export.Exports (LocationFor value) value
-
--- | The 'Heap' for an abstract value type.
-type HeapFor value = Heap (LocationFor value) value
-
--- | The address set type for an abstract value type.
-type LiveFor value = Live (LocationFor value) value
-
--- | The location type (the body of 'Address'es) which should be used for an abstract value type.
-type family LocationFor value :: *

src/Control/Abstract/Value.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE GADTs, MultiParamTypeClasses, Rank2Types, TypeFamilies, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE FunctionalDependencies, GADTs, Rank2Types, TypeFamilies, TypeOperators, UndecidableInstances #-}
 module Control.Abstract.Value
 ( MonadValue(..)
 , Comparator(..)
@@ -9,20 +9,14 @@ module Control.Abstract.Value
 , makeNamespace
 , ValueRoots(..)
 , ValueExc(..)
-, EnvironmentFor
-, ExportsFor
-, HeapFor
-, CellFor
-, LiveFor
-, LocationFor
-, ConfigurationFor
 ) where
 
 import Control.Abstract.Evaluator
 import Data.Abstract.FreeVariables
 import Data.Abstract.Environment as Env
-import Data.Abstract.Address (Address)
+import Data.Abstract.Address (Address, Cell)
 import Data.Abstract.Number as Number
+import Data.Abstract.Live (Live)
 import Data.Scientific (Scientific)
 import Data.Semigroup.Reducer hiding (unit)
 import Prelude
@@ -41,7 +35,7 @@ data Comparator
 -- | A 'Monad' abstracting the evaluation of (and under) binding constructs (functions, methods, etc).
 --
 --   This allows us to abstract the choice of whether to evaluate under binders for different value types.
-class (Monad m, Show value) => MonadValue value m where
+class (Monad m, Show value) => MonadValue location value m | m value -> location where
   -- | Construct an abstract unit value.
   --   TODO: This might be the same as the empty tuple for some value types
   unit :: m value
@@ -114,20 +108,20 @@ class (Monad m, Show value) => MonadValue value m where
   null :: m value
 
   -- | Build a class value from a name and environment.
-  klass :: Name                 -- ^ The new class's identifier
+  klass :: Name                       -- ^ The new class's identifier
-        -> [value]              -- ^ A list of superclasses
+        -> [value]                    -- ^ A list of superclasses
-        -> EnvironmentFor value -- ^ The environment to capture
+        -> Environment location value -- ^ The environment to capture
         -> m value
 
   -- | Build a namespace value from a name and environment stack
   --
   -- Namespaces model closures with monoidal environments.
-  namespace :: Name                 -- ^ The namespace's identifier
+  namespace :: Name                       -- ^ The namespace's identifier
-            -> EnvironmentFor value -- ^ The environment to mappend
+            -> Environment location value -- ^ The environment to mappend
             -> m value
 
   -- | Extract the environment from any scoped object (e.g. classes, namespaces, etc).
-  scopedEnvironment :: value -> m (EnvironmentFor value)
+  scopedEnvironment :: value -> m (Environment location value)
 
   -- | Evaluate an abstraction (a binder like a lambda or method definition).
   abstract :: (FreeVariables term, MonadControl term m) => [Name] -> Subterm term (m value) -> m value
@@ -141,10 +135,10 @@ class (Monad m, Show value) => MonadValue value m where
 
 
 -- | Attempt to extract a 'Prelude.Bool' from a given value.
-toBool :: MonadValue value m => value -> m Bool
+toBool :: MonadValue location value m => value -> m Bool
 toBool v = ifthenelse v (pure True) (pure False)
 
-forLoop :: (MonadEnvironment value m, MonadValue value m)
+forLoop :: (MonadEnvironment location value m, MonadValue location value m)
         => m value -- ^ Initial statement
         -> m value -- ^ Condition
         -> m value -- ^ Increment/stepper
@@ -154,7 +148,7 @@ forLoop initial cond step body =
   localize (initial *> while cond (body *> step))
 
 -- | The fundamental looping primitive, built on top of ifthenelse.
-while :: MonadValue value m
+while :: MonadValue location value m
       => m value
       -> m value
       -> m value
@@ -163,7 +157,7 @@ while cond body = loop $ \ continue -> do
   ifthenelse this (body *> continue) unit
 
 -- | Do-while loop, built on top of while.
-doWhile :: MonadValue value m
+doWhile :: MonadValue location value m
         => m value
         -> m value
         -> m value
@@ -171,14 +165,14 @@ doWhile body cond = loop $ \ continue -> body *> do
   this <- cond
   ifthenelse this continue unit
 
-makeNamespace :: ( MonadValue value m
+makeNamespace :: ( MonadValue location value m
-                 , MonadEnvironment value m
+                 , MonadEnvironment location value m
-                 , MonadHeap value m
+                 , MonadHeap location value m
-                 , Reducer value (CellFor value)
+                 , Ord location
-                 , Ord (LocationFor value)
+                 , Reducer value (Cell location value)
                  )
               => Name
-              -> Address (LocationFor value) value
+              -> Address location value
               -> [value]
               -> m value
 makeNamespace name addr supers = do
@@ -189,25 +183,25 @@ makeNamespace name addr supers = do
 
 
 -- | Value types, e.g. closures, which can root a set of addresses.
-class ValueRoots value where
+class ValueRoots location value where
   -- | Compute the set of addresses rooted by a given value.
-  valueRoots :: value -> LiveFor value
+  valueRoots :: value -> Live location value
 
 
 -- The type of exceptions that can be thrown when constructing values in `MonadValue`.
-data ValueExc value resume where
+data ValueExc location value resume where
-  TypeError              :: Prelude.String -> ValueExc value value
+  TypeError              :: Prelude.String -> ValueExc location value value
-  StringError            :: Prelude.String -> ValueExc value ByteString
+  StringError            :: Prelude.String -> ValueExc location value ByteString
-  NamespaceError         :: Prelude.String -> ValueExc value (EnvironmentFor value)
+  NamespaceError         :: Prelude.String -> ValueExc location value (Environment location value)
-  ScopedEnvironmentError :: Prelude.String -> ValueExc value (EnvironmentFor value)
+  ScopedEnvironmentError :: Prelude.String -> ValueExc location value (Environment location value)
 
-instance Eq1 (ValueExc value) where
+instance Eq1 (ValueExc location value) where
   liftEq _ (TypeError a)  (TypeError b)                          = a == b
   liftEq _ (StringError a) (StringError b)                       = a == b
   liftEq _ (NamespaceError a) (NamespaceError b)                 = a == b
   liftEq _ (ScopedEnvironmentError a) (ScopedEnvironmentError b) = a == b
   liftEq _ _             _                                       = False
 
-deriving instance Show (ValueExc value resume)
+deriving instance Show (ValueExc location value resume)
-instance Show1 (ValueExc value) where
+instance Show1 (ValueExc location value) where
   liftShowsPrec _ _ = showsPrec

src/Control/Effect/Fresh.hs

@@ -4,22 +4,20 @@ module Control.Effect.Fresh where
 import Control.Effect
 import Control.Monad.Effect.Internal
 
-type TName = Int
-
 -- | An effect offering a (resettable) sequence of always-incrementing, and therefore “fresh,” type variables.
 data Fresh a where
   -- | Request a reset of the sequence of variable names.
-  Reset :: TName -> Fresh ()
+  Reset :: Int -> Fresh ()
   -- | Request a fresh variable name.
-  Fresh :: Fresh TName
+  Fresh :: Fresh Int
 
 -- | 'Monad's offering a (resettable) sequence of guaranteed-fresh type variables.
 class Monad m => MonadFresh m where
   -- | Get a fresh variable name, guaranteed unused (since the last 'reset').
-  fresh :: m TName
+  fresh :: m Int
 
   -- | Reset the sequence of variable names. Useful to avoid complicated alpha-equivalence comparisons when iteratively recomputing the results of an analysis til convergence.
-  reset :: TName -> m ()
+  reset :: Int -> m ()
 
 instance (Fresh :< fs) => MonadFresh (Eff fs) where
   fresh = send Fresh
@@ -28,6 +26,6 @@ instance (Fresh :< fs) => MonadFresh (Eff fs) where
 
 -- | 'Fresh' effects are interpreted starting from 0, incrementing the current name with each request for a fresh name, and overwriting the counter on reset.
 instance RunEffect Fresh a where
-  runEffect = relayState (0 :: TName) (const pure) (\ s action k -> case action of
+  runEffect = relayState (0 :: Int) (const pure) (\ s action k -> case action of
     Fresh -> k (succ s) s
     Reset s' -> k s' ())

src/Data/Abstract/Address.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE MultiParamTypeClasses, TypeFamilyDependencies #-}
+{-# LANGUAGE TypeFamilies #-}
 module Data.Abstract.Address where
 
 import Data.Abstract.FreeVariables
@@ -14,19 +14,25 @@ instance Ord l => Ord1 (Address l) where liftCompare = genericLiftCompare
 instance Show l => Show1 (Address l) where liftShowsPrec = genericLiftShowsPrec
 
 
+class Ord loc => Location loc where
+  -- | The type into which stored values will be written for a given location type.
+  type family Cell loc :: * -> *
+
+
 -- | 'Precise' models precise store semantics where only the 'Latest' value is taken. Everything gets it's own address (always makes a new allocation) which makes for a larger store.
 newtype Precise = Precise { unPrecise :: Int }
   deriving (Eq, Ord, Show)
 
+instance Location Precise where
+  type Cell Precise = Latest
+
+
 -- | 'Monovariant' models using one address for a particular name. It trackes the set of values that a particular address takes and uses it's name to lookup in the store and only allocation if new.
 newtype Monovariant = Monovariant { unMonovariant :: Name }
   deriving (Eq, Ord, Show)
 
-
+instance Location Monovariant where
--- | The type into which stored values will be written for a given location type.
+  type Cell Monovariant = Set
-type family Cell l = res | res -> l where
-  Cell Precise = Latest
-  Cell Monovariant = Set
 
 
 -- | A cell holding a single value. Writes will replace any prior value.

src/Data/Abstract/Evaluatable.hs

@@ -17,29 +17,32 @@ module Data.Abstract.Evaluatable
 
 import           Control.Abstract.Addressable as X
 import           Control.Abstract.Analysis as X
-import qualified Data.Abstract.Environment as Env
+import           Data.Abstract.Address
+import           Data.Abstract.Environment as X
 import qualified Data.Abstract.Exports as Exports
 import           Data.Abstract.FreeVariables as X
 import           Data.Abstract.Module
 import           Data.Abstract.ModuleTable as ModuleTable
 import           Data.Semigroup.App
 import           Data.Semigroup.Foldable
+import           Data.Semigroup.Reducer hiding (unit)
 import           Data.Term
 import           Prelude hiding (fail)
 import           Prologue
 
-type MonadEvaluatable term value m =
+type MonadEvaluatable location term value m =
   ( Evaluatable (Base term)
   , FreeVariables term
-  , MonadAddressable (LocationFor value) value m
+  , MonadAddressable location m
-  , MonadAnalysis term value m
+  , MonadAnalysis location term value m
   , MonadThrow (Unspecialized value) m
-  , MonadThrow (ValueExc value) m
+  , MonadThrow (ValueExc location value) m
   , MonadThrow (LoadError term value) m
   , MonadThrow (EvalError value) m
-  , MonadValue value m
+  , MonadValue location value m
   , Recursive term
-  , Show (LocationFor value)
+  , Reducer value (Cell location value)
+  , Show location
   )
 
 
@@ -66,7 +69,7 @@ instance Show1 (EvalError value) where
 instance Eq1 (EvalError term) where
   liftEq _ (FreeVariableError a) (FreeVariableError b) = a == b
 
-throwLoadError :: MonadEvaluatable term value m => LoadError term value resume -> m resume
+throwLoadError :: MonadEvaluatable location term value m => LoadError term value resume -> m resume
 throwLoadError = throwException
 
 data Unspecialized a b where
@@ -82,7 +85,7 @@ instance Show1 (Unspecialized a) where
 
 -- | The 'Evaluatable' class defines the necessary interface for a term to be evaluated. While a default definition of 'eval' is given, instances with computational content must implement 'eval' to perform their small-step operational semantics.
 class Evaluatable constr where
-  eval :: MonadEvaluatable term value m
+  eval :: MonadEvaluatable location term value m
        => SubtermAlgebra constr term (m value)
   default eval :: (MonadThrow (Unspecialized value) m, Show1 constr) => SubtermAlgebra constr term (m value)
   eval expr = throwException (Unspecialized ("Eval unspecialized for " ++ liftShowsPrec (const (const id)) (const id) 0 expr ""))
@@ -110,17 +113,17 @@ instance Evaluatable [] where
 -- | Require/import another module by name and return it's environment and value.
 --
 -- Looks up the term's name in the cache of evaluated modules first, returns if found, otherwise loads/evaluates the module.
-require :: MonadEvaluatable term value m
+require :: MonadEvaluatable location term value m
         => ModuleName
-        -> m (EnvironmentFor value, value)
+        -> m (Environment location value, value)
 require name = getModuleTable >>= maybe (load name) pure . moduleTableLookup name
 
 -- | Load another module by name and return it's environment and value.
 --
 -- Always loads/evaluates.
-load :: MonadEvaluatable term value m
+load :: MonadEvaluatable location term value m
      => ModuleName
-     -> m (EnvironmentFor value, value)
+     -> m (Environment location value, value)
 load name = askModuleTable >>= maybe notFound pure . moduleTableLookup name >>= evalAndCache
   where
     notFound = throwLoadError (LoadError name)
@@ -141,36 +144,36 @@ load name = askModuleTable >>= maybe notFound pure . moduleTableLookup name >>=
     -- TODO: If the set of exports is empty because no exports have been
     -- defined, do we export all terms, or no terms? This behavior varies across
     -- languages. We need better semantics rather than doing it ad-hoc.
-    filterEnv :: Exports.Exports l a -> Env.Environment l a -> Env.Environment l a
+    filterEnv :: Exports.Exports l a -> Environment l a -> Environment l a
     filterEnv ports env
       | Exports.null ports = env
-      | otherwise = Exports.toEnvironment ports <> Env.overwrite (Exports.aliases ports) env
+      | otherwise = Exports.toEnvironment ports <> overwrite (Exports.aliases ports) env
 
 
 -- | Evaluate a term to a value using the semantics of the current analysis.
 --
 --   This should always be called when e.g. evaluating the bodies of closures instead of explicitly folding either 'eval' or 'analyzeTerm' over subterms, except in 'MonadAnalysis' instances themselves. On the other hand, top-level evaluation should be performed using 'evaluateModule'.
-evaluateTerm :: MonadEvaluatable term value m
+evaluateTerm :: MonadEvaluatable location term value m
              => term
              -> m value
 evaluateTerm = foldSubterms (analyzeTerm eval)
 
 -- | Evaluate a (root-level) term to a value using the semantics of the current analysis. This should be used to evaluate single-term programs, or (via 'evaluateModules') the entry point of multi-term programs.
-evaluateModule :: MonadEvaluatable term value m
+evaluateModule :: MonadEvaluatable location term value m
                => Module term
                -> m value
 evaluateModule m = analyzeModule (subtermValue . moduleBody) (fmap (Subterm <*> evaluateTerm) m)
 
 
 -- | Run an action with the a list of 'Module's available for imports.
-withModules :: MonadEvaluatable term value m
+withModules :: MonadEvaluatable location term value m
             => [Module term]
             -> m a
             -> m a
 withModules = localModuleTable . const . ModuleTable.fromList
 
 -- | Evaluate with a list of modules in scope, taking the head module as the entry point.
-evaluateModules :: MonadEvaluatable term value m
+evaluateModules :: MonadEvaluatable location term value m
                 => [Module term]
                 -> m value
 evaluateModules []     = fail "evaluateModules: empty list"

src/Data/Abstract/Located.hs

@@ -0,0 +1,17 @@
+{-# LANGUAGE TypeFamilies #-}
+module Data.Abstract.Located where
+
+import Control.Abstract.Addressable
+import Data.Abstract.Address
+import Data.Abstract.Origin
+
+data Located location = Located { location :: location, origin :: !Origin }
+  deriving (Eq, Ord, Show)
+
+instance Location location => Location (Located location) where
+  type Cell (Located location) = Cell location
+
+instance (MonadAddressable location m, MonadOrigin m) => MonadAddressable (Located location) m where
+  derefCell (Address (Located loc _)) = derefCell (Address loc)
+
+  allocLoc name = Located <$> allocLoc name <*> askOrigin

src/Data/Abstract/Origin.hs

@@ -0,0 +1,45 @@
+{-# LANGUAGE UndecidableInstances #-}
+module Data.Abstract.Origin where
+
+import Control.Effect
+import Control.Monad.Effect.Reader
+import Data.Abstract.Module
+import Data.Range
+import Data.Record
+import Data.Span
+import Data.Term
+import Prologue
+
+-- TODO: Upstream dependencies
+data Origin
+  = Unknown
+  | Local !ModuleName !FilePath !Range !Span
+  deriving (Eq, Ord, Show)
+
+
+class HasOrigin f where
+  originFor :: [Module a] -> f b -> Origin
+
+instance (HasField fields Range, HasField fields Span) => HasOrigin (TermF syntax (Record fields)) where
+  originFor []    _          = Unknown
+  originFor (m:_) (In ann _) = Local (moduleName m) (modulePath m) (getField ann) (getField ann)
+
+
+class Monad m => MonadOrigin m where
+  askOrigin :: m Origin
+
+instance ( Effectful m
+         , Member (Reader Origin) effects
+         , Monad (m effects)
+         )
+      => MonadOrigin (m effects) where
+  askOrigin = raise ask
+
+
+instance Semigroup Origin where
+  a       <> Unknown = a
+  _       <> b       = b
+
+instance Monoid Origin where
+  mempty = Unknown
+  mappend = (<>)

src/Data/Abstract/Type.hs

@@ -5,9 +5,12 @@ import Control.Abstract.Analysis
 import Data.Abstract.Address
 import Data.Abstract.Environment as Env
 import Data.Align (alignWith)
+import Data.Semigroup.Reducer (Reducer)
 import Prelude hiding (fail)
 import Prologue
 
+type TName = Int
+
 -- | A datatype representing primitive types and combinations thereof.
 data Type
   = Int                 -- ^ Primitive int type.
@@ -43,14 +46,20 @@ unify t1 t2
   | otherwise = fail ("cannot unify " ++ show t1 ++ " with " ++ show t2)
 
 
-type instance LocationFor Type = Monovariant
+instance Ord location => ValueRoots location Type where
-
-instance ValueRoots Type where
   valueRoots _ = mempty
 
 
 -- | Discard the value arguments (if any), constructing a 'Type' instead.
-instance (Alternative m, MonadEnvironment Type m, MonadFail m, MonadFresh m, MonadHeap Type m) => MonadValue Type m where
+instance ( Alternative m
+         , MonadAddressable location m
+         , MonadEnvironment location Type m
+         , MonadFail m
+         , MonadFresh m
+         , MonadHeap location Type m
+         , Reducer Type (Cell location Type)
+         )
+      => MonadValue location Type m where
   abstract names (Subterm _ body) = do
     (env, tvars) <- foldr (\ name rest -> do
       a <- alloc name

src/Data/Abstract/Value.hs

@@ -2,7 +2,6 @@
 module Data.Abstract.Value where
 
 import Control.Abstract.Analysis
-import Data.Abstract.Address
 import Data.Abstract.Environment (Environment)
 import qualified Data.Abstract.Environment as Env
 import Data.Abstract.Evaluatable
@@ -13,16 +12,16 @@ import Prologue hiding (TypeError)
 import Prelude hiding (Float, Integer, String, Rational, fail)
 import qualified Prelude
 
-type ValueConstructors
+type ValueConstructors location
   = '[Array
     , Boolean
-    , Class
+    , Class location
-    , Closure
+    , Closure location
     , Float
     , Hash
     , Integer
     , KVPair
-    , Namespace
+    , Namespace location
     , Null
     , Rational
     , String
@@ -33,32 +32,32 @@ type ValueConstructors
 
 -- | Open union of primitive values that terms can be evaluated to.
 --   Fix by another name.
-newtype Value = Value { deValue :: Union ValueConstructors Value }
+newtype Value location = Value { deValue :: Union (ValueConstructors location) (Value location) }
   deriving (Eq, Show, Ord)
 
 -- | Identical to 'inj', but wraps the resulting sub-entity in a 'Value'.
-injValue :: (f :< ValueConstructors) => f Value -> Value
+injValue :: (f :< ValueConstructors location) => f (Value location) -> Value location
 injValue = Value . inj
 
 -- | Identical to 'prj', but unwraps the argument out of its 'Value' wrapper.
-prjValue :: (f :< ValueConstructors) => Value -> Maybe (f Value)
+prjValue :: (f :< ValueConstructors location) => Value location -> Maybe (f (Value location))
 prjValue = prj . deValue
 
 -- | Convenience function for projecting two values.
-prjPair :: (f :< ValueConstructors , g :< ValueConstructors)
+prjPair :: (f :< ValueConstructors location , g :< ValueConstructors location)
-        => (Value, Value)
+        => (Value location, Value location)
-        -> Maybe (f Value, g Value)
+        -> Maybe (f (Value location), g (Value location))
 prjPair = bitraverse prjValue prjValue
 
 -- TODO: Parameterize Value by the set of constructors s.t. each language can have a distinct value union.
 
 -- | A function value consisting of a list of parameter 'Name's, a 'Label' to jump to the body of the function, and an 'Environment' of bindings captured by the body.
-data Closure value = Closure [Name] Label (Environment Precise value)
+data Closure location value = Closure [Name] Label (Environment location value)
   deriving (Eq, Generic1, Ord, Show)
 
-instance Eq1 Closure where liftEq = genericLiftEq
+instance Eq location => Eq1 (Closure location) where liftEq = genericLiftEq
-instance Ord1 Closure where liftCompare = genericLiftCompare
+instance Ord location => Ord1 (Closure location) where liftCompare = genericLiftCompare
-instance Show1 Closure where liftShowsPrec = genericLiftShowsPrec
+instance Show location => Show1 (Closure location) where liftShowsPrec = genericLiftShowsPrec
 
 -- | The unit value. Typically used to represent the result of imperative statements.
 data Unit value = Unit
@@ -138,23 +137,23 @@ instance Show1 Array where liftShowsPrec = genericLiftShowsPrec
 
 -- | Class values. There will someday be a difference between classes and objects,
 --   but for the time being we're pretending all languages have prototypical inheritance.
-data Class value = Class
+data Class location value = Class
   { _className  :: Name
-  , _classScope :: Environment Precise value
+  , _classScope :: Environment location value
   } deriving (Eq, Generic1, Ord, Show)
 
-instance Eq1 Class where liftEq = genericLiftEq
+instance Eq location => Eq1 (Class location) where liftEq = genericLiftEq
-instance Ord1 Class where liftCompare = genericLiftCompare
+instance Ord location => Ord1 (Class location) where liftCompare = genericLiftCompare
-instance Show1 Class where liftShowsPrec = genericLiftShowsPrec
+instance Show location => Show1 (Class location) where liftShowsPrec = genericLiftShowsPrec
 
-data Namespace value = Namespace
+data Namespace location value = Namespace
   { namespaceName  :: Name
-  , namespaceScope :: Environment Precise value
+  , namespaceScope :: Environment location value
   } deriving (Eq, Generic1, Ord, Show)
 
-instance Eq1 Namespace where liftEq = genericLiftEq
+instance Eq location => Eq1 (Namespace location) where liftEq = genericLiftEq
-instance Ord1 Namespace where liftCompare = genericLiftCompare
+instance Ord location => Ord1 (Namespace location) where liftCompare = genericLiftCompare
-instance Show1 Namespace where liftShowsPrec = genericLiftShowsPrec
+instance Show location => Show1 (Namespace location) where liftShowsPrec = genericLiftShowsPrec
 
 data KVPair value = KVPair value value
   deriving (Eq, Generic1, Ord, Show)
@@ -184,15 +183,14 @@ instance Ord1 Null where liftCompare = genericLiftCompare
 instance Show1 Null where liftShowsPrec = genericLiftShowsPrec
 
 
-type instance LocationFor Value = Precise
+instance Ord location => ValueRoots location (Value location) where
-
-instance ValueRoots Value where
   valueRoots v
     | Just (Closure _ _ env) <- prjValue v = Env.addresses env
     | otherwise                            = mempty
 
+
 -- | Construct a 'Value' wrapping the value arguments (if any).
-instance (Monad m, MonadEvaluatable term Value m) => MonadValue Value m where
+instance (Monad m, MonadEvaluatable location term (Value location) m) => MonadValue location (Value location) m where
   unit     = pure . injValue $ Unit
   integer  = pure . injValue . Integer . Number.Integer
   boolean  = pure . injValue . Boolean
@@ -259,7 +257,7 @@ instance (Monad m, MonadEvaluatable term Value m) => MonadValue Value m where
     | otherwise = fail ("Invalid operands to liftNumeric2: " <> show pair)
       where
         -- Dispatch whatever's contained inside a 'Number.SomeNumber' to its appropriate 'MonadValue' ctor
-        specialize :: MonadValue value m => Number.SomeNumber -> m value
+        specialize :: MonadValue location value m => Number.SomeNumber -> m value
         specialize (Number.SomeNumber (Number.Integer i)) = integer i
         specialize (Number.SomeNumber (Number.Ratio r))          = rational r
         specialize (Number.SomeNumber (Number.Decimal d))        = float d
@@ -277,7 +275,7 @@ instance (Monad m, MonadEvaluatable term Value m) => MonadValue Value m where
       where
         -- Explicit type signature is necessary here because we're passing all sorts of things
         -- to these comparison functions.
-        go :: (Ord a, MonadValue value m) => a -> a -> m value
+        go :: (Ord a, MonadValue location value m) => a -> a -> m value
         go l r = case comparator of
           Concrete f  -> boolean (f l r)
           Generalized -> integer (orderingToInt (compare l r))

src/Language/PHP/Syntax.hs

@@ -33,14 +33,14 @@ instance Evaluatable VariableName
 -- file, the complete contents of the included file are treated as though it
 -- were defined inside that function.
 
-doInclude :: MonadEvaluatable term value m => Subterm t (m value) -> m value
+doInclude :: MonadEvaluatable location term value m => Subterm t (m value) -> m value
 doInclude path = do
   name <- toQualifiedName <$> (subtermValue path >>= asString)
   (importedEnv, v) <- isolate (load name)
   modifyEnv (mappend importedEnv)
   pure v
 
-doIncludeOnce :: MonadEvaluatable term value m => Subterm t (m value) -> m value
+doIncludeOnce :: MonadEvaluatable location term value m => Subterm t (m value) -> m value
 doIncludeOnce path = do
   name <- toQualifiedName <$> (subtermValue path >>= asString)
   (importedEnv, v) <- isolate (require name)

src/Language/Ruby/Syntax.hs

@@ -25,9 +25,9 @@ instance Evaluatable Require where
     where
       toName = qualifiedName . splitOnPathSeparator . dropRelativePrefix . stripQuotes
 
-doRequire :: MonadEvaluatable term value m
+doRequire :: MonadEvaluatable location term value m
           => ModuleName
-          -> m (EnvironmentFor value, value)
+          -> m (Environment location value, value)
 doRequire name = do
   moduleTable <- getModuleTable
   case moduleTableLookup name moduleTable of
@@ -52,7 +52,7 @@ instance Evaluatable Load where
     doLoad path shouldWrap
   eval (Load _) = fail "invalid argument supplied to load, path is required"
 
-doLoad :: MonadEvaluatable term value m => ByteString -> Bool -> m value
+doLoad :: MonadEvaluatable location term value m => ByteString -> Bool -> m value
 doLoad path shouldWrap = do
   (importedEnv, _) <- isolate (load (toName path))
   unless shouldWrap $ modifyEnv (mappend importedEnv)

src/Semantic/Util.hs

@@ -12,15 +12,17 @@ import Analysis.Abstract.Tracing
 import Analysis.Declaration
 import Control.Abstract.Analysis
 import Control.Monad.IO.Class
-import Data.Abstract.Evaluatable
+import Data.Abstract.Evaluatable hiding (head)
 import Data.Abstract.Address
 import Data.Abstract.Module
+import Data.Abstract.Origin
 import Data.Abstract.Type
 import Data.Abstract.Value
 import Data.Blob
 import Data.Diff
 import Data.Range
 import Data.Record
+import Data.Semigroup.Reducer
 import Data.Span
 import Data.Term
 import Diffing.Algorithm
@@ -42,27 +44,27 @@ import qualified Language.TypeScript.Assignment as TypeScript
 -- Ruby
 evaluateRubyFile = evaluateWithPrelude rubyParser
 evaluateRubyFiles = evaluateFilesWithPrelude rubyParser
-evaluateRubyImportGraph paths = runAnalysis @(ImportGraphing (Evaluating Ruby.Term Value)) . evaluateModules <$> parseFiles rubyParser paths
+evaluateRubyImportGraph paths = runAnalysis @(ImportGraphing (Evaluating Precise Ruby.Term (Value Precise))) . evaluateModules <$> parseFiles rubyParser paths
-evaluateRubyBadVariables paths = runAnalysis @(BadVariables (Evaluating Ruby.Term Value)) . evaluateModules <$> parseFiles rubyParser paths
+evaluateRubyBadVariables paths = runAnalysis @(BadVariables (Evaluating Precise Ruby.Term (Value Precise))) . evaluateModules <$> parseFiles rubyParser paths
 
 -- Go
 evaluateGoFile = evaluateFile goParser
 evaluateGoFiles = evaluateFiles goParser
-typecheckGoFile path = runAnalysis @(Caching (Evaluating Go.Term Type)) . evaluateModule <$> parseFile goParser Nothing path
+typecheckGoFile path = runAnalysis @(Caching (Evaluating Monovariant Go.Term Type)) . evaluateModule <$> parseFile goParser Nothing path
 
 -- Python
 evaluatePythonFile = evaluateWithPrelude pythonParser
 evaluatePythonFiles = evaluateFilesWithPrelude pythonParser
-typecheckPythonFile path = runAnalysis @(Caching (Evaluating Python.Term Type)) . evaluateModule <$> parseFile pythonParser Nothing path
+typecheckPythonFile path = runAnalysis @(Caching (Evaluating Monovariant Python.Term Type)) . evaluateModule <$> parseFile pythonParser Nothing path
-tracePythonFile path = runAnalysis @(Tracing [] (Evaluating Python.Term Value)) . evaluateModule <$> parseFile pythonParser Nothing path
+tracePythonFile path = runAnalysis @(Tracing [] (Evaluating Precise Python.Term (Value Precise))) . evaluateModule <$> parseFile pythonParser Nothing path
-evaluateDeadTracePythonFile path = runAnalysis @(DeadCode (Tracing [] (Evaluating Python.Term Value))) . evaluateModule <$> parseFile pythonParser Nothing path
+evaluateDeadTracePythonFile path = runAnalysis @(DeadCode (Tracing [] (Evaluating Precise Python.Term (Value Precise)))) . evaluateModule <$> parseFile pythonParser Nothing path
 
 -- PHP
 evaluatePHPFile = evaluateFile phpParser
 evaluatePHPFiles = evaluateFiles phpParser
 
 -- TypeScript
-typecheckTypeScriptFile path = runAnalysis @(Caching (Evaluating TypeScript.Term Type)) . evaluateModule <$> parseFile typescriptParser Nothing path
+typecheckTypeScriptFile path = runAnalysis @(Caching (Evaluating Monovariant TypeScript.Term Type)) . evaluateModule <$> parseFile typescriptParser Nothing path
 evaluateTypeScriptFile = evaluateFile typescriptParser
 evaluateTypeScriptFiles = evaluateFiles typescriptParser
 
@@ -70,29 +72,31 @@ evaluateTypeScriptFiles = evaluateFiles typescriptParser
 evaluateFile :: forall term effects
              .  ( Evaluatable (Base term)
                 , FreeVariables term
-                , effects ~ Effects term Value (Evaluating term Value effects)
+                , effects ~ Effects Precise term (Value Precise) (Evaluating Precise term (Value Precise) effects)
-                , MonadAddressable Precise Value (Evaluating term Value effects)
+                , HasOrigin (Base term)
-                , MonadValue Value (Evaluating term Value effects)
+                , MonadAddressable Precise (Evaluating Precise term (Value Precise) effects)
                 , Recursive term
                 )
              => Parser term
              -> FilePath
-             -> IO (Final effects Value)
+             -> IO (Final effects (Value Precise))
-evaluateFile parser path = runAnalysis @(Evaluating term Value) . evaluateModule <$> parseFile parser Nothing path
+evaluateFile parser path = runAnalysis @(Evaluating Precise term (Value Precise)) . evaluateModule <$> parseFile parser Nothing path
 
-evaluateWith :: forall value term effects
+evaluateWith :: forall location value term effects
-             .  ( effects ~ Effects term value (Evaluating term value effects)
+             .  ( effects ~ Effects location term value (Evaluating location term value effects)
                 , Evaluatable (Base term)
                 , FreeVariables term
-                , MonadAddressable (LocationFor value) value (Evaluating term value effects)
+                , HasOrigin (Base term)
-                , MonadValue value (Evaluating term value effects)
+                , MonadAddressable location (Evaluating location term value effects)
+                , MonadValue location value (Evaluating location term value effects)
                 , Recursive term
-                , Show (LocationFor value)
+                , Reducer value (Cell location value)
+                , Show location
                 )
          => Module term
          -> Module term
          -> Final effects value
-evaluateWith prelude m = runAnalysis @(Evaluating term value) $ do
+evaluateWith prelude m = runAnalysis @(Evaluating location term value) $ do
   -- TODO: we could add evaluatePrelude to MonadAnalysis as an alias for evaluateModule,
   -- overridden in Evaluating to not reset the environment. In the future we'll want the
   -- result of evaluating the Prelude to be a build artifact, rather than something that's
@@ -104,71 +108,73 @@ evaluateWith prelude m = runAnalysis @(Evaluating term value) $ do
 evaluateWithPrelude :: forall term effects
                     .  ( Evaluatable (Base term)
                        , FreeVariables term
-                       , effects ~ Effects term Value (Evaluating term Value effects)
+                       , effects ~ Effects Precise term (Value Precise) (Evaluating Precise term (Value Precise) effects)
-                       , MonadAddressable Precise Value (Evaluating term Value effects)
+                       , HasOrigin (Base term)
-                       , MonadValue Value (Evaluating term Value effects)
+                       , MonadAddressable Precise (Evaluating Precise term (Value Precise) effects)
                        , Recursive term
                        , TypeLevel.KnownSymbol (PreludePath term)
                        )
                     => Parser term
                     -> FilePath
-                    -> IO (Final effects Value)
+                    -> IO (Final effects (Value Precise))
 evaluateWithPrelude parser path = do
   let preludePath = TypeLevel.symbolVal (Proxy :: Proxy (PreludePath term))
   prelude <- parseFile parser Nothing preludePath
   m <- parseFile parser Nothing path
-  pure $ evaluateWith prelude m
+  pure $ evaluateWith @Precise prelude m
 
 
 -- Evaluate a list of files (head of file list is considered the entry point).
 evaluateFiles :: forall term effects
               .  ( Evaluatable (Base term)
                  , FreeVariables term
-                 , effects ~ Effects term Value (Evaluating term Value effects)
+                 , effects ~ Effects Precise term (Value Precise) (Evaluating Precise term (Value Precise) effects)
-                 , MonadAddressable Precise Value (Evaluating term Value effects)
+                 , HasOrigin (Base term)
-                 , MonadValue Value (Evaluating term Value effects)
+                 , MonadAddressable Precise (Evaluating Precise term (Value Precise) effects)
                  , Recursive term
                  )
               => Parser term
               -> [FilePath]
-              -> IO (Final effects Value)
+              -> IO (Final effects (Value Precise))
-evaluateFiles parser paths = runAnalysis @(Evaluating term Value) . evaluateModules <$> parseFiles parser paths
+evaluateFiles parser paths = runAnalysis @(Evaluating Precise term (Value Precise)) . evaluateModules <$> parseFiles parser paths
 
 -- | Evaluate terms and an entry point to a value with a given prelude.
-evaluatesWith :: forall value term effects
+evaluatesWith :: forall location value term effects
-              .  ( effects ~ Effects term value (Evaluating term value effects)
+              .  ( effects ~ Effects location term value (Evaluating location term value effects)
                  , Evaluatable (Base term)
                  , FreeVariables term
-                 , MonadAddressable (LocationFor value) value (Evaluating term value effects)
+                 , HasOrigin (Base term)
-                 , MonadValue value (Evaluating term value effects)
+                 , MonadAddressable location (Evaluating location term value effects)
+                 , MonadValue location value (Evaluating location term value effects)
                  , Recursive term
-                 , Show (LocationFor value)
+                 , Reducer value (Cell location value)
+                 , Show location
                  )
               => Module term   -- ^ Prelude to evaluate once
               -> [Module term] -- ^ List of (blob, term) pairs that make up the program to be evaluated
               -> Module term   -- ^ Entrypoint
               -> Final effects value
-evaluatesWith prelude modules m = runAnalysis @(Evaluating term value) $ do
+evaluatesWith prelude modules m = runAnalysis @(Evaluating location term value) $ do
   preludeEnv <- evaluateModule prelude *> getEnv
   withDefaultEnvironment preludeEnv (withModules modules (evaluateModule m))
 
 evaluateFilesWithPrelude :: forall term effects
                          .  ( Evaluatable (Base term)
                             , FreeVariables term
-                            , effects ~ Effects term Value (Evaluating term Value effects)
+                            , effects ~ Effects Precise term (Value Precise) (Evaluating Precise term (Value Precise) effects)
-                            , MonadAddressable Precise Value (Evaluating term Value effects)
+                            , HasOrigin (Base term)
-                            , MonadValue Value (Evaluating term Value effects)
+                            , MonadAddressable Precise (Evaluating Precise term (Value Precise) effects)
                             , Recursive term
                             , TypeLevel.KnownSymbol (PreludePath term)
                             )
                          => Parser term
                          -> [FilePath]
-                         -> IO (Final effects Value)
+                         -> IO (Final effects (Value Precise))
 evaluateFilesWithPrelude parser paths = do
   let preludePath = TypeLevel.symbolVal (Proxy :: Proxy (PreludePath term))
   prelude <- parseFile parser Nothing preludePath
   entry:xs <- traverse (parseFile parser Nothing) paths
-  pure $ evaluatesWith @Value prelude xs entry
+  pure $ evaluatesWith @Precise @(Value Precise) prelude xs entry
 
 
 -- Read and parse a file.