{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
#include "version-compatibility-macros.h"
module Data.Text.Prettyprint.Doc.Render.Terminal (
AnsiTerminal(..), Color(..), Intensity(..), Layer(..),
color, colorDull,
bgColor, bgColorDull,
bold, italics, underline,
renderLazy, renderStrict,
renderIO,
putDoc, hPutDoc,
) where
import Control.Monad
import Data.Functor
import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TLB
import qualified Data.Text.Lazy.IO as TL
import qualified System.Console.ANSI as ANSI
import System.IO (Handle, stdout)
import Data.Text.Prettyprint.Doc
import Data.Text.Prettyprint.Doc.Render.Util.Panic
import Data.Text.Prettyprint.Doc.Render.Util.StackMachine
#if !(APPLICATIVE_MONAD)
import Control.Applicative
#endif
data AnsiTerminal =
Italicized
| Bold
| Underlined
| Color Layer Intensity Color
deriving (Eq, Ord, Show)
data Color = Black | Red | Green | Yellow | Blue | Magenta | Cyan | White
deriving (Eq, Ord, Show)
data Intensity = Vivid | Dull
deriving (Eq, Ord, Show)
data Layer = Foreground | Background
deriving (Eq, Ord, Show)
color :: Color -> Doc AnsiTerminal -> Doc AnsiTerminal
color c = annotate (Color Foreground Vivid c)
bgColor :: Color -> Doc AnsiTerminal -> Doc AnsiTerminal
bgColor c = annotate (Color Background Vivid c)
colorDull :: Color -> Doc AnsiTerminal -> Doc AnsiTerminal
colorDull c = annotate (Color Foreground Dull c)
bgColorDull :: Color -> Doc AnsiTerminal -> Doc AnsiTerminal
bgColorDull c = annotate (Color Background Dull c)
bold :: Doc AnsiTerminal -> Doc AnsiTerminal
bold = annotate Bold
italics :: Doc AnsiTerminal -> Doc AnsiTerminal
italics = annotate Italicized
underline :: Doc AnsiTerminal -> Doc AnsiTerminal
underline = annotate Underlined
renderLazy :: SimpleDocStream AnsiTerminal -> TL.Text
renderLazy doc
= let (resultBuilder, remainingStyles) = execStackMachine [emptyStyle] (build doc)
in case remainingStyles of
[] -> error ("There is no empty style left at the end of rendering" ++
" (but there should be). Please report this as a bug.")
[_] -> TLB.toLazyText resultBuilder
xs -> error ("There are " <> show (length xs) <> " styles left at the" ++
"end of rendering (there should be only 1). Please report" ++
" this as a bug.")
build :: SimpleDocStream AnsiTerminal -> StackMachine TLB.Builder CombinedStyle ()
build = \case
SFail -> panicUncaughtFail
SEmpty -> pure ()
SChar c x -> do
writeOutput (TLB.singleton c)
build x
SText _l t x -> do
writeOutput (TLB.fromText t)
build x
SLine i x -> do
writeOutput (TLB.singleton '\n')
writeOutput (TLB.fromText (T.replicate i " "))
build x
SAnnPush s x -> do
currentStyle <- unsafePeekStyle
let newStyle = currentStyle `addStyle` s
writeOutput (styleToBuilder newStyle)
pushStyle newStyle
build x
SAnnPop x -> do
_currentStyle <- unsafePopStyle
newStyle <- unsafePeekStyle
writeOutput (styleToBuilder newStyle)
build x
styleToBuilder :: CombinedStyle -> TLB.Builder
styleToBuilder = TLB.fromString . ANSI.setSGRCode . stylesToSgrs
data CombinedStyle = CombinedStyle
(Maybe (Intensity, Color))
(Maybe (Intensity, Color))
Bool
Bool
Bool
addStyle :: CombinedStyle -> AnsiTerminal -> CombinedStyle
addStyle (CombinedStyle m'fg m'bg b i u) = \case
Italicized -> CombinedStyle m'fg m'bg b True u
Bold -> CombinedStyle m'fg m'bg True i u
Underlined -> CombinedStyle m'fg m'bg b i True
Color Foreground dv col -> CombinedStyle (Just (dv, col)) m'bg b i u
Color Background dv col -> CombinedStyle m'fg (Just (dv, col)) b i u
emptyStyle :: CombinedStyle
emptyStyle = CombinedStyle Nothing Nothing False False False
stylesToSgrs :: CombinedStyle -> [ANSI.SGR]
stylesToSgrs (CombinedStyle m'fg m'bg b i u) = catMaybes
[ Just ANSI.Reset
, fmap (\(intensity, c) -> ANSI.SetColor ANSI.Foreground (convertIntensity intensity) (convertColor c)) m'fg
, fmap (\(intensity, c) -> ANSI.SetColor ANSI.Background (convertIntensity intensity) (convertColor c)) m'bg
, guard b $> ANSI.SetConsoleIntensity ANSI.BoldIntensity
, guard i $> ANSI.SetItalicized True
, guard u $> ANSI.SetUnderlining ANSI.SingleUnderline
]
where
convertIntensity :: Intensity -> ANSI.ColorIntensity
convertIntensity = \case
Vivid -> ANSI.Vivid
Dull -> ANSI.Dull
convertColor :: Color -> ANSI.Color
convertColor = \case
Black -> ANSI.Black
Red -> ANSI.Red
Green -> ANSI.Green
Yellow -> ANSI.Yellow
Blue -> ANSI.Blue
Magenta -> ANSI.Magenta
Cyan -> ANSI.Cyan
White -> ANSI.White
renderStrict :: SimpleDocStream AnsiTerminal -> Text
renderStrict = TL.toStrict . renderLazy
renderIO :: Handle -> SimpleDocStream AnsiTerminal -> IO ()
renderIO h sdoc = TL.hPutStrLn h (renderLazy sdoc)
putDoc :: Doc AnsiTerminal -> IO ()
putDoc = hPutDoc stdout
hPutDoc :: Handle -> Doc AnsiTerminal -> IO ()
hPutDoc h doc = renderIO h (layoutPretty defaultLayoutOptions doc)