diff --git a/src/Semantic/Parse.hs b/src/Semantic/Parse.hs index 84d662c21..ae5a391ba 100644 --- a/src/Semantic/Parse.hs +++ b/src/Semantic/Parse.hs @@ -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))