├── .gitignore ├── .stylish-haskell.yaml ├── .travis.yml ├── CHANGELOG.md ├── LICENSE.md ├── README.md ├── Setup.hs ├── scripts └── ci │ └── install │ └── stack ├── show-prettyprint.cabal ├── src └── Text │ └── Show │ ├── Prettyprint.hs │ └── Prettyprint │ ├── Diagnostic.hs │ └── Internal.hs ├── stack.yaml ├── stack.yaml.lock └── test └── Doctest └── Main.hs /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work 2 | .cabal-sandbox 3 | cabal.sandbox.config 4 | dist -------------------------------------------------------------------------------- /.stylish-haskell.yaml: -------------------------------------------------------------------------------- 1 | # stylish-haskell configuration file 2 | # ================================== 3 | 4 | # Auto-generated by stylish-haskell 0.9.2.1 via stylish-haskell --defaults 5 | 6 | # The stylish-haskell tool is mainly configured by specifying steps. These steps 7 | # are a list, so they have an order, and one specific step may appear more than 8 | # once (if needed). Each file is processed by these steps in the given order. 9 | steps: 10 | # Convert some ASCII sequences to their Unicode equivalents. This is disabled 11 | # by default. 12 | # - unicode_syntax: 13 | # # In order to make this work, we also need to insert the UnicodeSyntax 14 | # # language pragma. If this flag is set to true, we insert it when it's 15 | # # not already present. You may want to disable it if you configure 16 | # # language extensions using some other method than pragmas. Default: 17 | # # true. 18 | # add_language_pragma: true 19 | 20 | # Align the right hand side of some elements. This is quite conservative 21 | # and only applies to statements where each element occupies a single 22 | # line. 23 | - simple_align: 24 | cases: false 25 | top_level_patterns: false 26 | records: false 27 | 28 | # Import cleanup 29 | - imports: 30 | # There are different ways we can align names and lists. 31 | # 32 | # - global: Align the import names and import list throughout the entire 33 | # file. 34 | # 35 | # - file: Like global, but don't add padding when there are no qualified 36 | # imports in the file. 37 | # 38 | # - group: Only align the imports per group (a group is formed by adjacent 39 | # import lines). 40 | # 41 | # - none: Do not perform any alignment. 42 | # 43 | # Default: global. 44 | align: group 45 | 46 | # The following options affect only import list alignment. 47 | # 48 | # List align has following options: 49 | # 50 | # - after_alias: Import list is aligned with end of import including 51 | # 'as' and 'hiding' keywords. 52 | # 53 | # > import qualified Data.List as List (concat, foldl, foldr, head, 54 | # > init, last, length) 55 | # 56 | # - with_alias: Import list is aligned with start of alias or hiding. 57 | # 58 | # > import qualified Data.List as List (concat, foldl, foldr, head, 59 | # > init, last, length) 60 | # 61 | # - new_line: Import list starts always on new line. 62 | # 63 | # > import qualified Data.List as List 64 | # > (concat, foldl, foldr, head, init, last, length) 65 | # 66 | # Default: after_alias 67 | list_align: after_alias 68 | 69 | # Right-pad the module names to align imports in a group: 70 | # 71 | # - true: a little more readable 72 | # 73 | # > import qualified Data.List as List (concat, foldl, foldr, 74 | # > init, last, length) 75 | # > import qualified Data.List.Extra as List (concat, foldl, foldr, 76 | # > init, last, length) 77 | # 78 | # - false: diff-safe 79 | # 80 | # > import qualified Data.List as List (concat, foldl, foldr, init, 81 | # > last, length) 82 | # > import qualified Data.List.Extra as List (concat, foldl, foldr, 83 | # > init, last, length) 84 | # 85 | # Default: true 86 | pad_module_names: true 87 | 88 | # Long list align style takes effect when import is too long. This is 89 | # determined by 'columns' setting. 90 | # 91 | # - inline: This option will put as much specs on same line as possible. 92 | # 93 | # - new_line: Import list will start on new line. 94 | # 95 | # - new_line_multiline: Import list will start on new line when it's 96 | # short enough to fit to single line. Otherwise it'll be multiline. 97 | # 98 | # - multiline: One line per import list entry. 99 | # Type with constructor list acts like single import. 100 | # 101 | # > import qualified Data.Map as M 102 | # > ( empty 103 | # > , singleton 104 | # > , ... 105 | # > , delete 106 | # > ) 107 | # 108 | # Default: inline 109 | long_list_align: new_line_multiline 110 | 111 | # Align empty list (importing instances) 112 | # 113 | # Empty list align has following options 114 | # 115 | # - inherit: inherit list_align setting 116 | # 117 | # - right_after: () is right after the module name: 118 | # 119 | # > import Vector.Instances () 120 | # 121 | # Default: inherit 122 | empty_list_align: inherit 123 | 124 | # List padding determines indentation of import list on lines after import. 125 | # This option affects 'long_list_align'. 126 | # 127 | # - : constant value 128 | # 129 | # - module_name: align under start of module name. 130 | # Useful for 'file' and 'group' align settings. 131 | list_padding: 4 132 | 133 | # Separate lists option affects formatting of import list for type 134 | # or class. The only difference is single space between type and list 135 | # of constructors, selectors and class functions. 136 | # 137 | # - true: There is single space between Foldable type and list of it's 138 | # functions. 139 | # 140 | # > import Data.Foldable (Foldable (fold, foldl, foldMap)) 141 | # 142 | # - false: There is no space between Foldable type and list of it's 143 | # functions. 144 | # 145 | # > import Data.Foldable (Foldable(fold, foldl, foldMap)) 146 | # 147 | # Default: true 148 | separate_lists: true 149 | 150 | # Space surround option affects formatting of import lists on a single 151 | # line. The only difference is single space after the initial 152 | # parenthesis and a single space before the terminal parenthesis. 153 | # 154 | # - true: There is single space associated with the enclosing 155 | # parenthesis. 156 | # 157 | # > import Data.Foo ( foo ) 158 | # 159 | # - false: There is no space associated with the enclosing parenthesis 160 | # 161 | # > import Data.Foo (foo) 162 | # 163 | # Default: false 164 | space_surround: false 165 | 166 | # Language pragmas 167 | - language_pragmas: 168 | # We can generate different styles of language pragma lists. 169 | # 170 | # - vertical: Vertical-spaced language pragmas, one per line. 171 | # 172 | # - compact: A more compact style. 173 | # 174 | # - compact_line: Similar to compact, but wrap each line with 175 | # `{-#LANGUAGE #-}'. 176 | # 177 | # Default: vertical. 178 | style: vertical 179 | 180 | # Align affects alignment of closing pragma brackets. 181 | # 182 | # - true: Brackets are aligned in same column. 183 | # 184 | # - false: Brackets are not aligned together. There is only one space 185 | # between actual import and closing bracket. 186 | # 187 | # Default: true 188 | align: true 189 | 190 | # stylish-haskell can detect redundancy of some language pragmas. If this 191 | # is set to true, it will remove those redundant pragmas. Default: true. 192 | remove_redundant: true 193 | 194 | # Replace tabs by spaces. This is disabled by default. 195 | # - tabs: 196 | # # Number of spaces to use for each tab. Default: 8, as specified by the 197 | # # Haskell report. 198 | # spaces: 8 199 | 200 | # Remove trailing whitespace 201 | - trailing_whitespace: {} 202 | 203 | # Squash multiple spaces between the left and right hand sides of some 204 | # elements into single spaces. Basically, this undoes the effect of 205 | # simple_align but is a bit less conservative. 206 | # - squash: {} 207 | 208 | # A common setting is the number of columns (parts of) code will be wrapped 209 | # to. Different steps take this into account. Default: 80. 210 | columns: 80 211 | 212 | # By default, line endings are converted according to the OS. You can override 213 | # preferred format here. 214 | # 215 | # - native: Native newline format. CRLF on Windows, LF on other OSes. 216 | # 217 | # - lf: Convert to LF ("\n"). 218 | # 219 | # - crlf: Convert to CRLF ("\r\n"). 220 | # 221 | # Default: native. 222 | newline: lf 223 | 224 | # Sometimes, language extensions are specified in a cabal file or from the 225 | # command line instead of using language pragmas in the file. stylish-haskell 226 | # needs to be aware of these, so it can parse the file correctly. 227 | # 228 | # No language extensions are enabled by default. 229 | # language_extensions: 230 | # - TemplateHaskell 231 | # - QuasiQuotes 232 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | sudo: false 2 | language: c 3 | addons: 4 | apt: 5 | packages: 6 | - libgmp-dev 7 | before_install: 8 | - export PATH="$HOME/.local/bin:$PATH" 9 | - travis_retry scripts/ci/install/stack 10 | - | 11 | _stack() { 12 | stack --no-terminal "$@" 13 | } 14 | - _stack setup 15 | script: 16 | - _stack test 17 | - _stack haddock --no-haddock-deps 18 | - _stack sdist 19 | cache: 20 | directories: 21 | - $HOME/.stack 22 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # 0.4 (next) 2 | 3 | - Fix alignment of children of multiline lists 4 | 5 | # 0.3.0.1 6 | 7 | - Fix dependencies of Doctest suite 8 | 9 | # 0.3 10 | 11 | - Fix lists not being prettified at the top level (#6) 12 | - Fix lists in nested data structures not being aligned (#6) 13 | 14 | # 0.2.3 15 | 16 | - Fix escaping of backslashes (#5) 17 | - Fix a bug with ambiguous types on newer cabal new-repl runs (#4) 18 | 19 | # 0.2.{1,2} 20 | 21 | Add functions to prettify to `Doc` instead of just supporting `String`, 22 | 23 | ```haskell 24 | prettifyToDoc :: String -> Doc ann 25 | prettyShowDoc :: Show a => a -> Doc ann 26 | ``` 27 | 28 | # 0.2.0.1 29 | 30 | Tagged the wrong version as 0.2 on Github. Releasing a new version with an 31 | updated tag to remedy this. 32 | 33 | # 0.2 34 | 35 | Prettyprint based on the `prettyprinter` library, instead of `ansi-wl-pprint`. 36 | To support the `Diagnostic` module, the Trifecta-generated `Doc` has to be 37 | rendered still, so we cannot drop the dependency on ansi-wl-pprint just yet. 38 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | BSD3 License 2 | ============ 3 | 4 | Copyright David Luposchainsky (c) 2016 5 | 6 | All rights reserved. 7 | 8 | Redistribution and use in source and binary forms, with or without modification, 9 | are permitted provided that the following conditions are met: 10 | 11 | - Redistributions of source code must retain the above copyright notice, this 12 | list of conditions and the following disclaimer. 13 | - Redistributions in binary form must reproduce the above copyright notice, 14 | this list of conditions and the following disclaimer in the documentation 15 | and/or other materials provided with the distribution. 16 | - Neither the name of Author name here nor the names of other contributors may 17 | be used to endorse or promote products derived from this software without 18 | specific prior written permission. 19 | 20 | This software is provided by the copyright holders and contributors "as is" and 21 | any express or implied warranties, including, but not limited to, the implied 22 | warranties of merchantability and fitness for a particular purpose are 23 | disclaimed. In no event shall the copyright owner or contributors be liable for 24 | any direct, indirect, incidental, special, exemplary, or consequential damages 25 | (including, but not limited to, procurement of substitute goods or services; 26 | loss of use, data, or profits; or business interruption) however caused and on 27 | any theory of liability, whether in contract, strict liability, or tort 28 | (including negligence or otherwise) arising in any way out of the use of this 29 | software, even if advised of the possibility of such damage. -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | [![](https://travis-ci.org/quchen/show-prettyprint.svg?branch=master)](https://travis-ci.org/quchen/show-prettyprint) 2 | 3 | Prettyprint `Show` output 4 | ========================= 5 | 6 | Output of nested data structures by `Show` instances is often very hard to read. 7 | This package offers a simple function to insert line breaks and indentation into 8 | that ouput so that the semantics are unchanged, but makes it *much* easier to 9 | read. 10 | 11 | The package does not rely on a parser for actual Haskell; instead, it merely 12 | reacts on parentheses, commas and the like. This makes it fairly robust even in 13 | the face of invalid `Show` instances, that may not produce valid Haskell code. 14 | 15 | 16 | 17 | ## Examples 18 | 19 | ### Artificial 20 | 21 | ```haskell 22 | Hello Foo ("(Bar", Haha) (Baz (A { foo = C, bar = D, qux = (E,"He)llo World!",G, 23 | H,[A,B,c,d,e,Fghi]) } ) (B,C) [Baz A1 B2, (Baz A3 (B4)), (Baz A5 (B6)), (Baz 24 | (A7) B8)]) (Foo) (Bar) (Baz (A) (B)) 25 | 26 | ==> 27 | 28 | 29 | Hello Foo ("(Bar",Haha) 30 | (Baz (A {foo = C 31 | ,bar = D 32 | ,qux = (E,"He)llo World!",G,H,[A,B,c,d,e,Fghi])}) 33 | (B,C) 34 | [Baz A1 B2,(Baz A3 (B4)),(Baz A5 (B6)),(Baz (A7) B8)]) 35 | (Foo) 36 | (Bar) 37 | (Baz (A) (B)) 38 | ``` 39 | 40 | ### Inspired by a real AST 41 | 42 | ```haskell 43 | Set (fromList [(Name "A string with (parenthesis",Ann (Entry (Quality 1 1) 44 | (Ann False) (Ann (Map [Ann (Bound (Ann (Id "lorem"))),Ann (Variable 45 | (Ann (Id "ipsum")))])))),(Name "string",Ann (Entry (Quality 1 1) (Ann 46 | True) (Ann (Internal (Ann (Reduce (Ann (Id "dolor")) (Ann (Id "sit"))))) 47 | ))),(Name "Another } here",Ann (Entry (Quality 1 1) (Ann (Or [Ann (Not 48 | (Ann (Is (Ann Flagged) (Ann Type) (Ann (Multi [Ann (Literal (Ann One)) 49 | ]))))),Ann (Is (Ann Flagged) (Ann Type) (Ann (Multi [Ann (Literal (Ann 50 | Three))]))),Ann (Is (Ann Flagged) (Ann Type) (Ann (Multi [Ann (Literal 51 | (Ann Two))])))])) (Ann (Internal (Ann (Concat (Ann (Id "amet"))))))))]) 52 | 53 | ==> 54 | 55 | Set (fromList [(Name "A string with (parenthesis" 56 | ,Ann (Entry (Quality 1 1) 57 | (Ann False) 58 | (Ann (Map [Ann (Bound (Ann (Id "lorem"))) 59 | ,Ann (Variable (Ann (Id "ipsum")))])))) 60 | ,(Name "string" 61 | ,Ann (Entry (Quality 1 1) 62 | (Ann True) 63 | (Ann (Internal (Ann (Reduce (Ann (Id "dolor")) 64 | (Ann (Id "sit")))))))) 65 | ,(Name "Another } here" 66 | ,Ann (Entry (Quality 1 1) 67 | (Ann (Or [Ann (Not (Ann (Is (Ann Flagged) 68 | (Ann Type) 69 | (Ann (Multi [Ann (Literal (Ann One))]))))) 70 | ,Ann (Is (Ann Flagged) 71 | (Ann Type) 72 | (Ann (Multi [Ann (Literal (Ann Three))]))) 73 | ,Ann (Is (Ann Flagged) 74 | (Ann Type) 75 | (Ann (Multi [Ann (Literal (Ann Two))])))])) 76 | (Ann (Internal (Ann (Concat (Ann (Id "amet"))))))))]) 77 | ``` 78 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /scripts/ci/install/stack: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | set -euo pipefail 4 | 5 | mkdir -p ~/.local/bin 6 | curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 7 | -------------------------------------------------------------------------------- /show-prettyprint.cabal: -------------------------------------------------------------------------------- 1 | name: show-prettyprint 2 | version: 0.3 3 | synopsis: Robust prettyprinter for output of auto-generated Show 4 | instances 5 | description: See README.md 6 | homepage: https://github.com/quchen/show-prettyprint#readme 7 | license: BSD3 8 | license-file: LICENSE.md 9 | author: David Luposchainsky 10 | maintainer: David Luposchainsky 11 | copyright: David Luposchainsky, 2016 12 | category: User Interfaces, Text 13 | build-type: Simple 14 | extra-source-files: README.md 15 | , CHANGELOG.md 16 | , .stylish-haskell.yaml 17 | cabal-version: >=1.10 18 | 19 | library 20 | hs-source-dirs: src 21 | exposed-modules: Text.Show.Prettyprint 22 | , Text.Show.Prettyprint.Diagnostic 23 | , Text.Show.Prettyprint.Internal 24 | build-depends: base >= 4.7 && < 5 25 | , trifecta >= 1.6 26 | , prettyprinter >= 1.2 27 | 28 | -- Transitive dep of Trifecta, figure it out via that one 29 | , ansi-wl-pprint 30 | ghc-options: -Wall 31 | default-language: Haskell2010 32 | 33 | test-suite doctest 34 | type: exitcode-stdio-1.0 35 | hs-source-dirs: test/Doctest 36 | main-is: Main.hs 37 | build-depends: base 38 | , doctest >= 0.9 39 | , trifecta 40 | , prettyprinter 41 | , containers 42 | ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N 43 | default-language: Haskell2010 44 | 45 | source-repository head 46 | type: git 47 | location: https://github.com/quchen/show-prettyprint 48 | -------------------------------------------------------------------------------- /src/Text/Show/Prettyprint.hs: -------------------------------------------------------------------------------- 1 | -- | Format a 'show'-generated string to make it nicer to read. 2 | -- 3 | -- For example, consider this nested data structure: 4 | -- 5 | -- >>> :{ 6 | -- let nestedExample = fromList 7 | -- [ ("hello", Left (Pair True ())) 8 | -- , ("world", Right (Record { r1 = ('c', -1.2e34), r2 = 123 })) 9 | -- , ("!" , Left (Pair False ())) ] 10 | -- :} 11 | -- 12 | -- Applying 'show' to the nested example results in the fairly dense representation 13 | -- 14 | -- >>> print nestedExample 15 | -- fromList [("!",Left (Pair False ())),("hello",Left (Pair True ())),("world",Right (Record {r1 = ('c',-1.2e34), r2 = 123}))] 16 | -- 17 | -- With the functions defined in this module, we can make this output a bit more 18 | -- readable, 19 | -- 20 | -- >>> prettyPrint nestedExample 21 | -- fromList [("!",Left (Pair False ())) 22 | -- ,("hello",Left (Pair True ())) 23 | -- ,("world",Right (Record {r1 = ('c',-1.2e34),r2 = 123}))] 24 | module Text.Show.Prettyprint ( 25 | prettifyShow, 26 | prettifyToDoc, 27 | 28 | prettyShow, 29 | prettyShowDoc, 30 | prettyPrint, 31 | ) where 32 | 33 | 34 | 35 | import Text.Trifecta 36 | 37 | import Data.Text.Prettyprint.Doc (Doc, pretty) 38 | import Text.Show.Prettyprint.Internal 39 | 40 | 41 | 42 | -- $setup 43 | -- >>> data Record a b = Record { r1 :: a, r2 :: b } deriving Show 44 | -- >>> data Pair a b = Pair a b deriving Show 45 | -- >>> import Data.Map (fromList) 46 | 47 | -- | Prettyprint a string produced by 'show'. On parse error, silently fall back 48 | -- to a non-prettyprinted version. 49 | prettifyShow :: String -> String 50 | prettifyShow s = case parseShowString s of 51 | Success x -> show x 52 | Failure _ -> s 53 | 54 | -- | 'prettifyShow' with the 'show' baked in. 55 | prettyShow :: Show a => a -> String 56 | prettyShow = prettifyShow . show 57 | 58 | -- | 'prettifyShow' with the 'show' and the 'putStrLn' baked in. 59 | prettyPrint :: Show a => a -> IO () 60 | prettyPrint = putStrLn . prettyShow 61 | 62 | -- | Like 'prettifyShow', but maps to a 'Doc' for easier interoperability with 63 | -- the @prettyprinter@ package. 64 | prettifyToDoc :: String -> Doc ann 65 | prettifyToDoc s = case parseShowString s of 66 | Success x -> x 67 | Failure _ -> pretty s 68 | 69 | -- | 'prettifyToDoc' with the 'show' baked in. 70 | prettyShowDoc :: Show a => a -> Doc ann 71 | prettyShowDoc = prettifyToDoc . show 72 | 73 | -- $ 74 | -- Regression (#6): Top-level lists weren’t prettified 75 | -- >>> :{ 76 | -- let listExample = 77 | -- [ ("hello", Left (Pair True ())) 78 | -- , ("world", Right (Record { r1 = ('c', -1.2e34), r2 = 123 })) 79 | -- , ("!" , Left (Pair False ())) ] 80 | -- :} 81 | -- 82 | -- >>> prettyPrint listExample 83 | -- [("hello",Left (Pair True ())) 84 | -- ,("world",Right (Record {r1 = ('c',-1.2e34),r2 = 123})) 85 | -- ,("!",Left (Pair False ()))] 86 | 87 | -- $ 88 | -- Example from README 89 | -- >>> :{ 90 | -- (putStrLn . prettifyShow . unlines) 91 | -- [ "Hello Foo (\"(Bar\", Haha) (Baz (A { foo = C, bar = D, qux = (E,\"He)llo World!\",G," 92 | -- , " H,[A,B,c,d,e,Fghi]) } ) (B,C) [Baz A1 B2, (Baz A3 (B4)), (Baz A5 (B6)), (Baz" 93 | -- , " (A7) B8)]) (Foo) (Bar) (Baz (A) (B))" ] 94 | -- :} 95 | -- Hello Foo ("(Bar",Haha) 96 | -- (Baz (A {foo = C 97 | -- ,bar = D 98 | -- ,qux = (E,"He)llo World!",G,H,[A,B,c,d,e,Fghi])}) 99 | -- (B,C) 100 | -- [Baz A1 B2,(Baz A3 (B4)),(Baz A5 (B6)),(Baz (A7) B8)]) 101 | -- (Foo) 102 | -- (Bar) 103 | -- (Baz (A) (B)) 104 | 105 | -- $ 106 | -- Example from README 107 | -- >>> :{ 108 | -- (putStrLn . prettifyShow . unlines) 109 | -- ["Set (fromList [(Name \"A string with (parenthesis\",Ann (Entry (Quality 1 1)" 110 | -- ,"(Ann False) (Ann (Map [Ann (Bound (Ann (Id \"lorem\"))),Ann (Variable" 111 | -- ,"(Ann (Id \"ipsum\")))])))),(Name \"string\",Ann (Entry (Quality 1 1) (Ann" 112 | -- ,"True) (Ann (Internal (Ann (Reduce (Ann (Id \"dolor\")) (Ann (Id \"sit\")))))" 113 | -- ,"))),(Name \"Another } here\",Ann (Entry (Quality 1 1) (Ann (Or [Ann (Not" 114 | -- ,"(Ann (Is (Ann Flagged) (Ann Type) (Ann (Multi [Ann (Literal (Ann One))" 115 | -- ,"]))))),Ann (Is (Ann Flagged) (Ann Type) (Ann (Multi [Ann (Literal (Ann" 116 | -- ,"Three))]))),Ann (Is (Ann Flagged) (Ann Type) (Ann (Multi [Ann (Literal" 117 | -- ,"(Ann Two))])))])) (Ann (Internal (Ann (Concat (Ann (Id \"amet\"))))))))])"] 118 | -- :} 119 | -- Set (fromList [(Name "A string with (parenthesis" 120 | -- ,Ann (Entry (Quality 1 1) 121 | -- (Ann False) 122 | -- (Ann (Map [Ann (Bound (Ann (Id "lorem"))) 123 | -- ,Ann (Variable (Ann (Id "ipsum")))])))) 124 | -- ,(Name "string" 125 | -- ,Ann (Entry (Quality 1 1) 126 | -- (Ann True) 127 | -- (Ann (Internal (Ann (Reduce (Ann (Id "dolor")) 128 | -- (Ann (Id "sit")))))))) 129 | -- ,(Name "Another } here" 130 | -- ,Ann (Entry (Quality 1 1) 131 | -- (Ann (Or [Ann (Not (Ann (Is (Ann Flagged) 132 | -- (Ann Type) 133 | -- (Ann (Multi [Ann (Literal (Ann One))]))))) 134 | -- ,Ann (Is (Ann Flagged) 135 | -- (Ann Type) 136 | -- (Ann (Multi [Ann (Literal (Ann Three))]))) 137 | -- ,Ann (Is (Ann Flagged) 138 | -- (Ann Type) 139 | -- (Ann (Multi [Ann (Literal (Ann Two))])))])) 140 | -- (Ann (Internal (Ann (Concat (Ann (Id "amet"))))))))]) 141 | -------------------------------------------------------------------------------- /src/Text/Show/Prettyprint/Diagnostic.hs: -------------------------------------------------------------------------------- 1 | -- | These functions are identical to the ones in the main module, but instead 2 | -- of falling back to the un-prettyprinted input, they will report an error on 3 | -- failure. 4 | -- 5 | -- >>> putStrLn (prettifyShowErr "Imbalanced (Parenthesis)) here") 6 | -- ERROR (interactive):1:25: error: expected: char literal, 7 | -- end of input, identifier, list, 8 | -- number, record, string literal, 9 | -- tuple, unit 10 | -- Imbalanced (Parenthesis)) here 11 | -- ^ 12 | module Text.Show.Prettyprint.Diagnostic ( 13 | prettifyShowErr, 14 | prettyShowErr, 15 | prettyPrintErr, 16 | ) where 17 | 18 | 19 | 20 | import qualified Text.PrettyPrint.ANSI.Leijen as OldAnsiPpr 21 | import Text.Trifecta as Tri 22 | 23 | import Text.Show.Prettyprint.Internal 24 | 25 | 26 | 27 | -- | Attempt to prettify a string produced by 'show'. Report error information 28 | -- on failure. 29 | prettifyShowErr :: String -> String 30 | prettifyShowErr s = case parseString shownP mempty s of 31 | Success x -> show x 32 | Failure ErrInfo{ _errDoc = e } -> "ERROR " <> show (OldAnsiPpr.plain e) 33 | 34 | -- | 'prettifyShowErr' with the 'show' baked in. 35 | prettyShowErr :: Show a => a -> String 36 | prettyShowErr = prettifyShowErr . show 37 | 38 | -- | 'prettifyShowErr' with the 'show' and the 'putStrLn' baked in. 39 | prettyPrintErr :: Show a => a -> IO () 40 | prettyPrintErr = putStrLn . prettyShowErr 41 | -------------------------------------------------------------------------------- /src/Text/Show/Prettyprint/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | 3 | -- | __This module may change arbitrarily between versions.__ It is exposed only 4 | -- for documentary purposes. 5 | module Text.Show.Prettyprint.Internal ( 6 | parseShowString, 7 | shownP, 8 | valueP, 9 | identifierP, 10 | numberP, 11 | stringLitP, 12 | charLitP, 13 | argP, 14 | unitP, 15 | tupleP, 16 | listP, 17 | recordP, 18 | ) where 19 | 20 | 21 | 22 | import Control.Applicative 23 | import Data.Text.Prettyprint.Doc as Ppr 24 | import Text.Trifecta as Tri 25 | 26 | 27 | 28 | -- $setup 29 | -- 30 | -- >>> import Text.PrettyPrint.ANSI.Leijen (plain) 31 | -- >>> :{ 32 | -- let testParse p s = case parseString p mempty s of 33 | -- Success x -> print x 34 | -- Failure ErrInfo{ _errDoc = e } -> putStrLn ("ERROR " ++ show (plain e)) 35 | -- :} 36 | 37 | 38 | 39 | parseShowString :: String -> Result (Doc ann) 40 | parseShowString = parseString shownP mempty 41 | 42 | -- | Prettyparser for a 'show'-generated string 43 | shownP :: Parser (Doc ann) 44 | shownP = valueP <* eof 45 | 46 | -- | Prettyparser for a constructor, which is roughly a word applied to 47 | -- arguments. 48 | -- 49 | -- >>> testParse valueP "Just ('c', Left ())" 50 | -- Just ('c',Left ()) 51 | valueP :: Parser (Doc ann) 52 | valueP = do 53 | thing <- choice [identifierP, numberP, stringLitP, charLitP, listP] 54 | args <- many argP 55 | pure (if null args 56 | then thing 57 | else thing <+> align (sep args) ) 58 | 59 | -- | An identifier is a liberal version of a "variable or constructor", which 60 | -- roughly means that it's a printable word without parentheses. 61 | -- 62 | -- >>> testParse identifierP "_foo'bar" 63 | -- _foo'bar 64 | identifierP :: Parser (Doc ann) 65 | identifierP = token (p "identifier") 66 | where 67 | p = fmap Ppr.pretty (some (alphaNum <|> oneOf "'_")) 68 | 69 | -- | Number in integer or scientific notation. 70 | -- 71 | -- >>> testParse numberP "123456" 72 | -- 123456 73 | -- 74 | -- >>> testParse numberP "-123.4e56" 75 | -- -1.234e58 76 | numberP :: Parser (Doc ann) 77 | numberP = p "number" 78 | where 79 | p = integerOrDouble >>= \case 80 | Left i -> pure (pretty i) 81 | Right d -> pure (pretty d) 82 | 83 | -- | 84 | -- >>> testParse stringLitP "\"Hello\\\\ world!\"" 85 | -- "Hello\\ world!" 86 | stringLitP :: Parser (Doc ann) 87 | stringLitP = token (p "string literal") 88 | where 89 | p = fmap (dquotes . pretty . concatMap escapeBackslashes) 90 | (stringLiteral :: Parser String) 91 | 92 | escapeBackslashes :: Char -> String 93 | escapeBackslashes '\\' = "\\\\" 94 | escapeBackslashes x = [x] 95 | 96 | -- | 97 | -- >>> testParse charLitP "'c'" 98 | -- 'c' 99 | charLitP :: Parser (Doc ann) 100 | charLitP = token (p "char literal") 101 | where 102 | p = fmap (squotes . pretty . escapeBackslashes) Tri.charLiteral 103 | 104 | -- $ 105 | -- Correct backslash handling 106 | -- >>> testParse charLitP "'\\\\'" 107 | -- '\\' 108 | 109 | -- | Anything that could be considered an argument to something else. 110 | -- 111 | -- >>> testParse argP "()" 112 | -- () 113 | -- 114 | -- >>> testParse argP "['h', 'e', 'l', 'l', 'o']" 115 | -- ['h','e','l','l','o'] 116 | argP :: Parser (Doc ann) 117 | argP = (token . choice) [unitP, tupleP, listP, recordP, valueP] 118 | 119 | -- | 120 | -- >>> testParse unitP "()" 121 | -- () 122 | unitP :: Parser (Doc ann) 123 | unitP = p "unit" 124 | where 125 | p = fmap pretty (Tri.string "()") 126 | 127 | -- | Prettyparser for tuples from size 1. Since 1-tuples are just parenthesized 128 | -- expressions to first order approximation, this parser handles those as well. 129 | -- 130 | -- >>> testParse tupleP "((), True, 'c')" 131 | -- ((),True,'c') 132 | tupleP :: Parser (Doc ann) 133 | tupleP = p "tuple" 134 | where 135 | p = fmap (encloseSep lparen rparen Ppr.comma) (Tri.parens (do 136 | x <- argP 137 | xs <- many (Tri.comma *> argP) 138 | pure (x:xs) )) 139 | 140 | -- | List prettyparser. Lists can be heterogeneous, which is realistic if we 141 | -- consider ill-defined Show instances. 142 | -- 143 | -- >>> testParse listP "[\"Hello\", World]" 144 | -- ["Hello",World] 145 | listP :: Parser (Doc ann) 146 | listP = p "list" 147 | where 148 | p = fmap (encloseSep lbracket rbracket Ppr.comma . map align) 149 | (Tri.brackets (sepBy argP Tri.comma)) 150 | 151 | -- | 152 | -- >>> testParse recordP "{ r1 = (), r2 = Just True }" 153 | -- {r1 = (),r2 = Just True} 154 | recordP :: Parser (Doc ann) 155 | recordP = p "record" 156 | where 157 | p = fmap (encloseSep lbrace rbrace Ppr.comma) (Tri.braces (sepBy recordEntryP Tri.comma)) 158 | recordEntryP = do 159 | lhs <- token identifierP 160 | _ <- token (Tri.char '=') 161 | rhs <- argP 162 | pure (lhs <+> pretty '=' <+> align rhs) 163 | 164 | -- $ 165 | -- Regression (#6): Nested lists were not aligned properly 166 | -- >>> :{ 167 | -- testParse valueP (concat 168 | -- ["ApiGroup {name = \"API Key\" ,endpoints = [Endpoint {path = " 169 | -- ,"\"/v1/auth/info\" ,description = \"Retrieve information about the" 170 | -- ," current API key.\" ,needsAPIKey = \"Yes\" ,method = \"GET\" ," 171 | -- ,"requiredAccess = \"\"} ,Endpoint {path = \"/v1/auth/info\" ," 172 | -- ,"description = \"Retrieve information about the current API key.\" ," 173 | -- ,"needsAPIKey = \"Yes\" ,method = \"GET\" ,requiredAccess = \"\"}]}]" 174 | -- ]) 175 | -- :} 176 | -- ApiGroup {name = "API Key" 177 | -- ,endpoints = [Endpoint {path = "/v1/auth/info" 178 | -- ,description = "Retrieve information about the current API key." 179 | -- ,needsAPIKey = "Yes" 180 | -- ,method = "GET" 181 | -- ,requiredAccess = ""} 182 | -- ,Endpoint {path = "/v1/auth/info" 183 | -- ,description = "Retrieve information about the current API key." 184 | -- ,needsAPIKey = "Yes" 185 | -- ,method = "GET" 186 | -- ,requiredAccess = ""}]} 187 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-13.22 2 | packages: 3 | - '.' 4 | flags: {} 5 | extra-package-dbs: [] 6 | -------------------------------------------------------------------------------- /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 | size: 498186 10 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/13/22.yaml 11 | sha256: d4f07dc3d5658260c2fe34266ad7618f6c84d34decf559c9c786ac1cfccf4e7b 12 | original: lts-13.22 13 | -------------------------------------------------------------------------------- /test/Doctest/Main.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Test.DocTest 4 | 5 | main :: IO () 6 | main = doctest ["src", "-ignore-package prettyprinter-compat-ansi-wl-pprint"] 7 | --------------------------------------------------------------------------------