packages feed

pretty-compact 2.1 → 3.0

raw patch · 3 files changed

+87/−180 lines, 3 filesdep ~basedep ~base-compat

Dependency ranges changed: base, base-compat

Files

Text/PrettyPrint/Compact.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE TupleSections #-} {-# LANGUAGE OverloadedStrings #-} -- | Compact pretty-printer. --@@ -67,16 +68,16 @@    -- * Basic combinators    module Data.Monoid, text, flush, char, -   hang, encloseSep, list, tupled, semiBraces,+   hang, hangWith, encloseSep, list, tupled, semiBraces,     -- * Operators-   (<+>), ($$), (</>), (<//>), (<$$>), (<|>),+   (<+>), ($$), (</>), (<//>), (<$$>),     -- * List combinators    hsep, sep, hcat, vcat, cat, punctuate,     -- * Fill combiantors-   fillSep, fillCat,+   -- fillSep, fillCat,     -- * Bracketing combinators    enclose, squotes, dquotes, parens, angles, braces, brackets,@@ -103,12 +104,9 @@    ) 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@@ -165,11 +163,11 @@ --      ,3000] -- @ encloseSep :: Annotation a => Doc a -> Doc a -> Doc a -> [Doc a] -> Doc a-encloseSep left right sep ds-    = (\mid -> mid <> right) $ case ds of-        []  -> left <> mempty+encloseSep left right separator ds+    = (<> right) $ case ds of+        []  -> left         [d] -> left <> d-        (d:ds') -> hcat (left:intersperse (sep<>text " ") ds) <|> vcat (left <> d:map (sep <>) ds')+        (d:ds') -> cat (left <> d:map (separator <>) ds')  ----------------------------------------------------------- -- punctuate p [d1,d2,...,dn] => [d1 <> p,d2 <> p, ... ,dn]@@ -200,8 +198,8 @@ -- (If you want put the commas in front of their elements instead of -- at the end, you should use 'tupled' or, in general, 'encloseSep'.) punctuate :: Annotation a => Doc a -> [Doc a] -> [Doc a]-punctuate p []      = []-punctuate p [d]     = [d]+punctuate _p []      = []+punctuate _p [d]     = [d] punctuate p (d:ds)  = (d <> p) : punctuate p ds  @@ -211,51 +209,47 @@   -- | 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 :: Annotation a => [Doc a] -> Doc a-sep [] = mempty-sep [x] = x-sep xs = hsep xs <|> vcat xs+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 :: Annotation a => [Doc a] -> Doc a-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 :: Annotation a => [Doc a] -> Doc a-hsep            = foldDoc (<-+>)+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 :: Annotation a => [Doc a] -> Doc a-cat [] =  mempty-cat [x] = x-cat xs = hcat xs <|> vcat xs+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 :: Annotation a => [Doc a] -> Doc a-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 @(\<-\>)@.+-- horizontally with @(\<\>)@. hcat :: Annotation a => [Doc a] -> Doc a-hcat            = foldDoc (<->)+hcat            = foldDoc (<>)  -- | The document @(vcat xs)@ concatenates all documents @xs@ -- vertically with @($$)@.@@ -266,39 +260,26 @@ 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) (<+>) :: 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) if @x@ fits on a single line, or underneath each other. (infixr 5)+-- (with a @space@ in between) or underneath each other. (infixr 5) (</>) :: Annotation a => Doc a -> Doc a -> Doc a-x </> y         = ((singleLine x <> space) <|> flush x) <> y+x </> y         = hang 0 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-+x <//> y        = hangWith "" 0 x y  -- | The document @(x \<$$\> y)@ concatenates document @x@ and @y@ with -- a linebreak in between. (infixr 5) (<$$>) :: Annotation a => Doc a -> Doc a -> Doc a-x <$$> y = flush x <> y-+(<$$>) = ($$)  -- | Document @(squotes x)@ encloses document @x@ with single quotes -- \"'\".@@ -434,56 +415,22 @@   -- | 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 i x y)@ either @x@ and @y@ concatenated with @\<+\>@ or @y@+-- below @x@ with an additional indentation of @i@.+ hang :: Annotation a => Int -> Doc a -> Doc a -> Doc a-hang n x y = (x <+> y) <|> (x $$ nest' n y)+hang = hangWith " " --- | 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--- !--- @ +-- | 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)]  space :: Annotation a => Doc a space = text " "---nest' :: Annotation a => Int -> Doc a -> Doc a-nest' n x = spaces n <> x--spaces :: Annotation a => Int -> Doc a-spaces n = text $ replicate n ' '---- | 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
Text/PrettyPrint/Compact/Core.hs view
@@ -1,7 +1,8 @@+{-# LANGUAGE TupleSections #-} {-# 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+module Text.PrettyPrint.Compact.Core(Annotation,Layout(..),renderWith,Options(..),groupingBy,Doc,($$)) where  import Prelude () import Prelude.Compat as P@@ -12,7 +13,7 @@ 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).@@ -65,7 +66,6 @@       where annotateAS (AS i s) = AS i (fmap annotatePart s)             annotatePart (b, s) = (b `mappend` a, s) - renderWithL :: (Monoid a, Monoid r) => Options a r -> L a -> r renderWithL opts (L xs) = intercalate (toList xs)   where@@ -95,11 +95,7 @@   --   annotate :: forall a. Monoid a => a -> d a -> d a -class Layout d => Document d where-  (<|>) :: Eq a => d a -> d a -> d a-  empty :: d a---- | type parameter is phantom.+-- type parameter is phantom. data M a = M {height    :: Int,               lastWidth :: Int,               maxWidth  :: Int@@ -176,31 +172,50 @@   mempty = text ""   mappend = (<>) --- TODO: make columns configurable fits :: Int -> M a -> Bool fits w x = maxWidth x <= w  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]+  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,  Monoid a, Eq a)+renderWith :: (Monoid r, Annotation a)            => Options a r  -- ^ rendering options-           -> Doc a          -- ^ renderable+           -> 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 (interp d) pageWidth)+    xs = discardInvalid pageWidth (fromDoc d pageWidth) -instance Document ODoc where-  MkDoc m1 <|> MkDoc m2 = MkDoc $ \w -> bestsOn frst [m1 w,m2 w]-  empty = MkDoc $ \_ -> []+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}  instance (Semigroup (f a), Semigroup (g a)) => Semigroup (Pair f g a) where@@ -217,68 +232,13 @@ 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 ""-  mappend = (<>)--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 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---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--type Doc = DDoc+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
pretty-compact.cabal view
@@ -1,5 +1,5 @@ name: pretty-compact-version: 2.1+version: 3.0 synopsis: Pretty-printing library description:   This package contains a pretty-printing library, a set of API's