diff --git a/CHANGELOG.md b/CHANGELOG.md index 669fd01..fbc36d5 100644 --- a/CHANGELOG.md +++ b/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 diff --git a/app/Main.hs b/app/Main.hs index 3e5c0fc..2225f2e 100644 --- a/app/Main.hs +++ b/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. diff --git a/data/diff-tests/inputs/empty.hs b/data/diff-tests/inputs/empty.hs new file mode 100644 index 0000000..e69de29 diff --git a/data/diff-tests/inputs/main-and-bar-v2.hs b/data/diff-tests/inputs/main-and-bar-v2.hs new file mode 100644 index 0000000..4a24757 --- /dev/null +++ b/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 diff --git a/data/diff-tests/inputs/main-and-bar.hs b/data/diff-tests/inputs/main-and-bar.hs new file mode 100644 index 0000000..bda0679 --- /dev/null +++ b/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 diff --git a/data/diff-tests/inputs/main-and-baz-v2.hs b/data/diff-tests/inputs/main-and-baz-v2.hs new file mode 100644 index 0000000..91eb7f6 --- /dev/null +++ b/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 diff --git a/data/diff-tests/inputs/main-and-baz.hs b/data/diff-tests/inputs/main-and-baz.hs new file mode 100644 index 0000000..4cca58f --- /dev/null +++ b/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 diff --git a/data/diff-tests/inputs/main-and-foo-v2.hs b/data/diff-tests/inputs/main-and-foo-v2.hs new file mode 100644 index 0000000..d32c8e0 --- /dev/null +++ b/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 diff --git a/data/diff-tests/inputs/main-and-foo.hs b/data/diff-tests/inputs/main-and-foo.hs new file mode 100644 index 0000000..3d17f9a --- /dev/null +++ b/data/diff-tests/inputs/main-and-foo.hs @@ -0,0 +1,7 @@ +module Main (main) where + +main :: IO () +main = return () + +foo :: Int +foo = 5 diff --git a/data/diff-tests/inputs/main-foo.hs b/data/diff-tests/inputs/main-foo.hs new file mode 100644 index 0000000..7ce1f5b --- /dev/null +++ b/data/diff-tests/inputs/main-foo.hs @@ -0,0 +1,4 @@ +module Main (foo) where + +main :: IO () +main = return () diff --git a/data/diff-tests/inputs/main-v2.hs b/data/diff-tests/inputs/main-v2.hs new file mode 100644 index 0000000..a31c5a0 --- /dev/null +++ b/data/diff-tests/inputs/main-v2.hs @@ -0,0 +1,4 @@ +module Main (main) where + +main :: IO () +main = pure () diff --git a/data/diff-tests/inputs/main.hs b/data/diff-tests/inputs/main.hs new file mode 100644 index 0000000..c8dbf9f --- /dev/null +++ b/data/diff-tests/inputs/main.hs @@ -0,0 +1,4 @@ +module Main (main) where + +main :: IO () +main = return () diff --git a/data/diff-tests/inputs/one-line.hs b/data/diff-tests/inputs/one-line.hs new file mode 100644 index 0000000..0fdcb21 --- /dev/null +++ b/data/diff-tests/inputs/one-line.hs @@ -0,0 +1 @@ +module Main (main) where diff --git a/data/diff-tests/inputs/spaced-v2.hs b/data/diff-tests/inputs/spaced-v2.hs new file mode 100644 index 0000000..4b870c2 --- /dev/null +++ b/data/diff-tests/inputs/spaced-v2.hs @@ -0,0 +1,16 @@ +module Main (main) where + + + + + +main :: IO () +main = pure () + + + + + + +foo :: Int +foo = 5 diff --git a/data/diff-tests/inputs/spaced.hs b/data/diff-tests/inputs/spaced.hs new file mode 100644 index 0000000..53ba968 --- /dev/null +++ b/data/diff-tests/inputs/spaced.hs @@ -0,0 +1,16 @@ +module Main (main) where + + + + + +main :: IO () +main = return () + + + + + + +foo :: Int +foo = 5 diff --git a/data/diff-tests/outputs/joined-hunk.txt b/data/diff-tests/outputs/joined-hunk.txt new file mode 100644 index 0000000..2cdc049 --- /dev/null +++ b/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 diff --git a/data/diff-tests/outputs/no-following.txt b/data/diff-tests/outputs/no-following.txt new file mode 100644 index 0000000..bdaf56b --- /dev/null +++ b/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 () diff --git a/data/diff-tests/outputs/no-preceding.txt b/data/diff-tests/outputs/no-preceding.txt new file mode 100644 index 0000000..a87bc79 --- /dev/null +++ b/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 () diff --git a/data/diff-tests/outputs/one-line-added.txt b/data/diff-tests/outputs/one-line-added.txt new file mode 100644 index 0000000..afe1529 --- /dev/null +++ b/data/diff-tests/outputs/one-line-added.txt @@ -0,0 +1,3 @@ +TEST +@@ -1,0 +1,1 @@ ++ module Main (main) where diff --git a/data/diff-tests/outputs/one-line-removed.txt b/data/diff-tests/outputs/one-line-removed.txt new file mode 100644 index 0000000..fcc53ed --- /dev/null +++ b/data/diff-tests/outputs/one-line-removed.txt @@ -0,0 +1,3 @@ +TEST +@@ -1,1 +1,0 @@ +- module Main (main) where diff --git a/data/diff-tests/outputs/simple-hunk.txt b/data/diff-tests/outputs/simple-hunk.txt new file mode 100644 index 0000000..47bc039 --- /dev/null +++ b/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 diff --git a/data/diff-tests/outputs/trimming.txt b/data/diff-tests/outputs/trimming.txt new file mode 100644 index 0000000..27ea53b --- /dev/null +++ b/data/diff-tests/outputs/trimming.txt @@ -0,0 +1,5 @@ +TEST +@@ -7,2 +7,2 @@ + main :: IO () +- main = return () ++ main = pure () diff --git a/data/diff-tests/outputs/two-hunks.txt b/data/diff-tests/outputs/two-hunks.txt new file mode 100644 index 0000000..a55ad97 --- /dev/null +++ b/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 diff --git a/expected-failures/Agda.txt b/expected-failures/Agda.txt index 8ec8dc0..5d46b98 100644 --- a/expected-failures/Agda.txt +++ b/expected-failures/Agda.txt @@ -1,11 +1,46 @@ Formatting is not idempotent: - dist/build/Agda/Syntax/Parser/Lexer.hs: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: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. diff --git a/expected-failures/hlint.txt b/expected-failures/hlint.txt index 3a6414d..1eef684 100644 --- a/expected-failures/hlint.txt +++ b/expected-failures/hlint.txt @@ -1,11 +1,35 @@ Formatting is not idempotent: - src/Extension.hs: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: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. diff --git a/expected-failures/intero.txt b/expected-failures/intero.txt index 6af0c06..d5f705b 100644 --- a/expected-failures/intero.txt +++ b/expected-failures/intero.txt @@ -1,5 +1,14 @@ Formatting is not idempotent: - src/InteractiveUI.hs: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. diff --git a/expected-failures/leksah.txt b/expected-failures/leksah.txt index 881d176..87cc21c 100644 --- a/expected-failures/leksah.txt +++ b/expected-failures/leksah.txt @@ -1,5 +1,17 @@ Formatting is not idempotent: - src/IDE/Pane/Modules.hs: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. diff --git a/expected-failures/pandoc.txt b/expected-failures/pandoc.txt index 4f0bf93..905507a 100644 --- a/expected-failures/pandoc.txt +++ b/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: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. diff --git a/expected-failures/postgrest.txt b/expected-failures/postgrest.txt index ce4f73c..d49225d 100644 --- a/expected-failures/postgrest.txt +++ b/expected-failures/postgrest.txt @@ -1,5 +1,48 @@ Formatting is not idempotent: - src/PostgREST/DbRequestBuilder.hs: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. diff --git a/ormolu.cabal b/ormolu.cabal index 37ad0da..a84458a 100644 --- a/ormolu.cabal +++ b/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 diff --git a/src/Ormolu.hs b/src/Ormolu.hs index d7b4639..fb165db 100644 --- a/src/Ormolu.hs +++ b/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 ++ "" -- 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 diff --git a/src/Ormolu/Diff.hs b/src/Ormolu/Diff/ParseResult.hs similarity index 60% rename from src/Ormolu/Diff.hs rename to src/Ormolu/Diff/ParseResult.hs index c25b60a..be64f06 100644 --- a/src/Ormolu/Diff.hs +++ b/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) diff --git a/src/Ormolu/Diff/Text.hs b/src/Ormolu/Diff/Text.hs new file mode 100644 index 0000000..9838dd7 --- /dev/null +++ b/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 diff --git a/src/Ormolu/Exception.hs b/src/Ormolu/Exception.hs index 8a46ccc..29f15f0 100644 --- a/src/Ormolu/Exception.hs +++ b/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 diff --git a/tests/Ormolu/Diff/TextSpec.hs b/tests/Ormolu/Diff/TextSpec.hs new file mode 100644 index 0000000..706d37b --- /dev/null +++ b/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")