pretty-simple 2.2.0.1 → 4.1.4.0
raw patch · 16 files changed
Files
- CHANGELOG.md +135/−0
- README.md +41/−12
- Setup.hs +0/−2
- app/Main.hs +39/−15
- pretty-simple.cabal +8/−17
- src/Debug/Pretty/Simple.hs +317/−31
- src/Text/Pretty/Simple.hs +413/−54
- src/Text/Pretty/Simple/Internal.hs +1/−3
- src/Text/Pretty/Simple/Internal/Color.hs +78/−253
- src/Text/Pretty/Simple/Internal/Expr.hs +7/−1
- src/Text/Pretty/Simple/Internal/ExprParser.hs +122/−11
- src/Text/Pretty/Simple/Internal/ExprToOutput.hs +0/−286
- src/Text/Pretty/Simple/Internal/Output.hs +0/−95
- src/Text/Pretty/Simple/Internal/OutputPrinter.hs +0/−243
- src/Text/Pretty/Simple/Internal/Printer.hs +356/−0
- test/DocTest.hs +0/−40
CHANGELOG.md view
@@ -1,3 +1,138 @@+## 4.1.4.0++* Fix double-quoting issue with `pTraceShowWith`.+ [#132](https://github.com/cdepillabout/pretty-simple/pull/132)+ Thanks [@leoslf](https://github.com/leoslf)!++## 4.1.3.0++* Remove custom setup. This makes cross-compiling `pretty-simple` a lot more+ straightforward. No functionality has been lost from the library, since the+ custom setup was only used for generating tests.+ [#107](https://github.com/cdepillabout/pretty-simple/pull/107)++## 4.1.2.0++* Fix a problem with the `pHPrint` function incorrectly+ outputting a trailing newline to stdout, instead of the+ handle you pass it.+ [#118](https://github.com/cdepillabout/pretty-simple/pull/118)+* Add a [web app](https://cdepillabout.github.io/pretty-simple/) where you+ can play around with `pretty-simple` in your browser.+ [#116](https://github.com/cdepillabout/pretty-simple/pull/116).+ This took a lot of hard work by [@georgefst](https://github.com/georgefst)!++## 4.1.1.0++* Make the pretty-printed output with `outputOptionsCompact` enabled a little+ more compact.+ [#110](https://github.com/cdepillabout/pretty-simple/pull/110).+ Thanks [@juhp](https://github.com/juhp)!+* Add a `--compact` / `-C` flag to the `pretty-simple` executable that enables+ `outputOptionsCompact`.+ [#111](https://github.com/cdepillabout/pretty-simple/pull/111).+ Thanks again @juhp!+* Add `pTraceWith` and `pTraceShowWith` to `Debug.Pretty.Simple`.+ [#104](https://github.com/cdepillabout/pretty-simple/pull/104).+ Thanks [@LeviButcher](https://github.com/LeviButcher)!++## 4.1.0.0++* Fix a regression which arose in 4.0, whereby excess spaces would be inserted for unusual strings like dates and IP addresses.+ [#105](https://github.com/cdepillabout/pretty-simple/pull/105)+* Attach warnings to debugging functions, so that they're easy to find and remove.+ [#103](https://github.com/cdepillabout/pretty-simple/pull/103)+* Some minor improvements to the CLI tool:+ * Add a `--version`/`-v` flag.+ [#83](https://github.com/cdepillabout/pretty-simple/pull/83)+ * Add a trailing newline.+ [#87](https://github.com/cdepillabout/pretty-simple/pull/87)+ * Install by default, without requiring a flag.+ [#94](https://github.com/cdepillabout/pretty-simple/pull/94)++## 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+ literally when outputting strings.+ [#68](https://github.com/cdepillabout/pretty-simple/pull/68) and+ [#69](https://github.com/cdepillabout/pretty-simple/pull/69)+ Thanks Joe Hermaszewski ([@expipiplus1](https://github.com/expipiplus1))!++## 3.2.3.0++* Fix a bug that messes up printing identifiers with `'` in the name.+ Now identifiers like `data Don't = Don't` show up properly.+ [#65](https://github.com/cdepillabout/pretty-simple/pull/65)+ Thanks George Thomas ([@georgefst](https://github.com/georgefst))!++## 3.2.2.0++* Remove whitespace from the ends of lines.+ [#62](https://github.com/cdepillabout/pretty-simple/pull/62)+ Thanks Gaith Hallak ([@ghallak](https://github.com/ghallak))!++## 3.2.1.0++* Added `pTraceOpt` functions to `Debug.Pretty.Simple`.+ [#58](https://github.com/cdepillabout/pretty-simple/pull/58)+ Thanks again [sureyeaah](https://github.com/sureyeaah)!++## 3.2.0.0++* Add support for pretty-printing Haskell character literals.+ [#57](https://github.com/cdepillabout/pretty-simple/pull/57)+ Thanks again [sjakobi](https://github.com/sjakobi)!++## 3.1.1.0++* Added a `pPrintString` function for pretty-printing a `String` that is the+ output of `show`. Implemented in+ [#54](https://github.com/cdepillabout/pretty-simple/pull/54). Thanks+ [sureyeaah](https://github.com/sureyeaah)!+* Fix build on GHC-7.10.3.+ [#55](https://github.com/cdepillabout/pretty-simple/pull/55). Thanks+ [sjakobi](https://github.com/sjakobi).++## 3.1.0.0++* Numbers are now highlighted in green by default. Implemented in+ [#51](https://github.com/cdepillabout/pretty-simple/pull/51).+ Thanks [lawrencebell](https://github.com/lawrencebell)!++## 3.0.0.0++* pretty-simple now escapes non-printable characters by default. A field+ called `outputOptionsEscapeNonPrintable` has been added to `OutputOptions`+ to control this behavior. Implemented in+ [#44](https://github.com/cdepillabout/pretty-simple/pull/44). Thanks+ [dminuoso](https://github.com/dminuoso)!+* pretty-simple now checks the output `Handle` to determine whether to print+ in color when using functions like `pPrint`. This makes it so that you+ can redirect output to a file on disk and still be able to read the+ output from `pPrint`! Implemented in+ [#47](https://github.com/cdepillabout/pretty-simple/pull/47). Thanks+ [metiulekm](https://github.com/metiulekm)!+* Add functions like `pHPrint` for specifying the `Handle` to output to.+ Added in [#47](https://github.com/cdepillabout/pretty-simple/pull/47).+ ## 2.2.0.1 * Fixed a [bug](https://github.com/cdepillabout/pretty-simple/pull/41) where the parser failed to parse escaped quotation marks in string literals.
README.md view
@@ -2,7 +2,7 @@ Text.Pretty.Simple ================== -[](http://travis-ci.org/cdepillabout/pretty-simple)+[](https://github.com/cdepillabout/pretty-simple/actions) [](https://hackage.haskell.org/package/pretty-simple) [](http://stackage.org/lts/package/pretty-simple) [](http://stackage.org/nightly/package/pretty-simple)@@ -37,19 +37,25 @@ `pretty-simple` can be used to print `bar` in an easy-to-read format: -+ ## Usage `pretty-simple` can be easily used from `ghci` when debugging. -When using `stack` to run `ghci`, just append append the `--package` flag to-the command line to load `pretty-simple`.+When using `stack` to run `ghci`, just append the `--package` flag to+the command line to load `pretty-simple`: ```sh $ stack ghci --package pretty-simple ``` +Or, with cabal:++```sh+$ cabal repl --build-depends pretty-simple+```+ Once you get a prompt in `ghci`, you can use `import` to get `pretty-simple`'s [`pPrint`](https://hackage.haskell.org/package/pretty-simple/docs/Text-Pretty-Simple.html#v:pPrint) function in scope.@@ -68,6 +74,14 @@ ) ``` +If for whatever reason you're not able to incur a dependency on the `pretty-simple` library, you can simulate its behaviour by using `process` to call out to the command line executable (see below for installation):+```hs+pPrint :: Show a => a -> IO ()+pPrint = putStrLn <=< readProcess "pretty-simple" [] . show+```++There's also a [web app](https://cdepillabout.github.io/pretty-simple), compiled with GHCJS, where you can play around with `pretty-simple` in your browser.+ ## Features - Easy-to-read@@ -79,8 +93,8 @@ function. - Rainbow Parentheses - Easy to understand deeply nested data types.-- Configurable Indentation- - Amount of indentation is configurable with the+- Configurable+ - Indentation, compactness, colors and more are configurable with the [`pPrintOpt`](https://hackage.haskell.org/package/pretty-simple-1.0.0.6/docs/Text-Pretty-Simple.html#v:pPrintOpt) function. - Fast@@ -106,11 +120,14 @@ The `pPrint` function can be used as the default output function in GHCi. -All you need to do is run GHCi like this:+All you need to do is run GHCi with a command like one of these: ```sh $ stack ghci --ghci-options "-interactive-print=Text.Pretty.Simple.pPrint" --package pretty-simple ```+```sh+$ cabal repl --repl-options "-interactive-print=Text.Pretty.Simple.pPrint" --build-depends pretty-simple+``` Now, whenever you make GHCi evaluate an expression, GHCi will pretty-print the result using `pPrint`! See@@ -166,7 +183,7 @@ `pretty-simple` can be used to pretty-print the JSON-encoded `bar` in an easy-to-read format: -+ (You can find the `lazyByteStringToString`, `putLazyByteStringLn`, and `putLazyTextLn` in the [`ExampleJSON.hs`](example/ExampleJSON.hs)@@ -177,17 +194,16 @@ `pretty-simple` includes a command line executable that can be used to pretty-print anything passed in on stdin. -It can be installed to `~/.local/bin/` with the following command. Note that you-must enable the `buildexe` flag, since it will not be built by default:+It can be installed to `~/.local/bin/` with the following command. ```sh-$ stack install pretty-simple-2.2.0.1 --flag pretty-simple:buildexe+$ stack install pretty-simple ``` When run on the command line, you can paste in the Haskell datatype you want to be formatted, then hit <kbd>Ctrl</kbd>-<kbd>D</kbd>: -+ This is very useful if you accidentally print out a Haskell data type with `print` instead of `pPrint`.@@ -198,3 +214,16 @@ [issue](https://github.com/cdepillabout/pretty-simple/issues) or [PR](https://github.com/cdepillabout/pretty-simple/pulls) for any bugs/problems/suggestions/improvements.++### Testing++To run the test suite locally, one must install the executables `doctest` and+`cabal-doctest`, e.g. with+`cabal install --ignore-project doctest --flag cabal-doctest`.++Then run the command `cabal doctest`.++## Maintainers++- [@cdepillabout](https://github.com/cdepillabout)+- [@georgefst](https://github.com/georgefst)
− Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
app/Main.hs view
@@ -23,25 +23,32 @@ -- ] -- @ +import Data.Monoid ((<>)) import Data.Text (unpack) import qualified Data.Text.IO as T import qualified Data.Text.Lazy.IO as LT-import Options.Applicative - ( Parser, ReadM, execParser, fullDesc, help, helper, info, long- , option, progDesc, readerError, short, showDefaultWith, str, value, (<**>))-import Data.Monoid ((<>))-import Text.Pretty.Simple +import Data.Version (showVersion)+import Options.Applicative+ ( Parser, ReadM, execParser, fullDesc, help, helper, info, infoOption+ , long, option, progDesc, readerError, short, showDefaultWith, str+ , switch, value)+import Paths_pretty_simple (version)+import Text.Pretty.Simple ( pStringOpt, OutputOptions , defaultOutputOptionsDarkBg , defaultOutputOptionsLightBg , defaultOutputOptionsNoColor+ , outputOptionsCompact ) data Color = DarkBg | LightBg | NoColor -newtype Args = Args { color :: Color }+data Args = Args+ { color :: Color+ , compact :: Bool+ } colorReader :: ReadM Color colorReader = do@@ -58,24 +65,41 @@ ( long "color" <> short 'c' <> help "Select printing color. Available options: dark-bg (default), light-bg, no-color."- <> showDefaultWith (\_ -> "dark-bg")+ <> showDefaultWith (const "dark-bg") <> value DarkBg )+ <*> switch+ ( long "compact"+ <> short 'C'+ <> help "Compact output"+ ) +versionOption :: Parser (a -> a)+versionOption =+ infoOption+ (showVersion version)+ ( long "version"+ <> short 'V'+ <> help "Show version"+ )+ main :: IO () main = do args' <- execParser opts input <- T.getContents- let printOpt = getPrintOpt $ color args'- output = pStringOpt printOpt $ unpack input- LT.putStr output+ let output = pStringOpt (getPrintOpt args') $ unpack input+ LT.putStrLn output where- opts = info (args <**> helper)+ opts = info (helper <*> versionOption <*> args) ( fullDesc <> progDesc "Format Haskell data types with indentation and highlighting" ) - getPrintOpt :: Color -> OutputOptions- getPrintOpt DarkBg = defaultOutputOptionsDarkBg- getPrintOpt LightBg = defaultOutputOptionsLightBg- getPrintOpt NoColor = defaultOutputOptionsNoColor+ getPrintOpt :: Args -> OutputOptions+ getPrintOpt as =+ (getColorOpt (color as)) {outputOptionsCompact = compact as}++ getColorOpt :: Color -> OutputOptions+ getColorOpt DarkBg = defaultOutputOptionsDarkBg+ getColorOpt LightBg = defaultOutputOptionsLightBg+ getColorOpt NoColor = defaultOutputOptionsNoColor
pretty-simple.cabal view
@@ -1,5 +1,5 @@ name: pretty-simple-version: 2.2.0.1+version: 4.1.4.0 synopsis: pretty printer for data types with a 'Show' instance. description: Please see <https://github.com/cdepillabout/pretty-simple#readme README.md>. homepage: https://github.com/cdepillabout/pretty-simple@@ -7,7 +7,7 @@ license-file: LICENSE author: Dennis Gosnell maintainer: cdep.illabout@gmail.com-copyright: 2017 Dennis Gosnell+copyright: 2017-2019 Dennis Gosnell category: Text build-type: Simple extra-source-files: CHANGELOG.md@@ -17,7 +17,7 @@ flag buildexe description: Build an small command line program that pretty-print anything from stdin.- default: False+ default: True flag buildexample description: Build a small example program showing how to use the pPrint function@@ -31,12 +31,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@@ -45,6 +45,7 @@ executable pretty-simple main-is: Main.hs+ other-modules: Paths_pretty_simple hs-source-dirs: app build-depends: base , pretty-simple@@ -89,16 +90,6 @@ buildable: True else buildable: False--test-suite pretty-simple-doctest- type: exitcode-stdio-1.0- main-is: DocTest.hs- hs-source-dirs: test- build-depends: base- , doctest- , Glob- default-language: Haskell2010- ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N benchmark pretty-simple-bench type: exitcode-stdio-1.0
src/Debug/Pretty/Simple.hs view
@@ -16,6 +16,8 @@ module Debug.Pretty.Simple ( -- * Trace with color on dark background+ -- This determines whether to print in color by looking at whether 'stderr'+ -- is a TTY device. pTrace , pTraceId , pTraceShow@@ -28,6 +30,21 @@ , pTraceEventIO , pTraceMarker , pTraceMarkerIO+ , pTraceWith+ , pTraceShowWith+ -- * Trace forcing color+ , pTraceForceColor+ , pTraceIdForceColor+ , pTraceShowForceColor+ , pTraceShowIdForceColor+ , pTraceMForceColor+ , pTraceShowMForceColor+ , pTraceStackForceColor+ , pTraceEventForceColor+ , pTraceEventIOForceColor+ , pTraceMarkerForceColor+ , pTraceMarkerIOForceColor+ , pTraceIOForceColor -- * Trace without color , pTraceNoColor , pTraceIdNoColor@@ -41,13 +58,32 @@ , pTraceMarkerNoColor , pTraceMarkerIONoColor , pTraceIONoColor+ -- * Trace With 'OutputOptions'+ , pTraceOpt+ , pTraceIdOpt+ , pTraceShowOpt+ , pTraceShowIdOpt+ , pTraceOptIO+ , pTraceOptM+ , pTraceShowOptM+ , pTraceStackOpt+ , pTraceEventOpt+ , pTraceEventOptIO+ , pTraceMarkerOpt+ , pTraceMarkerOptIO ) where -import Data.Text.Lazy (unpack)+import Control.Monad ((<=<))+import Data.Text.Lazy (Text, unpack) import Debug.Trace (trace, traceEvent, traceEventIO, traceIO, traceM, traceMarker, traceMarkerIO, traceStack)-import Text.Pretty.Simple (pShow, pShowNoColor, pString, pStringNoColor)+import System.IO (stderr)+import System.IO.Unsafe (unsafePerformIO)+import Text.Pretty.Simple+ (CheckColorTty(..), OutputOptions, pStringOpt,+ defaultOutputOptionsNoColor, defaultOutputOptionsDarkBg)+import Text.Pretty.Simple.Internal (hCheckTTY) #if __GLASGOW_HASKELL__ < 710 -- We don't need this import for GHC 7.10 as it exports all required functions@@ -61,8 +97,9 @@ @since 2.0.1.0 -}+{-# WARNING pTraceIO "'pTraceIO' remains in code" #-} pTraceIO :: String -> IO ()-pTraceIO = traceIO . unpack . pString+pTraceIO = pTraceOptIO CheckColorTty defaultOutputOptionsDarkBg {-| The 'pTrace' function pretty prints the trace message given as its first@@ -79,16 +116,18 @@ @since 2.0.1.0 -}+{-# WARNING pTrace "'pTrace' remains in code" #-} pTrace :: String -> a -> a-pTrace = trace . unpack . pString+pTrace = pTraceOpt CheckColorTty defaultOutputOptionsDarkBg {-| Like 'pTrace' but returns the message instead of a third value. @since 2.0.1.0 -}+{-# WARNING pTraceId "'pTraceId' remains in code" #-} pTraceId :: String -> String-pTraceId a = pTrace a a+pTraceId = pTraceIdOpt CheckColorTty defaultOutputOptionsDarkBg {-| Like 'pTrace', but uses 'show' on the argument to convert it to a 'String'.@@ -105,17 +144,18 @@ @since 2.0.1.0 -}+{-# WARNING pTraceShow "'pTraceShow' remains in code" #-} pTraceShow :: (Show a) => a -> b -> b-pTraceShow = trace . unpack . pShow+pTraceShow = pTraceShowOpt CheckColorTty defaultOutputOptionsDarkBg {-| Like 'pTraceShow' but returns the shown value instead of a third value. @since 2.0.1.0 -}+{-# WARNING pTraceShowId "'pTraceShowId' remains in code" #-} pTraceShowId :: (Show a) => a -> a-pTraceShowId a = trace (unpack (pShow a)) a-+pTraceShowId = pTraceShowIdOpt CheckColorTty defaultOutputOptionsDarkBg {-| Like 'pTrace' but returning unit in an arbitrary 'Applicative' context. Allows for convenient use in do-notation.@@ -135,13 +175,13 @@ @since 2.0.1.0 -}+{-# WARNING pTraceM "'pTraceM' remains in code" #-} #if __GLASGOW_HASKELL__ < 800 pTraceM :: (Monad f) => String -> f () #else pTraceM :: (Applicative f) => String -> f () #endif-pTraceM string = trace (unpack (pString string)) $ pure ()-+pTraceM = pTraceOptM CheckColorTty defaultOutputOptionsDarkBg {-| Like 'pTraceM', but uses 'show' on the argument to convert it to a 'String'. @@ -153,12 +193,13 @@ @since 2.0.1.0 -}+{-# WARNING pTraceShowM "'pTraceShowM' remains in code" #-} #if __GLASGOW_HASKELL__ < 800 pTraceShowM :: (Show a, Monad f) => a -> f () #else pTraceShowM :: (Show a, Applicative f) => a -> f () #endif-pTraceShowM = traceM . unpack . pShow+pTraceShowM = pTraceShowOptM CheckColorTty defaultOutputOptionsDarkBg {-| like 'pTrace', but additionally prints a call stack if one is@@ -172,8 +213,9 @@ @since 2.0.1.0 -}+{-# WARNING pTraceStack "'pTraceStack' remains in code" #-} pTraceStack :: String -> a -> a-pTraceStack = traceStack . unpack . pString+pTraceStack = pTraceStackOpt CheckColorTty defaultOutputOptionsDarkBg {-| The 'pTraceEvent' function behaves like 'trace' with the difference that@@ -189,8 +231,9 @@ @since 2.0.1.0 -}+{-# WARNING pTraceEvent "'pTraceEvent' remains in code" #-} pTraceEvent :: String -> a -> a-pTraceEvent = traceEvent . unpack . pString+pTraceEvent = pTraceEventOpt CheckColorTty defaultOutputOptionsDarkBg {-| The 'pTraceEventIO' function emits a message to the eventlog, if eventlog@@ -201,8 +244,9 @@ @since 2.0.1.0 -}+{-# WARNING pTraceEventIO "'pTraceEventIO' remains in code" #-} pTraceEventIO :: String -> IO ()-pTraceEventIO = traceEventIO . unpack . pString+pTraceEventIO = pTraceEventOptIO CheckColorTty defaultOutputOptionsDarkBg -- | The 'pTraceMarker' function emits a marker to the eventlog, if eventlog -- profiling is available and enabled at runtime. The @String@ is the name of@@ -217,8 +261,9 @@ -- that uses 'pTraceMarker'. -- -- @since 2.0.1.0+{-# WARNING pTraceMarker "'pTraceMarker' remains in code" #-} pTraceMarker :: String -> a -> a-pTraceMarker = traceMarker . unpack . pString+pTraceMarker = pTraceMarkerOpt CheckColorTty defaultOutputOptionsDarkBg -- | The 'pTraceMarkerIO' function emits a marker to the eventlog, if eventlog -- profiling is available and enabled at runtime.@@ -227,13 +272,132 @@ -- to other IO actions. -- -- @since 2.0.1.0+{-# WARNING pTraceMarkerIO "'pTraceMarkerIO' remains in code" #-} pTraceMarkerIO :: String -> IO ()-pTraceMarkerIO = traceMarkerIO . unpack . pString+pTraceMarkerIO = pTraceMarkerOptIO CheckColorTty defaultOutputOptionsDarkBg +-- | The 'pTraceWith' function pretty prints the result of+-- applying @f to @a and returns back @a+--+-- @since ?+{-# WARNING pTraceWith "'pTraceWith' remains in code" #-}+pTraceWith :: (a -> String) -> a -> a+pTraceWith f a = pTrace (f a) a++-- | The 'pTraceShowWith' function similar to 'pTraceWith' except that+-- @f can return any type that implements Show+--+-- @since ?+{-# WARNING pTraceShowWith "'pTraceShowWith' remains in code" #-}+pTraceShowWith :: Show b => (a -> b) -> a -> a+pTraceShowWith f = pTraceWith (show . f)+ --------------------------------------------- Traces without color+-- Helpers ------------------------------------------+{-# WARNING pStringTTYOptIO "'pStringTTYOptIO' remains in code" #-}+pStringTTYOptIO :: CheckColorTty -> OutputOptions -> String -> IO Text+pStringTTYOptIO checkColorTty outputOptions v = do+ realOutputOpts <-+ case checkColorTty of+ CheckColorTty -> hCheckTTY stderr outputOptions+ NoCheckColorTty -> pure outputOptions+ pure $ pStringOpt realOutputOpts v +{-# WARNING pStringTTYOpt "'pStringTTYOpt' remains in code" #-}+pStringTTYOpt :: CheckColorTty -> OutputOptions -> String -> Text+pStringTTYOpt checkColorTty outputOptions =+ unsafePerformIO . pStringTTYOptIO checkColorTty outputOptions++{-# WARNING pShowTTYOptIO "'pShowTTYOptIO' remains in code" #-}+pShowTTYOptIO :: Show a => CheckColorTty -> OutputOptions -> a -> IO Text+pShowTTYOptIO checkColorTty outputOptions =+ pStringTTYOptIO checkColorTty outputOptions . show++{-# WARNING pShowTTYOpt "'pShowTTYOpt' remains in code" #-}+pShowTTYOpt :: Show a => CheckColorTty -> OutputOptions -> a -> Text+pShowTTYOpt checkColorTty outputOptions =+ unsafePerformIO . pShowTTYOptIO checkColorTty outputOptions++------------------------------------------+-- Traces forcing color+------------------------------------------+-- | Similar to 'pTrace', but forcing color.+{-# WARNING pTraceForceColor "'pTraceForceColor' remains in code" #-}+pTraceForceColor :: String -> a -> a+pTraceForceColor = pTraceOpt NoCheckColorTty defaultOutputOptionsDarkBg++-- | Similar to 'pTraceId', but forcing color.+{-# WARNING pTraceIdForceColor "'pTraceIdForceColor' remains in code" #-}+pTraceIdForceColor :: String -> String+pTraceIdForceColor = pTraceIdOpt NoCheckColorTty defaultOutputOptionsDarkBg++-- | Similar to 'pTraceShow', but forcing color.+{-# WARNING pTraceShowForceColor "'pTraceShowForceColor' remains in code" #-}+pTraceShowForceColor :: (Show a) => a -> b -> b+pTraceShowForceColor = pTraceShowOpt NoCheckColorTty defaultOutputOptionsDarkBg++-- | Similar to 'pTraceShowId', but forcing color.+{-# WARNING pTraceShowIdForceColor "'pTraceShowIdForceColor' remains in code" #-}+pTraceShowIdForceColor :: (Show a) => a -> a+pTraceShowIdForceColor =+ pTraceShowIdOpt NoCheckColorTty defaultOutputOptionsDarkBg+-- | Similar to 'pTraceM', but forcing color.+{-# WARNING pTraceMForceColor "'pTraceMForceColor' remains in code" #-}+#if __GLASGOW_HASKELL__ < 800+pTraceMForceColor :: (Monad f) => String -> f ()+#else+pTraceMForceColor :: (Applicative f) => String -> f ()+#endif+pTraceMForceColor = pTraceOptM NoCheckColorTty defaultOutputOptionsDarkBg+-- | Similar to 'pTraceShowM', but forcing color.+{-# WARNING pTraceShowMForceColor "'pTraceShowMForceColor' remains in code" #-}+#if __GLASGOW_HASKELL__ < 800+pTraceShowMForceColor :: (Show a, Monad f) => a -> f ()+#else+pTraceShowMForceColor :: (Show a, Applicative f) => a -> f ()+#endif+pTraceShowMForceColor =+ pTraceShowOptM NoCheckColorTty defaultOutputOptionsDarkBg++-- | Similar to 'pTraceStack', but forcing color.+{-# WARNING pTraceStackForceColor "'pTraceStackForceColor' remains in code" #-}+pTraceStackForceColor :: String -> a -> a+pTraceStackForceColor =+ pTraceStackOpt NoCheckColorTty defaultOutputOptionsDarkBg++-- | Similar to 'pTraceEvent', but forcing color.+{-# WARNING pTraceEventForceColor "'pTraceEventForceColor' remains in code" #-}+pTraceEventForceColor :: String -> a -> a+pTraceEventForceColor =+ pTraceEventOpt NoCheckColorTty defaultOutputOptionsDarkBg++-- | Similar to 'pTraceEventIO', but forcing color.+{-# WARNING pTraceEventIOForceColor "'pTraceEventIOForceColor' remains in code" #-}+pTraceEventIOForceColor :: String -> IO ()+pTraceEventIOForceColor =+ pTraceEventOptIO NoCheckColorTty defaultOutputOptionsDarkBg++-- | Similar to 'pTraceMarker', but forcing color.+{-# WARNING pTraceMarkerForceColor "'pTraceMarkerForceColor' remains in code" #-}+pTraceMarkerForceColor :: String -> a -> a+pTraceMarkerForceColor =+ pTraceMarkerOpt NoCheckColorTty defaultOutputOptionsDarkBg++-- | Similar to 'pTraceMarkerIO', but forcing color.+{-# WARNING pTraceMarkerIOForceColor "'pTraceMarkerIOForceColor' remains in code" #-}+pTraceMarkerIOForceColor :: String -> IO ()+pTraceMarkerIOForceColor =+ pTraceMarkerOptIO NoCheckColorTty defaultOutputOptionsDarkBg++-- | Similar to 'pTraceIO', but forcing color.+{-# WARNING pTraceIOForceColor "'pTraceIOForceColor' remains in code" #-}+pTraceIOForceColor :: String -> IO ()+pTraceIOForceColor = pTraceOptIO NoCheckColorTty defaultOutputOptionsDarkBg++------------------------------------------+-- Traces without color+------------------------------------------ -- | Similar to 'pTrace', but without color. -- -- >>> pTraceNoColor "wow" ()@@ -241,8 +405,9 @@ -- () -- -- @since 2.0.2.0+{-# WARNING pTraceNoColor "'pTraceNoColor' remains in code" #-} pTraceNoColor :: String -> a -> a-pTraceNoColor = trace . unpack . pStringNoColor+pTraceNoColor = pTraceOpt NoCheckColorTty defaultOutputOptionsNoColor -- | Similar to 'pTraceId', but without color. --@@ -254,8 +419,9 @@ -- () -- -- @since 2.0.2.0+{-# WARNING pTraceIdNoColor "'pTraceIdNoColor' remains in code" #-} pTraceIdNoColor :: String -> String-pTraceIdNoColor a = pTraceNoColor a a+pTraceIdNoColor = pTraceIdOpt NoCheckColorTty defaultOutputOptionsNoColor -- | Similar to 'pTraceShow', but without color. --@@ -270,8 +436,9 @@ -- () -- -- @since 2.0.2.0+{-# WARNING pTraceShowNoColor "'pTraceShowNoColor' remains in code" #-} pTraceShowNoColor :: (Show a) => a -> b -> b-pTraceShowNoColor = trace . unpack . pShowNoColor+pTraceShowNoColor = pTraceShowOpt NoCheckColorTty defaultOutputOptionsNoColor -- | Similar to 'pTraceShowId', but without color. --@@ -286,22 +453,23 @@ -- () -- -- @since 2.0.2.0+{-# WARNING pTraceShowIdNoColor "'pTraceShowIdNoColor' remains in code" #-} pTraceShowIdNoColor :: (Show a) => a -> a-pTraceShowIdNoColor a = trace (unpack (pShowNoColor a)) a-+pTraceShowIdNoColor =+ pTraceShowIdOpt NoCheckColorTty defaultOutputOptionsNoColor -- | Similar to 'pTraceM', but without color. -- -- >>> pTraceMNoColor "wow" -- wow -- -- @since 2.0.2.0+{-# WARNING pTraceMNoColor "'pTraceMNoColor' remains in code" #-} #if __GLASGOW_HASKELL__ < 800 pTraceMNoColor :: (Monad f) => String -> f () #else pTraceMNoColor :: (Applicative f) => String -> f () #endif-pTraceMNoColor string = trace (unpack (pString string)) $ pure ()-+pTraceMNoColor = pTraceOptM NoCheckColorTty defaultOutputOptionsNoColor -- | Similar to 'pTraceShowM', but without color. -- -- >>> pTraceShowMNoColor [1,2,3]@@ -311,12 +479,13 @@ -- ] -- -- @since 2.0.2.0+{-# WARNING pTraceShowMNoColor "'pTraceShowMNoColor' remains in code" #-} #if __GLASGOW_HASKELL__ < 800 pTraceShowMNoColor :: (Show a, Monad f) => a -> f () #else pTraceShowMNoColor :: (Show a, Applicative f) => a -> f () #endif-pTraceShowMNoColor = traceM . unpack . pShowNoColor+pTraceShowMNoColor = pTraceShowOptM NoCheckColorTty defaultOutputOptionsNoColor -- | Similar to 'pTraceStack', but without color. --@@ -325,32 +494,40 @@ -- () -- -- @since 2.0.2.0+{-# WARNING pTraceStackNoColor "'pTraceStackNoColor' remains in code" #-} pTraceStackNoColor :: String -> a -> a-pTraceStackNoColor = traceStack . unpack . pStringNoColor+pTraceStackNoColor = pTraceStackOpt NoCheckColorTty defaultOutputOptionsNoColor -- | Similar to 'pTraceEvent', but without color. -- -- @since 2.0.2.0+{-# WARNING pTraceEventNoColor "'pTraceEventNoColor' remains in code" #-} pTraceEventNoColor :: String -> a -> a-pTraceEventNoColor = traceEvent . unpack . pStringNoColor+pTraceEventNoColor = pTraceEventOpt NoCheckColorTty defaultOutputOptionsNoColor -- | Similar to 'pTraceEventIO', but without color. -- -- @since 2.0.2.0+{-# WARNING pTraceEventIONoColor "'pTraceEventIONoColor' remains in code" #-} pTraceEventIONoColor :: String -> IO ()-pTraceEventIONoColor = traceEventIO . unpack . pStringNoColor+pTraceEventIONoColor =+ pTraceEventOptIO NoCheckColorTty defaultOutputOptionsNoColor -- | Similar to 'pTraceMarker', but without color. -- -- @since 2.0.2.0+{-# WARNING pTraceMarkerNoColor "'pTraceMarkerNoColor' remains in code" #-} pTraceMarkerNoColor :: String -> a -> a-pTraceMarkerNoColor = traceMarker . unpack . pStringNoColor+pTraceMarkerNoColor =+ pTraceMarkerOpt NoCheckColorTty defaultOutputOptionsNoColor -- | Similar to 'pTraceMarkerIO', but without color. -- -- @since 2.0.2.0+{-# WARNING pTraceMarkerIONoColor "'pTraceMarkerIONoColor' remains in code" #-} pTraceMarkerIONoColor :: String -> IO ()-pTraceMarkerIONoColor = traceMarkerIO . unpack . pStringNoColor+pTraceMarkerIONoColor =+ pTraceMarkerOptIO NoCheckColorTty defaultOutputOptionsNoColor -- | Similar to 'pTraceIO', but without color. --@@ -361,5 +538,114 @@ -- ) -- -- @since 2.0.2.0+{-# WARNING pTraceIONoColor "'pTraceIONoColor' remains in code" #-} pTraceIONoColor :: String -> IO ()-pTraceIONoColor = traceIO . unpack . pStringNoColor+pTraceIONoColor = pTraceOptIO NoCheckColorTty defaultOutputOptionsNoColor++------------------------------------------+-- Traces that take options+------------------------------------------+{-|+Like 'pTrace' but takes OutputOptions.+-}+{-# WARNING pTraceOpt "'pTraceOpt' remains in code" #-}+pTraceOpt :: CheckColorTty -> OutputOptions -> String -> a -> a+pTraceOpt checkColorTty outputOptions =+ trace . unpack . pStringTTYOpt checkColorTty outputOptions++{-|+Like 'pTraceId' but takes OutputOptions.+-}+{-# WARNING pTraceIdOpt "'pTraceIdOpt' remains in code" #-}+pTraceIdOpt :: CheckColorTty -> OutputOptions -> String -> String+pTraceIdOpt checkColorTty outputOptions a =+ pTraceOpt checkColorTty outputOptions a a++{-|+Like 'pTraceShow' but takes OutputOptions.+-}+{-# WARNING pTraceShowOpt "'pTraceShowOpt' remains in code" #-}+pTraceShowOpt :: (Show a) => CheckColorTty -> OutputOptions -> a -> b -> b+pTraceShowOpt checkColorTty outputOptions =+ trace . unpack . pShowTTYOpt checkColorTty outputOptions++{-|+Like 'pTraceShowId' but takes OutputOptions.+-}+{-# WARNING pTraceShowIdOpt "'pTraceShowIdOpt' remains in code" #-}+pTraceShowIdOpt :: (Show a) => CheckColorTty -> OutputOptions -> a -> a+pTraceShowIdOpt checkColorTty outputOptions a =+ trace (unpack $ pShowTTYOpt checkColorTty outputOptions a) a++{-|+Like 'pTraceIO' but takes OutputOptions.+-}+{-# WARNING pTraceOptIO "'pTraceOptIO' remains in code" #-}+pTraceOptIO :: CheckColorTty -> OutputOptions -> String -> IO ()+pTraceOptIO checkColorTty outputOptions =+ traceIO . unpack <=< pStringTTYOptIO checkColorTty outputOptions+{-|+Like 'pTraceM' but takes OutputOptions.+-}+{-# WARNING pTraceOptM "'pTraceOptM' remains in code" #-}+#if __GLASGOW_HASKELL__ < 800+pTraceOptM :: (Monad f) => CheckColorTty -> OutputOptions -> String -> f ()+#else+pTraceOptM ::+ (Applicative f) => CheckColorTty -> OutputOptions -> String -> f ()+#endif+pTraceOptM checkColorTty outputOptions string =+ trace (unpack $ pStringTTYOpt checkColorTty outputOptions string) $ pure ()+{-|+Like 'pTraceShowM' but takes OutputOptions.+-}+{-# WARNING pTraceShowOptM "'pTraceShowOptM' remains in code" #-}+#if __GLASGOW_HASKELL__ < 800+pTraceShowOptM ::+ (Show a, Monad f) => CheckColorTty -> OutputOptions -> a -> f ()+#else+pTraceShowOptM ::+ (Show a, Applicative f) => CheckColorTty -> OutputOptions -> a -> f ()+#endif+pTraceShowOptM checkColorTty outputOptions =+ traceM . unpack . pShowTTYOpt checkColorTty outputOptions++{-|+Like 'pTraceStack' but takes OutputOptions.+-}+{-# WARNING pTraceStackOpt "'pTraceStackOpt' remains in code" #-}+pTraceStackOpt :: CheckColorTty -> OutputOptions -> String -> a -> a+pTraceStackOpt checkColorTty outputOptions =+ traceStack . unpack . pStringTTYOpt checkColorTty outputOptions++{-|+Like 'pTraceEvent' but takes OutputOptions.+-}+{-# WARNING pTraceEventOpt "'pTraceEventOpt' remains in code" #-}+pTraceEventOpt :: CheckColorTty -> OutputOptions -> String -> a -> a+pTraceEventOpt checkColorTty outputOptions =+ traceEvent . unpack . pStringTTYOpt checkColorTty outputOptions++{-|+Like 'pTraceEventIO' but takes OutputOptions.+-}+{-# WARNING pTraceEventOptIO "'pTraceEventOptIO' remains in code" #-}+pTraceEventOptIO :: CheckColorTty -> OutputOptions -> String -> IO ()+pTraceEventOptIO checkColorTty outputOptions =+ traceEventIO . unpack <=< pStringTTYOptIO checkColorTty outputOptions++{-|+Like 'pTraceMarker' but takes OutputOptions.+-}+{-# WARNING pTraceMarkerOpt "'pTraceMarkerOpt' remains in code" #-}+pTraceMarkerOpt :: CheckColorTty -> OutputOptions -> String -> a -> a+pTraceMarkerOpt checkColorTty outputOptions =+ traceMarker . unpack . pStringTTYOpt checkColorTty outputOptions++{-|+Like 'pTraceMarkerIO' but takes OutputOptions.+-}+{-# WARNING pTraceMarkerOptIO "'pTraceMarkerOptIO' remains in code" #-}+pTraceMarkerOptIO :: CheckColorTty -> OutputOptions -> String -> IO ()+pTraceMarkerOptIO checkColorTty outputOptions =+ traceMarkerIO . unpack <=< pStringTTYOptIO checkColorTty outputOptions
src/Text/Pretty/Simple.hs view
@@ -1,10 +1,8 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-} {-| Module : Text.Pretty.Simple@@ -27,9 +25,16 @@ 'pPrintNoColor', 'pShowNoColor', and 'pStringNoColor' are for pretty-printing without using color. +'pPrint' and 'pPrintLightBg' will intelligently decide whether or not to use+ANSI escape codes for coloring depending on whether or not the output is+a TTY. This works in most cases. If you want to force color output,+you can use the 'pPrintForceColor' or 'pPrintForceColorLightBg' functions.+ The variations 'pPrintOpt', 'pShowOpt', and 'pStringOpt' are used when specifying the 'OutputOptions'. Most users can ignore these. +There are a few other functions available that are similar to 'pPrint'.+ See the Examples section at the end of this module for examples of acutally using 'pPrint'. See the <https://github.com/cdepillabout/pretty-simple#textprettysimple README.md>@@ -39,33 +44,66 @@ ( -- * Output with color on dark background pPrint+ , pHPrint+ , pPrintString+ , pHPrintString+ , pPrintForceColor+ , pHPrintForceColor+ , pPrintStringForceColor+ , pHPrintStringForceColor , pShow , pString -- * Aliases for output with color on dark background , pPrintDarkBg+ , pHPrintDarkBg+ , pPrintStringDarkBg+ , pHPrintStringDarkBg+ , pPrintForceColorDarkBg+ , pHPrintForceColorDarkBg+ , pPrintStringForceColorDarkBg+ , pHPrintStringForceColorDarkBg , pShowDarkBg , pStringDarkBg -- * Output with color on light background , pPrintLightBg+ , pHPrintLightBg+ , pPrintStringLightBg+ , pHPrintStringLightBg+ , pPrintForceColorLightBg+ , pHPrintForceColorLightBg+ , pPrintStringForceColorLightBg+ , pHPrintStringForceColorLightBg , pShowLightBg , pStringLightBg -- * Output with NO color , pPrintNoColor+ , pHPrintNoColor+ , pPrintStringNoColor+ , pHPrintStringNoColor , pShowNoColor , pStringNoColor -- * Output With 'OutputOptions' , pPrintOpt+ , pHPrintOpt+ , pPrintStringOpt+ , pHPrintStringOpt , pShowOpt , pStringOpt -- * 'OutputOptions' , OutputOptions(..)+ , StringOutputStyle(..) , defaultOutputOptionsDarkBg , defaultOutputOptionsLightBg , defaultOutputOptionsNoColor+ , CheckColorTty(..) -- * 'ColorOptions'- -- $colorOptions , defaultColorOptionsDarkBg , defaultColorOptionsLightBg+ , ColorOptions(..)+ , Style(..)+ , Color(..)+ , Intensity(..)+ , colorNull -- * Examples -- $examples ) where@@ -77,16 +115,24 @@ #endif import Control.Monad.IO.Class (MonadIO, liftIO)-import Data.Foldable (toList)-import Data.Text.Lazy (Text, pack, unpack)-import Data.Text.Lazy.IO as LText+import Data.Text.Lazy (Text)+import Prettyprinter (SimpleDocStream)+import Prettyprinter.Render.Terminal+ (Color (..), Intensity(Vivid,Dull), AnsiStyle,+ renderLazy, renderIO)+import System.IO (Handle, stdout, hPutStrLn) import Text.Pretty.Simple.Internal- (OutputOptions(..), defaultColorOptionsDarkBg,- defaultColorOptionsLightBg, defaultOutputOptionsDarkBg,- defaultOutputOptionsLightBg, defaultOutputOptionsNoColor,- expressionParse, expressionsToOutputs, render)+ (ColorOptions(..), Style(..), CheckColorTty(..),+ OutputOptions(..), StringOutputStyle(..),+ convertStyle, colorNull,+ defaultColorOptionsDarkBg, defaultColorOptionsLightBg,+ defaultOutputOptionsDarkBg, defaultOutputOptionsLightBg,+ defaultOutputOptionsNoColor, hCheckTTY, layoutString) +-- $setup+-- >>> import Data.Text.Lazy (unpack)+ ---------------------------------------------------------- -- functions for printing in color to a dark background -- ----------------------------------------------------------@@ -100,14 +146,91 @@ -- pPrint :: Show a => a -> IO () -- @ ----- This function is for printing to a dark background.+-- This function will only use colors if it detects it's printing to a TTY.+--+-- This function is for printing to a dark background. Use 'pPrintLightBg' for+-- printing to a terminal with a light background. Different colors are used.+--+-- Prints to 'stdout'. Use 'pHPrint' to print to a different 'Handle'.+--+-- >>> pPrint [Just (1, "hello")]+-- [ Just+-- ( 1+-- , "hello"+-- )+-- ] pPrint :: (MonadIO m, Show a) => a -> m ()-pPrint = pPrintOpt defaultOutputOptionsDarkBg+pPrint = pPrintOpt CheckColorTty defaultOutputOptionsDarkBg --- | Similar to 'pPrint', but just return the resulting pretty-printed data--- type as a 'Text' instead of printing it to the screen.+-- | Similar to 'pPrint', but take a 'Handle' to print to. --+-- >>> pHPrint stdout [Just (1, "hello")]+-- [ Just+-- ( 1+-- , "hello"+-- )+-- ]+pHPrint :: (MonadIO m, Show a) => Handle -> a -> m ()+pHPrint = pHPrintOpt CheckColorTty defaultOutputOptionsDarkBg++-- | Similar to 'pPrint', but the first argument is a 'String' representing a+-- data type that has already been 'show'ed.+--+-- >>> pPrintString $ show [ Just (1, "hello"), Nothing ]+-- [ Just+-- ( 1+-- , "hello"+-- )+-- , Nothing+-- ]+pPrintString :: MonadIO m => String -> m ()+pPrintString = pPrintStringOpt CheckColorTty defaultOutputOptionsDarkBg++-- | Similar to 'pHPrintString', but take a 'Handle' to print to.+--+-- >>> pHPrintString stdout $ show [ Just (1, "hello"), Nothing ]+-- [ Just+-- ( 1+-- , "hello"+-- )+-- , Nothing+-- ]+pHPrintString :: MonadIO m => Handle -> String -> m ()+pHPrintString = pHPrintStringOpt CheckColorTty defaultOutputOptionsDarkBg++-- | Similar to 'pPrint', but print in color regardless of whether the output+-- goes to a TTY or not.+--+-- See 'pPrint' for an example of how to use this function.+pPrintForceColor :: (MonadIO m, Show a) => a -> m ()+pPrintForceColor = pPrintOpt NoCheckColorTty defaultOutputOptionsDarkBg++-- | Similar to 'pPrintForceColor', but take a 'Handle' to print to.+--+-- See 'pHPrint' for an example of how to use this function.+pHPrintForceColor :: (MonadIO m, Show a) => Handle -> a -> m ()+pHPrintForceColor = pHPrintOpt NoCheckColorTty defaultOutputOptionsDarkBg++-- | Similar to 'pPrintString', but print in color regardless of whether the+-- output goes to a TTY or not.+--+-- See 'pPrintString' for an example of how to use this function.+pPrintStringForceColor :: MonadIO m => String -> m ()+pPrintStringForceColor = pPrintStringOpt NoCheckColorTty defaultOutputOptionsDarkBg++-- | Similar to 'pHPrintString', but print in color regardless of whether the+-- output goes to a TTY or not.+--+-- See 'pHPrintString' for an example of how to use this function.+pHPrintStringForceColor :: MonadIO m => Handle -> String -> m ()+pHPrintStringForceColor = pHPrintStringOpt NoCheckColorTty defaultOutputOptionsDarkBg++-- | Similar to 'pPrintForceColor', but just return the resulting pretty-printed+-- data type as a 'Text' instead of printing it to the screen.+-- -- This function is for printing to a dark background.+--+-- See 'pShowNoColor' for an example of how to use this function. pShow :: Show a => a -> Text pShow = pShowOpt defaultOutputOptionsDarkBg @@ -120,6 +243,8 @@ -- 'pString' will correctly pretty-print JSON. -- -- This function is for printing to a dark background.+--+-- See 'pStringNoColor' for an example of how to use this function. pString :: String -> Text pString = pStringOpt defaultOutputOptionsDarkBg @@ -131,6 +256,34 @@ pPrintDarkBg :: (MonadIO m, Show a) => a -> m () pPrintDarkBg = pPrint +-- | Alias for 'pHPrint'.+pHPrintDarkBg :: (MonadIO m, Show a) => Handle -> a -> m ()+pHPrintDarkBg = pHPrint++-- | Alias for 'pPrintString'.+pPrintStringDarkBg :: MonadIO m => String -> m ()+pPrintStringDarkBg = pPrintString++-- | Alias for 'pHPrintString'.+pHPrintStringDarkBg :: MonadIO m => Handle -> String -> m ()+pHPrintStringDarkBg = pHPrintString++-- | Alias for 'pPrintForceColor'.+pPrintForceColorDarkBg :: (MonadIO m, Show a) => a -> m ()+pPrintForceColorDarkBg = pPrintForceColor++-- | Alias for 'pHPrintForceColor'.+pHPrintForceColorDarkBg :: (MonadIO m, Show a) => Handle -> a -> m ()+pHPrintForceColorDarkBg = pHPrintForceColor++-- | Alias for 'pPrintStringForceColor'.+pPrintStringForceColorDarkBg :: MonadIO m => String -> m ()+pPrintStringForceColorDarkBg = pPrintStringForceColor++-- | Alias for 'pHPrintStringForceColor'.+pHPrintStringForceColorDarkBg :: MonadIO m => Handle -> String -> m ()+pHPrintStringForceColorDarkBg = pHPrintStringForceColor+ -- | Alias for 'pShow'. pShowDarkBg :: Show a => a -> Text pShowDarkBg = pShow@@ -145,8 +298,40 @@ -- | Just like 'pPrintDarkBg', but for printing to a light background. pPrintLightBg :: (MonadIO m, Show a) => a -> m ()-pPrintLightBg = pPrintOpt defaultOutputOptionsLightBg+pPrintLightBg = pPrintOpt CheckColorTty defaultOutputOptionsLightBg +-- | Just like 'pHPrintDarkBg', but for printing to a light background.+pHPrintLightBg :: (MonadIO m, Show a) => Handle -> a -> m ()+pHPrintLightBg = pHPrintOpt CheckColorTty defaultOutputOptionsLightBg++-- | Just like 'pPrintStringDarkBg', but for printing to a light background.+pPrintStringLightBg :: MonadIO m => String -> m ()+pPrintStringLightBg = pPrintStringOpt CheckColorTty defaultOutputOptionsLightBg++-- | Just like 'pHPrintStringDarkBg', but for printing to a light background.+pHPrintStringLightBg :: MonadIO m => Handle -> String -> m ()+pHPrintStringLightBg = pHPrintStringOpt CheckColorTty defaultOutputOptionsLightBg++-- | Just like 'pPrintForceColorDarkBg', but for printing to a light+-- background.+pPrintForceColorLightBg :: (MonadIO m, Show a) => a -> m ()+pPrintForceColorLightBg = pPrintOpt NoCheckColorTty defaultOutputOptionsLightBg++-- | Just like 'pHPrintForceColorDarkBg', but for printing to a light+-- background.+pHPrintForceColorLightBg :: (MonadIO m, Show a) => Handle -> a -> m ()+pHPrintForceColorLightBg = pHPrintOpt NoCheckColorTty defaultOutputOptionsLightBg++-- | Just like 'pPrintStringForceColorDarkBg', but for printing to a light+-- background.+pPrintStringForceColorLightBg :: MonadIO m => String -> m ()+pPrintStringForceColorLightBg = pPrintStringOpt NoCheckColorTty defaultOutputOptionsLightBg++-- | Just like 'pHPrintStringForceColorDarkBg', but for printing to a light+-- background.+pHPrintStringForceColorLightBg :: MonadIO m => Handle -> String -> m ()+pHPrintStringForceColorLightBg = pHPrintStringOpt NoCheckColorTty defaultOutputOptionsLightBg+ -- | Just like 'pShowDarkBg', but for printing to a light background. pShowLightBg :: Show a => a -> Text pShowLightBg = pShowOpt defaultOutputOptionsLightBg@@ -168,13 +353,50 @@ -- , "bye" -- ] pPrintNoColor :: (MonadIO m, Show a) => a -> m ()-pPrintNoColor = pPrintOpt defaultOutputOptionsNoColor+pPrintNoColor = pPrintOpt NoCheckColorTty defaultOutputOptionsNoColor +-- | Like 'pPrintNoColor', but take a 'Handle' to determine where to print to.+--+-- >>> pHPrintNoColor stdout $ Just ["hello", "bye"]+-- Just+-- [ "hello"+-- , "bye"+-- ]+pHPrintNoColor :: (MonadIO m, Show a) => Handle -> a -> m ()+pHPrintNoColor = pHPrintOpt NoCheckColorTty defaultOutputOptionsNoColor++-- | Similar to 'pPrintString', but doesn't print in color. However, data types+-- will still be indented nicely.+--+-- >>> pPrintStringNoColor $ show $ Just ["hello", "bye"]+-- Just+-- [ "hello"+-- , "bye"+-- ]+pPrintStringNoColor :: MonadIO m => String -> m ()+pPrintStringNoColor = pPrintStringOpt NoCheckColorTty defaultOutputOptionsNoColor++-- | Like 'pPrintStringNoColor', but take a 'Handle' to determine where to print to.+--+-- >>> pHPrintStringNoColor stdout $ show $ Just ["hello", "bye"]+-- Just+-- [ "hello"+-- , "bye"+-- ]+pHPrintStringNoColor :: MonadIO m => Handle -> String -> m ()+pHPrintStringNoColor = pHPrintStringOpt NoCheckColorTty defaultOutputOptionsNoColor+ -- | Like 'pShow', but without color.+--+-- >>> pShowNoColor [ Nothing, Just (1, "hello") ]+-- "[ Nothing\n, Just\n ( 1\n , \"hello\"\n )\n]" pShowNoColor :: Show a => a -> Text pShowNoColor = pShowOpt defaultOutputOptionsNoColor -- | LIke 'pString', but without color.+--+-- >>> pStringNoColor $ show [1, 2, 3]+-- "[ 1\n, 2\n, 3\n]" pStringNoColor :: String -> Text pStringNoColor = pStringOpt defaultOutputOptionsNoColor @@ -190,7 +412,7 @@ -- -- This is what the normal indentation looks like: ----- >>> pPrintOpt defaultOutputOptionsNoColor $ Just ("hello", "bye")+-- >>> pPrintOpt NoCheckColorTty defaultOutputOptionsNoColor $ Just ("hello", "bye") -- Just -- ( "hello" -- , "bye"@@ -199,7 +421,7 @@ -- This is what smaller indentation looks like: -- -- >>> let smallIndent = defaultOutputOptionsNoColor {outputOptionsIndentAmount = 1}--- >>> pPrintOpt smallIndent $ Just ("hello", "bye")+-- >>> pPrintOpt CheckColorTty smallIndent $ Just ("hello", "bye") -- Just -- ( "hello" -- , "bye"@@ -207,7 +429,7 @@ -- -- Lines in strings get indented ----- >>> pPrintOpt defaultOutputOptionsNoColor (1, (2, "foo\nbar\nbaz", 3))+-- >>> pPrintOpt NoCheckColorTty defaultOutputOptionsNoColor (1, (2, "foo\nbar\nbaz", 3)) -- ( 1 -- , -- ( 2@@ -222,7 +444,7 @@ -- -- >>> data Foo = Foo -- >>> instance Show Foo where show _ = "foo\nbar\nbaz"--- >>> pPrintOpt defaultOutputOptionsNoColor (1, (2, Foo, 3))+-- >>> pPrintOpt CheckColorTty defaultOutputOptionsNoColor (1, (2, Foo, 3)) -- ( 1 -- , -- ( 2@@ -232,10 +454,80 @@ -- , 3 -- ) -- )+--+-- 'CheckColorTty' determines whether to test 'stdout' for whether or not it is+-- connected to a TTY.+--+-- If set to 'NoCheckColorTty', then 'pPrintOpt' won't+-- check if 'stdout' is a TTY. It will print in color depending on the value+-- of 'outputOptionsColorOptions'.+--+-- If set to 'CheckColorTty', then 'pPrintOpt' will check if 'stdout' is+-- conneted to a TTY. If 'stdout' is determined to be connected to a TTY, then+-- it will print in color depending on the value of+-- 'outputOptionsColorOptions'. If 'stdout' is determined to NOT be connected+-- to a TTY, then it will NOT print in color, regardless of the value of+-- 'outputOptionsColorOptions'.+pPrintOpt :: (MonadIO m, Show a) => CheckColorTty -> OutputOptions -> a -> m ()+pPrintOpt checkColorTty outputOptions =+ pHPrintOpt checkColorTty outputOptions stdout -pPrintOpt :: (MonadIO m, Show a) => OutputOptions -> a -> m ()-pPrintOpt outputOptions = liftIO . LText.putStrLn . pShowOpt outputOptions+-- | Similar to 'pPrintOpt', but take a 'Handle' to determine where to print+-- to.+pHPrintOpt ::+ (MonadIO m, Show a)+ => CheckColorTty+ -> OutputOptions+ -> Handle+ -> a+ -> m ()+pHPrintOpt checkColorTty outputOptions handle a =+ pHPrintStringOpt checkColorTty outputOptions handle $ show a +-- | Similar to 'pPrintOpt', but the last argument is a string representing a+-- data structure that has already been 'show'ed.+--+-- >>> let foo = show (1, (2, "hello", 3))+-- >>> pPrintStringOpt CheckColorTty defaultOutputOptionsNoColor foo+-- ( 1+-- ,+-- ( 2+-- , "hello"+-- , 3+-- )+-- )+pPrintStringOpt :: MonadIO m => CheckColorTty -> OutputOptions -> String -> m ()+pPrintStringOpt checkColorTty outputOptions =+ pHPrintStringOpt checkColorTty outputOptions stdout++-- | Similar to 'pPrintStringOpt', but take a 'Handle' to determine where to+-- print to.+--+-- >>> let foo = show (1, (2, "hello", 3))+-- >>> pHPrintStringOpt CheckColorTty defaultOutputOptionsNoColor stdout foo+-- ( 1+-- ,+-- ( 2+-- , "hello"+-- , 3+-- )+-- )+pHPrintStringOpt ::+ MonadIO m+ => CheckColorTty+ -> OutputOptions+ -> Handle+ -> String+ -> m ()+pHPrintStringOpt checkColorTty outputOptions handle str = do+ realOutputOpts <-+ case checkColorTty of+ CheckColorTty -> hCheckTTY handle outputOptions+ NoCheckColorTty -> pure outputOptions+ liftIO $ do+ renderIO handle $ layoutStringAnsi realOutputOpts str+ hPutStrLn handle ""+ -- | Like 'pShow' but takes 'OutputOptions' to change how the -- pretty-printing is done. pShowOpt :: Show a => OutputOptions -> a -> Text@@ -244,34 +536,26 @@ -- | 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 -- -- Here are some examples of using 'pPrint' on different data types. You can -- look at these examples to get an idea of what 'pPrint' will output. ----- The following examples are all using 'pPrintNoColor' instead of 'pPrint'--- because their output is being checked using--- <https://github.com/sol/doctest#readme doctest>. 'pPrint' outputs ANSI--- escape codes in order to produce color, so the following examples would be--- hard to read had 'pPrint' been used.--- -- __Simple Haskell data type__ ----- >>> data Foo a = Foo a String deriving Show+-- >>> data Foo a = Foo a String Char deriving Show ----- >>> pPrintNoColor $ Foo 3 "hello"--- Foo 3 "hello"+-- >>> pPrint $ Foo 3 "hello" 'a'+-- Foo 3 "hello" 'a' -- -- __List__ ----- >>> pPrintNoColor $ [1,2,3]+-- >>> pPrint $ [1,2,3] -- [ 1 -- , 2 -- , 3@@ -279,19 +563,19 @@ -- -- __Slightly more complicated list__ ----- >>> pPrintNoColor $ [ Foo [ (), () ] "hello" ]+-- >>> pPrint $ [ Foo [ (), () ] "hello" 'b' ] -- [ Foo -- [ () -- , ()--- ] "hello"+-- ] "hello" 'b' -- ] ----- >>> pPrintNoColor $ [ Foo [ "bar", "baz" ] "hello", Foo [] "bye" ]+-- >>> pPrint $ [ Foo [ "bar", "baz" ] "hello" 'a', Foo [] "bye" 'b' ] -- [ Foo -- [ "bar" -- , "baz"--- ] "hello"--- , Foo [] "bye"+-- ] "hello" 'a'+-- , Foo [] "bye" 'b' -- ] -- -- __Record__@@ -304,7 +588,7 @@ -- } deriving Show -- :} ----- >>> pPrintNoColor $ Bar 1 [10, 11] [Foo 1.1 "", Foo 2.2 "hello"]+-- >>> pPrint $ Bar 1 [10, 11] [Foo 1.1 "" 'a', Foo 2.2 "hello" 'b'] -- Bar -- { barInt = 1 -- , barA =@@ -312,8 +596,8 @@ -- , 11 -- ] -- , barList =--- [ Foo 1.1 ""--- , Foo 2.2 "hello"+-- [ Foo 1.1 "" 'a'+-- , Foo 2.2 "hello" 'b' -- ] -- } --@@ -321,7 +605,7 @@ -- -- >>> newtype Baz = Baz { unBaz :: [String] } deriving Show ----- >>> pPrintNoColor $ Baz ["hello", "bye"]+-- >>> pPrint $ Baz ["hello", "bye"] -- Baz -- { unBaz = -- [ "hello"@@ -333,20 +617,20 @@ -- -- >>> data Foo = A | B Foo | C [Foo] [Foo] deriving Show ----- >>> pPrintNoColor $ B ( B A )+-- >>> pPrint $ B ( B A ) -- B ( B A ) ----- >>> pPrintNoColor $ B ( B ( B A ) )+-- >>> pPrint $ B ( B ( B A ) ) -- B -- ( B ( B A ) ) ----- >>> pPrintNoColor $ B ( B ( B ( B A ) ) )+-- >>> pPrint $ B ( B ( B ( B A ) ) ) -- B -- ( B -- ( B ( B A ) ) -- ) ----- >>> pPrintNoColor $ B ( C [A, A] [B A, B (B (B A))] )+-- >>> pPrint $ B ( C [A, A] [B A, B (B (B A))] ) -- B -- ( C -- [ A@@ -365,7 +649,7 @@ -- -- __Unicode__ ----- >>> pPrintNoColor $ Baz ["猫", "犬", "ヤギ"]+-- >>> pPrint $ Baz ["猫", "犬", "ヤギ"] -- Baz -- { unBaz = -- [ "猫"@@ -374,11 +658,86 @@ -- ] -- } --+-- __Char__+--+-- >>> pPrint 'λ'+-- 'λ'+--+-- __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 ) ) ] )+--+-- >>> pPrintOpt CheckColorTty defaultOutputOptionsDarkBg {outputOptionsCompact = True} $ [("id", 123), ("state", 1), ("pass", 1), ("tested", 100), ("time", 12345)]+-- [+-- ( "id", 123 ),+-- ( "state", 1 ),+-- ( "pass", 1 ),+-- ( "tested", 100 ),+-- ( "time", 12345 )+-- ]+--+-- __Initial indent__+--+-- >>> pPrintOpt CheckColorTty defaultOutputOptionsDarkBg {outputOptionsInitialIndent = 3} $ B ( B ( B ( B A ) ) )+-- B+-- ( B+-- ( B ( B A ) )+-- )+--+-- __Weird/illegal show instances__+--+-- >>> pPrintString "2019-02-18 20:56:24.265489 UTC"+-- 2019-02-18 20:56:24.265489 UTC+--+-- >>> pPrintString "a7ed86f7-7f2c-4be5-a760-46a3950c2abf"+-- a7ed86f7-7f2c-4be5-a760-46a3950c2abf+--+-- >>> pPrintString "192.168.0.1:8000"+-- 192.168.0.1:8000+--+-- >>> pPrintString "A @\"type\" 1"+-- A @"type" 1+--+-- >>> pPrintString "2+2"+-- 2+2+--+-- >>> pPrintString "1.0e-2"+-- 1.0e-2+--+-- >>> pPrintString "0x1b"+-- 0x1b+-- -- __Other__ ----- Making sure the spacing after a string is correct+-- Making sure the spacing after a string is correct. -- -- >>> data Foo = Foo String Int deriving Show ----- >>> pPrintNoColor $ Foo "bar" 0+-- >>> pPrint $ Foo "bar" 0 -- Foo "bar" 0+--+-- Non-printable characters will get escaped.+--+-- >>> pPrint "this string has non-printable characters: \x8 and \x9"+-- "this string has non-printable characters: \x8 and \x9"+--+-- If you don't want non-printable characters to be escaped, take a look at+-- 'outputOptionsStringStyle' and 'StringOutputStyle'.
src/Text/Pretty/Simple/Internal.hs view
@@ -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
src/Text/Pretty/Simple/Internal/Color.hs view
@@ -2,13 +2,14 @@ {-# 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 +26,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- -- ^ (currently not used)- , colorRainbowParens :: [Builder]- -- ^ A list of 'Builder' colors to use for rainbow parenthesis output. Use+ , colorError :: Style+ -- ^ Color for errors, e.g. unmatched brackets.+ , colorNum :: Style+ -- ^ Color to use for numbers.+ , 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
src/Text/Pretty/Simple/Internal/Expr.hs view
@@ -4,7 +4,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-} {-| Module : Text.Pretty.Simple.Internal.Expr@@ -36,5 +35,12 @@ | Braces !(CommaSeparated [Expr]) | Parens !(CommaSeparated [Expr]) | StringLit !String+ | CharLit !String+ | NumberLit !String+ -- ^ We could store this as a 'Rational', say, instead of a 'String'.+ -- However, we will never need to use its value for anything. Indeed, the+ -- only thing we will be doing with it is turning it /back/ into a string+ -- at some stage, so we might as well cut out the middle man and store it+ -- directly like this. | Other !String deriving (Data, Eq, Generic, Show, Typeable)
src/Text/Pretty/Simple/Internal/ExprParser.hs view
@@ -1,10 +1,7 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-} {-| Module : Text.Pretty.Simple.Internal.ExprParser@@ -20,9 +17,15 @@ import Text.Pretty.Simple.Internal.Expr (CommaSeparated(..), Expr(..)) import Control.Arrow (first)+import Data.Char (isAlpha, isDigit) -testString1, testString2 :: String+-- | 'testString1' and 'testString2' are convenient to use in GHCi when playing+-- around with how parsing works.+testString1 :: String testString1 = "Just [TextInput {textInputClass = Just (Class {unClass = \"class\"}), textInputId = Just (Id {unId = \"id\"}), textInputName = Just (Name {unName = \"name\"}), textInputValue = Just (Value {unValue = \"value\"}), textInputPlaceholder = Just (Placeholder {unPlaceholder = \"placeholder\"})}, TextInput {textInputClass = Just (Class {unClass = \"class\"}), textInputId = Just (Id {unId = \"id\"}), textInputName = Just (Name {unName = \"name\"}), textInputValue = Just (Value {unValue = \"value\"}), textInputPlaceholder = Just (Placeholder {unPlaceholder = \"placeholder\"})}]"++-- | See 'testString1'.+testString2 :: String testString2 = "some stuff (hello [\"dia\\x40iahello\", why wh, bye] ) (bye)" expressionParse :: String -> [Expr]@@ -33,8 +36,21 @@ parseExpr ('[':rest) = first (Brackets . CommaSeparated) $ parseCSep ']' rest parseExpr ('{':rest) = first (Braces . CommaSeparated) $ parseCSep '}' rest parseExpr ('"':rest) = first StringLit $ parseStringLit rest+parseExpr ('\'':rest) = first CharLit $ parseCharLit rest+parseExpr (c:rest) | isDigit c = first NumberLit $ parseNumberLit c rest parseExpr other = first Other $ parseOther other +-- | Parse multiple expressions.+--+-- >>> parseExprs "Just 'a'"+-- ([Other "Just ",CharLit "a"],"")+--+-- Handle escaped characters correctly+--+-- >>> parseExprs $ "Foo \"hello \\\"world!\""+-- ([Other "Foo ",StringLit "hello \\\"world!"],"")+-- >>> parseExprs $ "'\\''"+-- ([CharLit "\\'"],"") parseExprs :: String -> ([Expr], String) parseExprs [] = ([], "") parseExprs s@(c:_)@@ -55,19 +71,114 @@ (toParse, rest) = parseCSep end rest' in (parsed : toParse, rest) +-- | Parse string literals until a trailing double quote.+--+-- >>> parseStringLit "foobar\" baz"+-- ("foobar"," baz")+--+-- Keep literal back slashes:+--+-- >>> parseStringLit "foobar\\\" baz\" after"+-- ("foobar\\\" baz"," after") parseStringLit :: String -> (String, String) parseStringLit [] = ("", "") parseStringLit ('"':rest) = ("", rest) parseStringLit ('\\':c:cs) = ('\\':c:cs', rest) where (cs', rest) = parseStringLit cs-parseStringLit (c:cs) = (c:cs', rest)+parseStringLit (c:cs) = (c:cs', rest) where (cs', rest) = parseStringLit cs -parseOther :: String -> (String, String)-parseOther = span . flip notElem $ ("{[()]}\"," :: String)+-- | Parse character literals until a trailing single quote.+--+-- >>> parseCharLit "a' foobar"+-- ("a"," foobar")+--+-- Keep literal back slashes:+--+-- >>> parseCharLit "\\'' hello"+-- ("\\'"," hello")+parseCharLit :: String -> (String, String)+parseCharLit [] = ("", "")+parseCharLit ('\'':rest) = ("", rest)+parseCharLit ('\\':c:cs) = ('\\':c:cs', rest)+ where (cs', rest) = parseCharLit cs+parseCharLit (c:cs) = (c:cs', rest)+ where (cs', rest) = parseCharLit cs --- |--- Handle escaped characters correctly+-- | Parses integers and reals, like @123@ and @45.67@. ----- >>> parseExprs $ "Foo \"hello \\\"world!\""--- ([Other "Foo ",StringLit "hello \\\"world!"],"")+-- To be more precise, any numbers matching the regex @\\d+(\\.\\d+)?@ should+-- get parsed by this function.+--+-- >>> parseNumberLit '3' "456hello world []"+-- ("3456","hello world []")+-- >>> parseNumberLit '0' ".12399880 foobar"+-- ("0.12399880"," foobar")+parseNumberLit :: Char -> String -> (String, String)+parseNumberLit firstDigit rest1 =+ case rest2 of+ [] -> (firstDigit:remainingDigits, "")+ '.':rest3 ->+ let (digitsAfterDot, rest4) = span isDigit rest3+ in ((firstDigit : remainingDigits) ++ ('.' : digitsAfterDot), rest4)+ _ -> (firstDigit:remainingDigits, rest2)+ where+ remainingDigits :: String+ rest2 :: String+ (remainingDigits, rest2) = span isDigit rest1++-- | This function consumes input, stopping only when it hits a special+-- character or a digit. However, if the digit is in the middle of a+-- Haskell-style identifier (e.g. @foo123@), then keep going+-- anyway.+--+-- This is almost the same as the function+--+-- > parseOtherSimple = span $ \c ->+-- > notElem c ("{[()]}\"," :: String) && not (isDigit c) && (c /= '\'')+--+-- except 'parseOther' ignores digits and single quotes that appear in+-- Haskell-like identifiers.+--+-- >>> parseOther "hello world []"+-- ("hello world ","[]")+-- >>> parseOther "hello234 world"+-- ("hello234 world","")+-- >>> parseOther "hello 234 world"+-- ("hello ","234 world")+-- >>> parseOther "hello{[ 234 world"+-- ("hello","{[ 234 world")+-- >>> parseOther "H3110 World"+-- ("H3110 World","")+-- >>> parseOther "Node' (Leaf' 1) (Leaf' 2)"+-- ("Node' ","(Leaf' 1) (Leaf' 2)")+-- >>> parseOther "I'm One"+-- ("I'm One","")+-- >>> parseOther "I'm 2"+-- ("I'm ","2")+parseOther :: String -> (String, String)+parseOther = go False+ where+ go+ :: Bool+ -- ^ in an identifier?+ -> String+ -> (String, String)+ go _ [] = ("", "")+ go insideIdent cs@(c:cs')+ | c `elem` ("{[()]}\"," :: String) = ("", cs)+ | ignoreInIdent c && not insideIdent = ("", cs)+ | insideIdent = first (c :) (go (isIdentRest c) cs')+ | otherwise = first (c :) (go (isIdentBegin c) cs')++ isIdentBegin :: Char -> Bool+ isIdentBegin '_' = True+ isIdentBegin c = isAlpha c++ isIdentRest :: Char -> Bool+ isIdentRest '_' = True+ isIdentRest '\'' = True+ isIdentRest c = isAlpha c || ignoreInIdent c++ ignoreInIdent :: Char -> Bool+ ignoreInIdent x = isDigit x || x == '\''
− src/Text/Pretty/Simple/Internal/ExprToOutput.hs
@@ -1,286 +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--- >>> 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 (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
− src/Text/Pretty/Simple/Internal/Output.hs
@@ -1,95 +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\"@.- 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' 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)
− src/Text/Pretty/Simple/Internal/OutputPrinter.hs
@@ -1,243 +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.Reader (MonadReader(reader), runReader)-import Data.Foldable (fold)-import Data.Text.Lazy (Text)-import Data.Text.Lazy.Builder (Builder, fromString, toLazyText)-import Data.Typeable (Typeable)-import Data.List (intercalate)-import Data.Maybe (fromMaybe)-import Text.Read (readMaybe)-import GHC.Generics (Generic)--import Text.Pretty.Simple.Internal.Color- (ColorOptions(..), colorReset, defaultColorOptionsDarkBg,- defaultColorOptionsLightBg)-import Text.Pretty.Simple.Internal.Output- (NestLevel(..), Output(..), OutputType(..))---- | 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.- } 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- }---- | 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- }---- | 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}---- | 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) = renderRaibowParenFor nest "}"-renderOutput (Output nest OutputCloseBracket) = renderRaibowParenFor nest "]"-renderOutput (Output nest OutputCloseParen) = renderRaibowParenFor nest ")"-renderOutput (Output nest OutputComma) = renderRaibowParenFor nest ","-renderOutput (Output _ OutputIndent) = do- indentSpaces <- reader outputOptionsIndentAmount- pure . mconcat $ replicate indentSpaces " "-renderOutput (Output _ OutputNewLine) = pure "\n"-renderOutput (Output nest OutputOpenBrace) = renderRaibowParenFor nest "{"-renderOutput (Output nest OutputOpenBracket) = renderRaibowParenFor nest "["-renderOutput (Output nest OutputOpenParen) = renderRaibowParenFor 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 _ (OutputStringLit string)) = do- indentSpaces <- reader outputOptionsIndentAmount- let spaces = replicate (indentSpaces + 2) ' '-- sequenceFold- [ useColorQuote- , pure "\""- , useColorReset- , useColorString- -- TODO: This probably shouldn't be a string to begin with.- , pure $ fromString $ indentSubsequentLinesWith spaces $ readStr string- , useColorReset- , useColorQuote- , pure "\""- , useColorReset- ]- where readStr s = fromMaybe s . readMaybe $ '"':s ++ "\""---- |--- >>> 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.-renderRaibowParenFor- :: MonadReader OutputOptions m- => NestLevel -> Builder -> m Builder-renderRaibowParenFor 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 = 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---- | 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 "" = ""
+ src/Text/Pretty/Simple/Internal/Printer.hs view
@@ -0,0 +1,356 @@+{-# 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, ord)+import Data.List.NonEmpty (NonEmpty, nonEmpty)+import Data.Maybe (fromMaybe)+import Prettyprinter+ (indent, line', PageWidth(AvailablePerLine), layoutPageWidth, nest,+ concatWith, space, Doc, SimpleDocStream, annotate, defaultLayoutOptions,+ enclose, hcat, layoutSmart, line, unAnnotateS, pretty, group,+ removeTrailingWhitespace)+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 . layoutStringAbstract opts++layoutStringAbstract :: OutputOptions -> String -> SimpleDocStream Annotation+layoutStringAbstract opts =+ removeTrailingWhitespace+ . layoutSmart defaultLayoutOptions+ {layoutPageWidth = AvailablePerLine (outputOptionsPageWidth opts) 1}+ . indent (outputOptionsInitialIndent opts)+ . prettyExprs' 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 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 $ escapeString s+ CharLit s -> join enclose (annotate Quote "'") $ annotate String $ pretty $ escapeString s+ Other s -> pretty s+ NumberLit n -> annotate Num $ pretty n+ where+ escapeString s = case outputOptionsStringStyle opts of+ Literal -> s+ EscapeNonPrintable -> escapeNonPrintable $ readStr s+ DoNotEscapeNonPrintable -> readStr s+ readStr :: String -> String+ readStr s = fromMaybe s . readMaybe $ '"' : s ++ "\""+ 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 <> hcat (map (prettyExpr opts) xs) <> space+ _ -> concatWith lineAndCommaSep (map (\xs -> spaceIfNeeded xs <> prettyExprs opts xs) xss)+ <> if outputOptionsCompactParens opts then space else line+ where+ spaceIfNeeded = \case+ Other (' ' : _) : _ -> mempty+ _ -> space+ lineAndCommaSep x y = x <> munless (outputOptionsCompact opts) line' <> annotate Comma "," <> y+ munless b x = if b then mempty else x++-- | 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+ deriving (Eq, Show)++-- | 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 = foldr escape ""++-- | 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)++-- | 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
− test/DocTest.hs
@@ -1,40 +0,0 @@--module Main (main) where--import Prelude--import Data.Monoid ((<>))-import System.FilePath.Glob (glob)-import Test.DocTest (doctest)--main :: IO ()-main = glob "src/**/*.hs" >>= doDocTest--doDocTest :: [String] -> IO ()-doDocTest options = doctest $ options <> ghcExtensions--ghcExtensions :: [String]-ghcExtensions =- [- -- "-XConstraintKinds"- -- , "-XDataKinds"- "-XDeriveDataTypeable"- , "-XDeriveGeneric"- -- , "-XEmptyDataDecls"- , "-XFlexibleContexts"- -- , "-XFlexibleInstances"- -- , "-XGADTs"- -- , "-XGeneralizedNewtypeDeriving"- -- , "-XInstanceSigs"- -- , "-XMultiParamTypeClasses"- -- , "-XNoImplicitPrelude"- , "-XOverloadedStrings"- -- , "-XPolyKinds"- -- , "-XRankNTypes"- -- , "-XRecordWildCards"- , "-XScopedTypeVariables"- -- , "-XStandaloneDeriving"- -- , "-XTupleSections"- -- , "-XTypeFamilies"- -- , "-XTypeOperators"- ]