Move runDiff into Semantic.Diff.

src/Rendering/Renderer.hs

@@ -38,7 +38,7 @@ data DiffRenderer output where
   -- | Render to a 'ByteString' formatted as nested s-expressions with patches indicated.
   SExpressionDiffRenderer :: DiffRenderer Builder
   -- | Render to a 'ByteString' formatted as a DOT description of the diff.
-  DOTDiffRenderer :: DiffRenderer Builder
+  DOTDiffRenderer :: DiffRenderer (Graph (Vertex DiffTag))
 
 deriving instance Eq (DiffRenderer output)
 deriving instance Show (DiffRenderer output)

src/Semantic/CLI.hs

@@ -2,16 +2,14 @@
 module Semantic.CLI
 ( main
 -- Testing
-, runDiff
+, Diff.runDiff
 , Parse.runParse
 ) where
 
-import           Data.ByteString.Builder
 import           Data.File
 import           Data.Language (Language)
 import           Data.List (intercalate)
 import           Data.List.Split (splitWhen)
-import           Data.Output
 import           Data.Version (showVersion)
 import           Development.GitRev
 import           Options.Applicative hiding (style)
@@ -31,9 +29,6 @@ import           Text.Read
 main :: IO ()
 main = customExecParser (prefs showHelpOnEmpty) arguments >>= uncurry Task.runTaskWithOptions
 
-runDiff :: SomeRenderer DiffRenderer -> Either (Handle 'IO.ReadMode) [Both File] -> Task.TaskEff Builder
-runDiff (SomeRenderer diffRenderer) = fmap toOutput . Diff.diffBlobPairs diffRenderer <=< Task.readBlobPairs
-
 runGraph :: Semantic.GraphType -> Maybe FilePath -> FilePath -> Language -> [FilePath] -> Task.TaskEff (Graph Vertex)
 runGraph graphType rootDir dir excludeDirs = Semantic.graph graphType <=< Task.readProject rootDir dir excludeDirs
 
@@ -62,12 +57,12 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar
 
     diffCommand = command "diff" (info diffArgumentsParser (progDesc "Compute changes between paths"))
     diffArgumentsParser = do
-      renderer <- flag  (SomeRenderer SExpressionDiffRenderer) (SomeRenderer SExpressionDiffRenderer) (long "sexpression" <> help "Output s-expression diff tree (default)")
-              <|> flag'                                        (SomeRenderer JSONDiffRenderer)        (long "json"        <> help "Output JSON diff trees")
-              <|> flag'                                        (SomeRenderer ToCDiffRenderer)         (long "toc"         <> help "Output JSON table of contents diff summary")
-              <|> flag'                                        (SomeRenderer DOTDiffRenderer)         (long "dot"         <> help "Output the diff as a DOT graph")
+      renderer <- flag  (Diff.runDiff SExpressionDiffRenderer) (Diff.runDiff SExpressionDiffRenderer) (long "sexpression" <> help "Output s-expression diff tree (default)")
+              <|> flag'                                        (Diff.runDiff JSONDiffRenderer)        (long "json"        <> help "Output JSON diff trees")
+              <|> flag'                                        (Diff.runDiff ToCDiffRenderer)         (long "toc"         <> help "Output JSON table of contents diff summary")
+              <|> flag'                                        (Diff.runDiff DOTDiffRenderer)         (long "dot"         <> help "Output the diff as a DOT graph")
       filesOrStdin <- Right <$> some (both <$> argument filePathReader (metavar "FILE_A") <*> argument filePathReader (metavar "FILE_B")) <|> pure (Left stdin)
-      pure $ runDiff renderer filesOrStdin
+      pure $ Task.readBlobPairs filesOrStdin >>= renderer
 
     parseCommand = command "parse" (info parseArgumentsParser (progDesc "Generate parse trees for path(s)"))
     parseArgumentsParser = do

src/Semantic/Diff.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE GADTs, ScopedTypeVariables #-}
+{-# LANGUAGE GADTs, RankNTypes, ScopedTypeVariables #-}
 module Semantic.Diff where
 
 import Analysis.ConstructorName (ConstructorName, constructorLabel)
@@ -20,27 +20,36 @@ import Semantic.Stat as Stat
 import Semantic.Task as Task
 import Serializing.Format
 
-diffBlobPairs :: (Members '[Distribute WrappedTask, Task, Telemetry, Exc SomeException, IO] effs, Monoid output) => DiffRenderer output -> [BlobPair] -> Eff effs output
-diffBlobPairs renderer = distributeFoldMap (WrapTask . diffBlobPair renderer)
+runDiff :: Members '[Distribute WrappedTask, Task, Telemetry, Exc SomeException, IO] effs => DiffRenderer output -> [BlobPair] -> Eff effs Builder
+runDiff ToCDiffRenderer         = withParsedBlobPairs (decorate . declarationAlgebra) (render . renderToCDiff) >=> serialize JSON
+runDiff JSONDiffRenderer        = withParsedBlobPairs (const (decorate constructorLabel >=> decorate identifierLabel)) (render . renderJSONDiff) >=> serialize JSON
+runDiff SExpressionDiffRenderer = withParsedBlobPairs (const pure) (const (serialize (SExpression ByConstructorName)))
+runDiff DOTDiffRenderer         = withParsedBlobPairs (const pure) (const (render renderTreeGraph)) >=> serialize (DOT (diffStyle "diffs"))
 
--- | 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] <$> languageForBlobPair blobs
-  = diffBlobPairWithParser renderer blobs parser
-  | otherwise = noLanguageForBlob (pathForBlobPair blobs)
+data SomeTermPair typeclasses ann where
+  SomeTermPair :: ApplyAll typeclasses syntax => Join These (Term syntax ann) -> SomeTermPair typeclasses ann
 
-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)))
+withSomeTermPair :: (forall syntax . ApplyAll typeclasses syntax => Join These (Term syntax ann) -> a) -> SomeTermPair typeclasses ann -> a
+withSomeTermPair with (SomeTermPair terms) = with terms
+
+withParsedBlobPairs :: (Members '[Distribute WrappedTask, Exc SomeException, IO, Task, Telemetry] effs, Monoid output)
+                    => (forall syntax . (ConstructorName syntax, Diffable syntax, Eq1 syntax, GAlign syntax, HasDeclaration syntax, IdentifierName syntax, Show1 syntax, ToJSONFields1 syntax, Traversable syntax) => Blob -> Term syntax (Record Location) -> TaskEff (Term syntax (Record fields)))
+                    -> (forall syntax . (ConstructorName syntax, Diffable syntax, Eq1 syntax, GAlign syntax, HasDeclaration syntax, IdentifierName syntax, Show1 syntax, ToJSONFields1 syntax, Traversable syntax) => BlobPair -> Diff syntax (Record fields) (Record fields) -> TaskEff output)
+                    -> [BlobPair]
+                    -> Eff effs output
+withParsedBlobPairs decorate render = distributeFoldMap (\ blobs -> WrapTask (withParsedBlobPair decorate blobs >>= withSomeTermPair (diffTerms blobs >=> render blobs)))
+
+diffTerms :: (Diffable syntax, Eq1 syntax, GAlign syntax, Show1 syntax, Traversable syntax, Members '[IO, Task, Telemetry] effs) => BlobPair -> Join These (Term syntax (Record fields)) -> Eff effs (Diff syntax (Record fields) (Record fields))
+diffTerms blobs terms = time "diff" languageTag $ do
+  diff <- diff (runJoin terms)
+  diff <$ writeStat (Stat.count "diff.nodes" (bilength diff) languageTag)
   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))
-        diffTerms terms = time "diff" languageTag $ do
-          diff <- diff (runJoin terms)
-          diff <$ writeStat (Stat.count "diff.nodes" (bilength diff) languageTag)
+
+withParsedBlobPair :: Members '[Distribute WrappedTask, Exc SomeException, Task] effs
+                   => (forall syntax . (ConstructorName syntax, Diffable syntax, Eq1 syntax, GAlign syntax, HasDeclaration syntax, IdentifierName syntax, Show1 syntax, ToJSONFields1 syntax, Traversable syntax) => Blob -> Term syntax (Record Location) -> TaskEff (Term syntax (Record fields)))
+                   -> BlobPair
+                   -> Eff effs (SomeTermPair '[ConstructorName, Diffable, Eq1, GAlign, HasDeclaration, IdentifierName, Show1, ToJSONFields1, Traversable] (Record fields))
+withParsedBlobPair decorate blobs
+  | Just (SomeParser parser) <- someParser @'[ConstructorName, Diffable, Eq1, GAlign, HasDeclaration, IdentifierName, Show1, ToJSONFields1, Traversable] <$> languageForBlobPair blobs
+  = SomeTermPair <$> distributeFor blobs (\ blob -> WrapTask (parse parser blob >>= decorate blob))
+  | otherwise = noLanguageForBlob (pathForBlobPair blobs)