module Text.Format(
Doc,
Graphics(..),
Format(..),
FormatM(..),
empty,
line,
linebreak,
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.Monad
import Data.Hashable
import Data.HashMap.Strict(HashMap)
import Data.List(intersperse, minimumBy)
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
data Doc =
Char { charContent :: !Char }
| Builder {
builderLength :: !Int,
builderContent :: !Builder
}
| Line {
insertSpace :: !Bool
}
| Cat {
catDocs :: [Doc]
}
| Nest {
nestLevel :: !Int,
nestAlign :: !Bool,
nestDelay :: !Bool,
nestDoc :: Doc
}
| Choose {
chooseOptions :: [Doc]
}
| Graphics {
graphicsSGR :: !Graphics,
graphicsDoc :: Doc
}
data Graphics =
Options {
consoleIntensity :: !(Maybe ConsoleIntensity),
underlining :: !(Maybe Underlining),
blinkSpeed :: !(Maybe BlinkSpeed),
foreground :: !(Maybe (Color, ColorIntensity)),
background :: !(Maybe (Color, ColorIntensity)),
swapForegroundBackground :: !(Maybe Bool)
}
| Default
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 { insertSpace = False }
linebreak :: Doc
linebreak = Line { insertSpace = True }
softline :: Doc
softline = Choose { chooseOptions = [ char ' ', linebreak ] }
softbreak :: Doc
softbreak = Choose { chooseOptions = [ empty, line ] }
char :: Char -> Doc
char '\n' = line
char chr = Char { charContent = chr }
string :: String -> Doc
string str = Builder { builderContent = fromString str,
builderLength = length str }
bytestring :: Strict.ByteString -> Doc
bytestring txt
| Strict.null txt = empty
| otherwise = Builder { builderLength = Strict.UTF8.length txt,
builderContent = fromByteString txt }
lazyBytestring :: Lazy.ByteString -> Doc
lazyBytestring txt
| Lazy.null txt = empty
| otherwise = Builder { builderLength = Lazy.UTF8.length txt,
builderContent = fromLazyByteString 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 <> 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 = 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 = [hsep docs, vsep docs] }
cat :: [Doc] -> Doc
cat docs = Choose { chooseOptions = [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 -> Doc
flatten Line { insertSpace = True } = Char { charContent = ' ' }
flatten Line { insertSpace = False } = empty
flatten Cat { catDocs = docs } = Cat { catDocs = map flatten docs }
flatten Choose { chooseOptions = docs } =
Choose { chooseOptions = map flatten docs }
flatten n @ Nest { nestDoc = inner } = n { nestDoc = flatten inner }
flatten doc = doc
group :: Doc -> Doc
group doc = Choose { chooseOptions = [ doc, flatten doc ] }
buildOneLine :: Doc -> Builder
buildOneLine Char { charContent = chr } = fromChar chr
buildOneLine Builder { builderContent = builder } = builder
buildOneLine Line { insertSpace = True } = fromChar ' '
buildOneLine Line { insertSpace = False } = mempty
buildOneLine Cat { catDocs = docs } = mconcat (map buildOneLine docs)
buildOneLine Nest { nestDoc = inner } = buildOneLine inner
buildOneLine Choose { chooseOptions = first : _ } = buildOneLine first
buildOneLine Choose {} = error "Choose with no options"
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 Builder { builderContent = builder } = builder
buildFast Line {} = fromChar '\n'
buildFast Cat { catDocs = docs } = mconcat (map buildFast docs)
buildFast Nest { nestDoc = inner } = buildFast inner
buildFast Choose { chooseOptions = first : _ } = buildFast first
buildFast Choose {} = error "Choose with no options"
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 Render =
Render {
renderLines :: !Word,
renderOverrun :: !Column,
renderBuilder :: !(Int -> Int -> Builder),
renderIndent :: !Indent
}
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 Offsets =
Offsets {
offsetUpper :: !Int,
offsetCol :: !Column
}
deriving Eq
instance Hashable Offsets where
hashWithSalt s Offsets { offsetUpper = upper, offsetCol = col } =
s `hashWithSalt` upper `hashWithSalt` col
data Result =
Single {
singleRender :: !Render,
singleUpper :: !Int,
singleCol :: !Column
}
| Multi {
multiOptions :: !(HashMap Offsets Render)
}
makespaces :: Int -> Builder
makespaces n = fromLazyByteString (Lazy.Char8.replicate (fromIntegral n) ' ')
bestRender :: Render -> Render -> Render
bestRender r1 @ Render { renderLines = lines1, renderOverrun = overrun1 }
r2 @ Render { renderLines = lines2, renderOverrun = overrun2 }
| overrun1 < overrun2 = r1
| overrun1 > overrun2 = r2
| otherwise = if lines1 < lines2 then r1 else r2
insertRender :: Int -> Column -> Render -> HashMap Offsets Render ->
HashMap Offsets Render
insertRender upper col render =
let
offsets = Offsets { offsetUpper = upper, offsetCol = col }
in
HashMap.insertWith bestRender offsets render
packResult :: HashMap Offsets Render -> Result
packResult opts =
case HashMap.toList opts of
[(Offsets { offsetUpper = upper, offsetCol = col }, render)] ->
Single { singleCol = col, singleUpper = upper, singleRender = render }
_ -> Multi { multiOptions = opts }
bestRenderInOpts :: HashMap Offsets 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 . HashMap.elems
appendOne :: (Int, Column, Render) -> (Int, Column, Render) ->
(Int, Column, Render)
appendOne (upper1, col1, Render { renderBuilder = build1,
renderLines = lines1,
renderOverrun = overrun1 })
(upper2, col2, Render { renderBuilder = build2,
renderLines = lines2,
renderOverrun = overrun2,
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
(newupper, col1 `advance` col2,
Render { renderBuilder = newbuild, renderIndent = ind,
renderOverrun = max (max overrun1 overrun2) newoverrun,
renderLines = lines1 + lines2 })
mergeResults :: Result -> Result -> Result
mergeResults s1 @ Single { singleRender =
r1 @ Render { renderOverrun = overrun1,
renderLines = lines1 },
singleUpper = upper1, singleCol = col1 }
s2 @ Single { singleRender =
r2 @ Render { renderOverrun = overrun2,
renderLines = lines2 },
singleUpper = upper2, singleCol = col2 }
| upper1 == upper2 && col1 == col2 =
if overrun1 < overrun2
then s1
else if overrun1 > overrun2
then s2
else if lines1 < lines2
then s1
else s2
| otherwise =
Multi { multiOptions =
HashMap.fromList [(Offsets { offsetUpper = upper1,
offsetCol = col1 },
r1),
(Offsets { offsetUpper = upper2,
offsetCol = col2 },
r2)] }
mergeResults Single { singleRender = render, singleUpper = upper,
singleCol = col }
Multi { multiOptions = opts } =
let
offsets = Offsets { offsetUpper = upper, offsetCol = col }
in
Multi { multiOptions = HashMap.insertWith bestRender offsets render opts }
mergeResults m @ Multi {} s @ Single {} = mergeResults s m
mergeResults Multi { multiOptions = opts1 } Multi { multiOptions = opts2 } =
Multi { multiOptions = HashMap.unionWith bestRender 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 { renderLines = 0, renderOverrun = overrun,
renderBuilder = builder, renderIndent = None },
singleCol = Relative 1, singleUpper = maxcol 1
}
buildDynamic _ _ ind Builder { builderContent = txt, builderLength = len } =
let
overrun = if maxcol >= len then Relative 0 else Relative (len maxcol)
builder = contentBuilder ind txt
in
Single {
singleRender = Render { renderLines = 0, renderOverrun = overrun,
renderBuilder = builder, renderIndent = None },
singleCol = Relative len, singleUpper = maxcol len
}
buildDynamic _ nesting _ Line {} =
Single {
singleRender = Render { renderOverrun = Fixed { fixedOffset = 0 },
renderIndent = Full, renderLines = 1,
renderBuilder = const $! const $!
fromChar '\n' },
singleCol = nesting, singleUpper = maxcol
}
buildDynamic _ _ ind Cat { catDocs = [] } =
Single {
singleRender = Render { renderOverrun = Fixed { fixedOffset = 0 },
renderIndent = ind, renderLines = 0,
renderBuilder = const mempty },
singleCol = Relative { relOffset = 0 }, singleUpper = maxcol
}
buildDynamic sgr nesting ind Cat { catDocs = first : rest } =
let
appendResults :: Result -> Doc -> Result
appendResults Single { singleRender =
render1 @ Render { renderIndent = ind' },
singleUpper = upper1, singleCol = col1 } doc' =
case buildDynamic sgr nesting ind' doc' of
Single { singleUpper = upper2, singleCol = col2,
singleRender = render2 } ->
let
(newupper, newcol, newrender) =
appendOne (upper1, col1, render1) (upper2, col2, render2)
in
Single { singleUpper = newupper, singleCol = newcol,
singleRender = newrender }
Multi { multiOptions = opts } ->
let
foldfun :: HashMap Offsets Render -> Offsets -> Render ->
HashMap Offsets Render
foldfun accum Offsets { offsetUpper = upper2,
offsetCol = col2 } render2 =
let
(newupper, newcol, newrender) =
appendOne (upper1, col1, render1) (upper2, col2, render2)
in
insertRender newupper newcol newrender accum
in
packResult (HashMap.foldlWithKey' foldfun HashMap.empty opts)
appendResults Multi { multiOptions = opts } doc' =
let
outerfold :: HashMap Offsets Render -> Offsets -> Render ->
HashMap Offsets Render
outerfold accum Offsets { offsetUpper = upper1,
offsetCol = col1 }
render1 @ Render { renderIndent = ind' } =
case buildDynamic sgr nesting ind' doc' of
Single { singleUpper = upper2, singleCol = col2,
singleRender = render2 } ->
let
(newupper, newcol, newrender) =
appendOne (upper1, col1, render1) (upper2, col2, render2)
in
insertRender newupper newcol newrender accum
Multi { multiOptions = opts2 } ->
let
innerfold :: HashMap Offsets Render -> Offsets -> Render ->
HashMap Offsets Render
innerfold accum' Offsets { offsetUpper = upper2,
offsetCol = col2 } render2 =
let
(newupper, newcol, newrender) =
appendOne (upper1, col1, render1)
(upper2, col2, render2)
in
insertRender newupper newcol newrender accum'
in
HashMap.foldlWithKey' innerfold accum opts2
in
packResult (HashMap.foldlWithKey' outerfold HashMap.empty 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 = HashMap.map updateRender opts }
buildDynamic sgr nesting ind Choose { chooseOptions = options } =
let
results = map (buildDynamic sgr nesting ind) 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 = HashMap.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