Bring back ability to get the currently evaluating module

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

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

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))