├── .gitignore ├── tests ├── T3911.stdout ├── all.T ├── pp1.stdout ├── PrettyTestVersion.hs ├── T3911.hs ├── pp1.hs ├── BugSep.hs ├── Bench1.hs ├── TestGenerators.hs ├── TestStructures.hs └── Test.hs ├── Setup.hs ├── README.md ├── pretty.cabal ├── LICENSE ├── src └── Text │ ├── PrettyPrint.hs │ └── PrettyPrint │ └── HughesPJ.hs ├── TODO └── CHANGELOG /.gitignore: -------------------------------------------------------------------------------- 1 | dist/ 2 | -------------------------------------------------------------------------------- /tests/T3911.stdout: -------------------------------------------------------------------------------- 1 | hello world 2 | hello world 3 | hello 4 | world 5 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Distribution.Simple 4 | 5 | main :: IO () 6 | main = defaultMain 7 | 8 | -------------------------------------------------------------------------------- /tests/all.T: -------------------------------------------------------------------------------- 1 | test('pp1', compose(expect_broken(1062), only_ways(['normal'])), compile_and_run, ['']) 2 | test('T3911', normal, compile_and_run, ['']) 3 | -------------------------------------------------------------------------------- /tests/pp1.stdout: -------------------------------------------------------------------------------- 1 | This output is not what is expected, becuase the 2 | test "works" now, by virtue of a hack in HughesPJ.spaces. 3 | I'm leaving this strange output here to remind us to look 4 | at the root cause of the problem. Sometime. -------------------------------------------------------------------------------- /tests/PrettyTestVersion.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | #define TESTING 4 | 5 | -- | Here we use some CPP hackery to get a whitebox 6 | -- version of HughesPJ for testing purposes. 7 | module PrettyTestVersion where 8 | 9 | #include "HughesPJ.hs" 10 | 11 | -------------------------------------------------------------------------------- /tests/T3911.hs: -------------------------------------------------------------------------------- 1 | 2 | module Main where 3 | 4 | import Text.PrettyPrint.HughesPJ 5 | 6 | xs :: [Doc] 7 | xs = [text "hello", 8 | nest 10 (text "world")] 9 | 10 | d1 :: Doc 11 | d1 = vcat xs 12 | 13 | d2 :: Doc 14 | d2 = foldr ($$) empty xs 15 | 16 | d3 :: Doc 17 | d3 = foldr ($+$) empty xs 18 | 19 | main :: IO () 20 | main = do print d1 21 | print d2 22 | print d3 23 | 24 | -------------------------------------------------------------------------------- /tests/pp1.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 | 7 | module Main where 8 | 9 | import Text.PrettyPrint.HughesPJ 10 | 11 | 12 | ncat x y = nest 4 $ cat [ x, y ] 13 | 14 | d1 = foldl1 ncat $ take 50 $ repeat $ char 'a' 15 | d2 = parens $ sep [ d1, text "+" , d1 ] 16 | 17 | main = print d2 18 | 19 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Pretty : A Haskell Pretty-printer library 2 | ------------------------------------------------------------------------------ 3 | This repository contains a pretty-printing library, a set of API's that 4 | provides a way to easily print out text in a consistent format of your 5 | choosing. This is useful for compilers and related tools. The library was 6 | originally designed by John Hughes's and has since been heavily modified by 7 | Simon Peyton Jones. 8 | 9 | It is based on the pretty-printer outlined in the paper 'The Design of a 10 | Pretty-printing Library' in Advanced Functional Programming, Johan Jeuring and 11 | Erik Meijer (eds), LNCS 925 12 | 13 | The library uses the Cabal build system, so building is simply a matter of 14 | running 'cabal install' or 'cabal configure && cabal build'. 15 | 16 | Usually two branches are maintained for Pretty development: 17 | 18 | * master: This branch is generally kept in a stable state and is where 19 | release are pulled and made from. The reason for this is GHC includes 20 | the pretty library and tracks the master branch by default so we don't 21 | want experimental code being pulled into GHC at times. 22 | 23 | * next: This branch is the general development branch. 24 | 25 | -------------------------------------------------------------------------------- /tests/BugSep.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Text.PrettyPrint.HughesPJ 4 | 5 | main :: IO () 6 | main = do 7 | putStrLn "" 8 | putStrLn "Note that the correct definition of sep is currently unclear" 9 | putStrLn "It is neither foldr ($+$) empty nor foldr ($$) empty" 10 | putStrLn "------------------------------------------------------------" 11 | let test1 = [ text "" $+$ text "c", nest 3 ( text "a") ] 12 | let test2 = [ text "c", nest 3 ( text "b") ] 13 | putStrLn "--------------------------Test 1----------------------------" 14 | putStrLn "[ text \"\" $+$ text \"c\", nest 3 ( text \"a\") ]" 15 | putStrLn "-----------------------------sep----------------------------" 16 | print $ renderStyle style{lineLength=1} $ sep test1 17 | putStrLn "-----------------------------<+>----------------------------" 18 | print $ renderStyle style{lineLength=1} $ foldr (<+>) empty test1 19 | putStrLn "-----------------------------$+$----------------------------" 20 | print $ renderStyle style{lineLength=1} $ foldr ($+$) empty test1 21 | putStrLn "------------------------------$$----------------------------" 22 | print $ renderStyle style{lineLength=1} $ foldr ($$) empty test1 23 | putStrLn "--------------------------Test 2----------------------------" 24 | putStrLn "[ text \"c\", nest 3 ( text \"b\") ]" 25 | putStrLn "-----------------------------sep----------------------------" 26 | print $ renderStyle style{lineLength=1} $ sep test2 27 | putStrLn "-----------------------------<+>----------------------------" 28 | print $ renderStyle style{lineLength=1} $ foldr (<+>) empty test2 29 | putStrLn "-----------------------------$+$----------------------------" 30 | print $ renderStyle style{lineLength=1} $ foldr ($+$) empty test2 31 | putStrLn "------------------------------$$----------------------------" 32 | print $ renderStyle style{lineLength=1} $ foldr ($$) empty test2 33 | 34 | -------------------------------------------------------------------------------- /pretty.cabal: -------------------------------------------------------------------------------- 1 | name: pretty 2 | version: 1.1.1.0 3 | synopsis: Pretty-printing library 4 | description: 5 | This package contains a pretty-printing library, a set of API's 6 | that provides a way to easily print out text in a consistent 7 | format of your choosing. This is useful for compilers and related 8 | tools. 9 | . 10 | This library was originally designed by John Hughes's and has since 11 | been heavily modified by Simon Peyton Jones. 12 | 13 | license: BSD3 14 | license-file: LICENSE 15 | category: Text 16 | maintainer: David Terei 17 | homepage: http://github.com/haskell/pretty 18 | bug-reports: http://hackage.haskell.org/trac/ghc/newticket?component=libraries/pretty 19 | stability: Stable 20 | build-type: Simple 21 | Extra-Source-Files: README CHANGELOG 22 | Cabal-Version: >= 1.8 23 | 24 | source-repository head 25 | type: git 26 | location: http://github.com/haskell/pretty.git 27 | 28 | Library 29 | hs-source-dirs: src 30 | exposed-modules: 31 | Text.PrettyPrint 32 | Text.PrettyPrint.HughesPJ 33 | build-depends: base >= 3 && < 5 34 | extensions: CPP, BangPatterns 35 | ghc-options: -Wall -fwarn-tabs 36 | 37 | Test-Suite test-pretty 38 | type: exitcode-stdio-1.0 39 | hs-source-dirs: tests 40 | src 41 | build-depends: base >= 3 && < 5, 42 | QuickCheck == 2.* 43 | main-is: Test.hs 44 | other-modules: 45 | TestGenerators 46 | TestStructures 47 | extensions: CPP, BangPatterns 48 | include-dirs: src/Text/PrettyPrint 49 | 50 | -- Executable Bench1 51 | -- main-is: Bench1.hs 52 | -- hs-source-dirs: test 53 | -- src 54 | -- other-modules: 55 | -- Text.PrettyPrint 56 | -- Text.PrettyPrint.HughesPJ 57 | -- extensions: CPP, BangPatterns 58 | -- ghc-options: -O -fwarn-tabs 59 | 60 | -------------------------------------------------------------------------------- /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/Bench1.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Text.PrettyPrint.HughesPJ 4 | 5 | stuff :: String -> String -> Double -> Rational -> Int -> Int -> Int -> Doc 6 | stuff s1 s2 d1 r1 i1 i2 i3 = 7 | let a = nest i1 $ text s1 8 | b = double d1 9 | c = rational r1 10 | d = replicate i1 (text s2 <> b <> c <+> a) 11 | e = cat d $+$ cat d $$ (c <> b <+> a) 12 | f = parens e <> brackets c <> hcat d 13 | g = lparen <> f <> rparen 14 | h = text $ s2 ++ s1 15 | i = map rational ([1..(toRational i2)]::[Rational]) 16 | j = punctuate comma i 17 | k = nest i3 h <> (nest (i1 + i3) $ sep i) $+$ g <> cat j 18 | l = cat $ punctuate (comma <> b <> comma) $ replicate i3 k 19 | in l 20 | 21 | doc1 :: Doc 22 | doc1 = stuff "Adsas ads" "dassdab weeaa xxxxx" 123.231321 ((-1)/5) 30 300 20 23 | 24 | doc2 :: Doc 25 | doc2 = stuff "aDSAS ADS asdasdsa sdsda xx" "SDAB WEEAA" 1333.212 ((-4)/5) 31 301 30 26 | 27 | doc3 :: Doc 28 | doc3 = stuff "ADsAs --____ aDS" "DasSdAB weEAA" 2533.21299 ((-4)/999) 39 399 60 29 | 30 | {- 31 | txt :: TextDetails -> String -> String 32 | txt (Chr c) s = c:s 33 | txt (Str s1) s2 = s1 ++ s2 34 | -} 35 | 36 | main :: IO () 37 | main = do 38 | putStrLn "===================================================" 39 | putStrLn $ render doc1 40 | {- 41 | putStrLn "===================================================" 42 | putStrLn $ fullRender PageMode 1000 4 txt "" doc2 43 | putStrLn "===================================================" 44 | putStrLn $ fullRender PageMode 100 1.5 txt "" doc2 45 | putStrLn "===================================================" 46 | putStrLn $ fullRender ZigZagMode 1000 4 txt "" doc2 47 | putStrLn "===================================================" 48 | putStrLn $ fullRender LeftMode 1000 4 txt "" doc2 49 | putStrLn "===================================================" 50 | putStrLn $ fullRender OneLineMode 1000 4 txt "" doc3 51 | putStrLn "===================================================" 52 | -} 53 | putStrLn $ render doc3 54 | 55 | 56 | -------------------------------------------------------------------------------- /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 | -- The default interface to the pretty-printing library. Provides a collection 15 | -- of pretty printer combinators. 16 | -- 17 | -- This module should be used as opposed to the "Text.PrettyPrint.HughesPJ" 18 | -- module. Both are equivalent though as this module simply re-exports the 19 | -- other. 20 | -- 21 | ----------------------------------------------------------------------------- 22 | 23 | module Text.PrettyPrint ( 24 | 25 | -- * The document type 26 | Doc, 27 | 28 | -- * Constructing documents 29 | 30 | -- ** Converting values into documents 31 | char, text, ptext, sizedText, zeroWidthText, 32 | int, integer, float, double, rational, 33 | 34 | -- ** Simple derived documents 35 | semi, comma, colon, space, equals, 36 | lparen, rparen, lbrack, rbrack, lbrace, rbrace, 37 | 38 | -- ** Wrapping documents in delimiters 39 | parens, brackets, braces, quotes, doubleQuotes, 40 | 41 | -- ** Combining documents 42 | empty, 43 | (<>), (<+>), hcat, hsep, 44 | ($$), ($+$), vcat, 45 | sep, cat, 46 | fsep, fcat, 47 | nest, 48 | hang, punctuate, 49 | 50 | -- * Predicates on documents 51 | isEmpty, 52 | 53 | -- * Rendering documents 54 | 55 | -- ** Default rendering 56 | render, 57 | 58 | -- ** Rendering with a particular style 59 | Style(..), 60 | style, 61 | renderStyle, 62 | 63 | -- ** General rendering 64 | fullRender, 65 | Mode(..), TextDetails(..) 66 | 67 | ) where 68 | 69 | import Text.PrettyPrint.HughesPJ 70 | 71 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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', tdToStr, genericCProp 13 | ) where 14 | 15 | import PrettyTestVersion 16 | 17 | data CDoc = CEmpty -- empty 18 | | CText String -- text s 19 | | CList CList [CDoc] -- cat,sep,fcat,fsep ds 20 | | CBeside Bool CDoc CDoc -- a <> b and a <+> b 21 | | CAbove Bool CDoc CDoc -- a $$ b and a $+$ b 22 | | CNest Int CDoc -- nest k d 23 | deriving (Eq, Ord) 24 | 25 | data CList = CCat | CSep | CFCat | CFSep deriving (Eq,Ord) 26 | 27 | newtype CDocList = CDocList { unDocList :: [CDoc] } 28 | 29 | -- wrapper for String argument of `text' 30 | newtype Text = Text { unText :: String } deriving (Eq, Ord, Show) 31 | 32 | instance Show CDoc where 33 | showsPrec k CEmpty = showString "empty" 34 | showsPrec k (CText s) = showParen (k >= 10) (showString " text " . shows s) 35 | showsPrec k (CList sp ds) = showParen (k >= 10) $ (shows sp . showList ds) 36 | showsPrec k (CBeside sep d1 d2) = showParen (k >= 6) $ 37 | (showsPrec 6 d1) . showString (if sep then " <+> " else " <> ") . (showsPrec 6 d2) 38 | showsPrec k (CAbove noOvlap d1 d2) = showParen (k >= 5) $ 39 | (showsPrec 5 d1) . showString (if noOvlap then " $+$ " else " $$ ") . (showsPrec 5 d2) 40 | showsPrec k (CNest n d) = showParen (k >= 10) $ showString " nest " . showsPrec 10 n . showString " ". showsPrec 10 d 41 | 42 | instance Show CList where 43 | show cs = case cs of CCat -> "cat" ; CSep -> "sep" ; CFCat -> "fcat" ; CFSep -> "fsep" 44 | 45 | instance Show CDocList where show = show . unDocList 46 | 47 | buildDoc :: CDoc -> Doc 48 | buildDoc CEmpty = empty 49 | buildDoc (CText s) = text s 50 | buildDoc (CList sp ds) = (listComb sp) $ map buildDoc ds 51 | buildDoc (CBeside sep d1 d2) = (if sep then (<+>) else (<>)) (buildDoc d1) (buildDoc d2) 52 | buildDoc (CAbove noOvlap d1 d2) = (if noOvlap then ($+$) else ($$)) (buildDoc d1) (buildDoc d2) 53 | buildDoc (CNest k d) = nest k $ buildDoc d 54 | 55 | listComb :: CList -> ([Doc] -> Doc) 56 | listComb cs = case cs of CCat -> cat ; CSep -> sep ; CFCat -> fcat ; CFSep -> fsep 57 | 58 | liftDoc2 :: (Doc -> Doc -> a) -> (CDoc -> CDoc -> a) 59 | liftDoc2 f cd1 cd2 = f (buildDoc cd1) (buildDoc cd2) 60 | 61 | liftDoc3 :: (Doc -> Doc -> Doc -> a) -> (CDoc -> CDoc -> CDoc -> a) 62 | liftDoc3 f cd1 cd2 cd3 = f (buildDoc cd1) (buildDoc cd2) (buildDoc cd3) 63 | 64 | buildDocList :: CDocList -> [Doc] 65 | buildDocList = map buildDoc . unDocList 66 | 67 | text' :: Text -> Doc 68 | text' (Text str) = text str 69 | 70 | -- convert text details to string 71 | tdToStr :: TextDetails -> String 72 | tdToStr (Chr c) = [c] 73 | tdToStr (Str s) = s 74 | tdToStr (PStr s) = s 75 | 76 | -- synthesize with stop for cdoc 77 | -- constructor order 78 | genericCProp :: (a -> a -> a) -> (CDoc -> (a, Bool)) -> CDoc -> a 79 | genericCProp c q cdoc = 80 | case q cdoc of 81 | (v,False) -> v 82 | (v,True) -> foldl c v subs 83 | where 84 | rec = genericCProp c q 85 | subs = case cdoc of 86 | CEmpty -> [] 87 | CText _ -> [] 88 | CList _ ds -> map rec ds 89 | CBeside _ d1 d2 -> [rec d1, rec d2] 90 | CAbove b d1 d2 -> [rec d1, rec d2] 91 | CNest k d -> [rec d] 92 | 93 | -------------------------------------------------------------------------------- /TODO: -------------------------------------------------------------------------------- 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 | =========================================================== 22 | 23 | dcoutts davidt_: are you sure that using a typeclass is faster than TextDetails? 24 | 25 | dcoutts davidt_: why not just add PStr back in? 26 | 27 | dcoutts davidt_: you can already generate different output types by using the fold (TextDetails -> a -> a) 28 | 29 | dcoutts e.g. using the Text builder or the new bytestring builder 30 | 31 | davidt_ dcoutts: So far it seems as fast but I need to do more testing, hence I haven't pushed anything yet 32 | 33 | 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 34 | 35 | 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 36 | 37 | dcoutts davidt_: the problem with the typeclass is the leakage 38 | 39 | dcoutts that extra type param leaks out into everything 40 | 41 | dcoutts davidt_: and it doesn't mean you have to change LItString to be a ByteString 42 | 43 | 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 44 | 45 | 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 46 | 47 | dcoutts I think we overuse typeclasses 48 | 49 | dcoutts davidt_: it means your pretty printing function producing a Doc will not be compatible with mine 50 | 51 | dcoutts davidt_: since you'll use GDoc This and I'll use GDoc That... 52 | 53 | dcoutts and in this case it is for variation that isn't really needed 54 | dcoutts it's to cope with the proliferation of string types 55 | dcoutts when we should just not have so many string types 56 | dcoutts davidt_: so how about using TextDetails with constructors for Char, String, Text and ByteString 57 | 58 | davidt_ Hmm I'll look into it I guess. 59 | 60 | 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. 61 | 62 | davidt_ but I agree that we have too many string types 63 | 64 | davidt_ so I am tempted by that argument not to encourage it further 65 | 66 | dcoutts davidt_: btw, I expect you can convert a ghc LItString into a ByteString quite easily and cheaply 67 | 68 | dcoutts davidt_: or are they unpinned ByteArr#s? 69 | 70 | davidt_ dcoutts: Yes you probably can. Had a brief discussion about this with Simon Marlow. 71 | 72 | dcoutts davidt_: so there's a couple other options here 73 | 74 | dcoutts davidt_: you can fix the output type and allow any input string type that can be converted into it 75 | 76 | 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 77 | 78 | dcoutts davidt_: but allowing both means that the internal type arg has to become visible (which is the bad option imho) 79 | 80 | 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 81 | 82 | dcoutts ptext :: (a -> Builder) -> a -> doc 83 | 84 | 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 85 | 86 | dcoutts and the IO case is only an illusion of performance, the builder monoid will be a lot faster 87 | 88 | dcoutts davidt_: because a builder monoid is writing directly into a buffer too, but unlike an IO handle, there's no MVar locking overhead 89 | 90 | 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 91 | 92 | dcoutts davidt_: the next bytestring release will have a fast builder monoid 93 | 94 | dcoutts davidt_: and text has one already 95 | 96 | -------------------------------------------------------------------------------- /CHANGELOG: -------------------------------------------------------------------------------- 1 | ======== CHANGE LOG ========== 2 | 3 | Pretty library change log. 4 | 5 | ========= Version 4.0, 24 August 2011 ========== 6 | 7 | * Big change to the structure of the library. Now we don't have a fixed 8 | TextDetails data type for storing the various String types that we 9 | support. Instead we have changed that to be a type class that just 10 | provides a way to convert String and Chars to an arbitary type. This 11 | arbitary type is now provided by the user of the library so that they 12 | can implement support very easily for any String type they want. 13 | 14 | This new code lives in Text.PrettyPrint.Core and the Text.PrettyPrint 15 | module uses it to implement the old API. The Text.PrettyPrint.HughesPJ 16 | module has been left unchanged for a compatability module but deprecated. 17 | 18 | ========= Version 3.0, 28 May 1987 ========== 19 | 20 | * Cured massive performance bug. If you write: 21 | 22 | foldl <> empty (map (text.show) [1..10000]) 23 | 24 | You get quadratic behaviour with V2.0. Why? For just the same 25 | reason as you get quadratic behaviour with left-associated (++) 26 | chains. 27 | 28 | This is really bad news. One thing a pretty-printer abstraction 29 | should certainly guarantee is insensitivity to associativity. It 30 | matters: suddenly GHC's compilation times went up by a factor of 31 | 100 when I switched to the new pretty printer. 32 | 33 | I fixed it with a bit of a hack (because I wanted to get GHC back 34 | on the road). I added two new constructors to the Doc type, Above 35 | and Beside: 36 | 37 | <> = Beside 38 | $$ = Above 39 | 40 | Then, where I need to get to a "TextBeside" or "NilAbove" form I 41 | "force" the Doc to squeeze out these suspended calls to Beside and 42 | Above; but in so doing I re-associate. It's quite simple, but I'm 43 | not satisfied that I've done the best possible job. I'll send you 44 | the code if you are interested. 45 | 46 | * Added new exports: 47 | punctuate, hang 48 | int, integer, float, double, rational, 49 | lparen, rparen, lbrack, rbrack, lbrace, rbrace, 50 | 51 | * fullRender's type signature has changed. Rather than producing a 52 | string it now takes an extra couple of arguments that tells it how 53 | to glue fragments of output together: 54 | 55 | fullRender :: Mode 56 | -> Int -- Line length 57 | -> Float -- Ribbons per line 58 | -> (TextDetails -> a -> a) -- What to do with text 59 | -> a -- What to do at the end 60 | -> Doc 61 | -> a -- Result 62 | 63 | The "fragments" are encapsulated in the TextDetails data type: 64 | 65 | data TextDetails = Chr Char 66 | | Str String 67 | | PStr FAST_STRING 68 | 69 | The Chr and Str constructors are obvious enough. The PStr 70 | constructor has a packed string (FAST_STRING) inside it. It's 71 | generated by using the new "ptext" export. 72 | 73 | An advantage of this new setup is that you can get the renderer to 74 | do output directly (by passing in a function of type (TextDetails 75 | -> IO () -> IO ()), rather than producing a string that you then 76 | print. 77 | 78 | 79 | 80 | ========= Version 3.0, 28 May 1987 ========== 81 | 82 | * Made empty into a left unit for <> as well as a right unit; 83 | it is also now true that 84 | nest k empty = empty 85 | which wasn't true before. 86 | 87 | * Fixed an obscure bug in sep that occasionally gave very weird behaviour 88 | 89 | * Added $+$ 90 | 91 | * Corrected and tidied up the laws and invariants 92 | 93 | 94 | 95 | ========= Version 1.0 ========== 96 | 97 | Relative to John's original paper, there are the following new features: 98 | 99 | 1. There's an empty document, "empty". It's a left and right unit for 100 | both <> and $$, and anywhere in the argument list for 101 | sep, hcat, hsep, vcat, fcat etc. 102 | 103 | It is Really Useful in practice. 104 | 105 | 2. There is a paragraph-fill combinator, fsep, that's much like sep, 106 | only it keeps fitting things on one line until it can't fit any more. 107 | 108 | 3. Some random useful extra combinators are provided. 109 | <+> puts its arguments beside each other with a space between them, 110 | unless either argument is empty in which case it returns the other 111 | 112 | 113 | hcat is a list version of <> 114 | hsep is a list version of <+> 115 | vcat is a list version of $$ 116 | 117 | sep (separate) is either like hsep or like vcat, depending on what fits 118 | 119 | cat behaves like sep, but it uses <> for horizontal composition 120 | fcat behaves like fsep, but it uses <> for horizontal composition 121 | 122 | These new ones do the obvious things: 123 | char, semi, comma, colon, space, 124 | parens, brackets, braces, 125 | quotes, doubleQuotes 126 | 127 | 4. The "above" combinator, $$, now overlaps its two arguments if the 128 | last line of the top argument stops before the first line of the 129 | second begins. 130 | 131 | For example: text "hi" $$ nest 5 (text "there") 132 | lays out as 133 | hi there 134 | rather than 135 | hi 136 | there 137 | 138 | There are two places this is really useful 139 | 140 | a) When making labelled blocks, like this: 141 | Left -> code for left 142 | Right -> code for right 143 | LongLongLongLabel -> 144 | code for longlonglonglabel 145 | The block is on the same line as the label if the label is 146 | short, but on the next line otherwise. 147 | 148 | b) When laying out lists like this: 149 | [ first 150 | , second 151 | , third 152 | ] 153 | which some people like. But if the list fits on one line you 154 | want [first, second, third]. You can't do this with John's 155 | original combinators, but it's quite easy with the new $$. 156 | 157 | The combinator $+$ gives the original "never-overlap" behaviour. 158 | 159 | 5. Several different renderers are provided: 160 | * a standard one 161 | * one that uses cut-marks to avoid deeply-nested documents 162 | simply piling up in the right-hand margin 163 | * one that ignores indentation (fewer chars output; good for machines) 164 | * one that ignores indentation and newlines (ditto, only more so) 165 | 166 | 6. Numerous implementation tidy-ups 167 | Use of unboxed data types to speed up the implementation 168 | 169 | 170 | -------------------------------------------------------------------------------- /src/Text/PrettyPrint/HughesPJ.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK not-home #-} 2 | {-# LANGUAGE BangPatterns #-} 3 | #if __GLASGOW_HASKELL__ >= 701 4 | {-# LANGUAGE Safe #-} 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 | -- John Hughes's and Simon Peyton Jones's Pretty Printer Combinators 18 | -- 19 | -- Based on /The Design of a Pretty-printing Library/ 20 | -- in Advanced Functional Programming, 21 | -- Johan Jeuring and Erik Meijer (eds), LNCS 925 22 | -- 23 | -- 24 | ----------------------------------------------------------------------------- 25 | 26 | #ifndef TESTING 27 | module Text.PrettyPrint.HughesPJ ( 28 | 29 | -- * The document type 30 | Doc, TextDetails(..), 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 | (<>), (<+>), hcat, hsep, 48 | ($$), ($+$), vcat, 49 | sep, cat, 50 | fsep, fcat, 51 | nest, 52 | hang, punctuate, 53 | 54 | -- * Predicates on documents 55 | isEmpty, 56 | 57 | -- * Utility functions for documents 58 | first, reduceDoc, 59 | -- TODO: Should these be exported? Previously they weren't 60 | 61 | -- * Rendering documents 62 | 63 | -- ** Default rendering 64 | render, 65 | 66 | -- ** Rendering with a particular style 67 | Style(..), 68 | style, 69 | renderStyle, 70 | Mode(..), 71 | 72 | -- ** General rendering 73 | fullRender 74 | 75 | ) where 76 | #endif 77 | 78 | import Data.Monoid ( Monoid(mempty, mappend) ) 79 | import Data.String ( IsString(fromString) ) 80 | 81 | -- --------------------------------------------------------------------------- 82 | -- The Doc calculus 83 | 84 | {- 85 | Laws for $$ 86 | ~~~~~~~~~~~ 87 | (x $$ y) $$ z = x $$ (y $$ z) 88 | empty $$ x = x 89 | x $$ empty = x 90 | 91 | ...ditto $+$... 92 | 93 | Laws for <> 94 | ~~~~~~~~~~~ 95 | (x <> y) <> z = x <> (y <> z) 96 | empty <> x = empty 97 | x <> empty = x 98 | 99 | ...ditto <+>... 100 | 101 | Laws for text 102 | ~~~~~~~~~~~~~ 103 | text s <> text t = text (s++t) 104 | text "" <> x = x, if x non-empty 105 | 106 | ** because of law n6, t2 only holds if x doesn't 107 | ** start with `nest'. 108 | 109 | 110 | Laws for nest 111 | ~~~~~~~~~~~~~ 112 | nest 0 x = x 113 | nest k (nest k' x) = nest (k+k') x 114 | nest k (x <> y) = nest k x <> nest k y 115 | nest k (x $$ y) = nest k x $$ nest k y 116 | nest k empty = empty 117 | x <> nest k y = x <> y, if x non-empty 118 | 119 | ** Note the side condition on ! It is this that 120 | ** makes it OK for empty to be a left unit for <>. 121 | 122 | Miscellaneous 123 | ~~~~~~~~~~~~~ 124 | (text s <> x) $$ y = text s <> ((text "" <> x) $$ 125 | nest (-length s) y) 126 | 127 | (x $$ y) <> z = x $$ (y <> z) 128 | if y non-empty 129 | 130 | 131 | Laws for list versions 132 | ~~~~~~~~~~~~~~~~~~~~~~ 133 | sep (ps++[empty]++qs) = sep (ps ++ qs) 134 | ...ditto hsep, hcat, vcat, fill... 135 | 136 | nest k (sep ps) = sep (map (nest k) ps) 137 | ...ditto hsep, hcat, vcat, fill... 138 | 139 | Laws for oneLiner 140 | ~~~~~~~~~~~~~~~~~ 141 | oneLiner (nest k p) = nest k (oneLiner p) 142 | oneLiner (x <> y) = oneLiner x <> oneLiner y 143 | 144 | You might think that the following verion of would 145 | be neater: 146 | 147 | <3 NO> (text s <> x) $$ y = text s <> ((empty <> x)) $$ 148 | nest (-length s) y) 149 | 150 | But it doesn't work, for if x=empty, we would have 151 | 152 | text s $$ y = text s <> (empty $$ nest (-length s) y) 153 | = text s <> nest (-length s) y 154 | -} 155 | 156 | -- --------------------------------------------------------------------------- 157 | -- Operator fixity 158 | 159 | infixl 6 <> 160 | infixl 6 <+> 161 | infixl 5 $$, $+$ 162 | 163 | -- --------------------------------------------------------------------------- 164 | -- The Doc data type 165 | 166 | -- | The abstract type of documents. 167 | -- A Doc represents a *set* of layouts. A Doc with 168 | -- no occurrences of Union or NoDoc represents just one layout. 169 | data Doc 170 | = Empty -- empty 171 | | NilAbove Doc -- text "" $$ x 172 | | TextBeside !TextDetails {-# UNPACK #-} !Int Doc -- text s <> x 173 | | Nest {-# UNPACK #-} !Int Doc -- nest k x 174 | | Union Doc Doc -- ul `union` ur 175 | | NoDoc -- The empty set of documents 176 | | Beside Doc Bool Doc -- True <=> space between 177 | | Above Doc Bool Doc -- True <=> never overlap 178 | 179 | {- 180 | Here are the invariants: 181 | 182 | 1) The argument of NilAbove is never Empty. Therefore 183 | a NilAbove occupies at least two lines. 184 | 185 | 2) The argument of @TextBeside@ is never @Nest@. 186 | 187 | 3) The layouts of the two arguments of @Union@ both flatten to the same 188 | string. 189 | 190 | 4) The arguments of @Union@ are either @TextBeside@, or @NilAbove@. 191 | 192 | 5) A @NoDoc@ may only appear on the first line of the left argument of an 193 | union. Therefore, the right argument of an union can never be equivalent 194 | to the empty set (@NoDoc@). 195 | 196 | 6) An empty document is always represented by @Empty@. It can't be 197 | hidden inside a @Nest@, or a @Union@ of two @Empty@s. 198 | 199 | 7) The first line of every layout in the left argument of @Union@ is 200 | longer than the first line of any layout in the right argument. 201 | (1) ensures that the left argument has a first line. In view of 202 | (3), this invariant means that the right argument must have at 203 | least two lines. 204 | 205 | Notice the difference between 206 | * NoDoc (no documents) 207 | * Empty (one empty document; no height and no width) 208 | * text "" (a document containing the empty string; 209 | one line high, but has no width) 210 | -} 211 | 212 | 213 | -- | RDoc is a "reduced GDoc", guaranteed not to have a top-level Above or Beside. 214 | type RDoc = Doc 215 | 216 | -- | The TextDetails data type 217 | -- 218 | -- A TextDetails represents a fragment of text that will be 219 | -- output at some point. 220 | data TextDetails = Chr {-# UNPACK #-} !Char -- ^ A single Char fragment 221 | | Str String -- ^ A whole String fragment 222 | | PStr String -- ^ Used to represent a Fast String fragment 223 | -- but now deprecated and identical to the 224 | -- Str constructor. 225 | 226 | -- Combining @Doc@ values 227 | instance Monoid Doc where 228 | mempty = empty 229 | mappend = (<>) 230 | 231 | instance IsString Doc where 232 | fromString = text 233 | 234 | instance Show Doc where 235 | showsPrec _ doc cont = fullRender (mode style) (lineLength style) 236 | (ribbonsPerLine style) 237 | txtPrinter cont doc 238 | 239 | -- --------------------------------------------------------------------------- 240 | -- Values and Predicates on GDocs and TextDetails 241 | 242 | -- | A document of height and width 1, containing a literal character. 243 | char :: Char -> Doc 244 | char c = textBeside_ (Chr c) 1 Empty 245 | 246 | -- | A document of height 1 containing a literal string. 247 | -- 'text' satisfies the following laws: 248 | -- 249 | -- * @'text' s '<>' 'text' t = 'text' (s'++'t)@ 250 | -- 251 | -- * @'text' \"\" '<>' x = x@, if @x@ non-empty 252 | -- 253 | -- The side condition on the last law is necessary because @'text' \"\"@ 254 | -- has height 1, while 'empty' has no height. 255 | text :: String -> Doc 256 | text s = case length s of {sl -> textBeside_ (Str s) sl Empty} 257 | 258 | -- | Same as @text@. Used to be used for Bytestrings. 259 | ptext :: String -> Doc 260 | ptext s = case length s of {sl -> textBeside_ (PStr s) sl Empty} 261 | 262 | -- | Some text with any width. (@text s = sizedText (length s) s@) 263 | sizedText :: Int -> String -> Doc 264 | sizedText l s = textBeside_ (Str s) l Empty 265 | 266 | -- | Some text, but without any width. Use for non-printing text 267 | -- such as a HTML or Latex tags 268 | zeroWidthText :: String -> Doc 269 | zeroWidthText = sizedText 0 270 | 271 | -- | The empty document, with no height and no width. 272 | -- 'empty' is the identity for '<>', '<+>', '$$' and '$+$', and anywhere 273 | -- in the argument list for 'sep', 'hcat', 'hsep', 'vcat', 'fcat' etc. 274 | empty :: Doc 275 | empty = Empty 276 | 277 | -- | Returns 'True' if the document is empty 278 | isEmpty :: Doc -> Bool 279 | isEmpty Empty = True 280 | isEmpty _ = False 281 | 282 | -- | Produce spacing for indenting the amount specified. 283 | -- 284 | -- an old version inserted tabs being 8 columns apart in the output. 285 | indent :: Int -> String 286 | indent !n = replicate n ' ' 287 | 288 | {- 289 | Q: What is the reason for negative indentation (i.e. argument to indent 290 | is < 0) ? 291 | 292 | A: 293 | This indicates an error in the library client's code. 294 | If we compose a <> b, and the first line of b is more indented than some 295 | other lines of b, the law (<> eats nests) may cause the pretty 296 | printer to produce an invalid layout: 297 | 298 | doc |0123345 299 | ------------------ 300 | d1 |a...| 301 | d2 |...b| 302 | |c...| 303 | 304 | d1<>d2 |ab..| 305 | c|....| 306 | 307 | Consider a <> b, let `s' be the length of the last line of `a', `k' the 308 | indentation of the first line of b, and `k0' the indentation of the 309 | left-most line b_i of b. 310 | 311 | The produced layout will have negative indentation if `k - k0 > s', as 312 | the first line of b will be put on the (s+1)th column, effectively 313 | translating b horizontally by (k-s). Now if the i^th line of b has an 314 | indentation k0 < (k-s), it is translated out-of-page, causing 315 | `negative indentation'. 316 | -} 317 | 318 | 319 | semi :: Doc -- ^ A ';' character 320 | comma :: Doc -- ^ A ',' character 321 | colon :: Doc -- ^ A ':' character 322 | space :: Doc -- ^ A space character 323 | equals :: Doc -- ^ A '=' character 324 | lparen :: Doc -- ^ A '(' character 325 | rparen :: Doc -- ^ A ')' character 326 | lbrack :: Doc -- ^ A '[' character 327 | rbrack :: Doc -- ^ A ']' character 328 | lbrace :: Doc -- ^ A '{' character 329 | rbrace :: Doc -- ^ A '}' character 330 | semi = char ';' 331 | comma = char ',' 332 | colon = char ':' 333 | space = char ' ' 334 | equals = char '=' 335 | lparen = char '(' 336 | rparen = char ')' 337 | lbrack = char '[' 338 | rbrack = char ']' 339 | lbrace = char '{' 340 | rbrace = char '}' 341 | 342 | space_text, nl_text :: TextDetails 343 | space_text = Chr ' ' 344 | nl_text = Chr '\n' 345 | 346 | int :: Int -> Doc -- ^ @int n = text (show n)@ 347 | integer :: Integer -> Doc -- ^ @integer n = text (show n)@ 348 | float :: Float -> Doc -- ^ @float n = text (show n)@ 349 | double :: Double -> Doc -- ^ @double n = text (show n)@ 350 | rational :: Rational -> Doc -- ^ @rational n = text (show n)@ 351 | int n = text (show n) 352 | integer n = text (show n) 353 | float n = text (show n) 354 | double n = text (show n) 355 | rational n = text (show n) 356 | 357 | parens :: Doc -> Doc -- ^ Wrap document in @(...)@ 358 | brackets :: Doc -> Doc -- ^ Wrap document in @[...]@ 359 | braces :: Doc -> Doc -- ^ Wrap document in @{...}@ 360 | quotes :: Doc -> Doc -- ^ Wrap document in @\'...\'@ 361 | doubleQuotes :: Doc -> Doc -- ^ Wrap document in @\"...\"@ 362 | quotes p = char '\'' <> p <> char '\'' 363 | doubleQuotes p = char '"' <> p <> char '"' 364 | parens p = char '(' <> p <> char ')' 365 | brackets p = char '[' <> p <> char ']' 366 | braces p = char '{' <> p <> char '}' 367 | 368 | 369 | -- --------------------------------------------------------------------------- 370 | -- Structural operations on GDocs 371 | 372 | -- | Perform some simplification of a built up @GDoc@. 373 | reduceDoc :: Doc -> RDoc 374 | reduceDoc (Beside p g q) = beside p g (reduceDoc q) 375 | reduceDoc (Above p g q) = above p g (reduceDoc q) 376 | reduceDoc p = p 377 | 378 | -- | List version of '<>'. 379 | hcat :: [Doc] -> Doc 380 | hcat = reduceAB . foldr (beside_' False) empty 381 | 382 | -- | List version of '<+>'. 383 | hsep :: [Doc] -> Doc 384 | hsep = reduceAB . foldr (beside_' True) empty 385 | 386 | -- | List version of '$$'. 387 | vcat :: [Doc] -> Doc 388 | vcat = reduceAB . foldr (above_' False) empty 389 | 390 | -- | Nest (or indent) a document by a given number of positions 391 | -- (which may also be negative). 'nest' satisfies the laws: 392 | -- 393 | -- * @'nest' 0 x = x@ 394 | -- 395 | -- * @'nest' k ('nest' k' x) = 'nest' (k+k') x@ 396 | -- 397 | -- * @'nest' k (x '<>' y) = 'nest' k z '<>' 'nest' k y@ 398 | -- 399 | -- * @'nest' k (x '$$' y) = 'nest' k x '$$' 'nest' k y@ 400 | -- 401 | -- * @'nest' k 'empty' = 'empty'@ 402 | -- 403 | -- * @x '<>' 'nest' k y = x '<>' y@, if @x@ non-empty 404 | -- 405 | -- The side condition on the last law is needed because 406 | -- 'empty' is a left identity for '<>'. 407 | nest :: Int -> Doc -> Doc 408 | nest k p = mkNest k (reduceDoc p) 409 | 410 | -- | @hang d1 n d2 = sep [d1, nest n d2]@ 411 | hang :: Doc -> Int -> Doc -> Doc 412 | hang d1 n d2 = sep [d1, nest n d2] 413 | 414 | -- | @punctuate p [d1, ... dn] = [d1 \<> p, d2 \<> p, ... dn-1 \<> p, dn]@ 415 | punctuate :: Doc -> [Doc] -> [Doc] 416 | punctuate _ [] = [] 417 | punctuate p (x:xs) = go x xs 418 | where go y [] = [y] 419 | go y (z:zs) = (y <> p) : go z zs 420 | 421 | -- mkNest checks for Nest's invariant that it doesn't have an Empty inside it 422 | mkNest :: Int -> Doc -> Doc 423 | mkNest k _ | k `seq` False = undefined 424 | mkNest k (Nest k1 p) = mkNest (k + k1) p 425 | mkNest _ NoDoc = NoDoc 426 | mkNest _ Empty = Empty 427 | mkNest 0 p = p 428 | mkNest k p = nest_ k p 429 | 430 | -- mkUnion checks for an empty document 431 | mkUnion :: Doc -> Doc -> Doc 432 | mkUnion Empty _ = Empty 433 | mkUnion p q = p `union_` q 434 | 435 | beside_' :: Bool -> Doc -> Doc -> Doc 436 | beside_' _ p Empty = p 437 | beside_' g p q = Beside p g q 438 | 439 | above_' :: Bool -> Doc -> Doc -> Doc 440 | above_' _ p Empty = p 441 | above_' g p q = Above p g q 442 | 443 | reduceAB :: Doc -> Doc 444 | reduceAB (Above Empty _ q) = q 445 | reduceAB (Beside Empty _ q) = q 446 | reduceAB doc = doc 447 | 448 | nilAbove_ :: RDoc -> RDoc 449 | nilAbove_ p = NilAbove p 450 | 451 | -- Arg of a TextBeside is always an RDoc 452 | textBeside_ :: TextDetails -> Int -> RDoc -> RDoc 453 | textBeside_ s sl p = TextBeside s sl p 454 | 455 | nest_ :: Int -> RDoc -> RDoc 456 | nest_ k p = Nest k p 457 | 458 | union_ :: RDoc -> RDoc -> RDoc 459 | union_ p q = Union p q 460 | 461 | 462 | -- --------------------------------------------------------------------------- 463 | -- Vertical composition @$$@ 464 | 465 | -- | Above, except that if the last line of the first argument stops 466 | -- at least one position before the first line of the second begins, 467 | -- these two lines are overlapped. For example: 468 | -- 469 | -- > text "hi" $$ nest 5 (text "there") 470 | -- 471 | -- lays out as 472 | -- 473 | -- > hi there 474 | -- 475 | -- rather than 476 | -- 477 | -- > hi 478 | -- > there 479 | -- 480 | -- '$$' is associative, with identity 'empty', and also satisfies 481 | -- 482 | -- * @(x '$$' y) '<>' z = x '$$' (y '<>' z)@, if @y@ non-empty. 483 | -- 484 | ($$) :: Doc -> Doc -> Doc 485 | p $$ q = above_ p False q 486 | 487 | -- | Above, with no overlapping. 488 | -- '$+$' is associative, with identity 'empty'. 489 | ($+$) :: Doc -> Doc -> Doc 490 | p $+$ q = above_ p True q 491 | 492 | above_ :: Doc -> Bool -> Doc -> Doc 493 | above_ p _ Empty = p 494 | above_ Empty _ q = q 495 | above_ p g q = Above p g q 496 | 497 | above :: Doc -> Bool -> RDoc -> RDoc 498 | above (Above p g1 q1) g2 q2 = above p g1 (above q1 g2 q2) 499 | above p@(Beside _ _ _) g q = aboveNest (reduceDoc p) g 0 (reduceDoc q) 500 | above p g q = aboveNest p g 0 (reduceDoc q) 501 | 502 | -- Specfication: aboveNest p g k q = p $g$ (nest k q) 503 | aboveNest :: RDoc -> Bool -> Int -> RDoc -> RDoc 504 | aboveNest _ _ k _ | k `seq` False = undefined 505 | aboveNest NoDoc _ _ _ = NoDoc 506 | aboveNest (p1 `Union` p2) g k q = aboveNest p1 g k q `union_` 507 | aboveNest p2 g k q 508 | 509 | aboveNest Empty _ k q = mkNest k q 510 | aboveNest (Nest k1 p) g k q = nest_ k1 (aboveNest p g (k - k1) q) 511 | -- p can't be Empty, so no need for mkNest 512 | 513 | aboveNest (NilAbove p) g k q = nilAbove_ (aboveNest p g k q) 514 | aboveNest (TextBeside s sl p) g k q = textBeside_ s sl rest 515 | where 516 | !k1 = k - sl 517 | rest = case p of 518 | Empty -> nilAboveNest g k1 q 519 | _ -> aboveNest p g k1 q 520 | aboveNest (Above {}) _ _ _ = error "aboveNest Above" 521 | aboveNest (Beside {}) _ _ _ = error "aboveNest Beside" 522 | 523 | -- Specification: text s <> nilaboveNest g k q 524 | -- = text s <> (text "" $g$ nest k q) 525 | nilAboveNest :: Bool -> Int -> RDoc -> RDoc 526 | nilAboveNest _ k _ | k `seq` False = undefined 527 | nilAboveNest _ _ Empty = Empty 528 | -- Here's why the "text s <>" is in the spec! 529 | nilAboveNest g k (Nest k1 q) = nilAboveNest g (k + k1) q 530 | nilAboveNest g k q | not g && k > 0 -- No newline if no overlap 531 | = textBeside_ (Str (indent k)) k q 532 | | otherwise -- Put them really above 533 | = nilAbove_ (mkNest k q) 534 | 535 | 536 | -- --------------------------------------------------------------------------- 537 | -- Horizontal composition @<>@ 538 | 539 | -- We intentionally avoid Data.Monoid.(<>) here due to interactions of 540 | -- Data.Monoid.(<>) and (<+>). See 541 | -- http://www.haskell.org/pipermail/libraries/2011-November/017066.html 542 | 543 | -- | Beside. 544 | -- '<>' is associative, with identity 'empty'. 545 | (<>) :: Doc -> Doc -> Doc 546 | p <> q = beside_ p False q 547 | 548 | -- | Beside, separated by space, unless one of the arguments is 'empty'. 549 | -- '<+>' is associative, with identity 'empty'. 550 | (<+>) :: Doc -> Doc -> Doc 551 | p <+> q = beside_ p True q 552 | 553 | beside_ :: Doc -> Bool -> Doc -> Doc 554 | beside_ p _ Empty = p 555 | beside_ Empty _ q = q 556 | beside_ p g q = Beside p g q 557 | 558 | -- Specification: beside g p q = p q 559 | beside :: Doc -> Bool -> RDoc -> RDoc 560 | beside NoDoc _ _ = NoDoc 561 | beside (p1 `Union` p2) g q = beside p1 g q `union_` beside p2 g q 562 | beside Empty _ q = q 563 | beside (Nest k p) g q = nest_ k $! beside p g q 564 | beside p@(Beside p1 g1 q1) g2 q2 565 | | g1 == g2 = beside p1 g1 $! beside q1 g2 q2 566 | | otherwise = beside (reduceDoc p) g2 q2 567 | beside p@(Above _ _ _) g q = let !d = reduceDoc p in beside d g q 568 | beside (NilAbove p) g q = nilAbove_ $! beside p g q 569 | beside (TextBeside s sl p) g q = textBeside_ s sl $! rest 570 | where 571 | rest = case p of 572 | Empty -> nilBeside g q 573 | _ -> beside p g q 574 | 575 | -- Specification: text "" <> nilBeside g p 576 | -- = text "" p 577 | nilBeside :: Bool -> RDoc -> RDoc 578 | nilBeside _ Empty = Empty -- Hence the text "" in the spec 579 | nilBeside g (Nest _ p) = nilBeside g p 580 | nilBeside g p | g = textBeside_ space_text 1 p 581 | | otherwise = p 582 | 583 | 584 | -- --------------------------------------------------------------------------- 585 | -- Separate, @sep@ 586 | 587 | -- Specification: sep ps = oneLiner (hsep ps) 588 | -- `union` 589 | -- vcat ps 590 | 591 | -- | Either 'hsep' or 'vcat'. 592 | sep :: [Doc] -> Doc 593 | sep = sepX True -- Separate with spaces 594 | 595 | -- | Either 'hcat' or 'vcat'. 596 | cat :: [Doc] -> Doc 597 | cat = sepX False -- Don't 598 | 599 | sepX :: Bool -> [Doc] -> Doc 600 | sepX _ [] = empty 601 | sepX x (p:ps) = sep1 x (reduceDoc p) 0 ps 602 | 603 | 604 | -- Specification: sep1 g k ys = sep (x : map (nest k) ys) 605 | -- = oneLiner (x nest k (hsep ys)) 606 | -- `union` x $$ nest k (vcat ys) 607 | sep1 :: Bool -> RDoc -> Int -> [Doc] -> RDoc 608 | sep1 _ _ k _ | k `seq` False = undefined 609 | sep1 _ NoDoc _ _ = NoDoc 610 | sep1 g (p `Union` q) k ys = sep1 g p k ys `union_` 611 | aboveNest q False k (reduceDoc (vcat ys)) 612 | 613 | sep1 g Empty k ys = mkNest k (sepX g ys) 614 | sep1 g (Nest n p) k ys = nest_ n (sep1 g p (k - n) ys) 615 | 616 | sep1 _ (NilAbove p) k ys = nilAbove_ 617 | (aboveNest p False k (reduceDoc (vcat ys))) 618 | sep1 g (TextBeside s sl p) k ys = textBeside_ s sl (sepNB g p (k - sl) ys) 619 | sep1 _ (Above {}) _ _ = error "sep1 Above" 620 | sep1 _ (Beside {}) _ _ = error "sep1 Beside" 621 | 622 | -- Specification: sepNB p k ys = sep1 (text "" <> p) k ys 623 | -- Called when we have already found some text in the first item 624 | -- We have to eat up nests 625 | sepNB :: Bool -> Doc -> Int -> [Doc] -> Doc 626 | sepNB g (Nest _ p) k ys 627 | = sepNB g p k ys -- Never triggered, because of invariant (2) 628 | sepNB g Empty k ys 629 | = oneLiner (nilBeside g (reduceDoc rest)) `mkUnion` 630 | -- XXX: TODO: PRETTY: Used to use True here (but GHC used False...) 631 | nilAboveNest False k (reduceDoc (vcat ys)) 632 | where 633 | rest | g = hsep ys 634 | | otherwise = hcat ys 635 | sepNB g p k ys 636 | = sep1 g p k ys 637 | 638 | 639 | -- --------------------------------------------------------------------------- 640 | -- @fill@ 641 | 642 | -- | \"Paragraph fill\" version of 'cat'. 643 | fcat :: [Doc] -> Doc 644 | fcat = fill False 645 | 646 | -- | \"Paragraph fill\" version of 'sep'. 647 | fsep :: [Doc] -> Doc 648 | fsep = fill True 649 | 650 | -- Specification: 651 | -- 652 | -- fill g docs = fillIndent 0 docs 653 | -- 654 | -- fillIndent k [] = [] 655 | -- fillIndent k [p] = p 656 | -- fillIndent k (p1:p2:ps) = 657 | -- oneLiner p1 fillIndent (k + length p1 + g ? 1 : 0) 658 | -- (remove_nests (oneLiner p2) : ps) 659 | -- `Union` 660 | -- (p1 $*$ nest (-k) (fillIndent 0 ps)) 661 | -- 662 | -- $*$ is defined for layouts (not Docs) as 663 | -- layout1 $*$ layout2 | hasMoreThanOneLine layout1 = layout1 $$ layout2 664 | -- | otherwise = layout1 $+$ layout2 665 | 666 | fill :: Bool -> [Doc] -> RDoc 667 | fill _ [] = empty 668 | fill g (p:ps) = fill1 g (reduceDoc p) 0 ps 669 | 670 | fill1 :: Bool -> RDoc -> Int -> [Doc] -> Doc 671 | fill1 _ _ k _ | k `seq` False = undefined 672 | fill1 _ NoDoc _ _ = NoDoc 673 | fill1 g (p `Union` q) k ys = fill1 g p k ys `union_` 674 | aboveNest q False k (fill g ys) 675 | fill1 g Empty k ys = mkNest k (fill g ys) 676 | fill1 g (Nest n p) k ys = nest_ n (fill1 g p (k - n) ys) 677 | fill1 g (NilAbove p) k ys = nilAbove_ (aboveNest p False k (fill g ys)) 678 | fill1 g (TextBeside s sl p) k ys = textBeside_ s sl (fillNB g p (k - sl) ys) 679 | fill1 _ (Above {}) _ _ = error "fill1 Above" 680 | fill1 _ (Beside {}) _ _ = error "fill1 Beside" 681 | 682 | fillNB :: Bool -> Doc -> Int -> [Doc] -> Doc 683 | fillNB _ _ k _ | k `seq` False = undefined 684 | fillNB g (Nest _ p) k ys = fillNB g p k ys 685 | -- Never triggered, because of invariant (2) 686 | fillNB _ Empty _ [] = Empty 687 | fillNB g Empty k (Empty:ys) = fillNB g Empty k ys 688 | fillNB g Empty k (y:ys) = fillNBE g k y ys 689 | fillNB g p k ys = fill1 g p k ys 690 | 691 | 692 | fillNBE :: Bool -> Int -> Doc -> [Doc] -> Doc 693 | fillNBE g k y ys 694 | = nilBeside g (fill1 g ((elideNest . oneLiner . reduceDoc) y) k' ys) 695 | -- XXX: TODO: PRETTY: Used to use True here (but GHC used False...) 696 | `mkUnion` nilAboveNest False k (fill g (y:ys)) 697 | where k' = if g then k - 1 else k 698 | 699 | elideNest :: Doc -> Doc 700 | elideNest (Nest _ d) = d 701 | elideNest d = d 702 | 703 | 704 | -- --------------------------------------------------------------------------- 705 | -- Selecting the best layout 706 | 707 | best :: Int -- Line length 708 | -> Int -- Ribbon length 709 | -> RDoc 710 | -> RDoc -- No unions in here! 711 | best w0 r p0 712 | = get w0 p0 713 | where 714 | get w _ | w == 0 && False = undefined 715 | get _ Empty = Empty 716 | get _ NoDoc = NoDoc 717 | get w (NilAbove p) = nilAbove_ (get w p) 718 | get w (TextBeside s sl p) = textBeside_ s sl (get1 w sl p) 719 | get w (Nest k p) = nest_ k (get (w - k) p) 720 | get w (p `Union` q) = nicest w r (get w p) (get w q) 721 | get _ (Above {}) = error "best get Above" 722 | get _ (Beside {}) = error "best get Beside" 723 | 724 | get1 w _ _ | w == 0 && False = undefined 725 | get1 _ _ Empty = Empty 726 | get1 _ _ NoDoc = NoDoc 727 | get1 w sl (NilAbove p) = nilAbove_ (get (w - sl) p) 728 | get1 w sl (TextBeside t tl p) = textBeside_ t tl (get1 w (sl + tl) p) 729 | get1 w sl (Nest _ p) = get1 w sl p 730 | get1 w sl (p `Union` q) = nicest1 w r sl (get1 w sl p) 731 | (get1 w sl q) 732 | get1 _ _ (Above {}) = error "best get1 Above" 733 | get1 _ _ (Beside {}) = error "best get1 Beside" 734 | 735 | nicest :: Int -> Int -> Doc -> Doc -> Doc 736 | nicest !w !r p q = nicest1 w r 0 p q 737 | 738 | nicest1 :: Int -> Int -> Int -> Doc -> Doc -> Doc 739 | nicest1 !w !r !sl p q | fits ((w `min` r) - sl) p = p 740 | | otherwise = q 741 | 742 | fits :: Int -- Space available 743 | -> Doc 744 | -> Bool -- True if *first line* of Doc fits in space available 745 | fits n _ | n < 0 = False 746 | fits _ NoDoc = False 747 | fits _ Empty = True 748 | fits _ (NilAbove _) = True 749 | fits n (TextBeside _ sl p) = fits (n - sl) p 750 | fits _ (Above {}) = error "fits Above" 751 | fits _ (Beside {}) = error "fits Beside" 752 | fits _ (Union {}) = error "fits Union" 753 | fits _ (Nest {}) = error "fits Nest" 754 | 755 | -- | @first@ returns its first argument if it is non-empty, otherwise its second. 756 | first :: Doc -> Doc -> Doc 757 | first p q | nonEmptySet p = p -- unused, because (get OneLineMode) is unused 758 | | otherwise = q 759 | 760 | nonEmptySet :: Doc -> Bool 761 | nonEmptySet NoDoc = False 762 | nonEmptySet (_ `Union` _) = True 763 | nonEmptySet Empty = True 764 | nonEmptySet (NilAbove _) = True 765 | nonEmptySet (TextBeside _ _ p) = nonEmptySet p 766 | nonEmptySet (Nest _ p) = nonEmptySet p 767 | nonEmptySet (Above {}) = error "nonEmptySet Above" 768 | nonEmptySet (Beside {}) = error "nonEmptySet Beside" 769 | 770 | -- @oneLiner@ returns the one-line members of the given set of @GDoc@s. 771 | oneLiner :: Doc -> Doc 772 | oneLiner NoDoc = NoDoc 773 | oneLiner Empty = Empty 774 | oneLiner (NilAbove _) = NoDoc 775 | oneLiner (TextBeside s sl p) = textBeside_ s sl (oneLiner p) 776 | oneLiner (Nest k p) = nest_ k (oneLiner p) 777 | oneLiner (p `Union` _) = oneLiner p 778 | oneLiner (Above {}) = error "oneLiner Above" 779 | oneLiner (Beside {}) = error "oneLiner Beside" 780 | 781 | 782 | -- --------------------------------------------------------------------------- 783 | -- Rendering 784 | 785 | -- | A rendering style. 786 | data Style 787 | = Style { mode :: Mode -- ^ The rendering mode 788 | , lineLength :: Int -- ^ Length of line, in chars 789 | , ribbonsPerLine :: Float -- ^ Ratio of ribbon length to line length 790 | } 791 | 792 | -- | The default style (@mode=PageMode, lineLength=100, ribbonsPerLine=1.5@). 793 | style :: Style 794 | style = Style { lineLength = 100, ribbonsPerLine = 1.5, mode = PageMode } 795 | 796 | -- | Rendering mode. 797 | data Mode = PageMode -- ^ Normal 798 | | ZigZagMode -- ^ With zig-zag cuts 799 | | LeftMode -- ^ No indentation, infinitely long lines 800 | | OneLineMode -- ^ All on one line 801 | 802 | -- | Render the @Doc@ to a String using the default @Style@. 803 | render :: Doc -> String 804 | render doc = fullRender (mode style) (lineLength style) (ribbonsPerLine style) 805 | txtPrinter "" doc 806 | 807 | -- | Render the @Doc@ to a String using the given @Style@. 808 | renderStyle :: Style -> Doc -> String 809 | renderStyle s doc = fullRender (mode s) (lineLength s) (ribbonsPerLine s) 810 | txtPrinter "" doc 811 | 812 | -- | Default TextDetails printer 813 | txtPrinter :: TextDetails -> String -> String 814 | txtPrinter (Chr c) s = c:s 815 | txtPrinter (Str s1) s2 = s1 ++ s2 816 | txtPrinter (PStr s1) s2 = s1 ++ s2 817 | 818 | -- | The general rendering interface. 819 | fullRender :: Mode -- ^ Rendering mode 820 | -> Int -- ^ Line length 821 | -> Float -- ^ Ribbons per line 822 | -> (TextDetails -> a -> a) -- ^ What to do with text 823 | -> a -- ^ What to do at the end 824 | -> Doc -- ^ The document 825 | -> a -- ^ Result 826 | fullRender OneLineMode _ _ txt end doc 827 | = easy_display space_text (\_ y -> y) txt end (reduceDoc doc) 828 | fullRender LeftMode _ _ txt end doc 829 | = easy_display nl_text first txt end (reduceDoc doc) 830 | 831 | fullRender m lineLen ribbons txt rest doc 832 | = display m lineLen ribbonLen txt rest doc' 833 | where 834 | doc' = best bestLineLen ribbonLen (reduceDoc doc) 835 | 836 | bestLineLen, ribbonLen :: Int 837 | ribbonLen = round (fromIntegral lineLen / ribbons) 838 | bestLineLen = case m of 839 | ZigZagMode -> maxBound 840 | _ -> lineLen 841 | 842 | easy_display :: TextDetails 843 | -> (Doc -> Doc -> Doc) 844 | -> (TextDetails -> a -> a) 845 | -> a 846 | -> Doc 847 | -> a 848 | easy_display nl_space_text choose txt end doc 849 | = lay doc 850 | where 851 | lay NoDoc = error "easy_display: NoDoc" 852 | lay (Union p q) = lay (choose p q) 853 | lay (Nest _ p) = lay p 854 | lay Empty = end 855 | lay (NilAbove p) = nl_space_text `txt` lay p 856 | lay (TextBeside s _ p) = s `txt` lay p 857 | lay (Above {}) = error "easy_display Above" 858 | lay (Beside {}) = error "easy_display Beside" 859 | 860 | display :: Mode -> Int -> Int -> (TextDetails -> a -> a) -> a -> Doc -> a 861 | display m !page_width !ribbon_width txt end doc 862 | = case page_width - ribbon_width of { gap_width -> 863 | case gap_width `quot` 2 of { shift -> 864 | let 865 | lay k _ | k `seq` False = undefined 866 | lay k (Nest k1 p) = lay (k + k1) p 867 | lay _ Empty = end 868 | lay k (NilAbove p) = nl_text `txt` lay k p 869 | lay k (TextBeside s sl p) 870 | = case m of 871 | ZigZagMode | k >= gap_width 872 | -> nl_text `txt` ( 873 | Str (replicate shift '/') `txt` ( 874 | nl_text `txt` 875 | lay1 (k - shift) s sl p )) 876 | 877 | | k < 0 878 | -> nl_text `txt` ( 879 | Str (replicate shift '\\') `txt` ( 880 | nl_text `txt` 881 | lay1 (k + shift) s sl p )) 882 | 883 | _ -> lay1 k s sl p 884 | lay _ (Above {}) = error "display lay Above" 885 | lay _ (Beside {}) = error "display lay Beside" 886 | lay _ NoDoc = error "display lay NoDoc" 887 | lay _ (Union {}) = error "display lay Union" 888 | 889 | lay1 !k s !sl p = let !r = k + sl 890 | in Str (indent k) `txt` (s `txt` lay2 r p) 891 | 892 | lay2 k _ | k `seq` False = undefined 893 | lay2 k (NilAbove p) = nl_text `txt` lay k p 894 | lay2 k (TextBeside s sl p) = s `txt` lay2 (k + sl) p 895 | lay2 k (Nest _ p) = lay2 k p 896 | lay2 _ Empty = end 897 | lay2 _ (Above {}) = error "display lay2 Above" 898 | lay2 _ (Beside {}) = error "display lay2 Beside" 899 | lay2 _ NoDoc = error "display lay2 NoDoc" 900 | lay2 _ (Union {}) = error "display lay2 Union" 901 | in 902 | lay 0 doc 903 | }} 904 | 905 | -------------------------------------------------------------------------------- /tests/Test.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -XStandaloneDeriving -XDeriveDataTypeable -XPackageImports #-} 2 | ----------------------------------------------------------------------------- 3 | -- Module : HughesPJQuickCheck 4 | -- Copyright : (c) 2008 Benedikt Huber 5 | -- License : BSD-style 6 | -- 7 | -- QuickChecks for HughesPJ pretty printer. 8 | -- 9 | -- 1) Testing laws (blackbox) 10 | -- - CDoc (combinator datatype) 11 | -- 2) Testing invariants (whitebox) 12 | -- 3) Testing bug fixes (whitebox) 13 | -- 14 | ----------------------------------------------------------------------------- 15 | import PrettyTestVersion 16 | import TestGenerators 17 | import TestStructures 18 | 19 | import Control.Monad 20 | import Data.Char (isSpace) 21 | import Data.List (intersperse) 22 | import Debug.Trace 23 | 24 | import Test.QuickCheck 25 | 26 | main :: IO () 27 | main = do 28 | check_laws 29 | check_invariants 30 | check_improvements 31 | check_non_prims -- hpc full coverage 32 | check_rendering 33 | check_list_def 34 | 35 | -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 36 | -- Utility functions 37 | -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 38 | 39 | -- tweaked to perform many small tests 40 | myConfig :: Int -> Int -> Args 41 | myConfig d n = stdArgs { maxSize = d, maxDiscard = n*5 } 42 | 43 | maxTests :: Int 44 | maxTests = 1000 45 | 46 | myTest :: (Testable a) => String -> a -> IO () 47 | myTest = myTest' 15 maxTests 48 | 49 | myTest' :: (Testable a) => Int -> Int -> String -> a -> IO () 50 | myTest' d n msg t = do 51 | putStrLn (" * " ++ msg) 52 | r <- quickCheckWithResult (myConfig d n) t 53 | case r of 54 | (Failure {}) -> error "Failed testing!" 55 | _ -> return () 56 | 57 | myAssert :: String -> Bool -> IO () 58 | myAssert msg b = putStrLn $ (if b then "Ok, passed " else "Failed test:\n ") ++ msg 59 | 60 | -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 61 | -- Quickcheck tests 62 | -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 63 | 64 | -- Equalities on Documents 65 | -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 66 | 67 | -- compare text details 68 | tdEq :: TextDetails -> TextDetails -> Bool 69 | tdEq td1 td2 = (tdToStr td1) == (tdToStr td2) 70 | 71 | -- algebraic equality on reduced docs 72 | docEq :: RDoc -> RDoc -> Bool 73 | docEq rd1 rd2 = case (rd1, rd2) of 74 | (Empty, Empty) -> True 75 | (NoDoc, NoDoc) -> True 76 | (NilAbove ds1, NilAbove ds2) -> docEq ds1 ds2 77 | (TextBeside td1 l1 ds1, TextBeside td2 l2 ds2) | td1 `tdEq` td2 -> docEq ds1 ds2 78 | (Nest k1 d1, Nest k2 d2) | k1 == k2 -> docEq d1 d2 79 | (Union d11 d12, Union d21 d22) -> docEq d11 d21 && docEq d12 d22 80 | (d1,d2) -> False 81 | 82 | -- algebraic equality, with text reduction 83 | deq :: Doc -> Doc -> Bool 84 | deq d1 d2 = docEq (reduceDoc' d1) (reduceDoc' d2) where 85 | reduceDoc' = mergeTexts . reduceDoc 86 | deqs :: [Doc] -> [Doc] -> Bool 87 | deqs ds1 ds2 = 88 | case zipE ds1 ds2 of 89 | Nothing -> False 90 | (Just zds) -> all (uncurry deq) zds 91 | 92 | 93 | zipLayouts :: Doc -> Doc -> Maybe [(Doc,Doc)] 94 | zipLayouts d1 d2 = zipE (reducedDocs d1) (reducedDocs d2) 95 | where reducedDocs = map mergeTexts . flattenDoc 96 | 97 | zipE :: [Doc] -> [Doc] -> Maybe [(Doc, Doc)] 98 | zipE l1 l2 | length l1 == length l2 = Just $ zip l1 l2 99 | | otherwise = Nothing 100 | 101 | -- algebraic equality for layouts (without permutations) 102 | lseq :: Doc -> Doc -> Bool 103 | lseq d1 d2 = maybe False id . fmap (all (uncurry docEq)) $ zipLayouts d1 d2 104 | 105 | -- abstract render equality for layouts 106 | -- should only be performed if the number of layouts is reasonably small 107 | rdeq :: Doc -> Doc -> Bool 108 | rdeq d1 d2 = maybe False id . fmap (all (uncurry layoutEq)) $ zipLayouts d1 d2 109 | where layoutEq d1 d2 = (abstractLayout d1) == (abstractLayout d2) 110 | 111 | layoutsCountBounded :: Int -> [Doc] -> Bool 112 | layoutsCountBounded k docs = isBoundedBy k (concatMap flattenDoc docs) 113 | where 114 | isBoundedBy k [] = True 115 | isBoundedBy 0 (x:xs) = False 116 | isBoundedBy k (x:xs) = isBoundedBy (k-1) xs 117 | 118 | layoutCountBounded :: Int -> Doc -> Bool 119 | layoutCountBounded k doc = layoutsCountBounded k [doc] 120 | 121 | maxLayouts :: Int 122 | maxLayouts = 64 123 | 124 | infix 4 `deq` 125 | infix 4 `lseq` 126 | infix 4 `rdeq` 127 | 128 | debugRender :: Int -> Doc -> IO () 129 | debugRender k = putStr . visibleSpaces . renderStyle (Style PageMode k 1) 130 | visibleSpaces = unlines . map (map visibleSpace) . lines 131 | 132 | visibleSpace :: Char -> Char 133 | visibleSpace ' ' = '.' 134 | visibleSpace '.' = error "dot in visibleSpace (avoid confusion, please)" 135 | visibleSpace c = c 136 | 137 | -- shorthands debug functions 138 | pd = (print.prettyDoc) 139 | pds = mapM_ pd 140 | rds = (map mergeTexts.flattenDoc) 141 | 142 | 143 | -- (1) QuickCheck Properties: Laws 144 | -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 145 | 146 | {- 147 | Monoid laws for <>,<+>,$$,$+$ 148 | ~~~~~~~~~~~~~ 149 | (x * y) * z = x * (y * z) 150 | empty * x = x 151 | x * empty = x 152 | -} 153 | prop_1 op x y z = classify (any isEmpty [x,y,z]) "empty x, y or z" $ 154 | ((x `op` y) `op` z) `deq` (x `op` (y `op` z)) 155 | prop_2 op x = classify (isEmpty x) "empty" $ (empty `op` x) `deq` x 156 | prop_3 op x = classify (isEmpty x) "empty" $ x `deq` (empty `op` x) 157 | 158 | check_monoid = do 159 | putStrLn " = Monoid Laws =" 160 | mapM_ (myTest' 5 maxTests "Associativity") [ liftDoc3 (prop_1 op) | op <- allops ] 161 | mapM_ (myTest "Left neutral") [ prop_2 op . buildDoc | op <- allops ] 162 | mapM_ (myTest "Right neutral") [ prop_3 op . buildDoc | op <- allops ] 163 | where 164 | allops = [ (<>), (<+>) ,($$) , ($+$) ] 165 | 166 | {- 167 | Laws for text 168 | ~~~~~~~~~~~~~ 169 | text s <> text t = text (s++t) 170 | text "" <> x = x, if x non-empty [only true if x does not start with nest, because of ] 171 | -} 172 | prop_t1 s t = text' s <> text' t `deq` text (unText s ++ unText t) 173 | prop_t2 x = not (isEmpty x) ==> text "" <> x `deq` x 174 | prop_t2_a x = not (isEmpty x) && not (isNest x) ==> text "" <> x `deq` x 175 | 176 | isNest :: Doc -> Bool 177 | isNest d = case reduceDoc d of 178 | (Nest _ _) -> True 179 | (Union d1 d2) -> isNest d1 || isNest d2 180 | _ -> False 181 | 182 | check_t = do 183 | putStrLn " = Text laws =" 184 | myTest "t1" prop_t1 185 | myTest "t2_a (precondition: x does not start with nest)" (prop_t2_a . buildDoc) 186 | myTest "t_2 (Known to fail)" (expectFailure . prop_t2 . buildDoc) 187 | 188 | {- 189 | Laws for nest 190 | ~~~~~~~~~~~~~ 191 | nest 0 x = x 192 | nest k (nest k' x) = nest (k+k') x 193 | nest k (x <> y) = nest k z <> nest k y 194 | nest k (x $$ y) = nest k x $$ nest k y 195 | nest k empty = empty 196 | x <> nest k y = x <> y, if x non-empty 197 | -} 198 | prop_n1 x = nest 0 x `deq` x 199 | prop_n2 k k' x = nest k (nest k' x) `deq` nest (k+k') x 200 | prop_n3 k k' x = nest k (nest k' x) `deq` nest (k+k') x 201 | prop_n4 k x y = nest k (x $$ y) `deq` nest k x $$ nest k y 202 | prop_n5 k = nest k empty `deq` empty 203 | prop_n6 x k y = not (isEmpty x) ==> 204 | x <> nest k y `deq` x <> y 205 | check_n = do 206 | putStrLn "Nest laws" 207 | myTest "n1" (prop_n1 . buildDoc) 208 | myTest "n2" (\k k' -> prop_n2 k k' . buildDoc) 209 | myTest "n3" (\k k' -> prop_n3 k k' . buildDoc) 210 | myTest "n4" (\k -> liftDoc2 (prop_n4 k)) 211 | myTest "n5" prop_n5 212 | myTest "n6" (\k -> liftDoc2 (\x -> prop_n6 x k)) 213 | 214 | {- 215 | (text s <> x) $$ y = text s <> ((text "" <> x)) $$ 216 | nest (-length s) y) 217 | 218 | (x $$ y) <> z = x $$ (y <> z) 219 | if y non-empty 220 | -} 221 | prop_m1 s x y = (text' s <> x) $$ y `deq` text' s <> ((text "" <> x) $$ 222 | nest (-length (unText s)) y) 223 | prop_m2 x y z = not (isEmpty y) ==> 224 | (x $$ y) <> z `deq` x $$ (y <> z) 225 | check_m = do 226 | putStrLn "Misc laws" 227 | myTest "m1" (\s -> liftDoc2 (prop_m1 s)) 228 | myTest' 10 maxTests "m2" (liftDoc3 prop_m2) 229 | 230 | 231 | {- 232 | Laws for list versions 233 | ~~~~~~~~~~~~~~~~~~~~~~ 234 | sep (ps++[empty]++qs) = sep (ps ++ qs) 235 | ...ditto hsep, hcat, vcat, fill... 236 | [ Fails for fill ! ] 237 | nest k (sep ps) = sep (map (nest k) ps) 238 | ...ditto hsep, hcat, vcat, fill... 239 | -} 240 | prop_l1 sp ps qs = 241 | sp (ps++[empty]++qs) `rdeq` sp (ps ++ qs) 242 | prop_l2 sp k ps = nest k (sep ps) `deq` sep (map (nest k) ps) 243 | 244 | 245 | prop_l1' sp cps cqs = 246 | let [ps,qs] = map buildDocList [cps,cqs] in 247 | layoutCountBounded maxLayouts (sp (ps++qs)) ==> prop_l1 sp ps qs 248 | prop_l2' sp k ps = prop_l2 sp k (buildDocList ps) 249 | check_l = do 250 | allCats $ myTest "l1" . prop_l1' 251 | allCats $ myTest "l2" . prop_l2' 252 | where 253 | allCats = flip mapM_ [ sep, hsep, cat, hcat, vcat, fsep, fcat ] 254 | prop_l1_fail_1 = [ text "a" ] 255 | prop_l1_fail_2 = [ text "a" $$ text "b" ] 256 | 257 | {- 258 | Laws for oneLiner 259 | ~~~~~~~~~~~~~~~~~ 260 | oneLiner (nest k p) = nest k (oneLiner p) 261 | oneLiner (x <> y) = oneLiner x <> oneLiner y 262 | 263 | [One liner only takes reduced arguments] 264 | -} 265 | oneLinerR = oneLiner . reduceDoc 266 | prop_o1 k p = oneLinerR (nest k p) `deq` nest k (oneLinerR p) 267 | prop_o2 x y = oneLinerR (x <> y) `deq` oneLinerR x <> oneLinerR y 268 | 269 | check_o = do 270 | putStrLn "oneliner laws" 271 | myTest "o1 (RDoc arg)" (\k p -> prop_o1 k (buildDoc p)) 272 | myTest "o2 (RDoc arg)" (liftDoc2 prop_o2) 273 | 274 | {- 275 | Definitions of list versions 276 | ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 277 | vcat = foldr ($$) empty 278 | hcat = foldr (<>) empty 279 | hsep = foldr (<+>) empty 280 | -} 281 | prop_hcat :: [Doc] -> Bool 282 | prop_hcat ds = hcat ds `deq` (foldr (<>) empty) ds 283 | 284 | prop_hsep :: [Doc] -> Bool 285 | prop_hsep ds = hsep ds `deq` (foldr (<+>) empty) ds 286 | 287 | prop_vcat :: [Doc] -> Bool 288 | prop_vcat ds = vcat ds `deq` (foldr ($$) empty) ds 289 | 290 | {- 291 | Update (pretty-1.1.0): 292 | *failing* definition of sep: oneLiner (hsep ps) `union` vcat ps 293 | ? 294 | -} 295 | prop_sep :: [Doc] -> Bool 296 | prop_sep ds = sep ds `rdeq` (sepDef ds) 297 | 298 | sepDef :: [Doc] -> Doc 299 | sepDef docs = let ds = filter (not . isEmpty) docs in 300 | case ds of 301 | [] -> empty 302 | [d] -> d 303 | ds -> reduceDoc (oneLiner (reduceDoc $ hsep ds) 304 | `Union` 305 | (reduceDoc $ foldr ($+$) empty ds)) 306 | 307 | check_list_def = do 308 | myTest "hcat def" (prop_hcat . buildDocList) 309 | myTest "hsep def" (prop_hsep . buildDocList) 310 | myTest "vcat def" (prop_vcat . buildDocList) 311 | -- XXX: Not sure if this is meant to fail (I added the expectFailure [DT]) 312 | myTest "sep def" (expectFailure . prop_sep . buildDocList) 313 | 314 | {- 315 | Definition of fill (fcat/fsep) 316 | -- Specification: 317 | -- fill [] = empty 318 | -- fill [p] = p 319 | -- fill (p1:p2:ps) = oneLiner p1 <#> nest (length p1) 320 | -- (fill (oneLiner p2 : ps)) 321 | -- `union` 322 | -- p1 $$ fill ps 323 | -- Revised Specification: 324 | -- fill g docs = fillIndent 0 docs 325 | -- 326 | -- fillIndent k [] = [] 327 | -- fillIndent k [p] = p 328 | -- fillIndent k (p1:p2:ps) = 329 | -- oneLiner p1 fillIndent (k + length p1 + g ? 1 : 0) (remove_nests (oneLiner p2) : ps) 330 | -- `Union` 331 | -- (p1 $*$ nest (-k) (fillIndent 0 ps)) 332 | -- 333 | -- $*$ is defined for layouts (not Docs) as 334 | -- layout1 $*$ layout2 | isOneLiner layout1 = layout1 $+$ layout2 335 | -- | otherwise = layout1 $$ layout2 336 | -- 337 | -- Old implementation ambiguities/problems: 338 | -- ======================================== 339 | -- Preserving nesting: 340 | -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 341 | -- fcat [cat[ text "b", text "a"], nest 2 ( text "" $$ text "a")] 342 | -- ==> fcat [ text "b" $$ text "a", nest 2 (text "" $$ text "a")] // cat: union right 343 | -- ==> (text "b" $$ text "a" $$ nest 2 (text "" $$ text "a")) // fcat: union right with overlap 344 | -- ==> (text "ab" $$ nest 2 (text "" $$ text "a")) 345 | -- ==> "b\na\n..a" 346 | -- Bug #1337: 347 | -- ~~~~~~~~~~ 348 | -- > fcat [ nest 1 $ text "a", nest 2 $ text "b", text "c"] 349 | -- ==> [second alternative] roughly (a <#> b $#$ c) 350 | -- " ab" 351 | -- "c " 352 | -- expected: (nest 1; text "a"; text "b"; nest -3; "c") 353 | -- actual : (nest 1; text "a"; text "b"; nest -5; "c") 354 | -- === (nest 1; text a) <> (fill (-2) (p2:ps)) 355 | -- ==> (nest 2 (text "b") $+$ text "c") 356 | -- ==> (nest 2 (text "b") `nilabove` nest (-3) (text "c")) 357 | -- ==> (nest 1; text a; text b; nest -5 c) 358 | 359 | -} 360 | prop_fcat_vcat :: [Doc] -> Bool 361 | prop_fcat_vcat ds = last (flattenDoc $ fcat ds) `deq` last (flattenDoc $ vcat ds) 362 | 363 | prop_fcat :: [Doc] -> Bool 364 | prop_fcat ds = fcat ds `rdeq` fillDef False (filter (not . isEmpty) ds) 365 | 366 | prop_fsep :: [Doc] -> Bool 367 | prop_fsep ds = fsep ds `rdeq` fillDef True (filter (not . isEmpty) ds) 368 | 369 | prop_fcat_old :: [Doc] -> Bool 370 | prop_fcat_old ds = fillOld2 False ds `rdeq` fillDef False (filter (not . isEmpty) ds) 371 | 372 | prop_fcat_old_old :: [Doc] -> Bool 373 | prop_fcat_old_old ds = fillOld2 False ds `rdeq` fillDefOld False (filter (not . isEmpty) ds) 374 | 375 | prop_restrict_sz :: (Testable a) => Int -> ([Doc] -> a) -> ([Doc] -> Property) 376 | prop_restrict_sz k p ds = layoutCountBounded k (fsep ds) ==> p ds 377 | 378 | prop_restrict_ol :: (Testable a) => ([Doc] -> a) -> ([Doc] -> Property) 379 | prop_restrict_ol p ds = (all isOneLiner . map normalize $ ds) ==> p ds 380 | 381 | prop_restrict_no_nest_start :: (Testable a) => ([Doc] -> a) -> ([Doc] -> Property) 382 | prop_restrict_no_nest_start p ds = (all (not .isNest) ds) ==> p ds 383 | 384 | fillDef :: Bool -> [Doc] -> Doc 385 | fillDef g = normalize . fill' 0 . filter (not.isEmpty) . map reduceDoc 386 | where 387 | fill' _ [] = Empty 388 | fill' _ [x] = x 389 | fill' k (p1:p2:ps) = 390 | reduceDoc (oneLiner p1 `append` (fill' (k + firstLineLength p1 + (if g then 1 else 0)) $ (oneLiner' p2) : ps)) 391 | `union` 392 | reduceDoc (p1 $*$ (nest (-k) (fillDef g (p2:ps)))) 393 | 394 | union = Union 395 | 396 | append = if g then (<+>) else (<>) 397 | 398 | oneLiner' (Nest k d) = oneLiner' d 399 | oneLiner' d = oneLiner d 400 | 401 | ($*$) :: RDoc -> RDoc -> RDoc 402 | ($*$) p ps = case flattenDoc p of 403 | [] -> NoDoc 404 | ls -> foldr1 Union (map combine ls) 405 | where 406 | combine p | isOneLiner p = p $+$ ps 407 | | otherwise = p $$ ps 408 | 409 | fillDefOld :: Bool -> [Doc] -> Doc 410 | fillDefOld g = normalize . fill' . filter (not.isEmpty) . map normalize where 411 | fill' [] = Empty 412 | fill' [p1] = p1 413 | fill' (p1:p2:ps) = (normalize (oneLiner p1 `append` nest (firstLineLength p1) 414 | (fill' (oneLiner p2 : ps)))) 415 | `union` 416 | (p1 $$ fill' (p2:ps)) 417 | append = if g then (<+>) else (<>) 418 | union = Union 419 | 420 | check_fill_prop :: Testable a => String -> ([Doc] -> a) -> IO () 421 | check_fill_prop msg p = myTest msg (prop_restrict_sz maxLayouts p . buildDocList) 422 | 423 | check_fill_def_fail :: IO () 424 | check_fill_def_fail = do 425 | check_fill_prop "fcat defOld vs fcatOld (ol)" (prop_restrict_ol prop_fcat_old_old) 426 | check_fill_prop "fcat defOld vs fcatOld" prop_fcat_old_old 427 | 428 | check_fill_prop "fcat def (ol) vs fcatOld" (prop_restrict_ol prop_fcat_old) 429 | check_fill_prop "fcat def vs fcatOld" prop_fcat_old 430 | 431 | check_fill_def_ok :: IO () 432 | check_fill_def_ok = do 433 | check_fill_prop "fcat def (not nest start) vs fcatOld" (prop_restrict_no_nest_start prop_fcat_old) 434 | 435 | check_fill_prop "fcat def (not nest start) vs fcat" (prop_restrict_no_nest_start prop_fcat) 436 | -- XXX: These all fail now with the change of pretty to GHC behaviour. 437 | check_fill_prop "fcat def (ol) vs fcat" (expectFailure . prop_restrict_ol prop_fcat) 438 | check_fill_prop "fcat def vs fcat" (expectFailure . prop_fcat) 439 | check_fill_prop "fsep def vs fsep" (expectFailure . prop_fsep) 440 | 441 | 442 | check_fill_def_laws :: IO () 443 | check_fill_def_laws = do 444 | check_fill_prop "lastLayout (fcat ps) == vcat ps" prop_fcat_vcat 445 | 446 | check_fill_def :: IO () 447 | check_fill_def = check_fill_def_fail >> check_fill_def_ok 448 | {- 449 | text "ac"; nilabove; nest -1; text "a"; empty 450 | text "ac"; nilabove; nest -2; text "a"; empty 451 | -} 452 | 453 | {- 454 | Zero width text (Neil) 455 | 456 | Here it would be convenient to generate functions (or replace empty / text bz z-w-t) 457 | -} 458 | -- TODO 459 | {- 460 | All laws: monoid, text, nest, misc, list versions, oneLiner, list def 461 | -} 462 | check_laws :: IO () 463 | check_laws = do 464 | check_fill_def_ok 465 | check_monoid 466 | check_t 467 | check_n 468 | check_m 469 | check_l 470 | check_o 471 | check_list_def 472 | 473 | -- (2) QuickCheck Properties: Invariants (whitebox) 474 | -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 475 | 476 | -- strategies: synthesize with stop condition 477 | -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 478 | stop :: a -> (a, Bool) 479 | stop a = (a,False) 480 | 481 | recurse :: a -> (a, Bool) 482 | recurse a = (a,True) 483 | -- strategy: generic synthesize with stop condition 484 | -- terms are combined top-down, left-right (latin text order) 485 | genericProp :: (a -> a -> a) -> (Doc -> (a,Bool)) -> Doc -> a 486 | genericProp c q doc = 487 | case q doc of 488 | (v,False) -> v 489 | (v,True) -> foldl c v (subs doc) 490 | where 491 | rec = genericProp c q 492 | subs d = case d of 493 | Empty -> [] 494 | NilAbove d -> [rec d] 495 | TextBeside _ _ d -> [rec d] 496 | Nest _ d -> [rec d] 497 | Union d1 d2 -> [rec d1, rec d2] 498 | NoDoc -> [] 499 | Beside d1 _ d2 -> subs (reduceDoc d) 500 | Above d1 _ d2 -> subs (reduceDoc d) 501 | 502 | 503 | {- 504 | * The argument of NilAbove is never Empty. Therefore 505 | a NilAbove occupies at least two lines. 506 | -} 507 | prop_inv1 :: Doc -> Bool 508 | prop_inv1 d = genericProp (&&) nilAboveNotEmpty d where 509 | nilAboveNotEmpty (NilAbove Empty) = stop False 510 | nilAboveNotEmpty _ = recurse True 511 | 512 | {- 513 | * The argument of @TextBeside@ is never @Nest@. 514 | -} 515 | prop_inv2 :: Doc -> Bool 516 | prop_inv2 = genericProp (&&) textBesideNotNest where 517 | textBesideNotNest (TextBeside _ _ (Nest _ _)) = stop False 518 | textBesideNotNest _ = recurse True 519 | {- 520 | * The layouts of the two arguments of @Union@ both flatten to the same 521 | string 522 | -} 523 | prop_inv3 :: Doc -> Bool 524 | prop_inv3 = genericProp (&&) unionsFlattenSame where 525 | unionsFlattenSame (Union d1 d2) = stop (pairwiseEqual (extractTexts d1 ++ extractTexts d2)) 526 | unionsFlattenSame _ = recurse True 527 | pairwiseEqual (x:y:zs) = x==y && pairwiseEqual (y:zs) 528 | pairwiseEqual _ = True 529 | 530 | 531 | {- 532 | * The arguments of @Union@ are either @TextBeside@, or @NilAbove@. 533 | -} 534 | prop_inv4 :: Doc -> Bool 535 | prop_inv4 = genericProp (&&) unionArgs where 536 | unionArgs (Union d1 d2) | goodUnionArg d1 && goodUnionArg d2 = recurse True 537 | | otherwise = stop False 538 | unionArgs _ = recurse True 539 | goodUnionArg (TextBeside _ _ _) = True 540 | goodUnionArg (NilAbove _) = True 541 | goodUnionArg _ = False 542 | 543 | {- 544 | * A @NoDoc@ may only appear on the first line of the left argument of 545 | an union. Therefore, the right argument of an union can never be equivalent 546 | to the empty set. 547 | -} 548 | prop_inv5 :: Doc -> Bool 549 | prop_inv5 = genericProp (&&) unionArgs . reduceDoc where 550 | unionArgs NoDoc = stop False 551 | unionArgs (Union d1 d2) = stop $ genericProp (&&) noDocIsFirstLine d1 && nonEmptySet (reduceDoc d2) 552 | unionArgs _ = (True,True) -- recurse 553 | noDocIsFirstLine (NilAbove d) = stop $ genericProp (&&) unionArgs d 554 | noDocIsFirstLine _ = recurse True 555 | 556 | {- 557 | * An empty document is always represented by @Empty@. It can't be 558 | hidden inside a @Nest@, or a @Union@ of two @Empty@s. 559 | -} 560 | prop_inv6 :: Doc -> Bool 561 | prop_inv6 d | not (prop_inv1 d) || not (prop_inv2 d) = False 562 | | not (isEmptyDoc d) = True 563 | | otherwise = case d of Empty -> True ; _ -> False 564 | 565 | isEmptyDoc :: Doc -> Bool 566 | isEmptyDoc d = case emptyReduction d of Empty -> True; _ -> False 567 | 568 | {- 569 | * Consistency 570 | If all arguments of one of the list versions are empty documents, the list is an empty document 571 | -} 572 | prop_inv6a :: ([Doc] -> Doc) -> Property 573 | prop_inv6a sep = forAll emptyDocListGen $ 574 | \ds -> isEmptyRepr (sep $ buildDocList ds) 575 | where 576 | isEmptyRepr Empty = True 577 | isEmptyRepr _ = False 578 | 579 | {- 580 | * The first line of every layout in the left argument of @Union@ is 581 | longer than the first line of any layout in the right argument. 582 | (1) ensures that the left argument has a first line. In view of 583 | (3), this invariant means that the right argument must have at 584 | least two lines. 585 | -} 586 | counterexample_inv7 = cat [ text " ", nest 2 ( text "a") ] 587 | 588 | prop_inv7 :: Doc -> Bool 589 | prop_inv7 = genericProp (&&) firstLonger where 590 | firstLonger (Union d1 d2) = (firstLineLength d1 >= firstLineLength d2, True) 591 | firstLonger _ = (True, True) 592 | 593 | {- 594 | * If we take as precondition: the arguments of cat,sep,fill do not start with Nest, invariant 7 holds 595 | -} 596 | prop_inv7_pre :: CDoc -> Bool 597 | prop_inv7_pre cdoc = nestStart True cdoc where 598 | nestStart nestOk doc = 599 | case doc of 600 | CList sep ds -> all (nestStart False) ds 601 | CBeside _ d1 d2 -> nestStart nestOk d1 && nestStart (not . isEmpty $ buildDoc d1) d2 602 | CAbove _ d1 d2 -> nestStart nestOk d1 && nestStart (not . isEmpty $ buildDoc d1) d2 603 | CNest _ d | not nestOk -> False 604 | | otherwise -> nestStart True d 605 | _empty_or_text -> True 606 | 607 | {- 608 | inv7_pre ==> inv7 609 | -} 610 | prop_inv7_a :: CDoc -> Property 611 | prop_inv7_a cdoc = prop_inv7_pre cdoc ==> prop_inv7 (buildDoc cdoc) 612 | 613 | check_invariants :: IO () 614 | check_invariants = do 615 | myTest "Invariant 1" (prop_inv1 . buildDoc) 616 | myTest "Invariant 2" (prop_inv2 . buildDoc) 617 | myTest "Invariant 3" (prop_inv3 . buildDoc) 618 | myTest "Invariant 4" (prop_inv4 . buildDoc) 619 | myTest "Invariant 5+" (prop_inv5 . buildDoc) 620 | myTest "Invariant 6" (prop_inv6 . buildDoc) 621 | mapM_ (\sp -> myTest "Invariant 6a" $ prop_inv6a sp) [ cat, sep, fcat, fsep, vcat, hcat, hsep ] 622 | -- XXX: Not sure if this is meant to fail (I added the expectFailure [DT]) 623 | myTest "Invariant 7 (fails in HughesPJ:20080621)" (expectFailure . prop_inv7 . buildDoc) 624 | 625 | -- `negative indent' 626 | -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 627 | 628 | {- 629 | In the documentation we have: 630 | 631 | (spaces n) generates a list of n spaces 632 | It should never be called with 'n' < 0, but that can happen for reasons I don't understand 633 | 634 | This is easy to explain: 635 | Suppose we have layout1 <> layout2 636 | length of last line layout1 is k1 637 | indentation of first line of layout2 is k2 638 | indentation of some other line of layout2 is k2' 639 | Now layout1 <> nest k2 (line1 $$ nest k2' lineK) 640 | ==> layout1 <> (line1 $$ nest k2' lineK) 641 | When k1 - k2' < 0, we need to layout lineK with negative indentation 642 | 643 | Here is a quick check property to ducment this. 644 | -} 645 | prop_negative_indent :: CDoc -> Property 646 | prop_negative_indent cdoc = noNegNest cdoc ==> noNegSpaces (buildDoc cdoc) 647 | noNegNest = genericCProp (&&) notIsNegNest where 648 | notIsNegNest (CNest k _) | k < 0 = stop False 649 | notIsNegNest _ = recurse True 650 | noNegSpaces = go 0 . reduceDoc where 651 | go k Empty = True 652 | go k (NilAbove d) = go k d 653 | go k (TextBeside _ s d) | k < 0 = False 654 | go k (TextBeside _ s d) = go (k+s) d 655 | go k (Nest k' d) = go (k+k') d 656 | go k (Union d1 d2) = (if nonEmptySet d1 then (&&) (go k d1) else id) (go k d2) 657 | go k NoDoc = True 658 | 659 | counterexample_fail9 :: Doc 660 | counterexample_fail9 = text "a" <> ( nest 2 ( text "b") $$ text "c") 661 | -- reduces to textb "a" ; textb "b" ; nilabove ; nest -3 ; textb "c" ; empty 662 | 663 | {- 664 | This cannot be fixed with violating the "intuitive property of layouts", described by John Hughes: 665 | "Composing layouts should preserve the layouts themselves (i.e. translation)" 666 | 667 | Consider the following example: 668 | It is the user's fault to use <+> in t2. 669 | -} 670 | 671 | tstmt = (nest 6 $ text "/* double indented comment */") $+$ 672 | (nest 3 $ text "/* indented comment */") $+$ 673 | text "skip;" 674 | 675 | t1 = text "while(true)" $+$ (nest 2) tstmt 676 | {- 677 | while(true) 678 | /* double indented comment */ 679 | /* indented comment */ 680 | skip; 681 | -} 682 | t2 = text "while(true)" $+$ (nest 2 $ text "//" <+> tstmt) 683 | {- 684 | while(true) 685 | // /* double indented comment */ 686 | /* indented comment */ 687 | skip; 688 | -} 689 | 690 | -- (3) Touching non-prims 691 | -- ~~~~~~~~~~~~~~~~~~~~~~ 692 | 693 | check_non_prims :: IO () 694 | check_non_prims = do 695 | myTest "Non primitive: show = renderStyle style" $ \cd -> let d = buildDoc cd in 696 | show ((zeroWidthText "a") <> d) /= renderStyle style d 697 | myAssert "symbols" $ 698 | (semi <> comma <> colon <> equals <> lparen <> rparen <> lbrack <> rbrack <> lbrace <> rbrace) 699 | `deq` 700 | (text ";,:=()[]{}") 701 | myAssert "quoting" $ 702 | (quotes . doubleQuotes . parens . brackets .braces $ (text "a" $$ text "b")) 703 | `deq` 704 | (text "'\"([{" <> (text "a" $$ text "b") <> text "}])\"'") 705 | myAssert "numbers" $ 706 | fsep [int 42, integer 42, float 42, double 42, rational 42] 707 | `rdeq` 708 | (fsep . map text) 709 | [show (42 :: Int), show (42 :: Integer), show (42 :: Float), show (42 :: Double), show (42 :: Rational)] 710 | myTest "Definition of <+>" $ \cd1 cd2 -> 711 | let (d1,d2) = (buildDoc cd1, buildDoc cd2) in 712 | layoutsCountBounded maxLayouts [d1,d2] ==> 713 | not (isEmpty d1) && not (isEmpty d2) ==> 714 | d1 <+> d2 `rdeq` d1 <> space <> d2 715 | 716 | myTest "hang" $ liftDoc2 (\d1 d2 -> hang d1 2 d2 `deq` sep [d1, nest 2 d2]) 717 | 718 | let pLift f cp cds = f (buildDoc cp) (buildDocList cds) 719 | myTest "punctuate" $ pLift (\p ds -> (punctuate p ds) `deqs` (punctuateDef p ds)) 720 | 721 | check_rendering = do 722 | myTest' 20 10000 "one - line rendering" $ \cd -> 723 | let d = buildDoc cd in 724 | (renderStyle (Style OneLineMode undefined undefined) d) == oneLineRender d 725 | myTest' 20 10000 "left-mode rendering" $ \cd -> 726 | let d = buildDoc cd in 727 | extractText (renderStyle (Style LeftMode undefined undefined) d) == extractText (oneLineRender d) 728 | myTest' 20 10000 "page mode rendering" $ \cd -> 729 | let d = buildDoc cd in 730 | extractText (renderStyle (Style PageMode 6 1.7) d) == extractText (oneLineRender d) 731 | myTest' 20 10000 "zigzag mode rendering" $ \cd -> 732 | let d = buildDoc cd in 733 | extractTextZZ (renderStyle (Style ZigZagMode 6 1.7) d) == extractText (oneLineRender d) 734 | 735 | extractText :: String -> String 736 | extractText = filter (not . isSpace) 737 | 738 | extractTextZZ :: String -> String 739 | extractTextZZ = filter (\c -> not (isSpace c) && c /= '/' && c /= '\\') 740 | 741 | punctuateDef :: Doc -> [Doc] -> [Doc] 742 | punctuateDef p [] = [] 743 | punctuateDef p ps = 744 | let (dsInit,dLast) = (init ps, last ps) in 745 | map (\d -> d <> p) dsInit ++ [dLast] 746 | 747 | -- (4) QuickChecking improvments and bug fixes 748 | -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 749 | 750 | {- 751 | putStrLn $ render' $ fill True [ text "c", text "c",empty, text "c", text "b"] 752 | c c c 753 | b 754 | putStrLn $ render' $ fillOld True [ text "c", text "c",empty, text "c", text "b"] 755 | c c c 756 | b 757 | -} 758 | prop_fill_empty_reduce :: [Doc] -> Bool 759 | prop_fill_empty_reduce ds = fill True ds `deq` fillOld True (filter (not.isEmpty.reduceDoc) ds) 760 | 761 | check_improvements :: IO () 762 | check_improvements = do 763 | myTest "fill = fillOld . filter (not.isEmpty) [if no argument starts with nest]" 764 | (prop_fill_empty_reduce . filter (not .isNest) . buildDocList) 765 | 766 | -- old implementation of fill 767 | fillOld :: Bool -> [Doc] -> RDoc 768 | fillOld _ [] = empty 769 | fillOld g (p:ps) = fill1 g (reduceDoc p) 0 ps where 770 | fill1 :: Bool -> RDoc -> Int -> [Doc] -> Doc 771 | fill1 _ _ k _ | k `seq` False = undefined 772 | fill1 _ NoDoc _ _ = NoDoc 773 | fill1 g (p `Union` q) k ys = fill1 g p k ys 774 | `union_` 775 | (aboveNest q False k (fillOld g ys)) 776 | 777 | fill1 g Empty k ys = mkNest k (fillOld g ys) 778 | fill1 g (Nest n p) k ys = nest_ n (fill1 g p (k - n) ys) 779 | 780 | fill1 g (NilAbove p) k ys = nilAbove_ (aboveNest p False k (fillOld g ys)) 781 | fill1 g (TextBeside s sl p) k ys = textBeside_ s sl (fillNB g p (k - sl) ys) 782 | fill1 _ (Above {}) _ _ = error "fill1 Above" 783 | fill1 _ (Beside {}) _ _ = error "fill1 Beside" 784 | -- fillNB gap textBesideArgument space_left docs 785 | fillNB :: Bool -> Doc -> Int -> [Doc] -> Doc 786 | fillNB _ _ k _ | k `seq` False = undefined 787 | fillNB g (Nest _ p) k ys = fillNB g p k ys 788 | fillNB _ Empty _ [] = Empty 789 | fillNB g Empty k (y:ys) = nilBeside g (fill1 g (oneLiner (reduceDoc y)) k1 ys) 790 | `mkUnion` 791 | nilAboveNest False k (fillOld g (y:ys)) 792 | where 793 | k1 | g = k - 1 794 | | otherwise = k 795 | fillNB g p k ys = fill1 g p k ys 796 | 797 | 798 | -- Specification: 799 | -- fill [] = empty 800 | -- fill [p] = p 801 | -- fill (p1:p2:ps) = oneLiner p1 <#> nest (length p1) 802 | -- (fill (oneLiner p2 : ps)) 803 | -- `union` 804 | -- p1 $$ fill ps 805 | fillOld2 :: Bool -> [Doc] -> RDoc 806 | fillOld2 _ [] = empty 807 | fillOld2 g (p:ps) = fill1 g (reduceDoc p) 0 ps where 808 | fill1 :: Bool -> RDoc -> Int -> [Doc] -> Doc 809 | fill1 _ _ k _ | k `seq` False = undefined 810 | fill1 _ NoDoc _ _ = NoDoc 811 | fill1 g (p `Union` q) k ys = fill1 g p k ys 812 | `union_` 813 | (aboveNest q False k (fill g ys)) 814 | 815 | fill1 g Empty k ys = mkNest k (fill g ys) 816 | fill1 g (Nest n p) k ys = nest_ n (fill1 g p (k - n) ys) 817 | 818 | fill1 g (NilAbove p) k ys = nilAbove_ (aboveNest p False k (fill g ys)) 819 | fill1 g (TextBeside s sl p) k ys = textBeside_ s sl (fillNB g p (k - sl) ys) 820 | fill1 _ (Above {}) _ _ = error "fill1 Above" 821 | fill1 _ (Beside {}) _ _ = error "fill1 Beside" 822 | 823 | fillNB :: Bool -> Doc -> Int -> [Doc] -> Doc 824 | fillNB _ _ k _ | k `seq` False = undefined 825 | fillNB g (Nest _ p) k ys = fillNB g p k ys 826 | fillNB _ Empty _ [] = Empty 827 | fillNB g Empty k (Empty:ys) = fillNB g Empty k ys 828 | fillNB g Empty k (y:ys) = fillNBE g k y ys 829 | fillNB g p k ys = fill1 g p k ys 830 | 831 | fillNBE g k y ys = nilBeside g (fill1 g (oneLiner (reduceDoc y)) k1 ys) 832 | `mkUnion` 833 | nilAboveNest True k (fill g (y:ys)) 834 | where 835 | k1 | g = k - 1 836 | | otherwise = k 837 | 838 | -- (5) Pretty printing RDocs and RDOC properties 839 | -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 840 | prettyDoc :: Doc -> Doc 841 | prettyDoc d = 842 | case reduceDoc d of 843 | Empty -> text "empty" 844 | NilAbove d -> (text "nilabove") <> semi <+> (prettyDoc d) 845 | TextBeside s sl d -> (text ("text \""++tdToStr s ++ "\"" ++ show sl)) <> semi <+> (prettyDoc d) 846 | Nest k d -> text "nest" <+> integer (fromIntegral k) <> semi <+> prettyDoc d 847 | Union d1 d2 -> sep [text "union", parens (prettyDoc d1), parens (prettyDoc d2)] 848 | NoDoc -> text "nodoc" 849 | 850 | -- TODO: map strategy for Docs to avoid code duplication 851 | -- Debug: Doc -> [Layout] 852 | flattenDoc :: Doc -> [RDoc] 853 | flattenDoc d = flatten (reduceDoc d) where 854 | flatten NoDoc = [] 855 | flatten Empty = return Empty 856 | flatten (NilAbove d) = map NilAbove (flatten d) 857 | flatten (TextBeside s sl d) = map (TextBeside s sl) (flatten d) 858 | flatten (Nest k d) = map (Nest k) (flatten d) 859 | flatten (Union d1 d2) = flattenDoc d1 ++ flattenDoc d2 860 | flatten (Beside d1 b d2) = error $ "flattenDoc Beside" 861 | flatten (Above d1 b d2) = error $ "flattenDoc Above" 862 | 863 | normalize :: Doc -> RDoc 864 | normalize d = norm d where 865 | norm NoDoc = NoDoc 866 | norm Empty = Empty 867 | norm (NilAbove d) = NilAbove (norm d) 868 | norm (TextBeside s sl (Nest k d)) = norm (TextBeside s sl d) 869 | norm (TextBeside s sl d) = (TextBeside s sl) (norm d) 870 | norm (Nest k (Nest k' d)) = norm $ Nest (k+k') d 871 | norm (Nest 0 d) = norm d 872 | norm (Nest k d) = (Nest k) (norm d) 873 | -- * The arguments of @Union@ are either @TextBeside@, or @NilAbove@. 874 | norm (Union d1 d2) = normUnion (norm d1) (norm d2) 875 | norm d@(Beside d1 b d2) = norm (reduceDoc d) 876 | norm d@(Above d1 b d2) = norm (reduceDoc d) 877 | normUnion d0@(Nest k d) (Union d1 d2) = norm (Union d0 (normUnion d1 d2)) 878 | normUnion (Union d1 d2) d3@(Nest k d) = norm (Union (normUnion d1 d2) d3) 879 | normUnion (Nest k d1) (Nest k' d2) | k == k' = Nest k $ Union (norm d1) (norm d2) 880 | | otherwise = error "normalize: Union Nest length mismatch ?" 881 | normUnion (Nest _ _) d2 = error$ "normUnion Nest "++topLevelCTor d2 882 | normUnion d1 (Nest _ _) = error$ "normUnion Nset "++topLevelCTor d1 883 | normUnion p1 p2 = Union p1 p2 884 | 885 | topLevelCTor :: Doc -> String 886 | topLevelCTor d = tlc d where 887 | tlc NoDoc = "NoDoc" 888 | tlc Empty = "Empty" 889 | tlc (NilAbove d) = "NilAbove" 890 | tlc (TextBeside s sl d) = "TextBeside" 891 | tlc (Nest k d) = "Nest" 892 | tlc (Union d1 d2) = "Union" 893 | tlc (Above _ _ _) = "Above" 894 | tlc (Beside _ _ _) = "Beside" 895 | 896 | -- normalize TextBeside (and consequently apply some laws for simplification) 897 | mergeTexts :: RDoc -> RDoc 898 | mergeTexts = merge where 899 | merge NoDoc = NoDoc 900 | merge Empty = Empty 901 | merge (NilAbove d) = NilAbove (merge d) 902 | merge (TextBeside t1 l1 (TextBeside t2 l2 doc)) = (merge.normalize) (TextBeside (mergeText t1 t2) (l1 +l2) doc) 903 | merge (TextBeside s sl d) = TextBeside s sl (merge d) 904 | merge (Nest k d) = Nest k (merge d) 905 | merge (Union d1 d2) = Union (merge d1) (merge d2) 906 | mergeText t1 t2 = Str $ tdToStr t1 ++ tdToStr t2 907 | 908 | isOneLiner :: RDoc -> Bool 909 | isOneLiner = genericProp (&&) iol where 910 | iol (NilAbove _) = stop False 911 | iol (Union _ _) = stop False 912 | iol NoDoc = stop False 913 | iol _ = recurse True 914 | 915 | hasOneLiner :: RDoc -> Bool 916 | hasOneLiner = genericProp (&&) iol where 917 | iol (NilAbove _) = stop False 918 | iol (Union d1 _) = stop $ hasOneLiner d1 919 | iol NoDoc = stop False 920 | iol _ = recurse True 921 | 922 | -- use elementwise concatenation as generic combinator 923 | extractTexts :: Doc -> [String] 924 | extractTexts = map normWS . genericProp combine go where 925 | combine xs ys = [ a ++ b | a <- xs, b <- ys ] 926 | go (TextBeside s _ _ ) = recurse [tdToStr s] 927 | go (Union d1 d2) = stop $ extractTexts d1 ++ extractTexts d2 928 | go NoDoc = stop [] 929 | go _ = recurse [""] 930 | -- modulo whitespace 931 | normWS txt = filter (not . isWS) txt where 932 | isWS ws | ws == ' ' || ws == '\n' || ws == '\t' = True 933 | | otherwise = False 934 | 935 | emptyReduction :: Doc -> Doc 936 | emptyReduction doc = 937 | case doc of 938 | Empty -> Empty 939 | NilAbove d -> case emptyReduction d of Empty -> Empty ; d' -> NilAbove d' 940 | TextBeside s sl d -> TextBeside s sl (emptyReduction d) 941 | Nest k d -> case emptyReduction d of Empty -> Empty; d -> Nest k d 942 | Union d1 d2 -> case emptyReduction d2 of Empty -> Empty; _ -> Union d1 d2 -- if d2 is empty, both have to be 943 | NoDoc -> NoDoc 944 | Beside d1 _ d2 -> emptyReduction (reduceDoc doc) 945 | Above d1 _ d2 -> emptyReduction (reduceDoc doc) 946 | 947 | firstLineLength :: Doc -> Int 948 | firstLineLength = genericProp (+) fll . reduceDoc where 949 | fll (NilAbove d) = stop 0 950 | fll (TextBeside _ l d) = recurse l 951 | fll (Nest k d) = recurse k 952 | fll (Union d1 d2) = stop (firstLineLength d1) -- inductively assuming inv7 953 | fll (Above _ _ _) = error "Above" 954 | fll (Beside _ _ _) = error "Beside" 955 | fll _ = (0,True) 956 | 957 | abstractLayout :: Doc -> [(Int,String)] 958 | abstractLayout d = cal 0 Nothing (reduceDoc d) where 959 | -- current column -> this line -> doc -> [(indent,line)] 960 | cal :: Int -> (Maybe (Int,String)) -> Doc -> [(Int,String)] 961 | cal k cur Empty = [ addTextEOL k (Str "") cur ] 962 | cal k cur (NilAbove d) = (addTextEOL k (Str "") cur) : cal k Nothing d 963 | cal k cur (TextBeside s sl d) = cal (k+sl) (addText k s cur) d 964 | cal k cur (Nest n d) = cal (k+n) cur d 965 | cal _ _ (Union d1 d2) = error "abstractLayout: Union" 966 | cal _ _ NoDoc = error "NoDoc" 967 | cal _ _ (Above _ _ _) = error "Above" 968 | cal _ _ (Beside _ _ _) = error "Beside" 969 | addTextEOL k str Nothing = (k,tdToStr str) 970 | addTextEOL _ str (Just (k,pre)) = (k,pre++ tdToStr str) 971 | addText k str = Just . addTextEOL k str 972 | 973 | docifyLayout :: [(Int,String)] -> Doc 974 | docifyLayout = vcat . map (\(k,t) -> nest k (text t)) 975 | 976 | oneLineRender :: Doc -> String 977 | oneLineRender = olr . abstractLayout . last . flattenDoc where 978 | olr = concat . intersperse " " . map snd 979 | 980 | -- because of invariant 4, we do not have to expand to layouts here 981 | -- but it is easier, so for now we use abstractLayout 982 | firstLineIsLeftMost :: Doc -> Bool 983 | firstLineIsLeftMost = all (firstIsLeftMost . abstractLayout) . flattenDoc where 984 | firstIsLeftMost ((k,_):xs@(_:_)) = all ( (>= k) . fst) xs 985 | firstIsLeftMost _ = True 986 | 987 | noNegativeIndent :: Doc -> Bool 988 | noNegativeIndent = all (noNegIndent . abstractLayout) . flattenDoc where 989 | noNegIndent = all ( (>= 0) . fst) 990 | 991 | --------------------------------------------------------------------------------