{-# Language TemplateHaskell #-}
module Client.Image.MircFormatting
( parseIrcText
, parseIrcText'
, plainText
, controlImage
, mircColor
) 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
makeLensesFor
[ ("attrForeColor", "foreColorLens")
, ("attrBackColor", "backColorLens")
, ("attrStyle" , "styleLens" )]
''Attr
parseIrcText :: Text -> Image'
parseIrcText = parseIrcText' False
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)
| 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 (Color, Maybe 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 (Color, Maybe Color)) -> Attr -> Attr
applyColors Nothing = set foreColorLens Default
. set backColorLens Default
applyColors (Just (c1, Nothing)) = set foreColorLens (SetTo c1)
applyColors (Just (c1, Just c2)) = set foreColorLens (SetTo c1)
. set backColorLens (SetTo c2)
mircColor :: Int -> Maybe Color
mircColor 0 = Just (white )
mircColor 1 = Just (black )
mircColor 2 = Just (blue )
mircColor 3 = Just (green )
mircColor 4 = Just (red )
mircColor 5 = Just (rgbColor' 127 0 0 )
mircColor 6 = Just (rgbColor' 156 0 156 )
mircColor 7 = Just (rgbColor' 252 127 0 )
mircColor 8 = Just (yellow )
mircColor 9 = Just (brightGreen )
mircColor 10 = Just (cyan )
mircColor 11 = Just (brightCyan )
mircColor 12 = Just (brightBlue )
mircColor 13 = Just (rgbColor' 255 0 255 )
mircColor 14 = Just (rgbColor' 127 127 127)
mircColor 15 = Just (rgbColor' 210 210 210)
mircColor _ = Nothing
rgbColor' :: Int -> Int -> Int -> Color
rgbColor' = rgbColor
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
controlImage :: Char -> Image'
controlImage = I.char attr . controlName
where
attr = withStyle defAttr reverseVideo
controlName c
| c < '\128' = chr (0x40 `xor` ord c)
| otherwise = '!'
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