{- This file is part of irc-fun-color. - - Written in 2015 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - - The author(s) have dedicated all copyright and related and neighboring - rights to this software to the public domain worldwide. This software is - distributed without any warranty. - - You should have received a copy of the CC0 Public Domain Dedication along - with this software. If not, see - . -} -- | This module allows you to add color and style to IRC text messages. -- Decoding style-encoded messages isn't implemented currently. -- -- Building styled strings is done in two steps: -- -- (1) Construct the string using combinators -- (2) Encode it into the IRC message styling format -- -- The result you get is a style-encoded 'String' which you can send as an IRC -- message (e.g. using PRIVMSG). -- -- The combinators are: -- -- * '(#>)', '(<#)' : Apply a style to a styled string -- * '(<>)' : Styles strings are monoids, use '(<>)' to concatenate them -- -- The tools for choosing styles for application are: -- -- * 'Color' : Choose a (foreground) color -- * 'Decoration' : Choose a decoration style, e.g. bold or underline -- * 'fg' : Choose a foreground color, you can use the 'Color' itself directly -- * 'bg' : Choose background color -- * 'fgBg' : Choose both colors -- -- Once you build the styled string, use 'encode' to obtain an encoded 'String' -- for use in IRC. -- -- Here are some examples. I assume here the @OverloadedStrings@ extension is -- enabled. If you prefer not to use it, you'll need to directly apply -- 'Pure' or 'fromString' to 'String's before styling (e.g. with '(#>)'). -- -- Green text: -- -- > Green #> "hello beautiful world" -- -- The same, but without the extension mentioned above: -- -- > Green #> Pure "hello beautiful world" -- -- Bold text: -- -- > Bold #> "hello beautiful world" -- -- Green text with some underlined text in the middle: -- -- > Green #> ("hello " <> Underline #> "beautiful" <> " world") -- -- Red text on gray background: -- -- > Red `fgBg` Gray #> "hello beautiful world" -- -- Text with a red underlined part in the middle, and the whole string with -- blue background: -- -- > ("hello " <> Red #> Underline #> "beaufitul" <> " world") <# bg Blue -- -- Three letters. The first is lime-on-black and bold. The second is -- black-on-line. The third is again lime-on-black, and italicized: -- -- > Lime `fgBg` Black #> (Bold #> "A" <> Reverse #> "B" <> Italic #> "C") -- -- Bold, underlined purple-on-white text: -- -- > Bold #> Underline #> Purple `fgBg` White #> "hello beautiful world" module Network.IRC.Fun.Color ( -- * Primary Toolkit Color (..) , Decoration (..) , (#>) , (<#) , fg , bg , fgBg , encode -- * Underlying Types , Style (..) , StyledString (..) , FgBg (..) -- * Utilities , RGB (..) , toIrcRGB , toTangoRGB , strip ) where import Data.List (nub) import Data.Monoid import Data.String (IsString (..)) {- TODO check out packages irc-colors, rainbow, colour, palette, color -} ------------------------------------------------------------------------------- -- Classes ------------------------------------------------------------------------------- -- | A class for types which add style formatting to a string. This is what -- makes '(#>)' and '(<#)' work. class Style s where style :: s -> StyledString -> StyledString ------------------------------------------------------------------------------- -- Types ------------------------------------------------------------------------------- -- | One of the 16 available color codes. data Color = White | Black | Navy | Green | Red | Maroon | Purple | Orange | Yellow | Lime | Teal | Cyan | Blue | Magenta | Gray | Silver deriving (Enum, Eq, Show) -- | A color specified by its red, green and blue components. data RGB a = RGB a a a deriving (Eq, Show) -- | A text decoration style. data Decoration = Bold | Italic | Underline | Reverse --x | Plain deriving (Eq, Show) -- | A string tagged with style attributes. data StyledString = Pure String | Colored (Maybe Color) (Maybe Color) StyledString | Decorated Decoration StyledString | Concat [StyledString] deriving Show -- A string with all styling applied to it specified explicitly. data StyledChunk = StyledChunk FgBg [Decoration] String deriving Show -- | A color decoration, specifying text foreground and background colors. data FgBg = FgBg (Maybe Color) (Maybe Color) deriving (Eq, Show) ------------------------------------------------------------------------------- -- Instances ------------------------------------------------------------------------------- mappend' :: StyledString -> StyledString -> StyledString mappend' (Concat l) (Concat m) = Concat $ l ++ m mappend' str (Concat l) = Concat $ str : l mappend' (Concat l) str = Concat $ l ++ [str] mappend' s t = Concat [s, t] instance Monoid StyledString where mempty = Pure "" mappend = mappend' instance IsString StyledString where fromString = Pure 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 ------------------------------------------------------------------------------- -- Functions ------------------------------------------------------------------------------- -- | Apply a style to a given string. (#>) :: Style s => s -> StyledString -> StyledString (#>) = style infixr 7 #> -- | Apply a style to a given string. (<#) :: Style s => StyledString -> s -> StyledString (<#) = flip style infixl 7 <# -- | Create a foreground color style with a given color. fg :: Color -> FgBg fg color = FgBg (Just color) Nothing -- | Create a background color style with a given color. bg :: Color -> FgBg bg color = FgBg Nothing (Just color) -- | Create a color style with a given foreground and background colors. fgBg :: Color -> Color -> FgBg fgBg f b = FgBg (Just f) (Just b) -- | The IRC color number (between 0 and 15 inclusive) of a given color. colorNumber :: Color -> Int colorNumber = fromEnum -- | Return the default RGB values of IRC colors. Client often allow the user -- to change the values, but these are the defaults. 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 -- | Return RGB values for color codes, using the Tango color scheme. It is a -- rough mapping between IRC color names and the 16 terminal colors. 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' --decorationCode Plain = '\x0f' colorChar = '\x03' colorCode :: Maybe Color -> Maybe Color -> String colorCode Nothing Nothing = "" colorCode (Just f) Nothing = colorChar : show (colorNumber f) colorCode Nothing (Just b) = colorChar : ',' : show (colorNumber b) colorCode (Just f) (Just b) = colorChar : show (colorNumber f) ++ ',' : show (colorNumber b) -- Apply color to a flat styled string applyColor :: Maybe Color -> Maybe Color -> [StyledChunk] -> [StyledChunk] applyColor f' b' = map 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 -- Apply decoration to a flat styled string applyDeco :: Decoration -> [StyledChunk] -> [StyledChunk] applyDeco d = map h where g ds d = if {-Plain `elem` ds ||-} d `elem` ds then ds else d : ds h (StyledChunk c ds s) = StyledChunk c (g ds d) s -- Tag the actual strings with all the hierarchically attached styles flatten :: StyledString -> [StyledChunk] flatten (Pure s) = [StyledChunk (FgBg Nothing Nothing) [] s] flatten (Colored f b s) = applyColor f b $ flatten s flatten (Decorated d s) = applyDeco d $ flatten s flatten (Concat ss) = concatMap flatten ss encodeColor :: Maybe Color -> Maybe Color -> String -> String encodeColor Nothing Nothing s = s encodeColor f b s = colorCode f b ++ s ++ [colorChar] encodeDeco :: [Decoration] -> String -> String encodeDeco ds s = foldl f s $ nub ds where f s' d = let c = decoCode d in c : s' ++ [c] -- | Convert a styled string value into an IRC style-coded text message. encode :: StyledString -> String encode = concatMap f . flatten where f (StyledChunk (FgBg f b) ds s) = encodeDeco ds $ encodeColor f b s -- | Remove style from a string, returning just the content. strip :: StyledString -> String strip (Pure s) = s strip (Colored _ _ s) = strip s strip (Decorated _ s) = strip s strip (Concat l) = concatMap strip l -- this is cool, but only do this if it doesn't take too much time... --decode ::String -> StyledString