Remove render formats and use render/encode functions directly

src/Arguments.hs

@@ -2,48 +2,50 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 module Arguments where
 
+import Command
 import Data.Maybe
-import Prologue hiding ((<>))
 import Prelude
-import qualified Renderer as R
+
 
 data DiffMode = DiffCommits String String [FilePath] | DiffPaths FilePath FilePath
-  deriving (Show)
+  deriving Show
 
 data DiffArguments = DiffArguments
-  { diffFormat :: R.Format
+  { encodeDiff :: DiffEncoder
   , diffMode :: DiffMode
   , gitDir :: FilePath
   , alternateObjectDirs :: [FilePath] }
-  deriving (Show)
 
 data ParseMode = ParseCommit String [FilePath] | ParsePaths [FilePath]
-  deriving (Show)
+  deriving Show
 
 data ParseArguments = ParseArguments
-  { parseFormat :: R.ParseFormat
+  { renderParseTree :: ParseTreeRenderer
   , parseMode :: ParseMode
   , debug :: Bool
   , gitDir :: FilePath
   , alternateObjectDirs :: [FilePath] }
-  deriving (Show)
 
 data ProgramMode = Parse ParseArguments | Diff DiffArguments
-  deriving (Show)
+  deriving Show
 
 data Arguments = Arguments
   { programMode :: ProgramMode
   , outputFilePath :: Maybe FilePath
-  } deriving (Show)
+  } deriving Show
 
--- | Quickly assemble an Arguments data record with defaults.
-args :: FilePath -> String -> String -> [String] -> R.Format -> Arguments
-args gitDir sha1 sha2 paths format = Arguments
-  { programMode = Diff DiffArguments
-      { diffFormat = format
-      , diffMode = DiffCommits sha1 sha2 paths
-      , gitDir = gitDir
-      , alternateObjectDirs = []
-      }
-  , outputFilePath = Nothing
-  }
+
+instance Show DiffArguments where
+  showsPrec d DiffArguments{..} = showParen (d >= 10) $ showString "DiffArguments "
+    . showsPrec 10 (encodeDiff []) . showChar ' '
+    . showsPrec 10 diffMode . showChar ' '
+    . showsPrec 10 gitDir . showChar ' '
+    . showsPrec 10 alternateObjectDirs
+
+instance Show ParseArguments where
+  showsPrec d ParseArguments{..} = showParen (d >= 10) $ showString "ParseArguments "
+    -- . showsPrec 10 (renderParseTree []) . showChar ' '
+    . showsPrec 10 parseMode . showChar ' '
+    . showsPrec 10 debug . showChar ' '
+    . showsPrec 10 gitDir . showChar ' '
+    . showsPrec 10 alternateObjectDirs

src/Command.hs

@@ -10,6 +10,14 @@ module Command
 , maybeDiff
 , renderDiffs
 , concurrently
+, patch
+, split
+, json
+, summary
+, sExpression
+, toc
+, DiffEncoder
+, ParseTreeRenderer
 -- Evaluation
 , runCommand
 ) where
@@ -20,15 +28,15 @@ import Control.Exception (catch)
 import Control.Monad.Free.Freer
 import Control.Monad.IO.Class
 import Control.Parallel.Strategies
+import Data.Aeson hiding (json)
 import qualified Data.ByteString as B
 import Data.Functor.Both
+import Data.Functor.Classes
 import Data.List ((\\), nub)
 import Data.RandomWalkSimilarity
 import Data.Record
 import Data.String
 import Diff
-import Info
-import Interpreter
 import GHC.Conc (numCapabilities)
 import qualified Git
 import Git.Blob
@@ -37,14 +45,19 @@ import Git.Libgit2.Backend
 import Git.Repository
 import Git.Types
 import GitmonClient
+import Info
+import Interpreter
 import Language
 import Patch
 import Prologue hiding (concurrently, Concurrently, readFile)
+import qualified Renderer as R
+import qualified Renderer.SExpression as R
 import Renderer
 import Source
 import Syntax
 import System.FilePath
 import Term
+import Text.Show
 
 
 -- | High-level commands encapsulating the work done to perform a diff or parse operation.
@@ -188,5 +201,47 @@ runRenderDiffs :: Monoid output => DiffRenderer fields output -> [(Both SourceBl
 runRenderDiffs = runDiffRenderer
 
 
+type DiffEncoder = [(Both SourceBlob, Diff (Syntax Text) (Record DefaultFields))] -> Command ByteString
+
+patch :: DiffEncoder
+patch = fmap encodeText . renderDiffs R.PatchRenderer
+
+split :: DiffEncoder
+split = fmap encodeText . renderDiffs R.SplitRenderer
+
+json :: DiffEncoder
+json = fmap encodeJSON . renderDiffs R.JSONDiffRenderer
+
+summary :: DiffEncoder
+summary = fmap encodeSummaries . renderDiffs R.SummaryRenderer
+
+sExpression :: DiffEncoder
+sExpression = renderDiffs (R.SExpressionDiffRenderer R.TreeOnly)
+
+toc :: DiffEncoder
+toc = fmap encodeSummaries . renderDiffs R.ToCRenderer
+
+encodeJSON :: Map Text Value -> ByteString
+encodeJSON = toS . (<> "\n") . encode
+
+encodeText :: File -> ByteString
+encodeText = encodeUtf8 . R.unFile
+
+encodeSummaries :: Summaries -> ByteString
+encodeSummaries = toS . (<> "\n") . encode
+
+
 instance MonadIO Command where
   liftIO io = LiftIO io `Then` return
+
+instance Show1 CommandF where
+  liftShowsPrec sp sl d command = case command of
+    ReadFile path -> showsUnaryWith showsPrec "ReadFile" d path
+    ReadFilesAtSHAs gitDir alternates paths shas -> showsQuaternaryWith showsPrec showsPrec showsPrec showsPrec "ReadFilesAtSHAs" d gitDir alternates paths shas
+      where showsQuaternaryWith sp1 sp2 sp3 sp4 name d x y z w = showParen (d > 10) $
+              showString name . showChar ' ' . sp1 11 x . showChar ' ' . sp2 11 y . showChar ' ' . sp3 11 z . showChar ' ' . sp4 11 w
+    Parse language _ -> showsBinaryWith showsPrec (const showChar) "Parse" d language '_'
+    Diff _ -> showsUnaryWith (const showChar) "Diff" d '_'
+    RenderDiffs renderer _ -> showsBinaryWith showsPrec (const showChar) "RenderDiffs" d renderer '_'
+    Concurrently commands f -> showsBinaryWith (liftShowsPrec sp sl) (const showChar) "Concurrently" d (traverse f commands) '_'
+    LiftIO _ -> showsUnaryWith (const showChar) "LiftIO" d '_'

src/Command/Parse.hs

@@ -31,6 +31,8 @@ import Text.Parser.TreeSitter.JavaScript
 import Text.Parser.TreeSitter.Ruby
 import Text.Parser.TreeSitter.TypeScript
 
+type ParseTreeRenderer = Bool -> [SourceBlob] -> IO ByteString
+
 data ParseTreeFile = ParseTreeFile { parseTreeFilePath :: FilePath, node :: Rose ParseNode } deriving (Show)
 
 data Rose a = Rose a [Rose a]
@@ -64,8 +66,8 @@ parseNodeToJSONFields ParseNode{..} =
   <> [ "identifier" .= identifier | isJust identifier ]
 
 -- | Parses file contents into an SExpression format for the provided arguments.
-parseSExpression :: [SourceBlob] -> IO ByteString
-parseSExpression blobs =
+parseSExpression :: Bool -> [SourceBlob] -> IO ByteString
+parseSExpression _ blobs =
   pure . printTerms TreeOnly =<< parse blobs
   where parse = traverse (\sourceBlob@SourceBlob{..} -> parserForType (toS (takeExtension path)) sourceBlob)
 

src/Renderer.hs

@@ -2,16 +2,15 @@
 module Renderer
 ( DiffRenderer(..)
 , runDiffRenderer
-, Format(..)
-, ParseFormat(..)
 , Summaries(..)
 , File(..)
 ) where
 
 import Data.Aeson (ToJSON, Value)
 import Data.Functor.Both
+import Data.Functor.Classes
+import Text.Show
 import Data.Map as Map hiding (null)
-import Data.Functor.Listable
 import Data.Record
 import Diff
 import Info
@@ -33,6 +32,7 @@ data DiffRenderer fields output where
   SExpressionDiffRenderer :: (HasField fields Category, HasField fields SourceSpan) => SExpressionFormat -> DiffRenderer fields ByteString
   ToCRenderer :: HasDefaultFields fields => DiffRenderer fields Summaries
 
+
 runDiffRenderer :: Monoid output => DiffRenderer fields output -> [(Both SourceBlob, Diff (Syntax Text) (Record fields))] -> output
 runDiffRenderer renderer = foldMap . uncurry $ case renderer of
   SplitRenderer -> (File .) . R.split
@@ -42,29 +42,17 @@ runDiffRenderer renderer = foldMap . uncurry $ case renderer of
   SExpressionDiffRenderer format -> R.sExpression format
   ToCRenderer -> R.toc
 
--- | The available types of diff rendering.
-data Format = Split | Patch | JSON | Summary | SExpression | TOC
-  deriving (Show)
-
-data ParseFormat = JSONTree | JSONIndex | SExpressionTree
-  deriving (Show)
-
 newtype File = File { unFile :: Text }
   deriving Show
 
+instance Show (DiffRenderer fields output) where
+  showsPrec _ SplitRenderer = showString "SplitRenderer"
+  showsPrec _ PatchRenderer = showString "PatchRenderer"
+  showsPrec _ JSONDiffRenderer = showString "JSONDiffRenderer"
+  showsPrec _ SummaryRenderer = showString "SummaryRenderer"
+  showsPrec d (SExpressionDiffRenderer format) = showsUnaryWith showsPrec "SExpressionDiffRenderer" d format
+  showsPrec _ ToCRenderer = showString "ToCRenderer"
+
 instance Monoid File where
   mempty = File mempty
   mappend (File a) (File b) = File (a <> "\n" <> b)
-
-instance Listable Format where
-  tiers = cons0 Split
-       \/ cons0 Patch
-       \/ cons0 JSON
-       \/ cons0 Summary
-       \/ cons0 SExpression
-       \/ cons0 TOC
-
-instance Listable ParseFormat where
-  tiers = cons0 JSONTree
-       \/ cons0 JSONIndex
-       \/ cons0 SExpressionTree

src/Renderer/SExpression.hs

@@ -15,6 +15,7 @@ import Syntax
 import Term
 
 data SExpressionFormat = TreeOnly | TreeAndRanges
+  deriving (Show)
 
 sExpression :: (HasField fields Category, HasField fields SourceSpan) => SExpressionFormat -> Both SourceBlob -> Diff (Syntax Text) (Record fields) -> ByteString
 sExpression format _ diff = printDiff diff 0 format

src/SemanticDiff.hs

@@ -2,9 +2,8 @@
 module SemanticDiff (main) where
 
 import Arguments
-import Command
+import Command hiding (diff, parse)
 import Command.Parse
-import Data.Aeson
 import Data.Functor.Both
 import Data.List.Split (splitWhen)
 import Data.String
@@ -14,8 +13,6 @@ import Options.Applicative hiding (action)
 import Prologue hiding (concurrently, fst, snd, readFile)
 import qualified Data.ByteString as B
 import qualified Paths_semantic_diff as Library (version)
-import qualified Renderer as R
-import qualified Renderer.SExpression as R
 import Source
 import System.Directory
 import System.Environment
@@ -28,49 +25,13 @@ main = do
   gitDir <- findGitDir
   alternates <- findAlternates
   Arguments{..} <- customExecParser (prefs showHelpOnEmpty) (arguments gitDir alternates)
-  text <- case programMode of
-
-    Diff DiffArguments{..} -> runCommand $ do
-      let render = case diffFormat of
-            R.Split -> fmap encodeText . renderDiffs R.SplitRenderer
-            R.Patch -> fmap encodeText . renderDiffs R.PatchRenderer
-            R.JSON -> fmap encodeJSON . renderDiffs R.JSONDiffRenderer
-            R.Summary -> fmap encodeSummaries . renderDiffs R.SummaryRenderer
-            R.SExpression -> renderDiffs (R.SExpressionDiffRenderer R.TreeOnly)
-            R.TOC -> fmap encodeSummaries . renderDiffs R.ToCRenderer
-      diffs <- case diffMode of
-        DiffPaths pathA pathB -> do
-          let paths = both pathA pathB
-          blobs <- traverse readFile paths
-          terms <- traverse (traverse parseBlob) blobs
-          diff' <- maybeDiff terms
-          pure [(fromMaybe . emptySourceBlob <$> paths <*> blobs, diff')]
-        DiffCommits sha1 sha2 paths -> do
-          blobPairs <- readFilesAtSHAs gitDir alternateObjectDirs paths (both sha1 sha2)
-          concurrently blobPairs . uncurry $ \ path blobs -> do
-            terms <- concurrently blobs (traverse parseBlob)
-            diff' <- maybeDiff terms
-            pure (fromMaybe <$> pure (emptySourceBlob path) <*> blobs, diff')
-      render (diffs >>= \ (blobs, diff) -> (,) blobs <$> toList diff)
-
-    Parse ParseArguments{..} -> do
-      let renderTree = case parseFormat of
-            R.JSONTree -> parseTree debug
-            R.JSONIndex -> parseIndex debug
-            R.SExpressionTree -> parseSExpression
-      blobs <- case parseMode of
-        ParseCommit sha paths -> sourceBlobsFromSha sha gitDir paths
-        ParsePaths paths -> sourceBlobsFromPaths paths
-      renderTree blobs
-
   outputPath <- getOutputPath outputFilePath
+  text <- case programMode of
+    Diff args -> diff args
+    Parse args -> parse args
   writeToOutput outputPath text
 
   where
-    encodeText = encodeUtf8 . R.unFile
-    encodeJSON = toS . (<> "\n") . encode
-    encodeSummaries = toS . (<> "\n") . encode
-
     findGitDir = do
       pwd <- getCurrentDirectory
       fromMaybe pwd <$> lookupEnv "GIT_DIR"
@@ -89,6 +50,30 @@ main = do
     writeToOutput :: Maybe FilePath -> ByteString -> IO ()
     writeToOutput = maybe B.putStr B.writeFile
 
+diff :: DiffArguments -> IO ByteString
+diff DiffArguments{..} = runCommand $ do
+  diffs <- case diffMode of
+    DiffPaths pathA pathB -> do
+      let paths = both pathA pathB
+      blobs <- traverse readFile paths
+      terms <- traverse (traverse parseBlob) blobs
+      diff' <- maybeDiff terms
+      pure [(fromMaybe . emptySourceBlob <$> paths <*> blobs, diff')]
+    DiffCommits sha1 sha2 paths -> do
+      blobPairs <- readFilesAtSHAs gitDir alternateObjectDirs paths (both sha1 sha2)
+      concurrently blobPairs . uncurry $ \ path blobs -> do
+        terms <- concurrently blobs (traverse parseBlob)
+        diff' <- maybeDiff terms
+        pure (fromMaybe <$> pure (emptySourceBlob path) <*> blobs, diff')
+  encodeDiff (diffs >>= \ (blobs, diff) -> (,) blobs <$> toList diff)
+
+parse :: ParseArguments -> IO ByteString
+parse ParseArguments{..} = do
+  blobs <- case parseMode of
+    ParseCommit sha paths -> sourceBlobsFromSha sha gitDir paths
+    ParsePaths paths -> sourceBlobsFromPaths paths
+  renderParseTree debug blobs
+
 -- | A parser for the application's command-line arguments.
 arguments :: FilePath -> [FilePath] -> ParserInfo Arguments
 arguments gitDir alternates = info (version <*> helper <*> argumentsParser) description
@@ -105,12 +90,12 @@ arguments gitDir alternates = info (version <*> helper <*> argumentsParser) desc
     diffCommand = command "diff" (info diffArgumentsParser (progDesc "Show changes between commits or paths"))
     diffArgumentsParser = Diff
       <$> ( DiffArguments
-            <$> (  flag R.Patch R.Patch (long "patch" <> help "Output a patch(1)-compatible diff (default)")
-               <|> flag' R.JSON (long "json" <> help "Output a json diff")
-               <|> flag' R.Split (long "split" <> help "Output a split diff")
-               <|> flag' R.Summary (long "summary" <> help "Output a diff summary")
-               <|> flag' R.SExpression (long "sexpression" <> help "Output an s-expression diff tree")
-               <|> flag' R.TOC (long "toc" <> help "Output a table of contents diff summary") )
+            <$> (  flag patch patch (long "patch" <> help "Output a patch(1)-compatible diff (default)")
+               <|> flag' split (long "split" <> help "Output a split diff")
+               <|> flag' json (long "json" <> help "Output a json diff")
+               <|> flag' summary (long "summary" <> help "Output a diff summary")
+               <|> flag' sExpression (long "sexpression" <> help "Output an s-expression diff tree")
+               <|> flag' toc (long "toc" <> help "Output a table of contents diff summary") )
             <*> (  DiffPaths
                   <$> argument str (metavar "FILE_A")
                   <*> argument str (metavar "FILE_B")
@@ -124,9 +109,9 @@ arguments gitDir alternates = info (version <*> helper <*> argumentsParser) desc
     parseCommand = command "parse" (info parseArgumentsParser (progDesc "Print parse trees for a commit or paths"))
     parseArgumentsParser = Parse
       <$> ( ParseArguments
-            <$> (  flag R.SExpressionTree R.SExpressionTree (long "sexpression" <> help "Output s-expression parse trees (default)")
-               <|> flag' R.JSONTree (long "json" <> help "Output JSON parse trees")
-               <|> flag' R.JSONIndex (long "index" <> help "Output JSON parse trees in index format") )
+            <$> (  flag parseSExpression parseSExpression (long "sexpression" <> help "Output s-expression parse trees (default)")
+               <|> flag' parseTree (long "json" <> help "Output JSON parse trees")
+               <|> flag' parseIndex (long "index" <> help "Output JSON parse trees in index format") )
             <*> (  ParsePaths
                   <$> some (argument str (metavar "FILES..."))
                <|> ParseCommit

test/Command/Parse/Spec.hs

@@ -10,7 +10,7 @@ spec :: Spec
 spec = parallel . context "parse" $ do
     let blobs = sourceBlobsFromPaths ["test/fixtures/ruby/and-or.A.rb"]
     it "should produce s-expression trees" $ do
-      output <- parseSExpression =<< blobs
+      output <- parseSExpression False =<< blobs
       output `shouldNotBe` ""
     it "should produce JSON trees" $ do
       output <- parseTree False =<< blobs