WIP - Return partial results from json parse blobs

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

src/Rendering/Renderer.hs

@@ -11,6 +11,7 @@ module Rendering.Renderer
 , renderSymbolTerms
 , renderToSymbols
 , renderTreeGraph
+, renderJSONError
 , Summaries(..)
 , TOCSummary(..)
 , SymbolFields(..)

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)