{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE LambdaCase #-}
module Chapelure.Style where
import Control.Applicative ((<|>))
import Data.Colour (Colour)
import Data.Maybe (catMaybes, listToMaybe, fromMaybe)
import Data.Text qualified as T
import Data.Text.IO qualified as T
import Data.Word (Word8)
import Prettyprinter (Doc, SimpleDocStream (..))
import System.Console.ANSI (Color, ColorIntensity, ConsoleIntensity, ConsoleLayer (Background, Foreground), SGR (SetColor, SetConsoleIntensity, SetDefaultColor, SetItalicized, SetPaletteColor, SetRGBColor, SetSwapForegroundBackground, SetUnderlining), Underlining, hSetSGR, setSGR, setSGRCode)
import System.IO (Handle)
data Style = Style
{ Style -> Maybe ConsoleIntensity
_intensity :: !(Maybe ConsoleIntensity),
Style -> Maybe Bool
_italicize :: !(Maybe Bool),
Style -> Maybe Underlining
_underline :: !(Maybe Underlining),
Style -> Maybe Bool
_negative :: !(Maybe Bool),
Style -> Maybe StyleColor
_colorFG :: !(Maybe StyleColor),
Style -> Maybe StyleColor
_colorBG :: !(Maybe StyleColor)
}
deriving (Int -> Style -> ShowS
[Style] -> ShowS
Style -> String
(Int -> Style -> ShowS)
-> (Style -> String) -> ([Style] -> ShowS) -> Show Style
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Style] -> ShowS
$cshowList :: [Style] -> ShowS
show :: Style -> String
$cshow :: Style -> String
showsPrec :: Int -> Style -> ShowS
$cshowsPrec :: Int -> Style -> ShowS
Show, Style -> Style -> Bool
(Style -> Style -> Bool) -> (Style -> Style -> Bool) -> Eq Style
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Style -> Style -> Bool
$c/= :: Style -> Style -> Bool
== :: Style -> Style -> Bool
$c== :: Style -> Style -> Bool
Eq)
styleIntensity :: ConsoleIntensity -> Style
styleIntensity :: ConsoleIntensity -> Style
styleIntensity ConsoleIntensity
si = Maybe ConsoleIntensity
-> Maybe Bool
-> Maybe Underlining
-> Maybe Bool
-> Maybe StyleColor
-> Maybe StyleColor
-> Style
Style (ConsoleIntensity -> Maybe ConsoleIntensity
forall a. a -> Maybe a
Just ConsoleIntensity
si) Maybe Bool
forall a. Maybe a
Nothing Maybe Underlining
forall a. Maybe a
Nothing Maybe Bool
forall a. Maybe a
Nothing Maybe StyleColor
forall a. Maybe a
Nothing Maybe StyleColor
forall a. Maybe a
Nothing
styleItalicized :: Bool -> Style
styleItalicized :: Bool -> Style
styleItalicized Bool
it = Maybe ConsoleIntensity
-> Maybe Bool
-> Maybe Underlining
-> Maybe Bool
-> Maybe StyleColor
-> Maybe StyleColor
-> Style
Style Maybe ConsoleIntensity
forall a. Maybe a
Nothing (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
it) Maybe Underlining
forall a. Maybe a
Nothing Maybe Bool
forall a. Maybe a
Nothing Maybe StyleColor
forall a. Maybe a
Nothing Maybe StyleColor
forall a. Maybe a
Nothing
styleUnderline :: Underlining -> Style
styleUnderline :: Underlining -> Style
styleUnderline Underlining
ul = Maybe ConsoleIntensity
-> Maybe Bool
-> Maybe Underlining
-> Maybe Bool
-> Maybe StyleColor
-> Maybe StyleColor
-> Style
Style Maybe ConsoleIntensity
forall a. Maybe a
Nothing Maybe Bool
forall a. Maybe a
Nothing (Underlining -> Maybe Underlining
forall a. a -> Maybe a
Just Underlining
ul) Maybe Bool
forall a. Maybe a
Nothing Maybe StyleColor
forall a. Maybe a
Nothing Maybe StyleColor
forall a. Maybe a
Nothing
styleNegative :: Bool -> Style
styleNegative :: Bool -> Style
styleNegative Bool
sn = Maybe ConsoleIntensity
-> Maybe Bool
-> Maybe Underlining
-> Maybe Bool
-> Maybe StyleColor
-> Maybe StyleColor
-> Style
Style Maybe ConsoleIntensity
forall a. Maybe a
Nothing Maybe Bool
forall a. Maybe a
Nothing Maybe Underlining
forall a. Maybe a
Nothing (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
sn) Maybe StyleColor
forall a. Maybe a
Nothing Maybe StyleColor
forall a. Maybe a
Nothing
styleFG :: StyleColor -> Style
styleFG :: StyleColor -> Style
styleFG StyleColor
c = Maybe ConsoleIntensity
-> Maybe Bool
-> Maybe Underlining
-> Maybe Bool
-> Maybe StyleColor
-> Maybe StyleColor
-> Style
Style Maybe ConsoleIntensity
forall a. Maybe a
Nothing Maybe Bool
forall a. Maybe a
Nothing Maybe Underlining
forall a. Maybe a
Nothing Maybe Bool
forall a. Maybe a
Nothing (StyleColor -> Maybe StyleColor
forall a. a -> Maybe a
Just StyleColor
c) Maybe StyleColor
forall a. Maybe a
Nothing
styleBG :: StyleColor -> Style
styleBG :: StyleColor -> Style
styleBG StyleColor
c = Maybe ConsoleIntensity
-> Maybe Bool
-> Maybe Underlining
-> Maybe Bool
-> Maybe StyleColor
-> Maybe StyleColor
-> Style
Style Maybe ConsoleIntensity
forall a. Maybe a
Nothing Maybe Bool
forall a. Maybe a
Nothing Maybe Underlining
forall a. Maybe a
Nothing Maybe Bool
forall a. Maybe a
Nothing Maybe StyleColor
forall a. Maybe a
Nothing (StyleColor -> Maybe StyleColor
forall a. a -> Maybe a
Just StyleColor
c)
instance Semigroup Style where
Style Maybe ConsoleIntensity
is Maybe Bool
it Maybe Underlining
un Maybe Bool
ne Maybe StyleColor
fg Maybe StyleColor
bg <> :: Style -> Style -> Style
<> Style Maybe ConsoleIntensity
is2 Maybe Bool
it2 Maybe Underlining
un2 Maybe Bool
ne2 Maybe StyleColor
fg2 Maybe StyleColor
bg2 =
Maybe ConsoleIntensity
-> Maybe Bool
-> Maybe Underlining
-> Maybe Bool
-> Maybe StyleColor
-> Maybe StyleColor
-> Style
Style (Maybe ConsoleIntensity
is Maybe ConsoleIntensity
-> Maybe ConsoleIntensity -> Maybe ConsoleIntensity
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe ConsoleIntensity
is2) (Maybe Bool
it Maybe Bool -> Maybe Bool -> Maybe Bool
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Bool
it2) (Maybe Underlining
un Maybe Underlining -> Maybe Underlining -> Maybe Underlining
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Underlining
un2) (Maybe Bool
ne Maybe Bool -> Maybe Bool -> Maybe Bool
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Bool
ne2) (Maybe StyleColor
fg Maybe StyleColor -> Maybe StyleColor -> Maybe StyleColor
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe StyleColor
fg2) (Maybe StyleColor
bg Maybe StyleColor -> Maybe StyleColor -> Maybe StyleColor
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe StyleColor
bg2)
instance Monoid Style where
mempty :: Style
mempty = Maybe ConsoleIntensity
-> Maybe Bool
-> Maybe Underlining
-> Maybe Bool
-> Maybe StyleColor
-> Maybe StyleColor
-> Style
Style Maybe ConsoleIntensity
forall a. Maybe a
Nothing Maybe Bool
forall a. Maybe a
Nothing Maybe Underlining
forall a. Maybe a
Nothing Maybe Bool
forall a. Maybe a
Nothing Maybe StyleColor
forall a. Maybe a
Nothing Maybe StyleColor
forall a. Maybe a
Nothing
data StyleColor
= ColorDefault
| Color16 !ColorIntensity !Color
| Color256 !Word8
| ColorRGB !(Colour Float)
deriving (Int -> StyleColor -> ShowS
[StyleColor] -> ShowS
StyleColor -> String
(Int -> StyleColor -> ShowS)
-> (StyleColor -> String)
-> ([StyleColor] -> ShowS)
-> Show StyleColor
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StyleColor] -> ShowS
$cshowList :: [StyleColor] -> ShowS
show :: StyleColor -> String
$cshow :: StyleColor -> String
showsPrec :: Int -> StyleColor -> ShowS
$cshowsPrec :: Int -> StyleColor -> ShowS
Show, StyleColor -> StyleColor -> Bool
(StyleColor -> StyleColor -> Bool)
-> (StyleColor -> StyleColor -> Bool) -> Eq StyleColor
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: StyleColor -> StyleColor -> Bool
$c/= :: StyleColor -> StyleColor -> Bool
== :: StyleColor -> StyleColor -> Bool
$c== :: StyleColor -> StyleColor -> Bool
Eq)
type DocText = Doc Style
toSGR :: Style -> [SGR]
toSGR :: Style -> [SGR]
toSGR (Style Maybe ConsoleIntensity
is Maybe Bool
it Maybe Underlining
un Maybe Bool
ne Maybe StyleColor
fg Maybe StyleColor
bg) =
[Maybe SGR] -> [SGR]
forall a. [Maybe a] -> [a]
catMaybes
[ ConsoleIntensity -> SGR
SetConsoleIntensity (ConsoleIntensity -> SGR) -> Maybe ConsoleIntensity -> Maybe SGR
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ConsoleIntensity
is,
Bool -> SGR
SetItalicized (Bool -> SGR) -> Maybe Bool -> Maybe SGR
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Bool
it,
Underlining -> SGR
SetUnderlining (Underlining -> SGR) -> Maybe Underlining -> Maybe SGR
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Underlining
un,
Bool -> SGR
SetSwapForegroundBackground (Bool -> SGR) -> Maybe Bool -> Maybe SGR
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Bool
ne,
ConsoleLayer -> StyleColor -> SGR
go ConsoleLayer
Foreground (StyleColor -> SGR) -> Maybe StyleColor -> Maybe SGR
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe StyleColor
fg,
ConsoleLayer -> StyleColor -> SGR
go ConsoleLayer
Background (StyleColor -> SGR) -> Maybe StyleColor -> Maybe SGR
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe StyleColor
bg
]
where
go :: ConsoleLayer -> StyleColor -> SGR
go :: ConsoleLayer -> StyleColor -> SGR
go ConsoleLayer
l = \case
StyleColor
ColorDefault -> ConsoleLayer -> SGR
SetDefaultColor ConsoleLayer
l
Color16 ColorIntensity
ci Color
co -> ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
l ColorIntensity
ci Color
co
Color256 Word8
wo -> ConsoleLayer -> Word8 -> SGR
SetPaletteColor ConsoleLayer
l Word8
wo
ColorRGB Colour Float
co -> ConsoleLayer -> Colour Float -> SGR
SetRGBColor ConsoleLayer
l Colour Float
co
setStyleCode :: Style -> String
setStyleCode :: Style -> String
setStyleCode = [SGR] -> String
setSGRCode ([SGR] -> String) -> (Style -> [SGR]) -> Style -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Style -> [SGR]
toSGR
setStyle :: Style -> IO ()
setStyle :: Style -> IO ()
setStyle = [SGR] -> IO ()
setSGR ([SGR] -> IO ()) -> (Style -> [SGR]) -> Style -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Style -> [SGR]
toSGR
hSetStyle :: Handle -> Style -> IO ()
hSetStyle :: Handle -> Style -> IO ()
hSetStyle Handle
h = Handle -> [SGR] -> IO ()
hSetSGR Handle
h ([SGR] -> IO ()) -> (Style -> [SGR]) -> Style -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Style -> [SGR]
toSGR
renderDoc :: SimpleDocStream Style -> T.Text
renderDoc :: SimpleDocStream Style -> Text
renderDoc = [Maybe Style] -> SimpleDocStream Style -> Text
go []
where
go :: [Maybe Style] -> SimpleDocStream Style -> T.Text
go :: [Maybe Style] -> SimpleDocStream Style -> Text
go [Maybe Style]
st = \case
SimpleDocStream Style
SFail -> String -> Text
forall a. HasCallStack => String -> a
error String
"SFail left in pretty-printed output"
SimpleDocStream Style
SEmpty -> Text
forall a. Monoid a => a
mempty
SChar Char
c SimpleDocStream Style
sds -> Char -> Text
T.singleton Char
c Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Maybe Style] -> SimpleDocStream Style -> Text
go [Maybe Style]
st SimpleDocStream Style
sds
SText Int
_n Text
txt SimpleDocStream Style
sds -> Text
txt Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Maybe Style] -> SimpleDocStream Style -> Text
go [Maybe Style]
st SimpleDocStream Style
sds
SLine Int
n SimpleDocStream Style
sds -> Char -> Text
T.singleton Char
'\n' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
T.replicate Int
n (Char -> Text
T.singleton Char
' ') Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Maybe Style] -> SimpleDocStream Style -> Text
go [Maybe Style]
st SimpleDocStream Style
sds
SAnnPush Style
st' SimpleDocStream Style
sds -> if Style
st' Style -> Style -> Bool
forall a. Eq a => a -> a -> Bool
== Style
forall a. Monoid a => a
mempty
then [Maybe Style] -> SimpleDocStream Style -> Text
go (Maybe Style
forall a. Maybe a
Nothing Maybe Style -> [Maybe Style] -> [Maybe Style]
forall a. a -> [a] -> [a]
: [Maybe Style]
st) SimpleDocStream Style
sds
else String -> Text
T.pack (Style -> String
setStyleCode (Style -> Maybe Style -> Style
forall a. a -> Maybe a -> a
fromMaybe Style
forall a. Monoid a => a
mempty (Maybe Style -> Maybe (Maybe Style) -> Maybe Style
forall a. a -> Maybe a -> a
fromMaybe Maybe Style
forall a. Monoid a => a
mempty ([Maybe Style] -> Maybe (Maybe Style)
forall a. [a] -> Maybe a
listToMaybe [Maybe Style]
st)) Style -> Style -> Style
forall a. Semigroup a => a -> a -> a
<> Style
st')) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Maybe Style] -> SimpleDocStream Style -> Text
go (Style -> Maybe Style
forall a. a -> Maybe a
Just Style
st' Maybe Style -> [Maybe Style] -> [Maybe Style]
forall a. a -> [a] -> [a]
: [Maybe Style]
st) SimpleDocStream Style
sds
SAnnPop SimpleDocStream Style
sds -> case [Maybe Style]
st of
[] -> [Maybe Style] -> SimpleDocStream Style -> Text
go [] SimpleDocStream Style
sds
[Maybe Style
Nothing] -> [Maybe Style] -> SimpleDocStream Style -> Text
go [] SimpleDocStream Style
sds
(Maybe Style
Nothing : Maybe Style
t : [Maybe Style]
ss) -> [Maybe Style] -> SimpleDocStream Style -> Text
go (Maybe Style
t Maybe Style -> [Maybe Style] -> [Maybe Style]
forall a. a -> [a] -> [a]
: [Maybe Style]
ss) SimpleDocStream Style
sds
[Just Style
_s] -> String -> Text
T.pack (Style -> String
setStyleCode Style
forall a. Monoid a => a
mempty) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Maybe Style] -> SimpleDocStream Style -> Text
go [] SimpleDocStream Style
sds
(Just Style
_s : Maybe Style
t : [Maybe Style]
ss) -> Text -> (Style -> Text) -> Maybe Style -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
forall a. Monoid a => a
mempty (String -> Text
T.pack (String -> Text) -> (Style -> String) -> Style -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Style -> String
setStyleCode) Maybe Style
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Maybe Style] -> SimpleDocStream Style -> Text
go (Maybe Style
t Maybe Style -> [Maybe Style] -> [Maybe Style]
forall a. a -> [a] -> [a]
: [Maybe Style]
ss) SimpleDocStream Style
sds
putDocText :: SimpleDocStream Style -> IO ()
putDocText :: SimpleDocStream Style -> IO ()
putDocText = [Maybe Style] -> SimpleDocStream Style -> IO ()
go []
where
go :: [Maybe Style] -> SimpleDocStream Style -> IO ()
go :: [Maybe Style] -> SimpleDocStream Style -> IO ()
go [Maybe Style]
st = \case
SimpleDocStream Style
SFail -> String -> IO ()
forall a. HasCallStack => String -> a
error String
"SFail left in pretty-printed output"
SimpleDocStream Style
SEmpty -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
SChar Char
c SimpleDocStream Style
sds -> Char -> IO ()
putChar Char
c IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Maybe Style] -> SimpleDocStream Style -> IO ()
go [Maybe Style]
st SimpleDocStream Style
sds
SText Int
_n Text
txt SimpleDocStream Style
sds -> Text -> IO ()
T.putStr Text
txt IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Maybe Style] -> SimpleDocStream Style -> IO ()
go [Maybe Style]
st SimpleDocStream Style
sds
SLine Int
n SimpleDocStream Style
sds -> Char -> IO ()
putChar Char
'\n' IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Text -> IO ()
T.putStr (Int -> Text -> Text
T.replicate Int
n (Char -> Text
T.singleton Char
' ')) IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Maybe Style] -> SimpleDocStream Style -> IO ()
go [Maybe Style]
st SimpleDocStream Style
sds
SAnnPush Style
st' SimpleDocStream Style
sds -> if Style
st' Style -> Style -> Bool
forall a. Eq a => a -> a -> Bool
== Style
forall a. Monoid a => a
mempty
then [Maybe Style] -> SimpleDocStream Style -> IO ()
go (Maybe Style
forall a. Maybe a
Nothing Maybe Style -> [Maybe Style] -> [Maybe Style]
forall a. a -> [a] -> [a]
: [Maybe Style]
st) SimpleDocStream Style
sds
else do
Style -> IO ()
setStyle (Style -> Maybe Style -> Style
forall a. a -> Maybe a -> a
fromMaybe Style
forall a. Monoid a => a
mempty (Maybe Style -> Maybe (Maybe Style) -> Maybe Style
forall a. a -> Maybe a -> a
fromMaybe Maybe Style
forall a. Monoid a => a
mempty ([Maybe Style] -> Maybe (Maybe Style)
forall a. [a] -> Maybe a
listToMaybe [Maybe Style]
st)) Style -> Style -> Style
forall a. Semigroup a => a -> a -> a
<> Style
st')
[Maybe Style] -> SimpleDocStream Style -> IO ()
go (Style -> Maybe Style
forall a. a -> Maybe a
Just Style
st' Maybe Style -> [Maybe Style] -> [Maybe Style]
forall a. a -> [a] -> [a]
: [Maybe Style]
st) SimpleDocStream Style
sds
SAnnPop SimpleDocStream Style
sds -> case [Maybe Style]
st of
[] -> [Maybe Style] -> SimpleDocStream Style -> IO ()
go [] SimpleDocStream Style
sds
[Maybe Style
Nothing] -> [Maybe Style] -> SimpleDocStream Style -> IO ()
go [] SimpleDocStream Style
sds
(Maybe Style
Nothing : Maybe Style
t : [Maybe Style]
ss) -> [Maybe Style] -> SimpleDocStream Style -> IO ()
go (Maybe Style
t Maybe Style -> [Maybe Style] -> [Maybe Style]
forall a. a -> [a] -> [a]
: [Maybe Style]
ss) SimpleDocStream Style
sds
[Just Style
_s] -> Style -> IO ()
setStyle Style
forall a. Monoid a => a
mempty IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Maybe Style] -> SimpleDocStream Style -> IO ()
go [] SimpleDocStream Style
sds
(Just Style
_s : Maybe Style
t : [Maybe Style]
ss) -> IO () -> (Style -> IO ()) -> Maybe Style -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) Style -> IO ()
setStyle Maybe Style
t IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Maybe Style] -> SimpleDocStream Style -> IO ()
go (Maybe Style
t Maybe Style -> [Maybe Style] -> [Maybe Style]
forall a. a -> [a] -> [a]
: [Maybe Style]
ss) SimpleDocStream Style
sds