mirror of
https://github.com/github/semantic.git
synced 2024-12-29 18:06:14 +03:00
Move EvaluatingState into Evaluator and rename to EvaluatorState.
This commit is contained in:
Rob Rix
parent
584f3a7fc8
commit
035c606dca
@ -1,22 +1,18 @@
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving, RankNTypes, TypeFamilies, UndecidableInstances, ScopedTypeVariables #-}
|
||||
module Analysis.Abstract.Evaluating
|
||||
( Evaluating
|
||||
, EvaluatingState(..)
|
||||
, EvaluatorState(..)
|
||||
, State
|
||||
) where
|
||||
|
||||
import Control.Abstract.Analysis
|
||||
import Control.Monad.Effect
|
||||
import Data.Abstract.Address
|
||||
import Data.Abstract.Configuration
|
||||
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 Data.Empty
|
||||
import qualified Data.IntMap as IntMap
|
||||
import Lens.Micro
|
||||
import Prelude hiding (fail)
|
||||
@ -39,71 +35,29 @@ type EvaluatingEffects location term value
|
||||
, Resumable (ValueError location value)
|
||||
, Resumable (Unspecialized value)
|
||||
, Resumable (AddressError location value)
|
||||
, Fail -- Failure with an error message
|
||||
, Fresh -- For allocating new addresses and/or type variables.
|
||||
, Reader (SomeOrigin term) -- The current term’s origin.
|
||||
, 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.
|
||||
, Fail -- Failure with an error message
|
||||
, Fresh -- For allocating new addresses and/or type variables.
|
||||
, Reader (SomeOrigin term) -- The current term’s origin.
|
||||
, Reader (ModuleTable [Module term]) -- Cache of unevaluated modules
|
||||
, Reader (Environment location value) -- Default environment used as a fallback in lookupEnv
|
||||
, State (EvaluatorState location term value) -- Environment, heap, modules, exports, and jumps.
|
||||
]
|
||||
|
||||
data EvaluatingState location term value = EvaluatingState
|
||||
{ environment :: Environment location value
|
||||
, heap :: Heap location value
|
||||
, modules :: ModuleTable (Environment location value, value)
|
||||
, loadStack :: LoadStack
|
||||
, exports :: Exports location value
|
||||
, jumps :: IntMap.IntMap term
|
||||
, origin :: SomeOrigin term
|
||||
}
|
||||
|
||||
deriving instance (Eq (Cell location value), Eq location, Eq term, Eq value, Eq (Base term ())) => Eq (EvaluatingState location term value)
|
||||
deriving instance (Ord (Cell location value), Ord location, Ord term, Ord value, Ord (Base term ())) => Ord (EvaluatingState location term value)
|
||||
deriving instance (Show (Cell location value), Show location, Show term, Show value, Show (Base term ())) => Show (EvaluatingState location term value)
|
||||
|
||||
instance (Ord location, Semigroup (Cell location value)) => Semigroup (EvaluatingState location term value) where
|
||||
EvaluatingState e1 h1 m1 l1 x1 j1 o1 <> EvaluatingState e2 h2 m2 l2 x2 j2 o2 = EvaluatingState (e1 <> e2) (h1 <> h2) (m1 <> m2) (l1 <> l2) (x1 <> x2) (j1 <> j2) (o1 <> o2)
|
||||
|
||||
instance (Ord location, Semigroup (Cell location value)) => Empty (EvaluatingState location term value) where
|
||||
empty = EvaluatingState mempty mempty mempty mempty mempty mempty mempty
|
||||
|
||||
_environment :: Lens' (EvaluatingState location term value) (Environment location value)
|
||||
_environment = lens environment (\ s e -> s {environment = e})
|
||||
|
||||
_heap :: Lens' (EvaluatingState location term value) (Heap location value)
|
||||
_heap = lens heap (\ s h -> s {heap = h})
|
||||
|
||||
_modules :: Lens' (EvaluatingState location term value) (ModuleTable (Environment location value, value))
|
||||
_modules = lens modules (\ s m -> s {modules = m})
|
||||
|
||||
_loadStack :: Lens' (EvaluatingState location term value) LoadStack
|
||||
_loadStack = lens loadStack (\ s l -> s {loadStack = l})
|
||||
|
||||
_exports :: Lens' (EvaluatingState location term value) (Exports location value)
|
||||
_exports = lens exports (\ s e -> s {exports = e})
|
||||
|
||||
_jumps :: Lens' (EvaluatingState location term value) (IntMap.IntMap term)
|
||||
_jumps = lens jumps (\ s j -> s {jumps = j})
|
||||
|
||||
_origin :: Lens' (EvaluatingState location term value) (SomeOrigin term)
|
||||
_origin = lens origin (\ s o -> s {origin = o})
|
||||
|
||||
|
||||
(.=) :: Member (State (EvaluatingState location term value)) effects => ASetter (EvaluatingState location term value) (EvaluatingState location term value) a b -> b -> Evaluating location term value effects ()
|
||||
(.=) :: Member (State (EvaluatorState location term value)) effects => ASetter (EvaluatorState location term value) (EvaluatorState location term value) a b -> b -> Evaluating location term value effects ()
|
||||
lens .= val = raise (modify' (lens .~ val))
|
||||
|
||||
view :: Member (State (EvaluatingState location term value)) effects => Getting a (EvaluatingState location term value) a -> Evaluating location term value effects a
|
||||
view :: Member (State (EvaluatorState location term value)) effects => Getting a (EvaluatorState location term value) a -> Evaluating location term value effects a
|
||||
view lens = raise (gets (^. lens))
|
||||
|
||||
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
|
||||
localEvaluatorState :: Member (State (EvaluatorState location term value)) effects => Lens' (EvaluatorState location term value) prj -> (prj -> prj) -> Evaluating location term value effects a -> Evaluating location term value effects a
|
||||
localEvaluatorState lens f action = do
|
||||
original <- view lens
|
||||
lens .= f original
|
||||
v <- action
|
||||
v <$ lens .= original
|
||||
|
||||
|
||||
instance Members '[Fail, State (EvaluatingState location term value)] effects => MonadControl term effects (Evaluating location term value) where
|
||||
instance Members '[Fail, State (EvaluatorState location term value)] effects => MonadControl term effects (Evaluating location term value) where
|
||||
label term = do
|
||||
m <- view _jumps
|
||||
let i = IntMap.size m
|
||||
@ -112,33 +66,33 @@ instance Members '[Fail, State (EvaluatingState location term value)] effects =>
|
||||
|
||||
goto label = IntMap.lookup label <$> view _jumps >>= maybe (fail ("unknown label: " <> show label)) pure
|
||||
|
||||
instance Members '[ State (EvaluatingState location term value)
|
||||
instance Members '[ State (EvaluatorState location term value)
|
||||
, Reader (Environment location value)
|
||||
] effects
|
||||
=> MonadEnvironment location value effects (Evaluating location term value) where
|
||||
getEnv = view _environment
|
||||
putEnv = (_environment .=)
|
||||
withEnv s = localEvaluatingState _environment (const s)
|
||||
withEnv s = localEvaluatorState _environment (const s)
|
||||
|
||||
defaultEnvironment = raise ask
|
||||
withDefaultEnvironment e = raise . local (const e) . lower
|
||||
|
||||
getExports = view _exports
|
||||
putExports = (_exports .=)
|
||||
withExports s = localEvaluatingState _exports (const s)
|
||||
withExports s = localEvaluatorState _exports (const s)
|
||||
|
||||
localEnv f a = do
|
||||
modifyEnv (f . Env.push)
|
||||
result <- a
|
||||
result <$ modifyEnv Env.pop
|
||||
|
||||
instance Member (State (EvaluatingState location term value)) effects
|
||||
instance Member (State (EvaluatorState location term value)) effects
|
||||
=> MonadHeap location value effects (Evaluating location term value) where
|
||||
getHeap = view _heap
|
||||
putHeap = (_heap .=)
|
||||
|
||||
instance Members '[ Reader (ModuleTable [Module term])
|
||||
, State (EvaluatingState location term value)
|
||||
, State (EvaluatorState location term value)
|
||||
, Reader (SomeOrigin term)
|
||||
, Fail
|
||||
] effects
|
||||
|
||||
@ -9,7 +9,7 @@ module Analysis.Abstract.ImportGraph
|
||||
import qualified Algebra.Graph as G
|
||||
import Algebra.Graph.Class hiding (Vertex)
|
||||
import Algebra.Graph.Export.Dot hiding (vertexName)
|
||||
import Control.Abstract.Analysis
|
||||
import Control.Abstract.Analysis hiding (origin)
|
||||
import Data.Abstract.Address
|
||||
import Data.Abstract.Evaluatable (LoadError (..))
|
||||
import Data.Abstract.FreeVariables
|
||||
|
||||
@ -1,6 +1,15 @@
|
||||
{-# LANGUAGE ConstrainedClassMethods, FunctionalDependencies, RankNTypes, TypeFamilies, UndecidableInstances #-}
|
||||
module Control.Abstract.Evaluator
|
||||
( MonadEvaluator(..)
|
||||
-- State
|
||||
, EvaluatorState(..)
|
||||
, _environment
|
||||
, _heap
|
||||
, _modules
|
||||
, _loadStack
|
||||
, _exports
|
||||
, _jumps
|
||||
, _origin
|
||||
, MonadEnvironment(..)
|
||||
, modifyEnv
|
||||
, modifyExports
|
||||
@ -21,19 +30,23 @@ module Control.Abstract.Evaluator
|
||||
, catchException
|
||||
) where
|
||||
|
||||
import Control.Effect
|
||||
import Control.Monad.Effect.Exception as Exception
|
||||
import Control.Monad.Effect.Resumable as Resumable
|
||||
import Data.Abstract.Address
|
||||
import Data.Abstract.Configuration
|
||||
import Data.Abstract.Environment as Env
|
||||
import Data.Abstract.Exports as Export
|
||||
import Data.Abstract.FreeVariables
|
||||
import Data.Abstract.Heap
|
||||
import Data.Abstract.Module
|
||||
import Data.Abstract.ModuleTable
|
||||
import Data.Semigroup.Reducer
|
||||
import Prologue
|
||||
import Control.Effect
|
||||
import Control.Monad.Effect.Exception as Exception
|
||||
import Control.Monad.Effect.Resumable as Resumable
|
||||
import Data.Abstract.Address
|
||||
import Data.Abstract.Configuration
|
||||
import Data.Abstract.Environment as Env
|
||||
import Data.Abstract.Exports as Export
|
||||
import Data.Abstract.FreeVariables
|
||||
import Data.Abstract.Heap
|
||||
import Data.Abstract.Module
|
||||
import Data.Abstract.ModuleTable
|
||||
import Data.Abstract.Origin
|
||||
import Data.Empty
|
||||
import qualified Data.IntMap as IntMap
|
||||
import Data.Semigroup.Reducer
|
||||
import Lens.Micro
|
||||
import Prologue
|
||||
|
||||
-- | A 'Monad' providing the basic essentials for evaluation.
|
||||
--
|
||||
@ -51,6 +64,48 @@ class ( Effectful m
|
||||
-- | Get the current 'Configuration' with a passed-in term.
|
||||
getConfiguration :: Ord location => term -> m effects (Configuration location term value)
|
||||
|
||||
data EvaluatorState location term value = EvaluatorState
|
||||
{ environment :: Environment location value
|
||||
, heap :: Heap location value
|
||||
, modules :: ModuleTable (Environment location value, value)
|
||||
, loadStack :: LoadStack
|
||||
, exports :: Exports location value
|
||||
, jumps :: IntMap.IntMap term
|
||||
, origin :: SomeOrigin term
|
||||
}
|
||||
|
||||
deriving instance (Eq (Cell location value), Eq location, Eq term, Eq value, Eq (Base term ())) => Eq (EvaluatorState location term value)
|
||||
deriving instance (Ord (Cell location value), Ord location, Ord term, Ord value, Ord (Base term ())) => Ord (EvaluatorState location term value)
|
||||
deriving instance (Show (Cell location value), Show location, Show term, Show value, Show (Base term ())) => Show (EvaluatorState location term value)
|
||||
|
||||
instance (Ord location, Semigroup (Cell location value)) => Semigroup (EvaluatorState location term value) where
|
||||
EvaluatorState e1 h1 m1 l1 x1 j1 o1 <> EvaluatorState e2 h2 m2 l2 x2 j2 o2 = EvaluatorState (e1 <> e2) (h1 <> h2) (m1 <> m2) (l1 <> l2) (x1 <> x2) (j1 <> j2) (o1 <> o2)
|
||||
|
||||
instance (Ord location, Semigroup (Cell location value)) => Empty (EvaluatorState location term value) where
|
||||
empty = EvaluatorState mempty mempty mempty mempty mempty mempty mempty
|
||||
|
||||
_environment :: Lens' (EvaluatorState location term value) (Environment location value)
|
||||
_environment = lens environment (\ s e -> s {environment = e})
|
||||
|
||||
_heap :: Lens' (EvaluatorState location term value) (Heap location value)
|
||||
_heap = lens heap (\ s h -> s {heap = h})
|
||||
|
||||
_modules :: Lens' (EvaluatorState location term value) (ModuleTable (Environment location value, value))
|
||||
_modules = lens modules (\ s m -> s {modules = m})
|
||||
|
||||
_loadStack :: Lens' (EvaluatorState location term value) LoadStack
|
||||
_loadStack = lens loadStack (\ s l -> s {loadStack = l})
|
||||
|
||||
_exports :: Lens' (EvaluatorState location term value) (Exports location value)
|
||||
_exports = lens exports (\ s e -> s {exports = e})
|
||||
|
||||
_jumps :: Lens' (EvaluatorState location term value) (IntMap.IntMap term)
|
||||
_jumps = lens jumps (\ s j -> s {jumps = j})
|
||||
|
||||
_origin :: Lens' (EvaluatorState location term value) (SomeOrigin term)
|
||||
_origin = lens origin (\ s o -> s {origin = o})
|
||||
|
||||
|
||||
-- | A 'Monad' abstracting local and global environments.
|
||||
class Monad (m effects) => MonadEnvironment location value (effects :: [* -> *]) m | m effects -> value, m -> location where
|
||||
-- | Retrieve the environment.
|
||||
|
||||
Loading…
Reference in New Issue
Block a user