pretty-compact 1.0 → 2.0
raw patch · 3 files changed
+137/−333 lines, 3 filesdep +containersdep ~base
Dependencies added: containers
Dependency ranges changed: base
Files
- Text/PrettyPrint/Compact.hs +36/−216
- Text/PrettyPrint/Compact/Core.hs +96/−114
- pretty-compact.cabal +5/−3
Text/PrettyPrint/Compact.hs view
@@ -2,34 +2,18 @@ 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, encloseSep, list, tupled, semiBraces, -- * Operators- (<+>), (<$>), (</>), (<$$>), (<//>),+ (<+>), ($$), -- * List combinators- hsep, vsep, fillSep, sep, hcat, vcat, fillCat, cat, punctuate,-- -- * Fillers- fill, fillBreak,+ hsep, sep, hcat, vcat, cat, punctuate, -- * Bracketing combinators enclose, squotes, dquotes, parens, angles, braces, brackets,@@ -49,16 +33,10 @@ -- column, nesting, width ) where -import Control.Applicative import Data.Monoid import Text.PrettyPrint.Compact.Core as Text.PrettyPrint.Compact -type Indentation = Int--infixr 5 </>,<//>,<$$$>,<$$>-infixr 6 <+>- -- | 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@@ -109,7 +87,7 @@ = case ds of [] -> left <> right [d] -> left <> d <> right- _ -> align (cat (zipWith (<>) (left : repeat sep) ds) <> right)+ _ -> cat (zipWith (<>) (left : repeat sep) ds) <> right ----------------------------------------------------------- -- punctuate p [d1,d2,...,dn] => [d1 <> p,d2 <> p, ... ,dn]@@ -154,10 +132,11 @@ -- horizontally with @(\<+\>)@, if it fits the page, or vertically with -- @(\<$\>)@. ----- > sep xs = group (vsep xs) sep :: [Doc] -> Doc-sep = group . vsep+sep [] = mempty+sep xs = hsep xs <|> vcat 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@@ -173,38 +152,6 @@ 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@@ -212,7 +159,8 @@ -- -- > cat xs = group (vcat xs) cat :: [Doc] -> Doc-cat = group . vcat+cat [] = mempty+cat xs = hcat xs <> vcat xs -- | The document @(fillCat xs)@ concatenates documents @xs@ -- horizontally with @(\<\>)@ as long as its fits the page, than inserts@@ -228,13 +176,12 @@ 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.+-- vertically with @($$)@. vcat :: [Doc] -> Doc-vcat = foldDoc (<$$>)+vcat = foldDoc ($$) foldDoc :: (Doc -> Doc -> Doc) -> [Doc] -> Doc-foldDoc f [] = mempty+foldDoc _ [] = mempty foldDoc f ds = foldr1 f ds -- | The document @(x \<+\> y)@ concatenates document @x@ and @y@ with a@@ -242,43 +189,23 @@ (<+>) :: Doc -> Doc -> Doc 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)+-- | 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 <> softline <> y+x </> y = ((x <> space) <|> flush x) <> 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)+-- | 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 <> softbreak <> y+x <//> y = (x <|> flush 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)@ concatenates document @x@ and @y@ with--- a @linebreak@ in between. (infixr 5)+-- a linebreak in between. (infixr 5) (<$$>) :: Doc -> Doc -> Doc-x <$$> y = x <> linebreak <> y+x <$$> y = flush x <> 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- -- | Document @(squotes x)@ encloses document @x@ with single quotes -- \"'\". squotes :: Doc -> Doc@@ -380,10 +307,7 @@ -- 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 = vcat . map text . lines bool :: Bool -> Doc bool b = text (show b)@@ -413,85 +337,8 @@ rational :: Rational -> Doc 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@@ -511,43 +358,10 @@ -- The @hang@ combinator is implemented as: -- -- > hang i x = align (nest i x)-hang :: Indentation -> Doc -> Doc-hang i d = align (nest i d)---- | 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 :: Int -> Doc -> Doc -> Doc+hang n x y = (x <+> y) <|> (x $$ nest' n y) --- | 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 document @(nest i x)@ renders document @x@ with the current -- indentation level increased by i (See also 'hang', 'align' and -- 'indent').@@ -561,9 +375,15 @@ -- world -- ! -- @-nest :: Indentation -> Doc -> Doc-nest i x = Nest i x -column, nesting :: (Indentation -> Doc) -> Doc-column f = Column f-nesting f = Nesting f++space = text " "+++nest' n x = spaces n <> x++spaces :: Int -> Doc+spaces n = text $ replicate n ' '++($$) :: Doc -> Doc -> Doc+a $$ b = flush a <> b
Text/PrettyPrint/Compact/Core.hs view
@@ -1,142 +1,124 @@-{-# LANGUAGE RecordWildCards #-}-module Text.PrettyPrint.Compact.Core(Doc(..),render,group,flatten,space,spacing,text) where+{-# LANGUAGE ScopedTypeVariables, TypeSynonymInstances, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, ViewPatterns #-}+module Text.PrettyPrint.Compact.Core(Layout(..),Document(..),Doc) where -import Data.Monoid+import Data.List (intercalate,sort,groupBy) import Data.Function (on)-import Data.List (partition,minimumBy,sort)-import Data.Either (partitionEithers)-import Data.String+import Data.Monoid+import Data.Sequence (singleton, Seq, viewl, viewr, ViewL(..), ViewR(..))+import qualified Data.Sequence as S -type Indentation = Int -data Box = Str String | Spacing Indentation | NewLine {-^ not allowed in the input -} -instance IsString Doc where- fromString = text+newtype L = L (Seq String) -- non-empty sequence+ deriving (Eq,Ord) -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 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 ' ' +newtype N = N {fromN :: String}+instance Monoid N where+ mempty = N ""+ mappend (N x) (N y) = N (x ++ "\n" ++ y)+instance Layout L where+ render (L xs) = fromN $ foldMap N xs+ text = L . singleton+ flush (L xs) = L (xs <> singleton "") -instance Monoid Doc where- mempty = Empty- mappend = Cat -text :: String -> Doc-text = Text . Str+class Monoid d => Layout d where+ text :: String -> d+ flush :: d -> d+ render :: d -> String -spacing = Text . Spacing+class Layout d => Document d where+ (<|>) :: d -> d -> d -space = spacing 1+data M = M {height :: Int,+ lastWidth :: Int,+ maxWidth :: Int+ }+ deriving (Show,Eq,Ord) -group :: Doc -> Doc-group x = Union (flatten x) x+instance Monoid M where+ mempty = text ""+ a `mappend` b =+ M {maxWidth = max (maxWidth a) (maxWidth b + lastWidth a),+ height = height a + height b,+ lastWidth = lastWidth a + lastWidth b} -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+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" -len :: Box -> Int-len (Str s) = length s-len (Spacing x) = x-len NewLine = 0+fits :: M -> Bool+fits x = maxWidth x <= 80 -data Docs = Nil- | Cons !Indentation Doc Docs+class Poset a where+ (≺) :: a -> a -> Bool -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. -measure :: Process -> (Indentation, Int)-measure Process{..} = (curIndent, negate numToks)+instance Poset M where+ M c1 l1 s1 ≺ M c2 l2 s2 = c1 <= c2 && l1 <= l2 && s1 <= s2 -instance Eq Process where- (==) = (==) `on` measure-instance Ord Process where- compare = compare `on` measure -filtering :: [Process] -> [Process]-filtering (x:y:xs) | numToks x >= numToks y = filtering (x:xs)- | otherwise = x:filtering (y:xs)-filtering xs = xs -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"]+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 - 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)))+mergeAll :: Ord a => [[a]] -> [a]+mergeAll [] = []+mergeAll (x:xs) = merge x (mergeAll xs) - -- Automatically inserted spacing does not count as doing more production.- count (Spacing _) = 0- count (Str _) = 1+bests :: forall a. (Ord a, Poset a) => [[a]] -> [a]+bests = pareto' [] . mergeAll - -- 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)+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 -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+newtype Doc = MkDoc [(M,L)] -render :: Double -> Indentation -> Doc -> String-render rfrac w d = do- layout $ renderAll rfrac w d+quasifilter :: (a -> Bool) -> [a] -> [a]+quasifilter p xs = let fxs = filter p xs in if null fxs then take 1 xs else fxs -instance Show Doc where- show = render 0.8 80+instance Monoid Doc where+ mempty = text ""+ MkDoc xs `mappend` MkDoc ys = MkDoc $ bests [ quasifilter (fits . fst) [x <> y | y <- ys] | x <- xs]++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 Document Doc where+ MkDoc m1 <|> MkDoc m2 = MkDoc (bests [m1,m2])+++-- (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++instance (Document a, Document b) => Document (a,b) where+ (a,b) <|> (c,d) = (a<|>c,b<|>d)++instance (Poset a) => Poset (a,b) where+ (a,_) ≺ (b,_) = a ≺ b
pretty-compact.cabal view
@@ -1,5 +1,5 @@ name: pretty-compact-version: 1.0+version: 2.0 synopsis: Pretty-printing library description: This package contains a pretty-printing library, a set of API's@@ -9,7 +9,7 @@ . 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.+ The core API is based on Hughes-PJ, but some combinators of the Leijen API are implemented as well. license: GPL license-file: LICENSE category: Text@@ -21,9 +21,11 @@ type: git location: http://github.com/jyp/prettiest.git + Library exposed-modules: Text.PrettyPrint.Compact Text.PrettyPrint.Compact.Core build-depends:- base >= 3 && < 5+ base >= 3 && < 5,+ containers