rio-prettyprint-0.1.8.0/src/0000755000000000000000000000000014475133214014032 5ustar0000000000000000rio-prettyprint-0.1.8.0/src/RIO/0000755000000000000000000000000014541614725014470 5ustar0000000000000000rio-prettyprint-0.1.8.0/src/RIO/PrettyPrint/0000755000000000000000000000000014541614725016774 5ustar0000000000000000rio-prettyprint-0.1.8.0/src/Text/0000755000000000000000000000000014475133214014756 5ustar0000000000000000rio-prettyprint-0.1.8.0/src/Text/PrettyPrint/0000755000000000000000000000000014475133214017262 5ustar0000000000000000rio-prettyprint-0.1.8.0/src/Text/PrettyPrint/Leijen/0000755000000000000000000000000014542032725020470 5ustar0000000000000000rio-prettyprint-0.1.8.0/src/RIO/PrettyPrint.hs0000644000000000000000000002640014541614725017332 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 -- | The @pretty...@ functions come in three varieties: -- -- * The normal variety, with a single styled document; -- * The @L@ variety. The listed styled documents are concatenated with -- 'fillSep'; and -- * The @S@ variety. 'flow' is applied to the 'String'. -- -- Pretty message at log level 'LevelDebug'. , prettyDebug , prettyDebugL , prettyDebugS -- | Pretty message at log level 'LevelInfo'. , prettyInfo , prettyInfoL , prettyInfoS -- | Pretty messages at log level 'LevelInfo', starting on a new line with -- label @Note:@, with the message indented after the label. , prettyNote , prettyNoteL , prettyNoteS -- | Pretty messages at log level 'LevelWarn', starting on a new line with -- label @Warning:@, with or without the message indented after the label. , prettyWarn , prettyWarnL , prettyWarnS , prettyWarnNoIndent , prettyWarnNoIndentL , prettyWarnNoIndentS -- | Pretty messages at log level 'LevelError', starting on a new line with -- label @Error:@, with or without the message indented after the label. , prettyError , prettyErrorL , prettyErrorS , prettyErrorNoIndent , prettyErrorNoIndentL , prettyErrorNoIndentS -- | Pretty messages at the specified log level. , prettyGeneric , prettyWith -- * Semantic styling functions -- | These are used rather than applying colors or other styling directly, -- to provide consistency. , style , displayMilliseconds , logLevelToStyle -- * Formatting utils , blankLine , bulletedList , spacedBulletedList , mkBulletedList , mkNarrativeList , 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 prettyGeneric :: (HasTerm env, HasCallStack, Pretty b, MonadReader env m, MonadIO m) => LogLevel -> b -> m () prettyGeneric level = prettyWith level id 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 'StyleDoc' from each word in a 'String' wordDocs :: String -> [StyleDoc] wordDocs = map fromString . words -- | Wordwrap a 'String' flow :: String -> StyleDoc flow = fillSep . wordDocs -- | A blank line. blankLine :: StyleDoc blankLine = line <> line -- | @debug message action@ brackets any output of the specified @action@ with -- an initial and final @message@ at log level 'LevelDebug'. The initial message -- is prefixed with the label @Start:@. The final message is prefixed with -- information about the duration of the action in milliseconds (ms) and, if -- an exception is thrown by the action, the exception. For example: -- -- > Start: -- > -- > Finished in ...ms: -- -- or: -- -- > Start: -- > -- > Finished with exception in ...ms: -- > Exception thrown: 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 as milliseconds in style 'Good'. displayMilliseconds :: Double -- ^ Amount of time in seconds. -> StyleDoc displayMilliseconds t = style Good $ fromString (show (round (t * 1000) :: Int)) <> "ms" -- | Display a bulleted list of 'StyleDoc' with @*@ as the bullet point. bulletedList :: [StyleDoc] -> StyleDoc bulletedList = mkBulletedList False '*' -- | Display a bulleted list of 'StyleDoc', spaced with blank lines or not, -- given a character for the bullet point. -- -- @since 0.1.6.0 mkBulletedList :: Bool -- ^ Spaced with a blank line between each item? -> Char -- ^ The character to act as the bullet point. -> [StyleDoc] -> StyleDoc mkBulletedList isSpaced bullet = mconcat . intersperse spacer . map ((fromString [bullet] <+>) . align) where spacer = if isSpaced then line <> line else line -- | 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 and @*@ as the bullet point. spacedBulletedList :: [StyleDoc] -> StyleDoc spacedBulletedList = mkBulletedList True '*' -- | 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.8.0/src/RIO/PrettyPrint/DefaultStyles.hs0000644000000000000000000000353014475142527022123 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.8.0/src/RIO/PrettyPrint/PrettyException.hs0000644000000000000000000000646414541614725022510 0ustar0000000000000000{-# 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 (..) , ppException , prettyThrowIO , prettyThrowM ) where import RIO ( Exception (..), Maybe (..), MonadIO, MonadThrow, Show, SomeException , Typeable, (.), throwIO, throwM ) import Text.PrettyPrint.Leijen.Extended ( Pretty (..), StyleDoc, string ) -- | 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 -- | Provide the prettiest available information about an exception. ppException :: SomeException -> StyleDoc ppException e = case fromException e of Just (PrettyException e') -> pretty e' Nothing -> (string . displayException) e -- | Synchronously throw the given exception as a 'PrettyException'. prettyThrowIO :: (Exception e, MonadIO m, Pretty e) => e -> m a prettyThrowIO = throwIO . PrettyException -- | Throw the given exception as a 'PrettyException', when the action is run in -- the monad @m@. prettyThrowM :: (Exception e, MonadThrow m, Pretty e) => e -> m a prettyThrowM = throwM . PrettyException rio-prettyprint-0.1.8.0/src/RIO/PrettyPrint/Simple.hs0000644000000000000000000000626714475142527020576 0ustar0000000000000000{-# 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 rio-prettyprint-0.1.8.0/src/RIO/PrettyPrint/StylesUpdate.hs0000644000000000000000000001530314475142527021762 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.8.0/src/RIO/PrettyPrint/Types.hs0000644000000000000000000000604614541614725020442 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 ) -- | Type representing styles of output. data Style = Error -- ^ Intended to be used sparingly, not to style entire long messages. For -- example, to style the @Error:@ or @[error]@ label for an error message, -- not the entire message. | Warning -- ^ Intended to be used sparingly, not to style entire long messages. For -- example, to style the @Warning:@ or @[warn]@ label for a warning message, -- not the entire message. | Info -- ^ Intended to be used sparingly, not to style entire long messages. For -- example, to style the @[info]@ label for an info message, not the entire -- message. | Debug -- ^ Intended to be used sparingly, not to style entire long messages. For -- example, to style the @[debug]@ label for a debug message, not the entire -- message. | OtherLevel -- ^ Intended to be used sparingly, not to style entire long messages. For -- example, 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, to report the current package that is being processed when -- outputting the name of it. | Target -- ^ Style used the highlight the target of a course of action. | Module -- ^ Style as a module name. | PkgComponent -- ^ Style used to highlight the named component of a package. | Secondary -- ^ Style for secondary content. For example, to style timestamps. | Highlight -- ^ Intended to be used sparingly, not to style entire long messages. For -- example, 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.8.0/src/Text/PrettyPrint/Leijen/Extended.hs0000644000000000000000000006101314542032725022565 0ustar0000000000000000{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -- | This module is based, in part, on some of the interface for -- "Text.PrettyPrint.Annotated.Leijen". -- module Text.PrettyPrint.Leijen.Extended ( -- * Pretty-print typeclass Pretty (..) -- * Documents annotated by a style , StyleDoc (..) , StyleAnn (..) , displayAnsi , displayPlain , renderDefault -- * Selective use of the "Text.PrettyPrint.Annotated.Leijen" interface -- -- | Documented omissions by reference to package -- @annotated-wl-pprint-0.7.0@. -- ** Documents, parametrized by their annotations -- -- | Omitted compared to original: -- -- @ -- Doc, putDoc, hPutDoc -- @ -- ** Basic combinators -- -- | Omitted compared to the original: -- -- @ -- empty, char, text, (<>) -- @ -- -- Instead of @empty@, use 'mempty'. -- -- Instead of @char@ and @text@, use 'fromString'. -- -- A 'Monoid' instance for 'StyleDoc' is defined. , 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 the original: -- -- @ -- list, tupled, semiBraces -- @ , align , hang , indent , encloseSep -- ** Operators -- -- | Omitted compared to the 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 -- | 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 Distribution.System ( Arch (..), OS (..) ) import qualified Distribution.Text ( display ) import Distribution.Utils.Generic ( lowercase ) 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 instance Pretty Arch where pretty (OtherArch name) = fromString name pretty other = fromString $ lowercase $ show other instance Pretty OS where pretty (OtherOS name) = fromString name pretty other = fromString $ lowercase $ show other -------------------------------------------------------------------------------- -- 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 -- | The document @(x \<+\> y)@ concatenates document @x@ and @y@ with a -- @(fromString \"\ \")@ in between. (infixr 6) (<+>) :: StyleDoc -> StyleDoc -> StyleDoc StyleDoc x <+> StyleDoc y = StyleDoc (x P.<+> y) -- | The document @(align x)@ renders document @x@ with the nesting level set to -- the current column. It is used for example to implement 'hang'. -- -- As an example, we will put a document right above another one, regardless of -- the current nesting level: -- -- > x $$ y = align (x <> line <> y) -- -- > test = fromString "hi" <+> (fromString "nice" $$ fromString "world") -- -- which will be layed out as: -- -- @ -- hi nice -- world -- @ align :: StyleDoc -> StyleDoc align = StyleDoc . P.align . unStyleDoc -- | Strip annotations from a document. This is useful for re-using the textual -- formatting of some sub-document, but applying a different high-level -- annotation. noAnnotate :: StyleDoc -> StyleDoc noAnnotate = StyleDoc . P.noAnnotate . unStyleDoc -- | Document @(braces x)@ encloses document @x@ in braces, \"{\" and \"}\". braces :: StyleDoc -> StyleDoc braces = StyleDoc . P.braces . unStyleDoc -- | Document @(angles x)@ encloses document @x@ in angles, \"\<\" and \"\>\". angles :: StyleDoc -> StyleDoc angles = StyleDoc . P.angles . unStyleDoc -- | Document @(parens x)@ encloses document @x@ in parenthesis, \"(\" and -- \")\". parens :: StyleDoc -> StyleDoc parens = StyleDoc . P.parens . unStyleDoc -- | Document @(dquotes x)@ encloses document @x@ with double quotes '\"'. dquotes :: StyleDoc -> StyleDoc dquotes = StyleDoc . P.dquotes . unStyleDoc -- | Document @(squotes x)@ encloses document @x@ with single quotes \"'\". squotes :: StyleDoc -> StyleDoc squotes = StyleDoc . P.squotes . unStyleDoc -- | Document @(brackets x)@ encloses document @x@ in square brackets, \"[\" and -- \"]\". brackets :: StyleDoc -> StyleDoc brackets = StyleDoc . P.brackets . unStyleDoc -- | The document @string s@ concatenates all characters in @s@ using @line@ for -- newline characters and @fromString@ 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 -- | The document @(nest i x)@ renders document @x@ with the current indentation -- level increased by i (See also 'hang', 'align' and 'indent'). -- -- > nest 2 (fromString "hello" <> line <> fromString "world") -- > <> line -- > <> fromString "!" -- -- outputs as: -- -- @ -- hello -- world -- ! -- @ nest :: Int -> StyleDoc -> StyleDoc nest a = StyleDoc . P.nest a . unStyleDoc -- | The @line@ document advances to the next line and indents to the current -- nesting level. Document @line@ behaves like @(fromString \" \")@ if the line -- break is undone by 'group'. line :: StyleDoc line = StyleDoc P.line -- | The @linebreak@ document advances to the next line and indents to the -- current nesting level. Document @linebreak@ behaves like 'mempty' if the line -- break is undone by 'group'. linebreak :: StyleDoc linebreak = StyleDoc P.linebreak -- | The document @(fill i x)@ renders document @x@. It than appends -- @(fromString \"\ \")@s until the width is equal to @i@. If the width of @x@ -- is already larger, nothing is appended. This combinator is quite useful in -- practice to output a list of bindings. The following example demonstrates -- this. -- -- > types = [ ("empty", "Doc a") -- > , ("nest", "Int -> Doc a -> Doc a") -- > , ("linebreak", "Doc a") -- > ] -- > -- > ptype (name, tp) = -- > fill 6 (fromString name) <+> fromString "::" <+> fromString tp -- > -- > test = fromString "let" <+> align (vcat (map ptype types)) -- -- Which is layed out as: -- -- @ -- let empty :: Doc a -- nest :: Int -> Doc a -> Doc a -- linebreak :: Doc a -- @ fill :: Int -> StyleDoc -> StyleDoc fill a = StyleDoc . P.fill a . unStyleDoc -- | The document @(fillBreak i x)@ first renders document @x@. It then appends -- @(fromString \"\ \")@s until the width is equal to @i@. If the width of @x@ -- is already larger than @i@, the nesting level is increased by @i@ and a -- @line@ is appended. When we redefine @ptype@ in the previous example to use -- @fillBreak@, we get a useful variation of the previous output: -- -- > ptype (name, tp) = -- > fillBreak 6 (fromString name) <+> fromString "::" <+> fromString tp -- -- The output will now be: -- -- @ -- let empty :: Doc a -- nest :: Int -> Doc a -> Doc a -- linebreak -- :: Doc a -- @ fillBreak :: Int -> StyleDoc -> StyleDoc fillBreak a = StyleDoc . P.fillBreak a . unStyleDoc -- | The document @(enclose l r x)@ encloses document @x@ between documents @l@ -- and @r@ using @(\<\>)@. -- -- > enclose l r x = l <> x <> r enclose :: StyleDoc -> StyleDoc -> StyleDoc -> StyleDoc enclose l r x = l <> x <> r -- | The document @(cat xs)@ concatenates all documents @xs@ either -- horizontally with @(\<\>)@, if it fits the page, or vertically with -- @(\<\> linebreak \<\>)@. -- -- > cat xs = group (vcat xs) cat :: [StyleDoc] -> StyleDoc cat = StyleDoc . P.cat . map unStyleDoc -- | @(punctuate p xs)@ concatenates all documents in @xs@ with document @p@ -- except for the last document. -- -- > someText = map fromString ["words", "in", "a", "tuple"] -- > test = parens (align (cat (punctuate comma someText))) -- -- This is layed out on a page width of 20 as: -- -- @ -- (words,in,a,tuple) -- @ -- -- But when the page width is 15, it is layed out as: -- -- @ -- (words, -- in, -- a, -- tuple) -- @ -- -- (If you want put the commas in front of their elements instead of at the end, -- you should use 'encloseSep'.) punctuate :: StyleDoc -> [StyleDoc] -> [StyleDoc] punctuate (StyleDoc x) = map StyleDoc . P.punctuate x . map unStyleDoc -- | The document @(fillCat xs)@ concatenates documents @xs@ horizontally with -- @(\<\>)@ as long as its fits the page, than inserts a @linebreak@ and -- continues doing that for all documents in @xs@. -- -- > fillCat xs = foldr (<> softbreak <>) mempty xs fillCat :: [StyleDoc] -> StyleDoc fillCat = StyleDoc . P.fillCat . map unStyleDoc -- | The document @(hcat xs)@ concatenates all documents @xs@ horizontally with -- @(\<\>)@. hcat :: [StyleDoc] -> StyleDoc hcat = StyleDoc . P.hcat . map unStyleDoc -- | The document @(vcat xs)@ concatenates all documents @xs@ vertically with -- @(\<\> linebreak \<\>)@. If a 'group' undoes the line breaks inserted by -- 'vcat', all documents are directly concatenated. vcat :: [StyleDoc] -> StyleDoc vcat = StyleDoc . P.vcat . map unStyleDoc -- | The document @(sep xs)@ concatenates all documents @xs@ either horizontally -- with @(\<+\>)@, if it fits the page, or vertically with @(\<\> line \<\>)@. -- -- > sep xs = group (vsep xs) sep :: [StyleDoc] -> StyleDoc sep = StyleDoc . P.sep . map unStyleDoc -- | The document @(vsep xs)@ concatenates all documents @xs@ vertically with -- @(\<\> line \<\>)@. If a 'group' undoes the line breaks inserted by 'vsep', -- all documents are separated with a space. -- -- > someText = map fromString (words ("text to lay out")) -- > -- > test = fromString "some" <+> vsep someText -- -- This is layed out as: -- -- @ -- some text -- to -- lay -- out -- @ -- -- The 'align' combinator can be used to align the documents under their first -- element -- -- > test = fromString "some" <+> align (vsep someText) -- -- Which is printed as: -- -- @ -- some text -- to -- lay -- out -- @ vsep :: [StyleDoc] -> StyleDoc vsep = StyleDoc . P.vsep . map unStyleDoc -- | The document @(hsep xs)@ concatenates all documents @xs@ horizontally with -- @('<+>')@. hsep :: [StyleDoc] -> StyleDoc hsep = StyleDoc . P.hsep . map unStyleDoc -- | The document @(fillSep xs)@ concatenates documents @xs@ horizontally with -- @('<+>')@ as long as its fits the page, than inserts a 'line' and continues -- doing that for all documents in @xs@. -- -- > fillSep xs = foldr (<> softline <>) mempty xs fillSep :: [StyleDoc] -> StyleDoc fillSep = StyleDoc . P.fillSep . map unStyleDoc -- | The document @(encloseSep l r sep xs)@ concatenates the documents @xs@ -- separated by @sep@ and encloses the resulting document by @l@ and @r@. The -- documents are rendered horizontally if that fits the page. Otherwise they are -- aligned vertically. All separators are put in front of the elements. For -- example, the combinator 'list' can be defined with 'encloseSep': -- -- > list xs = encloseSep lbracket rbracket comma xs -- > test = fromString "list" <+> (list (map int [10, 200, 3000])) -- -- Which is layed out with a page width of 20 as: -- -- @ -- list [10,200,3000] -- @ -- -- But when the page width is 15, it is layed out as: -- -- @ -- list [10 -- ,200 -- ,3000] -- @ encloseSep :: StyleDoc -> StyleDoc -> StyleDoc -> [StyleDoc] -> StyleDoc encloseSep (StyleDoc x) (StyleDoc y) (StyleDoc z) = StyleDoc . P.encloseSep x y z . map unStyleDoc -- | The document @(indent i x)@ indents document @x@ with @i@ spaces. -- -- > test = indent 4 (fillSep (map fromString -- > (words "the indent combinator indents these words !"))) -- -- Which lays out with a page width of 20 as: -- -- @ -- the indent -- combinator -- indents these -- words ! -- @ indent :: Int -> StyleDoc -> StyleDoc indent a = StyleDoc . P.indent a . unStyleDoc -- | The hang combinator implements hanging indentation. The document -- @(hang i x)@ renders document @x@ with a nesting level set to the current -- column plus @i@. The following example uses hanging indentation for some -- text: -- -- > test = hang 4 (fillSep (map fromString -- > (words "the hang combinator indents these words !"))) -- -- Which lays out on a page with a width of 20 characters as: -- -- @ -- the hang combinator -- indents these -- words ! -- @ -- -- The @hang@ combinator is implemented as: -- -- > hang i x = align (nest i x) hang :: Int -> StyleDoc -> StyleDoc hang a = StyleDoc . P.hang a . unStyleDoc -- | The document @softbreak@ behaves like 'mempty' if the resulting output fits -- the page, otherwise it behaves like 'line'. -- -- > softbreak = group linebreak softbreak :: StyleDoc softbreak = StyleDoc P.softbreak -- | The document @softline@ behaves like @(fromString \"\ \")@ if the resulting -- output fits the page, otherwise it behaves like 'line'. -- -- > softline = group line softline :: StyleDoc softline = StyleDoc P.softline -- | The @group@ combinator is used to specify alternative layouts. The document -- @(group x)@ undoes all line breaks in document @x@. The resulting line is -- added to the current line if that fits the page. Otherwise, the document @x@ -- is rendered without any changes. group :: StyleDoc -> StyleDoc group = StyleDoc . P.group . unStyleDoc rio-prettyprint-0.1.8.0/ChangeLog.md0000644000000000000000000000316714542032725015423 0ustar0000000000000000# Changelog for rio-prettyprint ## 0.1.8.0 * Add `Arch` and `OS` instances of `Pretty`. ## 0.1.7.0 * Add `prettyThrowIO` and `prettyThrowM`, to throw an exception as a `PrettyException`. * Add `ppException`, to provide the prettiest available information about an exception. * Add `prettyGeneric` and `prettyWith` for greater flexibility with pretty logging. * Add `blankLine`. ## 0.1.6.0 * Add `mkBulletedList` for greater flexibility in the format of such lists. * Improve Haddock documentation. ## 0.1.5.0 * Add `SomeBase Dir` and `SomeBase File` instances of `Pretty`. ## 0.1.4.0 * Add `string` and `mkNarrativeList`. * The `PrettyException` instance of `Show` is now derived. `displayException` is now defined, as the `displayException` of the inner exception. ## 0.1.3.0 * Add `SimplePrettyApp`, `mkSimplePrettyApp` and `runSimplePrettyApp`, which facilitate the provision, and use, of a basic environment including pretty printing functionality. * Add `PrettyException` representing pretty exceptions. ## 0.1.2.0 * Expose data constructor of StyleDoc [#8](https://github.com/commercialhaskell/rio-prettyprint/pull/8) ## 0.1.1.0 * Add `Debug`, `Info` and `OtherLevel` data constructors to type `Style` (intended to be used like the existing `Warning` and `Error` constructors) and a `logLevelToStyle` function. * Add `Secondary` and `Highlight` data constructors to type `Style`. * `defaultStyles` now includes defaults for the new `Style` values, corresponding to those used by the `rio` package in its logging output. ## 0.1.0.0 * Initial stable release rio-prettyprint-0.1.8.0/README.md0000644000000000000000000000157714541614725014541 0ustar0000000000000000## rio-prettyprint `rio-prettyprint` is a Haskell package that provides a library that combines the logging capabilities of the [`rio` package](https://hackage.haskell.org/package/rio) with the pretty printing capabilities of the [`annotated-wl-pprint` package](https://hackage.haskell.org/package/annotated-wl-pprint). Documents can be annotated with an optional style from a set of named styles, and the style associated with each named style can be specified as a list of ANSI Select Graphic Rendition (SGR) commands. These commands are represented by the constructors of a type provided by the [`ansi-terminal-types` package](https://hackage.haskell.org/package/ansi-terminal-types) The library also provides: * a type that represents a simple, non-customisable environments that provide pretty logging functionality; and * a type that represents pretty exceptions. rio-prettyprint-0.1.8.0/stack.yaml0000644000000000000000000000004014541615306015227 0ustar0000000000000000resolver: stack-ghc-9.6.3.yaml rio-prettyprint-0.1.8.0/LICENSE0000644000000000000000000000276114475133214014256 0ustar0000000000000000Copyright (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. rio-prettyprint-0.1.8.0/rio-prettyprint.cabal0000644000000000000000000000262414542032725017426 0ustar0000000000000000cabal-version: 1.12 -- This file has been generated from package.yaml by hpack version 0.36.0. -- -- see: https://github.com/sol/hpack name: rio-prettyprint version: 0.1.8.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-2023 FP Complete license: BSD3 license-file: LICENSE build-type: Simple extra-source-files: ChangeLog.md README.md stack.yaml 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