From 28b45b71d8f56783f7082b7e389ce89470aaa288 Mon Sep 17 00:00:00 2001
From: Timothy Clem <timothy.clem@gmail.com>
Date: Wed, 29 Aug 2018 13:41:47 -0700
Subject: [PATCH] WIP - Return partial results from json parse blobs

---
 src/Rendering/JSON.hs     |  8 ++++++++
 src/Rendering/Renderer.hs |  1 +
 src/Semantic/Parse.hs     | 38 +++++++++++++++++++++++++++++++-------
 3 files changed, 40 insertions(+), 7 deletions(-)

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)