wl-pprint-annotated 0.0.1.1 → 0.0.1.2
raw patch · 3 files changed
+192/−172 lines, 3 filesdep ~base
Dependency ranges changed: base
Files
- src/Text/PrettyPrint/Annotated/WL.hs +183/−165
- test/WLPPrintTests.hs +4/−4
- wl-pprint-annotated.cabal +5/−3
src/Text/PrettyPrint/Annotated/WL.hs view
@@ -37,7 +37,8 @@ -- (1997). Additions and the main differences with his original paper -- are: ----- * The nil document is called mempty.+-- * The nil document is called 'mempty'. We cannot use 'empty'+-- for compatibility with base. -- -- * The operator '</>' is used -- for soft line breaks.@@ -47,31 +48,30 @@ -- -- * Lots of other useful combinators, like 'fillSep' and 'list'. ----- * There are two renderers, 'renderPretty' for pretty printing and--- 'renderCompact' for compact output. The pretty printing algorithm+-- * There are three renderers, 'renderPretty/renderPrettyDefault' and 'renderSmart'+-- for pretty printing and 'renderCompact' for compact output. The pretty printing algorithm -- also uses a ribbon-width now for even prettier output. ----- * There are two display routines, 'displayS' for strings and 'displayIO'--- for file based output.+-- * There are display routines 'displayS' and 'display' for strings,+-- 'displayT' for lazy text, 'displayIO' for file based output.+-- Generalized display routines for display with annotations+-- are provided, i.e., 'displayDecoratedA' and 'displayDecorated'.+-- Furthermore 'displaySpans' exists which creates a monoid and a SpanList+-- of the annotations. ----- * There is a 'Pretty' class.+-- * There is a 'Pretty' class which creates documents without annotations. -- -- * The implementation uses optimised representations and strictness -- annotations. --+-- * There is the wl-pprint-console package, based on this package,+-- which provides additional display routines, e.g., colorful output using+-- ANSI escape sequences. ---{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DefaultSignatures #-}- ----------------------------------------------------------- module Text.PrettyPrint.Annotated.WL ( -- * Documents- Doc, ADoc(..), putDoc, hPutDoc+ Doc(..), putDoc, hPutDoc -- * Basic combinators , char, text, nest, line, linebreak, group, softline@@ -115,8 +115,8 @@ , Pretty(..) -- * Rendering- , SimpleDoc(..), renderPretty, renderCompact, renderSmart- , display, displayS, displayLT, displayIO, displayDecoratedA, displayDecorated+ , SimpleDoc(..), renderPrettyDefault, renderPretty, renderCompact, renderSmart+ , display, displayS, displayT, displayIO, displayDecoratedA, displayDecorated , SpanList, displaySpans -- * Undocumented@@ -127,12 +127,10 @@ , mempty, (<>) ) where -import Data.String import Data.Foldable hiding (fold) import Data.Traversable import Data.Int import Data.Word-import Data.Void import Data.Bifunctor import Data.Functor.Identity import qualified Data.Text as T@@ -146,6 +144,7 @@ import System.IO (Handle,hPutStr,stdout) import Control.DeepSeq (NFData) import GHC.Generics (Generic)+import Data.String (IsString(..)) infixr 5 </>, <//>, <#>, <##> infixr 6 <+>@@ -159,24 +158,24 @@ -- encloses them in square brackets. The documents are rendered -- horizontally if that fits the page. Otherwise they are aligned -- vertically. All comma separators are put in front of the elements.-list :: Foldable f => f (ADoc a) -> ADoc a+list :: Foldable f => f (Doc a) -> Doc a list = encloseSep lbracket rbracket comma -- | The document @(tupled xs)@ comma separates the documents @xs@ and -- encloses them in parenthesis. The documents are rendered -- horizontally if that fits the page. Otherwise they are aligned -- vertically. All comma separators are put in front of the elements.-tupled :: Foldable f => f (ADoc a) -> ADoc a+tupled :: Foldable f => f (Doc a) -> Doc a tupled = encloseSep lparen rparen comma -(<+>) :: ADoc a -> ADoc a -> ADoc a+(<+>) :: Doc a -> Doc a -> Doc a x <+> y = x <> space <> y -- | The document @(semiBraces xs)@ separates the documents @xs@ with -- semi colons and encloses them in braces. The documents are rendered -- horizontally if that fits the page. Otherwise they are aligned -- vertically. All semi colons are put in front of the elements.-semiBraces :: Foldable f => f (ADoc a) -> ADoc a+semiBraces :: Foldable f => f (Doc a) -> Doc a semiBraces = encloseSep lbrace rbrace semi -- | The document @(encloseSep l r sep xs)@ concatenates the documents@@ -202,13 +201,13 @@ -- , 200 -- , 3000 ] -- @-encloseSep :: Foldable f => ADoc a -> ADoc a -> ADoc a -> f (ADoc a) -> ADoc a+encloseSep :: Foldable f => Doc a -> Doc a -> Doc a -> f (Doc a) -> Doc a encloseSep left right sp ds0 = case toList ds0 of [] -> left <> right [d] -> left <> d <> right ds -> group $ align $ left'- <> (vcat (zipWith (<>) (mempty : repeat (sp <> space)) ds))+ <> vcat (zipWith (<>) (mempty : repeat (sp <> space)) ds) <> right' where left' = left <> flatAlt space mempty right' = flatAlt space mempty <> right@@ -242,8 +241,8 @@ -- -- (If you want put the commas in front of their elements instead of -- at the end, you should use 'tupled' or, in general, 'encloseSep'.)-punctuate :: Traversable f => ADoc a -> f (ADoc a) -> f (ADoc a)-punctuate p xs = snd $ mapAccumL (\(d:ds) _ -> (ds, if null ds then d else (d <> p))) (toList xs) xs+punctuate :: Traversable f => Doc a -> f (Doc a) -> f (Doc a)+punctuate p xs = snd $ mapAccumL (\(d:ds) _ -> (ds, if null ds then d else d <> p)) (toList xs) xs ----------------------------------------------------------- -- high-level combinators@@ -255,7 +254,7 @@ -- @(\<\#\>)@. -- -- > sep xs = group (vsep xs)-sep :: Foldable f => f (ADoc a) -> ADoc a+sep :: Foldable f => f (Doc a) -> Doc a sep = group . vsep -- | The document @(fillSep xs)@ concatenates documents @xs@@@ -264,12 +263,12 @@ -- @xs@. -- -- > fillSep xs = foldr (</>) mempty xs-fillSep :: Foldable f => f (ADoc a) -> ADoc a+fillSep :: Foldable f => f (Doc a) -> Doc a fillSep = fold (</>) -- | The document @(hsep xs)@ concatenates all documents @xs@ -- horizontally with @(\<+\>)@.-hsep :: Foldable f => f (ADoc a) -> ADoc a+hsep :: Foldable f => f (Doc a) -> Doc a hsep = fold (<+>) -- | The document @(vsep xs)@ concatenates all documents @xs@@@ -302,7 +301,7 @@ -- lay -- out -- @-vsep :: Foldable f => f (ADoc a) -> ADoc a+vsep :: Foldable f => f (Doc a) -> Doc a vsep = fold (<#>) -- | The document @(cat xs)@ concatenates all documents @xs@ either@@ -310,7 +309,7 @@ -- @(\<\#\#\>)@. -- -- > cat xs = group (vcat xs)-cat :: Foldable f => f (ADoc a) -> ADoc a+cat :: Foldable f => f (Doc a) -> Doc a cat = group . vcat -- | The document @(fillCat xs)@ concatenates documents @xs@@@ -318,31 +317,31 @@ -- a @linebreak@ and continues doing that for all documents in @xs@. -- -- > fillCat xs = foldr (<//>) mempty xs-fillCat :: Foldable f => f (ADoc a) -> ADoc a+fillCat :: Foldable f => f (Doc a) -> Doc a fillCat = fold (<//>) -- | The document @(hcat xs)@ concatenates all documents @xs@ -- horizontally with @(\<\>)@.-hcat :: Foldable f => f (ADoc a) -> ADoc a+hcat :: Foldable f => f (Doc a) -> Doc a hcat = fold (<>) -- | The document @(vcat xs)@ concatenates all documents @xs@ -- vertically with @(\<\#\#\>)@. If a 'group' undoes the line breaks -- inserted by @vcat@, all documents are directly concatenated.-vcat :: Foldable f => f (ADoc a) -> ADoc a+vcat :: Foldable f => f (Doc a) -> Doc a vcat = fold (<##>) -fold :: Foldable f => (ADoc a -> ADoc a -> ADoc a) -> f (ADoc a) -> ADoc a+fold :: Foldable f => (Doc a -> Doc a -> Doc a) -> f (Doc a) -> Doc a fold f xs | null xs = mempty | otherwise = foldr1 f xs -instance Semigroup (ADoc a) where+instance Semigroup (Doc a) where -- | The document @(x \<\> y)@ concatenates document @x@ and document -- @y@. It is an associative operation having 'mempty' as a left and -- right unit. (infixl 6) (<>) = Cat -instance Monoid (ADoc a) where+instance Monoid (Doc a) where mappend = Cat mempty = Empty mconcat = hcat@@ -351,148 +350,147 @@ -- 'softline' in between. This effectively puts @x@ and @y@ either -- next to each other (with a @space@ in between) or underneath each -- other. (infixr 5)-(</>) :: ADoc a -> ADoc a -> ADoc a+(</>) :: Doc a -> Doc a -> Doc a x </> y = x <> softline <> y -- | The document @(x \<\/\/\> y)@ concatenates document @x@ and @y@ with -- a 'softbreak' in between. This effectively puts @x@ and @y@ either -- right next to each other or underneath each other. (infixr 5)-(<//>) :: ADoc a -> ADoc a -> ADoc a+(<//>) :: Doc a -> Doc a -> Doc a x <//> y = x <> softbreak <> y -- | The document @(x \<\#\> y)@ concatenates document @x@ and @y@ with a -- 'line' in between. (infixr 5)-(<#>) :: ADoc a -> ADoc a -> ADoc a+(<#>) :: Doc a -> Doc a -> Doc a x <#> y = x <> line <> y -- | The document @(x \<\#\#\> y)@ concatenates document @x@ and @y@ with -- a @linebreak@ in between. (infixr 5)-(<##>) :: ADoc a -> ADoc a -> ADoc a+(<##>) :: Doc a -> Doc a -> Doc a x <##> y = x <> linebreak <> y -- | The document @softline@ behaves like 'space' if the resulting -- output fits the page, otherwise it behaves like 'line'. -- -- > softline = group line-softline :: ADoc a+softline :: Doc a softline = group line -- | The document @softbreak@ behaves like 'mempty' if the resulting -- output fits the page, otherwise it behaves like 'line'. -- -- > softbreak = group linebreak-softbreak :: ADoc a+softbreak :: Doc a softbreak = group linebreak -- | Document @(squotes x)@ encloses document @x@ with single quotes -- \"'\".-squotes :: ADoc a -> ADoc a+squotes :: Doc a -> Doc a squotes = enclose squote squote -- | Document @(dquotes x)@ encloses document @x@ with double quotes -- '\"'.-dquotes :: ADoc a -> ADoc a+dquotes :: Doc a -> Doc a dquotes = enclose dquote dquote -- | Document @(braces x)@ encloses document @x@ in braces, \"{\" and -- \"}\".-braces :: ADoc a -> ADoc a+braces :: Doc a -> Doc a braces = enclose lbrace rbrace -- | Document @(parens x)@ encloses document @x@ in parenthesis, \"(\" -- and \")\".-parens :: ADoc a -> ADoc a+parens :: Doc a -> Doc a parens = enclose lparen rparen -- | Document @(angles x)@ encloses document @x@ in angles, \"\<\" and -- \"\>\".-angles :: ADoc a -> ADoc a+angles :: Doc a -> Doc a angles = enclose langle rangle -- | Document @(brackets x)@ encloses document @x@ in square brackets, -- \"[\" and \"]\".-brackets :: ADoc a -> ADoc a+brackets :: Doc a -> Doc a brackets = enclose lbracket rbracket -- | The document @(enclose l r x)@ encloses document @x@ between -- documents @l@ and @r@ using @(\<\>)@. -- -- > enclose l r x = l <> x <> r-enclose :: ADoc a -> ADoc a -> ADoc a -> ADoc a+enclose :: Doc a -> Doc a -> Doc a -> Doc a enclose l r x = l <> x <> r -- | The document @lparen@ contains a left parenthesis, \"(\".-lparen :: ADoc a+lparen :: Doc a lparen = char '(' -- | The document @rparen@ contains a right parenthesis, \")\".-rparen :: ADoc a+rparen :: Doc a rparen = char ')' -- | The document @langle@ contains a left angle, \"\<\".-langle :: ADoc a+langle :: Doc a langle = char '<' -- | The document @rangle@ contains a right angle, \">\".-rangle :: ADoc a+rangle :: Doc a rangle = char '>' -- | The document @lbrace@ contains a left brace, \"{\".-lbrace :: ADoc a+lbrace :: Doc a lbrace = char '{' -- | The document @rbrace@ contains a right brace, \"}\".-rbrace :: ADoc a+rbrace :: Doc a rbrace = char '}' -- | The document @lbracket@ contains a left square bracket, \"[\".-lbracket :: ADoc a+lbracket :: Doc a lbracket = char '[' -- | The document @rbracket@ contains a right square bracket, \"]\".-rbracket :: ADoc a+rbracket :: Doc a rbracket = char ']' -- | The document @squote@ contains a single quote, \"'\".-squote :: ADoc a+squote :: Doc a squote = char '\'' -- | The document @dquote@ contains a double quote, '\"'.-dquote :: ADoc a+dquote :: Doc a dquote = char '"' -- | The document @semi@ contains a semi colon, \";\".-semi :: ADoc a+semi :: Doc a semi = char ';' -- | The document @colon@ contains a colon, \":\".-colon :: ADoc a+colon :: Doc a colon = char ':' -- | The document @comma@ contains a comma, \",\".-comma :: ADoc a+comma :: Doc a comma = char ',' -- | The document @space@ contains a single space, \" \". -- -- > x <+> y = x <> space <> y-space :: ADoc a+space :: Doc a space = char ' ' -- | The document @dot@ contains a single dot, \".\".-dot :: ADoc a+dot :: Doc a dot = char '.' -- | The document @backslash@ contains a back slash, \"\\\".-backslash :: ADoc a+backslash :: Doc a backslash = char '\\' -- | The document @equals@ contains an equal sign, \"=\".-equals :: ADoc a+equals :: Doc a equals = char '=' -docMapAnn :: (a -> ADoc a' -> ADoc a') -- ^ Annotate- -> ADoc a -> ADoc a'+docMapAnn :: (a -> Doc a' -> Doc a') -> Doc a -> Doc a' docMapAnn an = go where go Empty = Empty@@ -509,7 +507,7 @@ go (Columns k) = Columns (go . k) go (Ribbon k) = Ribbon (go . k) -instance IsString (ADoc a) where+instance IsString (Doc a) where fromString = pretty -----------------------------------------------------------@@ -520,14 +518,14 @@ -- a => Pretty [a]@. In normal circumstances only the @pretty@ function -- is used. class Pretty a where- pretty :: a -> ADoc b- prettyList :: [a] -> ADoc b+ pretty :: a -> Doc b+ prettyList :: [a] -> Doc b prettyList = list . map pretty - default pretty :: Show a => a -> ADoc b+ default pretty :: Show a => a -> Doc b pretty = text . show -instance Pretty (ADoc a) where+instance Pretty (Doc a) where pretty = noAnnotate instance Pretty a => Pretty [a] where@@ -597,15 +595,15 @@ -- The output will now be: -- -- @--- let mempty :: ADoc a--- nest :: Int -> ADoc a -> ADoc a+-- let mempty :: Doc a+-- nest :: Int -> Doc a -> Doc a -- linebreak--- :: ADoc a+-- :: Doc a -- @-fillBreak :: Int -> ADoc a -> ADoc a+fillBreak :: Int -> Doc a -> Doc a fillBreak f x = width x $ \w ->- if (w > f) then nest f linebreak- else text (spaces (f - w))+ if w > f then nest f linebreak+ else text (spaces (f - w)) -- | The document @(fill i x)@ renders document @x@. It then appends@@ -615,7 +613,7 @@ -- example demonstrates this. -- -- > types = [("mempty","Doc a")--- > ,("nest","Int -> ADoc a -> ADoc a")+-- > ,("nest","Int -> Doc a -> Doc a") -- > ,("linebreak","Doc a")] -- > -- > ptype (name,tp)@@ -626,17 +624,17 @@ -- Which is layed out as: -- -- @--- let mempty :: ADoc a--- nest :: Int -> ADoc a -> ADoc a--- linebreak :: ADoc a+-- let mempty :: Doc a+-- nest :: Int -> Doc a -> Doc a+-- linebreak :: Doc a -- @-fill :: Int -> ADoc a -> ADoc a+fill :: Int -> Doc a -> Doc a fill f d = width d $ \w ->- if (w >= f)+ if w >= f then mempty else text (spaces (f - w)) -width :: ADoc a -> (Int -> ADoc a) -> ADoc a+width :: Doc a -> (Int -> Doc a) -> Doc a width d f = column (\k1 -> d <> column (\k2 -> f (k2 - k1))) @@ -657,7 +655,7 @@ -- indents these -- words ! -- @-indent :: Int -> ADoc a -> ADoc a+indent :: Int -> Doc a -> Doc a indent i d = hang i (text (spaces i) <> d) -- | The hang combinator implements hanging indentation. The document@@ -679,7 +677,7 @@ -- The @hang@ combinator is implemented as: -- -- > hang i x = align (nest i x)-hang :: Int -> ADoc a -> ADoc a+hang :: Int -> Doc a -> Doc a hang i d = align (nest i d) -- | The document @(align x)@ renders document @x@ with the nesting@@ -699,7 +697,7 @@ -- hi nice -- world -- @-align :: ADoc a -> ADoc a+align :: Doc a -> Doc a align d = column $ \k -> nesting $ \i -> nest (k - i) d --nesting might be negative :-) @@ -707,9 +705,7 @@ -- Primitives ----------------------------------------------------------- -type Doc = ADoc Void---- | The abstract data type @Doc@ represents pretty documents.+-- | The data type @Doc@ represents pretty documents. -- -- @Doc@ is an instance of the 'Show' class. @(show doc)@ pretty -- prints document @doc@ with a page width of 100 characters and a@@ -723,29 +719,31 @@ -- hello -- world -- @-data ADoc a+data Doc a = Empty | Char {-# UNPACK #-} !Char -- invariant: char is not '\n' | Text {-# UNPACK #-} !Int String -- invariant: text doesn't contain '\n' | Line- | FlatAlt (ADoc a) (ADoc a) -- Render the first doc, but when flattened, render the second.- | Cat (ADoc a) (ADoc a)- | Nest {-# UNPACK #-} !Int (ADoc a)- | Union (ADoc a) (ADoc a) -- invariant: first lines of first doc longer than the first lines of the second doc- | Annotate a (ADoc a)- | Column (Int -> ADoc a)- | Nesting (Int -> ADoc a)- | Columns (Maybe Int -> ADoc a)- | Ribbon (Maybe Int -> ADoc a)+ | FlatAlt (Doc a) (Doc a) -- Render the first doc, but when flattened, render the second.+ | Cat (Doc a) (Doc a)+ | Nest {-# UNPACK #-} !Int (Doc a)+ | Union (Doc a) (Doc a) -- invariant: first lines of first doc longer than the first lines of the second doc+ | Annotate a (Doc a)+ | Column (Int -> Doc a)+ | Nesting (Int -> Doc a)+ | Columns (Maybe Int -> Doc a)+ | Ribbon (Maybe Int -> Doc a) deriving (Generic, Functor) -instance NFData a => NFData (ADoc a)+instance NFData a => NFData (Doc a) -annotate :: a -> ADoc a -> ADoc a+-- | Annotate a document.+annotate :: a -> Doc a -> Doc a annotate = Annotate -noAnnotate :: ADoc a -> ADoc a'-noAnnotate = docMapAnn (const id)+-- | Remove the annotations from a document.+noAnnotate :: Doc a -> Doc a'+noAnnotate = docMapAnn $ const id -- | The data type @SimpleDoc@ represents rendered documents and is -- used by the display functions.@@ -769,7 +767,7 @@ -- | The document @(char c)@ contains the literal character @c@. The -- character shouldn't be a newline (@'\n'@), the function 'line' -- should be used for line breaks.-char :: Char -> ADoc a+char :: Char -> Doc a char '\n' = line char c = Char c @@ -777,25 +775,25 @@ -- string shouldn't contain any newline (@'\n'@) characters. If the -- string contains newline characters, the function 'pretty' should be -- used.-text :: String -> ADoc a+text :: String -> Doc a text "" = Empty text s = Text (length s) s -- | The @line@ document advances to the next line and indents to the -- current nesting level. Document @line@ behaves like @(text \" \")@ -- if the line break is undone by 'group'.-line :: ADoc a+line :: Doc a line = FlatAlt Line space -- | The @linebreak@ document advances to the next line and indents to -- the current nesting level. Document @linebreak@ behaves like -- 'mempty' if the line break is undone by 'group'.-linebreak :: ADoc a+linebreak :: Doc a linebreak = FlatAlt Line mempty -- | A linebreak that can not be flattened; it is guaranteed to be -- rendered as a newline.-hardline :: ADoc a+hardline :: Doc a hardline = Line -- | The document @(nest i x)@ renders document @x@ with the current@@ -811,17 +809,17 @@ -- world -- ! -- @-nest :: Int -> ADoc a -> ADoc a+nest :: Int -> Doc a -> Doc a nest = Nest -column, nesting :: (Int -> ADoc a) -> ADoc a+column, nesting :: (Int -> Doc a) -> Doc a column = Column nesting = Nesting -columns :: (Maybe Int -> ADoc a) -> ADoc a+columns :: (Maybe Int -> Doc a) -> Doc a columns = Columns -ribbon :: (Maybe Int -> ADoc a) -> ADoc a+ribbon :: (Maybe Int -> Doc a) -> Doc a ribbon = Ribbon -- | The @group@ combinator is used to specify alternative@@ -829,16 +827,16 @@ -- document @x@. The resulting line is added to the current line if -- that fits the page. Otherwise, the document @x@ is rendered without -- any changes.-group :: ADoc a -> ADoc a+group :: Doc a -> Doc a group x = Union (flatten x) x -- | @flatAlt@ creates a document that changes when flattened; normally -- it is rendered as the first argument, but when flattened is rendered -- as the second.-flatAlt :: ADoc a -> ADoc a -> ADoc a+flatAlt :: Doc a -> Doc a -> Doc a flatAlt = FlatAlt -flatten :: ADoc a -> ADoc a+flatten :: Doc a -> Doc a flatten (FlatAlt _ y) = y flatten (Cat x y) = Cat (flatten x) (flatten y) flatten (Nest i x) = Nest i (flatten x)@@ -860,7 +858,7 @@ -- list of indentation/document pairs; saves an indirection over [(Int,Doc)] data Docs a e = Nil- | Cons {-# UNPACK #-} !Int (ADoc a) (Docs a e)+ | Cons {-# UNPACK #-} !Int (Doc a) (Docs a e) -- | This is the default pretty printer which is used by 'show', -- 'putDoc' and 'hPutDoc'. @(renderPretty ribbonfrac width x)@ renders@@ -869,9 +867,15 @@ -- amount of non-indentation characters on a line. The parameter -- @ribbonfrac@ should be between @0.0@ and @1.0@. If it is lower or -- higher, the ribbon width will be 0 or @width@ respectively.-renderPretty :: Float -> Int -> ADoc a -> SimpleDoc a+renderPretty :: Float -> Int -> Doc a -> SimpleDoc a renderPretty = renderFits nicest1 +-- | This is the default pretty printer which is used by 'show',+-- 'putDoc' and 'hPutDoc'. This routine uses a page width of 100 characters+-- and a ribbon width of 40 characters.+renderPrettyDefault :: Doc a -> SimpleDoc a+renderPrettyDefault = renderPretty 0.4 100+ -- | A slightly smarter rendering algorithm with more lookahead. It provides -- provide earlier breaking on deeply nested structures. -- For example, consider this python-ish pseudocode:@@ -919,12 +923,12 @@ -- aaaaaaaaaaa( -- [abc, def, ghi]) -- @-renderSmart :: Int -> ADoc a -> SimpleDoc a+renderSmart :: Int -> Doc a -> SimpleDoc a renderSmart = renderFits nicestR 1.0 renderFits :: (Int -> Int -> Int -> Int -> SimpleDoc a -> SimpleDoc a -> SimpleDoc a)- -> Float -> Int -> ADoc a -> SimpleDoc a+ -> Float -> Int -> Doc a -> SimpleDoc a renderFits nicest rfrac w x = best 0 0 SEmpty (Cons 0 x Nil) where@@ -1006,7 +1010,7 @@ -- renderer is very fast. The resulting output contains fewer -- characters than a pretty printed version and can be used for output -- that is read by other programs.-renderCompact :: ADoc a -> SimpleDoc a+renderCompact :: Doc a -> SimpleDoc a renderCompact x = scan SEmpty 0 [x] where@@ -1031,27 +1035,30 @@ -- Displayers: displayS and displayIO ----------------------------------------------------------- --simpleDocMapAnn :: (r -> a -> r) -- ^ SPushAnn state merge- -> (r -> SimpleDoc a' -> SimpleDoc a') -- ^ SPushAnn processor- -> (r -> SimpleDoc a' -> SimpleDoc a') -- ^ SPopAnn processor- -> r -- ^ Initial state- -> SimpleDoc a -> SimpleDoc a'-simpleDocMapAnn arf adf apf r0 = go [] r0+simpleDocMapAnn :: (r -> a -> r) -- ^ SPushAnn state update+ -> (r -> a -> r) -- ^ SPopAnn state update+ -> (r -> SimpleDoc a' -> SimpleDoc a') -- ^ SPushAnn processor+ -> (r -> SimpleDoc a' -> SimpleDoc a') -- ^ SPopAnn processor+ -> r -- ^ Initial state+ -> SimpleDoc a -> SimpleDoc a'+simpleDocMapAnn upPush upPop push pop = go where- go _ _ SEmpty = SEmpty- go rs r (SChar c x) = SChar c (go rs r x)- go rs r (SText l s x) = SText l s (go rs r x)- go rs r (SLine i x) = SLine i (go rs r x)- go rs r (SPushAnn a x) = let r' = arf r a in adf r' (go (r:rs) r' x)- go [] _ (SPopAnn _ x) = apf r0 (go [] r0 x)- go (r:rs) _ (SPopAnn _ x) = apf r (go rs r x)+ go _ SEmpty = SEmpty+ go r (SChar c x) = SChar c (go r x)+ go r (SText l s x) = SText l s (go r x)+ go r (SLine i x) = SLine i (go r x)+ go r (SPushAnn a x) = let r' = upPush r a in push r' $ go r' x+ go r (SPopAnn a x) = let r' = upPop r a in pop r' $ go r' x -simpleDocScanAnn :: (r -> a -> r)- -> r- -> SimpleDoc a- -> SimpleDoc r-simpleDocScanAnn af r0 = simpleDocMapAnn af SPushAnn SPopAnn r0+simpleDocScanAnn :: (r -> a -> r) -- ^ SPushAnn state merge+ -> r -- ^ Initial state+ -> SimpleDoc a+ -> SimpleDoc r+simpleDocScanAnn f r0 = simpleDocMapAnn merge pop (SPushAnn . head) (SPopAnn . head) [r0]+ where merge rs@(r:_) x = f r x : rs+ merge [] _ = error "Stack underflow"+ pop (_:rs) _ = rs+ pop [] _ = error "Stack underflow" -- | Display a rendered document. --@@ -1073,62 +1080,73 @@ go (SPopAnn a x) = pop a <++> go x (<++>) = liftA2 mappend +-- | Display a rendered document.+--+-- This function takes a means of pushing an annotated region, a means of ending it,+-- and a means of displaying a string to compute the output @o@. displayDecorated :: Monoid o => (a -> o) -- ^ How to push an annotated region -> (a -> o) -- ^ How to end an annotated region -> (String -> o) -- ^ How to display a string (from document or whitespace) -> SimpleDoc a -> o-displayDecorated push pop str = runIdentity . displayDecoratedA (pure . push) (pure . pop) (pure . str)+displayDecorated push pop str = runIdentity .+ displayDecoratedA (pure . push) (pure . pop) (pure . str) -- | @(displayIO handle simpleDoc)@ writes @simpleDoc@ to the file -- handle @handle@, discarding all annotations. This function -- is used for example by 'hPutDoc': ----- > hPutDoc handle doc = displayIO handle (renderPretty 0.4 100 doc)+-- > hPutDoc handle doc = displayIO handle (renderPrettyDefault doc) displayIO :: Handle -> SimpleDoc a -> IO () displayIO handle = displayDecoratedA cpu cpu (hPutStr handle) where cpu = const $ pure () -- | @(displayS simpleDoc)@ takes the output @simpleDoc@ from a -- rendering function and transforms it to a 'ShowS' type (for use in--- the 'Show' class). Along the way, all annotations are+-- the 'Show' class). Along the way, all annotations are -- discarded.------ > showWidth :: Int -> ADoc -> String--- > showWidth w x = displayS (renderPretty 0.4 w x) "" displayS :: SimpleDoc a -> ShowS-displayS = displayDecoratedA ci ci showString+displayS = displayDecoratedA ci ci (++) where ci = const id +-- | @(display simpleDoc)@ takes the output @simpleDoc@ from a+-- rendering function and outputs a 'String'. Along the way, all annotations are+-- discarded. display :: SimpleDoc a -> String display = flip displayS "" -displayLT :: SimpleDoc a -> TL.Text-displayLT = TL.toLazyText . displayDecorated cm cm TL.fromString+-- | @(display simpleDoc)@ takes the output @simpleDoc@ from a+-- rendering function and outputs a 'Text'. Along the way, all annotations are+-- discarded.+displayT :: SimpleDoc a -> TL.Text+displayT = TL.toLazyText . displayDecorated cm cm TL.fromString where cm = const mempty +-- | The type alias @SpanList@ is used by @displaySpan@+--+-- First element is the starting position, second the length+-- and third the annotation at the given range. type SpanList a = [(Int, Int, a)] -- | Generate a pair of a string and a list of source span/annotation pairs displaySpans :: Monoid o => (String -> o) -> SimpleDoc a -> (o, SpanList a)-displaySpans str = first ($ mempty) . go 0 []+displaySpans str = go 0 [] where- go _ [] SEmpty = (id, [])- go i stk (SChar c x) = first (str' $ pure c) $ go (i+1) stk x- go i stk (SText l s x) = first (str' s) $ go (i + l) stk x- go i stk (SLine ind x) = first (str' $ '\n':spaces ind) $ go (1+i+ind) stk x+ go _ [] SEmpty = (mempty, [])+ go i stk (SChar c x) = first (mappend $ str $ pure c) $ go (i+1) stk x+ go i stk (SText l s x) = first (mappend $ str s) $ go (i + l) stk x+ go i stk (SLine ind x) = first (mappend $ str $ '\n':spaces ind) $ go (1+i+ind) stk x go i stk (SPushAnn _ x) = go i (i:stk) x go i (start:stk) (SPopAnn ann x) = second ((start, i-start, ann):) $ go i stk x go _ _ SEmpty = error "Stack not empty" go _ [] (SPopAnn _ _) = error "Stack underflow"- str' s = (mappend (str s) .) ----------------------------------------------------------- -- default pretty printers: show, putDoc and hPutDoc ------------------------------------------------------------instance Show (ADoc a) where- showsPrec _ doc = displayS (renderPretty 0.4 80 doc)+instance Show (Doc a) where+ showsPrec _ = displayS . renderPrettyDefault -- | The action @(putDoc doc)@ pretty prints document @doc@ to the -- standard output, with a page width of 100 characters and a ribbon@@ -1142,8 +1160,8 @@ -- @ -- hello world -- @-putDoc :: ADoc a -> IO ()-putDoc doc = hPutDoc stdout doc+putDoc :: Doc a -> IO ()+putDoc = hPutDoc stdout -- | @(hPutDoc handle doc)@ pretty prints document @doc@ to the file -- handle @handle@ with a page width of 100 characters and a ribbon@@ -1154,8 +1172,8 @@ -- > ["vertical","text"])) -- > ; hClose handle -- > }-hPutDoc :: Handle -> ADoc a -> IO ()-hPutDoc handle doc = displayIO handle (renderPretty 0.4 100 doc)+hPutDoc :: Handle -> Doc a -> IO ()+hPutDoc handle = displayIO handle . renderPrettyDefault ----------------------------------------------------------- -- insert spaces
test/WLPPrintTests.hs view
@@ -32,15 +32,15 @@ ------------------------------------------------------------ -- We test the @Doc@ constructors. -assertPretty :: Int -> String -> String -> ADoc a -> Assertion+assertPretty :: Int -> String -> String -> Doc a -> Assertion assertPretty w desc str doc = assertEqual (desc ++ " (pretty)") str $ displayS (renderPretty 1.0 w doc) "" -assertSmart :: Int -> String -> String -> ADoc a -> Assertion+assertSmart :: Int -> String -> String -> Doc a -> Assertion assertSmart w desc str doc = assertEqual (desc ++ " (smart)") str $ displayS (renderSmart w doc) "" -assertRender :: Int -> String -> String -> ADoc a -> Assertion+assertRender :: Int -> String -> String -> Doc a -> Assertion assertRender w desc str doc = do assertPretty w desc str doc assertSmart w desc str doc @@ -91,7 +91,7 @@ $ text "foo" <+> (nest 2 $ columns $ \w -> pretty w) ribbonTests :: Assertion-ribbonTests = do assertEqual "Ribbon test 1" "foo 32"+ribbonTests = do assertEqual "Ribbon test 1" "foo 40" $ show (text "foo" <+> (ribbon $ \r -> pretty r)) ------------------------------------------------------------
wl-pprint-annotated.cabal view
@@ -4,7 +4,7 @@ name: wl-pprint-annotated category: Text-version: 0.0.1.1+version: 0.0.1.2 synopsis: Wadler/Leijen pretty printer with annotations and slightly modernized API cabal-version: >= 1.10 license: BSD3@@ -26,9 +26,10 @@ library hs-source-dirs: src+ default-extensions: FlexibleInstances TypeSynonymInstances DeriveFunctor DeriveFoldable DeriveTraversable DeriveGeneric DefaultSignatures ghc-options: -Wall build-depends:- base < 6,+ base >= 4.8 && < 5, containers >= 0.4 && < 0.6, semigroups >= 0.9 && < 1, text >= 0.11 && < 1.3,@@ -42,9 +43,10 @@ main-is: WLPPrintTests.hs hs-source-dirs: test+ default-extensions: FlexibleInstances TypeSynonymInstances DeriveFunctor DeriveFoldable DeriveTraversable DeriveGeneric DefaultSignatures ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N build-depends:- base < 6,+ base >= 4.8 && < 5, containers >= 0.4 && < 0.6, semigroups >= 0.9 && < 1, text >= 0.11 && < 1.3,