From a16d581b53fa842cfe224b6a48acf9162a8cc30a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 10 May 2018 11:53:19 -0400 Subject: [PATCH] Handle the reader effect for the queues internally to runTelemetry. --- src/Semantic/Task.hs | 2 +- src/Semantic/Telemetry.hs | 11 ++++++----- 2 files changed, 7 insertions(+), 6 deletions(-) diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 764754c17..f9cf436ee 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -125,7 +125,7 @@ runTaskWithOptions options task = do (result, stat) <- withTiming "run" [] $ do let run :: TaskEff a -> IO (Either SomeException a) - run = runM . runError . flip runReader (Queues logger statter) . runTelemetry . runTraceInTelemetry . flip runReader options . IO.runFiles . runTaskF . runDistribute (run . unwrapTask) + run = runM . runError . runTelemetry logger statter . runTraceInTelemetry . flip runReader options . IO.runFiles . runTaskF . runDistribute (run . unwrapTask) run task queue statter stat diff --git a/src/Semantic/Telemetry.hs b/src/Semantic/Telemetry.hs index f3604c266..1987f7265 100644 --- a/src/Semantic/Telemetry.hs +++ b/src/Semantic/Telemetry.hs @@ -4,7 +4,6 @@ module Semantic.Telemetry , writeStat , time , Telemetry -, Queues(..) , runTelemetry , ignoreTelemetry ) where @@ -40,10 +39,12 @@ data Telemetry output where data Queues = Queues { logger :: AsyncQueue Message Options, statter :: AsyncQueue Stat StatsClient } -- | Run a 'Telemetry' effect by expecting a 'Reader' of 'Queue's to write stats and logs to. -runTelemetry :: Member IO effects => Eff (Telemetry ': effects) a -> Eff (Reader Queues ': effects) a -runTelemetry = reinterpret (\ t -> case t of - WriteStat stat -> asks statter >>= \ statter -> liftIO (queue statter stat) - WriteLog level message pairs -> asks logger >>= \ logger -> queueLogMessage logger level message pairs) +runTelemetry :: Member IO effects => AsyncQueue Message Options -> AsyncQueue Stat StatsClient -> Eff (Telemetry ': effects) a -> Eff effects a +runTelemetry logQ statQ + = flip runReader (Queues logQ statQ) + . reinterpret (\ t -> case t of + WriteStat stat -> asks @Queues statter >>= \ statter -> liftIO (queue statter stat) + WriteLog level message pairs -> asks @Queues logger >>= \ logger -> queueLogMessage logger level message pairs) -- | Run a 'Telemetry' effect by ignoring statting/logging. ignoreTelemetry :: Eff (Telemetry ': effs) a -> Eff effs a