Add ‘--color’ for controlling how diffs are printed

Also refactor the printing code and standardize how error messages are
output.

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

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

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.

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.
   -}'

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'

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'

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'

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.

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 `@'

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.

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.

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__'

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.

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.

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.

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'

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'

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,

src/Ormolu.hs

@@ -6,6 +6,7 @@ module Ormolu
     ormoluFile,
     ormoluStdin,
     Config (..),
+    ColorMode (..),
     RegionIndices (..),
     defaultConfig,
     DynOption (..),

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,

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

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

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 () ->

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"

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)