Rephrase Collecting & Retaining as collectingTerms & providingLiveSet handlers.

src/Analysis/Abstract/Collecting.hs

@@ -1,11 +1,11 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE TypeOperators #-}
-{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For the Interpreter instance’s Evaluator constraint
 module Analysis.Abstract.Collecting
-( Collecting
+( collectingTerms
-, Retaining
+, providingLiveSet
 ) where
 
-import Control.Abstract.Analysis
+import Control.Abstract.Evaluator
+import Control.Abstract.Value
 import Data.Abstract.Address
 import Data.Abstract.Heap
 import Data.Abstract.Live
@@ -13,27 +13,19 @@ import Data.Semilattice.Lower
 import Prologue
 
 -- | An analysis performing GC after every instruction.
-newtype Collecting m (effects :: [* -> *]) a = Collecting { runCollecting :: m effects a }
+collectingTerms :: ( Foldable (Cell location)
-  deriving (Alternative, Applicative, Effectful, Functor, Monad)
+                   , Members '[ Reader (Live location value)
-
+                              , State (Heap location value)
-deriving instance Evaluator location term value m => Evaluator location term value (Collecting m)
+                              ] effects
-deriving instance AnalyzeModule location term value inner outer m => AnalyzeModule location term value inner outer (Collecting m)
+                   , Ord location
-
+                   , ValueRoots location value
-instance ( Effectful m
+                   )
-         , Foldable (Cell location)
+                => SubtermAlgebra (Base term) term (Evaluator location term value effects value)
-         , Member (Reader (Live location value)) outer
+                -> SubtermAlgebra (Base term) term (Evaluator location term value effects value)
-         , Member (State (Heap location value)) outer
+collectingTerms recur term = do
-         , AnalyzeTerm location term value inner outer m
+  roots <- askRoots
-         , Ord location
+  v <- recur term
-         , ValueRoots location value
+  v <$ modifyHeap (gc (roots <> valueRoots v))
-         )
-      => AnalyzeTerm location term value inner outer (Collecting m) where
-  analyzeTerm recur term = do
-    roots <- askRoots
-    v <- Collecting (analyzeTerm (runCollecting . recur) term)
-    modifyHeap (gc (roots <> valueRoots v))
-    pure v
-
 
 -- | Collect any addresses in the heap not rooted in or reachable from the given 'Live' set.
 gc :: ( Ord location
@@ -61,25 +53,5 @@ reachable roots heap = go mempty roots
             _           -> seen)
 
 
-instance ( Evaluator location term value m
+providingLiveSet :: Evaluator location term value (Reader (Live location value) ': effects) a -> Evaluator location term value effects a
-         , Interpreter m effects
+providingLiveSet = handleReader lowerBound
-         )
-      => Interpreter (Collecting m) (Reader (Live location value) ': effects) where
-  type Result (Collecting m) (Reader (Live location value) ': effects) result = Result m effects result
-  interpret = interpret . runCollecting . handleReader lowerBound
-
-
--- | An analysis providing a 'Live' set, but never performing GC.
-newtype Retaining m (effects :: [* -> *]) a = Retaining { runRetaining :: m effects a }
-  deriving (Alternative, Applicative, Effectful, Functor, Monad)
-
-deriving instance Evaluator location term value m => Evaluator location term value (Retaining m)
-deriving instance AnalyzeModule location term value inner outer m => AnalyzeModule location term value inner outer (Retaining m)
-deriving instance AnalyzeTerm location term value inner outer m => AnalyzeTerm location term value inner outer (Retaining m)
-
-instance ( Evaluator location term value m
-         , Interpreter m effects
-         )
-      => Interpreter (Retaining m) (Reader (Live location value) ': effects) where
-  type Result (Retaining m) (Reader (Live location value) ': effects) result = Result m effects result
-  interpret = interpret . runRetaining . handleReader lowerBound