├── Setup.hs ├── .gitignore ├── cabal.project ├── tests ├── UnitT32.hs ├── PrettyTestVersion.hs ├── UnitLargeDoc.hs ├── UnitT3911.hs ├── TestUtils.hs ├── UnitPP1.hs ├── BugSep.hs ├── TestGenerators.hs ├── TestStructures.hs └── Test.hs ├── cabal.haskell-ci ├── .github └── workflows │ ├── mhs-ci.yml │ ├── ci.yml │ └── haskell-ci.yml ├── stack.yaml ├── LICENSE ├── src └── Text │ ├── PrettyPrint.hs │ └── PrettyPrint │ ├── Annotated.hs │ ├── HughesPJClass.hs │ ├── Annotated │ ├── HughesPJClass.hs │ └── HughesPJ.hs │ └── HughesPJ.hs ├── README.md ├── pretty.cabal ├── bench └── Bench.hs ├── docs └── new-pretty.md └── CHANGELOG.md /Setup.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Distribution.Simple 4 | 5 | main :: IO () 6 | main = defaultMain 7 | 8 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist/ 2 | dist-newstyle/ 3 | GNUmakefile 4 | dist-install 5 | ghc.mk 6 | cabal.sandbox.config 7 | .cabal-sandbox/ 8 | .stack-work/ 9 | *~ 10 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | 3 | constraints: QuickCheck -templatehaskell 4 | 5 | -- If we could get rid of template-haskell we could build the testsuite. 6 | -- https://github.com/haskell/containers/issues/1156 7 | -- constraints: containers -templatehaskell 8 | -------------------------------------------------------------------------------- /tests/UnitT32.hs: -------------------------------------------------------------------------------- 1 | -- Test from https://github.com/haskell/pretty/issues/32#issuecomment-223073337 2 | module UnitT32 where 3 | 4 | import Text.PrettyPrint.HughesPJ 5 | 6 | import TestUtils 7 | 8 | testT32 :: IO () 9 | testT32 = simpleMatch "T3911" (replicate 10 'x') $ take 10 $ render $ hcat $ repeat $ text "x" 10 | -------------------------------------------------------------------------------- /tests/PrettyTestVersion.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE BangPatterns #-} 3 | #if __GLASGOW_HASKELL__ >= 701 4 | {-# LANGUAGE DeriveGeneric #-} 5 | #endif 6 | 7 | #define TESTING 8 | 9 | -- | Here we use some CPP hackery to get a whitebox 10 | -- version of HughesPJ for testing purposes. 11 | module PrettyTestVersion where 12 | 13 | #include "HughesPJ.hs" 14 | 15 | -------------------------------------------------------------------------------- /tests/UnitLargeDoc.hs: -------------------------------------------------------------------------------- 1 | module UnitLargeDoc where 2 | 3 | import Text.PrettyPrint.HughesPJ 4 | 5 | import Control.DeepSeq 6 | import Control.Exception 7 | 8 | testLargeDoc :: IO () 9 | testLargeDoc = do 10 | putStrLn "Testing large doc..." 11 | evaluate largeDocRender 12 | return () 13 | 14 | largeDocRender :: String 15 | largeDocRender = force $ render $ vcat $ replicate 10000000 $ text "Hello" 16 | 17 | -------------------------------------------------------------------------------- /tests/UnitT3911.hs: -------------------------------------------------------------------------------- 1 | module UnitT3911 where 2 | 3 | import Text.PrettyPrint.HughesPJ 4 | 5 | import TestUtils 6 | 7 | xs :: [Doc] 8 | xs = [text "hello", 9 | nest 10 (text "world")] 10 | 11 | d1, d2, d3 :: Doc 12 | d1 = vcat xs 13 | d2 = foldr ($$) empty xs 14 | d3 = foldr ($+$) empty xs 15 | 16 | testT3911 :: IO () 17 | testT3911 = simpleMatch "T3911" expected out 18 | where out = show d1 ++ "\n" ++ show d2 ++ "\n" ++ show d3 19 | 20 | expected :: String 21 | expected = 22 | "hello world\n\ 23 | hello world\n\ 24 | hello\n\ 25 | world" 26 | -------------------------------------------------------------------------------- /tests/TestUtils.hs: -------------------------------------------------------------------------------- 1 | -- | Test-suite framework and utility functions. 2 | module TestUtils ( 3 | simpleMatch 4 | ) where 5 | 6 | import Control.Monad 7 | import System.Exit 8 | 9 | simpleMatch :: String -> String -> String -> IO () 10 | simpleMatch test expected actual = 11 | when (actual /= expected) $ do 12 | putStrLn $ "Test `" ++ test ++ "' failed!" 13 | putStrLn "-----------------------------" 14 | putStrLn $ "Expected: " ++ expected 15 | putStrLn "-----------------------------" 16 | putStrLn $ "Actual: " ++ actual 17 | putStrLn "-----------------------------" 18 | exitFailure 19 | 20 | -------------------------------------------------------------------------------- /cabal.haskell-ci: -------------------------------------------------------------------------------- 1 | branches: master 2 | installed: +all -pretty 3 | -- Tests and benchmarks do not build due to cycling package dependencies. 4 | -- QuickCheck/containers -> template-haskell -> pretty. 5 | -- Building the benchmarks requires template-haskell which depends on pretty 6 | -- causing a dependency cycle that cabal cannot handle. 7 | benchmarks: False 8 | 9 | -- Testsuite broken with GHC 8 because it does some hack 10 | -- dropping the module header when building the testsuite 11 | -- which leads to misplaced LANGUAGE pragmas. 12 | -- Testsuite broken with GHC >= 9.4 due to cycle involving 13 | -- QuickCheck, containers, template-haskell and pretty. 14 | tests: >=9.0 && <9.4 15 | -------------------------------------------------------------------------------- /.github/workflows/mhs-ci.yml: -------------------------------------------------------------------------------- 1 | name: mhs-ci 2 | 3 | on: 4 | push: 5 | branches: [ "master" ] 6 | pull_request: 7 | branches: [ "master" ] 8 | 9 | jobs: 10 | build-mhs-pretty: 11 | runs-on: ubuntu-latest 12 | steps: 13 | 14 | - name: checkout mhs repo 15 | uses: actions/checkout@v4 16 | with: 17 | repository: augustss/MicroHs 18 | ref: stable-3 19 | path: mhs 20 | - name: make and install mhs 21 | run: | 22 | cd mhs 23 | make minstall 24 | 25 | - name: checkout pretty repo 26 | uses: actions/checkout@v4 27 | with: 28 | path: pretty 29 | - name: compile and install pretty package 30 | run: | 31 | PATH="$HOME/.mcabal/bin:$PATH" 32 | cd pretty 33 | mcabal install 34 | 35 | - name: cleanup 36 | run: | 37 | rm -rf $HOME/.mcabal 38 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md 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-10.4 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: >= 0.1.4.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 | -------------------------------------------------------------------------------- /tests/UnitPP1.hs: -------------------------------------------------------------------------------- 1 | -- This code used to print an infinite string, by calling 'spaces' 2 | -- with a negative argument. There's a patch in the library now, 3 | -- which makes 'spaces' do something sensible when called with a negative 4 | -- argument, but it really should not happen at all. 5 | 6 | module UnitPP1 where 7 | 8 | import TestUtils 9 | 10 | import Text.PrettyPrint.HughesPJ 11 | 12 | ncat :: Doc -> Doc -> Doc 13 | ncat x y = nest 4 $ cat [ x, y ] 14 | 15 | d1, d2 :: Doc 16 | d1 = foldl1 ncat $ take 50 $ repeat $ char 'a' 17 | d2 = parens $ sep [ d1, text "+" , d1 ] 18 | 19 | testPP1 :: IO () 20 | testPP1 = simpleMatch "PP1" expected out 21 | where out = show d2 22 | 23 | expected :: String 24 | expected = 25 | "(aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\n\ 26 | + a\n\ 27 | a\n\ 28 | a\n\ 29 | a\n\ 30 | a\n\ 31 | a\n\ 32 | a\n\ 33 | a\n\ 34 | a\n\ 35 | a\n\ 36 | a\n\ 37 | a\n\ 38 | a\n\ 39 | a\n\ 40 | a\n\ 41 | a\n\ 42 | a\n\ 43 | a\n\ 44 | a\n\ 45 | a\n\ 46 | a\n\ 47 | a\n\ 48 | a\n\ 49 | a\n\ 50 | a\n\ 51 | a\n\ 52 | a\n\ 53 | a\n\ 54 | a\n\ 55 | a\n\ 56 | a\n\ 57 | a\n\ 58 | a\n\ 59 | a\n\ 60 | a\n\ 61 | a\n\ 62 | a\n\ 63 | a\n\ 64 | a\n\ 65 | a\n\ 66 | a\n\ 67 | a\n\ 68 | a\n\ 69 | a\n\ 70 | a\n\ 71 | a\n\ 72 | a\n\ 73 | a\n\ 74 | a\n\ 75 | a)" 76 | 77 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | This library (libraries/pretty) is derived from code from 2 | the GHC project which is largely (c) The University of 3 | Glasgow, and distributable under a BSD-style license (see below). 4 | 5 | ----------------------------------------------------------------------------- 6 | 7 | The Glasgow Haskell Compiler License 8 | 9 | Copyright 2004, The University Court of the University of Glasgow. 10 | All rights reserved. 11 | 12 | Redistribution and use in source and binary forms, with or without 13 | modification, are permitted provided that the following conditions are met: 14 | 15 | - Redistributions of source code must retain the above copyright notice, 16 | this list of conditions and the following disclaimer. 17 | 18 | - Redistributions in binary form must reproduce the above copyright notice, 19 | this list of conditions and the following disclaimer in the documentation 20 | and/or other materials provided with the distribution. 21 | 22 | - Neither name of the University nor the names of its contributors may be 23 | used to endorse or promote products derived from this software without 24 | specific prior written permission. 25 | 26 | THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF 27 | GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, 28 | INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND 29 | FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 30 | UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE 31 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 32 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 33 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 34 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 35 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 36 | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH 37 | DAMAGE. 38 | 39 | ----------------------------------------------------------------------------- 40 | -------------------------------------------------------------------------------- /tests/BugSep.hs: -------------------------------------------------------------------------------- 1 | -- | Demonstration of ambiguity in HughesPJ library at this time. GHC's 2 | -- internal copy has a different answer than we currently do, preventing them 3 | -- using our library. 4 | module Main (main) where 5 | 6 | import Text.PrettyPrint.HughesPJ 7 | 8 | main :: IO () 9 | main = do 10 | putStrLn "" 11 | putStrLn "Note that the correct definition of sep is currently unclear" 12 | putStrLn "It is neither foldr ($+$) empty nor foldr ($$) empty" 13 | putStrLn "------------------------------------------------------------" 14 | let test1 = [ text "" $+$ text "c", nest 3 ( text "a") ] 15 | let test2 = [ text "c", nest 3 ( text "b") ] 16 | putStrLn "--------------------------Test 1----------------------------" 17 | putStrLn "[ text \"\" $+$ text \"c\", nest 3 ( text \"a\") ]" 18 | putStrLn "-----------------------------sep----------------------------" 19 | print $ renderStyle style{lineLength=1} $ sep test1 20 | putStrLn "-----------------------------<+>----------------------------" 21 | print $ renderStyle style{lineLength=1} $ foldr (<+>) empty test1 22 | putStrLn "-----------------------------$+$----------------------------" 23 | print $ renderStyle style{lineLength=1} $ foldr ($+$) empty test1 24 | putStrLn "------------------------------$$----------------------------" 25 | print $ renderStyle style{lineLength=1} $ foldr ($$) empty test1 26 | putStrLn "--------------------------Test 2----------------------------" 27 | putStrLn "[ text \"c\", nest 3 ( text \"b\") ]" 28 | putStrLn "-----------------------------sep----------------------------" 29 | print $ renderStyle style{lineLength=1} $ sep test2 30 | putStrLn "-----------------------------<+>----------------------------" 31 | print $ renderStyle style{lineLength=1} $ foldr (<+>) empty test2 32 | putStrLn "-----------------------------$+$----------------------------" 33 | print $ renderStyle style{lineLength=1} $ foldr ($+$) empty test2 34 | putStrLn "------------------------------$$----------------------------" 35 | print $ renderStyle style{lineLength=1} $ foldr ($$) empty test2 36 | 37 | -------------------------------------------------------------------------------- /src/Text/PrettyPrint.hs: -------------------------------------------------------------------------------- 1 | #if __GLASGOW_HASKELL__ >= 701 2 | {-# LANGUAGE Safe #-} 3 | #endif 4 | ----------------------------------------------------------------------------- 5 | -- | 6 | -- Module : Text.PrettyPrint 7 | -- Copyright : (c) The University of Glasgow 2001 8 | -- License : BSD-style (see the file LICENSE) 9 | -- 10 | -- Maintainer : David Terei 11 | -- Stability : stable 12 | -- Portability : portable 13 | -- 14 | -- Provides a collection of pretty printer combinators, a set of API's 15 | -- that provides a way to easily print out text in a consistent format 16 | -- of your choosing. 17 | -- 18 | -- This module should be used as opposed to the 'Text.PrettyPrint.HughesPJ' 19 | -- module. Both are equivalent though as this module simply re-exports the 20 | -- other. 21 | -- 22 | ----------------------------------------------------------------------------- 23 | 24 | module Text.PrettyPrint ( 25 | 26 | -- * The document type 27 | Doc, 28 | 29 | -- ** Converting to an annotated Doc 30 | docToUnitDoc, 31 | 32 | -- * Constructing documents 33 | 34 | -- ** Converting values into documents 35 | char, text, ptext, sizedText, zeroWidthText, 36 | int, integer, float, double, rational, 37 | 38 | -- ** Simple derived documents 39 | semi, comma, colon, space, equals, 40 | lparen, rparen, lbrack, rbrack, lbrace, rbrace, 41 | 42 | -- ** Wrapping documents in delimiters 43 | parens, brackets, braces, quotes, doubleQuotes, 44 | 45 | -- ** Combining documents 46 | empty, 47 | (X.<>), (<+>), hcat, hsep, 48 | ($$), ($+$), vcat, 49 | sep, cat, 50 | fsep, fcat, 51 | nest, 52 | hang, punctuate, 53 | 54 | -- * Predicates on documents 55 | isEmpty, 56 | 57 | -- * Rendering documents 58 | 59 | -- ** Default rendering 60 | render, 61 | 62 | -- ** Rendering with a particular style 63 | Style(..), 64 | style, 65 | renderStyle, 66 | 67 | -- ** General rendering 68 | fullRender, 69 | Mode(..), TextDetails(..) 70 | 71 | ) where 72 | 73 | import Text.PrettyPrint.HughesPJ as X 74 | 75 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Pretty : A Haskell Pretty-printer library 2 | 3 | [![Hackage](https://img.shields.io/hackage/v/pretty.svg?style=flat)](https://hackage.haskell.org/package/pretty) 4 | [![Hackage Dependencies](https://img.shields.io/hackage-deps/v/pretty.svg?style=flat)](http://packdeps.haskellers.com/reverse/pretty) 5 | [![BSD3 License](http://img.shields.io/badge/license-BSD3-brightgreen.svg?style=flat)][tl;dr Legal: BSD3] 6 | [![Build](https://img.shields.io/travis/haskell/pretty.svg?style=flat)](https://travis-ci.org/haskell/pretty) 7 | 8 | [tl;dr Legal: BSD3]: 9 | https://tldrlegal.com/license/bsd-3-clause-license-(revised) 10 | "BSD3 License" 11 | 12 | Pretty is a pretty-printing library, a set of API's that provides a 13 | way to easily print out text in a consistent format of your choosing. 14 | This is useful for compilers and related tools. 15 | 16 | It is based on the pretty-printer outlined in the paper 'The Design 17 | of a Pretty-printing Library' by John Hughes in Advanced Functional 18 | Programming, 1995. It can be found 19 | [here](http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.38.8777). 20 | 21 | ## Licensing 22 | 23 | This library is BSD-licensed. 24 | 25 | ## Building 26 | 27 | The library uses the Cabal build system, so building is simply a 28 | matter of running: 29 | 30 | ``` 31 | cabal sandbox init 32 | cabal install "QuickCheck >= 2.5 && < 3" 33 | cabal install --only-dependencies 34 | cabal configure --enable-tests 35 | cabal build 36 | cabal test 37 | ``` 38 | 39 | We have to install `QuickCheck` manually as otherwise Cabal currently 40 | throws an error due to the cyclic dependency between `pretty` and 41 | `QuickCheck`. 42 | 43 | *If `cabal test` freezes*, then run 44 | `cabal test --show-details=streaming` instead. This is due to a 45 | [bug](https://github.com/haskell/cabal/issues/1810) in certain 46 | versions of Cabal. 47 | 48 | ## Get involved! 49 | 50 | We are happy to receive bug reports, fixes, documentation enhancements, 51 | and other improvements. 52 | 53 | Please report bugs via the 54 | [github issue tracker](http://github.com/haskell/pretty/issues). 55 | 56 | Master [git repository](http://github.com/haskell/pretty): 57 | 58 | * `git clone git://github.com/haskell/pretty.git` 59 | 60 | ## Authors 61 | 62 | This library is maintained by David Terei, . It 63 | was originally designed by John Hughes's and since heavily modified by 64 | Simon Peyton Jones. 65 | 66 | -------------------------------------------------------------------------------- /src/Text/PrettyPrint/Annotated.hs: -------------------------------------------------------------------------------- 1 | #if __GLASGOW_HASKELL__ >= 701 2 | {-# LANGUAGE Safe #-} 3 | #endif 4 | ----------------------------------------------------------------------------- 5 | -- | 6 | -- Module : Text.PrettyPrint.Annotated 7 | -- Copyright : (c) Trevor Elliott 2015 8 | -- License : BSD-style (see the file LICENSE) 9 | -- 10 | -- Maintainer : David Terei 11 | -- Stability : stable 12 | -- Portability : portable 13 | -- 14 | -- This module provides a version of pretty that allows for annotations to be 15 | -- attached to documents. Annotations are arbitrary pieces of metadata that can 16 | -- be attached to sub-documents. 17 | -- 18 | -- This module should be used as opposed to the 19 | -- 'Text.PrettyPrint.Annotated.HughesPJ' module. Both are equivalent though as 20 | -- this module simply re-exports the other. 21 | -- 22 | ----------------------------------------------------------------------------- 23 | 24 | module Text.PrettyPrint.Annotated ( 25 | 26 | -- * The document type 27 | Doc, 28 | 29 | -- ** Convert unit-annotated Doc to an arbitrary annotation type 30 | unitDocToAnnotatedDoc, 31 | 32 | -- * Constructing documents 33 | 34 | -- ** Converting values into documents 35 | char, text, ptext, sizedText, zeroWidthText, 36 | int, integer, float, double, rational, 37 | 38 | -- ** Simple derived documents 39 | semi, comma, colon, space, equals, 40 | lparen, rparen, lbrack, rbrack, lbrace, rbrace, 41 | 42 | -- ** Wrapping documents in delimiters 43 | parens, brackets, braces, quotes, doubleQuotes, 44 | 45 | -- ** Combining documents 46 | empty, 47 | (X.<>), (<+>), hcat, hsep, 48 | ($$), ($+$), vcat, 49 | sep, cat, 50 | fsep, fcat, 51 | nest, 52 | hang, punctuate, 53 | 54 | -- ** Annotating documents 55 | annotate, 56 | 57 | -- * Predicates on documents 58 | isEmpty, 59 | 60 | -- * Rendering documents 61 | 62 | -- ** Default rendering 63 | render, 64 | 65 | -- ** Annotation rendering 66 | renderSpans, Span(..), 67 | 68 | -- ** Rendering with a particular style 69 | Style(..), 70 | style, 71 | renderStyle, 72 | 73 | -- ** General rendering 74 | fullRender, 75 | fullRenderAnn, 76 | Mode(..), TextDetails(..) 77 | 78 | ) where 79 | 80 | import Text.PrettyPrint.Annotated.HughesPJ as X 81 | 82 | -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | # Andreas, 2025-07-26, hand-knitted CI using Cabal 2 | 3 | name: Cabal CI 4 | on: 5 | push: 6 | branches: 7 | - master 8 | pull_request: 9 | branches: 10 | - master 11 | 12 | jobs: 13 | build: 14 | name: ${{ matrix.os }} GHC ${{ matrix.ghc }} 15 | runs-on: ${{ matrix.os }} 16 | strategy: 17 | matrix: 18 | os: [ubuntu-latest] 19 | ghc: 20 | # - '9.12' # currently subsumed by latest 21 | - '9.10' 22 | - '9.8' 23 | - '9.6' 24 | # - '9.4' # skip intermediate ghc version 25 | # - '9.2' # skip intermediate ghc version 26 | # - '9.0' # skip intermediate ghc version 27 | # - '8.10' # skip intermediate ghc version 28 | # - '8.8' # skip intermediate ghc version 29 | # - '8.6' # skip intermediate ghc version 30 | # - '8.4' # skip intermediate ghc version 31 | # - '8.2' # skip intermediate ghc version 32 | - '8.0' 33 | include: 34 | - os: ubuntu-latest 35 | ghc: latest 36 | - os: macos-latest 37 | ghc: latest 38 | - os: windows-latest 39 | ghc: latest 40 | 41 | steps: 42 | - uses: actions/checkout@v4 43 | - uses: haskell-actions/setup@v2 44 | id: setup 45 | with: 46 | ghc-version: ${{ matrix.ghc }} 47 | 48 | - name: Restore cache 49 | uses: actions/cache/restore@v4 50 | id: cache 51 | with: 52 | path: ${{ steps.setup.outputs.cabal-store }} 53 | key: ${{ runner.os }}-ghc-${{ steps.setup.outputs.ghc-version }}-cabal-${{ steps.setup.outputs.cabal-version }}-sha-${{ github.sha }} 54 | 55 | - run: cabal build --dependencies-only 56 | - run: cabal build 57 | 58 | - name: Tests (not possible for GHC 9.8 and up) 59 | if: matrix.ghc == '9.6' 60 | run: | 61 | cabal build -c 'QuickCheck -templatehaskell' --enable-tests 62 | cabal test -c 'QuickCheck -templatehaskell' --enable-tests 63 | # Since 9.8, containers depends on template-haskell which depends on pretty. 64 | # This cycle cannot be solved by cabal. 65 | # See https://github.com/haskell/containers/issues/1156 66 | 67 | # Cannot build the benchmarks because they depend on template-haskell 68 | # which depends on pretty. 69 | # - run: cabal build -c 'QuickCheck -templatehaskell' --enable-tests --enable-benchmarks 70 | # - run: cabal bench -c 'QuickCheck -templatehaskell' --enable-tests --enable-benchmarks 71 | 72 | - name: Save cache 73 | uses: actions/cache/save@v4 74 | if: always() 75 | with: 76 | path: ${{ steps.setup.outputs.cabal-store }} 77 | key: ${{ steps.cache.outputs.cache-primary-key }} 78 | -------------------------------------------------------------------------------- /tests/TestGenerators.hs: -------------------------------------------------------------------------------- 1 | -- | Test generators. 2 | -- 3 | module TestGenerators ( 4 | emptyDocGen, 5 | emptyDocListGen 6 | ) where 7 | 8 | import PrettyTestVersion 9 | import TestStructures 10 | 11 | import Control.Monad 12 | 13 | import Test.QuickCheck 14 | 15 | instance Arbitrary CDoc where 16 | arbitrary = sized arbDoc 17 | where 18 | -- TODO: finetune frequencies 19 | arbDoc k | k <= 1 = frequency [ 20 | (1,return CEmpty) 21 | , (2,return (CText . unText) `ap` arbitrary) 22 | ] 23 | arbDoc n = frequency [ 24 | (1, return CList `ap` arbitrary `ap` (liftM unDocList $ resize (pred n) arbitrary)) 25 | ,(1, binaryComb n CBeside) 26 | ,(1, binaryComb n CAbove) 27 | ,(1, choose (0,10) >>= \k -> return (CNest k) `ap` (resize (pred n) arbitrary)) 28 | ] 29 | binaryComb n f = 30 | split2 (n-1) >>= \(n1,n2) -> 31 | return f `ap` arbitrary `ap` (resize n1 arbitrary) `ap` (resize n2 arbitrary) 32 | split2 n = flip liftM ( choose (0,n) ) $ \sz -> (sz, n - sz) 33 | 34 | instance CoArbitrary CDoc where 35 | coarbitrary CEmpty = variant 0 36 | coarbitrary (CText t) = variant 1 . coarbitrary (length t) 37 | coarbitrary (CList f list) = variant 2 . coarbitrary f . coarbitrary list 38 | coarbitrary (CBeside b d1 d2) = variant 3 . coarbitrary b . coarbitrary d1 . coarbitrary d2 39 | coarbitrary (CAbove b d1 d2) = variant 4 . coarbitrary b . coarbitrary d1 . coarbitrary d2 40 | coarbitrary (CNest k d) = variant 5 . coarbitrary k . coarbitrary d 41 | 42 | instance Arbitrary CList where 43 | arbitrary = oneof $ map return [ CCat, CSep, CFCat, CFSep ] 44 | 45 | instance CoArbitrary CList where 46 | coarbitrary cl = variant (case cl of CCat -> 0; CSep -> 1; CFCat -> 2; CFSep -> 3) 47 | 48 | -- we assume that the list itself has no size, so that 49 | -- sizeof (a $$ b) = sizeof (sep [a,b]) = sizeof(a) + sizeof(b)+1 50 | instance Arbitrary CDocList where 51 | arbitrary = liftM CDocList $ sized $ \n -> arbDocList n where 52 | arbDocList 0 = return [] 53 | arbDocList n = do 54 | listSz <- choose (1,n) 55 | let elems = take listSz $ repeat (n `div` listSz) -- approximative 56 | mapM (\sz -> resize sz arbitrary) elems 57 | 58 | instance CoArbitrary CDocList where 59 | coarbitrary (CDocList ds) = coarbitrary ds 60 | 61 | instance Arbitrary Text where 62 | arbitrary = liftM Text $ sized $ \n -> mapM (const arbChar) [1..n] 63 | where arbChar = oneof (map return ['a'..'c']) 64 | 65 | instance CoArbitrary Text where 66 | coarbitrary (Text str) = coarbitrary (length str) 67 | 68 | emptyDocGen :: Gen CDoc 69 | emptyDocGen = return CEmpty 70 | 71 | emptyDocListGen :: Gen CDocList 72 | emptyDocListGen = do 73 | ls <- listOf emptyDocGen 74 | return $ CDocList ls 75 | 76 | -------------------------------------------------------------------------------- /pretty.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.18 2 | name: pretty 3 | version: 1.1.3.6 4 | synopsis: Pretty-printing library 5 | description: 6 | This package contains a pretty-printing library, a set of API's 7 | that provides a way to easily print out text in a consistent 8 | format of your choosing. This is useful for compilers and related 9 | tools. 10 | . 11 | This library was originally designed by John Hughes and has since 12 | been heavily modified by Simon Peyton Jones. 13 | 14 | license: BSD3 15 | license-file: LICENSE 16 | category: Text 17 | maintainer: David Terei 18 | homepage: https://github.com/haskell/pretty 19 | bug-reports: https://github.com/haskell/pretty/issues 20 | stability: Stable 21 | build-type: Simple 22 | 23 | -- extra-doc-files supported since cabal-version 1.18 24 | extra-doc-files: 25 | README.md 26 | CHANGELOG.md 27 | 28 | tested-with: 29 | GHC == 9.12.2 30 | GHC == 9.10.2 31 | GHC == 9.8.4 32 | GHC == 9.6.7 33 | GHC == 9.4.8 34 | GHC == 9.2.8 35 | GHC == 9.0.2 36 | GHC == 8.10.7 37 | GHC == 8.8.4 38 | GHC == 8.6.5 39 | GHC == 8.4.4 40 | GHC == 8.2.2 41 | GHC == 8.0.2 42 | 43 | source-repository head 44 | type: git 45 | location: https://github.com/haskell/pretty.git 46 | 47 | Library 48 | hs-source-dirs: src 49 | exposed-modules: 50 | Text.PrettyPrint 51 | Text.PrettyPrint.HughesPJ 52 | Text.PrettyPrint.HughesPJClass 53 | Text.PrettyPrint.Annotated 54 | Text.PrettyPrint.Annotated.HughesPJ 55 | Text.PrettyPrint.Annotated.HughesPJClass 56 | 57 | build-depends: base >= 4.5 && < 5, 58 | deepseq >= 1.1 59 | if impl(ghc) 60 | build-depends: ghc-prim 61 | 62 | default-language: Haskell98 63 | default-extensions: CPP, BangPatterns, DeriveGeneric 64 | ghc-options: -Wall -fwarn-tabs 65 | 66 | Test-Suite test-pretty 67 | type: exitcode-stdio-1.0 68 | main-is: Test.hs 69 | hs-source-dirs: tests 70 | src 71 | include-dirs: src/Text/PrettyPrint/Annotated 72 | other-modules: 73 | Text.PrettyPrint.Annotated.HughesPJ 74 | Text.PrettyPrint.HughesPJ 75 | PrettyTestVersion 76 | TestGenerators 77 | TestStructures 78 | TestUtils 79 | UnitLargeDoc 80 | UnitPP1 81 | UnitT3911 82 | UnitT32 83 | 84 | build-depends: base >= 4.5 && < 5, 85 | deepseq >= 1.1, 86 | ghc-prim, 87 | QuickCheck >= 2.5 && <3 88 | 89 | default-language: Haskell98 90 | default-extensions: CPP, BangPatterns, DeriveGeneric 91 | ghc-options: -rtsopts -with-rtsopts=-K2M 92 | 93 | benchmark pretty-bench 94 | type: exitcode-stdio-1.0 95 | main-is: Bench.hs 96 | hs-source-dirs: bench 97 | 98 | build-depends: base >= 4.5 && < 5 99 | , criterion 100 | , pretty 101 | 102 | default-language: Haskell98 103 | ghc-options: 104 | -Wall 105 | -fwarn-tabs 106 | -fwarn-incomplete-uni-patterns 107 | -fwarn-incomplete-record-updates 108 | -O2 109 | -threaded 110 | -rtsopts 111 | -with-rtsopts=-N1 112 | -with-rtsopts=-s 113 | -with-rtsopts=-qg 114 | -------------------------------------------------------------------------------- /bench/Bench.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE PackageImports #-} 4 | module Main where 5 | 6 | import Prelude hiding ( (<>) ) 7 | 8 | import Criterion.Main ( bench, bgroup, defaultMain, nf) 9 | import qualified Data.List as List 10 | import Text.PrettyPrint.HughesPJ 11 | 12 | -------------------------------------------------------------------------------- 13 | f_left :: Int -> Doc 14 | f_left n = List.foldl' (<>) empty (map (text . show) [10001..10000+n]) 15 | 16 | -------------------------------------------------------------------------------- 17 | f_right :: Int -> Doc 18 | f_right n = List.foldr (<>) empty (map (text . show) [10001..10000+n]) 19 | 20 | -------------------------------------------------------------------------------- 21 | stuff :: String -> String -> Double -> Rational -> Int -> Int -> Int -> Doc 22 | stuff s1 s2 d1 r1 i1 i2 i3 = 23 | let a = nest i1 $ text s1 24 | b = double d1 25 | c = rational r1 26 | d = replicate i1 (text s2 <> b <> c <+> a) 27 | e = cat d $+$ cat d $$ (c <> b <+> a) 28 | f = parens e <> brackets c <> hcat d 29 | g = lparen <> f <> rparen 30 | h = text $ s2 ++ s1 31 | i = map rational ([1..(toRational i2)]::[Rational]) 32 | j = punctuate comma i 33 | k = nest i3 h <> (nest (i1 + i3) $ sep i) $+$ g <> cat j 34 | l = cat $ punctuate (comma <> b <> comma) $ replicate i3 k 35 | in l 36 | 37 | -------------------------------------------------------------------------------- 38 | doc1 :: Doc 39 | doc1 = stuff "Adsas ads" "dassdab weeaa xxxxx" 123.231321 ((-1)/5) 30 300 20 40 | 41 | -------------------------------------------------------------------------------- 42 | doc2 :: Doc 43 | doc2 = stuff "aDSAS ADS asdasdsa sdsda xx" "SDAB WEEAA" 1333.212 ((-4)/5) 31 301 30 44 | 45 | -------------------------------------------------------------------------------- 46 | doc3 :: Doc 47 | doc3 = stuff "ADsAs --____ aDS" "DasSdAB weEAA" 2533.21299 ((-4)/999) 39 399 60 48 | 49 | -------------------------------------------------------------------------------- 50 | processTxt :: TextDetails -> String -> String 51 | processTxt (Chr c) s = c:s 52 | processTxt (Str s1) s2 = s1 ++ s2 53 | processTxt (PStr s1) s2 = s1 ++ s2 54 | 55 | -------------------------------------------------------------------------------- 56 | main :: IO () 57 | main = defaultMain $ [ 58 | bgroup "<> associativity" [ bench "left" $ nf (length . render . f_left) 10000 59 | , bench "right" $ nf (length . render . f_right) 10000 60 | , bench "left20k" $ nf (length . render . f_left) 20000 61 | , bench "right20k" $ nf (length . render . f_right) 20000 62 | , bench "left30k" $ nf (length . render . f_left) 30000 63 | , bench "right30k" $ nf (length . render . f_right) 30000 64 | ] 65 | 66 | , bgroup "render" [ bench "doc1" $ nf render doc1 67 | , bench "doc2" $ nf render doc2 68 | , bench "doc3" $ nf render doc3 69 | ] 70 | 71 | , bgroup "fullRender" [ bench "PageMode 1000" $ nf (fullRender PageMode 1000 4 processTxt "") doc2 72 | , bench "PageMode 100" $ nf (fullRender PageMode 100 1.5 processTxt "") doc2 73 | , bench "ZigZagMode" $ nf (fullRender ZigZagMode 1000 4 processTxt "") doc2 74 | , bench "LeftMode" $ nf (fullRender LeftMode 1000 4 processTxt "") doc2 75 | , bench "OneLineMode" $ nf (fullRender OneLineMode 1000 4 processTxt "") doc3 76 | ] 77 | ] 78 | -------------------------------------------------------------------------------- /tests/TestStructures.hs: -------------------------------------------------------------------------------- 1 | -- | Datatypes for law QuickChecks 2 | 3 | -- User visible combinators. The tests are performed on pretty printing terms 4 | -- which are constructable using the public combinators. We need to have a 5 | -- datatype for those combinators, otherwise it becomes almost impossible to 6 | -- reconstruct failing tests. 7 | -- 8 | module TestStructures ( 9 | CDoc(..), CList(..), CDocList(..), Text(..), 10 | 11 | buildDoc, liftDoc2, liftDoc3, buildDocList, 12 | text', annotToTd, tdToStr, genericCProp 13 | ) where 14 | 15 | #if __GLASGOW_HASKELL__ >= 803 16 | import Prelude hiding ( (<>) ) 17 | #endif 18 | 19 | import PrettyTestVersion 20 | 21 | data CDoc = CEmpty -- empty 22 | | CText String -- text s 23 | | CList CList [CDoc] -- cat,sep,fcat,fsep ds 24 | | CBeside Bool CDoc CDoc -- a <> b and a <+> b 25 | | CAbove Bool CDoc CDoc -- a $$ b and a $+$ b 26 | | CNest Int CDoc -- nest k d 27 | deriving (Eq, Ord) 28 | 29 | data CList = CCat | CSep | CFCat | CFSep deriving (Eq,Ord) 30 | 31 | newtype CDocList = CDocList { unDocList :: [CDoc] } 32 | 33 | -- wrapper for String argument of `text' 34 | newtype Text = Text { unText :: String } deriving (Eq, Ord, Show) 35 | 36 | instance Show CDoc where 37 | showsPrec k CEmpty = showString "empty" 38 | showsPrec k (CText s) = showParen (k >= 10) (showString " text " . shows s) 39 | showsPrec k (CList sp ds) = showParen (k >= 10) $ (shows sp . showList ds) 40 | showsPrec k (CBeside sep d1 d2) = showParen (k >= 6) $ 41 | (showsPrec 6 d1) . showString (if sep then " <+> " else " <> ") . (showsPrec 6 d2) 42 | showsPrec k (CAbove noOvlap d1 d2) = showParen (k >= 5) $ 43 | (showsPrec 5 d1) . showString (if noOvlap then " $+$ " else " $$ ") . (showsPrec 5 d2) 44 | showsPrec k (CNest n d) = showParen (k >= 10) $ showString " nest " . showsPrec 10 n . showString " ". showsPrec 10 d 45 | 46 | instance Show CList where 47 | show cs = case cs of CCat -> "cat" ; CSep -> "sep" ; CFCat -> "fcat" ; CFSep -> "fsep" 48 | 49 | instance Show CDocList where show = show . unDocList 50 | 51 | buildDoc :: CDoc -> Doc () 52 | buildDoc CEmpty = empty 53 | buildDoc (CText s) = text s 54 | buildDoc (CList sp ds) = (listComb sp) $ map buildDoc ds 55 | buildDoc (CBeside sep d1 d2) = (if sep then (<+>) else (<>)) (buildDoc d1) (buildDoc d2) 56 | buildDoc (CAbove noOvlap d1 d2) = (if noOvlap then ($+$) else ($$)) (buildDoc d1) (buildDoc d2) 57 | buildDoc (CNest k d) = nest k $ buildDoc d 58 | 59 | listComb :: CList -> ([Doc ()] -> Doc ()) 60 | listComb cs = case cs of CCat -> cat ; CSep -> sep ; CFCat -> fcat ; CFSep -> fsep 61 | 62 | liftDoc2 :: (Doc () -> Doc () -> a) -> (CDoc -> CDoc -> a) 63 | liftDoc2 f cd1 cd2 = f (buildDoc cd1) (buildDoc cd2) 64 | 65 | liftDoc3 :: (Doc () -> Doc () -> Doc () -> a) -> (CDoc -> CDoc -> CDoc -> a) 66 | liftDoc3 f cd1 cd2 cd3 = f (buildDoc cd1) (buildDoc cd2) (buildDoc cd3) 67 | 68 | buildDocList :: CDocList -> [Doc ()] 69 | buildDocList = map buildDoc . unDocList 70 | 71 | text' :: Text -> Doc () 72 | text' (Text str) = text str 73 | 74 | annotToTd :: AnnotDetails a -> TextDetails 75 | annotToTd (NoAnnot s _) = s 76 | annotToTd _ = Str "" 77 | 78 | -- convert text details to string 79 | tdToStr :: TextDetails -> String 80 | tdToStr (Chr c) = [c] 81 | tdToStr (Str s) = s 82 | tdToStr (PStr s) = s 83 | 84 | -- synthesize with stop for cdoc 85 | -- constructor order 86 | genericCProp :: (a -> a -> a) -> (CDoc -> (a, Bool)) -> CDoc -> a 87 | genericCProp c q cdoc = 88 | case q cdoc of 89 | (v,False) -> v 90 | (v,True) -> foldl c v subs 91 | where 92 | rec = genericCProp c q 93 | subs = case cdoc of 94 | CEmpty -> [] 95 | CText _ -> [] 96 | CList _ ds -> map rec ds 97 | CBeside _ d1 d2 -> [rec d1, rec d2] 98 | CAbove b d1 d2 -> [rec d1, rec d2] 99 | CNest k d -> [rec d] 100 | 101 | -------------------------------------------------------------------------------- /docs/new-pretty.md: -------------------------------------------------------------------------------- 1 | 1. I want to eliminate the duplicate of this library in 2 | GHC. The underlying TextDetails store types are different 3 | though which is a problem: 4 | 5 | -> Use type classes (see new-pretty branch). 6 | [Duncan not a fan.] 7 | [Make sure performance not lost.] 8 | 9 | -> Use a better underlying storage type. 10 | [Say add bytestring and text to TextDetails.] 11 | 12 | -> Use a fixed underlying storage type like 13 | Builder from Text or Bytestring but allow 14 | input functions to take any type that can be 15 | converted into one. 16 | [ptext :: (a -> Builder) -> a -> Doc 17 | 18 | Also would be useful to provide render functions to produce 19 | Bytestring / Text builders. 20 | 21 | 2. Add monadic wrapper (check out haskell-src-exts for example although maybe 22 | use a transformer monand...) 23 | 24 | =========================================================== 25 | 26 | dcoutts davidt_: are you sure that using a typeclass is faster than TextDetails? 27 | 28 | dcoutts davidt_: why not just add PStr back in? 29 | 30 | dcoutts davidt_: you can already generate different output types by using the fold (TextDetails -> a -> a) 31 | 32 | dcoutts e.g. using the Text builder or the new bytestring builder 33 | 34 | davidt_ dcoutts: So far it seems as fast but I need to do more testing, hence I haven't pushed anything yet 35 | 36 | davidt_ dcoutts: Yes adding PStr back in is one option but I also need to change LItString in GHC then to be backed by a bytestring which is a decent amount of work on a area thats already very boring 37 | 38 | davidt_ dcoutts: as long as speed isn't lost I still feel a type class is better, you can generate different outputs yes but a fixed TextDetails still fixes the storage which isn't as nice as a type class imho 39 | 40 | dcoutts davidt_: the problem with the typeclass is the leakage 41 | 42 | dcoutts that extra type param leaks out into everything 43 | 44 | dcoutts davidt_: and it doesn't mean you have to change LItString to be a ByteString 45 | 46 | dcoutts davidt_: it just means you need a conversion function, it doesn't imply any copying either since it's lazy, it'll do the conversion during the fullRender 47 | 48 | davidt_ yes i guess so, there are a few options here. What is the issue with the leakage though? It sounds bad but how is it practically a bad thing? I quite like the type class design 49 | 50 | dcoutts I think we overuse typeclasses 51 | 52 | dcoutts davidt_: it means your pretty printing function producing a Doc will not be compatible with mine 53 | 54 | dcoutts davidt_: since you'll use GDoc This and I'll use GDoc That... 55 | 56 | dcoutts and in this case it is for variation that isn't really needed 57 | dcoutts it's to cope with the proliferation of string types 58 | dcoutts when we should just not have so many string types 59 | dcoutts davidt_: so how about using TextDetails with constructors for Char, String, Text and ByteString 60 | 61 | davidt_ Hmm I'll look into it I guess. 62 | 63 | davidt_ But I think what I want to do is a pretty simple and 'good' thing to do. I want to abstract pretty from the underlying storage of strings. As far as I can tell type classes is the best way to do this. 64 | 65 | davidt_ but I agree that we have too many string types 66 | 67 | davidt_ so I am tempted by that argument not to encourage it further 68 | 69 | dcoutts davidt_: btw, I expect you can convert a ghc LItString into a ByteString quite easily and cheaply 70 | 71 | dcoutts davidt_: or are they unpinned ByteArr#s? 72 | 73 | davidt_ dcoutts: Yes you probably can. Had a brief discussion about this with Simon Marlow. 74 | 75 | dcoutts davidt_: so there's a couple other options here 76 | 77 | dcoutts davidt_: you can fix the output type and allow any input string type that can be converted into it 78 | 79 | dcoutts davidt_: or you can fix the set of primitive input string types (ie Char, String, etc) and allow any kind of output type that can be constructed from those 80 | 81 | dcoutts davidt_: but allowing both means that the internal type arg has to become visible (which is the bad option imho) 82 | 83 | dcoutts davidt_: e.g. suppose we said that the output type should just always be a Text builder, or perhaps a ByteString builder, then we could allow primitive strings of any type that can be converted to a bytestring builder 84 | 85 | dcoutts ptext :: (a -> Builder) -> a -> doc 86 | 87 | dcoutts davidt_: in practice I bet fullRender is only used for two types: IO to write out to a handle directly, and some builder monoid 88 | 89 | dcoutts and the IO case is only an illusion of performance, the builder monoid will be a lot faster 90 | 91 | dcoutts davidt_: because a builder monoid is writing directly into a buffer too, but unlike an IO handle, there's no MVar locking overhead 92 | 93 | dcoutts davidt_: whichever way you do go, it'd be nice to provide render functions to produce bytestring / text builders, since people will generally not be aware that that's possible via fullRender 94 | 95 | dcoutts davidt_: the next bytestring release will have a fast builder monoid 96 | 97 | dcoutts davidt_: and text has one already 98 | 99 | -------------------------------------------------------------------------------- /src/Text/PrettyPrint/HughesPJClass.hs: -------------------------------------------------------------------------------- 1 | #if __GLASGOW_HASKELL__ >= 701 2 | {-# LANGUAGE Safe #-} 3 | #endif 4 | 5 | ----------------------------------------------------------------------------- 6 | -- | 7 | -- Module : Text.PrettyPrint.HughesPJClass 8 | -- Copyright : (c) Lennart Augustsson 2014 9 | -- License : BSD-style (see the file LICENSE) 10 | -- 11 | -- Maintainer : David Terei 12 | -- Stability : stable 13 | -- Portability : portable 14 | -- 15 | -- Pretty printing class, simlar to 'Show' but nicer looking. 16 | -- 17 | -- Note that the precedence level is a 'Rational' so there is an unlimited 18 | -- number of levels. This module re-exports 'Text.PrettyPrint.HughesPJ'. 19 | -- 20 | ----------------------------------------------------------------------------- 21 | 22 | module Text.PrettyPrint.HughesPJClass ( 23 | -- * Pretty typeclass 24 | Pretty(..), 25 | 26 | PrettyLevel(..), prettyNormal, 27 | prettyShow, prettyParen, 28 | 29 | -- re-export HughesPJ 30 | module Text.PrettyPrint.HughesPJ 31 | ) where 32 | 33 | import Text.PrettyPrint.HughesPJ 34 | 35 | -- | Level of detail in the pretty printed output. Level 0 is the least 36 | -- detail. 37 | newtype PrettyLevel = PrettyLevel Int 38 | deriving (Eq, Ord, Show) 39 | 40 | -- | The "normal" (Level 0) of detail. 41 | prettyNormal :: PrettyLevel 42 | prettyNormal = PrettyLevel 0 43 | 44 | -- | Pretty printing class. The precedence level is used in a similar way as in 45 | -- the 'Show' class. Minimal complete definition is either 'pPrintPrec' or 46 | -- 'pPrint'. 47 | class Pretty a where 48 | pPrintPrec :: PrettyLevel -> Rational -> a -> Doc 49 | pPrintPrec _ _ = pPrint 50 | 51 | pPrint :: a -> Doc 52 | pPrint = pPrintPrec prettyNormal 0 53 | 54 | pPrintList :: PrettyLevel -> [a] -> Doc 55 | pPrintList l = brackets . fsep . punctuate comma . map (pPrintPrec l 0) 56 | 57 | #if __GLASGOW_HASKELL__ >= 708 58 | {-# MINIMAL pPrintPrec | pPrint #-} 59 | #endif 60 | 61 | -- | Pretty print a value with the 'prettyNormal' level. 62 | prettyShow :: (Pretty a) => a -> String 63 | prettyShow = render . pPrint 64 | 65 | pPrint0 :: (Pretty a) => PrettyLevel -> a -> Doc 66 | pPrint0 l = pPrintPrec l 0 67 | 68 | appPrec :: Rational 69 | appPrec = 10 70 | 71 | -- | Parenthesize an value if the boolean is true. 72 | {-# DEPRECATED prettyParen "Please use 'maybeParens' instead" #-} 73 | prettyParen :: Bool -> Doc -> Doc 74 | prettyParen = maybeParens 75 | 76 | -- Various Pretty instances 77 | instance Pretty Int where pPrint = int 78 | 79 | instance Pretty Integer where pPrint = integer 80 | 81 | instance Pretty Float where pPrint = float 82 | 83 | instance Pretty Double where pPrint = double 84 | 85 | instance Pretty () where pPrint _ = text "()" 86 | 87 | instance Pretty Bool where pPrint = text . show 88 | 89 | instance Pretty Ordering where pPrint = text . show 90 | 91 | instance Pretty Char where 92 | pPrint = char 93 | pPrintList _ = text . show 94 | 95 | instance (Pretty a) => Pretty (Maybe a) where 96 | pPrintPrec _ _ Nothing = text "Nothing" 97 | pPrintPrec l p (Just x) = 98 | prettyParen (p > appPrec) $ text "Just" <+> pPrintPrec l (appPrec+1) x 99 | 100 | instance (Pretty a, Pretty b) => Pretty (Either a b) where 101 | pPrintPrec l p (Left x) = 102 | prettyParen (p > appPrec) $ text "Left" <+> pPrintPrec l (appPrec+1) x 103 | pPrintPrec l p (Right x) = 104 | prettyParen (p > appPrec) $ text "Right" <+> pPrintPrec l (appPrec+1) x 105 | 106 | instance (Pretty a) => Pretty [a] where 107 | pPrintPrec l _ = pPrintList l 108 | 109 | instance (Pretty a, Pretty b) => Pretty (a, b) where 110 | pPrintPrec l _ (a, b) = 111 | parens $ fsep $ punctuate comma [pPrint0 l a, pPrint0 l b] 112 | 113 | instance (Pretty a, Pretty b, Pretty c) => Pretty (a, b, c) where 114 | pPrintPrec l _ (a, b, c) = 115 | parens $ fsep $ punctuate comma [pPrint0 l a, pPrint0 l b, pPrint0 l c] 116 | 117 | instance (Pretty a, Pretty b, Pretty c, Pretty d) => Pretty (a, b, c, d) where 118 | pPrintPrec l _ (a, b, c, d) = 119 | parens $ fsep $ punctuate comma 120 | [pPrint0 l a, pPrint0 l b, pPrint0 l c, pPrint0 l d] 121 | 122 | instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e) => Pretty (a, b, c, d, e) where 123 | pPrintPrec l _ (a, b, c, d, e) = 124 | parens $ fsep $ punctuate comma 125 | [pPrint0 l a, pPrint0 l b, pPrint0 l c, pPrint0 l d, pPrint0 l e] 126 | 127 | instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e, Pretty f) => Pretty (a, b, c, d, e, f) where 128 | pPrintPrec l _ (a, b, c, d, e, f) = 129 | parens $ fsep $ punctuate comma 130 | [pPrint0 l a, pPrint0 l b, pPrint0 l c, 131 | pPrint0 l d, pPrint0 l e, pPrint0 l f] 132 | 133 | instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e, Pretty f, Pretty g) => 134 | Pretty (a, b, c, d, e, f, g) where 135 | pPrintPrec l _ (a, b, c, d, e, f, g) = 136 | parens $ fsep $ punctuate comma 137 | [pPrint0 l a, pPrint0 l b, pPrint0 l c, 138 | pPrint0 l d, pPrint0 l e, pPrint0 l f, pPrint0 l g] 139 | 140 | instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e, Pretty f, Pretty g, Pretty h) => 141 | Pretty (a, b, c, d, e, f, g, h) where 142 | pPrintPrec l _ (a, b, c, d, e, f, g, h) = 143 | parens $ fsep $ punctuate comma 144 | [pPrint0 l a, pPrint0 l b, pPrint0 l c, 145 | pPrint0 l d, pPrint0 l e, pPrint0 l f, pPrint0 l g, pPrint0 l h] 146 | 147 | -------------------------------------------------------------------------------- /src/Text/PrettyPrint/Annotated/HughesPJClass.hs: -------------------------------------------------------------------------------- 1 | #if __GLASGOW_HASKELL__ >= 701 2 | {-# LANGUAGE Safe #-} 3 | #endif 4 | 5 | ----------------------------------------------------------------------------- 6 | -- | 7 | -- Module : Text.PrettyPrint.Annotated.HughesPJClass 8 | -- Copyright : (c) Trevor Elliott 2015 9 | -- License : BSD-style (see the file LICENSE) 10 | -- 11 | -- Maintainer : David Terei 12 | -- Stability : stable 13 | -- Portability : portable 14 | -- 15 | -- Pretty printing class, simlar to 'Show' but nicer looking. 16 | -- 17 | -- Note that the precedence level is a 'Rational' so there is an unlimited 18 | -- number of levels. This module re-exports 19 | -- 'Text.PrettyPrint.Annotated.HughesPJ'. 20 | -- 21 | ----------------------------------------------------------------------------- 22 | 23 | module Text.PrettyPrint.Annotated.HughesPJClass ( 24 | -- * Pretty typeclass 25 | Pretty(..), 26 | 27 | PrettyLevel(..), prettyNormal, 28 | prettyShow, prettyParen, 29 | 30 | -- re-export HughesPJ 31 | module Text.PrettyPrint.Annotated.HughesPJ 32 | ) where 33 | 34 | import Text.PrettyPrint.Annotated.HughesPJ 35 | 36 | -- | Level of detail in the pretty printed output. Level 0 is the least 37 | -- detail. 38 | newtype PrettyLevel = PrettyLevel Int 39 | deriving (Eq, Ord, Show) 40 | 41 | -- | The "normal" (Level 0) of detail. 42 | prettyNormal :: PrettyLevel 43 | prettyNormal = PrettyLevel 0 44 | 45 | -- | Pretty printing class. The precedence level is used in a similar way as in 46 | -- the 'Show' class. Minimal complete definition is either 'pPrintPrec' or 47 | -- 'pPrint'. 48 | class Pretty a where 49 | pPrintPrec :: PrettyLevel -> Rational -> a -> Doc ann 50 | pPrintPrec _ _ = pPrint 51 | 52 | pPrint :: a -> Doc ann 53 | pPrint = pPrintPrec prettyNormal 0 54 | 55 | pPrintList :: PrettyLevel -> [a] -> Doc ann 56 | pPrintList l = brackets . fsep . punctuate comma . map (pPrintPrec l 0) 57 | 58 | #if __GLASGOW_HASKELL__ >= 708 59 | {-# MINIMAL pPrintPrec | pPrint #-} 60 | #endif 61 | 62 | -- | Pretty print a value with the 'prettyNormal' level. 63 | prettyShow :: (Pretty a) => a -> String 64 | prettyShow = render . pPrint 65 | 66 | pPrint0 :: (Pretty a) => PrettyLevel -> a -> Doc ann 67 | pPrint0 l = pPrintPrec l 0 68 | 69 | appPrec :: Rational 70 | appPrec = 10 71 | 72 | -- | Parenthesize an value if the boolean is true. 73 | {-# DEPRECATED prettyParen "Please use 'maybeParens' instead" #-} 74 | prettyParen :: Bool -> Doc ann -> Doc ann 75 | prettyParen = maybeParens 76 | 77 | -- Various Pretty instances 78 | instance Pretty Int where pPrint = int 79 | 80 | instance Pretty Integer where pPrint = integer 81 | 82 | instance Pretty Float where pPrint = float 83 | 84 | instance Pretty Double where pPrint = double 85 | 86 | instance Pretty () where pPrint _ = text "()" 87 | 88 | instance Pretty Bool where pPrint = text . show 89 | 90 | instance Pretty Ordering where pPrint = text . show 91 | 92 | instance Pretty Char where 93 | pPrint = char 94 | pPrintList _ = text . show 95 | 96 | instance (Pretty a) => Pretty (Maybe a) where 97 | pPrintPrec _ _ Nothing = text "Nothing" 98 | pPrintPrec l p (Just x) = 99 | prettyParen (p > appPrec) $ text "Just" <+> pPrintPrec l (appPrec+1) x 100 | 101 | instance (Pretty a, Pretty b) => Pretty (Either a b) where 102 | pPrintPrec l p (Left x) = 103 | prettyParen (p > appPrec) $ text "Left" <+> pPrintPrec l (appPrec+1) x 104 | pPrintPrec l p (Right x) = 105 | prettyParen (p > appPrec) $ text "Right" <+> pPrintPrec l (appPrec+1) x 106 | 107 | instance (Pretty a) => Pretty [a] where 108 | pPrintPrec l _ = pPrintList l 109 | 110 | instance (Pretty a, Pretty b) => Pretty (a, b) where 111 | pPrintPrec l _ (a, b) = 112 | parens $ fsep $ punctuate comma [pPrint0 l a, pPrint0 l b] 113 | 114 | instance (Pretty a, Pretty b, Pretty c) => Pretty (a, b, c) where 115 | pPrintPrec l _ (a, b, c) = 116 | parens $ fsep $ punctuate comma [pPrint0 l a, pPrint0 l b, pPrint0 l c] 117 | 118 | instance (Pretty a, Pretty b, Pretty c, Pretty d) => Pretty (a, b, c, d) where 119 | pPrintPrec l _ (a, b, c, d) = 120 | parens $ fsep $ punctuate comma 121 | [pPrint0 l a, pPrint0 l b, pPrint0 l c, pPrint0 l d] 122 | 123 | instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e) => Pretty (a, b, c, d, e) where 124 | pPrintPrec l _ (a, b, c, d, e) = 125 | parens $ fsep $ punctuate comma 126 | [pPrint0 l a, pPrint0 l b, pPrint0 l c, pPrint0 l d, pPrint0 l e] 127 | 128 | instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e, Pretty f) => Pretty (a, b, c, d, e, f) where 129 | pPrintPrec l _ (a, b, c, d, e, f) = 130 | parens $ fsep $ punctuate comma 131 | [pPrint0 l a, pPrint0 l b, pPrint0 l c, 132 | pPrint0 l d, pPrint0 l e, pPrint0 l f] 133 | 134 | instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e, Pretty f, Pretty g) => 135 | Pretty (a, b, c, d, e, f, g) where 136 | pPrintPrec l _ (a, b, c, d, e, f, g) = 137 | parens $ fsep $ punctuate comma 138 | [pPrint0 l a, pPrint0 l b, pPrint0 l c, 139 | pPrint0 l d, pPrint0 l e, pPrint0 l f, pPrint0 l g] 140 | 141 | instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e, Pretty f, Pretty g, Pretty h) => 142 | Pretty (a, b, c, d, e, f, g, h) where 143 | pPrintPrec l _ (a, b, c, d, e, f, g, h) = 144 | parens $ fsep $ punctuate comma 145 | [pPrint0 l a, pPrint0 l b, pPrint0 l c, 146 | pPrint0 l d, pPrint0 l e, pPrint0 l f, pPrint0 l g, pPrint0 l h] 147 | 148 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Pretty library change log 2 | 3 | ## 1.1.3.6 -- 30th January, 2018 4 | 5 | * Fix compatability with GHC-8.4/base-4.11 (by Herbert Valerio Riedel). 6 | * Add in benchmarking framework (by Alfredo Di Napoli). 7 | 8 | ## 1.1.3.5 -- 1st February, 2017 9 | 10 | * Fix documentation formatting bug (by Ivan Lazar Miljenovic) 11 | * Fix missing git tag on Github for v1.1.3.4 release. 12 | 13 | ## 1.1.3.4 -- 3rd June, 2016 14 | 15 | * Fix over-zeleaous use of strictness causing stack allocation, fixes part of 16 | issue #32 (by Neil Mitchell). 17 | 18 | ## 1.1.3.3 -- 29th February, 2016 19 | 20 | * Improve documentation. 21 | 22 | ## 1.1.3.2 -- 19th March, 2015 23 | 24 | * Fix bug with haddock documentation. 25 | * Clean up module intro documentation. 26 | 27 | ## 1.1.3.1 -- 11th March, 2015 28 | 29 | * Add support for annotations in pretty (by Trevor Elliott). 30 | 31 | ## 1.1.2.1 -- 25th December, 2014 32 | 33 | * Fix overly-strict issue preventing use of pretty for very large 34 | docs (by Eyal Lotem). 35 | 36 | ## 1.1.2.0 -- 25th December, 2014 37 | 38 | * Merge in prettyclass package -- new Text.PrettyPrint.HughesPHClass. 39 | * Add in 'maybe\*' variants of various bracket functins. 40 | * Add Generic instances for appropriate data types. 41 | * Fix compilation under GHC 7.10 42 | 43 | ## 1.1.1.3 -- 21st December, 2014 44 | 45 | * Remove upper bound on `deepseq` package to fix build issues with 46 | latest GHC. 47 | 48 | ## 1.1.1.2 -- 18th August, 2014 49 | 50 | * Add NFData and Eq instances (by Ivan Lazar Miljenovic). 51 | 52 | ## 1.1.1.1 -- 27th October, 2013 53 | 54 | * Update pretty cabal file and readme. 55 | * Fix tests to work with latest quickcheck. 56 | 57 | ## Version 3.0, 28 May 1987 58 | 59 | * Cured massive performance bug. If you write: 60 | 61 | foldl <> empty (map (text.show) [1..10000]) 62 | 63 | You get quadratic behaviour with V2.0. Why? For just the same 64 | reason as you get quadratic behaviour with left-associated (++) 65 | chains. 66 | 67 | This is really bad news. One thing a pretty-printer abstraction 68 | should certainly guarantee is insensitivity to associativity. It 69 | matters: suddenly GHC's compilation times went up by a factor of 70 | 100 when I switched to the new pretty printer. 71 | 72 | I fixed it with a bit of a hack (because I wanted to get GHC back 73 | on the road). I added two new constructors to the Doc type, Above 74 | and Beside: 75 | 76 | <> = Beside 77 | $$ = Above 78 | 79 | Then, where I need to get to a "TextBeside" or "NilAbove" form I 80 | "force" the Doc to squeeze out these suspended calls to Beside and 81 | Above; but in so doing I re-associate. It's quite simple, but I'm 82 | not satisfied that I've done the best possible job. I'll send you 83 | the code if you are interested. 84 | 85 | * Added new exports: 86 | punctuate, hang 87 | int, integer, float, double, rational, 88 | lparen, rparen, lbrack, rbrack, lbrace, rbrace, 89 | 90 | * fullRender's type signature has changed. Rather than producing a 91 | string it now takes an extra couple of arguments that tells it how 92 | to glue fragments of output together: 93 | 94 | fullRender :: Mode 95 | -> Int -- Line length 96 | -> Float -- Ribbons per line 97 | -> (TextDetails -> a -> a) -- What to do with text 98 | -> a -- What to do at the end 99 | -> Doc 100 | -> a -- Result 101 | 102 | The "fragments" are encapsulated in the TextDetails data type: 103 | 104 | data TextDetails = Chr Char 105 | | Str String 106 | | PStr FAST_STRING 107 | 108 | The Chr and Str constructors are obvious enough. The PStr 109 | constructor has a packed string (FAST_STRING) inside it. It's 110 | generated by using the new "ptext" export. 111 | 112 | An advantage of this new setup is that you can get the renderer to 113 | do output directly (by passing in a function of type (TextDetails 114 | -> IO () -> IO ()), rather than producing a string that you then 115 | print. 116 | 117 | ## Version 3.0, 28 May 1987 118 | 119 | * Made empty into a left unit for <> as well as a right unit; 120 | it is also now true that 121 | nest k empty = empty 122 | which wasn't true before. 123 | 124 | * Fixed an obscure bug in sep that occasionally gave very weird behaviour 125 | 126 | * Added $+$ 127 | 128 | * Corrected and tidied up the laws and invariants 129 | 130 | ## Version 1.0 131 | 132 | Relative to John's original paper, there are the following new features: 133 | 134 | 1. There's an empty document, "empty". It's a left and right unit for 135 | both <> and $$, and anywhere in the argument list for 136 | sep, hcat, hsep, vcat, fcat etc. 137 | 138 | It is Really Useful in practice. 139 | 140 | 2. There is a paragraph-fill combinator, fsep, that's much like sep, 141 | only it keeps fitting things on one line until it can't fit any more. 142 | 143 | 3. Some random useful extra combinators are provided. 144 | <+> puts its arguments beside each other with a space between them, 145 | unless either argument is empty in which case it returns the other 146 | 147 | 148 | hcat is a list version of <> 149 | hsep is a list version of <+> 150 | vcat is a list version of $$ 151 | 152 | sep (separate) is either like hsep or like vcat, depending on what fits 153 | 154 | cat behaves like sep, but it uses <> for horizontal composition 155 | fcat behaves like fsep, but it uses <> for horizontal composition 156 | 157 | These new ones do the obvious things: 158 | char, semi, comma, colon, space, 159 | parens, brackets, braces, 160 | quotes, doubleQuotes 161 | 162 | 4. The "above" combinator, $$, now overlaps its two arguments if the 163 | last line of the top argument stops before the first line of the 164 | second begins. 165 | 166 | For example: text "hi" $$ nest 5 (text "there") 167 | lays out as 168 | hi there 169 | rather than 170 | hi 171 | there 172 | 173 | There are two places this is really useful 174 | 175 | a) When making labelled blocks, like this: 176 | Left -> code for left 177 | Right -> code for right 178 | LongLongLongLabel -> 179 | code for longlonglonglabel 180 | The block is on the same line as the label if the label is 181 | short, but on the next line otherwise. 182 | 183 | b) When laying out lists like this: 184 | [ first 185 | , second 186 | , third 187 | ] 188 | which some people like. But if the list fits on one line you 189 | want [first, second, third]. You can't do this with John's 190 | original combinators, but it's quite easy with the new $$. 191 | 192 | The combinator $+$ gives the original "never-overlap" behaviour. 193 | 194 | 5. Several different renderers are provided: 195 | * a standard one 196 | * one that uses cut-marks to avoid deeply-nested documents 197 | simply piling up in the right-hand margin 198 | * one that ignores indentation (fewer chars output; good for machines) 199 | * one that ignores indentation and newlines (ditto, only more so) 200 | 201 | 6. Numerous implementation tidy-ups 202 | Use of unboxed data types to speed up the implementation 203 | 204 | -------------------------------------------------------------------------------- /.github/workflows/haskell-ci.yml: -------------------------------------------------------------------------------- 1 | # This GitHub workflow config has been generated by a script via 2 | # 3 | # haskell-ci 'github' 'cabal.project' 4 | # 5 | # To regenerate the script (for example after adjusting tested-with) run 6 | # 7 | # haskell-ci regenerate 8 | # 9 | # For more information, see https://github.com/haskell-CI/haskell-ci 10 | # 11 | # version: 0.19.20250506 12 | # 13 | # REGENDATA ("0.19.20250506",["github","cabal.project"]) 14 | # 15 | name: Haskell-CI 16 | on: 17 | push: 18 | branches: 19 | - master 20 | pull_request: 21 | branches: 22 | - master 23 | jobs: 24 | linux: 25 | name: Haskell-CI - Linux - ${{ matrix.compiler }} 26 | runs-on: ubuntu-24.04 27 | timeout-minutes: 28 | 60 29 | container: 30 | image: buildpack-deps:jammy 31 | continue-on-error: ${{ matrix.allow-failure }} 32 | strategy: 33 | matrix: 34 | include: 35 | - compiler: ghc-9.12.2 36 | compilerKind: ghc 37 | compilerVersion: 9.12.2 38 | setup-method: ghcup 39 | allow-failure: false 40 | - compiler: ghc-9.10.2 41 | compilerKind: ghc 42 | compilerVersion: 9.10.2 43 | setup-method: ghcup 44 | allow-failure: false 45 | - compiler: ghc-9.8.4 46 | compilerKind: ghc 47 | compilerVersion: 9.8.4 48 | setup-method: ghcup 49 | allow-failure: false 50 | - compiler: ghc-9.6.7 51 | compilerKind: ghc 52 | compilerVersion: 9.6.7 53 | setup-method: ghcup 54 | allow-failure: false 55 | - compiler: ghc-9.4.8 56 | compilerKind: ghc 57 | compilerVersion: 9.4.8 58 | setup-method: ghcup 59 | allow-failure: false 60 | - compiler: ghc-9.2.8 61 | compilerKind: ghc 62 | compilerVersion: 9.2.8 63 | setup-method: ghcup 64 | allow-failure: false 65 | - compiler: ghc-9.0.2 66 | compilerKind: ghc 67 | compilerVersion: 9.0.2 68 | setup-method: ghcup 69 | allow-failure: false 70 | - compiler: ghc-8.10.7 71 | compilerKind: ghc 72 | compilerVersion: 8.10.7 73 | setup-method: ghcup 74 | allow-failure: false 75 | - compiler: ghc-8.8.4 76 | compilerKind: ghc 77 | compilerVersion: 8.8.4 78 | setup-method: ghcup 79 | allow-failure: false 80 | - compiler: ghc-8.6.5 81 | compilerKind: ghc 82 | compilerVersion: 8.6.5 83 | setup-method: ghcup 84 | allow-failure: false 85 | - compiler: ghc-8.4.4 86 | compilerKind: ghc 87 | compilerVersion: 8.4.4 88 | setup-method: ghcup 89 | allow-failure: false 90 | - compiler: ghc-8.2.2 91 | compilerKind: ghc 92 | compilerVersion: 8.2.2 93 | setup-method: ghcup 94 | allow-failure: false 95 | - compiler: ghc-8.0.2 96 | compilerKind: ghc 97 | compilerVersion: 8.0.2 98 | setup-method: ghcup 99 | allow-failure: false 100 | fail-fast: false 101 | steps: 102 | - name: apt-get install 103 | run: | 104 | apt-get update 105 | apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 libnuma-dev 106 | - name: Install GHCup 107 | run: | 108 | mkdir -p "$HOME/.ghcup/bin" 109 | curl -sL https://downloads.haskell.org/ghcup/0.1.50.1/x86_64-linux-ghcup-0.1.50.1 > "$HOME/.ghcup/bin/ghcup" 110 | chmod a+x "$HOME/.ghcup/bin/ghcup" 111 | - name: Install cabal-install 112 | run: | 113 | "$HOME/.ghcup/bin/ghcup" install cabal 3.14.2.0 || (cat "$HOME"/.ghcup/logs/*.* && false) 114 | echo "CABAL=$HOME/.ghcup/bin/cabal-3.14.2.0 -vnormal+nowrap" >> "$GITHUB_ENV" 115 | - name: Install GHC (GHCup) 116 | if: matrix.setup-method == 'ghcup' 117 | run: | 118 | "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) 119 | HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") 120 | HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') 121 | HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') 122 | echo "HC=$HC" >> "$GITHUB_ENV" 123 | echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" 124 | echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" 125 | env: 126 | HCKIND: ${{ matrix.compilerKind }} 127 | HCNAME: ${{ matrix.compiler }} 128 | HCVER: ${{ matrix.compilerVersion }} 129 | - name: Set PATH and environment variables 130 | run: | 131 | echo "$HOME/.cabal/bin" >> $GITHUB_PATH 132 | echo "LANG=C.UTF-8" >> "$GITHUB_ENV" 133 | echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" 134 | echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" 135 | HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') 136 | echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" 137 | if [ $((HCNUMVER >= 90000 && HCNUMVER < 90400)) -ne 0 ] ; then echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" ; else echo "ARG_TESTS=--disable-tests" >> "$GITHUB_ENV" ; fi 138 | echo "ARG_BENCH=--disable-benchmarks" >> "$GITHUB_ENV" 139 | echo "HEADHACKAGE=false" >> "$GITHUB_ENV" 140 | echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" 141 | env: 142 | HCKIND: ${{ matrix.compilerKind }} 143 | HCNAME: ${{ matrix.compiler }} 144 | HCVER: ${{ matrix.compilerVersion }} 145 | - name: env 146 | run: | 147 | env 148 | - name: write cabal config 149 | run: | 150 | mkdir -p $CABAL_DIR 151 | cat >> $CABAL_CONFIG <> $CABAL_CONFIG < cabal-plan.xz 184 | echo 'f62ccb2971567a5f638f2005ad3173dba14693a45154c1508645c52289714cb2 cabal-plan.xz' | sha256sum -c - 185 | xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan 186 | rm -f cabal-plan.xz 187 | chmod a+x $HOME/.cabal/bin/cabal-plan 188 | cabal-plan --version 189 | - name: checkout 190 | uses: actions/checkout@v4 191 | with: 192 | path: source 193 | - name: initial cabal.project for sdist 194 | run: | 195 | touch cabal.project 196 | echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project 197 | cat cabal.project 198 | - name: sdist 199 | run: | 200 | mkdir -p sdist 201 | $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist 202 | - name: unpack 203 | run: | 204 | mkdir -p unpacked 205 | find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \; 206 | - name: generate cabal.project 207 | run: | 208 | PKGDIR_pretty="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/pretty-[0-9.]*')" 209 | echo "PKGDIR_pretty=${PKGDIR_pretty}" >> "$GITHUB_ENV" 210 | rm -f cabal.project cabal.project.local 211 | touch cabal.project 212 | touch cabal.project.local 213 | echo "packages: ${PKGDIR_pretty}" >> cabal.project 214 | if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo "package pretty" >> cabal.project ; fi 215 | if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo " ghc-options: -Werror=missing-methods" >> cabal.project ; fi 216 | cat >> cabal.project <> cabal.project.local 220 | cat cabal.project 221 | cat cabal.project.local 222 | - name: dump install plan 223 | run: | 224 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all 225 | cabal-plan 226 | - name: restore cache 227 | uses: actions/cache/restore@v4 228 | with: 229 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 230 | path: ~/.cabal/store 231 | restore-keys: ${{ runner.os }}-${{ matrix.compiler }}- 232 | - name: install dependencies 233 | run: | 234 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all 235 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all 236 | - name: build w/o tests 237 | run: | 238 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 239 | - name: build 240 | run: | 241 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always 242 | - name: tests 243 | run: | 244 | if [ $((HCNUMVER >= 90000 && HCNUMVER < 90400)) -ne 0 ] ; then $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct ; fi 245 | - name: cabal check 246 | run: | 247 | cd ${PKGDIR_pretty} || false 248 | ${CABAL} -vnormal check 249 | - name: haddock 250 | run: | 251 | $CABAL v2-haddock --disable-documentation --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all 252 | - name: unconstrained build 253 | run: | 254 | rm -f cabal.project.local 255 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 256 | - name: save cache 257 | if: always() 258 | uses: actions/cache/save@v4 259 | with: 260 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 261 | path: ~/.cabal/store 262 | -------------------------------------------------------------------------------- /src/Text/PrettyPrint/HughesPJ.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK not-home #-} 2 | #if __GLASGOW_HASKELL__ >= 701 3 | {-# LANGUAGE Safe #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | #endif 6 | 7 | ----------------------------------------------------------------------------- 8 | -- | 9 | -- Module : Text.PrettyPrint.HughesPJ 10 | -- Copyright : (c) The University of Glasgow 2001 11 | -- License : BSD-style (see the file LICENSE) 12 | -- 13 | -- Maintainer : David Terei 14 | -- Stability : stable 15 | -- Portability : portable 16 | -- 17 | -- Provides a collection of pretty printer combinators, a set of API's that 18 | -- provides a way to easily print out text in a consistent format of your 19 | -- choosing. 20 | -- 21 | -- Originally designed by John Hughes's and Simon Peyton Jones's. 22 | -- 23 | -- For more information you can refer to the 24 | -- that 25 | -- serves as the basis for this libraries design: /The Design of a 26 | -- Pretty-printing Library/ by John Hughes, in Advanced Functional Programming, 27 | -- 1995. 28 | -- 29 | ----------------------------------------------------------------------------- 30 | 31 | #ifndef TESTING 32 | module Text.PrettyPrint.HughesPJ ( 33 | 34 | -- * The document type 35 | Doc, TextDetails(..), 36 | 37 | -- ** Converting to an annotated Doc 38 | docToUnitDoc, 39 | 40 | -- * Constructing documents 41 | 42 | -- ** Converting values into documents 43 | char, text, ptext, sizedText, zeroWidthText, 44 | int, integer, float, double, rational, 45 | 46 | -- ** Simple derived documents 47 | semi, comma, colon, space, equals, 48 | lparen, rparen, lbrack, rbrack, lbrace, rbrace, 49 | 50 | -- ** Wrapping documents in delimiters 51 | parens, brackets, braces, quotes, doubleQuotes, 52 | maybeParens, maybeBrackets, maybeBraces, maybeQuotes, maybeDoubleQuotes, 53 | 54 | -- ** Combining documents 55 | empty, 56 | (<>), (<+>), hcat, hsep, 57 | ($$), ($+$), vcat, 58 | sep, cat, 59 | fsep, fcat, 60 | nest, 61 | hang, punctuate, 62 | 63 | -- * Predicates on documents 64 | isEmpty, 65 | 66 | -- * Utility functions for documents 67 | first, reduceDoc, 68 | 69 | -- * Rendering documents 70 | 71 | -- ** Default rendering 72 | render, 73 | 74 | -- ** Rendering with a particular style 75 | Style(..), 76 | style, 77 | renderStyle, 78 | Mode(..), 79 | 80 | -- ** General rendering 81 | fullRender 82 | 83 | ) where 84 | #endif 85 | 86 | import Text.PrettyPrint.Annotated.HughesPJ 87 | ( TextDetails(..), Mode(..), Style(..), style ) 88 | import qualified Text.PrettyPrint.Annotated.HughesPJ as Ann 89 | 90 | import Control.DeepSeq ( NFData(rnf) ) 91 | import Data.Function ( on ) 92 | #if __GLASGOW_HASKELL__ >= 803 93 | import Prelude hiding ( (<>) ) 94 | #endif 95 | #if __GLASGOW_HASKELL__ >= 800 || __MHS__ 96 | import qualified Data.Semigroup as Semi ( Semigroup((<>)) ) 97 | #elif __GLASGOW_HASKELL__ < 709 98 | import Data.Monoid ( Monoid(mempty, mappend) ) 99 | #endif 100 | import Data.String ( IsString(fromString) ) 101 | 102 | import GHC.Generics 103 | 104 | 105 | -- --------------------------------------------------------------------------- 106 | -- Operator fixity 107 | 108 | infixl 6 <> 109 | infixl 6 <+> 110 | infixl 5 $$, $+$ 111 | 112 | -- --------------------------------------------------------------------------- 113 | -- The Doc data type 114 | 115 | -- | The abstract type of documents. A Doc represents a /set/ of layouts. A 116 | -- Doc with no occurrences of Union or NoDoc represents just one layout. 117 | newtype Doc = Doc (Ann.Doc ()) 118 | #if __GLASGOW_HASKELL__ >= 701 119 | deriving (Generic) 120 | #endif 121 | 122 | liftList :: ([Ann.Doc ()] -> Ann.Doc ()) -> ([Doc] -> Doc) 123 | liftList f ds = Doc (f [ d | Doc d <- ds ]) 124 | {-# INLINE liftList #-} 125 | 126 | liftBinary :: (Ann.Doc () -> Ann.Doc () -> Ann.Doc ()) 127 | -> ( Doc -> Doc -> Doc ) 128 | liftBinary f (Doc a) (Doc b) = Doc (f a b) 129 | {-# INLINE liftBinary #-} 130 | 131 | -- | RDoc is a "reduced GDoc", guaranteed not to have a top-level Above or 132 | -- Beside. 133 | type RDoc = Doc 134 | 135 | -- Combining @Doc@ values 136 | #if __GLASGOW_HASKELL__ >= 800 || __MHS__ 137 | instance Semi.Semigroup Doc where 138 | (<>) = (Text.PrettyPrint.HughesPJ.<>) 139 | 140 | instance Monoid Doc where 141 | mempty = empty 142 | mappend = (Semi.<>) 143 | #else 144 | instance Monoid Doc where 145 | mempty = empty 146 | mappend = (<>) 147 | #endif 148 | 149 | instance IsString Doc where 150 | fromString = text 151 | 152 | instance Show Doc where 153 | showsPrec _ doc cont = fullRender (mode style) (lineLength style) 154 | (ribbonsPerLine style) 155 | txtPrinter cont doc 156 | 157 | instance Eq Doc where 158 | (==) = (==) `on` render 159 | 160 | instance NFData Doc where 161 | rnf (Doc a) = rnf a 162 | 163 | -- --------------------------------------------------------------------------- 164 | -- Values and Predicates on GDocs and TextDetails 165 | 166 | -- | A document of height and width 1, containing a literal character. 167 | char :: Char -> Doc 168 | char c = Doc (Ann.char c) 169 | {-# INLINE char #-} 170 | 171 | -- | A document of height 1 containing a literal string. 172 | -- 'text' satisfies the following laws: 173 | -- 174 | -- * @'text' s '<>' 'text' t = 'text' (s'++'t)@ 175 | -- 176 | -- * @'text' \"\" '<>' x = x@, if @x@ non-empty 177 | -- 178 | -- The side condition on the last law is necessary because @'text' \"\"@ 179 | -- has height 1, while 'empty' has no height. 180 | text :: String -> Doc 181 | text s = Doc (Ann.text s) 182 | {-# INLINE text #-} 183 | 184 | -- | Same as @text@. Used to be used for Bytestrings. 185 | ptext :: String -> Doc 186 | ptext s = Doc (Ann.ptext s) 187 | {-# INLINE ptext #-} 188 | 189 | -- | Some text with any width. (@text s = sizedText (length s) s@) 190 | sizedText :: Int -> String -> Doc 191 | sizedText l s = Doc (Ann.sizedText l s) 192 | 193 | -- | Some text, but without any width. Use for non-printing text 194 | -- such as a HTML or Latex tags 195 | zeroWidthText :: String -> Doc 196 | zeroWidthText = sizedText 0 197 | 198 | -- | The empty document, with no height and no width. 199 | -- 'empty' is the identity for '<>', '<+>', '$$' and '$+$', and anywhere 200 | -- in the argument list for 'sep', 'hcat', 'hsep', 'vcat', 'fcat' etc. 201 | empty :: Doc 202 | empty = Doc Ann.empty 203 | 204 | -- | Returns 'True' if the document is empty 205 | isEmpty :: Doc -> Bool 206 | isEmpty (Doc d) = Ann.isEmpty d 207 | 208 | semi :: Doc -- ^ A ';' character 209 | comma :: Doc -- ^ A ',' character 210 | colon :: Doc -- ^ A ':' character 211 | space :: Doc -- ^ A space character 212 | equals :: Doc -- ^ A '=' character 213 | lparen :: Doc -- ^ A '(' character 214 | rparen :: Doc -- ^ A ')' character 215 | lbrack :: Doc -- ^ A '[' character 216 | rbrack :: Doc -- ^ A ']' character 217 | lbrace :: Doc -- ^ A '{' character 218 | rbrace :: Doc -- ^ A '}' character 219 | semi = char ';' 220 | comma = char ',' 221 | colon = char ':' 222 | space = char ' ' 223 | equals = char '=' 224 | lparen = char '(' 225 | rparen = char ')' 226 | lbrack = char '[' 227 | rbrack = char ']' 228 | lbrace = char '{' 229 | rbrace = char '}' 230 | 231 | int :: Int -> Doc -- ^ @int n = text (show n)@ 232 | integer :: Integer -> Doc -- ^ @integer n = text (show n)@ 233 | float :: Float -> Doc -- ^ @float n = text (show n)@ 234 | double :: Double -> Doc -- ^ @double n = text (show n)@ 235 | rational :: Rational -> Doc -- ^ @rational n = text (show n)@ 236 | int n = text (show n) 237 | integer n = text (show n) 238 | float n = text (show n) 239 | double n = text (show n) 240 | rational n = text (show n) 241 | 242 | parens :: Doc -> Doc -- ^ Wrap document in @(...)@ 243 | brackets :: Doc -> Doc -- ^ Wrap document in @[...]@ 244 | braces :: Doc -> Doc -- ^ Wrap document in @{...}@ 245 | quotes :: Doc -> Doc -- ^ Wrap document in @\'...\'@ 246 | doubleQuotes :: Doc -> Doc -- ^ Wrap document in @\"...\"@ 247 | quotes p = char '\'' <> p <> char '\'' 248 | doubleQuotes p = char '"' <> p <> char '"' 249 | parens p = char '(' <> p <> char ')' 250 | brackets p = char '[' <> p <> char ']' 251 | braces p = char '{' <> p <> char '}' 252 | 253 | -- | Apply 'parens' to 'Doc' if boolean is true. 254 | maybeParens :: Bool -> Doc -> Doc 255 | maybeParens False = id 256 | maybeParens True = parens 257 | 258 | -- | Apply 'brackets' to 'Doc' if boolean is true. 259 | maybeBrackets :: Bool -> Doc -> Doc 260 | maybeBrackets False = id 261 | maybeBrackets True = brackets 262 | 263 | -- | Apply 'braces' to 'Doc' if boolean is true. 264 | maybeBraces :: Bool -> Doc -> Doc 265 | maybeBraces False = id 266 | maybeBraces True = braces 267 | 268 | -- | Apply 'quotes' to 'Doc' if boolean is true. 269 | maybeQuotes :: Bool -> Doc -> Doc 270 | maybeQuotes False = id 271 | maybeQuotes True = quotes 272 | 273 | -- | Apply 'doubleQuotes' to 'Doc' if boolean is true. 274 | maybeDoubleQuotes :: Bool -> Doc -> Doc 275 | maybeDoubleQuotes False = id 276 | maybeDoubleQuotes True = doubleQuotes 277 | 278 | -- --------------------------------------------------------------------------- 279 | -- Structural operations on GDocs 280 | 281 | -- | Perform some simplification of a built up @GDoc@. 282 | reduceDoc :: Doc -> RDoc 283 | reduceDoc (Doc d) = Doc (Ann.reduceDoc d) 284 | {-# INLINE reduceDoc #-} 285 | 286 | -- | List version of '<>'. 287 | hcat :: [Doc] -> Doc 288 | hcat = liftList Ann.hcat 289 | {-# INLINE hcat #-} 290 | 291 | -- | List version of '<+>'. 292 | hsep :: [Doc] -> Doc 293 | hsep = liftList Ann.hsep 294 | {-# INLINE hsep #-} 295 | 296 | -- | List version of '$$'. 297 | vcat :: [Doc] -> Doc 298 | vcat = liftList Ann.vcat 299 | {-# INLINE vcat #-} 300 | 301 | -- | Nest (or indent) a document by a given number of positions 302 | -- (which may also be negative). 'nest' satisfies the laws: 303 | -- 304 | -- * @'nest' 0 x = x@ 305 | -- 306 | -- * @'nest' k ('nest' k' x) = 'nest' (k+k') x@ 307 | -- 308 | -- * @'nest' k (x '<>' y) = 'nest' k x '<>' 'nest' k y@ 309 | -- 310 | -- * @'nest' k (x '$$' y) = 'nest' k x '$$' 'nest' k y@ 311 | -- 312 | -- * @'nest' k 'empty' = 'empty'@ 313 | -- 314 | -- * @x '<>' 'nest' k y = x '<>' y@, if @x@ non-empty 315 | -- 316 | -- The side condition on the last law is needed because 317 | -- 'empty' is a left identity for '<>'. 318 | nest :: Int -> Doc -> Doc 319 | nest k (Doc p) = Doc (Ann.nest k p) 320 | {-# INLINE nest #-} 321 | 322 | -- | @hang d1 n d2 = sep [d1, nest n d2]@ 323 | hang :: Doc -> Int -> Doc -> Doc 324 | hang (Doc d1) n (Doc d2) = Doc (Ann.hang d1 n d2) 325 | {-# INLINE hang #-} 326 | 327 | -- | @punctuate p [d1, ... dn] = [d1 \<> p, d2 \<> p, ... dn-1 \<> p, dn]@ 328 | punctuate :: Doc -> [Doc] -> [Doc] 329 | punctuate (Doc p) ds = [ Doc d | d <- Ann.punctuate p [ d | Doc d <- ds ] ] 330 | {-# INLINE punctuate #-} 331 | 332 | 333 | -- --------------------------------------------------------------------------- 334 | -- Vertical composition @$$@ 335 | 336 | -- | Above, except that if the last line of the first argument stops 337 | -- at least one position before the first line of the second begins, 338 | -- these two lines are overlapped. For example: 339 | -- 340 | -- > text "hi" $$ nest 5 (text "there") 341 | -- 342 | -- lays out as 343 | -- 344 | -- > hi there 345 | -- 346 | -- rather than 347 | -- 348 | -- > hi 349 | -- > there 350 | -- 351 | -- '$$' is associative, with identity 'empty', and also satisfies 352 | -- 353 | -- * @(x '$$' y) '<>' z = x '$$' (y '<>' z)@, if @y@ non-empty. 354 | -- 355 | ($$) :: Doc -> Doc -> Doc 356 | ($$) = liftBinary (Ann.$$) 357 | {-# INLINE ($$) #-} 358 | 359 | -- | Above, with no overlapping. 360 | -- '$+$' is associative, with identity 'empty'. 361 | ($+$) :: Doc -> Doc -> Doc 362 | ($+$) = liftBinary (Ann.$+$) 363 | {-# INLINE ($+$) #-} 364 | 365 | 366 | -- --------------------------------------------------------------------------- 367 | -- Horizontal composition @<>@ 368 | 369 | -- We intentionally avoid Data.Monoid.(<>) here due to interactions of 370 | -- Data.Monoid.(<>) and (<+>). See 371 | -- http://www.haskell.org/pipermail/libraries/2011-November/017066.html 372 | 373 | -- | Beside. 374 | -- '<>' is associative, with identity 'empty'. 375 | (<>) :: Doc -> Doc -> Doc 376 | (<>) = liftBinary (Ann.<>) 377 | {-# INLINE (<>) #-} 378 | 379 | -- | Beside, separated by space, unless one of the arguments is 'empty'. 380 | -- '<+>' is associative, with identity 'empty'. 381 | (<+>) :: Doc -> Doc -> Doc 382 | (<+>) = liftBinary (Ann.<+>) 383 | {-# INLINE (<+>) #-} 384 | 385 | 386 | -- --------------------------------------------------------------------------- 387 | -- Separate, @sep@ 388 | 389 | -- Specification: sep ps = oneLiner (hsep ps) 390 | -- `union` 391 | -- vcat ps 392 | 393 | -- | 'hsep' if it fits, otherwise 'vcat'. 394 | sep :: [Doc] -> Doc 395 | sep = liftList Ann.sep 396 | {-# INLINE sep #-} 397 | 398 | -- |'hcat' if it fits, otherwise 'vcat'. 399 | cat :: [Doc] -> Doc 400 | cat = liftList Ann.cat 401 | {-# INLINE cat #-} 402 | 403 | 404 | -- --------------------------------------------------------------------------- 405 | -- @fill@ 406 | 407 | -- | \"Paragraph fill\" version of 'cat'. 408 | fcat :: [Doc] -> Doc 409 | fcat = liftList Ann.fcat 410 | {-# INLINE fcat #-} 411 | 412 | -- | \"Paragraph fill\" version of 'sep'. 413 | fsep :: [Doc] -> Doc 414 | fsep = liftList Ann.fsep 415 | {-# INLINE fsep #-} 416 | 417 | 418 | -- --------------------------------------------------------------------------- 419 | -- Selecting the best layout 420 | 421 | -- | @first@ returns its first argument if it is non-empty, otherwise its second. 422 | first :: Doc -> Doc -> Doc 423 | first = liftBinary Ann.first 424 | {-# INLINE first #-} 425 | 426 | 427 | -- --------------------------------------------------------------------------- 428 | -- Rendering 429 | 430 | -- | Render the @Doc@ to a String using the default @Style@ (see 'style'). 431 | render :: Doc -> String 432 | render = fullRender (mode style) (lineLength style) (ribbonsPerLine style) 433 | txtPrinter "" 434 | {-# INLINE render #-} 435 | 436 | -- | Render the @Doc@ to a String using the given @Style@. 437 | renderStyle :: Style -> Doc -> String 438 | renderStyle s = fullRender (mode s) (lineLength s) (ribbonsPerLine s) 439 | txtPrinter "" 440 | {-# INLINE renderStyle #-} 441 | 442 | -- | Default TextDetails printer. 443 | txtPrinter :: TextDetails -> String -> String 444 | txtPrinter (Chr c) s = c:s 445 | txtPrinter (Str s1) s2 = s1 ++ s2 446 | txtPrinter (PStr s1) s2 = s1 ++ s2 447 | 448 | -- | The general rendering interface. Please refer to the @Style@ and @Mode@ 449 | -- types for a description of rendering mode, line length and ribbons. 450 | fullRender :: Mode -- ^ Rendering mode. 451 | -> Int -- ^ Line length. 452 | -> Float -- ^ Ribbons per line. 453 | -> (TextDetails -> a -> a) -- ^ What to do with text. 454 | -> a -- ^ What to do at the end. 455 | -> Doc -- ^ The document. 456 | -> a -- ^ Result. 457 | fullRender m lineLen ribbons txt rest (Doc doc) 458 | = Ann.fullRender m lineLen ribbons txt rest doc 459 | {-# INLINE fullRender #-} 460 | 461 | -- | Convert an unannotated 'Doc' to a unit-annotated @Ann.Doc ()@. 462 | docToUnitDoc :: Doc -> Ann.Doc () 463 | docToUnitDoc (Doc ad) = ad 464 | 465 | -------------------------------------------------------------------------------- /tests/Test.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- Module : HughesPJQuickCheck 3 | -- Copyright : (c) 2008 Benedikt Huber 4 | -- License : BSD-style 5 | -- 6 | -- QuickChecks for HughesPJ pretty printer. 7 | -- 8 | -- 1) Testing laws (blackbox) 9 | -- - CDoc (combinator datatype) 10 | -- 2) Testing invariants (whitebox) 11 | -- 3) Testing bug fixes (whitebox) 12 | -- 13 | ----------------------------------------------------------------------------- 14 | 15 | #if __GLASGOW_HASKELL__ >= 803 16 | import Prelude hiding ( (<>) ) 17 | #endif 18 | 19 | import PrettyTestVersion 20 | import TestGenerators 21 | import TestStructures 22 | 23 | import UnitLargeDoc 24 | import UnitPP1 25 | import UnitT3911 26 | import UnitT32 27 | 28 | import Control.Monad 29 | import Data.Char (isSpace) 30 | import Data.List (intersperse) 31 | import Debug.Trace 32 | 33 | import Test.QuickCheck 34 | ( Args(..), Property, Testable, Result(Failure) 35 | , (==>) 36 | , classify, expectFailure, forAll, quickCheckWithResult, stdArgs 37 | ) 38 | 39 | main :: IO () 40 | main = do 41 | -- quickcheck tests 42 | check_laws 43 | check_invariants 44 | check_improvements 45 | check_non_prims -- hpc full coverage 46 | check_rendering 47 | check_list_def 48 | 49 | -- unit tests 50 | testPP1 51 | testT3911 52 | testT32 53 | testLargeDoc 54 | 55 | -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 56 | -- Utility functions 57 | -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 58 | 59 | -- tweaked to perform many small tests 60 | myConfig :: Int -> Int -> Args 61 | myConfig d n = stdArgs { maxSize = d, maxDiscardRatio = n*5 } 62 | 63 | maxTests :: Int 64 | maxTests = 1000 65 | 66 | myTest :: (Testable a) => String -> a -> IO () 67 | myTest = myTest' 15 maxTests 68 | 69 | myTest' :: (Testable a) => Int -> Int -> String -> a -> IO () 70 | myTest' d n msg t = do 71 | putStrLn (" * " ++ msg) 72 | r <- quickCheckWithResult (myConfig d n) t 73 | case r of 74 | (Failure {}) -> error "Failed testing!" 75 | _ -> return () 76 | 77 | myAssert :: String -> Bool -> IO () 78 | myAssert msg b = putStrLn $ (if b then "Ok, passed " else "Failed test:\n ") ++ msg 79 | 80 | -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 81 | -- Quickcheck tests 82 | -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 83 | 84 | -- Equalities on Documents 85 | -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 86 | 87 | -- compare text details 88 | tdEq :: TextDetails -> TextDetails -> Bool 89 | tdEq td1 td2 = (tdToStr td1) == (tdToStr td2) 90 | 91 | -- algebraic equality on reduced docs 92 | docEq :: RDoc () -> RDoc () -> Bool 93 | docEq rd1 rd2 = case (rd1, rd2) of 94 | (Empty, Empty) -> True 95 | (NoDoc, NoDoc) -> True 96 | (NilAbove ds1, NilAbove ds2) -> docEq ds1 ds2 97 | (TextBeside td1 ds1, TextBeside td2 ds2) | annotToTd td1 `tdEq` annotToTd td2 -> docEq ds1 ds2 98 | (Nest k1 d1, Nest k2 d2) | k1 == k2 -> docEq d1 d2 99 | (Union d11 d12, Union d21 d22) -> docEq d11 d21 && docEq d12 d22 100 | (d1,d2) -> False 101 | 102 | -- algebraic equality, with text reduction 103 | deq :: Doc () -> Doc () -> Bool 104 | deq d1 d2 = docEq (reduceDoc' d1) (reduceDoc' d2) where 105 | reduceDoc' = mergeTexts . reduceDoc 106 | deqs :: [Doc ()] -> [Doc ()] -> Bool 107 | deqs ds1 ds2 = 108 | case zipE ds1 ds2 of 109 | Nothing -> False 110 | (Just zds) -> all (uncurry deq) zds 111 | 112 | 113 | zipLayouts :: Doc () -> Doc () -> Maybe [(Doc (),Doc ())] 114 | zipLayouts d1 d2 = zipE (reducedDocs d1) (reducedDocs d2) 115 | where reducedDocs = map mergeTexts . flattenDoc 116 | 117 | zipE :: [Doc ()] -> [Doc ()] -> Maybe [(Doc (), Doc ())] 118 | zipE l1 l2 | length l1 == length l2 = Just $ zip l1 l2 119 | | otherwise = Nothing 120 | 121 | -- algebraic equality for layouts (without permutations) 122 | lseq :: Doc () -> Doc () -> Bool 123 | lseq d1 d2 = maybe False id . fmap (all (uncurry docEq)) $ zipLayouts d1 d2 124 | 125 | -- abstract render equality for layouts 126 | -- should only be performed if the number of layouts is reasonably small 127 | rdeq :: Doc () -> Doc () -> Bool 128 | rdeq d1 d2 = maybe False id . fmap (all (uncurry layoutEq)) $ zipLayouts d1 d2 129 | where layoutEq d1 d2 = (abstractLayout d1) == (abstractLayout d2) 130 | 131 | layoutsCountBounded :: Int -> [Doc ()] -> Bool 132 | layoutsCountBounded k docs = isBoundedBy k (concatMap flattenDoc docs) 133 | where 134 | isBoundedBy k [] = True 135 | isBoundedBy 0 (x:xs) = False 136 | isBoundedBy k (x:xs) = isBoundedBy (k-1) xs 137 | 138 | layoutCountBounded :: Int -> Doc () -> Bool 139 | layoutCountBounded k doc = layoutsCountBounded k [doc] 140 | 141 | maxLayouts :: Int 142 | maxLayouts = 64 143 | 144 | infix 4 `deq` 145 | infix 4 `lseq` 146 | infix 4 `rdeq` 147 | 148 | debugRender :: Int -> Doc () -> IO () 149 | debugRender k = putStr . visibleSpaces . renderStyle (Style PageMode k 1) 150 | visibleSpaces = unlines . map (map visibleSpace) . lines 151 | 152 | visibleSpace :: Char -> Char 153 | visibleSpace ' ' = '.' 154 | visibleSpace '.' = error "dot in visibleSpace (avoid confusion, please)" 155 | visibleSpace c = c 156 | 157 | 158 | -- (1) QuickCheck Properties: Laws 159 | -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 160 | 161 | {- 162 | Monoid laws for <>,<+>,$$,$+$ 163 | ~~~~~~~~~~~~~ 164 | (x * y) * z = x * (y * z) 165 | empty * x = x 166 | x * empty = x 167 | -} 168 | prop_1 op x y z = classify (any isEmpty [x,y,z]) "empty x, y or z" $ 169 | ((x `op` y) `op` z) `deq` (x `op` (y `op` z)) 170 | prop_2 op x = classify (isEmpty x) "empty" $ (empty `op` x) `deq` x 171 | prop_3 op x = classify (isEmpty x) "empty" $ x `deq` (empty `op` x) 172 | 173 | check_monoid = do 174 | putStrLn " = Monoid Laws =" 175 | mapM_ (myTest' 5 maxTests "Associativity") [ liftDoc3 (prop_1 op) | op <- allops ] 176 | mapM_ (myTest "Left neutral") [ prop_2 op . buildDoc | op <- allops ] 177 | mapM_ (myTest "Right neutral") [ prop_3 op . buildDoc | op <- allops ] 178 | where 179 | allops = [ (<>), (<+>) ,($$) , ($+$) ] 180 | 181 | {- 182 | Laws for text 183 | ~~~~~~~~~~~~~ 184 | text s <> text t = text (s++t) 185 | text "" <> x = x, if x non-empty [only true if x does not start with nest, because of ] 186 | -} 187 | prop_t1 s t = text' s <> text' t `deq` text (unText s ++ unText t) 188 | prop_t2 x = not (isEmpty x) ==> text "" <> x `deq` x 189 | prop_t2_a x = not (isEmpty x) && not (isNest x) ==> text "" <> x `deq` x 190 | 191 | isNest :: Doc () -> Bool 192 | isNest d = case reduceDoc d of 193 | (Nest _ _) -> True 194 | (Union d1 d2) -> isNest d1 || isNest d2 195 | _ -> False 196 | 197 | check_t = do 198 | putStrLn " = Text laws =" 199 | myTest "t1" prop_t1 200 | myTest "t2_a (precondition: x does not start with nest)" (prop_t2_a . buildDoc) 201 | myTest "t_2 (Known to fail)" (expectFailure . prop_t2 . buildDoc) 202 | 203 | {- 204 | Laws for nest 205 | ~~~~~~~~~~~~~ 206 | nest 0 x = x 207 | nest k (nest k' x) = nest (k+k') x 208 | nest k (x <> y) = nest k z <> nest k y 209 | nest k (x $$ y) = nest k x $$ nest k y 210 | nest k empty = empty 211 | x <> nest k y = x <> y, if x non-empty 212 | -} 213 | prop_n1 x = nest 0 x `deq` x 214 | prop_n2 k k' x = nest k (nest k' x) `deq` nest (k+k') x 215 | prop_n3 k k' x = nest k (nest k' x) `deq` nest (k+k') x 216 | prop_n4 k x y = nest k (x $$ y) `deq` nest k x $$ nest k y 217 | prop_n5 k = nest k empty `deq` empty 218 | prop_n6 x k y = not (isEmpty x) ==> 219 | x <> nest k y `deq` x <> y 220 | check_n = do 221 | putStrLn "Nest laws" 222 | myTest "n1" (prop_n1 . buildDoc) 223 | myTest "n2" (\k k' -> prop_n2 k k' . buildDoc) 224 | myTest "n3" (\k k' -> prop_n3 k k' . buildDoc) 225 | myTest "n4" (\k -> liftDoc2 (prop_n4 k)) 226 | myTest "n5" prop_n5 227 | myTest "n6" (\k -> liftDoc2 (\x -> prop_n6 x k)) 228 | 229 | {- 230 | (text s <> x) $$ y = text s <> ((text "" <> x)) $$ 231 | nest (-length s) y) 232 | 233 | (x $$ y) <> z = x $$ (y <> z) 234 | if y non-empty 235 | -} 236 | prop_m1 s x y = (text' s <> x) $$ y `deq` text' s <> ((text "" <> x) $$ 237 | nest (-length (unText s)) y) 238 | prop_m2 x y z = not (isEmpty y) ==> 239 | (x $$ y) <> z `deq` x $$ (y <> z) 240 | check_m = do 241 | putStrLn "Misc laws" 242 | myTest "m1" (\s -> liftDoc2 (prop_m1 s)) 243 | myTest' 10 maxTests "m2" (liftDoc3 prop_m2) 244 | 245 | 246 | {- 247 | Laws for list versions 248 | ~~~~~~~~~~~~~~~~~~~~~~ 249 | sep (ps++[empty]++qs) = sep (ps ++ qs) 250 | ...ditto hsep, hcat, vcat, fill... 251 | [ Fails for fill ! ] 252 | nest k (sep ps) = sep (map (nest k) ps) 253 | ...ditto hsep, hcat, vcat, fill... 254 | -} 255 | prop_l1 sp ps qs = 256 | sp (ps++[empty]++qs) `rdeq` sp (ps ++ qs) 257 | prop_l2 sp k ps = nest k (sep ps) `deq` sep (map (nest k) ps) 258 | 259 | 260 | prop_l1' sp cps cqs = 261 | let [ps,qs] = map buildDocList [cps,cqs] in 262 | layoutCountBounded maxLayouts (sp (ps++qs)) ==> prop_l1 sp ps qs 263 | prop_l2' sp k ps = prop_l2 sp k (buildDocList ps) 264 | check_l = do 265 | allCats $ myTest "l1" . prop_l1' 266 | allCats $ myTest "l2" . prop_l2' 267 | where 268 | allCats = flip mapM_ [ sep, hsep, cat, hcat, vcat, fsep, fcat ] 269 | prop_l1_fail_1 = [ text "a" ] 270 | prop_l1_fail_2 = [ text "a" $$ text "b" ] 271 | 272 | {- 273 | Laws for oneLiner 274 | ~~~~~~~~~~~~~~~~~ 275 | oneLiner (nest k p) = nest k (oneLiner p) 276 | oneLiner (x <> y) = oneLiner x <> oneLiner y 277 | 278 | [One liner only takes reduced arguments] 279 | -} 280 | oneLinerR = oneLiner . reduceDoc 281 | prop_o1 k p = oneLinerR (nest k p) `deq` nest k (oneLinerR p) 282 | prop_o2 x y = oneLinerR (x <> y) `deq` oneLinerR x <> oneLinerR y 283 | 284 | check_o = do 285 | putStrLn "oneliner laws" 286 | myTest "o1 (RDoc arg)" (\k p -> prop_o1 k (buildDoc p)) 287 | myTest "o2 (RDoc arg)" (liftDoc2 prop_o2) 288 | 289 | {- 290 | Definitions of list versions 291 | ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 292 | vcat = foldr ($$) empty 293 | hcat = foldr (<>) empty 294 | hsep = foldr (<+>) empty 295 | -} 296 | prop_hcat :: [Doc ()] -> Bool 297 | prop_hcat ds = hcat ds `deq` (foldr (<>) empty) ds 298 | 299 | prop_hsep :: [Doc ()] -> Bool 300 | prop_hsep ds = hsep ds `deq` (foldr (<+>) empty) ds 301 | 302 | prop_vcat :: [Doc ()] -> Bool 303 | prop_vcat ds = vcat ds `deq` (foldr ($$) empty) ds 304 | 305 | {- 306 | Update (pretty-1.1.0): 307 | *failing* definition of sep: oneLiner (hsep ps) `union` vcat ps 308 | ? 309 | -} 310 | prop_sep :: [Doc ()] -> Bool 311 | prop_sep ds = sep ds `rdeq` (sepDef ds) 312 | 313 | sepDef :: [Doc ()] -> Doc () 314 | sepDef docs = let ds = filter (not . isEmpty) docs in 315 | case ds of 316 | [] -> empty 317 | [d] -> d 318 | ds -> reduceDoc (oneLiner (reduceDoc $ hsep ds) 319 | `Union` 320 | (reduceDoc $ foldr ($+$) empty ds)) 321 | 322 | check_list_def = do 323 | myTest "hcat def" (prop_hcat . buildDocList) 324 | myTest "hsep def" (prop_hsep . buildDocList) 325 | myTest "vcat def" (prop_vcat . buildDocList) 326 | -- XXX: Not sure if this is meant to fail (I added the expectFailure [DT]) 327 | myTest "sep def" (expectFailure . prop_sep . buildDocList) 328 | 329 | {- 330 | Definition of fill (fcat/fsep) 331 | -- Specification: 332 | -- fill [] = empty 333 | -- fill [p] = p 334 | -- fill (p1:p2:ps) = oneLiner p1 <#> nest (length p1) 335 | -- (fill (oneLiner p2 : ps)) 336 | -- `union` 337 | -- p1 $$ fill ps 338 | -- Revised Specification: 339 | -- fill g docs = fillIndent 0 docs 340 | -- 341 | -- fillIndent k [] = [] 342 | -- fillIndent k [p] = p 343 | -- fillIndent k (p1:p2:ps) = 344 | -- oneLiner p1 fillIndent (k + length p1 + g ? 1 : 0) (remove_nests (oneLiner p2) : ps) 345 | -- `Union` 346 | -- (p1 $*$ nest (-k) (fillIndent 0 ps)) 347 | -- 348 | -- $*$ is defined for layouts (not Docs) as 349 | -- layout1 $*$ layout2 | isOneLiner layout1 = layout1 $+$ layout2 350 | -- | otherwise = layout1 $$ layout2 351 | -- 352 | -- Old implementation ambiguities/problems: 353 | -- ======================================== 354 | -- Preserving nesting: 355 | -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 356 | -- fcat [cat[ text "b", text "a"], nest 2 ( text "" $$ text "a")] 357 | -- ==> fcat [ text "b" $$ text "a", nest 2 (text "" $$ text "a")] // cat: union right 358 | -- ==> (text "b" $$ text "a" $$ nest 2 (text "" $$ text "a")) // fcat: union right with overlap 359 | -- ==> (text "ab" $$ nest 2 (text "" $$ text "a")) 360 | -- ==> "b\na\n..a" 361 | -- Bug #1337: 362 | -- ~~~~~~~~~~ 363 | -- > fcat [ nest 1 $ text "a", nest 2 $ text "b", text "c"] 364 | -- ==> [second alternative] roughly (a <#> b $#$ c) 365 | -- " ab" 366 | -- "c " 367 | -- expected: (nest 1; text "a"; text "b"; nest -3; "c") 368 | -- actual : (nest 1; text "a"; text "b"; nest -5; "c") 369 | -- === (nest 1; text a) <> (fill (-2) (p2:ps)) 370 | -- ==> (nest 2 (text "b") $+$ text "c") 371 | -- ==> (nest 2 (text "b") `nilabove` nest (-3) (text "c")) 372 | -- ==> (nest 1; text a; text b; nest -5 c) 373 | 374 | -} 375 | prop_fcat_vcat :: [Doc ()] -> Bool 376 | prop_fcat_vcat ds = last (flattenDoc $ fcat ds) `deq` last (flattenDoc $ vcat ds) 377 | 378 | prop_fcat :: [Doc ()] -> Bool 379 | prop_fcat ds = fcat ds `rdeq` fillDef False (filter (not . isEmpty) ds) 380 | 381 | prop_fsep :: [Doc ()] -> Bool 382 | prop_fsep ds = fsep ds `rdeq` fillDef True (filter (not . isEmpty) ds) 383 | 384 | prop_fcat_old :: [Doc ()] -> Bool 385 | prop_fcat_old ds = fillOld2 False ds `rdeq` fillDef False (filter (not . isEmpty) ds) 386 | 387 | prop_fcat_old_old :: [Doc ()] -> Bool 388 | prop_fcat_old_old ds = fillOld2 False ds `rdeq` fillDefOld False (filter (not . isEmpty) ds) 389 | 390 | prop_restrict_sz :: (Testable a) => Int -> ([Doc ()] -> a) -> ([Doc ()] -> Property) 391 | prop_restrict_sz k p ds = layoutCountBounded k (fsep ds) ==> p ds 392 | 393 | prop_restrict_ol :: (Testable a) => ([Doc ()] -> a) -> ([Doc ()] -> Property) 394 | prop_restrict_ol p ds = (all isOneLiner . map normalize $ ds) ==> p ds 395 | 396 | prop_restrict_no_nest_start :: (Testable a) => ([Doc ()] -> a) -> ([Doc ()] -> Property) 397 | prop_restrict_no_nest_start p ds = (all (not .isNest) ds) ==> p ds 398 | 399 | fillDef :: Bool -> [Doc ()] -> Doc () 400 | fillDef g = normalize . fill' 0 . filter (not.isEmpty) . map reduceDoc 401 | where 402 | fill' _ [] = Empty 403 | fill' _ [x] = x 404 | fill' k (p1:p2:ps) = 405 | reduceDoc (oneLiner p1 `append` (fill' (k + firstLineLength p1 + (if g then 1 else 0)) $ (oneLiner' p2) : ps)) 406 | `union` 407 | reduceDoc (p1 $*$ (nest (-k) (fillDef g (p2:ps)))) 408 | 409 | union = Union 410 | 411 | append = if g then (<+>) else (<>) 412 | 413 | oneLiner' (Nest k d) = oneLiner' d 414 | oneLiner' d = oneLiner d 415 | 416 | ($*$) :: RDoc () -> RDoc () -> RDoc () 417 | ($*$) p ps = case flattenDoc p of 418 | [] -> NoDoc 419 | ls -> foldr1 Union (map combine ls) 420 | where 421 | combine p | isOneLiner p = p $+$ ps 422 | | otherwise = p $$ ps 423 | 424 | fillDefOld :: Bool -> [Doc ()] -> Doc () 425 | fillDefOld g = normalize . fill' . filter (not.isEmpty) . map normalize where 426 | fill' [] = Empty 427 | fill' [p1] = p1 428 | fill' (p1:p2:ps) = (normalize (oneLiner p1 `append` nest (firstLineLength p1) 429 | (fill' (oneLiner p2 : ps)))) 430 | `union` 431 | (p1 $$ fill' (p2:ps)) 432 | append = if g then (<+>) else (<>) 433 | union = Union 434 | 435 | check_fill_prop :: Testable a => String -> ([Doc ()] -> a) -> IO () 436 | check_fill_prop msg p = myTest msg (prop_restrict_sz maxLayouts p . buildDocList) 437 | 438 | check_fill_def_fail :: IO () 439 | check_fill_def_fail = do 440 | check_fill_prop "fcat defOld vs fcatOld (ol)" (prop_restrict_ol prop_fcat_old_old) 441 | check_fill_prop "fcat defOld vs fcatOld" prop_fcat_old_old 442 | 443 | check_fill_prop "fcat def (ol) vs fcatOld" (prop_restrict_ol prop_fcat_old) 444 | check_fill_prop "fcat def vs fcatOld" prop_fcat_old 445 | 446 | check_fill_def_ok :: IO () 447 | check_fill_def_ok = do 448 | check_fill_prop "fcat def (not nest start) vs fcatOld" (prop_restrict_no_nest_start prop_fcat_old) 449 | 450 | check_fill_prop "fcat def (not nest start) vs fcat" (prop_restrict_no_nest_start prop_fcat) 451 | -- XXX: These all fail now with the change of pretty to GHC behaviour. 452 | check_fill_prop "fcat def (ol) vs fcat" (expectFailure . prop_restrict_ol prop_fcat) 453 | check_fill_prop "fcat def vs fcat" (expectFailure . prop_fcat) 454 | check_fill_prop "fsep def vs fsep" (expectFailure . prop_fsep) 455 | 456 | 457 | check_fill_def_laws :: IO () 458 | check_fill_def_laws = do 459 | check_fill_prop "lastLayout (fcat ps) == vcat ps" prop_fcat_vcat 460 | 461 | check_fill_def :: IO () 462 | check_fill_def = check_fill_def_fail >> check_fill_def_ok 463 | {- 464 | text "ac"; nilabove; nest -1; text "a"; empty 465 | text "ac"; nilabove; nest -2; text "a"; empty 466 | -} 467 | 468 | {- 469 | Zero width text (Neil) 470 | 471 | Here it would be convenient to generate functions (or replace empty / text bz z-w-t) 472 | -} 473 | -- TODO 474 | {- 475 | All laws: monoid, text, nest, misc, list versions, oneLiner, list def 476 | -} 477 | check_laws :: IO () 478 | check_laws = do 479 | check_fill_def_ok 480 | check_monoid 481 | check_t 482 | check_n 483 | check_m 484 | check_l 485 | check_o 486 | check_list_def 487 | 488 | -- (2) QuickCheck Properties: Invariants (whitebox) 489 | -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 490 | 491 | -- strategies: synthesize with stop condition 492 | -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 493 | stop :: a -> (a, Bool) 494 | stop a = (a,False) 495 | 496 | recurse :: a -> (a, Bool) 497 | recurse a = (a,True) 498 | -- strategy: generic synthesize with stop condition 499 | -- terms are combined top-down, left-right (latin text order) 500 | genericProp :: (a -> a -> a) -> (Doc () -> (a,Bool)) -> Doc () -> a 501 | genericProp c q doc = 502 | case q doc of 503 | (v,False) -> v 504 | (v,True) -> foldl c v (subs doc) 505 | where 506 | rec = genericProp c q 507 | subs d = case d of 508 | Empty -> [] 509 | NilAbove d -> [rec d] 510 | TextBeside _ d -> [rec d] 511 | Nest _ d -> [rec d] 512 | Union d1 d2 -> [rec d1, rec d2] 513 | NoDoc -> [] 514 | Beside d1 _ d2 -> subs (reduceDoc d) 515 | Above d1 _ d2 -> subs (reduceDoc d) 516 | 517 | 518 | {- 519 | * The argument of NilAbove is never Empty. Therefore 520 | a NilAbove occupies at least two lines. 521 | -} 522 | prop_inv1 :: Doc () -> Bool 523 | prop_inv1 d = genericProp (&&) nilAboveNotEmpty d where 524 | nilAboveNotEmpty (NilAbove Empty) = stop False 525 | nilAboveNotEmpty _ = recurse True 526 | 527 | {- 528 | * The argument of @TextBeside@ is never @Nest@. 529 | -} 530 | prop_inv2 :: Doc () -> Bool 531 | prop_inv2 = genericProp (&&) textBesideNotNest where 532 | textBesideNotNest (TextBeside _ (Nest _ _)) = stop False 533 | textBesideNotNest _ = recurse True 534 | {- 535 | * The layouts of the two arguments of @Union@ both flatten to the same 536 | string 537 | -} 538 | prop_inv3 :: Doc () -> Bool 539 | prop_inv3 = genericProp (&&) unionsFlattenSame where 540 | unionsFlattenSame (Union d1 d2) = stop (pairwiseEqual (extractTexts d1 ++ extractTexts d2)) 541 | unionsFlattenSame _ = recurse True 542 | pairwiseEqual (x:y:zs) = x==y && pairwiseEqual (y:zs) 543 | pairwiseEqual _ = True 544 | 545 | 546 | {- 547 | * The arguments of @Union@ are either @TextBeside@, or @NilAbove@. 548 | -} 549 | prop_inv4 :: Doc () -> Bool 550 | prop_inv4 = genericProp (&&) unionArgs where 551 | unionArgs (Union d1 d2) | goodUnionArg d1 && goodUnionArg d2 = recurse True 552 | | otherwise = stop False 553 | unionArgs _ = recurse True 554 | goodUnionArg (TextBeside _ _) = True 555 | goodUnionArg (NilAbove _) = True 556 | goodUnionArg _ = False 557 | 558 | {- 559 | * A @NoDoc@ may only appear on the first line of the left argument of 560 | an union. Therefore, the right argument of an union can never be equivalent 561 | to the empty set. 562 | -} 563 | prop_inv5 :: Doc () -> Bool 564 | prop_inv5 = genericProp (&&) unionArgs . reduceDoc where 565 | unionArgs NoDoc = stop False 566 | unionArgs (Union d1 d2) = stop $ genericProp (&&) noDocIsFirstLine d1 && nonEmptySet (reduceDoc d2) 567 | unionArgs _ = (True,True) -- recurse 568 | noDocIsFirstLine (NilAbove d) = stop $ genericProp (&&) unionArgs d 569 | noDocIsFirstLine _ = recurse True 570 | 571 | {- 572 | * An empty document is always represented by @Empty@. It can't be 573 | hidden inside a @Nest@, or a @Union@ of two @Empty@s. 574 | -} 575 | prop_inv6 :: Doc () -> Bool 576 | prop_inv6 d | not (prop_inv1 d) || not (prop_inv2 d) = False 577 | | not (isEmptyDoc d) = True 578 | | otherwise = case d of Empty -> True ; _ -> False 579 | 580 | isEmptyDoc :: Doc () -> Bool 581 | isEmptyDoc d = case emptyReduction d of Empty -> True; _ -> False 582 | 583 | {- 584 | * Consistency 585 | If all arguments of one of the list versions are empty documents, the list is an empty document 586 | -} 587 | prop_inv6a :: ([Doc ()] -> Doc ()) -> Property 588 | prop_inv6a sep = forAll emptyDocListGen $ 589 | \ds -> isEmptyRepr (sep $ buildDocList ds) 590 | where 591 | isEmptyRepr Empty = True 592 | isEmptyRepr _ = False 593 | 594 | {- 595 | * The first line of every layout in the left argument of @Union@ is 596 | longer than the first line of any layout in the right argument. 597 | (1) ensures that the left argument has a first line. In view of 598 | (3), this invariant means that the right argument must have at 599 | least two lines. 600 | -} 601 | counterexample_inv7 = cat [ text " ", nest 2 ( text "a") ] 602 | 603 | prop_inv7 :: Doc () -> Bool 604 | prop_inv7 = genericProp (&&) firstLonger where 605 | firstLonger (Union d1 d2) = (firstLineLength d1 >= firstLineLength d2, True) 606 | firstLonger _ = (True, True) 607 | 608 | {- 609 | * If we take as precondition: the arguments of cat,sep,fill do not start with Nest, invariant 7 holds 610 | -} 611 | prop_inv7_pre :: CDoc -> Bool 612 | prop_inv7_pre cdoc = nestStart True cdoc where 613 | nestStart nestOk doc = 614 | case doc of 615 | CList sep ds -> all (nestStart False) ds 616 | CBeside _ d1 d2 -> nestStart nestOk d1 && nestStart (not . isEmpty $ buildDoc d1) d2 617 | CAbove _ d1 d2 -> nestStart nestOk d1 && nestStart (not . isEmpty $ buildDoc d1) d2 618 | CNest _ d | not nestOk -> False 619 | | otherwise -> nestStart True d 620 | _empty_or_text -> True 621 | 622 | {- 623 | inv7_pre ==> inv7 624 | -} 625 | prop_inv7_a :: CDoc -> Property 626 | prop_inv7_a cdoc = prop_inv7_pre cdoc ==> prop_inv7 (buildDoc cdoc) 627 | 628 | check_invariants :: IO () 629 | check_invariants = do 630 | myTest "Invariant 1" (prop_inv1 . buildDoc) 631 | myTest "Invariant 2" (prop_inv2 . buildDoc) 632 | myTest "Invariant 3" (prop_inv3 . buildDoc) 633 | myTest "Invariant 4" (prop_inv4 . buildDoc) 634 | myTest "Invariant 5+" (prop_inv5 . buildDoc) 635 | myTest "Invariant 6" (prop_inv6 . buildDoc) 636 | mapM_ (\sp -> myTest "Invariant 6a" $ prop_inv6a sp) [ cat, sep, fcat, fsep, vcat, hcat, hsep ] 637 | -- XXX: Not sure if this is meant to fail (I added the expectFailure [DT]) 638 | myTest "Invariant 7 (fails in HughesPJ:20080621)" (expectFailure . prop_inv7 . buildDoc) 639 | 640 | -- `negative indent' 641 | -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 642 | 643 | {- 644 | In the documentation we have: 645 | 646 | (spaces n) generates a list of n spaces 647 | It should never be called with 'n' < 0, but that can happen for reasons I don't understand 648 | 649 | This is easy to explain: 650 | Suppose we have layout1 <> layout2 651 | length of last line layout1 is k1 652 | indentation of first line of layout2 is k2 653 | indentation of some other line of layout2 is k2' 654 | Now layout1 <> nest k2 (line1 $$ nest k2' lineK) 655 | ==> layout1 <> (line1 $$ nest k2' lineK) 656 | When k1 - k2' < 0, we need to layout lineK with negative indentation 657 | 658 | Here is a quick check property to ducment this. 659 | -} 660 | prop_negative_indent :: CDoc -> Property 661 | prop_negative_indent cdoc = noNegNest cdoc ==> noNegSpaces (buildDoc cdoc) 662 | noNegNest = genericCProp (&&) notIsNegNest where 663 | notIsNegNest (CNest k _) | k < 0 = stop False 664 | notIsNegNest _ = recurse True 665 | noNegSpaces = go 0 . reduceDoc where 666 | go k Empty = True 667 | go k (NilAbove d) = go k d 668 | go k (TextBeside _ d) | k < 0 = False 669 | go k (TextBeside s d) = go (k+annotSize s) d 670 | go k (Nest k' d) = go (k+k') d 671 | go k (Union d1 d2) = (if nonEmptySet d1 then (&&) (go k d1) else id) (go k d2) 672 | go k NoDoc = True 673 | 674 | counterexample_fail9 :: Doc () 675 | counterexample_fail9 = text "a" <> ( nest 2 ( text "b") $$ text "c") 676 | -- reduces to textb "a" ; textb "b" ; nilabove ; nest -3 ; textb "c" ; empty 677 | 678 | {- 679 | This cannot be fixed with violating the "intuitive property of layouts", described by John Hughes: 680 | "Composing layouts should preserve the layouts themselves (i.e. translation)" 681 | 682 | Consider the following example: 683 | It is the user's fault to use <+> in t2. 684 | -} 685 | 686 | tstmt = (nest 6 $ text "/* double indented comment */") $+$ 687 | (nest 3 $ text "/* indented comment */") $+$ 688 | text "skip;" 689 | 690 | t1 = text "while(true)" $+$ (nest 2) tstmt 691 | {- 692 | while(true) 693 | /* double indented comment */ 694 | /* indented comment */ 695 | skip; 696 | -} 697 | t2 = text "while(true)" $+$ (nest 2 $ text "//" <+> tstmt) 698 | {- 699 | while(true) 700 | // /* double indented comment */ 701 | /* indented comment */ 702 | skip; 703 | -} 704 | 705 | -- (3) Touching non-prims 706 | -- ~~~~~~~~~~~~~~~~~~~~~~ 707 | 708 | check_non_prims :: IO () 709 | check_non_prims = do 710 | myTest "Non primitive: show = renderStyle style" $ \cd -> let d = buildDoc cd in 711 | show ((zeroWidthText "a") <> d) /= renderStyle style d 712 | myAssert "symbols" $ 713 | (semi <> comma <> colon <> equals <> lparen <> rparen <> lbrack <> rbrack <> lbrace <> rbrace) 714 | `deq` 715 | (text ";,:=()[]{}") 716 | myAssert "quoting" $ 717 | (quotes . doubleQuotes . parens . brackets .braces $ (text "a" $$ text "b")) 718 | `deq` 719 | (text "'\"([{" <> (text "a" $$ text "b") <> text "}])\"'") 720 | myAssert "numbers" $ 721 | fsep [int 42, integer 42, float 42, double 42, rational 42] 722 | `rdeq` 723 | (fsep . map text) 724 | [show (42 :: Int), show (42 :: Integer), show (42 :: Float), show (42 :: Double), show (42 :: Rational)] 725 | myTest "Definition of <+>" $ \cd1 cd2 -> 726 | let (d1,d2) = (buildDoc cd1, buildDoc cd2) in 727 | layoutsCountBounded maxLayouts [d1,d2] ==> 728 | not (isEmpty d1) && not (isEmpty d2) ==> 729 | d1 <+> d2 `rdeq` d1 <> space <> d2 730 | 731 | myTest "hang" $ liftDoc2 (\d1 d2 -> hang d1 2 d2 `deq` sep [d1, nest 2 d2]) 732 | 733 | let pLift f cp cds = f (buildDoc cp) (buildDocList cds) 734 | myTest "punctuate" $ pLift (\p ds -> (punctuate p ds) `deqs` (punctuateDef p ds)) 735 | 736 | check_rendering = do 737 | myTest' 20 10000 "one - line rendering" $ \cd -> 738 | let d = buildDoc cd in 739 | (renderStyle (Style OneLineMode undefined undefined) d) == oneLineRender d 740 | myTest' 20 10000 "left-mode rendering" $ \cd -> 741 | let d = buildDoc cd in 742 | extractText (renderStyle (Style LeftMode undefined undefined) d) == extractText (oneLineRender d) 743 | myTest' 20 10000 "page mode rendering" $ \cd -> 744 | let d = buildDoc cd in 745 | extractText (renderStyle (Style PageMode 6 1.7) d) == extractText (oneLineRender d) 746 | myTest' 20 10000 "zigzag mode rendering" $ \cd -> 747 | let d = buildDoc cd in 748 | extractTextZZ (renderStyle (Style ZigZagMode 6 1.7) d) == extractText (oneLineRender d) 749 | 750 | extractText :: String -> String 751 | extractText = filter (not . isSpace) 752 | 753 | extractTextZZ :: String -> String 754 | extractTextZZ = filter (\c -> not (isSpace c) && c /= '/' && c /= '\\') 755 | 756 | punctuateDef :: Doc () -> [Doc ()] -> [Doc ()] 757 | punctuateDef p [] = [] 758 | punctuateDef p ps = 759 | let (dsInit,dLast) = (init ps, last ps) in 760 | map (\d -> d <> p) dsInit ++ [dLast] 761 | 762 | -- (4) QuickChecking improvments and bug fixes 763 | -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 764 | 765 | {- 766 | putStrLn $ render' $ fill True [ text "c", text "c",empty, text "c", text "b"] 767 | c c c 768 | b 769 | putStrLn $ render' $ fillOld True [ text "c", text "c",empty, text "c", text "b"] 770 | c c c 771 | b 772 | -} 773 | prop_fill_empty_reduce :: [Doc ()] -> Bool 774 | prop_fill_empty_reduce ds = fill True ds `deq` fillOld True (filter (not.isEmpty.reduceDoc) ds) 775 | 776 | check_improvements :: IO () 777 | check_improvements = do 778 | myTest "fill = fillOld . filter (not.isEmpty) [if no argument starts with nest]" 779 | (prop_fill_empty_reduce . filter (not .isNest) . buildDocList) 780 | 781 | -- old implementation of fill 782 | fillOld :: Bool -> [Doc ()] -> RDoc () 783 | fillOld _ [] = empty 784 | fillOld g (p:ps) = fill1 g (reduceDoc p) 0 ps where 785 | fill1 :: Bool -> RDoc () -> Int -> [Doc ()] -> Doc () 786 | fill1 _ _ k _ | k `seq` False = undefined 787 | fill1 _ NoDoc _ _ = NoDoc 788 | fill1 g (p `Union` q) k ys = fill1 g p k ys 789 | `union_` 790 | (aboveNest q False k (fillOld g ys)) 791 | 792 | fill1 g Empty k ys = mkNest k (fillOld g ys) 793 | fill1 g (Nest n p) k ys = nest_ n (fill1 g p (k - n) ys) 794 | 795 | fill1 g (NilAbove p) k ys = nilAbove_ (aboveNest p False k (fillOld g ys)) 796 | fill1 g (TextBeside s p) k ys = textBeside_ s (fillNB g p (k - annotSize s) ys) 797 | fill1 _ (Above {}) _ _ = error "fill1 Above" 798 | fill1 _ (Beside {}) _ _ = error "fill1 Beside" 799 | -- fillNB gap textBesideArgument space_left docs 800 | fillNB :: Bool -> Doc () -> Int -> [Doc ()] -> Doc () 801 | fillNB _ _ k _ | k `seq` False = undefined 802 | fillNB g (Nest _ p) k ys = fillNB g p k ys 803 | fillNB _ Empty _ [] = Empty 804 | fillNB g Empty k (y:ys) = nilBeside g (fill1 g (oneLiner (reduceDoc y)) k1 ys) 805 | `mkUnion` 806 | nilAboveNest False k (fillOld g (y:ys)) 807 | where 808 | k1 | g = k - 1 809 | | otherwise = k 810 | fillNB g p k ys = fill1 g p k ys 811 | 812 | 813 | -- Specification: 814 | -- fill [] = empty 815 | -- fill [p] = p 816 | -- fill (p1:p2:ps) = oneLiner p1 <#> nest (length p1) 817 | -- (fill (oneLiner p2 : ps)) 818 | -- `union` 819 | -- p1 $$ fill ps 820 | fillOld2 :: Bool -> [Doc ()] -> RDoc () 821 | fillOld2 _ [] = empty 822 | fillOld2 g (p:ps) = fill1 g (reduceDoc p) 0 ps where 823 | fill1 :: Bool -> RDoc () -> Int -> [Doc ()] -> Doc () 824 | fill1 _ _ k _ | k `seq` False = undefined 825 | fill1 _ NoDoc _ _ = NoDoc 826 | fill1 g (p `Union` q) k ys = fill1 g p k ys 827 | `union_` 828 | (aboveNest q False k (fill g ys)) 829 | 830 | fill1 g Empty k ys = mkNest k (fill g ys) 831 | fill1 g (Nest n p) k ys = nest_ n (fill1 g p (k - n) ys) 832 | 833 | fill1 g (NilAbove p) k ys = nilAbove_ (aboveNest p False k (fill g ys)) 834 | fill1 g (TextBeside s p) k ys = textBeside_ s (fillNB g p (k - annotSize s) ys) 835 | fill1 _ (Above {}) _ _ = error "fill1 Above" 836 | fill1 _ (Beside {}) _ _ = error "fill1 Beside" 837 | 838 | fillNB :: Bool -> Doc () -> Int -> [Doc ()] -> Doc () 839 | fillNB _ _ k _ | k `seq` False = undefined 840 | fillNB g (Nest _ p) k ys = fillNB g p k ys 841 | fillNB _ Empty _ [] = Empty 842 | fillNB g Empty k (Empty:ys) = fillNB g Empty k ys 843 | fillNB g Empty k (y:ys) = fillNBE g k y ys 844 | fillNB g p k ys = fill1 g p k ys 845 | 846 | fillNBE g k y ys = nilBeside g (fill1 g (oneLiner (reduceDoc y)) k1 ys) 847 | `mkUnion` 848 | nilAboveNest True k (fill g (y:ys)) 849 | where 850 | k1 | g = k - 1 851 | | otherwise = k 852 | 853 | -- (5) Pretty printing RDocs and RDOC properties 854 | -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 855 | prettyDoc :: Doc () -> Doc () 856 | prettyDoc d = 857 | case reduceDoc d of 858 | Empty -> text "empty" 859 | NilAbove d -> (text "nilabove") <> semi <+> (prettyDoc d) 860 | TextBeside s d -> (text ("text \""++tdToStr (annotToTd s) ++ "\"" ++ show (annotSize s))) <> semi <+> (prettyDoc d) 861 | Nest k d -> text "nest" <+> integer (fromIntegral k) <> semi <+> prettyDoc d 862 | Union d1 d2 -> sep [text "union", parens (prettyDoc d1), parens (prettyDoc d2)] 863 | NoDoc -> text "nodoc" 864 | 865 | -- TODO: map strategy for Docs to avoid code duplication 866 | -- Debug: Doc -> [Layout] 867 | flattenDoc :: Doc () -> [RDoc ()] 868 | flattenDoc d = flatten (reduceDoc d) where 869 | flatten NoDoc = [] 870 | flatten Empty = return Empty 871 | flatten (NilAbove d) = map NilAbove (flatten d) 872 | flatten (TextBeside s d) = map (TextBeside s) (flatten d) 873 | flatten (Nest k d) = map (Nest k) (flatten d) 874 | flatten (Union d1 d2) = flattenDoc d1 ++ flattenDoc d2 875 | flatten (Beside d1 b d2) = error $ "flattenDoc Beside" 876 | flatten (Above d1 b d2) = error $ "flattenDoc Above" 877 | 878 | normalize :: Doc () -> RDoc () 879 | normalize d = norm d where 880 | norm NoDoc = NoDoc 881 | norm Empty = Empty 882 | norm (NilAbove d) = NilAbove (norm d) 883 | norm (TextBeside s (Nest k d)) = norm (TextBeside s d) 884 | norm (TextBeside s d) = (TextBeside s) (norm d) 885 | norm (Nest k (Nest k' d)) = norm $ Nest (k+k') d 886 | norm (Nest 0 d) = norm d 887 | norm (Nest k d) = (Nest k) (norm d) 888 | -- * The arguments of @Union@ are either @TextBeside@, or @NilAbove@. 889 | norm (Union d1 d2) = normUnion (norm d1) (norm d2) 890 | norm d@(Beside d1 b d2) = norm (reduceDoc d) 891 | norm d@(Above d1 b d2) = norm (reduceDoc d) 892 | normUnion d0@(Nest k d) (Union d1 d2) = norm (Union d0 (normUnion d1 d2)) 893 | normUnion (Union d1 d2) d3@(Nest k d) = norm (Union (normUnion d1 d2) d3) 894 | normUnion (Nest k d1) (Nest k' d2) | k == k' = Nest k $ Union (norm d1) (norm d2) 895 | | otherwise = error "normalize: Union Nest length mismatch ?" 896 | normUnion (Nest _ _) d2 = error$ "normUnion Nest "++topLevelCTor d2 897 | normUnion d1 (Nest _ _) = error$ "normUnion Nset "++topLevelCTor d1 898 | normUnion p1 p2 = Union p1 p2 899 | 900 | topLevelCTor :: Doc () -> String 901 | topLevelCTor d = tlc d where 902 | tlc NoDoc = "NoDoc" 903 | tlc Empty = "Empty" 904 | tlc (NilAbove d) = "NilAbove" 905 | tlc (TextBeside s d) = "TextBeside" 906 | tlc (Nest k d) = "Nest" 907 | tlc (Union d1 d2) = "Union" 908 | tlc (Above _ _ _) = "Above" 909 | tlc (Beside _ _ _) = "Beside" 910 | 911 | -- normalize TextBeside (and consequently apply some laws for simplification) 912 | mergeTexts :: RDoc () -> RDoc () 913 | mergeTexts = merge where 914 | merge NoDoc = NoDoc 915 | merge Empty = Empty 916 | merge (NilAbove d) = NilAbove (merge d) 917 | merge (TextBeside t1 (TextBeside t2 doc)) = (merge.normalize) (TextBeside (mergeText t1 t2) doc) 918 | merge (TextBeside s d) = TextBeside s (merge d) 919 | merge (Nest k d) = Nest k (merge d) 920 | merge (Union d1 d2) = Union (merge d1) (merge d2) 921 | mergeText t1 t2 = 922 | NoAnnot (Str $ tdToStr (annotToTd t1) ++ tdToStr (annotToTd t2)) 923 | (annotSize t1 + annotSize t2) 924 | 925 | isOneLiner :: RDoc () -> Bool 926 | isOneLiner = genericProp (&&) iol where 927 | iol (NilAbove _) = stop False 928 | iol (Union _ _) = stop False 929 | iol NoDoc = stop False 930 | iol _ = recurse True 931 | 932 | hasOneLiner :: RDoc () -> Bool 933 | hasOneLiner = genericProp (&&) iol where 934 | iol (NilAbove _) = stop False 935 | iol (Union d1 _) = stop $ hasOneLiner d1 936 | iol NoDoc = stop False 937 | iol _ = recurse True 938 | 939 | -- use elementwise concatenation as generic combinator 940 | extractTexts :: Doc () -> [String] 941 | extractTexts = map normWS . genericProp combine go where 942 | combine xs ys = [ a ++ b | a <- xs, b <- ys ] 943 | go (TextBeside s _ ) = recurse [tdToStr (annotToTd s)] 944 | go (Union d1 d2) = stop $ extractTexts d1 ++ extractTexts d2 945 | go NoDoc = stop [] 946 | go _ = recurse [""] 947 | -- modulo whitespace 948 | normWS txt = filter (not . isWS) txt where 949 | isWS ws | ws == ' ' || ws == '\n' || ws == '\t' = True 950 | | otherwise = False 951 | 952 | emptyReduction :: Doc () -> Doc () 953 | emptyReduction doc = 954 | case doc of 955 | Empty -> Empty 956 | NilAbove d -> case emptyReduction d of Empty -> Empty ; d' -> NilAbove d' 957 | TextBeside s d -> TextBeside s (emptyReduction d) 958 | Nest k d -> case emptyReduction d of Empty -> Empty; d -> Nest k d 959 | Union d1 d2 -> case emptyReduction d2 of Empty -> Empty; _ -> Union d1 d2 -- if d2 is empty, both have to be 960 | NoDoc -> NoDoc 961 | Beside d1 _ d2 -> emptyReduction (reduceDoc doc) 962 | Above d1 _ d2 -> emptyReduction (reduceDoc doc) 963 | 964 | firstLineLength :: Doc () -> Int 965 | firstLineLength = genericProp (+) fll . reduceDoc where 966 | fll (NilAbove d) = stop 0 967 | fll (TextBeside s d) = recurse (annotSize s) 968 | fll (Nest k d) = recurse k 969 | fll (Union d1 d2) = stop (firstLineLength d1) -- inductively assuming inv7 970 | fll (Above _ _ _) = error "Above" 971 | fll (Beside _ _ _) = error "Beside" 972 | fll _ = (0,True) 973 | 974 | abstractLayout :: Doc () -> [(Int,String)] 975 | abstractLayout d = cal 0 Nothing (reduceDoc d) where 976 | -- current column -> this line -> doc -> [(indent,line)] 977 | cal :: Int -> (Maybe (Int,String)) -> Doc () -> [(Int,String)] 978 | cal k cur Empty = [ addTextEOL k (Str "") cur ] 979 | cal k cur (NilAbove d) = (addTextEOL k (Str "") cur) : cal k Nothing d 980 | cal k cur (TextBeside s d) = cal (k + annotSize s) (addText k s cur) d 981 | cal k cur (Nest n d) = cal (k+n) cur d 982 | cal _ _ (Union d1 d2) = error "abstractLayout: Union" 983 | cal _ _ NoDoc = error "NoDoc" 984 | cal _ _ (Above _ _ _) = error "Above" 985 | cal _ _ (Beside _ _ _) = error "Beside" 986 | addTextEOL k str Nothing = (k,tdToStr str) 987 | addTextEOL _ str (Just (k,pre)) = (k,pre++ tdToStr str) 988 | addText k str = Just . addTextEOL k (annotToTd str) 989 | 990 | docifyLayout :: [(Int,String)] -> Doc () 991 | docifyLayout = vcat . map (\(k,t) -> nest k (text t)) 992 | 993 | oneLineRender :: Doc () -> String 994 | oneLineRender = olr . abstractLayout . last . flattenDoc where 995 | olr = concat . intersperse " " . map snd 996 | 997 | -- because of invariant 4, we do not have to expand to layouts here 998 | -- but it is easier, so for now we use abstractLayout 999 | firstLineIsLeftMost :: Doc () -> Bool 1000 | firstLineIsLeftMost = all (firstIsLeftMost . abstractLayout) . flattenDoc where 1001 | firstIsLeftMost ((k,_):xs@(_:_)) = all ( (>= k) . fst) xs 1002 | firstIsLeftMost _ = True 1003 | 1004 | noNegativeIndent :: Doc () -> Bool 1005 | noNegativeIndent = all (noNegIndent . abstractLayout) . flattenDoc where 1006 | noNegIndent = all ( (>= 0) . fst) 1007 | 1008 | -------------------------------------------------------------------------------- /src/Text/PrettyPrint/Annotated/HughesPJ.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK not-home #-} 2 | {-# LANGUAGE BangPatterns #-} 3 | #if __GLASGOW_HASKELL__ >= 701 4 | {-# LANGUAGE Safe #-} 5 | {-# LANGUAGE DeriveGeneric #-} 6 | #endif 7 | 8 | ----------------------------------------------------------------------------- 9 | -- | 10 | -- Module : Text.PrettyPrint.Annotated.HughesPJ 11 | -- Copyright : (c) Trevor Elliott 2015 12 | -- License : BSD-style (see the file LICENSE) 13 | -- 14 | -- Maintainer : David Terei 15 | -- Stability : stable 16 | -- Portability : portable 17 | -- 18 | -- This module provides a version of pretty that allows for annotations to be 19 | -- attached to documents. Annotations are arbitrary pieces of metadata that can 20 | -- be attached to sub-documents. 21 | -- 22 | ----------------------------------------------------------------------------- 23 | 24 | #ifndef TESTING 25 | module Text.PrettyPrint.Annotated.HughesPJ ( 26 | 27 | -- * The document type 28 | Doc, TextDetails(..), AnnotDetails(..), 29 | 30 | -- ** Convert unit-annotated Doc to an arbitrary annotation type 31 | unitDocToAnnotatedDoc, 32 | 33 | -- * Constructing documents 34 | 35 | -- ** Converting values into documents 36 | char, text, ptext, sizedText, zeroWidthText, 37 | int, integer, float, double, rational, 38 | 39 | -- ** Simple derived documents 40 | semi, comma, colon, space, equals, 41 | lparen, rparen, lbrack, rbrack, lbrace, rbrace, 42 | 43 | -- ** Wrapping documents in delimiters 44 | parens, brackets, braces, quotes, doubleQuotes, 45 | maybeParens, maybeBrackets, maybeBraces, maybeQuotes, maybeDoubleQuotes, 46 | 47 | -- ** Combining documents 48 | empty, 49 | (<>), (<+>), hcat, hsep, 50 | ($$), ($+$), vcat, 51 | sep, cat, 52 | fsep, fcat, 53 | nest, 54 | hang, punctuate, 55 | 56 | -- ** Annotating documents 57 | annotate, 58 | 59 | -- * Predicates on documents 60 | isEmpty, 61 | 62 | -- * Utility functions for documents 63 | first, reduceDoc, 64 | 65 | -- * Rendering documents 66 | 67 | -- ** Default rendering 68 | render, 69 | 70 | -- ** Annotation rendering 71 | renderSpans, Span(..), 72 | renderDecorated, 73 | renderDecoratedM, 74 | 75 | -- ** Rendering with a particular style 76 | Style(..), 77 | style, 78 | renderStyle, 79 | Mode(..), 80 | 81 | -- ** General rendering 82 | fullRender, 83 | fullRenderAnn 84 | 85 | ) where 86 | #endif 87 | 88 | import Control.DeepSeq ( NFData(rnf) ) 89 | import Data.Function ( on ) 90 | #if __GLASGOW_HASKELL__ >= 803 91 | import Prelude hiding ( (<>) ) 92 | #endif 93 | #if __GLASGOW_HASKELL__ >= 800 || __MHS__ 94 | import qualified Data.Semigroup as Semi ( Semigroup((<>)) ) 95 | #elif __GLASGOW_HASKELL__ < 709 96 | import Data.Monoid ( Monoid(mempty, mappend) ) 97 | #endif 98 | import Data.String ( IsString(fromString) ) 99 | 100 | import GHC.Generics 101 | 102 | -- --------------------------------------------------------------------------- 103 | -- The Doc calculus 104 | 105 | {- 106 | Laws for $$ 107 | ~~~~~~~~~~~ 108 | (x $$ y) $$ z = x $$ (y $$ z) 109 | empty $$ x = x 110 | x $$ empty = x 111 | 112 | ...ditto $+$... 113 | 114 | Laws for <> 115 | ~~~~~~~~~~~ 116 | (x <> y) <> z = x <> (y <> z) 117 | empty <> x = empty 118 | x <> empty = x 119 | 120 | ...ditto <+>... 121 | 122 | Laws for text 123 | ~~~~~~~~~~~~~ 124 | text s <> text t = text (s++t) 125 | text "" <> x = x, if x non-empty 126 | 127 | ** because of law n6, t2 only holds if x doesn't 128 | ** start with `nest'. 129 | 130 | 131 | Laws for nest 132 | ~~~~~~~~~~~~~ 133 | nest 0 x = x 134 | nest k (nest k' x) = nest (k+k') x 135 | nest k (x <> y) = nest k x <> nest k y 136 | nest k (x $$ y) = nest k x $$ nest k y 137 | nest k empty = empty 138 | x <> nest k y = x <> y, if x non-empty 139 | 140 | ** Note the side condition on ! It is this that 141 | ** makes it OK for empty to be a left unit for <>. 142 | 143 | Miscellaneous 144 | ~~~~~~~~~~~~~ 145 | (text s <> x) $$ y = text s <> ((text "" <> x) $$ 146 | nest (-length s) y) 147 | 148 | (x $$ y) <> z = x $$ (y <> z) 149 | if y non-empty 150 | 151 | 152 | Laws for list versions 153 | ~~~~~~~~~~~~~~~~~~~~~~ 154 | sep (ps++[empty]++qs) = sep (ps ++ qs) 155 | ...ditto hsep, hcat, vcat, fill... 156 | 157 | nest k (sep ps) = sep (map (nest k) ps) 158 | ...ditto hsep, hcat, vcat, fill... 159 | 160 | Laws for oneLiner 161 | ~~~~~~~~~~~~~~~~~ 162 | oneLiner (nest k p) = nest k (oneLiner p) 163 | oneLiner (x <> y) = oneLiner x <> oneLiner y 164 | 165 | You might think that the following version of would 166 | be neater: 167 | 168 | <3 NO> (text s <> x) $$ y = text s <> ((empty <> x)) $$ 169 | nest (-length s) y) 170 | 171 | But it doesn't work, for if x=empty, we would have 172 | 173 | text s $$ y = text s <> (empty $$ nest (-length s) y) 174 | = text s <> nest (-length s) y 175 | -} 176 | 177 | -- --------------------------------------------------------------------------- 178 | -- Operator fixity 179 | 180 | infixl 6 <> 181 | infixl 6 <+> 182 | infixl 5 $$, $+$ 183 | 184 | -- --------------------------------------------------------------------------- 185 | -- The Doc data type 186 | 187 | -- | The abstract type of documents. A Doc represents a /set/ of layouts. A Doc 188 | -- with no occurrences of Union or NoDoc represents just one layout. 189 | data Doc a 190 | = Empty -- ^ An empty span, see 'empty'. 191 | | NilAbove (Doc a) -- ^ @text "" $$ x@. 192 | | TextBeside !(AnnotDetails a) (Doc a) -- ^ @text s <> x@. 193 | | Nest {-# UNPACK #-} !Int (Doc a) -- ^ @nest k x@. 194 | | Union (Doc a) (Doc a) -- ^ @ul `union` ur@. 195 | | NoDoc -- ^ The empty set of documents. 196 | | Beside (Doc a) Bool (Doc a) -- ^ True <=> space between. 197 | | Above (Doc a) Bool (Doc a) -- ^ True <=> never overlap. 198 | #if __GLASGOW_HASKELL__ >= 701 199 | deriving (Generic) 200 | #endif 201 | 202 | {- 203 | Here are the invariants: 204 | 205 | 1) The argument of NilAbove is never Empty. Therefore a NilAbove occupies at 206 | least two lines. 207 | 208 | 2) The argument of @TextBeside@ is never @Nest@. 209 | 210 | 3) The layouts of the two arguments of @Union@ both flatten to the same string. 211 | 212 | 4) The arguments of @Union@ are either @TextBeside@, or @NilAbove@. 213 | 214 | 5) A @NoDoc@ may only appear on the first line of the left argument of an 215 | union. Therefore, the right argument of an union can never be equivalent to 216 | the empty set (@NoDoc@). 217 | 218 | 6) An empty document is always represented by @Empty@. It can't be hidden 219 | inside a @Nest@, or a @Union@ of two @Empty@s. 220 | 221 | 7) The first line of every layout in the left argument of @Union@ is longer 222 | than the first line of any layout in the right argument. (1) ensures that 223 | the left argument has a first line. In view of (3), this invariant means 224 | that the right argument must have at least two lines. 225 | 226 | Notice the difference between 227 | * NoDoc (no documents) 228 | * Empty (one empty document; no height and no width) 229 | * text "" (a document containing the empty string; one line high, but has no 230 | width) 231 | -} 232 | 233 | 234 | -- | RDoc is a "reduced GDoc", guaranteed not to have a top-level Above or Beside. 235 | type RDoc = Doc 236 | 237 | -- | An annotation (side-metadata) attached at a particular point in a @Doc@. 238 | -- Allows carrying non-pretty-printed data around in a @Doc@ that is attached 239 | -- at particular points in the structure. Once the @Doc@ is render to an output 240 | -- type (such as 'String'), we can also retrieve where in the rendered document 241 | -- our annotations start and end (see 'Span' and 'renderSpans'). 242 | data AnnotDetails a = AnnotStart 243 | | NoAnnot !TextDetails {-# UNPACK #-} !Int 244 | | AnnotEnd a 245 | deriving (Show,Eq) 246 | 247 | instance Functor AnnotDetails where 248 | fmap _ AnnotStart = AnnotStart 249 | fmap _ (NoAnnot d i) = NoAnnot d i 250 | fmap f (AnnotEnd a) = AnnotEnd (f a) 251 | 252 | -- NOTE: Annotations are assumed to have zero length; only text has a length. 253 | annotSize :: AnnotDetails a -> Int 254 | annotSize (NoAnnot _ l) = l 255 | annotSize _ = 0 256 | 257 | -- | A TextDetails represents a fragment of text that will be output at some 258 | -- point in a @Doc@. 259 | data TextDetails = Chr {-# UNPACK #-} !Char -- ^ A single Char fragment 260 | | Str String -- ^ A whole String fragment 261 | | PStr String -- ^ Used to represent a Fast String fragment 262 | -- but now deprecated and identical to the 263 | -- Str constructor. 264 | #if __GLASGOW_HASKELL__ >= 701 || __MHS__ 265 | deriving (Show, Eq, Generic) 266 | #endif 267 | 268 | -- Combining @Doc@ values 269 | #if __GLASGOW_HASKELL__ >= 800 || __MHS__ 270 | instance Semi.Semigroup (Doc a) where 271 | #ifndef TESTING 272 | (<>) = (Text.PrettyPrint.Annotated.HughesPJ.<>) 273 | #else 274 | (<>) = (PrettyTestVersion.<>) 275 | #endif 276 | 277 | instance Monoid (Doc a) where 278 | mempty = empty 279 | mappend = (Semi.<>) 280 | #else 281 | instance Monoid (Doc a) where 282 | mempty = empty 283 | mappend = (<>) 284 | #endif 285 | 286 | instance IsString (Doc a) where 287 | fromString = text 288 | 289 | instance Show (Doc a) where 290 | showsPrec _ doc cont = fullRender (mode style) (lineLength style) 291 | (ribbonsPerLine style) 292 | txtPrinter cont doc 293 | 294 | instance Eq (Doc a) where 295 | (==) = (==) `on` render 296 | 297 | instance Functor Doc where 298 | fmap _ Empty = Empty 299 | fmap f (NilAbove d) = NilAbove (fmap f d) 300 | fmap f (TextBeside td d) = TextBeside (fmap f td) (fmap f d) 301 | fmap f (Nest k d) = Nest k (fmap f d) 302 | fmap f (Union ur ul) = Union (fmap f ur) (fmap f ul) 303 | fmap _ NoDoc = NoDoc 304 | fmap f (Beside ld s rd) = Beside (fmap f ld) s (fmap f rd) 305 | fmap f (Above ud s ld) = Above (fmap f ud) s (fmap f ld) 306 | 307 | instance NFData a => NFData (Doc a) where 308 | rnf Empty = () 309 | rnf (NilAbove d) = rnf d 310 | rnf (TextBeside td d) = rnf td `seq` rnf d 311 | rnf (Nest k d) = rnf k `seq` rnf d 312 | rnf (Union ur ul) = rnf ur `seq` rnf ul 313 | rnf NoDoc = () 314 | rnf (Beside ld s rd) = rnf ld `seq` rnf s `seq` rnf rd 315 | rnf (Above ud s ld) = rnf ud `seq` rnf s `seq` rnf ld 316 | 317 | instance NFData a => NFData (AnnotDetails a) where 318 | rnf AnnotStart = () 319 | rnf (NoAnnot d sl) = rnf d `seq` rnf sl 320 | rnf (AnnotEnd a) = rnf a 321 | 322 | instance NFData TextDetails where 323 | rnf (Chr c) = rnf c 324 | rnf (Str str) = rnf str 325 | rnf (PStr str) = rnf str 326 | 327 | -- --------------------------------------------------------------------------- 328 | -- Values and Predicates on GDocs and TextDetails 329 | 330 | -- | Attach an annotation to a document. 331 | annotate :: a -> Doc a -> Doc a 332 | annotate a d = TextBeside AnnotStart 333 | $ beside (reduceDoc d) False 334 | $ TextBeside (AnnotEnd a) Empty 335 | 336 | 337 | -- | A document of height and width 1, containing a literal character. 338 | char :: Char -> Doc a 339 | char c = textBeside_ (NoAnnot (Chr c) 1) Empty 340 | 341 | -- | A document of height 1 containing a literal string. 342 | -- 'text' satisfies the following laws: 343 | -- 344 | -- * @'text' s '<>' 'text' t = 'text' (s'++'t)@ 345 | -- 346 | -- * @'text' \"\" '<>' x = x@, if @x@ non-empty 347 | -- 348 | -- The side condition on the last law is necessary because @'text' \"\"@ 349 | -- has height 1, while 'empty' has no height. 350 | text :: String -> Doc a 351 | text s = case length s of {sl -> textBeside_ (NoAnnot (Str s) sl) Empty} 352 | 353 | -- | Same as @text@. Used to be used for Bytestrings. 354 | ptext :: String -> Doc a 355 | ptext s = case length s of {sl -> textBeside_ (NoAnnot (PStr s) sl) Empty} 356 | 357 | -- | Some text with any width. (@text s = sizedText (length s) s@) 358 | sizedText :: Int -> String -> Doc a 359 | sizedText l s = textBeside_ (NoAnnot (Str s) l) Empty 360 | 361 | -- | Some text, but without any width. Use for non-printing text 362 | -- such as a HTML or Latex tags 363 | zeroWidthText :: String -> Doc a 364 | zeroWidthText = sizedText 0 365 | 366 | -- | The empty document, with no height and no width. 367 | -- 'empty' is the identity for '<>', '<+>', '$$' and '$+$', and anywhere 368 | -- in the argument list for 'sep', 'hcat', 'hsep', 'vcat', 'fcat' etc. 369 | empty :: Doc a 370 | empty = Empty 371 | 372 | -- | Returns 'True' if the document is empty 373 | isEmpty :: Doc a -> Bool 374 | isEmpty Empty = True 375 | isEmpty _ = False 376 | 377 | -- | Produce spacing for indenting the amount specified. 378 | -- 379 | -- an old version inserted tabs being 8 columns apart in the output. 380 | indent :: Int -> String 381 | indent !n = replicate n ' ' 382 | 383 | {- 384 | Q: What is the reason for negative indentation (i.e. argument to indent 385 | is < 0) ? 386 | 387 | A: 388 | This indicates an error in the library client's code. 389 | If we compose a <> b, and the first line of b is more indented than some 390 | other lines of b, the law (<> eats nests) may cause the pretty 391 | printer to produce an invalid layout: 392 | 393 | doc |0123345 394 | ------------------ 395 | d1 |a...| 396 | d2 |...b| 397 | |c...| 398 | 399 | d1<>d2 |ab..| 400 | c|....| 401 | 402 | Consider a <> b, let `s' be the length of the last line of `a', `k' the 403 | indentation of the first line of b, and `k0' the indentation of the 404 | left-most line b_i of b. 405 | 406 | The produced layout will have negative indentation if `k - k0 > s', as 407 | the first line of b will be put on the (s+1)th column, effectively 408 | translating b horizontally by (k-s). Now if the i^th line of b has an 409 | indentation k0 < (k-s), it is translated out-of-page, causing 410 | `negative indentation'. 411 | -} 412 | 413 | 414 | semi :: Doc a -- ^ A ';' character 415 | comma :: Doc a -- ^ A ',' character 416 | colon :: Doc a -- ^ A ':' character 417 | space :: Doc a -- ^ A space character 418 | equals :: Doc a -- ^ A '=' character 419 | lparen :: Doc a -- ^ A '(' character 420 | rparen :: Doc a -- ^ A ')' character 421 | lbrack :: Doc a -- ^ A '[' character 422 | rbrack :: Doc a -- ^ A ']' character 423 | lbrace :: Doc a -- ^ A '{' character 424 | rbrace :: Doc a -- ^ A '}' character 425 | semi = char ';' 426 | comma = char ',' 427 | colon = char ':' 428 | space = char ' ' 429 | equals = char '=' 430 | lparen = char '(' 431 | rparen = char ')' 432 | lbrack = char '[' 433 | rbrack = char ']' 434 | lbrace = char '{' 435 | rbrace = char '}' 436 | 437 | spaceText, nlText :: AnnotDetails a 438 | spaceText = NoAnnot (Chr ' ') 1 439 | nlText = NoAnnot (Chr '\n') 1 440 | 441 | int :: Int -> Doc a -- ^ @int n = text (show n)@ 442 | integer :: Integer -> Doc a -- ^ @integer n = text (show n)@ 443 | float :: Float -> Doc a -- ^ @float n = text (show n)@ 444 | double :: Double -> Doc a -- ^ @double n = text (show n)@ 445 | rational :: Rational -> Doc a -- ^ @rational n = text (show n)@ 446 | int n = text (show n) 447 | integer n = text (show n) 448 | float n = text (show n) 449 | double n = text (show n) 450 | rational n = text (show n) 451 | 452 | parens :: Doc a -> Doc a -- ^ Wrap document in @(...)@ 453 | brackets :: Doc a -> Doc a -- ^ Wrap document in @[...]@ 454 | braces :: Doc a -> Doc a -- ^ Wrap document in @{...}@ 455 | quotes :: Doc a -> Doc a -- ^ Wrap document in @\'...\'@ 456 | doubleQuotes :: Doc a -> Doc a -- ^ Wrap document in @\"...\"@ 457 | quotes p = char '\'' <> p <> char '\'' 458 | doubleQuotes p = char '"' <> p <> char '"' 459 | parens p = char '(' <> p <> char ')' 460 | brackets p = char '[' <> p <> char ']' 461 | braces p = char '{' <> p <> char '}' 462 | 463 | -- | Apply 'parens' to 'Doc' if boolean is true. 464 | maybeParens :: Bool -> Doc a -> Doc a 465 | maybeParens False = id 466 | maybeParens True = parens 467 | 468 | -- | Apply 'brackets' to 'Doc' if boolean is true. 469 | maybeBrackets :: Bool -> Doc a -> Doc a 470 | maybeBrackets False = id 471 | maybeBrackets True = brackets 472 | 473 | -- | Apply 'braces' to 'Doc' if boolean is true. 474 | maybeBraces :: Bool -> Doc a -> Doc a 475 | maybeBraces False = id 476 | maybeBraces True = braces 477 | 478 | -- | Apply 'quotes' to 'Doc' if boolean is true. 479 | maybeQuotes :: Bool -> Doc a -> Doc a 480 | maybeQuotes False = id 481 | maybeQuotes True = quotes 482 | 483 | -- | Apply 'doubleQuotes' to 'Doc' if boolean is true. 484 | maybeDoubleQuotes :: Bool -> Doc a -> Doc a 485 | maybeDoubleQuotes False = id 486 | maybeDoubleQuotes True = doubleQuotes 487 | 488 | -- --------------------------------------------------------------------------- 489 | -- Structural operations on GDocs 490 | 491 | -- | Perform some simplification of a built up @GDoc@. 492 | reduceDoc :: Doc a -> RDoc a 493 | reduceDoc (Beside p g q) = beside p g (reduceDoc q) 494 | reduceDoc (Above p g q) = above p g (reduceDoc q) 495 | reduceDoc p = p 496 | 497 | -- | List version of '<>'. 498 | hcat :: [Doc a] -> Doc a 499 | hcat = snd . reduceHoriz . foldr (\p q -> Beside p False q) empty 500 | 501 | -- | List version of '<+>'. 502 | hsep :: [Doc a] -> Doc a 503 | hsep = snd . reduceHoriz . foldr (\p q -> Beside p True q) empty 504 | 505 | -- | List version of '$$'. 506 | vcat :: [Doc a] -> Doc a 507 | vcat = snd . reduceVert . foldr (\p q -> Above p False q) empty 508 | 509 | -- | Nest (or indent) a document by a given number of positions 510 | -- (which may also be negative). 'nest' satisfies the laws: 511 | -- 512 | -- * @'nest' 0 x = x@ 513 | -- 514 | -- * @'nest' k ('nest' k' x) = 'nest' (k+k') x@ 515 | -- 516 | -- * @'nest' k (x '<>' y) = 'nest' k z '<>' 'nest' k y@ 517 | -- 518 | -- * @'nest' k (x '$$' y) = 'nest' k x '$$' 'nest' k y@ 519 | -- 520 | -- * @'nest' k 'empty' = 'empty'@ 521 | -- 522 | -- * @x '<>' 'nest' k y = x '<>' y@, if @x@ non-empty 523 | -- 524 | -- The side condition on the last law is needed because 525 | -- 'empty' is a left identity for '<>'. 526 | nest :: Int -> Doc a -> Doc a 527 | nest k p = mkNest k (reduceDoc p) 528 | 529 | -- | @hang d1 n d2 = sep [d1, nest n d2]@ 530 | hang :: Doc a -> Int -> Doc a -> Doc a 531 | hang d1 n d2 = sep [d1, nest n d2] 532 | 533 | -- | @punctuate p [d1, ... dn] = [d1 \<> p, d2 \<> p, ... dn-1 \<> p, dn]@ 534 | punctuate :: Doc a -> [Doc a] -> [Doc a] 535 | punctuate _ [] = [] 536 | punctuate p (x:xs) = go x xs 537 | where go y [] = [y] 538 | go y (z:zs) = (y <> p) : go z zs 539 | 540 | -- mkNest checks for Nest's invariant that it doesn't have an Empty inside it 541 | mkNest :: Int -> Doc a -> Doc a 542 | mkNest k _ | k `seq` False = undefined 543 | mkNest k (Nest k1 p) = mkNest (k + k1) p 544 | mkNest _ NoDoc = NoDoc 545 | mkNest _ Empty = Empty 546 | mkNest 0 p = p 547 | mkNest k p = nest_ k p 548 | 549 | -- mkUnion checks for an empty document 550 | mkUnion :: Doc a -> Doc a -> Doc a 551 | mkUnion Empty _ = Empty 552 | mkUnion p q = p `union_` q 553 | 554 | data IsEmpty = IsEmpty | NotEmpty 555 | 556 | reduceHoriz :: Doc a -> (IsEmpty, Doc a) 557 | reduceHoriz (Beside p g q) = eliminateEmpty Beside (snd (reduceHoriz p)) g (reduceHoriz q) 558 | reduceHoriz doc = (NotEmpty, doc) 559 | 560 | reduceVert :: Doc a -> (IsEmpty, Doc a) 561 | reduceVert (Above p g q) = eliminateEmpty Above (snd (reduceVert p)) g (reduceVert q) 562 | reduceVert doc = (NotEmpty, doc) 563 | 564 | {-# INLINE eliminateEmpty #-} 565 | eliminateEmpty :: 566 | (Doc a -> Bool -> Doc a -> Doc a) -> 567 | Doc a -> Bool -> (IsEmpty, Doc a) -> (IsEmpty, Doc a) 568 | eliminateEmpty _ Empty _ q = q 569 | eliminateEmpty cons p g q = 570 | (NotEmpty, 571 | -- We're not empty whether or not q is empty, so for laziness-sake, 572 | -- after checking that p isn't empty, we put the NotEmpty result 573 | -- outside independent of q. This allows reduceAB to immediately 574 | -- return the appropriate constructor (Above or Beside) without 575 | -- forcing the entire nested Doc. This allows the foldr in vcat, 576 | -- hsep, and hcat to be lazy on its second argument, avoiding a 577 | -- stack overflow. 578 | case q of 579 | (NotEmpty, q') -> cons p g q' 580 | (IsEmpty, _) -> p) 581 | 582 | nilAbove_ :: RDoc a -> RDoc a 583 | nilAbove_ = NilAbove 584 | 585 | -- | Arg of a TextBeside is always an RDoc. 586 | textBeside_ :: AnnotDetails a -> RDoc a -> RDoc a 587 | textBeside_ = TextBeside 588 | 589 | nest_ :: Int -> RDoc a -> RDoc a 590 | nest_ = Nest 591 | 592 | union_ :: RDoc a -> RDoc a -> RDoc a 593 | union_ = Union 594 | 595 | 596 | -- --------------------------------------------------------------------------- 597 | -- Vertical composition @$$@ 598 | 599 | -- | Above, except that if the last line of the first argument stops 600 | -- at least one position before the first line of the second begins, 601 | -- these two lines are overlapped. For example: 602 | -- 603 | -- > text "hi" $$ nest 5 (text "there") 604 | -- 605 | -- lays out as 606 | -- 607 | -- > hi there 608 | -- 609 | -- rather than 610 | -- 611 | -- > hi 612 | -- > there 613 | -- 614 | -- '$$' is associative, with identity 'empty', and also satisfies 615 | -- 616 | -- * @(x '$$' y) '<>' z = x '$$' (y '<>' z)@, if @y@ non-empty. 617 | -- 618 | ($$) :: Doc a -> Doc a -> Doc a 619 | p $$ q = above_ p False q 620 | 621 | -- | Above, with no overlapping. 622 | -- '$+$' is associative, with identity 'empty'. 623 | ($+$) :: Doc a -> Doc a -> Doc a 624 | p $+$ q = above_ p True q 625 | 626 | above_ :: Doc a -> Bool -> Doc a -> Doc a 627 | above_ p _ Empty = p 628 | above_ Empty _ q = q 629 | above_ p g q = Above p g q 630 | 631 | above :: Doc a -> Bool -> RDoc a -> RDoc a 632 | above (Above p g1 q1) g2 q2 = above p g1 (above q1 g2 q2) 633 | above p@(Beside{}) g q = aboveNest (reduceDoc p) g 0 (reduceDoc q) 634 | above p g q = aboveNest p g 0 (reduceDoc q) 635 | 636 | -- Specfication: aboveNest p g k q = p $g$ (nest k q) 637 | aboveNest :: RDoc a -> Bool -> Int -> RDoc a -> RDoc a 638 | aboveNest _ _ k _ | k `seq` False = undefined 639 | aboveNest NoDoc _ _ _ = NoDoc 640 | aboveNest (p1 `Union` p2) g k q = aboveNest p1 g k q `union_` 641 | aboveNest p2 g k q 642 | 643 | aboveNest Empty _ k q = mkNest k q 644 | aboveNest (Nest k1 p) g k q = nest_ k1 (aboveNest p g (k - k1) q) 645 | -- p can't be Empty, so no need for mkNest 646 | 647 | aboveNest (NilAbove p) g k q = nilAbove_ (aboveNest p g k q) 648 | aboveNest (TextBeside s p) g k q = TextBeside s rest 649 | where 650 | !k1 = k - annotSize s 651 | rest = case p of 652 | Empty -> nilAboveNest g k1 q 653 | _ -> aboveNest p g k1 q 654 | 655 | aboveNest (Above {}) _ _ _ = error "aboveNest Above" 656 | aboveNest (Beside {}) _ _ _ = error "aboveNest Beside" 657 | 658 | -- Specification: text s <> nilaboveNest g k q 659 | -- = text s <> (text "" $g$ nest k q) 660 | nilAboveNest :: Bool -> Int -> RDoc a -> RDoc a 661 | nilAboveNest _ k _ | k `seq` False = undefined 662 | nilAboveNest _ _ Empty = Empty 663 | -- Here's why the "text s <>" is in the spec! 664 | nilAboveNest g k (Nest k1 q) = nilAboveNest g (k + k1) q 665 | nilAboveNest g k q | not g && k > 0 -- No newline if no overlap 666 | = textBeside_ (NoAnnot (Str (indent k)) k) q 667 | | otherwise -- Put them really above 668 | = nilAbove_ (mkNest k q) 669 | 670 | 671 | -- --------------------------------------------------------------------------- 672 | -- Horizontal composition @<>@ 673 | 674 | -- We intentionally avoid Data.Monoid.(<>) here due to interactions of 675 | -- Data.Monoid.(<>) and (<+>). See 676 | -- http://www.haskell.org/pipermail/libraries/2011-November/017066.html 677 | 678 | -- | Beside. 679 | -- '<>' is associative, with identity 'empty'. 680 | (<>) :: Doc a -> Doc a -> Doc a 681 | p <> q = beside_ p False q 682 | 683 | -- | Beside, separated by space, unless one of the arguments is 'empty'. 684 | -- '<+>' is associative, with identity 'empty'. 685 | (<+>) :: Doc a -> Doc a -> Doc a 686 | p <+> q = beside_ p True q 687 | 688 | beside_ :: Doc a -> Bool -> Doc a -> Doc a 689 | beside_ p _ Empty = p 690 | beside_ Empty _ q = q 691 | beside_ p g q = Beside p g q 692 | 693 | -- Specification: beside g p q = p q 694 | beside :: Doc a -> Bool -> RDoc a -> RDoc a 695 | beside NoDoc _ _ = NoDoc 696 | beside (p1 `Union` p2) g q = beside p1 g q `union_` beside p2 g q 697 | beside Empty _ q = q 698 | beside (Nest k p) g q = nest_ k $! beside p g q 699 | beside p@(Beside p1 g1 q1) g2 q2 700 | | g1 == g2 = beside p1 g1 $! beside q1 g2 q2 701 | | otherwise = beside (reduceDoc p) g2 q2 702 | beside p@(Above{}) g q = let !d = reduceDoc p in beside d g q 703 | beside (NilAbove p) g q = nilAbove_ $! beside p g q 704 | beside (TextBeside t p) g q = TextBeside t rest 705 | where 706 | rest = case p of 707 | Empty -> nilBeside g q 708 | _ -> beside p g q 709 | 710 | -- Specification: text "" <> nilBeside g p 711 | -- = text "" p 712 | nilBeside :: Bool -> RDoc a -> RDoc a 713 | nilBeside _ Empty = Empty -- Hence the text "" in the spec 714 | nilBeside g (Nest _ p) = nilBeside g p 715 | nilBeside g p | g = textBeside_ spaceText p 716 | | otherwise = p 717 | 718 | 719 | -- --------------------------------------------------------------------------- 720 | -- Separate, @sep@ 721 | 722 | -- Specification: sep ps = oneLiner (hsep ps) 723 | -- `union` 724 | -- vcat ps 725 | 726 | -- | 'hsep' if it fits, else 'vcat'. 727 | sep :: [Doc a] -> Doc a 728 | sep = sepX True -- Separate with spaces 729 | 730 | -- | 'hcat' if it fits, else 'vcat'. 731 | cat :: [Doc a] -> Doc a 732 | cat = sepX False -- Don't 733 | 734 | sepX :: Bool -> [Doc a] -> Doc a 735 | sepX _ [] = empty 736 | sepX x (p:ps) = sep1 x (reduceDoc p) 0 ps 737 | 738 | 739 | -- Specification: sep1 g k ys = sep (x : map (nest k) ys) 740 | -- = oneLiner (x nest k (hsep ys)) 741 | -- `union` x $$ nest k (vcat ys) 742 | sep1 :: Bool -> RDoc a -> Int -> [Doc a] -> RDoc a 743 | sep1 _ _ k _ | k `seq` False = undefined 744 | sep1 _ NoDoc _ _ = NoDoc 745 | sep1 g (p `Union` q) k ys = sep1 g p k ys `union_` 746 | aboveNest q False k (reduceDoc (vcat ys)) 747 | 748 | sep1 g Empty k ys = mkNest k (sepX g ys) 749 | sep1 g (Nest n p) k ys = nest_ n (sep1 g p (k - n) ys) 750 | 751 | sep1 _ (NilAbove p) k ys = nilAbove_ 752 | (aboveNest p False k (reduceDoc (vcat ys))) 753 | sep1 g (TextBeside s p) k ys = textBeside_ s (sepNB g p (k - annotSize s) ys) 754 | sep1 _ (Above {}) _ _ = error "sep1 Above" 755 | sep1 _ (Beside {}) _ _ = error "sep1 Beside" 756 | 757 | -- Specification: sepNB p k ys = sep1 (text "" <> p) k ys 758 | -- Called when we have already found some text in the first item 759 | -- We have to eat up nests 760 | sepNB :: Bool -> Doc a -> Int -> [Doc a] -> Doc a 761 | sepNB g (Nest _ p) k ys 762 | = sepNB g p k ys -- Never triggered, because of invariant (2) 763 | sepNB g Empty k ys 764 | = oneLiner (nilBeside g (reduceDoc rest)) `mkUnion` 765 | -- XXX: TODO: PRETTY: Used to use True here (but GHC used False...) 766 | nilAboveNest False k (reduceDoc (vcat ys)) 767 | where 768 | rest | g = hsep ys 769 | | otherwise = hcat ys 770 | sepNB g p k ys 771 | = sep1 g p k ys 772 | 773 | 774 | -- --------------------------------------------------------------------------- 775 | -- @fill@ 776 | 777 | -- | \"Paragraph fill\" version of 'cat'. 778 | fcat :: [Doc a] -> Doc a 779 | fcat = fill False 780 | 781 | -- | \"Paragraph fill\" version of 'sep'. 782 | fsep :: [Doc a] -> Doc a 783 | fsep = fill True 784 | 785 | -- Specification: 786 | -- 787 | -- fill g docs = fillIndent 0 docs 788 | -- 789 | -- fillIndent k [] = [] 790 | -- fillIndent k [p] = p 791 | -- fillIndent k (p1:p2:ps) = 792 | -- oneLiner p1 fillIndent (k + length p1 + g ? 1 : 0) 793 | -- (remove_nests (oneLiner p2) : ps) 794 | -- `Union` 795 | -- (p1 $*$ nest (-k) (fillIndent 0 ps)) 796 | -- 797 | -- $*$ is defined for layouts (not Docs) as 798 | -- layout1 $*$ layout2 | hasMoreThanOneLine layout1 = layout1 $$ layout2 799 | -- | otherwise = layout1 $+$ layout2 800 | 801 | fill :: Bool -> [Doc a] -> RDoc a 802 | fill _ [] = empty 803 | fill g (p:ps) = fill1 g (reduceDoc p) 0 ps 804 | 805 | fill1 :: Bool -> RDoc a -> Int -> [Doc a] -> Doc a 806 | fill1 _ _ k _ | k `seq` False = undefined 807 | fill1 _ NoDoc _ _ = NoDoc 808 | fill1 g (p `Union` q) k ys = fill1 g p k ys `union_` 809 | aboveNest q False k (fill g ys) 810 | fill1 g Empty k ys = mkNest k (fill g ys) 811 | fill1 g (Nest n p) k ys = nest_ n (fill1 g p (k - n) ys) 812 | fill1 g (NilAbove p) k ys = nilAbove_ (aboveNest p False k (fill g ys)) 813 | fill1 g (TextBeside s p) k ys = textBeside_ s (fillNB g p (k - annotSize s) ys) 814 | fill1 _ (Above {}) _ _ = error "fill1 Above" 815 | fill1 _ (Beside {}) _ _ = error "fill1 Beside" 816 | 817 | fillNB :: Bool -> Doc a -> Int -> [Doc a] -> Doc a 818 | fillNB _ _ k _ | k `seq` False = undefined 819 | fillNB g (Nest _ p) k ys = fillNB g p k ys 820 | -- Never triggered, because of invariant (2) 821 | fillNB _ Empty _ [] = Empty 822 | fillNB g Empty k (Empty:ys) = fillNB g Empty k ys 823 | fillNB g Empty k (y:ys) = fillNBE g k y ys 824 | fillNB g p k ys = fill1 g p k ys 825 | 826 | 827 | fillNBE :: Bool -> Int -> Doc a -> [Doc a] -> Doc a 828 | fillNBE g k y ys 829 | = nilBeside g (fill1 g ((elideNest . oneLiner . reduceDoc) y) k' ys) 830 | -- XXX: TODO: PRETTY: Used to use True here (but GHC used False...) 831 | `mkUnion` nilAboveNest False k (fill g (y:ys)) 832 | where k' = if g then k - 1 else k 833 | 834 | elideNest :: Doc a -> Doc a 835 | elideNest (Nest _ d) = d 836 | elideNest d = d 837 | 838 | 839 | -- --------------------------------------------------------------------------- 840 | -- Selecting the best layout 841 | 842 | best :: Int -- Line length. 843 | -> Int -- Ribbon length. 844 | -> RDoc a 845 | -> RDoc a -- No unions in here!. 846 | best w0 r = get w0 847 | where 848 | get w _ | w == 0 && False = undefined 849 | get _ Empty = Empty 850 | get _ NoDoc = NoDoc 851 | get w (NilAbove p) = nilAbove_ (get w p) 852 | get w (TextBeside s p) = textBeside_ s (get1 w (annotSize s) p) 853 | get w (Nest k p) = nest_ k (get (w - k) p) 854 | get w (p `Union` q) = nicest w r (get w p) (get w q) 855 | get _ (Above {}) = error "best get Above" 856 | get _ (Beside {}) = error "best get Beside" 857 | 858 | get1 w _ _ | w == 0 && False = undefined 859 | get1 _ _ Empty = Empty 860 | get1 _ _ NoDoc = NoDoc 861 | get1 w sl (NilAbove p) = nilAbove_ (get (w - sl) p) 862 | get1 w sl (TextBeside s p) = textBeside_ s (get1 w (sl + annotSize s) p) 863 | get1 w sl (Nest _ p) = get1 w sl p 864 | get1 w sl (p `Union` q) = nicest1 w r sl (get1 w sl p) 865 | (get1 w sl q) 866 | get1 _ _ (Above {}) = error "best get1 Above" 867 | get1 _ _ (Beside {}) = error "best get1 Beside" 868 | 869 | nicest :: Int -> Int -> Doc a -> Doc a -> Doc a 870 | nicest !w !r = nicest1 w r 0 871 | 872 | nicest1 :: Int -> Int -> Int -> Doc a -> Doc a -> Doc a 873 | nicest1 !w !r !sl p q | fits ((w `min` r) - sl) p = p 874 | | otherwise = q 875 | 876 | fits :: Int -- Space available 877 | -> Doc a 878 | -> Bool -- True if *first line* of Doc fits in space available 879 | fits n _ | n < 0 = False 880 | fits _ NoDoc = False 881 | fits _ Empty = True 882 | fits _ (NilAbove _) = True 883 | fits n (TextBeside s p) = fits (n - annotSize s) p 884 | fits _ (Above {}) = error "fits Above" 885 | fits _ (Beside {}) = error "fits Beside" 886 | fits _ (Union {}) = error "fits Union" 887 | fits _ (Nest {}) = error "fits Nest" 888 | 889 | -- | @first@ returns its first argument if it is non-empty, otherwise its 890 | -- second. 891 | first :: Doc a -> Doc a -> Doc a 892 | first p q | nonEmptySet p = p -- unused, because (get OneLineMode) is unused 893 | | otherwise = q 894 | 895 | nonEmptySet :: Doc a -> Bool 896 | nonEmptySet NoDoc = False 897 | nonEmptySet (_ `Union` _) = True 898 | nonEmptySet Empty = True 899 | nonEmptySet (NilAbove _) = True 900 | nonEmptySet (TextBeside _ p) = nonEmptySet p 901 | nonEmptySet (Nest _ p) = nonEmptySet p 902 | nonEmptySet (Above {}) = error "nonEmptySet Above" 903 | nonEmptySet (Beside {}) = error "nonEmptySet Beside" 904 | 905 | -- @oneLiner@ returns the one-line members of the given set of @GDoc@s. 906 | oneLiner :: Doc a -> Doc a 907 | oneLiner NoDoc = NoDoc 908 | oneLiner Empty = Empty 909 | oneLiner (NilAbove _) = NoDoc 910 | oneLiner (TextBeside s p) = textBeside_ s (oneLiner p) 911 | oneLiner (Nest k p) = nest_ k (oneLiner p) 912 | oneLiner (p `Union` _) = oneLiner p 913 | oneLiner (Above {}) = error "oneLiner Above" 914 | oneLiner (Beside {}) = error "oneLiner Beside" 915 | 916 | 917 | -- --------------------------------------------------------------------------- 918 | -- Rendering 919 | 920 | -- | A rendering style. Allows us to specify constraints to choose among the 921 | -- many different rendering options. 922 | data Style 923 | = Style { mode :: Mode 924 | -- ^ The rendering mode. 925 | , lineLength :: Int 926 | -- ^ Maximum length of a line, in characters. 927 | , ribbonsPerLine :: Float 928 | -- ^ Ratio of line length to ribbon length. A ribbon refers to the 929 | -- characters on a line /excluding/ indentation. So a 'lineLength' 930 | -- of 100, with a 'ribbonsPerLine' of @2.0@ would only allow up to 931 | -- 50 characters of ribbon to be displayed on a line, while 932 | -- allowing it to be indented up to 50 characters. 933 | } 934 | #if __GLASGOW_HASKELL__ >= 701 935 | deriving (Show, Eq, Generic) 936 | #endif 937 | 938 | -- | The default style (@mode=PageMode, lineLength=100, ribbonsPerLine=1.5@). 939 | style :: Style 940 | style = Style { lineLength = 100, ribbonsPerLine = 1.5, mode = PageMode } 941 | 942 | -- | Rendering mode. 943 | data Mode = PageMode 944 | -- ^ Normal rendering ('lineLength' and 'ribbonsPerLine' 945 | -- respected'). 946 | | ZigZagMode 947 | -- ^ With zig-zag cuts. 948 | | LeftMode 949 | -- ^ No indentation, infinitely long lines ('lineLength' ignored), 950 | -- but explicit new lines, i.e., @text "one" $$ text "two"@, are 951 | -- respected. 952 | | OneLineMode 953 | -- ^ All on one line, 'lineLength' ignored and explicit new lines 954 | -- (@$$@) are turned into spaces. 955 | #if __GLASGOW_HASKELL__ >= 701 || __MHS__ 956 | deriving (Show, Eq, Generic) 957 | #endif 958 | 959 | -- | Render the @Doc@ to a String using the default @Style@ (see 'style'). 960 | render :: Doc a -> String 961 | render = fullRender (mode style) (lineLength style) (ribbonsPerLine style) 962 | txtPrinter "" 963 | 964 | -- | Render the @Doc@ to a String using the given @Style@. 965 | renderStyle :: Style -> Doc a -> String 966 | renderStyle s = fullRender (mode s) (lineLength s) (ribbonsPerLine s) 967 | txtPrinter "" 968 | 969 | -- | Default TextDetails printer. 970 | txtPrinter :: TextDetails -> String -> String 971 | txtPrinter (Chr c) s = c:s 972 | txtPrinter (Str s1) s2 = s1 ++ s2 973 | txtPrinter (PStr s1) s2 = s1 ++ s2 974 | 975 | -- | The general rendering interface. Please refer to the @Style@ and @Mode@ 976 | -- types for a description of rendering mode, line length and ribbons. 977 | fullRender :: Mode -- ^ Rendering mode. 978 | -> Int -- ^ Line length. 979 | -> Float -- ^ Ribbons per line. 980 | -> (TextDetails -> a -> a) -- ^ What to do with text. 981 | -> a -- ^ What to do at the end. 982 | -> Doc b -- ^ The document. 983 | -> a -- ^ Result. 984 | fullRender m l r txt = fullRenderAnn m l r annTxt 985 | where 986 | annTxt (NoAnnot s _) = txt s 987 | annTxt _ = id 988 | 989 | -- | The general rendering interface, supporting annotations. Please refer to 990 | -- the @Style@ and @Mode@ types for a description of rendering mode, line 991 | -- length and ribbons. 992 | fullRenderAnn :: Mode -- ^ Rendering mode. 993 | -> Int -- ^ Line length. 994 | -> Float -- ^ Ribbons per line. 995 | -> (AnnotDetails b -> a -> a) -- ^ What to do with text. 996 | -> a -- ^ What to do at the end. 997 | -> Doc b -- ^ The document. 998 | -> a -- ^ Result. 999 | fullRenderAnn OneLineMode _ _ txt end doc 1000 | = easyDisplay spaceText (\_ y -> y) txt end (reduceDoc doc) 1001 | fullRenderAnn LeftMode _ _ txt end doc 1002 | = easyDisplay nlText first txt end (reduceDoc doc) 1003 | 1004 | fullRenderAnn m lineLen ribbons txt rest doc 1005 | = display m lineLen ribbonLen txt rest doc' 1006 | where 1007 | doc' = best bestLineLen ribbonLen (reduceDoc doc) 1008 | 1009 | bestLineLen, ribbonLen :: Int 1010 | ribbonLen = round (fromIntegral lineLen / ribbons) 1011 | bestLineLen = case m of 1012 | ZigZagMode -> maxBound 1013 | _ -> lineLen 1014 | 1015 | easyDisplay :: AnnotDetails b 1016 | -> (Doc b -> Doc b -> Doc b) 1017 | -> (AnnotDetails b -> a -> a) 1018 | -> a 1019 | -> Doc b 1020 | -> a 1021 | easyDisplay nlSpaceText choose txt end 1022 | = lay 1023 | where 1024 | lay NoDoc = error "easyDisplay: NoDoc" 1025 | lay (Union p q) = lay (choose p q) 1026 | lay (Nest _ p) = lay p 1027 | lay Empty = end 1028 | lay (NilAbove p) = nlSpaceText `txt` lay p 1029 | lay (TextBeside s p) = s `txt` lay p 1030 | lay (Above {}) = error "easyDisplay Above" 1031 | lay (Beside {}) = error "easyDisplay Beside" 1032 | 1033 | display :: Mode -> Int -> Int -> (AnnotDetails b -> a -> a) -> a -> Doc b -> a 1034 | display m !page_width !ribbon_width txt end doc 1035 | = case page_width - ribbon_width of { gap_width -> 1036 | case gap_width `quot` 2 of { shift -> 1037 | let 1038 | lay k _ | k `seq` False = undefined 1039 | lay k (Nest k1 p) = lay (k + k1) p 1040 | lay _ Empty = end 1041 | lay k (NilAbove p) = nlText `txt` lay k p 1042 | lay k (TextBeside s p) 1043 | = case m of 1044 | ZigZagMode | k >= gap_width 1045 | -> nlText `txt` ( 1046 | NoAnnot (Str (replicate shift '/')) shift `txt` ( 1047 | nlText `txt` 1048 | lay1 (k - shift) s p )) 1049 | 1050 | | k < 0 1051 | -> nlText `txt` ( 1052 | NoAnnot (Str (replicate shift '\\')) shift `txt` ( 1053 | nlText `txt` 1054 | lay1 (k + shift) s p )) 1055 | 1056 | _ -> lay1 k s p 1057 | 1058 | lay _ (Above {}) = error "display lay Above" 1059 | lay _ (Beside {}) = error "display lay Beside" 1060 | lay _ NoDoc = error "display lay NoDoc" 1061 | lay _ (Union {}) = error "display lay Union" 1062 | 1063 | lay1 !k s p = let !r = k + annotSize s 1064 | in NoAnnot (Str (indent k)) k `txt` (s `txt` lay2 r p) 1065 | 1066 | lay2 k _ | k `seq` False = undefined 1067 | lay2 k (NilAbove p) = nlText `txt` lay k p 1068 | lay2 k (TextBeside s p) = s `txt` lay2 (k + annotSize s) p 1069 | lay2 k (Nest _ p) = lay2 k p 1070 | lay2 _ Empty = end 1071 | lay2 _ (Above {}) = error "display lay2 Above" 1072 | lay2 _ (Beside {}) = error "display lay2 Beside" 1073 | lay2 _ NoDoc = error "display lay2 NoDoc" 1074 | lay2 _ (Union {}) = error "display lay2 Union" 1075 | in 1076 | lay 0 doc 1077 | }} 1078 | 1079 | 1080 | 1081 | -- Rendering Annotations ------------------------------------------------------- 1082 | 1083 | -- | A @Span@ represents the result of an annotation after a @Doc@ has been 1084 | -- rendered, capturing where the annotation now starts and ends in the rendered 1085 | -- output. 1086 | data Span a = Span { spanStart :: !Int 1087 | , spanLength :: !Int 1088 | , spanAnnotation :: a 1089 | } deriving (Show,Eq) 1090 | 1091 | instance Functor Span where 1092 | fmap f (Span x y a) = Span x y (f a) 1093 | 1094 | 1095 | -- State required for generating document spans. 1096 | data Spans a = Spans { sOffset :: !Int 1097 | -- ^ Current offset from the end of the document. 1098 | , sStack :: [Int -> Span a] 1099 | -- ^ Currently open spans. 1100 | , sSpans :: [Span a] 1101 | -- ^ Collected annotation regions. 1102 | , sOutput :: String 1103 | -- ^ Collected output. 1104 | } 1105 | 1106 | -- | Render an annotated @Doc@ to a String and list of annotations (see 'Span') 1107 | -- using the default @Style@ (see 'style'). 1108 | renderSpans :: Doc ann -> (String,[Span ann]) 1109 | renderSpans = finalize 1110 | . fullRenderAnn (mode style) (lineLength style) (ribbonsPerLine style) 1111 | spanPrinter 1112 | Spans { sOffset = 0, sStack = [], sSpans = [], sOutput = "" } 1113 | where 1114 | 1115 | finalize (Spans size _ spans out) = (out, map adjust spans) 1116 | where 1117 | adjust s = s { spanStart = size - spanStart s } 1118 | 1119 | mkSpan a end start = Span { spanStart = start 1120 | , spanLength = start - end 1121 | -- this seems wrong, but remember that it's 1122 | -- working backwards at this point 1123 | , spanAnnotation = a } 1124 | 1125 | -- the document gets generated in reverse, which is why the starting 1126 | -- annotation ends the annotation. 1127 | spanPrinter AnnotStart s = 1128 | case sStack s of 1129 | sp : rest -> s { sSpans = sp (sOffset s) : sSpans s, sStack = rest } 1130 | _ -> error "renderSpans: stack underflow" 1131 | 1132 | spanPrinter (AnnotEnd a) s = 1133 | s { sStack = mkSpan a (sOffset s) : sStack s } 1134 | 1135 | spanPrinter (NoAnnot td l) s = 1136 | case td of 1137 | Chr c -> s { sOutput = c : sOutput s, sOffset = sOffset s + l } 1138 | Str t -> s { sOutput = t ++ sOutput s, sOffset = sOffset s + l } 1139 | PStr t -> s { sOutput = t ++ sOutput s, sOffset = sOffset s + l } 1140 | 1141 | 1142 | -- | Render out a String, interpreting the annotations as part of the resulting 1143 | -- document. 1144 | -- 1145 | -- /IMPORTANT/: the size of the annotation string does NOT figure into the 1146 | -- layout of the document, so the document will lay out as though the 1147 | -- annotations are not present. 1148 | renderDecorated :: (ann -> String) -- ^ Starting an annotation. 1149 | -> (ann -> String) -- ^ Ending an annotation. 1150 | -> Doc ann -> String 1151 | renderDecorated startAnn endAnn = 1152 | finalize . fullRenderAnn (mode style) (lineLength style) (ribbonsPerLine style) 1153 | annPrinter 1154 | ("", []) 1155 | where 1156 | annPrinter AnnotStart (rest,stack) = 1157 | case stack of 1158 | a : as -> (startAnn a ++ rest, as) 1159 | _ -> error "renderDecorated: stack underflow" 1160 | 1161 | annPrinter (AnnotEnd a) (rest,stack) = 1162 | (endAnn a ++ rest, a : stack) 1163 | 1164 | annPrinter (NoAnnot s _) (rest,stack) = 1165 | (txtPrinter s rest, stack) 1166 | 1167 | finalize (str,_) = str 1168 | 1169 | 1170 | -- | Render a document with annotations, by interpreting the start and end of 1171 | -- the annotations, as well as the text details in the context of a monad. 1172 | renderDecoratedM :: Monad m 1173 | => (ann -> m r) -- ^ Starting an annotation. 1174 | -> (ann -> m r) -- ^ Ending an annotation. 1175 | -> (String -> m r) -- ^ Text formatting. 1176 | -> m r -- ^ Document end. 1177 | -> Doc ann -> m r 1178 | renderDecoratedM startAnn endAnn txt docEnd = 1179 | finalize . fullRenderAnn (mode style) (lineLength style) (ribbonsPerLine style) 1180 | annPrinter 1181 | (docEnd, []) 1182 | where 1183 | annPrinter AnnotStart (rest,stack) = 1184 | case stack of 1185 | a : as -> (startAnn a >> rest, as) 1186 | _ -> error "renderDecorated: stack underflow" 1187 | 1188 | annPrinter (AnnotEnd a) (rest,stack) = 1189 | (endAnn a >> rest, a : stack) 1190 | 1191 | annPrinter (NoAnnot td _) (rest,stack) = 1192 | case td of 1193 | Chr c -> (txt [c] >> rest, stack) 1194 | Str s -> (txt s >> rest, stack) 1195 | PStr s -> (txt s >> rest, stack) 1196 | 1197 | finalize (m,_) = m 1198 | 1199 | -- | Accepte a document with unit annotations and convert it to a document 1200 | -- of an arbitrary annotated type. Removes any existing annotations. 1201 | unitDocToAnnotatedDoc :: Doc () -> Doc a 1202 | unitDocToAnnotatedDoc (TextBeside AnnotStart d) 1203 | = unitDocToAnnotatedDoc d 1204 | unitDocToAnnotatedDoc (TextBeside (AnnotEnd _) d) 1205 | = unitDocToAnnotatedDoc d 1206 | unitDocToAnnotatedDoc (TextBeside (NoAnnot td n) d) 1207 | = TextBeside (NoAnnot td n) $ unitDocToAnnotatedDoc d 1208 | unitDocToAnnotatedDoc Empty 1209 | = Empty 1210 | unitDocToAnnotatedDoc NoDoc 1211 | = NoDoc 1212 | unitDocToAnnotatedDoc (Nest i d) 1213 | = Nest i $ unitDocToAnnotatedDoc d 1214 | unitDocToAnnotatedDoc (NilAbove d) 1215 | = NilAbove $ unitDocToAnnotatedDoc d 1216 | unitDocToAnnotatedDoc (Union a b) 1217 | = Union (unitDocToAnnotatedDoc a) (unitDocToAnnotatedDoc b) 1218 | unitDocToAnnotatedDoc (Beside a f b) 1219 | = Beside (unitDocToAnnotatedDoc a) f (unitDocToAnnotatedDoc b) 1220 | unitDocToAnnotatedDoc (Above a f b) 1221 | = Above (unitDocToAnnotatedDoc a) f (unitDocToAnnotatedDoc b) 1222 | --------------------------------------------------------------------------------