github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-29 18:06:14 +03:00
Code Issues Projects Releases Wiki Activity

Let the time task do it's own logging

Browse Source
This commit is contained in:
Timothy Clem 2017-07-31 08:37:35 -07:00
parent 6e682c880e
commit 79b5509b00
2 changed files with 14 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
src/Semantic.hs
View File

@ -97,14 +97,13 @@ diffTermPair :: Functor f => Both Blob -> Differ f a -> Both (Term f a) -> Task
diffTermPair blobs differ terms = case runJoin (blobExists <$> blobs) of
(True, False) -> pure (deleting (Both.fst terms))
(False, True) -> pure (inserting (Both.snd terms))
_ -> time (logTiming "diff") $ diff differ terms
_ -> time "diff" logInfo $ diff differ terms
where
(a, b) = runJoin blobs
logTiming msg delta = writeLog Info msg [ ("before_path", blobPath a)
, ("before_language", maybe "" show (blobLanguage a))
, ("after_path", blobPath b)
, ("after_language", maybe "" show (blobLanguage b))
, ("time", show delta) ]
logInfo = let (a, b) = runJoin blobs in
[ ("before_path", blobPath a)
, ("before_language", maybe "" show (blobLanguage a))
, ("after_path", blobPath b)
, ("after_language", maybe "" show (blobLanguage b)) ]
keepCategory :: HasField fields Category => Record fields -> Record '[Category]

17
src/Semantic/Task.hs
View File

@ -59,7 +59,7 @@ data TaskF output where
ReadBlobPairs :: Either Handle [Both (FilePath, Maybe Language)] -> TaskF [Both Blob]
WriteToOutput :: Either Handle FilePath -> ByteString -> TaskF ()
WriteLog :: Level -> String -> [(String, String)] -> TaskF ()
Time :: (Time.NominalDiffTime -> Task ()) -> Task output -> TaskF output
Time :: String -> [(String, String)] -> Task output -> TaskF output
Parse :: Parser term -> Blob -> TaskF term
Decorate :: Functor f => RAlgebra (TermF f (Record fields)) (Term f (Record fields)) field -> Term f (Record fields) -> TaskF (Term f (Record (field ': fields)))
Diff :: Differ f a -> Both (Term f a) -> TaskF (Diff f a)
@ -93,9 +93,9 @@ writeToOutput path contents = WriteToOutput path contents `Then` return
writeLog :: Level -> String -> [(String, String)] -> Task ()
writeLog level message pairs = WriteLog level message pairs `Then` return
-- | A 'Task' which measures timing of another 'Task'.
time :: (Time.NominalDiffTime -> Task ()) -> Task output -> Task output
time report task = Time report task `Then` return
-- | A 'Task' which measures and logs the timing of another 'Task'.
time :: String -> [(String, String)] -> Task output -> Task output
time message pairs task = Time message pairs task `Then` return
-- | A 'Task' which parses a 'Blob' with the given 'Parser'.
parse :: Parser term -> Blob -> Task term
@ -165,11 +165,11 @@ runTaskWithOptions options task = do
WriteLog level message pairs
| Just logLevel <- optionsLevel options, level <= logLevel -> Time.getCurrentTime >>= LocalTime.utcToLocalZonedTime >>= atomically . writeTMQueue logQueue . Message level message pairs >>= yield
| otherwise -> pure () >>= yield
Time report task -> do
Time message pairs task -> do
start <- liftIO Time.getCurrentTime
!res <- go task
end <- liftIO Time.getCurrentTime
_ <- go $ report (Time.diffUTCTime end start)
_ <- go $ writeLog Info message (pairs <> [("time", show (Time.diffUTCTime end start))])
either (pure . Left) yield res
Parse parser blob -> go (runParser options parser blob) >>= either (pure . Left) yield . join
Decorate algebra term -> pure (decoratorWithAlgebra algebra term) >>= yield
@ -204,9 +204,8 @@ runParser options@Options{..} parser blob@Blob{..} = case parser of
_ | Just err <- prj syntax -> const True (err :: Syntax.Error Bool)
_ -> or syntax
logTiming :: String -> Task a -> Task a
logTiming msg = time $ \delta -> writeLog Info msg [ ("path", blobPath)
, ("language", maybe "" show blobLanguage)
, ("time", show delta) ]
logTiming msg = time msg [ ("path", blobPath)
, ("language", maybe "" show blobLanguage)]
instance MonadIO Task where
liftIO action = LiftIO action `Then` return