{-# 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 :: Palette -> Text -> Image'
parseIrcText = Bool -> Palette -> Text -> Image'
parseIrcText' Bool
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' :: Bool -> Palette -> Text -> Image'
parseIrcText' Bool
explicit Palette
pal
  = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Image'
plainText forall a. a -> a
id
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Parser a -> Text -> Either String a
parseOnly (Palette -> Bool -> Bool -> Attr -> Parser Image'
pIrcLine Palette
pal Bool
explicit Bool
False Attr
defAttr)

data Segment = TextSegment Text | ControlSegment Char

pSegment :: Parser Segment
pSegment :: Parser Segment
pSegment = Text -> Segment
TextSegment    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser Text
takeWhile1 (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isControl)
       forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> Segment
ControlSegment forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser Char
satisfy Char -> Bool
isControl

pIrcLine :: Palette -> Bool -> Bool -> Attr -> Parser Image'
pIrcLine :: Palette -> Bool -> Bool -> Attr -> Parser Image'
pIrcLine Palette
pal Bool
explicit Bool
mono Attr
fmt =
  do Maybe Segment
seg <- forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Segment
pSegment)
     case Maybe Segment
seg of
       Maybe Segment
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty
       Just (TextSegment Text
txt) ->
           do Image'
rest <- Palette -> Bool -> Bool -> Attr -> Parser Image'
pIrcLine Palette
pal Bool
explicit Bool
mono Attr
fmt
              forall (m :: * -> *) a. Monad m => a -> m a
return (Attr -> Text -> Image'
text' Attr
fmt Text
txt forall a. Semigroup a => a -> a -> a
<> Image'
rest)
       Just (ControlSegment Char
'\^C') ->
           do (Text
numberText, Maybe (MaybeDefault Color, Maybe (MaybeDefault Color))
colorNumbers) <- forall a. Parser a -> Parser (Text, a)
match (Parser (MaybeDefault Color)
-> Parser (Maybe (MaybeDefault Color, Maybe (MaybeDefault Color)))
pColorNumbers Parser (MaybeDefault Color)
pColorNumber)
              Image'
rest <- Palette -> Bool -> Bool -> Attr -> Parser Image'
pIrcLine Palette
pal Bool
explicit Bool
mono (Maybe (MaybeDefault Color, Maybe (MaybeDefault Color))
-> Attr -> Attr
applyColors Maybe (MaybeDefault Color, Maybe (MaybeDefault Color))
colorNumbers Attr
fmt)
              forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if Bool
explicit
                         then Char -> Image'
controlImage Char
'\^C'
                              forall a. Semigroup a => a -> a -> a
<> Attr -> Text -> Image'
text' Attr
defAttr Text
numberText
                              forall a. Semigroup a => a -> a -> a
<> Image'
rest
                          else Image'
rest
       Just (ControlSegment Char
'\^D') ->
           do (Text
numberText, Maybe (MaybeDefault Color, Maybe (MaybeDefault Color))
colorNumbers) <- forall a. Parser a -> Parser (Text, a)
match (Parser (MaybeDefault Color)
-> Parser (Maybe (MaybeDefault Color, Maybe (MaybeDefault Color)))
pColorNumbers Parser (MaybeDefault Color)
pColorHex)
              Image'
rest <- Palette -> Bool -> Bool -> Attr -> Parser Image'
pIrcLine Palette
pal Bool
explicit Bool
mono (Maybe (MaybeDefault Color, Maybe (MaybeDefault Color))
-> Attr -> Attr
applyColors Maybe (MaybeDefault Color, Maybe (MaybeDefault Color))
colorNumbers Attr
fmt)
              forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if Bool
explicit
                         then Char -> Image'
controlImage Char
'\^D'
                              forall a. Semigroup a => a -> a -> a
<> Attr -> Text -> Image'
text' Attr
defAttr Text
numberText
                              forall a. Semigroup a => a -> a -> a
<> Image'
rest
                          else Image'
rest
       Just (ControlSegment Char
'\^Q')
         | Bool
explicit -> (Char -> Image'
controlImage Char
'\^Q' forall a. Semigroup a => a -> a -> a
<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Image'
rest
         | Bool
otherwise -> Parser Image'
rest
         where
           rest :: Parser Image'
rest = Palette -> Bool -> Bool -> Attr -> Parser Image'
pIrcLine Palette
pal Bool
explicit (Bool -> Bool
not Bool
mono)
                    (if Bool
mono then Attr
defAttr else forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Palette Attr
palMonospace Palette
pal)
       Just (ControlSegment Char
c)
          -- always render control codes that we don't understand
          | forall a. Maybe a -> Bool
isNothing Maybe Attr
mbFmt' Bool -> Bool -> Bool
|| Bool
explicit ->
                do Image'
rest <- Parser Image'
next
                   forall (m :: * -> *) a. Monad m => a -> m a
return (Char -> Image'
controlImage Char
c forall a. Semigroup a => a -> a -> a
<> Image'
rest)
          | Bool
otherwise -> Parser Image'
next
          where
            mbFmt' :: Maybe Attr
mbFmt' = Char -> Attr -> Maybe Attr
applyControlEffect Char
c Attr
fmt
            next :: Parser Image'
next   = Palette -> Bool -> Bool -> Attr -> Parser Image'
pIrcLine Palette
pal Bool
explicit Bool
mono (forall a. a -> Maybe a -> a
fromMaybe Attr
fmt Maybe Attr
mbFmt')

pColorNumbers ::
  Parser (MaybeDefault Color) ->
  Parser (Maybe (MaybeDefault Color, Maybe (MaybeDefault Color)))
pColorNumbers :: Parser (MaybeDefault Color)
-> Parser (Maybe (MaybeDefault Color, Maybe (MaybeDefault Color)))
pColorNumbers Parser (MaybeDefault Color)
color = forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$
  do MaybeDefault Color
fc <- Parser (MaybeDefault Color)
color
     Maybe (MaybeDefault Color)
bc <- forall a. Parser a -> Parser (Maybe a)
optional (Char -> Parser Char
Parse.char Char
',' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser (MaybeDefault Color)
color)
     forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (MaybeDefault Color
fc,Maybe (MaybeDefault Color)
bc))

pColorNumber :: Parser (MaybeDefault Color)
pColorNumber :: Parser (MaybeDefault Color)
pColorNumber =
  do Char
d1 <- Parser Char
digit
     String
ds <- forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option [] (forall (m :: * -> *) a. Monad m => a -> m a
return forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Char
digit)
     case Int -> Maybe (MaybeDefault Color)
mircColor (forall a. Read a => String -> a
read (Char
d1forall a. a -> [a] -> [a]
:String
ds)) of
       Just MaybeDefault Color
c -> forall (f :: * -> *) a. Applicative f => a -> f a
pure MaybeDefault Color
c
       Maybe (MaybeDefault Color)
Nothing -> forall (f :: * -> *) a. Alternative f => f a
empty

pColorHex :: Parser (MaybeDefault Color)
pColorHex :: Parser (MaybeDefault Color)
pColorHex = forall v. v -> MaybeDefault v
SetTo forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> Int -> Int -> Color
rgbColor' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text Int
p forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Text Int
p forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Text Int
p)
  where
    p :: Parser Text Int
p = do Char
x <- (Char -> Bool) -> Parser Char
satisfy Char -> Bool
isHexDigit
           Char
y <- (Char -> Bool) -> Parser Char
satisfy Char -> Bool
isHexDigit
           forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. (a, b) -> a
fst (forall a. [a] -> a
head (forall a. (Eq a, Num a) => ReadS a
readHex [Char
x,Char
y])))

optional :: Parser a -> Parser (Maybe a)
optional :: forall a. Parser a -> Parser (Maybe a)
optional Parser a
p = forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser a
p)

applyColors :: Maybe (MaybeDefault Color, Maybe (MaybeDefault Color)) -> Attr -> Attr
applyColors :: Maybe (MaybeDefault Color, Maybe (MaybeDefault Color))
-> Attr -> Attr
applyColors Maybe (MaybeDefault Color, Maybe (MaybeDefault Color))
Nothing = forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' Attr (MaybeDefault Color)
foreColorLens forall v. MaybeDefault v
Default
                    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' Attr (MaybeDefault Color)
backColorLens forall v. MaybeDefault v
Default
applyColors (Just (MaybeDefault Color
c1, Maybe (MaybeDefault Color)
Nothing)) = forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' Attr (MaybeDefault Color)
foreColorLens MaybeDefault Color
c1 -- preserve background
applyColors (Just (MaybeDefault Color
c1, Just MaybeDefault Color
c2)) = forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' Attr (MaybeDefault Color)
foreColorLens MaybeDefault Color
c1
                                 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' Attr (MaybeDefault Color)
backColorLens MaybeDefault Color
c2

mircColor :: Int -> Maybe (MaybeDefault Color)
mircColor :: Int -> Maybe (MaybeDefault Color)
mircColor Int
99 = forall a. a -> Maybe a
Just forall v. MaybeDefault v
Default
mircColor Int
i  = forall v. v -> MaybeDefault v
SetTo forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Vector Color
mircColors forall a. Vector a -> Int -> Maybe a
Vector.!? Int
i

mircColors :: Vector Color
mircColors :: Vector Color
mircColors =
  forall a. [a] -> Vector a
Vector.fromList forall a b. (a -> b) -> a -> b
$
    [ Color
white                 -- white
    , Color
black                 -- black
    , Color
blue                  -- blue
    , Color
green                 -- green
    , Color
red                   -- red
    , Int -> Int -> Int -> Color
rgbColor' Int
127 Int
0 Int
0     -- brown
    , Int -> Int -> Int -> Color
rgbColor' Int
156 Int
0 Int
156   -- purple
    , Int -> Int -> Int -> Color
rgbColor' Int
252 Int
127 Int
0   -- yellow
    , Color
yellow                -- yellow
    , Color
brightGreen           -- green
    , Color
cyan                  -- brightBlue
    , Color
brightCyan            -- brightCyan
    , Color
brightBlue            -- brightBlue
    , Int -> Int -> Int -> Color
rgbColor' Int
255 Int
0 Int
255   -- brightRed
    , Int -> Int -> Int -> Color
rgbColor' Int
127 Int
127 Int
127 -- brightBlack
    , Int -> Int -> Int -> Color
rgbColor' Int
210 Int
210 Int
210 -- brightWhite
    ] forall a. [a] -> [a] -> [a]
++
    forall a b. (a -> b) -> [a] -> [b]
map (Word8 -> Color
Color240 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => a -> a -> a
subtract Word8
16) [ -- https://modern.ircdocs.horse/formatting.html#colors-16-98
      Word8
052, Word8
094, Word8
100, Word8
058,
      Word8
022, Word8
029, Word8
023, Word8
024, Word8
017, Word8
054, Word8
053, Word8
089, Word8
088, Word8
130,
      Word8
142, Word8
064, Word8
028, Word8
035, Word8
030, Word8
025, Word8
018, Word8
091, Word8
090, Word8
125,
      Word8
124, Word8
166, Word8
184, Word8
106, Word8
034, Word8
049, Word8
037, Word8
033, Word8
019, Word8
129,
      Word8
127, Word8
161, Word8
196, Word8
208, Word8
226, Word8
154, Word8
046, Word8
086, Word8
051, Word8
075,
      Word8
021, Word8
171, Word8
201, Word8
198, Word8
203, Word8
215, Word8
227, Word8
191, Word8
083, Word8
122,
      Word8
087, Word8
111, Word8
063, Word8
177, Word8
207, Word8
205, Word8
217, Word8
223, Word8
229, Word8
193,
      Word8
157, Word8
158, Word8
159, Word8
153, Word8
147, Word8
183, Word8
219, Word8
212, Word8
016, Word8
233,
      Word8
235, Word8
237, Word8
239, Word8
241, Word8
244, Word8
247, Word8
250, Word8
254, Word8
231 ]

rgbColor' :: Int -> Int -> Int -> Color
rgbColor' :: Int -> Int -> Int -> Color
rgbColor' = forall i. Integral i => i -> i -> i -> Color
srgbColor -- fix the type to Int

applyControlEffect :: Char -> Attr -> Maybe Attr
applyControlEffect :: Char -> Attr -> Maybe Attr
applyControlEffect Char
'\^B' Attr
attr = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$! Word8 -> Attr -> Attr
toggleStyle Word8
bold Attr
attr
applyControlEffect Char
'\^V' Attr
attr = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$! Word8 -> Attr -> Attr
toggleStyle Word8
reverseVideo Attr
attr
applyControlEffect Char
'\^_' Attr
attr = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$! Word8 -> Attr -> Attr
toggleStyle Word8
underline Attr
attr
applyControlEffect Char
'\^^' Attr
attr = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$! Word8 -> Attr -> Attr
toggleStyle Word8
strikethrough Attr
attr
applyControlEffect Char
'\^]' Attr
attr = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$! Word8 -> Attr -> Attr
toggleStyle Word8
italic Attr
attr
applyControlEffect Char
'\^O' Attr
_    = forall a. a -> Maybe a
Just Attr
defAttr
applyControlEffect Char
_     Attr
_    = forall a. Maybe a
Nothing

toggleStyle :: Style -> Attr -> Attr
toggleStyle :: Word8 -> Attr -> Attr
toggleStyle Word8
s1 = forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over Lens' Attr (MaybeDefault Word8)
styleLens forall a b. (a -> b) -> a -> b
$ \MaybeDefault Word8
old ->
  case MaybeDefault Word8
old of
    SetTo Word8
s2 -> forall v. v -> MaybeDefault v
SetTo (forall a. Bits a => a -> a -> a
xor Word8
s1 Word8
s2)
    MaybeDefault Word8
_        -> forall v. v -> MaybeDefault v
SetTo Word8
s1

-- | Safely render a control character.
controlImage :: Char -> Image'
controlImage :: Char -> Image'
controlImage = Attr -> Char -> Image'
I.char Attr
attr forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Char
controlName
  where
    attr :: Attr
attr          = Attr -> Word8 -> Attr
withStyle Attr
defAttr Word8
reverseVideo
    controlName :: Char -> Char
controlName Char
c
      | Char
c forall a. Ord a => a -> a -> Bool
< Char
'\128' = Int -> Char
chr (Int
0x40 forall a. Bits a => a -> a -> a
`xor` Char -> Int
ord Char
c)
      | Bool
otherwise  = Char
'!'

-- | 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 :: String -> Image'
plainText String
"" = forall a. Monoid a => a
mempty
plainText String
xs =
  case forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
isControl String
xs of
    (String
first, String
""       ) -> Attr -> String -> Image'
I.string Attr
defAttr String
first
    (String
first, Char
cntl:String
rest) -> Attr -> String -> Image'
I.string Attr
defAttr String
first forall a. Semigroup a => a -> a -> a
<>
                          Char -> Image'
controlImage Char
cntl forall a. Semigroup a => a -> a -> a
<>
                          String -> Image'
plainText String
rest