packages feed

pretty-compact 1.0 → 3.1

raw patch · 5 files changed

Files

− Setup.hs 
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
Text/PrettyPrint/Compact.hs view
@@ -1,35 +1,83 @@+{-# LANGUAGE TupleSections #-} {-# LANGUAGE OverloadedStrings #-}-+-- | Compact pretty-printer.+--+-- == Examples+--+-- Assume that we want to pretty print S-Expressions, which can either be atom or a list of S-Expressions.+--+-- >>> data SExpr = SExpr [SExpr] | Atom String deriving Show+-- >>> let pretty :: SExpr -> Doc (); pretty (Atom s) = text s; pretty (SExpr xs) = text "(" <> (sep $ map pretty xs) <> text ")"+--+-- Using the above representation, the S-Expression @(a b c d)@ has the following encoding:+--+-- >>> let abcd = SExpr [Atom "a",Atom "b",Atom "c",Atom "d"]+--+-- The legible layouts of the @abcd@ S-Expression defined above would be either+--+-- >>> putStrLn $ render $ pretty abcd+-- (a b c d)+--+-- or+--+-- >>> putStrLn $ renderWith defaultOptions { optsPageWidth = 5 } $ pretty abcd+-- (a+--  b+--  c+--  d)+--+-- The @testData@ S-Expression is specially crafted to+-- demonstrate general shortcomings of both Hughes and Wadler libraries.+--+-- >>> let abcd4 = SExpr [abcd,abcd,abcd,abcd]+-- >>> let testData = SExpr [ SExpr [Atom "abcde", abcd4], SExpr [Atom "abcdefgh", abcd4]]+-- >>> putStrLn $ render $ pretty testData+-- ((abcde ((a b c d) (a b c d) (a b c d) (a b c d)))+--  (abcdefgh ((a b c d) (a b c d) (a b c d) (a b c d))))+--+-- on 20-column-wide page+--+-- >>> putStrLn $ renderWith defaultOptions { optsPageWidth = 20 } $ pretty testData+-- ((abcde ((a b c d)+--          (a b c d)+--          (a b c d)+--          (a b c d)))+--  (abcdefgh+--   ((a b c d)+--    (a b c d)+--    (a b c d)+--    (a b c d))))+--+-- Yet, neither Hughes' nor Wadler's library can deliver those results.+--+-- === Annotations+--+-- For example we can annotate every /car/ element of S-Expressions,+-- and in the rendering phase emphasise them by rendering them in uppercase.+--+-- >>> let pretty' :: SExpr -> Doc Any; pretty' (Atom s) = text s; pretty' (SExpr []) = text "()"; pretty' (SExpr (x:xs)) = text "(" <> (sep $ annotate (Any True) (pretty' x) : map pretty' xs) <> text ")"+-- >>> let render' = renderWith defaultOptions { optsAnnotate  = \a x -> if a == Any True then map toUpper x else x }+-- >>> putStrLn $ render' $ pretty' testData+-- ((ABCDE ((A B C D) (A B C D) (A B C D) (A B C D)))+--  (ABCDEFGH ((A B C D) (A b c d) (A b c d) (A b c d))))+-- module Text.PrettyPrint.Compact (    -- * Documents-   Doc, +   Doc,     -- * Basic combinators-   mempty, char, text, (<>), nest, line, linebreak, group, softline,-   softbreak,+   module Data.Monoid, text, flush, char, -   -- * Alignment-   ---   -- The combinators in this section can not be described by Wadler's-   -- original combinators. They align their output relative to the-   -- current output position - in contrast to @nest@ which always-   -- aligns to the current nesting level. This deprives these-   -- combinators from being \`optimal\'. In practice however they-   -- prove to be very useful. The combinators in this section should-   -- be used with care, since they are more expensive than the other-   -- combinators. For example, @align@ shouldn't be used to pretty-   -- print all top-level declarations of a language, but using @hang@-   -- for let expressions is fine.-   align, hang, indent, encloseSep, list, tupled, semiBraces,+   hang, hangWith, encloseSep, list, tupled, semiBraces,     -- * Operators-   (<+>), (<$>), (</>), (<$$>), (<//>),+   (<+>), ($$), (</>), (<//>), (<$$>),     -- * List combinators-   hsep, vsep, fillSep, sep, hcat, vcat, fillCat, cat, punctuate,+   hsep, sep, hcat, vcat, cat, punctuate, -   -- * Fillers-   fill, fillBreak,+   -- * Fill combiantors+   -- fillSep, fillCat,     -- * Bracketing combinators    enclose, squotes, dquotes, parens, angles, braces, brackets,@@ -43,34 +91,44 @@    bool,     -- * Rendering+   renderWith,    render,+   Options(..),+   defaultOptions, +   -- * Annotations+   annotate,+    -- * Undocumented    -- column, nesting, width    ) where -import Control.Applicative import Data.Monoid  import Text.PrettyPrint.Compact.Core as Text.PrettyPrint.Compact -type Indentation = Int+-- | Render the 'Doc' into 'String' omitting all annotations.+render :: Annotation a => Doc a -> String+render = renderWith defaultOptions -infixr 5 </>,<//>,<$$$>,<$$>-infixr 6 <+>+defaultOptions :: Options a String+defaultOptions = Options+    { optsAnnotate = \_ s -> s+    , optsPageWidth = 80+    }  -- | The document @(list xs)@ comma separates the documents @xs@ and -- 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 :: [Doc] -> Doc+list :: Annotation a => [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 :: [Doc] -> Doc+tupled :: Annotation a => [Doc a] -> Doc a tupled          = encloseSep lparen   rparen  comma  @@ -78,7 +136,7 @@ -- 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 :: [Doc] -> Doc+semiBraces :: Annotation a => [Doc a] -> Doc a semiBraces      = encloseSep lbrace   rbrace  semi  -- | The document @(enclosure l r sep xs)@ concatenates the documents@@ -104,12 +162,12 @@ --      ,200 --      ,3000] -- @-encloseSep :: Doc -> Doc -> Doc -> [Doc] -> Doc-encloseSep left right sep ds-    = case ds of-        []  -> left <> right-        [d] -> left <> d <> right-        _   -> align (cat (zipWith (<>) (left : repeat sep) ds) <> right)+encloseSep :: Annotation a => Doc a -> Doc a -> Doc a -> [Doc a] -> Doc a+encloseSep left right separator ds+    = (<> right) $ case ds of+        []  -> left+        [d] -> left <> d+        (d:ds') -> cat (left <> d:map (separator <>) ds')  ----------------------------------------------------------- -- punctuate p [d1,d2,...,dn] => [d1 <> p,d2 <> p, ... ,dn]@@ -139,9 +197,9 @@ -- -- (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 :: Doc -> [Doc] -> [Doc]-punctuate p []      = []-punctuate p [d]     = [d]+punctuate :: Annotation a => Doc a -> [Doc a] -> [Doc a]+punctuate _p []      = []+punctuate _p [d]     = [d] punctuate p (d:ds)  = (d <> p) : punctuate p ds  @@ -151,222 +209,166 @@   -- | The document @(sep xs)@ concatenates all documents @xs@ either--- horizontally with @(\<+\>)@, if it fits the page, or vertically with--- @(\<$\>)@.+-- horizontally with @(\<+\>)@, if it fits the page, or vertically+-- with @(\<$$\>)@. Documents on the left of horizontal concatenation+-- must fit on a single line. ----- > sep xs  = group (vsep xs)-sep :: [Doc] -> Doc-sep             = group . vsep+sep :: Annotation a => [Doc a] -> Doc a+sep xs = groupingBy " " (map (0,) xs) --- | The document @(fillSep xs)@ concatenates documents @xs@--- horizontally with @(\<+\>)@ as long as its fits the page, than--- inserts a @line@ and continues doing that for all documents in--- @xs@.------ > fillSep xs  = foldr (\<\/\>) empty xs-fillSep :: [Doc] -> Doc-fillSep         = foldDoc (</>) +-- -- | The document @(fillSep xs)@ concatenates documents @xs@+-- -- horizontally with @(\<+\>)@ as long as its fits the page, than+-- -- inserts a @line@ and continues doing that for all documents in+-- -- @xs@.+-- --+-- -- > fillSep xs  = foldr (\<\/\>) empty xs+-- fillSep :: Annotation a => [Doc a] -> Doc a+-- fillSep         = foldDoc (</>)+ -- | The document @(hsep xs)@ concatenates all documents @xs@ -- horizontally with @(\<+\>)@.-hsep :: [Doc] -> Doc+hsep :: Annotation a => [Doc a] -> Doc a hsep            = foldDoc (<+>) ---- | The document @(vsep xs)@ concatenates all documents @xs@--- vertically with @(\<$\>)@. If a 'group' undoes the line breaks--- inserted by @vsep@, all documents are separated with a space.------ > someText = map text (words ("text to lay out"))--- >--- > test     = text "some" <+> vsep someText------ This is layed out as:------ @--- some text--- to--- lay--- out--- @------ The 'align' combinator can be used to align the documents under--- their first element------ > test     = text "some" <+> align (vsep someText)------ Which is printed as:------ @--- some text---      to---      lay---      out--- @-vsep :: [Doc] -> Doc-vsep            = foldDoc (<$$$>)- -- | The document @(cat xs)@ concatenates all documents @xs@ either -- horizontally with @(\<\>)@, if it fits the page, or vertically with -- @(\<$$\>)@. ----- > cat xs  = group (vcat xs)-cat :: [Doc] -> Doc-cat             = group . vcat+cat :: Annotation a => [Doc a] -> Doc a+cat xs = groupingBy "" (map (0,) xs) --- | The document @(fillCat xs)@ concatenates documents @xs@--- horizontally with @(\<\>)@ as long as its fits the page, than inserts--- a @linebreak@ and continues doing that for all documents in @xs@.------ > fillCat xs  = foldr (\<\/\/\>) empty xs-fillCat :: [Doc] -> Doc-fillCat         = foldDoc (<//>)+-- -- | The document @(fillCat xs)@ concatenates documents @xs@+-- -- horizontally with @(\<\>)@ as long as its fits the page, than inserts+-- -- a @linebreak@ and continues doing that for all documents in @xs@.+-- --+-- -- > fillCat xs  = foldr (\<\/\/\>) empty xs+-- fillCat :: Annotation a => [Doc a] -> Doc a+-- fillCat         = foldDoc (<//>)  -- | The document @(hcat xs)@ concatenates all documents @xs@ -- horizontally with @(\<\>)@.-hcat :: [Doc] -> Doc+hcat :: Annotation a => [Doc a] -> Doc a hcat            = foldDoc (<>)  -- | 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 :: [Doc] -> Doc-vcat            = foldDoc (<$$>)+-- vertically with @($$)@.+vcat :: Annotation a => [Doc a] -> Doc a+vcat            = foldDoc ($$) -foldDoc :: (Doc -> Doc -> Doc) -> [Doc] -> Doc-foldDoc f []       = mempty+foldDoc :: Annotation a => (Doc a -> Doc a -> Doc a) -> [Doc a] -> Doc a+foldDoc _ []       = mempty foldDoc f ds       = foldr1 f ds  -- | The document @(x \<+\> y)@ concatenates document @x@ and @y@ with a -- @space@ in between.  (infixr 6)-(<+>) :: Doc -> Doc -> Doc+(<+>) :: Annotation a => Doc a -> Doc a -> Doc a x <+> y         = x <> space <> y --- | The document @(x \<\/\> y)@ concatenates document @x@ and @y@ with a--- '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)-(</>) :: Doc -> Doc -> Doc-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)-(<//>) :: Doc -> Doc -> Doc-x <//> y        = x <> softbreak <> y+-- | The document @(x \<\/\> y)@ puts @x@ and @y@ either next to each other+-- (with a @space@ in between) or underneath each other. (infixr 5)+(</>) :: Annotation a => Doc a -> Doc a -> Doc a+x </> y         = hang 0 x y --- | The document @(x \<$\> y)@ concatenates document @x@ and @y@ with a--- 'line' in between. (infixr 5)-(<$$$>) :: Doc -> Doc -> Doc-x <$$$> y         = x <> line <> y+-- | The document @(x \<\/\/\> y)@ puts @x@ and @y@ either right next+-- to each other (if @x@ fits on a single line) or underneath each+-- other. (infixr 5)+(<//>) :: Annotation a => Doc a -> Doc a -> Doc a+x <//> y        = hangWith "" 0 x y  -- | The document @(x \<$$\> y)@ concatenates document @x@ and @y@ with--- a @linebreak@ in between. (infixr 5)-(<$$>) :: Doc -> Doc -> Doc-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 :: Doc-softline        = group line---- | The document @softbreak@ behaves like 'empty' if the resulting--- output fits the page, otherwise it behaves like 'line'.------ > softbreak  = group linebreak-softbreak :: Doc-softbreak       = group linebreak+-- a linebreak in between. (infixr 5)+(<$$>) :: Annotation a => Doc a -> Doc a -> Doc a+(<$$>) = ($$)  -- | Document @(squotes x)@ encloses document @x@ with single quotes -- \"'\".-squotes :: Doc -> Doc+squotes :: Annotation a => Doc a -> Doc a squotes         = enclose squote squote  -- | Document @(dquotes x)@ encloses document @x@ with double quotes -- '\"'.-dquotes :: Doc -> Doc+dquotes :: Annotation a => Doc a -> Doc a dquotes         = enclose dquote dquote  -- | Document @(braces x)@ encloses document @x@ in braces, \"{\" and -- \"}\".-braces :: Doc -> Doc+braces :: Annotation a => Doc a -> Doc a braces          = enclose lbrace rbrace  -- | Document @(parens x)@ encloses document @x@ in parenthesis, \"(\" -- and \")\".-parens :: Doc -> Doc+parens :: Annotation a => Doc a -> Doc a parens          = enclose lparen rparen  -- | Document @(angles x)@ encloses document @x@ in angles, \"\<\" and -- \"\>\".-angles :: Doc -> Doc+angles :: Annotation a => Doc a -> Doc a angles          = enclose langle rangle  -- | Document @(brackets x)@ encloses document @x@ in square brackets, -- \"[\" and \"]\".-brackets :: Doc -> Doc+brackets :: Annotation a => Doc a -> Doc a brackets        = enclose lbracket rbracket  -- | The document @(enclose l r x)@ encloses document @x@ between -- documents @l@ and @r@ using @(\<\>)@.-enclose :: Doc -> Doc -> Doc -> Doc+enclose :: Annotation a => Doc a -> Doc a -> Doc a -> Doc a enclose l r x   = l <> x <> r -char :: Char -> Doc+char :: Annotation a => Char -> Doc a char x = text [x]  -- | The document @lparen@ contains a left parenthesis, \"(\".-lparen :: Doc+lparen :: Annotation a => Doc a lparen          = char '(' -- | The document @rparen@ contains a right parenthesis, \")\".-rparen :: Doc+rparen :: Annotation a => Doc a rparen          = char ')' -- | The document @langle@ contains a left angle, \"\<\".-langle :: Doc+langle :: Annotation a => Doc a langle          = char '<' -- | The document @rangle@ contains a right angle, \">\".-rangle :: Doc+rangle :: Annotation a => Doc a rangle          = char '>' -- | The document @lbrace@ contains a left brace, \"{\".-lbrace :: Doc+lbrace :: Annotation a => Doc a lbrace          = char '{' -- | The document @rbrace@ contains a right brace, \"}\".-rbrace :: Doc+rbrace :: Annotation a => Doc a rbrace          = char '}' -- | The document @lbracket@ contains a left square bracket, \"[\".-lbracket :: Doc+lbracket :: Annotation a => Doc a lbracket        = char '[' -- | The document @rbracket@ contains a right square bracket, \"]\".-rbracket :: Doc+rbracket :: Annotation a => Doc a rbracket        = char ']'   -- | The document @squote@ contains a single quote, \"'\".-squote :: Doc+squote :: Annotation a => Doc a squote          = char '\'' -- | The document @dquote@ contains a double quote, '\"'.-dquote :: Doc+dquote :: Annotation a => Doc a dquote          = char '"' -- | The document @semi@ contains a semi colon, \";\".-semi :: Doc+semi :: Annotation a => Doc a semi            = char ';' -- | The document @colon@ contains a colon, \":\".-colon :: Doc+colon :: Annotation a => Doc a colon           = char ':' -- | The document @comma@ contains a comma, \",\".-comma :: Doc+comma :: Annotation a => Doc a comma           = char ','  -- | The document @dot@ contains a single dot, \".\".-dot :: Doc+dot :: Annotation a => Doc a dot             = char '.' -- | The document @backslash@ contains a back slash, \"\\\".-backslash :: Doc+backslash :: Annotation a => Doc a backslash       = char '\\' -- | The document @equals@ contains an equal sign, \"=\".-equals :: Doc+equals :: Annotation a => Doc a equals          = char '='  -----------------------------------------------------------@@ -379,191 +381,57 @@ -- using @line@ for newline characters and @char@ for all other -- characters. It is used instead of 'text' whenever the text contains -- newline characters.-string :: String -> Doc-string ""       = mempty-string ('\n':s) = line <> string s-string s        = case (span (/='\n') s) of-                    (xs,ys) -> text xs <> string ys+string :: Annotation a => String -> Doc a+string = vcat . map text . lines -bool :: Bool -> Doc+bool :: Annotation a => Bool -> Doc a bool b          = text (show b)  -- | The document @(int i)@ shows the literal integer @i@ using -- 'text'.-int :: Int -> Doc+int :: Annotation a => Int -> Doc a int i           = text (show i)  -- | The document @(integer i)@ shows the literal integer @i@ using -- 'text'.-integer :: Integer -> Doc+integer :: Annotation a => Integer -> Doc a integer i       = text (show i)  -- | The document @(float f)@ shows the literal float @f@ using -- 'text'.-float :: Float -> Doc+float :: Annotation a => Float -> Doc a float f         = text (show f)  -- | The document @(double d)@ shows the literal double @d@ using -- 'text'.-double :: Double -> Doc+double :: Annotation a => Double -> Doc a double d        = text (show d)  -- | The document @(rational r)@ shows the literal rational @r@ using -- 'text'.-rational :: Rational -> Doc+rational :: Annotation a => Rational -> Doc a rational r      = text (show r) --------------------------------------------------------------- semi primitive: fill and fillBreak------------------------------------------------------------ --- | The document @(fillBreak i x)@ first renders document @x@. It--- than appends @space@s until the width is equal to @i@. If the--- width of @x@ is already larger than @i@, the nesting level is--- increased by @i@ and a @line@ is appended. When we redefine @ptype@--- in the previous example to use @fillBreak@, we get a useful--- variation of the previous output:------ > ptype (name,tp)--- >        = fillBreak 6 (text name) <+> text "::" <+> text tp------ The output will now be:------ @--- let empty  :: Doc---     nest   :: Indentation -> Doc -> Doc---     linebreak---            :: Doc--- @-fillBreak :: Indentation -> Doc -> Doc-fillBreak f x   = width x (\w ->-                  if (w > f) then nest f linebreak-                             else spacing (f - w)) ---- | The document @(fill i x)@ renders document @x@. It than appends--- @space@s until the width is equal to @i@. If the width of @x@ is--- already larger, nothing is appended. This combinator is quite--- useful in practice to output a list of bindings. The following--- example demonstrates this.------ > types  = [("empty","Doc")--- >          ,("nest","Indentation -> Doc -> Doc")--- >          ,("linebreak","Doc")]--- >--- > ptype (name,tp)--- >        = fill 6 (text name) <+> text "::" <+> text tp--- >--- > test   = text "let" <+> align (vcat (map ptype types))------ Which is layed out as:------ @--- let empty  :: Doc---     nest   :: Indentation -> Doc -> Doc---     linebreak :: Doc--- @-fill :: Indentation -> Doc -> Doc-fill f d        = width d (\w ->-                  if (w >= f) then mempty-                              else spacing (f - w))--width :: Doc -> (Indentation -> Doc) -> Doc-width d f       = column (\k1 -> d <> column (\k2 -> f (k2 - k1)))----------------------------------------------------------------- semi primitive: Alignment and indentation---------------------------------------------------------------- | The document @(indent i x)@ indents document @x@ with @i@ spaces.------ > test  = indent 4 (fillSep (map text--- >         (words "the indent combinator indents these words !")))------ Which lays out with a page width of 20 as:------ @---     the indent---     combinator---     indents these---     words !--- @-indent :: Indentation -> Doc -> Doc-indent i d      = hang i (spacing i <> d)- -- | The hang combinator implements hanging indentation. The document--- @(hang i x)@ renders document @x@ with a nesting level set to the--- current column plus @i@. The following example uses hanging--- indentation for some text:------ > test  = hang 4 (fillSep (map text--- >         (words "the hang combinator indents these words !")))------ Which lays out on a page with a width of 20 characters as:------ @--- the hang combinator---     indents these---     words !--- @------ The @hang@ combinator is implemented as:------ > hang i x  = align (nest i x)-hang :: Indentation -> Doc -> Doc-hang i d        = align (nest i d)+-- @(hang i x y)@ either @x@ and @y@ concatenated with @\<+\>@ or @y@+-- below @x@ with an additional indentation of @i@. --- | The document @(align x)@ renders document @x@ with the nesting--- level set to the current column. It is used for example to--- implement 'hang'.------ As an example, we will put a document right above another one,--- regardless of the current nesting level:------ > x $$ y  = align (x <$$$> y)------ > test    = text "hi" <+> (text "nice" $$ text "world")------ which will be layed out as:------ @--- hi nice---    world--- @-align :: Doc -> Doc-align d         = column (\k ->-                  nesting (\i -> nest (k - i) d))   --nesting might be negative :-)+hang :: Annotation a => Int -> Doc a -> Doc a -> Doc a+hang = hangWith " "  --- | 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 :: Doc-line            = Line False---- | The @linebreak@ document advances to the next line and indents to--- the current nesting level. Document @linebreak@ behaves like--- 'empty' if the line break is undone by 'group'.-linebreak :: Doc-linebreak       = Line True+-- | The hang combinator implements hanging indentation. The document+-- @(hang separator i x y)@ either @x@ and @y@ concatenated with @\<\>+-- text separator \<\>@ or @y@ below @x@ with an additional+-- indentation of @i@.+hangWith :: Annotation a => String -> Int -> Doc a -> Doc a -> Doc a+hangWith separator n x y = groupingBy separator [(0,x), (n,y)] --- | The document @(nest i x)@ renders document @x@ with the current--- indentation level increased by i (See also 'hang', 'align' and--- 'indent').------ > nest 2 (text "hello" <$$$> text "world") <$$$> text "!"------ outputs as:------ @--- hello---   world--- !--- @-nest :: Indentation -> Doc -> Doc-nest i x        = Nest i x+space :: Annotation a => Doc a+space = text " " -column, nesting :: (Indentation -> Doc) -> Doc-column f        = Column f-nesting f       = Nesting f+-- $setup+-- >>> import Data.Monoid+-- >>> import Data.Char
Text/PrettyPrint/Compact/Core.hs view
@@ -1,142 +1,250 @@+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE RecordWildCards #-}-module Text.PrettyPrint.Compact.Core(Doc(..),render,group,flatten,space,spacing,text) where+{-# LANGUAGE ScopedTypeVariables, TypeSynonymInstances, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, ViewPatterns, DeriveFunctor, DeriveFoldable, DeriveTraversable, LambdaCase #-}+module Text.PrettyPrint.Compact.Core(Annotation,Layout(..),renderWith,Options(..),groupingBy,Doc,($$)) where -import Data.Monoid+import Prelude ()+import Prelude.Compat as P++import Data.List.Compat (sortOn,groupBy,minimumBy) import Data.Function (on)-import Data.List (partition,minimumBy,sort)-import Data.Either (partitionEithers)+import Data.Semigroup+import Data.Sequence (singleton, Seq, viewl, viewr, ViewL(..), ViewR(..), (|>)) import Data.String+import Data.Foldable (toList)+import Control.Applicative (liftA2)+-- | Annotated string, which consists of segments with separate (or no) annotations.+--+-- We keep annotated segments in a container (list).+-- The annotation is @Maybe a@, because the no-annotation case is common.+--+-- /Note:/ with @Last x@ annotation, the 'annotate' will overwrite all annotations.+--+-- /Note:/ if the list is changed into `Seq` or similar structure+-- allowing fast viewr and viewl, then we can impose an additional+-- invariant that there aren't two consequtive non-annotated segments;+-- yet there is no performance reason to do so.+--+data AS a = AS !Int [(a, String)]+  deriving (Eq,Ord,Show,Functor,Foldable,Traversable) -type Indentation = Int+-- | Tests the invariants of 'AS'+_validAs :: AS a -> Bool+_validAs (AS i s) = lengthInvariant && noNewlineInvariant+  where+    lengthInvariant = i == sum (map (length . snd) s)+    noNewlineInvariant = all (notElem '\n' . snd) s -data Box = Str String | Spacing Indentation | NewLine {-^ not allowed in the input -}+asLength :: AS a -> Int+asLength (AS l _) = l -instance IsString Doc where-  fromString = text+-- | Make a non-annotated 'AS'.+mkAS :: Monoid a => String -> AS a+mkAS s = AS (length s) [(mempty, s)] -data Doc = Empty-         | Text Box-         | Line !Bool            -- True <=> when undone by group, do not insert a space-         | Cat Doc Doc-         | Nest Indentation Doc-         | Union Doc Doc           -- invariant: first lines of first doc longer than the first lines of the second doc-         | Column  (Indentation -> Doc)-         | Nesting (Indentation -> Doc)+instance Semigroup (AS a) where+  AS i xs <> AS j ys = AS (i + j) (xs <> ys) +newtype L a = L (Seq (AS a)) -- non-empty sequence+  deriving (Eq,Ord,Show,Functor,Foldable,Traversable) -instance Monoid Doc where-  mempty = Empty-  mappend = Cat+instance Monoid a => Semigroup (L a) where+  L (viewr -> xs :> x) <> L (viewl -> y :< ys) =+    L (xs <> singleton (x <> y) <> indent ys) where -text :: String -> Doc-text = Text . Str+    n      = asLength x+    pad    = mkAS (P.replicate n ' ')+    indent = if n == 0 then id else fmap (pad <>) -spacing = Text . Spacing+  L _ <> L _ = error "<> @L: invariant violated, Seq is empty" -space = spacing 1+instance Monoid a => Monoid (L a) where+   mempty = L (singleton (mkAS "")) -group :: Doc -> Doc-group x         = Union (flatten x) x+instance Layout L where+   text = L . singleton . mkAS+   flush (L xs) = L (xs |> mkAS "")+   annotate a (L s') = L (fmap annotateAS s')+      where annotateAS (AS i s) = AS i (fmap annotatePart s)+            annotatePart (b, s) = (b `mappend` a, s) -flatten :: Doc -> Doc-flatten (Cat x y)       = Cat (flatten x) (flatten y)-flatten (Nest i x)      = Nest i (flatten x)-flatten (Line noSpace)  = if noSpace then Empty else space-flatten (Union x _y)    = flatten x-flatten (Column f)      = Column (flatten . f)-flatten (Nesting f)     = Nesting (flatten . f)-flatten other           = other                     --Empty,Char,Text+renderWithL :: (Monoid a, Monoid r) => Options a r -> L a -> r+renderWithL opts (L xs) = intercalate (toList xs)+  where+    f = optsAnnotate opts+    f' (AS _ s) = foldMap (uncurry f) s+    sep = f mempty "\n" -len :: Box -> Int-len (Str s) = length s-len (Spacing x) = x-len NewLine = 0+    intercalate []     = mempty+    intercalate (y:ys) = f' y `mappend` foldMap (mappend sep . f') ys -data Docs   = Nil-            | Cons !Indentation Doc Docs+data Options a r = Options+    { optsPageWidth :: !Int              -- ^ maximum page width+    , optsAnnotate  :: a -> String -> r  -- ^ how to annotate the string. /Note:/ the annotation should preserve the visible length of the string.+    } -data Process = Process {overflow :: Indentation-                       ,curIndent :: !Indentation -- current indentation-                       ,numToks :: Int -- total number of non-space tokens produced-                       ,tokens :: [Box] -- tokens produced, in reverse order-                       ,rest :: !Docs -- rest of the input document to process-                       }--- The ⟨filtering⟩ step takes all process states starting at the current--- line, and discards those that are dominated.  A process state--- dominates another one if it was able to produce more tokens while--- having less indentation. This is implemented by first sorting the--- process states by following 'measure', and then applying the--- 'filtering' function.+class Layout d where+  text :: Monoid a => String -> d a+  flush :: Monoid a => d a -> d a+  -- | `<>` new annotation to the 'Doc'.+  --+  -- Example: 'Any True' annotation will transform the rendered 'Doc' into uppercase:+  --+  -- >>> let r = putStrLn . renderWith defaultOptions { optsAnnotate = \a x -> if a == Any True then map toUpper x else x }+  -- >>> r $ text "hello" <$$> annotate (Any True) (text "world")+  -- hello+  -- WORLD+  --+  annotate :: forall a. Monoid a => a -> d a -> d a -measure :: Process -> (Indentation, Int)-measure Process{..} = (curIndent, negate numToks)+-- type parameter is phantom.+data M a = M {height    :: Int,+              lastWidth :: Int,+              maxWidth  :: Int+              }+  deriving (Show,Eq,Ord,Functor,Foldable,Traversable) -instance Eq Process where-  (==) = (==) `on` measure-instance Ord Process where-  compare = compare `on` measure+instance Semigroup (M a) where+  a <> b =+    M {maxWidth = max (maxWidth a) (maxWidth b + lastWidth a),+       height = height a + height b,+       lastWidth = lastWidth a + lastWidth b} -filtering :: [Process] -> [Process]-filtering (x:y:xs) | numToks x >= numToks y = filtering (x:xs)-                   | otherwise = x:filtering (y:xs)-filtering xs = xs+instance Monoid a => Monoid (M a) where+  mempty = text ""+  mappend = (<>) -renderAll :: Double -> Indentation -> Doc -> [Box]-renderAll rfrac w doc = reverse $ loop [Process 0 0 0 [] $ Cons 0 doc Nil]-    where-      loop ps = case dones of-        ((_,done):_) -> done -- here we could attempt to do a better choice. Seems to be fine for now.-        [] -> case conts of-          (_:_) -> loop $ filtering $ sort $ conts -- See the comment ⟨filtering⟩ above-          [] -> case conts'over of-            (_:_) -> loop [minimumBy (compare `on` overflow) conts'over]-            [] -> case dones'over of-              ((_,done):_) -> done-              [] -> [Str "Pretty print: Panic"]+instance Layout M where+  text s = M {height = 0, maxWidth = length s, lastWidth = length s}+  flush a = M {maxWidth = maxWidth a,+               height = height a + 1,+               lastWidth = 0}+  annotate _ M{..} = M{..}+class Poset a where+  (≺) :: a -> a -> Bool -        where-          -- advance all processes by one line (if possible)-          ps' = concatMap (\Process{..} -> rall numToks tokens curIndent curIndent rest) ps-          -- Have some processes reached the end? With some overflow?-          (dones0,conts0) = partitionEithers ps'-          (conts,conts'over) = partition (\p -> overflow p <= 0) conts0-          (dones,dones'over) = partition (\(o,_) -> o <= 0) dones0 -      -- r :: the ribbon width in characters-      r  =  max 0 (min w (round (fromIntegral w * rfrac)))+instance Poset (M a) where+  M c1 l1 s1 ≺ M c2 l2 s2 = c1 <= c2 && l1 <= l2 && s1 <= s2 -      -- Automatically inserted spacing does not count as doing more production.-      count (Spacing _) = 0-      count (Str _) = 1+mergeOn :: Ord b => (a -> b) -> [a] -> [a] -> [a]+mergeOn m = go+  where+    go [] xs = xs+    go xs [] = xs+    go (x:xs) (y:ys)+      | m x <= m y  = x:go xs (y:ys)+      | otherwise    = y:go (x:xs) ys -      -- Compute the state(s) after reaching the end of line.-      -- rall :: n = indentation of current line-      --         k = current column-      --        (ie. (k >= n) && (k - n == count of inserted characters)-      rall :: Int -> [Box] -> Indentation -> Indentation -> Docs -> [Either (Indentation,[Box]) Process]-      rall nts ts n k ds0 = case ds0 of-         Nil ->  [Left $ (overflow,ts)] -- Done!-         Cons i d ds -> case d of-            Empty       -> rall nts ts n k ds-            Text s      -> let k' = k+len s in seq k' (rall (nts+count s) (s:ts) n k' ds)-            Line _      -> [Right $ Process overflow i nts (Spacing i:NewLine:ts) ds] -- "yield" when the end of line is reached-            Cat x y     -> rall nts ts n k (Cons i x (Cons i y ds))-            Nest j x    -> let i' = i+j in seq i' (rall nts ts n k (Cons i' x ds))-            Union x y   -> rall nts ts n k (Cons i x ds) ++ rall nts ts n k (Cons i y ds)-            Column f    -> rall nts ts n k (Cons i (f k) ds)-            Nesting f   -> rall nts ts n k (Cons i (f i) ds)-        where overflow = negate $ min (w - k) (r - k + n)+mergeAllOn :: Ord b => (a -> b) -> [[a]] -> [a]+mergeAllOn _ [] = []+mergeAllOn m (x:xs) = mergeOn m x (mergeAllOn m xs) +bestsOn :: forall a b. (Poset b, Ord b)+      => (a -> b) -- ^ measure+      -> [[a]] -> [a]+bestsOn m = paretoOn' m [] . mergeAllOn m -layout :: [Box] -> String-layout [] = []-layout (Str s:xs) = s ++ layout xs-layout (NewLine:xs) = '\n' : layout xs-layout (Spacing x:xs) = replicate x ' ' ++ layout xs+-- | @paretoOn m = paretoOn' m []@+paretoOn' :: Poset b => (a -> b) -> [a] -> [a] -> [a]+paretoOn' _ acc [] = P.reverse acc+paretoOn' m acc (x:xs) = if any ((≺ m x) . m) acc+                            then paretoOn' m acc xs+                            else paretoOn' m (x:acc) xs+                            -- because of the ordering, we have that+                            -- for all y ∈ acc, y <= x, and thus x ≺ y+                            -- is false. No need to refilter acc. -render :: Double -> Indentation -> Doc -> String-render rfrac w d = do-  layout $ renderAll rfrac w d+-- list sorted by lexicographic order for the first component+-- function argument is the page width+newtype ODoc a = MkDoc {fromDoc :: Int -> [(Pair M L a)]}+  deriving Functor -instance Show Doc where-  show = render 0.8 80+instance Monoid a => Semigroup (ODoc a) where+  MkDoc xs <> MkDoc ys = MkDoc $ \w -> bestsOn frst [ discardInvalid w [x <> y | y <- ys w] | x <- xs w]++discardInvalid w = quasifilter (fits w . frst)++quasifilter _ [] = []+quasifilter p zs = let fzs = filter p zs+                   in if null fzs -- in case that there are no valid layouts, we take a narrow one.+                      then [minimumBy (compare `on` (maxWidth . frst)) zs]+                      else fzs++instance Monoid a => Monoid (ODoc a) where+  mempty = text ""+  mappend = (<>)++fits :: Int -> M a -> Bool+fits w x = maxWidth x <= w++instance Layout ODoc where+  text s = MkDoc $ \_ -> [text s]+  flush (MkDoc xs) = MkDoc $ \w -> fmap flush (xs w)+  annotate a (MkDoc xs) = MkDoc $ \w -> fmap (annotate a) (xs w)++renderWith :: (Monoid r, Annotation a)+           => Options a r  -- ^ rendering options+           -> ODoc a          -- ^ renderable+           -> r+renderWith opts d = case xs of+    [] -> error "No suitable layout found."+    ((_ :-: x):_) -> renderWithL opts x+  where+    pageWidth = optsPageWidth opts+    xs = discardInvalid pageWidth (fromDoc d pageWidth)++onlySingleLine :: [Pair M L a] -> [Pair M L a]+onlySingleLine = takeWhile (\(M{..} :-: _) -> height == 0)++spaces :: (Monoid a,Layout l) => Int -> l a+spaces n = text $ replicate n ' '+++-- | The document @(x \$$> y)@ concatenates document @x@ and @y@ with+-- a linebreak in between. (infixr 5)+($$) :: (Layout d, Monoid a, Semigroup (d a)) => d a -> d a -> d a+a $$ b = flush a <> b++second f (a,b) = (a, f b)++groupingBy :: Monoid a => String -> [(Int,Doc a)] -> Doc a+groupingBy _ [] = mempty+groupingBy separator ms = MkDoc $ \w ->+  let mws = map (second (($ w) . fromDoc)) ms+      (_,lastMw) = last mws+      hcatElems = map (onlySingleLine . snd) (init mws) ++ [lastMw] -- all the elements except the first must fit on a single line+      vcatElems = map (\(indent,x) -> map (spaces indent <>) x) mws+      horizontal = discardInvalid w $ foldr1 (liftA2 (\x y -> x <> text separator <> y)) hcatElems+      vertical = foldr1 (\xs ys -> bestsOn frst [[x $$ y | y <- ys] | x <- xs]) vcatElems+  in bestsOn frst [horizontal,vertical]++data Pair f g a = (:-:) {frst :: f a, scnd :: g a}+  deriving (Functor,Foldable,Traversable)++instance (Semigroup (f a), Semigroup (g a)) => Semigroup (Pair f g a) where+  (x :-: y) <> (x' :-: y') = (x <> x') :-: (y <> y')+instance (Monoid (f a), Monoid (g a)) => Monoid (Pair f g a) where+  mempty = mempty :-: mempty++instance (Layout a, Layout b) => Layout (Pair a b) where+  text s = text s :-: text s+  flush (a:-:b) = (flush a:-: flush b)+  annotate x (a:-:b) = (annotate x a:-:annotate x b)++instance Monoid a => IsString (Doc a) where+  fromString = text++type Annotation a = (Monoid a)+type Doc = ODoc++-- tt :: Doc ()+-- tt = groupingBy " " $ map (4,) $ +--      ((replicate 4 $ groupingBy " " (map (4,) (map text ["fw"]))) +++--       [groupingBy " " (map (0,) (map text ["fw","arstnwfyut","arstin","arstaruf"]))])++-- $setup+-- >>> import Text.PrettyPrint.Compact+-- >>> import Data.Monoid+-- >>> import Data.Char
+ bench/Benchmark.hs view
@@ -0,0 +1,85 @@+module Main (main) where++import Prelude ()+import Prelude.Compat++import Control.DeepSeq (force)+import Control.Exception (evaluate)+import Data.Aeson (Value (..), decode)+import Data.Foldable (toList)++import qualified Criterion.Main as C+import qualified Data.HashMap.Lazy as H+import qualified Data.ByteString.Lazy as BSL+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Builder as TLB++import qualified Text.PrettyPrint.Compact  as PC+import qualified Text.PrettyPrint.HughesPJ as HPJ+import qualified Text.PrettyPrint.Leijen   as WL++prettiestJSON :: Value -> PC.Doc ()+prettiestJSON (Bool True)  = PC.text "true"+prettiestJSON (Bool False) = PC.text "false"+prettiestJSON (Object o)   = PC.encloseSep (PC.text "{") (PC.text "}") (PC.text ",") (map prettyKV $ H.toList o)+  where prettyKV (k,v)     = PC.text (show k) PC.<> PC.text ":" PC.<+> prettiestJSON v+prettiestJSON (String s)   = PC.string (show s)+prettiestJSON (Array a)    = PC.encloseSep (PC.text "[") (PC.text "]") (PC.text ",") (map prettiestJSON $ toList a)+prettiestJSON Null         = PC.mempty+prettiestJSON (Number n)   = PC.text (show n)++pcRenderText :: Monoid a => PC.Doc a -> TL.Text+pcRenderText = TLB.toLazyText . PC.renderWith PC.defaultOptions+    { PC.optsAnnotate = \_ -> TLB.fromString }++wlJSON :: Value -> WL.Doc+wlJSON (Bool True)     = WL.text "true"+wlJSON (Bool False)    = WL.text "false"+wlJSON (Object o)      = WL.encloseSep (WL.text "{") (WL.text "}") (WL.text ",") (map prettyKV $ H.toList o)+  where prettyKV (k,v) = WL.text (show k) WL.<> WL.text ":" WL.<+> wlJSON v+wlJSON (String s)      = WL.string (show s)+wlJSON (Array a)       = WL.encloseSep (WL.text "[") (WL.text "]") (WL.text ",") (map wlJSON $ toList a)+wlJSON Null            = WL.empty+wlJSON (Number n)      = WL.text (show n)++wlRender :: WL.Doc -> String+wlRender d = WL.displayS (WL.renderPretty 1 80 d) ""++hpjEncloseSep :: HPJ.Doc -> HPJ.Doc -> HPJ.Doc -> [HPJ.Doc] -> HPJ.Doc+hpjEncloseSep open close sep list = open HPJ.<> HPJ.sep (HPJ.punctuate sep list) HPJ.<> close++hpjJSON :: Value -> HPJ.Doc+hpjJSON (Bool True)    = HPJ.text "true"+hpjJSON (Bool False)   = HPJ.text "false"+hpjJSON (Object o)     = hpjEncloseSep (HPJ.text "{") (HPJ.text "}") (HPJ.text ",") (map prettyKV $ H.toList o)+  where prettyKV (k,v) = HPJ.text (show k) HPJ.<> HPJ.text ":" HPJ.<+> hpjJSON v+hpjJSON (String s)     = HPJ.text (show s)+hpjJSON (Array a)      = hpjEncloseSep (HPJ.text "[") (HPJ.text "]") (HPJ.text ",") (map hpjJSON $ toList a)+hpjJSON Null           = HPJ.empty+hpjJSON (Number n)     = HPJ.text (show n)++readJSONValue :: FilePath -> IO Value+readJSONValue fname = do+    contents <- BSL.readFile fname+    let Just inpJson = decode contents+    return inpJson++main :: IO ()+main = do+    smallValue <- evaluate . force =<< readJSONValue "bench/small.json"+    bigValue <- evaluate . force =<< readJSONValue "bench/big.json"++    C.defaultMain+        [ C.bgroup "small"+            [ C.bench "pretty-compact" $ C.nf (PC.render . prettiestJSON) smallValue+            , C.bench "pretty-compact Text" $ C.nf (pcRenderText . prettiestJSON) smallValue+            , C.bench "pretty"         $ C.nf (HPJ.render . hpjJSON) smallValue+            , C.bench "wl-pprint"      $ C.nf (wlRender . wlJSON) smallValue+            ]+        , C.bgroup "big"+            [ C.bench "pretty-compact" $ C.nf (PC.render . prettiestJSON) bigValue+            , C.bench "pretty-compact Text" $ C.nf (pcRenderText . prettiestJSON) bigValue+            , C.bench "pretty"         $ C.nf (HPJ.render . hpjJSON) bigValue +            , C.bench "wl-pprint"      $ C.nf (wlRender . wlJSON) bigValue+            ]+        ]
pretty-compact.cabal view
@@ -1,5 +1,6 @@+Cabal-Version: 3.4 name: pretty-compact-version: 1.0+version: 3.1 synopsis: Pretty-printing library description:   This package contains a pretty-printing library, a set of API's@@ -9,21 +10,46 @@   .   This library produces more compact outputs than both   Wadler-Leijen or Hughes-PJ algorithms, at the expense of computational ressources.-  The API is the same as Wadler-Leijen's.-license: GPL+  The core API is based on Hughes-PJ, but some combinators of the Leijen API are implemented as well.+license: LGPL-3.0-only license-file: LICENSE category: Text maintainer: Jean-Philippe Bernardy <jeanphilippe.bernardy@gmail.com> build-type: Simple-Cabal-Version: >= 1.8  source-repository head                   type: git                   location: http://github.com/jyp/prettiest.git + Library-        exposed-modules:-                Text.PrettyPrint.Compact-                Text.PrettyPrint.Compact.Core-        build-depends:-                base >= 3 && < 5+  exposed-modules:+    Text.PrettyPrint.Compact+    Text.PrettyPrint.Compact.Core+  build-depends:+    base >= 4.6 && < 5,+    base-compat >= 0.9.3 && <0.12,+    containers >= 0 && <666++  if !impl(ghc >= 8.0)+    build-depends: semigroups >= 0 && <666++  other-extensions:+    LambdaCase++benchmark pretty-comparison+  type: exitcode-stdio-1.0+  hs-source-dirs: bench+  main-is: Benchmark.hs+  build-depends:+    aeson,+    base,+    base-compat,+    bytestring,+    criterion,+    deepseq,+    pretty,+    pretty-compact,+    text,+    unordered-containers,+    wl-pprint