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

Resume a deep embedding of telemetry.

Browse Source
This commit is contained in:
Rob Rix 2018-04-04 10:27:40 -04:00
parent 3a25320bc7
commit 45a604b04c
1 changed files with 21 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
src/Semantic/Task.hs
View File

@ -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.