rio-prettyprint-0.1.1.0/src/0000755000000000000000000000000013712423256014024 5ustar0000000000000000rio-prettyprint-0.1.1.0/src/RIO/0000755000000000000000000000000013712423256014455 5ustar0000000000000000rio-prettyprint-0.1.1.0/src/RIO/PrettyPrint/0000755000000000000000000000000013712423256016761 5ustar0000000000000000rio-prettyprint-0.1.1.0/src/Text/0000755000000000000000000000000013712423256014750 5ustar0000000000000000rio-prettyprint-0.1.1.0/src/Text/PrettyPrint/0000755000000000000000000000000013712423256017254 5ustar0000000000000000rio-prettyprint-0.1.1.0/src/Text/PrettyPrint/Leijen/0000755000000000000000000000000013712423256020462 5ustar0000000000000000rio-prettyprint-0.1.1.0/src/RIO/PrettyPrint.hs0000644000000000000000000001712613712423256017324 0ustar0000000000000000{-# 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 , 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) -- | 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 rio-prettyprint-0.1.1.0/src/RIO/PrettyPrint/DefaultStyles.hs0000644000000000000000000000331213712423256022104 0ustar0000000000000000{-# 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])) ] rio-prettyprint-0.1.1.0/src/RIO/PrettyPrint/StylesUpdate.hs0000644000000000000000000001464313712423256021753 0ustar0000000000000000{-# 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 and -- those codes supported on current versions of Windows at -- . 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 rio-prettyprint-0.1.1.0/src/RIO/PrettyPrint/Types.hs0000644000000000000000000000621413712423256020424 0ustar0000000000000000{-# 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 rio-prettyprint-0.1.1.0/src/Text/PrettyPrint/Leijen/Extended.hs0000644000000000000000000003517713712423256022573 0ustar0000000000000000{-# 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 = 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 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 rio-prettyprint-0.1.1.0/LICENSE0000644000000000000000000000273113712423256014245 0ustar0000000000000000Copyright (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-0.1.1.0/rio-prettyprint.cabal0000644000000000000000000000243713712424506017421 0ustar0000000000000000cabal-version: 1.12 -- This file has been generated from package.yaml by hpack version 0.33.0. -- -- see: https://github.com/sol/hpack -- -- hash: bf50273f06f81eee478b5dd1dc56a8006c9fd634dc6eb2a70fd70821b5a1cade name: rio-prettyprint version: 0.1.1.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.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