module Network.IRC.Fun.Color.Style
(
Color (..)
, Decoration (..)
, (#>)
, (<#)
, plain
, fmt
, fg
, bg
, fgBg
, encode
, Style (..)
, StyledText ()
, FgBg ()
, RGB (..)
, toIrcRGB
, toTangoRGB
, strip
)
where
import Data.Char (isDigit)
import Data.Foldable (foldr)
import Data.List (nub)
import Data.Monoid
import Data.String (IsString (..))
import Formatting.Internal (Format (..))
import Prelude hiding (foldr)
import TextShow (showt)
import qualified Data.DList as D
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL (toStrict)
import qualified Data.Text.Lazy.Builder as TLB (toLazyText)
class Style s where
style :: s -> StyledText -> StyledText
data Color
= White
| Black
| Navy
| Green
| Red
| Maroon
| Purple
| Orange
| Yellow
| Lime
| Teal
| Cyan
| Blue
| Magenta
| Gray
| Silver
deriving (Enum, Eq, Show)
data RGB a = RGB a a a deriving (Eq, Show)
data Decoration
= Bold
| Italic
| Underline
| Reverse
deriving (Eq, Show)
data StyledText
= Pure T.Text
| Colored (Maybe Color) (Maybe Color) StyledText
| Decorated Decoration StyledText
| Concat (D.DList StyledText)
deriving Show
data StyledChunk = StyledChunk FgBg [Decoration] T.Text deriving Show
data FgBg = FgBg (Maybe Color) (Maybe Color) deriving (Eq, Show)
mappend' :: StyledText -> StyledText -> StyledText
mappend' (Concat l) (Concat m) = Concat $ l <> m
mappend' str (Concat l) = Concat $ str `D.cons` l
mappend' (Concat l) str = Concat $ l `D.snoc` str
mappend' s t = Concat $ D.singleton s `D.snoc` t
instance Monoid StyledText where
mempty = Pure mempty
mappend = mappend'
instance IsString StyledText where
fromString = Pure . fromString
instance Style Color where
style color = Colored (Just color) Nothing
instance Style FgBg where
style (FgBg f b) = Colored f b
instance Style Decoration where
style = Decorated
(#>) :: Style s => s -> StyledText -> StyledText
(#>) = style
infixr 7 #>
(<#) :: Style s => StyledText -> s -> StyledText
(<#) = flip style
infixl 7 <#
plain :: T.Text -> StyledText
plain = Pure
fmt :: Format StyledText a -> a
fmt m = runFormat m (Pure . TL.toStrict . TLB.toLazyText)
fg :: Color -> FgBg
fg color = FgBg (Just color) Nothing
bg :: Color -> FgBg
bg color = FgBg Nothing (Just color)
fgBg :: Color -> Color -> FgBg
fgBg f b = FgBg (Just f) (Just b)
colorNumber :: Color -> Int
colorNumber = fromEnum
toIrcRGB :: Num a => Color -> RGB a
toIrcRGB White = RGB 0xff 0xff 0xff
toIrcRGB Black = RGB 0x00 0x00 0x00
toIrcRGB Navy = RGB 0x00 0x00 0x7f
toIrcRGB Green = RGB 0x00 0x93 0x00
toIrcRGB Red = RGB 0xff 0x00 0x00
toIrcRGB Maroon = RGB 0x7f 0x00 0x00
toIrcRGB Purple = RGB 0x9c 0x00 0x9c
toIrcRGB Orange = RGB 0xfc 0x7f 0x00
toIrcRGB Yellow = RGB 0xff 0xff 0x00
toIrcRGB Lime = RGB 0x00 0xfc 0x00
toIrcRGB Teal = RGB 0x00 0x93 0x93
toIrcRGB Cyan = RGB 0x00 0xff 0xff
toIrcRGB Blue = RGB 0x00 0x00 0xfc
toIrcRGB Magenta = RGB 0xff 0x00 0xff
toIrcRGB Gray = RGB 0x7f 0x7f 0x7f
toIrcRGB Silver = RGB 0xd2 0xd2 0xd2
toTangoRGB :: Num a => Color -> RGB a
toTangoRGB White = RGB 0xee 0xee 0xec
toTangoRGB Black = RGB 0x00 0x00 0x00
toTangoRGB Navy = RGB 0x34 0x65 0xa4
toTangoRGB Green = RGB 0x4e 0x9a 0x06
toTangoRGB Red = RGB 0xef 0x29 0x29
toTangoRGB Maroon = RGB 0xcc 0x00 0x00
toTangoRGB Purple = RGB 0x75 0x50 0x7b
toTangoRGB Orange = RGB 0xc4 0xa0 0x00
toTangoRGB Yellow = RGB 0xfc 0xe9 0x4f
toTangoRGB Lime = RGB 0x8a 0xe2 0x34
toTangoRGB Teal = RGB 0x06 0x98 0x9a
toTangoRGB Cyan = RGB 0x34 0xe2 0xe2
toTangoRGB Blue = RGB 0x73 0x9f 0xcf
toTangoRGB Magenta = RGB 0xad 0x7f 0xa8
toTangoRGB Gray = RGB 0x55 0x57 0x53
toTangoRGB Silver = RGB 0xd3 0xd7 0xcf
decoCode :: Decoration -> Char
decoCode Bold = '\x02'
decoCode Italic = '\x1d'
decoCode Underline = '\x1f'
decoCode Reverse = '\x16'
colorChar :: Char
colorChar = '\x03'
colorCode :: Maybe Color -> Maybe Color -> T.Text
colorCode Nothing Nothing = T.empty
colorCode (Just f) Nothing = colorChar `T.cons` showt (colorNumber f)
colorCode Nothing (Just b) =
colorChar `T.cons` ',' `T.cons` showt (colorNumber b)
colorCode (Just f) (Just b) = T.concat
[ T.singleton colorChar
, showt (colorNumber f)
, T.singleton ','
, showt (colorNumber b)
]
applyColor
:: Maybe Color
-> Maybe Color
-> D.DList StyledChunk
-> D.DList StyledChunk
applyColor f' b' = fmap h
where
g Nothing (Just c) = Just c
g curr _ = curr
h (StyledChunk (FgBg f b) d s) = StyledChunk (FgBg (g f f') (g b b')) d s
applyDeco :: Decoration -> D.DList StyledChunk -> D.DList StyledChunk
applyDeco dec = fmap h
where
g ds d = if d `elem` ds then ds else d : ds
h (StyledChunk c ds s) = StyledChunk c (g ds dec) s
flatten :: StyledText -> D.DList StyledChunk
flatten (Pure t) = D.singleton $ StyledChunk (FgBg Nothing Nothing) [] t
flatten (Colored f b s) = applyColor f b $ flatten s
flatten (Decorated d s) = applyDeco d $ flatten s
flatten (Concat ss) = foldr (\ q qs -> flatten q <> qs) D.empty ss
protect :: T.Text -> T.Text
protect t =
case T.uncons t of
Nothing -> T.empty
Just (d, _) ->
if isDigit d
then decoCode Bold `T.cons` decoCode Bold `T.cons` t
else t
encodeColor :: Maybe Color -> Maybe Color -> T.Text -> T.Text
encodeColor Nothing Nothing t = t
encodeColor f b t = colorCode f b <> protect t `T.snoc` colorChar
encodeDeco :: [Decoration] -> T.Text -> T.Text
encodeDeco ds s = foldl f s $ nub ds
where
f s' d = let c = decoCode d in c `T.cons` s' `T.snoc` c
encode :: StyledText -> T.Text
encode = foldr (\ sc t -> g sc <> t) T.empty . flatten
where
g (StyledChunk (FgBg f b) ds s) = encodeDeco ds $ encodeColor f b s
strip :: StyledText -> T.Text
strip (Pure s) = s
strip (Colored _ _ s) = strip s
strip (Decorated _ s) = strip s
strip (Concat l) = foldr (\ st t -> strip st <> t) T.empty l