1
1
mirror of https://github.com/github/semantic.git synced 2024-12-22 14:21:31 +03:00

Basic ability to set exitStatus

This commit is contained in:
Timothy Clem 2017-07-26 20:50:59 -07:00
parent b52972b587
commit a71e9ca428

View File

@ -23,6 +23,7 @@ module Semantic.Task
) where ) where
import Control.Concurrent.STM.TMQueue import Control.Concurrent.STM.TMQueue
import Control.Exception
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Parallel.Strategies import Control.Parallel.Strategies
import qualified Control.Concurrent.Async as Async import qualified Control.Concurrent.Async as Async
@ -31,7 +32,6 @@ import Data.Blob
import qualified Data.ByteString as B import qualified Data.ByteString as B
import Data.Functor.Both as Both import Data.Functor.Both as Both
import Data.Record import Data.Record
import Data.Source
import Data.String import Data.String
import qualified Data.Syntax as Syntax import qualified Data.Syntax as Syntax
import Data.Syntax.Algebra (RAlgebra, decoratorWithAlgebra) import Data.Syntax.Algebra (RAlgebra, decoratorWithAlgebra)
@ -50,6 +50,7 @@ import System.Console.ANSI
import System.IO (hIsTerminalDevice, hPutStr) import System.IO (hIsTerminalDevice, hPutStr)
import Term import Term
import Text.Show import Text.Show
import Text.Printf
import TreeSitter import TreeSitter
data TaskF output where 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 Warning = Assignment.withSGRCode colourize [SetColor Foreground Vivid Yellow, SetConsoleIntensity BoldIntensity] (showString "warning")
showLevel Info = Assignment.withSGRCode colourize [SetConsoleIntensity BoldIntensity] (showString "info") showLevel Info = Assignment.withSGRCode colourize [SetConsoleIntensity BoldIntensity] (showString "info")
showLevel Debug = Assignment.withSGRCode colourize [SetColor Foreground Vivid Cyan, SetConsoleIntensity BoldIntensity] (showString "debug") 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. -- | 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 logQueue <- newTMQueueIO
logging <- async (logSink options logQueue) logging <- async (logSink options logQueue)
result <- runFreerM (\ task -> case task of result <- run options logQueue task
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
atomically (closeTMQueue logQueue) atomically (closeTMQueue logQueue)
wait logging wait logging
pure result case result of
Left err -> die err
Right output -> pure output
where logSink options queue = do where logSink options queue = do
message <- atomically (readTMQueue queue) message <- atomically (readTMQueue queue)
case message of case message of
@ -205,35 +195,54 @@ runTaskWithOptions options task = do
hPutStr stderr (formatMessage (fromMaybe True (optionsColour options)) message) hPutStr stderr (formatMessage (fromMaybe True (optionsColour options)) message)
logSink options queue logSink options queue
_ -> pure () _ -> 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 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 AssignmentParser parser by assignment -> do
ast <- runParser options parser blob start <- liftIO Time.getCurrentTime
case Assignment.assignBy by blobSource assignment ast of 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 Left err -> do
let formatOptions = Assignment.defaultOptions let formatOptions = Assignment.defaultOptions
{ Assignment.optionsColour = fromMaybe True (optionsColour options) { Assignment.optionsColour = fromMaybe True (optionsColour options)
, Assignment.optionsIncludeSource = optionsPrintSource options , Assignment.optionsIncludeSource = optionsPrintSource options
} }
writeLog Warning (Assignment.formatErrorWithOptions formatOptions blob err) writeLog Error (Assignment.formatErrorWithOptions formatOptions blob err)
pure (errorTerm blobSource) pure $ Left (blobPath <> ":" <> showLanguage blob <> " failed assignment")
-- pure (errorTerm blobSource)
Right term -> do Right term -> do
when (hasErrors term) $ writeLog Warning (blobPath <> ":" <> show blobLanguage <> " has parse errors") when (hasErrors term) $ writeLog Warning (blobPath <> ":" <> showLanguage blob <> " has parse errors")
pure term pure $ Right term
TreeSitterParser tslanguage -> liftIO $ treeSitterParser tslanguage blob TreeSitterParser tslanguage -> liftIO $ Right <$> treeSitterParser tslanguage blob
MarkdownParser -> pure (cmarkParser blobSource) MarkdownParser -> pure $ Right (cmarkParser blobSource)
LineByLineParser -> pure (lineByLineParser blobSource) LineByLineParser -> pure $ Right (lineByLineParser blobSource)
where
errorTerm :: Syntax.Error :< fs => Source -> Term (Union fs) (Record Assignment.Location) showLanguage Blob{..} = maybe "" show blobLanguage
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
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) _ | Just err <- prj syntax -> const True (err :: Syntax.Error Bool)
_ -> or syntax _ -> or syntax
instance MonadIO Task where instance MonadIO Task where
liftIO action = LiftIO action `Then` return liftIO action = LiftIO action `Then` return