{- This file is part of irc-fun-color.
 -
 - Written in 2015, 2016 by fr33domlover <fr33domlover@riseup.net>.
 -
 - ♡ 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 'T.Text' 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 'plain'
-- to 'Text's before styling (e.g. with '#>').
--
-- Green text:
--
-- > Green #> "hello beautiful world"
--
-- The same, but without the extension mentioned above:
--
-- > Green #> plain "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.Style
    ( -- * Primary Toolkit
      Color (..)
    , Decoration (..)
    , (#>)
    , (<#)
    , plain
    , fmt
    , fg
    , bg
    , fgBg
    , encode
      -- * Underlying Types
    , Style (..)
    , StyledText ()
    , FgBg ()
      -- * Utilities
    , RGB (..)
    , toIrcRGB
    , toTangoRGB
    , strip
    )
where

import Data.Char (isDigit)
import Data.Foldable (foldr)
import Data.List (intercalate, nub, sort)
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)

{-
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 -> StyledText -> StyledText

-------------------------------------------------------------------------------
-- 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 StyledText
    = Pure T.Text
    | Colored (Maybe Color) (Maybe Color) StyledText
    | Decorated Decoration StyledText
    | Concat (D.DList StyledText)
    deriving Show

-- A string with all styling applied to it specified explicitly.
data StyledChunk = StyledChunk FgBg [Decoration] T.Text deriving Show

-- | A color decoration, specifying text foreground and background colors.
data FgBg = FgBg (Maybe Color) (Maybe Color) deriving (Eq, Show)

-------------------------------------------------------------------------------
-- Instances
-------------------------------------------------------------------------------

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

-------------------------------------------------------------------------------
-- Functions
-------------------------------------------------------------------------------

-- | Apply a style to a given string.
(#>) :: Style s => s -> StyledText -> StyledText
(#>) = style
infixr 7 #>

-- | Apply a style to a given string.
(<#) :: Style s => StyledText -> s -> StyledText
(<#) = flip style
infixl 7 <#

-- | Create a plain-text styled text.
plain :: T.Text -> StyledText
plain = Pure

-- | Create plain text using formatting. This is simply a shortcut that is
-- equivalent to using 'Network.IRC.Fun.Color.Format.format' to get a strict
-- 'T.Text' and applying 'plain' to that.
fmt :: Format StyledText a -> a
fmt m = runFormat m (Pure . TL.toStrict . TLB.toLazyText)

-- | 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 :: 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)
    ]

-- Apply color to a flat styled string
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

-- Apply decoration to a flat styled string
applyDeco :: Decoration -> D.DList StyledChunk -> D.DList StyledChunk
applyDeco d = fmap 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 :: 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

-- If a message to be colored starts with a digit, insert dummy codes to
-- separate the text from the color code number
protect :: T.Text -> T.Text
protect t =
    case T.uncons t of
        Nothing     -> T.empty
        Just (d, r) ->
            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

-- | Convert a styled string value into an IRC style-coded text message.
encode :: StyledText -> T.Text
encode = foldr (\ sc t -> f sc <> t) T.empty . 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 :: 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

-- this is cool, but only do this if it doesn't take too much time...
--decode :: T.Text -> StyledText