pretty-simple 3.3.0.0 → 4.1.4.0

raw patch · 16 files changed

Files

• CHANGELOG.md +69/−0
• README.md +41/−12
• Setup.hs +0/−33
• app/Main.hs +39/−15
• pretty-simple.cabal +7/−24
• src/Debug/Pretty/Simple.hs +70/−0
• src/Text/Pretty/Simple.hs +88/−17
• src/Text/Pretty/Simple/Internal.hs +1/−3
• src/Text/Pretty/Simple/Internal/Color.hs +77/−252
• src/Text/Pretty/Simple/Internal/Expr.hs +0/−1
• src/Text/Pretty/Simple/Internal/ExprParser.hs +0/−3
• src/Text/Pretty/Simple/Internal/ExprToOutput.hs +0/−296
• src/Text/Pretty/Simple/Internal/Output.hs +0/−99
• src/Text/Pretty/Simple/Internal/OutputPrinter.hs +0/−410
• src/Text/Pretty/Simple/Internal/Printer.hs +356/−0
• test/DocTest.hs +0/−12

@@ -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 

@@ -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 <kbd>Ctrl</kbd>-<kbd>D</kbd>: -![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)

@@ -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

@@ -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

@@ -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 <https://github.com/cdepillabout/pretty-simple#readme README.md>. 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

@@ -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

@@ -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__ --

@@ -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

@@ -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

@@ -4,7 +4,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-}  {-| Module      : Text.Pretty.Simple.Internal.Expr

@@ -1,10 +1,7 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-}  {-| Module      : Text.Pretty.Simple.Internal.ExprParser

@@ -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

@@ -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)

@@ -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 "" = ""

@@ -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

@@ -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