diff --git a/COPYING b/COPYING new file mode 100644 --- /dev/null +++ b/COPYING @@ -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. + +----------------------------------------------------------------------------- + + diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,4 @@ +#! /usr/bin/env runhaskell + +> import Distribution.Simple +> main = defaultMain diff --git a/prettify.cabal b/prettify.cabal new file mode 100644 --- /dev/null +++ b/prettify.cabal @@ -0,0 +1,30 @@ + +name: prettify +version: 1.0 +cabal-version: >= 1.6 +build-type: Simple +author: Hans Hoglund +maintainer: Hans Hoglund +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 + diff --git a/src/Text/Pretty.hs b/src/Text/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pretty.hs @@ -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 +-- 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 +~~~~~~~~~~~ + (x y) z = x (y z) + empty x = x + x empty = x + + ...ditto ... + +Laws for <> +~~~~~~~~~~~ + (x <> y) <> z = x <> (y <> z) + empty <> x = empty + x <> empty = x + + ...ditto <+>... + +Laws for string +~~~~~~~~~~~~~ + string s <> string t = string (s++t) + string "" <> x = x, if x non-empty + +** because of law n6, t2 only holds if x doesn't +** start with `nest'. + + +Laws for nest +~~~~~~~~~~~~~ + nest 0 x = x + nest k (nest k' x) = nest (k+k') x + nest k (x <> y) = nest k x <> 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 + +** Note the side condition on ! It is this that +** makes it OK for empty to be a left unit for <>. + +Miscellaneous +~~~~~~~~~~~~~ + (string s <> x) y = string s <> ((string "" <> x) + nest (-length s) y) + + (x y) <> z = x (y <> z) + if y non-empty + + +Laws for list versions +~~~~~~~~~~~~~~~~~~~~~~ + sep (ps++[empty]++qs) = sep (ps ++ qs) + ...ditto hsep, hcat, vcat, fill... + + nest k (sep ps) = sep (map (nest k) ps) + ...ditto hsep, hcat, vcat, fill... + +Laws for oneLiner +~~~~~~~~~~~~~~~~~ + oneLiner (nest k p) = nest k (oneLiner p) + oneLiner (x <> y) = oneLiner x <> oneLiner y + +You might think that the following verion of 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 (<> 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 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 "" 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 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 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 + }} +