Catch errors for some diff outputs

src/Rendering/JSON.hs

@@ -8,6 +8,7 @@ module Rendering.JSON
 , renderJSONAST
 , renderSymbolTerms
 , renderJSONError
+, renderJSONDiffError
 , SomeJSON(..)
 ) where
 
@@ -99,6 +100,10 @@ renderJSONError Blob{..} e = JSON [ SomeJSON (object [ "error" .= err ]) ]
                      , "path" .= blobPath
                      , "language" .= blobLanguage ]
 
+renderJSONDiffError :: BlobPair -> String -> JSON "diffs" SomeJSON
+renderJSONDiffError pair e = JSON [ SomeJSON (object [ "error" .= err ]) ]
+  where err = object ["message" .= e, "info" .= toJSON (JSONStat pair)]
+
 data SomeJSON where
   SomeJSON :: ToJSON a => a -> SomeJSON
 

src/Rendering/Renderer.hs

@@ -14,6 +14,8 @@ module Rendering.Renderer
 , renderToSymbols
 , renderTreeGraph
 , renderJSONError
+, renderJSONDiffError
+, renderJSONSummaryError
 , Summaries(..)
 , TOCSummary(..)
 , SymbolFields(..)

src/Rendering/TOC.hs

@@ -3,6 +3,7 @@ module Rendering.TOC
 ( renderToCDiff
 , renderRPCToCDiff
 , renderToCTerm
+, renderJSONSummaryError
 , diffTOC
 , Summaries(..)
 , TOCSummary(..)
@@ -31,6 +32,10 @@ import Data.Location
 import Data.Term
 import qualified Data.Text as T
 
+renderJSONSummaryError :: BlobPair -> String -> Summaries
+renderJSONSummaryError pair e = Summaries mempty (Map.singleton "msg" [toJSON e]) -- JSON [ SomeJSON (object [ "error" .= err ]) ]
+  -- where err = object ["message" .= e, "info" .= toJSON (JSONStat pair)]
+
 data Summaries = Summaries { changes, errors :: !(Map.Map T.Text [Value]) }
   deriving (Eq, Show)
 

src/Semantic/Diff.hs

@@ -4,30 +4,31 @@ module Semantic.Diff
   , diffBlobTOCPairs
   ) where
 
-import Analysis.ConstructorName (ConstructorName)
-import Analysis.TOCSummary (HasDeclaration, declarationAlgebra)
-import Control.Effect
-import Control.Monad.IO.Class
-import Data.Blob
-import Data.Diff
-import Data.JSON.Fields
-import Data.Location
-import Data.Term
-import Data.Graph.DiffVertex
-import Diffing.Algorithm (Diffable)
-import Parsing.Parser
-import Prologue
-import Rendering.Graph
-import Rendering.Renderer
-import Semantic.Telemetry as Stat
-import Semantic.Task as Task
-import Serializing.Format
-import Rendering.JSON (SomeJSON (..))
+import           Analysis.ConstructorName (ConstructorName)
+import           Analysis.TOCSummary (HasDeclaration, declarationAlgebra)
+import           Control.Effect
+import           Control.Effect.Error
+import           Control.Monad.IO.Class
+import           Data.Blob
+import           Data.Diff
+import           Data.Graph.DiffVertex
+import           Data.JSON.Fields
+import           Data.Location
+import           Data.Term
+import           Diffing.Algorithm (Diffable)
+import           Parsing.Parser
+import           Prologue
+import           Rendering.Graph
+import           Rendering.JSON (SomeJSON (..))
 import qualified Rendering.JSON as JSON
+import           Rendering.Renderer
+import           Semantic.Task as Task
+import           Semantic.Telemetry as Stat
+import           Serializing.Format
 
 -- | Using the specified renderer, diff a list of 'BlobPair's to produce a 'Builder' output.
 runDiff :: (Member Distribute sig, Member (Error SomeException) sig, Member Task sig, Member Telemetry sig, MonadIO m, Carrier sig m) => DiffRenderer output -> [BlobPair] -> m Builder
-runDiff ToCDiffRenderer         = withParsedBlobPairs (decorate . declarationAlgebra) (render . renderToCDiff) >=> serialize JSON
+runDiff ToCDiffRenderer         = withParsedBlobPairs' renderJSONSummaryError (decorate . declarationAlgebra) (render . renderToCDiff) >=> serialize JSON
 runDiff JSONDiffRenderer        = withParsedBlobPairs (const pure) (render . renderJSONDiff) >=> serialize JSON
 runDiff JSONGraphDiffRenderer   = withParsedBlobPairs (const pure) (render . renderAdjGraph) >=> serialize JSON
   where renderAdjGraph :: (Recursive t, ToTreeGraph DiffVertex (Base t)) => BlobPair -> t -> JSON.JSON "diffs" SomeJSON
@@ -48,6 +49,19 @@ diffBlobTOCPairs = withParsedBlobPairs (decorate . declarationAlgebra) (render .
 type CanDiff syntax = (ConstructorName syntax, Diffable syntax, Eq1 syntax, HasDeclaration syntax, Hashable1 syntax, Show1 syntax, ToJSONFields1 syntax, Traversable syntax)
 type Decorate m a b = forall syntax . CanDiff syntax => Blob -> Term syntax a -> m (Term syntax b)
 
+withParsedBlobPairs' :: (Member Distribute sig, Member (Error SomeException) sig, Member Task sig, Member Telemetry sig, MonadIO m, Monoid output, Carrier sig m)
+                    => (BlobPair -> String -> output)
+                    -> Decorate m Location ann
+                    -> (forall syntax . CanDiff syntax => BlobPair -> Diff syntax ann ann -> m output)
+                    -> [BlobPair]
+                    -> m output
+withParsedBlobPairs' onError decorate render = distributeFoldMap (\ blobs -> (withParsedBlobPair decorate blobs >>= withSomeTermPair (diffTerms blobs >=> render blobs)) `catchError` \(SomeException e) -> pure (onError blobs (show e)))
+  where diffTerms :: (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax, Member Task sig, Member Telemetry sig, Carrier sig m, MonadIO m) => BlobPair -> Join These (Term syntax ann) -> m (Diff syntax ann ann)
+        diffTerms blobs terms = time "diff" languageTag $ do
+          diff <- diff (runJoin terms)
+          diff <$ writeStat (Stat.count "diff.nodes" (bilength diff) languageTag)
+          where languageTag = languageTagForBlobPair blobs
+
 withParsedBlobPairs :: (Member Distribute sig, Member (Error SomeException) sig, Member Task sig, Member Telemetry sig, MonadIO m, Monoid output, Carrier sig m)
                     => Decorate m Location ann
                     -> (forall syntax . CanDiff syntax => BlobPair -> Diff syntax ann ann -> m output)