diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -2,7 +2,7 @@ Text.Pretty.Simple ================== -[![Build Status](https://secure.travis-ci.org/cdepillabout/pretty-simple.svg)](http://travis-ci.org/cdepillabout/pretty-simple) +[![Build Status](https://github.com/cdepillabout/pretty-simple/workflows/CI/badge.svg)](https://github.com/cdepillabout/pretty-simple/actions) [![Hackage](https://img.shields.io/hackage/v/pretty-simple.svg)](https://hackage.haskell.org/package/pretty-simple) [![Stackage LTS](http://stackage.org/package/pretty-simple/badge/lts)](http://stackage.org/lts/package/pretty-simple) [![Stackage Nightly](http://stackage.org/package/pretty-simple/badge/nightly)](http://stackage.org/nightly/package/pretty-simple) @@ -37,19 +37,25 @@ `pretty-simple` can be used to print `bar` in an easy-to-read format: -![example screenshot](/img/pretty-simple-example-screenshot.png?raw=true "example screenshot") +![example screenshot](https://raw.githubusercontent.com/cdepillabout/pretty-simple/master/img/pretty-simple-example-screenshot.png) ## 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: -![json example screenshot](/img/pretty-simple-json-example-screenshot.png?raw=true "json example screenshot") +![json example screenshot](https://raw.githubusercontent.com/cdepillabout/pretty-simple/master/img/pretty-simple-json-example-screenshot.png) (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 Ctrl-D: -![cli example screenshot](/img/pretty-simple-cli-screenshot.png?raw=true "cli example screenshot") +![cli example screenshot](https://raw.githubusercontent.com/cdepillabout/pretty-simple/master/img/pretty-simple-cli-screenshot.png) 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) diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -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 diff --git a/pretty-simple.cabal b/pretty-simple.cabal --- a/pretty-simple.cabal +++ b/pretty-simple.cabal @@ -1,5 +1,5 @@ name: pretty-simple -version: 2.2.0.1 +version: 4.1.4.0 synopsis: pretty printer for data types with a 'Show' instance. description: Please see . 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 diff --git a/src/Debug/Pretty/Simple.hs b/src/Debug/Pretty/Simple.hs --- a/src/Debug/Pretty/Simple.hs +++ b/src/Debug/Pretty/Simple.hs @@ -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 diff --git a/src/Text/Pretty/Simple.hs b/src/Text/Pretty/Simple.hs --- a/src/Text/Pretty/Simple.hs +++ b/src/Text/Pretty/Simple.hs @@ -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 @@ -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 --- . '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'. diff --git a/src/Text/Pretty/Simple/Internal.hs b/src/Text/Pretty/Simple/Internal.hs --- a/src/Text/Pretty/Simple/Internal.hs +++ b/src/Text/Pretty/Simple/Internal.hs @@ -14,6 +14,4 @@ import Text.Pretty.Simple.Internal.Color as X import Text.Pretty.Simple.Internal.ExprParser as X import Text.Pretty.Simple.Internal.Expr as X -import Text.Pretty.Simple.Internal.ExprToOutput as X -import Text.Pretty.Simple.Internal.Output as X -import Text.Pretty.Simple.Internal.OutputPrinter as X +import Text.Pretty.Simple.Internal.Printer as X diff --git a/src/Text/Pretty/Simple/Internal/Color.hs b/src/Text/Pretty/Simple/Internal/Color.hs --- a/src/Text/Pretty/Simple/Internal/Color.hs +++ b/src/Text/Pretty/Simple/Internal/Color.hs @@ -2,13 +2,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 diff --git a/src/Text/Pretty/Simple/Internal/Expr.hs b/src/Text/Pretty/Simple/Internal/Expr.hs --- a/src/Text/Pretty/Simple/Internal/Expr.hs +++ b/src/Text/Pretty/Simple/Internal/Expr.hs @@ -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) diff --git a/src/Text/Pretty/Simple/Internal/ExprParser.hs b/src/Text/Pretty/Simple/Internal/ExprParser.hs --- a/src/Text/Pretty/Simple/Internal/ExprParser.hs +++ b/src/Text/Pretty/Simple/Internal/ExprParser.hs @@ -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 == '\'' diff --git a/src/Text/Pretty/Simple/Internal/ExprToOutput.hs b/src/Text/Pretty/Simple/Internal/ExprToOutput.hs deleted file mode 100644 --- a/src/Text/Pretty/Simple/Internal/ExprToOutput.hs +++ /dev/null @@ -1,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 diff --git a/src/Text/Pretty/Simple/Internal/Output.hs b/src/Text/Pretty/Simple/Internal/Output.hs deleted file mode 100644 --- a/src/Text/Pretty/Simple/Internal/Output.hs +++ /dev/null @@ -1,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) diff --git a/src/Text/Pretty/Simple/Internal/OutputPrinter.hs b/src/Text/Pretty/Simple/Internal/OutputPrinter.hs deleted file mode 100644 --- a/src/Text/Pretty/Simple/Internal/OutputPrinter.hs +++ /dev/null @@ -1,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 "" = "" diff --git a/src/Text/Pretty/Simple/Internal/Printer.hs b/src/Text/Pretty/Simple/Internal/Printer.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pretty/Simple/Internal/Printer.hs @@ -0,0 +1,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 diff --git a/test/DocTest.hs b/test/DocTest.hs deleted file mode 100644 --- a/test/DocTest.hs +++ /dev/null @@ -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" - ]