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

Minor refactor so we still get errors when we want that behavior

Browse Source
This commit is contained in:
Timothy Clem 2018-09-25 14:00:39 -05:00
parent 14c175156d
commit eabd5b97e2
1 changed files with 25 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

51
src/Semantic/Parse.hs
View File

@ -21,40 +21,39 @@ import Semantic.IO (noLanguageForBlob)
import Semantic.Task
import Serializing.Format
-- | Using the specified renderer, parse a list of 'Blob's to produce a 'Builder' output.
runParse :: (Member Distribute effs, Member (Exc SomeException) effs, Member Task effs) => TermRenderer output -> [Blob] -> Eff effs Builder
runParse JSONTermRenderer = withParsedBlobs renderJSONError (render . renderJSONTerm) >=> serialize JSON
runParse JSONGraphTermRenderer = withParsedBlobs renderJSONError (render . renderAdjGraph) >=> serialize JSON
runParse JSONTermRenderer = withParsedBlobs' renderJSONError (render . renderJSONTerm) >=> serialize JSON
runParse JSONGraphTermRenderer = withParsedBlobs' renderJSONError (render . renderAdjGraph) >=> serialize JSON
where renderAdjGraph :: (Recursive t, ToTreeGraph TermVertex (Base t)) => Blob -> t -> JSON.JSON "trees" SomeJSON
renderAdjGraph blob term = renderJSONAdjTerm blob (renderTreeGraph term)
runParse SExpressionTermRenderer = withParsedBlobs (\_ _ -> mempty) (const (serialize (SExpression ByConstructorName)))
runParse ShowTermRenderer = withParsedBlobs (\_ _ -> mempty) (const (serialize Show . quieterm))
runParse (SymbolsTermRenderer fields) = withParsedBlobs (\_ _ -> mempty) (\ blob -> decorate (declarationAlgebra blob) >=> render (renderSymbolTerms . renderToSymbols fields blob)) >=> serialize JSON
runParse DOTTermRenderer = withParsedBlobs (\_ _ -> mempty) (const (render renderTreeGraph)) >=> serialize (DOT (termStyle "terms"))
runParse SExpressionTermRenderer = withParsedBlobs (const (serialize (SExpression ByConstructorName)))
runParse ShowTermRenderer = withParsedBlobs (const (serialize Show . quieterm))
runParse (SymbolsTermRenderer fields) = withParsedBlobs (\ blob -> decorate (declarationAlgebra blob) >=> render (renderSymbolTerms . renderToSymbols fields blob)) >=> serialize JSON
runParse DOTTermRenderer = withParsedBlobs (const (render renderTreeGraph)) >=> serialize (DOT (termStyle "terms"))
-- | For testing and running parse-examples.
runParse' :: (Member (Exc SomeException) effs, Member Task effs) => Blob -> Eff effs Builder
runParse' blob = parseSomeBlob blob >>= withSomeTerm (serialize Show . quieterm)
withParsedBlobs ::
( Member Distribute effs
, Member (Exc SomeException) effs
, Member Task effs
, Monoid output
type Render effs output = forall syntax .
( ConstructorName syntax
, HasDeclaration syntax
, HasPackageDef syntax
, Foldable syntax
, Functor syntax
, Show1 syntax
, ToJSONFields1 syntax
)
=> (Blob -> String -> output)
-> ( forall syntax .
( ConstructorName syntax
, Foldable syntax
, Functor syntax
, HasDeclaration syntax
, HasPackageDef syntax
, Show1 syntax
, ToJSONFields1 syntax
) => Blob -> Term syntax Location -> Eff effs output
)
-> [Blob]
-> Eff effs output
withParsedBlobs onError render = distributeFoldMap $ \blob ->
=> Blob -> Term syntax Location -> Eff effs output
withParsedBlobs :: (Member Distribute effs, Member (Exc SomeException) effs, Member Task effs, Monoid output)
=> Render effs output -> [Blob] -> Eff effs output
withParsedBlobs render = distributeFoldMap $ \blob -> parseSomeBlob blob >>= withSomeTerm (render blob)
withParsedBlobs' :: (Member Distribute effs, Member (Exc SomeException) effs, Member Task effs, Monoid output)
=> (Blob -> String -> output) -> Render effs output -> [Blob] -> Eff effs output
withParsedBlobs' onError render = distributeFoldMap $ \blob ->
(parseSomeBlob blob >>= withSomeTerm (render blob)) `catchError` \(SomeException e) ->
pure (onError blob (show e))