{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_HADDOCK not-home #-}
#include "version-compatibility-macros.h"
module Prettyprinter.Render.Terminal.Internal (
AnsiStyle(..),
Color(..),
color, colorDull,
bgColor, bgColorDull,
bold, italicized, underlined,
Intensity(..),
Bold(..),
Underlined(..),
Italicized(..),
renderLazy, renderStrict,
renderIO,
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 Data.Text.Prettyprint.Doc
import Data.Text.Prettyprint.Doc.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
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)
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)
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)
color :: Color -> AnsiStyle
color :: Color -> AnsiStyle
color c :: 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) }
bgColor :: Color -> AnsiStyle
bgColor :: Color -> AnsiStyle
bgColor c :: 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) }
colorDull :: Color -> AnsiStyle
colorDull :: Color -> AnsiStyle
colorDull c :: 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) }
bgColorDull :: Color -> AnsiStyle
bgColorDull :: Color -> AnsiStyle
bgColorDull c :: 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) }
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 }
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 }
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 :: SimpleDocStream AnsiStyle -> TL.Text
renderLazy :: SimpleDocStream AnsiStyle -> Text
renderLazy =
let push :: a -> [a] -> [a]
push x :: a
x = (a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
:)
unsafePeek :: [p] -> p
unsafePeek [] = p
forall void. void
panicPeekedEmpty
unsafePeek (x :: p
x:_) = p
x
unsafePop :: [a] -> (a, [a])
unsafePop [] = (a, [a])
forall void. void
panicPoppedEmpty
unsafePop (x :: a
x:xs :: [a]
xs) = (a
x, [a]
xs)
go :: [AnsiStyle] -> SimpleDocStream AnsiStyle -> TLB.Builder
go :: [AnsiStyle] -> SimpleDocStream AnsiStyle -> Builder
go s :: [AnsiStyle]
s sds :: SimpleDocStream AnsiStyle
sds = case SimpleDocStream AnsiStyle
sds of
SFail -> Builder
forall void. void
panicUncaughtFail
SEmpty -> Builder
forall a. Monoid a => a
mempty
SChar c :: Char
c rest :: 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 _ t :: Text
t rest :: 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 i :: Int
i rest :: SimpleDocStream AnsiStyle
rest -> Char -> Builder
TLB.singleton '\n' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
TLB.fromText (Int -> Text -> Text
T.replicate Int
i " ") Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [AnsiStyle] -> SimpleDocStream AnsiStyle -> Builder
go [AnsiStyle]
s SimpleDocStream AnsiStyle
rest
SAnnPush style :: AnsiStyle
style rest :: 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 rest :: SimpleDocStream AnsiStyle
rest ->
let (_currentStyle :: AnsiStyle
_currentStyle, s' :: [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 :: Handle -> SimpleDocStream AnsiStyle -> IO ()
renderIO :: Handle -> SimpleDocStream AnsiStyle -> IO ()
renderIO h :: Handle
h sdoc :: 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 x :: 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
>>= \tok :: [AnsiStyle]
tok -> case [AnsiStyle]
tok of
[] -> IO AnsiStyle
forall void. void
panicPeekedEmpty
x :: AnsiStyle
x:_ -> 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
>>= \tok :: [AnsiStyle]
tok -> case [AnsiStyle]
tok of
[] -> IO AnsiStyle
forall void. void
panicPoppedEmpty
x :: AnsiStyle
x:xs :: [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 = \sds :: SimpleDocStream AnsiStyle
sds -> case SimpleDocStream AnsiStyle
sds of
SFail -> IO ()
forall void. void
panicUncaughtFail
SEmpty -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
SChar c :: Char
c rest :: SimpleDocStream AnsiStyle
rest -> do
Handle -> Char -> IO ()
hPutChar Handle
h Char
c
SimpleDocStream AnsiStyle -> IO ()
go SimpleDocStream AnsiStyle
rest
SText _ t :: Text
t rest :: SimpleDocStream AnsiStyle
rest -> do
Handle -> Text -> IO ()
T.hPutStr Handle
h Text
t
SimpleDocStream AnsiStyle -> IO ()
go SimpleDocStream AnsiStyle
rest
SLine i :: Int
i rest :: SimpleDocStream AnsiStyle
rest -> do
Handle -> Char -> IO ()
hPutChar Handle
h '\n'
Handle -> Text -> IO ()
T.hPutStr Handle
h (Int -> Text -> Text
T.replicate Int
i (Char -> Text
T.singleton ' '))
SimpleDocStream AnsiStyle -> IO ()
go SimpleDocStream AnsiStyle
rest
SAnnPush style :: AnsiStyle
style rest :: 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 rest :: 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
>>= \stack :: [AnsiStyle]
stack -> case [AnsiStyle]
stack of
[] -> IO ()
forall void. void
panicStyleStackFullyConsumed
[_] -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
xs :: [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 ("There is no empty style left at the end of rendering" String -> ShowS
forall a. [a] -> [a] -> [a]
++
" (but there should be). Please report this as a bug.")
panicStyleStackNotFullyConsumed :: Int -> void
panicStyleStackNotFullyConsumed :: Int -> void
panicStyleStackNotFullyConsumed len :: Int
len
= String -> void
forall a. HasCallStack => String -> a
error ("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
<> " styles left at the" String -> ShowS
forall a. [a] -> [a] -> [a]
++
"end of rendering (there should be only 1). Please report" String -> ShowS
forall a. [a] -> [a] -> [a]
++
" this as a bug.")
data AnsiStyle = SetAnsiStyle
{ AnsiStyle -> Maybe (Intensity, Color)
ansiForeground :: Maybe (Intensity, Color)
, AnsiStyle -> Maybe (Intensity, Color)
ansiBackground :: Maybe (Intensity, Color)
, AnsiStyle -> Maybe Bold
ansiBold :: Maybe Bold
, AnsiStyle -> Maybe Italicized
ansiItalics :: Maybe Italicized
, AnsiStyle -> Maybe Underlined
ansiUnderlining :: Maybe Underlined
} 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)
instance Semigroup AnsiStyle where
cs1 :: AnsiStyle
cs1 <> :: AnsiStyle -> AnsiStyle -> AnsiStyle
<> cs2 :: 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 }
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 fg :: Maybe (Intensity, Color)
fg bg :: Maybe (Intensity, Color)
bg b :: Maybe Bold
b i :: Maybe Italicized
i u :: 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
intensity, c :: 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
intensity, c :: 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 (\_ -> 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 (\_ -> 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 (\_ -> Underlining -> SGR
ANSI.SetUnderlining Underlining
ANSI.SingleUnderline) Maybe Underlined
u
]
convertIntensity :: Intensity -> ANSI.ColorIntensity
convertIntensity :: Intensity -> ColorIntensity
convertIntensity = \i :: Intensity
i -> case Intensity
i of
Vivid -> ColorIntensity
ANSI.Vivid
Dull -> ColorIntensity
ANSI.Dull
convertColor :: Color -> ANSI.Color
convertColor :: Color -> Color
convertColor = \c :: Color
c -> case Color
c of
Black -> Color
ANSI.Black
Red -> Color
ANSI.Red
Green -> Color
ANSI.Green
Yellow -> Color
ANSI.Yellow
Blue -> Color
ANSI.Blue
Magenta -> Color
ANSI.Magenta
Cyan -> Color
ANSI.Cyan
White -> Color
ANSI.White
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 AnsiStyle -> IO ()
putDoc :: Doc AnsiStyle -> IO ()
putDoc = Handle -> Doc AnsiStyle -> IO ()
hPutDoc Handle
stdout
hPutDoc :: Handle -> Doc AnsiStyle -> IO ()
hPutDoc :: Handle -> Doc AnsiStyle -> IO ()
hPutDoc h :: Handle
h doc :: 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)