mirror of
https://github.com/tweag/ormolu.git
synced 2024-10-26 15:35:11 +03:00
Display diffs in the checking mode
Also improve the way the diffs are printed.
This commit is contained in:
parent
286afb7ed6
commit
93bef509ca
@ -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
|
||||
|
97
app/Main.hs
97
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.
|
||||
|
0
data/diff-tests/inputs/empty.hs
Normal file
0
data/diff-tests/inputs/empty.hs
Normal file
11
data/diff-tests/inputs/main-and-bar-v2.hs
Normal file
11
data/diff-tests/inputs/main-and-bar-v2.hs
Normal file
@ -0,0 +1,11 @@
|
||||
module Main (main) where
|
||||
|
||||
main :: IO ()
|
||||
main = pure ()
|
||||
|
||||
foo :: Int
|
||||
foo =
|
||||
5
|
||||
|
||||
bar :: Int
|
||||
bar = 7
|
11
data/diff-tests/inputs/main-and-bar.hs
Normal file
11
data/diff-tests/inputs/main-and-bar.hs
Normal file
@ -0,0 +1,11 @@
|
||||
module Main (main) where
|
||||
|
||||
main :: IO ()
|
||||
main = return ()
|
||||
|
||||
foo :: Int
|
||||
foo =
|
||||
5
|
||||
|
||||
bar :: Int
|
||||
bar = 6
|
12
data/diff-tests/inputs/main-and-baz-v2.hs
Normal file
12
data/diff-tests/inputs/main-and-baz-v2.hs
Normal file
@ -0,0 +1,12 @@
|
||||
module Main (main) where
|
||||
|
||||
main :: IO ()
|
||||
main = pure ()
|
||||
|
||||
foo :: Int
|
||||
foo =
|
||||
5
|
||||
+ 5
|
||||
|
||||
bar :: Int
|
||||
bar = 7
|
12
data/diff-tests/inputs/main-and-baz.hs
Normal file
12
data/diff-tests/inputs/main-and-baz.hs
Normal file
@ -0,0 +1,12 @@
|
||||
module Main (main) where
|
||||
|
||||
main :: IO ()
|
||||
main = return ()
|
||||
|
||||
foo :: Int
|
||||
foo =
|
||||
5
|
||||
+ 5
|
||||
|
||||
bar :: Int
|
||||
bar = 6
|
7
data/diff-tests/inputs/main-and-foo-v2.hs
Normal file
7
data/diff-tests/inputs/main-and-foo-v2.hs
Normal file
@ -0,0 +1,7 @@
|
||||
module Main (main) where
|
||||
|
||||
main :: IO ()
|
||||
main = pure ()
|
||||
|
||||
foo :: Int
|
||||
foo = 5
|
7
data/diff-tests/inputs/main-and-foo.hs
Normal file
7
data/diff-tests/inputs/main-and-foo.hs
Normal file
@ -0,0 +1,7 @@
|
||||
module Main (main) where
|
||||
|
||||
main :: IO ()
|
||||
main = return ()
|
||||
|
||||
foo :: Int
|
||||
foo = 5
|
4
data/diff-tests/inputs/main-foo.hs
Normal file
4
data/diff-tests/inputs/main-foo.hs
Normal file
@ -0,0 +1,4 @@
|
||||
module Main (foo) where
|
||||
|
||||
main :: IO ()
|
||||
main = return ()
|
4
data/diff-tests/inputs/main-v2.hs
Normal file
4
data/diff-tests/inputs/main-v2.hs
Normal file
@ -0,0 +1,4 @@
|
||||
module Main (main) where
|
||||
|
||||
main :: IO ()
|
||||
main = pure ()
|
4
data/diff-tests/inputs/main.hs
Normal file
4
data/diff-tests/inputs/main.hs
Normal file
@ -0,0 +1,4 @@
|
||||
module Main (main) where
|
||||
|
||||
main :: IO ()
|
||||
main = return ()
|
1
data/diff-tests/inputs/one-line.hs
Normal file
1
data/diff-tests/inputs/one-line.hs
Normal file
@ -0,0 +1 @@
|
||||
module Main (main) where
|
16
data/diff-tests/inputs/spaced-v2.hs
Normal file
16
data/diff-tests/inputs/spaced-v2.hs
Normal file
@ -0,0 +1,16 @@
|
||||
module Main (main) where
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
main :: IO ()
|
||||
main = pure ()
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
foo :: Int
|
||||
foo = 5
|
16
data/diff-tests/inputs/spaced.hs
Normal file
16
data/diff-tests/inputs/spaced.hs
Normal file
@ -0,0 +1,16 @@
|
||||
module Main (main) where
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
main :: IO ()
|
||||
main = return ()
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
foo :: Int
|
||||
foo = 5
|
15
data/diff-tests/outputs/joined-hunk.txt
Normal file
15
data/diff-tests/outputs/joined-hunk.txt
Normal file
@ -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
|
7
data/diff-tests/outputs/no-following.txt
Normal file
7
data/diff-tests/outputs/no-following.txt
Normal file
@ -0,0 +1,7 @@
|
||||
TEST
|
||||
@@ -1,4 +1,4 @@
|
||||
module Main (main) where
|
||||
|
||||
main :: IO ()
|
||||
- main = return ()
|
||||
+ main = pure ()
|
7
data/diff-tests/outputs/no-preceding.txt
Normal file
7
data/diff-tests/outputs/no-preceding.txt
Normal file
@ -0,0 +1,7 @@
|
||||
TEST
|
||||
@@ -1,4 +1,4 @@
|
||||
- module Main (foo) where
|
||||
+ module Main (main) where
|
||||
|
||||
main :: IO ()
|
||||
main = return ()
|
3
data/diff-tests/outputs/one-line-added.txt
Normal file
3
data/diff-tests/outputs/one-line-added.txt
Normal file
@ -0,0 +1,3 @@
|
||||
TEST
|
||||
@@ -1,0 +1,1 @@
|
||||
+ module Main (main) where
|
3
data/diff-tests/outputs/one-line-removed.txt
Normal file
3
data/diff-tests/outputs/one-line-removed.txt
Normal file
@ -0,0 +1,3 @@
|
||||
TEST
|
||||
@@ -1,1 +1,0 @@
|
||||
- module Main (main) where
|
10
data/diff-tests/outputs/simple-hunk.txt
Normal file
10
data/diff-tests/outputs/simple-hunk.txt
Normal file
@ -0,0 +1,10 @@
|
||||
TEST
|
||||
@@ -1,7 +1,7 @@
|
||||
module Main (main) where
|
||||
|
||||
main :: IO ()
|
||||
- main = return ()
|
||||
+ main = pure ()
|
||||
|
||||
foo :: Int
|
||||
foo = 5
|
5
data/diff-tests/outputs/trimming.txt
Normal file
5
data/diff-tests/outputs/trimming.txt
Normal file
@ -0,0 +1,5 @@
|
||||
TEST
|
||||
@@ -7,2 +7,2 @@
|
||||
main :: IO ()
|
||||
- main = return ()
|
||||
+ main = pure ()
|
16
data/diff-tests/outputs/two-hunks.txt
Normal file
16
data/diff-tests/outputs/two-hunks.txt
Normal file
@ -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
|
@ -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.
|
||||
|
@ -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.
|
||||
|
@ -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.
|
||||
|
@ -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.
|
||||
|
@ -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.
|
||||
|
@ -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.
|
||||
|
@ -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
|
||||
|
||||
|
@ -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
|
||||
|
@ -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)
|
318
src/Ormolu/Diff/Text.hs
Normal file
318
src/Ormolu/Diff/Text.hs
Normal file
@ -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
|
@ -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
|
||||
|
65
tests/Ormolu/Diff/TextSpec.hs
Normal file
65
tests/Ormolu/Diff/TextSpec.hs
Normal file
@ -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")
|
Loading…
Reference in New Issue
Block a user