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           Control.Applicative ((<|>))
import           Control.Lens
import           Data.Attoparsec.Text as Parse
import           Data.Bits
import           Data.Char
import           Data.Maybe
import           Data.Text (Text)
import           Graphics.Vty.Attributes
import           Data.Vector (Vector)
import qualified Data.Vector as Vector

makeLensesFor
  [ ("attrForeColor", "foreColorLens")
  , ("attrBackColor", "backColorLens")
  , ("attrStyle"    , "styleLens"    )]
  ''Attr

-- | Parse mIRC encoded format characters and hide the control characters.
parseIrcText :: 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 -> Text -> Image'
parseIrcText' explicit = either plainText id
                       . parseOnly (pIrcLine explicit defAttr)

data Segment = TextSegment Text | ControlSegment Char

pSegment :: Parser Segment
pSegment = TextSegment    <$> takeWhile1 (not . isControl)
       <|> ControlSegment <$> satisfy isControl

pIrcLine :: Bool -> Attr -> Parser Image'
pIrcLine explicit fmt =
  do seg <- option Nothing (Just <$> pSegment)
     case seg of
       Nothing -> return mempty
       Just (TextSegment txt) ->
           do rest <- pIrcLine explicit fmt
              return (text' fmt txt <> rest)
       Just (ControlSegment '\^C') ->
           do (numberText, colorNumbers) <- match pColorNumbers
              rest <- pIrcLine explicit (applyColors colorNumbers fmt)
              return $ if explicit
                         then controlImage '\^C'
                              <> text' defAttr numberText
                              <> rest
                          else rest
       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 explicit (fromMaybe fmt mbFmt')

pColorNumbers :: Parser (Maybe (MaybeDefault Color, Maybe (MaybeDefault Color)))
pColorNumbers = option Nothing $
  do n       <- pNumber
     Just fc <- pure (mircColor n)
     bc      <- optional $
                  do m       <- Parse.char ',' *> pNumber
                     Just bc <- pure (mircColor m)
                     pure bc
     return (Just (fc,bc))

  where
    pNumber = do d1 <- digit
                 ds <- option [] (return <$> digit)
                 return $! read (d1:ds)

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' = rgbColor -- 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 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