diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,4 +1,22 @@ +## 4.0.0.0 + +* Expand `OutputOptions`: + * Compactness, including grouping of parentheses. + [#72](https://github.com/cdepillabout/pretty-simple/pull/72) + * Page width, affecting when lines are grouped if compact output is enabled. + [#72](https://github.com/cdepillabout/pretty-simple/pull/72) + * Indent whole expression. Useful when using `pretty-simple` for one part + of a larger output. + [#71](https://github.com/cdepillabout/pretty-simple/pull/71) + * Use `Style` type for easier configuration of colour, boldness etc. + [#73](https://github.com/cdepillabout/pretty-simple/pull/73) +* Significant internal rewrite of printing code, to make use of the [prettyprinter](https://hackage.haskell.org/package/prettyprinter) + library. The internal function `layoutString` can be used to integrate with + other `prettyprinter` backends, such as [prettyprinter-lucid](https://hackage.haskell.org/package/prettyprinter-lucid) + for HTML output. + [#67](https://github.com/cdepillabout/pretty-simple/pull/67) + ## 3.3.0.0 * Add an output option to print escaped and non-printable characters diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -2,7 +2,7 @@ Text.Pretty.Simple ================== -[![Build Status](https://secure.travis-ci.org/cdepillabout/pretty-simple.svg)](http://travis-ci.org/cdepillabout/pretty-simple) +[![Build Status](https://github.com/cdepillabout/pretty-simple/workflows/CI/badge.svg)](https://github.com/cdepillabout/pretty-simple/actions) [![Hackage](https://img.shields.io/hackage/v/pretty-simple.svg)](https://hackage.haskell.org/package/pretty-simple) [![Stackage LTS](http://stackage.org/package/pretty-simple/badge/lts)](http://stackage.org/lts/package/pretty-simple) [![Stackage Nightly](http://stackage.org/package/pretty-simple/badge/nightly)](http://stackage.org/nightly/package/pretty-simple) @@ -43,7 +43,7 @@ `pretty-simple` can be easily used from `ghci` when debugging. -When using `stack` to run `ghci`, just append append the `--package` flag to +When using `stack` to run `ghci`, just append the `--package` flag to the command line to load `pretty-simple`. ```sh @@ -79,9 +79,9 @@ function. - Rainbow Parentheses - Easy to understand deeply nested data types. -- Configurable Indentation - - Amount of indentation is configurable with the - [`pPrintOpt`](https://hackage.haskell.org/package/pretty-simple-1.0.0.6/docs/Text-Pretty-Simple.html#v:pPrintOpt) +- Configurable + - Indentation, compactness, colors and more are configurable with the + [`pPrintOpt`](https://hackage.haskell.org/package/pretty-simple/docs/Text-Pretty-Simple.html#v:pPrintOpt) function. - Fast - No problem pretty-printing data types thousands of lines long. @@ -181,7 +181,7 @@ must enable the `buildexe` flag, since it will not be built by default: ```sh -$ stack install pretty-simple-2.2.0.1 --flag pretty-simple:buildexe +$ stack install pretty-simple-4.0.0.0 --flag pretty-simple:buildexe ``` When run on the command line, you can paste in the Haskell datatype you want to @@ -198,3 +198,8 @@ [issue](https://github.com/cdepillabout/pretty-simple/issues) or [PR](https://github.com/cdepillabout/pretty-simple/pulls) for any bugs/problems/suggestions/improvements. + +## Maintainers + +- [@cdepillabout](https://github.com/cdepillabout) +- [@georgefst](https://github.com/georgefst) diff --git a/pretty-simple.cabal b/pretty-simple.cabal --- a/pretty-simple.cabal +++ b/pretty-simple.cabal @@ -1,5 +1,5 @@ name: pretty-simple -version: 3.3.0.0 +version: 4.0.0.0 synopsis: pretty printer for data types with a 'Show' instance. description: Please see . homepage: https://github.com/cdepillabout/pretty-simple @@ -36,13 +36,12 @@ , Text.Pretty.Simple.Internal.Color , Text.Pretty.Simple.Internal.Expr , Text.Pretty.Simple.Internal.ExprParser - , Text.Pretty.Simple.Internal.ExprToOutput - , Text.Pretty.Simple.Internal.Output - , Text.Pretty.Simple.Internal.OutputPrinter + , Text.Pretty.Simple.Internal.Printer build-depends: base >= 4.8 && < 5 - , ansi-terminal >= 0.6 , containers , mtl >= 2.2 + , prettyprinter >= 1.7.0 + , prettyprinter-ansi-terminal >= 1.1.2 , text >= 1.2 , transformers >= 0.4 default-language: Haskell2010 diff --git a/src/Text/Pretty/Simple.hs b/src/Text/Pretty/Simple.hs --- a/src/Text/Pretty/Simple.hs +++ b/src/Text/Pretty/Simple.hs @@ -2,6 +2,8 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} @@ -99,9 +101,13 @@ , defaultOutputOptionsNoColor , CheckColorTty(..) -- * 'ColorOptions' - -- $colorOptions , defaultColorOptionsDarkBg , defaultColorOptionsLightBg + , ColorOptions(..) + , Style(..) + , Color(..) + , Intensity(..) + , colorNull -- * Examples -- $examples ) where @@ -113,17 +119,20 @@ #endif import Control.Monad.IO.Class (MonadIO, liftIO) -import Data.Foldable (toList) import Data.Text.Lazy (Text) -import Data.Text.Lazy.IO as LText +import Prettyprinter (SimpleDocStream) +import Prettyprinter.Render.Terminal + (Color (..), Intensity(Vivid,Dull), AnsiStyle, + renderLazy, renderIO) import System.IO (Handle, stdout) import Text.Pretty.Simple.Internal - (CheckColorTty(..), OutputOptions(..), StringOutputStyle(..), + (ColorOptions(..), Style(..), CheckColorTty(..), + OutputOptions(..), StringOutputStyle(..), + convertStyle, colorNull, defaultColorOptionsDarkBg, defaultColorOptionsLightBg, defaultOutputOptionsDarkBg, defaultOutputOptionsLightBg, - defaultOutputOptionsNoColor, hCheckTTY, expressionParse, - expressionsToOutputs, render) + defaultOutputOptionsNoColor, hCheckTTY, layoutString) -- $setup -- >>> import Data.Text.Lazy (unpack) @@ -519,7 +528,9 @@ case checkColorTty of CheckColorTty -> hCheckTTY handle outputOptions NoCheckColorTty -> pure outputOptions - liftIO $ LText.hPutStrLn handle $ pStringOpt realOutputOpts str + liftIO $ do + renderIO handle $ layoutStringAnsi realOutputOpts str + putStrLn "" -- | Like 'pShow' but takes 'OutputOptions' to change how the -- pretty-printing is done. @@ -529,13 +540,10 @@ -- | Like 'pString' but takes 'OutputOptions' to change how the -- pretty-printing is done. pStringOpt :: OutputOptions -> String -> Text -pStringOpt outputOptions = - render outputOptions . toList . expressionsToOutputs . expressionParse +pStringOpt outputOptions = renderLazy . layoutStringAnsi outputOptions --- $colorOptions --- --- Additional settings for color options can be found in --- "Text.Pretty.Simple.Internal.Color". +layoutStringAnsi :: OutputOptions -> String -> SimpleDocStream AnsiStyle +layoutStringAnsi opts = fmap convertStyle . layoutString opts -- $examples -- @@ -653,6 +661,36 @@ -- , "ヤギ" -- ] -- } +-- +-- __Compactness options__ +-- +-- >>> pPrintStringOpt CheckColorTty defaultOutputOptionsDarkBg {outputOptionsCompact = True} "AST [] [Def ((3,1),(5,30)) (Id \"fact'\" \"fact'\") [] (Forall ((3,9),(3,26)) [((Id \"n\" \"n_0\"),KPromote (TyCon (Id \"Nat\" \"Nat\")))])]" +-- AST [] +-- [ Def +-- ( ( 3, 1 ), ( 5, 30 ) ) +-- ( Id "fact'" "fact'" ) [] +-- ( Forall +-- ( ( 3, 9 ), ( 3, 26 ) ) +-- [ ( ( Id "n" "n_0" ), KPromote ( TyCon ( Id "Nat" "Nat" ) ) ) ] +-- ) +-- ] +-- +-- >>> pPrintOpt CheckColorTty defaultOutputOptionsDarkBg {outputOptionsCompactParens = True} $ B ( C [A, A] [B A, B (B (B A))] ) +-- B +-- ( C +-- [ A +-- , A ] +-- [ B A +-- , B +-- ( B ( B A ) ) ] ) +-- +-- __Initial indent__ +-- +-- >>> pPrintOpt CheckColorTty defaultOutputOptionsDarkBg {outputOptionsInitialIndent = 3} $ B ( B ( B ( B A ) ) ) +-- B +-- ( B +-- ( B ( B A ) ) +-- ) -- -- __Other__ -- diff --git a/src/Text/Pretty/Simple/Internal.hs b/src/Text/Pretty/Simple/Internal.hs --- a/src/Text/Pretty/Simple/Internal.hs +++ b/src/Text/Pretty/Simple/Internal.hs @@ -14,6 +14,4 @@ import Text.Pretty.Simple.Internal.Color as X import Text.Pretty.Simple.Internal.ExprParser as X import Text.Pretty.Simple.Internal.Expr as X -import Text.Pretty.Simple.Internal.ExprToOutput as X -import Text.Pretty.Simple.Internal.Output as X -import Text.Pretty.Simple.Internal.OutputPrinter as X +import Text.Pretty.Simple.Internal.Printer as X diff --git a/src/Text/Pretty/Simple/Internal/Color.hs b/src/Text/Pretty/Simple/Internal/Color.hs --- a/src/Text/Pretty/Simple/Internal/Color.hs +++ b/src/Text/Pretty/Simple/Internal/Color.hs @@ -2,13 +2,15 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-| -Module : Text.Pretty.Simple.Internal.OutputPrinter +Module : Text.Pretty.Simple.Internal.Color Copyright : (c) Dennis Gosnell, 2016 License : BSD-style (see LICENSE file) Maintainer : cdep.illabout@gmail.com @@ -25,283 +27,107 @@ import Control.Applicative #endif -import Data.Text.Lazy.Builder (Builder, fromString) import Data.Typeable (Typeable) import GHC.Generics (Generic) -import System.Console.ANSI - (Color(..), ColorIntensity(..), ConsoleIntensity(..), - ConsoleLayer(..), SGR(..), setSGRCode) +import Prettyprinter.Render.Terminal + (AnsiStyle, Intensity(Dull,Vivid), Color(..)) +import qualified Prettyprinter.Render.Terminal as Ansi -- | These options are for colorizing the output of functions like 'pPrint'. -- --- For example, if you set 'colorQuote' to something like 'colorVividBlueBold', --- then the quote character (@\"@) will be output as bright blue in bold. --- -- If you don't want to use a color for one of the options, use 'colorNull'. data ColorOptions = ColorOptions - { colorQuote :: Builder + { colorQuote :: Style -- ^ Color to use for quote characters (@\"@) around strings. - , colorString :: Builder + , colorString :: Style -- ^ Color to use for strings. - , colorError :: Builder - -- ^ (currently not used) - , colorNum :: Builder + , colorError :: Style + -- ^ Color for errors, e.g. unmatched brackets. + , colorNum :: Style -- ^ Color to use for numbers. - , colorRainbowParens :: [Builder] - -- ^ A list of 'Builder' colors to use for rainbow parenthesis output. Use + , colorRainbowParens :: [Style] + -- ^ A list of colors to use for rainbow parenthesis output. Use -- '[]' if you don't want rainbow parenthesis. Use just a single item if you -- want all the rainbow parenthesis to be colored the same. } deriving (Eq, Generic, Show, Typeable) ------------------------------------- --- Dark background default colors -- ------------------------------------- - -- | Default color options for use on a dark background. --- --- 'colorQuote' is 'defaultColorQuoteDarkBg'. 'colorString' is --- 'defaultColorStringDarkBg'. 'colorError' is 'defaultColorErrorDarkBg'. --- 'colorNum' is 'defaultColorNumDarkBg'. 'colorRainbowParens' is --- 'defaultColorRainboxParensDarkBg'. defaultColorOptionsDarkBg :: ColorOptions defaultColorOptionsDarkBg = ColorOptions - { colorQuote = defaultColorQuoteDarkBg - , colorString = defaultColorStringDarkBg - , colorError = defaultColorErrorDarkBg - , colorNum = defaultColorNumDarkBg - , colorRainbowParens = defaultColorRainbowParensDarkBg + { colorQuote = colorBold Vivid White + , colorString = colorBold Vivid Blue + , colorError = colorBold Vivid Red + , colorNum = colorBold Vivid Green + , colorRainbowParens = + [ colorBold Vivid Magenta + , colorBold Vivid Cyan + , colorBold Vivid Yellow + , color Dull Magenta + , color Dull Cyan + , color Dull Yellow + , colorBold Dull Magenta + , colorBold Dull Cyan + , colorBold Dull Yellow + , color Vivid Magenta + , color Vivid Cyan + , color Vivid Yellow + ] } --- | Default color for 'colorQuote' for dark backgrounds. This is --- 'colorVividWhiteBold'. -defaultColorQuoteDarkBg :: Builder -defaultColorQuoteDarkBg = colorVividWhiteBold - --- | Default color for 'colorString' for dark backgrounds. This is --- 'colorVividBlueBold'. -defaultColorStringDarkBg :: Builder -defaultColorStringDarkBg = colorVividBlueBold - --- | Default color for 'colorError' for dark backgrounds. This is --- 'colorVividRedBold'. -defaultColorErrorDarkBg :: Builder -defaultColorErrorDarkBg = colorVividRedBold - --- | Default color for 'colorNum' for dark backgrounds. This is --- 'colorVividGreenBold'. -defaultColorNumDarkBg :: Builder -defaultColorNumDarkBg = colorVividGreenBold - --- | Default colors for 'colorRainbowParens' for dark backgrounds. -defaultColorRainbowParensDarkBg :: [Builder] -defaultColorRainbowParensDarkBg = - [ colorVividMagentaBold - , colorVividCyanBold - , colorVividYellowBold - , colorDullMagenta - , colorDullCyan - , colorDullYellow - , colorDullMagentaBold - , colorDullCyanBold - , colorDullYellowBold - , colorVividMagenta - , colorVividCyan - , colorVividYellow - ] - -------------------------------------- --- Light background default colors -- -------------------------------------- - -- | Default color options for use on a light background. --- --- 'colorQuote' is 'defaultColorQuoteLightBg'. 'colorString' is --- 'defaultColorStringLightBg'. 'colorError' is 'defaultColorErrorLightBg'. --- 'colorNum' is 'defaultColorNumLightBg'. 'colorRainbowParens' is --- 'defaultColorRainboxParensLightBg'. defaultColorOptionsLightBg :: ColorOptions defaultColorOptionsLightBg = ColorOptions - { colorQuote = defaultColorQuoteLightBg - , colorString = defaultColorStringLightBg - , colorError = defaultColorErrorLightBg - , colorNum = defaultColorNumLightBg - , colorRainbowParens = defaultColorRainbowParensLightBg + { colorQuote = colorBold Vivid Black + , colorString = colorBold Vivid Blue + , colorError = colorBold Vivid Red + , colorNum = colorBold Vivid Green + , colorRainbowParens = + [ colorBold Vivid Magenta + , colorBold Vivid Cyan + , color Dull Magenta + , color Dull Cyan + , colorBold Dull Magenta + , colorBold Dull Cyan + , color Vivid Magenta + , color Vivid Cyan + ] } --- | Default color for 'colorQuote' for light backgrounds. This is --- 'colorVividWhiteBold'. -defaultColorQuoteLightBg :: Builder -defaultColorQuoteLightBg = colorVividBlackBold - --- | Default color for 'colorString' for light backgrounds. This is --- 'colorVividBlueBold'. -defaultColorStringLightBg :: Builder -defaultColorStringLightBg = colorVividBlueBold - --- | Default color for 'colorError' for light backgrounds. This is --- 'colorVividRedBold'. -defaultColorErrorLightBg :: Builder -defaultColorErrorLightBg = colorVividRedBold - --- | Default color for 'colorNum' for light backgrounds. This is --- 'colorVividGreenBold'. -defaultColorNumLightBg :: Builder -defaultColorNumLightBg = colorVividGreenBold - --- | Default colors for 'colorRainbowParens' for light backgrounds. -defaultColorRainbowParensLightBg :: [Builder] -defaultColorRainbowParensLightBg = - [ colorVividMagentaBold - , colorVividCyanBold - , colorDullMagenta - , colorDullCyan - , colorDullMagentaBold - , colorDullCyanBold - , colorVividMagenta - , colorVividCyan - ] - ------------------------ --- Vivid Bold Colors -- ------------------------ - -colorVividBlackBold :: Builder -colorVividBlackBold = colorBold `mappend` colorVividBlack - -colorVividBlueBold :: Builder -colorVividBlueBold = colorBold `mappend` colorVividBlue - -colorVividCyanBold :: Builder -colorVividCyanBold = colorBold `mappend` colorVividCyan - -colorVividGreenBold :: Builder -colorVividGreenBold = colorBold `mappend` colorVividGreen - -colorVividMagentaBold :: Builder -colorVividMagentaBold = colorBold `mappend` colorVividMagenta - -colorVividRedBold :: Builder -colorVividRedBold = colorBold `mappend` colorVividRed - -colorVividWhiteBold :: Builder -colorVividWhiteBold = colorBold `mappend` colorVividWhite - -colorVividYellowBold :: Builder -colorVividYellowBold = colorBold `mappend` colorVividYellow - ------------------------ --- Dull Bold Colors -- ------------------------ - -colorDullBlackBold :: Builder -colorDullBlackBold = colorBold `mappend` colorDullBlack - -colorDullBlueBold :: Builder -colorDullBlueBold = colorBold `mappend` colorDullBlue - -colorDullCyanBold :: Builder -colorDullCyanBold = colorBold `mappend` colorDullCyan - -colorDullGreenBold :: Builder -colorDullGreenBold = colorBold `mappend` colorDullGreen - -colorDullMagentaBold :: Builder -colorDullMagentaBold = colorBold `mappend` colorDullMagenta - -colorDullRedBold :: Builder -colorDullRedBold = colorBold `mappend` colorDullRed - -colorDullWhiteBold :: Builder -colorDullWhiteBold = colorBold `mappend` colorDullWhite - -colorDullYellowBold :: Builder -colorDullYellowBold = colorBold `mappend` colorDullYellow - ------------------- --- Vivid Colors -- ------------------- - -colorVividBlack :: Builder -colorVividBlack = colorHelper Vivid Black - -colorVividBlue :: Builder -colorVividBlue = colorHelper Vivid Blue - -colorVividCyan :: Builder -colorVividCyan = colorHelper Vivid Cyan - -colorVividGreen :: Builder -colorVividGreen = colorHelper Vivid Green - -colorVividMagenta :: Builder -colorVividMagenta = colorHelper Vivid Magenta - -colorVividRed :: Builder -colorVividRed = colorHelper Vivid Red - -colorVividWhite :: Builder -colorVividWhite = colorHelper Vivid White - -colorVividYellow :: Builder -colorVividYellow = colorHelper Vivid Yellow - ------------------- --- Dull Colors -- ------------------- - -colorDullBlack :: Builder -colorDullBlack = colorHelper Dull Black - -colorDullBlue :: Builder -colorDullBlue = colorHelper Dull Blue - -colorDullCyan :: Builder -colorDullCyan = colorHelper Dull Cyan - -colorDullGreen :: Builder -colorDullGreen = colorHelper Dull Green - -colorDullMagenta :: Builder -colorDullMagenta = colorHelper Dull Magenta - -colorDullRed :: Builder -colorDullRed = colorHelper Dull Red - -colorDullWhite :: Builder -colorDullWhite = colorHelper Dull White - -colorDullYellow :: Builder -colorDullYellow = colorHelper Dull Yellow - --------------------- --- Special Colors -- --------------------- - --- | Change the intensity to 'BoldIntensity'. -colorBold :: Builder -colorBold = setSGRCodeBuilder [SetConsoleIntensity BoldIntensity] - --- | 'Reset' the console color back to normal. -colorReset :: Builder -colorReset = setSGRCodeBuilder [Reset] - --- | Empty string. -colorNull :: Builder -colorNull = "" +-- | No styling. +colorNull :: Style +colorNull = Style + { styleColor = Nothing + , styleBold = False + , styleItalic = False + , styleUnderlined = False + } -------------- --- Helpers -- -------------- +-- | Ways to style terminal output. +data Style = Style + { styleColor :: Maybe (Color, Intensity) + , styleBold :: Bool + , styleItalic :: Bool + , styleUnderlined :: Bool + } + deriving (Eq, Generic, Show, Typeable) --- | Helper for creating a 'Builder' for an ANSI escape sequence color based on --- a 'ColorIntensity' and a 'Color'. -colorHelper :: ColorIntensity -> Color -> Builder -colorHelper colorIntensity color = - setSGRCodeBuilder [SetColor Foreground colorIntensity color] +color :: Intensity -> Color -> Style +color i c = colorNull {styleColor = Just (c, i)} --- | Convert a list of 'SGR' to a 'Builder'. -setSGRCodeBuilder :: [SGR] -> Builder -setSGRCodeBuilder = fromString . setSGRCode +colorBold :: Intensity -> Color -> Style +colorBold i c = (color i c) {styleBold = True} +convertStyle :: Style -> AnsiStyle +convertStyle Style {..} = + mconcat + [ maybe mempty (uncurry $ flip col) styleColor + , if styleBold then Ansi.bold else mempty + , if styleItalic then Ansi.italicized else mempty + , if styleUnderlined then Ansi.underlined else mempty + ] + where + col = \case + Vivid -> Ansi.color + Dull -> Ansi.colorDull diff --git a/src/Text/Pretty/Simple/Internal/ExprToOutput.hs b/src/Text/Pretty/Simple/Internal/ExprToOutput.hs deleted file mode 100644 --- a/src/Text/Pretty/Simple/Internal/ExprToOutput.hs +++ /dev/null @@ -1,296 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} - -{-| -Module : Text.Pretty.Simple.Internal.Printer -Copyright : (c) Dennis Gosnell, 2016 -License : BSD-style (see LICENSE file) -Maintainer : cdep.illabout@gmail.com -Stability : experimental -Portability : POSIX - --} -module Text.Pretty.Simple.Internal.ExprToOutput - where - -#if __GLASGOW_HASKELL__ < 710 --- We don't need this import for GHC 7.10 as it exports all required functions --- from Prelude -import Control.Applicative -#endif - -import Control.Monad (when) -import Control.Monad.State (MonadState, evalState, gets, modify) -import Data.Data (Data) -import Data.Monoid ((<>)) -import Data.List (intersperse) -import Data.Typeable (Typeable) -import GHC.Generics (Generic) - -import Text.Pretty.Simple.Internal.Expr (CommaSeparated(..), Expr(..)) -import Text.Pretty.Simple.Internal.Output - (NestLevel(..), Output(..), OutputType(..), unNestLevel) - --- $setup --- >>> :set -XOverloadedStrings --- >>> import Control.Monad.State (State) --- >>> :{ --- let test :: PrinterState -> State PrinterState [Output] -> [Output] --- test initState state = evalState state initState --- testInit :: State PrinterState [Output] -> [Output] --- testInit = test initPrinterState --- :} - --- | Newtype around 'Int' to represent a line number. After a newline, the --- 'LineNum' will increase by 1. -newtype LineNum = LineNum { unLineNum :: Int } - deriving (Data, Eq, Generic, Num, Ord, Read, Show, Typeable) - -data PrinterState = PrinterState - { currLine :: {-# UNPACK #-} !LineNum - , nestLevel :: {-# UNPACK #-} !NestLevel - } deriving (Eq, Data, Generic, Show, Typeable) - --- | Smart-constructor for 'PrinterState'. -printerState :: LineNum -> NestLevel -> PrinterState -printerState currLineNum nestNum = - PrinterState - { currLine = currLineNum - , nestLevel = nestNum - } - - -addOutput - :: MonadState PrinterState m - => OutputType -> m Output -addOutput outputType = do - nest <- gets nestLevel - return $ Output nest outputType - -addOutputs - :: MonadState PrinterState m - => [OutputType] -> m [Output] -addOutputs outputTypes = do - nest <- gets nestLevel - return $ Output nest <$> outputTypes - -initPrinterState :: PrinterState -initPrinterState = printerState 0 (-1) - --- | Print a surrounding expression (like @\[\]@ or @\{\}@ or @\(\)@). --- --- If the 'CommaSeparated' expressions are empty, just print the start and end --- markers. --- --- >>> testInit $ putSurroundExpr "[" "]" (CommaSeparated []) --- [Output {outputNestLevel = NestLevel {unNestLevel = 0}, outputOutputType = OutputOpenBracket},Output {outputNestLevel = NestLevel {unNestLevel = 0}, outputOutputType = OutputCloseBracket}] --- --- If there is only one expression, and it will print out on one line, then --- just print everything all on one line, with spaces around the expressions. --- --- >>> testInit $ putSurroundExpr "{" "}" (CommaSeparated [[Other "hello"]]) --- [Output {outputNestLevel = NestLevel {unNestLevel = 0}, outputOutputType = OutputOpenBrace},Output {outputNestLevel = NestLevel {unNestLevel = 0}, outputOutputType = OutputOther " "},Output {outputNestLevel = NestLevel {unNestLevel = 0}, outputOutputType = OutputOther "hello"},Output {outputNestLevel = NestLevel {unNestLevel = 0}, outputOutputType = OutputOther " "},Output {outputNestLevel = NestLevel {unNestLevel = 0}, outputOutputType = OutputCloseBrace}] --- --- If there is only one expression, but it will print out on multiple lines, --- then go to newline and print out on multiple lines. --- --- >>> 1 + 1 -- TODO: Example here. --- 2 --- --- If there are multiple expressions, then first go to a newline. --- Print out on multiple lines. --- --- >>> 1 + 1 -- TODO: Example here. --- 2 -putSurroundExpr - :: MonadState PrinterState m - => OutputType - -> OutputType - -> CommaSeparated [Expr] -- ^ comma separated inner expression. - -> m [Output] -putSurroundExpr startOutputType endOutputType (CommaSeparated []) = do - addToNestLevel 1 - outputs <- addOutputs [startOutputType, endOutputType] - addToNestLevel (-1) - return outputs -putSurroundExpr startOutputType endOutputType (CommaSeparated [exprs]) = do - addToNestLevel 1 - let (thisLayerMulti, nextLayerMulti) = thisAndNextMulti exprs - - maybeNL <- if thisLayerMulti - then newLineAndDoIndent - else return [] - start <- addOutputs [startOutputType, OutputOther " "] - middle <- concat <$> traverse putExpression exprs - nlOrSpace <- if nextLayerMulti - then newLineAndDoIndent - else (:[]) <$> (addOutput $ OutputOther " ") - end <- addOutput endOutputType - - addToNestLevel (-1) - - return $ maybeNL <> start <> middle <> nlOrSpace <> [end] - where - thisAndNextMulti = (\(a,b) -> (or a, or b)) . unzip . map isMultiLine - - isMultiLine (Brackets commaSeparated) = isMultiLine' commaSeparated - isMultiLine (Braces commaSeparated) = isMultiLine' commaSeparated - isMultiLine (Parens commaSeparated) = isMultiLine' commaSeparated - isMultiLine _ = (False, False) - - isMultiLine' (CommaSeparated []) = (False, False) - isMultiLine' (CommaSeparated [es]) = (True, fst $ thisAndNextMulti es) - isMultiLine' _ = (True, True) -putSurroundExpr startOutputType endOutputType commaSeparated = do - addToNestLevel 1 - nl <- newLineAndDoIndent - start <- addOutputs [startOutputType, OutputOther " "] - middle <- putCommaSep commaSeparated - nl2 <- newLineAndDoIndent - end <- addOutput endOutputType - addToNestLevel (-1) - endSpace <- addOutput $ OutputOther " " - - return $ nl <> start <> middle <> nl2 <> [end, endSpace] - - -putCommaSep - :: forall m. - MonadState PrinterState m - => CommaSeparated [Expr] -> m [Output] -putCommaSep (CommaSeparated expressionsList) = - concat <$> (sequence $ intersperse putComma evaledExpressionList) - where - evaledExpressionList :: [m [Output]] - evaledExpressionList = - (concat <.> traverse putExpression) <$> expressionsList - - (f <.> g) x = f <$> g x - -putComma - :: MonadState PrinterState m - => m [Output] -putComma = do - nl <- newLineAndDoIndent - outputs <- addOutputs [OutputComma, OutputOther " "] - return $ nl <> outputs - -doIndent :: MonadState PrinterState m => m [Output] -doIndent = do - nest <- gets $ unNestLevel . nestLevel - addOutputs $ replicate nest OutputIndent - -newLine - :: MonadState PrinterState m - => m Output -newLine = do - output <- addOutput OutputNewLine - addToCurrentLine 1 - return output - -newLineAndDoIndent - :: MonadState PrinterState m - => m [Output] -newLineAndDoIndent = do - nl <- newLine - indent <- doIndent - return $ nl:indent - -addToNestLevel - :: MonadState PrinterState m - => NestLevel -> m () -addToNestLevel diff = - modify (\printState -> printState {nestLevel = nestLevel printState + diff}) - -addToCurrentLine - :: MonadState PrinterState m - => LineNum -> m () -addToCurrentLine diff = - modify (\printState -> printState {currLine = currLine printState + diff}) - -putExpression :: MonadState PrinterState m => Expr -> m [Output] -putExpression (Brackets commaSeparated) = - putSurroundExpr OutputOpenBracket OutputCloseBracket commaSeparated -putExpression (Braces commaSeparated) = - putSurroundExpr OutputOpenBrace OutputCloseBrace commaSeparated -putExpression (Parens commaSeparated) = - putSurroundExpr OutputOpenParen OutputCloseParen commaSeparated -putExpression (StringLit string) = do - nest <- gets nestLevel - when (nest < 0) $ addToNestLevel 1 - addOutputs [OutputStringLit string, OutputOther " "] -putExpression (CharLit string) = do - nest <- gets nestLevel - when (nest < 0) $ addToNestLevel 1 - addOutputs [OutputCharLit string, OutputOther " "] -putExpression (NumberLit integer) = do - nest <- gets nestLevel - when (nest < 0) $ addToNestLevel 1 - (:[]) <$> (addOutput $ OutputNumberLit integer) -putExpression (Other string) = do - nest <- gets nestLevel - when (nest < 0) $ addToNestLevel 1 - (:[]) <$> (addOutput $ OutputOther string) - -runPrinterState :: PrinterState -> [Expr] -> [Output] -runPrinterState initState expressions = - concat $ evalState (traverse putExpression expressions) initState - -runInitPrinterState :: [Expr] -> [Output] -runInitPrinterState = runPrinterState initPrinterState - -expressionsToOutputs :: [Expr] -> [Output] -expressionsToOutputs = runInitPrinterState . modificationsExprList - --- | A function that performs optimizations and modifications to a list of --- input 'Expr's. --- --- An sample of an optimization is 'removeEmptyInnerCommaSeparatedExprList' --- which removes empty inner lists in a 'CommaSeparated' value. -modificationsExprList :: [Expr] -> [Expr] -modificationsExprList = removeEmptyInnerCommaSeparatedExprList - -removeEmptyInnerCommaSeparatedExprList :: [Expr] -> [Expr] -removeEmptyInnerCommaSeparatedExprList = fmap removeEmptyInnerCommaSeparatedExpr - -removeEmptyInnerCommaSeparatedExpr :: Expr -> Expr -removeEmptyInnerCommaSeparatedExpr (Brackets commaSeparated) = - Brackets $ removeEmptyInnerCommaSeparated commaSeparated -removeEmptyInnerCommaSeparatedExpr (Braces commaSeparated) = - Braces $ removeEmptyInnerCommaSeparated commaSeparated -removeEmptyInnerCommaSeparatedExpr (Parens commaSeparated) = - Parens $ removeEmptyInnerCommaSeparated commaSeparated -removeEmptyInnerCommaSeparatedExpr other = other - -removeEmptyInnerCommaSeparated :: CommaSeparated [Expr] -> CommaSeparated [Expr] -removeEmptyInnerCommaSeparated (CommaSeparated commaSeps) = - CommaSeparated . fmap removeEmptyInnerCommaSeparatedExprList $ - removeEmptyList commaSeps - --- | Remove empty lists from a list of lists. --- --- >>> removeEmptyList [[1,2,3], [], [4,5]] --- [[1,2,3],[4,5]] --- --- >>> removeEmptyList [[]] --- [] --- --- >>> removeEmptyList [[1]] --- [[1]] --- --- >>> removeEmptyList [[1,2], [10,20], [100,200]] --- [[1,2],[10,20],[100,200]] -removeEmptyList :: forall a . [[a]] -> [[a]] -removeEmptyList = foldr f [] - where - f :: [a] -> [[a]] -> [[a]] - f [] accum = accum - f a accum = [a] <> accum diff --git a/src/Text/Pretty/Simple/Internal/Output.hs b/src/Text/Pretty/Simple/Internal/Output.hs deleted file mode 100644 --- a/src/Text/Pretty/Simple/Internal/Output.hs +++ /dev/null @@ -1,99 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} - -{-| -Module : Text.Pretty.Simple.Internal.Output -Copyright : (c) Dennis Gosnell, 2016 -License : BSD-style (see LICENSE file) -Maintainer : cdep.illabout@gmail.com -Stability : experimental -Portability : POSIX - --} -module Text.Pretty.Simple.Internal.Output - where - -#if __GLASGOW_HASKELL__ < 710 --- We don't need this import for GHC 7.10 as it exports all required functions --- from Prelude -import Control.Applicative -#endif - -import Data.Data (Data) -import Data.String (IsString, fromString) -import Data.Typeable (Typeable) -import GHC.Generics (Generic) - --- | Datatype representing how much something is nested. --- --- For example, a 'NestLevel' of 0 would mean an 'Output' token --- is at the very highest level, not in any braces. --- --- A 'NestLevel' of 1 would mean that an 'Output' token is in one single pair --- of @\{@ and @\}@, or @\[@ and @\], or @\(@ and @\)@. --- --- A 'NestLevel' of 2 would mean that an 'Output' token is two levels of --- brackets, etc. -newtype NestLevel = NestLevel { unNestLevel :: Int } - deriving (Data, Eq, Generic, Num, Ord, Read, Show, Typeable) - --- | These are the output tokens that we will be printing to the screen. -data OutputType - = OutputCloseBrace - -- ^ This represents the @\}@ character. - | OutputCloseBracket - -- ^ This represents the @\]@ character. - | OutputCloseParen - -- ^ This represents the @\)@ character. - | OutputComma - -- ^ This represents the @\,@ character. - | OutputIndent - -- ^ This represents an indentation. - | OutputNewLine - -- ^ This represents the @\\n@ character. - | OutputOpenBrace - -- ^ This represents the @\{@ character. - | OutputOpenBracket - -- ^ This represents the @\[@ character. - | OutputOpenParen - -- ^ This represents the @\(@ character. - | OutputOther !String - -- ^ This represents some collection of characters that don\'t fit into any - -- of the other tokens. - | OutputStringLit !String - -- ^ This represents a string literal. For instance, @\"foobar\"@. - | OutputCharLit !String - -- ^ This represents a char literal. For example, @'x'@ or @'\b'@ - | OutputNumberLit !String - -- ^ This represents a numeric literal. For example, @12345@ or @3.14159@. - deriving (Data, Eq, Generic, Read, Show, Typeable) - --- | 'IsString' (and 'fromString') should generally only be used in tests and --- debugging. There is no way to represent 'OutputIndent', 'OutputNumberLit' --- and 'OutputStringLit'. -instance IsString OutputType where - fromString :: String -> OutputType - fromString "}" = OutputCloseBrace - fromString "]" = OutputCloseBracket - fromString ")" = OutputCloseParen - fromString "," = OutputComma - fromString "\n" = OutputNewLine - fromString "{" = OutputOpenBrace - fromString "[" = OutputOpenBracket - fromString "(" = OutputOpenParen - fromString string = OutputOther string - --- | An 'OutputType' token together with a 'NestLevel'. Basically, each --- 'OutputType' keeps track of its own 'NestLevel'. -data Output = Output - { outputNestLevel :: {-# UNPACK #-} !NestLevel - , outputOutputType :: !OutputType - } deriving (Data, Eq, Generic, Read, Show, Typeable) diff --git a/src/Text/Pretty/Simple/Internal/OutputPrinter.hs b/src/Text/Pretty/Simple/Internal/OutputPrinter.hs deleted file mode 100644 --- a/src/Text/Pretty/Simple/Internal/OutputPrinter.hs +++ /dev/null @@ -1,410 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} - -{-| -Module : Text.Pretty.Simple.Internal.OutputPrinter -Copyright : (c) Dennis Gosnell, 2016 -License : BSD-style (see LICENSE file) -Maintainer : cdep.illabout@gmail.com -Stability : experimental -Portability : POSIX - --} -module Text.Pretty.Simple.Internal.OutputPrinter - where - -#if __GLASGOW_HASKELL__ < 710 --- We don't need this import for GHC 7.10 as it exports all required functions --- from Prelude -import Control.Applicative -#endif - -import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Reader (MonadReader(ask, reader), runReader) -import Data.Char (isPrint, isSpace, ord) -import Numeric (showHex) -import Data.Foldable (fold) -import Data.Text.Lazy (Text) -import Data.Text.Lazy.Builder (Builder, fromString, toLazyText) -import Data.Typeable (Typeable) -import Data.List (dropWhileEnd, intercalate) -import Data.Maybe (fromMaybe) -import Text.Read (readMaybe) -import GHC.Generics (Generic) -import System.IO (Handle, hIsTerminalDevice) - -import Text.Pretty.Simple.Internal.Color - (ColorOptions(..), colorReset, defaultColorOptionsDarkBg, - defaultColorOptionsLightBg) -import Text.Pretty.Simple.Internal.Output - (NestLevel(..), Output(..), OutputType(..)) - --- $setup --- >>> import Text.Pretty.Simple (pPrintString, pPrintStringOpt) - --- | Determines whether pretty-simple should check if the output 'Handle' is a --- TTY device. Normally, users only want to print in color if the output --- 'Handle' is a TTY device. -data CheckColorTty - = CheckColorTty - -- ^ Check if the output 'Handle' is a TTY device. If the output 'Handle' is - -- a TTY device, determine whether to print in color based on - -- 'outputOptionsColorOptions'. If not, then set 'outputOptionsColorOptions' - -- to 'Nothing' so the output does not get colorized. - | NoCheckColorTty - -- ^ Don't check if the output 'Handle' is a TTY device. Determine whether to - -- colorize the output based solely on the value of - -- 'outputOptionsColorOptions'. - deriving (Eq, Generic, Show, Typeable) - --- | Control how escaped and non-printable are output for strings. --- --- See 'outputOptionsStringStyle' for what the output looks like with each of --- these options. -data StringOutputStyle - = Literal - -- ^ Output string literals by printing the source characters exactly. - -- - -- For examples: without this option the printer will insert a newline in - -- place of @"\n"@, with this options the printer will output @'\'@ and - -- @'n'@. Similarly the exact escape codes used in the input string will be - -- replicated, so @"\65"@ will be printed as @"\65"@ and not @"A"@. - | EscapeNonPrintable - -- ^ Replace non-printable characters with hexadecimal escape sequences. - | DoNotEscapeNonPrintable - -- ^ Output non-printable characters without modification. - deriving (Eq, Generic, Show, Typeable) - --- | Data-type wrapping up all the options available when rendering the list --- of 'Output's. -data OutputOptions = OutputOptions - { outputOptionsIndentAmount :: Int - -- ^ Number of spaces to use when indenting. It should probably be either 2 - -- or 4. - , outputOptionsColorOptions :: Maybe ColorOptions - -- ^ If this is 'Nothing', then don't colorize the output. If this is - -- @'Just' colorOptions@, then use @colorOptions@ to colorize the output. - -- - , outputOptionsStringStyle :: StringOutputStyle - -- ^ Controls how string literals are output. - -- - -- By default, the pPrint functions escape non-printable characters, but - -- print all printable characters: - -- - -- >>> pPrintString "\"A \\x42 Ä \\xC4 \\x1 \\n\"" - -- "A B Ä Ä \x1 " - -- - -- Here, you can see that the character @A@ has been printed as-is. @\x42@ - -- has been printed in the non-escaped version, @B@. The non-printable - -- character @\x1@ has been printed as @\x1@. Newlines will be removed to - -- make the output easier to read. - -- - -- This corresponds to the 'StringOutputStyle' called 'EscapeNonPrintable'. - -- - -- (Note that in the above and following examples, the characters have to be - -- double-escaped, which makes it somewhat confusing...) - -- - -- Another output style is 'DoNotEscapeNonPrintable'. This is similar - -- to 'EscapeNonPrintable', except that non-printable characters get printed - -- out literally to the screen. - -- - -- >>> pPrintStringOpt CheckColorTty defaultOutputOptionsDarkBg{ outputOptionsStringStyle = DoNotEscapeNonPrintable } "\"A \\x42 Ä \\xC4 \\n\"" - -- "A B Ä Ä " - -- - -- If you change the above example to contain @\x1@, you can see that it is - -- output as a literal, non-escaped character. Newlines are still removed - -- for readability. - -- - -- Another output style is 'Literal'. This just outputs all escape characters. - -- - -- >>> pPrintStringOpt CheckColorTty defaultOutputOptionsDarkBg{ outputOptionsStringStyle = Literal } "\"A \\x42 Ä \\xC4 \\x1 \\n\"" - -- "A \x42 Ä \xC4 \x1 \n" - -- - -- You can see that all the escape characters get output literally, including - -- newline. - } deriving (Eq, Generic, Show, Typeable) - --- | Default values for 'OutputOptions' when printing to a console with a dark --- background. 'outputOptionsIndentAmount' is 4, and --- 'outputOptionsColorOptions' is 'defaultColorOptionsDarkBg'. -defaultOutputOptionsDarkBg :: OutputOptions -defaultOutputOptionsDarkBg = - OutputOptions - { outputOptionsIndentAmount = 4 - , outputOptionsColorOptions = Just defaultColorOptionsDarkBg - , outputOptionsStringStyle = EscapeNonPrintable - } - --- | Default values for 'OutputOptions' when printing to a console with a light --- background. 'outputOptionsIndentAmount' is 4, and --- 'outputOptionsColorOptions' is 'defaultColorOptionsLightBg'. -defaultOutputOptionsLightBg :: OutputOptions -defaultOutputOptionsLightBg = - OutputOptions - { outputOptionsIndentAmount = 4 - , outputOptionsColorOptions = Just defaultColorOptionsLightBg - , outputOptionsStringStyle = EscapeNonPrintable - } - --- | Default values for 'OutputOptions' when printing using using ANSI escape --- sequences for color. 'outputOptionsIndentAmount' is 4, and --- 'outputOptionsColorOptions' is 'Nothing'. -defaultOutputOptionsNoColor :: OutputOptions -defaultOutputOptionsNoColor = - OutputOptions - { outputOptionsIndentAmount = 4 - , outputOptionsColorOptions = Nothing - , outputOptionsStringStyle = EscapeNonPrintable - } - --- | Given 'OutputOptions', disable colorful output if the given handle --- is not connected to a TTY. -hCheckTTY :: MonadIO m => Handle -> OutputOptions -> m OutputOptions -hCheckTTY h options = liftIO $ conv <$> tty - where - conv :: Bool -> OutputOptions - conv True = options - conv False = options { outputOptionsColorOptions = Nothing } - - tty :: IO Bool - tty = hIsTerminalDevice h - --- | Given 'OutputOptions' and a list of 'Output', turn the 'Output' into a --- lazy 'Text'. -render :: OutputOptions -> [Output] -> Text -render options = toLazyText . foldr foldFunc "" . modificationsOutputList - where - foldFunc :: Output -> Builder -> Builder - foldFunc output accum = runReader (renderOutput output) options `mappend` accum - --- | Render a single 'Output' as a 'Builder', using the options specified in --- the 'OutputOptions'. -renderOutput :: MonadReader OutputOptions m => Output -> m Builder -renderOutput (Output nest OutputCloseBrace) = renderRainbowParenFor nest "}" -renderOutput (Output nest OutputCloseBracket) = renderRainbowParenFor nest "]" -renderOutput (Output nest OutputCloseParen) = renderRainbowParenFor nest ")" -renderOutput (Output nest OutputComma) = renderRainbowParenFor nest "," -renderOutput (Output _ OutputIndent) = do - indentSpaces <- reader outputOptionsIndentAmount - pure . mconcat $ replicate indentSpaces " " -renderOutput (Output _ OutputNewLine) = pure "\n" -renderOutput (Output nest OutputOpenBrace) = renderRainbowParenFor nest "{" -renderOutput (Output nest OutputOpenBracket) = renderRainbowParenFor nest "[" -renderOutput (Output nest OutputOpenParen) = renderRainbowParenFor nest "(" -renderOutput (Output _ (OutputOther string)) = do - indentSpaces <- reader outputOptionsIndentAmount - let spaces = replicate (indentSpaces + 2) ' ' - -- TODO: This probably shouldn't be a string to begin with. - pure $ fromString $ indentSubsequentLinesWith spaces string -renderOutput (Output _ (OutputNumberLit number)) = do - sequenceFold - [ useColorNum - , pure (fromString number) - , useColorReset - ] -renderOutput (Output _ (OutputStringLit string)) = do - options <- ask - - sequenceFold - [ useColorQuote - , pure "\"" - , useColorReset - , useColorString - -- TODO: This probably shouldn't be a string to begin with. - , pure (fromString (process options string)) - , useColorReset - , useColorQuote - , pure "\"" - , useColorReset - ] - where - process :: OutputOptions -> String -> String - process opts = case outputOptionsStringStyle opts of - Literal -> id - EscapeNonPrintable -> - indentSubsequentLinesWith spaces . escapeNonPrintable . readStr - DoNotEscapeNonPrintable -> indentSubsequentLinesWith spaces . readStr - where - spaces :: String - spaces = replicate (indentSpaces + 2) ' ' - - indentSpaces :: Int - indentSpaces = outputOptionsIndentAmount opts - - readStr :: String -> String - readStr s = fromMaybe s . readMaybe $ '"':s ++ "\"" -renderOutput (Output _ (OutputCharLit string)) = do - sequenceFold - [ useColorQuote - , pure "'" - , useColorReset - , useColorString - , pure (fromString string) - , useColorReset - , useColorQuote - , pure "'" - , useColorReset - ] - --- | Replace non-printable characters with hex escape sequences. --- --- >>> escapeNonPrintable "\x1\x2" --- "\\x1\\x2" --- --- Newlines will not be escaped. --- --- >>> escapeNonPrintable "hello\nworld" --- "hello\nworld" --- --- Printable characters will not be escaped. --- --- >>> escapeNonPrintable "h\101llo" --- "hello" -escapeNonPrintable :: String -> String -escapeNonPrintable input = foldr escape "" input - --- Replace an unprintable character except a newline --- with a hex escape sequence. -escape :: Char -> ShowS -escape c - | isPrint c || c == '\n' = (c:) - | otherwise = ('\\':) . ('x':) . showHex (ord c) - --- | --- >>> indentSubsequentLinesWith " " "aaa" --- "aaa" --- --- >>> indentSubsequentLinesWith " " "aaa\nbbb\nccc" --- "aaa\n bbb\n ccc" --- --- >>> indentSubsequentLinesWith " " "" --- "" -indentSubsequentLinesWith :: String -> String -> String -indentSubsequentLinesWith indent input = - intercalate "\n" $ (start ++) $ map (indent ++) $ end - where (start, end) = splitAt 1 $ lines input - --- | Produce a 'Builder' corresponding to the ANSI escape sequence for the --- color for the @\"@, based on whether or not 'outputOptionsColorOptions' is --- 'Just' or 'Nothing', and the value of 'colorQuote'. -useColorQuote :: forall m. MonadReader OutputOptions m => m Builder -useColorQuote = maybe "" colorQuote <$> reader outputOptionsColorOptions - --- | Produce a 'Builder' corresponding to the ANSI escape sequence for the --- color for the characters of a string, based on whether or not --- 'outputOptionsColorOptions' is 'Just' or 'Nothing', and the value of --- 'colorString'. -useColorString :: forall m. MonadReader OutputOptions m => m Builder -useColorString = maybe "" colorString <$> reader outputOptionsColorOptions - -useColorError :: forall m. MonadReader OutputOptions m => m Builder -useColorError = maybe "" colorError <$> reader outputOptionsColorOptions - -useColorNum :: forall m. MonadReader OutputOptions m => m Builder -useColorNum = maybe "" colorNum <$> reader outputOptionsColorOptions - --- | Produce a 'Builder' corresponding to the ANSI escape sequence for --- resetting the console color back to the default. Produces an empty 'Builder' --- if 'outputOptionsColorOptions' is 'Nothing'. -useColorReset :: forall m. MonadReader OutputOptions m => m Builder -useColorReset = maybe "" (const colorReset) <$> reader outputOptionsColorOptions - --- | Produce a 'Builder' representing the ANSI escape sequence for the color of --- the rainbow parenthesis, given an input 'NestLevel' and 'Builder' to use as --- the input character. --- --- If 'outputOptionsColorOptions' is 'Nothing', then just return the input --- character. If it is 'Just', then return the input character colorized. -renderRainbowParenFor - :: MonadReader OutputOptions m - => NestLevel -> Builder -> m Builder -renderRainbowParenFor nest string = - sequenceFold [useColorRainbowParens nest, pure string, useColorReset] - -useColorRainbowParens - :: forall m. - MonadReader OutputOptions m - => NestLevel -> m Builder -useColorRainbowParens nest = do - maybeOutputColor <- reader outputOptionsColorOptions - pure $ - case maybeOutputColor of - Just ColorOptions {colorRainbowParens} -> do - let choicesLen = length colorRainbowParens - if choicesLen == 0 - then "" - else colorRainbowParens !! (unNestLevel nest `mod` choicesLen) - Nothing -> "" - --- | This is simply @'fmap' 'fold' '.' 'sequence'@. -sequenceFold :: (Monad f, Monoid a, Traversable t) => t (f a) -> f a -sequenceFold = fmap fold . sequence - --- | A function that performs optimizations and modifications to a list of --- input 'Output's. --- --- An sample of an optimization is 'removeStartingNewLine' which just removes a --- newline if it is the first item in an 'Output' list. -modificationsOutputList :: [Output] -> [Output] -modificationsOutputList = - removeTrailingSpacesInOtherBeforeNewLine . shrinkWhitespaceInOthers . compressOthers . removeStartingNewLine - --- | Remove a 'OutputNewLine' if it is the first item in the 'Output' list. --- --- >>> removeStartingNewLine [Output 3 OutputNewLine, Output 3 OutputComma] --- [Output {outputNestLevel = NestLevel {unNestLevel = 3}, outputOutputType = OutputComma}] -removeStartingNewLine :: [Output] -> [Output] -removeStartingNewLine ((Output _ OutputNewLine) : t) = t -removeStartingNewLine outputs = outputs - --- | Remove trailing spaces from the end of a 'OutputOther' token if it is --- followed by a 'OutputNewLine', or if it is the final 'Output' in the list. --- This function assumes that there is a single 'OutputOther' before any --- 'OutputNewLine' (and before the end of the list), so it must be run after --- running 'compressOthers'. --- --- >>> removeTrailingSpacesInOtherBeforeNewLine [Output 2 (OutputOther "foo "), Output 4 OutputNewLine] --- [Output {outputNestLevel = NestLevel {unNestLevel = 2}, outputOutputType = OutputOther "foo"},Output {outputNestLevel = NestLevel {unNestLevel = 4}, outputOutputType = OutputNewLine}] -removeTrailingSpacesInOtherBeforeNewLine :: [Output] -> [Output] -removeTrailingSpacesInOtherBeforeNewLine [] = [] -removeTrailingSpacesInOtherBeforeNewLine (Output nest (OutputOther string):[]) = - (Output nest (OutputOther $ dropWhileEnd isSpace string)):[] -removeTrailingSpacesInOtherBeforeNewLine (Output nest (OutputOther string):nl@(Output _ OutputNewLine):t) = - (Output nest (OutputOther $ dropWhileEnd isSpace string)):nl:removeTrailingSpacesInOtherBeforeNewLine t -removeTrailingSpacesInOtherBeforeNewLine (h:t) = h : removeTrailingSpacesInOtherBeforeNewLine t - --- | If there are two subsequent 'OutputOther' tokens, combine them into just --- one 'OutputOther'. --- --- >>> compressOthers [Output 0 (OutputOther "foo"), Output 0 (OutputOther "bar")] --- [Output {outputNestLevel = NestLevel {unNestLevel = 0}, outputOutputType = OutputOther "foobar"}] -compressOthers :: [Output] -> [Output] -compressOthers [] = [] -compressOthers (Output _ (OutputOther string1):(Output nest (OutputOther string2)):t) = - compressOthers ((Output nest (OutputOther (string1 `mappend` string2))) : t) -compressOthers (h:t) = h : compressOthers t - --- | In each 'OutputOther' token, compress multiple whitespaces to just one --- whitespace. --- --- >>> shrinkWhitespaceInOthers [Output 0 (OutputOther " hello ")] --- [Output {outputNestLevel = NestLevel {unNestLevel = 0}, outputOutputType = OutputOther " hello "}] -shrinkWhitespaceInOthers :: [Output] -> [Output] -shrinkWhitespaceInOthers = fmap shrinkWhitespaceInOther - -shrinkWhitespaceInOther :: Output -> Output -shrinkWhitespaceInOther (Output nest (OutputOther string)) = - Output nest . OutputOther $ shrinkWhitespace string -shrinkWhitespaceInOther other = other - -shrinkWhitespace :: String -> String -shrinkWhitespace (' ':' ':t) = shrinkWhitespace (' ':t) -shrinkWhitespace (h:t) = h : shrinkWhitespace t -shrinkWhitespace "" = "" diff --git a/src/Text/Pretty/Simple/Internal/Printer.hs b/src/Text/Pretty/Simple/Internal/Printer.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pretty/Simple/Internal/Printer.hs @@ -0,0 +1,385 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{-| +Module : Text.Pretty.Simple.Internal.Printer +Copyright : (c) Dennis Gosnell, 2016 +License : BSD-style (see LICENSE file) +Maintainer : cdep.illabout@gmail.com +Stability : experimental +Portability : POSIX + +-} +module Text.Pretty.Simple.Internal.Printer + where + +-- We don't need these imports for later GHCs as all required functions +-- are exported from Prelude +#if __GLASGOW_HASKELL__ < 710 +import Control.Applicative +#endif +#if __GLASGOW_HASKELL__ < 804 +import Data.Monoid ((<>)) +#endif + +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad (join) +import Control.Monad.State (MonadState, evalState, modify, gets) +import Data.Char (isPrint, isSpace, ord) +import Data.List (dropWhileEnd) +import Data.List.NonEmpty (NonEmpty, nonEmpty) +import Data.Maybe (fromMaybe) +import Prettyprinter + (indent, line', PageWidth(AvailablePerLine), layoutPageWidth, nest, hsep, + concatWith, space, Doc, SimpleDocStream, annotate, defaultLayoutOptions, + enclose, hcat, layoutSmart, line, unAnnotateS, pretty, group) +import Data.Typeable (Typeable) +import GHC.Generics (Generic) +import Numeric (showHex) +import System.IO (Handle, hIsTerminalDevice) +import Text.Read (readMaybe) + +import Text.Pretty.Simple.Internal.Expr + (Expr(..), CommaSeparated(CommaSeparated)) +import Text.Pretty.Simple.Internal.ExprParser (expressionParse) +import Text.Pretty.Simple.Internal.Color + (colorNull, Style, ColorOptions(..), defaultColorOptionsDarkBg, + defaultColorOptionsLightBg) + +-- $setup +-- >>> import Text.Pretty.Simple (pPrintString, pPrintStringOpt) + +-- | Determines whether pretty-simple should check if the output 'Handle' is a +-- TTY device. Normally, users only want to print in color if the output +-- 'Handle' is a TTY device. +data CheckColorTty + = CheckColorTty + -- ^ Check if the output 'Handle' is a TTY device. If the output 'Handle' is + -- a TTY device, determine whether to print in color based on + -- 'outputOptionsColorOptions'. If not, then set 'outputOptionsColorOptions' + -- to 'Nothing' so the output does not get colorized. + | NoCheckColorTty + -- ^ Don't check if the output 'Handle' is a TTY device. Determine whether to + -- colorize the output based solely on the value of + -- 'outputOptionsColorOptions'. + deriving (Eq, Generic, Show, Typeable) + +-- | Control how escaped and non-printable are output for strings. +-- +-- See 'outputOptionsStringStyle' for what the output looks like with each of +-- these options. +data StringOutputStyle + = Literal + -- ^ Output string literals by printing the source characters exactly. + -- + -- For examples: without this option the printer will insert a newline in + -- place of @"\n"@, with this options the printer will output @'\'@ and + -- @'n'@. Similarly the exact escape codes used in the input string will be + -- replicated, so @"\65"@ will be printed as @"\65"@ and not @"A"@. + | EscapeNonPrintable + -- ^ Replace non-printable characters with hexadecimal escape sequences. + | DoNotEscapeNonPrintable + -- ^ Output non-printable characters without modification. + deriving (Eq, Generic, Show, Typeable) + +-- | Data-type wrapping up all the options available when rendering the list +-- of 'Output's. +data OutputOptions = OutputOptions + { outputOptionsIndentAmount :: Int + -- ^ Number of spaces to use when indenting. It should probably be either 2 + -- or 4. + , outputOptionsPageWidth :: Int + -- ^ The maximum number of characters to fit on to one line. + , outputOptionsCompact :: Bool + -- ^ Use less vertical (and more horizontal) space. + , outputOptionsCompactParens :: Bool + -- ^ Group closing parentheses on to a single line. + , outputOptionsInitialIndent :: Int + -- ^ Indent the whole output by this amount. + , outputOptionsColorOptions :: Maybe ColorOptions + -- ^ If this is 'Nothing', then don't colorize the output. If this is + -- @'Just' colorOptions@, then use @colorOptions@ to colorize the output. + -- + , outputOptionsStringStyle :: StringOutputStyle + -- ^ Controls how string literals are output. + -- + -- By default, the pPrint functions escape non-printable characters, but + -- print all printable characters: + -- + -- >>> pPrintString "\"A \\x42 Ä \\xC4 \\x1 \\n\"" + -- "A B Ä Ä \x1 + -- " + -- + -- Here, you can see that the character @A@ has been printed as-is. @\x42@ + -- has been printed in the non-escaped version, @B@. The non-printable + -- character @\x1@ has been printed as @\x1@. Newlines will be removed to + -- make the output easier to read. + -- + -- This corresponds to the 'StringOutputStyle' called 'EscapeNonPrintable'. + -- + -- (Note that in the above and following examples, the characters have to be + -- double-escaped, which makes it somewhat confusing...) + -- + -- Another output style is 'DoNotEscapeNonPrintable'. This is similar + -- to 'EscapeNonPrintable', except that non-printable characters get printed + -- out literally to the screen. + -- + -- >>> pPrintStringOpt CheckColorTty defaultOutputOptionsDarkBg{ outputOptionsStringStyle = DoNotEscapeNonPrintable } "\"A \\x42 Ä \\xC4 \\n\"" + -- "A B Ä Ä + -- " + -- + -- If you change the above example to contain @\x1@, you can see that it is + -- output as a literal, non-escaped character. Newlines are still removed + -- for readability. + -- + -- Another output style is 'Literal'. This just outputs all escape characters. + -- + -- >>> pPrintStringOpt CheckColorTty defaultOutputOptionsDarkBg{ outputOptionsStringStyle = Literal } "\"A \\x42 Ä \\xC4 \\x1 \\n\"" + -- "A \x42 Ä \xC4 \x1 \n" + -- + -- You can see that all the escape characters get output literally, including + -- newline. + } deriving (Eq, Generic, Show, Typeable) + +-- | Default values for 'OutputOptions' when printing to a console with a dark +-- background. 'outputOptionsIndentAmount' is 4, and +-- 'outputOptionsColorOptions' is 'defaultColorOptionsDarkBg'. +defaultOutputOptionsDarkBg :: OutputOptions +defaultOutputOptionsDarkBg = + defaultOutputOptionsNoColor + { outputOptionsColorOptions = Just defaultColorOptionsDarkBg } + +-- | Default values for 'OutputOptions' when printing to a console with a light +-- background. 'outputOptionsIndentAmount' is 4, and +-- 'outputOptionsColorOptions' is 'defaultColorOptionsLightBg'. +defaultOutputOptionsLightBg :: OutputOptions +defaultOutputOptionsLightBg = + defaultOutputOptionsNoColor + { outputOptionsColorOptions = Just defaultColorOptionsLightBg } + +-- | Default values for 'OutputOptions' when printing using using ANSI escape +-- sequences for color. 'outputOptionsIndentAmount' is 4, and +-- 'outputOptionsColorOptions' is 'Nothing'. +defaultOutputOptionsNoColor :: OutputOptions +defaultOutputOptionsNoColor = + OutputOptions + { outputOptionsIndentAmount = 4 + , outputOptionsPageWidth = 80 + , outputOptionsCompact = False + , outputOptionsCompactParens = False + , outputOptionsInitialIndent = 0 + , outputOptionsColorOptions = Nothing + , outputOptionsStringStyle = EscapeNonPrintable + } + +-- | Given 'OutputOptions', disable colorful output if the given handle +-- is not connected to a TTY. +hCheckTTY :: MonadIO m => Handle -> OutputOptions -> m OutputOptions +hCheckTTY h options = liftIO $ conv <$> tty + where + conv :: Bool -> OutputOptions + conv True = options + conv False = options { outputOptionsColorOptions = Nothing } + + tty :: IO Bool + tty = hIsTerminalDevice h + +-- | Parse a string, and generate an intermediate representation, +-- suitable for passing to any /prettyprinter/ backend. +-- Used by 'Simple.pString' etc. +layoutString :: OutputOptions -> String -> SimpleDocStream Style +layoutString opts = + annotateStyle opts + . layoutSmart defaultLayoutOptions + {layoutPageWidth = AvailablePerLine (outputOptionsPageWidth opts) 1} + . indent (outputOptionsInitialIndent opts) + . prettyExprs' opts + . preprocess opts + . expressionParse + +-- | Slight adjustment of 'prettyExprs' for the outermost level, +-- to avoid indenting everything. +prettyExprs' :: OutputOptions -> [Expr] -> Doc Annotation +prettyExprs' opts = \case + [] -> mempty + x : xs -> prettyExpr opts x <> prettyExprs opts xs + +-- | Construct a 'Doc' from multiple 'Expr's. +prettyExprs :: OutputOptions -> [Expr] -> Doc Annotation +prettyExprs opts = hcat . map subExpr + where + subExpr x = + let doc = prettyExpr opts x + in + if isSimple x then + -- keep the expression on the current line + nest 2 $ space <> doc + else + -- put the expression on a new line, indented (unless grouped) + nest (outputOptionsIndentAmount opts) $ line <> doc + +-- | Construct a 'Doc' from a single 'Expr'. +prettyExpr :: OutputOptions -> Expr -> Doc Annotation +prettyExpr opts = (if outputOptionsCompact opts then group else id) . \case + Brackets xss -> list "[" "]" xss + Braces xss -> list "{" "}" xss + Parens xss -> list "(" ")" xss + StringLit s -> join enclose (annotate Quote "\"") $ annotate String $ pretty s + CharLit s -> join enclose (annotate Quote "'") $ annotate String $ pretty s + Other s -> pretty s + NumberLit n -> annotate Num $ pretty n + where + list :: Doc Annotation -> Doc Annotation -> CommaSeparated [Expr] + -> Doc Annotation + list open close (CommaSeparated xss) = + enclose (annotate Open open) (annotate Close close) $ case xss of + [] -> mempty + [xs] | all isSimple xs -> + space <> hsep (map (prettyExpr opts) xs) <> space + _ -> concatWith lineAndCommaSep (map (prettyExprs opts) xss) + <> if outputOptionsCompactParens opts then space else line + lineAndCommaSep x y = x <> line' <> annotate Comma "," <> y + +-- | Determine whether this expression should be displayed on a single line. +isSimple :: Expr -> Bool +isSimple = \case + Brackets (CommaSeparated xs) -> isListSimple xs + Braces (CommaSeparated xs) -> isListSimple xs + Parens (CommaSeparated xs) -> isListSimple xs + _ -> True + where + isListSimple = \case + [[e]] -> isSimple e + _:_ -> False + [] -> True + +-- | Traverse the stream, using a 'Tape' to keep track of the current style. +annotateStyle :: OutputOptions -> SimpleDocStream Annotation + -> SimpleDocStream Style +annotateStyle opts ds = case outputOptionsColorOptions opts of + Nothing -> unAnnotateS ds + Just ColorOptions {..} -> evalState (traverse style ds) initialTape + where + style :: MonadState (Tape Style) m => Annotation -> m Style + style = \case + Open -> modify moveR *> gets tapeHead + Close -> gets tapeHead <* modify moveL + Comma -> gets tapeHead + Quote -> pure colorQuote + String -> pure colorString + Num -> pure colorNum + initialTape = Tape + { tapeLeft = streamRepeat colorError + , tapeHead = colorError + , tapeRight = streamCycle $ fromMaybe (pure colorNull) + $ nonEmpty colorRainbowParens + } + +-- | An abstract annotation type, representing the various elements +-- we may want to highlight. +data Annotation + = Open + | Close + | Comma + | Quote + | String + | Num + +-- | Apply various transformations to clean up the 'Expr's. +preprocess :: OutputOptions -> [Expr] -> [Expr] +preprocess opts = map processExpr . removeEmptyOthers + where + processExpr = \case + Brackets xss -> Brackets $ cs xss + Braces xss -> Braces $ cs xss + Parens xss -> Parens $ cs xss + StringLit s -> StringLit $ + case outputOptionsStringStyle opts of + Literal -> s + EscapeNonPrintable -> escapeNonPrintable $ readStr s + DoNotEscapeNonPrintable -> readStr s + CharLit s -> CharLit s + Other s -> Other $ shrinkWhitespace $ strip s + NumberLit n -> NumberLit n + cs (CommaSeparated ess) = CommaSeparated $ map (preprocess opts) ess + readStr :: String -> String + readStr s = fromMaybe s . readMaybe $ '"': s ++ "\"" + +-- | Remove any 'Other' 'Expr's which contain only spaces. +-- These provide no value, but mess up formatting if left in. +removeEmptyOthers :: [Expr] -> [Expr] +removeEmptyOthers = filter $ \case + Other s -> not $ all isSpace s + _ -> True + +-- | Replace non-printable characters with hex escape sequences. +-- +-- >>> escapeNonPrintable "\x1\x2" +-- "\\x1\\x2" +-- +-- Newlines will not be escaped. +-- +-- >>> escapeNonPrintable "hello\nworld" +-- "hello\nworld" +-- +-- Printable characters will not be escaped. +-- +-- >>> escapeNonPrintable "h\101llo" +-- "hello" +escapeNonPrintable :: String -> String +escapeNonPrintable input = foldr escape "" input + +-- | Replace an unprintable character except a newline +-- with a hex escape sequence. +escape :: Char -> ShowS +escape c + | isPrint c || c == '\n' = (c:) + | otherwise = ('\\':) . ('x':) . showHex (ord c) + +-- | Compress multiple whitespaces to just one whitespace. +-- +-- >>> shrinkWhitespace " hello there " +-- " hello there " +shrinkWhitespace :: String -> String +shrinkWhitespace (' ':' ':t) = shrinkWhitespace (' ':t) +shrinkWhitespace (h:t) = h : shrinkWhitespace t +shrinkWhitespace "" = "" + +-- | Remove trailing and leading whitespace (see 'Data.Text.strip'). +-- +-- >>> strip " hello there " +-- "hello there" +strip :: String -> String +strip = dropWhile isSpace . dropWhileEnd isSpace + +-- | A bidirectional Turing-machine tape: +-- infinite in both directions, with a head pointing to one element. +data Tape a = Tape + { tapeLeft :: Stream a -- ^ the side of the 'Tape' left of 'tapeHead' + , tapeHead :: a -- ^ the focused element + , tapeRight :: Stream a -- ^ the side of the 'Tape' right of 'tapeHead' + } deriving Show +-- | Move the head left +moveL :: Tape a -> Tape a +moveL (Tape (l :.. ls) c rs) = Tape ls l (c :.. rs) +-- | Move the head right +moveR :: Tape a -> Tape a +moveR (Tape ls c (r :.. rs)) = Tape (c :.. ls) r rs + +-- | An infinite list +data Stream a = a :.. Stream a deriving Show +-- | Analogous to 'repeat' +streamRepeat :: t -> Stream t +streamRepeat x = x :.. streamRepeat x +-- | Analogous to 'cycle' +-- While the inferred signature here is more general, +-- it would diverge on an empty structure +streamCycle :: NonEmpty a -> Stream a +streamCycle xs = foldr (:..) (streamCycle xs) xs