Merge branch 'master' into evaluatable-instances

semantic.cabal

@@ -35,6 +35,7 @@ library
                      , Assigning.Assignment.Table
                      -- Control structures & interfaces for abstract interpretation
                      , Control.Abstract
+                     , Control.Abstract.Configuration
                      , Control.Abstract.Context
                      , Control.Abstract.Environment
                      , Control.Abstract.Evaluator

src/Analysis/Abstract/Caching.hs

@@ -5,9 +5,11 @@ module Analysis.Abstract.Caching
 , 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 Prologue

src/Analysis/Abstract/Graph.hs

@@ -21,6 +21,7 @@ import           Control.Abstract hiding (Function(..))
 import           Data.Abstract.Address.Hole
 import           Data.Abstract.Address.Located
 import           Data.Abstract.BaseError
+import           Data.Abstract.Environment
 import           Data.Abstract.Ref
 import           Data.Abstract.Declarations
 import           Data.Abstract.Module (Module (moduleInfo), ModuleInfo (..))

src/Analysis/Abstract/Tracing.hs

@@ -4,6 +4,7 @@ module Analysis.Abstract.Tracing
 , tracing
 ) where
 
+import Control.Abstract.Configuration
 import Control.Abstract hiding (trace)
 import Control.Monad.Effect.Writer
 import Data.Semigroup.Reducer as Reducer

src/Control/Abstract/Configuration.hs

@@ -0,0 +1,15 @@
+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/Environment.hs

@@ -13,18 +13,21 @@ module Control.Abstract.Environment
 , locally
 , close
 , self
+, letrec
+, letrec'
+, variable
 -- * Effects
 , Env(..)
 , runEnv
-, EnvironmentError(..)
 , freeVariableError
 , runEnvironmentError
 , runEnvironmentErrorWith
 ) where
 
 import Control.Abstract.Evaluator
+import Control.Abstract.Heap
 import Data.Abstract.BaseError
-import Data.Abstract.Environment (Bindings, Environment, EvalContext(..))
+import Data.Abstract.Environment (Bindings, Environment, EvalContext(..), EnvironmentError(..))
 import qualified Data.Abstract.Environment as Env
 import Data.Abstract.Exports as Exports
 import Data.Abstract.Module
@@ -37,7 +40,8 @@ getEvalContext :: Member (Env address) effects => Evaluator address value effect
 getEvalContext = send GetCtx
 
 -- | Retrieve the current environment
-getEnv :: Member (Env address) effects => Evaluator address value effects (Environment address)
+getEnv :: Member (Env address) effects
+       => Evaluator address value effects (Environment address)
 getEnv = ctxEnvironment <$> getEvalContext
 
 -- | Replace the execution context. This is only for use in Analysis.Abstract.Caching.
@@ -82,6 +86,51 @@ close = send . Close
 self :: Member (Env address) effects => Evaluator address value effects (Maybe address)
 self = ctxSelf <$> getEvalContext
 
+-- | Look up or allocate an address for a 'Name'.
+lookupOrAlloc :: ( Member (Allocator address) effects
+                 , Member (Env address) effects
+                 )
+              => Name
+              -> Evaluator address value effects address
+lookupOrAlloc name = lookupEnv name >>= maybeM (alloc name)
+
+letrec :: ( Member (Allocator address) effects
+          , Member (Deref value) effects
+          , Member (Env address) effects
+          , Member (State (Heap address value)) effects
+          , Ord address
+          )
+       => Name
+       -> Evaluator address value effects value
+       -> Evaluator address value effects (value, address)
+letrec name body = do
+  addr <- lookupOrAlloc name
+  v <- locally (bind name addr *> body)
+  assign addr v
+  pure (v, addr)
+
+-- Lookup/alloc a name passing the address to a body evaluated in a new local environment.
+letrec' :: ( Member (Allocator address) effects
+           , Member (Env address) effects
+           )
+        => Name
+        -> (address -> Evaluator address value effects a)
+        -> Evaluator address value effects a
+letrec' name body = do
+  addr <- lookupOrAlloc name
+  v <- locally (body addr)
+  v <$ bind name addr
+
+-- | Look up and dereference the given 'Name', throwing an exception for free variables.
+variable :: ( Member (Env address) effects
+            , Member (Reader ModuleInfo) effects
+            , Member (Reader Span) effects
+            , Member (Resumable (BaseError (EnvironmentError address))) effects
+            )
+         => Name
+         -> Evaluator address value effects address
+variable name = lookupEnv name >>= maybeM (freeVariableError name)
+
 -- Effects
 
 data Env address m return where
@@ -132,15 +181,6 @@ handleEnv = \case
   PutCtx e -> put e
   Export name alias addr -> modify (Exports.insert name alias addr)
 
--- | Errors involving the environment.
-data EnvironmentError address return where
-  FreeVariable :: Name -> EnvironmentError address address
-
-deriving instance Eq (EnvironmentError address return)
-deriving instance Show (EnvironmentError address return)
-instance Show1 (EnvironmentError address) where liftShowsPrec _ _ = showsPrec
-instance Eq1 (EnvironmentError address) where liftEq _ (FreeVariable n1) (FreeVariable n2) = n1 == n2
-
 freeVariableError :: ( Member (Reader ModuleInfo) effects
                      , Member (Reader Span) effects
                      , Member (Resumable (BaseError (EnvironmentError address))) effects

src/Control/Abstract/Heap.hs

@@ -3,7 +3,6 @@ module Control.Abstract.Heap
 ( Heap
 , Configuration(..)
 , Live
-, getConfiguration
 , getHeap
 , putHeap
 , box
@@ -11,9 +10,6 @@ module Control.Abstract.Heap
 , dealloc
 , deref
 , assign
-, letrec
-, letrec'
-, variable
 -- * Garbage collection
 , gc
 -- * Effects
@@ -24,10 +20,8 @@ module Control.Abstract.Heap
 , runAddressErrorWith
 ) where
 
-import Control.Abstract.Environment
 import Control.Abstract.Evaluator
 import Control.Abstract.Roots
-import Control.Abstract.TermEvaluator
 import Data.Abstract.Configuration
 import Data.Abstract.BaseError
 import Data.Abstract.Heap
@@ -37,11 +31,6 @@ import Data.Abstract.Name
 import Data.Span (Span)
 import Prologue
 
--- | 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
-
-
 -- | Retrieve the heap.
 getHeap :: Member (State (Heap address value)) effects => Evaluator address value effects (Heap address value)
 getHeap = get
@@ -101,54 +90,6 @@ assign addr value = do
   putHeap (heapInit addr cell heap)
 
 
--- | Look up or allocate an address for a 'Name'.
-lookupOrAlloc :: ( Member (Allocator address) effects
-                 , Member (Env address) effects
-                 )
-              => Name
-              -> Evaluator address value effects address
-lookupOrAlloc name = lookupEnv name >>= maybeM (alloc name)
-
-
-letrec :: ( Member (Allocator address) effects
-          , Member (Deref value) effects
-          , Member (Env address) effects
-          , Member (State (Heap address value)) effects
-          , Ord address
-          )
-       => Name
-       -> Evaluator address value effects value
-       -> Evaluator address value effects (value, address)
-letrec name body = do
-  addr <- lookupOrAlloc name
-  v <- locally (bind name addr *> body)
-  assign addr v
-  pure (v, addr)
-
--- Lookup/alloc a name passing the address to a body evaluated in a new local environment.
-letrec' :: ( Member (Allocator address) effects
-           , Member (Env address) effects
-           )
-        => Name
-        -> (address -> Evaluator address value effects a)
-        -> Evaluator address value effects a
-letrec' name body = do
-  addr <- lookupOrAlloc name
-  v <- locally (body addr)
-  v <$ bind name addr
-
-
--- | Look up and dereference the given 'Name', throwing an exception for free variables.
-variable :: ( Member (Env address) effects
-            , Member (Reader ModuleInfo) effects
-            , Member (Reader Span) effects
-            , Member (Resumable (BaseError (EnvironmentError address))) effects
-            )
-         => Name
-         -> Evaluator address value effects address
-variable name = lookupEnv name >>= maybeM (freeVariableError name)
-
-
 -- Garbage collection
 
 -- | Collect any addresses in the heap not rooted in or reachable from the given 'Live' set.

src/Control/Abstract/Primitive.hs

@@ -9,6 +9,7 @@ module Control.Abstract.Primitive
   , Lambda(..)
   ) where
 
+import Data.Abstract.Environment
 import Control.Abstract.Context
 import Control.Abstract.Environment
 import Control.Abstract.Evaluator

src/Data/Abstract/Environment.hs

@@ -1,7 +1,10 @@
+{-# LANGUAGE GADTs #-}
+
 module Data.Abstract.Environment
   ( Environment(..)
   , Bindings(..)
   , EvalContext(..)
+  , EnvironmentError(..)
   , addresses
   , aliasBindings
   , allNames
@@ -62,6 +65,15 @@ newtype Environment address = Environment { unEnvironment :: NonEmpty (Bindings
 data EvalContext address = EvalContext { ctxSelf :: Maybe address, ctxEnvironment :: Environment address }
   deriving (Eq, Ord, Show)
 
+-- | Errors involving the environment.
+data EnvironmentError address return where
+  FreeVariable :: Name -> EnvironmentError address address
+
+deriving instance Eq (EnvironmentError address return)
+deriving instance Show (EnvironmentError address return)
+instance Show1 (EnvironmentError address) where liftShowsPrec _ _ = showsPrec
+instance Eq1 (EnvironmentError address) where liftEq _ (FreeVariable n1) (FreeVariable n2) = n1 == n2
+
 instance Lower (EvalContext address) where
   lowerBound = EvalContext Nothing lowerBound
 

test/Control/Abstract/Evaluator/Spec.hs

@@ -6,6 +6,7 @@ module Control.Abstract.Evaluator.Spec
 import Control.Abstract
 import Data.Abstract.Address.Precise as Precise
 import Data.Abstract.BaseError
+import Data.Abstract.Environment
 import Data.Abstract.Module
 import qualified Data.Abstract.Number as Number
 import Data.Abstract.Package