github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-21 05:41:54 +03:00
Code Issues Projects Releases Wiki Activity

Separate log level & message.

Browse Source
This commit is contained in:
Rob Rix 2017-07-21 16:02:35 -04:00
parent 09baaffc46
commit 94e8eb7f20
1 changed files with 28 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

56
src/Semantic/Task.hs
View File

@ -1,8 +1,8 @@
{-# LANGUAGE DataKinds, GADTs, TypeOperators #-} {-# LANGUAGE DataKinds, GADTs, TypeOperators #-}
module Semantic.Task module Semantic.Task
( Task ( Task
, Level(..)
, RAlgebra , RAlgebra
, Message(..)
, Differ , Differ
, readBlobs , readBlobs
, readBlobPairs , readBlobPairs
@ -53,7 +53,7 @@ data TaskF output where
ReadBlobs :: Either Handle [(FilePath, Maybe Language)] -> TaskF [Blob] ReadBlobs :: Either Handle [(FilePath, Maybe Language)] -> TaskF [Blob]
ReadBlobPairs :: Either Handle [Both (FilePath, Maybe Language)] -> TaskF [Both Blob] ReadBlobPairs :: Either Handle [Both (FilePath, Maybe Language)] -> TaskF [Both Blob]
WriteToOutput :: Either Handle FilePath -> ByteString -> TaskF () WriteToOutput :: Either Handle FilePath -> ByteString -> TaskF ()
WriteLog :: Message -> TaskF () WriteLog :: Level -> String -> TaskF ()
Parse :: Parser term -> Blob -> TaskF term 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))) 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) Diff :: Differ f a -> Both (Term f a) -> TaskF (Diff f a)
@ -65,20 +65,20 @@ data TaskF output where
type Task = Freer TaskF type Task = Freer TaskF
-- | A log message at a specific level. -- | A log message at a specific level.
data Message data Level
= Error { messageContent :: String } = Error
| Warning { messageContent :: String } | Warning
| Info { messageContent :: String } | Info
| Debug { messageContent :: String } | Debug
deriving (Eq, Show) deriving (Eq, Ord, Show)
-- | Format a 'Message', optionally colourized. -- | Format a 'Message', optionally colourized.
formatMessage :: Bool -> Message -> String formatMessage :: Bool -> Level -> String -> String
formatMessage colourize m = showLabel m . showString ": " . showString (messageContent m) . showChar '\n' $ "" formatMessage colourize level message = showLabel level . showString ": " . showString message . showChar '\n' $ ""
where showLabel Error{} = Assignment.withSGRCode colourize [SetColor Foreground Vivid Red, SetConsoleIntensity BoldIntensity] (showString "error") where showLabel Error = Assignment.withSGRCode colourize [SetColor Foreground Vivid Red, SetConsoleIntensity BoldIntensity] (showString "error")
showLabel Warning{} = Assignment.withSGRCode colourize [SetColor Foreground Vivid Yellow, SetConsoleIntensity BoldIntensity] (showString "warning") showLabel Warning = Assignment.withSGRCode colourize [SetColor Foreground Vivid Yellow, SetConsoleIntensity BoldIntensity] (showString "warning")
showLabel Info{} = Assignment.withSGRCode colourize [SetConsoleIntensity BoldIntensity] (showString "info") showLabel Info = Assignment.withSGRCode colourize [SetConsoleIntensity BoldIntensity] (showString "info")
showLabel Debug{} = Assignment.withSGRCode colourize [SetColor Foreground Vivid Cyan, SetConsoleIntensity BoldIntensity] (showString "debug") showLabel Debug = Assignment.withSGRCode colourize [SetColor Foreground Vivid Cyan, SetConsoleIntensity BoldIntensity] (showString "debug")
-- | A function to compute the 'Diff' for a pair of 'Term's with arbitrary syntax functor & annotation types. -- | A function to compute the 'Diff' for a pair of 'Term's with arbitrary syntax functor & annotation types.
@ -101,8 +101,8 @@ writeToOutput path contents = WriteToOutput path contents `Then` return
-- | A 'Task' which logs a message at a specific log level to stderr. -- | A 'Task' which logs a message at a specific log level to stderr.
writeLog :: Message -> Task () writeLog :: Level -> String -> Task ()
writeLog message = WriteLog message `Then` return writeLog level message = WriteLog level message `Then` return
-- | A 'Task' which parses a 'Blob' with the given 'Parser'. -- | A 'Task' which parses a 'Blob' with the given 'Parser'.
@ -170,15 +170,15 @@ runTaskWithOptions options task = do
logging <- async (logSink options logQueue) logging <- async (logSink options logQueue)
result <- runFreerM (\ task -> case task of result <- runFreerM (\ task -> case task of
ReadBlobs source -> pure <$ writeLog (Info "ReadBlobs") <*> either Files.readBlobsFromHandle (traverse (uncurry Files.readFile)) source ReadBlobs source -> pure <$ writeLog Info "ReadBlobs" <*> either Files.readBlobsFromHandle (traverse (uncurry Files.readFile)) source
ReadBlobPairs source -> pure <$ writeLog (Info "ReadBlobPairs") <*> either Files.readBlobPairsFromHandle (traverse (traverse (uncurry Files.readFile))) source ReadBlobPairs source -> pure <$ writeLog Info "ReadBlobPairs" <*> either Files.readBlobPairsFromHandle (traverse (traverse (uncurry Files.readFile))) source
WriteToOutput destination contents -> pure <$ writeLog (Info "WriteToOutput") <*> liftIO (either B.hPutStr B.writeFile destination contents) WriteToOutput destination contents -> pure <$ writeLog Info "WriteToOutput" <*> liftIO (either B.hPutStr B.writeFile destination contents)
WriteLog message -> pure <$> liftIO (atomically (writeTMQueue logQueue message)) WriteLog level message -> pure <$> liftIO (atomically (writeTMQueue logQueue (level, message)))
Parse parser blob -> pure <$ writeLog (Info "Parse") <*> runParser options parser blob Parse parser blob -> pure <$ writeLog Info "Parse" <*> runParser options parser blob
Decorate algebra term -> pure <$ writeLog (Info "Decorate") <*> pure (decoratorWithAlgebra algebra term) Decorate algebra term -> pure <$ writeLog Info "Decorate" <*> pure (decoratorWithAlgebra algebra term)
Diff differ terms -> pure <$ writeLog (Info "Diff") <*> pure (differ terms) Diff differ terms -> pure <$ writeLog Info "Diff" <*> pure (differ terms)
Render renderer input -> pure <$ writeLog (Info "Render") <*> pure (renderer input) Render renderer input -> pure <$ writeLog Info "Render" <*> pure (renderer input)
Distribute tasks -> pure <$ writeLog (Info "Distribute") <*> liftIO (Async.mapConcurrently runTask tasks >>= pure . withStrategy (parTraversable rseq)) Distribute tasks -> pure <$ writeLog Info "Distribute" <*> liftIO (Async.mapConcurrently runTask tasks >>= pure . withStrategy (parTraversable rseq))
LiftIO action -> pure action) LiftIO action -> pure action)
task task
atomically (closeTMQueue logQueue) atomically (closeTMQueue logQueue)
@ -187,8 +187,8 @@ runTaskWithOptions options task = do
where logSink options queue = do where logSink options queue = do
message <- atomically (readTMQueue queue) message <- atomically (readTMQueue queue)
case message of case message of
Just message -> do Just (level, message) -> do
hPutStr stderr (formatMessage (fromMaybe True (optionsColour options)) message) hPutStr stderr (formatMessage (fromMaybe True (optionsColour options)) level message)
logSink options queue logSink options queue
_ -> pure () _ -> pure ()
@ -202,7 +202,7 @@ runParser options parser blob@Blob{..} = case parser of
let formatOptions = Assignment.defaultOptions let formatOptions = Assignment.defaultOptions
{ Assignment.optionsColour = fromMaybe True (optionsColour options) { Assignment.optionsColour = fromMaybe True (optionsColour options)
} }
writeLog (Warning (Assignment.formatErrorWithOptions formatOptions blob err)) writeLog Warning (Assignment.formatErrorWithOptions formatOptions blob err)
pure (errorTerm blobSource) pure (errorTerm blobSource)
Right term -> pure term Right term -> pure term
TreeSitterParser language tslanguage -> liftIO $ treeSitterParser language tslanguage blobSource TreeSitterParser language tslanguage -> liftIO $ treeSitterParser language tslanguage blobSource