{-# LANGUAGE CPP               #-}
{-# LANGUAGE OverloadedStrings #-}

{-# OPTIONS_HADDOCK not-home #-}

#include "version-compatibility-macros.h"

-- | __Warning:__ Internal module. May change arbitrarily between versions.
module Prettyprinter.Render.Terminal.Internal (
    -- * Styling
    AnsiStyle(..),
    Color(..),

    -- ** Font color
    color, colorDull,

    -- ** Background color
    bgColor, bgColorDull,

    -- ** Font style
    bold, italicized, underlined,

    -- ** Internal markers
    Intensity(..),
    Bold(..),
    Underlined(..),
    Italicized(..),

    -- * Conversion to ANSI-infused 'Text'
    renderLazy, renderStrict,

    -- * Render directly to 'stdout'
    renderIO,

    -- ** Convenience functions
    putDoc, hPutDoc,
) where



import           Control.Applicative
import           Data.IORef
import           Data.Maybe
import           Data.Text              (Text)
import qualified Data.Text              as T
import qualified Data.Text.IO           as T
import qualified Data.Text.Lazy         as TL
import qualified Data.Text.Lazy.Builder as TLB
import qualified System.Console.ANSI    as ANSI
import           System.IO              (Handle, hPutChar, stdout)

import Prettyprinter
import Prettyprinter.Render.Util.Panic

#if !(SEMIGROUP_MONOID_SUPERCLASS)
import Data.Semigroup
#endif

#if !(MIN_VERSION_base(4,6,0))
modifyIORef' :: IORef a -> (a -> a) -> IO ()
modifyIORef' ref f = do
    x <- readIORef ref
    let x' = f x
    x' `seq` writeIORef ref x'
#endif

-- $setup
--
-- (Definitions for the doctests)
--
-- >>> :set -XOverloadedStrings
-- >>> import qualified Data.Text.Lazy.IO as TL
-- >>> import qualified Data.Text.Lazy as TL
-- >>> import Prettyprinter.Render.Terminal



-- | The 8 ANSI terminal colors.
data Color = Black | Red | Green | Yellow | Blue | Magenta | Cyan | White
    deriving (Color -> Color -> Bool
(Color -> Color -> Bool) -> (Color -> Color -> Bool) -> Eq Color
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Color -> Color -> Bool
$c/= :: Color -> Color -> Bool
== :: Color -> Color -> Bool
$c== :: Color -> Color -> Bool
Eq, Eq Color
Eq Color
-> (Color -> Color -> Ordering)
-> (Color -> Color -> Bool)
-> (Color -> Color -> Bool)
-> (Color -> Color -> Bool)
-> (Color -> Color -> Bool)
-> (Color -> Color -> Color)
-> (Color -> Color -> Color)
-> Ord Color
Color -> Color -> Bool
Color -> Color -> Ordering
Color -> Color -> Color
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Color -> Color -> Color
$cmin :: Color -> Color -> Color
max :: Color -> Color -> Color
$cmax :: Color -> Color -> Color
>= :: Color -> Color -> Bool
$c>= :: Color -> Color -> Bool
> :: Color -> Color -> Bool
$c> :: Color -> Color -> Bool
<= :: Color -> Color -> Bool
$c<= :: Color -> Color -> Bool
< :: Color -> Color -> Bool
$c< :: Color -> Color -> Bool
compare :: Color -> Color -> Ordering
$ccompare :: Color -> Color -> Ordering
$cp1Ord :: Eq Color
Ord, Int -> Color -> ShowS
[Color] -> ShowS
Color -> String
(Int -> Color -> ShowS)
-> (Color -> String) -> ([Color] -> ShowS) -> Show Color
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Color] -> ShowS
$cshowList :: [Color] -> ShowS
show :: Color -> String
$cshow :: Color -> String
showsPrec :: Int -> Color -> ShowS
$cshowsPrec :: Int -> Color -> ShowS
Show)

-- | Dull or vivid coloring, as supported by ANSI terminals.
data Intensity = Vivid | Dull
    deriving (Intensity -> Intensity -> Bool
(Intensity -> Intensity -> Bool)
-> (Intensity -> Intensity -> Bool) -> Eq Intensity
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Intensity -> Intensity -> Bool
$c/= :: Intensity -> Intensity -> Bool
== :: Intensity -> Intensity -> Bool
$c== :: Intensity -> Intensity -> Bool
Eq, Eq Intensity
Eq Intensity
-> (Intensity -> Intensity -> Ordering)
-> (Intensity -> Intensity -> Bool)
-> (Intensity -> Intensity -> Bool)
-> (Intensity -> Intensity -> Bool)
-> (Intensity -> Intensity -> Bool)
-> (Intensity -> Intensity -> Intensity)
-> (Intensity -> Intensity -> Intensity)
-> Ord Intensity
Intensity -> Intensity -> Bool
Intensity -> Intensity -> Ordering
Intensity -> Intensity -> Intensity
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Intensity -> Intensity -> Intensity
$cmin :: Intensity -> Intensity -> Intensity
max :: Intensity -> Intensity -> Intensity
$cmax :: Intensity -> Intensity -> Intensity
>= :: Intensity -> Intensity -> Bool
$c>= :: Intensity -> Intensity -> Bool
> :: Intensity -> Intensity -> Bool
$c> :: Intensity -> Intensity -> Bool
<= :: Intensity -> Intensity -> Bool
$c<= :: Intensity -> Intensity -> Bool
< :: Intensity -> Intensity -> Bool
$c< :: Intensity -> Intensity -> Bool
compare :: Intensity -> Intensity -> Ordering
$ccompare :: Intensity -> Intensity -> Ordering
$cp1Ord :: Eq Intensity
Ord, Int -> Intensity -> ShowS
[Intensity] -> ShowS
Intensity -> String
(Int -> Intensity -> ShowS)
-> (Intensity -> String)
-> ([Intensity] -> ShowS)
-> Show Intensity
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Intensity] -> ShowS
$cshowList :: [Intensity] -> ShowS
show :: Intensity -> String
$cshow :: Intensity -> String
showsPrec :: Int -> Intensity -> ShowS
$cshowsPrec :: Int -> Intensity -> ShowS
Show)

-- | Foreground (text) or background (paper) color
data Layer = Foreground | Background
    deriving (Layer -> Layer -> Bool
(Layer -> Layer -> Bool) -> (Layer -> Layer -> Bool) -> Eq Layer
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Layer -> Layer -> Bool
$c/= :: Layer -> Layer -> Bool
== :: Layer -> Layer -> Bool
$c== :: Layer -> Layer -> Bool
Eq, Eq Layer
Eq Layer
-> (Layer -> Layer -> Ordering)
-> (Layer -> Layer -> Bool)
-> (Layer -> Layer -> Bool)
-> (Layer -> Layer -> Bool)
-> (Layer -> Layer -> Bool)
-> (Layer -> Layer -> Layer)
-> (Layer -> Layer -> Layer)
-> Ord Layer
Layer -> Layer -> Bool
Layer -> Layer -> Ordering
Layer -> Layer -> Layer
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Layer -> Layer -> Layer
$cmin :: Layer -> Layer -> Layer
max :: Layer -> Layer -> Layer
$cmax :: Layer -> Layer -> Layer
>= :: Layer -> Layer -> Bool
$c>= :: Layer -> Layer -> Bool
> :: Layer -> Layer -> Bool
$c> :: Layer -> Layer -> Bool
<= :: Layer -> Layer -> Bool
$c<= :: Layer -> Layer -> Bool
< :: Layer -> Layer -> Bool
$c< :: Layer -> Layer -> Bool
compare :: Layer -> Layer -> Ordering
$ccompare :: Layer -> Layer -> Ordering
$cp1Ord :: Eq Layer
Ord, Int -> Layer -> ShowS
[Layer] -> ShowS
Layer -> String
(Int -> Layer -> ShowS)
-> (Layer -> String) -> ([Layer] -> ShowS) -> Show Layer
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Layer] -> ShowS
$cshowList :: [Layer] -> ShowS
show :: Layer -> String
$cshow :: Layer -> String
showsPrec :: Int -> Layer -> ShowS
$cshowsPrec :: Int -> Layer -> ShowS
Show)

data Bold       = Bold       deriving (Bold -> Bold -> Bool
(Bold -> Bold -> Bool) -> (Bold -> Bold -> Bool) -> Eq Bold
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Bold -> Bold -> Bool
$c/= :: Bold -> Bold -> Bool
== :: Bold -> Bold -> Bool
$c== :: Bold -> Bold -> Bool
Eq, Eq Bold
Eq Bold
-> (Bold -> Bold -> Ordering)
-> (Bold -> Bold -> Bool)
-> (Bold -> Bold -> Bool)
-> (Bold -> Bold -> Bool)
-> (Bold -> Bold -> Bool)
-> (Bold -> Bold -> Bold)
-> (Bold -> Bold -> Bold)
-> Ord Bold
Bold -> Bold -> Bool
Bold -> Bold -> Ordering
Bold -> Bold -> Bold
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Bold -> Bold -> Bold
$cmin :: Bold -> Bold -> Bold
max :: Bold -> Bold -> Bold
$cmax :: Bold -> Bold -> Bold
>= :: Bold -> Bold -> Bool
$c>= :: Bold -> Bold -> Bool
> :: Bold -> Bold -> Bool
$c> :: Bold -> Bold -> Bool
<= :: Bold -> Bold -> Bool
$c<= :: Bold -> Bold -> Bool
< :: Bold -> Bold -> Bool
$c< :: Bold -> Bold -> Bool
compare :: Bold -> Bold -> Ordering
$ccompare :: Bold -> Bold -> Ordering
$cp1Ord :: Eq Bold
Ord, Int -> Bold -> ShowS
[Bold] -> ShowS
Bold -> String
(Int -> Bold -> ShowS)
-> (Bold -> String) -> ([Bold] -> ShowS) -> Show Bold
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Bold] -> ShowS
$cshowList :: [Bold] -> ShowS
show :: Bold -> String
$cshow :: Bold -> String
showsPrec :: Int -> Bold -> ShowS
$cshowsPrec :: Int -> Bold -> ShowS
Show)
data Underlined = Underlined deriving (Underlined -> Underlined -> Bool
(Underlined -> Underlined -> Bool)
-> (Underlined -> Underlined -> Bool) -> Eq Underlined
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Underlined -> Underlined -> Bool
$c/= :: Underlined -> Underlined -> Bool
== :: Underlined -> Underlined -> Bool
$c== :: Underlined -> Underlined -> Bool
Eq, Eq Underlined
Eq Underlined
-> (Underlined -> Underlined -> Ordering)
-> (Underlined -> Underlined -> Bool)
-> (Underlined -> Underlined -> Bool)
-> (Underlined -> Underlined -> Bool)
-> (Underlined -> Underlined -> Bool)
-> (Underlined -> Underlined -> Underlined)
-> (Underlined -> Underlined -> Underlined)
-> Ord Underlined
Underlined -> Underlined -> Bool
Underlined -> Underlined -> Ordering
Underlined -> Underlined -> Underlined
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Underlined -> Underlined -> Underlined
$cmin :: Underlined -> Underlined -> Underlined
max :: Underlined -> Underlined -> Underlined
$cmax :: Underlined -> Underlined -> Underlined
>= :: Underlined -> Underlined -> Bool
$c>= :: Underlined -> Underlined -> Bool
> :: Underlined -> Underlined -> Bool
$c> :: Underlined -> Underlined -> Bool
<= :: Underlined -> Underlined -> Bool
$c<= :: Underlined -> Underlined -> Bool
< :: Underlined -> Underlined -> Bool
$c< :: Underlined -> Underlined -> Bool
compare :: Underlined -> Underlined -> Ordering
$ccompare :: Underlined -> Underlined -> Ordering
$cp1Ord :: Eq Underlined
Ord, Int -> Underlined -> ShowS
[Underlined] -> ShowS
Underlined -> String
(Int -> Underlined -> ShowS)
-> (Underlined -> String)
-> ([Underlined] -> ShowS)
-> Show Underlined
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Underlined] -> ShowS
$cshowList :: [Underlined] -> ShowS
show :: Underlined -> String
$cshow :: Underlined -> String
showsPrec :: Int -> Underlined -> ShowS
$cshowsPrec :: Int -> Underlined -> ShowS
Show)
data Italicized = Italicized deriving (Italicized -> Italicized -> Bool
(Italicized -> Italicized -> Bool)
-> (Italicized -> Italicized -> Bool) -> Eq Italicized
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Italicized -> Italicized -> Bool
$c/= :: Italicized -> Italicized -> Bool
== :: Italicized -> Italicized -> Bool
$c== :: Italicized -> Italicized -> Bool
Eq, Eq Italicized
Eq Italicized
-> (Italicized -> Italicized -> Ordering)
-> (Italicized -> Italicized -> Bool)
-> (Italicized -> Italicized -> Bool)
-> (Italicized -> Italicized -> Bool)
-> (Italicized -> Italicized -> Bool)
-> (Italicized -> Italicized -> Italicized)
-> (Italicized -> Italicized -> Italicized)
-> Ord Italicized
Italicized -> Italicized -> Bool
Italicized -> Italicized -> Ordering
Italicized -> Italicized -> Italicized
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Italicized -> Italicized -> Italicized
$cmin :: Italicized -> Italicized -> Italicized
max :: Italicized -> Italicized -> Italicized
$cmax :: Italicized -> Italicized -> Italicized
>= :: Italicized -> Italicized -> Bool
$c>= :: Italicized -> Italicized -> Bool
> :: Italicized -> Italicized -> Bool
$c> :: Italicized -> Italicized -> Bool
<= :: Italicized -> Italicized -> Bool
$c<= :: Italicized -> Italicized -> Bool
< :: Italicized -> Italicized -> Bool
$c< :: Italicized -> Italicized -> Bool
compare :: Italicized -> Italicized -> Ordering
$ccompare :: Italicized -> Italicized -> Ordering
$cp1Ord :: Eq Italicized
Ord, Int -> Italicized -> ShowS
[Italicized] -> ShowS
Italicized -> String
(Int -> Italicized -> ShowS)
-> (Italicized -> String)
-> ([Italicized] -> ShowS)
-> Show Italicized
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Italicized] -> ShowS
$cshowList :: [Italicized] -> ShowS
show :: Italicized -> String
$cshow :: Italicized -> String
showsPrec :: Int -> Italicized -> ShowS
$cshowsPrec :: Int -> Italicized -> ShowS
Show)

-- | Style the foreground with a vivid color.
color :: Color -> AnsiStyle
color :: Color -> AnsiStyle
color Color
c = AnsiStyle
forall a. Monoid a => a
mempty { ansiForeground :: Maybe (Intensity, Color)
ansiForeground = (Intensity, Color) -> Maybe (Intensity, Color)
forall a. a -> Maybe a
Just (Intensity
Vivid, Color
c) }

-- | Style the background with a vivid color.
bgColor :: Color -> AnsiStyle
bgColor :: Color -> AnsiStyle
bgColor Color
c =  AnsiStyle
forall a. Monoid a => a
mempty { ansiBackground :: Maybe (Intensity, Color)
ansiBackground = (Intensity, Color) -> Maybe (Intensity, Color)
forall a. a -> Maybe a
Just (Intensity
Vivid, Color
c) }

-- | Style the foreground with a dull color.
colorDull :: Color -> AnsiStyle
colorDull :: Color -> AnsiStyle
colorDull Color
c =  AnsiStyle
forall a. Monoid a => a
mempty { ansiForeground :: Maybe (Intensity, Color)
ansiForeground = (Intensity, Color) -> Maybe (Intensity, Color)
forall a. a -> Maybe a
Just (Intensity
Dull, Color
c) }

-- | Style the background with a dull color.
bgColorDull :: Color -> AnsiStyle
bgColorDull :: Color -> AnsiStyle
bgColorDull Color
c =  AnsiStyle
forall a. Monoid a => a
mempty { ansiBackground :: Maybe (Intensity, Color)
ansiBackground = (Intensity, Color) -> Maybe (Intensity, Color)
forall a. a -> Maybe a
Just (Intensity
Dull, Color
c) }

-- | Render in __bold__.
bold :: AnsiStyle
bold :: AnsiStyle
bold = AnsiStyle
forall a. Monoid a => a
mempty { ansiBold :: Maybe Bold
ansiBold = Bold -> Maybe Bold
forall a. a -> Maybe a
Just Bold
Bold }

-- | Render in /italics/.
italicized :: AnsiStyle
italicized :: AnsiStyle
italicized = AnsiStyle
forall a. Monoid a => a
mempty { ansiItalics :: Maybe Italicized
ansiItalics = Italicized -> Maybe Italicized
forall a. a -> Maybe a
Just Italicized
Italicized }

-- | Render underlined.
underlined :: AnsiStyle
underlined :: AnsiStyle
underlined = AnsiStyle
forall a. Monoid a => a
mempty { ansiUnderlining :: Maybe Underlined
ansiUnderlining = Underlined -> Maybe Underlined
forall a. a -> Maybe a
Just Underlined
Underlined }

-- | @('renderLazy' doc)@ takes the output @doc@ from a rendering function
-- and transforms it to lazy text, including ANSI styling directives for things
-- like colorization.
--
-- ANSI color information will be discarded by this function unless you are
-- running on a Unix-like operating system. This is due to a technical
-- limitation in Windows ANSI support.
--
-- With a bit of trickery to make the ANSI codes printable, here is an example
-- that would render colored in an ANSI terminal:
--
-- >>> let render = TL.putStrLn . TL.replace "\ESC" "\\e" . renderLazy . layoutPretty defaultLayoutOptions
-- >>> let doc = annotate (color Red) ("red" <+> align (vsep [annotate (color Blue <> underlined) ("blue+u" <+> annotate bold "bold" <+> "blue+u"), "red"]))
-- >>> render (unAnnotate doc)
-- red blue+u bold blue+u
--     red
-- >>> render doc
-- \e[0;91mred \e[0;94;4mblue+u \e[0;94;1;4mbold\e[0;94;4m blue+u\e[0;91m
--     red\e[0m
--
-- Run the above via @echo -e '...'@ in your terminal to see the coloring.
renderLazy :: SimpleDocStream AnsiStyle -> TL.Text
renderLazy :: SimpleDocStream AnsiStyle -> Text
renderLazy =
    let push :: a -> [a] -> [a]
push a
x = (a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
:)

        unsafePeek :: [p] -> p
unsafePeek []    = p
forall void. void
panicPeekedEmpty
        unsafePeek (p
x:[p]
_) = p
x

        unsafePop :: [a] -> (a, [a])
unsafePop []     = (a, [a])
forall void. void
panicPoppedEmpty
        unsafePop (a
x:[a]
xs) = (a
x, [a]
xs)

        go :: [AnsiStyle] -> SimpleDocStream AnsiStyle -> TLB.Builder
        go :: [AnsiStyle] -> SimpleDocStream AnsiStyle -> Builder
go [AnsiStyle]
s SimpleDocStream AnsiStyle
sds = case SimpleDocStream AnsiStyle
sds of
            SimpleDocStream AnsiStyle
SFail -> Builder
forall void. void
panicUncaughtFail
            SimpleDocStream AnsiStyle
SEmpty -> Builder
forall a. Monoid a => a
mempty
            SChar Char
c SimpleDocStream AnsiStyle
rest -> Char -> Builder
TLB.singleton Char
c Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [AnsiStyle] -> SimpleDocStream AnsiStyle -> Builder
go [AnsiStyle]
s SimpleDocStream AnsiStyle
rest
            SText Int
_ Text
t SimpleDocStream AnsiStyle
rest -> Text -> Builder
TLB.fromText Text
t Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [AnsiStyle] -> SimpleDocStream AnsiStyle -> Builder
go [AnsiStyle]
s SimpleDocStream AnsiStyle
rest
            SLine Int
i SimpleDocStream AnsiStyle
rest -> Char -> Builder
TLB.singleton Char
'\n' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
TLB.fromText (Int -> Text -> Text
T.replicate Int
i Text
" ") Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [AnsiStyle] -> SimpleDocStream AnsiStyle -> Builder
go [AnsiStyle]
s SimpleDocStream AnsiStyle
rest
            SAnnPush AnsiStyle
style SimpleDocStream AnsiStyle
rest ->
                let currentStyle :: AnsiStyle
currentStyle = [AnsiStyle] -> AnsiStyle
forall p. [p] -> p
unsafePeek [AnsiStyle]
s
                    newStyle :: AnsiStyle
newStyle = AnsiStyle
style AnsiStyle -> AnsiStyle -> AnsiStyle
forall a. Semigroup a => a -> a -> a
<> AnsiStyle
currentStyle
                in  Text -> Builder
TLB.fromText (AnsiStyle -> Text
styleToRawText AnsiStyle
newStyle) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [AnsiStyle] -> SimpleDocStream AnsiStyle -> Builder
go (AnsiStyle -> [AnsiStyle] -> [AnsiStyle]
forall a. a -> [a] -> [a]
push AnsiStyle
style [AnsiStyle]
s) SimpleDocStream AnsiStyle
rest
            SAnnPop SimpleDocStream AnsiStyle
rest ->
                let (AnsiStyle
_currentStyle, [AnsiStyle]
s') = [AnsiStyle] -> (AnsiStyle, [AnsiStyle])
forall a. [a] -> (a, [a])
unsafePop [AnsiStyle]
s
                    newStyle :: AnsiStyle
newStyle = [AnsiStyle] -> AnsiStyle
forall p. [p] -> p
unsafePeek [AnsiStyle]
s'
                in  Text -> Builder
TLB.fromText (AnsiStyle -> Text
styleToRawText AnsiStyle
newStyle) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [AnsiStyle] -> SimpleDocStream AnsiStyle -> Builder
go [AnsiStyle]
s' SimpleDocStream AnsiStyle
rest

    in  Builder -> Text
TLB.toLazyText (Builder -> Text)
-> (SimpleDocStream AnsiStyle -> Builder)
-> SimpleDocStream AnsiStyle
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [AnsiStyle] -> SimpleDocStream AnsiStyle -> Builder
go [AnsiStyle
forall a. Monoid a => a
mempty]


-- | @('renderIO' h sdoc)@ writes @sdoc@ to the handle @h@.
--
-- >>> let render = renderIO System.IO.stdout . layoutPretty defaultLayoutOptions
-- >>> let doc = annotate (color Red) ("red" <+> align (vsep [annotate (color Blue <> underlined) ("blue+u" <+> annotate bold "bold" <+> "blue+u"), "red"]))
--
-- We render the 'unAnnotate'd version here, since the ANSI codes don’t display
-- well in Haddock,
--
-- >>> render (unAnnotate doc)
-- red blue+u bold blue+u
--     red
--
-- This function behaves just like
--
-- @
-- 'renderIO' h sdoc = 'TL.hPutStr' h ('renderLazy' sdoc)
-- @
--
-- but will not generate any intermediate text, rendering directly to the
-- handle.
renderIO :: Handle -> SimpleDocStream AnsiStyle -> IO ()
renderIO :: Handle -> SimpleDocStream AnsiStyle -> IO ()
renderIO Handle
h SimpleDocStream AnsiStyle
sdoc = do
    IORef [AnsiStyle]
styleStackRef <- [AnsiStyle] -> IO (IORef [AnsiStyle])
forall a. a -> IO (IORef a)
newIORef [AnsiStyle
forall a. Monoid a => a
mempty]

    let push :: AnsiStyle -> IO ()
push AnsiStyle
x = IORef [AnsiStyle] -> ([AnsiStyle] -> [AnsiStyle]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef [AnsiStyle]
styleStackRef (AnsiStyle
x AnsiStyle -> [AnsiStyle] -> [AnsiStyle]
forall a. a -> [a] -> [a]
:)
        unsafePeek :: IO AnsiStyle
unsafePeek = IORef [AnsiStyle] -> IO [AnsiStyle]
forall a. IORef a -> IO a
readIORef IORef [AnsiStyle]
styleStackRef IO [AnsiStyle] -> ([AnsiStyle] -> IO AnsiStyle) -> IO AnsiStyle
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[AnsiStyle]
tok -> case [AnsiStyle]
tok of
            [] -> IO AnsiStyle
forall void. void
panicPeekedEmpty
            AnsiStyle
x:[AnsiStyle]
_ -> AnsiStyle -> IO AnsiStyle
forall (f :: * -> *) a. Applicative f => a -> f a
pure AnsiStyle
x
        unsafePop :: IO AnsiStyle
unsafePop = IORef [AnsiStyle] -> IO [AnsiStyle]
forall a. IORef a -> IO a
readIORef IORef [AnsiStyle]
styleStackRef IO [AnsiStyle] -> ([AnsiStyle] -> IO AnsiStyle) -> IO AnsiStyle
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[AnsiStyle]
tok -> case [AnsiStyle]
tok of
            [] -> IO AnsiStyle
forall void. void
panicPoppedEmpty
            AnsiStyle
x:[AnsiStyle]
xs -> IORef [AnsiStyle] -> [AnsiStyle] -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef [AnsiStyle]
styleStackRef [AnsiStyle]
xs IO () -> IO AnsiStyle -> IO AnsiStyle
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> AnsiStyle -> IO AnsiStyle
forall (f :: * -> *) a. Applicative f => a -> f a
pure AnsiStyle
x

    let go :: SimpleDocStream AnsiStyle -> IO ()
go = \SimpleDocStream AnsiStyle
sds -> case SimpleDocStream AnsiStyle
sds of
            SimpleDocStream AnsiStyle
SFail -> IO ()
forall void. void
panicUncaughtFail
            SimpleDocStream AnsiStyle
SEmpty -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            SChar Char
c SimpleDocStream AnsiStyle
rest -> do
                Handle -> Char -> IO ()
hPutChar Handle
h Char
c
                SimpleDocStream AnsiStyle -> IO ()
go SimpleDocStream AnsiStyle
rest
            SText Int
_ Text
t SimpleDocStream AnsiStyle
rest -> do
                Handle -> Text -> IO ()
T.hPutStr Handle
h Text
t
                SimpleDocStream AnsiStyle -> IO ()
go SimpleDocStream AnsiStyle
rest
            SLine Int
i SimpleDocStream AnsiStyle
rest -> do
                Handle -> Char -> IO ()
hPutChar Handle
h Char
'\n'
                Handle -> Text -> IO ()
T.hPutStr Handle
h (Int -> Text -> Text
T.replicate Int
i (Char -> Text
T.singleton Char
' '))
                SimpleDocStream AnsiStyle -> IO ()
go SimpleDocStream AnsiStyle
rest
            SAnnPush AnsiStyle
style SimpleDocStream AnsiStyle
rest -> do
                AnsiStyle
currentStyle <- IO AnsiStyle
unsafePeek
                let newStyle :: AnsiStyle
newStyle = AnsiStyle
style AnsiStyle -> AnsiStyle -> AnsiStyle
forall a. Semigroup a => a -> a -> a
<> AnsiStyle
currentStyle
                AnsiStyle -> IO ()
push AnsiStyle
newStyle
                Handle -> Text -> IO ()
T.hPutStr Handle
h (AnsiStyle -> Text
styleToRawText AnsiStyle
newStyle)
                SimpleDocStream AnsiStyle -> IO ()
go SimpleDocStream AnsiStyle
rest
            SAnnPop SimpleDocStream AnsiStyle
rest -> do
                AnsiStyle
_currentStyle <- IO AnsiStyle
unsafePop
                AnsiStyle
newStyle <- IO AnsiStyle
unsafePeek
                Handle -> Text -> IO ()
T.hPutStr Handle
h (AnsiStyle -> Text
styleToRawText AnsiStyle
newStyle)
                SimpleDocStream AnsiStyle -> IO ()
go SimpleDocStream AnsiStyle
rest
    SimpleDocStream AnsiStyle -> IO ()
go SimpleDocStream AnsiStyle
sdoc
    IORef [AnsiStyle] -> IO [AnsiStyle]
forall a. IORef a -> IO a
readIORef IORef [AnsiStyle]
styleStackRef IO [AnsiStyle] -> ([AnsiStyle] -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[AnsiStyle]
stack -> case [AnsiStyle]
stack of
        []  -> IO ()
forall void. void
panicStyleStackFullyConsumed
        [AnsiStyle
_] -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        [AnsiStyle]
xs  -> Int -> IO ()
forall void. Int -> void
panicStyleStackNotFullyConsumed ([AnsiStyle] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [AnsiStyle]
xs)

panicStyleStackFullyConsumed :: void
panicStyleStackFullyConsumed :: void
panicStyleStackFullyConsumed
  = String -> void
forall a. HasCallStack => String -> a
error (String
"There is no empty style left at the end of rendering" String -> ShowS
forall a. [a] -> [a] -> [a]
++
           String
" (but there should be). Please report this as a bug.")

panicStyleStackNotFullyConsumed :: Int -> void
panicStyleStackNotFullyConsumed :: Int -> void
panicStyleStackNotFullyConsumed Int
len
  = String -> void
forall a. HasCallStack => String -> a
error (String
"There are " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
len String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" styles left at the" String -> ShowS
forall a. [a] -> [a] -> [a]
++
           String
"end of rendering (there should be only 1). Please report" String -> ShowS
forall a. [a] -> [a] -> [a]
++
           String
" this as a bug.")

-- $
-- >>> let render = renderIO System.IO.stdout . layoutPretty defaultLayoutOptions
-- >>> let doc = annotate (color Red) ("red" <+> align (vsep [annotate (color Blue <> underlined) ("blue+u" <+> annotate bold "bold" <+> "blue+u"), "red"]))
-- >>> render (unAnnotate doc)
-- red blue+u bold blue+u
--     red
--
-- This test won’t work since I don’t know how to type \ESC for doctest :-/
-- -- >>> render doc
-- -- \ESC[0;91mred \ESC[0;94;4mblue+u \ESC[0;94;1;4mbold\ESC[0;94;4m blue+u\ESC[0;91m
-- --     red\ESC[0m

-- | Render the annotated document in a certain style. Styles not set in the
-- annotation will use the style of the surrounding document, or the terminal’s
-- default if none has been set yet.
--
-- @
-- style = 'color' 'Green' '<>' 'bold'
-- styledDoc = 'annotate' style "hello world"
-- @
data AnsiStyle = SetAnsiStyle
    { AnsiStyle -> Maybe (Intensity, Color)
ansiForeground  :: Maybe (Intensity, Color) -- ^ Set the foreground color, or keep the old one.
    , AnsiStyle -> Maybe (Intensity, Color)
ansiBackground  :: Maybe (Intensity, Color) -- ^ Set the background color, or keep the old one.
    , AnsiStyle -> Maybe Bold
ansiBold        :: Maybe Bold               -- ^ Switch on boldness, or don’t do anything.
    , AnsiStyle -> Maybe Italicized
ansiItalics     :: Maybe Italicized         -- ^ Switch on italics, or don’t do anything.
    , AnsiStyle -> Maybe Underlined
ansiUnderlining :: Maybe Underlined         -- ^ Switch on underlining, or don’t do anything.
    } deriving (AnsiStyle -> AnsiStyle -> Bool
(AnsiStyle -> AnsiStyle -> Bool)
-> (AnsiStyle -> AnsiStyle -> Bool) -> Eq AnsiStyle
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AnsiStyle -> AnsiStyle -> Bool
$c/= :: AnsiStyle -> AnsiStyle -> Bool
== :: AnsiStyle -> AnsiStyle -> Bool
$c== :: AnsiStyle -> AnsiStyle -> Bool
Eq, Eq AnsiStyle
Eq AnsiStyle
-> (AnsiStyle -> AnsiStyle -> Ordering)
-> (AnsiStyle -> AnsiStyle -> Bool)
-> (AnsiStyle -> AnsiStyle -> Bool)
-> (AnsiStyle -> AnsiStyle -> Bool)
-> (AnsiStyle -> AnsiStyle -> Bool)
-> (AnsiStyle -> AnsiStyle -> AnsiStyle)
-> (AnsiStyle -> AnsiStyle -> AnsiStyle)
-> Ord AnsiStyle
AnsiStyle -> AnsiStyle -> Bool
AnsiStyle -> AnsiStyle -> Ordering
AnsiStyle -> AnsiStyle -> AnsiStyle
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: AnsiStyle -> AnsiStyle -> AnsiStyle
$cmin :: AnsiStyle -> AnsiStyle -> AnsiStyle
max :: AnsiStyle -> AnsiStyle -> AnsiStyle
$cmax :: AnsiStyle -> AnsiStyle -> AnsiStyle
>= :: AnsiStyle -> AnsiStyle -> Bool
$c>= :: AnsiStyle -> AnsiStyle -> Bool
> :: AnsiStyle -> AnsiStyle -> Bool
$c> :: AnsiStyle -> AnsiStyle -> Bool
<= :: AnsiStyle -> AnsiStyle -> Bool
$c<= :: AnsiStyle -> AnsiStyle -> Bool
< :: AnsiStyle -> AnsiStyle -> Bool
$c< :: AnsiStyle -> AnsiStyle -> Bool
compare :: AnsiStyle -> AnsiStyle -> Ordering
$ccompare :: AnsiStyle -> AnsiStyle -> Ordering
$cp1Ord :: Eq AnsiStyle
Ord, Int -> AnsiStyle -> ShowS
[AnsiStyle] -> ShowS
AnsiStyle -> String
(Int -> AnsiStyle -> ShowS)
-> (AnsiStyle -> String)
-> ([AnsiStyle] -> ShowS)
-> Show AnsiStyle
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AnsiStyle] -> ShowS
$cshowList :: [AnsiStyle] -> ShowS
show :: AnsiStyle -> String
$cshow :: AnsiStyle -> String
showsPrec :: Int -> AnsiStyle -> ShowS
$cshowsPrec :: Int -> AnsiStyle -> ShowS
Show)

-- | Keep the first decision for each of foreground color, background color,
-- boldness, italication, and underlining. If a certain style is not set, the
-- terminal’s default will be used.
--
-- Example:
--
-- @
-- 'color' 'Red' '<>' 'color' 'Green'
-- @
--
-- is red because the first color wins, and not bold because (or if) that’s the
-- terminal’s default.
instance Semigroup AnsiStyle where
    AnsiStyle
cs1 <> :: AnsiStyle -> AnsiStyle -> AnsiStyle
<> AnsiStyle
cs2 = SetAnsiStyle :: Maybe (Intensity, Color)
-> Maybe (Intensity, Color)
-> Maybe Bold
-> Maybe Italicized
-> Maybe Underlined
-> AnsiStyle
SetAnsiStyle
        { ansiForeground :: Maybe (Intensity, Color)
ansiForeground  = AnsiStyle -> Maybe (Intensity, Color)
ansiForeground  AnsiStyle
cs1 Maybe (Intensity, Color)
-> Maybe (Intensity, Color) -> Maybe (Intensity, Color)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> AnsiStyle -> Maybe (Intensity, Color)
ansiForeground  AnsiStyle
cs2
        , ansiBackground :: Maybe (Intensity, Color)
ansiBackground  = AnsiStyle -> Maybe (Intensity, Color)
ansiBackground  AnsiStyle
cs1 Maybe (Intensity, Color)
-> Maybe (Intensity, Color) -> Maybe (Intensity, Color)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> AnsiStyle -> Maybe (Intensity, Color)
ansiBackground  AnsiStyle
cs2
        , ansiBold :: Maybe Bold
ansiBold        = AnsiStyle -> Maybe Bold
ansiBold        AnsiStyle
cs1 Maybe Bold -> Maybe Bold -> Maybe Bold
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> AnsiStyle -> Maybe Bold
ansiBold        AnsiStyle
cs2
        , ansiItalics :: Maybe Italicized
ansiItalics     = AnsiStyle -> Maybe Italicized
ansiItalics     AnsiStyle
cs1 Maybe Italicized -> Maybe Italicized -> Maybe Italicized
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> AnsiStyle -> Maybe Italicized
ansiItalics     AnsiStyle
cs2
        , ansiUnderlining :: Maybe Underlined
ansiUnderlining = AnsiStyle -> Maybe Underlined
ansiUnderlining AnsiStyle
cs1 Maybe Underlined -> Maybe Underlined -> Maybe Underlined
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> AnsiStyle -> Maybe Underlined
ansiUnderlining AnsiStyle
cs2 }

-- | 'mempty' does nothing, which is equivalent to inheriting the style of the
-- surrounding doc, or the terminal’s default if no style has been set yet.
instance Monoid AnsiStyle where
    mempty :: AnsiStyle
mempty = Maybe (Intensity, Color)
-> Maybe (Intensity, Color)
-> Maybe Bold
-> Maybe Italicized
-> Maybe Underlined
-> AnsiStyle
SetAnsiStyle Maybe (Intensity, Color)
forall a. Maybe a
Nothing Maybe (Intensity, Color)
forall a. Maybe a
Nothing Maybe Bold
forall a. Maybe a
Nothing Maybe Italicized
forall a. Maybe a
Nothing Maybe Underlined
forall a. Maybe a
Nothing
    mappend :: AnsiStyle -> AnsiStyle -> AnsiStyle
mappend = AnsiStyle -> AnsiStyle -> AnsiStyle
forall a. Semigroup a => a -> a -> a
(<>)

styleToRawText :: AnsiStyle -> Text
styleToRawText :: AnsiStyle -> Text
styleToRawText = String -> Text
T.pack (String -> Text) -> (AnsiStyle -> String) -> AnsiStyle -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SGR] -> String
ANSI.setSGRCode ([SGR] -> String) -> (AnsiStyle -> [SGR]) -> AnsiStyle -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnsiStyle -> [SGR]
stylesToSgrs
  where
    stylesToSgrs :: AnsiStyle -> [ANSI.SGR]
    stylesToSgrs :: AnsiStyle -> [SGR]
stylesToSgrs (SetAnsiStyle Maybe (Intensity, Color)
fg Maybe (Intensity, Color)
bg Maybe Bold
b Maybe Italicized
i Maybe Underlined
u) = [Maybe SGR] -> [SGR]
forall a. [Maybe a] -> [a]
catMaybes
        [ SGR -> Maybe SGR
forall a. a -> Maybe a
Just SGR
ANSI.Reset
        , ((Intensity, Color) -> SGR)
-> Maybe (Intensity, Color) -> Maybe SGR
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Intensity
intensity, Color
c) -> ConsoleLayer -> ColorIntensity -> Color -> SGR
ANSI.SetColor ConsoleLayer
ANSI.Foreground (Intensity -> ColorIntensity
convertIntensity Intensity
intensity) (Color -> Color
convertColor Color
c)) Maybe (Intensity, Color)
fg
        , ((Intensity, Color) -> SGR)
-> Maybe (Intensity, Color) -> Maybe SGR
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Intensity
intensity, Color
c) -> ConsoleLayer -> ColorIntensity -> Color -> SGR
ANSI.SetColor ConsoleLayer
ANSI.Background (Intensity -> ColorIntensity
convertIntensity Intensity
intensity) (Color -> Color
convertColor Color
c)) Maybe (Intensity, Color)
bg
        , (Bold -> SGR) -> Maybe Bold -> Maybe SGR
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Bold
_              -> ConsoleIntensity -> SGR
ANSI.SetConsoleIntensity ConsoleIntensity
ANSI.BoldIntensity) Maybe Bold
b
        , (Italicized -> SGR) -> Maybe Italicized -> Maybe SGR
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Italicized
_              -> Bool -> SGR
ANSI.SetItalicized Bool
True) Maybe Italicized
i
        , (Underlined -> SGR) -> Maybe Underlined -> Maybe SGR
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Underlined
_              -> Underlining -> SGR
ANSI.SetUnderlining Underlining
ANSI.SingleUnderline) Maybe Underlined
u
        ]

    convertIntensity :: Intensity -> ANSI.ColorIntensity
    convertIntensity :: Intensity -> ColorIntensity
convertIntensity = \Intensity
i -> case Intensity
i of
        Intensity
Vivid -> ColorIntensity
ANSI.Vivid
        Intensity
Dull  -> ColorIntensity
ANSI.Dull

    convertColor :: Color -> ANSI.Color
    convertColor :: Color -> Color
convertColor = \Color
c -> case Color
c of
        Color
Black   -> Color
ANSI.Black
        Color
Red     -> Color
ANSI.Red
        Color
Green   -> Color
ANSI.Green
        Color
Yellow  -> Color
ANSI.Yellow
        Color
Blue    -> Color
ANSI.Blue
        Color
Magenta -> Color
ANSI.Magenta
        Color
Cyan    -> Color
ANSI.Cyan
        Color
White   -> Color
ANSI.White



-- | @('renderStrict' sdoc)@ takes the output @sdoc@ from a rendering and
-- transforms it to strict text.
renderStrict :: SimpleDocStream AnsiStyle -> Text
renderStrict :: SimpleDocStream AnsiStyle -> Text
renderStrict = Text -> Text
TL.toStrict (Text -> Text)
-> (SimpleDocStream AnsiStyle -> Text)
-> SimpleDocStream AnsiStyle
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleDocStream AnsiStyle -> Text
renderLazy

-- | @('putDoc' doc)@ prettyprints document @doc@ to standard output using
-- 'defaultLayoutOptions'.
--
-- >>> putDoc ("hello" <+> "world")
-- hello world
--
-- @
-- 'putDoc' = 'hPutDoc' 'stdout'
-- @
putDoc :: Doc AnsiStyle -> IO ()
putDoc :: Doc AnsiStyle -> IO ()
putDoc = Handle -> Doc AnsiStyle -> IO ()
hPutDoc Handle
stdout

-- | Like 'putDoc', but instead of using 'stdout', print to a user-provided
-- handle, e.g. a file or a socket using 'defaultLayoutOptions'.
--
-- > main = withFile "someFile.txt" (\h -> hPutDoc h (vcat ["vertical", "text"]))
--
-- @
-- 'hPutDoc' h doc = 'renderIO' h ('layoutPretty' 'defaultLayoutOptions' doc)
-- @
hPutDoc :: Handle -> Doc AnsiStyle -> IO ()
hPutDoc :: Handle -> Doc AnsiStyle -> IO ()
hPutDoc Handle
h Doc AnsiStyle
doc = Handle -> SimpleDocStream AnsiStyle -> IO ()
renderIO Handle
h (LayoutOptions -> Doc AnsiStyle -> SimpleDocStream AnsiStyle
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutPretty LayoutOptions
defaultLayoutOptions Doc AnsiStyle
doc)