github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2025-01-03 04:51:57 +03:00
Code Issues Projects Releases Wiki Activity

Handle the reader effect for the queues internally to runTelemetry.

Browse Source
This commit is contained in:
Rob Rix 2018-05-10 11:53:19 -04:00
parent 79b15fc959
commit a16d581b53
2 changed files with 7 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
src/Semantic/Task.hs
View File

@ -125,7 +125,7 @@ runTaskWithOptions options task = do
(result, stat) <- withTiming "run" [] $ do (result, stat) <- withTiming "run" [] $ do
let run :: TaskEff a -> IO (Either SomeException a) 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 run task
queue statter stat queue statter stat

11
src/Semantic/Telemetry.hs
View File

@ -4,7 +4,6 @@ module Semantic.Telemetry
, writeStat , writeStat
, time , time
, Telemetry , Telemetry
, Queues(..)
, runTelemetry , runTelemetry
, ignoreTelemetry , ignoreTelemetry
) where ) where
@ -40,10 +39,12 @@ data Telemetry output where
data Queues = Queues { logger :: AsyncQueue Message Options, statter :: AsyncQueue Stat StatsClient } 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. -- | 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 :: Member IO effects => AsyncQueue Message Options -> AsyncQueue Stat StatsClient -> Eff (Telemetry ': effects) a -> Eff effects a
runTelemetry = reinterpret (\ t -> case t of runTelemetry logQ statQ
WriteStat stat -> asks statter >>= \ statter -> liftIO (queue statter stat) = flip runReader (Queues logQ statQ)
WriteLog level message pairs -> asks logger >>= \ logger -> queueLogMessage logger level message pairs) . 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. -- | Run a 'Telemetry' effect by ignoring statting/logging.
ignoreTelemetry :: Eff (Telemetry ': effs) a -> Eff effs a ignoreTelemetry :: Eff (Telemetry ': effs) a -> Eff effs a