prettyprinter 1.6.0 → 1.6.1
raw patch · 13 files changed
+373/−145 lines, 13 files
Files
- CHANGELOG.md +10/−0
- bench/LargeOutput.hs +18/−3
- prettyprinter.cabal +2/−2
- src/Data/Text/Prettyprint/Doc/Internal.hs +266/−64
- src/Data/Text/Prettyprint/Doc/Internal/Debug.hs +14/−14
- src/Data/Text/Prettyprint/Doc/Render/Text.hs +2/−2
- src/Data/Text/Prettyprint/Doc/Render/Tutorials/StackMachineTutorial.hs +2/−2
- src/Data/Text/Prettyprint/Doc/Render/Tutorials/TreeRenderingTutorial.hs +2/−2
- src/Data/Text/Prettyprint/Doc/Render/Util/SimpleDocTree.hs +3/−2
- src/Data/Text/Prettyprint/Doc/Render/Util/StackMachine.hs +3/−4
- src/Data/Text/Prettyprint/Doc/Symbols/Ascii.hs +18/−18
- src/Data/Text/Prettyprint/Doc/Symbols/Unicode.hs +17/−19
- test/Testsuite/Main.hs +16/−13
CHANGELOG.md view
@@ -1,3 +1,13 @@+# 1.6.1++- Use an export list in `Data.Text.Prettyprint.Doc.Internal`.+- Improve `group` for `Union` and `FlatAlt`.+- Speed up `removeTrailingWhitespace`.+- Improve generating spaces for indentation and `spaces`.+- Simplify some `Doc` constants by defining them as `Doc` literals.+- Enable `-O2`.+- Various documentation fixes and improvements.+ # 1.6.0 ## Breaking changes
bench/LargeOutput.hs view
@@ -183,12 +183,27 @@ (progLines, progWidth) = let l = TL.lines renderedProg in (length l, maximum (map TL.length l)) putDoc ("Program size:" <+> pretty progLines <+> "lines, maximum width:" <+> pretty progWidth) - rnf prog `seq` T.putStrLn "Staring benchmark…"+ let renderWith :: (Doc ann -> SimpleDocStream ann) -> Program -> TL.Text+ renderWith f = renderLazy . f . pretty++ let _80ColumnsLayoutOptions = defaultLayoutOptions { layoutPageWidth = AvailablePerLine 80 0.5 }+ unboundedLayoutOptions = defaultLayoutOptions { layoutPageWidth = Unbounded }++ rnf prog `seq` T.putStrLn "Starting benchmark…"+ defaultMain [ bgroup "80 characters, 50% ribbon"- [ bench "prettyprinter" (nf (renderLazy . layoutPretty defaultLayoutOptions { layoutPageWidth = AvailablePerLine 80 0.5 } . pretty) prog)+ [ bgroup "prettyprinter"+ [ bench "layoutPretty" (nf (renderWith (layoutPretty _80ColumnsLayoutOptions)) prog)+ , bench "layoutSmart" (nf (renderWith (layoutSmart _80ColumnsLayoutOptions)) prog)+ , bench "layoutCompact" (nf (renderWith layoutCompact ) prog)+ ] , bench "ansi-wl-pprint" (nf (($ "") . WL.displayS . WL.renderPretty 0.5 80 . WL.pretty) prog) ] , bgroup "Infinite/large page width"- [ bench "prettyprinter" (nf (renderLazy . layoutPretty defaultLayoutOptions { layoutPageWidth = Unbounded } . pretty) prog)+ [ bgroup "prettyprinter"+ [ bench "layoutPretty" (nf (renderWith (layoutPretty unboundedLayoutOptions)) prog)+ , bench "layoutSmart" (nf (renderWith (layoutSmart unboundedLayoutOptions)) prog)+ , bench "layoutCompact" (nf (renderWith layoutCompact ) prog)+ ] , bench "ansi-wl-pprint" (nf (($ "") . WL.displayS . WL.renderPretty 1 (fromIntegral progWidth + 10) . WL.pretty) prog) ] ]
prettyprinter.cabal view
@@ -1,5 +1,5 @@ name: prettyprinter-version: 1.6.0+version: 1.6.1 cabal-version: >= 1.10 category: User Interfaces, Text synopsis: A modern, easy to use, well-documented, extensible pretty-printer.@@ -44,7 +44,7 @@ -- Deprecated , Data.Text.Prettyprint.Doc.Render.ShowS - ghc-options: -Wall+ ghc-options: -Wall -O2 hs-source-dirs: src include-dirs: misc default-language: Haskell2010
src/Data/Text/Prettyprint/Doc/Internal.hs view
@@ -15,10 +15,68 @@ -- For a stable API, use the non-internal modules. For the special case of -- writing adaptors to this library’s @'Doc'@ type, see -- "Data.Text.Prettyprint.Doc.Internal.Type".-module Data.Text.Prettyprint.Doc.Internal where+module Data.Text.Prettyprint.Doc.Internal (+ -- * Documents+ Doc(..), + -- * Basic functionality+ Pretty(..),+ viaShow, unsafeViaShow, unsafeTextWithoutNewlines,+ emptyDoc, nest, line, line', softline, softline', hardline, group, flatAlt, + -- * Alignment functions+ align, hang, indent, encloseSep, list, tupled, + -- * Binary functions+ (<+>),++ -- * List functions+ concatWith,++ -- ** 'sep' family+ hsep, vsep, fillSep, sep,+ -- ** 'cat' family+ hcat, vcat, fillCat, cat,+ -- ** Others+ punctuate,++ -- * Reactive/conditional layouts+ column, nesting, width, pageWidth,++ -- * Filler functions+ fill, fillBreak,++ -- * General convenience+ plural, enclose, surround,++ -- ** Annotations+ annotate,+ unAnnotate,+ reAnnotate,+ alterAnnotations,+ unAnnotateS,+ reAnnotateS,+ alterAnnotationsS,++ -- * Optimization+ fuse, FusionDepth(..),++ -- * Layout+ SimpleDocStream(..),+ PageWidth(..), defaultPageWidth,+ LayoutOptions(..), defaultLayoutOptions,+ layoutPretty, layoutCompact, layoutSmart,+ removeTrailingWhitespace,++ -- * Rendering+ renderShowS,++ -- * Internal helpers+ textSpaces+) where+++ import Control.Applicative import Data.Int import Data.List.NonEmpty (NonEmpty (..))@@ -46,10 +104,6 @@ import Prelude hiding (foldr, foldr1) #endif -#if !(MONOID_IN_PRELUDE)-import Data.Monoid hiding ((<>))-#endif- #if FUNCTOR_IDENTITY_IN_BASE import Data.Functor.Identity #endif@@ -475,7 +529,7 @@ -- 'softline' = 'group' 'line' -- @ softline :: Doc ann-softline = group line+softline = Union (Char ' ') Line -- | @'softline''@ is like @'softline'@, but behaves like @'mempty'@ if the -- resulting output does not fit on the page (instead of @'space'@). In other@@ -497,7 +551,7 @@ -- 'softline'' = 'group' 'line'' -- @ softline' :: Doc ann-softline' = group line'+softline' = Union mempty Line -- | A @'hardline'@ is /always/ laid out as a line break, even when 'group'ed or -- when there is plenty of space. Note that it might still be simply discarded@@ -523,10 +577,16 @@ -- use of it. group :: Doc ann -> Doc ann -- See note [Group: special flattening]-group x = case changesUponFlattening x of- Flattened x' -> Union x' x- AlreadyFlat -> x- NeverFlat -> x+group x = case x of+ Union{} -> x+ FlatAlt a b -> case changesUponFlattening b of+ Flattened b' -> Union b' a+ AlreadyFlat -> Union b a+ NeverFlat -> a+ _ -> case changesUponFlattening x of+ Flattened x' -> Union x' x+ AlreadyFlat -> x+ NeverFlat -> x -- Note [Group: special flattening] --@@ -1136,7 +1196,10 @@ -- | Insert a number of spaces. Negative values count as 0. spaces :: Int -> Doc ann-spaces n = unsafeTextWithoutNewlines (T.replicate n " ")+spaces n+ | n <= 0 = Empty+ | n == 1 = Char ' '+ | otherwise = Text n (textSpaces n) -- $ -- prop> \(NonNegative n) -> length (show (spaces n)) == n@@ -1481,14 +1544,16 @@ -> Int -- Withheld spaces -> SimpleDocStream ann -> SimpleDocStream ann- commitWhitespace is0 n0 = commitLines is0 . commitSpaces n0- where- commitLines [] = id- commitLines (i:is) = foldr (\_ f -> SLine 0 . f) (SLine i) is+ commitWhitespace is !n sds = case is of+ [] -> case n of+ 0 -> sds+ 1 -> SChar ' ' sds+ _ -> SText n (textSpaces n) sds+ (i:is') -> let !end = SLine (i + n) sds+ in prependEmptyLines is' end - commitSpaces 0 = id- commitSpaces 1 = SChar ' '- commitSpaces n = SText n (T.replicate n " ")+ prependEmptyLines :: [Int] -> SimpleDocStream ann -> SimpleDocStream ann+ prependEmptyLines is sds0 = foldr (\_ sds -> SLine 0 sds) sds0 is go :: WhitespaceStrippingState -> SimpleDocStream ann -> SimpleDocStream ann -- We do not strip whitespace inside annotated documents, since it might@@ -1509,7 +1574,7 @@ -- release only the necessary ones. go (RecordedWhitespace withheldLines withheldSpaces) = \sds -> case sds of SFail -> SFail- SEmpty -> foldr (\_i sds' -> SLine 0 sds') SEmpty withheldLines+ SEmpty -> prependEmptyLines withheldLines SEmpty SChar c rest | c == ' ' -> go (RecordedWhitespace withheldLines (withheldSpaces+1)) rest | otherwise -> commitWhitespace@@ -1543,15 +1608,7 @@ deriving Typeable --- | Test whether a docstream starts with a linebreak, ignoring any annotations.-startsWithLine :: SimpleDocStream ann -> Bool-startsWithLine sds = case sds of- SLine{} -> True- SAnnPush _ s -> startsWithLine s- SAnnPop s -> startsWithLine s- _ -> False - -- $ -- >>> import qualified Data.Text.IO as T -- >>> doc = "lorem" <> hardline <> hardline <> pretty "ipsum"@@ -1704,7 +1761,7 @@ -- >>> let hr = pipe <> pretty (replicate (26-2) '-') <> pipe -- >>> let go layouter x = (T.putStrLn . renderStrict . layouter (LayoutOptions (AvailablePerLine 26 1))) (vsep [hr, x, hr]) ----- If we render this using @'layoutPretty'@ with a page width of 26 characters+-- If we render this using 'layoutPretty' with a page width of 26 characters -- per line, all the @fun@ calls fit into the first line so they will be put -- there, --@@ -1729,22 +1786,38 @@ -- , ghijklm ]))))) -- |------------------------| ----- The key difference between @'layoutPretty'@ and @'layoutSmart'@ is that the--- latter will check the potential document up to the end of the current--- indentation level, instead of just having one element lookahead.+-- The key difference between 'layoutPretty' and 'layoutSmart' is that the+-- latter will check the potential document until it encounters a line with the+-- same indentation or less than the start of the document. Any line encountered+-- earlier is assumed to belong to the same syntactic structure.+-- 'layoutPretty' checks only the first line.+--+-- Consider for example the question of whether the @A@s fit into the document+-- below:+--+-- > 1 A+-- > 2 A+-- > 3 A+-- > 4 B+-- > 5 B+--+-- 'layoutPretty' will check only line 1, ignoring whether e.g. line 2 might+-- already be too wide.+-- By contrast, 'layoutSmart' stops only once it reaches line 4, where the @B@+-- has the same indentation as the first @A@. layoutSmart :: LayoutOptions -> Doc ann -> SimpleDocStream ann layoutSmart = layoutWadlerLeijen (FittingPredicate fits) where- -- Search with more lookahead: assuming that nesting roughly corresponds to- -- syntactic depth, @fits@ checks that not only the current line fits, but- -- the entire syntactic structure being formatted at this level of- -- indentation fits. If we were to remove the second case for @SLine@, we- -- would check that not only the current structure fits, but also the rest- -- of the document, which would be slightly more intelligent but would have- -- exponential runtime (and is prohibitively expensive in practice).+ -- Why doesn't layoutSmart simply check the entire document?+ --+ -- 1. That would be very expensive.+ -- 2. In that case the layout of a particular part of a document would+ -- depend on the fit of completely unrelated parts of the same document.+ -- See https://github.com/quchen/prettyprinter/issues/83 for a related+ -- bug. fits :: PageWidth -> Int -- ^ Minimum nesting level to fit in -> Int -- ^ Width in which to fit the first line@@ -1800,26 +1873,37 @@ Nesting f -> best nl cc (Cons i (f i) ds) Annotated ann x -> SAnnPush ann (best nl cc (Cons i x (UndoAnn ds))) + -- Select the better fitting of two documents:+ -- Choice A if it fits, otherwise choice B.+ --+ -- The fit of choice B is /not/ checked! It is ultimately the user's+ -- responsibility to provide an alternative that can fit the page even when+ -- choice A doesn't. selectNicer :: Int -- ^ Current nesting level -> Int -- ^ Current column- -> SimpleDocStream ann -- ^ Choice A. Invariant: first lines should not be longer than B's.- -> SimpleDocStream ann -- ^ Choice B.+ -> SimpleDocStream ann -- ^ Choice A.+ -> SimpleDocStream ann -- ^ Choice B. Should fit more easily+ -- (== be less wide) than choice A. -> SimpleDocStream ann -- ^ Choice A if it fits, otherwise B. selectNicer lineIndent currentColumn x y = case pWidth of AvailablePerLine lineLength ribbonFraction | fits pWidth minNestingLevel availableWidth x -> x where minNestingLevel =- -- See https://github.com/quchen/prettyprinter/issues/83.- if startsWithLine y- -- y might be a (more compact) hanging layout. Let's check x- -- thoroughly with the smaller lineIndent.- then lineIndent- -- y definitely isn't a hanging layout. Let's allow the first- -- line of x to be checked on its own and format it consistently- -- with subsequent lines with the same indentation.- else currentColumn+ -- See the Note+ -- [Choosing the right minNestingLevel for consistent smart layouts]+ case initialIndentation y of+ Just i ->+ -- y could be a (less wide) hanging layout. If so, let's+ -- check x a bit more thoroughly so we don't miss a potentially+ -- better fitting y.+ min i currentColumn+ Nothing ->+ -- y definitely isn't a hanging layout. Let's check x with the+ -- same minNestingLevel that any subsequent lines with the same+ -- indentation use.+ currentColumn availableWidth = min columnsLeftInLine columnsLeftInRibbon where columnsLeftInLine = lineLength - currentColumn@@ -1832,6 +1916,13 @@ | not (failsOnFirstLine x) -> x _ -> y + initialIndentation :: SimpleDocStream ann -> Maybe Int+ initialIndentation sds = case sds of+ SLine i _ -> Just i+ SAnnPush _ s -> initialIndentation s+ SAnnPop s -> initialIndentation s+ _ -> Nothing+ failsOnFirstLine :: SimpleDocStream ann -> Bool failsOnFirstLine = go where@@ -1845,23 +1936,120 @@ SAnnPop s -> go s --- Note [Detecting failure with Unbounded page width]------ To understand why it is sufficient to check the first line of the--- SimpleDocStream, trace how an SFail ends up there:------ 1. We group a Doc containing a Line, producing a (Union x y) where--- x contains Fail.------ 2. In best, any Unions are handled recursively, rejecting any--- alternatives that would result in SFail.------ So once a SimpleDocStream reaches selectNicer, any SFail in it must--- appear before the first linebreak – any other SFail would have been--- detected and rejected in a previous iteration.+{- Note [Choosing the right minNestingLevel for consistent smart layouts]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this document: + doc =+ "Groceries: "+ <> align+ (cat+ [ sep ["pommes", "de", "terre"]+ , "apples"+ , "Donaudampfschifffahrtskapitänskajütenmülleimer"+ ]+ ) +... and assume we want to fit it into 40 columns as nicely as possible: + opts = LayoutOptions (AvailablePerLine 40 1)++We already have bad luck with the last item – it's longer than 40 characters+on its own!++We'd still like the first item, pommes de terre, to be laid out nicely, that is,+on one line, since it's not too wide. This is what we'd like to see:++ Groceries: pommes de terre+ apples+ Donaudampfschifffahrtskapitänskajütenmülleimer++Before #83 was fixed, that wasn't what we got! Instead we got this:++> renderIO stdout $ layoutSmart opts doc+Groceries: pommes+ de+ terre+ apples+ Donaudampfschifffahrtskapitänskajütenmülleimer++Why?++minNestingLevel was effectively defined as++ minNestingLevel = lineIndent++The lineIndent for "pommes de terre" is 0.++The FittingPredicate for layoutSmart will continue to check the rest of the+document until it finds a line where the indentation <= minNestingLevel.+In this case this meant that layoutSmart would traverse all the items,+and note that the last item, Donaudampfschifffahrtskapitänskajütenmülleimer,+doesn't fit into the available space! The "flatter" version of the document+has failed, so "pommes de terre" gets spread over several lines!++Obviously this would be an inconsistency with the layout of the other items.+Their lineIndent is 11 each, so for them, the FittingPredicate stops already+on the next line.++The obvious solution is to change the definition of minNestingLevel:++ minNestingLevel = currentColumn++This however breaks the "python-ish" document from the documentation for+layoutSmart:++ expected: |------------------------|+ fun(+ fun(+ fun(+ fun(+ fun(+ [ abcdef+ , ghijklm ])))))+ |------------------------|++ but got: |------------------------|+ fun(+ fun(+ fun(+ fun(+ fun([ abcdef+ , ghijklm ])))))+ |------------------------|++We now accept the worse layout because the problematic last line has+the same indentation as the current column of "[ abcdef", so we don't check it!++The solution we went with in the end is a bit of a hack:++We check whether the alternative, "high" layout is a (potentially less wide)+hanging layout, and in that case pick its indentation as the minNestingLevel.++This way we achieve the optimal layout in both scenarios.++See https://github.com/quchen/prettyprinter/issues/83 for the bug that lead+to the current solution.+++Note [Detecting failure with Unbounded page width]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+To understand why it is sufficient to check the first line of the+SimpleDocStream, trace how an SFail ends up there:++1. We group a Doc containing a Line, producing a (Union x y) where+ x contains Fail.++2. In best, any Unions are handled recursively, rejecting any+ alternatives that would result in SFail.++So once a SimpleDocStream reaches selectNicer, any SFail in it must+appear before the first linebreak – any other SFail would have been+detected and rejected in a previous iteration.+-}+++ -- | @(layoutCompact x)@ lays out the document @x@ without adding any -- indentation. Since no \'pretty\' printing is involved, this layouter is very -- fast. The resulting output contains fewer characters than a prettyprinted@@ -1920,6 +2108,20 @@ SLine i x -> showString ('\n' : replicate i ' ') . renderShowS x SAnnPush _ x -> renderShowS x SAnnPop x -> renderShowS x+++-- | A utility for producing indentation etc.+--+-- >>> textSpaces 3+-- " "+--+-- This produces much better Core than the equivalent+--+-- > T.replicate n " "+--+-- (See <https://github.com/quchen/prettyprinter/issues/131>.)+textSpaces :: Int -> Text+textSpaces n = T.replicate n (T.singleton ' ') -- $setup
src/Data/Text/Prettyprint/Doc/Internal/Debug.hs view
@@ -7,19 +7,19 @@ -- Use the @pretty-simple@ package to get a nicer layout for 'show'n -- 'Diag's: ----- >>> Text.Pretty.Simple.pPrintNoColor . diag $ align (vcat ["foo", "bar"])--- Column--- [--- ( 10--- , Nesting--- [--- ( 10--- , Cat ( Text 3 "foo" )--- ( Cat ( FlatAlt Line Empty ) ( Text 3 "bar" ) )--- )--- ]--- )--- ]+-- > > Text.Pretty.Simple.pPrintNoColor . diag $ align (vcat ["foo", "bar"])+-- > Column+-- > [+-- > ( 10+-- > , Nesting+-- > [+-- > ( 10+-- > , Cat ( Text 3 "foo" )+-- > ( Cat ( FlatAlt Line Empty ) ( Text 3 "bar" ) )+-- > )+-- > ]+-- > )+-- > ] module Data.Text.Prettyprint.Doc.Internal.Debug where@@ -59,7 +59,7 @@ -- -- Use `diag'` to control the function inputs yourself. ----- >>> diag $ align (vcat ["foo", "bar"])+-- >>> diag $ Doc.align (Doc.vcat ["foo", "bar"]) -- Column [(10,Nesting [(10,Cat (Text 3 "foo") (Cat (FlatAlt Line Empty) (Text 3 "bar")))])] diag :: Doc ann -> Diag ann diag = diag' [10] [Doc.defaultPageWidth] [10]
src/Data/Text/Prettyprint/Doc/Render/Text.hs view
@@ -18,13 +18,13 @@ import Data.Text (Text)-import qualified Data.Text as T import qualified Data.Text.IO as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Builder as TLB import System.IO import Data.Text.Prettyprint.Doc+import Data.Text.Prettyprint.Doc.Internal import Data.Text.Prettyprint.Doc.Render.Util.Panic import Data.Text.Prettyprint.Doc.Render.Util.StackMachine @@ -86,7 +86,7 @@ SText _ t rest -> do T.hPutStr h t go rest SLine n rest -> do hPutChar h '\n'- T.hPutStr h (T.replicate n " ")+ T.hPutStr h (textSpaces n) go rest SAnnPush _ann rest -> go rest SAnnPop rest -> go rest
src/Data/Text/Prettyprint/Doc/Render/Tutorials/StackMachineTutorial.hs view
@@ -20,11 +20,11 @@ {-# DEPRECATED "Writing your own stack machine is probably more efficient and customizable; also consider using »renderSimplyDecorated(A)« instead" #-} where -import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Builder as TLB import Data.Text.Prettyprint.Doc+import Data.Text.Prettyprint.Doc.Internal import Data.Text.Prettyprint.Doc.Render.Util.Panic import Data.Text.Prettyprint.Doc.Render.Util.StackMachine @@ -92,7 +92,7 @@ renderStackMachine x SLine i x -> do writeOutput (TLB.singleton '\n')- writeOutput (TLB.fromText (T.replicate i " "))+ writeOutput (TLB.fromText (textSpaces i)) renderStackMachine x SAnnPush s x -> do pushStyle s
src/Data/Text/Prettyprint/Doc/Render/Tutorials/TreeRenderingTutorial.hs view
@@ -15,11 +15,11 @@ -- source form. module Data.Text.Prettyprint.Doc.Render.Tutorials.TreeRenderingTutorial where -import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Builder as TLB import Data.Text.Prettyprint.Doc+import Data.Text.Prettyprint.Doc.Internal import Data.Text.Prettyprint.Doc.Render.Util.SimpleDocTree #if !(FOLDABLE_TRAVERSABLE_IN_PRELUDE)@@ -87,7 +87,7 @@ STEmpty -> mempty STChar c -> TLB.singleton c STText _ t -> TLB.fromText t- STLine i -> "\n" <> TLB.fromText (T.replicate i " ")+ STLine i -> "\n" <> TLB.fromText (textSpaces i) STAnn ann content -> encloseInTagFor ann (renderTree content) STConcat contents -> foldMap renderTree contents
src/Data/Text/Prettyprint/Doc/Render/Util/SimpleDocTree.hs view
@@ -32,6 +32,7 @@ import GHC.Generics import Data.Text.Prettyprint.Doc+import Data.Text.Prettyprint.Doc.Internal import Data.Text.Prettyprint.Doc.Render.Util.Panic import qualified Control.Monad.Fail as Fail@@ -75,7 +76,7 @@ STEmpty -> mempty STChar c -> text (T.singleton c) STText _ t -> text t- STLine i -> text (T.singleton '\n' <> T.replicate i " ")+ STLine i -> text (T.singleton '\n') `mappend` text (textSpaces i) STAnn ann rest -> renderAnn ann (go rest) STConcat xs -> foldMap go xs {-# INLINE renderSimplyDecorated #-}@@ -93,7 +94,7 @@ STEmpty -> pure mempty STChar c -> text (T.singleton c) STText _ t -> text t- STLine i -> text (T.singleton '\n' <> T.replicate i " ")+ STLine i -> text (T.cons '\n' (textSpaces i)) STAnn ann rest -> renderAnn ann (go rest) STConcat xs -> fmap mconcat (traverse go xs) {-# INLINE renderSimplyDecoratedA #-}
src/Data/Text/Prettyprint/Doc/Render/Util/StackMachine.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-} #include "version-compatibility-macros.h" @@ -36,7 +35,7 @@ import Data.Text (Text) import qualified Data.Text as T -import Data.Text.Prettyprint.Doc (SimpleDocStream (..))+import Data.Text.Prettyprint.Doc.Internal import Data.Text.Prettyprint.Doc.Render.Util.Panic #if !(SEMIGROUP_MONOID_SUPERCLASS)@@ -78,7 +77,7 @@ go (_:_) SEmpty = panicInputNotFullyConsumed go stack (SChar c rest) = text (T.singleton c) <> go stack rest go stack (SText _l t rest) = text t <> go stack rest- go stack (SLine i rest) = text (T.singleton '\n') <> text (T.replicate i " ") <> go stack rest+ go stack (SLine i rest) = text (T.singleton '\n') <> text (textSpaces i) <> go stack rest go stack (SAnnPush ann rest) = push ann <> go (ann : stack) rest go (ann:stack) (SAnnPop rest) = pop ann <> go stack rest go [] SAnnPop{} = panicUnpairedPop@@ -99,7 +98,7 @@ go (_:_) SEmpty = panicInputNotFullyConsumed go stack (SChar c rest) = text (T.singleton c) <++> go stack rest go stack (SText _l t rest) = text t <++> go stack rest- go stack (SLine i rest) = text (T.singleton '\n') <++> text (T.replicate i " ") <++> go stack rest+ go stack (SLine i rest) = text (T.singleton '\n') <++> text (textSpaces i) <++> go stack rest go stack (SAnnPush ann rest) = push ann <++> go (ann : stack) rest go (ann:stack) (SAnnPop rest) = pop ann <++> go stack rest go [] SAnnPop{} = panicUnpairedPop
src/Data/Text/Prettyprint/Doc/Symbols/Ascii.hs view
@@ -46,65 +46,65 @@ -- | >>> squote -- ' squote :: Doc ann-squote = "'"+squote = Char '\'' -- | >>> dquote -- " dquote :: Doc ann-dquote = "\""+dquote = Char '"' -- | >>> lparen -- ( lparen :: Doc ann-lparen = "("+lparen = Char '(' -- | >>> rparen -- ) rparen :: Doc ann-rparen = ")"+rparen = Char ')' -- | >>> langle -- < langle :: Doc ann-langle = "<"+langle = Char '<' -- | >>> rangle -- > rangle :: Doc ann-rangle = ">"+rangle = Char '>' -- | >>> lbracket -- [ lbracket :: Doc ann-lbracket = "["+lbracket = Char '[' -- | >>> rbracket -- ] rbracket :: Doc ann-rbracket = "]"+rbracket = Char ']' -- | >>> lbrace -- { lbrace :: Doc ann-lbrace = "{"+lbrace = Char '{' -- | >>> rbrace -- } rbrace :: Doc ann-rbrace = "}"+rbrace = Char '}' -- | >>> semi -- ; semi :: Doc ann-semi = ";"+semi = Char ';' -- | >>> colon -- : colon :: Doc ann-colon = ":"+colon = Char ':' -- | >>> comma -- , comma :: Doc ann-comma = ","+comma = Char ',' -- | >>> "a" <> space <> "b" -- a b@@ -114,17 +114,17 @@ -- >>> "a" <+> "b" -- a b space :: Doc ann-space = " "+space = Char ' ' -- | >>> dot -- . dot :: Doc ann-dot = "."+dot = Char '.' -- | >>> slash -- / slash :: Doc ann-slash = "/"+slash = Char '/' -- | >>> backslash -- \\@@ -135,12 +135,12 @@ -- | >>> equals -- = equals :: Doc ann-equals = "="+equals = Char '=' -- | >>> pipe -- | pipe :: Doc ann-pipe = "|"+pipe = Char '|'
src/Data/Text/Prettyprint/Doc/Symbols/Unicode.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE OverloadedStrings #-}- -- | A collection of predefined Unicode values outside of ASCII range. For -- ASCII, see "Data.Text.Prettyprint.Doc.Symbols.Ascii". module Data.Text.Prettyprint.Doc.Symbols.Unicode (@@ -41,7 +39,7 @@ -import Data.Text.Prettyprint.Doc+import Data.Text.Prettyprint.Doc.Internal @@ -106,100 +104,100 @@ -- >>> putDoc b99dquote -- „ b99dquote :: Doc ann-b99dquote = "„"+b99dquote = Char '„' -- | Top “66” style double quotes. -- -- >>> putDoc t66dquote -- “ t66dquote :: Doc ann-t66dquote = "“"+t66dquote = Char '“' -- | Top “99” style double quotes. -- -- >>> putDoc t99dquote -- ” t99dquote :: Doc ann-t99dquote = "”"+t99dquote = Char '”' -- | Bottom ‚9‘ style single quote. -- -- >>> putDoc b9quote -- ‚ b9quote :: Doc ann-b9quote = "‚"+b9quote = Char '‚' -- | Top ‘66’ style single quote. -- -- >>> putDoc t6quote -- ‘ t6quote :: Doc ann-t6quote = "‘"+t6quote = Char '‘' -- | Top ‘9’ style single quote. -- -- >>> putDoc t9quote -- ’ t9quote :: Doc ann-t9quote = "’"+t9quote = Char '’' -- | Right-pointing double guillemets -- -- >>> putDoc rdGuillemet -- » rdGuillemet :: Doc ann-rdGuillemet = "»"+rdGuillemet = Char '»' -- | Left-pointing double guillemets -- -- >>> putDoc ldGuillemet -- « ldGuillemet :: Doc ann-ldGuillemet = "«"+ldGuillemet = Char '«' -- | Right-pointing single guillemets -- -- >>> putDoc rsGuillemet -- › rsGuillemet :: Doc ann-rsGuillemet = "›"+rsGuillemet = Char '›' -- | Left-pointing single guillemets -- -- >>> putDoc lsGuillemet -- ‹ lsGuillemet :: Doc ann-lsGuillemet = "‹"+lsGuillemet = Char '‹' -- | >>> putDoc bullet -- • bullet :: Doc ann-bullet = "•"+bullet = Char '•' -- | >>> putDoc endash -- – endash :: Doc ann-endash = "–"+endash = Char '–' -- | >>> putDoc euro -- € euro :: Doc ann-euro = "€"+euro = Char '€' -- | >>> putDoc cent -- ¢ cent :: Doc ann-cent = "¢"+cent = Char '¢' -- | >>> putDoc yen -- ¥ yen :: Doc ann-yen = "¥"+yen = Char '¥' -- | >>> putDoc pound -- £ pound :: Doc ann-pound = "£"+pound = Char '£'
test/Testsuite/Main.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -Wno-orphans #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} #include "version-compatibility-macros.h" @@ -16,7 +16,6 @@ import System.Timeout (timeout) import Data.Text.Prettyprint.Doc-import Data.Text.Prettyprint.Doc.Internal import Data.Text.Prettyprint.Doc.Internal.Debug import Data.Text.Prettyprint.Doc.Render.Text import Data.Text.Prettyprint.Doc.Render.Util.StackMachine (renderSimplyDecorated)@@ -199,12 +198,9 @@ = LayoutPretty LayoutOptions | LayoutSmart LayoutOptions | LayoutCompact- | LayoutWadlerLeijen (FittingPredicate ann) LayoutOptions+ -- LayoutWadlerLeijen (FittingPredicate ann) LayoutOptions deriving Show -instance Show (FittingPredicate ann) where- show _ = "<fitting predicate>"- instance Arbitrary (Layouter ann) where arbitrary = oneof [ LayoutPretty <$> arbitrary@@ -214,11 +210,19 @@ -- , LayoutWadlerLeijen <$> arbitrary <*> arbitrary ] +{-+instance Show (FittingPredicate ann) where+ show _ = "<fitting predicate>"++instance Arbitrary (FittingPredicate ann) where+ arbitrary = FittingPredicate <$> arbitrary+-}+ layout :: Layouter ann -> Doc ann -> SimpleDocStream ann layout (LayoutPretty opts) = layoutPretty opts layout (LayoutSmart opts) = layoutSmart opts layout LayoutCompact = layoutCompact-layout (LayoutWadlerLeijen fp opts) = layoutWadlerLeijen fp opts+-- layout (LayoutWadlerLeijen fp opts) = layoutWadlerLeijen fp opts instance Arbitrary LayoutOptions where arbitrary = LayoutOptions <$> oneof@@ -226,9 +230,6 @@ , pure Unbounded ] -instance Arbitrary (FittingPredicate ann) where- arbitrary = FittingPredicate <$> arbitrary- instance CoArbitrary (SimpleDocStream ann) where coarbitrary s0 = case s0 of SFail -> variant' 0@@ -302,19 +303,21 @@ doNotRemoveLeadingWhitespaceText = let sdoc :: SimpleDocStream () sdoc = SLine 0 (SText 2 " " (SChar 'x' SEmpty))- in assertEqual "" sdoc (removeTrailingWhitespace sdoc)+ sdoc' = SLine 2 (SChar 'x' SEmpty)+ in assertEqual "" sdoc' (removeTrailingWhitespace sdoc) doNotRemoveLeadingWhitespaceChar :: Assertion doNotRemoveLeadingWhitespaceChar = let sdoc :: SimpleDocStream () sdoc = SLine 0 (SChar ' ' (SChar 'x' SEmpty))- in assertEqual "" sdoc (removeTrailingWhitespace sdoc)+ sdoc' = SLine 1 (SChar 'x' SEmpty)+ in assertEqual "" sdoc' (removeTrailingWhitespace sdoc) doNotRemoveLeadingWhitespaceTextChar :: Assertion doNotRemoveLeadingWhitespaceTextChar = let sdoc :: SimpleDocStream () sdoc = SLine 0 (SChar ' ' (SText 2 " " (SChar 'x' SEmpty)))- sdoc' = SLine 0 (SText 3 " " (SChar 'x' SEmpty))+ sdoc' = SLine 3 (SChar 'x' SEmpty) in assertEqual "" sdoc' (removeTrailingWhitespace sdoc) removeTrailingWhitespaceKeepTrailingNewline :: Assertion