packages feed

pretty-compact 2.0 → 2.1

raw patch · 4 files changed

+530/−154 lines, 4 filesdep +aesondep +base-compatdep +bytestringdep ~base

Dependencies added: aeson, base-compat, bytestring, criterion, deepseq, pretty, pretty-compact, semigroups, text, unordered-containers, wl-pprint

Dependency ranges changed: base

Files

Text/PrettyPrint/Compact.hs view
@@ -1,5 +1,65 @@ {-# 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,@@ -10,11 +70,14 @@    hang, encloseSep, list, tupled, semiBraces,     -- * Operators-   (<+>), ($$),+   (<+>), ($$), (</>), (<//>), (<$$>), (<|>),     -- * List combinators    hsep, sep, hcat, vcat, cat, punctuate, +   -- * Fill combiantors+   fillSep, fillCat,+    -- * Bracketing combinators    enclose, squotes, dquotes, parens, angles, braces, brackets, @@ -27,28 +90,47 @@    bool,     -- * Rendering+   renderWith,    render,+   Options(..),+   defaultOptions, +   -- * Annotations+   annotate,+    -- * Undocumented    -- column, nesting, width    ) where  import Data.Monoid+import Data.List (intersperse)  import Text.PrettyPrint.Compact.Core as Text.PrettyPrint.Compact+import Text.PrettyPrint.Compact.Core (singleLine) ++-- | Render the 'Doc' into 'String' omitting all annotations.+render :: Annotation a => Doc a -> String+render = renderWith defaultOptions++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  @@ -56,7 +138,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@@ -82,12 +164,12 @@ --      ,200 --      ,3000] -- @-encloseSep :: Doc -> Doc -> Doc -> [Doc] -> Doc+encloseSep :: Annotation a => Doc a -> Doc a -> Doc a -> [Doc a] -> Doc a encloseSep left right sep ds-    = case ds of-        []  -> left <> right-        [d] -> left <> d <> right-        _   -> cat (zipWith (<>) (left : repeat sep) ds) <> right+    = (\mid -> mid <> right) $ case ds of+        []  -> left <> mempty+        [d] -> left <> d+        (d:ds') -> hcat (left:intersperse (sep<>text " ") ds) <|> vcat (left <> d:map (sep <>) ds')  ----------------------------------------------------------- -- punctuate p [d1,d2,...,dn] => [d1 <> p,d2 <> p, ... ,dn]@@ -117,7 +199,7 @@ -- -- (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 :: Annotation a => Doc a -> [Doc a] -> [Doc a] punctuate p []      = [] punctuate p [d]     = [d] punctuate p (d:ds)  = (d <> p) : punctuate p ds@@ -132,8 +214,9 @@ -- horizontally with @(\<+\>)@, if it fits the page, or vertically with -- @(\<$\>)@. ---sep :: [Doc] -> Doc+sep :: Annotation a => [Doc a] -> Doc a sep [] = mempty+sep [x] = x sep xs = hsep xs <|> vcat xs  @@ -143,157 +226,168 @@ -- @xs@. -- -- > fillSep xs  = foldr (\<\/\>) empty xs-fillSep :: [Doc] -> Doc+fillSep :: Annotation a => [Doc a] -> Doc a fillSep         = foldDoc (</>)  -- | The document @(hsep xs)@ concatenates all documents @xs@ -- horizontally with @(\<+\>)@.-hsep :: [Doc] -> Doc-hsep            = foldDoc (<+>)--+hsep :: Annotation a => [Doc a] -> Doc a+hsep            = 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 :: Annotation a => [Doc a] -> Doc a cat [] =  mempty-cat xs = hcat xs <> vcat xs+cat [x] = x+cat xs = hcat xs <|> vcat 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 :: Annotation a => [Doc a] -> Doc a fillCat         = foldDoc (<//>)  -- | The document @(hcat xs)@ concatenates all documents @xs@--- horizontally with @(\<\>)@.-hcat :: [Doc] -> Doc-hcat            = foldDoc (<>)+-- horizontally with @(\<-\>)@.+hcat :: Annotation a => [Doc a] -> Doc a+hcat            = foldDoc (<->)  -- | The document @(vcat xs)@ concatenates all documents @xs@ -- vertically with @($$)@.-vcat :: [Doc] -> Doc+vcat :: Annotation a => [Doc a] -> Doc a vcat            = foldDoc ($$) -foldDoc :: (Doc -> Doc -> Doc) -> [Doc] -> Doc+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@, if+-- @x@ fits on a single line, and fails otherwise.+(<->) :: Annotation a => Doc a -> Doc a -> Doc a+x <-> y         = singleLine x <> y+ -- | 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 @space@ in between, if @x@ fits on a single line, and fails+-- otherwise.  (infixr 6)+(<-+>) :: Annotation a => Doc a -> Doc a -> Doc a+x <-+> y         = (singleLine x <> space <> 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)-(</>) :: Doc -> Doc -> Doc-x </> y         = ((x <> space) <|> flush x) <> y+-- (with a @space@ in between) if @x@ fits on a single line, or underneath each other. (infixr 5)+(</>) :: Annotation a => Doc a -> Doc a -> Doc a+x </> y         = ((singleLine x <> space) <|> flush x) <> y --- | The document @(x \<\/\/\> y)@ puts @x@ and @y@ either right next to each--- other or underneath each other. (infixr 5)-(<//>) :: Doc -> Doc -> Doc-x <//> y        = (x <|> flush x) <> 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        = (singleLine x <|> flush x) <> y   -- | The document @(x \<$$\> y)@ concatenates document @x@ and @y@ with -- a linebreak in between. (infixr 5)-(<$$>) :: Doc -> Doc -> Doc+(<$$>) :: Annotation a => Doc a -> Doc a -> Doc a x <$$> y = flush x <> y   -- | 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 '='  -----------------------------------------------------------@@ -306,35 +400,35 @@ -- 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 :: 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)  @@ -358,10 +452,9 @@ -- The @hang@ combinator is implemented as: -- -- > hang i x  = align (nest i x)-hang :: Int -> Doc -> Doc -> Doc+hang :: Annotation a => Int -> Doc a -> Doc a -> Doc a hang n x y = (x <+> y) <|> (x $$ nest' n y) - -- | The document @(nest i x)@ renders document @x@ with the current -- indentation level increased by i (See also 'hang', 'align' and -- 'indent').@@ -377,13 +470,21 @@ -- @  +space :: Annotation a => Doc a space = text " "  +nest' :: Annotation a => Int -> Doc a -> Doc a nest' n x = spaces n <> x -spaces :: Int -> Doc+spaces :: Annotation a => Int -> Doc a spaces n = text $ replicate n ' ' -($$) :: Doc -> Doc -> Doc-a $$ b = flush a <> b+-- | The document @(x \<$$\> y)@ concatenates document @x@ and @y@ with+-- a linebreak in between. (infixr 5)+($$) :: Annotation a => Doc a -> Doc a -> Doc a+($$)  = (<$$>)++-- $setup+-- >>> import Data.Monoid+-- >>> import Data.Char
Text/PrettyPrint/Compact/Core.hs view
@@ -1,124 +1,286 @@-{-# LANGUAGE ScopedTypeVariables, TypeSynonymInstances, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, ViewPatterns #-}-module Text.PrettyPrint.Compact.Core(Layout(..),Document(..),Doc) where+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables, TypeSynonymInstances, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, ViewPatterns, DeriveFunctor, DeriveFoldable, DeriveTraversable, LambdaCase #-}+module Text.PrettyPrint.Compact.Core(Annotation,Layout(..),renderWith,Options(..),Document(..),Doc,singleLine) where -import Data.List (intercalate,sort,groupBy)+import Prelude ()+import Prelude.Compat as P++import Data.List.Compat (sortOn,groupBy,minimumBy) import Data.Function (on)-import Data.Monoid-import Data.Sequence (singleton, Seq, viewl, viewr, ViewL(..), ViewR(..))-import qualified Data.Sequence as S+import Data.Semigroup+import Data.Sequence (singleton, Seq, viewl, viewr, ViewL(..), ViewR(..), (|>))+import Data.String+import Data.Foldable (toList) +-- | 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) +-- | 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 -newtype L = L (Seq String) -- non-empty sequence-  deriving (Eq,Ord)+asLength :: AS a -> Int+asLength (AS l _) = l -instance Monoid L where-   mempty = L (singleton "")-   L (viewr -> xs :> x) `mappend` L (viewl -> y :< ys) = L (xs <> singleton (x ++ y) <> fmap (indent ++) ys)-      where n = length x-            indent = Prelude.replicate n ' '+-- | Make a non-annotated 'AS'.+mkAS :: Monoid a => String -> AS a+mkAS s = AS (length s) [(mempty, s)] -newtype N = N {fromN :: String}-instance Monoid N where-  mempty = N ""-  mappend (N x) (N y) = N (x ++ "\n" ++ y)+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 a => Semigroup (L a) where+  L (viewr -> xs :> x) <> L (viewl -> y :< ys) = L (xs <> singleton (x <> y) <> fmap (indent <>) ys)+      where n = asLength x+            indent = mkAS (P.replicate n ' ')+  L _ <> L _ = error "<> @L: invariant violated, Seq is empty"++instance Monoid a => Monoid (L a) where+   mempty = L (singleton (mkAS ""))+   mappend = (<>)+ instance Layout L where-   render (L xs) = fromN $ foldMap N xs-   text = L . singleton-   flush (L xs) = L (xs <> singleton "")+   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)  -class Monoid d => Layout d where-  text :: String -> d-  flush :: d -> d-  render :: d -> String+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" +    intercalate []     = mempty+    intercalate (y:ys) = f' y `mappend` foldMap (mappend sep . f') ys++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.+    }++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+ class Layout d => Document d where-  (<|>) :: d -> d -> d+  (<|>) :: Eq a => d a -> d a -> d a+  empty :: d a -data M = M {height    :: Int,-            lastWidth :: Int,-            maxWidth  :: Int-            }-  deriving (Show,Eq,Ord)+-- | type parameter is phantom.+data M a = M {height    :: Int,+              lastWidth :: Int,+              maxWidth  :: Int+              }+  deriving (Show,Eq,Ord,Functor,Foldable,Traversable) -instance Monoid M where-  mempty = text ""-  a `mappend` b =+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} +instance Monoid a => Monoid (M a) where+  mempty = text ""+  mappend = (<>)+ 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}-  render = error "don't use this render"--fits :: M -> Bool-fits x = maxWidth x <= 80-+  annotate _ M{..} = M{..} class Poset a where   (≺) :: a -> a -> Bool  -instance Poset M where+instance Poset (M a) where   M c1 l1 s1 ≺ M c2 l2 s2 = c1 <= c2 && l1 <= l2 && s1 <= s2 +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 +mergeAllOn :: Ord b => (a -> b) -> [[a]] -> [a]+mergeAllOn _ [] = []+mergeAllOn m (x:xs) = mergeOn m x (mergeAllOn m xs) -merge :: Ord a => [a] -> [a] -> [a]-merge [] xs = xs-merge xs [] = xs-merge (x:xs) (y:ys)-  | x <= y = x:merge xs (y:ys)-  | otherwise = y:merge (x:xs) ys+bestsOn :: forall a b. (Poset b, Ord b)+      => (a -> b) -- ^ measure+      -> [[a]] -> [a]+bestsOn m = paretoOn' m [] . mergeAllOn m +-- | @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. -mergeAll :: Ord a => [[a]] -> [a]-mergeAll [] = []-mergeAll (x:xs) = merge x (mergeAll xs)+-- 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)]} -bests :: forall a. (Ord a, Poset a) => [[a]] -> [a]-bests = pareto' [] . mergeAll+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] -pareto' :: Poset a => [a] -> [a] -> [a]-pareto' acc [] = Prelude.reverse acc-pareto' acc (x:xs) = if any (≺ x) acc-                       then pareto' acc xs-                       else pareto' (x:acc) xs+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 -newtype Doc = MkDoc [(M,L)]+instance Monoid a => Monoid (ODoc a) where+  mempty = text ""+  mappend = (<>) -quasifilter :: (a -> Bool) -> [a] -> [a]-quasifilter p xs = let fxs = filter p xs in if null fxs then take 1 xs else fxs+-- TODO: make columns configurable+fits :: Int -> M a -> Bool+fits w x = maxWidth x <= w -instance Monoid Doc where+instance Layout ODoc where+  flush (MkDoc xs) = MkDoc $ \w -> bestsOn frst $ map (sortOn frst) $ groupBy ((==) `on` (height . frst)) $ (map flush (xs w))+  -- flush xs = paretoOn' fst [] $ sort $ (map flush xs)+  text s = MkDoc $ \w -> [text s]+  annotate a (MkDoc xs) = MkDoc $ \w -> fmap (annotate a) (xs w)++renderWith :: (Monoid r,  Monoid a, Eq a)+           => Options a r  -- ^ rendering options+           -> Doc 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 (interp d) pageWidth)++instance Document ODoc where+  MkDoc m1 <|> MkDoc m2 = MkDoc $ \w -> bestsOn frst [m1 w,m2 w]+  empty = MkDoc $ \_ -> []++data Pair f g a = (:-:) {frst :: f a, scnd :: g a}++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+  mappend (x :-: y)(x' :-: y') = (x `mappend` x') :-: (y `mappend` y')++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++data DDoc a = Text String | Flush (DDoc a) | S (Seq (DDoc a)) | DDoc a :<|> DDoc a | Fail | Annotate a (DDoc a)+  deriving Eq++type Annotation a = (Eq a, Monoid a)++interp :: Annotation a => DDoc a -> ODoc a+interp = \case+  Text s -> text s+  Flush d -> flush (interp d)+  Fail -> empty+  S ds -> foldMap interp $ catTexts $ toList ds+  d :<|> e -> interp d <|> interp e+  Annotate a d -> annotate a (interp d)+++catTexts :: forall a. [DDoc a] -> [DDoc a]+catTexts (Text t:Text u:xs) = catTexts (Text (t<>u):xs)+catTexts (x:xs) = x:catTexts xs+catTexts [] = []++instance Semigroup (DDoc a) where+  Fail <> _ = Fail+  _ <> Fail = Fail+  S as <> S bs = S (as <> bs)+  S as <> b = S (as <> singleton b)+  a <> S bs = S (singleton a <> bs)+  a <> b = S (singleton a <> singleton b)++instance Monoid a => Monoid (DDoc a) where   mempty = text ""-  MkDoc xs `mappend` MkDoc ys = MkDoc $ bests [ quasifilter (fits . fst) [x <> y | y <- ys] | x <- xs]+  mappend = (<>) -instance Layout Doc where-  flush (MkDoc xs) = MkDoc $ bests $ map sort $ groupBy ((==) `on` (height . fst)) $ (map flush xs)-  -- flush xs = pareto' [] $ sort $ (map flush xs)-  text s = MkDoc [text s]-  render (MkDoc []) = error "No suitable layout found."-  render (MkDoc (x:_)) = render x+instance Layout DDoc where+  text = Text+  flush (Flush x) = Flush x+  flush x = Flush x+  annotate = Annotate -- can be pushed down to text. Is this a good idea? (Note it'll get rid of complications in the classes, etc.) -instance Document Doc where-  MkDoc m1 <|> MkDoc m2 = MkDoc (bests [m1,m2])+instance Document DDoc where+  S (viewl -> a :< as) <|> S (viewl -> b :< bs) | a == b = a <> (S as <|> S bs)+  S (viewr -> as :> a) <|> S (viewr -> bs :> b) | a == b = (S as <|> S bs) <> a+  Flush a <|> Flush b = Flush (a <|> b)+  Annotate a b <|> Annotate a' d | a == a' = Annotate a' (b <|> d)+  a <|> b = a <||> b+  empty = Fail +(<||>) :: forall a. DDoc a -> DDoc a -> DDoc a+a <||> Fail = a+Fail <||> a = a+a <||> b = a :<|> b ---  (a,b) `mappend` (c,d) = (a<>c ,b<>d) -instance (Layout a, Layout b) => Layout (a,b) where-  text s = (text s, text s)-  flush (a,b) = (flush a, flush b)-  render = render . snd+singleLine :: forall a. Monoid a => DDoc a -> DDoc a+singleLine (Flush _) = Fail+singleLine (Annotate a d) = Annotate a (singleLine d)+singleLine (Text s) = Text s+singleLine (a :<|> b) = singleLine a <||> singleLine b+singleLine Fail = Fail+singleLine (S xs) = foldMap singleLine xs -instance (Document a, Document b) => Document (a,b) where-  (a,b) <|> (c,d) = (a<|>c,b<|>d)+type Doc = DDoc -instance (Poset a) => Poset (a,b) where-  (a,_) ≺ (b,_) = a ≺ b++-- $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,5 @@ name: pretty-compact-version: 2.0+version: 2.1 synopsis: Pretty-printing library description:   This package contains a pretty-printing library, a set of API's@@ -16,6 +16,13 @@ maintainer: Jean-Philippe Bernardy <jeanphilippe.bernardy@gmail.com> build-type: Simple Cabal-Version: >= 1.8+tested-with:+  GHC == 7.4.2,+  GHC == 7.6.3,+  GHC == 7.8.4,+  GHC == 7.10.3,+  GHC == 8.0.2,+  GHC == 8.2.1  source-repository head                   type: git@@ -23,9 +30,30 @@   Library-        exposed-modules:-                Text.PrettyPrint.Compact-                Text.PrettyPrint.Compact.Core-        build-depends:-                      base >= 3 && < 5,-                      containers+  exposed-modules:+    Text.PrettyPrint.Compact+    Text.PrettyPrint.Compact.Core+  build-depends:+    base >= 3 && < 5,+    base-compat >= 0.9.3 && <0.10,+    containers++  if !impl(ghc >= 8.0)+    build-depends: semigroups++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