dynamic-pp-0.2.0: src/Text/Format.hs
-- Copyright (c) 2015 Eric McCorkle. All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
-- modification, are permitted provided that the following conditions
-- are met:
-- 1. Redistributions of source code must retain the above copyright
-- notice, this list of conditions and the following disclaimer.
-- 2. 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.
-- 3. Neither the name of the author nor the names of any contributors
-- may be used to endorse or promote products derived from this software
-- without specific prior written permission.
--
-- THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND 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 AUTHORS
-- OR 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.
{-# OPTIONS_GHC -Wall -Werror -funbox-strict-fields #-}
{-# LANGUAGE TypeSynonymInstances, FlexibleInstances,
MultiParamTypeClasses, UndecidableInstances #-}
-- | A pretty printer implementation, based loosely on the
-- Wadler-Leijin pretty printer, but redesigned to facilitate a
-- dynamic programming optimal layout algorithm.
--
-- This pretty printer module trades some of the generality of the
-- Wadler-Leijin scheme in order to facilitate an efficient optimizing
-- layout engine. The nesting, column, and width combinators are
-- removed.
module Text.Format(
-- * Basic Definitions
-- ** Types
Doc,
Graphics(..),
-- ** Type Classes
Format(..),
FormatM(..),
-- * Creating @Doc@s
-- ** Constructors
-- *** Basic
empty,
line,
linebreak,
hardline,
softline,
softbreak,
-- *** From datatypes
char,
string,
bytestring,
lazyBytestring,
-- *** Literals
lparen,
rparen,
lbrack,
rbrack,
lbrace,
rbrace,
langle,
rangle,
squote,
dquote,
backquote,
comma,
semi,
colon,
dot,
backslash,
equals,
space,
-- *** Derived
nest,
indent,
align,
squoted,
dquoted,
parens,
brackets,
braces,
angles,
list,
-- *** Graphics Mode
graphics,
dullWhite,
dullRed,
dullYellow,
dullGreen,
dullBlue,
dullCyan,
dullMagenta,
dullBlack,
vividWhite,
vividRed,
vividYellow,
vividGreen,
vividBlue,
vividCyan,
vividMagenta,
vividBlack,
dullWhiteBackground,
dullRedBackground,
dullYellowBackground,
dullGreenBackground,
dullBlueBackground,
dullCyanBackground,
dullMagentaBackground,
dullBlackBackground,
vividWhiteBackground,
vividRedBackground,
vividYellowBackground,
vividGreenBackground,
vividBlueBackground,
vividCyanBackground,
vividMagentaBackground,
vividBlackBackground,
-- ** Combining @Doc@s
-- *** Basic
beside,
concat,
choose,
-- *** Derived
(<>),
(<+>),
(<!>),
(<$>),
(<$$>),
(</>),
(<//>),
hsep,
hcat,
vsep,
vcat,
sep,
cat,
fillSep,
fillCat,
enclose,
punctuate,
encloseSep,
-- ** Transforming @Doc@s
flatten,
group,
-- * Rendering @Doc@s
renderOneLine,
buildOneLine,
putOneLine,
renderFast,
buildFast,
putFast,
renderOptimal,
buildOptimal,
putOptimal
) where
import Blaze.ByteString.Builder
import Blaze.ByteString.Builder.Char.Utf8
import Control.Arrow((***))
import Control.Monad
import Data.Hashable
import Data.HashSet(HashSet)
--import Data.HashMap.Strict(HashMap)
import Data.List(intersperse, minimumBy, sort)
import Data.Maybe
import Data.Monoid hiding ((<>))
import Data.Word
import Prelude hiding (concat)
import System.Console.ANSI
import System.IO
import qualified Data.ByteString as Strict
import qualified Data.ByteString.UTF8 as Strict.UTF8
import qualified Data.ByteString.Lazy as Lazy
import qualified Data.ByteString.Lazy.Char8 as Lazy.Char8
import qualified Data.ByteString.Lazy.UTF8 as Lazy.UTF8
--import qualified Data.HashMap.Strict as HashMap
import qualified Data.HashSet as HashSet
-- | Datatype representing a formatted document.
data LineKind =
-- | Unerasable linebreak
Hard
-- | Linebreak replaced with nothing
| Soft
-- | Linebreak replaced with a space
| Break
deriving (Ord, Eq, Enum)
-- Docs are organized into a tree structure whose nodes dictate the
-- formatting of the generated text. These are rendered by the
-- various rendering engines into a Builder (from the blaze-builder
-- library).
data Doc =
-- | A single character. Cannot be a newline.
Char { charContent :: !Char }
-- | A raw Builder that constructs a string containing no
-- newlines. This is used to represent basic text.
| Content {
-- | Length of the text that gets built.
contentLength :: !Int,
-- | A Builder that constructs the text.
contentString :: !Lazy.ByteString
}
-- | An erasable newline.
| Line {
-- | Whether to insert a space when undone by a group.
lineKind :: !LineKind
}
-- | Concatenated documents. An empty list here represents an empty @Doc@.
| Cat {
catDocs :: [Doc]
}
-- | Increase the nesting level of a document.
| Nest {
-- | Amount by which to increase nesting.
nestLevel :: !Int,
-- | Whether to align to the current column, or the base nesting
-- level.
nestAlign :: !Bool,
-- | Whether the indentation is delayed, or takes place immediately.
nestDelay :: !Bool,
-- | Document whose nesting should be increased.
nestDoc :: Doc
}
-- | Choose the \"best\" from among a list of options.
| Choose {
-- | The list of options.
chooseOptions :: HashSet Doc
}
-- | Set graphics mode options when rendering the child @Doc@.
| Graphics {
-- | Graphics mode to set.
graphicsSGR :: !Graphics,
-- | Document to render with graphic mode.
graphicsDoc :: Doc
}
deriving (Eq)
-- | Graphics options for ANSI terminals. All options are wrapped in
-- the 'Maybe' datatype, with 'Nothing' meaning \"leave this option
-- as-is\".
data Graphics =
-- | Set options on the terminal, or keep the current setting in
-- the case of 'Nothing'.
Options {
-- | Console intensity.
consoleIntensity :: !(Maybe ConsoleIntensity),
-- | Underlining.
underlining :: !(Maybe Underlining),
-- | Blinking speed.
blinkSpeed :: !(Maybe BlinkSpeed),
-- | Foreground color and intensity.
foreground :: !(Maybe (Color, ColorIntensity)),
-- | Background color and intensity.
background :: !(Maybe (Color, ColorIntensity)),
-- | Whether or not to swap the foreground and background.
swapForegroundBackground :: !(Maybe Bool)
}
-- | Reset the terminal in this mode.
| Default
deriving (Ord, Eq)
instance Ord Doc where
compare Char { charContent = c1 } Char { charContent = c2 } = compare c1 c2
compare Char {} _ = LT
compare _ Char {} = GT
compare Content { contentString = str1 } Content { contentString = str2 } =
compare str1 str2
compare Content {} _ = LT
compare _ Content {} = GT
compare Line { lineKind = kind1 } Line { lineKind = kind2 } =
compare kind1 kind2
compare Line {} _ = LT
compare _ Line {} = GT
compare Cat { catDocs = docs1 } Cat { catDocs = docs2 } = compare docs1 docs2
compare Cat {} _ = LT
compare _ Cat {} = GT
compare Nest { nestLevel = lvl1, nestAlign = al1,
nestDelay = delay1, nestDoc = doc1 }
Nest { nestLevel = lvl2, nestAlign = al2,
nestDelay = delay2, nestDoc = doc2 } =
case compare lvl1 lvl2 of
EQ -> case compare al1 al2 of
EQ -> case compare delay1 delay2 of
EQ -> compare doc1 doc2
out -> out
out -> out
out -> out
compare Nest {} _ = LT
compare _ Nest {} = GT
compare Choose { chooseOptions = opts1 } Choose { chooseOptions = opts2 } =
compare (sort (HashSet.toList opts1)) (sort (HashSet.toList opts2))
compare Choose {} _ = LT
compare _ Choose {} = GT
compare Graphics { graphicsSGR = sgr1, graphicsDoc = doc1 }
Graphics { graphicsSGR = sgr2, graphicsDoc = doc2 } =
case compare sgr1 sgr2 of
EQ -> compare doc1 doc2
out -> out
instance Hashable LineKind where
hashWithSalt s = hashWithSalt s . fromEnum
instance Hashable Doc where
hashWithSalt s Char { charContent = c } =
s `hashWithSalt` (0 :: Int) `hashWithSalt` c
hashWithSalt s Content { contentLength = len, contentString = str } =
s `hashWithSalt` (1 :: Int) `hashWithSalt` len `hashWithSalt` str
hashWithSalt s Line { lineKind = kind } =
s `hashWithSalt` (2 :: Int) `hashWithSalt` kind
hashWithSalt s Cat { catDocs = docs } =
s `hashWithSalt` (3 :: Int) `hashWithSalt` docs
hashWithSalt s Nest { nestLevel = lvl, nestAlign = al,
nestDelay = delay, nestDoc = doc } =
s `hashWithSalt` (4 :: Int) `hashWithSalt` lvl `hashWithSalt`
al `hashWithSalt` delay `hashWithSalt` doc
hashWithSalt s Choose { chooseOptions = opts } =
s `hashWithSalt` (5 :: Int) `hashWithSalt` sort (HashSet.toList opts)
hashWithSalt s Graphics { graphicsSGR = sgr, graphicsDoc = doc } =
s `hashWithSalt` (6 :: Int) `hashWithSalt` sgr `hashWithSalt` doc
instance Hashable Graphics where
hashWithSalt s Options { consoleIntensity = consIntensity,
swapForegroundBackground = swap,
underlining = underline,
foreground = fore,
background = back,
blinkSpeed = blink } =
s `hashWithSalt` (0 :: Int) `hashWithSalt`
fmap fromEnum consIntensity `hashWithSalt`
fmap fromEnum swap `hashWithSalt` fmap fromEnum underline `hashWithSalt`
fmap (fromEnum *** fromEnum) fore `hashWithSalt`
fmap (fromEnum *** fromEnum) back `hashWithSalt` fmap fromEnum blink
hashWithSalt s Default = s `hashWithSalt` (1 :: Int)
-- | Generate a 'Doc' representing a graphics mode switch.
switchGraphics :: Graphics -> Graphics -> Builder
switchGraphics _ Default = fromString (setSGRCode [Reset])
switchGraphics Default Options { consoleIntensity = consIntensity,
swapForegroundBackground = swap,
underlining = underline,
foreground = fore,
background = back,
blinkSpeed = blink } =
let
withConsIntensity = maybe [] ((: []) . SetConsoleIntensity) consIntensity
withUnderline = maybe withConsIntensity ((: withConsIntensity) .
SetUnderlining)
underline
withBlink = maybe withUnderline ((: withUnderline) . SetBlinkSpeed) blink
withSwap = maybe withBlink ((: withBlink) . SetSwapForegroundBackground)
swap
withForeground =
maybe withSwap (\(color, intensity) -> SetColor Foreground intensity
color : withSwap) fore
withBackground =
maybe withForeground (\(color, intensity) -> SetColor Background intensity
color : withForeground) back
in
fromString (setSGRCode withBackground)
switchGraphics Options { consoleIntensity = consIntensity1,
swapForegroundBackground = swap1,
underlining = underline1,
foreground = fore1,
background = back1,
blinkSpeed = blink1 }
Options { consoleIntensity = consIntensity2,
swapForegroundBackground = swap2,
underlining = underline2,
foreground = fore2,
background = back2,
blinkSpeed = blink2 } =
let
withConsIntensity =
if consIntensity1 /= consIntensity2
then maybe [] ((: []) . SetConsoleIntensity) consIntensity2
else []
withUnderline =
if underline1 /= underline2
then maybe withConsIntensity ((: withConsIntensity) . SetUnderlining)
underline2
else withConsIntensity
withBlink =
if blink1 /= blink2
then maybe withUnderline ((: withUnderline) . SetBlinkSpeed) blink2
else withUnderline
withSwap =
if swap1 /= swap2
then maybe withBlink ((: withBlink) . SetSwapForegroundBackground) swap2
else withBlink
withForeground =
if fore1 /= fore2
then maybe withSwap (\(color, intensity) ->
SetColor Foreground intensity color : withSwap)
fore2
else withSwap
withBackground =
if back1 /= back2
then maybe withSwap (\(color, intensity) ->
SetColor Background intensity color :
withForeground) back2
else withForeground
in
fromString (setSGRCode withBackground)
-- | An empty 'Doc'.
empty :: Doc
empty = Cat { catDocs = [] }
-- | A 'Doc' consisting of a linebreak, that is not turned into a
-- space when erased by a 'group'.
line :: Doc
line = Line { lineKind = Soft }
-- | A 'Doc' consisting of a linebreak, that is turned into a space
-- when erased by a 'group'.
linebreak :: Doc
linebreak = Line { lineKind = Break }
-- | A 'Doc' consisting of a linebreak that cannot be erased by a 'group'.
hardline :: Doc
hardline = Line { lineKind = Hard }
-- | A 'Doc' consisting of a space character, that can be turned into
-- a linebreak in order to break lines that are too long.
softline :: Doc
softline = Choose { chooseOptions = HashSet.fromList [ char ' ', linebreak ] }
-- | An empty 'Doc' that can be turned into a linebreak in order to
-- break lines that are too long.
softbreak :: Doc
softbreak = Choose { chooseOptions = HashSet.fromList [ empty, line ] }
-- | A 'Doc' containing a single character.
char :: Char -> Doc
char '\n' = line
char chr = Char { charContent = chr }
-- | Create a 'Doc' containing a string.
string :: String -> Doc
string str = Content { contentString = Lazy.UTF8.fromString str,
contentLength = length str }
-- | Create a 'Doc' containing a bytestring.
bytestring :: Strict.ByteString -> Doc
bytestring txt
| Strict.null txt = empty
| otherwise = Content { contentLength = Strict.UTF8.length txt,
contentString = Lazy.fromStrict txt }
-- | Create a 'Doc' containing a lazy bytestring
lazyBytestring :: Lazy.ByteString -> Doc
lazyBytestring txt
| Lazy.null txt = empty
| otherwise = Content { contentLength = Lazy.UTF8.length txt,
contentString = txt }
-- | The character @(@
lparen :: Doc
lparen = char '('
-- | The character @)@
rparen :: Doc
rparen = char ')'
-- | The character @[@
lbrack :: Doc
lbrack = char '['
-- | The character @]@
rbrack :: Doc
rbrack = char ']'
-- | The character @{@
lbrace :: Doc
lbrace = char '{'
-- | The character @}@
rbrace :: Doc
rbrace = char '}'
-- | The character @<@
langle :: Doc
langle = char '<'
-- | The character @>@
rangle :: Doc
rangle = char '>'
-- | The character @'@
squote :: Doc
squote = char '\''
-- | The character @"@
dquote :: Doc
dquote = char '"'
-- | The character @`@
backquote :: Doc
backquote = char '`'
-- | The character @,@
comma :: Doc
comma = char ','
-- | The character @;@
semi :: Doc
semi = char ';'
-- | The character @:@
colon :: Doc
colon = char ':'
-- | The character @.@
dot :: Doc
dot = char '.'
-- | The character @\\@
backslash :: Doc
backslash = char '\\'
-- | A space character.
space :: Doc
space = char ' '
-- | The character @=@
equals :: Doc
equals = char '='
-- | Increase the indentation level of a document by some amount.
nest :: Int -> Doc -> Doc
nest _ c @ Cat { catDocs = [] } = c
nest lvl n @ Nest { nestLevel = lvl' } = n { nestLevel = lvl + lvl' }
nest lvl doc = Nest { nestDelay = True, nestAlign = False,
nestLevel = lvl, nestDoc = doc }
-- | Increase the indentation level of a document by some amount.
indent :: Int -> Doc -> Doc
indent _ c @ Cat { catDocs = [] } = c
indent lvl n @ Nest { nestLevel = lvl' } = n { nestLevel = lvl + lvl' }
indent lvl doc = Nest { nestDelay = False, nestAlign = False,
nestLevel = lvl, nestDoc = doc }
-- | Set the indentation level to the current column.
align :: Doc -> Doc
align inner = Nest { nestDelay = True, nestAlign = True,
nestLevel = 0, nestDoc = inner }
-- | Enclose a 'Doc' in single quotes
squoted :: Doc -> Doc
squoted = enclose squote squote
-- | Enclose a 'Doc' in double quotes
dquoted :: Doc -> Doc
dquoted = enclose dquote dquote
-- | Enclose a 'Doc' in paretheses
parens :: Doc -> Doc
parens = enclose lparen rparen
-- | Enclose a 'Doc' in brackets
brackets :: Doc -> Doc
brackets = enclose lbrack rbrack
-- | Enclose a 'Doc' in braces
braces :: Doc -> Doc
braces = enclose lbrace rbrace
-- | Enclose a 'Doc' in angles
angles :: Doc -> Doc
angles = enclose langle rangle
-- | Set the graphics mode on a document.
graphics :: Graphics -> Doc -> Doc
graphics sgr doc = Graphics { graphicsDoc = doc, graphicsSGR = sgr }
-- | Color a 'Doc' dull white.
dullWhite :: Doc -> Doc
dullWhite = graphics Options { consoleIntensity = Nothing,
underlining = Nothing,
blinkSpeed = Nothing,
foreground = Just (White, Dull),
background = Nothing,
swapForegroundBackground = Nothing }
-- | Color a 'Doc' dull red.
dullRed :: Doc -> Doc
dullRed = graphics Options { consoleIntensity = Nothing,
underlining = Nothing,
blinkSpeed = Nothing,
foreground = Just (Red, Dull),
background = Nothing,
swapForegroundBackground = Nothing }
-- | Color a 'Doc' dull yellow.
dullYellow :: Doc -> Doc
dullYellow = graphics Options { consoleIntensity = Nothing,
underlining = Nothing,
blinkSpeed = Nothing,
foreground = Just (Yellow, Dull),
background = Nothing,
swapForegroundBackground = Nothing }
-- | Color a 'Doc' dull green.
dullGreen :: Doc -> Doc
dullGreen = graphics Options { consoleIntensity = Nothing,
underlining = Nothing,
blinkSpeed = Nothing,
foreground = Just (Green, Dull),
background = Nothing,
swapForegroundBackground = Nothing }
-- | Color a 'Doc' dull blue.
dullBlue :: Doc -> Doc
dullBlue = graphics Options { consoleIntensity = Nothing,
underlining = Nothing,
blinkSpeed = Nothing,
foreground = Just (Blue, Dull),
background = Nothing,
swapForegroundBackground = Nothing }
-- | Color a 'Doc' dull cyan.
dullCyan :: Doc -> Doc
dullCyan = graphics Options { consoleIntensity = Nothing,
underlining = Nothing,
blinkSpeed = Nothing,
foreground = Just (Cyan, Dull),
background = Nothing,
swapForegroundBackground = Nothing }
-- | Color a 'Doc' dull magenta.
dullMagenta :: Doc -> Doc
dullMagenta = graphics Options { consoleIntensity = Nothing,
underlining = Nothing,
blinkSpeed = Nothing,
foreground = Just (Magenta, Dull),
background = Nothing,
swapForegroundBackground = Nothing }
-- | Color a 'Doc' dull black.
dullBlack :: Doc -> Doc
dullBlack = graphics Options { consoleIntensity = Nothing,
underlining = Nothing,
blinkSpeed = Nothing,
foreground = Just (Black, Dull),
background = Nothing,
swapForegroundBackground = Nothing }
-- | Color a 'Doc' vivid white.
vividWhite :: Doc -> Doc
vividWhite = graphics Options { consoleIntensity = Nothing,
underlining = Nothing,
blinkSpeed = Nothing,
foreground = Just (White, Vivid),
background = Nothing,
swapForegroundBackground = Nothing }
-- | Color a 'Doc' vivid red.
vividRed :: Doc -> Doc
vividRed = graphics Options { consoleIntensity = Nothing,
underlining = Nothing,
blinkSpeed = Nothing,
foreground = Just (Red, Vivid),
background = Nothing,
swapForegroundBackground = Nothing }
-- | Color a 'Doc' vivid yellow.
vividYellow :: Doc -> Doc
vividYellow = graphics Options { consoleIntensity = Nothing,
underlining = Nothing,
blinkSpeed = Nothing,
foreground = Just (Yellow, Vivid),
background = Nothing,
swapForegroundBackground = Nothing }
-- | Color a 'Doc' vivid green.
vividGreen :: Doc -> Doc
vividGreen = graphics Options { consoleIntensity = Nothing,
underlining = Nothing,
blinkSpeed = Nothing,
foreground = Just (Green, Vivid),
background = Nothing,
swapForegroundBackground = Nothing }
-- | Color a 'Doc' vivid blue.
vividBlue :: Doc -> Doc
vividBlue = graphics Options { consoleIntensity = Nothing,
underlining = Nothing,
blinkSpeed = Nothing,
foreground = Just (Blue, Vivid),
background = Nothing,
swapForegroundBackground = Nothing }
-- | Color a 'Doc' vivid cyan.
vividCyan :: Doc -> Doc
vividCyan = graphics Options { consoleIntensity = Nothing,
underlining = Nothing,
blinkSpeed = Nothing,
foreground = Just (Cyan, Vivid),
background = Nothing,
swapForegroundBackground = Nothing }
-- | Color a 'Doc' vivid magenta.
vividMagenta :: Doc -> Doc
vividMagenta = graphics Options { consoleIntensity = Nothing,
underlining = Nothing,
blinkSpeed = Nothing,
foreground = Just (Magenta, Vivid),
background = Nothing,
swapForegroundBackground = Nothing }
-- | Color a 'Doc' vivid black.
vividBlack :: Doc -> Doc
vividBlack = graphics Options { consoleIntensity = Nothing,
underlining = Nothing,
blinkSpeed = Nothing,
foreground = Just (Black, Vivid),
background = Nothing,
swapForegroundBackground = Nothing }
-- | Color a 'Doc's background dull white.
dullWhiteBackground :: Doc -> Doc
dullWhiteBackground = graphics Options { consoleIntensity = Nothing,
underlining = Nothing,
blinkSpeed = Nothing,
background = Just (White, Dull),
foreground = Nothing,
swapForegroundBackground = Nothing }
-- | Color a 'Doc's background dull red.
dullRedBackground :: Doc -> Doc
dullRedBackground = graphics Options { consoleIntensity = Nothing,
underlining = Nothing,
blinkSpeed = Nothing,
background = Just (Red, Dull),
foreground = Nothing,
swapForegroundBackground = Nothing }
-- | Color a 'Doc's background dull yellow.
dullYellowBackground :: Doc -> Doc
dullYellowBackground = graphics Options { consoleIntensity = Nothing,
underlining = Nothing,
blinkSpeed = Nothing,
background = Just (Yellow, Dull),
foreground = Nothing,
swapForegroundBackground = Nothing }
-- | Color a 'Doc's background dull green.
dullGreenBackground :: Doc -> Doc
dullGreenBackground = graphics Options { consoleIntensity = Nothing,
underlining = Nothing,
blinkSpeed = Nothing,
background = Just (Green, Dull),
foreground = Nothing,
swapForegroundBackground = Nothing }
-- | Color a 'Doc's background dull blue.
dullBlueBackground :: Doc -> Doc
dullBlueBackground = graphics Options { consoleIntensity = Nothing,
underlining = Nothing,
blinkSpeed = Nothing,
background = Just (Blue, Dull),
foreground = Nothing,
swapForegroundBackground = Nothing }
-- | Color a 'Doc's background dull cyan.
dullCyanBackground :: Doc -> Doc
dullCyanBackground = graphics Options { consoleIntensity = Nothing,
underlining = Nothing,
blinkSpeed = Nothing,
background = Just (Cyan, Dull),
foreground = Nothing,
swapForegroundBackground = Nothing }
-- | Color a 'Doc's background dull magenta.
dullMagentaBackground :: Doc -> Doc
dullMagentaBackground = graphics Options { consoleIntensity = Nothing,
underlining = Nothing,
blinkSpeed = Nothing,
background = Just (Magenta, Dull),
foreground = Nothing,
swapForegroundBackground = Nothing }
-- | Color a 'Doc's background dull black.
dullBlackBackground :: Doc -> Doc
dullBlackBackground = graphics Options { consoleIntensity = Nothing,
underlining = Nothing,
blinkSpeed = Nothing,
background = Just (Black, Dull),
foreground = Nothing,
swapForegroundBackground = Nothing }
-- | Color a 'Doc's background vivid white.
vividWhiteBackground :: Doc -> Doc
vividWhiteBackground = graphics Options { consoleIntensity = Nothing,
underlining = Nothing,
blinkSpeed = Nothing,
background = Just (White, Vivid),
foreground = Nothing,
swapForegroundBackground = Nothing }
-- | Color a 'Doc's background vivid red.
vividRedBackground :: Doc -> Doc
vividRedBackground = graphics Options { consoleIntensity = Nothing,
underlining = Nothing,
blinkSpeed = Nothing,
background = Just (Red, Vivid),
foreground = Nothing,
swapForegroundBackground = Nothing }
-- | Color a 'Doc's background vivid yellow.
vividYellowBackground :: Doc -> Doc
vividYellowBackground = graphics Options { consoleIntensity = Nothing,
underlining = Nothing,
blinkSpeed = Nothing,
background = Just (Yellow, Vivid),
foreground = Nothing,
swapForegroundBackground = Nothing }
-- | Color a 'Doc's background vivid green.
vividGreenBackground :: Doc -> Doc
vividGreenBackground = graphics Options { consoleIntensity = Nothing,
underlining = Nothing,
blinkSpeed = Nothing,
background = Just (Green, Vivid),
foreground = Nothing,
swapForegroundBackground = Nothing }
-- | Color a 'Doc's background vivid blue.
vividBlueBackground :: Doc -> Doc
vividBlueBackground = graphics Options { consoleIntensity = Nothing,
underlining = Nothing,
blinkSpeed = Nothing,
background = Just (Blue, Vivid),
foreground = Nothing,
swapForegroundBackground = Nothing }
-- | Color a 'Doc's background vivid cyan.
vividCyanBackground :: Doc -> Doc
vividCyanBackground = graphics Options { consoleIntensity = Nothing,
underlining = Nothing,
blinkSpeed = Nothing,
background = Just (Cyan, Vivid),
foreground = Nothing,
swapForegroundBackground = Nothing }
-- | Color a 'Doc's background vivid magenta.
vividMagentaBackground :: Doc -> Doc
vividMagentaBackground = graphics Options { consoleIntensity = Nothing,
underlining = Nothing,
blinkSpeed = Nothing,
background = Just (Magenta, Vivid),
foreground = Nothing,
swapForegroundBackground = Nothing }
-- | Color a 'Doc's background vivid black.
vividBlackBackground :: Doc -> Doc
vividBlackBackground = graphics Options { consoleIntensity = Nothing,
underlining = Nothing,
blinkSpeed = Nothing,
background = Just (Black, Vivid),
foreground = Nothing,
swapForegroundBackground = Nothing }
-- | Join two 'Doc's with no space in between.
(<>) :: Doc -> Doc -> Doc
(<>) = beside
-- | Join two 'Doc's with a space in between them.
(<+>) :: Doc -> Doc -> Doc
left <+> right = left <> space <> right
-- | Join two 'Doc's with a 'hardline' in between them.
(<!>) :: Doc -> Doc -> Doc
left <!> right = left <> hardline <> right
-- | Join two 'Doc's with a 'line' in between them.
(<$>) :: Doc -> Doc -> Doc
left <$> right = left <> line <> right
-- | Join two 'Doc's with a 'linebreak' in between them.
(<$$>) :: Doc -> Doc -> Doc
left <$$> right = left <> linebreak <> right
-- | Join two 'Doc's with a 'softline' in between them.
(</>) :: Doc -> Doc -> Doc
left </> right = left <> softline <> right
-- | Join two 'Doc's with a 'softbreak' in between them.
(<//>) :: Doc -> Doc -> Doc
left <//> right = left <> softbreak <> right
-- | Joun 'Doc's with no space in between them.
beside :: Doc -> Doc -> Doc
beside Cat { catDocs = left } Cat { catDocs = right } =
Cat { catDocs = left ++ right }
beside left Cat { catDocs = right } = Cat { catDocs = left : right }
beside Cat { catDocs = left } right = Cat { catDocs = left ++ [right] }
beside left right = Cat { catDocs = [left, right] }
-- | Concatenate a list of 'Doc's. This is generally more efficient
-- than repeatedly using 'beside' or '<>'.
concat :: [Doc] -> Doc
concat docs = Cat { catDocs = docs }
-- | A choice of several options. Only one of these will be chosen
-- and used to render the final document.
choose :: [Doc] -> Doc
choose [] = empty
choose [doc] = doc
choose docs = Choose { chooseOptions = HashSet.fromList docs }
-- | Concatenate a list of 'Doc's. This is generally more efficient
-- than repeatedly using 'beside' or '<>'.
hcat :: [Doc] -> Doc
hcat docs = Cat { catDocs = docs }
-- | Join a list of 'Doc's with spaces in between each. This is
-- generally more efficient than repeatedly using '<+>'.
hsep :: [Doc] -> Doc
hsep = concat . intersperse space
-- | Join a list of 'Doc's with 'line's in between each. This is
-- generally more efficient than repeatedly using '<$$>'.
vsep :: [Doc] -> Doc
vsep = concat . intersperse line
-- | Join a list of 'Doc's with 'linebreak's in between each. This is
-- generally more efficient than repeatedly using '<$>'.
vcat :: [Doc] -> Doc
vcat = concat . intersperse linebreak
-- | Join a list of 'Doc's using either 'hsep' or 'vsep'.
sep :: [Doc] -> Doc
sep docs = Choose { chooseOptions = HashSet.fromList [hsep docs, vsep docs] }
-- | Join a list of 'Doc's using either 'hcat' or 'vcat'.
cat :: [Doc] -> Doc
cat docs = Choose { chooseOptions = HashSet.fromList [hcat docs, vcat docs] }
-- | Join a list of 'Doc's with 'softline's in between each. This is
-- generally more efficient than repeatedly using '</>'.
fillSep :: [Doc] -> Doc
fillSep = concat . intersperse softline
-- | Join a list of 'Doc's with 'softbreak's in between each. This is
-- generally more efficient than repeatedly using '<//>'.
fillCat :: [Doc] -> Doc
fillCat = concat . intersperse softbreak
-- | Enclose a 'Doc' within two other 'Doc's
enclose :: Doc -> Doc -> Doc -> Doc
enclose left right middle = hcat [left, middle, right]
-- | Concatenate a list of 'Doc's into a single doc, with each element
-- separated from the others by a given 'Doc' representing
-- punctuation.
punctuate :: Doc -> [Doc] -> [Doc]
punctuate punc (first : rest @ (_ : _)) = first <> punc : punctuate punc rest
punctuate _ doc = doc
-- | Enclose a list of 'Doc's, separated by punctuation, and align
-- nesting of the contents to the end of the left enclosing 'Doc'
encloseSep :: Doc -> Doc -> Doc -> [Doc] -> Doc
encloseSep left right _ [] = left <> right
encloseSep left right _ [doc] = left <> doc <> right
encloseSep left right middle docs =
left <> align (concat (punctuate middle docs)) <> right
-- | Render a list, enclosed in brackets and separated by commas.
list :: [Doc] -> Doc
list = group . encloseSep lbrack rbrack (comma <> line)
-- | Erase all linebreaks in a 'Doc' and replace them with either
-- spaces or nothing, depending on the kind of linebreak.
flatten :: Doc -> Maybe Doc
flatten Line { lineKind = Hard } = Nothing
flatten Line { lineKind = Break } = Just Char { charContent = ' ' }
flatten Line { lineKind = Soft } = Just empty
flatten Cat { catDocs = docs } =
case mapMaybe flatten docs of
[] -> Nothing
flatinner -> Just Cat { catDocs = flatinner }
flatten Choose { chooseOptions = docs } =
case mapMaybe flatten (HashSet.toList docs) of
[] -> Nothing
flatdocs -> Just Choose { chooseOptions = HashSet.fromList flatdocs }
flatten n @ Nest { nestDoc = inner } =
do
flatinner <- flatten inner
return n { nestDoc = flatinner }
flatten doc = Just doc
-- | A 'Doc' that 'choose's between the unmodified argument, or the
-- 'flatten'ed version of the argument.
group :: Doc -> Doc
group doc = case flatten doc of
Just flatdoc -> Choose { chooseOptions = HashSet.fromList [ doc, flatdoc ] }
Nothing -> doc
-- | Produce a 'Builder' that renders the 'Doc' to one line.
buildOneLine :: Doc -> Builder
buildOneLine Char { charContent = chr } = fromChar chr
buildOneLine Content { contentString = builder } = fromLazyByteString builder
buildOneLine Line { lineKind = Break } = fromChar ' '
buildOneLine Line { lineKind = Soft } = mempty
buildOneLine Line { lineKind = Hard } = fromChar '\n'
buildOneLine Cat { catDocs = docs } = mconcat (map buildOneLine docs)
buildOneLine Nest { nestDoc = inner } = buildOneLine inner
buildOneLine Choose { chooseOptions = opts } =
buildOneLine (head (HashSet.toList opts))
buildOneLine Graphics { graphicsDoc = inner } = buildOneLine inner
-- | Render the entire 'Doc' to one line. Good for output that
-- will be read only by a machine, where newlines are not important at all
renderOneLine :: Doc -> Lazy.ByteString
renderOneLine = toLazyByteString . buildOneLine
-- | Output the entire 'Doc', as rendered by 'renderOneLine' to the
-- given 'Handle'.
putOneLine :: Handle -> Doc -> IO ()
putOneLine handle =
toByteStringIO (Strict.hPut handle) . buildOneLine
-- | Produce a 'Builder' that renders the 'Doc' quickly.
buildFast :: Doc -> Builder
buildFast Char { charContent = chr } = fromChar chr
buildFast Content { contentString = builder } = fromLazyByteString builder
buildFast Line {} = fromChar '\n'
buildFast Cat { catDocs = docs } = mconcat (map buildFast docs)
buildFast Nest { nestDoc = inner } = buildFast inner
buildFast Choose { chooseOptions = opts } =
buildFast (head (HashSet.toList opts))
buildFast Graphics { graphicsDoc = inner } = buildFast inner
-- | Render the entire 'Doc', preserving newlines, but without any
-- indentation. Good for output that will be read only by machine,
-- but where newlines matter.
renderFast :: Doc -> Lazy.ByteString
renderFast = toLazyByteString . buildFast
-- | Output the entire 'Doc', as rendered by 'renderFast' to the
-- given 'Handle'.
putFast :: Handle -> Doc -> IO ()
putFast handle =
toByteStringIO (Strict.hPut handle) . buildFast
-- | Column data type. Represents how rendered documents affect the
-- current column.
-- Columns can be fixed, relative, or the maximum of the two. Fixed
-- means "this colucm exactly". Relative means "some starting point
-- plus this number".
data Column =
-- | An absolute column offset.
Fixed { fixedOffset :: !Int }
-- | A relative column offset.
| Relative { relOffset :: !Int }
-- | The greater of a relative column offset and an absolute
-- column offset.
| Maximum {
-- | This many columns offset from a relative point.
maxRelative :: !Int,
-- | But not less than this value.
maxFixed :: !Int
}
deriving Show
-- | The indentation mode.
data Indent =
-- | Indent starting with the zero column.
Full
-- | Indent starting with the current column.
| Partial
-- | No indent.
| None
deriving Show
instance Hashable Column where
hashWithSalt s Fixed { fixedOffset = n } =
s `hashWithSalt` (0 :: Int) `hashWithSalt` n
hashWithSalt s Relative { relOffset = n } =
s `hashWithSalt` (1 :: Int) `hashWithSalt` n
hashWithSalt s Maximum { maxFixed = fixed, maxRelative = rel } =
s `hashWithSalt` (2 :: Int) `hashWithSalt` fixed `hashWithSalt` rel
instance Ord Column where
compare Fixed { fixedOffset = n1 } Fixed { fixedOffset = n2 } = compare n1 n2
compare Fixed { fixedOffset = n }
Maximum { maxFixed = fixed, maxRelative = rel } =
case compare n fixed of
EQ -> case compare n rel of
EQ -> LT
out -> out
out -> out
compare Fixed { fixedOffset = n1 } Relative { relOffset = n2 } =
case compare n1 n2 of
EQ -> LT
out -> out
compare Maximum { maxFixed = fixed, maxRelative = rel }
Fixed { fixedOffset = n } =
case compare fixed n of
EQ -> case compare rel n of
EQ -> GT
out -> out
out -> out
compare Maximum { maxFixed = fixed1, maxRelative = rel1 }
Maximum { maxFixed = fixed2, maxRelative = rel2 } =
case compare fixed1 fixed2 of
EQ -> compare rel1 rel2
out -> out
compare Maximum { maxFixed = fixed, maxRelative = rel }
Relative { relOffset = n } =
case compare rel n of
EQ -> case compare fixed n of
EQ -> GT
out -> out
out -> out
compare Relative { relOffset = n1 } Fixed { fixedOffset = n2 } =
case compare n1 n2 of
EQ -> GT
out -> out
compare Relative { relOffset = n }
Maximum { maxFixed = fixed, maxRelative = rel } =
case compare n rel of
EQ -> case compare n fixed of
EQ -> LT
out -> out
out -> out
compare Relative { relOffset = n1 } Relative { relOffset = n2 } =
compare n1 n2
instance Eq Column where
c1 == c2 = compare c1 c2 == EQ
-- | Given a starting column and an ending column, give a column
-- representing the combination of the two.
advance :: Column -> Column -> Column
-- If the second column is fixed, it doesn't matter what the first is.
advance _ f @ Fixed {} = f
-- If the first is fixed and the second is relative, then advance the
-- first by the relative offset.
advance Fixed { fixedOffset = start } Relative { relOffset = n } =
Fixed { fixedOffset = start + n }
-- If the first is fixed and the second is a maximum, then we can
-- figure out which is the larger.
advance Fixed { fixedOffset = start }
Maximum { maxFixed = fixed, maxRelative = rel } =
Fixed { fixedOffset = max fixed (start + rel) }
-- If both are relative, just add them and make a new relative.
advance Relative { relOffset = start } Relative { relOffset = n } =
Relative { relOffset = start + n }
-- If we combine a relative and a maximum, then add the relative
-- offset to the relative portion of the maximum
advance Relative { relOffset = start } m @ Maximum { maxRelative = n } =
m { maxRelative = start + n }
advance m @ Maximum { maxRelative = rel } Relative { relOffset = n } =
m { maxRelative = rel + n }
-- If both are a maximum, then the resulting relative portion is the
-- sum of the two relative portions. The resulting fixed portion is
-- the greater of the second fixed portion, or the first fixed portion
-- plus the second relative portion.
advance Maximum { maxFixed = fixed1, maxRelative = rel1 }
Maximum { maxFixed = fixed2, maxRelative = rel2 } =
Maximum { maxFixed = max fixed2 (fixed1 + rel2), maxRelative = rel1 + rel2 }
-- | A rendering of a document.
-- Renderings store three basic things: A notion of the "badness" of
-- this particular rendering (represented by the overrun and the
-- number of lines), the indentation mode for the next document, and a
-- function that actually produces the Builder.
data Render =
Render {
-- | Upper-bound: Highest starting column for this document
-- without causing overrun. If this is negative, it means you've
-- overrun by that much.
renderUpper :: !Int,
-- | Ending column.
renderCol :: !Column,
-- | The number of lines in the document.
renderLines :: !Word,
-- | The largest amount by which we've overrun.
renderOverrun :: !Column,
-- | A builder that constructs the document.
renderBuilder :: !(Int -> Int -> Builder),
-- | Indentation mode for the next document.
renderIndent :: !Indent
}
-- | Determine whether the first 'Render' is strictly better than the second.
subsumes :: Render -> Render -> Bool
-- Simple comparisons: if the upper bound is greater, the lines are
-- less, and the column is less, then the render is always better.
subsumes Render { renderUpper = upper1, renderLines = lines1,
renderCol = Fixed { fixedOffset = col1 } }
Render { renderUpper = upper2, renderLines = lines2,
renderCol = Fixed { fixedOffset = col2 } } =
upper1 >= upper2 && lines1 <= lines2 && col1 <= col2
subsumes Render { renderUpper = upper1, renderLines = lines1,
renderCol = Relative { relOffset = col1 } }
Render { renderUpper = upper2, renderLines = lines2,
renderCol = Relative { relOffset = col2 } } =
upper1 >= upper2 && lines1 <= lines2 && col1 <= col2
-- A fixed column offset can subsume a relative offset
subsumes Render { renderUpper = upper1, renderLines = lines1,
renderCol = Fixed { fixedOffset = col1 } }
Render { renderUpper = upper2, renderLines = lines2,
renderCol = Relative { relOffset = col2 } } =
upper1 >= upper2 && lines1 <= lines2 && col1 <= col2
-- For two maximums, it's a straightaway comparison
subsumes Render { renderUpper = upper1, renderLines = lines1,
renderCol = Maximum { maxRelative = rel1,
maxFixed = fixed1 } }
Render { renderUpper = upper2, renderLines = lines2,
renderCol = Maximum { maxRelative = rel2,
maxFixed = fixed2 } } =
upper1 >= upper2 && lines1 <= lines2 && rel1 <= rel2 && fixed1 <= fixed2
-- Fixed can subsume a maximum as above
subsumes Render { renderUpper = upper1, renderLines = lines1,
renderCol = Fixed { fixedOffset = col1 } }
Render { renderUpper = upper2, renderLines = lines2,
renderCol = Maximum { maxRelative = rel2,
maxFixed = fixed2 } } =
upper1 >= upper2 && lines1 <= lines2 && col1 <= rel2 && col1 <= fixed2
subsumes _ _ = False
-- | A result. This is split into 'Single' and 'Multi' in order to
-- optimize for the common case of a single possible rendering.
-- Otherwise, it would be perfectly fine to represent everything as a
-- HashMap.
data Result =
-- | A single possible rendering.
Single {
-- | The rendered document.
singleRender :: !Render
}
-- | Multiple possible renderings.
| Multi {
-- | A multi-level map. The first map is indexed by the column
-- upper-bound (meaning the first column at which using any of
-- the contents will cause an overrun). The second map is
-- indexed by the ending column.
multiOptions :: ![Render]
}
-- | Generate n spaces
makespaces :: Int -> Builder
makespaces n = fromLazyByteString (Lazy.Char8.replicate (fromIntegral n) ' ')
-- Add a 'Render' into a result set, ensuring that any subsumed
-- renders are dropped.
--
-- TODO: The asymptotic runtime of this could likely be improved by some
-- kind of tree structure; however, the design of this structure is
-- nontrivial, due to the 3+-dimensional nature of subsumption, and
-- the wierd interactions between the various kinds of column offsets.
insertRender :: [Render] -> Render -> [Render]
insertRender renders ins
-- If the inserted element is subsumed by anything in the
-- list, then don't insert it at all.
| any (`subsumes` ins) renders = renders
-- Otherwise, add the element to the list, and drop everything it subsumes.
| otherwise = ins : filter (not . subsumes ins) renders
-- If a result only has one possibility, convert it to a Single.
-- Otherwise, leave it.
packResult :: [Render] -> Result
packResult [opt] = Single { singleRender = opt }
packResult opts = Multi { multiOptions = opts }
-- Pick the best result out of a set of results. Used at the end to
-- pick the final result.
bestRenderInOpts :: [Render] -> Render
bestRenderInOpts =
let
-- | Compare two Renders. Less than means better.
compareRenders Render { renderLines = lines1, renderOverrun = overrun1 }
Render { renderLines = lines2, renderOverrun = overrun2 } =
-- This is the same logic as bestRender
case compare overrun1 overrun2 of
EQ -> compare lines1 lines2
out -> out
in
minimumBy compareRenders
-- | Append operation on complete states. A complete state is the
-- contents of an Offset and a Render (ie. the contents of Single, or
-- the contents of an entry in a Multi combined with the corresponding
-- key).
appendOne :: Render -> Render -> Render
appendOne Render { renderUpper = upper1, renderLines = lines1, renderCol = col1,
renderOverrun = overrun1, renderBuilder = build1 }
Render { renderUpper = upper2, renderLines = lines2, renderCol = col2,
renderOverrun = overrun2, renderBuilder = build2,
renderIndent = ind } =
let
-- The new build is completely determined by the first render's
-- starting column.
newbuild = case col1 of
-- If the first ending column is fixed, then start the second
-- builder at that column.
Fixed { fixedOffset = n } ->
\nesting col -> build1 nesting col `mappend` build2 nesting n
-- If the first ending column is relative, then advance the
-- column by that much and start the second builder at that
-- column.
Relative { relOffset = n } ->
\nesting col -> build1 nesting col `mappend` (build2 nesting $! col + n)
-- If the ending column is a maximum
Maximum { maxRelative = rel, maxFixed = fixed } ->
\nesting col -> build1 nesting col `mappend`
build2 nesting (max fixed (col + rel))
-- The new upper-bound is determined by both ending columns.
--
-- IMPORTANT: In this logic, a negative upper-bound means you
-- overrun by that much. This is critical to the functioning of
-- this logic.
newupper = case (col1, col2) of
-- If the second column is fixed, then the upper-bound is the
-- minimum of the two upper-bounds.
(_, Fixed {}) -> min upper1 upper2
-- Otherwise, we decrement the second upper-bound and take the
-- minimum with the first.
(Fixed { fixedOffset = n }, _) -> min upper1 (upper2 - n)
(Relative { relOffset = n }, _) -> min upper1 (upper2 - n)
-- For maximum, take the minimum over the first upper-bound, the
-- second decremented by the fixed portion, and the second
-- decremented by the relative portion.
(Maximum { maxFixed = fixed, maxRelative = rel }, _) ->
min upper1 (min (upper2 - fixed) (upper2 - rel))
-- If the new upper bound is negative, the overrun is its absolute value
newoverrun =
if newupper < 0
then Relative { relOffset = abs newupper }
else Fixed { fixedOffset = 0 }
in
Render { renderBuilder = newbuild, renderIndent = ind,
renderLines = lines1 + lines2, renderUpper = newupper,
-- For the new overrun, take the max of the existing
-- overruns and newoverrun
renderOverrun = max (max overrun1 overrun2) newoverrun,
-- For the new column, use advance
renderCol = col1 `advance` col2 }
-- | Combine two results into a Multi. This achieves the same result
-- as HashMap.unionWith bestRender (meaning, union these maps,
-- combining using bestRender to pick when both maps have a given
-- index), but handles Singles as well.
mergeResults :: Result -> Result -> Result
-- Single is equivalent to a single-entry HashMap
mergeResults s1 @ Single { singleRender = r1 }
s2 @ Single { singleRender = r2 }
| subsumes r1 r2 = s1
| subsumes r2 r1 = s2
| otherwise = Multi { multiOptions = [r1, r2] }
mergeResults Single { singleRender = render }
Multi { multiOptions = opts } =
packResult (insertRender opts render)
-- This operation is commutative
mergeResults m @ Multi {} s @ Single {} = mergeResults s m
-- Otherwise it's a straightaway HashMap union
mergeResults Multi { multiOptions = opts1 } Multi { multiOptions = opts2 } =
packResult (foldl insertRender opts1 opts2)
-- Add indentation on to a builder. Note, this is used to create the
-- builder functions used in Render.
contentBuilder :: Indent -> Builder -> Int -> Int -> Builder
-- For full indentation, glue on the full indent
contentBuilder Full builder nesting _ =
makespaces nesting `mappend` builder
-- For partial indentation, bring us up to the current indent level
contentBuilder Partial builder nesting col =
if col < nesting
then makespaces (nesting - col) `mappend` builder
else builder
-- Otherwise, do nothing.
contentBuilder None builder _ _ = builder
-- | Produce a 'Builder' that renders the 'Doc' using the optimal
-- layout engine.
-- Basic algorithm overview: each Doc is rendering into a Result,
-- which has an upper-bound (the last column at which we can start
-- without causing an overrun), an ending column (which may be a
-- relative or fixed position), and the actual render, which has a
-- "badness". A negative upper-bound value indicates overrun.
--
-- We keep only ONE result for each upper-bound, start column pair
-- (ie. the best one). This forms the "frontier" for the dynamic
-- programming algorithm.
--
-- Note that due to the complexity of the combinators, we CAN see
-- cubic time/space complexity. However, actual running times are
-- much lower, especially for Docs that contain many hard linebreaks
-- and few Options.
buildOptimal :: Int
-- ^ The maximum number of columns.
-> Bool
-- ^ Whether or not to render with ANSI terminal options.
-> Doc
-- ^ The document to render.
-> Builder
buildOptimal maxcol ansiterm doc =
let
buildDynamic :: Graphics -> Column -> Indent -> Doc -> Result
-- For char, bytestring, and lazy bytestring,
buildDynamic _ _ ind Char { charContent = chr } =
let
-- Why would you have maxcol == 0? Who knows, but check for it.
overrun = if maxcol >= 1 then Relative 0 else Relative (maxcol - 1)
builder = contentBuilder ind (fromChar chr)
in
-- Single characters have a single possibility, a relative
-- ending position one beyond the start, and an upper-bound
-- one shorter than the maximum width.
Single { singleRender =
Render { renderOverrun = overrun, renderIndent = None,
renderBuilder = builder, renderCol = Relative 1,
renderLines = 0, renderUpper = maxcol - 1 } }
buildDynamic _ _ ind Content { contentString = txt, contentLength = len } =
let
-- Why would you have maxcol == 0? Who knows, but check for it.
overrun = if maxcol >= len then Relative 0 else Relative (len - maxcol)
builder = contentBuilder ind (fromLazyByteString txt)
in
-- Text has a single possibility and a relative ending position
-- equal to its length
Single { singleRender =
Render { renderLines = 0, renderUpper = maxcol - len,
renderBuilder = builder, renderCol = Relative len,
renderIndent = None, renderOverrun = overrun } }
buildDynamic _ nesting _ Line {} =
-- A newline starts at the nesting level, has no overrun, and an
-- upper-bound equal to the maximum column width.
--
-- Note: the upper bound is adjusted elsewhere.
Single {
singleRender = Render { renderOverrun = Fixed { fixedOffset = 0 },
renderIndent = Full, renderLines = 1,
renderBuilder = const $! const $!
fromChar '\n',
renderCol = nesting, renderUpper = maxcol } }
-- This is for an empty cat, ie. the empty document
buildDynamic _ _ ind Cat { catDocs = [] } =
-- The empty document has no content, no overrun, a relative end
-- position of 0, and an upper-bound of maxcol.
Single {
singleRender = Render { renderOverrun = Fixed 0, renderIndent = ind,
renderLines = 0, renderBuilder = const mempty,
renderCol = Relative 0, renderUpper = maxcol } }
buildDynamic sgr nesting ind Cat { catDocs = first : rest } =
let
-- Glue two Results together. This gets used in a fold.
appendResults :: Result -> Doc -> Result
-- The accumulated result is a Single.
appendResults Single { singleRender =
render1 @ Render { renderIndent = ind' } }
doc' =
-- Render the document.
case buildDynamic sgr nesting ind' doc' of
-- If there's a single result, it's easy; just use appendOne.
Single { singleRender = render2 } ->
let
newrender = appendOne render1 render2
in
Single { singleRender = newrender }
-- Otherwise, we have to fold over all the options and
-- glue on the accumulated result.
Multi { multiOptions = opts } ->
let
-- Level 2 fold function: glue the accumulated result
-- on to an option.
foldfun :: [Render] -> Render -> [Render]
foldfun accum = insertRender accum . appendOne render1
in
-- Fold it up, then use packResult.
packResult (foldl foldfun [] opts)
-- If the accumulate result is a multi, then we'll need to
-- glue the next render on to each option.
appendResults Multi { multiOptions = opts } doc' =
let
-- Outer fold, over each option in the accumulated result,
-- gluing on the next render.
outerfold :: [Render] -> Render -> [Render]
outerfold accum render1 @ Render { renderIndent = ind' } =
case buildDynamic sgr nesting ind' doc' of
-- If the render is a single result, then just glue it
-- on to the current option.
Single { singleRender = render2 } ->
insertRender accum (appendOne render1 render2)
-- If the render result is ALSO a Multi, then we need
-- to do another level of fold to glue those options
-- on to the current one.
Multi { multiOptions = opts2 } ->
let
-- Innermost fold, glues two options together
innerfold :: [Render] -> Render -> [Render]
innerfold accum' = insertRender accum' . appendOne render1
in
-- Don't bother calling packResult here, we'll do
-- it at the end anyway.
foldl innerfold accum opts2
in
-- Fold it up, then use packResult.
packResult (foldl outerfold [] opts)
-- Build the first item
firstres = buildDynamic sgr nesting ind first
in
-- Fold them all together with appendResults
foldl appendResults firstres rest
buildDynamic sgr nesting ind Nest { nestDelay = delay, nestDoc = inner,
nestAlign = alignnest,
nestLevel = lvl } =
let
-- Wrap up the render functions in code that alters the
-- nesting and column numbers.
updateRender =
if alignnest
-- If we're relative to the current column, then make the
-- new nesting equal to the current column, plus an
-- offset.
then \r @ Render { renderBuilder = builder } ->
r { renderBuilder = \_ c -> builder (c + lvl) c }
-- Otherwise, make it relative to the current nesting level.
else \r @ Render { renderBuilder = builder } ->
r { renderBuilder = \n c -> builder (n + lvl) c }
-- If we delay the indentation, don't alter the indent mode,
-- otherwise, set it.
newindent = if delay then ind else Partial
res =
if alignnest
-- If we're aligning to the current column, the nesting
-- becomes a relative offset.
then buildDynamic sgr (Relative lvl) newindent inner
-- Otherwise, we have to update the nesting level.
else
let
-- Basically, increment everything by the nesting level.
newnesting = case nesting of
Fixed { fixedOffset = n } -> Fixed { fixedOffset = n + lvl }
Relative { relOffset = n } -> Relative { relOffset = n + lvl }
Maximum { maxFixed = fixed, maxRelative = rel } ->
Maximum { maxFixed = fixed + lvl, maxRelative = rel + lvl }
in
buildDynamic sgr newnesting newindent inner
in case res of
-- Update the render for a Single.
s @ Single { singleRender = r } -> s { singleRender = updateRender r }
-- Update all renders for a Multi.
m @ Multi { multiOptions = opts } ->
m { multiOptions = map updateRender opts }
buildDynamic sgr nesting ind Choose { chooseOptions = options } =
let
-- Build up all the components
results = map (buildDynamic sgr nesting ind) (HashSet.toList options)
in
-- Now merge them into an minimal set of options
foldl1 mergeResults results
buildDynamic sgr1 nesting ind Graphics { graphicsSGR = sgr2,
graphicsDoc = inner }
-- Only do graphics if the ansiterm flag is set.
| ansiterm =
let
-- Insert graphics control characters without updating
-- column numbers, as they aren't visible.
wrapBuilder r @ Render { renderBuilder = build } =
r { renderBuilder = \n c -> switchGraphics sgr1 sgr2 `mappend`
build n c `mappend`
switchGraphics sgr2 sgr1 }
in case buildDynamic sgr2 nesting ind inner of
s @ Single { singleRender = render } ->
s { singleRender = wrapBuilder render }
m @ Multi { multiOptions = opts } ->
m { multiOptions = map wrapBuilder opts }
-- Otherwise, skip it entirely
| otherwise = buildDynamic sgr2 nesting ind inner
-- Call buildDynamic, get the result, then pick the best one.
Render { renderBuilder = result } =
case buildDynamic Default Fixed { fixedOffset = 0 } None doc of
Single { singleRender = render } -> render
Multi opts -> bestRenderInOpts opts
in
result 0 0
-- | Render a 'Doc' as a lazy bytestring using an optimal layout
-- rendering engine. The engine will render the document in the
-- fewest number of lines possible without exceeding the maximum
-- column width.
renderOptimal :: Int
-- ^ The maximum number of columns.
-> Bool
-- ^ Whether or not to render with ANSI terminal options.
-> Doc
-- ^ The document to render.
-> Lazy.ByteString
renderOptimal cols color = toLazyByteString . buildOptimal cols color
-- | Output the entire 'Doc', as rendered by 'renderOptimal' to the
-- given 'Handle'.
putOptimal :: Handle
-- ^ The 'Handle' to which to write output
-> Int
-- ^ The maximum number of columns.
-> Bool
-- ^ Whether or not to render with ANSI terminal options.
-> Doc
-- ^ The document to render.
-> IO ()
putOptimal handle cols color =
toByteStringIO (Strict.hPut handle) . buildOptimal cols color
-- | A class representing datatypes that can be formatted as 'Doc's.
class Format item where
-- | Format an @item@ as a 'Doc'
format :: item -> Doc
-- | Format a list of @item@s as a 'Doc'
formatList :: [item] -> Doc
formatList = list . map format
-- | A class representing datatypes that can be formatted as 'Doc's
-- inside a monad.
class Monad m => FormatM m item where
-- | Format an @item@ as a 'Doc' inside an @m@ monad
formatM :: item -> m Doc
-- | Format a list of @item@s as a 'Doc' inside an @m@ monad
formatListM :: [item] -> m Doc
formatListM = liftM list . mapM formatM
instance Format a => Format [a] where
format = formatList
instance Format Doc where
format = id
instance Format String where
format = string
instance Format Strict.ByteString where
format = bytestring
instance Format Lazy.ByteString where
format = lazyBytestring
instance Format Int where
format = string . show
instance Format Integer where
format = string . show
instance Format Word where
format = string . show
instance Format Float where
format = string . show
instance Format Double where
format = string . show