module Text.Format(
Doc,
Graphics(..),
Format(..),
FormatM(..),
empty,
line,
linebreak,
hardline,
softline,
softbreak,
char,
string,
bytestring,
lazyBytestring,
lparen,
rparen,
lbrack,
rbrack,
lbrace,
rbrace,
langle,
rangle,
squote,
dquote,
backquote,
comma,
semi,
colon,
dot,
backslash,
equals,
space,
nest,
indent,
align,
squoted,
dquoted,
parens,
brackets,
braces,
angles,
list,
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,
beside,
concat,
choose,
(<>),
(<+>),
(<!>),
(<$>),
(<$$>),
(</>),
(<//>),
hsep,
hcat,
vsep,
vcat,
sep,
cat,
fillSep,
fillCat,
enclose,
punctuate,
encloseSep,
flatten,
group,
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.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.HashSet as HashSet
data LineKind =
Hard
| Soft
| Break
deriving (Ord, Eq, Enum)
data Doc =
Char { charContent :: !Char }
| Content {
contentLength :: !Int,
contentString :: !Lazy.ByteString
}
| Line {
lineKind :: !LineKind
}
| Cat {
catDocs :: [Doc]
}
| Nest {
nestLevel :: !Int,
nestAlign :: !Bool,
nestDelay :: !Bool,
nestDoc :: Doc
}
| Choose {
chooseOptions :: HashSet Doc
}
| Graphics {
graphicsSGR :: !Graphics,
graphicsDoc :: Doc
}
deriving (Eq)
data Graphics =
Options {
consoleIntensity :: !(Maybe ConsoleIntensity),
underlining :: !(Maybe Underlining),
blinkSpeed :: !(Maybe BlinkSpeed),
foreground :: !(Maybe (Color, ColorIntensity)),
background :: !(Maybe (Color, ColorIntensity)),
swapForegroundBackground :: !(Maybe Bool)
}
| 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)
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)
empty :: Doc
empty = Cat { catDocs = [] }
line :: Doc
line = Line { lineKind = Soft }
linebreak :: Doc
linebreak = Line { lineKind = Break }
hardline :: Doc
hardline = Line { lineKind = Hard }
softline :: Doc
softline = Choose { chooseOptions = HashSet.fromList [ char ' ', linebreak ] }
softbreak :: Doc
softbreak = Choose { chooseOptions = HashSet.fromList [ empty, line ] }
char :: Char -> Doc
char '\n' = line
char chr = Char { charContent = chr }
string :: String -> Doc
string str = Content { contentString = Lazy.UTF8.fromString str,
contentLength = length str }
bytestring :: Strict.ByteString -> Doc
bytestring txt
| Strict.null txt = empty
| otherwise = Content { contentLength = Strict.UTF8.length txt,
contentString = Lazy.fromStrict txt }
lazyBytestring :: Lazy.ByteString -> Doc
lazyBytestring txt
| Lazy.null txt = empty
| otherwise = Content { contentLength = Lazy.UTF8.length txt,
contentString = txt }
lparen :: Doc
lparen = char '('
rparen :: Doc
rparen = char ')'
lbrack :: Doc
lbrack = char '['
rbrack :: Doc
rbrack = char ']'
lbrace :: Doc
lbrace = char '{'
rbrace :: Doc
rbrace = char '}'
langle :: Doc
langle = char '<'
rangle :: Doc
rangle = char '>'
squote :: Doc
squote = char '\''
dquote :: Doc
dquote = char '"'
backquote :: Doc
backquote = char '`'
comma :: Doc
comma = char ','
semi :: Doc
semi = char ';'
colon :: Doc
colon = char ':'
dot :: Doc
dot = char '.'
backslash :: Doc
backslash = char '\\'
space :: Doc
space = char ' '
equals :: Doc
equals = char '='
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 }
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 }
align :: Doc -> Doc
align inner = Nest { nestDelay = True, nestAlign = True,
nestLevel = 0, nestDoc = inner }
squoted :: Doc -> Doc
squoted = enclose squote squote
dquoted :: Doc -> Doc
dquoted = enclose dquote dquote
parens :: Doc -> Doc
parens = enclose lparen rparen
brackets :: Doc -> Doc
brackets = enclose lbrack rbrack
braces :: Doc -> Doc
braces = enclose lbrace rbrace
angles :: Doc -> Doc
angles = enclose langle rangle
graphics :: Graphics -> Doc -> Doc
graphics sgr doc = Graphics { graphicsDoc = doc, graphicsSGR = sgr }
dullWhite :: Doc -> Doc
dullWhite = graphics Options { consoleIntensity = Nothing,
underlining = Nothing,
blinkSpeed = Nothing,
foreground = Just (White, Dull),
background = Nothing,
swapForegroundBackground = Nothing }
dullRed :: Doc -> Doc
dullRed = graphics Options { consoleIntensity = Nothing,
underlining = Nothing,
blinkSpeed = Nothing,
foreground = Just (Red, Dull),
background = Nothing,
swapForegroundBackground = Nothing }
dullYellow :: Doc -> Doc
dullYellow = graphics Options { consoleIntensity = Nothing,
underlining = Nothing,
blinkSpeed = Nothing,
foreground = Just (Yellow, Dull),
background = Nothing,
swapForegroundBackground = Nothing }
dullGreen :: Doc -> Doc
dullGreen = graphics Options { consoleIntensity = Nothing,
underlining = Nothing,
blinkSpeed = Nothing,
foreground = Just (Green, Dull),
background = Nothing,
swapForegroundBackground = Nothing }
dullBlue :: Doc -> Doc
dullBlue = graphics Options { consoleIntensity = Nothing,
underlining = Nothing,
blinkSpeed = Nothing,
foreground = Just (Blue, Dull),
background = Nothing,
swapForegroundBackground = Nothing }
dullCyan :: Doc -> Doc
dullCyan = graphics Options { consoleIntensity = Nothing,
underlining = Nothing,
blinkSpeed = Nothing,
foreground = Just (Cyan, Dull),
background = Nothing,
swapForegroundBackground = Nothing }
dullMagenta :: Doc -> Doc
dullMagenta = graphics Options { consoleIntensity = Nothing,
underlining = Nothing,
blinkSpeed = Nothing,
foreground = Just (Magenta, Dull),
background = Nothing,
swapForegroundBackground = Nothing }
dullBlack :: Doc -> Doc
dullBlack = graphics Options { consoleIntensity = Nothing,
underlining = Nothing,
blinkSpeed = Nothing,
foreground = Just (Black, Dull),
background = Nothing,
swapForegroundBackground = Nothing }
vividWhite :: Doc -> Doc
vividWhite = graphics Options { consoleIntensity = Nothing,
underlining = Nothing,
blinkSpeed = Nothing,
foreground = Just (White, Vivid),
background = Nothing,
swapForegroundBackground = Nothing }
vividRed :: Doc -> Doc
vividRed = graphics Options { consoleIntensity = Nothing,
underlining = Nothing,
blinkSpeed = Nothing,
foreground = Just (Red, Vivid),
background = Nothing,
swapForegroundBackground = Nothing }
vividYellow :: Doc -> Doc
vividYellow = graphics Options { consoleIntensity = Nothing,
underlining = Nothing,
blinkSpeed = Nothing,
foreground = Just (Yellow, Vivid),
background = Nothing,
swapForegroundBackground = Nothing }
vividGreen :: Doc -> Doc
vividGreen = graphics Options { consoleIntensity = Nothing,
underlining = Nothing,
blinkSpeed = Nothing,
foreground = Just (Green, Vivid),
background = Nothing,
swapForegroundBackground = Nothing }
vividBlue :: Doc -> Doc
vividBlue = graphics Options { consoleIntensity = Nothing,
underlining = Nothing,
blinkSpeed = Nothing,
foreground = Just (Blue, Vivid),
background = Nothing,
swapForegroundBackground = Nothing }
vividCyan :: Doc -> Doc
vividCyan = graphics Options { consoleIntensity = Nothing,
underlining = Nothing,
blinkSpeed = Nothing,
foreground = Just (Cyan, Vivid),
background = Nothing,
swapForegroundBackground = Nothing }
vividMagenta :: Doc -> Doc
vividMagenta = graphics Options { consoleIntensity = Nothing,
underlining = Nothing,
blinkSpeed = Nothing,
foreground = Just (Magenta, Vivid),
background = Nothing,
swapForegroundBackground = Nothing }
vividBlack :: Doc -> Doc
vividBlack = graphics Options { consoleIntensity = Nothing,
underlining = Nothing,
blinkSpeed = Nothing,
foreground = Just (Black, Vivid),
background = Nothing,
swapForegroundBackground = Nothing }
dullWhiteBackground :: Doc -> Doc
dullWhiteBackground = graphics Options { consoleIntensity = Nothing,
underlining = Nothing,
blinkSpeed = Nothing,
background = Just (White, Dull),
foreground = Nothing,
swapForegroundBackground = Nothing }
dullRedBackground :: Doc -> Doc
dullRedBackground = graphics Options { consoleIntensity = Nothing,
underlining = Nothing,
blinkSpeed = Nothing,
background = Just (Red, Dull),
foreground = Nothing,
swapForegroundBackground = Nothing }
dullYellowBackground :: Doc -> Doc
dullYellowBackground = graphics Options { consoleIntensity = Nothing,
underlining = Nothing,
blinkSpeed = Nothing,
background = Just (Yellow, Dull),
foreground = Nothing,
swapForegroundBackground = Nothing }
dullGreenBackground :: Doc -> Doc
dullGreenBackground = graphics Options { consoleIntensity = Nothing,
underlining = Nothing,
blinkSpeed = Nothing,
background = Just (Green, Dull),
foreground = Nothing,
swapForegroundBackground = Nothing }
dullBlueBackground :: Doc -> Doc
dullBlueBackground = graphics Options { consoleIntensity = Nothing,
underlining = Nothing,
blinkSpeed = Nothing,
background = Just (Blue, Dull),
foreground = Nothing,
swapForegroundBackground = Nothing }
dullCyanBackground :: Doc -> Doc
dullCyanBackground = graphics Options { consoleIntensity = Nothing,
underlining = Nothing,
blinkSpeed = Nothing,
background = Just (Cyan, Dull),
foreground = Nothing,
swapForegroundBackground = Nothing }
dullMagentaBackground :: Doc -> Doc
dullMagentaBackground = graphics Options { consoleIntensity = Nothing,
underlining = Nothing,
blinkSpeed = Nothing,
background = Just (Magenta, Dull),
foreground = Nothing,
swapForegroundBackground = Nothing }
dullBlackBackground :: Doc -> Doc
dullBlackBackground = graphics Options { consoleIntensity = Nothing,
underlining = Nothing,
blinkSpeed = Nothing,
background = Just (Black, Dull),
foreground = Nothing,
swapForegroundBackground = Nothing }
vividWhiteBackground :: Doc -> Doc
vividWhiteBackground = graphics Options { consoleIntensity = Nothing,
underlining = Nothing,
blinkSpeed = Nothing,
background = Just (White, Vivid),
foreground = Nothing,
swapForegroundBackground = Nothing }
vividRedBackground :: Doc -> Doc
vividRedBackground = graphics Options { consoleIntensity = Nothing,
underlining = Nothing,
blinkSpeed = Nothing,
background = Just (Red, Vivid),
foreground = Nothing,
swapForegroundBackground = Nothing }
vividYellowBackground :: Doc -> Doc
vividYellowBackground = graphics Options { consoleIntensity = Nothing,
underlining = Nothing,
blinkSpeed = Nothing,
background = Just (Yellow, Vivid),
foreground = Nothing,
swapForegroundBackground = Nothing }
vividGreenBackground :: Doc -> Doc
vividGreenBackground = graphics Options { consoleIntensity = Nothing,
underlining = Nothing,
blinkSpeed = Nothing,
background = Just (Green, Vivid),
foreground = Nothing,
swapForegroundBackground = Nothing }
vividBlueBackground :: Doc -> Doc
vividBlueBackground = graphics Options { consoleIntensity = Nothing,
underlining = Nothing,
blinkSpeed = Nothing,
background = Just (Blue, Vivid),
foreground = Nothing,
swapForegroundBackground = Nothing }
vividCyanBackground :: Doc -> Doc
vividCyanBackground = graphics Options { consoleIntensity = Nothing,
underlining = Nothing,
blinkSpeed = Nothing,
background = Just (Cyan, Vivid),
foreground = Nothing,
swapForegroundBackground = Nothing }
vividMagentaBackground :: Doc -> Doc
vividMagentaBackground = graphics Options { consoleIntensity = Nothing,
underlining = Nothing,
blinkSpeed = Nothing,
background = Just (Magenta, Vivid),
foreground = Nothing,
swapForegroundBackground = Nothing }
vividBlackBackground :: Doc -> Doc
vividBlackBackground = graphics Options { consoleIntensity = Nothing,
underlining = Nothing,
blinkSpeed = Nothing,
background = Just (Black, Vivid),
foreground = Nothing,
swapForegroundBackground = Nothing }
(<>) :: Doc -> Doc -> Doc
(<>) = beside
(<+>) :: Doc -> Doc -> Doc
left <+> right = left <> space <> right
(<!>) :: Doc -> Doc -> Doc
left <!> right = left <> hardline <> right
(<$>) :: Doc -> Doc -> Doc
left <$> right = left <> line <> right
(<$$>) :: Doc -> Doc -> Doc
left <$$> right = left <> linebreak <> right
(</>) :: Doc -> Doc -> Doc
left </> right = left <> softline <> right
(<//>) :: Doc -> Doc -> Doc
left <//> right = left <> softbreak <> right
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] }
concat :: [Doc] -> Doc
concat docs = Cat { catDocs = docs }
choose :: [Doc] -> Doc
choose [] = empty
choose [doc] = doc
choose docs = Choose { chooseOptions = HashSet.fromList docs }
hcat :: [Doc] -> Doc
hcat docs = Cat { catDocs = docs }
hsep :: [Doc] -> Doc
hsep = concat . intersperse space
vsep :: [Doc] -> Doc
vsep = concat . intersperse line
vcat :: [Doc] -> Doc
vcat = concat . intersperse linebreak
sep :: [Doc] -> Doc
sep docs = Choose { chooseOptions = HashSet.fromList [hsep docs, vsep docs] }
cat :: [Doc] -> Doc
cat docs = Choose { chooseOptions = HashSet.fromList [hcat docs, vcat docs] }
fillSep :: [Doc] -> Doc
fillSep = concat . intersperse softline
fillCat :: [Doc] -> Doc
fillCat = concat . intersperse softbreak
enclose :: Doc -> Doc -> Doc -> Doc
enclose left right middle = hcat [left, middle, right]
punctuate :: Doc -> [Doc] -> [Doc]
punctuate punc (first : rest @ (_ : _)) = first <> punc : punctuate punc rest
punctuate _ doc = 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
list :: [Doc] -> Doc
list = group . encloseSep lbrack rbrack (comma <> line)
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
group :: Doc -> Doc
group doc = case flatten doc of
Just flatdoc -> Choose { chooseOptions = HashSet.fromList [ doc, flatdoc ] }
Nothing -> doc
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
renderOneLine :: Doc -> Lazy.ByteString
renderOneLine = toLazyByteString . buildOneLine
putOneLine :: Handle -> Doc -> IO ()
putOneLine handle =
toByteStringIO (Strict.hPut handle) . buildOneLine
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
renderFast :: Doc -> Lazy.ByteString
renderFast = toLazyByteString . buildFast
putFast :: Handle -> Doc -> IO ()
putFast handle =
toByteStringIO (Strict.hPut handle) . buildFast
data Column =
Fixed { fixedOffset :: !Int }
| Relative { relOffset :: !Int }
| Maximum {
maxRelative :: !Int,
maxFixed :: !Int
}
deriving Show
data Indent =
Full
| Partial
| 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
advance :: Column -> Column -> Column
advance _ f @ Fixed {} = f
advance Fixed { fixedOffset = start } Relative { relOffset = n } =
Fixed { fixedOffset = start + n }
advance Fixed { fixedOffset = start }
Maximum { maxFixed = fixed, maxRelative = rel } =
Fixed { fixedOffset = max fixed (start + rel) }
advance Relative { relOffset = start } Relative { relOffset = n } =
Relative { relOffset = start + n }
advance Relative { relOffset = start } m @ Maximum { maxRelative = n } =
m { maxRelative = start + n }
advance m @ Maximum { maxRelative = rel } Relative { relOffset = n } =
m { maxRelative = rel + n }
advance Maximum { maxFixed = fixed1, maxRelative = rel1 }
Maximum { maxFixed = fixed2, maxRelative = rel2 } =
Maximum { maxFixed = max fixed2 (fixed1 + rel2), maxRelative = rel1 + rel2 }
data Render =
Render {
renderUpper :: !Int,
renderCol :: !Column,
renderLines :: !Word,
renderOverrun :: !Column,
renderBuilder :: !(Int -> Int -> Builder),
renderIndent :: !Indent
}
subsumes :: Render -> Render -> Bool
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
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
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
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
data Result =
Single {
singleRender :: !Render
}
| Multi {
multiOptions :: ![Render]
}
makespaces :: Int -> Builder
makespaces n = fromLazyByteString (Lazy.Char8.replicate (fromIntegral n) ' ')
insertRender :: [Render] -> Render -> [Render]
insertRender renders ins
| any (`subsumes` ins) renders = renders
| otherwise = ins : filter (not . subsumes ins) renders
packResult :: [Render] -> Result
packResult [opt] = Single { singleRender = opt }
packResult opts = Multi { multiOptions = opts }
bestRenderInOpts :: [Render] -> Render
bestRenderInOpts =
let
compareRenders Render { renderLines = lines1, renderOverrun = overrun1 }
Render { renderLines = lines2, renderOverrun = overrun2 } =
case compare overrun1 overrun2 of
EQ -> compare lines1 lines2
out -> out
in
minimumBy compareRenders
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
newbuild = case col1 of
Fixed { fixedOffset = n } ->
\nesting col -> build1 nesting col `mappend` build2 nesting n
Relative { relOffset = n } ->
\nesting col -> build1 nesting col `mappend` (build2 nesting $! col + n)
Maximum { maxRelative = rel, maxFixed = fixed } ->
\nesting col -> build1 nesting col `mappend`
build2 nesting (max fixed (col + rel))
newupper = case (col1, col2) of
(_, Fixed {}) -> min upper1 upper2
(Fixed { fixedOffset = n }, _) -> min upper1 (upper2 n)
(Relative { relOffset = n }, _) -> min upper1 (upper2 n)
(Maximum { maxFixed = fixed, maxRelative = rel }, _) ->
min upper1 (min (upper2 fixed) (upper2 rel))
newoverrun =
if newupper < 0
then Relative { relOffset = abs newupper }
else Fixed { fixedOffset = 0 }
in
Render { renderBuilder = newbuild, renderIndent = ind,
renderLines = lines1 + lines2, renderUpper = newupper,
renderOverrun = max (max overrun1 overrun2) newoverrun,
renderCol = col1 `advance` col2 }
mergeResults :: Result -> Result -> Result
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)
mergeResults m @ Multi {} s @ Single {} = mergeResults s m
mergeResults Multi { multiOptions = opts1 } Multi { multiOptions = opts2 } =
packResult (foldl insertRender opts1 opts2)
contentBuilder :: Indent -> Builder -> Int -> Int -> Builder
contentBuilder Full builder nesting _ =
makespaces nesting `mappend` builder
contentBuilder Partial builder nesting col =
if col < nesting
then makespaces (nesting col) `mappend` builder
else builder
contentBuilder None builder _ _ = builder
buildOptimal :: Int
-> Bool
-> Doc
-> Builder
buildOptimal maxcol ansiterm doc =
let
buildDynamic :: Graphics -> Column -> Indent -> Doc -> Result
buildDynamic _ _ ind Char { charContent = chr } =
let
overrun = if maxcol >= 1 then Relative 0 else Relative (maxcol 1)
builder = contentBuilder ind (fromChar chr)
in
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
overrun = if maxcol >= len then Relative 0 else Relative (len maxcol)
builder = contentBuilder ind (fromLazyByteString txt)
in
Single { singleRender =
Render { renderLines = 0, renderUpper = maxcol len,
renderBuilder = builder, renderCol = Relative len,
renderIndent = None, renderOverrun = overrun } }
buildDynamic _ nesting _ Line {} =
Single {
singleRender = Render { renderOverrun = Fixed { fixedOffset = 0 },
renderIndent = Full, renderLines = 1,
renderBuilder = const $! const $!
fromChar '\n',
renderCol = nesting, renderUpper = maxcol } }
buildDynamic _ _ ind Cat { catDocs = [] } =
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
appendResults :: Result -> Doc -> Result
appendResults Single { singleRender =
render1 @ Render { renderIndent = ind' } }
doc' =
case buildDynamic sgr nesting ind' doc' of
Single { singleRender = render2 } ->
let
newrender = appendOne render1 render2
in
Single { singleRender = newrender }
Multi { multiOptions = opts } ->
let
foldfun :: [Render] -> Render -> [Render]
foldfun accum = insertRender accum . appendOne render1
in
packResult (foldl foldfun [] opts)
appendResults Multi { multiOptions = opts } doc' =
let
outerfold :: [Render] -> Render -> [Render]
outerfold accum render1 @ Render { renderIndent = ind' } =
case buildDynamic sgr nesting ind' doc' of
Single { singleRender = render2 } ->
insertRender accum (appendOne render1 render2)
Multi { multiOptions = opts2 } ->
let
innerfold :: [Render] -> Render -> [Render]
innerfold accum' = insertRender accum' . appendOne render1
in
foldl innerfold accum opts2
in
packResult (foldl outerfold [] opts)
firstres = buildDynamic sgr nesting ind first
in
foldl appendResults firstres rest
buildDynamic sgr nesting ind Nest { nestDelay = delay, nestDoc = inner,
nestAlign = alignnest,
nestLevel = lvl } =
let
updateRender =
if alignnest
then \r @ Render { renderBuilder = builder } ->
r { renderBuilder = \_ c -> builder (c + lvl) c }
else \r @ Render { renderBuilder = builder } ->
r { renderBuilder = \n c -> builder (n + lvl) c }
newindent = if delay then ind else Partial
res =
if alignnest
then buildDynamic sgr (Relative lvl) newindent inner
else
let
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
s @ Single { singleRender = r } -> s { singleRender = updateRender r }
m @ Multi { multiOptions = opts } ->
m { multiOptions = map updateRender opts }
buildDynamic sgr nesting ind Choose { chooseOptions = options } =
let
results = map (buildDynamic sgr nesting ind) (HashSet.toList options)
in
foldl1 mergeResults results
buildDynamic sgr1 nesting ind Graphics { graphicsSGR = sgr2,
graphicsDoc = inner }
| ansiterm =
let
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 = buildDynamic sgr2 nesting ind inner
Render { renderBuilder = result } =
case buildDynamic Default Fixed { fixedOffset = 0 } None doc of
Single { singleRender = render } -> render
Multi opts -> bestRenderInOpts opts
in
result 0 0
renderOptimal :: Int
-> Bool
-> Doc
-> Lazy.ByteString
renderOptimal cols color = toLazyByteString . buildOptimal cols color
putOptimal :: Handle
-> Int
-> Bool
-> Doc
-> IO ()
putOptimal handle cols color =
toByteStringIO (Strict.hPut handle) . buildOptimal cols color
class Format item where
format :: item -> Doc
formatList :: [item] -> Doc
formatList = list . map format
class Monad m => FormatM m item where
formatM :: item -> m Doc
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