{- This file is part of irc-fun-color.
 -
 - Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.
 -
 - ♡ 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
 - <http://creativecommons.org/publicdomain/zero/1.0/>.
 -}

-- | 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.Char (isDigit)
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

-- If a message to be colored starts with a digit, insert dummy codes to
-- separate the text from the color code number
protect :: String -> String
protect []      = []
protect s@(d:r) =
    if isDigit d
        then decoCode Bold : decoCode Bold : s
        else s

encodeColor :: Maybe Color -> Maybe Color -> String -> String
encodeColor Nothing Nothing s = s
encodeColor f       b       s = colorCode f b ++ protect 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