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

Basic ability to set exitStatus

Browse Source
This commit is contained in:
Timothy Clem 2017-07-26 20:50:59 -07:00
parent b52972b587
commit a71e9ca428
1 changed files with 52 additions and 43 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

95
src/Semantic/Task.hs
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
Left err -> do end <- liftIO Time.getCurrentTime
let formatOptions = Assignment.defaultOptions writeLog Info $ printf "parsed %10s:%-48s %10s" (showLanguage blob) blobPath (show (Time.diffUTCTime end start))
{ Assignment.optionsColour = fromMaybe True (optionsColour options) case res of
, Assignment.optionsIncludeSource = optionsPrintSource options Left err -> pure $ Left err
} Right ast -> case Assignment.assignBy by blobSource assignment ast of
writeLog Warning (Assignment.formatErrorWithOptions formatOptions blob err) Left err -> do
pure (errorTerm blobSource) let formatOptions = Assignment.defaultOptions
Right term -> do { Assignment.optionsColour = fromMaybe True (optionsColour options)
when (hasErrors term) $ writeLog Warning (blobPath <> ":" <> show blobLanguage <> " has parse errors") , Assignment.optionsIncludeSource = optionsPrintSource options
pure term }
TreeSitterParser tslanguage -> liftIO $ treeSitterParser tslanguage blob writeLog Error (Assignment.formatErrorWithOptions formatOptions blob err)
MarkdownParser -> pure (cmarkParser blobSource) pure $ Left (blobPath <> ":" <> showLanguage blob <> " failed assignment")
LineByLineParser -> pure (lineByLineParser blobSource) -- pure (errorTerm blobSource)
Right term -> do
errorTerm :: Syntax.Error :< fs => Source -> Term (Union fs) (Record Assignment.Location) when (hasErrors term) $ writeLog Warning (blobPath <> ":" <> showLanguage blob <> " has parse errors")
errorTerm source = cofree ((totalRange source :. totalSpan source :. Nil) :< inj (Syntax.Error [])) pure $ Right term
TreeSitterParser tslanguage -> liftIO $ Right <$> treeSitterParser tslanguage blob
hasErrors :: (Syntax.Error :< fs, Foldable (Union fs), Functor (Union fs)) => Term (Union fs) (Record Assignment.Location) -> Bool MarkdownParser -> pure $ Right (cmarkParser blobSource)
hasErrors = cata $ \ (_ :< syntax) -> case syntax of LineByLineParser -> pure $ Right (lineByLineParser blobSource)
_ | Just err <- prj syntax -> const True (err :: Syntax.Error Bool) where
_ -> or syntax 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 instance MonadIO Task where
liftIO action = LiftIO action `Then` return liftIO action = LiftIO action `Then` return