From 45a604b04c87e3a319e038b11b05ade4f23294f2 Mon Sep 17 00:00:00 2001
From: Rob Rix <rob.rix@me.com>
Date: Wed, 4 Apr 2018 10:27:40 -0400
Subject: [PATCH] Resume a deep embedding of telemetry.

---
 src/Semantic/Task.hs | 33 +++++++++++++++++++++------------
 1 file changed, 21 insertions(+), 12 deletions(-)

diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs
index 7c0f0d39e..cc9236796 100644
--- a/src/Semantic/Task.hs
+++ b/src/Semantic/Task.hs
@@ -74,7 +74,7 @@ type LogQueue = AsyncQueue Message Options
 type StatQueue = AsyncQueue Stat StatsClient
 
 -- | A high-level task producing some result, e.g. parsing, diffing, rendering. 'Task's can also specify explicit concurrency via 'distribute', 'distributeFor', and 'distributeFoldMap'
-type Task = Eff '[Distribute, TaskF, Reader Options, Reader LogQueue, Reader StatQueue, Exc SomeException, IO]
+type Task = Eff '[Distribute, TaskF, Reader Options, Telemetry, Reader LogQueue, Reader StatQueue, Exc SomeException, IO]
 
 -- | A function to compute the 'Diff' for a pair of 'Term's with arbitrary syntax functor & annotation types.
 type Differ syntax ann1 ann2 = Term syntax ann1 -> Term syntax ann2 -> Diff syntax ann1 ann2
@@ -95,17 +95,15 @@ writeToOutput :: Member TaskF effs => Either Handle FilePath -> B.ByteString ->
 writeToOutput path = send . WriteToOutput path
 
 -- | A task which logs a message at a specific log level to stderr.
-writeLog :: Members '[Reader LogQueue, IO] effs => Level -> String -> [(String, String)] -> Eff effs ()
-writeLog level message pairs = do
-  logger <- ask
-  queueLogMessage logger level message pairs
+writeLog :: Member Telemetry effs => Level -> String -> [(String, String)] -> Eff effs ()
+writeLog level message pairs = send (WriteLog level message pairs)
 
 -- | A task which writes a stat.
-writeStat :: Members '[Reader StatQueue, IO] effs => Stat -> Eff effs ()
-writeStat stat = ask >>= \ statter -> liftIO (queue (statter :: StatQueue) stat)
+writeStat :: Member Telemetry effs => Stat -> Eff effs ()
+writeStat stat = send (WriteStat stat)
 
 -- | A task which measures and stats the timing of another task.
-time :: Members '[Reader StatQueue, IO] effs => String -> [(String, String)] -> Eff effs output -> Eff effs output
+time :: Members '[Telemetry, IO] effs => String -> [(String, String)] -> Eff effs output -> Eff effs output
 time statName tags task = do
   (a, stat) <- withTiming statName tags task
   a <$ writeStat stat
@@ -187,8 +185,8 @@ runTaskWithOptions options task = do
     run options logger statter = run'
       where
         run' :: Task a -> IO (Either SomeException a)
-        run' = runM . runError . flip runReader statter . flip runReader logger . flip runReader options . go . runDistribute
-        go :: Members '[Reader Options, Reader LogQueue, Reader StatQueue, Exc SomeException, IO] effs => Eff (TaskF ': effs) a -> Eff effs a
+        run' = runM . runError . flip runReader statter . flip runReader logger . runTelemetry . flip runReader options . go . runDistribute
+        go :: Members '[Reader Options, Telemetry, Reader LogQueue, Reader StatQueue, Exc SomeException, IO] effs => Eff (TaskF ': effs) a -> Eff effs a
         go = interpret (\ task -> case task of
           ReadBlobs (Left handle) -> rethrowing (IO.readBlobsFromHandle handle)
           ReadBlobs (Right paths@[(path, Nothing)]) -> rethrowing (IO.isDirectory path >>= bool (IO.readBlobsFromPaths paths) (IO.readBlobsFromDir path))
@@ -208,12 +206,12 @@ runTaskWithOptions options task = do
         parBitraversable :: Bitraversable t => Strategy a -> Strategy b -> Strategy (t a b)
         parBitraversable strat1 strat2 = bitraverse (rparWith strat1) (rparWith strat2)
 
-logError :: Members '[Reader Options, Reader LogQueue, IO] effs => Level -> Blob -> Error.Error String -> [(String, String)] -> Eff effs ()
+logError :: Members '[Reader Options, Telemetry] effs => Level -> Blob -> Error.Error String -> [(String, String)] -> Eff effs ()
 logError level blob err pairs = do
   Options{..} <- ask
   writeLog level (Error.formatError optionsPrintSource (optionsIsTerminal && optionsEnableColour) blob err) pairs
 
-runParser :: Members '[Reader Options, Reader LogQueue, Reader StatQueue, Exc SomeException, IO] effs => Blob -> Parser term -> Eff effs term
+runParser :: Members '[Reader Options, Telemetry, Exc SomeException, IO] effs => Blob -> Parser term -> Eff effs term
 runParser blob@Blob{..} parser = case parser of
   ASTParser language ->
     time "parse.tree_sitter_ast_parse" languageTag $
@@ -251,6 +249,17 @@ runParser blob@Blob{..} parser = case parser of
           _ -> fold syntax
 
 
+-- | Statting and logging effects.
+data Telemetry output where
+  WriteStat :: Stat -> Telemetry ()
+  WriteLog :: Level -> String -> [(String, String)] -> Telemetry ()
+
+runTelemetry :: Members '[Reader LogQueue, Reader StatQueue, IO] effs => Eff (Telemetry ': effs) a -> Eff effs a
+runTelemetry = interpret (\ t -> case t of
+  WriteStat stat -> ask >>= \ statter -> liftIO (queue (statter :: StatQueue) stat)
+  WriteLog level message pairs -> ask >>= \ logger -> queueLogMessage logger level message pairs)
+
+
 -- | Catch exceptions in 'IO' actions embedded in 'Eff', handling them with the passed function.
 --
 --   Note that while the type allows 'IO' to occur anywhere within the effect list, it must actually occur at the end to be able to run the computation.