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

Split parseBlob into separate parsing/rendering steps.

Browse Source
This commit is contained in:
Rob Rix 2018-05-11 17:13:17 -04:00
parent 559c303bb6
commit 8bb2793804
1 changed files with 16 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
src/Semantic/Parse.hs
View File

@ -5,8 +5,10 @@ import Analysis.ConstructorName (ConstructorName, constructorLabel)
import Analysis.IdentifierName (IdentifierName, identifierLabel)
import Analysis.Declaration (HasDeclaration, declarationAlgebra)
import Analysis.PackageDef (HasPackageDef, packageDefAlgebra)
import Data.AST
import Data.Blob
import Data.JSON.Fields
import Data.Record
import Parsing.Parser
import Prologue hiding (MonadError(..))
import Rendering.Graph
@ -18,18 +20,22 @@ import Serializing.Format
parseBlobs :: (Members '[Distribute WrappedTask, Task, Exc SomeException] effs, Monoid output) => TermRenderer output -> [Blob] -> Eff effs output
parseBlobs renderer blobs = distributeFoldMap (WrapTask . parseBlob renderer) blobs
parseSomeBlob :: Members '[Task, Exc SomeException] effs => Blob -> Eff effs (SomeTerm '[ConstructorName, HasPackageDef, HasDeclaration, IdentifierName, Foldable, Functor, ToJSONFields1] (Record Location))
parseSomeBlob blob@Blob{..} = maybe (noLanguageForBlob blobPath) (flip parse blob . someParser) blobLanguage
renderSomeTerm :: Members '[Task, Exc SomeException] effs => TermRenderer output -> Blob -> SomeTerm '[ConstructorName, HasPackageDef, HasDeclaration, IdentifierName, Foldable, Functor, ToJSONFields1] (Record Location) -> Eff effs output
renderSomeTerm renderer blob@Blob{..} = withSomeTerm $ case renderer of
JSONTermRenderer -> decorate constructorLabel >=> decorate identifierLabel >=> render (renderJSONTerm blob)
SExpressionTermRenderer -> serialize SExpression
TagsTermRenderer -> decorate (declarationAlgebra blob) >=> render (renderToTags blob)
ImportsTermRenderer -> decorate (declarationAlgebra blob) >=> decorate (packageDefAlgebra blob) >=> render (renderToImports blob)
SymbolsTermRenderer fields -> decorate (declarationAlgebra blob) >=> render (renderSymbolTerms . renderToSymbols fields blob)
DOTTermRenderer -> render renderTreeGraph >=> serialize (DOT (termStyle blobPath))
-- | A task to parse a 'Blob' and render the resulting 'Term'.
parseBlob :: Members '[Task, Exc SomeException] effs => TermRenderer output -> Blob -> Eff effs output
parseBlob renderer blob@Blob{..}
| Just (SomeParser parser) <- someParser @'[ConstructorName, HasPackageDef, HasDeclaration, IdentifierName, Foldable, Functor, ToJSONFields1] <$> blobLanguage
= parse parser blob >>= case renderer of
JSONTermRenderer -> decorate constructorLabel >=> decorate identifierLabel >=> render (renderJSONTerm blob)
SExpressionTermRenderer -> serialize SExpression
TagsTermRenderer -> decorate (declarationAlgebra blob) >=> render (renderToTags blob)
ImportsTermRenderer -> decorate (declarationAlgebra blob) >=> decorate (packageDefAlgebra blob) >=> render (renderToImports blob)
SymbolsTermRenderer fields -> decorate (declarationAlgebra blob) >=> render (renderSymbolTerms . renderToSymbols fields blob)
DOTTermRenderer -> render renderTreeGraph >=> serialize (DOT (termStyle blobPath))
| otherwise = noLanguageForBlob blobPath
parseBlob renderer blob@Blob{..} = parseSomeBlob blob >>= renderSomeTerm renderer blob
astParseBlobs :: (Members '[Distribute WrappedTask, Task, Exc SomeException] effs, Monoid output) => TermRenderer output -> [Blob] -> Eff effs output