diff --git a/src/Rendering/JSON.hs b/src/Rendering/JSON.hs index 7ecaf84aa..cc6bbbbe2 100644 --- a/src/Rendering/JSON.hs +++ b/src/Rendering/JSON.hs @@ -5,6 +5,7 @@ module Rendering.JSON , renderJSONTerm , renderJSONAST , renderSymbolTerms +, renderJSONError , SomeJSON(..) ) where @@ -43,6 +44,8 @@ instance ToJSON JSONStat where toJSON JSONStat{..} = object ("path" .= pathKeyForBlobPair jsonStatBlobs : toJSONFields (these Delete Insert Replace (runJoin jsonStatBlobs))) toEncoding JSONStat{..} = pairs (fold ("path" .= pathKeyForBlobPair jsonStatBlobs : toJSONFields (these Delete Insert Replace (runJoin jsonStatBlobs)))) +newtype JSONError = JSONError { jsonError :: String } + deriving (Eq, Show) -- | Render a term to a value representing its JSON. renderJSONTerm :: ToJSON a => Blob -> a -> JSON "trees" SomeJSON @@ -71,6 +74,11 @@ instance ToJSON a => ToJSON (JSONAST a) where renderSymbolTerms :: ToJSON a => [a] -> JSON "files" SomeJSON renderSymbolTerms = JSON . map SomeJSON +renderJSONError :: Blob -> String -> JSON "trees" SomeJSON +renderJSONError Blob{..} e = JSON [ SomeJSON (object [ "error" .= err ]) ] + where err = object [ "message" .= e + , "path" .= blobPath + , "language" .= blobLanguage ] data SomeJSON where SomeJSON :: ToJSON a => a -> SomeJSON diff --git a/src/Rendering/Renderer.hs b/src/Rendering/Renderer.hs index 423db1aa2..3884a7e9c 100644 --- a/src/Rendering/Renderer.hs +++ b/src/Rendering/Renderer.hs @@ -11,6 +11,7 @@ module Rendering.Renderer , renderSymbolTerms , renderToSymbols , renderTreeGraph +, renderJSONError , Summaries(..) , TOCSummary(..) , SymbolFields(..) diff --git a/src/Semantic/Parse.hs b/src/Semantic/Parse.hs index 998ba8c48..cc678c3d5 100644 --- a/src/Semantic/Parse.hs +++ b/src/Semantic/Parse.hs @@ -10,6 +10,7 @@ module Semantic.Parse import Analysis.ConstructorName (ConstructorName) import Analysis.Declaration (HasDeclaration, declarationAlgebra) import Analysis.PackageDef (HasPackageDef) +import Control.Monad.Effect.Exception import Data.AST import Data.Blob import Data.JSON.Fields @@ -28,12 +29,15 @@ import qualified Language.TypeScript.Assignment as TypeScript import qualified Language.JSON.Assignment as JSON import qualified Language.Python.Assignment as Python +-- import Data.Aeson +-- import qualified Rendering.JSON as J + runParse :: (Member Distribute effs, Member (Exc SomeException) effs, Member Task effs) => TermRenderer output -> [Blob] -> Eff effs Builder -runParse JSONTermRenderer = withParsedBlobs (render . renderJSONTerm) >=> serialize JSON -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")) +runParse JSONTermRenderer = withParsedBlobs renderJSONError (render . renderJSONTerm) >=> serialize JSON +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")) runRubyParse :: (Member Distribute effs, Member Task effs) => [Blob] -> Eff effs [Term (Sum Ruby.Syntax) ()] runRubyParse = flip distributeFor (\ blob -> do @@ -55,8 +59,28 @@ runJSONParse = flip distributeFor (\ blob -> do term <- parse jsonParser blob pure (() <$ term)) -withParsedBlobs :: (Member Distribute effs, Member (Exc SomeException) effs, Member Task effs, Monoid output) => (forall syntax . (ConstructorName syntax, Foldable syntax, Functor syntax, HasDeclaration syntax, HasPackageDef syntax, Show1 syntax, ToJSONFields1 syntax) => Blob -> Term syntax (Record Location) -> Eff 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) + -> ( forall syntax . + ( ConstructorName syntax + , Foldable syntax + , Functor syntax + , HasDeclaration syntax + , HasPackageDef syntax + , Show1 syntax + , ToJSONFields1 syntax + ) => Blob -> Term syntax (Record Location) -> Eff effs output + ) + -> [Blob] + -> Eff effs output +withParsedBlobs onError render = distributeFoldMap $ \blob -> + (parseSomeBlob blob >>= withSomeTerm (render blob)) `catchError` \(SomeException e) -> + pure (onError blob (show e)) parseSomeBlob :: (Member (Exc SomeException) effs, Member Task effs) => Blob -> Eff effs (SomeTerm '[ConstructorName, Foldable, Functor, HasDeclaration, HasPackageDef, Show1, ToJSONFields1] (Record Location)) parseSomeBlob blob@Blob{..} = maybe (noLanguageForBlob blobPath) (`parse` blob) (someParser blobLanguage)