Merge remote-tracking branch 'origin/master' into ruby-assignment

2024-11-28 18:23:44 +03:00 · 2017-06-16 15:55:06 -06:00 · 2017-06-16 15:55:06 -06:00 · 0285cf4939
commit 0285cf4939
parent 054e8a07f8 f0103cae10
10 changed files with 117 additions and 112 deletions
--- a/src/Arguments.hs
+++ b/src/Arguments.hs
@ -18,20 +18,6 @@ data DiffArguments where

 deriving instance Show DiffArguments

-type DiffArguments' = DiffMode -> DiffArguments
-
-patchDiff :: DiffArguments'
-patchDiff = DiffArguments PatchDiffRenderer
-
-jsonDiff :: DiffArguments'
-jsonDiff = DiffArguments JSONDiffRenderer
-
-sExpressionDiff :: DiffArguments'
-sExpressionDiff = DiffArguments SExpressionDiffRenderer
-
-tocDiff :: DiffArguments'
-tocDiff = DiffArguments ToCDiffRenderer
-

 data ParseMode = ParseStdin | ParsePaths [(FilePath, Maybe Language)]
  deriving Show
@ -44,13 +30,6 @@ data ParseArguments where

 deriving instance Show ParseArguments

-type ParseArguments' = ParseMode -> ParseArguments
-
-sExpressionParseTree :: ParseArguments'
-sExpressionParseTree = ParseArguments SExpressionTermRenderer
-
-jsonParseTree :: ParseArguments'
-jsonParseTree = ParseArguments JSONTermRenderer

 data ProgramMode = Parse ParseArguments | Diff DiffArguments
  deriving Show
--- a/src/Data/Align/Generic.hs
+++ b/src/Data/Align/Generic.hs
@ -10,38 +10,30 @@ import Prologue

 -- | Functors which can be aligned (structure-unioning-ly zipped). The default implementation will operate generically over the constructors in the aligning type.
 class GAlign f where
-  galign :: f a -> f b -> Maybe (f (These a b))
-  galign = galignWith identity
-
  -- | Perform generic alignment of values of some functor, applying the given function to alignments of elements.
  galignWith :: (These a b -> c) -> f a -> f b -> Maybe (f c)
  default galignWith :: (Generic1 f, GAlign (Rep1 f)) => (These a b -> c) -> f a -> f b -> Maybe (f c)
  galignWith f a b = to1 <$> galignWith f (from1 a) (from1 b)

+galign :: GAlign f => f a -> f b -> Maybe (f (These a b))
+galign = galignWith identity

 -- 'Data.Align.Align' instances

 instance GAlign [] where
-  galign = galignAlign
  galignWith = galignWithAlign
 instance GAlign Maybe where
-  galign = galignAlign
  galignWith = galignWithAlign
 instance GAlign Identity where
  galignWith f (Identity a) (Identity b) = Just (Identity (f (These a b)))

 instance (GAlign f, GAlign (Union fs)) => GAlign (Union (f ': fs)) where
-  galign u1 u2 = case (decompose u1, decompose u2) of
-    (Left u1', Left u2') -> weaken <$> galign u1' u2'
-    (Right r1, Right r2) -> inj <$> galign r1 r2
-    _ -> Nothing
  galignWith f u1 u2 = case (decompose u1, decompose u2) of
    (Left u1', Left u2') -> weaken <$> galignWith f u1' u2'
    (Right r1, Right r2) -> inj <$> galignWith f r1 r2
    _ -> Nothing

 instance GAlign (Union '[]) where
-  galign _ _ = Nothing
  galignWith _ _ _ = Nothing

 -- | Implements a function suitable for use as the definition of 'galign' for 'Align'able functors.
--- a/src/Data/Functor/Classes/Show/Generic.hs
+++ b/src/Data/Functor/Classes/Show/Generic.hs
@ -17,9 +17,9 @@ class GShow1 f where
  -- | showsPrec function for an application of the type constructor based on showsPrec and showList functions for the argument type.
  gliftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS

-  -- | showList function for an application of the type constructor based on showsPrec and showList functions for the argument type. The default implementation using standard list syntax is correct for most types.
-  gliftShowList :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> [f a] -> ShowS
-  gliftShowList sp sl = showListWith (gliftShowsPrec sp sl 0)
+-- | showList function for an application of the type constructor based on showsPrec and showList functions for the argument type. The default implementation using standard list syntax is correct for most types.
+gliftShowList :: GShow1 f => (Int -> a -> ShowS) -> ([a] -> ShowS) -> [f a] -> ShowS
+gliftShowList sp sl = showListWith (gliftShowsPrec sp sl 0)

 -- | A suitable implementation of Show1’s liftShowsPrec for Generic1 types.
 genericLiftShowsPrec :: (Generic1 f, GShow1 (Rep1 f)) => (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
--- a/src/Data/Syntax/Assignment.hs
+++ b/src/Data/Syntax/Assignment.hs
@ -75,8 +75,8 @@ module Data.Syntax.Assignment
 , Result(..)
 , Error(..)
 , ErrorCause(..)
-, showError
-, showExpectation
+, printError
+, withSGRCode
 -- Running
 , assign
 , assignBy
@ -94,7 +94,6 @@ import qualified Data.IntMap.Lazy as IntMap
 import Data.Ix (inRange)
 import Data.List.NonEmpty (nonEmpty)
 import Data.Record
-import Data.String
 import GHC.Stack
 import qualified Info
 import Prologue hiding (Alt, get, Location, state)
@ -103,6 +102,7 @@ import qualified Source (Source(..), drop, slice, sourceText, actualLines)
 import System.Console.ANSI
 import Text.Parser.TreeSitter.Language
 import Text.Show hiding (show)
+import System.IO (hIsTerminalDevice, hPutStr)

 -- | Assignment from an AST with some set of 'symbol's onto some other value.
 --
@ -181,18 +181,28 @@ data ErrorCause grammar
  deriving (Eq, Show)

 -- | Pretty-print an Error with reference to the source where it occurred.
-showError :: Show grammar => Source.Source -> Error grammar -> String
-showError source error@Error{..}
-  = withSGRCode [SetConsoleIntensity BoldIntensity] (showSourcePos Nothing errorPos) . showString ": " . withSGRCode [SetColor Foreground Vivid Red] (showString "error") . showString ": " . showExpectation error . showChar '\n'
-  . showString (toS context) . (if isSuffixOf "\n" context then identity else showChar '\n')
-  . showString (replicate (succ (Info.column errorPos + lineNumberDigits)) ' ') . withSGRCode [SetColor Foreground Vivid Green] (showChar '^') . showChar '\n'
-  . showString (prettyCallStack callStack)
-  $ ""
+printError :: Show grammar => Source.Source -> Error grammar -> IO ()
+printError source error@Error{..}
+  =  do
+    withSGRCode [SetConsoleIntensity BoldIntensity] . putStrErr . (showSourcePos Nothing errorPos) . showString ": " $ ""
+    withSGRCode [SetColor Foreground Vivid Red] . putStrErr . (showString "error") . showString ": " . showExpectation error . showChar '\n' . showString (toS context) . (if isSuffixOf "\n" context then identity else showChar '\n') . showString (replicate (succ (Info.column errorPos + lineNumberDigits)) ' ') $ ""
+    withSGRCode [SetColor Foreground Vivid Green] . putStrErr . (showChar '^') . showChar '\n' . showString (prettyCallStack callStack) $ ""
+
  where context = maybe "\n" (Source.sourceText . sconcat) (nonEmpty [ Source.Source (toS (showLineNumber i)) <> Source.Source ": " <> l | (i, l) <- zip [1..] (Source.actualLines source), inRange (Info.line errorPos - 2, Info.line errorPos) i ])
        showLineNumber n = let s = show n in replicate (lineNumberDigits - length s) ' ' <> s
        lineNumberDigits = succ (floor (logBase 10 (fromIntegral (Info.line errorPos) :: Double)))
-        showSGRCode = showString . setSGRCode
-        withSGRCode code s = showSGRCode code . s . showSGRCode []
+        putStrErr = hPutStr stderr
+
+withSGRCode :: [SGR] -> IO a -> IO ()
+withSGRCode code action = do
+  isTerm <- hIsTerminalDevice stderr
+  if isTerm then do
+    _ <- hSetSGR stderr code
+    _ <- action
+    hSetSGR stderr []
+  else do
+    _ <- action
+    pure ()

 showExpectation :: Show grammar => Error grammar -> ShowS
 showExpectation Error{..} = case errorCause of
--- a/src/Parser.hs
+++ b/src/Parser.hs
@ -26,6 +26,7 @@ import qualified Language.Ruby.Syntax as Ruby
 import Prologue hiding (Location)
 import Source
 import Syntax hiding (Go)
+import System.IO (hPutStrLn)
 import System.Console.ANSI
 import Term
 import qualified Text.Parser.TreeSitter as TS
@ -81,20 +82,18 @@ runParser parser = case parser of
  AssignmentParser parser by assignment -> \ source -> do
    ast <- runParser parser source
    let Result err term = assignBy by assignment source ast
-    traverse_ (putStrLn . showError source) (toList err)
+    traverse_ (printError source) (toList err)
    case term of
      Just term -> do
        let errors = termErrors term `asTypeOf` toList err
-        traverse_ (putStrLn . showError source) errors
-        unless (Prologue.null errors) $
-          putStrLn (withSGRCode [SetConsoleIntensity BoldIntensity, SetColor Foreground Vivid Red] (shows (Prologue.length errors) . showChar ' ' . showString (if Prologue.length errors == 1 then "error" else "errors")) $ "")
+        traverse_ (printError source) errors
+        unless (Prologue.null errors) $ do
+          withSGRCode [SetConsoleIntensity BoldIntensity, SetColor Foreground Vivid Red] . hPutStrLn stderr . (shows (Prologue.length errors) . showChar ' ' . showString (if Prologue.length errors == 1 then "error" else "errors")) $ ""
        pure term
      Nothing -> pure (errorTerm source err)
  TreeSitterParser language tslanguage -> treeSitterParser language tslanguage
  MarkdownParser -> pure . cmarkParser
  LineByLineParser -> lineByLineParser
-  where showSGRCode = showString . setSGRCode
-        withSGRCode code s = showSGRCode code . s . showSGRCode []

 errorTerm :: Syntax.Error (Error grammar) :< fs => Source -> Maybe (Error grammar) -> Term (Union fs) (Record Location)
 errorTerm source err = cofree ((totalRange source :. totalSpan source :. Nil) :< inj (Syntax.Error (fromMaybe (Error (SourcePos 0 0) (UnexpectedEndOfInput [])) err)))
--- a/src/Renderer.hs
+++ b/src/Renderer.hs
@ -7,7 +7,8 @@ module Renderer
 , renderSExpressionTerm
 , renderJSONDiff
 , renderJSONTerm
-, renderToC
+, renderToCDiff
+, renderToCTerm
 , declarationAlgebra
 , markupSectionAlgebra
 , syntaxDeclarationAlgebra
@ -47,6 +48,8 @@ deriving instance Show (DiffRenderer output)

 -- | Specification of renderers for terms, producing output in the parameter type.
 data TermRenderer output where
+  -- | Compute a table of contents for the term & encode it as JSON.
+  ToCTermRenderer :: TermRenderer Summaries
  -- | Render to JSON with the format documented in docs/json-format.md under “Term.”
  JSONTermRenderer :: TermRenderer [Value]
  -- | Render to a 'ByteString' formatted as nested s-expressions.
--- a/src/Renderer/TOC.hs
+++ b/src/Renderer/TOC.hs
@ -1,6 +1,7 @@
 {-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses, RankNTypes, TypeOperators #-}
 module Renderer.TOC
-( renderToC
+( renderToCDiff
+, renderToCTerm
 , diffTOC
 , Summaries(..)
 , JSONSummary(..)
@ -21,6 +22,7 @@ import Data.Align (crosswalk)
 import Data.Functor.Both hiding (fst, snd)
 import qualified Data.Functor.Both as Both
 import Data.Functor.Listable
+import Data.List.NonEmpty (nonEmpty)
 import Data.Proxy
 import Data.Record
 import Data.Text (toLower)
@ -114,12 +116,12 @@ declarationAlgebra proxy source r
  where getSource = toText . flip Source.slice source . byteRange . extract

 -- | Compute 'Declaration's with the headings of 'Markup.Section's.
-markupSectionAlgebra :: (Markup.Section :< fs, Syntax.Error error :< fs, HasField fields Range, Show error, Functor (Union fs))
+markupSectionAlgebra :: (Markup.Section :< fs, Syntax.Error error :< fs, HasField fields Range, Show error, Functor (Union fs), Foldable (Union fs))
                     => Proxy error
                     -> Source
                     -> RAlgebra (TermF (Union fs) (Record fields)) (Term (Union fs) (Record fields)) (Maybe Declaration)
 markupSectionAlgebra proxy source r
-  | Just (Markup.Section (heading, _) _) <- prj (tailF r) = Just $ SectionDeclaration (getSource heading)
+  | Just (Markup.Section (heading, _) _) <- prj (tailF r) = Just $ SectionDeclaration (maybe (getSource heading) (toText . flip Source.slice source . sconcat) (nonEmpty (byteRange . extract <$> toList (unwrap heading))))
  | Just (Syntax.Error err) <- prj (tailF r) = Just $ ErrorDeclaration (show (err `asProxyTypeOf` proxy))
  | otherwise = Nothing
  where getSource = toText . flip Source.slice source . byteRange . extract
@ -140,15 +142,21 @@ tableOfContentsBy :: Traversable f
                  => (forall b. TermF f annotation b -> Maybe a) -- ^ A function mapping relevant nodes onto values in Maybe.
                  -> Diff f annotation                           -- ^ The diff to compute the table of contents for.
                  -> [Entry a]                                   -- ^ A list of entries for relevant changed and unchanged nodes in the diff.
-tableOfContentsBy selector = fromMaybe [] . iter diffAlgebra . fmap (Just . fmap patchEntry . crosswalk (cata termAlgebra))
+tableOfContentsBy selector = fromMaybe [] . iter diffAlgebra . fmap (Just . fmap patchEntry . crosswalk (termTableOfContentsBy selector))
  where diffAlgebra r = case (selector (first Both.snd r), fold r) of
          (Just a, Nothing) -> Just [Unchanged a]
          (Just a, Just []) -> Just [Changed a]
          (_     , entries) -> entries
-        termAlgebra r | Just a <- selector r = [a]
-                      | otherwise = fold r
        patchEntry = these Deleted Inserted (const Replaced) . unPatch

+termTableOfContentsBy :: Traversable f
+                      => (forall b. TermF f annotation b -> Maybe a)
+                      -> Term f annotation
+                      -> [a]
+termTableOfContentsBy selector = cata termAlgebra
+  where termAlgebra r | Just a <- selector r = [a]
+                      | otherwise = fold r
+
 dedupe :: HasField fields (Maybe Declaration) => [Entry (Record fields)] -> [Entry (Record fields)]
 dedupe = foldl' go []
  where go xs x | (_, _:_) <- find (exactMatch `on` entryPayload) x xs = xs
@ -170,13 +178,16 @@ entrySummary entry = case entry of
  Deleted a   -> recordSummary a "removed"
  Inserted a  -> recordSummary a "added"
  Replaced a  -> recordSummary a "modified"
-  where recordSummary record = case getDeclaration record of
+
+-- | Construct a 'JSONSummary' from a node annotation and a change type label.
+recordSummary :: (HasField fields (Maybe Declaration), HasField fields SourceSpan) => Record fields -> Text -> Maybe JSONSummary
+recordSummary record = case getDeclaration record of
  Just (ErrorDeclaration text) -> Just . const (ErrorSummary text (sourceSpan record))
  Just declaration -> Just . JSONSummary (toCategoryName declaration) (declarationIdentifier declaration) (sourceSpan record)
  Nothing -> const Nothing

-renderToC :: (HasField fields (Maybe Declaration), HasField fields SourceSpan, Traversable f) => Both SourceBlob -> Diff f (Record fields) -> Summaries
-renderToC blobs = uncurry Summaries . bimap toMap toMap . List.partition isValidSummary . diffTOC
+renderToCDiff :: (HasField fields (Maybe Declaration), HasField fields SourceSpan, Traversable f) => Both SourceBlob -> Diff f (Record fields) -> Summaries
+renderToCDiff blobs = uncurry Summaries . bimap toMap toMap . List.partition isValidSummary . diffTOC
  where toMap [] = mempty
        toMap as = Map.singleton summaryKey (toJSON <$> as)
        summaryKey = toS $ case runJoin (path <$> blobs) of
@ -185,9 +196,17 @@ renderToC blobs = uncurry Summaries . bimap toMap toMap . List.partition isValid
                          | before == after -> after
                          | otherwise -> before <> " -> " <> after

+renderToCTerm :: (HasField fields (Maybe Declaration), HasField fields SourceSpan, Traversable f) => SourceBlob -> Term f (Record fields) -> Summaries
+renderToCTerm blob = uncurry Summaries . bimap toMap toMap . List.partition isValidSummary . termToC
+  where toMap [] = mempty
+        toMap as = Map.singleton (toS (path blob)) (toJSON <$> as)
+
 diffTOC :: (HasField fields (Maybe Declaration), HasField fields SourceSpan, Traversable f) => Diff f (Record fields) -> [JSONSummary]
 diffTOC = mapMaybe entrySummary . dedupe . tableOfContentsBy declaration

+termToC :: (HasField fields (Maybe Declaration), HasField fields SourceSpan, Traversable f) => Term f (Record fields) -> [JSONSummary]
+termToC = mapMaybe (flip recordSummary "unchanged") . termTableOfContentsBy declaration
+
 -- The user-facing category name
 toCategoryName :: Declaration -> Text
 toCategoryName declaration = case declaration of
--- a/src/Semantic.hs
+++ b/src/Semantic.hs
@ -45,6 +45,9 @@ parseBlobs renderer = fmap toS . distributeFoldMap (parseBlob renderer) . filter
 -- | A task to parse a 'SourceBlob' and render the resulting 'Term'.
 parseBlob :: TermRenderer output -> SourceBlob -> Task output
 parseBlob renderer blob@SourceBlob{..} = case (renderer, blobLanguage) of
+  (ToCTermRenderer, Just Language.Markdown) -> parse markdownParser source >>= decorate (markupSectionAlgebra (Proxy :: Proxy Markdown.Error) source) >>= render (renderToCTerm blob)
+  (ToCTermRenderer, Just Language.Python) -> parse pythonParser source >>= decorate (declarationAlgebra (Proxy :: Proxy Python.Error) source) . hoistCofree (weaken :: Union fs a -> Union (Declaration.Method ': fs) a) >>= render (renderToCTerm blob)
+  (ToCTermRenderer, _) -> parse syntaxParser source >>= decorate (syntaxDeclarationAlgebra source) >>= render (renderToCTerm blob)
  (JSONTermRenderer, Just Language.Markdown) -> parse markdownParser source >>= render (renderJSONTerm blob)
  (JSONTermRenderer, Just Language.Python) -> parse pythonParser source >>= render (renderJSONTerm blob)
  (JSONTermRenderer, _) -> parse syntaxParser source >>= decorate identifierAlgebra >>= render (renderJSONTerm blob)
@ -64,9 +67,9 @@ diffBlobPairs renderer = fmap toS . distributeFoldMap (diffBlobPair renderer) .
 -- | A task to parse a pair of 'SourceBlob's, diff them, and render the 'Diff'.
 diffBlobPair :: DiffRenderer output -> Both SourceBlob -> Task output
 diffBlobPair renderer blobs = case (renderer, effectiveLanguage) of
-  (ToCDiffRenderer, Just Language.Markdown) -> run (\ source -> parse markdownParser source >>= decorate (markupSectionAlgebra (Proxy :: Proxy Markdown.Error) source)) diffLinearly (renderToC blobs)
-  (ToCDiffRenderer, Just Language.Python) -> run (\ source -> parse pythonParser source >>= decorate (declarationAlgebra (Proxy :: Proxy Python.Error) source) . hoistCofree (weaken :: Union fs a -> Union (Declaration.Method ': fs) a)) diffLinearly (renderToC blobs)
-  (ToCDiffRenderer, _) -> run (\ source -> parse syntaxParser source >>= decorate (syntaxDeclarationAlgebra source)) diffTerms (renderToC blobs)
+  (ToCDiffRenderer, Just Language.Markdown) -> run (\ source -> parse markdownParser source >>= decorate (markupSectionAlgebra (Proxy :: Proxy Markdown.Error) source)) diffLinearly (renderToCDiff blobs)
+  (ToCDiffRenderer, Just Language.Python) -> run (\ source -> parse pythonParser source >>= decorate (declarationAlgebra (Proxy :: Proxy Python.Error) source) . hoistCofree (weaken :: Union fs a -> Union (Declaration.Method ': fs) a)) diffLinearly (renderToCDiff blobs)
+  (ToCDiffRenderer, _) -> run (\ source -> parse syntaxParser source >>= decorate (syntaxDeclarationAlgebra source)) diffTerms (renderToCDiff blobs)
  (JSONDiffRenderer, Just Language.Markdown) -> run (parse markdownParser) diffLinearly (renderJSONDiff blobs)
  (JSONDiffRenderer, Just Language.Python) -> run (parse pythonParser) diffLinearly (renderJSONDiff blobs)
  (JSONDiffRenderer, _) -> run (decorate identifierAlgebra <=< parse syntaxParser) diffTerms (renderJSONDiff blobs)
--- a/src/SemanticCmdLine.hs
+++ b/src/SemanticCmdLine.hs
@ -10,6 +10,7 @@ import Data.Version (showVersion)
 import Development.GitRev
 import Options.Applicative hiding (action)
 import Prologue hiding (concurrently, fst, snd, readFile)
+import Renderer
 import qualified Data.ByteString as B
 import qualified Paths_semantic_diff as Library (version)
 import qualified Semantic.Task as Task
@ -61,10 +62,10 @@ arguments = info (version <*> helper <*> argumentsParser) description

    diffCommand = command "diff" (info diffArgumentsParser (progDesc "Show changes between commits or paths"))
    diffArgumentsParser = Diff
-      <$> ( (  flag patchDiff patchDiff (long "patch" <> help "Output a patch(1)-compatible diff (default)")
-           <|> flag' jsonDiff (long "json" <> help "Output a json diff")
-           <|> flag' sExpressionDiff (long "sexpression" <> help "Output an s-expression diff tree")
-           <|> flag' tocDiff (long "toc" <> help "Output a table of contents for a diff") )
+      <$> ( (  flag (DiffArguments PatchDiffRenderer) (DiffArguments PatchDiffRenderer) (long "patch" <> help "Output a patch(1)-compatible diff (default)")
+           <|> flag' (DiffArguments JSONDiffRenderer) (long "json" <> help "Output a json diff")
+           <|> flag' (DiffArguments SExpressionDiffRenderer) (long "sexpression" <> help "Output an s-expression diff tree")
+           <|> flag' (DiffArguments ToCDiffRenderer) (long "toc" <> help "Output a table of contents for a diff") )
         <*> (  DiffPaths
               <$> argument filePathReader (metavar "FILE_A")
               <*> argument filePathReader (metavar "FILE_B")
@ -72,8 +73,9 @@ arguments = info (version <*> helper <*> argumentsParser) description

    parseCommand = command "parse" (info parseArgumentsParser (progDesc "Print parse trees for path(s)"))
    parseArgumentsParser = Parse
-      <$> ( (  flag sExpressionParseTree sExpressionParseTree (long "sexpression" <> help "Output s-expression parse trees (default)")
-           <|> flag' jsonParseTree (long "json" <> help "Output JSON parse trees") )
+      <$> ( (  flag (ParseArguments SExpressionTermRenderer) (ParseArguments SExpressionTermRenderer) (long "sexpression" <> help "Output s-expression parse trees (default)")
+           <|> flag' (ParseArguments JSONTermRenderer) (long "json" <> help "Output JSON parse trees")
+           <|> flag' (ParseArguments ToCTermRenderer) (long "toc" <> help "Output a table of contents for a file"))
         <*> (  ParsePaths
               <$> some (argument filePathReader (metavar "FILES..."))
            <|> pure ParseStdin ))
--- a/test/SemanticCmdLineSpec.hs
+++ b/test/SemanticCmdLineSpec.hs
@ -4,20 +4,22 @@ module SemanticCmdLineSpec where
 import Prologue
 import Arguments
 import Language
+import Renderer
 import SemanticCmdLine
-import Data.Functor.Listable
 import Test.Hspec hiding (shouldBe, shouldNotBe, shouldThrow, errorCall)
 import Test.Hspec.Expectations.Pretty
-import Test.Hspec.LeanCheck

 spec :: Spec
 spec = parallel $ do
-  prop "runDiff for all modes and formats" $
-    \ DiffFixture{..} -> do
+  describe "runDiff" $
+    for_ diffFixtures $ \ (arguments@DiffArguments{..}, expected) ->
+      it ("renders to " <> show diffRenderer <> " in mode " <> show diffMode) $ do
        output <- runDiff arguments
        output `shouldBe'` expected
-  prop "runParse for all modes and formats" $
-    \ ParseFixture{..} -> do
+
+  describe "runParse" $
+    for_ parseFixtures $ \ (arguments@ParseArguments{..}, expected) ->
+      it ("renders to " <> show parseTreeRenderer <> " in mode " <> show parseMode) $ do
        output <- runParse arguments
        output `shouldBe'` expected
  where
@ -25,27 +27,23 @@ spec = parallel $ do
      when (actual /= expected) $ print actual
      actual `shouldBe` expected

-
-data ParseFixture = ParseFixture
-  { arguments :: ParseArguments
-  , expected :: ByteString
-  } deriving (Show)
-
-instance Listable ParseFixture where
-  tiers = cons0 (ParseFixture (sExpressionParseTree pathMode) sExpressionParseTreeOutput)
-       \/ cons0 (ParseFixture (jsonParseTree pathMode) jsonParseTreeOutput)
-       \/ cons0 (ParseFixture (jsonParseTree pathMode') jsonParseTreeOutput')
-       \/ cons0 (ParseFixture (jsonParseTree (ParsePaths [])) emptyJsonParseTreeOutput)
-       \/ cons0 (ParseFixture (jsonParseTree (ParsePaths [("not-a-file.rb", Just Ruby)])) emptyJsonParseTreeOutput)
-
-    where
-      pathMode = ParsePaths [("test/fixtures/ruby/and-or.A.rb", Just Ruby)]
+parseFixtures :: [(ParseArguments, ByteString)]
+parseFixtures =
+  [ (ParseArguments SExpressionTermRenderer pathMode, sExpressionParseTreeOutput)
+  , (ParseArguments JSONTermRenderer pathMode, jsonParseTreeOutput)
+  , (ParseArguments JSONTermRenderer pathMode', jsonParseTreeOutput')
+  , (ParseArguments JSONTermRenderer (ParsePaths []), emptyJsonParseTreeOutput)
+  , (ParseArguments JSONTermRenderer (ParsePaths [("not-a-file.rb", Just Ruby)]), emptyJsonParseTreeOutput)
+  , (ParseArguments ToCTermRenderer (ParsePaths [("test/fixtures/ruby/method-declaration.A.rb", Just Ruby)]), tocOutput)
+  ]
+  where pathMode = ParsePaths [("test/fixtures/ruby/and-or.A.rb", Just Ruby)]
        pathMode' = ParsePaths [("test/fixtures/ruby/and-or.A.rb", Just Ruby), ("test/fixtures/ruby/and-or.B.rb", Just Ruby)]

        sExpressionParseTreeOutput = "(Program\n  (Binary\n    (Identifier)\n    (Other \"and\")\n    (Identifier)))\n"
        jsonParseTreeOutput = "[{\"filePath\":\"test/fixtures/ruby/and-or.A.rb\",\"programNode\":{\"category\":\"Program\",\"children\":[{\"category\":\"Binary\",\"children\":[{\"category\":\"Identifier\",\"children\":[],\"sourceRange\":[0,3],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,4]}},{\"category\":\"and\",\"children\":[],\"sourceRange\":[4,7],\"sourceSpan\":{\"start\":[1,5],\"end\":[1,8]}},{\"category\":\"Identifier\",\"children\":[],\"sourceRange\":[8,11],\"sourceSpan\":{\"start\":[1,9],\"end\":[1,12]}}],\"sourceRange\":[0,11],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,12]}}],\"sourceRange\":[0,12],\"sourceSpan\":{\"start\":[1,1],\"end\":[2,1]}},\"language\":\"Ruby\"}]\n"
        jsonParseTreeOutput' = "[{\"filePath\":\"test/fixtures/ruby/and-or.A.rb\",\"programNode\":{\"category\":\"Program\",\"children\":[{\"category\":\"Binary\",\"children\":[{\"category\":\"Identifier\",\"children\":[],\"sourceRange\":[0,3],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,4]}},{\"category\":\"and\",\"children\":[],\"sourceRange\":[4,7],\"sourceSpan\":{\"start\":[1,5],\"end\":[1,8]}},{\"category\":\"Identifier\",\"children\":[],\"sourceRange\":[8,11],\"sourceSpan\":{\"start\":[1,9],\"end\":[1,12]}}],\"sourceRange\":[0,11],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,12]}}],\"sourceRange\":[0,12],\"sourceSpan\":{\"start\":[1,1],\"end\":[2,1]}},\"language\":\"Ruby\"},{\"filePath\":\"test/fixtures/ruby/and-or.B.rb\",\"programNode\":{\"category\":\"Program\",\"children\":[{\"category\":\"Binary\",\"children\":[{\"category\":\"Identifier\",\"children\":[],\"sourceRange\":[0,3],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,4]}},{\"category\":\"or\",\"children\":[],\"sourceRange\":[4,6],\"sourceSpan\":{\"start\":[1,5],\"end\":[1,7]}},{\"category\":\"Identifier\",\"children\":[],\"sourceRange\":[7,10],\"sourceSpan\":{\"start\":[1,8],\"end\":[1,11]}}],\"sourceRange\":[0,10],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,11]}},{\"category\":\"Binary\",\"children\":[{\"category\":\"Binary\",\"children\":[{\"category\":\"Identifier\",\"children\":[],\"sourceRange\":[11,12],\"sourceSpan\":{\"start\":[2,1],\"end\":[2,2]}},{\"category\":\"or\",\"children\":[],\"sourceRange\":[13,15],\"sourceSpan\":{\"start\":[2,3],\"end\":[2,5]}},{\"category\":\"Identifier\",\"children\":[],\"sourceRange\":[16,17],\"sourceSpan\":{\"start\":[2,6],\"end\":[2,7]}}],\"sourceRange\":[11,17],\"sourceSpan\":{\"start\":[2,1],\"end\":[2,7]}},{\"category\":\"and\",\"children\":[],\"sourceRange\":[18,21],\"sourceSpan\":{\"start\":[2,8],\"end\":[2,11]}},{\"category\":\"Identifier\",\"children\":[],\"sourceRange\":[22,23],\"sourceSpan\":{\"start\":[2,12],\"end\":[2,13]}}],\"sourceRange\":[11,23],\"sourceSpan\":{\"start\":[2,1],\"end\":[2,13]}}],\"sourceRange\":[0,24],\"sourceSpan\":{\"start\":[1,1],\"end\":[3,1]}},\"language\":\"Ruby\"}]\n"
        emptyJsonParseTreeOutput = "[]\n"
+        tocOutput = "{\"changes\":{\"test/fixtures/ruby/method-declaration.A.rb\":[{\"span\":{\"start\":[1,1],\"end\":[2,4]},\"category\":\"Method\",\"term\":\"foo\",\"changeType\":\"unchanged\"}]},\"errors\":{}}\n"


 data DiffFixture = DiffFixture
@ -53,14 +51,14 @@ data DiffFixture = DiffFixture
  , expected :: ByteString
  } deriving (Show)

-instance Listable DiffFixture where
-  tiers = cons0 (DiffFixture (patchDiff pathMode) patchOutput)
-       \/ cons0 (DiffFixture (jsonDiff pathMode) jsonOutput)
-       \/ cons0 (DiffFixture (sExpressionDiff pathMode) sExpressionOutput)
-       \/ cons0 (DiffFixture (tocDiff pathMode) tocOutput)
-
-    where
-      pathMode = DiffPaths ("test/fixtures/ruby/method-declaration.A.rb", Just Ruby) ("test/fixtures/ruby/method-declaration.B.rb", Just Ruby)
+diffFixtures :: [(DiffArguments, ByteString)]
+diffFixtures =
+  [ (DiffArguments PatchDiffRenderer pathMode, patchOutput)
+  , (DiffArguments JSONDiffRenderer pathMode, jsonOutput)
+  , (DiffArguments SExpressionDiffRenderer pathMode, sExpressionOutput)
+  , (DiffArguments ToCDiffRenderer pathMode, tocOutput)
+  ]
+  where pathMode = DiffPaths ("test/fixtures/ruby/method-declaration.A.rb", Just Ruby) ("test/fixtures/ruby/method-declaration.B.rb", Just Ruby)

        patchOutput = "diff --git a/test/fixtures/ruby/method-declaration.A.rb b/test/fixtures/ruby/method-declaration.B.rb\nindex 0000000000000000000000000000000000000000..0000000000000000000000000000000000000000 100644\n--- a/test/fixtures/ruby/method-declaration.A.rb\n+++ b/test/fixtures/ruby/method-declaration.B.rb\n@@ -1,3 +1,4 @@\n-def foo\n+def bar(a)\n+  baz\n end\n\n"