diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,72 @@ +## 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 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,33 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -Wall #-} -module Main (main) where - -#ifndef MIN_VERSION_cabal_doctest -#define MIN_VERSION_cabal_doctest(x,y,z) 0 -#endif - -#if MIN_VERSION_cabal_doctest(1,0,0) - -import Distribution.Extra.Doctest ( defaultMainWithDoctests ) -main :: IO () -main = defaultMainWithDoctests "pretty-simple-doctest" - -#else - -#ifdef MIN_VERSION_Cabal --- If the macro is defined, we have new cabal-install, --- but for some reason we don't have cabal-doctest in package-db --- --- Probably we are running cabal sdist, when otherwise using new-build --- workflow -#warning You are configuring this package without cabal-doctest installed. \ - The doctests test-suite will not work as a result. \ - To fix this, install cabal-doctest before configuring. -#endif - -import Distribution.Simple - -main :: IO () -main = defaultMain - -#endif 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: 3.3.0.0 +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 @@ -9,20 +9,15 @@ maintainer: cdep.illabout@gmail.com copyright: 2017-2019 Dennis Gosnell category: Text -build-type: Custom +build-type: Simple extra-source-files: CHANGELOG.md , README.md , img/pretty-simple-example-screenshot.png cabal-version: >=1.10 -custom-setup - setup-depends: base - , Cabal >= 1.24 - , cabal-doctest >=1.0.2 - 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 @@ -36,13 +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 @@ -51,6 +45,7 @@ executable pretty-simple main-is: Main.hs + other-modules: Paths_pretty_simple hs-source-dirs: app build-depends: base , pretty-simple @@ -95,18 +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 >= 0.13 - , Glob - , QuickCheck - , template-haskell - 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 @@ -30,6 +30,8 @@ , pTraceEventIO , pTraceMarker , pTraceMarkerIO + , pTraceWith + , pTraceShowWith -- * Trace forcing color , pTraceForceColor , pTraceIdForceColor @@ -95,6 +97,7 @@ @since 2.0.1.0 -} +{-# WARNING pTraceIO "'pTraceIO' remains in code" #-} pTraceIO :: String -> IO () pTraceIO = pTraceOptIO CheckColorTty defaultOutputOptionsDarkBg @@ -113,6 +116,7 @@ @since 2.0.1.0 -} +{-# WARNING pTrace "'pTrace' remains in code" #-} pTrace :: String -> a -> a pTrace = pTraceOpt CheckColorTty defaultOutputOptionsDarkBg @@ -121,6 +125,7 @@ @since 2.0.1.0 -} +{-# WARNING pTraceId "'pTraceId' remains in code" #-} pTraceId :: String -> String pTraceId = pTraceIdOpt CheckColorTty defaultOutputOptionsDarkBg @@ -139,6 +144,7 @@ @since 2.0.1.0 -} +{-# WARNING pTraceShow "'pTraceShow' remains in code" #-} pTraceShow :: (Show a) => a -> b -> b pTraceShow = pTraceShowOpt CheckColorTty defaultOutputOptionsDarkBg @@ -147,6 +153,7 @@ @since 2.0.1.0 -} +{-# WARNING pTraceShowId "'pTraceShowId' remains in code" #-} pTraceShowId :: (Show a) => a -> a pTraceShowId = pTraceShowIdOpt CheckColorTty defaultOutputOptionsDarkBg {-| @@ -168,6 +175,7 @@ @since 2.0.1.0 -} +{-# WARNING pTraceM "'pTraceM' remains in code" #-} #if __GLASGOW_HASKELL__ < 800 pTraceM :: (Monad f) => String -> f () #else @@ -185,6 +193,7 @@ @since 2.0.1.0 -} +{-# WARNING pTraceShowM "'pTraceShowM' remains in code" #-} #if __GLASGOW_HASKELL__ < 800 pTraceShowM :: (Show a, Monad f) => a -> f () #else @@ -204,6 +213,7 @@ @since 2.0.1.0 -} +{-# WARNING pTraceStack "'pTraceStack' remains in code" #-} pTraceStack :: String -> a -> a pTraceStack = pTraceStackOpt CheckColorTty defaultOutputOptionsDarkBg @@ -221,6 +231,7 @@ @since 2.0.1.0 -} +{-# WARNING pTraceEvent "'pTraceEvent' remains in code" #-} pTraceEvent :: String -> a -> a pTraceEvent = pTraceEventOpt CheckColorTty defaultOutputOptionsDarkBg @@ -233,6 +244,7 @@ @since 2.0.1.0 -} +{-# WARNING pTraceEventIO "'pTraceEventIO' remains in code" #-} pTraceEventIO :: String -> IO () pTraceEventIO = pTraceEventOptIO CheckColorTty defaultOutputOptionsDarkBg @@ -249,6 +261,7 @@ -- that uses 'pTraceMarker'. -- -- @since 2.0.1.0 +{-# WARNING pTraceMarker "'pTraceMarker' remains in code" #-} pTraceMarker :: String -> a -> a pTraceMarker = pTraceMarkerOpt CheckColorTty defaultOutputOptionsDarkBg @@ -259,12 +272,30 @@ -- to other IO actions. -- -- @since 2.0.1.0 +{-# WARNING pTraceMarkerIO "'pTraceMarkerIO' remains in code" #-} pTraceMarkerIO :: String -> IO () 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) + ------------------------------------------ -- Helpers ------------------------------------------ +{-# WARNING pStringTTYOptIO "'pStringTTYOptIO' remains in code" #-} pStringTTYOptIO :: CheckColorTty -> OutputOptions -> String -> IO Text pStringTTYOptIO checkColorTty outputOptions v = do realOutputOpts <- @@ -273,14 +304,17 @@ 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 @@ -289,22 +323,27 @@ -- 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 @@ -312,6 +351,7 @@ #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 @@ -321,31 +361,37 @@ 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 @@ -359,6 +405,7 @@ -- () -- -- @since 2.0.2.0 +{-# WARNING pTraceNoColor "'pTraceNoColor' remains in code" #-} pTraceNoColor :: String -> a -> a pTraceNoColor = pTraceOpt NoCheckColorTty defaultOutputOptionsNoColor @@ -372,6 +419,7 @@ -- () -- -- @since 2.0.2.0 +{-# WARNING pTraceIdNoColor "'pTraceIdNoColor' remains in code" #-} pTraceIdNoColor :: String -> String pTraceIdNoColor = pTraceIdOpt NoCheckColorTty defaultOutputOptionsNoColor @@ -388,6 +436,7 @@ -- () -- -- @since 2.0.2.0 +{-# WARNING pTraceShowNoColor "'pTraceShowNoColor' remains in code" #-} pTraceShowNoColor :: (Show a) => a -> b -> b pTraceShowNoColor = pTraceShowOpt NoCheckColorTty defaultOutputOptionsNoColor @@ -404,6 +453,7 @@ -- () -- -- @since 2.0.2.0 +{-# WARNING pTraceShowIdNoColor "'pTraceShowIdNoColor' remains in code" #-} pTraceShowIdNoColor :: (Show a) => a -> a pTraceShowIdNoColor = pTraceShowIdOpt NoCheckColorTty defaultOutputOptionsNoColor @@ -413,6 +463,7 @@ -- wow -- -- @since 2.0.2.0 +{-# WARNING pTraceMNoColor "'pTraceMNoColor' remains in code" #-} #if __GLASGOW_HASKELL__ < 800 pTraceMNoColor :: (Monad f) => String -> f () #else @@ -428,6 +479,7 @@ -- ] -- -- @since 2.0.2.0 +{-# WARNING pTraceShowMNoColor "'pTraceShowMNoColor' remains in code" #-} #if __GLASGOW_HASKELL__ < 800 pTraceShowMNoColor :: (Show a, Monad f) => a -> f () #else @@ -442,18 +494,21 @@ -- () -- -- @since 2.0.2.0 +{-# WARNING pTraceStackNoColor "'pTraceStackNoColor' remains in code" #-} pTraceStackNoColor :: String -> a -> a 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 = pTraceEventOpt NoCheckColorTty defaultOutputOptionsNoColor -- | Similar to 'pTraceEventIO', but without color. -- -- @since 2.0.2.0 +{-# WARNING pTraceEventIONoColor "'pTraceEventIONoColor' remains in code" #-} pTraceEventIONoColor :: String -> IO () pTraceEventIONoColor = pTraceEventOptIO NoCheckColorTty defaultOutputOptionsNoColor @@ -461,6 +516,7 @@ -- | Similar to 'pTraceMarker', but without color. -- -- @since 2.0.2.0 +{-# WARNING pTraceMarkerNoColor "'pTraceMarkerNoColor' remains in code" #-} pTraceMarkerNoColor :: String -> a -> a pTraceMarkerNoColor = pTraceMarkerOpt NoCheckColorTty defaultOutputOptionsNoColor @@ -468,6 +524,7 @@ -- | Similar to 'pTraceMarkerIO', but without color. -- -- @since 2.0.2.0 +{-# WARNING pTraceMarkerIONoColor "'pTraceMarkerIONoColor' remains in code" #-} pTraceMarkerIONoColor :: String -> IO () pTraceMarkerIONoColor = pTraceMarkerOptIO NoCheckColorTty defaultOutputOptionsNoColor @@ -481,6 +538,7 @@ -- ) -- -- @since 2.0.2.0 +{-# WARNING pTraceIONoColor "'pTraceIONoColor' remains in code" #-} pTraceIONoColor :: String -> IO () pTraceIONoColor = pTraceOptIO NoCheckColorTty defaultOutputOptionsNoColor @@ -490,6 +548,7 @@ {-| 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 @@ -497,6 +556,7 @@ {-| 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 @@ -504,6 +564,7 @@ {-| 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 @@ -511,6 +572,7 @@ {-| 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 @@ -518,12 +580,14 @@ {-| 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 @@ -535,6 +599,7 @@ {-| Like 'pTraceShowM' but takes OutputOptions. -} +{-# WARNING pTraceShowOptM "'pTraceShowOptM' remains in code" #-} #if __GLASGOW_HASKELL__ < 800 pTraceShowOptM :: (Show a, Monad f) => CheckColorTty -> OutputOptions -> a -> f () @@ -548,6 +613,7 @@ {-| 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 @@ -555,6 +621,7 @@ {-| 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 @@ -562,6 +629,7 @@ {-| Like 'pTraceEventIO' but takes OutputOptions. -} +{-# WARNING pTraceEventOptIO "'pTraceEventOptIO' remains in code" #-} pTraceEventOptIO :: CheckColorTty -> OutputOptions -> String -> IO () pTraceEventOptIO checkColorTty outputOptions = traceEventIO . unpack <=< pStringTTYOptIO checkColorTty outputOptions @@ -569,6 +637,7 @@ {-| 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 @@ -576,6 +645,7 @@ {-| 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 @@ -99,9 +97,13 @@ , defaultOutputOptionsNoColor , CheckColorTty(..) -- * 'ColorOptions' - -- $colorOptions , defaultColorOptionsDarkBg , defaultColorOptionsLightBg + , ColorOptions(..) + , Style(..) + , Color(..) + , Intensity(..) + , colorNull -- * Examples -- $examples ) where @@ -113,17 +115,20 @@ #endif import Control.Monad.IO.Class (MonadIO, liftIO) -import Data.Foldable (toList) import Data.Text.Lazy (Text) -import Data.Text.Lazy.IO as LText -import System.IO (Handle, stdout) +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 - (CheckColorTty(..), OutputOptions(..), StringOutputStyle(..), + (ColorOptions(..), Style(..), CheckColorTty(..), + OutputOptions(..), StringOutputStyle(..), + convertStyle, colorNull, defaultColorOptionsDarkBg, defaultColorOptionsLightBg, defaultOutputOptionsDarkBg, defaultOutputOptionsLightBg, - defaultOutputOptionsNoColor, hCheckTTY, expressionParse, - expressionsToOutputs, render) + defaultOutputOptionsNoColor, hCheckTTY, layoutString) -- $setup -- >>> import Data.Text.Lazy (unpack) @@ -519,7 +524,9 @@ case checkColorTty of CheckColorTty -> hCheckTTY handle outputOptions NoCheckColorTty -> pure outputOptions - liftIO $ LText.hPutStrLn handle $ pStringOpt realOutputOpts str + liftIO $ do + renderIO handle $ layoutStringAnsi realOutputOpts str + hPutStrLn handle "" -- | Like 'pShow' but takes 'OutputOptions' to change how the -- pretty-printing is done. @@ -529,13 +536,10 @@ -- | Like 'pString' but takes 'OutputOptions' to change how the -- pretty-printing is done. pStringOpt :: OutputOptions -> String -> Text -pStringOpt outputOptions = - render outputOptions . toList . expressionsToOutputs . expressionParse +pStringOpt outputOptions = renderLazy . layoutStringAnsi outputOptions --- $colorOptions --- --- Additional settings for color options can be found in --- "Text.Pretty.Simple.Internal.Color". +layoutStringAnsi :: OutputOptions -> String -> SimpleDocStream AnsiStyle +layoutStringAnsi opts = fmap convertStyle . layoutString opts -- $examples -- @@ -653,6 +657,73 @@ -- , "ヤギ" -- ] -- } +-- +-- __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__ -- 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 + , colorError :: Style + -- ^ Color for errors, e.g. unmatched brackets. + , colorNum :: Style -- ^ Color to use for numbers. - , colorRainbowParens :: [Builder] - -- ^ A list of 'Builder' colors to use for rainbow parenthesis output. Use + , colorRainbowParens :: [Style] + -- ^ A list of colors to use for rainbow parenthesis output. Use -- '[]' if you don't want rainbow parenthesis. Use just a single item if you -- want all the rainbow parenthesis to be colored the same. } deriving (Eq, Generic, Show, Typeable) ------------------------------------- --- Dark background default colors -- ------------------------------------- - -- | Default color options for use on a dark background. --- --- 'colorQuote' is 'defaultColorQuoteDarkBg'. 'colorString' is --- 'defaultColorStringDarkBg'. 'colorError' is 'defaultColorErrorDarkBg'. --- 'colorNum' is 'defaultColorNumDarkBg'. 'colorRainbowParens' is --- 'defaultColorRainboxParensDarkBg'. defaultColorOptionsDarkBg :: ColorOptions defaultColorOptionsDarkBg = ColorOptions - { colorQuote = defaultColorQuoteDarkBg - , colorString = defaultColorStringDarkBg - , colorError = defaultColorErrorDarkBg - , colorNum = defaultColorNumDarkBg - , colorRainbowParens = defaultColorRainbowParensDarkBg + { colorQuote = colorBold Vivid White + , colorString = colorBold Vivid Blue + , colorError = colorBold Vivid Red + , colorNum = colorBold Vivid Green + , colorRainbowParens = + [ colorBold Vivid Magenta + , colorBold Vivid Cyan + , colorBold Vivid Yellow + , color Dull Magenta + , color Dull Cyan + , color Dull Yellow + , colorBold Dull Magenta + , colorBold Dull Cyan + , colorBold Dull Yellow + , color Vivid Magenta + , color Vivid Cyan + , color Vivid Yellow + ] } --- | Default color for 'colorQuote' for dark backgrounds. This is --- 'colorVividWhiteBold'. -defaultColorQuoteDarkBg :: Builder -defaultColorQuoteDarkBg = colorVividWhiteBold - --- | Default color for 'colorString' for dark backgrounds. This is --- 'colorVividBlueBold'. -defaultColorStringDarkBg :: Builder -defaultColorStringDarkBg = colorVividBlueBold - --- | Default color for 'colorError' for dark backgrounds. This is --- 'colorVividRedBold'. -defaultColorErrorDarkBg :: Builder -defaultColorErrorDarkBg = colorVividRedBold - --- | Default color for 'colorNum' for dark backgrounds. This is --- 'colorVividGreenBold'. -defaultColorNumDarkBg :: Builder -defaultColorNumDarkBg = colorVividGreenBold - --- | Default colors for 'colorRainbowParens' for dark backgrounds. -defaultColorRainbowParensDarkBg :: [Builder] -defaultColorRainbowParensDarkBg = - [ colorVividMagentaBold - , colorVividCyanBold - , colorVividYellowBold - , colorDullMagenta - , colorDullCyan - , colorDullYellow - , colorDullMagentaBold - , colorDullCyanBold - , colorDullYellowBold - , colorVividMagenta - , colorVividCyan - , colorVividYellow - ] - -------------------------------------- --- Light background default colors -- -------------------------------------- - -- | Default color options for use on a light background. --- --- 'colorQuote' is 'defaultColorQuoteLightBg'. 'colorString' is --- 'defaultColorStringLightBg'. 'colorError' is 'defaultColorErrorLightBg'. --- 'colorNum' is 'defaultColorNumLightBg'. 'colorRainbowParens' is --- 'defaultColorRainboxParensLightBg'. defaultColorOptionsLightBg :: ColorOptions defaultColorOptionsLightBg = ColorOptions - { colorQuote = defaultColorQuoteLightBg - , colorString = defaultColorStringLightBg - , colorError = defaultColorErrorLightBg - , colorNum = defaultColorNumLightBg - , colorRainbowParens = defaultColorRainbowParensLightBg + { colorQuote = colorBold Vivid Black + , colorString = colorBold Vivid Blue + , colorError = colorBold Vivid Red + , colorNum = colorBold Vivid Green + , colorRainbowParens = + [ colorBold Vivid Magenta + , colorBold Vivid Cyan + , color Dull Magenta + , color Dull Cyan + , colorBold Dull Magenta + , colorBold Dull Cyan + , color Vivid Magenta + , color Vivid Cyan + ] } --- | Default color for 'colorQuote' for light backgrounds. This is --- 'colorVividWhiteBold'. -defaultColorQuoteLightBg :: Builder -defaultColorQuoteLightBg = colorVividBlackBold - --- | Default color for 'colorString' for light backgrounds. This is --- 'colorVividBlueBold'. -defaultColorStringLightBg :: Builder -defaultColorStringLightBg = colorVividBlueBold - --- | Default color for 'colorError' for light backgrounds. This is --- 'colorVividRedBold'. -defaultColorErrorLightBg :: Builder -defaultColorErrorLightBg = colorVividRedBold - --- | Default color for 'colorNum' for light backgrounds. This is --- 'colorVividGreenBold'. -defaultColorNumLightBg :: Builder -defaultColorNumLightBg = colorVividGreenBold - --- | Default colors for 'colorRainbowParens' for light backgrounds. -defaultColorRainbowParensLightBg :: [Builder] -defaultColorRainbowParensLightBg = - [ colorVividMagentaBold - , colorVividCyanBold - , colorDullMagenta - , colorDullCyan - , colorDullMagentaBold - , colorDullCyanBold - , colorVividMagenta - , colorVividCyan - ] - ------------------------ --- Vivid Bold Colors -- ------------------------ - -colorVividBlackBold :: Builder -colorVividBlackBold = colorBold `mappend` colorVividBlack - -colorVividBlueBold :: Builder -colorVividBlueBold = colorBold `mappend` colorVividBlue - -colorVividCyanBold :: Builder -colorVividCyanBold = colorBold `mappend` colorVividCyan - -colorVividGreenBold :: Builder -colorVividGreenBold = colorBold `mappend` colorVividGreen - -colorVividMagentaBold :: Builder -colorVividMagentaBold = colorBold `mappend` colorVividMagenta - -colorVividRedBold :: Builder -colorVividRedBold = colorBold `mappend` colorVividRed - -colorVividWhiteBold :: Builder -colorVividWhiteBold = colorBold `mappend` colorVividWhite - -colorVividYellowBold :: Builder -colorVividYellowBold = colorBold `mappend` colorVividYellow - ------------------------ --- Dull Bold Colors -- ------------------------ - -colorDullBlackBold :: Builder -colorDullBlackBold = colorBold `mappend` colorDullBlack - -colorDullBlueBold :: Builder -colorDullBlueBold = colorBold `mappend` colorDullBlue - -colorDullCyanBold :: Builder -colorDullCyanBold = colorBold `mappend` colorDullCyan - -colorDullGreenBold :: Builder -colorDullGreenBold = colorBold `mappend` colorDullGreen - -colorDullMagentaBold :: Builder -colorDullMagentaBold = colorBold `mappend` colorDullMagenta - -colorDullRedBold :: Builder -colorDullRedBold = colorBold `mappend` colorDullRed - -colorDullWhiteBold :: Builder -colorDullWhiteBold = colorBold `mappend` colorDullWhite - -colorDullYellowBold :: Builder -colorDullYellowBold = colorBold `mappend` colorDullYellow - ------------------- --- Vivid Colors -- ------------------- - -colorVividBlack :: Builder -colorVividBlack = colorHelper Vivid Black - -colorVividBlue :: Builder -colorVividBlue = colorHelper Vivid Blue - -colorVividCyan :: Builder -colorVividCyan = colorHelper Vivid Cyan - -colorVividGreen :: Builder -colorVividGreen = colorHelper Vivid Green - -colorVividMagenta :: Builder -colorVividMagenta = colorHelper Vivid Magenta - -colorVividRed :: Builder -colorVividRed = colorHelper Vivid Red - -colorVividWhite :: Builder -colorVividWhite = colorHelper Vivid White - -colorVividYellow :: Builder -colorVividYellow = colorHelper Vivid Yellow - ------------------- --- Dull Colors -- ------------------- - -colorDullBlack :: Builder -colorDullBlack = colorHelper Dull Black - -colorDullBlue :: Builder -colorDullBlue = colorHelper Dull Blue - -colorDullCyan :: Builder -colorDullCyan = colorHelper Dull Cyan - -colorDullGreen :: Builder -colorDullGreen = colorHelper Dull Green - -colorDullMagenta :: Builder -colorDullMagenta = colorHelper Dull Magenta - -colorDullRed :: Builder -colorDullRed = colorHelper Dull Red - -colorDullWhite :: Builder -colorDullWhite = colorHelper Dull White - -colorDullYellow :: Builder -colorDullYellow = colorHelper Dull Yellow - --------------------- --- Special Colors -- --------------------- - --- | Change the intensity to 'BoldIntensity'. -colorBold :: Builder -colorBold = setSGRCodeBuilder [SetConsoleIntensity BoldIntensity] - --- | 'Reset' the console color back to normal. -colorReset :: Builder -colorReset = setSGRCodeBuilder [Reset] - --- | Empty string. -colorNull :: Builder -colorNull = "" +-- | No styling. +colorNull :: Style +colorNull = Style + { styleColor = Nothing + , styleBold = False + , styleItalic = False + , styleUnderlined = False + } -------------- --- Helpers -- -------------- +-- | Ways to style terminal output. +data Style = Style + { styleColor :: Maybe (Color, Intensity) + , styleBold :: Bool + , styleItalic :: Bool + , styleUnderlined :: Bool + } + deriving (Eq, Generic, Show, Typeable) --- | Helper for creating a 'Builder' for an ANSI escape sequence color based on --- a 'ColorIntensity' and a 'Color'. -colorHelper :: ColorIntensity -> Color -> Builder -colorHelper colorIntensity color = - setSGRCodeBuilder [SetColor Foreground colorIntensity color] +color :: Intensity -> Color -> Style +color i c = colorNull {styleColor = Just (c, i)} --- | Convert a list of 'SGR' to a 'Builder'. -setSGRCodeBuilder :: [SGR] -> Builder -setSGRCodeBuilder = fromString . setSGRCode +colorBold :: Intensity -> Color -> Style +colorBold i c = (color i c) {styleBold = True} +convertStyle :: Style -> AnsiStyle +convertStyle Style {..} = + mconcat + [ maybe mempty (uncurry $ flip col) styleColor + , if styleBold then Ansi.bold else mempty + , if styleItalic then Ansi.italicized else mempty + , if styleUnderlined then Ansi.underlined else mempty + ] + where + col = \case + Vivid -> Ansi.color + Dull -> Ansi.colorDull diff --git a/src/Text/Pretty/Simple/Internal/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 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 diff --git a/src/Text/Pretty/Simple/Internal/ExprToOutput.hs b/src/Text/Pretty/Simple/Internal/ExprToOutput.hs deleted file mode 100644 --- a/src/Text/Pretty/Simple/Internal/ExprToOutput.hs +++ /dev/null @@ -1,296 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} - -{-| -Module : Text.Pretty.Simple.Internal.Printer -Copyright : (c) Dennis Gosnell, 2016 -License : BSD-style (see LICENSE file) -Maintainer : cdep.illabout@gmail.com -Stability : experimental -Portability : POSIX - --} -module Text.Pretty.Simple.Internal.ExprToOutput - where - -#if __GLASGOW_HASKELL__ < 710 --- We don't need this import for GHC 7.10 as it exports all required functions --- from Prelude -import Control.Applicative -#endif - -import Control.Monad (when) -import Control.Monad.State (MonadState, evalState, gets, modify) -import Data.Data (Data) -import Data.Monoid ((<>)) -import Data.List (intersperse) -import Data.Typeable (Typeable) -import GHC.Generics (Generic) - -import Text.Pretty.Simple.Internal.Expr (CommaSeparated(..), Expr(..)) -import Text.Pretty.Simple.Internal.Output - (NestLevel(..), Output(..), OutputType(..), unNestLevel) - --- $setup --- >>> :set -XOverloadedStrings --- >>> import Control.Monad.State (State) --- >>> :{ --- let test :: PrinterState -> State PrinterState [Output] -> [Output] --- test initState state = evalState state initState --- testInit :: State PrinterState [Output] -> [Output] --- testInit = test initPrinterState --- :} - --- | Newtype around 'Int' to represent a line number. After a newline, the --- 'LineNum' will increase by 1. -newtype LineNum = LineNum { unLineNum :: Int } - deriving (Data, Eq, Generic, Num, Ord, Read, Show, Typeable) - -data PrinterState = PrinterState - { currLine :: {-# UNPACK #-} !LineNum - , nestLevel :: {-# UNPACK #-} !NestLevel - } deriving (Eq, Data, Generic, Show, Typeable) - --- | Smart-constructor for 'PrinterState'. -printerState :: LineNum -> NestLevel -> PrinterState -printerState currLineNum nestNum = - PrinterState - { currLine = currLineNum - , nestLevel = nestNum - } - - -addOutput - :: MonadState PrinterState m - => OutputType -> m Output -addOutput outputType = do - nest <- gets nestLevel - return $ Output nest outputType - -addOutputs - :: MonadState PrinterState m - => [OutputType] -> m [Output] -addOutputs outputTypes = do - nest <- gets nestLevel - return $ Output nest <$> outputTypes - -initPrinterState :: PrinterState -initPrinterState = printerState 0 (-1) - --- | Print a surrounding expression (like @\[\]@ or @\{\}@ or @\(\)@). --- --- If the 'CommaSeparated' expressions are empty, just print the start and end --- markers. --- --- >>> testInit $ putSurroundExpr "[" "]" (CommaSeparated []) --- [Output {outputNestLevel = NestLevel {unNestLevel = 0}, outputOutputType = OutputOpenBracket},Output {outputNestLevel = NestLevel {unNestLevel = 0}, outputOutputType = OutputCloseBracket}] --- --- If there is only one expression, and it will print out on one line, then --- just print everything all on one line, with spaces around the expressions. --- --- >>> testInit $ putSurroundExpr "{" "}" (CommaSeparated [[Other "hello"]]) --- [Output {outputNestLevel = NestLevel {unNestLevel = 0}, outputOutputType = OutputOpenBrace},Output {outputNestLevel = NestLevel {unNestLevel = 0}, outputOutputType = OutputOther " "},Output {outputNestLevel = NestLevel {unNestLevel = 0}, outputOutputType = OutputOther "hello"},Output {outputNestLevel = NestLevel {unNestLevel = 0}, outputOutputType = OutputOther " "},Output {outputNestLevel = NestLevel {unNestLevel = 0}, outputOutputType = OutputCloseBrace}] --- --- If there is only one expression, but it will print out on multiple lines, --- then go to newline and print out on multiple lines. --- --- >>> 1 + 1 -- TODO: Example here. --- 2 --- --- If there are multiple expressions, then first go to a newline. --- Print out on multiple lines. --- --- >>> 1 + 1 -- TODO: Example here. --- 2 -putSurroundExpr - :: MonadState PrinterState m - => OutputType - -> OutputType - -> CommaSeparated [Expr] -- ^ comma separated inner expression. - -> m [Output] -putSurroundExpr startOutputType endOutputType (CommaSeparated []) = do - addToNestLevel 1 - outputs <- addOutputs [startOutputType, endOutputType] - addToNestLevel (-1) - return outputs -putSurroundExpr startOutputType endOutputType (CommaSeparated [exprs]) = do - addToNestLevel 1 - let (thisLayerMulti, nextLayerMulti) = thisAndNextMulti exprs - - maybeNL <- if thisLayerMulti - then newLineAndDoIndent - else return [] - start <- addOutputs [startOutputType, OutputOther " "] - middle <- concat <$> traverse putExpression exprs - nlOrSpace <- if nextLayerMulti - then newLineAndDoIndent - else (:[]) <$> (addOutput $ OutputOther " ") - end <- addOutput endOutputType - - addToNestLevel (-1) - - return $ maybeNL <> start <> middle <> nlOrSpace <> [end] - where - thisAndNextMulti = (\(a,b) -> (or a, or b)) . unzip . map isMultiLine - - isMultiLine (Brackets commaSeparated) = isMultiLine' commaSeparated - isMultiLine (Braces commaSeparated) = isMultiLine' commaSeparated - isMultiLine (Parens commaSeparated) = isMultiLine' commaSeparated - isMultiLine _ = (False, False) - - isMultiLine' (CommaSeparated []) = (False, False) - isMultiLine' (CommaSeparated [es]) = (True, fst $ thisAndNextMulti es) - isMultiLine' _ = (True, True) -putSurroundExpr startOutputType endOutputType commaSeparated = do - addToNestLevel 1 - nl <- newLineAndDoIndent - start <- addOutputs [startOutputType, OutputOther " "] - middle <- putCommaSep commaSeparated - nl2 <- newLineAndDoIndent - end <- addOutput endOutputType - addToNestLevel (-1) - endSpace <- addOutput $ OutputOther " " - - return $ nl <> start <> middle <> nl2 <> [end, endSpace] - - -putCommaSep - :: forall m. - MonadState PrinterState m - => CommaSeparated [Expr] -> m [Output] -putCommaSep (CommaSeparated expressionsList) = - concat <$> (sequence $ intersperse putComma evaledExpressionList) - where - evaledExpressionList :: [m [Output]] - evaledExpressionList = - (concat <.> traverse putExpression) <$> expressionsList - - (f <.> g) x = f <$> g x - -putComma - :: MonadState PrinterState m - => m [Output] -putComma = do - nl <- newLineAndDoIndent - outputs <- addOutputs [OutputComma, OutputOther " "] - return $ nl <> outputs - -doIndent :: MonadState PrinterState m => m [Output] -doIndent = do - nest <- gets $ unNestLevel . nestLevel - addOutputs $ replicate nest OutputIndent - -newLine - :: MonadState PrinterState m - => m Output -newLine = do - output <- addOutput OutputNewLine - addToCurrentLine 1 - return output - -newLineAndDoIndent - :: MonadState PrinterState m - => m [Output] -newLineAndDoIndent = do - nl <- newLine - indent <- doIndent - return $ nl:indent - -addToNestLevel - :: MonadState PrinterState m - => NestLevel -> m () -addToNestLevel diff = - modify (\printState -> printState {nestLevel = nestLevel printState + diff}) - -addToCurrentLine - :: MonadState PrinterState m - => LineNum -> m () -addToCurrentLine diff = - modify (\printState -> printState {currLine = currLine printState + diff}) - -putExpression :: MonadState PrinterState m => Expr -> m [Output] -putExpression (Brackets commaSeparated) = - putSurroundExpr OutputOpenBracket OutputCloseBracket commaSeparated -putExpression (Braces commaSeparated) = - putSurroundExpr OutputOpenBrace OutputCloseBrace commaSeparated -putExpression (Parens commaSeparated) = - putSurroundExpr OutputOpenParen OutputCloseParen commaSeparated -putExpression (StringLit string) = do - nest <- gets nestLevel - when (nest < 0) $ addToNestLevel 1 - addOutputs [OutputStringLit string, OutputOther " "] -putExpression (CharLit string) = do - nest <- gets nestLevel - when (nest < 0) $ addToNestLevel 1 - addOutputs [OutputCharLit string, OutputOther " "] -putExpression (NumberLit integer) = do - nest <- gets nestLevel - when (nest < 0) $ addToNestLevel 1 - (:[]) <$> (addOutput $ OutputNumberLit integer) -putExpression (Other string) = do - nest <- gets nestLevel - when (nest < 0) $ addToNestLevel 1 - (:[]) <$> (addOutput $ OutputOther string) - -runPrinterState :: PrinterState -> [Expr] -> [Output] -runPrinterState initState expressions = - concat $ evalState (traverse putExpression expressions) initState - -runInitPrinterState :: [Expr] -> [Output] -runInitPrinterState = runPrinterState initPrinterState - -expressionsToOutputs :: [Expr] -> [Output] -expressionsToOutputs = runInitPrinterState . modificationsExprList - --- | A function that performs optimizations and modifications to a list of --- input 'Expr's. --- --- An sample of an optimization is 'removeEmptyInnerCommaSeparatedExprList' --- which removes empty inner lists in a 'CommaSeparated' value. -modificationsExprList :: [Expr] -> [Expr] -modificationsExprList = removeEmptyInnerCommaSeparatedExprList - -removeEmptyInnerCommaSeparatedExprList :: [Expr] -> [Expr] -removeEmptyInnerCommaSeparatedExprList = fmap removeEmptyInnerCommaSeparatedExpr - -removeEmptyInnerCommaSeparatedExpr :: Expr -> Expr -removeEmptyInnerCommaSeparatedExpr (Brackets commaSeparated) = - Brackets $ removeEmptyInnerCommaSeparated commaSeparated -removeEmptyInnerCommaSeparatedExpr (Braces commaSeparated) = - Braces $ removeEmptyInnerCommaSeparated commaSeparated -removeEmptyInnerCommaSeparatedExpr (Parens commaSeparated) = - Parens $ removeEmptyInnerCommaSeparated commaSeparated -removeEmptyInnerCommaSeparatedExpr other = other - -removeEmptyInnerCommaSeparated :: CommaSeparated [Expr] -> CommaSeparated [Expr] -removeEmptyInnerCommaSeparated (CommaSeparated commaSeps) = - CommaSeparated . fmap removeEmptyInnerCommaSeparatedExprList $ - removeEmptyList commaSeps - --- | Remove empty lists from a list of lists. --- --- >>> removeEmptyList [[1,2,3], [], [4,5]] --- [[1,2,3],[4,5]] --- --- >>> removeEmptyList [[]] --- [] --- --- >>> removeEmptyList [[1]] --- [[1]] --- --- >>> removeEmptyList [[1,2], [10,20], [100,200]] --- [[1,2],[10,20],[100,200]] -removeEmptyList :: forall a . [[a]] -> [[a]] -removeEmptyList = foldr f [] - where - f :: [a] -> [[a]] -> [[a]] - f [] accum = accum - f a accum = [a] <> accum diff --git a/src/Text/Pretty/Simple/Internal/Output.hs b/src/Text/Pretty/Simple/Internal/Output.hs deleted file mode 100644 --- a/src/Text/Pretty/Simple/Internal/Output.hs +++ /dev/null @@ -1,99 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} - -{-| -Module : Text.Pretty.Simple.Internal.Output -Copyright : (c) Dennis Gosnell, 2016 -License : BSD-style (see LICENSE file) -Maintainer : cdep.illabout@gmail.com -Stability : experimental -Portability : POSIX - --} -module Text.Pretty.Simple.Internal.Output - where - -#if __GLASGOW_HASKELL__ < 710 --- We don't need this import for GHC 7.10 as it exports all required functions --- from Prelude -import Control.Applicative -#endif - -import Data.Data (Data) -import Data.String (IsString, fromString) -import Data.Typeable (Typeable) -import GHC.Generics (Generic) - --- | Datatype representing how much something is nested. --- --- For example, a 'NestLevel' of 0 would mean an 'Output' token --- is at the very highest level, not in any braces. --- --- A 'NestLevel' of 1 would mean that an 'Output' token is in one single pair --- of @\{@ and @\}@, or @\[@ and @\], or @\(@ and @\)@. --- --- A 'NestLevel' of 2 would mean that an 'Output' token is two levels of --- brackets, etc. -newtype NestLevel = NestLevel { unNestLevel :: Int } - deriving (Data, Eq, Generic, Num, Ord, Read, Show, Typeable) - --- | These are the output tokens that we will be printing to the screen. -data OutputType - = OutputCloseBrace - -- ^ This represents the @\}@ character. - | OutputCloseBracket - -- ^ This represents the @\]@ character. - | OutputCloseParen - -- ^ This represents the @\)@ character. - | OutputComma - -- ^ This represents the @\,@ character. - | OutputIndent - -- ^ This represents an indentation. - | OutputNewLine - -- ^ This represents the @\\n@ character. - | OutputOpenBrace - -- ^ This represents the @\{@ character. - | OutputOpenBracket - -- ^ This represents the @\[@ character. - | OutputOpenParen - -- ^ This represents the @\(@ character. - | OutputOther !String - -- ^ This represents some collection of characters that don\'t fit into any - -- of the other tokens. - | OutputStringLit !String - -- ^ This represents a string literal. For instance, @\"foobar\"@. - | OutputCharLit !String - -- ^ This represents a char literal. For example, @'x'@ or @'\b'@ - | OutputNumberLit !String - -- ^ This represents a numeric literal. For example, @12345@ or @3.14159@. - deriving (Data, Eq, Generic, Read, Show, Typeable) - --- | 'IsString' (and 'fromString') should generally only be used in tests and --- debugging. There is no way to represent 'OutputIndent', 'OutputNumberLit' --- and 'OutputStringLit'. -instance IsString OutputType where - fromString :: String -> OutputType - fromString "}" = OutputCloseBrace - fromString "]" = OutputCloseBracket - fromString ")" = OutputCloseParen - fromString "," = OutputComma - fromString "\n" = OutputNewLine - fromString "{" = OutputOpenBrace - fromString "[" = OutputOpenBracket - fromString "(" = OutputOpenParen - fromString string = OutputOther string - --- | An 'OutputType' token together with a 'NestLevel'. Basically, each --- 'OutputType' keeps track of its own 'NestLevel'. -data Output = Output - { outputNestLevel :: {-# UNPACK #-} !NestLevel - , outputOutputType :: !OutputType - } deriving (Data, Eq, Generic, Read, Show, Typeable) diff --git a/src/Text/Pretty/Simple/Internal/OutputPrinter.hs b/src/Text/Pretty/Simple/Internal/OutputPrinter.hs deleted file mode 100644 --- a/src/Text/Pretty/Simple/Internal/OutputPrinter.hs +++ /dev/null @@ -1,410 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} - -{-| -Module : Text.Pretty.Simple.Internal.OutputPrinter -Copyright : (c) Dennis Gosnell, 2016 -License : BSD-style (see LICENSE file) -Maintainer : cdep.illabout@gmail.com -Stability : experimental -Portability : POSIX - --} -module Text.Pretty.Simple.Internal.OutputPrinter - where - -#if __GLASGOW_HASKELL__ < 710 --- We don't need this import for GHC 7.10 as it exports all required functions --- from Prelude -import Control.Applicative -#endif - -import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Reader (MonadReader(ask, reader), runReader) -import Data.Char (isPrint, isSpace, ord) -import Numeric (showHex) -import Data.Foldable (fold) -import Data.Text.Lazy (Text) -import Data.Text.Lazy.Builder (Builder, fromString, toLazyText) -import Data.Typeable (Typeable) -import Data.List (dropWhileEnd, intercalate) -import Data.Maybe (fromMaybe) -import Text.Read (readMaybe) -import GHC.Generics (Generic) -import System.IO (Handle, hIsTerminalDevice) - -import Text.Pretty.Simple.Internal.Color - (ColorOptions(..), colorReset, defaultColorOptionsDarkBg, - defaultColorOptionsLightBg) -import Text.Pretty.Simple.Internal.Output - (NestLevel(..), Output(..), OutputType(..)) - --- $setup --- >>> import Text.Pretty.Simple (pPrintString, pPrintStringOpt) - --- | Determines whether pretty-simple should check if the output 'Handle' is a --- TTY device. Normally, users only want to print in color if the output --- 'Handle' is a TTY device. -data CheckColorTty - = CheckColorTty - -- ^ Check if the output 'Handle' is a TTY device. If the output 'Handle' is - -- a TTY device, determine whether to print in color based on - -- 'outputOptionsColorOptions'. If not, then set 'outputOptionsColorOptions' - -- to 'Nothing' so the output does not get colorized. - | NoCheckColorTty - -- ^ Don't check if the output 'Handle' is a TTY device. Determine whether to - -- colorize the output based solely on the value of - -- 'outputOptionsColorOptions'. - deriving (Eq, Generic, Show, Typeable) - --- | Control how escaped and non-printable are output for strings. --- --- See 'outputOptionsStringStyle' for what the output looks like with each of --- these options. -data StringOutputStyle - = Literal - -- ^ Output string literals by printing the source characters exactly. - -- - -- For examples: without this option the printer will insert a newline in - -- place of @"\n"@, with this options the printer will output @'\'@ and - -- @'n'@. Similarly the exact escape codes used in the input string will be - -- replicated, so @"\65"@ will be printed as @"\65"@ and not @"A"@. - | EscapeNonPrintable - -- ^ Replace non-printable characters with hexadecimal escape sequences. - | DoNotEscapeNonPrintable - -- ^ Output non-printable characters without modification. - deriving (Eq, Generic, Show, Typeable) - --- | Data-type wrapping up all the options available when rendering the list --- of 'Output's. -data OutputOptions = OutputOptions - { outputOptionsIndentAmount :: Int - -- ^ Number of spaces to use when indenting. It should probably be either 2 - -- or 4. - , outputOptionsColorOptions :: Maybe ColorOptions - -- ^ If this is 'Nothing', then don't colorize the output. If this is - -- @'Just' colorOptions@, then use @colorOptions@ to colorize the output. - -- - , outputOptionsStringStyle :: StringOutputStyle - -- ^ Controls how string literals are output. - -- - -- By default, the pPrint functions escape non-printable characters, but - -- print all printable characters: - -- - -- >>> pPrintString "\"A \\x42 Ä \\xC4 \\x1 \\n\"" - -- "A B Ä Ä \x1 " - -- - -- Here, you can see that the character @A@ has been printed as-is. @\x42@ - -- has been printed in the non-escaped version, @B@. The non-printable - -- character @\x1@ has been printed as @\x1@. Newlines will be removed to - -- make the output easier to read. - -- - -- This corresponds to the 'StringOutputStyle' called 'EscapeNonPrintable'. - -- - -- (Note that in the above and following examples, the characters have to be - -- double-escaped, which makes it somewhat confusing...) - -- - -- Another output style is 'DoNotEscapeNonPrintable'. This is similar - -- to 'EscapeNonPrintable', except that non-printable characters get printed - -- out literally to the screen. - -- - -- >>> pPrintStringOpt CheckColorTty defaultOutputOptionsDarkBg{ outputOptionsStringStyle = DoNotEscapeNonPrintable } "\"A \\x42 Ä \\xC4 \\n\"" - -- "A B Ä Ä " - -- - -- If you change the above example to contain @\x1@, you can see that it is - -- output as a literal, non-escaped character. Newlines are still removed - -- for readability. - -- - -- Another output style is 'Literal'. This just outputs all escape characters. - -- - -- >>> pPrintStringOpt CheckColorTty defaultOutputOptionsDarkBg{ outputOptionsStringStyle = Literal } "\"A \\x42 Ä \\xC4 \\x1 \\n\"" - -- "A \x42 Ä \xC4 \x1 \n" - -- - -- You can see that all the escape characters get output literally, including - -- newline. - } deriving (Eq, Generic, Show, Typeable) - --- | Default values for 'OutputOptions' when printing to a console with a dark --- background. 'outputOptionsIndentAmount' is 4, and --- 'outputOptionsColorOptions' is 'defaultColorOptionsDarkBg'. -defaultOutputOptionsDarkBg :: OutputOptions -defaultOutputOptionsDarkBg = - OutputOptions - { outputOptionsIndentAmount = 4 - , outputOptionsColorOptions = Just defaultColorOptionsDarkBg - , outputOptionsStringStyle = EscapeNonPrintable - } - --- | Default values for 'OutputOptions' when printing to a console with a light --- background. 'outputOptionsIndentAmount' is 4, and --- 'outputOptionsColorOptions' is 'defaultColorOptionsLightBg'. -defaultOutputOptionsLightBg :: OutputOptions -defaultOutputOptionsLightBg = - OutputOptions - { outputOptionsIndentAmount = 4 - , outputOptionsColorOptions = Just defaultColorOptionsLightBg - , outputOptionsStringStyle = EscapeNonPrintable - } - --- | Default values for 'OutputOptions' when printing using using ANSI escape --- sequences for color. 'outputOptionsIndentAmount' is 4, and --- 'outputOptionsColorOptions' is 'Nothing'. -defaultOutputOptionsNoColor :: OutputOptions -defaultOutputOptionsNoColor = - OutputOptions - { outputOptionsIndentAmount = 4 - , outputOptionsColorOptions = Nothing - , outputOptionsStringStyle = EscapeNonPrintable - } - --- | Given 'OutputOptions', disable colorful output if the given handle --- is not connected to a TTY. -hCheckTTY :: MonadIO m => Handle -> OutputOptions -> m OutputOptions -hCheckTTY h options = liftIO $ conv <$> tty - where - conv :: Bool -> OutputOptions - conv True = options - conv False = options { outputOptionsColorOptions = Nothing } - - tty :: IO Bool - tty = hIsTerminalDevice h - --- | Given 'OutputOptions' and a list of 'Output', turn the 'Output' into a --- lazy 'Text'. -render :: OutputOptions -> [Output] -> Text -render options = toLazyText . foldr foldFunc "" . modificationsOutputList - where - foldFunc :: Output -> Builder -> Builder - foldFunc output accum = runReader (renderOutput output) options `mappend` accum - --- | Render a single 'Output' as a 'Builder', using the options specified in --- the 'OutputOptions'. -renderOutput :: MonadReader OutputOptions m => Output -> m Builder -renderOutput (Output nest OutputCloseBrace) = renderRainbowParenFor nest "}" -renderOutput (Output nest OutputCloseBracket) = renderRainbowParenFor nest "]" -renderOutput (Output nest OutputCloseParen) = renderRainbowParenFor nest ")" -renderOutput (Output nest OutputComma) = renderRainbowParenFor nest "," -renderOutput (Output _ OutputIndent) = do - indentSpaces <- reader outputOptionsIndentAmount - pure . mconcat $ replicate indentSpaces " " -renderOutput (Output _ OutputNewLine) = pure "\n" -renderOutput (Output nest OutputOpenBrace) = renderRainbowParenFor nest "{" -renderOutput (Output nest OutputOpenBracket) = renderRainbowParenFor nest "[" -renderOutput (Output nest OutputOpenParen) = renderRainbowParenFor nest "(" -renderOutput (Output _ (OutputOther string)) = do - indentSpaces <- reader outputOptionsIndentAmount - let spaces = replicate (indentSpaces + 2) ' ' - -- TODO: This probably shouldn't be a string to begin with. - pure $ fromString $ indentSubsequentLinesWith spaces string -renderOutput (Output _ (OutputNumberLit number)) = do - sequenceFold - [ useColorNum - , pure (fromString number) - , useColorReset - ] -renderOutput (Output _ (OutputStringLit string)) = do - options <- ask - - sequenceFold - [ useColorQuote - , pure "\"" - , useColorReset - , useColorString - -- TODO: This probably shouldn't be a string to begin with. - , pure (fromString (process options string)) - , useColorReset - , useColorQuote - , pure "\"" - , useColorReset - ] - where - process :: OutputOptions -> String -> String - process opts = case outputOptionsStringStyle opts of - Literal -> id - EscapeNonPrintable -> - indentSubsequentLinesWith spaces . escapeNonPrintable . readStr - DoNotEscapeNonPrintable -> indentSubsequentLinesWith spaces . readStr - where - spaces :: String - spaces = replicate (indentSpaces + 2) ' ' - - indentSpaces :: Int - indentSpaces = outputOptionsIndentAmount opts - - readStr :: String -> String - readStr s = fromMaybe s . readMaybe $ '"':s ++ "\"" -renderOutput (Output _ (OutputCharLit string)) = do - sequenceFold - [ useColorQuote - , pure "'" - , useColorReset - , useColorString - , pure (fromString string) - , useColorReset - , useColorQuote - , pure "'" - , useColorReset - ] - --- | Replace non-printable characters with hex escape sequences. --- --- >>> escapeNonPrintable "\x1\x2" --- "\\x1\\x2" --- --- Newlines will not be escaped. --- --- >>> escapeNonPrintable "hello\nworld" --- "hello\nworld" --- --- Printable characters will not be escaped. --- --- >>> escapeNonPrintable "h\101llo" --- "hello" -escapeNonPrintable :: String -> String -escapeNonPrintable input = foldr escape "" input - --- Replace an unprintable character except a newline --- with a hex escape sequence. -escape :: Char -> ShowS -escape c - | isPrint c || c == '\n' = (c:) - | otherwise = ('\\':) . ('x':) . showHex (ord c) - --- | --- >>> indentSubsequentLinesWith " " "aaa" --- "aaa" --- --- >>> indentSubsequentLinesWith " " "aaa\nbbb\nccc" --- "aaa\n bbb\n ccc" --- --- >>> indentSubsequentLinesWith " " "" --- "" -indentSubsequentLinesWith :: String -> String -> String -indentSubsequentLinesWith indent input = - intercalate "\n" $ (start ++) $ map (indent ++) $ end - where (start, end) = splitAt 1 $ lines input - --- | Produce a 'Builder' corresponding to the ANSI escape sequence for the --- color for the @\"@, based on whether or not 'outputOptionsColorOptions' is --- 'Just' or 'Nothing', and the value of 'colorQuote'. -useColorQuote :: forall m. MonadReader OutputOptions m => m Builder -useColorQuote = maybe "" colorQuote <$> reader outputOptionsColorOptions - --- | Produce a 'Builder' corresponding to the ANSI escape sequence for the --- color for the characters of a string, based on whether or not --- 'outputOptionsColorOptions' is 'Just' or 'Nothing', and the value of --- 'colorString'. -useColorString :: forall m. MonadReader OutputOptions m => m Builder -useColorString = maybe "" colorString <$> reader outputOptionsColorOptions - -useColorError :: forall m. MonadReader OutputOptions m => m Builder -useColorError = maybe "" colorError <$> reader outputOptionsColorOptions - -useColorNum :: forall m. MonadReader OutputOptions m => m Builder -useColorNum = maybe "" colorNum <$> reader outputOptionsColorOptions - --- | Produce a 'Builder' corresponding to the ANSI escape sequence for --- resetting the console color back to the default. Produces an empty 'Builder' --- if 'outputOptionsColorOptions' is 'Nothing'. -useColorReset :: forall m. MonadReader OutputOptions m => m Builder -useColorReset = maybe "" (const colorReset) <$> reader outputOptionsColorOptions - --- | Produce a 'Builder' representing the ANSI escape sequence for the color of --- the rainbow parenthesis, given an input 'NestLevel' and 'Builder' to use as --- the input character. --- --- If 'outputOptionsColorOptions' is 'Nothing', then just return the input --- character. If it is 'Just', then return the input character colorized. -renderRainbowParenFor - :: MonadReader OutputOptions m - => NestLevel -> Builder -> m Builder -renderRainbowParenFor nest string = - sequenceFold [useColorRainbowParens nest, pure string, useColorReset] - -useColorRainbowParens - :: forall m. - MonadReader OutputOptions m - => NestLevel -> m Builder -useColorRainbowParens nest = do - maybeOutputColor <- reader outputOptionsColorOptions - pure $ - case maybeOutputColor of - Just ColorOptions {colorRainbowParens} -> do - let choicesLen = length colorRainbowParens - if choicesLen == 0 - then "" - else colorRainbowParens !! (unNestLevel nest `mod` choicesLen) - Nothing -> "" - --- | This is simply @'fmap' 'fold' '.' 'sequence'@. -sequenceFold :: (Monad f, Monoid a, Traversable t) => t (f a) -> f a -sequenceFold = fmap fold . sequence - --- | A function that performs optimizations and modifications to a list of --- input 'Output's. --- --- An sample of an optimization is 'removeStartingNewLine' which just removes a --- newline if it is the first item in an 'Output' list. -modificationsOutputList :: [Output] -> [Output] -modificationsOutputList = - removeTrailingSpacesInOtherBeforeNewLine . shrinkWhitespaceInOthers . compressOthers . removeStartingNewLine - --- | Remove a 'OutputNewLine' if it is the first item in the 'Output' list. --- --- >>> removeStartingNewLine [Output 3 OutputNewLine, Output 3 OutputComma] --- [Output {outputNestLevel = NestLevel {unNestLevel = 3}, outputOutputType = OutputComma}] -removeStartingNewLine :: [Output] -> [Output] -removeStartingNewLine ((Output _ OutputNewLine) : t) = t -removeStartingNewLine outputs = outputs - --- | Remove trailing spaces from the end of a 'OutputOther' token if it is --- followed by a 'OutputNewLine', or if it is the final 'Output' in the list. --- This function assumes that there is a single 'OutputOther' before any --- 'OutputNewLine' (and before the end of the list), so it must be run after --- running 'compressOthers'. --- --- >>> removeTrailingSpacesInOtherBeforeNewLine [Output 2 (OutputOther "foo "), Output 4 OutputNewLine] --- [Output {outputNestLevel = NestLevel {unNestLevel = 2}, outputOutputType = OutputOther "foo"},Output {outputNestLevel = NestLevel {unNestLevel = 4}, outputOutputType = OutputNewLine}] -removeTrailingSpacesInOtherBeforeNewLine :: [Output] -> [Output] -removeTrailingSpacesInOtherBeforeNewLine [] = [] -removeTrailingSpacesInOtherBeforeNewLine (Output nest (OutputOther string):[]) = - (Output nest (OutputOther $ dropWhileEnd isSpace string)):[] -removeTrailingSpacesInOtherBeforeNewLine (Output nest (OutputOther string):nl@(Output _ OutputNewLine):t) = - (Output nest (OutputOther $ dropWhileEnd isSpace string)):nl:removeTrailingSpacesInOtherBeforeNewLine t -removeTrailingSpacesInOtherBeforeNewLine (h:t) = h : removeTrailingSpacesInOtherBeforeNewLine t - --- | If there are two subsequent 'OutputOther' tokens, combine them into just --- one 'OutputOther'. --- --- >>> compressOthers [Output 0 (OutputOther "foo"), Output 0 (OutputOther "bar")] --- [Output {outputNestLevel = NestLevel {unNestLevel = 0}, outputOutputType = OutputOther "foobar"}] -compressOthers :: [Output] -> [Output] -compressOthers [] = [] -compressOthers (Output _ (OutputOther string1):(Output nest (OutputOther string2)):t) = - compressOthers ((Output nest (OutputOther (string1 `mappend` string2))) : t) -compressOthers (h:t) = h : compressOthers t - --- | In each 'OutputOther' token, compress multiple whitespaces to just one --- whitespace. --- --- >>> shrinkWhitespaceInOthers [Output 0 (OutputOther " hello ")] --- [Output {outputNestLevel = NestLevel {unNestLevel = 0}, outputOutputType = OutputOther " hello "}] -shrinkWhitespaceInOthers :: [Output] -> [Output] -shrinkWhitespaceInOthers = fmap shrinkWhitespaceInOther - -shrinkWhitespaceInOther :: Output -> Output -shrinkWhitespaceInOther (Output nest (OutputOther string)) = - Output nest . OutputOther $ shrinkWhitespace string -shrinkWhitespaceInOther other = other - -shrinkWhitespace :: String -> String -shrinkWhitespace (' ':' ':t) = shrinkWhitespace (' ':t) -shrinkWhitespace (h:t) = h : shrinkWhitespace t -shrinkWhitespace "" = "" diff --git a/src/Text/Pretty/Simple/Internal/Printer.hs b/src/Text/Pretty/Simple/Internal/Printer.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pretty/Simple/Internal/Printer.hs @@ -0,0 +1,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,12 +0,0 @@ -module Main where - -import Build_doctests (flags, pkgs, module_sources) --- import Data.Foldable (traverse_) -import Test.DocTest (doctest) - -main :: IO () -main = do - -- traverse_ putStrLn args - doctest args - where - args = flags ++ pkgs ++ module_sources