content: {-# Language TemplateHaskell #-}
  
  {-|
  Module      : Client.Image.MircFormatting
  Description : Parser for mIRC's text formatting encoding
  Copyright   : (c) Eric Mertens, 2016
  License     : ISC
  Maintainer  : emertens@gmail.com
  
  This module parses mIRC encoded text and generates VTY images.
  
  -}
  module Client.Image.MircFormatting
    ( parseIrcText
    , parseIrcText'
    , plainText
    , controlImage
    , mircColor
    , mircColors
    ) where
  
  import Client.Image.PackedImage as I
  import Client.Image.Palette (Palette, palMonospace)
  import Control.Applicative ((<|>), empty)
  import Control.Lens (view, over, set, makeLensesFor)
  import Data.Attoparsec.Text as Parse
  import Data.Bits (Bits(xor))
  import Data.Char (ord, chr, isControl, isHexDigit)
  import Data.Maybe (fromMaybe, isNothing)
  import Data.Text (Text)
  import Data.Vector (Vector)
  import Data.Vector qualified as Vector
  import Graphics.Vty.Attributes
  import Numeric (readHex)
  
  makeLensesFor
    [ ("attrForeColor", "foreColorLens")
    , ("attrBackColor", "backColorLens")
    , ("attrStyle"    , "styleLens"    )]
    ''Attr
  
  -- | Parse mIRC encoded format characters and hide the control characters.
  parseIrcText :: Palette -> Text -> Image'
  parseIrcText = parseIrcText' False
  
  -- | Parse mIRC encoded format characters and render the control characters
  -- explicitly. This view is useful when inputting control characters to make
  -- it clear where they are in the text.
  parseIrcText' :: Bool -> Palette -> Text -> Image'
  parseIrcText' explicit pal
    = either plainText id
    . parseOnly (pIrcLine pal explicit False defAttr)
  
  data Segment = TextSegment Text | ControlSegment Char
  
  pSegment :: Parser Segment
  pSegment = TextSegment    <$> takeWhile1 (not . isControl)
         <|> ControlSegment <$> satisfy isControl
  
  pIrcLine :: Palette -> Bool -> Bool -> Attr -> Parser Image'
  pIrcLine pal explicit mono fmt =
    do seg <- option Nothing (Just <$> pSegment)
       case seg of
         Nothing -> return mempty
         Just (TextSegment txt) ->
             do rest <- pIrcLine pal explicit mono fmt
                return (text' fmt txt <> rest)
         Just (ControlSegment '\^C') ->
             do (numberText, colorNumbers) <- match (pColorNumbers pColorNumber)
                rest <- pIrcLine pal explicit mono (applyColors colorNumbers fmt)
                return $ if explicit
                           then controlImage '\^C'
                                <> text' defAttr numberText
                                <> rest
                            else rest
         Just (ControlSegment '\^D') ->
             do (numberText, colorNumbers) <- match (pColorNumbers pColorHex)
                rest <- pIrcLine pal explicit mono (applyColors colorNumbers fmt)
                return $ if explicit
                           then controlImage '\^D'
                                <> text' defAttr numberText
                                <> rest
                            else rest
         Just (ControlSegment '\^Q')
           | explicit -> (controlImage '\^Q' <>) <$> rest
           | otherwise -> rest
           where
             rest = pIrcLine pal explicit (not mono)
                      (if mono then defAttr else view palMonospace pal)
         Just (ControlSegment c)
            -- always render control codes that we don't understand
            | isNothing mbFmt' || explicit ->
                  do rest <- next
                     return (controlImage c <> rest)
            | otherwise -> next
            where
              mbFmt' = applyControlEffect c fmt
              next   = pIrcLine pal explicit mono (fromMaybe fmt mbFmt')
  
  pColorNumbers ::
    Parser (MaybeDefault Color) ->
    Parser (Maybe (MaybeDefault Color, Maybe (MaybeDefault Color)))
  pColorNumbers color = option Nothing $
    do fc <- color
       bc <- optional (Parse.char ',' *> color)
       return (Just (fc,bc))
  
  pColorNumber :: Parser (MaybeDefault Color)
  pColorNumber =
    do d1 <- digit
       ds <- option [] (return <$> digit)
       case mircColor (read (d1:ds)) of
         Just c -> pure c
         Nothing -> empty
  
  pColorHex :: Parser (MaybeDefault Color)
  pColorHex = SetTo <$> (rgbColor' <$> p <*> p <*> p)
    where
      p = do x <- satisfy isHexDigit
             y <- satisfy isHexDigit
             pure (fst (head (readHex [x,y])))
  
  optional :: Parser a -> Parser (Maybe a)
  optional p = option Nothing (Just <$> p)
  
  applyColors :: Maybe (MaybeDefault Color, Maybe (MaybeDefault Color)) -> Attr -> Attr
  applyColors Nothing = set foreColorLens Default
                      . set backColorLens Default
  applyColors (Just (c1, Nothing)) = set foreColorLens c1 -- preserve background
  applyColors (Just (c1, Just c2)) = set foreColorLens c1
                                   . set backColorLens c2
  
  mircColor :: Int -> Maybe (MaybeDefault Color)
  mircColor 99 = Just Default
  mircColor i  = SetTo <$> mircColors Vector.!? i
  
  mircColors :: Vector Color
  mircColors =
    Vector.fromList $
      [ white                 -- white
      , black                 -- black
      , blue                  -- blue
      , green                 -- green
      , red                   -- red
      , rgbColor' 127 0 0     -- brown
      , rgbColor' 156 0 156   -- purple
      , rgbColor' 252 127 0   -- yellow
      , yellow                -- yellow
      , brightGreen           -- green
      , cyan                  -- brightBlue
      , brightCyan            -- brightCyan
      , brightBlue            -- brightBlue
      , rgbColor' 255 0 255   -- brightRed
      , rgbColor' 127 127 127 -- brightBlack
      , rgbColor' 210 210 210 -- brightWhite
      ] ++
      map (Color240 . subtract 16) [ -- https://modern.ircdocs.horse/formatting.html#colors-16-98
        052, 094, 100, 058,
        022, 029, 023, 024, 017, 054, 053, 089, 088, 130,
        142, 064, 028, 035, 030, 025, 018, 091, 090, 125,
        124, 166, 184, 106, 034, 049, 037, 033, 019, 129,
        127, 161, 196, 208, 226, 154, 046, 086, 051, 075,
        021, 171, 201, 198, 203, 215, 227, 191, 083, 122,
        087, 111, 063, 177, 207, 205, 217, 223, 229, 193,
        157, 158, 159, 153, 147, 183, 219, 212, 016, 233,
        235, 237, 239, 241, 244, 247, 250, 254, 231 ]
  
  rgbColor' :: Int -> Int -> Int -> Color
  rgbColor' = srgbColor -- fix the type to Int
  
  applyControlEffect :: Char -> Attr -> Maybe Attr
  applyControlEffect '\^B' attr = Just $! toggleStyle bold attr
  applyControlEffect '\^V' attr = Just $! toggleStyle reverseVideo attr
  applyControlEffect '\^_' attr = Just $! toggleStyle underline attr
  applyControlEffect '\^^' attr = Just $! toggleStyle strikethrough attr
  applyControlEffect '\^]' attr = Just $! toggleStyle italic attr
  applyControlEffect '\^O' _    = Just defAttr
  applyControlEffect _     _    = Nothing
  
  toggleStyle :: Style -> Attr -> Attr
  toggleStyle s1 = over styleLens $ \old ->
    case old of
      SetTo s2 -> SetTo (xor s1 s2)
      _        -> SetTo s1
  
  -- | Safely render a control character.
  controlImage :: Char -> Image'
  controlImage = I.char attr . controlName
    where
      attr          = withStyle defAttr reverseVideo
      controlName c
        | c < '\128' = chr (0x40 `xor` ord c)
        | otherwise  = '!'
  
  -- | Render a 'String' with default attributes and replacing all of the
  -- control characters with reverse-video letters corresponding to caret
  -- notation.
  plainText :: String -> Image'
  plainText "" = mempty
  plainText xs =
    case break isControl xs of
      (first, ""       ) -> I.string defAttr first
      (first, cntl:rest) -> I.string defAttr first <>
                            controlImage cntl <>
                            plainText rest
  