prettify (empty) → 1.0
raw patch · 4 files changed
+1107/−0 lines, 4 filesdep +basedep +containersdep +semigroupssetup-changed
Dependencies added: base, containers, semigroups
Files
- COPYING +44/−0
- Setup.lhs +4/−0
- prettify.cabal +30/−0
- src/Text/Pretty.hs +1029/−0
+ COPYING view
@@ -0,0 +1,44 @@++This library (libraries/pretty) is derived from code from+the GHC project which is largely (c) The University of+Glasgow, and distributable under a BSD-style license (see below).++Modifications from pretty, copyright (c) 2012-2013, Hans Höglund++-----------------------------------------------------------------------------++The Glasgow Haskell Compiler License++Copyright 2004, The University Court of the University of Glasgow. +All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++- Redistributions of source code must retain the above copyright notice,+this list of conditions and the following disclaimer.+ +- Redistributions in binary form must reproduce the above copyright notice,+this list of conditions and the following disclaimer in the documentation+and/or other materials provided with the distribution.+ +- Neither name of the University nor the names of its contributors may be+used to endorse or promote products derived from this software without+specific prior written permission. ++THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF+GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND+FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE+UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH+DAMAGE.++-----------------------------------------------------------------------------++
+ Setup.lhs view
@@ -0,0 +1,4 @@+#! /usr/bin/env runhaskell++> import Distribution.Simple+> main = defaultMain
+ prettify.cabal view
@@ -0,0 +1,30 @@++name: prettify+version: 1.0+cabal-version: >= 1.6+build-type: Simple+author: Hans Hoglund+maintainer: Hans Hoglund <hans@hanshoglund.se>+synopsis: Haskell2010 structured text formatting+category: Text+license: BSD3+license-file: COPYING+tested-with: GHC++description: + A modern take on structured text formatting, also known as pretty-printing. + Based on the classic pretty package by Hughes, Peyton-Jones et al.++source-repository head+ type: git+ location: git://github.com/hanshoglund/prettify.git+ +library + build-depends: + base >= 4 && < 5,+ semigroups,+ containers+ hs-source-dirs: src+ exposed-modules:+ Text.Pretty+
+ src/Text/Pretty.hs view
@@ -0,0 +1,1029 @@++{-# LANGUAGE BangPatterns #-}++-----------------------------------------------------------------------------+-- |+-- Module : Text.Prettify+-- Copyright : (c) The University of Glasgow 2001+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Hans Hoglund <hans@hanshoglund.se>+-- Stability : experimental+-- Portability : portable+--+-- This library was based on /The Design of a Pretty-printing Library/ by Jeuring and +-- Meijer.+--+-- Heavily modified by Simon Peyton Jones (December 1996).+--+-- Lightly modified by Hans Hoglund (October 2012).+--+-----------------------------------------------------------------------------+module Text.Pretty (++ -- * The Pretty typeclass+ Pretty(..),++ -- * The Printer type+ Printer,++ -- * Construction++ -- ** Primitive types+ char, string, sizedText, zeroWidthText,+ int, integer, float, double, rational,++ -- ** Combinators+ empty,+ (<->), (<+>), hcat, hsep,+ (</>), (<//>), vcat,+ sep, cat,+ fsep, fcat,++ -- ** Wrapping and punctuation+ wrap, parens, brackets, braces, quotes, doubleQuotes,+ nest,+ hang,+ sepBy, initBy, termBy,+ sepByS, initByS, termByS,++ -- * Predicates on printers+ isEmpty,++ -- * Rendering printers+ runPrinter,+ Mode(..),+ Style(..),+ style,+ runPrinterStyle+ ) where++import Data.Semigroup+import Data.Ratio ( Ratio, numerator, denominator )+import Data.String ( IsString(fromString) )++-- ---------------------------------------------------------------------------+-- The Printer calculus++-- The Printer combinators satisfy the following laws:++{-+Laws for </>+~~~~~~~~~~~+<a1> (x </> y) </> z = x </> (y </> z)+<a2> empty </> x = x+<a3> x </> empty = x++ ...ditto <//>...++Laws for <>+~~~~~~~~~~~+<b1> (x <> y) <> z = x <> (y <> z)+<b2> empty <> x = empty+<b3> x <> empty = x++ ...ditto <+>...++Laws for string+~~~~~~~~~~~~~+<t1> string s <> string t = string (s++t)+<t2> string "" <> x = x, if x non-empty++** because of law n6, t2 only holds if x doesn't+** start with `nest'.+++Laws for nest+~~~~~~~~~~~~~+<n1> nest 0 x = x+<n2> nest k (nest k' x) = nest (k+k') x+<n3> nest k (x <> y) = nest k x <> nest k y+<n4> nest k (x </> y) = nest k x </> nest k y+<n5> nest k empty = empty+<n6> x <> nest k y = x <> y, if x non-empty++** Note the side condition on <n6>! It is this that+** makes it OK for empty to be a left unit for <>.++Miscellaneous+~~~~~~~~~~~~~+<m1> (string s <> x) </> y = string s <> ((string "" <> x) </>+ nest (-length s) y)++<m2> (x </> y) <> z = x </> (y <> z)+ if y non-empty+++Laws for list versions+~~~~~~~~~~~~~~~~~~~~~~+<l1> sep (ps++[empty]++qs) = sep (ps ++ qs)+ ...ditto hsep, hcat, vcat, fill...++<l2> nest k (sep ps) = sep (map (nest k) ps)+ ...ditto hsep, hcat, vcat, fill...++Laws for oneLiner+~~~~~~~~~~~~~~~~~+<o1> oneLiner (nest k p) = nest k (oneLiner p)+<o2> oneLiner (x <> y) = oneLiner x <> oneLiner y++You might think that the following verion of <m1> would+be neater:++<3 NO> (string s <> x) </> y = string s <> ((empty <> x)) </>+ nest (-length s) y)++But it doesn't work, for if x=empty, we would have++ string s </> y = string s <> (empty </> nest (-length s) y)+ = string s <> nest (-length s) y+-}++-- ---------------------------------------------------------------------------+-- Operator fixity++infixl 6 <->+infixl 6 <+>+infixl 5 </>, <//>+++-- ---------------------------------------------------------------------------+-- Internal+list :: b -> (a -> [a] -> b) -> [a] -> b+list z f [] = z+list z f (x:xs) = x `f` xs++-- ---------------------------------------------------------------------------+-- Pretty++-- |+-- Class of types that can be pretty-printed. +--+-- The Pretty class is similar to 'Show', but converts values to 'Printer's instead +-- of 'Strings'. A printer is essentially a string with some extra structural information+-- such as length and indentation.+--+-- Note that the instances for primitive types, lists and tuples all satisfy+--+-- > (show . pretty) x == show x+--+class Pretty a where++ -- | Return a printer for the given value.+ pretty :: a -> Printer++ -- | The method prettyList is provided to allow the programmer to give a+ -- specialised way of printing lists of values. For example, this is used by+ -- the predefined Pretty instance of the Char type, where values of type String+ -- should be shown in double quotes, rather than between square brackets. + prettyList :: [a] -> Printer+ prettyList = brackets . sepBy (char ',') . map pretty++int :: Int -> Printer+integer :: Integer -> Printer+float :: Float -> Printer+double :: Double -> Printer+rational :: Rational -> Printer+char' :: Char -> Printer+string' :: String -> Printer+int = string . show+integer = string . show+float = string . show+double = string . show+rational = string . show+char' = string . show+string' = string . show++instance Pretty Printer where+ pretty = id++instance Pretty () where+ pretty = string . show++instance Pretty Int where+ pretty = int++instance Pretty Float where+ pretty = float++instance Pretty Double where+ pretty = double++instance Pretty Char where+ pretty = char'+ prettyList = string'++instance Pretty Integer where+ pretty = integer++instance (Pretty a, Pretty b) => Pretty (a,b) where+ pretty (x, y) = parens $ pretty x `g` pretty y+ where x `g` y = x <> char ',' <> y++instance Pretty a => Pretty [a] where+ pretty x = prettyList x++instance Pretty a => Pretty (Maybe a) where+ pretty = maybe empty pretty++instance (Pretty a, Integral a) => Pretty (Ratio a) where+ pretty x = pretty (numerator x) <> string " % " <> pretty (denominator x) + +-- | The abstract type of printers.+data Printer+ = Empty -- empty+ | NilAbove Printer -- string "" </> x+ | TextBeside TextDetails Int Printer -- string s <> x+ | Nest Int Printer -- nest k x++ | Union Printer Printer -- ul `union` ur+ | NoPrinter -- The empty set of printers+ | Beside Printer Bool Printer -- True <=> space between+ | Above Printer Bool Printer -- True <=> never overlap++{-+ A Printer represents a *set* of layouts. A Printer with+ no occurrences of Union or NoPrinter represents just one layout.+ + Here are the invariants:++ 1) The argument of NilAbove is never Empty. Therefore+ a NilAbove occupies at least two lines.++ 2) The argument of @TextBeside@ is never @Nest@.++ 3) The layouts of the two arguments of @Union@ both flatten to the same+ string.++ 4) The arguments of @Union@ are either @TextBeside@, or @NilAbove@.++ 5) A @NoPrinter@ may only appear on the first line of the left argument of an+ union. Therefore, the right argument of an union can never be equivalent+ to the empty set (@NoPrinter@).++ 6) An empty printer is always represented by @Empty@. It can't be+ hidden inside a @Nest@, or a @Union@ of two @Empty@s.++ 7) The first line of every layout in the left argument of @Union@ is+ longer than the first line of any layout in the right argument.+ (1) ensures that the left argument has a first line. In view of+ (3), this invariant means that the right argument must have at+ least two lines.++ Notice the difference between+ * NoPrinter (no printers)+ * Empty (one empty printer; no height and no width)+ * string "" (a printer containing the empty string;+ one line high, but has no width)+-}+++-- | RPrinter is a "reduced Printer", guaranteed not to have a top-level Above or Beside.+type RPrinter a = Printer++-- | The TextDetails data type+--+-- A TextDetails represents a fragment of string that will be+-- output at some point.+data TextDetails = Chr Char -- ^ A single Char fragment+ | Str String -- ^ A whole String fragment++instance Semigroup Printer where+ (<>) = (<->)++instance Monoid Printer where+ mempty = empty+ mappend = (<->)++instance IsString Printer where+ fromString = string++instance Show Printer where+ showsPrec _ doc cont = runPrinter' (mode style) (lineLength style)+ (ribbonsPerLine style)+ txtPrinter cont doc++-- ---------------------------------------------------------------------------+-- Values and Predicates on Printers and TextDetails++-- | A printer of height and width 1, containing a literal character.+char :: Char -> Printer+char c = stringBeside_ (Chr c) 1 Empty++-- | A printer of height 1 containing a literal string.+-- 'string' satisfies the following laws:+--+-- * @'string' s '<>' 'string' t = 'string' (s'++'t)@+--+-- * @'string' \"\" '<>' x = x@, if @x@ non-empty+--+-- The side condition on the last law is necessary because @'string' \"\"@+-- has height 1, while 'empty' has no height.+string :: String -> Printer+string s = case length s of {sl -> stringBeside_ (Str s) sl Empty}++-- | Some string with any width. (@string s = sizedText (length s) s@)+sizedText :: Int -> String -> Printer+sizedText l s = stringBeside_ (Str s) l Empty++-- | Some string, but without any width. Use for non-printing string+-- such as a HTML or Latex tags+zeroWidthText :: String -> Printer+zeroWidthText = sizedText 0++-- | The empty printer, with no height and no width.+-- 'empty' is the identity for '<>', '<+>', '</>' and '<//>', and anywhere+-- in the argument list for 'sep', 'hcat', 'hsep', 'vcat', 'fcat' etc.+empty :: Printer+empty = Empty++-- | Returns 'True' if the printer is empty+isEmpty :: Printer -> Bool+isEmpty Empty = True+isEmpty _ = False++-- an old version inserted tabs being 8 columns apart in the output.+indent :: Int -> String+indent !n = replicate n ' '+{- TODO: GHC Optimised version+-- optimise long indentations using LitString chunks of 8 spaces+indent n r | n >=# _ILIT(8) = LStr (sLit " ") (_ILIT(8)) `txt`+ indent (n -# _ILIT(8)) r+ | otherwise = Str (spaces n) `txt` r+-}++{-+Q: What is the reason for negative indentation (i.e. argument to indent+ is < 0) ?++A:+This indicates an error in the library client's code.+If we compose a <> b, and the first line of b is more indented than some+other lines of b, the law <n6> (<> eats nests) may cause the pretty+printer to produce an invalid layout:++doc |0123345+------------------+d1 |a...|+d2 |...b|+ |c...|++d1<>d2 |ab..|+ c|....|++Consider a <> b, let `s' be the length of the last line of `a', `k' the+indentation of the first line of b, and `k0' the indentation of the+left-most line b_i of b.++The produced layout will have negative indentation if `k - k0 > s', as+the first line of b will be put on the (s+1)th column, effectively+translating b horizontally by (k-s). Now if the i^th line of b has an+indentation k0 < (k-s), it is translated out-of-page, causing+`negative indentation'.+-}+++space_string, nl_string :: TextDetails+space_string = Chr ' '+nl_string = Chr '\n'+++-- | Wrap printer in the given characters.+wrap :: Char -> Char -> Printer -> Printer+wrap s t p = char s <> p <> char t+-- | Wrap printer in @(...)@+parens :: Printer -> Printer+-- | Wrap printer in @[...]@+brackets :: Printer -> Printer+-- | Wrap printer in @{...}@+braces :: Printer -> Printer+-- | Wrap printer in @\'...\'@+quotes :: Printer -> Printer+-- | Wrap printer in @\"...\"@+doubleQuotes :: Printer -> Printer++quotes = wrap '\'' '\''+doubleQuotes = wrap '"' '"'+parens = wrap '(' ')'+brackets = wrap '[' ']'+braces = wrap '{' '}'+++-- ---------------------------------------------------------------------------+-- Structural operations on Printers++-- | Perform some simplification of a built up @Printer@.+reducePrinter :: Printer -> RPrinter a+reducePrinter (Beside p g q) = beside p g (reducePrinter q)+reducePrinter (Above p g q) = above p g (reducePrinter q)+reducePrinter p = p++-- | List version of '<>'.+hcat :: [Printer] -> Printer+hcat = reduceAB . foldr (beside_' False) empty++-- | List version of '<+>'.+hsep :: [Printer] -> Printer+hsep = reduceAB . foldr (beside_' True) empty++-- | List version of '</>'.+vcat :: [Printer] -> Printer+vcat = reduceAB . foldr (above_' False) empty++-- | Nest (or indent) a printer by a given number of positions+-- (which may also be negative). 'nest' satisfies the laws:+--+-- * @'nest' 0 x = x@+--+-- * @'nest' k ('nest' k' x) = 'nest' (k+k') x@+--+-- * @'nest' k (x '<>' y) = 'nest' k z '<>' 'nest' k y@+--+-- * @'nest' k (x '</>' y) = 'nest' k x '</>' 'nest' k y@+--+-- * @'nest' k 'empty' = 'empty'@+--+-- * @x '<>' 'nest' k y = x '<>' y@, if @x@ non-empty+--+-- The side condition on the last law is needed because+-- 'empty' is a left identity for '<>'.+nest :: Int -> Printer -> Printer+nest k p = mkNest k (reducePrinter p)++-- | @hang d1 n d2 = sep [d1, nest n d2]@+hang :: Printer -> Int -> Printer -> Printer+hang d1 n d2 = sep [d1, nest n d2]++-- mkNest checks for Nest's invariant that it doesn't have an Empty inside it+mkNest :: Int -> Printer -> Printer+mkNest k _ | k `seq` False = undefined+mkNest k (Nest k1 p) = mkNest (k + k1) p+mkNest _ NoPrinter = NoPrinter+mkNest _ Empty = Empty+mkNest 0 p = p+mkNest k p = nest_ k p++-- mkUnion checks for an empty printer+mkUnion :: Printer -> Printer -> Printer+mkUnion Empty _ = Empty+mkUnion p q = p `union_` q++beside_' :: Bool -> Printer -> Printer -> Printer+beside_' _ p Empty = p+beside_' g p q = Beside p g q++above_' :: Bool -> Printer -> Printer -> Printer+above_' _ p Empty = p+above_' g p q = Above p g q++reduceAB :: Printer -> Printer+reduceAB (Above Empty _ q) = q+reduceAB (Beside Empty _ q) = q+reduceAB doc = doc++nilAbove_ :: RPrinter a -> RPrinter a+nilAbove_ p = NilAbove p++-- Arg of a TextBeside is always an RPrinter+stringBeside_ :: TextDetails -> Int -> RPrinter a -> RPrinter a+stringBeside_ s sl p = TextBeside s sl p++nest_ :: Int -> RPrinter a -> RPrinter a+nest_ k p = Nest k p++union_ :: RPrinter a -> RPrinter a -> RPrinter a+union_ p q = Union p q+++-- ---------------------------------------------------------------------------+-- Vertical composition @</>@++-- | Above, except that if the last line of the first argument stops+-- at least one position before the first line of the second begins,+-- these two lines are overlapped. For example:+--+-- > string "hi" </> nest 5 (string "there")+--+-- lays out as+--+-- > hi there+--+-- rather than+--+-- > hi+-- > there+--+-- '</>' is associative, with identity 'empty', and also satisfies+--+-- * @(x '</>' y) '<>' z = x '</>' (y '<>' z)@, if @y@ non-empty.+--+(</>) :: Printer -> Printer -> Printer+p </> q = above_ p False q++-- | Above, with no overlapping.+-- '<//>' is associative, with identity 'empty'.+(<//>) :: Printer -> Printer -> Printer+p <//> q = above_ p True q++above_ :: Printer -> Bool -> Printer -> Printer+above_ p _ Empty = p+above_ Empty _ q = q+above_ p g q = Above p g q++above :: Printer -> Bool -> RPrinter a -> RPrinter a+above (Above p g1 q1) g2 q2 = above p g1 (above q1 g2 q2)+above p@(Beside _ _ _) g q = aboveNest (reducePrinter p) g 0 (reducePrinter q)+above p g q = aboveNest p g 0 (reducePrinter q)++aboveNest :: RPrinter a -> Bool -> Int -> RPrinter a -> RPrinter a+-- Specfication: aboveNest p g k q = p $g$ (nest k q)++aboveNest _ _ k _ | k `seq` False = undefined+aboveNest NoPrinter _ _ _ = NoPrinter+aboveNest (p1 `Union` p2) g k q = aboveNest p1 g k q `union_`+ aboveNest p2 g k q++aboveNest Empty _ k q = mkNest k q+aboveNest (Nest k1 p) g k q = nest_ k1 (aboveNest p g (k - k1) q)+ -- p can't be Empty, so no need for mkNest++aboveNest (NilAbove p) g k q = nilAbove_ (aboveNest p g k q)+aboveNest (TextBeside s sl p) g k q = stringBeside_ s sl rest+ where+ !k1 = k - sl+ rest = case p of+ Empty -> nilAboveNest g k1 q+ _ -> aboveNest p g k1 q+aboveNest (Above {}) _ _ _ = error "aboveNest Above"+aboveNest (Beside {}) _ _ _ = error "aboveNest Beside"++nilAboveNest :: Bool -> Int -> RPrinter a -> RPrinter a+-- Specification: string s <> nilaboveNest g k q+-- = string s <> (string "" $g$ nest k q)++nilAboveNest _ k _ | k `seq` False = undefined+nilAboveNest _ _ Empty = Empty+ -- Here's why the "string s <>" is in the spec!+nilAboveNest g k (Nest k1 q) = nilAboveNest g (k + k1) q++nilAboveNest g k q | not g && k > 0 -- No newline if no overlap+ = stringBeside_ (Str (indent k)) k q+ | otherwise -- Put them really above+ = nilAbove_ (mkNest k q)+++++++++-- ---------------------------------------------------------------------------+-- Horizontal composition @<>@++-- We intentionally avoid Data.Monoid.(<>) here due to interactions of+-- Data.Monoid.(<>) and (<+>). See+-- http://www.haskell.org/pipermail/libraries/2011-November/017066.html++-- | Beside.+-- '<>' is associative, with identity 'empty'.+(<->) :: Printer -> Printer -> Printer+p <-> q = beside_ p False q++-- | Beside, separated by space, unless one of the arguments is 'empty'.+-- '<+>' is associative, with identity 'empty'.+(<+>) :: Printer -> Printer -> Printer+p <+> q = beside_ p True q++beside_ :: Printer -> Bool -> Printer -> Printer+beside_ p _ Empty = p+beside_ Empty _ q = q+beside_ p g q = Beside p g q++beside :: Printer -> Bool -> RPrinter a -> RPrinter a+-- Specification: beside g p q = p <g> q++beside NoPrinter _ _ = NoPrinter+beside (p1 `Union` p2) g q = beside p1 g q `union_` beside p2 g q+beside Empty _ q = q+beside (Nest k p) g q = nest_ k $! beside p g q+beside p@(Beside p1 g1 q1) g2 q2+ | g1 == g2 = beside p1 g1 $! beside q1 g2 q2+ | otherwise = beside (reducePrinter p) g2 q2+beside p@(Above _ _ _) g q = let !d = reducePrinter p in beside d g q+beside (NilAbove p) g q = nilAbove_ $! beside p g q+beside (TextBeside s sl p) g q = stringBeside_ s sl $! rest+ where+ rest = case p of+ Empty -> nilBeside g q+ _ -> beside p g q++nilBeside :: Bool -> RPrinter a -> RPrinter a+-- Specification: string "" <> nilBeside g p+-- = string "" <g> p++nilBeside _ Empty = Empty -- Hence the string "" in the spec+nilBeside g (Nest _ p) = nilBeside g p+nilBeside g p | g = stringBeside_ space_string 1 p+ | otherwise = p++++++++-- ---------------------------------------------------------------------------+-- Separate, @sep@++-- Specification: sep ps = oneLiner (hsep ps)+-- `union`+-- vcat ps++-- | Either 'hsep' or 'vcat'.+sep :: [Printer] -> Printer+sep = sepX True -- Separate with spaces++-- | Either 'hcat' or 'vcat'.+cat :: [Printer] -> Printer+cat = sepX False -- Don't++sepX :: Bool -> [Printer] -> Printer+sepX _ [] = empty+sepX x (p:ps) = sep1 x (reducePrinter p) 0 ps+++-- Specification: sep1 g k ys = sep (x : map (nest k) ys)+-- = oneLiner (x <g> nest k (hsep ys))+-- `union` x </> nest k (vcat ys)++sep1 :: Bool -> RPrinter a -> Int -> [Printer] -> RPrinter a+sep1 _ _ k _ | k `seq` False = undefined+sep1 _ NoPrinter _ _ = NoPrinter+sep1 g (p `Union` q) k ys = sep1 g p k ys `union_`+ aboveNest q False k (reducePrinter (vcat ys))++sep1 g Empty k ys = mkNest k (sepX g ys)+sep1 g (Nest n p) k ys = nest_ n (sep1 g p (k - n) ys)++sep1 _ (NilAbove p) k ys = nilAbove_+ (aboveNest p False k (reducePrinter (vcat ys)))+sep1 g (TextBeside s sl p) k ys = stringBeside_ s sl (sepNB g p (k - sl) ys)+sep1 _ (Above {}) _ _ = error "sep1 Above"+sep1 _ (Beside {}) _ _ = error "sep1 Beside"++sepNB :: Bool -> Printer -> Int -> [Printer] -> Printer+-- Specification: sepNB p k ys = sep1 (string "" <> p) k ys+-- Called when we have already found some string in the first item+-- We have to eat up nests++sepNB g (Nest _ p) k ys+ = sepNB g p k ys -- Never triggered, because of invariant (2)+sepNB g Empty k ys+ = oneLiner (nilBeside g (reducePrinter rest)) `mkUnion`+-- XXX: PRETTY: Used True here+ nilAboveNest False k (reducePrinter (vcat ys))+ where+ rest | g = hsep ys+ | otherwise = hcat ys+sepNB g p k ys+ = sep1 g p k ys++++++++++-- ---------------------------------------------------------------------------+-- @fill@++-- | \"Paragraph fill\" version of 'cat'.+fcat :: [Printer] -> Printer+fcat = fill False++-- | \"Paragraph fill\" version of 'sep'.+fsep :: [Printer] -> Printer+fsep = fill True++-- Specification:+--+-- fill g docs = fillIndent 0 docs+--+-- fillIndent k [] = []+-- fillIndent k [p] = p+-- fillIndent k (p1:p2:ps) =+-- oneLiner p1 <g> fillIndent (k + length p1 + g ? 1 : 0)+-- (remove_nests (oneLiner p2) : ps)+-- `Union`+-- (p1 $*$ nest (-k) (fillIndent 0 ps))+--+-- $*$ is defined for layouts (not Printers) as+-- layout1 $*$ layout2 | hasMoreThanOneLine layout1 = layout1 </> layout2+-- | otherwise = layout1 <//> layout2++fill :: Bool -> [Printer] -> RPrinter a+fill _ [] = empty+fill g (p:ps) = fill1 g (reducePrinter p) 0 ps++fill1 :: Bool -> RPrinter a -> Int -> [Printer] -> Printer+fill1 _ _ k _ | k `seq` False = undefined+fill1 _ NoPrinter _ _ = NoPrinter+fill1 g (p `Union` q) k ys = fill1 g p k ys `union_`+ aboveNest q False k (fill g ys)+fill1 g Empty k ys = mkNest k (fill g ys)+fill1 g (Nest n p) k ys = nest_ n (fill1 g p (k - n) ys)+fill1 g (NilAbove p) k ys = nilAbove_ (aboveNest p False k (fill g ys))+fill1 g (TextBeside s sl p) k ys = stringBeside_ s sl (fillNB g p (k - sl) ys)+fill1 _ (Above {}) _ _ = error "fill1 Above"+fill1 _ (Beside {}) _ _ = error "fill1 Beside"++fillNB :: Bool -> Printer -> Int -> [Printer] -> Printer+fillNB _ _ k _ | k `seq` False = undefined+fillNB g (Nest _ p) k ys = fillNB g p k ys+ -- Never triggered, because of invariant (2)+fillNB _ Empty _ [] = Empty+fillNB g Empty k (Empty:ys) = fillNB g Empty k ys+fillNB g Empty k (y:ys) = fillNBE g k y ys+fillNB g p k ys = fill1 g p k ys+++fillNBE :: Bool -> Int -> Printer -> [Printer] -> Printer+fillNBE g k y ys+ = nilBeside g (fill1 g ((elideNest . oneLiner . reducePrinter) y) k' ys)+-- XXX: PRETTY: Used True here+ `mkUnion` nilAboveNest False k (fill g (y:ys))+ where k' = if g then k - 1 else k++elideNest :: Printer -> Printer+elideNest (Nest _ d) = d+elideNest d = d++++-- ---------------------------------------------------------------------------+-- Derived combinators++-- |+-- Join with separator.+--+-- > sepBy q [x1,x2..xn] = x1 <> q <> x2 <> q .. xn.+sepBy :: Printer -> [Printer] -> Printer++-- |+-- Join with initiator.+--+-- > initBy q [x1,x2..xn] = q <> x1 <> q <> x2 <> q .. xn.+initBy :: Printer -> [Printer] -> Printer++-- |+-- Join with terminator.+--+-- > termBy q [x1,x2..xn] = x1 <> q <> x2 <> q .. xn <> q.+termBy :: Printer -> [Printer] -> Printer+sepBy p = list empty $ \x -> (x <>) . initBy p+initBy p = hcat . map (p <>)+termBy p = hcat . map (<> p)+++-- |+-- Join with separator followed by space.+--+-- > sepByS q [x1,x2..xn] = x1 <> q <+> x2 <> q <+>.. xn.+sepByS :: Printer -> [Printer] -> Printer++-- |+-- Join with initiator followed by space.+--+-- > initByS q [x1,x2..xn] = q <+> x1 <> q <+> x2 <> q <+> .. xn.+initByS :: Printer -> [Printer] -> Printer++-- |+-- Join with terminator followed by space.+--+-- > termByS q [x1,x2..xn] = x1 <> q <+> x2 <> q <+> .. xn <> q.+termByS :: Printer -> [Printer] -> Printer+sepByS p = list empty $ \x -> (x <>) . initByS p+initByS p = hcat . map (p <+>)+termByS p = hsep . map (<> p)+++++++-- ---------------------------------------------------------------------------+-- Selecting the best layout++best :: Int -- Line length+ -> Int -- Ribbon length+ -> RPrinter a+ -> RPrinter a -- No unions in here!+best w0 r p0+ = get w0 p0+ where+ get w _ | w == 0 && False = undefined+ get _ Empty = Empty+ get _ NoPrinter = NoPrinter+ get w (NilAbove p) = nilAbove_ (get w p)+ get w (TextBeside s sl p) = stringBeside_ s sl (get1 w sl p)+ get w (Nest k p) = nest_ k (get (w - k) p)+ get w (p `Union` q) = nicest w r (get w p) (get w q)+ get _ (Above {}) = error "best get Above"+ get _ (Beside {}) = error "best get Beside"++ get1 w _ _ | w == 0 && False = undefined+ get1 _ _ Empty = Empty+ get1 _ _ NoPrinter = NoPrinter+ get1 w sl (NilAbove p) = nilAbove_ (get (w - sl) p)+ get1 w sl (TextBeside t tl p) = stringBeside_ t tl (get1 w (sl + tl) p)+ get1 w sl (Nest _ p) = get1 w sl p+ get1 w sl (p `Union` q) = nicest1 w r sl (get1 w sl p)+ (get1 w sl q)+ get1 _ _ (Above {}) = error "best get1 Above"+ get1 _ _ (Beside {}) = error "best get1 Beside"++nicest :: Int -> Int -> Printer -> Printer -> Printer+nicest !w !r p q = nicest1 w r 0 p q++nicest1 :: Int -> Int -> Int -> Printer -> Printer -> Printer+nicest1 !w !r !sl p q | fits ((w `min` r) - sl) p = p+ | otherwise = q++fits :: Int -- Space available+ -> Printer+ -> Bool -- True if *first line* of Printer fits in space available+fits n _ | n < 0 = False+fits _ NoPrinter = False+fits _ Empty = True+fits _ (NilAbove _) = True+fits n (TextBeside _ sl p) = fits (n - sl) p+fits _ (Above {}) = error "fits Above"+fits _ (Beside {}) = error "fits Beside"+fits _ (Union {}) = error "fits Union"+fits _ (Nest {}) = error "fits Nest"++-- | @first@ returns its first argument if it is non-empty, otherwise its second.+first :: Printer -> Printer -> Printer+first p q | nonEmptySet p = p -- unused, because (get OneLineMode) is unused+ | otherwise = q++nonEmptySet :: Printer -> Bool+nonEmptySet NoPrinter = False+nonEmptySet (_ `Union` _) = True+nonEmptySet Empty = True+nonEmptySet (NilAbove _) = True+nonEmptySet (TextBeside _ _ p) = nonEmptySet p+nonEmptySet (Nest _ p) = nonEmptySet p+nonEmptySet (Above {}) = error "nonEmptySet Above"+nonEmptySet (Beside {}) = error "nonEmptySet Beside"++-- @oneLiner@ returns the one-line members of the given set of @Printer@s.+oneLiner :: Printer -> Printer+oneLiner NoPrinter = NoPrinter+oneLiner Empty = Empty+oneLiner (NilAbove _) = NoPrinter+oneLiner (TextBeside s sl p) = stringBeside_ s sl (oneLiner p)+oneLiner (Nest k p) = nest_ k (oneLiner p)+oneLiner (p `Union` _) = oneLiner p+oneLiner (Above {}) = error "oneLiner Above"+oneLiner (Beside {}) = error "oneLiner Beside"++++++++++++++++-- ---------------------------------------------------------------------------+-- Rendering++-- | A printing style.+data Style+ = Style { mode :: Mode -- ^ The printing mode+ , lineLength :: Int -- ^ Length of line, in chars+ , ribbonsPerLine :: Float -- ^ Ratio of ribbon length to line length+ }++-- | The default style (@mode=PageMode, lineLength=100, ribbonsPerLine=1.5@).+style :: Style+style = Style { lineLength = 100, ribbonsPerLine = 1.5, mode = PageMode }++-- | Rendering mode.+data Mode = PageMode -- ^ Normal+ | ZigZagMode -- ^ With zig-zag cuts+ | LeftMode -- ^ No indentation, infinitely long lines+ | OneLineMode -- ^ All on one line++-- | Render the @Printer@ to a String using the default @Style@.+runPrinter :: Printer -> String+runPrinter doc = runPrinter' (mode style) (lineLength style) (ribbonsPerLine style)+ txtPrinter "" doc++-- | Render the @Printer@ to a String using the given @Style@.+runPrinterStyle :: Style -> Printer -> String+runPrinterStyle s doc = runPrinter' (mode s) (lineLength s) (ribbonsPerLine s)+ txtPrinter "" doc++-- | Default TextDetails printer+txtPrinter :: TextDetails -> String -> String+txtPrinter (Chr c) s = c:s+txtPrinter (Str s1) s2 = s1 ++ s2++-- | The general printing interface.+runPrinter' :: Mode -- ^ Rendering mode+ -> Int -- ^ Line length+ -> Float -- ^ Ribbons per line+ -> (TextDetails -> a -> a) -- ^ What to do with string+ -> a -- ^ What to do at the end+ -> Printer -- ^ The printer+ -> a -- ^ Result+runPrinter' OneLineMode _ _ txt end doc+ = easy_display space_string (\_ y -> y) txt end (reducePrinter doc)+runPrinter' LeftMode _ _ txt end doc+ = easy_display nl_string first txt end (reducePrinter doc)++runPrinter' m lineLen ribbons txt rest doc+ = display m lineLen ribbonLen txt rest doc'+ where+ doc' = best bestLineLen ribbonLen (reducePrinter doc)++ bestLineLen, ribbonLen :: Int+ ribbonLen = round (fromIntegral lineLen / ribbons)+ bestLineLen = case m of+ ZigZagMode -> maxBound+ _ -> lineLen++easy_display :: TextDetails+ -> (Printer -> Printer -> Printer)+ -> (TextDetails -> a -> a)+ -> a+ -> Printer+ -> a+easy_display nl_space_string choose txt end doc+ = lay doc+ where+ lay NoPrinter = error "easy_display: NoPrinter"+ lay (Union p q) = lay (choose p q)+ lay (Nest _ p) = lay p+ lay Empty = end+ lay (NilAbove p) = nl_space_string `txt` lay p+ lay (TextBeside s _ p) = s `txt` lay p+ lay (Above {}) = error "easy_display Above"+ lay (Beside {}) = error "easy_display Beside"++display :: Mode -> Int -> Int -> (TextDetails -> a -> a) -> a -> Printer -> a+display m !page_width !ribbon_width txt end doc+ = case page_width - ribbon_width of { gap_width ->+ case gap_width `quot` 2 of { shift ->+ let+ lay k _ | k `seq` False = undefined+ lay k (Nest k1 p) = lay (k + k1) p+ lay _ Empty = end+ lay k (NilAbove p) = nl_string `txt` lay k p+ lay k (TextBeside s sl p)+ = case m of+ ZigZagMode | k >= gap_width+ -> nl_string `txt` (+ Str (replicate shift '/') `txt` (+ nl_string `txt`+ lay1 (k - shift) s sl p ))++ | k < 0+ -> nl_string `txt` (+ Str (replicate shift '\\') `txt` (+ nl_string `txt`+ lay1 (k + shift) s sl p ))++ _ -> lay1 k s sl p+ lay _ (Above {}) = error "display lay Above"+ lay _ (Beside {}) = error "display lay Beside"+ lay _ NoPrinter = error "display lay NoPrinter"+ lay _ (Union {}) = error "display lay Union"++ lay1 !k s !sl p = let !r = k + sl+ in Str (indent k) `txt` (s `txt` lay2 r p)++ lay2 k _ | k `seq` False = undefined+ lay2 k (NilAbove p) = nl_string `txt` lay k p+ lay2 k (TextBeside s sl p) = s `txt` lay2 (k + sl) p+ lay2 k (Nest _ p) = lay2 k p+ lay2 _ Empty = end+ lay2 _ (Above {}) = error "display lay2 Above"+ lay2 _ (Beside {}) = error "display lay2 Beside"+ lay2 _ NoPrinter = error "display lay2 NoPrinter"+ lay2 _ (Union {}) = error "display lay2 Union"+ in+ lay 0 doc+ }}+