-- Copyright 2018 Evan Laforge
-- This program is distributed under the terms of the GNU General Public
-- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt

-- | A simple Styled Text implementation.  There are a few others on hackage
-- (terminal-text, rainbow, ...), but they're all too complicated for me.
--
-- Examples:
-- > printLn $ fgs (bright red) "hi" <> fgs red "there"
-- > printLn $ bgs (bright red) "hi" <> bgs red "there"
-- > printLn $ underlines "hi" <> " " <> bolds "there"
-- > printLn $ underlines $ fgs (bright red) "hi" <> fgs red "there"
--
-- > printLn $ bgs cyan "hello\nthere"
-- > printLn $ bgs cyan "hello" <> "\n" <> bgs cyan "there"
module Util.Styled (
    Styled, Style(..)
    , print, printLn
    , toByteString, toByteStrings
    , toText, toTexts
    , Color(..), RgbColor, AnsiColor
    , black, red, green, yellow, blue, magenta, cyan, white
    , rgb, rgbGray, rgbColor, toRgb
    , styled, plain
    , bright
    , fgs, bgs, bolds, underlines
    , fg, bg, bold, underline
    -- * text util
    , join
    -- * html
    , toHtml, toHtmls
    , styleHtml
) where
import           Prelude hiding (print)
import           Control.Applicative ((<|>))
import           Data.Bifunctor (second)
import           Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as ByteString
import qualified Data.Char as Char
import qualified Data.Colour as Colour
import qualified Data.Colour.Names as Colour.Names
import qualified Data.Colour.SRGB as SRGB
import qualified Data.List as List
import qualified Data.Maybe as Maybe
import qualified Data.String as String
import qualified Data.Text as Text
import           Data.Text (Text)
import qualified Data.Text.Encoding as Encoding

import qualified System.Console.ANSI as ANSI

import qualified Util.Html as Html
import qualified Util.Num as Num
import qualified Util.Lists as Lists
import qualified Util.Then as Then


data Styled = Branch Styled Styled | Styled !Style !Text
    deriving (Styled -> Styled -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Styled -> Styled -> Bool
$c/= :: Styled -> Styled -> Bool
== :: Styled -> Styled -> Bool
$c== :: Styled -> Styled -> Bool
Eq, Int -> Styled -> ShowS
[Styled] -> ShowS
Styled -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Styled] -> ShowS
$cshowList :: [Styled] -> ShowS
show :: Styled -> String
$cshow :: Styled -> String
showsPrec :: Int -> Styled -> ShowS
$cshowsPrec :: Int -> Styled -> ShowS
Show)

instance Semigroup Styled where
    Styled Style
_ Text
t1 <> :: Styled -> Styled -> Styled
<> Styled
s2 | Text -> Bool
Text.null Text
t1 = Styled
s2
    Styled
s1 <> Styled Style
_ Text
t2 | Text -> Bool
Text.null Text
t2 = Styled
s1
    Styled
s1 <> Styled
s2 = Styled -> Styled -> Styled
Branch Styled
s1 Styled
s2

instance Monoid Styled where
    mempty :: Styled
mempty = Style -> Text -> Styled
Styled forall a. Monoid a => a
mempty Text
""
    mappend :: Styled -> Styled -> Styled
mappend = forall a. Semigroup a => a -> a -> a
(<>)

instance String.IsString Styled where
    fromString :: String -> Styled
fromString = Style -> Text -> Styled
Styled forall a. Monoid a => a
mempty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => String -> a
String.fromString

class ToStyled a where toStyled :: a -> Styled
instance ToStyled Text where toStyled :: Text -> Styled
toStyled = Style -> Text -> Styled
Styled forall a. Monoid a => a
mempty
instance ToStyled Styled where toStyled :: Styled -> Styled
toStyled = forall a. a -> a
id

mapStyle :: (Style -> Style) -> Styled -> Styled
mapStyle :: (Style -> Style) -> Styled -> Styled
mapStyle Style -> Style
f (Branch Styled
t1 Styled
t2) = Styled -> Styled -> Styled
Branch ((Style -> Style) -> Styled -> Styled
mapStyle Style -> Style
f Styled
t1) ((Style -> Style) -> Styled -> Styled
mapStyle Style -> Style
f Styled
t2)
mapStyle Style -> Style
f (Styled Style
style Text
t) = Style -> Text -> Styled
Styled (Style -> Style
f Style
style) Text
t

print :: Styled -> IO ()
print :: Styled -> IO ()
print = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ByteString -> IO ()
ByteString.putStr forall b c a. (b -> c) -> (a -> b) -> a -> c
. Styled -> [ByteString]
toByteStrings

printLn :: Styled -> IO ()
printLn :: Styled -> IO ()
printLn Styled
s = Styled -> IO ()
print (Styled
s forall a. Semigroup a => a -> a -> a
<> Styled
"\n")

toByteString :: Styled -> ByteString
toByteString :: Styled -> ByteString
toByteString = forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. Styled -> [ByteString]
toByteStrings

toByteStrings :: Styled -> [ByteString]
toByteStrings :: Styled -> [ByteString]
toByteStrings = forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/=ByteString
"") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([SGR], Text) -> [ByteString]
render forall b c a. (b -> c) -> (a -> b) -> a -> c
. Styled -> [([SGR], Text)]
toSGRs
    where
    render :: ([SGR], Text) -> [ByteString]
render ([SGR]
sgrs, Text
text) =
        [ if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SGR]
sgrs then ByteString
"" else String -> ByteString
ByteString.pack ([SGR] -> String
ANSI.setSGRCode [SGR]
sgrs)
        , Text -> ByteString
Encoding.encodeUtf8 Text
text
        ]

toText :: Styled -> Text
toText :: Styled -> Text
toText = forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. Styled -> [Text]
toTexts

toTexts :: Styled -> [Text]
toTexts :: Styled -> [Text]
toTexts = forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/=Text
"") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([SGR], Text) -> [Text]
render forall b c a. (b -> c) -> (a -> b) -> a -> c
. Styled -> [([SGR], Text)]
toSGRs
    where
    render :: ([SGR], Text) -> [Text]
render ([SGR]
sgrs, Text
text)
        | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SGR]
sgrs = [Text
text]
        | Bool
otherwise = [String -> Text
Text.pack ([SGR] -> String
ANSI.setSGRCode [SGR]
sgrs), Text
text]

-- | Render in order, but only emit escape codes if the Style changed.
toSGRs :: Styled -> [([ANSI.SGR], Text)]
toSGRs :: Styled -> [([SGR], Text)]
toSGRs = forall a b. (a -> b) -> [b] -> [a] -> [b]
Then.map forall {b} {b}. ((Style, b), (Style, b)) -> ([SGR], b)
render1 [([SGR
ANSI.Reset], Text
"")] forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {b}. b -> [b] -> [(b, b)]
zipPrev (forall a. Monoid a => a
mempty, Text
"") forall b c a. (b -> c) -> (a -> b) -> a -> c
. Styled -> [(Style, Text)]
toList
    where
    render1 :: ((Style, b), (Style, b)) -> ([SGR], b)
render1 ((Style
prevStyle, b
_), (Style
style, b
text)) =
        (if Style
prevStyle forall a. Eq a => a -> a -> Bool
== Style
style then [] else Style -> [SGR]
styleSGR Style
style, b
text)
    zipPrev :: b -> [b] -> [(b, b)]
zipPrev b
fst [b]
xs = forall a b. [a] -> [b] -> [(a, b)]
zip (b
fst forall a. a -> [a] -> [a]
: [b]
xs) [b]
xs

toList :: Styled -> [(Style, Text)]
toList :: Styled -> [(Style, Text)]
toList Styled
xs = Styled -> [(Style, Text)] -> [(Style, Text)]
go Styled
xs []
    where
    go :: Styled -> [(Style, Text)] -> [(Style, Text)]
go (Branch Styled
as Styled
bs) [(Style, Text)]
xs = Styled -> [(Style, Text)] -> [(Style, Text)]
go Styled
as (Styled -> [(Style, Text)] -> [(Style, Text)]
go Styled
bs [(Style, Text)]
xs)
    go (Styled Style
style Text
text) [(Style, Text)]
xs = (Style
style, Text
text) forall a. a -> [a] -> [a]
: [(Style, Text)]
xs

styleSGR :: Style -> [ANSI.SGR]
styleSGR :: Style -> [SGR]
styleSGR (Style Maybe Color
fg Maybe Color
bg Bool
bold Bool
underline) = SGR
ANSI.Reset forall a. a -> [a] -> [a]
: forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ case Maybe Color
fg of
        Maybe Color
Nothing -> []
        Just (Ansi (AnsiColor ColorIntensity
intensity Color
color)) ->
            [ConsoleLayer -> ColorIntensity -> Color -> SGR
ANSI.SetColor ConsoleLayer
ANSI.Foreground ColorIntensity
intensity Color
color]
        Just (Rgb (RgbColor Colour Float
color)) -> [ConsoleLayer -> Colour Float -> SGR
ANSI.SetRGBColor ConsoleLayer
ANSI.Foreground Colour Float
color]
    , case Maybe Color
bg of
        Maybe Color
Nothing -> []
        Just (Ansi (AnsiColor ColorIntensity
intensity Color
color)) ->
            [ConsoleLayer -> ColorIntensity -> Color -> SGR
ANSI.SetColor ConsoleLayer
ANSI.Background ColorIntensity
intensity Color
color]
        Just (Rgb (RgbColor Colour Float
color)) -> [ConsoleLayer -> Colour Float -> SGR
ANSI.SetRGBColor ConsoleLayer
ANSI.Background Colour Float
color]
    , [ConsoleIntensity -> SGR
ANSI.SetConsoleIntensity ConsoleIntensity
ANSI.BoldIntensity | Bool
bold]
    , [Underlining -> SGR
ANSI.SetUnderlining Underlining
ANSI.SingleUnderline | Bool
underline]
    ]

data Style = Style {
    Style -> Maybe Color
_foreground :: !(Maybe Color)
    , Style -> Maybe Color
_background :: !(Maybe Color)
    , Style -> Bool
_bold :: !Bool
    , Style -> Bool
_underline :: !Bool
    } deriving (Style -> Style -> Bool
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, Int -> Style -> ShowS
[Style] -> ShowS
Style -> String
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)

-- | Left side overrides the right side, for consistency with other Semigroups.
instance Semigroup Style where
    Style Maybe Color
fg1 Maybe Color
bg1 Bool
bold1 Bool
underline1 <> :: Style -> Style -> Style
<> Style Maybe Color
fg2 Maybe Color
bg2 Bool
bold2 Bool
underline2 =
        Maybe Color -> Maybe Color -> Bool -> Bool -> Style
Style (Maybe Color
fg1 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Color
fg2) (Maybe Color
bg1 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Color
bg2)
            (Bool
bold1 Bool -> Bool -> Bool
|| Bool
bold2) (Bool
underline1 Bool -> Bool -> Bool
|| Bool
underline2)

instance Monoid Style where
    mempty :: Style
mempty = Style
        { _foreground :: Maybe Color
_foreground = forall a. Maybe a
Nothing
        , _background :: Maybe Color
_background = forall a. Maybe a
Nothing
        , _bold :: Bool
_bold = Bool
False
        , _underline :: Bool
_underline = Bool
False
        }
    mappend :: Style -> Style -> Style
mappend = forall a. Semigroup a => a -> a -> a
(<>)

data Color = Ansi !AnsiColor | Rgb !RgbColor
    deriving (Color -> Color -> Bool
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, Int -> Color -> ShowS
[Color] -> ShowS
Color -> String
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 AnsiColor = AnsiColor !ANSI.ColorIntensity !ANSI.Color
    deriving (AnsiColor -> AnsiColor -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AnsiColor -> AnsiColor -> Bool
$c/= :: AnsiColor -> AnsiColor -> Bool
== :: AnsiColor -> AnsiColor -> Bool
$c== :: AnsiColor -> AnsiColor -> Bool
Eq, Int -> AnsiColor -> ShowS
[AnsiColor] -> ShowS
AnsiColor -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AnsiColor] -> ShowS
$cshowList :: [AnsiColor] -> ShowS
show :: AnsiColor -> String
$cshow :: AnsiColor -> String
showsPrec :: Int -> AnsiColor -> ShowS
$cshowsPrec :: Int -> AnsiColor -> ShowS
Show)

data RgbColor = RgbColor !(Colour.Colour Float)
    deriving (RgbColor -> RgbColor -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RgbColor -> RgbColor -> Bool
$c/= :: RgbColor -> RgbColor -> Bool
== :: RgbColor -> RgbColor -> Bool
$c== :: RgbColor -> RgbColor -> Bool
Eq, Int -> RgbColor -> ShowS
[RgbColor] -> ShowS
RgbColor -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RgbColor] -> ShowS
$cshowList :: [RgbColor] -> ShowS
show :: RgbColor -> String
$cshow :: RgbColor -> String
showsPrec :: Int -> RgbColor -> ShowS
$cshowsPrec :: Int -> RgbColor -> ShowS
Show)

black, red, green, yellow, blue, magenta, cyan, white :: Color
(Color
black, Color
red, Color
green, Color
yellow, Color
blue, Color
magenta, Color
cyan, Color
white) =
    ( Color -> Color
c Color
ANSI.Black, Color -> Color
c Color
ANSI.Red, Color -> Color
c Color
ANSI.Green, Color -> Color
c Color
ANSI.Yellow, Color -> Color
c Color
ANSI.Blue
    , Color -> Color
c Color
ANSI.Magenta, Color -> Color
c Color
ANSI.Cyan, Color -> Color
c Color
ANSI.White
    )
    where c :: Color -> Color
c = AnsiColor -> Color
Ansi forall b c a. (b -> c) -> (a -> b) -> a -> c
. ColorIntensity -> Color -> AnsiColor
AnsiColor ColorIntensity
ANSI.Dull

rgb :: Float -> Float -> Float -> Color
rgb :: Float -> Float -> Float -> Color
rgb Float
r Float
g Float
b = RgbColor -> Color
Rgb forall a b. (a -> b) -> a -> b
$ Float -> Float -> Float -> RgbColor
rgbColor Float
r Float
g Float
b

rgbGray :: Float -> Color
rgbGray :: Float -> Color
rgbGray Float
n = Float -> Float -> Float -> Color
rgb Float
n Float
n Float
n

rgbColor :: Float -> Float -> Float -> RgbColor
rgbColor :: Float -> Float -> Float -> RgbColor
rgbColor Float
r Float
g Float
b = Colour Float -> RgbColor
RgbColor forall a b. (a -> b) -> a -> b
$ forall b. (Ord b, Floating b) => b -> b -> b -> Colour b
SRGB.sRGB Float
r Float
g Float
b

toRgb :: RgbColor -> (Float, Float, Float)
toRgb :: RgbColor -> (Float, Float, Float)
toRgb (RgbColor Colour Float
c) = (Float
r, Float
g, Float
b)
    where (SRGB.RGB Float
r Float
g Float
b) = forall b. (Ord b, Floating b) => Colour b -> RGB b
SRGB.toSRGB Colour Float
c

styled :: ToStyled a => Style -> a -> Styled
styled :: forall a. ToStyled a => Style -> a -> Styled
styled Style
style = (Style -> Style) -> Styled -> Styled
mapStyle (Style
style<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToStyled a => a -> Styled
toStyled

plain :: Text -> Styled
plain :: Text -> Styled
plain = Style -> Text -> Styled
Styled forall a. Monoid a => a
mempty

bright :: Color -> Color
bright :: Color -> Color
bright (Ansi (AnsiColor ColorIntensity
_ Color
color)) = AnsiColor -> Color
Ansi forall a b. (a -> b) -> a -> b
$ ColorIntensity -> Color -> AnsiColor
AnsiColor ColorIntensity
ANSI.Vivid Color
color
bright (Rgb (RgbColor Colour Float
color)) =
    RgbColor -> Color
Rgb forall a b. (a -> b) -> a -> b
$ Colour Float -> RgbColor
RgbColor forall a b. (a -> b) -> a -> b
$ forall a (f :: * -> *).
(Num a, AffineSpace f) =>
a -> f a -> f a -> f a
Colour.blend Float
0.5 Colour Float
color forall a. (Ord a, Floating a) => Colour a
Colour.Names.white

fgs, bgs :: Color -> Styled -> Styled
fgs :: Color -> Styled -> Styled
fgs Color
color = (Style -> Style) -> Styled -> Styled
mapStyle (\Style
style -> Style
style { _foreground :: Maybe Color
_foreground = forall a. a -> Maybe a
Just Color
color })
bgs :: Color -> Styled -> Styled
bgs Color
color = (Style -> Style) -> Styled -> Styled
mapStyle (\Style
style -> Style
style { _background :: Maybe Color
_background = forall a. a -> Maybe a
Just Color
color })

fg, bg :: ToStyled a => Color -> a -> Styled
fg :: forall a. ToStyled a => Color -> a -> Styled
fg Color
color = Color -> Styled -> Styled
fgs Color
color forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToStyled a => a -> Styled
toStyled
bg :: forall a. ToStyled a => Color -> a -> Styled
bg Color
color = Color -> Styled -> Styled
bgs Color
color forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToStyled a => a -> Styled
toStyled

bolds, underlines :: Styled -> Styled
bolds :: Styled -> Styled
bolds = (Style -> Style) -> Styled -> Styled
mapStyle (\Style
style -> Style
style { _bold :: Bool
_bold = Bool
True })
underlines :: Styled -> Styled
underlines = (Style -> Style) -> Styled -> Styled
mapStyle (\Style
style -> Style
style { _underline :: Bool
_underline = Bool
True })

bold, underline :: ToStyled a => a -> Styled
bold :: forall a. ToStyled a => a -> Styled
bold = Styled -> Styled
bolds forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToStyled a => a -> Styled
toStyled
underline :: forall a. ToStyled a => a -> Styled
underline = Styled -> Styled
underlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToStyled a => a -> Styled
toStyled

-- * text util

join :: Styled -> [Styled] -> Styled
join :: Styled -> [Styled] -> Styled
join Styled
sep = forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> [a] -> [a]
List.intersperse Styled
sep


-- * html

toHtml :: Styled -> Html.Html
toHtml :: Styled -> Html
toHtml = forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. Styled -> [Html]
toHtmls

toHtmls :: Styled -> [Html.Html]
toHtmls :: Styled -> [Html]
toHtmls = forall a b. (a -> b) -> [a] -> [b]
map (Style, [Text]) -> Html
fmt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Eq a => [(a, b)] -> [(a, [b])]
groupFst forall b c a. (b -> c) -> (a -> b) -> a -> c
. Styled -> [(Style, Text)]
toList
    where fmt :: (Style, [Text]) -> Html
fmt (Style
style, [Text]
texts) = Style -> Html -> Html
styleHtml Style
style (Text -> Html
Html.html (forall a. Monoid a => [a] -> a
mconcat [Text]
texts))

styleHtml :: Style -> Html.Html -> Html.Html
styleHtml :: Style -> Html -> Html
styleHtml (Style Maybe Color
fg Maybe Color
bg Bool
bold Bool
underline) = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) forall a. a -> a
id forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$
    [ case forall a. [Maybe a] -> [a]
Maybe.catMaybes [(Text
"color:",)forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>Maybe Color
fg, (Text
"background-color:",) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Color
bg] of
        [] -> []
        [(Text, Color)]
pairs -> [Text -> Html -> Html
spanStyle (Text -> [Text] -> Text
Text.intercalate Text
";" [Text]
css)]
            where css :: [Text]
css = [Text
name forall a. Semigroup a => a -> a -> a
<> Color -> Text
colorHtml Color
c | (Text
name, Color
c) <- [(Text, Color)]
pairs]
    , [Text -> Html -> Html
Html.tag Text
"b" | Bool
bold]
    , [Text -> Html -> Html
Html.tag Text
"u" | Bool
underline]
    ]

spanStyle :: Text -> Html.Html -> Html.Html
spanStyle :: Text -> Html -> Html
spanStyle Text
style = Text -> [(Text, Text)] -> Maybe Html -> Html
Html.tag_attrs Text
"span" [(Text
"style", Text
style)] forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just

colorHtml :: Color -> Text
colorHtml :: Color -> Text
colorHtml = \case
    Ansi AnsiColor
color -> AnsiColor -> Text
ansiHtml AnsiColor
color
    Rgb RgbColor
color -> RgbColor -> Text
rgbHtml RgbColor
color

rgbHtml :: RgbColor -> Text
rgbHtml :: RgbColor -> Text
rgbHtml RgbColor
color = forall a. Monoid a => [a] -> a
mconcat [Text
"#", Float -> Text
hex Float
r, Float -> Text
hex Float
g, Float -> Text
hex Float
b]
    where
    hex :: Float -> Text
hex = forall a. (Integral a, Show a) => Int -> a -> Text
Num.hex Int
2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => a -> a -> a -> a
Num.clamp Int
0 Int
255 forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a b. (RealFrac a, Integral b) => a -> b
round :: Float -> Int) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Num a => a -> a -> a
*Float
255)
    (Float
r, Float
g, Float
b) = RgbColor -> (Float, Float, Float)
toRgb RgbColor
color

ansiHtml :: AnsiColor -> Text
ansiHtml :: AnsiColor -> Text
ansiHtml (AnsiColor ColorIntensity
intensity Color
color) = case (ColorIntensity
intensity, Color
color) of
    (ColorIntensity
ANSI.Dull, Color
ANSI.Black) -> Text
"black"
    (ColorIntensity
ANSI.Vivid, Color
ANSI.Black) -> Text
"darkgray"
    (ColorIntensity, Color)
_ -> Text
cdark forall a. Semigroup a => a -> a -> a
<> Text
cname
    where
    cname :: Text
cname = String -> Text
Text.pack forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
Char.toLower forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Color
color
    cdark :: Text
cdark = case ColorIntensity
intensity of
        ColorIntensity
ANSI.Dull -> Text
"dark"
        ColorIntensity
ANSI.Vivid -> Text
""

-- | Group adjacent by fst.
groupFst :: Eq a => [(a, b)] -> [(a, [b])]
groupFst :: forall a b. Eq a => [(a, b)] -> [(a, [b])]
groupFst =  forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall key a. Eq key => (a -> key) -> [a] -> [(key, [a])]
Lists.keyedGroupAdjacent forall a b. (a, b) -> a
fst