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

Reduce duplication for hlint

Browse Source
This commit is contained in:
joshvera 2018-07-03 13:19:26 -04:00
parent 7eb207dace
commit 267de9d896
1 changed files with 59 additions and 63 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

46
src/Semantic/Task.hs
View File

@ -188,7 +188,23 @@ instance Exception ParserCancelled
-- | Parse a 'Blob' in 'IO'.
runParser :: (Member (Exc SomeException) effs, Member IO effs, Member (Reader Config) effs, Member Telemetry effs, Member Trace effs) => Blob -> Parser term -> Eff effs term
runParser blob@Blob{..} parser = case parser of
runParser blob@Blob{..} parser =
let
parseFailureHandler (SomeException err) = do
writeStat (increment "parse.parse_failures" languageTag)
writeLog Error "failed parsing" (("task", "parse") : blobFields)
throwError (toException err)
writeErrorStats errors = for_ errors $ \ err -> case Error.errorActual err of
Just "ParseError" -> do
writeStat (increment "parse.parse_errors" languageTag)
logError config Warning blob err (("task", "parse") : blobFields)
_ -> do
writeStat (increment "parse.assign_warnings" languageTag)
logError config Warning blob err (("task", "assign") : blobFields)
when (optionsFailOnWarning (configOptions config)) $ throwError (toException err)
in
case parser of
ASTParser language ->
time "parse.tree_sitter_ast_parse" languageTag $ do
config <- ask
@ -196,10 +212,7 @@ runParser blob@Blob{..} parser = case parser of
>>= maybeM (throwError (SomeException ParserTimedOut))
AssignmentParser parser assignment -> do
ast <- runParser blob parser `catchError` \ (SomeException err) -> do
writeStat (increment "parse.parse_failures" languageTag)
writeLog Error "failed parsing" (("task", "parse") : blobFields)
throwError (toException err)
ast <- runParser blob parser `catchError` parseFailureHandler
config <- ask
time "parse.assign" languageTag $
case Assignment.assign blobSource assignment ast of
@ -208,22 +221,12 @@ runParser blob@Blob{..} parser = case parser of
logError config Error blob err (("task", "assign") : blobFields)
throwError (toException err)
Right term -> do
for_ (errors term) $ \ err -> case Error.errorActual err of
Just "ParseError" -> do
writeStat (increment "parse.parse_errors" languageTag)
logError config Warning blob err (("task", "parse") : blobFields)
_ -> do
writeStat (increment "parse.assign_warnings" languageTag)
logError config Warning blob err (("task", "assign") : blobFields)
when (optionsFailOnWarning (configOptions config)) $ throwError (toException err)
writeErrorStats term
writeStat (count "parse.nodes" (length term) languageTag)
pure term
DeterministicParser parser assignment -> do
ast <- runParser blob parser `catchError` \ (SomeException err) -> do
writeStat (increment "parse.parse_failures" languageTag)
writeLog Error "failed parsing" (("task", "parse") : blobFields)
throwError (toException err)
ast <- runParser blob parser `catchError` parseFailureHandler
config <- ask
time "parse.assign_deterministic" languageTag $
case Deterministic.runAssignment (Deterministic.runTermAssignment assignment) blobSource (Deterministic.State 0 lowerBound [ast]) of
@ -232,14 +235,7 @@ runParser blob@Blob{..} parser = case parser of
logError config Error blob (either id show <$> err) (("task", "assign") : blobFields)
throwError (toException (either id show <$> err))
Right (_, term) -> do
for_ (errors term) $ \ err -> case Error.errorActual err of
Just "ParseError" -> do
writeStat (increment "parse.parse_errors" languageTag)
logError config Warning blob err (("task", "parse") : blobFields)
_ -> do
writeStat (increment "parse.assign_warnings" languageTag)
logError config Warning blob err (("task", "assign") : blobFields)
when (optionsFailOnWarning (configOptions config)) $ throwError (toException err)
writeErrorStats (errors term)
writeStat (count "parse.nodes" (length term) languageTag)
pure term