MircFormatting.hs

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