From b76812ec91221b979b972fb93220252444cb32a0 Mon Sep 17 00:00:00 2001
From: Rob Rix <rob.rix@me.com>
Date: Mon, 14 May 2018 14:15:28 -0400
Subject: [PATCH] Factor the language-specific parts of diffBlobPair out.

---
 src/Semantic/Diff.hs | 37 ++++++++++++++++++-------------------
 1 file changed, 18 insertions(+), 19 deletions(-)

diff --git a/src/Semantic/Diff.hs b/src/Semantic/Diff.hs
index c9642489c..294d19d54 100644
--- a/src/Semantic/Diff.hs
+++ b/src/Semantic/Diff.hs
@@ -1,9 +1,10 @@
-{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GADTs, ScopedTypeVariables #-}
 module Semantic.Diff where
 
 import Analysis.ConstructorName (ConstructorName, constructorLabel)
 import Analysis.IdentifierName (IdentifierName, identifierLabel)
 import Analysis.Declaration (HasDeclaration, declarationAlgebra)
+import Data.AST
 import Data.Blob
 import Data.Diff
 import Data.JSON.Fields
@@ -25,23 +26,21 @@ diffBlobPairs renderer = distributeFoldMap (WrapTask . diffBlobPair renderer)
 -- | A task to parse a pair of 'Blob's, diff them, and render the 'Diff'.
 diffBlobPair :: Members '[Distribute WrappedTask, Task, Telemetry, Exc SomeException, IO] effs => DiffRenderer output -> BlobPair -> Eff effs output
 diffBlobPair renderer blobs
-  | Just (SomeParser parser) <- someParser @'[ConstructorName, Diffable, Eq1, GAlign, HasDeclaration, IdentifierName, Show1, ToJSONFields1, Traversable] <$> effectiveLanguage
-  = case renderer of
-    ToCDiffRenderer         -> run parser (decorate . declarationAlgebra)                                  >>= render (renderToCDiff blobs)
-    JSONDiffRenderer        -> run parser (const (decorate constructorLabel >=> decorate identifierLabel)) >>= render (renderJSONDiff blobs)
-    SExpressionDiffRenderer -> run parser (const pure)                                                                                       >>= serialize (SExpression ByConstructorName)
-    DOTDiffRenderer         -> run parser (const pure)                                                     >>= render renderTreeGraph        >>= serialize (DOT (diffStyle (pathKeyForBlobPair blobs)))
-  | otherwise = noLanguageForBlob effectivePath
-  where effectivePath = pathForBlobPair blobs
-        effectiveLanguage = languageForBlobPair blobs
-        languageTag = languageTagForBlobPair blobs
+  | Just (SomeParser parser) <- someParser @'[ConstructorName, Diffable, Eq1, GAlign, HasDeclaration, IdentifierName, Show1, ToJSONFields1, Traversable] <$> (languageForBlobPair blobs)
+  = diffBlobPairWithParser renderer blobs parser
+  | otherwise = noLanguageForBlob (pathForBlobPair blobs)
 
-        run :: (Diffable syntax, Eq1 syntax, GAlign syntax, Show1 syntax, Traversable syntax, Members [Distribute WrappedTask, Task, Telemetry, IO] effs)
-            => Parser (Term syntax (Record fields'))
-            -> (Blob -> Term syntax (Record fields') -> TaskEff (Term syntax (Record fields)))
+diffBlobPairWithParser :: forall syntax effs output . (ConstructorName syntax, Diffable syntax, Eq1 syntax, GAlign syntax, HasDeclaration syntax, IdentifierName syntax, Show1 syntax, ToJSONFields1 syntax, Traversable syntax,  Members '[Distribute WrappedTask, Task, Telemetry, Exc SomeException, IO] effs) => DiffRenderer output -> BlobPair -> Parser (Term syntax (Record Location)) -> Eff effs output
+diffBlobPairWithParser renderer blobs parser = case renderer of
+  ToCDiffRenderer         -> parseBlobs (decorate . declarationAlgebra)                                  >>= diffTerms >>= render (renderToCDiff blobs)
+  JSONDiffRenderer        -> parseBlobs (const (decorate constructorLabel >=> decorate identifierLabel)) >>= diffTerms >>= render (renderJSONDiff blobs)
+  SExpressionDiffRenderer -> parseBlobs (const pure)                                                     >>= diffTerms                                   >>= serialize (SExpression ByConstructorName)
+  DOTDiffRenderer         -> parseBlobs (const pure)                                                     >>= diffTerms >>= render renderTreeGraph        >>= serialize (DOT (diffStyle (pathKeyForBlobPair blobs)))
+  where languageTag = languageTagForBlobPair blobs
+        parseBlobs :: (Blob -> Term syntax (Record Location) -> TaskEff (Term syntax (Record fields))) -> Eff effs (Join These (Term syntax (Record fields)))
+        parseBlobs decorate = distributeFor blobs (\ blob -> WrapTask (decorate blob =<< parse parser blob))
+        diffTerms :: Join These (Term syntax (Record fields))
             -> Eff effs (Diff syntax (Record fields) (Record fields))
-        run parser decorate = do
-          terms <- distributeFor blobs (\ blob -> WrapTask (decorate blob =<< parse parser blob))
-          time "diff" languageTag $ do
-            diff <- diff (runJoin terms)
-            diff <$ writeStat (Stat.count "diff.nodes" (bilength diff) languageTag)
+        diffTerms terms = time "diff" languageTag $ do
+          diff <- diff (runJoin terms)
+          diff <$ writeStat (Stat.count "diff.nodes" (bilength diff) languageTag)