Merge pull request #1553 from github/decompose-monad-evaluator

Decompose MonadEvaluator

src/Analysis/Abstract/Caching.hs

@@ -26,6 +26,9 @@ type CacheFor term value = Cache (LocationFor value) term value
 newtype Caching m term value (effects :: [* -> *]) a = Caching (m term value effects a)
   deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet)
 
+deriving instance MonadEnvironment value (m term value effects) => MonadEnvironment value (Caching m term value effects)
+deriving instance MonadStore value (m term value effects) => MonadStore value (Caching m term value effects)
+deriving instance MonadModuleTable term value (m term value effects) => MonadModuleTable term value (Caching m term value effects)
 deriving instance MonadEvaluator term value (m term value effects) => MonadEvaluator term value (Caching m term value effects)
 
 -- | Functionality used to perform caching analysis. This is not exported, and exists primarily for organizational reasons.

src/Analysis/Abstract/Dead.hs

@@ -12,6 +12,9 @@ import Prologue
 newtype DeadCode m term value (effects :: [* -> *]) a = DeadCode (m term value effects a)
   deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet)
 
+deriving instance MonadEnvironment value (m term value effects) => MonadEnvironment value (DeadCode m term value effects)
+deriving instance MonadStore value (m term value effects) => MonadStore value (DeadCode m term value effects)
+deriving instance MonadModuleTable term value (m term value effects) => MonadModuleTable term value (DeadCode m term value effects)
 deriving instance MonadEvaluator term value (m term value effects) => MonadEvaluator term value (DeadCode m term value effects)
 
 -- | A set of “dead” (unreachable) terms.

src/Analysis/Abstract/Evaluating.hs

@@ -12,6 +12,7 @@ import Control.Monad.Effect.Fresh
 import Control.Monad.Effect.NonDet
 import Control.Monad.Effect.Reader
 import Control.Monad.Effect.State
+import Data.Abstract.Configuration
 import Data.Abstract.Evaluatable
 import Data.Abstract.ModuleTable
 import Data.Abstract.Value
@@ -77,22 +78,27 @@ type EvaluatingEffects term value
      , State  (ModuleTable (EnvironmentFor value)) -- Cache of evaluated modules
      ]
 
-instance Members (EvaluatingEffects term value) effects => MonadEvaluator term value (Evaluating term value effects) where
+instance Members '[Reader (EnvironmentFor value), State (EnvironmentFor value)] effects => MonadEnvironment value (Evaluating term value effects) where
   getGlobalEnv = raise get
   putGlobalEnv = raise . put
 
   askLocalEnv = raise ask
   localEnv f a = raise (local f (lower a))
 
+instance Member (State (StoreFor value)) effects => MonadStore value (Evaluating term value effects) where
   getStore = raise get
   putStore = raise . put
 
+instance Members '[Reader (ModuleTable term), State (ModuleTable (EnvironmentFor value))] effects => MonadModuleTable term value (Evaluating term value effects) where
   getModuleTable = raise get
-  modifyModuleTable f = raise (modify f)
+  putModuleTable = raise . put
 
   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
+  getConfiguration term = Configuration term mempty <$> askLocalEnv <*> getStore
+
 instance ( Evaluatable (Base term)
          , FreeVariables term
          , Members (EvaluatingEffects term value) effects

src/Analysis/Abstract/Tracing.hs

@@ -16,6 +16,9 @@ import Prologue
 newtype Tracing (trace :: * -> *) m term value (effects :: [* -> *]) a = Tracing (m term value effects a)
   deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet)
 
+deriving instance MonadEnvironment value (m term value effects) => MonadEnvironment value (Tracing trace m term value effects)
+deriving instance MonadStore value (m term value effects) => MonadStore value (Tracing trace m term value effects)
+deriving instance MonadModuleTable term value (m term value effects) => MonadModuleTable term value (Tracing trace m term value effects)
 deriving instance MonadEvaluator term value (m term value effects) => MonadEvaluator term value (Tracing trace m term value effects)
 
 instance ( Corecursive term

src/Control/Abstract/Addressable.hs

@@ -25,7 +25,7 @@ class (Monad m, Ord l, l ~ LocationFor value, Reducer value (Cell l value)) => M
 --   The term is expected to contain one and only one free 'Name', meaning that care should be taken to apply this only to e.g. identifiers.
 lookupOrAlloc :: ( FreeVariables term
                  , MonadAddressable (LocationFor value) value m
-                 , MonadEvaluator term value m
+                 , MonadStore value m
                  , Semigroup (CellFor value)
                  )
                  => term
@@ -38,7 +38,7 @@ lookupOrAlloc term = let [name] = toList (freeVariables term) in
 -- | Look up or allocate an address for a 'Name' & assign it a given value, returning the 'Name' paired with the address.
 lookupOrAlloc' :: ( Semigroup (CellFor value)
                   , MonadAddressable (LocationFor value) value m
-                  , MonadEvaluator term value m
+                  , MonadStore value m
                   )
                   => Name
                   -> value
@@ -49,21 +49,11 @@ lookupOrAlloc' name v env = do
   assign a v
   pure (name, a)
 
--- | Write a value to the given 'Address' in the 'Store'.
-assign :: ( Ord (LocationFor value)
-          , MonadEvaluator term value m
-          , Reducer value (CellFor value)
-          )
-          => Address (LocationFor value) value
-          -> value
-          -> m ()
-assign address = modifyStore . storeInsert address
-
 
 -- Instances
 
 -- | 'Precise' locations are always 'alloc'ated a fresh 'Address', and 'deref'erence to the 'Latest' value written.
-instance (Monad m, LocationFor value ~ Precise, MonadEvaluator term value m) => MonadAddressable Precise value m where
+instance (MonadFail m, LocationFor value ~ Precise, MonadStore value m) => MonadAddressable Precise value m where
   deref = maybe uninitializedAddress (pure . unLatest) <=< flip fmap getStore . storeLookup
     where
       -- | 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).
@@ -74,7 +64,7 @@ instance (Monad m, LocationFor value ~ Precise, MonadEvaluator term value m) =>
 
 
 -- | 'Monovariant' locations 'alloc'ate one 'Address' per unique variable name, and 'deref'erence once per stored value, nondeterministically.
-instance (Alternative m, Monad m, LocationFor value ~ Monovariant, MonadEvaluator term value m, Ord value) => MonadAddressable Monovariant value m where
+instance (Alternative m, LocationFor value ~ Monovariant, MonadStore value m, Ord value) => MonadAddressable Monovariant value m where
   deref = asum . maybe [] (map pure . toList) <=< flip fmap getStore . storeLookup
 
   alloc = pure . Address . Monovariant

src/Control/Abstract/Evaluator.hs

@@ -1,10 +1,21 @@
 {-# LANGUAGE ConstrainedClassMethods, FunctionalDependencies #-}
-module Control.Abstract.Evaluator where
+module Control.Abstract.Evaluator
+( MonadEvaluator(..)
+, MonadEnvironment(..)
+, modifyGlobalEnv
+, MonadStore(..)
+, modifyStore
+, assign
+, MonadModuleTable(..)
+, modifyModuleTable
+) where
 
+import Data.Abstract.Address
 import Data.Abstract.Configuration
-import Data.Abstract.Live
 import Data.Abstract.ModuleTable
+import Data.Abstract.Store
 import Data.Abstract.Value
+import Data.Semigroup.Reducer
 import Prelude hiding (fail)
 import Prologue
 
@@ -14,7 +25,17 @@ import Prologue
 --   - environments binding names to addresses
 --   - a heap mapping addresses to (possibly sets of) values
 --   - tables of modules available for import
-class MonadFail m => MonadEvaluator term value m | m -> term, m -> value where
+class ( MonadEnvironment value m
+      , MonadFail m
+      , MonadModuleTable term value m
+      , MonadStore value m
+      )
+      => MonadEvaluator term value m | m -> term, m -> value where
+  -- | Get the current 'Configuration' with a passed-in term.
+  getConfiguration :: Ord (LocationFor value) => term -> m (ConfigurationFor term value)
+
+-- | A 'Monad' abstracting local and global environments.
+class Monad m => MonadEnvironment value m | m -> value where
   -- | Retrieve the global environment.
   getGlobalEnv :: m (EnvironmentFor value)
   -- | Set the global environment
@@ -25,33 +46,51 @@ class MonadFail m => MonadEvaluator term value m | m -> term, m -> value where
   -- | Run an action with a locally-modified environment.
   localEnv :: (EnvironmentFor value -> EnvironmentFor value) -> m a -> m a
 
+-- | Update the global environment.
+modifyGlobalEnv :: MonadEvaluator term value m => (EnvironmentFor value -> EnvironmentFor value) -> m  ()
+modifyGlobalEnv f = do
+  env <- getGlobalEnv
+  putGlobalEnv $! f env
+
+
+-- | A 'Monad' abstracting a heap of values.
+class Monad m => MonadStore value m | m -> value where
   -- | Retrieve the heap.
   getStore :: m (StoreFor value)
   -- | Set the heap.
   putStore :: StoreFor value -> m ()
 
+-- | Update the heap.
+modifyStore :: MonadStore value m => (StoreFor value -> StoreFor value) -> m ()
+modifyStore f = do
+  s <- getStore
+  putStore $! f s
+
+-- | Write a value to the given 'Address' in the 'Store'.
+assign :: ( Ord (LocationFor value)
+          , MonadStore value m
+          , Reducer value (CellFor value)
+          )
+          => Address (LocationFor value) value
+          -> value
+          -> m ()
+assign address = modifyStore . storeInsert address
+
+
+-- | A 'Monad' abstracting tables of modules available for import.
+class Monad m => MonadModuleTable term value m | m -> term, m -> value where
   -- | Retrieve the table of evaluated modules.
   getModuleTable :: m (ModuleTable (EnvironmentFor value))
-  -- | Update the table of evaluated modules.
-  modifyModuleTable :: (ModuleTable (EnvironmentFor value) -> ModuleTable (EnvironmentFor value)) -> m ()
+  -- | Set the table of evaluated modules.
+  putModuleTable :: ModuleTable (EnvironmentFor value) -> m ()
 
   -- | Retrieve the table of unevaluated modules.
   askModuleTable :: m (ModuleTable term)
   -- | Run an action with a locally-modified table of unevaluated modules.
   localModuleTable :: (ModuleTable term -> ModuleTable term) -> m a -> m a
 
-  -- | Retrieve the current root set.
-  askRoots :: Ord (LocationFor value) => m (Live (LocationFor value) value)
-  askRoots = pure mempty
-
-  -- | Get the current 'Configuration' with a passed-in term.
-  getConfiguration :: Ord (LocationFor value) => term -> m (Configuration (LocationFor value) term value)
-  getConfiguration term = Configuration term <$> askRoots <*> askLocalEnv <*> getStore
-
--- | Update the global environment.
-modifyGlobalEnv :: MonadEvaluator term value m => (EnvironmentFor value -> EnvironmentFor value) -> m  ()
-modifyGlobalEnv f = getGlobalEnv >>= putGlobalEnv . f
-
--- | Update the heap.
-modifyStore :: MonadEvaluator term value m => (StoreFor value -> StoreFor value) -> m ()
-modifyStore f = getStore >>= putStore . f
+-- | Update the evaluated module table.
+modifyModuleTable :: MonadModuleTable term value m => (ModuleTable (EnvironmentFor value) -> ModuleTable (EnvironmentFor value)) -> m ()
+modifyModuleTable f = do
+  table <- getModuleTable
+  putModuleTable $! f table