move the trace runners to Control.Effect

src/Control/Effect.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE RankNTypes, TypeOperators #-}
+{-# LANGUAGE GADTs, RankNTypes, ScopedTypeVariables, TypeOperators #-}
 module Control.Effect
 ( Effectful(..)
 -- * Effects
@@ -15,14 +15,18 @@ module Control.Effect
 , runFresh
 , resume
 , runResumableWith
+, runIgnoringTraces
+, runPrintingTraces
+, runReturningTraces
 ) where
 
 import qualified Control.Monad.Effect as Eff
-import Control.Monad.Effect.Fresh
+import           Control.Monad.Effect.Fresh
 import qualified Control.Monad.Effect.Reader as Eff
-import Control.Monad.Effect.Resumable
+import           Control.Monad.Effect.Resumable
 import qualified Control.Monad.Effect.State as Eff
-import Prologue hiding (throwError)
+import           Control.Monad.Effect.Trace
+import           Prologue hiding (throwError)
 
 -- | Types wrapping 'Eff.Eff' actions.
 --
@@ -74,3 +78,15 @@ resume m handle = raise (resumeError (lower m) (\yield -> yield <=< lower . hand
 -- | Run a 'Resumable' effect in an 'Effectful' context, using a handler to resume computation.
 runResumableWith :: Effectful m => (forall resume . exc resume -> m effects resume) -> m (Resumable exc ': effects) a -> m effects a
 runResumableWith handler = raiseHandler (Eff.relay pure (\ (Resumable err) -> (lower (handler err) >>=)))
+
+-- | Run a 'Trace' effect, discarding the traced values.
+runIgnoringTraces :: Effectful m => m (Trace ': effects) a -> m effects a
+runIgnoringTraces = runEffect (\(Trace _) yield -> yield ())
+
+-- | Run a 'Trace' effect, printing the traced values to stdout.
+runPrintingTraces :: (Member IO effects, Effectful m) => m (Trace ': effects) a -> m effects a
+runPrintingTraces = raiseHandler (Eff.relay pure (\(Trace s) yield -> Eff.send (putStrLn s) >>= yield))
+
+-- | Run a 'Trace' effect, accumulating the traced values into a list.
+runReturningTraces :: (Functor (m effects), Effectful m) => m (Trace ': effects) a -> m effects (a, [String])
+runReturningTraces e = fmap reverse <$> raiseHandler (Eff.relayState [] (\ts a -> pure (a, ts)) (\ts (Trace s) yield -> yield (s : ts) ())) e

src/Semantic/Graph.hs

@@ -3,6 +3,7 @@ module Semantic.Graph where
 
 import           Analysis.Abstract.Evaluating
 import           Analysis.Abstract.Graph
+import           Control.Effect (runIgnoringTraces)
 import qualified Control.Exception as Exc
 import           Control.Monad.Effect (relayState, send)
 import           Data.Abstract.Address
@@ -44,7 +45,7 @@ graph graphType renderer project
           runGraphAnalysis
             = run
             . evaluating
-            . ignoringTraces
+            . runIgnoringTraces
             . resumingLoadError
             . resumingUnspecialized
             . resumingValueError
@@ -57,15 +58,6 @@ graph graphType renderer project
           constrainingTypes :: Evaluator (Located Precise) term (Value (Located Precise)) effects a -> Evaluator (Located Precise) term (Value (Located Precise)) effects a
           constrainingTypes = id
 
-ignoringTraces :: Effectful m => m (Trace ': effects) a -> m effects a
-ignoringTraces = runEffect (\(Trace _) yield -> yield ())
-
-printingTraces :: (Member IO effects, Effectful m) => m (Trace ': effects) a -> m effects a
-printingTraces = raiseHandler (relay pure (\(Trace s) yield -> send (putStrLn s) >>= yield))
-
-returningTraces :: (Functor (m effects), Effectful m) => m (Trace ': effects) a -> m effects (a, [String])
-returningTraces e = fmap reverse <$> raiseHandler (relayState [] (\ts a -> pure (a, ts)) (\ts (Trace s) yield -> yield (s : ts) ())) e
-
 -- | Parse a list of files into a 'Package'.
 parsePackage :: Members '[Distribute WrappedTask, Files, Task] effs
              => Parser term -- ^ A parser.

src/Semantic/Util.hs

@@ -6,6 +6,7 @@ import           Analysis.Abstract.Caching
 import           Analysis.Abstract.Collecting
 import           Analysis.Abstract.Evaluating as X
 import           Control.Abstract.Evaluator
+import           Control.Effect (runPrintingTraces)
 import           Control.Monad.Effect (runM)
 import           Data.Abstract.Address
 import           Data.Abstract.Evaluatable
@@ -28,7 +29,7 @@ import qualified Language.Ruby.Assignment as Ruby
 justEvaluating
   = runM . lower
   . evaluating
-  . printingTraces
+  . runPrintingTraces
   . runLoadError
   . runValueError
   . runUnspecialized
@@ -40,7 +41,7 @@ justEvaluating
 evaluatingWithHoles
   = runM . lower
   . evaluating
-  . printingTraces
+  . runPrintingTraces
   . resumingLoadError
   . resumingUnspecialized
   . resumingValueError
@@ -53,7 +54,7 @@ evaluatingWithHoles
 checking
   = runM . lower
   . evaluating
-  . printingTraces
+  . runPrintingTraces
   . providingLiveSet
   . runLoadError
   . runUnspecialized

test/SpecHelpers.hs

@@ -15,6 +15,7 @@ import Analysis.Abstract.Evaluating
 import Analysis.Abstract.Evaluating as X (EvaluatingState(..))
 import Control.Abstract.Addressable
 import Control.Abstract.Value
+import Control.Effect as X (runIgnoringTraces)
 import Data.Abstract.Address as X
 import Data.Abstract.Evaluatable
 import Data.Abstract.FreeVariables as X hiding (dropExtension)
@@ -34,7 +35,6 @@ import Data.Term as X
 import Parsing.Parser as X
 import Rendering.Renderer as X
 import Semantic.Diff as X
-import Semantic.Graph as X (ignoringTraces)
 import Semantic.Parse as X
 import Semantic.Task as X hiding (parsePackage)
 import Semantic.Util as X
@@ -71,7 +71,7 @@ readFilePair paths = let paths' = fmap file paths in
 testEvaluating
   = run
   . evaluating
-  . ignoringTraces
+  . runIgnoringTraces
   . runLoadError
   . runValueError
   . runUnspecialized