github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-24 07:25:44 +03:00
Code Issues Projects Releases Wiki Activity

Use MonadError in runParser.

Browse Source
This commit is contained in:
Rob Rix 2017-08-29 18:20:03 -04:00
parent 04593870e7
commit 568fce81d3
1 changed files with 17 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
src/Semantic/Task.hs
View File

@ -26,7 +26,6 @@ module Semantic.Task
import Control.Concurrent.STM.TMQueue import Control.Concurrent.STM.TMQueue
import Control.Exception import Control.Exception
import Control.Monad (join)
import Control.Monad.Error.Class import Control.Monad.Error.Class
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Parallel.Strategies import Control.Parallel.Strategies
@ -181,7 +180,7 @@ runTaskWithOptions options task = do
end <- Time.getCurrentTime end <- Time.getCurrentTime
queueLogMessage Info message (pairs <> [("duration", show (Time.diffUTCTime end start))]) queueLogMessage Info message (pairs <> [("duration", show (Time.diffUTCTime end start))])
either (pure . Left) yield res either (pure . Left) yield res
Parse parser blob -> go (runParser options blob parser) >>= either (pure . Left) yield . join Parse parser blob -> go (runParser options blob parser) >>= either (pure . Left) yield
Decorate algebra term -> pure (decoratorWithAlgebra algebra term) >>= yield Decorate algebra term -> pure (decoratorWithAlgebra algebra term) >>= yield
Diff differ terms -> pure (differ terms) >>= yield Diff differ terms -> pure (differ terms) >>= yield
Render renderer input -> pure (renderer input) >>= yield Render renderer input -> pure (renderer input) >>= yield
@ -198,29 +197,27 @@ runTaskWithOptions options task = do
| otherwise = pure () | otherwise = pure ()
runParser :: Options -> Blob -> Parser term -> Task (Either String term) runParser :: Options -> Blob -> Parser term -> Task term
runParser Options{..} blob@Blob{..} = go runParser Options{..} blob@Blob{..} = go
where go :: Parser term -> Task (Either String term) where go :: Parser term -> Task term
go parser = case parser of go parser = case parser of
ASTParser language -> ASTParser language ->
logTiming "ts ast parse" $ logTiming "ts ast parse" $
liftIO $ (Right <$> parseToAST language blob) `catchError` (pure . Left. displayException) liftIO ((Right <$> parseToAST language blob) `catchError` (pure . Left . displayException)) >>= either throwError pure
AssignmentParser parser assignment -> do AssignmentParser parser assignment -> do
res <- go parser ast <- go parser `catchError` \ err -> writeLog Error "failed parsing" blobFields >> throwError err
case res of logTiming "assign" $ case Assignment.assign blobSource assignment ast of
Left err -> writeLog Error "failed parsing" blobFields >> pure (Left err)
Right ast -> logTiming "assign" $ case Assignment.assign blobSource assignment ast of
Left err -> do Left err -> do
let formatted = Error.formatError optionsPrintSource (optionsIsTerminal && optionsEnableColour) blob err let formatted = Error.formatError optionsPrintSource (optionsIsTerminal && optionsEnableColour) blob err
writeLog Error formatted blobFields writeLog Error formatted blobFields
pure $ Left formatted throwError formatted
Right term -> do Right term -> do
for_ (errors term) $ \ err -> for_ (errors term) $ \ err ->
writeLog Warning (Error.formatError optionsPrintSource (optionsIsTerminal && optionsEnableColour) blob err) blobFields writeLog Warning (Error.formatError optionsPrintSource (optionsIsTerminal && optionsEnableColour) blob err) blobFields
pure $ Right term pure term
TreeSitterParser tslanguage -> logTiming "ts parse" $ liftIO (Right <$> treeSitterParser tslanguage blob) TreeSitterParser tslanguage -> logTiming "ts parse" $ liftIO (treeSitterParser tslanguage blob)
MarkdownParser -> logTiming "cmark parse" $ pure (Right (cmarkParser blobSource)) MarkdownParser -> logTiming "cmark parse" $ pure (cmarkParser blobSource)
LineByLineParser -> logTiming "line-by-line parse" $ pure (Right (lineByLineParser blobSource)) LineByLineParser -> logTiming "line-by-line parse" $ pure (lineByLineParser blobSource)
blobFields = [ ("path", blobPath), ("language", maybe "" show blobLanguage) ] blobFields = [ ("path", blobPath), ("language", maybe "" show blobLanguage) ]
errors :: (Syntax.Error :< fs, Apply1 Foldable fs, Apply1 Functor fs) => Term (Union fs) (Record Assignment.Location) -> [Error.Error String] errors :: (Syntax.Error :< fs, Apply1 Foldable fs, Apply1 Functor fs) => Term (Union fs) (Record Assignment.Location) -> [Error.Error String]
errors = cata $ \ (a :< syntax) -> case syntax of errors = cata $ \ (a :< syntax) -> case syntax of