Display diffs in the checking mode

Also improve the way the diffs are printed.

CHANGELOG.md

@@ -7,6 +7,10 @@
   it wasn't strictly necessary. [Issue
   668](https://github.com/tweag/ormolu/issues/688).
 
+* Now the checking mode displays diffs per file when unformatted files are
+  found. The rendering of the diffs is also improved. [Issue
+  656](https://github.com/tweag/ormolu/issues/656).
+
 ## Ormolu 0.1.3.1
 
 * Fixed a problem with multiline record updates using the record dot

app/Main.hs

@@ -6,16 +6,16 @@
 
 module Main (main) where
 
-import Control.Exception (SomeException, displayException, try)
 import Control.Monad
 import Data.Bool (bool)
-import Data.Either (lefts)
 import Data.List (intercalate, sort)
+import Data.Maybe (mapMaybe)
 import qualified Data.Text.IO as TIO
 import Data.Version (showVersion)
 import Development.GitRev
 import Options.Applicative
 import Ormolu
+import Ormolu.Diff.Text (diffText, printTextDiff)
 import Ormolu.Parser (manualExts)
 import Ormolu.Utils (showOutputable)
 import Paths_ormolu (version)
@@ -24,21 +24,28 @@ import System.IO (hPutStrLn, stderr)
 
 -- | Entry point of the program.
 main :: IO ()
-main = withPrettyOrmoluExceptions $ do
+main = do
   Opts {..} <- execParser optsParserInfo
   let formatOne' = formatOne optMode optConfig
-  case optInputFiles of
+  exitCode <- case optInputFiles of
     [] -> formatOne' Nothing
     ["-"] -> formatOne' Nothing
     [x] -> formatOne' (Just x)
     xs -> do
-      -- It is possible to get IOException, error's and 'OrmoluException's
-      -- from 'formatOne', so we just catch everything.
-      errs <-
-        lefts <$> mapM (try @SomeException . formatOne' . Just) (sort xs)
-      unless (null errs) $ do
-        mapM_ (hPutStrLn stderr . displayException) errs
-        exitWith (ExitFailure 102)
+      let selectFailure = \case
+            ExitSuccess -> Nothing
+            ExitFailure n -> Just n
+      errorCodes <-
+        mapMaybe selectFailure <$> mapM (formatOne' . Just) (sort xs)
+      return $
+        if null errorCodes
+          then ExitSuccess
+          else
+            ExitFailure $
+              if all (== 100) errorCodes
+                then 100
+                else 102
+  exitWith exitCode
 
 -- | Format a single input.
 formatOne ::
@@ -48,36 +55,44 @@ formatOne ::
   Config RegionIndices ->
   -- | File to format or stdin as 'Nothing'
   Maybe FilePath ->
-  IO ()
-formatOne mode config = \case
-  Nothing -> do
-    r <- ormoluStdin config
-    case mode of
-      Stdout -> TIO.putStr r
-      _ -> do
-        hPutStrLn
-          stderr
-          "This feature is not supported when input comes from stdin."
-        -- 101 is different from all the other exit codes we already use.
-        exitWith (ExitFailure 101)
-  Just inputFile -> do
-    originalInput <- TIO.readFile inputFile
-    formattedInput <- ormoluFile config inputFile
-    case mode of
-      Stdout ->
-        TIO.putStr formattedInput
-      InPlace -> do
-        -- Only write when the contents have changed, in order to avoid
-        -- updating the modified timestamp if the file was already correctly
-        -- formatted.
-        when (formattedInput /= originalInput) $
-          TIO.writeFile inputFile formattedInput
-      Check -> do
-        when (formattedInput /= originalInput) $
-          -- 100 is different to all the other exit code that are emitted
-          -- either from an 'OrmoluException' or from 'error' and
-          -- 'notImplemented'.
-          exitWith (ExitFailure 100)
+  IO ExitCode
+formatOne mode config mpath = withPrettyOrmoluExceptions $
+  case mpath of
+    Nothing -> do
+      r <- ormoluStdin config
+      case mode of
+        Stdout -> do
+          TIO.putStr r
+          return ExitSuccess
+        _ -> do
+          hPutStrLn
+            stderr
+            "This feature is not supported when input comes from stdin."
+          -- 101 is different from all the other exit codes we already use.
+          return (ExitFailure 101)
+    Just inputFile -> do
+      originalInput <- TIO.readFile inputFile
+      formattedInput <- ormoluFile config inputFile
+      case mode of
+        Stdout -> do
+          TIO.putStr formattedInput
+          return ExitSuccess
+        InPlace -> do
+          -- Only write when the contents have changed, in order to avoid
+          -- updating the modified timestamp if the file was already correctly
+          -- formatted.
+          when (formattedInput /= originalInput) $
+            TIO.writeFile inputFile formattedInput
+          return ExitSuccess
+        Check ->
+          case diffText originalInput formattedInput inputFile of
+            Nothing -> return ExitSuccess
+            Just diff -> do
+              printTextDiff stderr diff
+              -- 100 is different to all the other exit code that are emitted
+              -- either from an 'OrmoluException' or from 'error' and
+              -- 'notImplemented'.
+              return (ExitFailure 100)
 
 ----------------------------------------------------------------------------
 -- Command line options parsing.

data/diff-tests/inputs/main-and-bar-v2.hs

@@ -0,0 +1,11 @@
+module Main (main) where
+
+main :: IO ()
+main = pure ()
+
+foo :: Int
+foo =
+  5
+
+bar :: Int
+bar = 7

data/diff-tests/inputs/main-and-bar.hs

@@ -0,0 +1,11 @@
+module Main (main) where
+
+main :: IO ()
+main = return ()
+
+foo :: Int
+foo =
+  5
+
+bar :: Int
+bar = 6

data/diff-tests/inputs/main-and-baz-v2.hs

@@ -0,0 +1,12 @@
+module Main (main) where
+
+main :: IO ()
+main = pure ()
+
+foo :: Int
+foo =
+  5
+   + 5
+
+bar :: Int
+bar = 7

data/diff-tests/inputs/main-and-baz.hs

@@ -0,0 +1,12 @@
+module Main (main) where
+
+main :: IO ()
+main = return ()
+
+foo :: Int
+foo =
+  5
+   + 5
+
+bar :: Int
+bar = 6

data/diff-tests/inputs/main-and-foo-v2.hs

@@ -0,0 +1,7 @@
+module Main (main) where
+
+main :: IO ()
+main = pure ()
+
+foo :: Int
+foo = 5

data/diff-tests/inputs/main-and-foo.hs

@@ -0,0 +1,7 @@
+module Main (main) where
+
+main :: IO ()
+main = return ()
+
+foo :: Int
+foo = 5

data/diff-tests/inputs/main-foo.hs

@@ -0,0 +1,4 @@
+module Main (foo) where
+
+main :: IO ()
+main = return ()

data/diff-tests/inputs/main-v2.hs

@@ -0,0 +1,4 @@
+module Main (main) where
+
+main :: IO ()
+main = pure ()

data/diff-tests/inputs/main.hs

@@ -0,0 +1,4 @@
+module Main (main) where
+
+main :: IO ()
+main = return ()

data/diff-tests/inputs/one-line.hs

@@ -0,0 +1 @@
+module Main (main) where

data/diff-tests/inputs/spaced-v2.hs

@@ -0,0 +1,16 @@
+module Main (main) where
+
+
+
+
+
+main :: IO ()
+main = pure ()
+
+
+
+
+
+
+foo :: Int
+foo = 5

data/diff-tests/inputs/spaced.hs

@@ -0,0 +1,16 @@
+module Main (main) where
+
+
+
+
+
+main :: IO ()
+main = return ()
+
+
+
+
+
+
+foo :: Int
+foo = 5

data/diff-tests/outputs/joined-hunk.txt

@@ -0,0 +1,15 @@
+TEST
+@@ -1,11 +1,11 @@
+  module Main (main) where
+
+  main :: IO ()
+- main = return ()
++ main = pure ()
+
+  foo :: Int
+  foo =
+    5
+
+  bar :: Int
+- bar = 6
++ bar = 7

data/diff-tests/outputs/no-following.txt

@@ -0,0 +1,7 @@
+TEST
+@@ -1,4 +1,4 @@
+  module Main (main) where
+
+  main :: IO ()
+- main = return ()
++ main = pure ()

data/diff-tests/outputs/no-preceding.txt

@@ -0,0 +1,7 @@
+TEST
+@@ -1,4 +1,4 @@
+- module Main (foo) where
++ module Main (main) where
+
+  main :: IO ()
+  main = return ()

data/diff-tests/outputs/one-line-added.txt

@@ -0,0 +1,3 @@
+TEST
+@@ -1,0 +1,1 @@
++ module Main (main) where

data/diff-tests/outputs/one-line-removed.txt

@@ -0,0 +1,3 @@
+TEST
+@@ -1,1 +1,0 @@
+- module Main (main) where

data/diff-tests/outputs/simple-hunk.txt

@@ -0,0 +1,10 @@
+TEST
+@@ -1,7 +1,7 @@
+  module Main (main) where
+
+  main :: IO ()
+- main = return ()
++ main = pure ()
+
+  foo :: Int
+  foo = 5

data/diff-tests/outputs/trimming.txt

@@ -0,0 +1,5 @@
+TEST
+@@ -7,2 +7,2 @@
+  main :: IO ()
+- main = return ()
++ main = pure ()

data/diff-tests/outputs/two-hunks.txt

@@ -0,0 +1,16 @@
+TEST
+@@ -1,7 +1,7 @@
+  module Main (main) where
+
+  main :: IO ()
+- main = return ()
++ main = pure ()
+
+  foo :: Int
+  foo =
+@@ -9,4 +9,4 @@
+     + 5
+
+  bar :: Int
+- bar = 6
++ bar = 7

expected-failures/Agda.txt

@@ -1,11 +1,46 @@
 Formatting is not idempotent:
-  dist/build/Agda/Syntax/Parser/Lexer.hs<rendered>:1602:17
-  before: "         = (check_ac"
-  after:  "         =\n         "
+
+./dist/build/Agda/Syntax/Parser/Lexer.hs
+@@ -1600,7 +1600,8 @@
+  alex_scan_tkn user__ orig_input len input__ s last_acc =
+    input__
+      `seq` let new_acc -- strict in the input
+-                 = (check_accs (alex_accept `quickIndex` (I# (s))))
++                 =
++                 (check_accs (alex_accept `quickIndex` (I# (s))))
+             in new_acc
+                  `seq` case alexGetByte input__ of
+                    Nothing -> (new_acc, input__)
+
 Please, consider reporting the bug.
 
 Formatting is not idempotent:
-  src/full/Agda/Syntax/Translation/InternalToAbstract.hs<rendered>:769:4
-  before: " nes\n\n              "
-  after:  " nes\n\n    -- Andreas"
+
+./src/full/Agda/Syntax/Translation/InternalToAbstract.hs
+@@ -767,16 +767,16 @@
+                  let hd = List.foldl' (A.App defaultAppInfo_) hd0 pad
+                  nelims hd =<< reify nes
+
+-                 -- Andreas, 2016-07-06 Issue #2047
++     -- Andreas, 2016-07-06 Issue #2047
+
+-                 -- With parameter refinement, the "parameter" patterns of an extended
+-                 -- lambda can now be different from variable patterns.  If we just drop
+-                 -- them (plus the associated arguments to the extended lambda), we produce
+-                 -- something
++     -- With parameter refinement, the "parameter" patterns of an extended
++     -- lambda can now be different from variable patterns.  If we just drop
++     -- them (plus the associated arguments to the extended lambda), we produce
++     -- something
+
+-                 --   dbPatPerm from the patterns to the telescope can no longer be
+-                 --   computed.  (And in fact, dropping from the start of the telescope is
+-                 --   just plainly unsound then.)
++     --   dbPatPerm from the patterns to the telescope can no longer be
++     --   computed.  (And in fact, dropping from the start of the telescope is
++     --   just plainly unsound then.)
+
+      -- What we do now, is more sound, although not entirely satisfying:
+      -- When the "parameter" patterns of an external lambdas are not variable
+
 Please, consider reporting the bug.

expected-failures/hlint.txt

@@ -1,11 +1,35 @@
 Formatting is not idempotent:
-  src/Extension.hs<rendered>:19:22
-  before: "DoRec , -} Recursive"
-  after:  "DoRec , -}\n         "
+
+./src/Extension.hs
+@@ -17,7 +17,8 @@
+           UnboxedTuples,
+           UnboxedSums, -- breaks (#) lens operator
+           QuasiQuotes, -- breaks [x| ...], making whitespace free list comps break
+-          {- DoRec , -} RecursiveDo -- breaks rec
++          {- DoRec , -}
++          RecursiveDo -- breaks rec
+         ]
+
+  reallyBadExtensions =
+
 Please, consider reporting the bug.
 
 Formatting is not idempotent:
-  src/Hint/Bracket.hs<rendered>:249:50
-  before: "\" x y [r]) {ideaSpan"
-  after:  "\" x y [r])\n         "
+
+./src/Hint/Bracket.hs
+@@ -247,8 +247,11 @@
+                 let y = noLoc $ HsApp noExtField a1 (noLoc (HsPar noExtField a2)),
+                 let r = Replace Expr (toSS e) [("a", toSS a1), ("b", toSS a2)] "a (b)"
+             ]
+-         ++ [ (suggest "Redundant bracket" x y [r]) {ideaSpan -- Special case of (v1 . v2) <$> v3
+-                                                     = locPar}
++         ++ [ (suggest "Redundant bracket" x y [r])
++                { ideaSpan -- Special case of (v1 . v2) <$> v3
++                  =
++                    locPar
++                }
+               | L _ (OpApp _ (L locPar (HsPar _ o1@(L locNoPar (OpApp _ v1 (isDot -> True) v2)))) o2 v3) <- [x],
+                 varToStr o2 == "<$>",
+                 let y = noLoc (OpApp noExtField o1 o2 v3) :: LHsExpr GhcPs,
+
 Please, consider reporting the bug.

expected-failures/intero.txt

@@ -1,5 +1,14 @@
 Formatting is not idempotent:
-  src/InteractiveUI.hs<rendered>:3748:33
-  before: "text \"Try\" <+> doWha"
-  after:  "text \"Try\"\n         "
+
+./src/InteractiveUI.hs
+@@ -3746,6 +3746,7 @@
+                  stdout
+                  ( text "Unable to list source for"
+                      <+> ppr pan
+-                     $$ text "Try" <+> doWhat
++                     $$ text "Try"
++                     <+> doWhat
+                  )
+  listCmd' str = list2 (words str)
+
 Please, consider reporting the bug.

expected-failures/leksah.txt

@@ -1,5 +1,17 @@
 Formatting is not idempotent:
-  src/IDE/Pane/Modules.hs<rendered>:1184:7
-  before: "cr\n          -- show"
-  after:  "cr\n       in -- show"
+
+./src/IDE/Pane/Modules.hs
+@@ -1182,9 +1182,9 @@
+        let modId = mdModuleId modDescr
+            modName = modu modId
+            mFilePath = mdMbSourcePath modDescr
+-           -- show relative file path for Main modules
++        in -- show relative file path for Main modules
+            -- since we can have several
+-        in case (components modName, mFilePath) of
++           case (components modName, mFilePath) of
+              (["Main"], Just fp) ->
+                let sfp = case (pdMbSourcePath (snd pair)) of
+                      Nothing -> fp
+
 Please, consider reporting the bug.

expected-failures/pandoc.txt

@@ -3,7 +3,17 @@ The GHC parser (in Haddock mode) failed:
   parse error on input `import'
 
 Formatting is not idempotent:
-  src/Text/Pandoc/Readers/Vimwiki.hs<rendered>:617:19
-  before: ".softbreak <$ endlin"
-  after:  ".softbreak\n    <$ en"
+
+./src/Text/Pandoc/Readers/Vimwiki.hs
+@@ -615,7 +615,8 @@
+      <$ ( skipMany1 spaceChar
+             <|> try (newline >> (comment <|> placeholder))
+         )
+-     <|> B.softbreak <$ endline
++     <|> B.softbreak
++     <$ endline
+
+  whitespace' :: PandocMonad m => VwParser m Inlines
+  whitespace' = B.space <$ skipMany1 spaceChar
+
 Please, consider reporting the bug.

expected-failures/postgrest.txt

@@ -1,5 +1,48 @@
 Formatting is not idempotent:
-  src/PostgREST/DbRequestBuilder.hs<rendered>:149:24
-  before: "       || -- clients"
-  after:  "       || ( origin ="
+
+./src/PostgREST/DbRequestBuilder.hs
+@@ -147,12 +147,11 @@
+                     -- /projects?select=clients(*)
+                     origin == tableName relTable
+                       && target == tableName relFTable -- projects
+-                      || -- clients
++                      || ( origin == tableName relTable -- clients
+                       -- /projects?select=projects_client_id_fkey(*)
+-                      ( origin == tableName relTable
+-                          && Just target == relConstraint -- projects
+-                          -- projects_client_id_fkey
+-                      )
++                             && Just target == relConstraint -- projects
++                             -- projects_client_id_fkey
++                         )
+                       ||
+                       -- /projects?select=client_id(*)
+                       ( origin == tableName relTable
+@@ -161,19 +160,16 @@
+                       )
+                   )
+                && ( isNothing hint
+-                      || -- hint is optional
++                      || hint == relConstraint -- hint is optional
+                       -- /projects?select=clients!projects_client_id_fkey(*)
+-                      hint == relConstraint
+-                      || -- projects_client_id_fkey
++                      || matchFKSingleCol hint relColumns -- projects_client_id_fkey
+                       -- /projects?select=clients!client_id(*) or /projects?select=clients!id(*)
+-                      matchFKSingleCol hint relColumns
+                       || matchFKSingleCol hint relFColumns -- client_id
+-                      || -- id
++                      || ( relType == M2M -- id
+                       -- /users?select=tasks!users_tasks(*)
+-                      ( relType == M2M
+-                          && hint == (tableName . junTable <$> relJunction) -- many-to-many between users and tasks
+-                          -- users_tasks
+-                      )
++                             && hint == (tableName . junTable <$> relJunction) -- many-to-many between users and tasks
++                             -- users_tasks
++                         )
+                   )
+          )
+          allRels
+
 Please, consider reporting the bug.

ormolu.cabal

@@ -48,6 +48,8 @@ data-files:
     data/examples/import/*.hs
     data/examples/module-header/*.hs
     data/examples/other/*.hs
+    data/diff-tests/inputs/*.hs
+    data/diff-tests/outputs/*.txt
 
 extra-doc-files:
     CONTRIBUTING.md
@@ -68,7 +70,8 @@ library
     exposed-modules:
         Ormolu
         Ormolu.Config
-        Ormolu.Diff
+        Ormolu.Diff.ParseResult
+        Ormolu.Diff.Text
         Ormolu.Exception
         Ormolu.Imports
         Ormolu.Parser
@@ -116,6 +119,8 @@ library
 
     default-language: Haskell2010
     build-depends:
+        Diff >=0.4 && <1.0,
+        ansi-terminal >=0.10 && <1.0,
         base >=4.12 && <5.0,
         bytestring >=0.2 && <0.11,
         containers >=0.5 && <0.7,
@@ -163,6 +168,7 @@ test-suite tests
     build-tools:      hspec-discover >=2.0 && <3.0
     hs-source-dirs:   tests
     other-modules:
+        Ormolu.Diff.TextSpec
         Ormolu.Parser.PragmaSpec
         Ormolu.PrinterSpec
 

src/Ormolu.hs

@@ -22,7 +22,8 @@ import Data.Text (Text)
 import qualified Data.Text as T
 import Debug.Trace
 import Ormolu.Config
-import Ormolu.Diff
+import Ormolu.Diff.ParseResult
+import Ormolu.Diff.Text
 import Ormolu.Exception
 import Ormolu.Parser
 import Ormolu.Parser.Result
@@ -64,14 +65,13 @@ ormolu cfgWithIndices path str = do
   -- lead to error messages presenting the exceptions as GHC bugs.
   let !txt = printModule result0
   when (not (cfgUnsafe cfg) || cfgCheckIdempotence cfg) $ do
-    let pathRendered = path ++ "<rendered>"
     -- Parse the result of pretty-printing again and make sure that AST
     -- is the same as AST of original snippet module span positions.
     (_, result1) <-
       parseModule'
         cfg
         OrmoluOutputParsingFailed
-        pathRendered
+        path
         (T.unpack txt)
     unless (cfgUnsafe cfg) $
       case diffParseResult result0 result1 of
@@ -81,11 +81,11 @@ ormolu cfgWithIndices path str = do
     -- the same output.
     when (cfgCheckIdempotence cfg) $
       let txt2 = printModule result1
-       in case diffText txt txt2 pathRendered of
+       in case diffText txt txt2 path of
             Nothing -> return ()
-            Just (loc, l, r) ->
+            Just diff ->
               liftIO $
-                throwIO (OrmoluNonIdempotentOutput loc l r)
+                throwIO (OrmoluNonIdempotentOutput diff)
   return txt
 
 -- | Load a file and format it. The file stays intact and the rendered

src/Ormolu/Diff/ParseResult.hs

@@ -1,18 +1,17 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
 
--- | Diffing GHC ASTs modulo span positions.
-module Ormolu.Diff
-  ( Diff (..),
+-- | This module allows us to diff two 'ParseResult's.
+module Ormolu.Diff.ParseResult
+  ( ParseResultDiff (..),
     diffParseResult,
-    diffText,
   )
 where
 
 import Data.ByteString (ByteString)
 import Data.Generics
-import Data.Text (Text)
-import qualified Data.Text as T
-import qualified FastString as GHC
 import GHC
 import Ormolu.Imports (normalizeImports)
 import Ormolu.Parser.CommentStream
@@ -20,22 +19,25 @@ import Ormolu.Parser.Result
 import Ormolu.Utils
 
 -- | Result of comparing two 'ParseResult's.
-data Diff
+data ParseResultDiff
   = -- | Two parse results are the same
     Same
   | -- | Two parse results differ
     Different [SrcSpan]
 
-instance Semigroup Diff where
+instance Semigroup ParseResultDiff where
   Same <> a = a
   a <> Same = a
   Different xs <> Different ys = Different (xs ++ ys)
 
-instance Monoid Diff where
+instance Monoid ParseResultDiff where
   mempty = Same
 
 -- | Return 'Diff' of two 'ParseResult's.
-diffParseResult :: ParseResult -> ParseResult -> Diff
+diffParseResult ::
+  ParseResult ->
+  ParseResult ->
+  ParseResultDiff
 diffParseResult
   ParseResult
     { prCommentStream = cstream0,
@@ -52,10 +54,10 @@ diffParseResult
 
 -- | Compare two values for equality disregarding differences in 'SrcSpan's
 -- and the ordering of import lists.
-matchIgnoringSrcSpans :: Data a => a -> a -> Diff
+matchIgnoringSrcSpans :: Data a => a -> a -> ParseResultDiff
 matchIgnoringSrcSpans = genericQuery
   where
-    genericQuery :: GenericQ (GenericQ Diff)
+    genericQuery :: GenericQ (GenericQ ParseResultDiff)
     genericQuery x y
       -- 'ByteString' implements 'Data' instance manually and does not
       -- implement 'toConstr', so we have to deal with it in a special way.
@@ -79,9 +81,9 @@ matchIgnoringSrcSpans = genericQuery
             x
             y
       | otherwise = Different []
-    srcSpanEq :: SrcSpan -> GenericQ Diff
+    srcSpanEq :: SrcSpan -> GenericQ ParseResultDiff
     srcSpanEq _ _ = Same
-    commentEq :: Comment -> GenericQ Diff
+    commentEq :: Comment -> GenericQ ParseResultDiff
     commentEq (Comment _ x) d =
       case cast d :: Maybe Comment of
         Nothing -> Different []
@@ -89,16 +91,18 @@ matchIgnoringSrcSpans = genericQuery
           if x == y
             then Same
             else Different []
-    sourceTextEq :: SourceText -> GenericQ Diff
+    sourceTextEq :: SourceText -> GenericQ ParseResultDiff
     sourceTextEq _ _ = Same
-    importDeclQualifiedStyleEq :: ImportDeclQualifiedStyle -> GenericQ Diff
+    importDeclQualifiedStyleEq ::
+      ImportDeclQualifiedStyle ->
+      GenericQ ParseResultDiff
     importDeclQualifiedStyleEq d0 d1' =
       case (d0, cast d1' :: Maybe ImportDeclQualifiedStyle) of
         (x, Just x') | x == x' -> Same
         (QualifiedPre, Just QualifiedPost) -> Same
         (QualifiedPost, Just QualifiedPre) -> Same
         _ -> Different []
-    hsDocStringEq :: HsDocString -> GenericQ Diff
+    hsDocStringEq :: HsDocString -> GenericQ ParseResultDiff
     hsDocStringEq str0 str1' =
       case cast str1' :: Maybe HsDocString of
         Nothing -> Different []
@@ -109,50 +113,12 @@ matchIgnoringSrcSpans = genericQuery
     forLocated ::
       (Data e0, Data e1) =>
       GenLocated e0 e1 ->
-      GenericQ Diff
+      GenericQ ParseResultDiff
     forLocated x@(L mspn _) y =
       maybe id appendSpan (cast mspn) (genericQuery x y)
-    appendSpan :: SrcSpan -> Diff -> Diff
+    appendSpan :: SrcSpan -> ParseResultDiff -> ParseResultDiff
     appendSpan s (Different ss) | fresh && helpful = Different (s : ss)
       where
         fresh = not $ any (`isSubspanOf` s) ss
         helpful = isGoodSrcSpan s
     appendSpan _ d = d
-
--- | Diff two texts and return the location they start to differ, alongside
--- with excerpts around that location.
-diffText ::
-  -- | Text before
-  Text ->
-  -- | Text after
-  Text ->
-  -- | Path to use to construct 'GHC.RealSrcLoc'
-  FilePath ->
-  Maybe (GHC.RealSrcLoc, Text, Text)
-diffText left right fp =
-  case go (0, 0, 0) left right of
-    Nothing -> Nothing
-    Just (row, col, loc) ->
-      Just
-        ( GHC.mkRealSrcLoc (GHC.mkFastString fp) row col,
-          getSpan loc left,
-          getSpan loc right
-        )
-  where
-    go (row, col, loc) t1 t2 =
-      case (T.uncons t1, T.uncons t2) of
-        -- both text empty, all good
-        (Nothing, Nothing) ->
-          Nothing
-        -- first chars are the same, adjust position and recurse
-        (Just (c1, r1), Just (c2, r2))
-          | c1 == c2 ->
-            let (row', col', loc') =
-                  if c1 == '\n'
-                    then (row + 1, 0, loc + 1)
-                    else (row, col + 1, loc + 1)
-             in go (row', col', loc') r1 r2
-        -- something is different, return the position
-        _ ->
-          Just (row, col, loc)
-    getSpan loc = T.take 20 . T.drop (loc - 10)

src/Ormolu/Diff/Text.hs

@@ -0,0 +1,318 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
+
+-- | This module allows us to diff two 'Text' values.
+module Ormolu.Diff.Text
+  ( TextDiff,
+    diffText,
+    printTextDiff,
+  )
+where
+
+import Control.Monad
+import qualified Data.Algorithm.Diff as D
+import Data.Maybe (listToMaybe)
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.IO as T
+import System.Console.ANSI
+import System.IO
+
+----------------------------------------------------------------------------
+-- Types
+
+-- | Result of diffing two 'Text's.
+data TextDiff = TextDiff FilePath DiffList
+  deriving (Eq)
+
+instance Show TextDiff where
+  show (TextDiff path _) = "TextDiff " ++ show path ++ " _"
+
+-- | List of lines tagged by 'D.Both', 'D.First', or 'D.Second'.
+type DiffList = [D.Diff [Text]]
+
+-- | Similar to 'DiffList', but with line numbers assigned.
+type DiffList' = [D.Diff [(Int, Int, Text)]]
+
+-- | Diff hunk.
+data Hunk = Hunk
+  { hunkFirstStartLine :: Int,
+    hunkFirstLength :: Int,
+    hunkSecondStartLine :: Int,
+    hunkSecondLength :: Int,
+    hunkDiff :: DiffList
+  }
+
+----------------------------------------------------------------------------
+-- API
+
+-- | Diff two texts and produce a 'TextDiff'.
+diffText ::
+  -- | Text before
+  Text ->
+  -- | Text after
+  Text ->
+  -- | Path to use
+  FilePath ->
+  -- | The resulting diff or 'Nothing' if the inputs are identical
+  Maybe TextDiff
+diffText a b path =
+  if all isBoth xs
+    then Nothing
+    else Just (TextDiff path xs)
+  where
+    xs = D.getGroupedDiff (T.lines a) (T.lines b)
+    isBoth = \case
+      D.Both _ _ -> True
+      D.First _ -> False
+      D.Second _ -> False
+
+-- | Print the given 'TextDiff' to 'Handle'. This function tries to mimic
+-- the style of @git diff@.
+printTextDiff :: Handle -> TextDiff -> IO ()
+printTextDiff h (TextDiff path xs) = do
+  supports <- hSupportsANSI h
+  let bold m =
+        if supports
+          then do
+            hSetSGR h [SetConsoleIntensity BoldIntensity]
+            m
+            hSetSGR h [Reset]
+          else m
+      cyan m =
+        if supports
+          then do
+            hSetSGR h [SetColor Foreground Dull Cyan]
+            m
+            hSetSGR h [Reset]
+          else m
+      green m =
+        if supports
+          then do
+            hSetSGR h [SetColor Foreground Dull Green]
+            m
+            hSetSGR h [Reset]
+          else m
+      red m =
+        if supports
+          then do
+            hSetSGR h [SetColor Foreground Dull Red]
+            m
+            hSetSGR h [Reset]
+          else m
+      put = T.hPutStr h
+      newline = hPutStr h "\n"
+  (bold . put . T.pack) path
+  newline
+  forM_ (toHunks (assignLines xs)) $ \Hunk {..} -> do
+    cyan $ do
+      put "@@ -"
+      put (T.pack $ show hunkFirstStartLine)
+      put ","
+      put (T.pack $ show hunkFirstLength)
+      put " +"
+      put (T.pack $ show hunkSecondStartLine)
+      put ","
+      put (T.pack $ show hunkSecondLength)
+      put " @@"
+    newline
+    forM_ hunkDiff $ \case
+      D.Both ys _ ->
+        forM_ ys $ \y -> do
+          unless (T.null y) $
+            put "  "
+          put y
+          newline
+      D.First ys ->
+        forM_ ys $ \y -> red $ do
+          put "-"
+          unless (T.null y) $
+            put " "
+          put y
+          newline
+      D.Second ys ->
+        forM_ ys $ \y -> green $ do
+          put "+"
+          unless (T.null y) $
+            put " "
+          put y
+          newline
+  hFlush h
+
+----------------------------------------------------------------------------
+-- Helpers
+
+-- | Assign lines to a 'DiffList'.
+assignLines :: DiffList -> DiffList'
+assignLines = go 1 1 id
+  where
+    go _ _ acc [] = acc []
+    go !firstLine !secondLine acc (x : xs) =
+      case x of
+        D.Both a b ->
+          let firstInc = length a
+              secondInc = length b
+              a' =
+                zipWith3
+                  (,,)
+                  (iterate (+ 1) firstLine)
+                  (iterate (+ 1) secondLine)
+                  a
+           in go
+                (firstLine + firstInc)
+                (secondLine + secondInc)
+                (acc . ((D.Both a' a') :))
+                xs
+        D.First a ->
+          let firstInc = length a
+              a' =
+                zipWith3
+                  (,,)
+                  (iterate (+ 1) firstLine)
+                  (repeat secondLine)
+                  a
+           in go
+                (firstLine + firstInc)
+                secondLine
+                (acc . ((D.First a') :))
+                xs
+        D.Second b ->
+          let secondInc = length b
+              b' =
+                zipWith3
+                  (,,)
+                  (repeat firstLine)
+                  (iterate (+ 1) secondLine)
+                  b
+           in go
+                firstLine
+                (secondLine + secondInc)
+                (acc . ((D.Second b') :))
+                xs
+
+-- | Form 'Hunk's from a 'DiffList''.
+toHunks :: DiffList' -> [Hunk]
+toHunks = go 0 False id id []
+  where
+    -- How many lines of context (that is, lines present in both texts) to
+    -- show per hunk.
+    margin = 3
+    go ::
+      Int ->
+      Bool ->
+      ([Hunk] -> [Hunk]) ->
+      (DiffList' -> DiffList') ->
+      [(Int, Int, Text)] ->
+      DiffList' ->
+      [Hunk]
+    go !n gotChanges hunksAcc currentAcc bothHistory = \case
+      [] ->
+        if gotChanges
+          then
+            let p = reverse (take margin bothHistory)
+                currentAcc' = addBothAfter p currentAcc
+             in case formHunk (currentAcc' []) of
+                  Nothing -> hunksAcc []
+                  Just hunk -> hunksAcc [hunk]
+          else hunksAcc []
+      (x : xs) ->
+        case x of
+          D.Both a _ ->
+            let currentAcc' = addBothAfter p currentAcc
+                p = reverse (drop (n' - margin) bothHistory')
+                hunksAcc' =
+                  case formHunk (currentAcc' []) of
+                    Nothing -> hunksAcc
+                    Just hunk -> hunksAcc . (hunk :)
+                bothHistory' = reverse a ++ bothHistory
+                lena = length a
+                n' = n + lena
+             in if gotChanges && n' > margin * 2
+                  then go 0 False hunksAcc' id bothHistory' xs
+                  else go n' gotChanges hunksAcc currentAcc bothHistory' xs
+          piece ->
+            if gotChanges
+              then
+                let p = reverse bothHistory
+                    currentAcc' = currentAcc . addBothBefore p (piece :)
+                 in go 0 True hunksAcc currentAcc' [] xs
+              else
+                let p = reverse (take margin bothHistory)
+                    currentAcc' = addBothBefore p (piece :)
+                 in go 0 True hunksAcc currentAcc' [] xs
+    addBothBefore [] acc = acc
+    addBothBefore p acc = (D.Both p p :) . acc
+    addBothAfter [] acc = acc
+    addBothAfter p acc = acc . (D.Both p p :)
+
+-- | Form a 'Hunk'.
+formHunk :: DiffList' -> Maybe Hunk
+formHunk xsRaw = do
+  let xs = trimEmpty xsRaw
+  hunkFirstStartLine <- listToMaybe xs >>= firstStartLine
+  let hunkFirstLength = firstLength xs
+  hunkSecondStartLine <- listToMaybe xs >>= secondStartLine
+  let hunkSecondLength = secondLength xs
+      hunkDiff = mapDiff (fmap third) xs
+  return Hunk {..}
+
+-- | Trim empty “both” lines from beginning and end of a 'DiffList''.
+trimEmpty :: DiffList' -> DiffList'
+trimEmpty = go True id
+  where
+    go isFirst acc = \case
+      [] -> acc []
+      [D.Both x _] ->
+        let x' = reverse $ dropWhile (T.null . third) (reverse x)
+         in go False (acc . (D.Both x' x' :)) []
+      (D.Both x _ : xs) ->
+        let x' = dropWhile (T.null . third) x
+         in if isFirst
+              then go False (acc . (D.Both x' x' :)) xs
+              else go False (acc . (D.Both x x :)) xs
+      (x : xs) ->
+        go False (acc . (x :)) xs
+
+firstStartLine :: D.Diff [(Int, Int, a)] -> Maybe Int
+firstStartLine = \case
+  D.Both ((x, _, _) : _) _ -> Just x
+  D.First ((x, _, _) : _) -> Just x
+  D.Second ((x, _, _) : _) -> Just x
+  _ -> Nothing
+
+firstLength :: [D.Diff [(Int, Int, a)]] -> Int
+firstLength = go 0
+  where
+    go n [] = n
+    go !n (x : xs) = case x of
+      D.Both as _ -> go (n + length as) xs
+      D.First as -> go (n + length as) xs
+      D.Second _ -> go n xs
+
+secondStartLine :: D.Diff [(Int, Int, a)] -> Maybe Int
+secondStartLine = \case
+  D.Both ((_, x, _) : _) _ -> Just x
+  D.First ((_, x, _) : _) -> Just x
+  D.Second ((_, x, _) : _) -> Just x
+  _ -> Nothing
+
+secondLength :: [D.Diff [(Int, Int, a)]] -> Int
+secondLength = go 0
+  where
+    go n [] = n
+    go !n (x : xs) = case x of
+      D.Both as _ -> go (n + length as) xs
+      D.First _ -> go n xs
+      D.Second as -> go (n + length as) xs
+
+mapDiff :: (a -> b) -> [D.Diff a] -> [D.Diff b]
+mapDiff f = fmap $ \case
+  D.Both a b -> D.Both (f a) (f b)
+  D.First a -> D.First (f a)
+  D.Second b -> D.Second (f b)
+
+third :: (Int, Int, Text) -> Text
+third (_, _, x) = x

src/Ormolu/Exception.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE TupleSections #-}
 
 -- | 'OrmoluException' type and surrounding definitions.
 module Ormolu.Exception
@@ -10,11 +11,11 @@ where
 import Control.Exception
 import Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.List.NonEmpty as NE
-import Data.Text (Text)
 import qualified GHC
+import Ormolu.Diff.Text (TextDiff, printTextDiff)
 import Ormolu.Utils (showOutputable)
 import qualified Outputable as GHC
-import System.Exit (ExitCode (..), exitWith)
+import System.Exit (ExitCode (..))
 import System.IO
 
 -- | Ormolu exception representing all cases when Ormolu can fail.
@@ -26,53 +27,55 @@ data OrmoluException
   | -- | Original and resulting ASTs differ
     OrmoluASTDiffers FilePath [GHC.SrcSpan]
   | -- | Formatted source code is not idempotent
-    OrmoluNonIdempotentOutput GHC.RealSrcLoc Text Text
+    OrmoluNonIdempotentOutput TextDiff
   | -- | Some GHC options were not recognized
     OrmoluUnrecognizedOpts (NonEmpty String)
   deriving (Eq, Show)
 
-instance Exception OrmoluException where
-  displayException = \case
-    OrmoluParsingFailed s e ->
+instance Exception OrmoluException
+
+-- |
+printOrmoluException :: Handle -> OrmoluException -> IO ()
+printOrmoluException h = \case
+  OrmoluParsingFailed s e ->
+    hPutStrLn h $
       showParsingErr "The GHC parser (in Haddock mode) failed:" s [e]
-    OrmoluOutputParsingFailed s e ->
+  OrmoluOutputParsingFailed s e ->
+    hPutStrLn h $
       showParsingErr "Parsing of formatted code failed:" s [e]
         ++ "Please, consider reporting the bug.\n"
-    OrmoluASTDiffers path ss ->
-      unlines $
-        [ "AST of input and AST of formatted code differ."
-        ]
-          ++ fmap
-            withIndent
-            ( case fmap (\s -> "at " ++ showOutputable s) ss of
-                [] -> ["in " ++ path]
-                xs -> xs
-            )
-          ++ ["Please, consider reporting the bug."]
-    OrmoluNonIdempotentOutput loc left right ->
-      showParsingErr
-        "Formatting is not idempotent:"
-        loc
-        ["before: " ++ show left, "after:  " ++ show right]
-        ++ "Please, consider reporting the bug.\n"
-    OrmoluUnrecognizedOpts opts ->
-      unlines
-        [ "The following GHC options were not recognized:",
-          (withIndent . unwords . NE.toList) opts
-        ]
+  OrmoluASTDiffers path ss ->
+    hPutStrLn h . unlines $
+      [ "AST of input and AST of formatted code differ."
+      ]
+        ++ fmap
+          withIndent
+          ( case fmap (\s -> "at " ++ showOutputable s) ss of
+              [] -> ["in " ++ path]
+              xs -> xs
+          )
+        ++ ["Please, consider reporting the bug."]
+  OrmoluNonIdempotentOutput diff -> do
+    hPutStrLn h "Formatting is not idempotent:\n"
+    printTextDiff h diff
+    hPutStrLn h "\nPlease, consider reporting the bug.\n"
+  OrmoluUnrecognizedOpts opts ->
+    hPutStrLn h . unlines $
+      [ "The following GHC options were not recognized:",
+        (withIndent . unwords . NE.toList) opts
+      ]
 
 -- | Inside this wrapper 'OrmoluException' will be caught and displayed
--- nicely using 'displayException'.
+-- nicely.
 withPrettyOrmoluExceptions ::
-  -- | Action that may throw the exception
-  IO a ->
-  IO a
+  -- | Action that may throw an exception
+  IO ExitCode ->
+  IO ExitCode
 withPrettyOrmoluExceptions m = m `catch` h
   where
-    h :: OrmoluException -> IO a
     h e = do
-      hPutStrLn stderr (displayException e)
-      exitWith . ExitFailure $
+      printOrmoluException stderr e
+      return . ExitFailure $
         case e of
           -- Error code 1 is for 'error' or 'notImplemented'
           -- 2 used to be for erroring out on CPP

tests/Ormolu/Diff/TextSpec.hs

@@ -0,0 +1,65 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Ormolu.Diff.TextSpec (spec) where
+
+import Data.Text (Text)
+import qualified Data.Text.IO as T
+import Ormolu.Diff.Text
+import Path
+import Path.IO
+import qualified System.FilePath as FP
+import System.IO (Handle, hClose)
+import Test.Hspec
+
+spec :: Spec
+spec =
+  describe "printTextDiff" $ do
+    stdTest "one-line-added" "empty" "one-line"
+    stdTest "one-line-removed" "one-line" "empty"
+    stdTest "no-preceding" "main-foo" "main"
+    stdTest "no-following" "main" "main-v2"
+    stdTest "simple-hunk" "main-and-foo" "main-and-foo-v2"
+    stdTest "joined-hunk" "main-and-bar" "main-and-bar-v2"
+    stdTest "two-hunks" "main-and-baz" "main-and-baz-v2"
+    stdTest "trimming" "spaced" "spaced-v2"
+
+-- | Test diff printig.
+stdTest ::
+  -- | Name of the test case
+  String ->
+  -- | Location of input A
+  FilePath ->
+  -- | Location of input B
+  FilePath ->
+  Spec
+stdTest name pathA pathB = it name $ do
+  inputA <-
+    parseRelFile (FP.addExtension pathA "hs")
+      >>= T.readFile . toFilePath . (diffInputsDir </>)
+  inputB <-
+    parseRelFile (FP.addExtension pathB "hs")
+      >>= T.readFile . toFilePath . (diffInputsDir </>)
+  let expectedDiffPath = FP.addExtension name "txt"
+  expectedDiffText <-
+    parseRelFile expectedDiffPath
+      >>= T.readFile . toFilePath . (diffOutputsDir </>)
+  let Just actualDiff = diffText inputA inputB "TEST"
+  actualDiffText <- printToText (\h -> printTextDiff h actualDiff)
+  actualDiffText `shouldBe` expectedDiffText
+
+-- | Print to a 'Text' value.
+printToText :: (Handle -> IO ()) -> IO Text
+printToText action =
+  withSystemTempFile "ormolu-diff-test" $ \path h -> do
+    action h
+    hClose h
+    T.readFile (toFilePath path)
+
+diffTestsDir :: Path Rel Dir
+diffTestsDir = $(mkRelDir "data/diff-tests")
+
+diffInputsDir :: Path Rel Dir
+diffInputsDir = diffTestsDir </> $(mkRelDir "inputs")
+
+diffOutputsDir :: Path Rel Dir
+diffOutputsDir = diffTestsDir </> $(mkRelDir "outputs")