packages feed

rio-prettyprint (empty) → 0.1.0.0

raw patch · 7 files changed

+956/−0 lines, 7 filesdep +Cabaldep +aesondep +annotated-wl-pprint

Dependencies added: Cabal, aeson, annotated-wl-pprint, ansi-terminal, array, base, colour, mtl, path, rio, text

Files

+ LICENSE view
@@ -0,0 +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.
+ rio-prettyprint.cabal view
@@ -0,0 +1,49 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.31.1.+--+-- see: https://github.com/sol/hpack+--+-- hash: 1d949118732b2fc99142bfdd103496c89c364dd299c30d2039eac2acea3de22b++name:           rio-prettyprint+version:        0.1.0.0+synopsis:       Pretty-printing for RIO+category:       Development+homepage:       https://github.com/commercialhaskell/stack#readme+bug-reports:    https://github.com/commercialhaskell/stack/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/stack++library+  exposed-modules:+      RIO.PrettyPrint+      RIO.PrettyPrint.DefaultStyles+      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+    , array+    , base >=4.10 && <5+    , colour+    , mtl+    , path+    , rio+    , text+  default-language: Haskell2010
+ src/RIO/PrettyPrint.hs view
@@ -0,0 +1,176 @@+{-# 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+      -- * Formatting utils+    , bulletedList+    , 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+    , 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,+                     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)++-- | Display a bulleted list of 'StyleDoc' with a blank line between+-- each.+spacedBulletedList :: [StyleDoc] -> StyleDoc+spacedBulletedList = mconcat . intersperse (line <> line) . map (("*" <+>) . align)
+ src/RIO/PrettyPrint/DefaultStyles.hs view
@@ -0,0 +1,33 @@+{-# 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]))+  , (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])) ]
+ src/RIO/PrettyPrint/StylesUpdate.hs view
@@ -0,0 +1,165 @@+{-# 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
+ src/RIO/PrettyPrint/Types.hs view
@@ -0,0 +1,55 @@+{-# 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:" 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:" label for an error+             -- 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.+  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
+ src/Text/PrettyPrint/Leijen/Extended.hs view
@@ -0,0 +1,454 @@+{-# 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+  -- Entirely omitted:+  --+  -- @+  -- string, int, integer, float, double, rational, bool,+  -- @++  -- ** 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++-- |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 = do+    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) = liftM (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) = liftM (fmap (fromString s <>)) (go x)+    go (SLine n x) = liftM (fmap ((display '\n' <>) . (spaces n <>))) (go x)+    go (SAnnotStart ann x) = do+        (mafter, contents) <- f ann (go x)+        case mafter of+            Just after -> liftM (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++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