├── cabal.project ├── img ├── pretty-simple-cli-screenshot.png ├── pretty-simple-example-screenshot.png ├── pretty-simple-cli-json-screenshot.png └── pretty-simple-json-example-screenshot.png ├── .gitignore ├── stack.yaml.lock ├── src ├── Text │ └── Pretty │ │ ├── Simple │ │ ├── Internal.hs │ │ └── Internal │ │ │ ├── Expr.hs │ │ │ ├── Color.hs │ │ │ ├── ExprParser.hs │ │ │ └── Printer.hs │ │ └── Simple.hs └── Debug │ └── Pretty │ └── Simple.hs ├── example ├── Example.hs ├── Example │ └── Data.hs └── ExampleJSON.hs ├── .github ├── FUNDING.yml └── workflows │ ├── deploy.yaml │ └── ci.yml ├── web ├── README.md ├── web.cabal ├── default.nix ├── style.css └── src │ └── Main.hs ├── bench └── Bench.hs ├── stack.yaml ├── LICENSE ├── Makefile ├── app └── Main.hs ├── pretty-simple.cabal ├── README.md └── CHANGELOG.md /cabal.project: -------------------------------------------------------------------------------- 1 | packages: 2 | . 3 | web 4 | 5 | constraints: miso +jsaddle 6 | -------------------------------------------------------------------------------- /img/pretty-simple-cli-screenshot.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cdepillabout/pretty-simple/HEAD/img/pretty-simple-cli-screenshot.png -------------------------------------------------------------------------------- /img/pretty-simple-example-screenshot.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cdepillabout/pretty-simple/HEAD/img/pretty-simple-example-screenshot.png -------------------------------------------------------------------------------- /img/pretty-simple-cli-json-screenshot.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cdepillabout/pretty-simple/HEAD/img/pretty-simple-cli-json-screenshot.png -------------------------------------------------------------------------------- /img/pretty-simple-json-example-screenshot.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cdepillabout/pretty-simple/HEAD/img/pretty-simple-json-example-screenshot.png -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | *.dyn_o 9 | *.dyn_hi 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | *.prof 15 | *.aux 16 | *.hp 17 | *.eventlog 18 | .stack-work/ 19 | web/result 20 | cabal.project.local 21 | -------------------------------------------------------------------------------- /stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: [] 7 | snapshots: 8 | - completed: 9 | sha256: 7f4393ad659c579944d12202cffb12d8e4b8114566b015f77bbc303a24cff934 10 | size: 619405 11 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/19/28.yaml 12 | original: lts-19.28 13 | -------------------------------------------------------------------------------- /src/Text/Pretty/Simple/Internal.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Text.Pretty.Simple.Internal 3 | Copyright : (c) Dennis Gosnell, 2016 4 | License : BSD-style (see LICENSE file) 5 | Maintainer : cdep.illabout@gmail.com 6 | Stability : experimental 7 | Portability : POSIX 8 | 9 | -} 10 | module Text.Pretty.Simple.Internal 11 | ( module X 12 | ) where 13 | 14 | import Text.Pretty.Simple.Internal.Color as X 15 | import Text.Pretty.Simple.Internal.ExprParser as X 16 | import Text.Pretty.Simple.Internal.Expr as X 17 | import Text.Pretty.Simple.Internal.Printer as X 18 | -------------------------------------------------------------------------------- /example/Example.hs: -------------------------------------------------------------------------------- 1 | 2 | {- | 3 | Copyright : Dennis Gosnell 2017 4 | License : BSD3 5 | Maintainer : Dennis Gosnell (cdep.illabout@gmail.com) 6 | Stability : experimental 7 | Portability : unknown 8 | 9 | This is an short example of using 'pPrint' from "Text.Pretty.Simple" to 10 | pretty-print a Haskell data type. 11 | -} 12 | module Main where 13 | 14 | import Text.Pretty.Simple (pPrint) 15 | 16 | import Example.Data (bar) 17 | 18 | main :: IO () 19 | main = do 20 | putStrLn "\nThe following normal \"print\" output:\n" 21 | print bar 22 | putStrLn "\ngets turned into this (using \"Text.Pretty.Simple.pPrint\"):\n" 23 | pPrint bar 24 | -------------------------------------------------------------------------------- /.github/FUNDING.yml: -------------------------------------------------------------------------------- 1 | # These are supported funding model platforms 2 | 3 | github: [cdepillabout] 4 | patreon: # Replace with a single Patreon username 5 | open_collective: # Replace with a single Open Collective username 6 | ko_fi: # Replace with a single Ko-fi username 7 | tidelift: # Replace with a single Tidelift platform-name/package-name e.g., npm/babel 8 | community_bridge: # Replace with a single Community Bridge project-name e.g., cloud-foundry 9 | liberapay: # Replace with a single Liberapay username 10 | issuehunt: # Replace with a single IssueHunt username 11 | otechie: # Replace with a single Otechie username 12 | custom: # Replace with up to 4 custom sponsorship URLs e.g., ['link1', 'link2'] 13 | -------------------------------------------------------------------------------- /web/README.md: -------------------------------------------------------------------------------- 1 | 2 | # pretty-simple Web Page 3 | 4 | This directory contains an interactive web page that can be compiled with GHCJS 5 | to show how `pretty-simple` works. 6 | 7 | This Haskell package can be built with GHCJS with the command `nix-build`. 8 | You'll need Nix [installed](https://nixos.org/download.html) for this to work. 9 | You'll also need to setup the Miso Nix cache, as explained 10 | [here](https://github.com/cdepillabout/pretty-simple/pull/117#issuecomment-1258023974). 11 | 12 | This Haskell package can also be built with GHC with the command `cabal build web`. 13 | Running this executable with `cabal run web` will start a web server listening on 14 | `0.0.0.0:8000`. You should be able to see the web page by opening 15 | in a web browser. _Note_ that you will need to run 16 | `cabal run web` within this current directory. 17 | -------------------------------------------------------------------------------- /.github/workflows/deploy.yaml: -------------------------------------------------------------------------------- 1 | on: 2 | push: 3 | branches: 4 | - master 5 | 6 | jobs: 7 | deploy: 8 | name: Nix build and deploy GHCJS web app 9 | runs-on: ubuntu-latest 10 | steps: 11 | - uses: actions/checkout@v3 12 | - uses: cachix/install-nix-action@v16 13 | with: 14 | extra_nix_config: | 15 | trusted-public-keys = cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY= miso-haskell.cachix.org-1:6N2DooyFlZOHUfJtAx1Q09H0P5XXYzoxxQYiwn6W1e8= haskell-pretty-simple.cachix.org-1:AWHkzPidwcDzWUIUjKcx/PYgud2OBAa9SNUEoIOsATY= 16 | substituters = https://cache.nixos.org/ https://miso-haskell.cachix.org https://haskell-pretty-simple.cachix.org 17 | - name: Build 18 | run: | 19 | nix-build ./web 20 | cp -rL result result-no-symlinks 21 | - name: Deploy 22 | uses: JamesIves/github-pages-deploy-action@v4 23 | with: 24 | folder: result-no-symlinks/bin/web.jsexe 25 | -------------------------------------------------------------------------------- /web/web.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | name: web 3 | version: 0.1.0.0 4 | category: Web 5 | build-type: Simple 6 | 7 | executable web 8 | main-is: Main.hs 9 | hs-source-dirs: src 10 | build-depends: 11 | containers, 12 | generic-lens, 13 | microlens, 14 | miso ^>= 1.8, 15 | mtl, 16 | pretty-simple, 17 | prettyprinter ^>= 1.7, 18 | text, 19 | if !impl(ghcjs) 20 | build-depends: 21 | base, 22 | jsaddle, 23 | jsaddle-warp, 24 | transformers, 25 | wai, 26 | wai-app-static, 27 | warp, 28 | websockets, 29 | else 30 | build-depends: 31 | base ^>= 4.12, 32 | ghc-options: 33 | -Wall 34 | ghcjs-options: 35 | -dedupe 36 | default-language: Haskell2010 37 | default-extensions: 38 | BlockArguments 39 | DeriveGeneric 40 | EmptyCase 41 | FlexibleContexts 42 | GADTs 43 | LambdaCase 44 | OverloadedLabels 45 | OverloadedStrings 46 | RankNTypes 47 | RecordWildCards 48 | TupleSections 49 | TypeApplications 50 | -------------------------------------------------------------------------------- /bench/Bench.hs: -------------------------------------------------------------------------------- 1 | 2 | module Main where 3 | 4 | import Data.Monoid ((<>)) 5 | import Data.Text.Lazy (Text) 6 | import Criterion.Main (Benchmark, bench, bgroup, defaultMain, nf) 7 | import Text.Pretty.Simple (pShow) 8 | 9 | import Example.Data (foo, bar, baz) 10 | 11 | main :: IO () 12 | main = 13 | defaultMain 14 | [ bgroup 15 | "pShow" 16 | [ bench "Foo" $ nf pShow foo 17 | , bench "Bar" $ nf pShow bar 18 | , bench "Baz" $ nf pShow baz 19 | ] 20 | , bgroup "recursive deeply-nested data structure" (fmap nestTest [22..25]) 21 | ] 22 | 23 | data ExampleExpr 24 | = A 25 | | B ExampleExpr 26 | | C [ExampleExpr] 27 | deriving (Show) 28 | 29 | nest :: ExampleExpr -> Int -> ExampleExpr 30 | nest expr 0 = expr 31 | nest expr n = nest (B expr) (n - 1) 32 | 33 | -- | There was a bug in the pretty-simple code that caused deeply nested data 34 | -- structures to have an exponential runtime. Effectively, the runtime doubled 35 | -- at level. The following benchmark is to make sure that we don't 36 | -- accidentally introduce this exponential runtime again. 37 | nestTest :: Int -> Benchmark 38 | nestTest n = bench ("level " <> show n) $ nf test n 39 | where 40 | test :: Int -> Text 41 | test = pShow . nest (C [A,A]) 42 | -------------------------------------------------------------------------------- /web/default.nix: -------------------------------------------------------------------------------- 1 | with (import 2 | (builtins.fetchTarball { 3 | url = 4 | "https://github.com/dmjio/miso/archive/refs/tags/1.8.3.tar.gz"; 5 | sha256 = "0kcr5agbcynm003zj70yfkhsc169ahdcp9pkyr795p5mc3ykycjl"; 6 | }) 7 | { }); 8 | #TODO we can remove all these patches once we're not stuck on such old tools 9 | # unfortunately GHCJS 8.10.7 has serious performance issues: https://github.com/dmjio/miso/pull/693 10 | let 11 | hp = pkgs.haskell.packages.ghcjs86.override { 12 | all-cabal-hashes = builtins.fetchurl { 13 | url = 14 | "https://github.com/commercialhaskell/all-cabal-hashes/archive/ead1bd926a1b10b04a5c07c8f15827091fa98b38.tar.gz"; 15 | sha256 = "15i7ia241wb3s9f6l9n2bqldb4ii73xrj49rfr02q43iqbmdjddv"; 16 | }; 17 | }; 18 | prettyprinter = hp.callHackage "prettyprinter" "1.7.0" { }; 19 | prettyprinter-ansi-terminal = 20 | hp.callHackage "prettyprinter-ansi-terminal" "1.1.2" { 21 | prettyprinter = prettyprinter; 22 | }; 23 | app = hp.callCabal2nix "web" ./. { 24 | prettyprinter = prettyprinter; 25 | pretty-simple = hp.callCabal2nix "pretty-simple" ./.. { 26 | prettyprinter = prettyprinter; 27 | prettyprinter-ansi-terminal = prettyprinter-ansi-terminal; 28 | }; 29 | }; 30 | in 31 | pkgs.buildEnv { 32 | name = "pretty-simple-web"; 33 | paths = [ 34 | app 35 | (pkgs.runCommand "css" { } '' 36 | mkdir -p $out/bin/web.jsexe 37 | cp ${./style.css} $out/bin/web.jsexe/style.css 38 | '') 39 | ]; 40 | } 41 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # For more information, see: http://docs.haskellstack.org/en/stable/yaml_configuration.html 2 | 3 | # Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2) 4 | resolver: lts-19.28 5 | 6 | # Local packages, usually specified by relative directory name 7 | packages: 8 | - '.' 9 | 10 | # Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) 11 | extra-deps: [] 12 | 13 | # Override default flag values for local packages and extra-deps 14 | flags: {} 15 | 16 | # Extra package databases containing global packages 17 | extra-package-dbs: [] 18 | 19 | # Control whether we use the GHC we find on the path 20 | # system-ghc: true 21 | 22 | # Require a specific version of stack, using version ranges 23 | # require-stack-version: -any # Default 24 | # require-stack-version: >= 1.0.0 25 | 26 | # Override the architecture used by stack, especially useful on Windows 27 | # arch: i386 28 | # arch: x86_64 29 | 30 | # Extra directories used by stack for building 31 | # extra-include-dirs: [/path/to/dir] 32 | # extra-lib-dirs: [/path/to/dir] 33 | 34 | # Allow a newer minor version of GHC than the snapshot specifies 35 | # compiler-check: newer-minor 36 | 37 | # Enable Hackage-friendly mode, for more details see 38 | # https://docs.haskellstack.org/en/stable/yaml_configuration/#pvp-bounds 39 | # This has been disabled because of the following exchange: 40 | # https://github.com/cdepillabout/pretty-simple/pull/1#issuecomment-272706215 41 | #pvp-bounds: both 42 | -------------------------------------------------------------------------------- /src/Text/Pretty/Simple/Internal/Expr.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | 8 | {-| 9 | Module : Text.Pretty.Simple.Internal.Expr 10 | Copyright : (c) Dennis Gosnell, 2016 11 | License : BSD-style (see LICENSE file) 12 | Maintainer : cdep.illabout@gmail.com 13 | Stability : experimental 14 | Portability : POSIX 15 | 16 | -} 17 | module Text.Pretty.Simple.Internal.Expr 18 | where 19 | 20 | #if __GLASGOW_HASKELL__ < 710 21 | -- We don't need this import for GHC 7.10 as it exports all required functions 22 | -- from Prelude 23 | import Control.Applicative 24 | #endif 25 | 26 | import Data.Data (Data) 27 | import Data.Typeable (Typeable) 28 | import GHC.Generics (Generic) 29 | 30 | newtype CommaSeparated a = CommaSeparated { unCommaSeparated :: [a] } 31 | deriving (Data, Eq, Generic, Show, Typeable) 32 | 33 | data Expr 34 | = Brackets !(CommaSeparated [Expr]) 35 | | Braces !(CommaSeparated [Expr]) 36 | | Parens !(CommaSeparated [Expr]) 37 | | StringLit !String 38 | | CharLit !String 39 | | NumberLit !String 40 | -- ^ We could store this as a 'Rational', say, instead of a 'String'. 41 | -- However, we will never need to use its value for anything. Indeed, the 42 | -- only thing we will be doing with it is turning it /back/ into a string 43 | -- at some stage, so we might as well cut out the middle man and store it 44 | -- directly like this. 45 | | Other !String 46 | deriving (Data, Eq, Generic, Show, Typeable) 47 | -------------------------------------------------------------------------------- /example/Example/Data.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | 3 | {- | 4 | Module : Example.Data 5 | Copyright : Dennis Gosnell 2017 6 | License : BSD3 7 | Maintainer : Dennis Gosnell (cdep.illabout@gmail.com) 8 | Stability : experimental 9 | Portability : unknown 10 | 11 | This module contains some data types and values that users can use to play 12 | around with pretty-simple. 13 | 14 | These data types are also use in the two example programs, as well as the 15 | benchmark for pretty-simple. 16 | 17 | Most users should use 'foo' or 'bar'. 'baz' is an extremely large data type, 18 | only used in the benchmark. 19 | -} 20 | 21 | module Example.Data where 22 | 23 | import Data.Data (Data) 24 | import Data.Typeable (Typeable) 25 | 26 | data Foo = Foo 27 | { foo1 :: Integer 28 | , foo2 :: [String] 29 | , foo3 :: Double 30 | } deriving (Data, Eq, Read, Show, Typeable) 31 | 32 | data Bar = Bar 33 | { bar1 :: Integer 34 | , bar2 :: [Foo] 35 | , bar3 :: Double 36 | } deriving (Data, Eq, Read, Show, Typeable) 37 | 38 | data Baz = Baz 39 | { baz1 :: Bar 40 | , baz2 :: [Baz] 41 | } deriving (Data, Eq, Read, Show, Typeable) 42 | 43 | foo :: Foo 44 | foo = Foo 3 fooList 3.3 45 | 46 | bar :: Bar 47 | bar = Bar 10 (replicate 1 foo) 10.55 48 | 49 | bazLevel1 :: Baz 50 | bazLevel1 = Baz bar [] 51 | 52 | bazLevel2 :: Baz 53 | bazLevel2 = Baz bar $ replicate 50 bazLevel1 54 | 55 | baz :: Baz 56 | baz = Baz bar $ replicate 30 bazLevel2 57 | 58 | fooList :: [String] 59 | fooList = 60 | [ "hello" 61 | , "goodbye" 62 | , "dog" 63 | , "cat" 64 | , "fox" 65 | , "beaver" 66 | ] 67 | 68 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Dennis Gosnell (c) 2016 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: bench benchmark build build-haddock clean dump-splices dump-th example example-json example-profile ghci haddock haddock-server lint repl test upload watch watch-tests watch-test 2 | all: build 3 | 4 | bench: benchmark 5 | benchmark: 6 | stack bench 7 | 8 | build: 9 | stack build 10 | 11 | clean: 12 | stack clean 13 | 14 | # dump the template haskell 15 | dump-splices: dump-th 16 | dump-th: 17 | -stack build --ghc-options="-ddump-splices" 18 | @echo 19 | @echo "Splice files:" 20 | @echo 21 | @find "$$(stack path --dist-dir)" -name "*.dump-splices" | sort 22 | 23 | example: 24 | stack build --flag pretty-simple:buildexample 25 | stack exec pretty-simple-example 26 | 27 | example-json: 28 | stack build --flag pretty-simple:buildexample 29 | stack exec pretty-simple-json-example 30 | 31 | example-profile: 32 | stack build --flag pretty-simple:buildexample --profile 33 | stack exec pretty-simple-example -- +RTS -p 34 | 35 | haddock: build-haddock 36 | build-haddock: 37 | stack build --haddock 38 | 39 | # Watch for changes. 40 | watch: 41 | stack build --file-watch --fast . 42 | 43 | # Watch for changes. 44 | watch-test: watch-tests 45 | watch-tests: 46 | stack test --file-watch --fast . 47 | 48 | # Run ghci using stack. 49 | repl: ghci 50 | ghci: 51 | stack ghci 52 | 53 | test: 54 | stack test 55 | 56 | # Run hlint. 57 | lint: 58 | hlint src/ 59 | 60 | # This runs a small python websever on port 8001 serving up haddocks for 61 | # packages you have installed. 62 | # 63 | # In order to run this, you need to have run `make build-haddock`. 64 | haddock-server: 65 | cd "$$(stack path --local-doc-root)" && python -m http.server 8001 66 | 67 | # Upload this package to hackage. 68 | upload: 69 | stack upload . 70 | -------------------------------------------------------------------------------- /web/style.css: -------------------------------------------------------------------------------- 1 | textarea, input, button, select, option { /* don't use the OS/browser style */ 2 | font-family: inherit; 3 | font-size: inherit; 4 | text-align: inherit; 5 | color: inherit; 6 | } 7 | input[type='checkbox'] { 8 | height: 2rem; 9 | width: 2rem; 10 | } 11 | input[type='range'] { 12 | width: 7rem; 13 | } 14 | select { 15 | padding: 0.5rem; 16 | width: 10rem; 17 | } 18 | 19 | :root { 20 | font-size: large; 21 | --ui-color: #2578bd; 22 | } 23 | 24 | body { 25 | background-color: #2c2f33; 26 | accent-color: var(--ui-color); 27 | caret-color: var(--ui-color); 28 | font-family: Helvetica, Arial, sans-serif; 29 | } 30 | 31 | .root { 32 | display: flex; 33 | flex-direction: column; 34 | justify-content: space-between; 35 | gap: 1rem; 36 | padding: 1rem; 37 | } 38 | 39 | .input { 40 | display: flex; 41 | align-items: center; 42 | gap: 1.5rem; 43 | } 44 | 45 | .hackage { 46 | display: flex; 47 | flex-direction: column; 48 | gap: 1rem; 49 | } 50 | .hackage img { 51 | width: 100%; 52 | height: 100%; 53 | } 54 | 55 | .input-text { 56 | height: 6rem; 57 | width: 100%; 58 | resize: none; 59 | } 60 | 61 | .opts { 62 | user-select: none; 63 | display: flex; 64 | flex-wrap: wrap; 65 | align-items: center; 66 | justify-content: center; 67 | gap: 1.5rem; 68 | } 69 | .opts > * { 70 | color: var(--ui-color); 71 | display: flex; 72 | flex-direction: column; 73 | align-items: center; 74 | gap: 0.2rem; 75 | text-align: center; 76 | } 77 | 78 | .output { 79 | color: white; /* for unannotated text e.g. data constructors */ 80 | margin-top: 0; 81 | margin-bottom: 0; 82 | } 83 | .annotation { 84 | font-weight: bold; 85 | } 86 | .parens0 { 87 | color: #f15acc 88 | } 89 | .parens1 { 90 | color: #fffb88; 91 | } 92 | .parens2 { 93 | color: #54c7e0; 94 | } 95 | .quote { 96 | color: #ffffff; 97 | } 98 | .string { 99 | color: #2578bd; 100 | } 101 | .num { 102 | color: #83e377; 103 | } 104 | -------------------------------------------------------------------------------- /example/ExampleJSON.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# OPTIONS_GHC -fno-warn-orphans #-} 3 | 4 | {- | 5 | Copyright : Dennis Gosnell 2017 6 | License : BSD3 7 | Maintainer : Dennis Gosnell (cdep.illabout@gmail.com) 8 | Stability : experimental 9 | Portability : unknown 10 | 11 | This is an short example of using 'pString' from "Text.Pretty.Simple" to 12 | pretty-print JSON. 13 | -} 14 | 15 | module Main where 16 | 17 | import Data.Aeson (encode) 18 | import Data.Aeson.TH (defaultOptions, deriveJSON) 19 | import qualified Data.ByteString.Lazy as LByteString (ByteString, toStrict) 20 | import Data.Text as Text (Text, unpack) 21 | import Data.Text.Encoding (decodeUtf8) 22 | import qualified Data.Text.IO as TextIO (putStrLn) 23 | import qualified Data.Text.Lazy as LText (Text) 24 | import qualified Data.Text.Lazy.IO as LTextIO (putStrLn) 25 | import Text.Pretty.Simple (pString) 26 | 27 | import Example.Data (Foo, Bar, bar) 28 | 29 | $(deriveJSON defaultOptions ''Foo) 30 | $(deriveJSON defaultOptions ''Bar) 31 | 32 | main :: IO () 33 | main = do 34 | putStrLn "\nThe following normal \"Data.Aeson.encode\" output:\n" 35 | putLazyByteStringLn $ encode bar 36 | putStrLn "\ngets turned into this (using \"Text.Pretty.Simple.pString\"):\n" 37 | LTextIO.putStrLn . pString . lazyByteStringToString $ encode bar 38 | 39 | -- | Convert a 'LByteString.ByteString' to a 'Text.Text' by utf8-encoding it. 40 | lazyByteStringToText :: LByteString.ByteString -> Text.Text 41 | lazyByteStringToText = decodeUtf8 . LByteString.toStrict 42 | 43 | -- | Convert a 'LByteString.ByteString' to a 'String' by utf8-encoding it. 44 | lazyByteStringToString :: LByteString.ByteString -> String 45 | lazyByteStringToString = unpack . lazyByteStringToText 46 | 47 | -- | Print a 'LByteString.ByteString' to the screen. Similar to 'putStrLn'. 48 | putLazyByteStringLn :: LByteString.ByteString -> IO () 49 | putLazyByteStringLn = TextIO.putStrLn . lazyByteStringToText 50 | 51 | -- | Print a 'LText.Text' to the screen. Similar to 'putStrLn'. 52 | putLazyTextLn :: LText.Text -> IO () 53 | putLazyTextLn = LTextIO.putStrLn 54 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | -- This is a small executable that will pretty-print anything from stdin. 4 | -- It can be installed to `~/.local/bin` if you enable the flag `buildexe` like so: 5 | -- 6 | -- @ 7 | -- $ stack install pretty-simple-2.0.1.1 --flag pretty-simple:buildexe 8 | -- @ 9 | -- 10 | -- When you run it, you can paste something you want formatted on stdin, then 11 | -- press @Ctrl-D@. It will print the formatted version on stdout: 12 | -- 13 | -- @ 14 | -- $ pretty-simple 15 | -- [(Just 3, Just 4)] 16 | -- 17 | -- ^D 18 | -- 19 | -- [ 20 | -- ( Just 3 21 | -- , Just 4 22 | -- ) 23 | -- ] 24 | -- @ 25 | 26 | import Data.Monoid ((<>)) 27 | import Data.Text (unpack) 28 | import qualified Data.Text.IO as T 29 | import qualified Data.Text.Lazy.IO as LT 30 | import Data.Version (showVersion) 31 | import Options.Applicative 32 | ( Parser, ReadM, execParser, fullDesc, help, helper, info, infoOption 33 | , long, option, progDesc, readerError, short, showDefaultWith, str 34 | , switch, value) 35 | import Paths_pretty_simple (version) 36 | import Text.Pretty.Simple 37 | ( pStringOpt, OutputOptions 38 | , defaultOutputOptionsDarkBg 39 | , defaultOutputOptionsLightBg 40 | , defaultOutputOptionsNoColor 41 | , outputOptionsCompact 42 | ) 43 | 44 | data Color = DarkBg 45 | | LightBg 46 | | NoColor 47 | 48 | data Args = Args 49 | { color :: Color 50 | , compact :: Bool 51 | } 52 | 53 | colorReader :: ReadM Color 54 | colorReader = do 55 | string <- str 56 | case string of 57 | "dark-bg" -> pure DarkBg 58 | "light-bg" -> pure LightBg 59 | "no-color" -> pure NoColor 60 | x -> readerError $ "Could not parse " <> x <> " as a color." 61 | 62 | args :: Parser Args 63 | args = Args 64 | <$> option colorReader 65 | ( long "color" 66 | <> short 'c' 67 | <> help "Select printing color. Available options: dark-bg (default), light-bg, no-color." 68 | <> showDefaultWith (const "dark-bg") 69 | <> value DarkBg 70 | ) 71 | <*> switch 72 | ( long "compact" 73 | <> short 'C' 74 | <> help "Compact output" 75 | ) 76 | 77 | versionOption :: Parser (a -> a) 78 | versionOption = 79 | infoOption 80 | (showVersion version) 81 | ( long "version" 82 | <> short 'V' 83 | <> help "Show version" 84 | ) 85 | 86 | main :: IO () 87 | main = do 88 | args' <- execParser opts 89 | input <- T.getContents 90 | let output = pStringOpt (getPrintOpt args') $ unpack input 91 | LT.putStrLn output 92 | where 93 | opts = info (helper <*> versionOption <*> args) 94 | ( fullDesc 95 | <> progDesc "Format Haskell data types with indentation and highlighting" 96 | ) 97 | 98 | getPrintOpt :: Args -> OutputOptions 99 | getPrintOpt as = 100 | (getColorOpt (color as)) {outputOptionsCompact = compact as} 101 | 102 | getColorOpt :: Color -> OutputOptions 103 | getColorOpt DarkBg = defaultOutputOptionsDarkBg 104 | getColorOpt LightBg = defaultOutputOptionsLightBg 105 | getColorOpt NoColor = defaultOutputOptionsNoColor 106 | -------------------------------------------------------------------------------- /pretty-simple.cabal: -------------------------------------------------------------------------------- 1 | name: pretty-simple 2 | version: 4.1.3.0 3 | synopsis: pretty printer for data types with a 'Show' instance. 4 | description: Please see . 5 | homepage: https://github.com/cdepillabout/pretty-simple 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Dennis Gosnell 9 | maintainer: cdep.illabout@gmail.com 10 | copyright: 2017-2019 Dennis Gosnell 11 | category: Text 12 | build-type: Simple 13 | extra-source-files: CHANGELOG.md 14 | , README.md 15 | , img/pretty-simple-example-screenshot.png 16 | cabal-version: >=1.10 17 | 18 | flag buildexe 19 | description: Build an small command line program that pretty-print anything from stdin. 20 | default: True 21 | 22 | flag buildexample 23 | description: Build a small example program showing how to use the pPrint function 24 | default: False 25 | 26 | library 27 | hs-source-dirs: src 28 | exposed-modules: Debug.Pretty.Simple 29 | , Text.Pretty.Simple 30 | , Text.Pretty.Simple.Internal 31 | , Text.Pretty.Simple.Internal.Color 32 | , Text.Pretty.Simple.Internal.Expr 33 | , Text.Pretty.Simple.Internal.ExprParser 34 | , Text.Pretty.Simple.Internal.Printer 35 | build-depends: base >= 4.8 && < 5 36 | , containers 37 | , mtl >= 2.2 38 | , prettyprinter >= 1.7.0 39 | , prettyprinter-ansi-terminal >= 1.1.2 40 | , text >= 1.2 41 | , transformers >= 0.4 42 | default-language: Haskell2010 43 | ghc-options: -Wall 44 | other-extensions: TemplateHaskell 45 | 46 | executable pretty-simple 47 | main-is: Main.hs 48 | other-modules: Paths_pretty_simple 49 | hs-source-dirs: app 50 | build-depends: base 51 | , pretty-simple 52 | , text 53 | , optparse-applicative 54 | default-language: Haskell2010 55 | ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N 56 | 57 | if flag(buildexe) 58 | buildable: True 59 | else 60 | buildable: False 61 | 62 | 63 | executable pretty-simple-example 64 | main-is: Example.hs 65 | other-modules: Example.Data 66 | hs-source-dirs: example 67 | build-depends: base 68 | , pretty-simple 69 | default-language: Haskell2010 70 | ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N 71 | 72 | if flag(buildexample) 73 | buildable: True 74 | else 75 | buildable: False 76 | 77 | executable pretty-simple-json-example 78 | main-is: ExampleJSON.hs 79 | other-modules: Example.Data 80 | hs-source-dirs: example 81 | build-depends: base 82 | , aeson 83 | , bytestring 84 | , pretty-simple 85 | , text 86 | default-language: Haskell2010 87 | ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N 88 | 89 | if flag(buildexample) 90 | buildable: True 91 | else 92 | buildable: False 93 | 94 | benchmark pretty-simple-bench 95 | type: exitcode-stdio-1.0 96 | main-is: Bench.hs 97 | other-modules: Example.Data 98 | hs-source-dirs: bench 99 | , example 100 | build-depends: base 101 | , criterion 102 | , pretty-simple 103 | , text 104 | default-language: Haskell2010 105 | ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N 106 | 107 | source-repository head 108 | type: git 109 | location: git@github.com:cdepillabout/pretty-simple.git 110 | -------------------------------------------------------------------------------- /src/Text/Pretty/Simple/Internal/Color.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE LambdaCase #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE RankNTypes #-} 8 | {-# LANGUAGE RecordWildCards #-} 9 | {-# LANGUAGE ScopedTypeVariables #-} 10 | 11 | {-| 12 | Module : Text.Pretty.Simple.Internal.Color 13 | Copyright : (c) Dennis Gosnell, 2016 14 | License : BSD-style (see LICENSE file) 15 | Maintainer : cdep.illabout@gmail.com 16 | Stability : experimental 17 | Portability : POSIX 18 | 19 | -} 20 | module Text.Pretty.Simple.Internal.Color 21 | where 22 | 23 | #if __GLASGOW_HASKELL__ < 710 24 | -- We don't need this import for GHC 7.10 as it exports all required functions 25 | -- from Prelude 26 | import Control.Applicative 27 | #endif 28 | 29 | import Data.Typeable (Typeable) 30 | import GHC.Generics (Generic) 31 | import Prettyprinter.Render.Terminal 32 | (AnsiStyle, Intensity(Dull,Vivid), Color(..)) 33 | import qualified Prettyprinter.Render.Terminal as Ansi 34 | 35 | -- | These options are for colorizing the output of functions like 'pPrint'. 36 | -- 37 | -- If you don't want to use a color for one of the options, use 'colorNull'. 38 | data ColorOptions = ColorOptions 39 | { colorQuote :: Style 40 | -- ^ Color to use for quote characters (@\"@) around strings. 41 | , colorString :: Style 42 | -- ^ Color to use for strings. 43 | , colorError :: Style 44 | -- ^ Color for errors, e.g. unmatched brackets. 45 | , colorNum :: Style 46 | -- ^ Color to use for numbers. 47 | , colorRainbowParens :: [Style] 48 | -- ^ A list of colors to use for rainbow parenthesis output. Use 49 | -- '[]' if you don't want rainbow parenthesis. Use just a single item if you 50 | -- want all the rainbow parenthesis to be colored the same. 51 | } deriving (Eq, Generic, Show, Typeable) 52 | 53 | -- | Default color options for use on a dark background. 54 | defaultColorOptionsDarkBg :: ColorOptions 55 | defaultColorOptionsDarkBg = 56 | ColorOptions 57 | { colorQuote = colorBold Vivid White 58 | , colorString = colorBold Vivid Blue 59 | , colorError = colorBold Vivid Red 60 | , colorNum = colorBold Vivid Green 61 | , colorRainbowParens = 62 | [ colorBold Vivid Magenta 63 | , colorBold Vivid Cyan 64 | , colorBold Vivid Yellow 65 | , color Dull Magenta 66 | , color Dull Cyan 67 | , color Dull Yellow 68 | , colorBold Dull Magenta 69 | , colorBold Dull Cyan 70 | , colorBold Dull Yellow 71 | , color Vivid Magenta 72 | , color Vivid Cyan 73 | , color Vivid Yellow 74 | ] 75 | } 76 | 77 | -- | Default color options for use on a light background. 78 | defaultColorOptionsLightBg :: ColorOptions 79 | defaultColorOptionsLightBg = 80 | ColorOptions 81 | { colorQuote = colorBold Vivid Black 82 | , colorString = colorBold Vivid Blue 83 | , colorError = colorBold Vivid Red 84 | , colorNum = colorBold Vivid Green 85 | , colorRainbowParens = 86 | [ colorBold Vivid Magenta 87 | , colorBold Vivid Cyan 88 | , color Dull Magenta 89 | , color Dull Cyan 90 | , colorBold Dull Magenta 91 | , colorBold Dull Cyan 92 | , color Vivid Magenta 93 | , color Vivid Cyan 94 | ] 95 | } 96 | 97 | -- | No styling. 98 | colorNull :: Style 99 | colorNull = Style 100 | { styleColor = Nothing 101 | , styleBold = False 102 | , styleItalic = False 103 | , styleUnderlined = False 104 | } 105 | 106 | -- | Ways to style terminal output. 107 | data Style = Style 108 | { styleColor :: Maybe (Color, Intensity) 109 | , styleBold :: Bool 110 | , styleItalic :: Bool 111 | , styleUnderlined :: Bool 112 | } 113 | deriving (Eq, Generic, Show, Typeable) 114 | 115 | color :: Intensity -> Color -> Style 116 | color i c = colorNull {styleColor = Just (c, i)} 117 | 118 | colorBold :: Intensity -> Color -> Style 119 | colorBold i c = (color i c) {styleBold = True} 120 | 121 | convertStyle :: Style -> AnsiStyle 122 | convertStyle Style {..} = 123 | mconcat 124 | [ maybe mempty (uncurry $ flip col) styleColor 125 | , if styleBold then Ansi.bold else mempty 126 | , if styleItalic then Ansi.italicized else mempty 127 | , if styleUnderlined then Ansi.underlined else mempty 128 | ] 129 | where 130 | col = \case 131 | Vivid -> Ansi.color 132 | Dull -> Ansi.colorDull 133 | -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | # Trigger the workflow on push or pull request, but only for the master branch 4 | on: 5 | pull_request: 6 | push: 7 | branches: 8 | - master 9 | 10 | jobs: 11 | cabal: 12 | name: cabal / ghc-${{ matrix.ghc }} / ${{ matrix.os }} 13 | runs-on: ${{ matrix.os }} 14 | strategy: 15 | matrix: 16 | os: 17 | # ubuntu-22.04 (currently ubuntu-latest) appears to not be able to 18 | # install ghc-8.2.2 with ghcup. Possibly because of 19 | # https://github.com/haskell/actions/issues/133. 20 | # TODO: Need to look into what is going on here, and try upgrading 21 | # back to ubuntu-latest at some point. 22 | # - ubuntu-latest 23 | - ubuntu-20.04 24 | 25 | # OSX builds were flakey at some point in the past, so we disabled 26 | # them. pretty-simple doesn't have any interesting system-level 27 | # dependencies, so it is probably okay we aren't testing on OSX. 28 | # - macOS-latest 29 | cabal: 30 | - "3.12.1.0" 31 | ghc: 32 | - "8.0.2" 33 | - "8.2.2" 34 | - "8.4.4" 35 | - "8.6.5" 36 | - "8.8.4" 37 | - "8.10.7" 38 | - "9.0.2" 39 | - "9.2.4" 40 | - "9.4.8" 41 | - "9.6.6" 42 | - "9.8.4" 43 | - "9.10.1" 44 | 45 | steps: 46 | - uses: actions/checkout@v2 47 | #if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master' 48 | 49 | - uses: haskell/actions/setup@v2 50 | id: setup-haskell-cabal 51 | name: Setup Haskell 52 | with: 53 | ghc-version: ${{ matrix.ghc }} 54 | cabal-version: ${{ matrix.cabal }} 55 | 56 | - uses: actions/cache@v1 57 | name: Cache cabal-store 58 | with: 59 | path: ${{ steps.setup-haskell-cabal.outputs.cabal-store }} 60 | key: ${{ runner.os }}-${{ matrix.ghc }}-cabal 61 | 62 | - name: Build 63 | run: | 64 | cabal update 65 | # TODO: We have a problem where cabal is not able to come up with a 66 | # build plan on GHC-9.2 because the ./cabal.project file defines both 67 | # pretty-simple, and ./web as packages. ./web uses a version of jsaddle 68 | # that doesn't seem to work yet on GHC-9.2. It doesn't seem possible 69 | # to tell cabal to just ignore the web package, and only run the solver 70 | # for pretty-simple. 71 | # 72 | # This hacky workaround just deletes the cabal.project file, so that 73 | # cabal doesn't realize there is another package in ./web. 74 | # 75 | # This workaround can likely be removed when we move to a more recent 76 | # version of jsaddle. 77 | rm ./cabal.project 78 | cabal build package:pretty-simple --enable-tests --enable-benchmarks --write-ghc-environment-files=always --flags="buildexample" 79 | 80 | - name: Install doctest 81 | run: | 82 | cabal install --ignore-project doctest --flag cabal-doctest 83 | echo "$HOME/.cabal/bin" >> $GITHUB_PATH 84 | 85 | - name: Test 86 | run: | 87 | cabal doctest 88 | 89 | stack: 90 | name: stack / ubuntu-latest 91 | runs-on: ubuntu-latest 92 | strategy: 93 | matrix: 94 | stack: ["latest"] 95 | 96 | steps: 97 | - uses: actions/checkout@v2 98 | #if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master' 99 | 100 | - uses: haskell/actions/setup@v2 101 | name: Setup Haskell Stack 102 | with: 103 | stack-version: ${{ matrix.stack }} 104 | enable-stack: true 105 | 106 | - uses: actions/cache@v1 107 | name: Cache ~/.stack 108 | with: 109 | path: ~/.stack 110 | key: ${{ runner.os }}-stack 111 | 112 | - name: Build 113 | run: | 114 | stack build --test --bench --no-run-tests --no-run-benchmarks --flag pretty-simple:buildexample 115 | 116 | nix-build-web: 117 | name: Nix build GHCJS web 118 | runs-on: ubuntu-latest 119 | steps: 120 | - uses: actions/checkout@v2 121 | - uses: cachix/install-nix-action@v16 122 | with: 123 | extra_nix_config: | 124 | trusted-public-keys = cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY= miso-haskell.cachix.org-1:6N2DooyFlZOHUfJtAx1Q09H0P5XXYzoxxQYiwn6W1e8= 125 | substituters = https://cache.nixos.org/ https://miso-haskell.cachix.org 126 | - name: Build web 127 | run: nix-build ./web 128 | -------------------------------------------------------------------------------- /src/Text/Pretty/Simple/Internal/ExprParser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | 6 | {-| 7 | Module : Text.Pretty.Simple.Internal.ExprParser 8 | Copyright : (c) Dennis Gosnell, 2016 9 | License : BSD-style (see LICENSE file) 10 | Maintainer : cdep.illabout@gmail.com 11 | Stability : experimental 12 | Portability : POSIX 13 | 14 | -} 15 | module Text.Pretty.Simple.Internal.ExprParser 16 | where 17 | 18 | import Text.Pretty.Simple.Internal.Expr (CommaSeparated(..), Expr(..)) 19 | import Control.Arrow (first) 20 | import Data.Char (isAlpha, isDigit) 21 | 22 | -- | 'testString1' and 'testString2' are convenient to use in GHCi when playing 23 | -- around with how parsing works. 24 | testString1 :: String 25 | testString1 = "Just [TextInput {textInputClass = Just (Class {unClass = \"class\"}), textInputId = Just (Id {unId = \"id\"}), textInputName = Just (Name {unName = \"name\"}), textInputValue = Just (Value {unValue = \"value\"}), textInputPlaceholder = Just (Placeholder {unPlaceholder = \"placeholder\"})}, TextInput {textInputClass = Just (Class {unClass = \"class\"}), textInputId = Just (Id {unId = \"id\"}), textInputName = Just (Name {unName = \"name\"}), textInputValue = Just (Value {unValue = \"value\"}), textInputPlaceholder = Just (Placeholder {unPlaceholder = \"placeholder\"})}]" 26 | 27 | -- | See 'testString1'. 28 | testString2 :: String 29 | testString2 = "some stuff (hello [\"dia\\x40iahello\", why wh, bye] ) (bye)" 30 | 31 | expressionParse :: String -> [Expr] 32 | expressionParse = fst . parseExprs 33 | 34 | parseExpr :: String -> (Expr, String) 35 | parseExpr ('(':rest) = first (Parens . CommaSeparated) $ parseCSep ')' rest 36 | parseExpr ('[':rest) = first (Brackets . CommaSeparated) $ parseCSep ']' rest 37 | parseExpr ('{':rest) = first (Braces . CommaSeparated) $ parseCSep '}' rest 38 | parseExpr ('"':rest) = first StringLit $ parseStringLit rest 39 | parseExpr ('\'':rest) = first CharLit $ parseCharLit rest 40 | parseExpr (c:rest) | isDigit c = first NumberLit $ parseNumberLit c rest 41 | parseExpr other = first Other $ parseOther other 42 | 43 | -- | Parse multiple expressions. 44 | -- 45 | -- >>> parseExprs "Just 'a'" 46 | -- ([Other "Just ",CharLit "a"],"") 47 | -- 48 | -- Handle escaped characters correctly 49 | -- 50 | -- >>> parseExprs $ "Foo \"hello \\\"world!\"" 51 | -- ([Other "Foo ",StringLit "hello \\\"world!"],"") 52 | -- >>> parseExprs $ "'\\''" 53 | -- ([CharLit "\\'"],"") 54 | parseExprs :: String -> ([Expr], String) 55 | parseExprs [] = ([], "") 56 | parseExprs s@(c:_) 57 | | c `elem` (")]}," :: String) = ([], s) 58 | | otherwise = let (parsed, rest') = parseExpr s 59 | (toParse, rest) = parseExprs rest' 60 | in (parsed : toParse, rest) 61 | 62 | parseCSep :: Char -> String -> ([[Expr]], String) 63 | parseCSep _ [] = ([], "") 64 | parseCSep end s@(c:cs) 65 | | c == end = ([], cs) 66 | -- Mismatch condition; if the end does not match, there is a mistake 67 | -- Perhaps there should be a Missing constructor for Expr 68 | | c `elem` (")]}" :: String) = ([], s) 69 | | c == ',' = parseCSep end cs 70 | | otherwise = let (parsed, rest') = parseExprs s 71 | (toParse, rest) = parseCSep end rest' 72 | in (parsed : toParse, rest) 73 | 74 | -- | Parse string literals until a trailing double quote. 75 | -- 76 | -- >>> parseStringLit "foobar\" baz" 77 | -- ("foobar"," baz") 78 | -- 79 | -- Keep literal back slashes: 80 | -- 81 | -- >>> parseStringLit "foobar\\\" baz\" after" 82 | -- ("foobar\\\" baz"," after") 83 | parseStringLit :: String -> (String, String) 84 | parseStringLit [] = ("", "") 85 | parseStringLit ('"':rest) = ("", rest) 86 | parseStringLit ('\\':c:cs) = ('\\':c:cs', rest) 87 | where (cs', rest) = parseStringLit cs 88 | parseStringLit (c:cs) = (c:cs', rest) 89 | where (cs', rest) = parseStringLit cs 90 | 91 | -- | Parse character literals until a trailing single quote. 92 | -- 93 | -- >>> parseCharLit "a' foobar" 94 | -- ("a"," foobar") 95 | -- 96 | -- Keep literal back slashes: 97 | -- 98 | -- >>> parseCharLit "\\'' hello" 99 | -- ("\\'"," hello") 100 | parseCharLit :: String -> (String, String) 101 | parseCharLit [] = ("", "") 102 | parseCharLit ('\'':rest) = ("", rest) 103 | parseCharLit ('\\':c:cs) = ('\\':c:cs', rest) 104 | where (cs', rest) = parseCharLit cs 105 | parseCharLit (c:cs) = (c:cs', rest) 106 | where (cs', rest) = parseCharLit cs 107 | 108 | -- | Parses integers and reals, like @123@ and @45.67@. 109 | -- 110 | -- To be more precise, any numbers matching the regex @\\d+(\\.\\d+)?@ should 111 | -- get parsed by this function. 112 | -- 113 | -- >>> parseNumberLit '3' "456hello world []" 114 | -- ("3456","hello world []") 115 | -- >>> parseNumberLit '0' ".12399880 foobar" 116 | -- ("0.12399880"," foobar") 117 | parseNumberLit :: Char -> String -> (String, String) 118 | parseNumberLit firstDigit rest1 = 119 | case rest2 of 120 | [] -> (firstDigit:remainingDigits, "") 121 | '.':rest3 -> 122 | let (digitsAfterDot, rest4) = span isDigit rest3 123 | in ((firstDigit : remainingDigits) ++ ('.' : digitsAfterDot), rest4) 124 | _ -> (firstDigit:remainingDigits, rest2) 125 | where 126 | remainingDigits :: String 127 | rest2 :: String 128 | (remainingDigits, rest2) = span isDigit rest1 129 | 130 | -- | This function consumes input, stopping only when it hits a special 131 | -- character or a digit. However, if the digit is in the middle of a 132 | -- Haskell-style identifier (e.g. @foo123@), then keep going 133 | -- anyway. 134 | -- 135 | -- This is almost the same as the function 136 | -- 137 | -- > parseOtherSimple = span $ \c -> 138 | -- > notElem c ("{[()]}\"," :: String) && not (isDigit c) && (c /= '\'') 139 | -- 140 | -- except 'parseOther' ignores digits and single quotes that appear in 141 | -- Haskell-like identifiers. 142 | -- 143 | -- >>> parseOther "hello world []" 144 | -- ("hello world ","[]") 145 | -- >>> parseOther "hello234 world" 146 | -- ("hello234 world","") 147 | -- >>> parseOther "hello 234 world" 148 | -- ("hello ","234 world") 149 | -- >>> parseOther "hello{[ 234 world" 150 | -- ("hello","{[ 234 world") 151 | -- >>> parseOther "H3110 World" 152 | -- ("H3110 World","") 153 | -- >>> parseOther "Node' (Leaf' 1) (Leaf' 2)" 154 | -- ("Node' ","(Leaf' 1) (Leaf' 2)") 155 | -- >>> parseOther "I'm One" 156 | -- ("I'm One","") 157 | -- >>> parseOther "I'm 2" 158 | -- ("I'm ","2") 159 | parseOther :: String -> (String, String) 160 | parseOther = go False 161 | where 162 | go 163 | :: Bool 164 | -- ^ in an identifier? 165 | -> String 166 | -> (String, String) 167 | go _ [] = ("", "") 168 | go insideIdent cs@(c:cs') 169 | | c `elem` ("{[()]}\"," :: String) = ("", cs) 170 | | ignoreInIdent c && not insideIdent = ("", cs) 171 | | insideIdent = first (c :) (go (isIdentRest c) cs') 172 | | otherwise = first (c :) (go (isIdentBegin c) cs') 173 | 174 | isIdentBegin :: Char -> Bool 175 | isIdentBegin '_' = True 176 | isIdentBegin c = isAlpha c 177 | 178 | isIdentRest :: Char -> Bool 179 | isIdentRest '_' = True 180 | isIdentRest '\'' = True 181 | isIdentRest c = isAlpha c || ignoreInIdent c 182 | 183 | ignoreInIdent :: Char -> Bool 184 | ignoreInIdent x = isDigit x || x == '\'' 185 | -------------------------------------------------------------------------------- /web/src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | module Main (main) where 4 | 5 | import Miso hiding (go, set) 6 | 7 | #ifndef __GHCJS__ 8 | import Language.Javascript.JSaddle.Warp as JSaddle 9 | import qualified Network.Wai.Handler.Warp as Warp 10 | import qualified Network.Wai as Wai 11 | import qualified Network.Wai.Application.Static as Wai 12 | import Network.WebSockets (defaultConnectionOptions) 13 | #endif 14 | 15 | import Control.Monad.State (evalState, gets, modify) 16 | import Data.Generics.Labels () 17 | import qualified Data.Map.Strict as Map 18 | import qualified Data.Text as T 19 | import GHC.Generics (Generic) 20 | import Lens.Micro (over, set) 21 | import Miso.String (MisoString, fromMisoString, ms, toLower) 22 | import qualified Miso.String as Miso 23 | import Prettyprinter.Render.Util.SimpleDocTree (SimpleDocTree (..), treeForm) 24 | import Text.Pretty.Simple (OutputOptions, StringOutputStyle (..), defaultOutputOptionsNoColor) 25 | import Text.Pretty.Simple.Internal (Annotation (..), layoutStringAbstract) 26 | 27 | #ifndef __GHCJS__ 28 | runApp :: JSM () -> IO () 29 | runApp f = do 30 | putStrLn "Web server running on 0.0.0.0:8000..." 31 | Warp.runSettings (Warp.setPort 8000 $ Warp.setTimeout 3600 Warp.defaultSettings) 32 | =<< JSaddle.jsaddleOr defaultConnectionOptions (f >> syncPoint) app 33 | where 34 | app :: Wai.Application 35 | app req = 36 | case Wai.pathInfo req of 37 | ["style.css"] -> Wai.staticApp (Wai.defaultWebAppSettings ".") req 38 | _ -> JSaddle.jsaddleApp req 39 | #else 40 | runApp :: IO () -> IO () 41 | runApp app = app 42 | #endif 43 | 44 | data Model = Model 45 | { inputText :: MisoString 46 | , outputOptions :: OutputOptions 47 | } 48 | deriving (Show, Eq, Generic) 49 | 50 | data Action 51 | = NoOp 52 | | Log MisoString 53 | | TextEntered MisoString 54 | | OptsChanged (OutputOptions -> OutputOptions) 55 | 56 | main :: IO () 57 | main = runApp $ startApp App{..} 58 | where 59 | initialAction = NoOp 60 | model = 61 | Model 62 | { inputText = "" 63 | , outputOptions = defaultOutputOptionsNoColor 64 | } 65 | update = updateModel 66 | view = viewModel 67 | events = defaultEvents 68 | subs = [] 69 | mountPoint = Nothing -- mount at `body` 70 | logLevel = Off 71 | 72 | updateModel :: Action -> Model -> Effect Action Model 73 | updateModel = \case 74 | NoOp -> noEff 75 | Log t -> (<# (consoleLog t >> pure NoOp)) 76 | TextEntered t -> noEff . set #inputText t 77 | OptsChanged f -> noEff . over #outputOptions f 78 | 79 | viewModel :: Model -> View Action 80 | viewModel m = 81 | div_ 82 | [class_ "root"] 83 | [ div_ 84 | [class_ "input"] 85 | [ textArea [class_ "input-text"] TextEntered "" 86 | , div_ 87 | [class_ "hackage"] 88 | [ a_ 89 | [href_ "https://hackage.haskell.org/package/pretty-simple"] 90 | [img_ [src_ "https://img.shields.io/hackage/v/pretty-simple.svg"]] 91 | , selectMenu 92 | [] 93 | (maybe NoOp TextEntered) 94 | Log 95 | ( ("Use example...", Nothing) 96 | : map 97 | (\x -> (x, Just x)) 98 | examples 99 | ) 100 | ] 101 | ] 102 | , div_ 103 | [class_ "opts"] 104 | [ checkBox [] (setOpts #outputOptionsCompact) "Compact" 105 | , checkBox [] (setOpts #outputOptionsCompactParens) "Compact parentheses" 106 | , slider [] (0, 10) (setOpts #outputOptionsIndentAmount) "Indentation" 107 | , slider [] (0, 20) (setOpts #outputOptionsInitialIndent) "Initial indent" 108 | , slider [] (1, 240) (setOpts #outputOptionsPageWidth) "Page width" 109 | , div_ 110 | [] 111 | [ text "Non-printable characters" 112 | , selectMenu 113 | [] 114 | (setOpts #outputOptionsStringStyle) 115 | Log 116 | [ ("Escape", EscapeNonPrintable) 117 | , ("Don't escape", DoNotEscapeNonPrintable) 118 | , ("Literal", Literal) 119 | ] 120 | ] 121 | ] 122 | , pPrintStringHtml [class_ "output"] (outputOptions m) . fromMisoString $ inputText m 123 | , link_ 124 | [ rel_ "stylesheet" 125 | , type_ "text/css" 126 | , href_ "style.css" 127 | ] 128 | ] 129 | where 130 | setOpts l = OptsChanged . set l 131 | 132 | data ParensLevel 133 | = Parens0 134 | | Parens1 135 | | Parens2 136 | deriving (Eq, Show, Bounded, Enum) 137 | 138 | -- TODO ideally, we'd reuse `layoutString`, and just map over its result, but `annotateStyle` crashes on GHCJS 8.6: 139 | -- https://github.com/ghcjs/ghcjs/issues/794 140 | pPrintStringHtml :: [Attribute act] -> OutputOptions -> String -> View act 141 | pPrintStringHtml as opts = renderHtml as . treeForm . annotateWithIndentation . layoutStringAbstract opts 142 | where 143 | annotateWithIndentation = 144 | flip evalState (prev Parens0) . traverse \ann -> 145 | (++ [Class "annotation", toClassName @Annotation ann]) <$> case ann of 146 | Open -> modify next *> g 147 | Close -> g <* modify prev 148 | Comma -> g 149 | _ -> pure [] 150 | where 151 | g = gets (pure . toClassName @ParensLevel) 152 | toClassName :: Show a => a -> Class 153 | toClassName = Class . toLower . ms . show 154 | 155 | examples :: [MisoString] 156 | examples = 157 | [ "Foo 3 \"hello\" 'a'" 158 | , "[Foo [(),()] \"hello\" 'b']" 159 | , "Bar {barInt = 1, barA = [10,11], barList = [Foo 1.1 \"\" 'a',Foo 2.2 \"hello\" 'b']}" 160 | , "Baz {unBaz = [\"\\29483\",\"\\29356\",\"\\12516\\12462\"]}" 161 | , "AST [] [Def ((3,1),(5,30)) (Id \"fact'\" \"fact'\") [] (Forall ((3,9),(3,26)) [((Id \"n\" \"n_0\"),KPromote (TyCon (Id \"Nat\" \"Nat\")))])]" 162 | , "[(\"id\",123),(\"state\",1),(\"pass\",1),(\"tested\",100),(\"time\",12345)]" 163 | , "2019-02-18 20:56:24.265489 UTC" 164 | , "192.168.0.1:8000" 165 | , "A @\"type\" 1" 166 | , "2+2" 167 | , "1.0e-2" 168 | , "\"this string has non-printable characters: \\b and \\t\"" 169 | ] 170 | 171 | {- Wrappers around HTML elements -} 172 | 173 | checkBox :: [Attribute action] -> (Bool -> action) -> MisoString -> View action 174 | checkBox as f t = 175 | label_ 176 | as 177 | [ text t 178 | , input_ [type_ "checkbox", onChecked $ f . unChecked] 179 | ] 180 | where 181 | unChecked (Checked b) = b 182 | 183 | slider :: [Attribute action] -> (Int, Int) -> (Int -> action) -> MisoString -> View action 184 | slider as (min', max') f t = 185 | label_ 186 | as 187 | [ text t 188 | , input_ 189 | [ type_ "range" 190 | , min_ $ ms min' 191 | , max_ $ ms max' 192 | , onInput $ f . fromMisoString 193 | ] 194 | ] 195 | 196 | selectMenu :: [Attribute action] -> (a -> action) -> (MisoString -> action) -> [(MisoString, a)] -> View action 197 | selectMenu as f e items = 198 | select_ (onChange (\s -> maybe (e $ "selectMenu: unrecognised value: " <> s) f $ Map.lookup s stringToItem) : as) $ 199 | map (option_ [] . pure . text . fst) items 200 | where 201 | stringToItem = Map.fromList items 202 | 203 | textArea :: [Attribute action] -> (MisoString -> action) -> MisoString -> View action 204 | textArea as f t = textarea_ (onInput f : as) [text t] 205 | 206 | {- Util -} 207 | 208 | -- | Safe, wrapping around, as in 'relude' 209 | next, prev :: (Eq a, Bounded a, Enum a) => a -> a 210 | next e 211 | | e == maxBound = minBound 212 | | otherwise = succ e 213 | prev e 214 | | e == minBound = maxBound 215 | | otherwise = pred e 216 | 217 | newtype Class = Class {unClass :: MisoString} 218 | 219 | renderHtml :: [Attribute action] -> SimpleDocTree [Class] -> View action 220 | renderHtml as = 221 | let go = \case 222 | STEmpty -> [text ""] 223 | STChar c -> [text $ ms $ T.singleton c] 224 | STText _ t -> [text $ ms t] 225 | STLine i -> [br_ [], text $ ms $ T.replicate i $ T.singleton ' '] 226 | STAnn cs content -> [span_ [class_ $ Miso.unwords $ map unClass cs] $ go content] 227 | STConcat contents -> foldMap go contents 228 | in pre_ as . go 229 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 2 | Text.Pretty.Simple 3 | ================== 4 | 5 | [![Build Status](https://github.com/cdepillabout/pretty-simple/workflows/CI/badge.svg)](https://github.com/cdepillabout/pretty-simple/actions) 6 | [![Hackage](https://img.shields.io/hackage/v/pretty-simple.svg)](https://hackage.haskell.org/package/pretty-simple) 7 | [![Stackage LTS](http://stackage.org/package/pretty-simple/badge/lts)](http://stackage.org/lts/package/pretty-simple) 8 | [![Stackage Nightly](http://stackage.org/package/pretty-simple/badge/nightly)](http://stackage.org/nightly/package/pretty-simple) 9 | ![BSD3 license](https://img.shields.io/badge/license-BSD3-blue.svg) 10 | 11 | `pretty-simple` is a pretty printer for Haskell data types that have a `Show` 12 | instance. 13 | 14 | For example, imagine the following Haskell data types and values: 15 | 16 | ```haskell 17 | data Foo = Foo { foo1 :: Integer , foo2 :: [String] } deriving Show 18 | 19 | foo :: Foo 20 | foo = Foo 3 ["hello", "goodbye"] 21 | 22 | data Bar = Bar { bar1 :: Double , bar2 :: [Foo] } deriving Show 23 | 24 | bar :: Bar 25 | bar = Bar 10.55 [foo, foo] 26 | ``` 27 | 28 | If you run this in `ghci` and type `print bar`, you'll get output like this: 29 | 30 | ```haskell 31 | > print bar 32 | Bar {bar1 = 10.55, bar2 = [Foo {foo1 = 3, foo2 = ["hello","goodbye"]},Foo {foo1 = 3, foo2 = ["hello","goodbye"]}]} 33 | ``` 34 | 35 | This is pretty hard to read. Imagine if there were more fields or it were even 36 | more deeply nested. It would be even more difficult to read. 37 | 38 | `pretty-simple` can be used to print `bar` in an easy-to-read format: 39 | 40 | ![example screenshot](https://raw.githubusercontent.com/cdepillabout/pretty-simple/master/img/pretty-simple-example-screenshot.png) 41 | 42 | ## Usage 43 | 44 | `pretty-simple` can be easily used from `ghci` when debugging. 45 | 46 | When using `stack` to run `ghci`, just append the `--package` flag to 47 | the command line to load `pretty-simple`: 48 | 49 | ```sh 50 | $ stack ghci --package pretty-simple 51 | ``` 52 | 53 | Or, with cabal: 54 | 55 | ```sh 56 | $ cabal repl --build-depends pretty-simple 57 | ``` 58 | 59 | Once you get a prompt in `ghci`, you can use `import` to get `pretty-simple`'s 60 | [`pPrint`](https://hackage.haskell.org/package/pretty-simple/docs/Text-Pretty-Simple.html#v:pPrint) 61 | function in scope. 62 | 63 | ```haskell 64 | > import Text.Pretty.Simple (pPrint) 65 | ``` 66 | 67 | You can test out `pPrint` with simple data types like `Maybe` or tuples. 68 | 69 | ```haskell 70 | > pPrint $ Just ("hello", "goodbye") 71 | Just 72 | ( "hello" 73 | , "goodbye" 74 | ) 75 | ``` 76 | 77 | 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): 78 | ```hs 79 | pPrint :: Show a => a -> IO () 80 | pPrint = putStrLn <=< readProcess "pretty-simple" [] . show 81 | ``` 82 | 83 | 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. 84 | 85 | ## Features 86 | 87 | - Easy-to-read 88 | - Complex data types are simple to understand. 89 | - Color 90 | - Prints in color using ANSI escape codes. 91 | - It is possible to print without color by using the 92 | [`pPrintNoColor`](https://hackage.haskell.org/package/pretty-simple/docs/Text-Pretty-Simple.html#v:pPrintNoColor) 93 | function. 94 | - Rainbow Parentheses 95 | - Easy to understand deeply nested data types. 96 | - Configurable 97 | - Indentation, compactness, colors and more are configurable with the 98 | [`pPrintOpt`](https://hackage.haskell.org/package/pretty-simple-1.0.0.6/docs/Text-Pretty-Simple.html#v:pPrintOpt) 99 | function. 100 | - Fast 101 | - No problem pretty-printing data types thousands of lines long. 102 | - Works with any data type with a `Show` instance 103 | - Some common Haskell data types have a `Show` instance that produces 104 | non-valid Haskell code. `pretty-simple` will pretty-print even these 105 | data types. 106 | 107 | ## Why not `(some other package)`? 108 | 109 | Other pretty-printing packages have some combination of these defects: 110 | 111 | - No options for printing in color. 112 | - No options for changing the amount of indentation 113 | - Requires every data type to be an instance of some special typeclass (instead 114 | of just `Show`). 115 | - Requires all `Show` instances to output valid Haskell code. 116 | 117 | ## Other Uses 118 | 119 | ### Pretty-print all GHCi output 120 | 121 | The `pPrint` function can be used as the default output function in GHCi. 122 | 123 | All you need to do is run GHCi with a command like one of these: 124 | 125 | ```sh 126 | $ stack ghci --ghci-options "-interactive-print=Text.Pretty.Simple.pPrint" --package pretty-simple 127 | ``` 128 | ```sh 129 | $ cabal repl --repl-options "-interactive-print=Text.Pretty.Simple.pPrint" --build-depends pretty-simple 130 | ``` 131 | 132 | Now, whenever you make GHCi evaluate an expression, GHCi will pretty-print the 133 | result using `pPrint`! See 134 | [here](https://downloads.haskell.org/%7Eghc/latest/docs/html/users_guide/ghci.html#using-a-custom-interactive-printing-function) 135 | for more info on this neat feature in GHCi. 136 | 137 | ### Pretty-printing JSON 138 | 139 | `pretty-simple` can be used to pretty-print any `String` that is similar to 140 | Haskell data types. The only requirement is that the `String` must correctly 141 | use brackets, parenthese, and braces to indicate nesting. 142 | 143 | For example, the 144 | [`pString`](https://hackage.haskell.org/package/pretty-simple/docs/Text-Pretty-Simple.html#v:pString) 145 | function can be used to pretty-print JSON. 146 | 147 | Recall our example from before. 148 | 149 | ```haskell 150 | data Foo = Foo { foo1 :: Integer , foo2 :: [String] } deriving Show 151 | 152 | foo :: Foo 153 | foo = Foo 3 ["hello", "goodbye"] 154 | 155 | data Bar = Bar { bar1 :: Double , bar2 :: [Foo] } deriving Show 156 | 157 | bar :: Bar 158 | bar = Bar 10.55 [foo, foo] 159 | ``` 160 | 161 | You can use [`aeson`](https://hackage.haskell.org/package/aeson) to turn these 162 | data types into JSON. First, you must derive 163 | [`ToJSON`](https://hackage.haskell.org/package/aeson/docs/Data-Aeson.html#t:ToJSON) 164 | instances for the data types. It is easiest to do this with Template Haskell: 165 | 166 | ```haskell 167 | {-# LANGUAGE TemplateHaskell #-} 168 | 169 | $(deriveJSON defaultOptions ''Foo) 170 | $(deriveJSON defaultOptions ''Bar) 171 | ``` 172 | 173 | If you run this in `ghci` and type `encode bar`, you'll get output like this: 174 | 175 | ```haskell 176 | > import Data.Aeson (encode) 177 | > putLazyByteStringLn $ encode bar 178 | {"bar1":10.55,"bar2":[{"foo1":3,"foo2":["hello","goodbye"]},{"foo1":3,"foo2":["hello","goodbye"]}]} 179 | ``` 180 | 181 | Just like Haskell's normal `print` output, this is pretty hard to read. 182 | 183 | `pretty-simple` can be used to pretty-print the JSON-encoded `bar` in an 184 | easy-to-read format: 185 | 186 | ![json example screenshot](https://raw.githubusercontent.com/cdepillabout/pretty-simple/master/img/pretty-simple-json-example-screenshot.png) 187 | 188 | (You can find the `lazyByteStringToString`, `putLazyByteStringLn`, 189 | and `putLazyTextLn` in the [`ExampleJSON.hs`](example/ExampleJSON.hs) 190 | file.) 191 | 192 | ### Pretty-printing from the command line 193 | 194 | `pretty-simple` includes a command line executable that can be used to 195 | pretty-print anything passed in on stdin. 196 | 197 | It can be installed to `~/.local/bin/` with the following command. 198 | 199 | ```sh 200 | $ stack install pretty-simple 201 | ``` 202 | 203 | When run on the command line, you can paste in the Haskell datatype you want to 204 | be formatted, then hit Ctrl-D: 205 | 206 | ![cli example screenshot](https://raw.githubusercontent.com/cdepillabout/pretty-simple/master/img/pretty-simple-cli-screenshot.png) 207 | 208 | This is very useful if you accidentally print out a Haskell data type with 209 | `print` instead of `pPrint`. 210 | 211 | ## Contributions 212 | 213 | Feel free to open an 214 | [issue](https://github.com/cdepillabout/pretty-simple/issues) or 215 | [PR](https://github.com/cdepillabout/pretty-simple/pulls) for any 216 | bugs/problems/suggestions/improvements. 217 | 218 | ### Testing 219 | 220 | To run the test suite locally, one must install the executables `doctest` and 221 | `cabal-doctest`, e.g. with 222 | `cabal install --ignore-project doctest --flag cabal-doctest`. 223 | 224 | Then run the command `cabal doctest`. 225 | 226 | ## Maintainers 227 | 228 | - [@cdepillabout](https://github.com/cdepillabout) 229 | - [@georgefst](https://github.com/georgefst) 230 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | 2 | ## (next) 3 | 4 | * Fix double-quoting issue with `pTraceShowWith`. 5 | [#132](https://github.com/cdepillabout/pretty-simple/pull/132) 6 | Thanks [@leoslf](https://github.com/leoslf)! 7 | 8 | ## 4.1.3.0 9 | 10 | * Remove custom setup. This makes cross-compiling `pretty-simple` a lot more 11 | straightforward. No functionality has been lost from the library, since the 12 | custom setup was only used for generating tests. 13 | [#107](https://github.com/cdepillabout/pretty-simple/pull/107) 14 | 15 | ## 4.1.2.0 16 | 17 | * Fix a problem with the `pHPrint` function incorrectly 18 | outputting a trailing newline to stdout, instead of the 19 | handle you pass it. 20 | [#118](https://github.com/cdepillabout/pretty-simple/pull/118) 21 | * Add a [web app](https://cdepillabout.github.io/pretty-simple/) where you 22 | can play around with `pretty-simple` in your browser. 23 | [#116](https://github.com/cdepillabout/pretty-simple/pull/116). 24 | This took a lot of hard work by [@georgefst](https://github.com/georgefst)! 25 | 26 | ## 4.1.1.0 27 | 28 | * Make the pretty-printed output with `outputOptionsCompact` enabled a little 29 | more compact. 30 | [#110](https://github.com/cdepillabout/pretty-simple/pull/110). 31 | Thanks [@juhp](https://github.com/juhp)! 32 | * Add a `--compact` / `-C` flag to the `pretty-simple` executable that enables 33 | `outputOptionsCompact`. 34 | [#111](https://github.com/cdepillabout/pretty-simple/pull/111). 35 | Thanks again @juhp! 36 | * Add `pTraceWith` and `pTraceShowWith` to `Debug.Pretty.Simple`. 37 | [#104](https://github.com/cdepillabout/pretty-simple/pull/104). 38 | Thanks [@LeviButcher](https://github.com/LeviButcher)! 39 | 40 | ## 4.1.0.0 41 | 42 | * Fix a regression which arose in 4.0, whereby excess spaces would be inserted for unusual strings like dates and IP addresses. 43 | [#105](https://github.com/cdepillabout/pretty-simple/pull/105) 44 | * Attach warnings to debugging functions, so that they're easy to find and remove. 45 | [#103](https://github.com/cdepillabout/pretty-simple/pull/103) 46 | * Some minor improvements to the CLI tool: 47 | * Add a `--version`/`-v` flag. 48 | [#83](https://github.com/cdepillabout/pretty-simple/pull/83) 49 | * Add a trailing newline. 50 | [#87](https://github.com/cdepillabout/pretty-simple/pull/87) 51 | * Install by default, without requiring a flag. 52 | [#94](https://github.com/cdepillabout/pretty-simple/pull/94) 53 | 54 | ## 4.0.0.0 55 | 56 | * Expand `OutputOptions`: 57 | * Compactness, including grouping of parentheses. 58 | [#72](https://github.com/cdepillabout/pretty-simple/pull/72) 59 | * Page width, affecting when lines are grouped if compact output is enabled. 60 | [#72](https://github.com/cdepillabout/pretty-simple/pull/72) 61 | * Indent whole expression. Useful when using `pretty-simple` for one part 62 | of a larger output. 63 | [#71](https://github.com/cdepillabout/pretty-simple/pull/71) 64 | * Use `Style` type for easier configuration of colour, boldness etc. 65 | [#73](https://github.com/cdepillabout/pretty-simple/pull/73) 66 | * Significant internal rewrite of printing code, to make use of the [prettyprinter](https://hackage.haskell.org/package/prettyprinter) 67 | library. The internal function `layoutString` can be used to integrate with 68 | other `prettyprinter` backends, such as [prettyprinter-lucid](https://hackage.haskell.org/package/prettyprinter-lucid) 69 | for HTML output. 70 | [#67](https://github.com/cdepillabout/pretty-simple/pull/67) 71 | 72 | ## 3.3.0.0 73 | 74 | * Add an output option to print escaped and non-printable characters 75 | literally when outputting strings. 76 | [#68](https://github.com/cdepillabout/pretty-simple/pull/68) and 77 | [#69](https://github.com/cdepillabout/pretty-simple/pull/69) 78 | Thanks Joe Hermaszewski ([@expipiplus1](https://github.com/expipiplus1))! 79 | 80 | ## 3.2.3.0 81 | 82 | * Fix a bug that messes up printing identifiers with `'` in the name. 83 | Now identifiers like `data Don't = Don't` show up properly. 84 | [#65](https://github.com/cdepillabout/pretty-simple/pull/65) 85 | Thanks George Thomas ([@georgefst](https://github.com/georgefst))! 86 | 87 | ## 3.2.2.0 88 | 89 | * Remove whitespace from the ends of lines. 90 | [#62](https://github.com/cdepillabout/pretty-simple/pull/62) 91 | Thanks Gaith Hallak ([@ghallak](https://github.com/ghallak))! 92 | 93 | ## 3.2.1.0 94 | 95 | * Added `pTraceOpt` functions to `Debug.Pretty.Simple`. 96 | [#58](https://github.com/cdepillabout/pretty-simple/pull/58) 97 | Thanks again [sureyeaah](https://github.com/sureyeaah)! 98 | 99 | ## 3.2.0.0 100 | 101 | * Add support for pretty-printing Haskell character literals. 102 | [#57](https://github.com/cdepillabout/pretty-simple/pull/57) 103 | Thanks again [sjakobi](https://github.com/sjakobi)! 104 | 105 | ## 3.1.1.0 106 | 107 | * Added a `pPrintString` function for pretty-printing a `String` that is the 108 | output of `show`. Implemented in 109 | [#54](https://github.com/cdepillabout/pretty-simple/pull/54). Thanks 110 | [sureyeaah](https://github.com/sureyeaah)! 111 | * Fix build on GHC-7.10.3. 112 | [#55](https://github.com/cdepillabout/pretty-simple/pull/55). Thanks 113 | [sjakobi](https://github.com/sjakobi). 114 | 115 | ## 3.1.0.0 116 | 117 | * Numbers are now highlighted in green by default. Implemented in 118 | [#51](https://github.com/cdepillabout/pretty-simple/pull/51). 119 | Thanks [lawrencebell](https://github.com/lawrencebell)! 120 | 121 | ## 3.0.0.0 122 | 123 | * pretty-simple now escapes non-printable characters by default. A field 124 | called `outputOptionsEscapeNonPrintable` has been added to `OutputOptions` 125 | to control this behavior. Implemented in 126 | [#44](https://github.com/cdepillabout/pretty-simple/pull/44). Thanks 127 | [dminuoso](https://github.com/dminuoso)! 128 | * pretty-simple now checks the output `Handle` to determine whether to print 129 | in color when using functions like `pPrint`. This makes it so that you 130 | can redirect output to a file on disk and still be able to read the 131 | output from `pPrint`! Implemented in 132 | [#47](https://github.com/cdepillabout/pretty-simple/pull/47). Thanks 133 | [metiulekm](https://github.com/metiulekm)! 134 | * Add functions like `pHPrint` for specifying the `Handle` to output to. 135 | Added in [#47](https://github.com/cdepillabout/pretty-simple/pull/47). 136 | 137 | ## 2.2.0.1 138 | * Fixed a [bug](https://github.com/cdepillabout/pretty-simple/pull/41) where 139 | the parser failed to parse escaped quotation marks in string literals. 140 | Thanks [Andreas](https://github.com/anka-213)! 141 | 142 | 143 | ## 2.2.0.0 144 | 145 | * Fixed a [bug](https://github.com/cdepillabout/pretty-simple/pull/33) with a 146 | missing space after strings. Thanks again 147 | [Andrew](https://github.com/andrew-lei)! 148 | * Add a command line flag `--color` to be able to set whether to use colors for 149 | a dark background (`--color dark-bg`), a light background (`--color light-bg`), 150 | or no color (`--color no-color`). This is from 151 | [great work](https://github.com/cdepillabout/pretty-simple/pull/35) by 152 | [Andrew](https://github.com/andrew-lei)! 153 | * Made parsing/printing lazy - pretty-printing will now output strings continuously 154 | as they're read, handling potentially infinite input. 155 | 156 | ## 2.1.0.1 157 | 158 | * Fix a [bug](https://github.com/cdepillabout/pretty-simple/pull/32) where 159 | printing deeply nested data structures would take exponential time. Thanks 160 | [Andrew](https://github.com/andrew-lei)! 161 | 162 | ## 2.1.0.0 163 | 164 | * Make strings have indentation by default when pretty-printed. See 165 | [#26](https://github.com/cdepillabout/pretty-simple/pull/26). Thanks 166 | [Milan](https://github.com/Wizek)! 167 | 168 | ## 2.0.2.1 169 | 170 | * Add a small command-line program that will pretty print anything from stdin 171 | called `pretty-print`. It can be installed to `~/.local/bin` if you enable 172 | the flag `buildexe` like so: 173 | 174 | ```sh 175 | $ stack install pretty-simple-2.0.2.1 --flag pretty-simple:buildexe 176 | ``` 177 | 178 | When you run it, you can paste something you want formatted on stdin, then 179 | press Ctrl-D. It will print the formatted version on 180 | stdout: 181 | 182 | ```sh 183 | $ pretty-simple 184 | [(Just 3, Just 4)] 185 | 186 | ^D 187 | 188 | [ 189 | ( Just 3 190 | , Just 4 191 | ) 192 | ] 193 | ``` 194 | 195 | ## 2.0.2.0 196 | 197 | * Fix a [problem](https://github.com/cdepillabout/pretty-simple/pull/20) with 198 | the pTraceShow functions not working correctly. 199 | 200 | ## 2.0.1.0 201 | 202 | * Added the `Debug.Pretty.Simple` that exports functions that work like 203 | `Debug.Trace`. 204 | -------------------------------------------------------------------------------- /src/Text/Pretty/Simple/Internal/Printer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE LambdaCase #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE RankNTypes #-} 8 | {-# LANGUAGE RecordWildCards #-} 9 | {-# LANGUAGE ScopedTypeVariables #-} 10 | 11 | {-| 12 | Module : Text.Pretty.Simple.Internal.Printer 13 | Copyright : (c) Dennis Gosnell, 2016 14 | License : BSD-style (see LICENSE file) 15 | Maintainer : cdep.illabout@gmail.com 16 | Stability : experimental 17 | Portability : POSIX 18 | 19 | -} 20 | module Text.Pretty.Simple.Internal.Printer 21 | where 22 | 23 | -- We don't need these imports for later GHCs as all required functions 24 | -- are exported from Prelude 25 | #if __GLASGOW_HASKELL__ < 710 26 | import Control.Applicative 27 | #endif 28 | #if __GLASGOW_HASKELL__ < 804 29 | import Data.Monoid ((<>)) 30 | #endif 31 | 32 | import Control.Monad.IO.Class (MonadIO, liftIO) 33 | import Control.Monad (join) 34 | import Control.Monad.State (MonadState, evalState, modify, gets) 35 | import Data.Char (isPrint, isSpace, ord,) 36 | import Data.List.NonEmpty (NonEmpty, nonEmpty) 37 | import Data.Maybe (fromMaybe) 38 | import Prettyprinter 39 | (indent, line', PageWidth(AvailablePerLine), layoutPageWidth, nest, 40 | concatWith, space, Doc, SimpleDocStream, annotate, defaultLayoutOptions, 41 | enclose, hcat, layoutSmart, line, unAnnotateS, pretty, group, 42 | removeTrailingWhitespace) 43 | import Data.Typeable (Typeable) 44 | import GHC.Generics (Generic) 45 | import Numeric (showHex) 46 | import System.IO (Handle, hIsTerminalDevice) 47 | import Text.Read (readMaybe) 48 | 49 | import Text.Pretty.Simple.Internal.Expr 50 | (Expr(..), CommaSeparated(CommaSeparated)) 51 | import Text.Pretty.Simple.Internal.ExprParser (expressionParse) 52 | import Text.Pretty.Simple.Internal.Color 53 | (colorNull, Style, ColorOptions(..), defaultColorOptionsDarkBg, 54 | defaultColorOptionsLightBg) 55 | 56 | -- $setup 57 | -- >>> import Text.Pretty.Simple (pPrintString, pPrintStringOpt) 58 | 59 | -- | Determines whether pretty-simple should check if the output 'Handle' is a 60 | -- TTY device. Normally, users only want to print in color if the output 61 | -- 'Handle' is a TTY device. 62 | data CheckColorTty 63 | = CheckColorTty 64 | -- ^ Check if the output 'Handle' is a TTY device. If the output 'Handle' is 65 | -- a TTY device, determine whether to print in color based on 66 | -- 'outputOptionsColorOptions'. If not, then set 'outputOptionsColorOptions' 67 | -- to 'Nothing' so the output does not get colorized. 68 | | NoCheckColorTty 69 | -- ^ Don't check if the output 'Handle' is a TTY device. Determine whether to 70 | -- colorize the output based solely on the value of 71 | -- 'outputOptionsColorOptions'. 72 | deriving (Eq, Generic, Show, Typeable) 73 | 74 | -- | Control how escaped and non-printable are output for strings. 75 | -- 76 | -- See 'outputOptionsStringStyle' for what the output looks like with each of 77 | -- these options. 78 | data StringOutputStyle 79 | = Literal 80 | -- ^ Output string literals by printing the source characters exactly. 81 | -- 82 | -- For examples: without this option the printer will insert a newline in 83 | -- place of @"\n"@, with this options the printer will output @'\'@ and 84 | -- @'n'@. Similarly the exact escape codes used in the input string will be 85 | -- replicated, so @"\65"@ will be printed as @"\65"@ and not @"A"@. 86 | | EscapeNonPrintable 87 | -- ^ Replace non-printable characters with hexadecimal escape sequences. 88 | | DoNotEscapeNonPrintable 89 | -- ^ Output non-printable characters without modification. 90 | deriving (Eq, Generic, Show, Typeable) 91 | 92 | -- | Data-type wrapping up all the options available when rendering the list 93 | -- of 'Output's. 94 | data OutputOptions = OutputOptions 95 | { outputOptionsIndentAmount :: Int 96 | -- ^ Number of spaces to use when indenting. It should probably be either 2 97 | -- or 4. 98 | , outputOptionsPageWidth :: Int 99 | -- ^ The maximum number of characters to fit on to one line. 100 | , outputOptionsCompact :: Bool 101 | -- ^ Use less vertical (and more horizontal) space. 102 | , outputOptionsCompactParens :: Bool 103 | -- ^ Group closing parentheses on to a single line. 104 | , outputOptionsInitialIndent :: Int 105 | -- ^ Indent the whole output by this amount. 106 | , outputOptionsColorOptions :: Maybe ColorOptions 107 | -- ^ If this is 'Nothing', then don't colorize the output. If this is 108 | -- @'Just' colorOptions@, then use @colorOptions@ to colorize the output. 109 | -- 110 | , outputOptionsStringStyle :: StringOutputStyle 111 | -- ^ Controls how string literals are output. 112 | -- 113 | -- By default, the pPrint functions escape non-printable characters, but 114 | -- print all printable characters: 115 | -- 116 | -- >>> pPrintString "\"A \\x42 Ä \\xC4 \\x1 \\n\"" 117 | -- "A B Ä Ä \x1 118 | -- " 119 | -- 120 | -- Here, you can see that the character @A@ has been printed as-is. @\x42@ 121 | -- has been printed in the non-escaped version, @B@. The non-printable 122 | -- character @\x1@ has been printed as @\x1@. Newlines will be removed to 123 | -- make the output easier to read. 124 | -- 125 | -- This corresponds to the 'StringOutputStyle' called 'EscapeNonPrintable'. 126 | -- 127 | -- (Note that in the above and following examples, the characters have to be 128 | -- double-escaped, which makes it somewhat confusing...) 129 | -- 130 | -- Another output style is 'DoNotEscapeNonPrintable'. This is similar 131 | -- to 'EscapeNonPrintable', except that non-printable characters get printed 132 | -- out literally to the screen. 133 | -- 134 | -- >>> pPrintStringOpt CheckColorTty defaultOutputOptionsDarkBg{ outputOptionsStringStyle = DoNotEscapeNonPrintable } "\"A \\x42 Ä \\xC4 \\n\"" 135 | -- "A B Ä Ä 136 | -- " 137 | -- 138 | -- If you change the above example to contain @\x1@, you can see that it is 139 | -- output as a literal, non-escaped character. Newlines are still removed 140 | -- for readability. 141 | -- 142 | -- Another output style is 'Literal'. This just outputs all escape characters. 143 | -- 144 | -- >>> pPrintStringOpt CheckColorTty defaultOutputOptionsDarkBg{ outputOptionsStringStyle = Literal } "\"A \\x42 Ä \\xC4 \\x1 \\n\"" 145 | -- "A \x42 Ä \xC4 \x1 \n" 146 | -- 147 | -- You can see that all the escape characters get output literally, including 148 | -- newline. 149 | } deriving (Eq, Generic, Show, Typeable) 150 | 151 | -- | Default values for 'OutputOptions' when printing to a console with a dark 152 | -- background. 'outputOptionsIndentAmount' is 4, and 153 | -- 'outputOptionsColorOptions' is 'defaultColorOptionsDarkBg'. 154 | defaultOutputOptionsDarkBg :: OutputOptions 155 | defaultOutputOptionsDarkBg = 156 | defaultOutputOptionsNoColor 157 | { outputOptionsColorOptions = Just defaultColorOptionsDarkBg } 158 | 159 | -- | Default values for 'OutputOptions' when printing to a console with a light 160 | -- background. 'outputOptionsIndentAmount' is 4, and 161 | -- 'outputOptionsColorOptions' is 'defaultColorOptionsLightBg'. 162 | defaultOutputOptionsLightBg :: OutputOptions 163 | defaultOutputOptionsLightBg = 164 | defaultOutputOptionsNoColor 165 | { outputOptionsColorOptions = Just defaultColorOptionsLightBg } 166 | 167 | -- | Default values for 'OutputOptions' when printing using using ANSI escape 168 | -- sequences for color. 'outputOptionsIndentAmount' is 4, and 169 | -- 'outputOptionsColorOptions' is 'Nothing'. 170 | defaultOutputOptionsNoColor :: OutputOptions 171 | defaultOutputOptionsNoColor = 172 | OutputOptions 173 | { outputOptionsIndentAmount = 4 174 | , outputOptionsPageWidth = 80 175 | , outputOptionsCompact = False 176 | , outputOptionsCompactParens = False 177 | , outputOptionsInitialIndent = 0 178 | , outputOptionsColorOptions = Nothing 179 | , outputOptionsStringStyle = EscapeNonPrintable 180 | } 181 | 182 | -- | Given 'OutputOptions', disable colorful output if the given handle 183 | -- is not connected to a TTY. 184 | hCheckTTY :: MonadIO m => Handle -> OutputOptions -> m OutputOptions 185 | hCheckTTY h options = liftIO $ conv <$> tty 186 | where 187 | conv :: Bool -> OutputOptions 188 | conv True = options 189 | conv False = options { outputOptionsColorOptions = Nothing } 190 | 191 | tty :: IO Bool 192 | tty = hIsTerminalDevice h 193 | 194 | -- | Parse a string, and generate an intermediate representation, 195 | -- suitable for passing to any /prettyprinter/ backend. 196 | -- Used by 'Simple.pString' etc. 197 | layoutString :: OutputOptions -> String -> SimpleDocStream Style 198 | layoutString opts = annotateStyle opts . layoutStringAbstract opts 199 | 200 | layoutStringAbstract :: OutputOptions -> String -> SimpleDocStream Annotation 201 | layoutStringAbstract opts = 202 | removeTrailingWhitespace 203 | . layoutSmart defaultLayoutOptions 204 | {layoutPageWidth = AvailablePerLine (outputOptionsPageWidth opts) 1} 205 | . indent (outputOptionsInitialIndent opts) 206 | . prettyExprs' opts 207 | . expressionParse 208 | 209 | -- | Slight adjustment of 'prettyExprs' for the outermost level, 210 | -- to avoid indenting everything. 211 | prettyExprs' :: OutputOptions -> [Expr] -> Doc Annotation 212 | prettyExprs' opts = \case 213 | [] -> mempty 214 | x : xs -> prettyExpr opts x <> prettyExprs opts xs 215 | 216 | -- | Construct a 'Doc' from multiple 'Expr's. 217 | prettyExprs :: OutputOptions -> [Expr] -> Doc Annotation 218 | prettyExprs opts = hcat . map subExpr 219 | where 220 | subExpr x = 221 | let doc = prettyExpr opts x 222 | in 223 | if isSimple x then 224 | -- keep the expression on the current line 225 | nest 2 doc 226 | else 227 | -- put the expression on a new line, indented (unless grouped) 228 | nest (outputOptionsIndentAmount opts) $ line' <> doc 229 | 230 | -- | Construct a 'Doc' from a single 'Expr'. 231 | prettyExpr :: OutputOptions -> Expr -> Doc Annotation 232 | prettyExpr opts = (if outputOptionsCompact opts then group else id) . \case 233 | Brackets xss -> list "[" "]" xss 234 | Braces xss -> list "{" "}" xss 235 | Parens xss -> list "(" ")" xss 236 | StringLit s -> join enclose (annotate Quote "\"") $ annotate String $ pretty $ escapeString s 237 | CharLit s -> join enclose (annotate Quote "'") $ annotate String $ pretty $ escapeString s 238 | Other s -> pretty s 239 | NumberLit n -> annotate Num $ pretty n 240 | where 241 | escapeString s = case outputOptionsStringStyle opts of 242 | Literal -> s 243 | EscapeNonPrintable -> escapeNonPrintable $ readStr s 244 | DoNotEscapeNonPrintable -> readStr s 245 | readStr :: String -> String 246 | readStr s = fromMaybe s . readMaybe $ '"' : s ++ "\"" 247 | list :: Doc Annotation -> Doc Annotation -> CommaSeparated [Expr] 248 | -> Doc Annotation 249 | list open close (CommaSeparated xss) = 250 | enclose (annotate Open open) (annotate Close close) $ case xss of 251 | [] -> mempty 252 | [xs] | all isSimple xs -> 253 | space <> hcat (map (prettyExpr opts) xs) <> space 254 | _ -> concatWith lineAndCommaSep (map (\xs -> spaceIfNeeded xs <> prettyExprs opts xs) xss) 255 | <> if outputOptionsCompactParens opts then space else line 256 | where 257 | spaceIfNeeded = \case 258 | Other (' ' : _) : _ -> mempty 259 | _ -> space 260 | lineAndCommaSep x y = x <> munless (outputOptionsCompact opts) line' <> annotate Comma "," <> y 261 | munless b x = if b then mempty else x 262 | 263 | -- | Determine whether this expression should be displayed on a single line. 264 | isSimple :: Expr -> Bool 265 | isSimple = \case 266 | Brackets (CommaSeparated xs) -> isListSimple xs 267 | Braces (CommaSeparated xs) -> isListSimple xs 268 | Parens (CommaSeparated xs) -> isListSimple xs 269 | _ -> True 270 | where 271 | isListSimple = \case 272 | [[e]] -> isSimple e && case e of Other s -> not $ any isSpace s ; _ -> True 273 | _:_ -> False 274 | [] -> True 275 | 276 | -- | Traverse the stream, using a 'Tape' to keep track of the current style. 277 | annotateStyle :: OutputOptions -> SimpleDocStream Annotation 278 | -> SimpleDocStream Style 279 | annotateStyle opts ds = case outputOptionsColorOptions opts of 280 | Nothing -> unAnnotateS ds 281 | Just ColorOptions {..} -> evalState (traverse style ds) initialTape 282 | where 283 | style :: MonadState (Tape Style) m => Annotation -> m Style 284 | style = \case 285 | Open -> modify moveR *> gets tapeHead 286 | Close -> gets tapeHead <* modify moveL 287 | Comma -> gets tapeHead 288 | Quote -> pure colorQuote 289 | String -> pure colorString 290 | Num -> pure colorNum 291 | initialTape = Tape 292 | { tapeLeft = streamRepeat colorError 293 | , tapeHead = colorError 294 | , tapeRight = streamCycle $ fromMaybe (pure colorNull) 295 | $ nonEmpty colorRainbowParens 296 | } 297 | 298 | -- | An abstract annotation type, representing the various elements 299 | -- we may want to highlight. 300 | data Annotation 301 | = Open 302 | | Close 303 | | Comma 304 | | Quote 305 | | String 306 | | Num 307 | deriving (Eq, Show) 308 | 309 | -- | Replace non-printable characters with hex escape sequences. 310 | -- 311 | -- >>> escapeNonPrintable "\x1\x2" 312 | -- "\\x1\\x2" 313 | -- 314 | -- Newlines will not be escaped. 315 | -- 316 | -- >>> escapeNonPrintable "hello\nworld" 317 | -- "hello\nworld" 318 | -- 319 | -- Printable characters will not be escaped. 320 | -- 321 | -- >>> escapeNonPrintable "h\101llo" 322 | -- "hello" 323 | escapeNonPrintable :: String -> String 324 | escapeNonPrintable = foldr escape "" 325 | 326 | -- | Replace an unprintable character except a newline 327 | -- with a hex escape sequence. 328 | escape :: Char -> ShowS 329 | escape c 330 | | isPrint c || c == '\n' = (c:) 331 | | otherwise = ('\\':) . ('x':) . showHex (ord c) 332 | 333 | -- | A bidirectional Turing-machine tape: 334 | -- infinite in both directions, with a head pointing to one element. 335 | data Tape a = Tape 336 | { tapeLeft :: Stream a -- ^ the side of the 'Tape' left of 'tapeHead' 337 | , tapeHead :: a -- ^ the focused element 338 | , tapeRight :: Stream a -- ^ the side of the 'Tape' right of 'tapeHead' 339 | } deriving Show 340 | -- | Move the head left 341 | moveL :: Tape a -> Tape a 342 | moveL (Tape (l :.. ls) c rs) = Tape ls l (c :.. rs) 343 | -- | Move the head right 344 | moveR :: Tape a -> Tape a 345 | moveR (Tape ls c (r :.. rs)) = Tape (c :.. ls) r rs 346 | 347 | -- | An infinite list 348 | data Stream a = a :.. Stream a deriving Show 349 | -- | Analogous to 'repeat' 350 | streamRepeat :: t -> Stream t 351 | streamRepeat x = x :.. streamRepeat x 352 | -- | Analogous to 'cycle' 353 | -- While the inferred signature here is more general, 354 | -- it would diverge on an empty structure 355 | streamCycle :: NonEmpty a -> Stream a 356 | streamCycle xs = foldr (:..) (streamCycle xs) xs 357 | -------------------------------------------------------------------------------- /src/Debug/Pretty/Simple.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | {-| 4 | Module : Debug.Pretty.Simple 5 | Copyright : (c) Dennis Gosnell, 2017 6 | License : BSD-style (see LICENSE file) 7 | Maintainer : cdep.illabout@gmail.com 8 | Stability : experimental 9 | Portability : POSIX 10 | 11 | This module contains the same functionality with Prelude's "Debug.Trace" module, 12 | with pretty printing the debug strings. 13 | 14 | Warning: This module also shares the same unsafety of "Debug.Trace" module. 15 | -} 16 | 17 | module Debug.Pretty.Simple 18 | ( -- * Trace with color on dark background 19 | -- This determines whether to print in color by looking at whether 'stderr' 20 | -- is a TTY device. 21 | pTrace 22 | , pTraceId 23 | , pTraceShow 24 | , pTraceShowId 25 | , pTraceIO 26 | , pTraceM 27 | , pTraceShowM 28 | , pTraceStack 29 | , pTraceEvent 30 | , pTraceEventIO 31 | , pTraceMarker 32 | , pTraceMarkerIO 33 | , pTraceWith 34 | , pTraceShowWith 35 | -- * Trace forcing color 36 | , pTraceForceColor 37 | , pTraceIdForceColor 38 | , pTraceShowForceColor 39 | , pTraceShowIdForceColor 40 | , pTraceMForceColor 41 | , pTraceShowMForceColor 42 | , pTraceStackForceColor 43 | , pTraceEventForceColor 44 | , pTraceEventIOForceColor 45 | , pTraceMarkerForceColor 46 | , pTraceMarkerIOForceColor 47 | , pTraceIOForceColor 48 | -- * Trace without color 49 | , pTraceNoColor 50 | , pTraceIdNoColor 51 | , pTraceShowNoColor 52 | , pTraceShowIdNoColor 53 | , pTraceMNoColor 54 | , pTraceShowMNoColor 55 | , pTraceStackNoColor 56 | , pTraceEventNoColor 57 | , pTraceEventIONoColor 58 | , pTraceMarkerNoColor 59 | , pTraceMarkerIONoColor 60 | , pTraceIONoColor 61 | -- * Trace With 'OutputOptions' 62 | , pTraceOpt 63 | , pTraceIdOpt 64 | , pTraceShowOpt 65 | , pTraceShowIdOpt 66 | , pTraceOptIO 67 | , pTraceOptM 68 | , pTraceShowOptM 69 | , pTraceStackOpt 70 | , pTraceEventOpt 71 | , pTraceEventOptIO 72 | , pTraceMarkerOpt 73 | , pTraceMarkerOptIO 74 | ) where 75 | 76 | import Control.Monad ((<=<)) 77 | import Data.Text.Lazy (Text, unpack) 78 | import Debug.Trace 79 | (trace, traceEvent, traceEventIO, traceIO, traceM, traceMarker, 80 | traceMarkerIO, traceStack) 81 | import System.IO (stderr) 82 | import System.IO.Unsafe (unsafePerformIO) 83 | import Text.Pretty.Simple 84 | (CheckColorTty(..), OutputOptions, pStringOpt, 85 | defaultOutputOptionsNoColor, defaultOutputOptionsDarkBg) 86 | import Text.Pretty.Simple.Internal (hCheckTTY) 87 | 88 | #if __GLASGOW_HASKELL__ < 710 89 | -- We don't need this import for GHC 7.10 as it exports all required functions 90 | -- from Prelude 91 | import Control.Applicative 92 | #endif 93 | 94 | {-| 95 | The 'pTraceIO' function outputs the trace message from the IO monad. 96 | This sequences the output with respect to other IO actions. 97 | 98 | @since 2.0.1.0 99 | -} 100 | {-# WARNING pTraceIO "'pTraceIO' remains in code" #-} 101 | pTraceIO :: String -> IO () 102 | pTraceIO = pTraceOptIO CheckColorTty defaultOutputOptionsDarkBg 103 | 104 | {-| 105 | The 'pTrace' function pretty prints the trace message given as its first 106 | argument, before returning the second argument as its result. 107 | 108 | For example, this returns the value of @f x@ but first outputs the message. 109 | 110 | > pTrace ("calling f with x = " ++ show x) (f x) 111 | 112 | The 'pTrace' function should /only/ be used for debugging, or for monitoring 113 | execution. The function is not referentially transparent: its type indicates 114 | that it is a pure function but it has the side effect of outputting the 115 | trace message. 116 | 117 | @since 2.0.1.0 118 | -} 119 | {-# WARNING pTrace "'pTrace' remains in code" #-} 120 | pTrace :: String -> a -> a 121 | pTrace = pTraceOpt CheckColorTty defaultOutputOptionsDarkBg 122 | 123 | {-| 124 | Like 'pTrace' but returns the message instead of a third value. 125 | 126 | @since 2.0.1.0 127 | -} 128 | {-# WARNING pTraceId "'pTraceId' remains in code" #-} 129 | pTraceId :: String -> String 130 | pTraceId = pTraceIdOpt CheckColorTty defaultOutputOptionsDarkBg 131 | 132 | {-| 133 | Like 'pTrace', but uses 'show' on the argument to convert it to a 'String'. 134 | 135 | This makes it convenient for printing the values of interesting variables or 136 | expressions inside a function. For example here we print the value of the 137 | variables @x@ and @z@: 138 | 139 | > f x y = 140 | > pTraceShow (x, z) $ result 141 | > where 142 | > z = ... 143 | > ... 144 | 145 | @since 2.0.1.0 146 | -} 147 | {-# WARNING pTraceShow "'pTraceShow' remains in code" #-} 148 | pTraceShow :: (Show a) => a -> b -> b 149 | pTraceShow = pTraceShowOpt CheckColorTty defaultOutputOptionsDarkBg 150 | 151 | {-| 152 | Like 'pTraceShow' but returns the shown value instead of a third value. 153 | 154 | @since 2.0.1.0 155 | -} 156 | {-# WARNING pTraceShowId "'pTraceShowId' remains in code" #-} 157 | pTraceShowId :: (Show a) => a -> a 158 | pTraceShowId = pTraceShowIdOpt CheckColorTty defaultOutputOptionsDarkBg 159 | {-| 160 | Like 'pTrace' but returning unit in an arbitrary 'Applicative' context. Allows 161 | for convenient use in do-notation. 162 | 163 | Note that the application of 'pTraceM' is not an action in the 'Applicative' 164 | context, as 'pTraceIO' is in the 'IO' type. While the fresh bindings in the 165 | following example will force the 'traceM' expressions to be reduced every time 166 | the @do@-block is executed, @traceM "not crashed"@ would only be reduced once, 167 | and the message would only be printed once. If your monad is in 'MonadIO', 168 | @liftIO . pTraceIO@ may be a better option. 169 | 170 | > ... = do 171 | > x <- ... 172 | > pTraceM $ "x: " ++ show x 173 | > y <- ... 174 | > pTraceM $ "y: " ++ show y 175 | 176 | @since 2.0.1.0 177 | -} 178 | {-# WARNING pTraceM "'pTraceM' remains in code" #-} 179 | #if __GLASGOW_HASKELL__ < 800 180 | pTraceM :: (Monad f) => String -> f () 181 | #else 182 | pTraceM :: (Applicative f) => String -> f () 183 | #endif 184 | pTraceM = pTraceOptM CheckColorTty defaultOutputOptionsDarkBg 185 | {-| 186 | Like 'pTraceM', but uses 'show' on the argument to convert it to a 'String'. 187 | 188 | > ... = do 189 | > x <- ... 190 | > pTraceShowM $ x 191 | > y <- ... 192 | > pTraceShowM $ x + y 193 | 194 | @since 2.0.1.0 195 | -} 196 | {-# WARNING pTraceShowM "'pTraceShowM' remains in code" #-} 197 | #if __GLASGOW_HASKELL__ < 800 198 | pTraceShowM :: (Show a, Monad f) => a -> f () 199 | #else 200 | pTraceShowM :: (Show a, Applicative f) => a -> f () 201 | #endif 202 | pTraceShowM = pTraceShowOptM CheckColorTty defaultOutputOptionsDarkBg 203 | 204 | {-| 205 | like 'pTrace', but additionally prints a call stack if one is 206 | available. 207 | 208 | In the current GHC implementation, the call stack is only 209 | available if the program was compiled with @-prof@; otherwise 210 | 'pTraceStack' behaves exactly like 'pTrace'. Entries in the call 211 | stack correspond to @SCC@ annotations, so it is a good idea to use 212 | @-fprof-auto@ or @-fprof-auto-calls@ to add SCC annotations automatically. 213 | 214 | @since 2.0.1.0 215 | -} 216 | {-# WARNING pTraceStack "'pTraceStack' remains in code" #-} 217 | pTraceStack :: String -> a -> a 218 | pTraceStack = pTraceStackOpt CheckColorTty defaultOutputOptionsDarkBg 219 | 220 | {-| 221 | The 'pTraceEvent' function behaves like 'trace' with the difference that 222 | the message is emitted to the eventlog, if eventlog profiling is available 223 | and enabled at runtime. 224 | 225 | It is suitable for use in pure code. In an IO context use 'pTraceEventIO' 226 | instead. 227 | 228 | Note that when using GHC's SMP runtime, it is possible (but rare) to get 229 | duplicate events emitted if two CPUs simultaneously evaluate the same thunk 230 | that uses 'pTraceEvent'. 231 | 232 | @since 2.0.1.0 233 | -} 234 | {-# WARNING pTraceEvent "'pTraceEvent' remains in code" #-} 235 | pTraceEvent :: String -> a -> a 236 | pTraceEvent = pTraceEventOpt CheckColorTty defaultOutputOptionsDarkBg 237 | 238 | {-| 239 | The 'pTraceEventIO' function emits a message to the eventlog, if eventlog 240 | profiling is available and enabled at runtime. 241 | 242 | Compared to 'pTraceEvent', 'pTraceEventIO' sequences the event with respect to 243 | other IO actions. 244 | 245 | @since 2.0.1.0 246 | -} 247 | {-# WARNING pTraceEventIO "'pTraceEventIO' remains in code" #-} 248 | pTraceEventIO :: String -> IO () 249 | pTraceEventIO = pTraceEventOptIO CheckColorTty defaultOutputOptionsDarkBg 250 | 251 | -- | The 'pTraceMarker' function emits a marker to the eventlog, if eventlog 252 | -- profiling is available and enabled at runtime. The @String@ is the name of 253 | -- the marker. The name is just used in the profiling tools to help you keep 254 | -- clear which marker is which. 255 | -- 256 | -- This function is suitable for use in pure code. In an IO context use 257 | -- 'pTraceMarkerIO' instead. 258 | -- 259 | -- Note that when using GHC's SMP runtime, it is possible (but rare) to get 260 | -- duplicate events emitted if two CPUs simultaneously evaluate the same thunk 261 | -- that uses 'pTraceMarker'. 262 | -- 263 | -- @since 2.0.1.0 264 | {-# WARNING pTraceMarker "'pTraceMarker' remains in code" #-} 265 | pTraceMarker :: String -> a -> a 266 | pTraceMarker = pTraceMarkerOpt CheckColorTty defaultOutputOptionsDarkBg 267 | 268 | -- | The 'pTraceMarkerIO' function emits a marker to the eventlog, if eventlog 269 | -- profiling is available and enabled at runtime. 270 | -- 271 | -- Compared to 'pTraceMarker', 'pTraceMarkerIO' sequences the event with respect 272 | -- to other IO actions. 273 | -- 274 | -- @since 2.0.1.0 275 | {-# WARNING pTraceMarkerIO "'pTraceMarkerIO' remains in code" #-} 276 | pTraceMarkerIO :: String -> IO () 277 | pTraceMarkerIO = pTraceMarkerOptIO CheckColorTty defaultOutputOptionsDarkBg 278 | 279 | -- | The 'pTraceWith' function pretty prints the result of 280 | -- applying @f to @a and returns back @a 281 | -- 282 | -- @since ? 283 | {-# WARNING pTraceWith "'pTraceWith' remains in code" #-} 284 | pTraceWith :: (a -> String) -> a -> a 285 | pTraceWith f a = pTrace (f a) a 286 | 287 | -- | The 'pTraceShowWith' function similar to 'pTraceWith' except that 288 | -- @f can return any type that implements Show 289 | -- 290 | -- @since ? 291 | {-# WARNING pTraceShowWith "'pTraceShowWith' remains in code" #-} 292 | pTraceShowWith :: Show b => (a -> b) -> a -> a 293 | pTraceShowWith f = pTraceWith (show . f) 294 | 295 | ------------------------------------------ 296 | -- Helpers 297 | ------------------------------------------ 298 | {-# WARNING pStringTTYOptIO "'pStringTTYOptIO' remains in code" #-} 299 | pStringTTYOptIO :: CheckColorTty -> OutputOptions -> String -> IO Text 300 | pStringTTYOptIO checkColorTty outputOptions v = do 301 | realOutputOpts <- 302 | case checkColorTty of 303 | CheckColorTty -> hCheckTTY stderr outputOptions 304 | NoCheckColorTty -> pure outputOptions 305 | pure $ pStringOpt realOutputOpts v 306 | 307 | {-# WARNING pStringTTYOpt "'pStringTTYOpt' remains in code" #-} 308 | pStringTTYOpt :: CheckColorTty -> OutputOptions -> String -> Text 309 | pStringTTYOpt checkColorTty outputOptions = 310 | unsafePerformIO . pStringTTYOptIO checkColorTty outputOptions 311 | 312 | {-# WARNING pShowTTYOptIO "'pShowTTYOptIO' remains in code" #-} 313 | pShowTTYOptIO :: Show a => CheckColorTty -> OutputOptions -> a -> IO Text 314 | pShowTTYOptIO checkColorTty outputOptions = 315 | pStringTTYOptIO checkColorTty outputOptions . show 316 | 317 | {-# WARNING pShowTTYOpt "'pShowTTYOpt' remains in code" #-} 318 | pShowTTYOpt :: Show a => CheckColorTty -> OutputOptions -> a -> Text 319 | pShowTTYOpt checkColorTty outputOptions = 320 | unsafePerformIO . pShowTTYOptIO checkColorTty outputOptions 321 | 322 | ------------------------------------------ 323 | -- Traces forcing color 324 | ------------------------------------------ 325 | -- | Similar to 'pTrace', but forcing color. 326 | {-# WARNING pTraceForceColor "'pTraceForceColor' remains in code" #-} 327 | pTraceForceColor :: String -> a -> a 328 | pTraceForceColor = pTraceOpt NoCheckColorTty defaultOutputOptionsDarkBg 329 | 330 | -- | Similar to 'pTraceId', but forcing color. 331 | {-# WARNING pTraceIdForceColor "'pTraceIdForceColor' remains in code" #-} 332 | pTraceIdForceColor :: String -> String 333 | pTraceIdForceColor = pTraceIdOpt NoCheckColorTty defaultOutputOptionsDarkBg 334 | 335 | -- | Similar to 'pTraceShow', but forcing color. 336 | {-# WARNING pTraceShowForceColor "'pTraceShowForceColor' remains in code" #-} 337 | pTraceShowForceColor :: (Show a) => a -> b -> b 338 | pTraceShowForceColor = pTraceShowOpt NoCheckColorTty defaultOutputOptionsDarkBg 339 | 340 | -- | Similar to 'pTraceShowId', but forcing color. 341 | {-# WARNING pTraceShowIdForceColor "'pTraceShowIdForceColor' remains in code" #-} 342 | pTraceShowIdForceColor :: (Show a) => a -> a 343 | pTraceShowIdForceColor = 344 | pTraceShowIdOpt NoCheckColorTty defaultOutputOptionsDarkBg 345 | -- | Similar to 'pTraceM', but forcing color. 346 | {-# WARNING pTraceMForceColor "'pTraceMForceColor' remains in code" #-} 347 | #if __GLASGOW_HASKELL__ < 800 348 | pTraceMForceColor :: (Monad f) => String -> f () 349 | #else 350 | pTraceMForceColor :: (Applicative f) => String -> f () 351 | #endif 352 | pTraceMForceColor = pTraceOptM NoCheckColorTty defaultOutputOptionsDarkBg 353 | -- | Similar to 'pTraceShowM', but forcing color. 354 | {-# WARNING pTraceShowMForceColor "'pTraceShowMForceColor' remains in code" #-} 355 | #if __GLASGOW_HASKELL__ < 800 356 | pTraceShowMForceColor :: (Show a, Monad f) => a -> f () 357 | #else 358 | pTraceShowMForceColor :: (Show a, Applicative f) => a -> f () 359 | #endif 360 | pTraceShowMForceColor = 361 | pTraceShowOptM NoCheckColorTty defaultOutputOptionsDarkBg 362 | 363 | -- | Similar to 'pTraceStack', but forcing color. 364 | {-# WARNING pTraceStackForceColor "'pTraceStackForceColor' remains in code" #-} 365 | pTraceStackForceColor :: String -> a -> a 366 | pTraceStackForceColor = 367 | pTraceStackOpt NoCheckColorTty defaultOutputOptionsDarkBg 368 | 369 | -- | Similar to 'pTraceEvent', but forcing color. 370 | {-# WARNING pTraceEventForceColor "'pTraceEventForceColor' remains in code" #-} 371 | pTraceEventForceColor :: String -> a -> a 372 | pTraceEventForceColor = 373 | pTraceEventOpt NoCheckColorTty defaultOutputOptionsDarkBg 374 | 375 | -- | Similar to 'pTraceEventIO', but forcing color. 376 | {-# WARNING pTraceEventIOForceColor "'pTraceEventIOForceColor' remains in code" #-} 377 | pTraceEventIOForceColor :: String -> IO () 378 | pTraceEventIOForceColor = 379 | pTraceEventOptIO NoCheckColorTty defaultOutputOptionsDarkBg 380 | 381 | -- | Similar to 'pTraceMarker', but forcing color. 382 | {-# WARNING pTraceMarkerForceColor "'pTraceMarkerForceColor' remains in code" #-} 383 | pTraceMarkerForceColor :: String -> a -> a 384 | pTraceMarkerForceColor = 385 | pTraceMarkerOpt NoCheckColorTty defaultOutputOptionsDarkBg 386 | 387 | -- | Similar to 'pTraceMarkerIO', but forcing color. 388 | {-# WARNING pTraceMarkerIOForceColor "'pTraceMarkerIOForceColor' remains in code" #-} 389 | pTraceMarkerIOForceColor :: String -> IO () 390 | pTraceMarkerIOForceColor = 391 | pTraceMarkerOptIO NoCheckColorTty defaultOutputOptionsDarkBg 392 | 393 | -- | Similar to 'pTraceIO', but forcing color. 394 | {-# WARNING pTraceIOForceColor "'pTraceIOForceColor' remains in code" #-} 395 | pTraceIOForceColor :: String -> IO () 396 | pTraceIOForceColor = pTraceOptIO NoCheckColorTty defaultOutputOptionsDarkBg 397 | 398 | ------------------------------------------ 399 | -- Traces without color 400 | ------------------------------------------ 401 | -- | Similar to 'pTrace', but without color. 402 | -- 403 | -- >>> pTraceNoColor "wow" () 404 | -- wow 405 | -- () 406 | -- 407 | -- @since 2.0.2.0 408 | {-# WARNING pTraceNoColor "'pTraceNoColor' remains in code" #-} 409 | pTraceNoColor :: String -> a -> a 410 | pTraceNoColor = pTraceOpt NoCheckColorTty defaultOutputOptionsNoColor 411 | 412 | -- | Similar to 'pTraceId', but without color. 413 | -- 414 | -- >>> pTraceIdNoColor "(1, 2, 3)" `seq` () 415 | -- ( 1 416 | -- , 2 417 | -- , 3 418 | -- ) 419 | -- () 420 | -- 421 | -- @since 2.0.2.0 422 | {-# WARNING pTraceIdNoColor "'pTraceIdNoColor' remains in code" #-} 423 | pTraceIdNoColor :: String -> String 424 | pTraceIdNoColor = pTraceIdOpt NoCheckColorTty defaultOutputOptionsNoColor 425 | 426 | -- | Similar to 'pTraceShow', but without color. 427 | -- 428 | -- >>> import qualified Data.Map as M 429 | -- >>> pTraceShowNoColor (M.fromList [(1, True)]) () 430 | -- fromList 431 | -- [ 432 | -- ( 1 433 | -- , True 434 | -- ) 435 | -- ] 436 | -- () 437 | -- 438 | -- @since 2.0.2.0 439 | {-# WARNING pTraceShowNoColor "'pTraceShowNoColor' remains in code" #-} 440 | pTraceShowNoColor :: (Show a) => a -> b -> b 441 | pTraceShowNoColor = pTraceShowOpt NoCheckColorTty defaultOutputOptionsNoColor 442 | 443 | -- | Similar to 'pTraceShowId', but without color. 444 | -- 445 | -- >>> import qualified Data.Map as M 446 | -- >>> pTraceShowIdNoColor (M.fromList [(1, True)]) `seq` () 447 | -- fromList 448 | -- [ 449 | -- ( 1 450 | -- , True 451 | -- ) 452 | -- ] 453 | -- () 454 | -- 455 | -- @since 2.0.2.0 456 | {-# WARNING pTraceShowIdNoColor "'pTraceShowIdNoColor' remains in code" #-} 457 | pTraceShowIdNoColor :: (Show a) => a -> a 458 | pTraceShowIdNoColor = 459 | pTraceShowIdOpt NoCheckColorTty defaultOutputOptionsNoColor 460 | -- | Similar to 'pTraceM', but without color. 461 | -- 462 | -- >>> pTraceMNoColor "wow" 463 | -- wow 464 | -- 465 | -- @since 2.0.2.0 466 | {-# WARNING pTraceMNoColor "'pTraceMNoColor' remains in code" #-} 467 | #if __GLASGOW_HASKELL__ < 800 468 | pTraceMNoColor :: (Monad f) => String -> f () 469 | #else 470 | pTraceMNoColor :: (Applicative f) => String -> f () 471 | #endif 472 | pTraceMNoColor = pTraceOptM NoCheckColorTty defaultOutputOptionsNoColor 473 | -- | Similar to 'pTraceShowM', but without color. 474 | -- 475 | -- >>> pTraceShowMNoColor [1,2,3] 476 | -- [ 1 477 | -- , 2 478 | -- , 3 479 | -- ] 480 | -- 481 | -- @since 2.0.2.0 482 | {-# WARNING pTraceShowMNoColor "'pTraceShowMNoColor' remains in code" #-} 483 | #if __GLASGOW_HASKELL__ < 800 484 | pTraceShowMNoColor :: (Show a, Monad f) => a -> f () 485 | #else 486 | pTraceShowMNoColor :: (Show a, Applicative f) => a -> f () 487 | #endif 488 | pTraceShowMNoColor = pTraceShowOptM NoCheckColorTty defaultOutputOptionsNoColor 489 | 490 | -- | Similar to 'pTraceStack', but without color. 491 | -- 492 | -- >>> pTraceStackNoColor "wow" () `seq` () 493 | -- wow 494 | -- () 495 | -- 496 | -- @since 2.0.2.0 497 | {-# WARNING pTraceStackNoColor "'pTraceStackNoColor' remains in code" #-} 498 | pTraceStackNoColor :: String -> a -> a 499 | pTraceStackNoColor = pTraceStackOpt NoCheckColorTty defaultOutputOptionsNoColor 500 | 501 | -- | Similar to 'pTraceEvent', but without color. 502 | -- 503 | -- @since 2.0.2.0 504 | {-# WARNING pTraceEventNoColor "'pTraceEventNoColor' remains in code" #-} 505 | pTraceEventNoColor :: String -> a -> a 506 | pTraceEventNoColor = pTraceEventOpt NoCheckColorTty defaultOutputOptionsNoColor 507 | 508 | -- | Similar to 'pTraceEventIO', but without color. 509 | -- 510 | -- @since 2.0.2.0 511 | {-# WARNING pTraceEventIONoColor "'pTraceEventIONoColor' remains in code" #-} 512 | pTraceEventIONoColor :: String -> IO () 513 | pTraceEventIONoColor = 514 | pTraceEventOptIO NoCheckColorTty defaultOutputOptionsNoColor 515 | 516 | -- | Similar to 'pTraceMarker', but without color. 517 | -- 518 | -- @since 2.0.2.0 519 | {-# WARNING pTraceMarkerNoColor "'pTraceMarkerNoColor' remains in code" #-} 520 | pTraceMarkerNoColor :: String -> a -> a 521 | pTraceMarkerNoColor = 522 | pTraceMarkerOpt NoCheckColorTty defaultOutputOptionsNoColor 523 | 524 | -- | Similar to 'pTraceMarkerIO', but without color. 525 | -- 526 | -- @since 2.0.2.0 527 | {-# WARNING pTraceMarkerIONoColor "'pTraceMarkerIONoColor' remains in code" #-} 528 | pTraceMarkerIONoColor :: String -> IO () 529 | pTraceMarkerIONoColor = 530 | pTraceMarkerOptIO NoCheckColorTty defaultOutputOptionsNoColor 531 | 532 | -- | Similar to 'pTraceIO', but without color. 533 | -- 534 | -- >>> pTraceIONoColor "(1, 2, 3)" 535 | -- ( 1 536 | -- , 2 537 | -- , 3 538 | -- ) 539 | -- 540 | -- @since 2.0.2.0 541 | {-# WARNING pTraceIONoColor "'pTraceIONoColor' remains in code" #-} 542 | pTraceIONoColor :: String -> IO () 543 | pTraceIONoColor = pTraceOptIO NoCheckColorTty defaultOutputOptionsNoColor 544 | 545 | ------------------------------------------ 546 | -- Traces that take options 547 | ------------------------------------------ 548 | {-| 549 | Like 'pTrace' but takes OutputOptions. 550 | -} 551 | {-# WARNING pTraceOpt "'pTraceOpt' remains in code" #-} 552 | pTraceOpt :: CheckColorTty -> OutputOptions -> String -> a -> a 553 | pTraceOpt checkColorTty outputOptions = 554 | trace . unpack . pStringTTYOpt checkColorTty outputOptions 555 | 556 | {-| 557 | Like 'pTraceId' but takes OutputOptions. 558 | -} 559 | {-# WARNING pTraceIdOpt "'pTraceIdOpt' remains in code" #-} 560 | pTraceIdOpt :: CheckColorTty -> OutputOptions -> String -> String 561 | pTraceIdOpt checkColorTty outputOptions a = 562 | pTraceOpt checkColorTty outputOptions a a 563 | 564 | {-| 565 | Like 'pTraceShow' but takes OutputOptions. 566 | -} 567 | {-# WARNING pTraceShowOpt "'pTraceShowOpt' remains in code" #-} 568 | pTraceShowOpt :: (Show a) => CheckColorTty -> OutputOptions -> a -> b -> b 569 | pTraceShowOpt checkColorTty outputOptions = 570 | trace . unpack . pShowTTYOpt checkColorTty outputOptions 571 | 572 | {-| 573 | Like 'pTraceShowId' but takes OutputOptions. 574 | -} 575 | {-# WARNING pTraceShowIdOpt "'pTraceShowIdOpt' remains in code" #-} 576 | pTraceShowIdOpt :: (Show a) => CheckColorTty -> OutputOptions -> a -> a 577 | pTraceShowIdOpt checkColorTty outputOptions a = 578 | trace (unpack $ pShowTTYOpt checkColorTty outputOptions a) a 579 | 580 | {-| 581 | Like 'pTraceIO' but takes OutputOptions. 582 | -} 583 | {-# WARNING pTraceOptIO "'pTraceOptIO' remains in code" #-} 584 | pTraceOptIO :: CheckColorTty -> OutputOptions -> String -> IO () 585 | pTraceOptIO checkColorTty outputOptions = 586 | traceIO . unpack <=< pStringTTYOptIO checkColorTty outputOptions 587 | {-| 588 | Like 'pTraceM' but takes OutputOptions. 589 | -} 590 | {-# WARNING pTraceOptM "'pTraceOptM' remains in code" #-} 591 | #if __GLASGOW_HASKELL__ < 800 592 | pTraceOptM :: (Monad f) => CheckColorTty -> OutputOptions -> String -> f () 593 | #else 594 | pTraceOptM :: 595 | (Applicative f) => CheckColorTty -> OutputOptions -> String -> f () 596 | #endif 597 | pTraceOptM checkColorTty outputOptions string = 598 | trace (unpack $ pStringTTYOpt checkColorTty outputOptions string) $ pure () 599 | {-| 600 | Like 'pTraceShowM' but takes OutputOptions. 601 | -} 602 | {-# WARNING pTraceShowOptM "'pTraceShowOptM' remains in code" #-} 603 | #if __GLASGOW_HASKELL__ < 800 604 | pTraceShowOptM :: 605 | (Show a, Monad f) => CheckColorTty -> OutputOptions -> a -> f () 606 | #else 607 | pTraceShowOptM :: 608 | (Show a, Applicative f) => CheckColorTty -> OutputOptions -> a -> f () 609 | #endif 610 | pTraceShowOptM checkColorTty outputOptions = 611 | traceM . unpack . pShowTTYOpt checkColorTty outputOptions 612 | 613 | {-| 614 | Like 'pTraceStack' but takes OutputOptions. 615 | -} 616 | {-# WARNING pTraceStackOpt "'pTraceStackOpt' remains in code" #-} 617 | pTraceStackOpt :: CheckColorTty -> OutputOptions -> String -> a -> a 618 | pTraceStackOpt checkColorTty outputOptions = 619 | traceStack . unpack . pStringTTYOpt checkColorTty outputOptions 620 | 621 | {-| 622 | Like 'pTraceEvent' but takes OutputOptions. 623 | -} 624 | {-# WARNING pTraceEventOpt "'pTraceEventOpt' remains in code" #-} 625 | pTraceEventOpt :: CheckColorTty -> OutputOptions -> String -> a -> a 626 | pTraceEventOpt checkColorTty outputOptions = 627 | traceEvent . unpack . pStringTTYOpt checkColorTty outputOptions 628 | 629 | {-| 630 | Like 'pTraceEventIO' but takes OutputOptions. 631 | -} 632 | {-# WARNING pTraceEventOptIO "'pTraceEventOptIO' remains in code" #-} 633 | pTraceEventOptIO :: CheckColorTty -> OutputOptions -> String -> IO () 634 | pTraceEventOptIO checkColorTty outputOptions = 635 | traceEventIO . unpack <=< pStringTTYOptIO checkColorTty outputOptions 636 | 637 | {-| 638 | Like 'pTraceMarker' but takes OutputOptions. 639 | -} 640 | {-# WARNING pTraceMarkerOpt "'pTraceMarkerOpt' remains in code" #-} 641 | pTraceMarkerOpt :: CheckColorTty -> OutputOptions -> String -> a -> a 642 | pTraceMarkerOpt checkColorTty outputOptions = 643 | traceMarker . unpack . pStringTTYOpt checkColorTty outputOptions 644 | 645 | {-| 646 | Like 'pTraceMarkerIO' but takes OutputOptions. 647 | -} 648 | {-# WARNING pTraceMarkerOptIO "'pTraceMarkerOptIO' remains in code" #-} 649 | pTraceMarkerOptIO :: CheckColorTty -> OutputOptions -> String -> IO () 650 | pTraceMarkerOptIO checkColorTty outputOptions = 651 | traceMarkerIO . unpack <=< pStringTTYOptIO checkColorTty outputOptions 652 | -------------------------------------------------------------------------------- /src/Text/Pretty/Simple.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | 7 | {-| 8 | Module : Text.Pretty.Simple 9 | Copyright : (c) Dennis Gosnell, 2016 10 | License : BSD-style (see LICENSE file) 11 | Maintainer : cdep.illabout@gmail.com 12 | Stability : experimental 13 | Portability : POSIX 14 | 15 | This module contains the functions 'pPrint', 'pShow', and 'pString' for 16 | pretty-printing any Haskell data type with a 'Show' instance. 17 | 18 | 'pPrint' is the main go-to function when debugging Haskell code. 'pShow' and 19 | 'pString' are slight variations on 'pPrint'. 20 | 21 | 'pPrint', 'pShow', and 'pString' will pretty-print in color using ANSI escape 22 | codes. They look good on a console with a dark (black) background. The 23 | variations 'pPrintLightBg', 'pShowLightBg', and 'pStringLightBg' are for 24 | printing in color to a console with a light (white) background. The variations 25 | 'pPrintNoColor', 'pShowNoColor', and 'pStringNoColor' are for pretty-printing 26 | without using color. 27 | 28 | 'pPrint' and 'pPrintLightBg' will intelligently decide whether or not to use 29 | ANSI escape codes for coloring depending on whether or not the output is 30 | a TTY. This works in most cases. If you want to force color output, 31 | you can use the 'pPrintForceColor' or 'pPrintForceColorLightBg' functions. 32 | 33 | The variations 'pPrintOpt', 'pShowOpt', and 'pStringOpt' are used when 34 | specifying the 'OutputOptions'. Most users can ignore these. 35 | 36 | There are a few other functions available that are similar to 'pPrint'. 37 | 38 | See the Examples section at the end of this module for examples of acutally 39 | using 'pPrint'. See the 40 | 41 | for examples of printing in color. 42 | -} 43 | module Text.Pretty.Simple 44 | ( 45 | -- * Output with color on dark background 46 | pPrint 47 | , pHPrint 48 | , pPrintString 49 | , pHPrintString 50 | , pPrintForceColor 51 | , pHPrintForceColor 52 | , pPrintStringForceColor 53 | , pHPrintStringForceColor 54 | , pShow 55 | , pString 56 | -- * Aliases for output with color on dark background 57 | , pPrintDarkBg 58 | , pHPrintDarkBg 59 | , pPrintStringDarkBg 60 | , pHPrintStringDarkBg 61 | , pPrintForceColorDarkBg 62 | , pHPrintForceColorDarkBg 63 | , pPrintStringForceColorDarkBg 64 | , pHPrintStringForceColorDarkBg 65 | , pShowDarkBg 66 | , pStringDarkBg 67 | -- * Output with color on light background 68 | , pPrintLightBg 69 | , pHPrintLightBg 70 | , pPrintStringLightBg 71 | , pHPrintStringLightBg 72 | , pPrintForceColorLightBg 73 | , pHPrintForceColorLightBg 74 | , pPrintStringForceColorLightBg 75 | , pHPrintStringForceColorLightBg 76 | , pShowLightBg 77 | , pStringLightBg 78 | -- * Output with NO color 79 | , pPrintNoColor 80 | , pHPrintNoColor 81 | , pPrintStringNoColor 82 | , pHPrintStringNoColor 83 | , pShowNoColor 84 | , pStringNoColor 85 | -- * Output With 'OutputOptions' 86 | , pPrintOpt 87 | , pHPrintOpt 88 | , pPrintStringOpt 89 | , pHPrintStringOpt 90 | , pShowOpt 91 | , pStringOpt 92 | -- * 'OutputOptions' 93 | , OutputOptions(..) 94 | , StringOutputStyle(..) 95 | , defaultOutputOptionsDarkBg 96 | , defaultOutputOptionsLightBg 97 | , defaultOutputOptionsNoColor 98 | , CheckColorTty(..) 99 | -- * 'ColorOptions' 100 | , defaultColorOptionsDarkBg 101 | , defaultColorOptionsLightBg 102 | , ColorOptions(..) 103 | , Style(..) 104 | , Color(..) 105 | , Intensity(..) 106 | , colorNull 107 | -- * Examples 108 | -- $examples 109 | ) where 110 | 111 | #if __GLASGOW_HASKELL__ < 710 112 | -- We don't need this import for GHC 7.10 as it exports all required functions 113 | -- from Prelude 114 | import Control.Applicative 115 | #endif 116 | 117 | import Control.Monad.IO.Class (MonadIO, liftIO) 118 | import Data.Text.Lazy (Text) 119 | import Prettyprinter (SimpleDocStream) 120 | import Prettyprinter.Render.Terminal 121 | (Color (..), Intensity(Vivid,Dull), AnsiStyle, 122 | renderLazy, renderIO) 123 | import System.IO (Handle, stdout, hPutStrLn) 124 | 125 | import Text.Pretty.Simple.Internal 126 | (ColorOptions(..), Style(..), CheckColorTty(..), 127 | OutputOptions(..), StringOutputStyle(..), 128 | convertStyle, colorNull, 129 | defaultColorOptionsDarkBg, defaultColorOptionsLightBg, 130 | defaultOutputOptionsDarkBg, defaultOutputOptionsLightBg, 131 | defaultOutputOptionsNoColor, hCheckTTY, layoutString) 132 | 133 | -- $setup 134 | -- >>> import Data.Text.Lazy (unpack) 135 | 136 | ---------------------------------------------------------- 137 | -- functions for printing in color to a dark background -- 138 | ---------------------------------------------------------- 139 | 140 | -- | Pretty-print any data type that has a 'Show' instance. 141 | -- 142 | -- If you've never seen 'MonadIO' before, you can think of this function as 143 | -- having the following type signature: 144 | -- 145 | -- @ 146 | -- pPrint :: Show a => a -> IO () 147 | -- @ 148 | -- 149 | -- This function will only use colors if it detects it's printing to a TTY. 150 | -- 151 | -- This function is for printing to a dark background. Use 'pPrintLightBg' for 152 | -- printing to a terminal with a light background. Different colors are used. 153 | -- 154 | -- Prints to 'stdout'. Use 'pHPrint' to print to a different 'Handle'. 155 | -- 156 | -- >>> pPrint [Just (1, "hello")] 157 | -- [ Just 158 | -- ( 1 159 | -- , "hello" 160 | -- ) 161 | -- ] 162 | pPrint :: (MonadIO m, Show a) => a -> m () 163 | pPrint = pPrintOpt CheckColorTty defaultOutputOptionsDarkBg 164 | 165 | -- | Similar to 'pPrint', but take a 'Handle' to print to. 166 | -- 167 | -- >>> pHPrint stdout [Just (1, "hello")] 168 | -- [ Just 169 | -- ( 1 170 | -- , "hello" 171 | -- ) 172 | -- ] 173 | pHPrint :: (MonadIO m, Show a) => Handle -> a -> m () 174 | pHPrint = pHPrintOpt CheckColorTty defaultOutputOptionsDarkBg 175 | 176 | -- | Similar to 'pPrint', but the first argument is a 'String' representing a 177 | -- data type that has already been 'show'ed. 178 | -- 179 | -- >>> pPrintString $ show [ Just (1, "hello"), Nothing ] 180 | -- [ Just 181 | -- ( 1 182 | -- , "hello" 183 | -- ) 184 | -- , Nothing 185 | -- ] 186 | pPrintString :: MonadIO m => String -> m () 187 | pPrintString = pPrintStringOpt CheckColorTty defaultOutputOptionsDarkBg 188 | 189 | -- | Similar to 'pHPrintString', but take a 'Handle' to print to. 190 | -- 191 | -- >>> pHPrintString stdout $ show [ Just (1, "hello"), Nothing ] 192 | -- [ Just 193 | -- ( 1 194 | -- , "hello" 195 | -- ) 196 | -- , Nothing 197 | -- ] 198 | pHPrintString :: MonadIO m => Handle -> String -> m () 199 | pHPrintString = pHPrintStringOpt CheckColorTty defaultOutputOptionsDarkBg 200 | 201 | -- | Similar to 'pPrint', but print in color regardless of whether the output 202 | -- goes to a TTY or not. 203 | -- 204 | -- See 'pPrint' for an example of how to use this function. 205 | pPrintForceColor :: (MonadIO m, Show a) => a -> m () 206 | pPrintForceColor = pPrintOpt NoCheckColorTty defaultOutputOptionsDarkBg 207 | 208 | -- | Similar to 'pPrintForceColor', but take a 'Handle' to print to. 209 | -- 210 | -- See 'pHPrint' for an example of how to use this function. 211 | pHPrintForceColor :: (MonadIO m, Show a) => Handle -> a -> m () 212 | pHPrintForceColor = pHPrintOpt NoCheckColorTty defaultOutputOptionsDarkBg 213 | 214 | -- | Similar to 'pPrintString', but print in color regardless of whether the 215 | -- output goes to a TTY or not. 216 | -- 217 | -- See 'pPrintString' for an example of how to use this function. 218 | pPrintStringForceColor :: MonadIO m => String -> m () 219 | pPrintStringForceColor = pPrintStringOpt NoCheckColorTty defaultOutputOptionsDarkBg 220 | 221 | -- | Similar to 'pHPrintString', but print in color regardless of whether the 222 | -- output goes to a TTY or not. 223 | -- 224 | -- See 'pHPrintString' for an example of how to use this function. 225 | pHPrintStringForceColor :: MonadIO m => Handle -> String -> m () 226 | pHPrintStringForceColor = pHPrintStringOpt NoCheckColorTty defaultOutputOptionsDarkBg 227 | 228 | -- | Similar to 'pPrintForceColor', but just return the resulting pretty-printed 229 | -- data type as a 'Text' instead of printing it to the screen. 230 | -- 231 | -- This function is for printing to a dark background. 232 | -- 233 | -- See 'pShowNoColor' for an example of how to use this function. 234 | pShow :: Show a => a -> Text 235 | pShow = pShowOpt defaultOutputOptionsDarkBg 236 | 237 | -- | Similar to 'pShow', but the first argument is a 'String' representing a 238 | -- data type that has already been 'show'ed. 239 | -- 240 | -- This will work on any 'String' that is similar to a Haskell data type. The 241 | -- only requirement is that the strings are quoted, and braces, parentheses, and 242 | -- brackets are correctly used to represent indentation. For example, 243 | -- 'pString' will correctly pretty-print JSON. 244 | -- 245 | -- This function is for printing to a dark background. 246 | -- 247 | -- See 'pStringNoColor' for an example of how to use this function. 248 | pString :: String -> Text 249 | pString = pStringOpt defaultOutputOptionsDarkBg 250 | 251 | -------------------------------------------------------- 252 | -- aliases for printing in color to a dark background -- 253 | -------------------------------------------------------- 254 | 255 | -- | Alias for 'pPrint'. 256 | pPrintDarkBg :: (MonadIO m, Show a) => a -> m () 257 | pPrintDarkBg = pPrint 258 | 259 | -- | Alias for 'pHPrint'. 260 | pHPrintDarkBg :: (MonadIO m, Show a) => Handle -> a -> m () 261 | pHPrintDarkBg = pHPrint 262 | 263 | -- | Alias for 'pPrintString'. 264 | pPrintStringDarkBg :: MonadIO m => String -> m () 265 | pPrintStringDarkBg = pPrintString 266 | 267 | -- | Alias for 'pHPrintString'. 268 | pHPrintStringDarkBg :: MonadIO m => Handle -> String -> m () 269 | pHPrintStringDarkBg = pHPrintString 270 | 271 | -- | Alias for 'pPrintForceColor'. 272 | pPrintForceColorDarkBg :: (MonadIO m, Show a) => a -> m () 273 | pPrintForceColorDarkBg = pPrintForceColor 274 | 275 | -- | Alias for 'pHPrintForceColor'. 276 | pHPrintForceColorDarkBg :: (MonadIO m, Show a) => Handle -> a -> m () 277 | pHPrintForceColorDarkBg = pHPrintForceColor 278 | 279 | -- | Alias for 'pPrintStringForceColor'. 280 | pPrintStringForceColorDarkBg :: MonadIO m => String -> m () 281 | pPrintStringForceColorDarkBg = pPrintStringForceColor 282 | 283 | -- | Alias for 'pHPrintStringForceColor'. 284 | pHPrintStringForceColorDarkBg :: MonadIO m => Handle -> String -> m () 285 | pHPrintStringForceColorDarkBg = pHPrintStringForceColor 286 | 287 | -- | Alias for 'pShow'. 288 | pShowDarkBg :: Show a => a -> Text 289 | pShowDarkBg = pShow 290 | 291 | -- | Alias for 'pString'. 292 | pStringDarkBg :: String -> Text 293 | pStringDarkBg = pString 294 | 295 | ----------------------------------------------------------- 296 | -- functions for printing in color to a light background -- 297 | ----------------------------------------------------------- 298 | 299 | -- | Just like 'pPrintDarkBg', but for printing to a light background. 300 | pPrintLightBg :: (MonadIO m, Show a) => a -> m () 301 | pPrintLightBg = pPrintOpt CheckColorTty defaultOutputOptionsLightBg 302 | 303 | -- | Just like 'pHPrintDarkBg', but for printing to a light background. 304 | pHPrintLightBg :: (MonadIO m, Show a) => Handle -> a -> m () 305 | pHPrintLightBg = pHPrintOpt CheckColorTty defaultOutputOptionsLightBg 306 | 307 | -- | Just like 'pPrintStringDarkBg', but for printing to a light background. 308 | pPrintStringLightBg :: MonadIO m => String -> m () 309 | pPrintStringLightBg = pPrintStringOpt CheckColorTty defaultOutputOptionsLightBg 310 | 311 | -- | Just like 'pHPrintStringDarkBg', but for printing to a light background. 312 | pHPrintStringLightBg :: MonadIO m => Handle -> String -> m () 313 | pHPrintStringLightBg = pHPrintStringOpt CheckColorTty defaultOutputOptionsLightBg 314 | 315 | -- | Just like 'pPrintForceColorDarkBg', but for printing to a light 316 | -- background. 317 | pPrintForceColorLightBg :: (MonadIO m, Show a) => a -> m () 318 | pPrintForceColorLightBg = pPrintOpt NoCheckColorTty defaultOutputOptionsLightBg 319 | 320 | -- | Just like 'pHPrintForceColorDarkBg', but for printing to a light 321 | -- background. 322 | pHPrintForceColorLightBg :: (MonadIO m, Show a) => Handle -> a -> m () 323 | pHPrintForceColorLightBg = pHPrintOpt NoCheckColorTty defaultOutputOptionsLightBg 324 | 325 | -- | Just like 'pPrintStringForceColorDarkBg', but for printing to a light 326 | -- background. 327 | pPrintStringForceColorLightBg :: MonadIO m => String -> m () 328 | pPrintStringForceColorLightBg = pPrintStringOpt NoCheckColorTty defaultOutputOptionsLightBg 329 | 330 | -- | Just like 'pHPrintStringForceColorDarkBg', but for printing to a light 331 | -- background. 332 | pHPrintStringForceColorLightBg :: MonadIO m => Handle -> String -> m () 333 | pHPrintStringForceColorLightBg = pHPrintStringOpt NoCheckColorTty defaultOutputOptionsLightBg 334 | 335 | -- | Just like 'pShowDarkBg', but for printing to a light background. 336 | pShowLightBg :: Show a => a -> Text 337 | pShowLightBg = pShowOpt defaultOutputOptionsLightBg 338 | 339 | -- | Just like 'pStringDarkBg', but for printing to a light background. 340 | pStringLightBg :: String -> Text 341 | pStringLightBg = pStringOpt defaultOutputOptionsLightBg 342 | 343 | ------------------------------------------ 344 | -- functions for printing without color -- 345 | ------------------------------------------ 346 | 347 | -- | Similar to 'pPrint', but doesn't print in color. However, data types 348 | -- will still be indented nicely. 349 | -- 350 | -- >>> pPrintNoColor $ Just ["hello", "bye"] 351 | -- Just 352 | -- [ "hello" 353 | -- , "bye" 354 | -- ] 355 | pPrintNoColor :: (MonadIO m, Show a) => a -> m () 356 | pPrintNoColor = pPrintOpt NoCheckColorTty defaultOutputOptionsNoColor 357 | 358 | -- | Like 'pPrintNoColor', but take a 'Handle' to determine where to print to. 359 | -- 360 | -- >>> pHPrintNoColor stdout $ Just ["hello", "bye"] 361 | -- Just 362 | -- [ "hello" 363 | -- , "bye" 364 | -- ] 365 | pHPrintNoColor :: (MonadIO m, Show a) => Handle -> a -> m () 366 | pHPrintNoColor = pHPrintOpt NoCheckColorTty defaultOutputOptionsNoColor 367 | 368 | -- | Similar to 'pPrintString', but doesn't print in color. However, data types 369 | -- will still be indented nicely. 370 | -- 371 | -- >>> pPrintStringNoColor $ show $ Just ["hello", "bye"] 372 | -- Just 373 | -- [ "hello" 374 | -- , "bye" 375 | -- ] 376 | pPrintStringNoColor :: MonadIO m => String -> m () 377 | pPrintStringNoColor = pPrintStringOpt NoCheckColorTty defaultOutputOptionsNoColor 378 | 379 | -- | Like 'pPrintStringNoColor', but take a 'Handle' to determine where to print to. 380 | -- 381 | -- >>> pHPrintStringNoColor stdout $ show $ Just ["hello", "bye"] 382 | -- Just 383 | -- [ "hello" 384 | -- , "bye" 385 | -- ] 386 | pHPrintStringNoColor :: MonadIO m => Handle -> String -> m () 387 | pHPrintStringNoColor = pHPrintStringOpt NoCheckColorTty defaultOutputOptionsNoColor 388 | 389 | -- | Like 'pShow', but without color. 390 | -- 391 | -- >>> pShowNoColor [ Nothing, Just (1, "hello") ] 392 | -- "[ Nothing\n, Just\n ( 1\n , \"hello\"\n )\n]" 393 | pShowNoColor :: Show a => a -> Text 394 | pShowNoColor = pShowOpt defaultOutputOptionsNoColor 395 | 396 | -- | LIke 'pString', but without color. 397 | -- 398 | -- >>> pStringNoColor $ show [1, 2, 3] 399 | -- "[ 1\n, 2\n, 3\n]" 400 | pStringNoColor :: String -> Text 401 | pStringNoColor = pStringOpt defaultOutputOptionsNoColor 402 | 403 | --------------------------------- 404 | -- functions that take options -- 405 | --------------------------------- 406 | 407 | -- | Similar to 'pPrint' but takes 'OutputOptions' to change how the 408 | -- pretty-printing is done. 409 | -- 410 | -- For example, 'pPrintOpt' can be used to make the indentation much smaller 411 | -- than normal. 412 | -- 413 | -- This is what the normal indentation looks like: 414 | -- 415 | -- >>> pPrintOpt NoCheckColorTty defaultOutputOptionsNoColor $ Just ("hello", "bye") 416 | -- Just 417 | -- ( "hello" 418 | -- , "bye" 419 | -- ) 420 | -- 421 | -- This is what smaller indentation looks like: 422 | -- 423 | -- >>> let smallIndent = defaultOutputOptionsNoColor {outputOptionsIndentAmount = 1} 424 | -- >>> pPrintOpt CheckColorTty smallIndent $ Just ("hello", "bye") 425 | -- Just 426 | -- ( "hello" 427 | -- , "bye" 428 | -- ) 429 | -- 430 | -- Lines in strings get indented 431 | -- 432 | -- >>> pPrintOpt NoCheckColorTty defaultOutputOptionsNoColor (1, (2, "foo\nbar\nbaz", 3)) 433 | -- ( 1 434 | -- , 435 | -- ( 2 436 | -- , "foo 437 | -- bar 438 | -- baz" 439 | -- , 3 440 | -- ) 441 | -- ) 442 | -- 443 | -- Lines get indented even in custom show instances 444 | -- 445 | -- >>> data Foo = Foo 446 | -- >>> instance Show Foo where show _ = "foo\nbar\nbaz" 447 | -- >>> pPrintOpt CheckColorTty defaultOutputOptionsNoColor (1, (2, Foo, 3)) 448 | -- ( 1 449 | -- , 450 | -- ( 2 451 | -- , foo 452 | -- bar 453 | -- baz 454 | -- , 3 455 | -- ) 456 | -- ) 457 | -- 458 | -- 'CheckColorTty' determines whether to test 'stdout' for whether or not it is 459 | -- connected to a TTY. 460 | -- 461 | -- If set to 'NoCheckColorTty', then 'pPrintOpt' won't 462 | -- check if 'stdout' is a TTY. It will print in color depending on the value 463 | -- of 'outputOptionsColorOptions'. 464 | -- 465 | -- If set to 'CheckColorTty', then 'pPrintOpt' will check if 'stdout' is 466 | -- conneted to a TTY. If 'stdout' is determined to be connected to a TTY, then 467 | -- it will print in color depending on the value of 468 | -- 'outputOptionsColorOptions'. If 'stdout' is determined to NOT be connected 469 | -- to a TTY, then it will NOT print in color, regardless of the value of 470 | -- 'outputOptionsColorOptions'. 471 | pPrintOpt :: (MonadIO m, Show a) => CheckColorTty -> OutputOptions -> a -> m () 472 | pPrintOpt checkColorTty outputOptions = 473 | pHPrintOpt checkColorTty outputOptions stdout 474 | 475 | -- | Similar to 'pPrintOpt', but take a 'Handle' to determine where to print 476 | -- to. 477 | pHPrintOpt :: 478 | (MonadIO m, Show a) 479 | => CheckColorTty 480 | -> OutputOptions 481 | -> Handle 482 | -> a 483 | -> m () 484 | pHPrintOpt checkColorTty outputOptions handle a = 485 | pHPrintStringOpt checkColorTty outputOptions handle $ show a 486 | 487 | -- | Similar to 'pPrintOpt', but the last argument is a string representing a 488 | -- data structure that has already been 'show'ed. 489 | -- 490 | -- >>> let foo = show (1, (2, "hello", 3)) 491 | -- >>> pPrintStringOpt CheckColorTty defaultOutputOptionsNoColor foo 492 | -- ( 1 493 | -- , 494 | -- ( 2 495 | -- , "hello" 496 | -- , 3 497 | -- ) 498 | -- ) 499 | pPrintStringOpt :: MonadIO m => CheckColorTty -> OutputOptions -> String -> m () 500 | pPrintStringOpt checkColorTty outputOptions = 501 | pHPrintStringOpt checkColorTty outputOptions stdout 502 | 503 | -- | Similar to 'pPrintStringOpt', but take a 'Handle' to determine where to 504 | -- print to. 505 | -- 506 | -- >>> let foo = show (1, (2, "hello", 3)) 507 | -- >>> pHPrintStringOpt CheckColorTty defaultOutputOptionsNoColor stdout foo 508 | -- ( 1 509 | -- , 510 | -- ( 2 511 | -- , "hello" 512 | -- , 3 513 | -- ) 514 | -- ) 515 | pHPrintStringOpt :: 516 | MonadIO m 517 | => CheckColorTty 518 | -> OutputOptions 519 | -> Handle 520 | -> String 521 | -> m () 522 | pHPrintStringOpt checkColorTty outputOptions handle str = do 523 | realOutputOpts <- 524 | case checkColorTty of 525 | CheckColorTty -> hCheckTTY handle outputOptions 526 | NoCheckColorTty -> pure outputOptions 527 | liftIO $ do 528 | renderIO handle $ layoutStringAnsi realOutputOpts str 529 | hPutStrLn handle "" 530 | 531 | -- | Like 'pShow' but takes 'OutputOptions' to change how the 532 | -- pretty-printing is done. 533 | pShowOpt :: Show a => OutputOptions -> a -> Text 534 | pShowOpt outputOptions = pStringOpt outputOptions . show 535 | 536 | -- | Like 'pString' but takes 'OutputOptions' to change how the 537 | -- pretty-printing is done. 538 | pStringOpt :: OutputOptions -> String -> Text 539 | pStringOpt outputOptions = renderLazy . layoutStringAnsi outputOptions 540 | 541 | layoutStringAnsi :: OutputOptions -> String -> SimpleDocStream AnsiStyle 542 | layoutStringAnsi opts = fmap convertStyle . layoutString opts 543 | 544 | -- $examples 545 | -- 546 | -- Here are some examples of using 'pPrint' on different data types. You can 547 | -- look at these examples to get an idea of what 'pPrint' will output. 548 | -- 549 | -- __Simple Haskell data type__ 550 | -- 551 | -- >>> data Foo a = Foo a String Char deriving Show 552 | -- 553 | -- >>> pPrint $ Foo 3 "hello" 'a' 554 | -- Foo 3 "hello" 'a' 555 | -- 556 | -- __List__ 557 | -- 558 | -- >>> pPrint $ [1,2,3] 559 | -- [ 1 560 | -- , 2 561 | -- , 3 562 | -- ] 563 | -- 564 | -- __Slightly more complicated list__ 565 | -- 566 | -- >>> pPrint $ [ Foo [ (), () ] "hello" 'b' ] 567 | -- [ Foo 568 | -- [ () 569 | -- , () 570 | -- ] "hello" 'b' 571 | -- ] 572 | -- 573 | -- >>> pPrint $ [ Foo [ "bar", "baz" ] "hello" 'a', Foo [] "bye" 'b' ] 574 | -- [ Foo 575 | -- [ "bar" 576 | -- , "baz" 577 | -- ] "hello" 'a' 578 | -- , Foo [] "bye" 'b' 579 | -- ] 580 | -- 581 | -- __Record__ 582 | -- 583 | -- >>> :{ 584 | -- data Bar b = Bar 585 | -- { barInt :: Int 586 | -- , barA :: b 587 | -- , barList :: [Foo Double] 588 | -- } deriving Show 589 | -- :} 590 | -- 591 | -- >>> pPrint $ Bar 1 [10, 11] [Foo 1.1 "" 'a', Foo 2.2 "hello" 'b'] 592 | -- Bar 593 | -- { barInt = 1 594 | -- , barA = 595 | -- [ 10 596 | -- , 11 597 | -- ] 598 | -- , barList = 599 | -- [ Foo 1.1 "" 'a' 600 | -- , Foo 2.2 "hello" 'b' 601 | -- ] 602 | -- } 603 | -- 604 | -- __Newtype__ 605 | -- 606 | -- >>> newtype Baz = Baz { unBaz :: [String] } deriving Show 607 | -- 608 | -- >>> pPrint $ Baz ["hello", "bye"] 609 | -- Baz 610 | -- { unBaz = 611 | -- [ "hello" 612 | -- , "bye" 613 | -- ] 614 | -- } 615 | -- 616 | -- __Newline Rules__ 617 | -- 618 | -- >>> data Foo = A | B Foo | C [Foo] [Foo] | D String | E [Foo] [Foo] [Foo] [Foo] [Foo] deriving Show 619 | -- 620 | -- >>> pPrint $ B ( B A ) 621 | -- B 622 | -- ( B A ) 623 | -- 624 | -- >>> pPrint $ B ( B ( B A ) ) 625 | -- B 626 | -- ( B 627 | -- ( B A ) 628 | -- ) 629 | -- 630 | -- >>> pPrint $ B ( B ( B ( B A ) ) ) 631 | -- B 632 | -- ( B 633 | -- ( B 634 | -- ( B A ) 635 | -- ) 636 | -- ) 637 | -- 638 | -- >>> pPrint $ B ( C [A, A] [B A, B (B (B A))] ) 639 | -- B 640 | -- ( C 641 | -- [ A 642 | -- , A 643 | -- ] 644 | -- [ B A 645 | -- , B 646 | -- ( B 647 | -- ( B A ) 648 | -- ) 649 | -- ] 650 | -- ) 651 | -- 652 | -- >>> pPrint [C [B A] [D "1"]] 653 | -- [ C 654 | -- [ B A ] 655 | -- [ D "1" ] 656 | -- ] 657 | -- 658 | -- >>> pPrint [E [B A] [D "1"] [B A] [B A] [D "2"]] 659 | -- [ E 660 | -- [ B A ] 661 | -- [ D "1" ] 662 | -- [ B A ] 663 | -- [ B A ] 664 | -- [ D "2" ] 665 | -- ] 666 | -- 667 | -- __Laziness__ 668 | -- 669 | -- >>> take 100 . unpack . pShowNoColor $ [1..] 670 | -- "[ 1\n, 2\n, 3\n, 4\n, 5\n, 6\n, 7\n, 8\n, 9\n, 10\n, 11\n, 12\n, 13\n, 14\n, 15\n, 16\n, 17\n, 18\n, 19\n, 20\n, 21\n, 22" 671 | -- 672 | -- __Unicode__ 673 | -- 674 | -- >>> pPrint $ Baz ["猫", "犬", "ヤギ"] 675 | -- Baz 676 | -- { unBaz = 677 | -- [ "猫" 678 | -- , "犬" 679 | -- , "ヤギ" 680 | -- ] 681 | -- } 682 | -- 683 | -- __Char__ 684 | -- 685 | -- >>> pPrint 'λ' 686 | -- 'λ' 687 | -- 688 | -- __Compactness options__ 689 | -- 690 | -- >>> pPrintOpt CheckColorTty defaultOutputOptionsDarkBg {outputOptionsCompact = True} $ B ( B ( B ( B A ) ) ) 691 | -- B 692 | -- ( B ( B ( B A ) ) ) 693 | -- 694 | -- >>> 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\")))])]" 695 | -- AST [] 696 | -- [ Def 697 | -- ( ( 3, 1 ), ( 5, 30 ) ) 698 | -- ( Id "fact'" "fact'" ) [] 699 | -- ( Forall 700 | -- ( ( 3, 9 ), ( 3, 26 ) ) 701 | -- [ ( ( Id "n" "n_0" ), KPromote ( TyCon ( Id "Nat" "Nat" ) ) ) ] 702 | -- ) 703 | -- ] 704 | -- 705 | -- >>> pPrintOpt CheckColorTty defaultOutputOptionsDarkBg {outputOptionsCompactParens = True} $ B ( C [A, A] [B A, B (B (B A))] ) 706 | -- B 707 | -- ( C 708 | -- [ A 709 | -- , A ] 710 | -- [ B A 711 | -- , B 712 | -- ( B 713 | -- ( B A ) ) ] ) 714 | -- 715 | -- >>> pPrintOpt CheckColorTty defaultOutputOptionsDarkBg {outputOptionsCompact = True} $ [("id", 123), ("state", 1), ("pass", 1), ("tested", 100), ("time", 12345)] 716 | -- [ 717 | -- ( "id", 123 ), 718 | -- ( "state", 1 ), 719 | -- ( "pass", 1 ), 720 | -- ( "tested", 100 ), 721 | -- ( "time", 12345 ) 722 | -- ] 723 | -- 724 | -- __Initial indent__ 725 | -- 726 | -- >>> pPrintOpt CheckColorTty defaultOutputOptionsDarkBg {outputOptionsInitialIndent = 3} $ B ( B ( B ( B A ) ) ) 727 | -- B 728 | -- ( B 729 | -- ( B 730 | -- ( B A ) 731 | -- ) 732 | -- ) 733 | -- 734 | -- __Weird/illegal show instances__ 735 | -- 736 | -- >>> pPrintString "2019-02-18 20:56:24.265489 UTC" 737 | -- 2019-02-18 20:56:24.265489 UTC 738 | -- 739 | -- >>> pPrintString "a7ed86f7-7f2c-4be5-a760-46a3950c2abf" 740 | -- a7ed86f7-7f2c-4be5-a760-46a3950c2abf 741 | -- 742 | -- >>> pPrintString "192.168.0.1:8000" 743 | -- 192.168.0.1:8000 744 | -- 745 | -- >>> pPrintString "A @\"type\" 1" 746 | -- A @"type" 1 747 | -- 748 | -- >>> pPrintString "2+2" 749 | -- 2+2 750 | -- 751 | -- >>> pPrintString "1.0e-2" 752 | -- 1.0e-2 753 | -- 754 | -- >>> pPrintString "0x1b" 755 | -- 0x1b 756 | -- 757 | -- >>> pPrintString "[div_ [class_ \"level\"] [button_ [onClick False] [text \"-\"], div_ [] [text $ ms level], button_ [onClick True] [text \"+\"]]]" 758 | -- [ div_ 759 | -- [ class_ "level" ] 760 | -- [ button_ 761 | -- [ onClick False ] 762 | -- [ text "-" ] 763 | -- , div_ [] 764 | -- [ text $ ms level ] 765 | -- , button_ 766 | -- [ onClick True ] 767 | -- [ text "+" ] 768 | -- ] 769 | -- ] 770 | -- 771 | -- __Other__ 772 | -- 773 | -- Making sure the spacing after a string is correct. 774 | -- 775 | -- >>> data Foo = Foo String Int deriving Show 776 | -- 777 | -- >>> pPrint $ Foo "bar" 0 778 | -- Foo "bar" 0 779 | -- 780 | -- Non-printable characters will get escaped. 781 | -- 782 | -- >>> pPrint "this string has non-printable characters: \x8 and \x9" 783 | -- "this string has non-printable characters: \x8 and \x9" 784 | -- 785 | -- If you don't want non-printable characters to be escaped, take a look at 786 | -- 'outputOptionsStringStyle' and 'StringOutputStyle'. 787 | --------------------------------------------------------------------------------