Fix some Graph module errors

src/Control/Abstract/Heap.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE GADTs, KindSignatures, RankNTypes, TypeOperators, UndecidableInstances, ScopedTypeVariables #-}
 module Control.Abstract.Heap
 ( Heap
-, HeapError
+, HeapError(..)
 , Address(..)
 , Position(..)
 , Configuration(..)
@@ -18,6 +18,7 @@ module Control.Abstract.Heap
 , withChildFrame
 , define
 , withFrame
+, putCurrentFrame
 -- * Garbage collection
 , gc
 -- * Effects
@@ -25,6 +26,7 @@ module Control.Abstract.Heap
 , AddressError(..)
 , runAddressError
 , runAddressErrorWith
+, runHeapErrorWith
 ) where
 
 import Control.Abstract.Context (withCurrentCallStack)
@@ -85,12 +87,14 @@ currentFrame :: forall address value effects. ( Member (State (Heap address addr
              => Evaluator address value effects address
 currentFrame = maybeM (throwHeapError EmptyHeapError) =<< (Heap.currentFrame <$> get @(Heap address address value))
 
+putCurrentFrame :: forall address value effects. ( Member (State (Heap address address value)) effects ) => address -> Evaluator address value effects ()
+putCurrentFrame address = modify @(Heap address address value) (\heap -> heap { Heap.currentFrame = Just address })
+
 -- | Inserts a new frame into the heap with the given scope and links.
 newFrame :: forall address value effects. (
             Member (State (Heap address address value)) effects
           , Member (Reader ModuleInfo) effects
           , Member (Reader Span) effects
-          , Member (Resumable (BaseError (HeapError address))) effects
           , Ord address
           , Member (Allocator address) effects
           , Member (State (ScopeGraph address)) effects
@@ -333,6 +337,12 @@ runHeapError :: ( Effectful (m address value)
                 -> m address value effects (Either (SomeExc (BaseError (HeapError address))) a)
 runHeapError = runResumable
 
+runHeapErrorWith :: (Effectful (m address value), Effects effects)
+                  => (forall resume . BaseError (HeapError address) resume -> m address value effects resume)
+                  -> m address value (Resumable (BaseError (HeapError address)) ': effects) a
+                  -> m address value effects a
+runHeapErrorWith = runResumableWith
+
 data AddressError address value resume where
   UnallocatedAddress   :: address -> AddressError address value (Set value)
   UninitializedAddress :: address -> AddressError address value value

src/Control/Abstract/ScopeGraph.hs

@@ -25,6 +25,7 @@ module Control.Abstract.ScopeGraph
   , Allocator(..)
   , alloc
   , Address(..)
+  , runScopeErrorWith
   ) where
 
 import           Control.Abstract.Evaluator hiding (Local)
@@ -222,3 +223,9 @@ instance PureEffect (Allocator address)
 
 instance Effect (Allocator address) where
   handleState c dist (Request (Alloc name) k) = Request (Alloc name) (dist . (<$ c) . k)
+
+runScopeErrorWith :: (Effectful (m address value), Effects effects)
+                  => (forall resume . BaseError (ScopeError address) resume -> m address value effects resume)
+                  -> m address value (Resumable (BaseError (ScopeError address)) ': effects) a
+                  -> m address value effects a
+runScopeErrorWith = runResumableWith

src/Semantic/Graph.hs

@@ -30,6 +30,7 @@ import           Analysis.Abstract.Caching
 import           Analysis.Abstract.Collecting
 import           Analysis.Abstract.Graph as Graph
 import           Control.Abstract
+import Control.Abstract.Heap as Heap
 import           Control.Abstract.PythonPackage as PythonPackage
 import           Data.Abstract.Address.Hole as Hole
 import           Data.Abstract.Address.Located as Located
@@ -72,13 +73,6 @@ runGraph :: forall effs. ( Member Distribute effs
                          , Member Resolution effs
                          , Member Task effs
                          , Member Trace effs
-                         , Member (State Span) effs
-                         , Member (Allocator (Address (Hole (Maybe Name) (Located Monovariant)))) effs
-                         , Member (Resumable (BaseError (HeapError (Hole (Maybe Name) (Located Monovariant))))) effs
-                         , Member (Resumable (BaseError (ScopeError (Hole (Maybe Name) (Located Monovariant))))) effs
-                         , Member (Allocator (Address (Hole (Maybe Name) Precise))) effs
-                         , Member (Resumable (BaseError (HeapError (Hole (Maybe Name) Precise)))) effs
-                         , Member (Resumable (BaseError (ScopeError (Hole (Maybe Name) Precise)))) effs
                          , Effects effs
                          )
          => GraphType
@@ -111,10 +105,6 @@ runCallGraph :: forall fields syntax term lang effs. ( HasField fields Span
                 , HasPrelude lang
                 , HasPostlude lang
                 , Member Trace effs
-                , Member (State Span) effs
-                , Member (Allocator (Address (Hole (Maybe Name) (Located Monovariant)))) effs
-                , Member (Resumable (BaseError (HeapError (Hole (Maybe Name) (Located Monovariant))))) effs
-                , Member (Resumable (BaseError (ScopeError (Hole (Maybe Name) (Located Monovariant))))) effs
                 , Effects effs
                 )
              => Proxy lang
@@ -135,6 +125,8 @@ runCallGraph lang includePackages modules package = do
         . resumingLoadError
         . resumingUnspecialized
         -- . resumingEnvironmentError -- TODO: Fix me. Replace with resumingScopeGraphError?
+        . resumingScopeError
+        . resumingHeapError
         . resumingEvalError
         . resumingResolutionError
         . resumingAddressError
@@ -212,6 +204,8 @@ runImportGraph lang (package :: Package term) f =
         . resumingLoadError
         . resumingUnspecialized
         -- . resumingEnvironmentError -- TODO: Fix me. Replace with `resumingScopeGraphError`?
+        . resumingScopeError
+        . resumingHeapError
         . resumingEvalError
         . resumingResolutionError
         . resumingAddressError
@@ -237,6 +231,8 @@ type ConcreteEffects address rest
   ': Resumable (BaseError (AddressError address (Value address (ConcreteEff address rest))))
   ': Resumable (BaseError ResolutionError)
   ': Resumable (BaseError EvalError)
+  ': Resumable (BaseError (HeapError address))
+  ': Resumable (BaseError (ScopeError address))
   ': Resumable (BaseError (UnspecializedError (Value address (ConcreteEff address rest))))
   ': Resumable (BaseError (LoadError address (Value address (ConcreteEff address rest))))
   ': Fresh
@@ -281,9 +277,6 @@ parsePythonPackage :: forall syntax fields effs term.
                    , Member Resolution effs
                    , Member Trace effs
                    , Member Task effs
-                   , Member (Allocator (Address (Hole (Maybe Name) Precise))) effs
-                   , Member (Resumable (BaseError (HeapError (Hole (Maybe Name) Precise)))) effs
-                   , Member (Resumable (BaseError (ScopeError (Hole (Maybe Name) Precise)))) effs
                    , (Show (Record fields))
                    , Effects effs)
                    => Parser term       -- ^ A parser.
@@ -297,6 +290,9 @@ parsePythonPackage parser project = do
         . resumingLoadError
         . resumingUnspecialized
         -- . resumingEnvironmentError -- TODO: Fix me. Replace with `resumineScopeGraphError`?
+        . Hole.runAllocator Precise.handleAllocator
+        . resumingScopeError
+        . resumingHeapError
         . resumingEvalError
         . resumingResolutionError
         . resumingAddressError
@@ -449,6 +445,50 @@ resumingValueError = runValueErrorWith (\ baseError -> traceError "ValueError" b
   ArrayError{}      -> pure lowerBound
   ArithmeticError{} -> pure hole)
 
+resumingHeapError :: forall m address value effects a. ( Applicative (m address value effects)
+  , Effectful (m address value)
+  , Effects effects
+  , Member Trace effects
+  , Show address
+  , Ord address
+  , Member (Reader ModuleInfo) effects
+  , Member (State (Heap address address value)) effects
+  , Member (Allocator address) effects
+  , Member Fresh effects
+  , Member (Resumable (BaseError (ScopeError address))) effects
+  , Member (Reader Span) effects
+  , Member (State (ScopeGraph address)) effects
+  )
+  => m address value (Resumable (BaseError (HeapError address)) ': effects) a
+  -> m address value effects a
+resumingHeapError = runHeapErrorWith (\ baseError -> traceError "HeapError" baseError *> case baseErrorException baseError of
+  EmptyHeapError -> raiseEff . lowerEff $ do
+    currentScope' <- raiseEff (lowerEff currentScope)
+    frame <- newFrame @_ @value currentScope' mempty
+    putCurrentFrame frame
+    pure frame)
+
+resumingScopeError :: forall m address value effects a. ( Applicative (m address value effects)
+    , Effectful (m address value)
+    , Effects effects
+    , Member Trace effects
+    , Show address
+    , Ord address
+    , Member (Reader ModuleInfo) effects
+    , Member (Allocator address) effects
+    , Member Fresh effects
+    , Member (Reader Span) effects
+    , Member (State (ScopeGraph address)) effects
+    )
+    => m address value (Resumable (BaseError (ScopeError address)) ': effects) a
+    -> m address value effects a
+resumingScopeError = runScopeErrorWith (\ baseError -> traceError "ScopeError" baseError *> case baseErrorException baseError of
+  _ -> undefined)
+  -- LookupError :: address -> HeapError address address
+  -- LookupLinksError :: address ->  HeapError address (Map EdgeLabel (Map address address))
+  -- LookupPathError :: Path address ->  HeapError address address
+
+
 -- TODO: Fix me.
 -- Replace this with ScopeGraphError?
 -- resumingEnvironmentError :: ( Monad (m (Hole (Maybe Name) address) value effects)

src/Semantic/Util.hs

@@ -129,7 +129,7 @@ evaluateProjectWithCaching proxy parser path = runTaskWithOptions debugOptions $
   pure (runReader (packageInfo package)
        (runState (lowerBound @Span)
        (runReader (lowerBound @Span)
-       (runReader (lowerBound @(ModuleTable (NonEmpty (Module (ModuleResult Monovariant)))))
+       (runReader (lowerBound @(ModuleTable (NonEmpty (Module (ModuleResult Monovariant Type)))))
        (raiseHandler (runModules (ModuleTable.modulePaths (packageModules package)))
        (evaluate proxy id withTermSpans (Monovariant.runAllocator . Monovariant.runDeref) (Type.runBoolean . Type.runFunction) modules))))))