diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index f717bf345..341891dd7 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, RankNTypes, TypeFamilies, UndecidableInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, RankNTypes, TypeFamilies, UndecidableInstances, ScopedTypeVariables #-} module Analysis.Abstract.Evaluating ( Evaluating , EvaluatingState(..) @@ -49,17 +49,18 @@ data EvaluatingState location term value = EvaluatingState , modules :: ModuleTable (Environment location value, value) , exports :: Exports location value , jumps :: IntMap.IntMap term + , origin :: SomeOrigin term } -deriving instance (Eq (Cell location value), Eq location, Eq term, Eq value) => Eq (EvaluatingState location term value) -deriving instance (Ord (Cell location value), Ord location, Ord term, Ord value) => Ord (EvaluatingState location term value) -deriving instance (Show (Cell location value), Show location, Show term, Show value) => Show (EvaluatingState location term value) +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 x1 j1 <> EvaluatingState e2 h2 m2 x2 j2 = EvaluatingState (e1 <> e2) (h1 <> h2) (m1 <> m2) (x1 <> x2) (j1 <> j2) + EvaluatingState e1 h1 m1 x1 j1 o1 <> EvaluatingState e2 h2 m2 x2 j2 o2 = EvaluatingState (e1 <> e2) (h1 <> h2) (m1 <> m2) (x1 <> x2) (j1 <> j2) (o1 <> o2) instance (Ord location, Semigroup (Cell location value)) => Monoid (EvaluatingState location term value) where - mempty = EvaluatingState mempty mempty mempty mempty mempty + mempty = EvaluatingState mempty mempty mempty mempty mempty mempty mappend = (<>) _environment :: Lens' (EvaluatingState location term value) (Environment location value) @@ -77,6 +78,9 @@ _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 () lens .= val = raise (modify' (lens .~ val)) @@ -126,7 +130,11 @@ instance Member (State (EvaluatingState location term value)) effects getHeap = view _heap putHeap = (_heap .=) -instance Members '[Reader (ModuleTable [Module term]), State (EvaluatingState location term value)] effects +instance Members '[ Reader (ModuleTable [Module term]) + , State (EvaluatingState location term value) + , Reader (SomeOrigin term) + , Fail + ] effects => MonadModuleTable location term value (Evaluating location term value effects) where getModuleTable = view _modules putModuleTable = (_modules .=) @@ -134,6 +142,10 @@ instance Members '[Reader (ModuleTable [Module term]), State (EvaluatingState lo askModuleTable = raise ask localModuleTable f a = raise (local f (lower a)) + currentModule = do + o <- raise ask + maybeFail "unable to get currentModule" $ withSomeOrigin (originModule @term) o + instance Members (EvaluatingEffects location term value) effects => MonadEvaluator location term value (Evaluating location term value effects) where getConfiguration term = Configuration term mempty <$> getEnv <*> getHeap diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index e9854cce8..635ae01bd 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -147,6 +147,9 @@ class Monad m => MonadModuleTable location term value m | m -> location, m -> te -- | Run an action with a locally-modified table of unevaluated modules. localModuleTable :: (ModuleTable [Module term] -> ModuleTable [Module term]) -> m a -> m a + -- | Get the currently evaluating 'ModuleInfo'. + currentModule :: m ModuleInfo + -- | Update the evaluated module table. modifyModuleTable :: MonadModuleTable location term value m => (ModuleTable (Environment location value, value) -> ModuleTable (Environment location value, value)) -> m () modifyModuleTable f = do diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index e23df2689..ae24f0699 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -1,6 +1,4 @@ {-# LANGUAGE ConstraintKinds, DefaultSignatures, GADTs, UndecidableInstances #-} -{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, - TypeFamilies, TypeOperators #-} module Data.Abstract.Evaluatable ( module X @@ -9,7 +7,6 @@ module Data.Abstract.Evaluatable , Unspecialized(..) , LoadError(..) , EvalError(..) -, currentModule , variable , evaluateTerm , evaluateModule @@ -31,7 +28,7 @@ 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.Abstract.Origin (SomeOrigin, packageOrigin, originModule, withSomeOrigin) +import Data.Abstract.Origin (SomeOrigin, packageOrigin) import Data.Abstract.Package as Package import Data.Semigroup.App import Data.Semigroup.Foldable @@ -71,22 +68,6 @@ data EvalError value resume where -- Indicates we weren't able to dereference a name from the evaluated environment. FreeVariableError :: Name -> EvalError value value --- | Get the current module. --- currentModule :: forall m location term value effects --- . ( Effectful m --- , Member (Reader (SomeOrigin term)) effects --- , MonadEvaluator location term value (m effects) --- ) --- => m effects ModuleInfo -currentModule :: m ModuleInfo -currentModule = undefined --- currentModule = do --- o <- raise ask --- let Just m = withSomeOrigin (originModule @term) o --- pure m - -- pure moduleInfo m --- currentModule = head <$> askModuleStack - -- | Look up and dereference the given 'Name', throwing an exception for free variables. variable :: MonadEvaluatable location term value m => Name -> m value variable name = lookupWith deref name >>= maybeM (throwException (FreeVariableError name))