mirror of
https://github.com/github/semantic.git
synced 2024-12-22 06:11:49 +03:00
Basic ability to set exitStatus
This commit is contained in:
parent
b52972b587
commit
a71e9ca428
@ -23,6 +23,7 @@ module Semantic.Task
|
||||
) where
|
||||
|
||||
import Control.Concurrent.STM.TMQueue
|
||||
import Control.Exception
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Parallel.Strategies
|
||||
import qualified Control.Concurrent.Async as Async
|
||||
@ -31,7 +32,6 @@ import Data.Blob
|
||||
import qualified Data.ByteString as B
|
||||
import Data.Functor.Both as Both
|
||||
import Data.Record
|
||||
import Data.Source
|
||||
import Data.String
|
||||
import qualified Data.Syntax as Syntax
|
||||
import Data.Syntax.Algebra (RAlgebra, decoratorWithAlgebra)
|
||||
@ -50,6 +50,7 @@ import System.Console.ANSI
|
||||
import System.IO (hIsTerminalDevice, hPutStr)
|
||||
import Term
|
||||
import Text.Show
|
||||
import Text.Printf
|
||||
import TreeSitter
|
||||
|
||||
data TaskF output where
|
||||
@ -85,7 +86,7 @@ formatMessage colourize (Message level message time) = showTime time . showChar
|
||||
showLevel Warning = Assignment.withSGRCode colourize [SetColor Foreground Vivid Yellow, SetConsoleIntensity BoldIntensity] (showString "warning")
|
||||
showLevel Info = Assignment.withSGRCode colourize [SetConsoleIntensity BoldIntensity] (showString "info")
|
||||
showLevel Debug = Assignment.withSGRCode colourize [SetColor Foreground Vivid Cyan, SetConsoleIntensity BoldIntensity] (showString "debug")
|
||||
showTime = showString . Time.formatTime Time.defaultTimeLocale (Time.iso8601DateFormat (Just "%H:%M:%S%Q"))
|
||||
showTime = showString . Time.formatTime Time.defaultTimeLocale (Time.iso8601DateFormat (Just "%H:%M:%S%.%q"))
|
||||
|
||||
|
||||
-- | A function to compute the 'Diff' for a pair of 'Term's with arbitrary syntax functor & annotation types.
|
||||
@ -181,23 +182,12 @@ runTaskWithOptions options task = do
|
||||
logQueue <- newTMQueueIO
|
||||
logging <- async (logSink options logQueue)
|
||||
|
||||
result <- runFreerM (\ task -> case task of
|
||||
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
|
||||
WriteToOutput destination contents -> pure <$ writeLog Info "WriteToOutput" <*> liftIO (either B.hPutStr B.writeFile destination contents)
|
||||
WriteLog level message
|
||||
| Just logLevel <- optionsLevel options, level <= logLevel -> pure <$> liftIO (Time.getCurrentTime >>= atomically . writeTMQueue logQueue . Message level message)
|
||||
| otherwise -> pure (pure ())
|
||||
Parse parser blob -> pure <$ writeLog Info "Parse" <*> runParser options parser blob
|
||||
Decorate algebra term -> pure <$ writeLog Info "Decorate" <*> pure (decoratorWithAlgebra algebra term)
|
||||
Diff differ terms -> pure <$ writeLog Info "Diff" <*> pure (differ terms)
|
||||
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))
|
||||
LiftIO action -> pure action)
|
||||
task
|
||||
result <- run options logQueue task
|
||||
atomically (closeTMQueue logQueue)
|
||||
wait logging
|
||||
pure result
|
||||
case result of
|
||||
Left err -> die err
|
||||
Right output -> pure output
|
||||
where logSink options queue = do
|
||||
message <- atomically (readTMQueue queue)
|
||||
case message of
|
||||
@ -205,35 +195,54 @@ runTaskWithOptions options task = do
|
||||
hPutStr stderr (formatMessage (fromMaybe True (optionsColour options)) message)
|
||||
logSink options queue
|
||||
_ -> pure ()
|
||||
run :: Options -> TMQueue Message -> Task a -> IO (Either String a)
|
||||
run options logQueue = go
|
||||
where go :: Task a -> IO (Either String a)
|
||||
go = iterFreerA (\ task yield -> case task of
|
||||
ReadBlobs source -> (either Files.readBlobsFromHandle (traverse (uncurry Files.readFile)) source >>= yield) `catchError` \ e -> pure (Left (displayException e))
|
||||
ReadBlobPairs source -> (either Files.readBlobPairsFromHandle (traverse (traverse (uncurry Files.readFile))) source >>= yield) `catchError` \ e -> pure (Left (displayException e))
|
||||
WriteToOutput destination contents -> either B.hPutStr B.writeFile destination contents >>= yield
|
||||
WriteLog level message
|
||||
| Just logLevel <- optionsLevel options, level <= logLevel -> Time.getCurrentTime >>= atomically . writeTMQueue logQueue . Message level message >>= yield
|
||||
| otherwise -> pure () >>= yield
|
||||
Parse parser blob -> go (runParser options parser blob) >>= either (pure . Left) (either (pure . Left) yield)
|
||||
Decorate algebra term -> pure (decoratorWithAlgebra algebra term) >>= yield
|
||||
Diff differ terms -> pure (differ terms) >>= yield
|
||||
Render renderer input -> pure (renderer input) >>= yield
|
||||
Distribute tasks -> Async.mapConcurrently go tasks >>= either (pure . Left) yield . sequenceA . withStrategy (parTraversable (parTraversable rseq))
|
||||
LiftIO action -> action >>= yield ) . fmap Right
|
||||
|
||||
runParser :: Options -> Parser term -> Blob -> Task term
|
||||
runParser :: Options -> Parser term -> Blob -> Task (Either String term)
|
||||
runParser options parser blob@Blob{..} = case parser of
|
||||
ASTParser language -> liftIO $ parseToAST language blob
|
||||
ASTParser language -> liftIO $ Right <$> parseToAST language blob
|
||||
AssignmentParser parser by assignment -> do
|
||||
ast <- runParser options parser blob
|
||||
case Assignment.assignBy by blobSource assignment ast of
|
||||
Left err -> do
|
||||
let formatOptions = Assignment.defaultOptions
|
||||
{ Assignment.optionsColour = fromMaybe True (optionsColour options)
|
||||
, Assignment.optionsIncludeSource = optionsPrintSource options
|
||||
}
|
||||
writeLog Warning (Assignment.formatErrorWithOptions formatOptions blob err)
|
||||
pure (errorTerm blobSource)
|
||||
Right term -> do
|
||||
when (hasErrors term) $ writeLog Warning (blobPath <> ":" <> show blobLanguage <> " has parse errors")
|
||||
pure term
|
||||
TreeSitterParser tslanguage -> liftIO $ treeSitterParser tslanguage blob
|
||||
MarkdownParser -> pure (cmarkParser blobSource)
|
||||
LineByLineParser -> pure (lineByLineParser blobSource)
|
||||
|
||||
errorTerm :: Syntax.Error :< fs => Source -> Term (Union fs) (Record Assignment.Location)
|
||||
errorTerm source = cofree ((totalRange source :. totalSpan source :. Nil) :< inj (Syntax.Error []))
|
||||
|
||||
hasErrors :: (Syntax.Error :< fs, Foldable (Union fs), Functor (Union fs)) => Term (Union fs) (Record Assignment.Location) -> Bool
|
||||
hasErrors = cata $ \ (_ :< syntax) -> case syntax of
|
||||
_ | Just err <- prj syntax -> const True (err :: Syntax.Error Bool)
|
||||
_ -> or syntax
|
||||
|
||||
start <- liftIO Time.getCurrentTime
|
||||
res <- runParser options parser blob
|
||||
end <- liftIO Time.getCurrentTime
|
||||
writeLog Info $ printf "parsed %10s:%-48s %10s" (showLanguage blob) blobPath (show (Time.diffUTCTime end start))
|
||||
case res of
|
||||
Left err -> pure $ Left err
|
||||
Right ast -> case Assignment.assignBy by blobSource assignment ast of
|
||||
Left err -> do
|
||||
let formatOptions = Assignment.defaultOptions
|
||||
{ Assignment.optionsColour = fromMaybe True (optionsColour options)
|
||||
, Assignment.optionsIncludeSource = optionsPrintSource options
|
||||
}
|
||||
writeLog Error (Assignment.formatErrorWithOptions formatOptions blob err)
|
||||
pure $ Left (blobPath <> ":" <> showLanguage blob <> " failed assignment")
|
||||
-- pure (errorTerm blobSource)
|
||||
Right term -> do
|
||||
when (hasErrors term) $ writeLog Warning (blobPath <> ":" <> showLanguage blob <> " has parse errors")
|
||||
pure $ Right term
|
||||
TreeSitterParser tslanguage -> liftIO $ Right <$> treeSitterParser tslanguage blob
|
||||
MarkdownParser -> pure $ Right (cmarkParser blobSource)
|
||||
LineByLineParser -> pure $ Right (lineByLineParser blobSource)
|
||||
where
|
||||
showLanguage Blob{..} = maybe "" show blobLanguage
|
||||
hasErrors :: (Syntax.Error :< fs, Foldable (Union fs), Functor (Union fs)) => Term (Union fs) (Record Assignment.Location) -> Bool
|
||||
hasErrors = cata $ \ (_ :< syntax) -> case syntax of
|
||||
_ | Just err <- prj syntax -> const True (err :: Syntax.Error Bool)
|
||||
_ -> or syntax
|
||||
|
||||
instance MonadIO Task where
|
||||
liftIO action = LiftIO action `Then` return
|
||||
|
Loading…
Reference in New Issue
Block a user