diff --git a/CHANGELOG.md b/CHANGELOG.md index 12e0ced..e0f395d 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,8 @@ +## Ormolu 0.1.4.1 + +* Added command line option `--color` to control how diffs are printed. + Standardized the way errors are printed. + ## Ormolu 0.1.4.0 * Added support for monad comprehensions. [Issue diff --git a/app/Main.hs b/app/Main.hs index 2225f2e..3d3498c 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -17,9 +17,11 @@ import Options.Applicative import Ormolu import Ormolu.Diff.Text (diffText, printTextDiff) import Ormolu.Parser (manualExts) +import Ormolu.Terminal import Ormolu.Utils (showOutputable) import Paths_ormolu (version) import System.Exit (ExitCode (..), exitWith) +import qualified System.FilePath as FP import System.IO (hPutStrLn, stderr) -- | Entry point of the program. @@ -56,8 +58,8 @@ formatOne :: -- | File to format or stdin as 'Nothing' Maybe FilePath -> IO ExitCode -formatOne mode config mpath = withPrettyOrmoluExceptions $ - case mpath of +formatOne mode config mpath = withPrettyOrmoluExceptions (cfgColorMode config) $ + case FP.normalise <$> mpath of Nothing -> do r <- ormoluStdin config case mode of @@ -88,7 +90,7 @@ formatOne mode config mpath = withPrettyOrmoluExceptions $ case diffText originalInput formattedInput inputFile of Nothing -> return ExitSuccess Just diff -> do - printTextDiff stderr diff + runTerm (printTextDiff diff) (cfgColorMode config) stderr -- 100 is different to all the other exit code that are emitted -- either from an 'OrmoluException' or from 'error' and -- 'notImplemented'. @@ -163,13 +165,13 @@ optsParser = short 'm', metavar "MODE", value Stdout, - help "Mode of operation: 'stdout' (default), 'inplace', or 'check'" + help "Mode of operation: 'stdout' (the default), 'inplace', or 'check'" ] ) <*> configParser <*> (many . strArgument . mconcat) [ metavar "FILE", - help "Haskell source files to format or stdin (default)" + help "Haskell source files to format or stdin (the default)" ] configParser :: Parser (Config RegionIndices) @@ -196,6 +198,12 @@ configParser = short 'c', help "Fail if formatting is not idempotent" ] + <*> (option parseColorMode . mconcat) + [ long "color", + metavar "WHEN", + value Auto, + help "Colorize the output; WHEN can be 'never', 'always', or 'auto' (the default)" + ] <*> ( RegionIndices <$> (optional . option auto . mconcat) [ long "start-line", @@ -219,3 +227,10 @@ parseMode = eitherReader $ \case "inplace" -> Right InPlace "check" -> Right Check s -> Left $ "unknown mode: " ++ s + +parseColorMode :: ReadM ColorMode +parseColorMode = eitherReader $ \case + "never" -> Right Never + "always" -> Right Always + "auto" -> Right Auto + s -> Left $ "unknown color mode: " ++ s diff --git a/expected-failures/Agda.txt b/expected-failures/Agda.txt index 5d46b98..13f29e8 100644 --- a/expected-failures/Agda.txt +++ b/expected-failures/Agda.txt @@ -1,6 +1,4 @@ -Formatting is not idempotent: - -./dist/build/Agda/Syntax/Parser/Lexer.hs +dist/build/Agda/Syntax/Parser/Lexer.hs @@ -1600,7 +1600,8 @@ alex_scan_tkn user__ orig_input len input__ s last_acc = input__ @@ -12,11 +10,9 @@ Formatting is not idempotent: `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 + Formatting is not idempotent. + Please, consider reporting the bug. +src/full/Agda/Syntax/Translation/InternalToAbstract.hs @@ -767,16 +767,16 @@ let hd = List.foldl' (A.App defaultAppInfo_) hd0 pad nelims hd =<< reify nes @@ -43,4 +39,5 @@ Formatting is not idempotent: -- 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. + Formatting is not idempotent. + Please, consider reporting the bug. diff --git a/expected-failures/aws.txt b/expected-failures/aws.txt index 3eb0998..d4fc607 100644 --- a/expected-failures/aws.txt +++ b/expected-failures/aws.txt @@ -1,9 +1,8 @@ -The GHC parser (in Haddock mode) failed: - Examples/PutBucketNearLine.hs:5:1-6 +Examples/PutBucketNearLine.hs:5:1-6 + The GHC parser (in Haddock mode) failed: parse error on input `import' - -The GHC parser (in Haddock mode) failed: - Examples/Sqs.hs:(88,3)-(90,4) +Examples/Sqs.hs:(88,3)-(90,4) + The GHC parser (in Haddock mode) failed: parse error on input `{- | Let's make sure the queue was actually deleted and that the same number of queues exist at when | the program ends as when it started. -}' diff --git a/expected-failures/distributed-process.txt b/expected-failures/distributed-process.txt index 16dad46..e1d216f 100644 --- a/expected-failures/distributed-process.txt +++ b/expected-failures/distributed-process.txt @@ -1,7 +1,6 @@ -The GHC parser (in Haddock mode) failed: - benchmarks/Channels.hs:2:1-6 +benchmarks/Channels.hs:2:1-6 + The GHC parser (in Haddock mode) failed: parse error on input `import' - -The GHC parser (in Haddock mode) failed: - benchmarks/Spawns.hs:5:1-6 +benchmarks/Spawns.hs:5:1-6 + The GHC parser (in Haddock mode) failed: parse error on input `import' diff --git a/expected-failures/esqueleto.txt b/expected-failures/esqueleto.txt index fbe83d9..64ae774 100644 --- a/expected-failures/esqueleto.txt +++ b/expected-failures/esqueleto.txt @@ -1,7 +1,6 @@ -The GHC parser (in Haddock mode) failed: - src/Database/Esqueleto/Internal/Internal.hs:385:1 +src/Database/Esqueleto/Internal/Internal.hs:385:1 + The GHC parser (in Haddock mode) failed: lexical error in string/character literal at character 's' - -The GHC parser (in Haddock mode) failed: - test/PostgreSQL/Test.hs:562:9-41 +test/PostgreSQL/Test.hs:562:9-41 + The GHC parser (in Haddock mode) failed: parse error on input `-- | Check the result is not null' diff --git a/expected-failures/fay.txt b/expected-failures/fay.txt index 3d037c2..25b3d08 100644 --- a/expected-failures/fay.txt +++ b/expected-failures/fay.txt @@ -1,18 +1,15 @@ -The GHC parser (in Haddock mode) failed: - examples/Separated.hs:12:1-6 +examples/Separated.hs:12:1-6 + The GHC parser (in Haddock mode) failed: parse error on input `module' - -The GHC parser (in Haddock mode) failed: - examples/calc.hs:(4,1)-(6,2) +examples/calc.hs:(4,1)-(6,2) + The GHC parser (in Haddock mode) failed: parse error on input `-- $ fay -p --html-wrapper --html-js-lib jquery.min.js examples/calc.hs -- You also need to download jquery.min.js. --' - -The GHC parser (in Haddock mode) failed: - examples/canvaswater.hs:(6,1)-(7,17) +examples/canvaswater.hs:(6,1)-(7,17) + The GHC parser (in Haddock mode) failed: parse error on input `-- | A demonstration of Fay using the canvas element to display a -- simple effect.' - -The GHC parser (in Haddock mode) failed: - examples/data.hs:9:1-6 +examples/data.hs:9:1-6 + The GHC parser (in Haddock mode) failed: parse error on input `module' diff --git a/expected-failures/hlint.txt b/expected-failures/hlint.txt index 1eef684..8b5e3b6 100644 --- a/expected-failures/hlint.txt +++ b/expected-failures/hlint.txt @@ -1,6 +1,4 @@ -Formatting is not idempotent: - -./src/Extension.hs +src/Extension.hs @@ -17,7 +17,8 @@ UnboxedTuples, UnboxedSums, -- breaks (#) lens operator @@ -12,11 +10,9 @@ Formatting is not idempotent: reallyBadExtensions = -Please, consider reporting the bug. - -Formatting is not idempotent: - -./src/Hint/Bracket.hs + Formatting is not idempotent. + Please, consider reporting the bug. +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)" @@ -32,4 +28,5 @@ Formatting is not idempotent: varToStr o2 == "<$>", let y = noLoc (OpApp noExtField o1 o2 v3) :: LHsExpr GhcPs, -Please, consider reporting the bug. + Formatting is not idempotent. + Please, consider reporting the bug. diff --git a/expected-failures/idris.txt b/expected-failures/idris.txt index 9e4b3b3..0a28650 100644 --- a/expected-failures/idris.txt +++ b/expected-failures/idris.txt @@ -1,7 +1,6 @@ -The GHC parser (in Haddock mode) failed: - src/Idris/Parser.hs:1052:1 +src/Idris/Parser.hs:1052:1 + The GHC parser (in Haddock mode) failed: parse error on input `@' - -The GHC parser (in Haddock mode) failed: - src/Idris/Parser/Expr.hs:75:1 +src/Idris/Parser/Expr.hs:75:1 + The GHC parser (in Haddock mode) failed: parse error on input `@' diff --git a/expected-failures/intero.txt b/expected-failures/intero.txt index d5f705b..c0c12ba 100644 --- a/expected-failures/intero.txt +++ b/expected-failures/intero.txt @@ -1,6 +1,4 @@ -Formatting is not idempotent: - -./src/InteractiveUI.hs +src/InteractiveUI.hs @@ -3746,6 +3746,7 @@ stdout ( text "Unable to list source for" @@ -11,4 +9,5 @@ Formatting is not idempotent: ) listCmd' str = list2 (words str) -Please, consider reporting the bug. + Formatting is not idempotent. + Please, consider reporting the bug. diff --git a/expected-failures/leksah.txt b/expected-failures/leksah.txt index 87cc21c..40064af 100644 --- a/expected-failures/leksah.txt +++ b/expected-failures/leksah.txt @@ -1,6 +1,4 @@ -Formatting is not idempotent: - -./src/IDE/Pane/Modules.hs +src/IDE/Pane/Modules.hs @@ -1182,9 +1182,9 @@ let modId = mdModuleId modDescr modName = modu modId @@ -14,4 +12,5 @@ Formatting is not idempotent: let sfp = case (pdMbSourcePath (snd pair)) of Nothing -> fp -Please, consider reporting the bug. + Formatting is not idempotent. + Please, consider reporting the bug. diff --git a/expected-failures/lens.txt b/expected-failures/lens.txt index 68a4929..97f0def 100644 --- a/expected-failures/lens.txt +++ b/expected-failures/lens.txt @@ -1,3 +1,3 @@ -The GHC parser (in Haddock mode) failed: - src/Control/Exception/Lens.hs:180:13-37 +src/Control/Exception/Lens.hs:180:13-37 + The GHC parser (in Haddock mode) failed: parse error on input `AllocationLimitExceeded__' diff --git a/expected-failures/pandoc.txt b/expected-failures/pandoc.txt index 905507a..0e27868 100644 --- a/expected-failures/pandoc.txt +++ b/expected-failures/pandoc.txt @@ -1,10 +1,7 @@ -The GHC parser (in Haddock mode) failed: - benchmark/weigh-pandoc.hs:14:1-6 +benchmark/weigh-pandoc.hs:14:1-6 + The GHC parser (in Haddock mode) failed: parse error on input `import' - -Formatting is not idempotent: - -./src/Text/Pandoc/Readers/Vimwiki.hs +src/Text/Pandoc/Readers/Vimwiki.hs @@ -615,7 +615,8 @@ <$ ( skipMany1 spaceChar <|> try (newline >> (comment <|> placeholder)) @@ -16,4 +13,5 @@ Formatting is not idempotent: whitespace' :: PandocMonad m => VwParser m Inlines whitespace' = B.space <$ skipMany1 spaceChar -Please, consider reporting the bug. + Formatting is not idempotent. + Please, consider reporting the bug. diff --git a/expected-failures/pipes.txt b/expected-failures/pipes.txt index 4fe329e..8eab524 100644 --- a/expected-failures/pipes.txt +++ b/expected-failures/pipes.txt @@ -1,3 +1,4 @@ -AST of input and AST of formatted code differ. - at src/Pipes/Core.hs:(128,1)-(151,2) -Please, consider reporting the bug. +src/Pipes/Core.hs + AST of input and AST of formatted code differ. + at src/Pipes/Core.hs:(128,1)-(151,2) + Please, consider reporting the bug. diff --git a/expected-failures/postgrest.txt b/expected-failures/postgrest.txt index d49225d..f3b3f80 100644 --- a/expected-failures/postgrest.txt +++ b/expected-failures/postgrest.txt @@ -1,6 +1,4 @@ -Formatting is not idempotent: - -./src/PostgREST/DbRequestBuilder.hs +src/PostgREST/DbRequestBuilder.hs @@ -147,12 +147,11 @@ -- /projects?select=clients(*) origin == tableName relTable @@ -45,4 +43,5 @@ Formatting is not idempotent: ) allRels -Please, consider reporting the bug. + Formatting is not idempotent. + Please, consider reporting the bug. diff --git a/expected-failures/purescript.txt b/expected-failures/purescript.txt index ce82c40..612e6c2 100644 --- a/expected-failures/purescript.txt +++ b/expected-failures/purescript.txt @@ -1,18 +1,15 @@ -The GHC parser (in Haddock mode) failed: - src/Language/PureScript/AST/Declarations.hs:479:1-17 +src/Language/PureScript/AST/Declarations.hs:479:1-17 + The GHC parser (in Haddock mode) failed: Invalid type signature: pattern ValueDecl :: ... Perhaps you meant to use PatternSynonyms? - -The GHC parser (in Haddock mode) failed: - src/Language/PureScript/AST/SourcePos.hs:99:1-22 +src/Language/PureScript/AST/SourcePos.hs:99:1-22 + The GHC parser (in Haddock mode) failed: Invalid type signature: pattern NullSourceSpan :: ... Perhaps you meant to use PatternSynonyms? - -The GHC parser (in Haddock mode) failed: - src/Language/PureScript/Constants.hs:42:1-15 +src/Language/PureScript/Constants.hs:42:1-15 + The GHC parser (in Haddock mode) failed: Invalid type signature: pattern Discard :: ... Perhaps you meant to use PatternSynonyms? - -The GHC parser (in Haddock mode) failed: - src/Language/PureScript/Crash.hs:16:1-6 +src/Language/PureScript/Crash.hs:16:1-6 + The GHC parser (in Haddock mode) failed: parse error on input `import' diff --git a/expected-failures/tensorflow.txt b/expected-failures/tensorflow.txt index 081f895..dcb69d0 100644 --- a/expected-failures/tensorflow.txt +++ b/expected-failures/tensorflow.txt @@ -1,7 +1,6 @@ -The GHC parser (in Haddock mode) failed: - tensorflow-mnist/app/Main.hs:50:13-14 +tensorflow-mnist/app/Main.hs:50:13-14 + The GHC parser (in Haddock mode) failed: parse error on input `->' - -The GHC parser (in Haddock mode) failed: - tensorflow-ops/tests/RegressionTest.hs:3:1-6 +tensorflow-ops/tests/RegressionTest.hs:3:1-6 + The GHC parser (in Haddock mode) failed: parse error on input `import' diff --git a/ormolu.cabal b/ormolu.cabal index 9ae8921..6872b34 100644 --- a/ormolu.cabal +++ b/ormolu.cabal @@ -110,6 +110,7 @@ library Ormolu.Processing.Cpp Ormolu.Processing.Postprocess Ormolu.Processing.Preprocess + Ormolu.Terminal Ormolu.Utils hs-source-dirs: src @@ -147,6 +148,7 @@ executable ormolu default-language: Haskell2010 build-depends: base >=4.12 && <5.0, + filepath >=1.2 && <1.5, ghc-lib-parser >=8.10 && <8.11, gitrev >=1.3 && <1.4, optparse-applicative >=0.14 && <0.17, diff --git a/src/Ormolu.hs b/src/Ormolu.hs index fb165db..8911484 100644 --- a/src/Ormolu.hs +++ b/src/Ormolu.hs @@ -6,6 +6,7 @@ module Ormolu ormoluFile, ormoluStdin, Config (..), + ColorMode (..), RegionIndices (..), defaultConfig, DynOption (..), diff --git a/src/Ormolu/Config.hs b/src/Ormolu/Config.hs index 4ac7218..96fe4cc 100644 --- a/src/Ormolu/Config.hs +++ b/src/Ormolu/Config.hs @@ -4,6 +4,7 @@ -- | Configuration options used by the tool. module Ormolu.Config ( Config (..), + ColorMode (..), RegionIndices (..), RegionDeltas (..), defaultConfig, @@ -13,6 +14,7 @@ module Ormolu.Config ) where +import Ormolu.Terminal (ColorMode (..)) import qualified SrcLoc as GHC -- | Ormolu configuration. @@ -25,6 +27,8 @@ data Config region = Config cfgDebug :: !Bool, -- | Checks if re-formatting the result is idempotent cfgCheckIdempotence :: !Bool, + -- | Whether to use colors and other features of ANSI terminals + cfgColorMode :: !ColorMode, -- | Region selection cfgRegion :: !region } @@ -57,6 +61,7 @@ defaultConfig = cfgUnsafe = False, cfgDebug = False, cfgCheckIdempotence = False, + cfgColorMode = Auto, cfgRegion = RegionIndices { regionStartLine = Nothing, diff --git a/src/Ormolu/Diff/Text.hs b/src/Ormolu/Diff/Text.hs index 9838dd7..b295393 100644 --- a/src/Ormolu/Diff/Text.hs +++ b/src/Ormolu/Diff/Text.hs @@ -17,9 +17,7 @@ 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 +import Ormolu.Terminal ---------------------------------------------------------------------------- -- Types @@ -70,53 +68,22 @@ diffText a b path = 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 +-- | Print the given 'TextDiff' as a 'Term' action. This function tries to +-- mimic the style of @git diff@. +printTextDiff :: TextDiff -> Term () +printTextDiff (TextDiff path xs) = do + (bold . putS) path newline forM_ (toHunks (assignLines xs)) $ \Hunk {..} -> do cyan $ do put "@@ -" - put (T.pack $ show hunkFirstStartLine) + putS (show hunkFirstStartLine) put "," - put (T.pack $ show hunkFirstLength) + putS (show hunkFirstLength) put " +" - put (T.pack $ show hunkSecondStartLine) + putS (show hunkSecondStartLine) put "," - put (T.pack $ show hunkSecondLength) + putS (show hunkSecondLength) put " @@" newline forM_ hunkDiff $ \case @@ -140,7 +107,6 @@ printTextDiff h (TextDiff path xs) = do put " " put y newline - hFlush h ---------------------------------------------------------------------------- -- Helpers diff --git a/src/Ormolu/Exception.hs b/src/Ormolu/Exception.hs index 29f15f0..ce8ad46 100644 --- a/src/Ormolu/Exception.hs +++ b/src/Ormolu/Exception.hs @@ -1,4 +1,5 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} -- | 'OrmoluException' type and surrounding definitions. @@ -9,12 +10,13 @@ module Ormolu.Exception where import Control.Exception +import Control.Monad (forM_) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE +import qualified Data.Text as T import qualified GHC import Ormolu.Diff.Text (TextDiff, printTextDiff) -import Ormolu.Utils (showOutputable) -import qualified Outputable as GHC +import Ormolu.Terminal import System.Exit (ExitCode (..)) import System.IO @@ -34,47 +36,63 @@ data OrmoluException 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 -> - hPutStrLn h $ - showParsingErr "Parsing of formatted code failed:" s [e] - ++ "Please, consider reporting the bug.\n" - 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."] +-- | Print an 'OrmoluException'. +printOrmoluException :: + OrmoluException -> + Term () +printOrmoluException = \case + OrmoluParsingFailed s e -> do + bold (putSrcSpan s) + newline + put " The GHC parser (in Haddock mode) failed:" + newline + put " " + put (T.pack e) + newline + OrmoluOutputParsingFailed s e -> do + bold (putSrcSpan s) + newline + put " Parsing of formatted code failed:" + put " " + put (T.pack e) + newline + OrmoluASTDiffers path ss -> do + putS path + newline + put " AST of input and AST of formatted code differ." + newline + forM_ ss $ \s -> do + put " at " + putSrcSpan s + newline + put " Please, consider reporting the bug." + newline 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 - ] + printTextDiff diff + newline + put " Formatting is not idempotent." + newline + put " Please, consider reporting the bug." + newline + OrmoluUnrecognizedOpts opts -> do + put "The following GHC options were not recognized:" + newline + put " " + (putS . unwords . NE.toList) opts + newline -- | Inside this wrapper 'OrmoluException' will be caught and displayed -- nicely. withPrettyOrmoluExceptions :: + -- | Color mode + ColorMode -> -- | Action that may throw an exception IO ExitCode -> IO ExitCode -withPrettyOrmoluExceptions m = m `catch` h +withPrettyOrmoluExceptions colorMode m = m `catch` h where h e = do - printOrmoluException stderr e + runTerm (printOrmoluException e) colorMode stderr return . ExitFailure $ case e of -- Error code 1 is for 'error' or 'notImplemented' @@ -84,19 +102,3 @@ withPrettyOrmoluExceptions m = m `catch` h OrmoluASTDiffers {} -> 5 OrmoluNonIdempotentOutput {} -> 6 OrmoluUnrecognizedOpts {} -> 7 - ----------------------------------------------------------------------------- --- Helpers - --- | Show a parse error. -showParsingErr :: GHC.Outputable a => String -> a -> [String] -> String -showParsingErr msg spn err = - unlines $ - [ msg, - withIndent (showOutputable spn) - ] - ++ map withIndent err - --- | Indent with 2 spaces for readability. -withIndent :: String -> String -withIndent txt = " " ++ txt diff --git a/src/Ormolu/Printer/Internal.hs b/src/Ormolu/Printer/Internal.hs index 540988f..3851e44 100644 --- a/src/Ormolu/Printer/Internal.hs +++ b/src/Ormolu/Printer/Internal.hs @@ -148,7 +148,7 @@ data CommentPosition OnNextLine deriving (Eq, Show) --- | Run an 'R' monad. +-- | Run 'R' monad. runR :: -- | Monad to run R () -> diff --git a/src/Ormolu/Terminal.hs b/src/Ormolu/Terminal.hs new file mode 100644 index 0000000..4315731 --- /dev/null +++ b/src/Ormolu/Terminal.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | An abstraction for colorful output in terminal. +module Ormolu.Terminal + ( -- * The 'Term' monad + Term, + ColorMode (..), + runTerm, + + -- * Styling + bold, + cyan, + green, + red, + + -- * Printing + put, + putS, + putSrcSpan, + newline, + ) +where + +import Control.Monad.Reader +import Data.Text (Text) +import qualified Data.Text.IO as T +import qualified GHC +import Ormolu.Utils (showOutputable) +import System.Console.ANSI +import System.IO (Handle, hFlush, hPutStr) + +---------------------------------------------------------------------------- +-- The 'Term' monad + +-- | Terminal monad. +newtype Term a = Term (ReaderT RC IO a) + deriving (Functor, Applicative, Monad) + +-- | Reader context of 'Term'. +data RC = RC + { -- | Whether to use colors + rcUseColor :: Bool, + -- | Handle to print to + rcHandle :: Handle + } + +-- | Whether to use colors and other features of ANSI terminals. +data ColorMode = Never | Always | Auto + deriving (Eq, Show) + +-- | Run 'Term' monad. +runTerm :: + -- | Monad to run + Term a -> + -- | Color mode + ColorMode -> + -- | Handle to print to + Handle -> + IO a +runTerm (Term m) colorMode rcHandle = do + rcUseColor <- case colorMode of + Never -> return False + Always -> return True + Auto -> hSupportsANSI rcHandle + x <- runReaderT m RC {..} + hFlush rcHandle + return x + +---------------------------------------------------------------------------- +-- Styling + +-- | Make the inner computation output bold text. +bold :: Term a -> Term a +bold = withSGR [SetConsoleIntensity BoldIntensity] + +-- | Make the inner computation output cyan text. +cyan :: Term a -> Term a +cyan = withSGR [SetColor Foreground Dull Cyan] + +-- | Make the inner computation output green text. +green :: Term a -> Term a +green = withSGR [SetColor Foreground Dull Green] + +-- | Make the inner computation output red text. +red :: Term a -> Term a +red = withSGR [SetColor Foreground Dull Red] + +-- | Alter 'SGR' for inner computation. +withSGR :: [SGR] -> Term a -> Term a +withSGR sgrs (Term m) = Term $ do + RC {..} <- ask + if rcUseColor + then do + liftIO $ hSetSGR rcHandle sgrs + x <- m + liftIO $ hSetSGR rcHandle [Reset] + return x + else m + +---------------------------------------------------------------------------- +-- Printing + +-- | Output 'Text'. +put :: Text -> Term () +put txt = Term $ do + RC {..} <- ask + liftIO $ T.hPutStr rcHandle txt + +-- | Output 'String'. +putS :: String -> Term () +putS str = Term $ do + RC {..} <- ask + liftIO $ hPutStr rcHandle str + +-- | Output a 'GHC.SrcSpan'. +putSrcSpan :: GHC.SrcSpan -> Term () +putSrcSpan = putS . showOutputable + +-- | Output a newline. +newline :: Term () +newline = Term $ do + RC {..} <- ask + liftIO $ T.hPutStr rcHandle "\n" diff --git a/tests/Ormolu/Diff/TextSpec.hs b/tests/Ormolu/Diff/TextSpec.hs index 706d37b..18ea982 100644 --- a/tests/Ormolu/Diff/TextSpec.hs +++ b/tests/Ormolu/Diff/TextSpec.hs @@ -5,10 +5,11 @@ module Ormolu.Diff.TextSpec (spec) where import Data.Text (Text) import qualified Data.Text.IO as T import Ormolu.Diff.Text +import Ormolu.Terminal import Path import Path.IO import qualified System.FilePath as FP -import System.IO (Handle, hClose) +import System.IO (hClose) import Test.Hspec spec :: Spec @@ -44,14 +45,14 @@ stdTest name pathA pathB = it name $ do parseRelFile expectedDiffPath >>= T.readFile . toFilePath . (diffOutputsDir ) let Just actualDiff = diffText inputA inputB "TEST" - actualDiffText <- printToText (\h -> printTextDiff h actualDiff) + actualDiffText <- printDiff actualDiff actualDiffText `shouldBe` expectedDiffText -- | Print to a 'Text' value. -printToText :: (Handle -> IO ()) -> IO Text -printToText action = +printDiff :: TextDiff -> IO Text +printDiff diff = withSystemTempFile "ormolu-diff-test" $ \path h -> do - action h + runTerm (printTextDiff diff) Never h hClose h T.readFile (toFilePath path)