rio-prettyprint 0.1.4.0 → 0.1.5.0

raw patch · 9 files changed

+1301/−1204 lines, 9 filesdep ~pathnew-uploader

Dependency ranges changed: path

Files

• LICENSE +24/−24
• rio-prettyprint.cabal +50/−50
• src/RIO/PrettyPrint.hs +271/−215
• src/RIO/PrettyPrint/DefaultStyles.hs +40/−39
• src/RIO/PrettyPrint/PrettyException.hs +77/−77
• src/RIO/PrettyPrint/Simple.hs +100/−98
• src/RIO/PrettyPrint/StylesUpdate.hs +166/−165
• src/RIO/PrettyPrint/Types.hs +69/−70
• src/Text/PrettyPrint/Leijen/Extended.hs +504/−466

@@ -1,24 +1,24 @@-Copyright (c) 2015-2019, Stack contributors-All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are met:-    * Redistributions of source code must retain the above copyright-      notice, this list of conditions and the following disclaimer.-    * Redistributions in binary form must reproduce the above copyright-      notice, this list of conditions and the following disclaimer in the-      documentation and/or other materials provided with the distribution.-    * Neither the name of Stack nor the-      names of its contributors may be used to endorse or promote products-      derived from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND-ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED-WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE-DISCLAIMED. IN NO EVENT SHALL STACK CONTRIBUTORS BE LIABLE FOR ANY-DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES-(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;-LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND-ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS-SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+Copyright (c) 2015-2023, Stack contributors
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+    * Redistributions in binary form must reproduce the above copyright
+      notice, this list of conditions and the following disclaimer in the
+      documentation and/or other materials provided with the distribution.
+    * Neither the name of Stack nor the
+      names of its contributors may be used to endorse or promote products
+      derived from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+DISCLAIMED. IN NO EVENT SHALL STACK CONTRIBUTORS BE LIABLE FOR ANY
+DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
+ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -1,50 +1,50 @@-cabal-version: 1.12---- This file has been generated from package.yaml by hpack version 0.35.0.------ see: https://github.com/sol/hpack--name:           rio-prettyprint-version:        0.1.4.0-synopsis:       Pretty-printing for RIO-description:    Combine RIO's log capabilities with pretty printing-category:       Development-homepage:       https://github.com/commercialhaskell/rio-prettyprint#readme-bug-reports:    https://github.com/commercialhaskell/rio-prettyprint/issues-author:         Michael Snoyman-maintainer:     michael@snoyman.com-copyright:      2018-2019 FP Complete-license:        BSD3-license-file:   LICENSE-build-type:     Simple--source-repository head-  type: git-  location: https://github.com/commercialhaskell/rio-prettyprint--library-  exposed-modules:-      RIO.PrettyPrint-      RIO.PrettyPrint.DefaultStyles-      RIO.PrettyPrint.PrettyException-      RIO.PrettyPrint.Simple-      RIO.PrettyPrint.StylesUpdate-      RIO.PrettyPrint.Types-      Text.PrettyPrint.Leijen.Extended-  other-modules:-      Paths_rio_prettyprint-  hs-source-dirs:-      src/-  build-depends:-      Cabal-    , aeson-    , annotated-wl-pprint-    , ansi-terminal >=0.9-    , array-    , base >=4.10 && <5-    , colour-    , mtl-    , path-    , rio-    , text-  default-language: Haskell2010+cabal-version: 1.12
+
+-- This file has been generated from package.yaml by hpack version 0.35.4.
+--
+-- see: https://github.com/sol/hpack
+
+name:           rio-prettyprint
+version:        0.1.5.0
+synopsis:       Pretty-printing for RIO
+description:    Combine RIO's log capabilities with pretty printing
+category:       Development
+homepage:       https://github.com/commercialhaskell/rio-prettyprint#readme
+bug-reports:    https://github.com/commercialhaskell/rio-prettyprint/issues
+author:         Michael Snoyman
+maintainer:     michael@snoyman.com
+copyright:      2018-2019 FP Complete
+license:        BSD3
+license-file:   LICENSE
+build-type:     Simple
+
+source-repository head
+  type: git
+  location: https://github.com/commercialhaskell/rio-prettyprint
+
+library
+  exposed-modules:
+      RIO.PrettyPrint
+      RIO.PrettyPrint.DefaultStyles
+      RIO.PrettyPrint.PrettyException
+      RIO.PrettyPrint.Simple
+      RIO.PrettyPrint.StylesUpdate
+      RIO.PrettyPrint.Types
+      Text.PrettyPrint.Leijen.Extended
+  other-modules:
+      Paths_rio_prettyprint
+  hs-source-dirs:
+      src/
+  build-depends:
+      Cabal
+    , aeson
+    , annotated-wl-pprint
+    , ansi-terminal >=0.9
+    , array
+    , base >=4.10 && <5
+    , colour
+    , mtl
+    , path >0.9.1
+    , rio
+    , text
+  default-language: Haskell2010

@@ -1,215 +1,271 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-}--module RIO.PrettyPrint-    (-      -- * Type classes for optionally colored terminal output-      HasTerm (..), HasStylesUpdate (..)-      -- * Pretty printing functions-    , displayPlain, displayWithColor-      -- * Logging based on pretty-print typeclass-    , prettyDebug, prettyInfo, prettyNote, prettyWarn, prettyError, prettyWarnNoIndent, prettyErrorNoIndent-    , prettyDebugL, prettyInfoL, prettyNoteL, prettyWarnL, prettyErrorL, prettyWarnNoIndentL, prettyErrorNoIndentL-    , prettyDebugS, prettyInfoS, prettyNoteS, prettyWarnS, prettyErrorS, prettyWarnNoIndentS, prettyErrorNoIndentS-      -- * Semantic styling functions-      -- | These are used rather than applying colors or other styling directly,-      -- to provide consistency.-    , style-    , displayMilliseconds-    , logLevelToStyle-      -- * Formatting utils-    , bulletedList-    , mkNarrativeList-    , spacedBulletedList-    , debugBracket-      -- * Re-exports from "Text.PrettyPrint.Leijen.Extended"-    , Pretty (..), StyleDoc (..), StyleAnn (..)-    , nest, line, linebreak, group, softline, softbreak-    , align, hang, indent, encloseSep-    , (<+>)-    , hsep, vsep, fillSep, sep, hcat, vcat, fillCat, cat, punctuate-    , fill, fillBreak-    , enclose, squotes, dquotes, parens, angles, braces, brackets-    , string-    , indentAfterLabel, wordDocs, flow-      -- * Re-exports from "RIO.PrettyPrint.Types.PrettyPrint"-    , Style (..)-    ) where--import Data.List (intersperse)-import RIO-import RIO.PrettyPrint.StylesUpdate (HasStylesUpdate (..))-import RIO.PrettyPrint.Types (Style (..))-import Text.PrettyPrint.Leijen.Extended (Pretty (pretty),-                     StyleAnn (..), StyleDoc, (<+>), align,-                     angles, braces, brackets, cat,-                     displayAnsi, displayPlain, dquotes, enclose, encloseSep,-                     fill, fillBreak, fillCat, fillSep, group, hang, hcat, hsep,-                     indent, line, linebreak,-                     nest, parens, punctuate, sep, softbreak, softline, squotes,-                     string, styleAnn, vcat, vsep)--class (HasLogFunc env, HasStylesUpdate env) => HasTerm env where-  useColorL :: Lens' env Bool-  termWidthL :: Lens' env Int--displayWithColor-    :: (HasTerm env, Pretty a, MonadReader env m, HasCallStack)-    => a -> m Utf8Builder-displayWithColor x = do-    useAnsi <- view useColorL-    termWidth <- view termWidthL-    (if useAnsi then displayAnsi else displayPlain) termWidth x---- TODO: switch to using implicit callstacks once 7.8 support is dropped--prettyWith :: (HasTerm env, HasCallStack, Pretty b,-               MonadReader env m, MonadIO m)-           => LogLevel -> (a -> b) -> a -> m ()-prettyWith level f = logGeneric "" level . RIO.display <=< displayWithColor . f---- Note: I think keeping this section aligned helps spot errors, might be--- worth keeping the alignment in place.--prettyDebugWith, prettyInfoWith, prettyNoteWith, prettyWarnWith, prettyErrorWith, prettyWarnNoIndentWith, prettyErrorNoIndentWith-  :: (HasCallStack, HasTerm env, MonadReader env m, MonadIO m)-  => (a -> StyleDoc) -> a -> m ()-prettyDebugWith = prettyWith LevelDebug-prettyInfoWith  = prettyWith LevelInfo-prettyNoteWith f  = prettyWith LevelInfo-                          ((line <>) . (style Good "Note:" <+>) .-                           indentAfterLabel . f)-prettyWarnWith f  = prettyWith LevelWarn-                          ((line <>) . (style Warning "Warning:" <+>) .-                           indentAfterLabel . f)-prettyErrorWith f = prettyWith LevelError-                          ((line <>) . (style Error   "Error:" <+>) .-                           indentAfterLabel . f)-prettyWarnNoIndentWith f  = prettyWith LevelWarn-                                  ((line <>) . (style Warning "Warning:" <+>) . f)-prettyErrorNoIndentWith f = prettyWith LevelError-                                  ((line <>) . (style Error   "Error:" <+>) . f)--prettyDebug, prettyInfo, prettyNote, prettyWarn, prettyError, prettyWarnNoIndent, prettyErrorNoIndent-  :: (HasCallStack, HasTerm env, MonadReader env m, MonadIO m)-  => StyleDoc -> m ()-prettyDebug         = prettyDebugWith         id-prettyInfo          = prettyInfoWith          id-prettyNote          = prettyNoteWith          id-prettyWarn          = prettyWarnWith          id-prettyError         = prettyErrorWith         id-prettyWarnNoIndent  = prettyWarnNoIndentWith  id-prettyErrorNoIndent = prettyErrorNoIndentWith id--prettyDebugL, prettyInfoL, prettyNoteL, prettyWarnL, prettyErrorL, prettyWarnNoIndentL, prettyErrorNoIndentL-  :: (HasCallStack, HasTerm env, MonadReader env m, MonadIO m)-  => [StyleDoc] -> m ()-prettyDebugL         = prettyDebugWith         fillSep-prettyInfoL          = prettyInfoWith          fillSep-prettyNoteL          = prettyNoteWith          fillSep-prettyWarnL          = prettyWarnWith          fillSep-prettyErrorL         = prettyErrorWith         fillSep-prettyWarnNoIndentL  = prettyWarnNoIndentWith  fillSep-prettyErrorNoIndentL = prettyErrorNoIndentWith fillSep--prettyDebugS, prettyInfoS, prettyNoteS, prettyWarnS, prettyErrorS, prettyWarnNoIndentS, prettyErrorNoIndentS-  :: (HasCallStack, HasTerm env, MonadReader env m, MonadIO m)-  => String -> m ()-prettyDebugS         = prettyDebugWith         flow-prettyInfoS          = prettyInfoWith          flow-prettyNoteS          = prettyNoteWith          flow-prettyWarnS          = prettyWarnWith          flow-prettyErrorS         = prettyErrorWith         flow-prettyWarnNoIndentS  = prettyWarnNoIndentWith  flow-prettyErrorNoIndentS = prettyErrorNoIndentWith flow---- End of aligned section---- | Use after a label and before the rest of what's being labelled for---   consistent spacing/indenting/etc.------   For example this is used after "Warning:" in warning messages.-indentAfterLabel :: StyleDoc -> StyleDoc-indentAfterLabel = align---- | Make a 'Doc' from each word in a 'String'-wordDocs :: String -> [StyleDoc]-wordDocs = map fromString . words---- | Wordwrap a 'String'-flow :: String -> StyleDoc-flow = fillSep . wordDocs--debugBracket :: (HasCallStack, HasTerm env, MonadReader env m,-                 MonadIO m, MonadUnliftIO m) => StyleDoc -> m a -> m a-debugBracket msg f = do-  let output = logDebug . RIO.display <=< displayWithColor-  output $ "Start: " <> msg-  start <- getMonotonicTime-  x <- f `catch` \ex -> do-      end <- getMonotonicTime-      let diff = end - start-      output $ "Finished with exception in" <+> displayMilliseconds diff <> ":" <+>-          msg <> line <>-          "Exception thrown: " <> fromString (show ex)-      throwIO (ex :: SomeException)-  end <- getMonotonicTime-  let diff = end - start-  output $ "Finished in" <+> displayMilliseconds diff <> ":" <+> msg-  return x---- |Annotate a 'StyleDoc' with a 'Style'.-style :: Style -> StyleDoc -> StyleDoc-style = styleAnn---- Display milliseconds.-displayMilliseconds :: Double -> StyleDoc-displayMilliseconds t = style Good $-    fromString (show (round (t * 1000) :: Int)) <> "ms"---- | Display a bulleted list of 'StyleDoc'.-bulletedList :: [StyleDoc] -> StyleDoc-bulletedList = mconcat . intersperse line . map (("*" <+>) . align)---- | A helper function to yield a narrative list from a list of items, with a--- final fullstop. For example, helps produce the output--- @\"apple, ball and cat.\"@ (no serial comma) or @\"apple, ball, and cat.\"@--- (serial comma) from @[\"apple\", \"ball\", \"cat\"]@.------ @since 0.1.4.0-mkNarrativeList :: Pretty a-                => Maybe Style-                -- ^ Style the items in the list?-                -> Bool-                -- ^ Use a serial comma?-                -> [a]-                -> [StyleDoc]-mkNarrativeList _ _ [] = []-mkNarrativeList mStyle _ [x] = [maybe id style mStyle (pretty x) <> "."]-mkNarrativeList mStyle useSerialComma [x1, x2] =-      mStyle' (pretty x1) <> (if useSerialComma then "," else mempty)-    : "and"-    : mkNarrativeList mStyle useSerialComma [x2]-  where-    mStyle' = maybe id style mStyle-mkNarrativeList mStyle useSerialComma (x:xs) =-      maybe id style mStyle (pretty x) <> ","-    : mkNarrativeList mStyle useSerialComma xs---- | Display a bulleted list of 'StyleDoc' with a blank line between--- each.-spacedBulletedList :: [StyleDoc] -> StyleDoc-spacedBulletedList = mconcat . intersperse (line <> line) . map (("*" <+>) . align)---- | The 'Style' intended to be associated with a 'LogLevel'.------ @since 0.1.1.0-logLevelToStyle :: LogLevel -> Style-logLevelToStyle level = case level of-  LevelDebug   -> Debug-  LevelInfo    -> Info-  LevelWarn    -> Warning-  LevelError   -> Error-  LevelOther _ -> OtherLevel+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module RIO.PrettyPrint
+  (
+    -- * Type classes for optionally colored terminal output
+    HasTerm (..)
+  , HasStylesUpdate (..)
+    -- * Pretty printing functions
+  , displayPlain
+  , displayWithColor
+    -- * Logging based on pretty-print typeclass
+  , prettyDebug
+  , prettyInfo
+  , prettyNote
+  , prettyWarn
+  , prettyError
+  , prettyWarnNoIndent
+  , prettyErrorNoIndent
+  , prettyDebugL
+  , prettyInfoL
+  , prettyNoteL
+  , prettyWarnL
+  , prettyErrorL
+  , prettyWarnNoIndentL
+  , prettyErrorNoIndentL
+  , prettyDebugS
+  , prettyInfoS
+  , prettyNoteS
+  , prettyWarnS
+  , prettyErrorS
+  , prettyWarnNoIndentS
+  , prettyErrorNoIndentS
+    -- * Semantic styling functions
+    -- | These are used rather than applying colors or other styling directly,
+    -- to provide consistency.
+  , style
+  , displayMilliseconds
+  , logLevelToStyle
+    -- * Formatting utils
+  , bulletedList
+  , mkNarrativeList
+  , spacedBulletedList
+  , debugBracket
+    -- * Re-exports from "Text.PrettyPrint.Leijen.Extended"
+  , Pretty (..)
+  , StyleDoc (..)
+  , StyleAnn (..)
+  , nest
+  , line
+  , linebreak
+  , group
+  , softline
+  , softbreak
+  , align
+  , hang
+  , indent
+  , encloseSep
+  , (<+>)
+  , hsep
+  , vsep
+  , fillSep
+  , sep
+  , hcat
+  , vcat
+  , fillCat
+  , cat
+  , punctuate
+  , fill
+  , fillBreak
+  , enclose
+  , squotes
+  , dquotes
+  , parens
+  , angles
+  , braces
+  , brackets
+  , string
+  , indentAfterLabel
+  , wordDocs
+  , flow
+    -- * Re-exports from "RIO.PrettyPrint.Types.PrettyPrint"
+  , Style (..)
+  ) where
+
+import           Data.List ( intersperse )
+import           RIO
+import           RIO.PrettyPrint.StylesUpdate ( HasStylesUpdate (..) )
+import           RIO.PrettyPrint.Types ( Style (..) )
+import           Text.PrettyPrint.Leijen.Extended
+                   ( Pretty (pretty), StyleAnn (..), StyleDoc, (<+>), align
+                   , angles, braces, brackets, cat, displayAnsi, displayPlain
+                   , dquotes, enclose, encloseSep, fill, fillBreak, fillCat
+                   , fillSep, group, hang, hcat, hsep, indent, line, linebreak
+                   , nest, parens, punctuate, sep, softbreak, softline, squotes
+                   , string, styleAnn, vcat, vsep
+                   )
+
+class (HasLogFunc env, HasStylesUpdate env) => HasTerm env where
+  useColorL :: Lens' env Bool
+  termWidthL :: Lens' env Int
+
+displayWithColor ::
+     (HasTerm env, Pretty a, MonadReader env m, HasCallStack)
+  => a
+  -> m Utf8Builder
+displayWithColor x = do
+  useAnsi <- view useColorL
+  termWidth <- view termWidthL
+  (if useAnsi then displayAnsi else displayPlain) termWidth x
+
+-- TODO: switch to using implicit callstacks once 7.8 support is dropped
+
+prettyWith ::
+     (HasTerm env, HasCallStack, Pretty b, MonadReader env m, MonadIO m)
+  => LogLevel
+  -> (a -> b)
+  -> a
+  -> m ()
+prettyWith level f = logGeneric "" level . RIO.display <=< displayWithColor . f
+
+-- Note: I think keeping this section aligned helps spot errors, might be
+-- worth keeping the alignment in place.
+
+prettyDebugWith, prettyInfoWith, prettyNoteWith, prettyWarnWith, prettyErrorWith, prettyWarnNoIndentWith, prettyErrorNoIndentWith
+  :: (HasCallStack, HasTerm env, MonadReader env m, MonadIO m)
+  => (a -> StyleDoc) -> a -> m ()
+prettyDebugWith = prettyWith LevelDebug
+prettyInfoWith  = prettyWith LevelInfo
+prettyNoteWith f  = prettyWith LevelInfo
+                          ((line <>) . (style Good "Note:" <+>) .
+                           indentAfterLabel . f)
+prettyWarnWith f  = prettyWith LevelWarn
+                          ((line <>) . (style Warning "Warning:" <+>) .
+                           indentAfterLabel . f)
+prettyErrorWith f = prettyWith LevelError
+                          ((line <>) . (style Error   "Error:" <+>) .
+                           indentAfterLabel . f)
+prettyWarnNoIndentWith f  = prettyWith LevelWarn
+                                  ((line <>) . (style Warning "Warning:" <+>) . f)
+prettyErrorNoIndentWith f = prettyWith LevelError
+                                  ((line <>) . (style Error   "Error:" <+>) . f)
+
+prettyDebug, prettyInfo, prettyNote, prettyWarn, prettyError, prettyWarnNoIndent, prettyErrorNoIndent
+  :: (HasCallStack, HasTerm env, MonadReader env m, MonadIO m)
+  => StyleDoc -> m ()
+prettyDebug         = prettyDebugWith         id
+prettyInfo          = prettyInfoWith          id
+prettyNote          = prettyNoteWith          id
+prettyWarn          = prettyWarnWith          id
+prettyError         = prettyErrorWith         id
+prettyWarnNoIndent  = prettyWarnNoIndentWith  id
+prettyErrorNoIndent = prettyErrorNoIndentWith id
+
+prettyDebugL, prettyInfoL, prettyNoteL, prettyWarnL, prettyErrorL, prettyWarnNoIndentL, prettyErrorNoIndentL
+  :: (HasCallStack, HasTerm env, MonadReader env m, MonadIO m)
+  => [StyleDoc] -> m ()
+prettyDebugL         = prettyDebugWith         fillSep
+prettyInfoL          = prettyInfoWith          fillSep
+prettyNoteL          = prettyNoteWith          fillSep
+prettyWarnL          = prettyWarnWith          fillSep
+prettyErrorL         = prettyErrorWith         fillSep
+prettyWarnNoIndentL  = prettyWarnNoIndentWith  fillSep
+prettyErrorNoIndentL = prettyErrorNoIndentWith fillSep
+
+prettyDebugS, prettyInfoS, prettyNoteS, prettyWarnS, prettyErrorS, prettyWarnNoIndentS, prettyErrorNoIndentS
+  :: (HasCallStack, HasTerm env, MonadReader env m, MonadIO m)
+  => String -> m ()
+prettyDebugS         = prettyDebugWith         flow
+prettyInfoS          = prettyInfoWith          flow
+prettyNoteS          = prettyNoteWith          flow
+prettyWarnS          = prettyWarnWith          flow
+prettyErrorS         = prettyErrorWith         flow
+prettyWarnNoIndentS  = prettyWarnNoIndentWith  flow
+prettyErrorNoIndentS = prettyErrorNoIndentWith flow
+
+-- End of aligned section
+
+-- | Use after a label and before the rest of what's being labelled for
+--   consistent spacing/indenting/etc.
+--
+--   For example this is used after "Warning:" in warning messages.
+indentAfterLabel :: StyleDoc -> StyleDoc
+indentAfterLabel = align
+
+-- | Make a 'Doc' from each word in a 'String'
+wordDocs :: String -> [StyleDoc]
+wordDocs = map fromString . words
+
+-- | Wordwrap a 'String'
+flow :: String -> StyleDoc
+flow = fillSep . wordDocs
+
+debugBracket :: (HasCallStack, HasTerm env, MonadReader env m,
+                 MonadIO m, MonadUnliftIO m) => StyleDoc -> m a -> m a
+debugBracket msg f = do
+  let output = logDebug . RIO.display <=< displayWithColor
+  output $ "Start: " <> msg
+  start <- getMonotonicTime
+  x <- f `catch` \ex -> do
+    end <- getMonotonicTime
+    let diff = end - start
+    output $
+         "Finished with exception in"
+      <+> displayMilliseconds diff <> ":"
+      <+> msg
+      <> line
+      <> "Exception thrown: "
+      <> fromString (show ex)
+    throwIO (ex :: SomeException)
+  end <- getMonotonicTime
+  let diff = end - start
+  output $ "Finished in" <+> displayMilliseconds diff <> ":" <+> msg
+  return x
+
+-- |Annotate a 'StyleDoc' with a 'Style'.
+style :: Style -> StyleDoc -> StyleDoc
+style = styleAnn
+
+-- Display milliseconds.
+displayMilliseconds :: Double -> StyleDoc
+displayMilliseconds t = style Good $
+  fromString (show (round (t * 1000) :: Int)) <> "ms"
+
+-- | Display a bulleted list of 'StyleDoc'.
+bulletedList :: [StyleDoc] -> StyleDoc
+bulletedList = mconcat . intersperse line . map (("*" <+>) . align)
+
+-- | A helper function to yield a narrative list from a list of items, with a
+-- final fullstop. For example, helps produce the output
+-- @\"apple, ball and cat.\"@ (no serial comma) or @\"apple, ball, and cat.\"@
+-- (serial comma) from @[\"apple\", \"ball\", \"cat\"]@.
+--
+-- @since 0.1.4.0
+mkNarrativeList ::
+     Pretty a
+  => Maybe Style
+  -- ^ Style the items in the list?
+  -> Bool
+  -- ^ Use a serial comma?
+  -> [a]
+  -> [StyleDoc]
+mkNarrativeList _ _ [] = []
+mkNarrativeList mStyle _ [x] = [maybe id style mStyle (pretty x) <> "."]
+mkNarrativeList mStyle useSerialComma [x1, x2] =
+    mStyle' (pretty x1) <> (if useSerialComma then "," else mempty)
+  : "and"
+  : mkNarrativeList mStyle useSerialComma [x2]
+ where
+  mStyle' = maybe id style mStyle
+mkNarrativeList mStyle useSerialComma (x:xs) =
+    maybe id style mStyle (pretty x) <> ","
+  : mkNarrativeList mStyle useSerialComma xs
+
+-- | Display a bulleted list of 'StyleDoc' with a blank line between
+-- each.
+spacedBulletedList :: [StyleDoc] -> StyleDoc
+spacedBulletedList = mconcat . intersperse (line <> line) . map (("*" <+>) . align)
+
+-- | The 'Style' intended to be associated with a 'LogLevel'.
+--
+-- @since 0.1.1.0
+logLevelToStyle :: LogLevel -> Style
+logLevelToStyle level = case level of
+  LevelDebug   -> Debug
+  LevelInfo    -> Info
+  LevelWarn    -> Warning
+  LevelError   -> Error
+  LevelOther _ -> OtherLevel

@@ -1,39 +1,40 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-}--module RIO.PrettyPrint.DefaultStyles-  (-    defaultStyles-  ) where--import Data.Array.IArray (array)-import RIO-import RIO.PrettyPrint.Types (Style (..), Styles)-import System.Console.ANSI.Codes (Color (..), ColorIntensity (..),-  ConsoleIntensity (..), ConsoleLayer (..), SGR (..))---- | Default styles for rio-prettyprint output.-defaultStyles :: Styles-defaultStyles = array (minBound, maxBound)-  [ (Error, ("error", [SetColor Foreground Vivid Red]))-  , (Warning, ("warning", [SetColor Foreground Dull Yellow]))-  , (Info, ("info", [SetColor Foreground Dull Blue]))-  , (Debug, ("debug", [SetColor Foreground Dull Green]))-  , (OtherLevel, ("other-level", [SetColor Foreground Dull Magenta]))-  , (Good, ("good", [SetColor Foreground Vivid Green]))-  , (Shell, ("shell", [SetColor Foreground Vivid Magenta]))-  , (File, ("file", [SetColor Foreground Dull Cyan]))-  -- For now 'Url' using the same style as 'File'-  , (Url, ("url", [SetColor Foreground Dull Cyan]))-  , (Dir, ("dir", [ SetConsoleIntensity BoldIntensity-                  , SetColor Foreground Vivid Blue ]))-  , (Recommendation, ("recommendation", [ SetConsoleIntensity BoldIntensity-                                      , SetColor Foreground Vivid Green]))-  , (Current, ("current", [SetColor Foreground Dull Yellow]))-  , (Target, ("target", [SetColor Foreground Vivid Cyan]))-  -- TODO: what color should Module be?-  , (Module, ("module", [SetColor Foreground Vivid Magenta]))-  , (PkgComponent, ("package-component", [SetColor Foreground Vivid Cyan]))-  , (Secondary, ("secondary", [SetColor Foreground Vivid Black]))-  , (Highlight, ("highlight", [SetColor Foreground Vivid Green]))-  ]+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module RIO.PrettyPrint.DefaultStyles
+  ( defaultStyles
+  ) where
+
+import           Data.Array.IArray ( array )
+import           RIO
+import           RIO.PrettyPrint.Types ( Style (..), Styles )
+import           System.Console.ANSI.Codes
+                   ( Color (..), ColorIntensity (..), ConsoleIntensity (..)
+                   , ConsoleLayer (..), SGR (..)
+                   )
+
+-- | Default styles for rio-prettyprint output.
+defaultStyles :: Styles
+defaultStyles = array (minBound, maxBound)
+  [ (Error, ("error", [SetColor Foreground Vivid Red]))
+  , (Warning, ("warning", [SetColor Foreground Dull Yellow]))
+  , (Info, ("info", [SetColor Foreground Dull Blue]))
+  , (Debug, ("debug", [SetColor Foreground Dull Green]))
+  , (OtherLevel, ("other-level", [SetColor Foreground Dull Magenta]))
+  , (Good, ("good", [SetColor Foreground Vivid Green]))
+  , (Shell, ("shell", [SetColor Foreground Vivid Magenta]))
+  , (File, ("file", [SetColor Foreground Dull Cyan]))
+    -- For now 'Url' using the same style as 'File'
+  , (Url, ("url", [SetColor Foreground Dull Cyan]))
+  , (Dir, ("dir", [ SetConsoleIntensity BoldIntensity
+                  , SetColor Foreground Vivid Blue ]))
+  , (Recommendation, ("recommendation", [ SetConsoleIntensity BoldIntensity
+                                      , SetColor Foreground Vivid Green]))
+  , (Current, ("current", [SetColor Foreground Dull Yellow]))
+  , (Target, ("target", [SetColor Foreground Vivid Cyan]))
+    -- TODO: what color should Module be?
+  , (Module, ("module", [SetColor Foreground Vivid Magenta]))
+  , (PkgComponent, ("package-component", [SetColor Foreground Vivid Cyan]))
+  , (Secondary, ("secondary", [SetColor Foreground Vivid Black]))
+  , (Highlight, ("highlight", [SetColor Foreground Vivid Green]))
+  ]

@@ -1,77 +1,77 @@-{-# LANGUAGE NoImplicitPrelude         #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE StandaloneDeriving        #-}---- | This module provides a type representing pretty exceptions. It can be used--- as in the example below:------ > {-# LANGUAGE NoImplicitPrelude #-}--- > {-# LANGUAGE OverloadedStrings #-}--- >--- > module Main (main) where--- >--- > import RIO--- >          ( Exception, Handler (..), IO, RIO, Show, SomeException (..), Typeable--- >          , ($), catches, displayException, exitFailure, fromString, logError--- >          , mempty, throwIO--- >          )--- > import RIO.PrettyPrint--- >          ( Pretty (..), Style (..), (<+>), prettyError, prettyInfo, style )--- > import RIO.PrettyPrint.PrettyException ( PrettyException (..) )--- > import RIO.PrettyPrint.Simple ( SimplePrettyApp, runSimplePrettyApp )--- >--- > main :: IO ()--- > main = runSimplePrettyApp 80 mempty (action `catches` handleExceptions)--- >  where--- >   action :: RIO SimplePrettyApp ()--- >   action = do--- >       prettyInfo "Running action!"--- >       throwIO (PrettyException MyPrettyException)--- >--- >  handleExceptions :: [Handler (RIO SimplePrettyApp) ()]--- >  handleExceptions =--- >    [ Handler handlePrettyException--- >    , Handler handleSomeException--- >    ]--- >--- >  handlePrettyException :: PrettyException -> RIO SimplePrettyApp ()--- >  handlePrettyException e = do--- >    prettyError $ pretty e--- >    exitFailure--- >--- >  handleSomeException :: SomeException -> RIO SimplePrettyApp ()--- >  handleSomeException (SomeException e) = do--- >    logError $ fromString $ displayException e--- >    exitFailure--- >--- > data MyPrettyException--- >   = MyPrettyException--- >   deriving (Show, Typeable)--- >--- > instance Pretty MyPrettyException where--- >   pretty MyPrettyException =--- >     "My" <+> style Highlight "pretty" <+> "exception!"--- >--- > instance Exception MyPrettyException----module RIO.PrettyPrint.PrettyException-  ( PrettyException (..)-  ) where--import RIO (Exception (..), Show, Typeable)-import Text.PrettyPrint.Leijen.Extended (Pretty (..))---- | Type representing pretty exceptions.------ @since 0.1.4.0-data PrettyException-  = forall e. (Exception e, Pretty e) => PrettyException e-  deriving Typeable--deriving instance Show PrettyException--instance Pretty PrettyException where-  pretty (PrettyException e) = pretty e--instance Exception PrettyException where-  displayException (PrettyException e) = displayException e+{-# LANGUAGE NoImplicitPrelude         #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE StandaloneDeriving        #-}
+
+-- | This module provides a type representing pretty exceptions. It can be used
+-- as in the example below:
+--
+-- > {-# LANGUAGE NoImplicitPrelude #-}
+-- > {-# LANGUAGE OverloadedStrings #-}
+-- >
+-- > module Main (main) where
+-- >
+-- > import RIO
+-- >          ( Exception, Handler (..), IO, RIO, Show, SomeException (..), Typeable
+-- >          , ($), catches, displayException, exitFailure, fromString, logError
+-- >          , mempty, throwIO
+-- >          )
+-- > import RIO.PrettyPrint
+-- >          ( Pretty (..), Style (..), (<+>), prettyError, prettyInfo, style )
+-- > import RIO.PrettyPrint.PrettyException ( PrettyException (..) )
+-- > import RIO.PrettyPrint.Simple ( SimplePrettyApp, runSimplePrettyApp )
+-- >
+-- > main :: IO ()
+-- > main = runSimplePrettyApp 80 mempty (action `catches` handleExceptions)
+-- >  where
+-- >   action :: RIO SimplePrettyApp ()
+-- >   action = do
+-- >       prettyInfo "Running action!"
+-- >       throwIO (PrettyException MyPrettyException)
+-- >
+-- >  handleExceptions :: [Handler (RIO SimplePrettyApp) ()]
+-- >  handleExceptions =
+-- >    [ Handler handlePrettyException
+-- >    , Handler handleSomeException
+-- >    ]
+-- >
+-- >  handlePrettyException :: PrettyException -> RIO SimplePrettyApp ()
+-- >  handlePrettyException e = do
+-- >    prettyError $ pretty e
+-- >    exitFailure
+-- >
+-- >  handleSomeException :: SomeException -> RIO SimplePrettyApp ()
+-- >  handleSomeException (SomeException e) = do
+-- >    logError $ fromString $ displayException e
+-- >    exitFailure
+-- >
+-- > data MyPrettyException
+-- >   = MyPrettyException
+-- >   deriving (Show, Typeable)
+-- >
+-- > instance Pretty MyPrettyException where
+-- >   pretty MyPrettyException =
+-- >     "My" <+> style Highlight "pretty" <+> "exception!"
+-- >
+-- > instance Exception MyPrettyException
+--
+module RIO.PrettyPrint.PrettyException
+  ( PrettyException (..)
+  ) where
+
+import RIO ( Exception (..), Show, Typeable )
+import Text.PrettyPrint.Leijen.Extended ( Pretty (..) )
+
+-- | Type representing pretty exceptions.
+--
+-- @since 0.1.4.0
+data PrettyException
+  = forall e. (Exception e, Pretty e) => PrettyException e
+  deriving Typeable
+
+deriving instance Show PrettyException
+
+instance Pretty PrettyException where
+  pretty (PrettyException e) = pretty e
+
+instance Exception PrettyException where
+  displayException (PrettyException e) = displayException e

@@ -1,98 +1,100 @@-{-# LANGUAGE NoImplicitPrelude #-}--{-|-This module exports a 'SimplePrettyApp' type, for providing a basic environment-including pretty printing functionality.--}-module RIO.PrettyPrint.Simple-  ( SimplePrettyApp-  , mkSimplePrettyApp-  , runSimplePrettyApp-  ) where--import System.Environment (lookupEnv)--import RIO-         ( Bool (..), HasLogFunc (..), Int, LogFunc, Maybe (..), MonadIO, RIO-         , ($), (<$>), isJust, lens, liftIO, logOptionsHandle, maybe, pure-         , runRIO, setLogUseColor, stderr, withLogFunc-         )-import RIO.Process-         ( HasProcessContext (..), ProcessContext, mkDefaultProcessContext )--import RIO.PrettyPrint (HasTerm (..))-import RIO.PrettyPrint.StylesUpdate (HasStylesUpdate (..), StylesUpdate (..))---- | A simple, non-customizable environment type, which provides--- pretty printing functionality.------ @since 0.1.3.0-data SimplePrettyApp = SimplePrettyApp-  { spaLogFunc :: !LogFunc-  , spaProcessContext :: !ProcessContext-  , spaUseColor :: !Bool-  , spaTermWidth :: !Int-  , spaStylesUpdate :: !StylesUpdate-  }--instance HasLogFunc SimplePrettyApp where-  logFuncL = lens spaLogFunc (\x y -> x { spaLogFunc = y })--instance HasProcessContext SimplePrettyApp where-  processContextL = lens spaProcessContext (\x y -> x { spaProcessContext = y })--instance HasStylesUpdate SimplePrettyApp where-  stylesUpdateL = lens spaStylesUpdate (\x y -> x { spaStylesUpdate = y })--instance HasTerm SimplePrettyApp where-  useColorL = lens spaUseColor (\x y -> x { spaUseColor = y })-  termWidthL = lens spaTermWidth (\x y -> x { spaTermWidth = y })---- | Constructor for 'SimplePrettyApp'. If 'ProcessContext' is not supplied--- 'mkDefaultProcessContext' will be used to create it.------ @since 0.1.3.0-mkSimplePrettyApp-  :: MonadIO m-  => LogFunc-  -> Maybe ProcessContext-  -> Bool-     -- ^ Use color?-  -> Int-     -- ^ Terminal width-  -> StylesUpdate-  -> m SimplePrettyApp-mkSimplePrettyApp logFunc mProcessContext useColor termWidth stylesUpdate = do-  processContext <- maybe mkDefaultProcessContext pure mProcessContext-  pure $ SimplePrettyApp-    { spaLogFunc = logFunc-    , spaProcessContext = processContext-    , spaUseColor = useColor-    , spaTermWidth = termWidth-    , spaStylesUpdate = stylesUpdate-    }---- | Run with a default configured @SimplePrettyApp@, consisting of:------ * Logging to 'stderr'------ * If the @RIO_VERBOSE@ environment variable is set, turns on verbose logging------ * Default process context------ * Logging using color------ @since 0.1.3.0-runSimplePrettyApp-  :: MonadIO m-  => Int-     -- ^ Terminal width-  -> StylesUpdate-  -> RIO SimplePrettyApp a-  -> m a-runSimplePrettyApp termWidth stylesUpdate m = liftIO $ do-  verbose <- isJust <$> lookupEnv "RIO_VERBOSE"-  lo <- setLogUseColor True <$> logOptionsHandle stderr verbose-  withLogFunc lo $ \lf -> do-    simplePrettyApp <- mkSimplePrettyApp lf Nothing True termWidth stylesUpdate-    runRIO simplePrettyApp m+{-# LANGUAGE NoImplicitPrelude #-}
+
+{-|
+This module exports a 'SimplePrettyApp' type, for providing a basic environment
+including pretty printing functionality.
+-}
+module RIO.PrettyPrint.Simple
+  ( SimplePrettyApp
+  , mkSimplePrettyApp
+  , runSimplePrettyApp
+  ) where
+
+import           RIO
+                   ( Bool (..), HasLogFunc (..), Int, LogFunc, Maybe (..)
+                   , MonadIO, RIO, ($), (<$>), isJust, lens, liftIO
+                   , logOptionsHandle, maybe, pure, runRIO, setLogUseColor
+                   , stderr, withLogFunc
+                   )
+import           RIO.PrettyPrint ( HasTerm (..) )
+import           RIO.PrettyPrint.StylesUpdate
+                   ( HasStylesUpdate (..), StylesUpdate (..) )
+import           RIO.Process
+                   ( HasProcessContext (..), ProcessContext
+                   , mkDefaultProcessContext
+                   )
+import           System.Environment ( lookupEnv )
+
+-- | A simple, non-customizable environment type, which provides
+-- pretty printing functionality.
+--
+-- @since 0.1.3.0
+data SimplePrettyApp = SimplePrettyApp
+  { spaLogFunc :: !LogFunc
+  , spaProcessContext :: !ProcessContext
+  , spaUseColor :: !Bool
+  , spaTermWidth :: !Int
+  , spaStylesUpdate :: !StylesUpdate
+  }
+
+instance HasLogFunc SimplePrettyApp where
+  logFuncL = lens spaLogFunc (\x y -> x { spaLogFunc = y })
+
+instance HasProcessContext SimplePrettyApp where
+  processContextL = lens spaProcessContext (\x y -> x { spaProcessContext = y })
+
+instance HasStylesUpdate SimplePrettyApp where
+  stylesUpdateL = lens spaStylesUpdate (\x y -> x { spaStylesUpdate = y })
+
+instance HasTerm SimplePrettyApp where
+  useColorL = lens spaUseColor (\x y -> x { spaUseColor = y })
+  termWidthL = lens spaTermWidth (\x y -> x { spaTermWidth = y })
+
+-- | Constructor for 'SimplePrettyApp'. If 'ProcessContext' is not supplied
+-- 'mkDefaultProcessContext' will be used to create it.
+--
+-- @since 0.1.3.0
+mkSimplePrettyApp ::
+     MonadIO m
+  => LogFunc
+  -> Maybe ProcessContext
+  -> Bool
+     -- ^ Use color?
+  -> Int
+     -- ^ Terminal width
+  -> StylesUpdate
+  -> m SimplePrettyApp
+mkSimplePrettyApp logFunc mProcessContext useColor termWidth stylesUpdate = do
+  processContext <- maybe mkDefaultProcessContext pure mProcessContext
+  pure $ SimplePrettyApp
+    { spaLogFunc = logFunc
+    , spaProcessContext = processContext
+    , spaUseColor = useColor
+    , spaTermWidth = termWidth
+    , spaStylesUpdate = stylesUpdate
+    }
+
+-- | Run with a default configured @SimplePrettyApp@, consisting of:
+--
+-- * Logging to 'stderr'
+--
+-- * If the @RIO_VERBOSE@ environment variable is set, turns on verbose logging
+--
+-- * Default process context
+--
+-- * Logging using color
+--
+-- @since 0.1.3.0
+runSimplePrettyApp ::
+     MonadIO m
+  => Int
+     -- ^ Terminal width
+  -> StylesUpdate
+  -> RIO SimplePrettyApp a
+  -> m a
+runSimplePrettyApp termWidth stylesUpdate m = liftIO $ do
+  verbose <- isJust <$> lookupEnv "RIO_VERBOSE"
+  lo <- setLogUseColor True <$> logOptionsHandle stderr verbose
+  withLogFunc lo $ \lf -> do
+    simplePrettyApp <- mkSimplePrettyApp lf Nothing True termWidth stylesUpdate
+    runRIO simplePrettyApp m

@@ -1,165 +1,166 @@-{-# LANGUAGE NoImplicitPrelude          #-}--module RIO.PrettyPrint.StylesUpdate-  (-    StylesUpdate (..)-  , parseStylesUpdateFromString-  , HasStylesUpdate (..)-  ) where--import Data.Aeson (FromJSON(..), withText)-import Data.Array.IArray (assocs)-import Data.Colour.SRGB (Colour, sRGB24)-import Data.Text as T (pack, unpack)-import RIO-import RIO.PrettyPrint.DefaultStyles (defaultStyles)-import RIO.PrettyPrint.Types (Style, StyleSpec)-import System.Console.ANSI.Types (BlinkSpeed (..), Color (..),-         ColorIntensity (..), ConsoleIntensity (..), ConsoleLayer (..),-         SGR (..), Underlining (..))---- |Updates to 'Styles'-newtype StylesUpdate = StylesUpdate { stylesUpdate :: [(Style, StyleSpec)] }-  deriving (Eq, Show)---- |The first styles update overrides the second one.-instance Semigroup StylesUpdate where-  -- See module "Data.IArray.Array" of package @array@: this depends on GHC's-  -- implementation of '(//)' being such that the last value specified for a-  -- duplicated index is used.-  StylesUpdate s1 <> StylesUpdate s2 = StylesUpdate (s2 <> s1)--instance Monoid StylesUpdate where-  mempty = StylesUpdate []-  mappend = (<>) -- This needs to be specified as, before package-                 -- @base-4.11.0.0@ (GHC 8.4.2, March 2018), the default is-                 -- 'mappend = (++)'.--instance FromJSON StylesUpdate where-  parseJSON = withText "StylesUpdate" $-    return . parseStylesUpdateFromString . T.unpack---- |Parse a string that is a colon-delimited sequence of key=value, where 'key'--- is a style name and 'value' is a semicolon-delimited list of 'ANSI' SGR--- (Select Graphic Rendition) control codes (in decimal). Keys that are not--- present in 'defaultStyles' are ignored. Items in the semicolon-delimited--- list that are not recognised as valid control codes are ignored.-parseStylesUpdateFromString :: String -> StylesUpdate-parseStylesUpdateFromString s = StylesUpdate $ mapMaybe process table- where-  table = do-    w <- split ':' s-    let (k, v') = break (== '=') w-    case v' of-      '=' : v -> return (T.pack k, parseCodes v)-      _ -> []--  process :: StyleSpec -> Maybe (Style, StyleSpec)-  process (k, sgrs) = do-    style <- lookup k styles-    return (style, (k, sgrs))--styles :: [(Text, Style)]-styles = map (\(s, (k, _)) -> (k, s)) $ assocs defaultStyles--parseCodes :: String -> [SGR]-parseCodes [] = []-parseCodes s = parseCodes' c- where-  s' = split ';' s-  c :: [Word8]-  c = mapMaybe readMaybe s'--parseCodes' :: [Word8] -> [SGR]-parseCodes' c = case codeToSGR c of-  (Nothing, []) -> []-  (Just sgr, []) -> [sgr]-  (Nothing, cs) -> parseCodes' cs-  (Just sgr, cs) -> sgr : parseCodes' cs--split :: Char -> String -> [String]-split c s = case rest of-                []     -> [chunk]-                _:rest1 -> chunk : split c rest1-  where-    (chunk, rest) = break (==c) s---- |This function is, essentially, the inverse of 'sgrToCode' exported by--- module "System.Console.ANSI.Codes" of the @ansi-terminal@ package. The--- \'ANSI\' standards refer to (1) standard ECMA-48 \`Control Functions for--- Coded Character Sets\' (5th edition, 1991); (2) extensions in ITU-T--- Recommendation (previously CCITT Recommendation) T.416 (03/93) \'Information--- Technology – Open Document Architecture (ODA) and Interchange Format:--- Character Content Architectures\` (also published as ISO/IEC International--- Standard 8613-6); and (3) further extensions used by \'XTerm\', a terminal--- emulator for the X Window System. The escape codes are described in a--- Wikipedia article at <http://en.wikipedia.org/wiki/ANSI_escape_code> and--- those codes supported on current versions of Windows at--- <https://docs.microsoft.com/en-us/windows/console/console-virtual-terminal-sequences>.-codeToSGR :: [Word8] -> (Maybe SGR, [Word8])-codeToSGR [] = (Nothing, [])-codeToSGR (c:cs)-  | c ==  0 = (Just Reset, cs)-  | c ==  1 = (Just $ SetConsoleIntensity BoldIntensity, cs)-  | c ==  2 = (Just $ SetConsoleIntensity FaintIntensity, cs)-  | c ==  3 = (Just $ SetItalicized True, cs)-  | c ==  4 = (Just $ SetUnderlining SingleUnderline, cs)-  | c ==  5 = (Just $ SetBlinkSpeed SlowBlink, cs)-  | c ==  6 = (Just $ SetBlinkSpeed RapidBlink, cs)-  | c ==  7 = (Just $ SetSwapForegroundBackground True, cs)-  | c ==  8 = (Just $ SetVisible False, cs)-  | c == 21 = (Just $ SetUnderlining DoubleUnderline, cs)-  | c == 22 = (Just $ SetConsoleIntensity NormalIntensity, cs)-  | c == 23 = (Just $ SetItalicized False, cs)-  | c == 24 = (Just $ SetUnderlining NoUnderline, cs)-  | c == 25 = (Just $ SetBlinkSpeed NoBlink, cs)-  | c == 27 = (Just $ SetSwapForegroundBackground False, cs)-  | c == 28 = (Just $ SetVisible True, cs)-  | c >= 30 && c <= 37 =-    (Just $ SetColor Foreground Dull $ codeToColor (c - 30), cs)-  | c == 38 = case codeToRGB cs of-    (Nothing, cs') -> (Nothing, cs')-    (Just color, cs') -> (Just $ SetRGBColor Foreground color, cs')-  | c >= 40 && c <= 47 =-    (Just $ SetColor Background Dull $ codeToColor (c - 40), cs)-  | c == 48 = case codeToRGB cs of-    (Nothing, cs') -> (Nothing, cs')-    (Just color, cs') -> (Just $ SetRGBColor Background color, cs')-  | c >= 90 && c <= 97 =-    (Just $ SetColor Foreground Vivid $ codeToColor (c - 90), cs)-  | c >= 100 && c <= 107 =-    (Just $ SetColor Background Vivid $ codeToColor (c - 100), cs)-  | otherwise = (Nothing, cs)---- |This function is, essentially, the inverse of 'colorToCode' exported by--- module "System.Console.ANSI.Codes" of the @ansi-terminal@ package. The--- \'ANSI\' standards refer to eight named colours in a specific order. The code--- is a 0-based index of those colours.-codeToColor :: Word8 -> Color-codeToColor c-  -- 'toEnum' is not used because the @ansi-terminal@ package does not-  -- /guarantee/ the order of the data constructors of type 'Color' will be the-  -- same as that of the \'ANSI\' standards (although it currently is). (The-  -- 'colorToCode' function itself does not use 'fromEnum'.)-  | c == 0 = Black-  | c == 1 = Red-  | c == 2 = Green-  | c == 3 = Yellow-  | c == 4 = Blue-  | c == 5 = Magenta-  | c == 6 = Cyan-  | c == 7 = White-  | otherwise = error "Error: codeToColor, code outside 0 to 7."--codeToRGB :: [Word8] -> (Maybe (Colour Float), [Word8])-codeToRGB [] = (Nothing, [])-codeToRGB (2:r:g:b:cs) = (Just $ sRGB24 r g b, cs)-codeToRGB cs = (Nothing, cs)---- | Environment values with a styles update.------ @since 0.1.0.0-class HasStylesUpdate env where-  stylesUpdateL :: Lens' env StylesUpdate-instance HasStylesUpdate StylesUpdate where-  stylesUpdateL = id+{-# LANGUAGE NoImplicitPrelude          #-}
+
+module RIO.PrettyPrint.StylesUpdate
+  ( StylesUpdate (..)
+  , parseStylesUpdateFromString
+  , HasStylesUpdate (..)
+  ) where
+
+import           Data.Aeson ( FromJSON (..), withText )
+import           Data.Array.IArray ( assocs )
+import           Data.Colour.SRGB ( Colour, sRGB24 )
+import           Data.Text as T ( pack, unpack )
+import           RIO
+import           RIO.PrettyPrint.DefaultStyles ( defaultStyles )
+import           RIO.PrettyPrint.Types ( Style, StyleSpec )
+import           System.Console.ANSI.Types
+                   ( BlinkSpeed (..), Color (..), ColorIntensity (..)
+                   , ConsoleIntensity (..), ConsoleLayer (..), SGR (..)
+                   , Underlining (..)
+                   )
+
+-- | Updates to 'Styles'
+newtype StylesUpdate = StylesUpdate { stylesUpdate :: [(Style, StyleSpec)] }
+  deriving (Eq, Show)
+
+-- | The first styles update overrides the second one.
+instance Semigroup StylesUpdate where
+  -- See module "Data.IArray.Array" of package @array@: this depends on GHC's
+  -- implementation of '(//)' being such that the last value specified for a
+  -- duplicated index is used.
+  StylesUpdate s1 <> StylesUpdate s2 = StylesUpdate (s2 <> s1)
+
+instance Monoid StylesUpdate where
+  mempty = StylesUpdate []
+  mappend = (<>) -- This needs to be specified as, before package
+                 -- @base-4.11.0.0@ (GHC 8.4.2, March 2018), the default is
+                 -- 'mappend = (++)'.
+
+instance FromJSON StylesUpdate where
+  parseJSON = withText "StylesUpdate" $
+    return . parseStylesUpdateFromString . T.unpack
+
+-- |Parse a string that is a colon-delimited sequence of key=value, where 'key'
+-- is a style name and 'value' is a semicolon-delimited list of 'ANSI' SGR
+-- (Select Graphic Rendition) control codes (in decimal). Keys that are not
+-- present in 'defaultStyles' are ignored. Items in the semicolon-delimited
+-- list that are not recognised as valid control codes are ignored.
+parseStylesUpdateFromString :: String -> StylesUpdate
+parseStylesUpdateFromString s = StylesUpdate $ mapMaybe process table
+ where
+  table = do
+    w <- split ':' s
+    let (k, v') = break (== '=') w
+    case v' of
+      '=' : v -> return (T.pack k, parseCodes v)
+      _ -> []
+
+  process :: StyleSpec -> Maybe (Style, StyleSpec)
+  process (k, sgrs) = do
+    style <- lookup k styles
+    return (style, (k, sgrs))
+
+styles :: [(Text, Style)]
+styles = map (\(s, (k, _)) -> (k, s)) $ assocs defaultStyles
+
+parseCodes :: String -> [SGR]
+parseCodes [] = []
+parseCodes s = parseCodes' c
+ where
+  s' = split ';' s
+  c :: [Word8]
+  c = mapMaybe readMaybe s'
+
+parseCodes' :: [Word8] -> [SGR]
+parseCodes' c = case codeToSGR c of
+  (Nothing, []) -> []
+  (Just sgr, []) -> [sgr]
+  (Nothing, cs) -> parseCodes' cs
+  (Just sgr, cs) -> sgr : parseCodes' cs
+
+split :: Char -> String -> [String]
+split c s = case rest of
+  []     -> [chunk]
+  _:rest1 -> chunk : split c rest1
+ where
+  (chunk, rest) = break (==c) s
+
+-- |This function is, essentially, the inverse of 'sgrToCode' exported by
+-- module "System.Console.ANSI.Codes" of the @ansi-terminal@ package. The
+-- \'ANSI\' standards refer to (1) standard ECMA-48 \`Control Functions for
+-- Coded Character Sets\' (5th edition, 1991); (2) extensions in ITU-T
+-- Recommendation (previously CCITT Recommendation) T.416 (03/93) \'Information
+-- Technology – Open Document Architecture (ODA) and Interchange Format:
+-- Character Content Architectures\` (also published as ISO/IEC International
+-- Standard 8613-6); and (3) further extensions used by \'XTerm\', a terminal
+-- emulator for the X Window System. The escape codes are described in a
+-- Wikipedia article at <http://en.wikipedia.org/wiki/ANSI_escape_code> and
+-- those codes supported on current versions of Windows at
+-- <https://docs.microsoft.com/en-us/windows/console/console-virtual-terminal-sequences>.
+codeToSGR :: [Word8] -> (Maybe SGR, [Word8])
+codeToSGR [] = (Nothing, [])
+codeToSGR (c:cs)
+  | c ==  0 = (Just Reset, cs)
+  | c ==  1 = (Just $ SetConsoleIntensity BoldIntensity, cs)
+  | c ==  2 = (Just $ SetConsoleIntensity FaintIntensity, cs)
+  | c ==  3 = (Just $ SetItalicized True, cs)
+  | c ==  4 = (Just $ SetUnderlining SingleUnderline, cs)
+  | c ==  5 = (Just $ SetBlinkSpeed SlowBlink, cs)
+  | c ==  6 = (Just $ SetBlinkSpeed RapidBlink, cs)
+  | c ==  7 = (Just $ SetSwapForegroundBackground True, cs)
+  | c ==  8 = (Just $ SetVisible False, cs)
+  | c == 21 = (Just $ SetUnderlining DoubleUnderline, cs)
+  | c == 22 = (Just $ SetConsoleIntensity NormalIntensity, cs)
+  | c == 23 = (Just $ SetItalicized False, cs)
+  | c == 24 = (Just $ SetUnderlining NoUnderline, cs)
+  | c == 25 = (Just $ SetBlinkSpeed NoBlink, cs)
+  | c == 27 = (Just $ SetSwapForegroundBackground False, cs)
+  | c == 28 = (Just $ SetVisible True, cs)
+  | c >= 30 && c <= 37 =
+    (Just $ SetColor Foreground Dull $ codeToColor (c - 30), cs)
+  | c == 38 = case codeToRGB cs of
+    (Nothing, cs') -> (Nothing, cs')
+    (Just color, cs') -> (Just $ SetRGBColor Foreground color, cs')
+  | c >= 40 && c <= 47 =
+    (Just $ SetColor Background Dull $ codeToColor (c - 40), cs)
+  | c == 48 = case codeToRGB cs of
+    (Nothing, cs') -> (Nothing, cs')
+    (Just color, cs') -> (Just $ SetRGBColor Background color, cs')
+  | c >= 90 && c <= 97 =
+    (Just $ SetColor Foreground Vivid $ codeToColor (c - 90), cs)
+  | c >= 100 && c <= 107 =
+    (Just $ SetColor Background Vivid $ codeToColor (c - 100), cs)
+  | otherwise = (Nothing, cs)
+
+-- |This function is, essentially, the inverse of 'colorToCode' exported by
+-- module "System.Console.ANSI.Codes" of the @ansi-terminal@ package. The
+-- \'ANSI\' standards refer to eight named colours in a specific order. The code
+-- is a 0-based index of those colours.
+codeToColor :: Word8 -> Color
+codeToColor c
+  -- 'toEnum' is not used because the @ansi-terminal@ package does not
+  -- /guarantee/ the order of the data constructors of type 'Color' will be the
+  -- same as that of the \'ANSI\' standards (although it currently is). (The
+  -- 'colorToCode' function itself does not use 'fromEnum'.)
+  | c == 0 = Black
+  | c == 1 = Red
+  | c == 2 = Green
+  | c == 3 = Yellow
+  | c == 4 = Blue
+  | c == 5 = Magenta
+  | c == 6 = Cyan
+  | c == 7 = White
+  | otherwise = error "Error: codeToColor, code outside 0 to 7."
+
+codeToRGB :: [Word8] -> (Maybe (Colour Float), [Word8])
+codeToRGB [] = (Nothing, [])
+codeToRGB (2:r:g:b:cs) = (Just $ sRGB24 r g b, cs)
+codeToRGB cs = (Nothing, cs)
+
+-- | Environment values with a styles update.
+--
+-- @since 0.1.0.0
+class HasStylesUpdate env where
+  stylesUpdateL :: Lens' env StylesUpdate
+instance HasStylesUpdate StylesUpdate where
+  stylesUpdateL = id

@@ -1,70 +1,69 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-|-For the most part, the data constructors of 'Style' do not clash with other-names. When they do, import the module qualified. For example:--> import qualified RIO.PrettyPrint.Types.PrettyPrint as PP--}-module RIO.PrettyPrint.Types-  (-    Style (..)-  , Styles-  , StyleSpec-  ) where--import Data.Array.IArray (Array)-import Data.Ix (Ix)-import Data.Text (Text)-import RIO-import System.Console.ANSI.Types (SGR)---- |A style of rio-prettyprint's output.-data Style-  = Error     -- Should be used sparingly, not to style entire long messages.-              -- For example, it's used to style the "Error:" or "[error]" label-              -- for an error message, not the entire message.-  | Warning   -- Should be used sparingly, not to style entire long messages.-              -- For example, it's used to style the "Warning:" or "[warn]"-              -- label for a warning message, not the entire message.-  | Info      -- Should be used sparingly, not to style entire long messages.-              -- For example, it's used to style the "[info]" label for an info-              -- message, not the entire message.-  | Debug     -- Should be used sparingly, not to style entire long messages.-              -- For example, it's used to style the "[debug]" label for a debug-              -- message, not the entire message.-  | OtherLevel      -- Should be used sparingly, not to style entire long-                    -- messages. For example, it's used to style the "[...]"-                    -- label for an other log level message, not the entire-                    -- message.-  | Good      -- Style in a way to emphasize that it is a particularly good-              -- thing.-  | Shell     -- Style as a shell command, i.e. when suggesting something to the-              -- user that should be typed in directly as written.-  | File      -- Style as a filename. See 'Dir' for directories.-  | Url       -- Style as a URL.-  | Dir       -- Style as a directory name. See 'File' for files.-  | Recommendation  -- Style used to highlight part of a recommended course of-                    -- action.-  | Current   -- Style in a way that emphasizes that it is related to a current-              -- thing. For example, could be used when talking about the current-              -- package we're processing when outputting the name of it.-  | Target    -- TODO: figure out how to describe this-  | Module    -- Style as a module name.-  | PkgComponent    -- Style used to highlight the named component of a package.-  | Secondary -- Style for secondary content. For example, it's used to style-              -- timestamps.-  | Highlight -- Should be used sparingly, not to style entire long messages.-              -- For example, it's used to style the duration in a "Finished-              -- process in ... ms" message.-  deriving (Bounded, Enum, Eq, Ix, Ord, Show)---- |The first style overrides the second.-instance Semigroup Style where-  s <> _ = s---- |A style specification, pairing its \'key\' with the corresponding list of--- 'SGR' codes.-type StyleSpec = (Text, [SGR])---- |Style specifications indexed by the style.-type Styles = Array Style StyleSpec+{-# LANGUAGE NoImplicitPrelude #-}
+{-|
+For the most part, the data constructors of 'Style' do not clash with other
+names. When they do, import the module qualified. For example:
+
+> import qualified RIO.PrettyPrint.Types.PrettyPrint as PP
+-}
+module RIO.PrettyPrint.Types
+  ( Style (..)
+  , Styles
+  , StyleSpec
+  ) where
+
+import           Data.Array.IArray ( Array )
+import           Data.Ix ( Ix )
+import           Data.Text ( Text )
+import           RIO
+import           System.Console.ANSI.Types ( SGR )
+
+-- | A style of rio-prettyprint's output.
+data Style
+  = Error     -- Should be used sparingly, not to style entire long messages.
+              -- For example, it's used to style the "Error:" or "[error]" label
+              -- for an error message, not the entire message.
+  | Warning   -- Should be used sparingly, not to style entire long messages.
+              -- For example, it's used to style the "Warning:" or "[warn]"
+              -- label for a warning message, not the entire message.
+  | Info      -- Should be used sparingly, not to style entire long messages.
+              -- For example, it's used to style the "[info]" label for an info
+              -- message, not the entire message.
+  | Debug     -- Should be used sparingly, not to style entire long messages.
+              -- For example, it's used to style the "[debug]" label for a debug
+              -- message, not the entire message.
+  | OtherLevel      -- Should be used sparingly, not to style entire long
+                    -- messages. For example, it's used to style the "[...]"
+                    -- label for an other log level message, not the entire
+                    -- message.
+  | Good      -- Style in a way to emphasize that it is a particularly good
+              -- thing.
+  | Shell     -- Style as a shell command, i.e. when suggesting something to the
+              -- user that should be typed in directly as written.
+  | File      -- Style as a filename. See 'Dir' for directories.
+  | Url       -- Style as a URL.
+  | Dir       -- Style as a directory name. See 'File' for files.
+  | Recommendation  -- Style used to highlight part of a recommended course of
+                    -- action.
+  | Current   -- Style in a way that emphasizes that it is related to a current
+              -- thing. For example, could be used when talking about the current
+              -- package we're processing when outputting the name of it.
+  | Target    -- TODO: figure out how to describe this
+  | Module    -- Style as a module name.
+  | PkgComponent    -- Style used to highlight the named component of a package.
+  | Secondary -- Style for secondary content. For example, it's used to style
+              -- timestamps.
+  | Highlight -- Should be used sparingly, not to style entire long messages.
+              -- For example, it's used to style the duration in a "Finished
+              -- process in ... ms" message.
+  deriving (Bounded, Enum, Eq, Ix, Ord, Show)
+
+-- | The first style overrides the second.
+instance Semigroup Style where
+  s <> _ = s
+
+-- | A style specification, pairing its \'key\' with the corresponding list of
+-- 'SGR' codes.
+type StyleSpec = (Text, [SGR])
+
+-- | Style specifications indexed by the style.
+type Styles = Array Style StyleSpec

@@ -1,466 +1,504 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE UndecidableInstances #-}--- | This module re-exports some of the interface for--- "Text.PrettyPrint.Annotated.Leijen" along with additional definitions--- useful for stack.------ It defines a 'Monoid' instance for 'Doc'.-module Text.PrettyPrint.Leijen.Extended-  (-  -- * Pretty-print typeclass-  Pretty (..),--  -- * Ansi terminal Doc-  ---  -- See "System.Console.ANSI" for 'SGR' values to use beyond the colors-  -- provided.-  StyleDoc (..), StyleAnn(..),-  -- hDisplayAnsi,-  displayAnsi, displayPlain, renderDefault,--  -- * Selective re-exports from "Text.PrettyPrint.Annotated.Leijen"-  ---  -- Documentation of omissions up-to-date with @annotated-wl-pprint-0.7.0@--  -- ** Documents, parametrized by their annotations-  ---  -- Omitted compared to original: @putDoc, hPutDoc@-  -- Doc,--  -- ** Basic combinators-  ---  -- Omitted compared to original: @empty, char, text, (<>)@-  ---  -- Instead of @text@ and @char@, use 'fromString'.-  ---  -- Instead of @empty@, use 'mempty'.-  nest, line, linebreak, group, softline, softbreak,--  -- ** Alignment-  ---  -- The combinators in this section can not be described by Wadler's-  -- original combinators. They align their output relative to the-  -- current output position - in contrast to @nest@ which always-  -- aligns to the current nesting level. This deprives these-  -- combinators from being \`optimal\'. In practice however they-  -- prove to be very useful. The combinators in this section should-  -- be used with care, since they are more expensive than the other-  -- combinators. For example, @align@ shouldn't be used to pretty-  -- print all top-level declarations of a language, but using @hang@-  -- for let expressions is fine.-  ---  -- Omitted compared to original: @list, tupled, semiBraces@-  align, hang, indent, encloseSep,--  -- ** Operators-  ---  -- Omitted compared to original: @(<$>), (</>), (<$$>), (<//>)@-  (<+>),--  -- ** List combinators-  hsep, vsep, fillSep, sep, hcat, vcat, fillCat, cat, punctuate,--  -- ** Fillers-  fill, fillBreak,--  -- ** Bracketing combinators-  enclose, squotes, dquotes, parens, angles, braces, brackets,--  -- ** Character documents-  -- Entirely omitted:-  ---  -- @-  -- lparen, rparen, langle, rangle, lbrace, rbrace, lbracket, rbracket,-  -- squote, dquote, semi, colon, comma, space, dot, backslash, equals,-  -- pipe-  -- @--  -- ** Primitive type documents-  -- Omitted compared to the original:-  ---  -- @-  -- int, integer, float, double, rational, bool,-  -- @-  string,--  -- ** Semantic annotations-  annotate, noAnnotate, styleAnn--  -- ** Rendering-  -- Original entirely omitted:-  -- @-  -- SimpleDoc(..), renderPretty, renderCompact, displayDecorated, displayDecoratedA, display, displayS, displayIO,-  -- SpanList(..), displaySpans-  -- @--  -- ** Undocumented-  -- Entirely omitted:-  -- @-  -- column, nesting, width-  -- @-  ) where--import Control.Monad.Reader (runReader, local)-import Data.Array.IArray ((!), (//))-import qualified Data.Text as T-import Distribution.ModuleName (ModuleName)-import qualified Distribution.Text (display)-import Path-import RIO-import qualified RIO.Map as M-import RIO.PrettyPrint.DefaultStyles (defaultStyles)-import RIO.PrettyPrint.Types (Style (Dir, File), Styles)-import RIO.PrettyPrint.StylesUpdate (StylesUpdate (..), HasStylesUpdate, stylesUpdateL)-import System.Console.ANSI (ConsoleLayer (..), SGR (..), setSGRCode)-import qualified Text.PrettyPrint.Annotated.Leijen as P-import Text.PrettyPrint.Annotated.Leijen-  ( Doc, SimpleDoc (..)-  )---- TODO: consider smashing together the code for wl-annotated-pprint and--- wl-pprint-text. The code here already handles doing the--- ansi-wl-pprint stuff (better!) atop wl-annotated-pprint. So the--- result would be a package unifying 3 different wl inspired packages.------ Perhaps it can still have native string support, by adding a type--- parameter to Doc?--instance Semigroup StyleDoc where-    StyleDoc x <> StyleDoc y = StyleDoc (x P.<> y)-instance Monoid StyleDoc where-    mappend = (<>)-    mempty = StyleDoc P.empty------------------------------------------------------------------------------------- Pretty-Print class--class Pretty a where-    pretty :: a -> StyleDoc-    default pretty :: Show a => a -> StyleDoc-    pretty = StyleDoc . fromString . show--instance Pretty StyleDoc where-    pretty = id--instance Pretty (Path b File) where-    pretty = styleAnn File . StyleDoc . fromString . toFilePath--instance Pretty (Path b Dir) where-    pretty = styleAnn Dir . StyleDoc . fromString . toFilePath--instance Pretty ModuleName where-    pretty = StyleDoc . fromString . Distribution.Text.display------------------------------------------------------------------------------------- Style Doc---- |A style annotation.-newtype StyleAnn = StyleAnn (Maybe Style)-    deriving (Eq, Show, Semigroup)--instance Monoid StyleAnn where-    mempty = StyleAnn Nothing-    mappend = (<>)---- |A document annotated by a style-newtype StyleDoc = StyleDoc { unStyleDoc :: Doc StyleAnn }-  deriving (IsString, Show)---- |An ANSI code(s) annotation.-newtype AnsiAnn = AnsiAnn [SGR]-    deriving (Eq, Show, Semigroup, Monoid)---- |Convert a 'SimpleDoc' annotated with 'StyleAnn' to one annotated with--- 'AnsiAnn', by reference to a 'Styles'.-toAnsiDoc :: Styles -> SimpleDoc StyleAnn -> SimpleDoc AnsiAnn-toAnsiDoc styles = go-  where-    go SEmpty        = SEmpty-    go (SChar c d)   = SChar c (go d)-    go (SText l s d) = SText l s (go d)-    go (SLine i d)   = SLine i (go d)-    go (SAnnotStart (StyleAnn (Just s)) d) =-        SAnnotStart (AnsiAnn (snd $ styles ! s)) (go d)-    go (SAnnotStart (StyleAnn Nothing) d) = SAnnotStart (AnsiAnn []) (go d)-    go (SAnnotStop d) = SAnnotStop (go d)--displayPlain-    :: (Pretty a, HasLogFunc env, HasStylesUpdate env,-        MonadReader env m, HasCallStack)-    => Int -> a -> m Utf8Builder-displayPlain w =-    displayAnsiSimple . renderDefault w . fmap (const mempty) . unStyleDoc . pretty---- TODO: tweak these settings more?--- TODO: options for settings if this is released as a lib--renderDefault :: Int -> Doc a -> SimpleDoc a-renderDefault = P.renderPretty 1--displayAnsi-    :: (Pretty a, HasLogFunc env, HasStylesUpdate env,-        MonadReader env m, HasCallStack)-    => Int -> a -> m Utf8Builder-displayAnsi w =-    displayAnsiSimple . renderDefault w . unStyleDoc . pretty--{- Not used ----------------------------------------------------------------------hDisplayAnsi-    :: (Display a, HasAnsiAnn (Ann a), MonadIO m)-    => Handle -> Int -> a -> m ()-hDisplayAnsi h w x = liftIO $ do-    useAnsi <- hSupportsANSI h-    T.hPutStr h $ if useAnsi then displayAnsi w x else displayPlain w x---}--displayAnsiSimple-    :: (HasLogFunc env, HasStylesUpdate env, MonadReader env m, HasCallStack)-    => SimpleDoc StyleAnn -> m Utf8Builder-displayAnsiSimple doc = do-    update <- view stylesUpdateL-    let styles = defaultStyles // stylesUpdate update-        doc' = toAnsiDoc styles doc-    return $-        flip runReader mempty $ displayDecoratedWrap go doc'-  where-    go (AnsiAnn sgrs) inner = do-        old <- ask-        let sgrs' = mapMaybe (\sgr -> if sgr == Reset-                                        then Nothing-                                        else Just (getSGRTag sgr, sgr)) sgrs-            new = if Reset `elem` sgrs-                      then M.fromList sgrs'-                      else foldl' (\mp (tag, sgr) -> M.insert tag sgr mp) old sgrs'-        (extra, contents) <- local (const new) inner-        return (extra, transitionCodes old new <> contents <> transitionCodes new old)-    transitionCodes old new =-        case (null removals, null additions) of-            (True, True) -> mempty-            (True, False) -> fromString (setSGRCode additions)-            (False, _) -> fromString (setSGRCode (Reset : M.elems new))-      where-        (removals, additions) = partitionEithers $ M.elems $-            M.mergeWithKey-               (\_ o n -> if o == n then Nothing else Just (Right n))-               (fmap Left)-               (fmap Right)-               old-               new--displayDecoratedWrap-    :: forall a m. Monad m-    => (forall b. a -> m (b, Utf8Builder) -> m (b, Utf8Builder))-    -> SimpleDoc a-    -> m Utf8Builder-displayDecoratedWrap f doc = do-    (mafter, result) <- go doc-    case mafter of-      Just _ -> error "Invariant violated by input to displayDecoratedWrap: no matching SAnnotStart for SAnnotStop."-      Nothing -> return result-  where-    spaces n = display (T.replicate n " ")--    go :: SimpleDoc a -> m (Maybe (SimpleDoc a), Utf8Builder)-    go SEmpty = return (Nothing, mempty)-    go (SChar c x) = fmap (fmap (display c <>)) (go x)-    -- NOTE: Could actually use the length to guess at an initial-    -- allocation.  Better yet would be to just use Text in pprint..-    go (SText _l s x) = fmap (fmap (fromString s <>)) (go x)-    go (SLine n x) = fmap (fmap ((display '\n' <>) . (spaces n <>))) (go x)-    go (SAnnotStart ann x) = do-        (mafter, contents) <- f ann (go x)-        case mafter of-            Just after -> fmap (fmap (contents <>)) (go after)-            Nothing -> error "Invariant violated by input to displayDecoratedWrap: no matching SAnnotStop for SAnnotStart."-    go (SAnnotStop x) = return (Just x, mempty)--{- Not used ------------------------------------------------------------------------ Foreground color combinators--black, red, green, yellow, blue, magenta, cyan, white,-    dullblack, dullred, dullgreen, dullyellow, dullblue, dullmagenta, dullcyan, dullwhite,-    onblack, onred, ongreen, onyellow, onblue, onmagenta, oncyan, onwhite,-    ondullblack, ondullred, ondullgreen, ondullyellow, ondullblue, ondullmagenta, ondullcyan, ondullwhite-    :: Doc AnsiAnn -> Doc AnsiAnn-(black, dullblack, onblack, ondullblack) = colorFunctions Black-(red, dullred, onred, ondullred) = colorFunctions Red-(green, dullgreen, ongreen, ondullgreen) = colorFunctions Green-(yellow, dullyellow, onyellow, ondullyellow) = colorFunctions Yellow-(blue, dullblue, onblue, ondullblue) = colorFunctions Blue-(magenta, dullmagenta, onmagenta, ondullmagenta) = colorFunctions Magenta-(cyan, dullcyan, oncyan, ondullcyan) = colorFunctions Cyan-(white, dullwhite, onwhite, ondullwhite) = colorFunctions White--type EndoAnsiDoc = Doc AnsiAnn -> Doc AnsiAnn--colorFunctions :: Color -> (EndoAnsiDoc, EndoAnsiDoc, EndoAnsiDoc, EndoAnsiDoc)-colorFunctions color =-    ( ansiAnn [SetColor Foreground Vivid color]-    , ansiAnn [SetColor Foreground Dull color]-    , ansiAnn [SetColor Background Vivid color]-    , ansiAnn [SetColor Background Dull color]-    )---}--styleAnn :: Style -> StyleDoc -> StyleDoc-styleAnn s = StyleDoc . P.annotate (StyleAnn (Just s)) . unStyleDoc--{- Not used ------------------------------------------------------------------------ Intensity combinators--bold, faint, normal :: Doc AnsiAnn -> Doc AnsiAnn-bold = ansiAnn [SetConsoleIntensity BoldIntensity]-faint = ansiAnn [SetConsoleIntensity FaintIntensity]-normal = ansiAnn [SetConsoleIntensity NormalIntensity]---}---- | Tags for each field of state in SGR (Select Graphics Rendition).------ It's a bit of a hack that 'TagReset' is included.-data SGRTag-    = TagReset-    | TagConsoleIntensity-    | TagItalicized-    | TagUnderlining-    | TagBlinkSpeed-    | TagVisible-    | TagSwapForegroundBackground-    | TagColorForeground-    | TagColorBackground-    | TagRGBColor-    | TagPaletteColor-    deriving (Eq, Ord)--getSGRTag :: SGR -> SGRTag-getSGRTag Reset{}                       = TagReset-getSGRTag SetConsoleIntensity{}         = TagConsoleIntensity-getSGRTag SetItalicized{}               = TagItalicized-getSGRTag SetUnderlining{}              = TagUnderlining-getSGRTag SetBlinkSpeed{}               = TagBlinkSpeed-getSGRTag SetVisible{}                  = TagVisible-getSGRTag SetSwapForegroundBackground{} = TagSwapForegroundBackground-getSGRTag (SetColor Foreground _ _)     = TagColorForeground-getSGRTag (SetColor Background _ _)     = TagColorBackground-getSGRTag SetRGBColor{}                 = TagRGBColor-getSGRTag SetPaletteColor{}             = TagPaletteColor--(<+>) :: StyleDoc -> StyleDoc -> StyleDoc-StyleDoc x <+> StyleDoc y = StyleDoc (x P.<+> y)--align :: StyleDoc -> StyleDoc-align = StyleDoc . P.align . unStyleDoc--noAnnotate :: StyleDoc -> StyleDoc-noAnnotate = StyleDoc . P.noAnnotate . unStyleDoc--braces :: StyleDoc -> StyleDoc-braces = StyleDoc . P.braces . unStyleDoc--angles :: StyleDoc -> StyleDoc-angles = StyleDoc . P.angles . unStyleDoc--parens :: StyleDoc -> StyleDoc-parens = StyleDoc . P.parens . unStyleDoc--dquotes :: StyleDoc -> StyleDoc-dquotes = StyleDoc . P.dquotes . unStyleDoc--squotes :: StyleDoc -> StyleDoc-squotes = StyleDoc . P.squotes . unStyleDoc--brackets :: StyleDoc -> StyleDoc-brackets = StyleDoc . P.brackets . unStyleDoc---- | The document @string s@ concatenates all characters in @s@ using @line@ for--- newline characters and @char@ for all other characters. It is used whenever--- the text contains newline characters.------ @since 0.1.4.0-string :: String -> StyleDoc-string "" = mempty-string ('\n':s) = line <> string s-string s        = let (xs, ys) = span (/='\n') s-                  in  fromString xs <> string ys--annotate :: StyleAnn -> StyleDoc -> StyleDoc-annotate a = StyleDoc . P.annotate a . unStyleDoc--nest :: Int -> StyleDoc -> StyleDoc-nest a = StyleDoc . P.nest a . unStyleDoc--line :: StyleDoc-line = StyleDoc P.line--linebreak :: StyleDoc-linebreak = StyleDoc P.linebreak--fill :: Int -> StyleDoc -> StyleDoc-fill a = StyleDoc . P.fill a . unStyleDoc--fillBreak :: Int -> StyleDoc -> StyleDoc-fillBreak a = StyleDoc . P.fillBreak a . unStyleDoc--enclose :: StyleDoc -> StyleDoc -> StyleDoc -> StyleDoc-enclose l r x = l <> x <> r--cat :: [StyleDoc] -> StyleDoc-cat = StyleDoc . P.cat . map unStyleDoc--punctuate :: StyleDoc -> [StyleDoc] -> [StyleDoc]-punctuate (StyleDoc x) = map StyleDoc . P.punctuate x . map unStyleDoc--fillCat :: [StyleDoc] -> StyleDoc-fillCat = StyleDoc . P.fillCat . map unStyleDoc--hcat :: [StyleDoc] -> StyleDoc-hcat = StyleDoc . P.hcat . map unStyleDoc--vcat :: [StyleDoc] -> StyleDoc-vcat = StyleDoc . P.vcat . map unStyleDoc--sep :: [StyleDoc] -> StyleDoc-sep = StyleDoc . P.sep . map unStyleDoc--vsep :: [StyleDoc] -> StyleDoc-vsep = StyleDoc . P.vsep . map unStyleDoc--hsep :: [StyleDoc] -> StyleDoc-hsep = StyleDoc . P.hsep . map unStyleDoc--fillSep :: [StyleDoc] -> StyleDoc-fillSep = StyleDoc . P.fillSep . map unStyleDoc--encloseSep :: StyleDoc -> StyleDoc -> StyleDoc -> [StyleDoc] -> StyleDoc-encloseSep (StyleDoc x) (StyleDoc y) (StyleDoc z) =-  StyleDoc . P.encloseSep x y z . map unStyleDoc--indent :: Int -> StyleDoc -> StyleDoc-indent a = StyleDoc . P.indent a . unStyleDoc--hang :: Int -> StyleDoc -> StyleDoc-hang a = StyleDoc . P.hang a . unStyleDoc--softbreak :: StyleDoc-softbreak = StyleDoc P.softbreak--softline :: StyleDoc-softline = StyleDoc P.softline--group :: StyleDoc -> StyleDoc-group = StyleDoc . P.group . unStyleDoc+{-# LANGUAGE NoImplicitPrelude          #-}
+{-# LANGUAGE DefaultSignatures          #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE OverloadedStrings          #-}
+{-# LANGUAGE RankNTypes                 #-}
+{-# LANGUAGE ScopedTypeVariables        #-}
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE UndecidableInstances       #-}
+
+-- | This module re-exports some of the interface for
+-- "Text.PrettyPrint.Annotated.Leijen" along with additional definitions
+-- useful for stack.
+--
+-- It defines a 'Monoid' instance for 'Doc'.
+module Text.PrettyPrint.Leijen.Extended
+  (
+    -- * Pretty-print typeclass
+    Pretty (..)
+
+    -- * Ansi terminal Doc
+    --
+    -- See "System.Console.ANSI" for 'SGR' values to use beyond the colors
+    -- provided.
+  , StyleDoc (..)
+  , StyleAnn(..)
+  -- hDisplayAnsi,
+  , displayAnsi
+  , displayPlain
+  , renderDefault
+
+  -- * Selective re-exports from "Text.PrettyPrint.Annotated.Leijen"
+  --
+  -- Documentation of omissions up-to-date with @annotated-wl-pprint-0.7.0@
+
+  -- ** Documents, parametrized by their annotations
+  --
+  -- Omitted compared to original: @putDoc, hPutDoc@
+  -- Doc,
+
+  -- ** Basic combinators
+  --
+  -- Omitted compared to original: @empty, char, text, (<>)@
+  --
+  -- Instead of @text@ and @char@, use 'fromString'.
+  --
+  -- Instead of @empty@, use 'mempty'.
+  , nest
+  , line
+  , linebreak
+  , group
+  , softline
+  , softbreak
+
+  -- ** Alignment
+  --
+  -- The combinators in this section can not be described by Wadler's
+  -- original combinators. They align their output relative to the
+  -- current output position - in contrast to @nest@ which always
+  -- aligns to the current nesting level. This deprives these
+  -- combinators from being \`optimal\'. In practice however they
+  -- prove to be very useful. The combinators in this section should
+  -- be used with care, since they are more expensive than the other
+  -- combinators. For example, @align@ shouldn't be used to pretty
+  -- print all top-level declarations of a language, but using @hang@
+  -- for let expressions is fine.
+  --
+  -- Omitted compared to original: @list, tupled, semiBraces@
+  , align
+  , hang
+  , indent
+  , encloseSep
+
+  -- ** Operators
+  --
+  -- Omitted compared to original: @(<$>), (</>), (<$$>), (<//>)@
+  , (<+>)
+
+    -- ** List combinators
+  , hsep
+  , vsep
+  , fillSep
+  , sep
+  , hcat
+  , vcat
+  , fillCat
+  , cat
+  , punctuate
+
+    -- ** Fillers
+  , fill
+  , fillBreak
+
+    -- ** Bracketing combinators
+  , enclose
+  , squotes
+  , dquotes
+  , parens
+  , angles
+  , braces
+  , brackets
+
+    -- ** Character documents
+    -- Entirely omitted:
+    --
+    -- @
+    -- lparen, rparen, langle, rangle, lbrace, rbrace, lbracket, rbracket,
+    -- squote, dquote, semi, colon, comma, space, dot, backslash, equals,
+    -- pipe
+    -- @
+
+    -- ** Primitive type documents
+    -- Omitted compared to the original:
+    --
+    -- @
+    -- int, integer, float, double, rational, bool,
+    -- @
+  , string
+
+    -- ** Semantic annotations
+  , annotate
+  , noAnnotate
+  , styleAnn
+
+  -- ** Rendering
+  -- Original entirely omitted:
+  -- @
+  -- SimpleDoc(..), renderPretty, renderCompact, displayDecorated, displayDecoratedA, display, displayS, displayIO,
+  -- SpanList(..), displaySpans
+  -- @
+
+  -- ** Undocumented
+  -- Entirely omitted:
+  -- @
+  -- column, nesting, width
+  -- @
+  ) where
+
+import           Control.Monad.Reader ( local, runReader )
+import           Data.Array.IArray ( (!), (//) )
+import qualified Data.Text as T
+import           Distribution.ModuleName ( ModuleName )
+import qualified Distribution.Text ( display )
+import           Path ( Dir, File, Path, SomeBase, prjSomeBase, toFilePath )
+import           RIO
+import qualified RIO.Map as M
+import           RIO.PrettyPrint.DefaultStyles ( defaultStyles )
+import           RIO.PrettyPrint.Types ( Style (Dir, File), Styles )
+import           RIO.PrettyPrint.StylesUpdate
+                   ( HasStylesUpdate, StylesUpdate (..), stylesUpdateL )
+import           System.Console.ANSI ( ConsoleLayer (..), SGR (..), setSGRCode )
+import qualified Text.PrettyPrint.Annotated.Leijen as P
+import           Text.PrettyPrint.Annotated.Leijen ( Doc, SimpleDoc (..) )
+
+-- TODO: consider smashing together the code for wl-annotated-pprint and
+-- wl-pprint-text. The code here already handles doing the
+-- ansi-wl-pprint stuff (better!) atop wl-annotated-pprint. So the
+-- result would be a package unifying 3 different wl inspired packages.
+--
+-- Perhaps it can still have native string support, by adding a type
+-- parameter to Doc?
+
+instance Semigroup StyleDoc where
+  StyleDoc x <> StyleDoc y = StyleDoc (x P.<> y)
+
+instance Monoid StyleDoc where
+  mappend = (<>)
+  mempty = StyleDoc P.empty
+
+--------------------------------------------------------------------------------
+-- Pretty-Print class
+
+class Pretty a where
+  pretty :: a -> StyleDoc
+  default pretty :: Show a => a -> StyleDoc
+  pretty = StyleDoc . fromString . show
+
+instance Pretty StyleDoc where
+  pretty = id
+
+instance Pretty (Path b File) where
+  pretty = styleAnn File . StyleDoc . fromString . toFilePath
+
+instance Pretty (Path b Dir) where
+  pretty = styleAnn Dir . StyleDoc . fromString . toFilePath
+
+instance Pretty (SomeBase File) where
+  pretty = prjSomeBase pretty
+
+instance Pretty (SomeBase Dir) where
+  pretty = prjSomeBase pretty
+
+instance Pretty ModuleName where
+  pretty = StyleDoc . fromString . Distribution.Text.display
+
+--------------------------------------------------------------------------------
+-- Style Doc
+
+-- |A style annotation.
+newtype StyleAnn = StyleAnn (Maybe Style)
+  deriving (Eq, Show, Semigroup)
+
+instance Monoid StyleAnn where
+  mempty = StyleAnn Nothing
+  mappend = (<>)
+
+-- |A document annotated by a style
+newtype StyleDoc = StyleDoc { unStyleDoc :: Doc StyleAnn }
+  deriving (IsString, Show)
+
+-- |An ANSI code(s) annotation.
+newtype AnsiAnn = AnsiAnn [SGR]
+  deriving (Eq, Show, Semigroup, Monoid)
+
+-- |Convert a 'SimpleDoc' annotated with 'StyleAnn' to one annotated with
+-- 'AnsiAnn', by reference to a 'Styles'.
+toAnsiDoc :: Styles -> SimpleDoc StyleAnn -> SimpleDoc AnsiAnn
+toAnsiDoc styles = go
+ where
+  go SEmpty        = SEmpty
+  go (SChar c d)   = SChar c (go d)
+  go (SText l s d) = SText l s (go d)
+  go (SLine i d)   = SLine i (go d)
+  go (SAnnotStart (StyleAnn (Just s)) d) =
+    SAnnotStart (AnsiAnn (snd $ styles ! s)) (go d)
+  go (SAnnotStart (StyleAnn Nothing) d) = SAnnotStart (AnsiAnn []) (go d)
+  go (SAnnotStop d) = SAnnotStop (go d)
+
+displayPlain ::
+     ( Pretty a, HasLogFunc env, HasStylesUpdate env, MonadReader env m
+     , HasCallStack
+     )
+  => Int -> a -> m Utf8Builder
+displayPlain w =
+  displayAnsiSimple . renderDefault w . fmap (const mempty) . unStyleDoc . pretty
+
+-- TODO: tweak these settings more?
+-- TODO: options for settings if this is released as a lib
+
+renderDefault :: Int -> Doc a -> SimpleDoc a
+renderDefault = P.renderPretty 1
+
+displayAnsi ::
+     ( Pretty a, HasLogFunc env, HasStylesUpdate env, MonadReader env m
+     , HasCallStack
+     )
+  => Int -> a -> m Utf8Builder
+displayAnsi w =
+  displayAnsiSimple . renderDefault w . unStyleDoc . pretty
+
+{- Not used --------------------------------------------------------------------
+
+hDisplayAnsi
+    :: (Display a, HasAnsiAnn (Ann a), MonadIO m)
+    => Handle -> Int -> a -> m ()
+hDisplayAnsi h w x = liftIO $ do
+    useAnsi <- hSupportsANSI h
+    T.hPutStr h $ if useAnsi then displayAnsi w x else displayPlain w x
+
+-}
+
+displayAnsiSimple ::
+     (HasLogFunc env, HasStylesUpdate env, MonadReader env m, HasCallStack)
+  => SimpleDoc StyleAnn
+  -> m Utf8Builder
+displayAnsiSimple doc = do
+  update <- view stylesUpdateL
+  let styles = defaultStyles // stylesUpdate update
+      doc' = toAnsiDoc styles doc
+  return $ flip runReader mempty $ displayDecoratedWrap go doc'
+ where
+  go (AnsiAnn sgrs) inner = do
+    old <- ask
+    let sgrs' = mapMaybe (\sgr -> if sgr == Reset
+                                    then Nothing
+                                    else Just (getSGRTag sgr, sgr)) sgrs
+        new = if Reset `elem` sgrs
+                then M.fromList sgrs'
+                else foldl' (\mp (tag, sgr) -> M.insert tag sgr mp) old sgrs'
+    (extra, contents) <- local (const new) inner
+    return (extra, transitionCodes old new <> contents <> transitionCodes new old)
+  transitionCodes old new =
+    case (null removals, null additions) of
+      (True, True) -> mempty
+      (True, False) -> fromString (setSGRCode additions)
+      (False, _) -> fromString (setSGRCode (Reset : M.elems new))
+   where
+    (removals, additions) = partitionEithers $ M.elems $
+      M.mergeWithKey
+        (\_ o n -> if o == n then Nothing else Just (Right n))
+        (fmap Left)
+        (fmap Right)
+        old
+        new
+
+displayDecoratedWrap ::
+     forall a m. Monad m
+  => (forall b. a -> m (b, Utf8Builder) -> m (b, Utf8Builder))
+  -> SimpleDoc a
+  -> m Utf8Builder
+displayDecoratedWrap f doc = do
+  (mafter, result) <- go doc
+  case mafter of
+    Just _ -> error "Invariant violated by input to displayDecoratedWrap: no \
+                    \matching SAnnotStart for SAnnotStop."
+    Nothing -> return result
+ where
+  spaces n = display (T.replicate n " ")
+
+  go :: SimpleDoc a -> m (Maybe (SimpleDoc a), Utf8Builder)
+  go SEmpty = return (Nothing, mempty)
+  go (SChar c x) = fmap (fmap (display c <>)) (go x)
+  -- NOTE: Could actually use the length to guess at an initial
+  -- allocation.  Better yet would be to just use Text in pprint..
+  go (SText _l s x) = fmap (fmap (fromString s <>)) (go x)
+  go (SLine n x) = fmap (fmap ((display '\n' <>) . (spaces n <>))) (go x)
+  go (SAnnotStart ann x) = do
+    (mafter, contents) <- f ann (go x)
+    case mafter of
+      Just after -> fmap (fmap (contents <>)) (go after)
+      Nothing -> error "Invariant violated by input to displayDecoratedWrap: \
+                       \no matching SAnnotStop for SAnnotStart."
+  go (SAnnotStop x) = return (Just x, mempty)
+
+{- Not used --------------------------------------------------------------------
+
+-- Foreground color combinators
+
+black, red, green, yellow, blue, magenta, cyan, white,
+    dullblack, dullred, dullgreen, dullyellow, dullblue, dullmagenta, dullcyan, dullwhite,
+    onblack, onred, ongreen, onyellow, onblue, onmagenta, oncyan, onwhite,
+    ondullblack, ondullred, ondullgreen, ondullyellow, ondullblue, ondullmagenta, ondullcyan, ondullwhite
+    :: Doc AnsiAnn -> Doc AnsiAnn
+(black, dullblack, onblack, ondullblack) = colorFunctions Black
+(red, dullred, onred, ondullred) = colorFunctions Red
+(green, dullgreen, ongreen, ondullgreen) = colorFunctions Green
+(yellow, dullyellow, onyellow, ondullyellow) = colorFunctions Yellow
+(blue, dullblue, onblue, ondullblue) = colorFunctions Blue
+(magenta, dullmagenta, onmagenta, ondullmagenta) = colorFunctions Magenta
+(cyan, dullcyan, oncyan, ondullcyan) = colorFunctions Cyan
+(white, dullwhite, onwhite, ondullwhite) = colorFunctions White
+
+type EndoAnsiDoc = Doc AnsiAnn -> Doc AnsiAnn
+
+colorFunctions :: Color -> (EndoAnsiDoc, EndoAnsiDoc, EndoAnsiDoc, EndoAnsiDoc)
+colorFunctions color =
+    ( ansiAnn [SetColor Foreground Vivid color]
+    , ansiAnn [SetColor Foreground Dull color]
+    , ansiAnn [SetColor Background Vivid color]
+    , ansiAnn [SetColor Background Dull color]
+    )
+
+-}
+
+styleAnn :: Style -> StyleDoc -> StyleDoc
+styleAnn s = StyleDoc . P.annotate (StyleAnn (Just s)) . unStyleDoc
+
+{- Not used --------------------------------------------------------------------
+
+-- Intensity combinators
+
+bold, faint, normal :: Doc AnsiAnn -> Doc AnsiAnn
+bold = ansiAnn [SetConsoleIntensity BoldIntensity]
+faint = ansiAnn [SetConsoleIntensity FaintIntensity]
+normal = ansiAnn [SetConsoleIntensity NormalIntensity]
+
+-}
+
+-- | Tags for each field of state in SGR (Select Graphics Rendition).
+--
+-- It's a bit of a hack that 'TagReset' is included.
+data SGRTag
+  = TagReset
+  | TagConsoleIntensity
+  | TagItalicized
+  | TagUnderlining
+  | TagBlinkSpeed
+  | TagVisible
+  | TagSwapForegroundBackground
+  | TagColorForeground
+  | TagColorBackground
+  | TagRGBColor
+  | TagPaletteColor
+  deriving (Eq, Ord)
+
+getSGRTag :: SGR -> SGRTag
+getSGRTag Reset{}                       = TagReset
+getSGRTag SetConsoleIntensity{}         = TagConsoleIntensity
+getSGRTag SetItalicized{}               = TagItalicized
+getSGRTag SetUnderlining{}              = TagUnderlining
+getSGRTag SetBlinkSpeed{}               = TagBlinkSpeed
+getSGRTag SetVisible{}                  = TagVisible
+getSGRTag SetSwapForegroundBackground{} = TagSwapForegroundBackground
+getSGRTag (SetColor Foreground _ _)     = TagColorForeground
+getSGRTag (SetColor Background _ _)     = TagColorBackground
+getSGRTag SetRGBColor{}                 = TagRGBColor
+getSGRTag SetPaletteColor{}             = TagPaletteColor
+
+(<+>) :: StyleDoc -> StyleDoc -> StyleDoc
+StyleDoc x <+> StyleDoc y = StyleDoc (x P.<+> y)
+
+align :: StyleDoc -> StyleDoc
+align = StyleDoc . P.align . unStyleDoc
+
+noAnnotate :: StyleDoc -> StyleDoc
+noAnnotate = StyleDoc . P.noAnnotate . unStyleDoc
+
+braces :: StyleDoc -> StyleDoc
+braces = StyleDoc . P.braces . unStyleDoc
+
+angles :: StyleDoc -> StyleDoc
+angles = StyleDoc . P.angles . unStyleDoc
+
+parens :: StyleDoc -> StyleDoc
+parens = StyleDoc . P.parens . unStyleDoc
+
+dquotes :: StyleDoc -> StyleDoc
+dquotes = StyleDoc . P.dquotes . unStyleDoc
+
+squotes :: StyleDoc -> StyleDoc
+squotes = StyleDoc . P.squotes . unStyleDoc
+
+brackets :: StyleDoc -> StyleDoc
+brackets = StyleDoc . P.brackets . unStyleDoc
+
+-- | The document @string s@ concatenates all characters in @s@ using @line@ for
+-- newline characters and @char@ for all other characters. It is used whenever
+-- the text contains newline characters.
+--
+-- @since 0.1.4.0
+string :: String -> StyleDoc
+string "" = mempty
+string ('\n':s) = line <> string s
+string s        = let (xs, ys) = span (/='\n') s
+                  in  fromString xs <> string ys
+
+annotate :: StyleAnn -> StyleDoc -> StyleDoc
+annotate a = StyleDoc . P.annotate a . unStyleDoc
+
+nest :: Int -> StyleDoc -> StyleDoc
+nest a = StyleDoc . P.nest a . unStyleDoc
+
+line :: StyleDoc
+line = StyleDoc P.line
+
+linebreak :: StyleDoc
+linebreak = StyleDoc P.linebreak
+
+fill :: Int -> StyleDoc -> StyleDoc
+fill a = StyleDoc . P.fill a . unStyleDoc
+
+fillBreak :: Int -> StyleDoc -> StyleDoc
+fillBreak a = StyleDoc . P.fillBreak a . unStyleDoc
+
+enclose :: StyleDoc -> StyleDoc -> StyleDoc -> StyleDoc
+enclose l r x = l <> x <> r
+
+cat :: [StyleDoc] -> StyleDoc
+cat = StyleDoc . P.cat . map unStyleDoc
+
+punctuate :: StyleDoc -> [StyleDoc] -> [StyleDoc]
+punctuate (StyleDoc x) = map StyleDoc . P.punctuate x . map unStyleDoc
+
+fillCat :: [StyleDoc] -> StyleDoc
+fillCat = StyleDoc . P.fillCat . map unStyleDoc
+
+hcat :: [StyleDoc] -> StyleDoc
+hcat = StyleDoc . P.hcat . map unStyleDoc
+
+vcat :: [StyleDoc] -> StyleDoc
+vcat = StyleDoc . P.vcat . map unStyleDoc
+
+sep :: [StyleDoc] -> StyleDoc
+sep = StyleDoc . P.sep . map unStyleDoc
+
+vsep :: [StyleDoc] -> StyleDoc
+vsep = StyleDoc . P.vsep . map unStyleDoc
+
+hsep :: [StyleDoc] -> StyleDoc
+hsep = StyleDoc . P.hsep . map unStyleDoc
+
+fillSep :: [StyleDoc] -> StyleDoc
+fillSep = StyleDoc . P.fillSep . map unStyleDoc
+
+encloseSep :: StyleDoc -> StyleDoc -> StyleDoc -> [StyleDoc] -> StyleDoc
+encloseSep (StyleDoc x) (StyleDoc y) (StyleDoc z) =
+  StyleDoc . P.encloseSep x y z . map unStyleDoc
+
+indent :: Int -> StyleDoc -> StyleDoc
+indent a = StyleDoc . P.indent a . unStyleDoc
+
+hang :: Int -> StyleDoc -> StyleDoc
+hang a = StyleDoc . P.hang a . unStyleDoc
+
+softbreak :: StyleDoc
+softbreak = StyleDoc P.softbreak
+
+softline :: StyleDoc
+softline = StyleDoc P.softline
+
+group :: StyleDoc -> StyleDoc
+group = StyleDoc . P.group . unStyleDoc