-- 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.Seq as Seq
import qualified Util.Then as Then


data Styled = Branch Styled Styled | Styled !Style !Text
    deriving (Styled -> Styled -> Bool
(Styled -> Styled -> Bool)
-> (Styled -> Styled -> Bool) -> Eq Styled
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
(Int -> Styled -> ShowS)
-> (Styled -> String) -> ([Styled] -> ShowS) -> Show Styled
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 Style
forall a. Monoid a => a
mempty Text
""
    mappend :: Styled -> Styled -> Styled
mappend = Styled -> Styled -> Styled
forall a. Semigroup a => a -> a -> a
(<>)

instance String.IsString Styled where
    fromString :: String -> Styled
fromString = Style -> Text -> Styled
Styled Style
forall a. Monoid a => a
mempty (Text -> Styled) -> (String -> Text) -> String -> Styled
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
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 Style
forall a. Monoid a => a
mempty
instance ToStyled Styled where toStyled :: Styled -> Styled
toStyled = Styled -> Styled
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 = (ByteString -> IO ()) -> [ByteString] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ByteString -> IO ()
ByteString.putStr ([ByteString] -> IO ())
-> (Styled -> [ByteString]) -> Styled -> IO ()
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 Styled -> Styled -> Styled
forall a. Semigroup a => a -> a -> a
<> Styled
"\n")

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

toByteStrings :: Styled -> [ByteString]
toByteStrings :: Styled -> [ByteString]
toByteStrings = (ByteString -> Bool) -> [ByteString] -> [ByteString]
forall a. (a -> Bool) -> [a] -> [a]
filter (ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/=ByteString
"") ([ByteString] -> [ByteString])
-> (Styled -> [ByteString]) -> Styled -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([SGR], Text) -> [ByteString]) -> [([SGR], Text)] -> [ByteString]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([SGR], Text) -> [ByteString]
render ([([SGR], Text)] -> [ByteString])
-> (Styled -> [([SGR], Text)]) -> Styled -> [ByteString]
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 [SGR] -> Bool
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 = [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ([Text] -> Text) -> (Styled -> [Text]) -> Styled -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Styled -> [Text]
toTexts

toTexts :: Styled -> [Text]
toTexts :: Styled -> [Text]
toTexts = (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/=Text
"") ([Text] -> [Text]) -> (Styled -> [Text]) -> Styled -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([SGR], Text) -> [Text]) -> [([SGR], Text)] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([SGR], Text) -> [Text]
render ([([SGR], Text)] -> [Text])
-> (Styled -> [([SGR], Text)]) -> Styled -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Styled -> [([SGR], Text)]
toSGRs
    where
    render :: ([SGR], Text) -> [Text]
render ([SGR]
sgrs, Text
text)
        | [SGR] -> Bool
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 = (((Style, Text), (Style, Text)) -> ([SGR], Text))
-> [([SGR], Text)]
-> [((Style, Text), (Style, Text))]
-> [([SGR], Text)]
forall a b. (a -> b) -> [b] -> [a] -> [b]
Then.map ((Style, Text), (Style, Text)) -> ([SGR], Text)
forall {b} {b}. ((Style, b), (Style, b)) -> ([SGR], b)
render1 [([SGR
ANSI.Reset], Text
"")] ([((Style, Text), (Style, Text))] -> [([SGR], Text)])
-> (Styled -> [((Style, Text), (Style, Text))])
-> Styled
-> [([SGR], Text)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Style, Text)
-> [(Style, Text)] -> [((Style, Text), (Style, Text))]
forall {b}. b -> [b] -> [(b, b)]
zipPrev (Style
forall a. Monoid a => a
mempty, Text
"") ([(Style, Text)] -> [((Style, Text), (Style, Text))])
-> (Styled -> [(Style, Text)])
-> Styled
-> [((Style, Text), (Style, 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 Style -> Style -> Bool
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 = [b] -> [b] -> [(b, b)]
forall a b. [a] -> [b] -> [(a, b)]
zip (b
fst b -> [b] -> [b]
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) (Style, Text) -> [(Style, Text)] -> [(Style, 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 SGR -> [SGR] -> [SGR]
forall a. a -> [a] -> [a]
: [[SGR]] -> [SGR]
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
(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, 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)

-- | 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 Maybe Color -> Maybe Color -> Maybe Color
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Color
fg2) (Maybe Color
bg1 Maybe Color -> Maybe Color -> Maybe Color
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 = Maybe Color
forall a. Maybe a
Nothing
        , _background :: Maybe Color
_background = Maybe Color
forall a. Maybe a
Nothing
        , _bold :: Bool
_bold = Bool
False
        , _underline :: Bool
_underline = Bool
False
        }
    mappend :: Style -> Style -> Style
mappend = Style -> Style -> Style
forall a. Semigroup a => a -> a -> a
(<>)

data Color = Ansi !AnsiColor | Rgb !RgbColor
    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, 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 AnsiColor = AnsiColor !ANSI.ColorIntensity !ANSI.Color
    deriving (AnsiColor -> AnsiColor -> Bool
(AnsiColor -> AnsiColor -> Bool)
-> (AnsiColor -> AnsiColor -> Bool) -> Eq AnsiColor
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
(Int -> AnsiColor -> ShowS)
-> (AnsiColor -> String)
-> ([AnsiColor] -> ShowS)
-> Show AnsiColor
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
(RgbColor -> RgbColor -> Bool)
-> (RgbColor -> RgbColor -> Bool) -> Eq RgbColor
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
(Int -> RgbColor -> ShowS)
-> (RgbColor -> String) -> ([RgbColor] -> ShowS) -> Show RgbColor
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 (AnsiColor -> Color) -> (Color -> AnsiColor) -> Color -> Color
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 (RgbColor -> Color) -> RgbColor -> Color
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 (Colour Float -> RgbColor) -> Colour Float -> RgbColor
forall a b. (a -> b) -> a -> b
$ Float -> Float -> Float -> Colour Float
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) = Colour Float -> RGB Float
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<>) (Styled -> Styled) -> (a -> Styled) -> a -> Styled
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Styled
forall a. ToStyled a => a -> Styled
toStyled

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

bright :: Color -> Color
bright :: Color -> Color
bright (Ansi (AnsiColor ColorIntensity
_ Color
color)) = AnsiColor -> Color
Ansi (AnsiColor -> Color) -> AnsiColor -> Color
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 (RgbColor -> Color) -> RgbColor -> Color
forall a b. (a -> b) -> a -> b
$ Colour Float -> RgbColor
RgbColor (Colour Float -> RgbColor) -> Colour Float -> RgbColor
forall a b. (a -> b) -> a -> b
$ Float -> Colour Float -> Colour Float -> Colour Float
forall a (f :: * -> *).
(Num a, AffineSpace f) =>
a -> f a -> f a -> f a
Colour.blend Float
0.5 Colour Float
color Colour Float
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 = Color -> Maybe Color
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 = Color -> Maybe Color
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 (Styled -> Styled) -> (a -> Styled) -> a -> Styled
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Styled
forall a. ToStyled a => a -> Styled
toStyled
bg :: forall a. ToStyled a => Color -> a -> Styled
bg Color
color = Color -> Styled -> Styled
bgs Color
color (Styled -> Styled) -> (a -> Styled) -> a -> Styled
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Styled
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 (Styled -> Styled) -> (a -> Styled) -> a -> Styled
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Styled
forall a. ToStyled a => a -> Styled
toStyled
underline :: forall a. ToStyled a => a -> Styled
underline = Styled -> Styled
underlines (Styled -> Styled) -> (a -> Styled) -> a -> Styled
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Styled
forall a. ToStyled a => a -> Styled
toStyled

-- * text util

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


-- * html

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

toHtmls :: Styled -> [Html.Html]
toHtmls :: Styled -> [Html]
toHtmls = ((Style, [Text]) -> Html) -> [(Style, [Text])] -> [Html]
forall a b. (a -> b) -> [a] -> [b]
map (Style, [Text]) -> Html
fmt ([(Style, [Text])] -> [Html])
-> (Styled -> [(Style, [Text])]) -> Styled -> [Html]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Style, Text)] -> [(Style, [Text])]
forall a b. Eq a => [(a, b)] -> [(a, [b])]
groupFst ([(Style, Text)] -> [(Style, [Text])])
-> (Styled -> [(Style, Text)]) -> Styled -> [(Style, [Text])]
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 ([Text] -> Text
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) = ((Html -> Html) -> (Html -> Html) -> Html -> Html)
-> (Html -> Html) -> [Html -> Html] -> Html -> Html
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Html -> Html) -> (Html -> Html) -> Html -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) Html -> Html
forall a. a -> a
id ([Html -> Html] -> Html -> Html)
-> ([[Html -> Html]] -> [Html -> Html])
-> [[Html -> Html]]
-> Html
-> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Html -> Html]] -> [Html -> Html]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Html -> Html]] -> Html -> Html)
-> [[Html -> Html]] -> Html -> Html
forall a b. (a -> b) -> a -> b
$
    [ case [Maybe (Text, Color)] -> [(Text, Color)]
forall a. [Maybe a] -> [a]
Maybe.catMaybes [(Text
"color:",)(Color -> (Text, Color)) -> Maybe Color -> Maybe (Text, Color)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>Maybe Color
fg, (Text
"background-color:",) (Color -> (Text, Color)) -> Maybe Color -> Maybe (Text, 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 Text -> Text -> Text
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)] (Maybe Html -> Html) -> (Html -> Maybe Html) -> Html -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html -> Maybe Html
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 = [Text] -> Text
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 = Int -> Int -> Text
forall a. (Integral a, Show a) => Int -> a -> Text
Num.hex Int
2 (Int -> Text) -> (Float -> Int) -> Float -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> Int -> Int
forall a. Ord a => a -> a -> a -> a
Num.clamp Int
0 Int
255 (Int -> Int) -> (Float -> Int) -> Float -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Float -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round :: Float -> Int) (Float -> Int) -> (Float -> Float) -> Float -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Float -> Float -> Float
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 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
cname
    where
    cname :: Text
cname = String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
Char.toLower ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Color -> String
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 =  ((a, [(a, b)]) -> (a, [b])) -> [(a, [(a, b)])] -> [(a, [b])]
forall a b. (a -> b) -> [a] -> [b]
map (([(a, b)] -> [b]) -> (a, [(a, b)]) -> (a, [b])
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (((a, b) -> b) -> [(a, b)] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map (a, b) -> b
forall a b. (a, b) -> b
snd)) ([(a, [(a, b)])] -> [(a, [b])])
-> ([(a, b)] -> [(a, [(a, b)])]) -> [(a, b)] -> [(a, [b])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, b) -> a) -> [(a, b)] -> [(a, [(a, b)])]
forall key a. Eq key => (a -> key) -> [a] -> [(key, [a])]
Seq.keyed_group_adjacent (a, b) -> a
forall a b. (a, b) -> a
fst