{-# Language TemplateHaskell #-}
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
parseIrcText :: Palette -> Text -> Image'
parseIrcText :: Palette -> Text -> Image'
parseIrcText = Bool -> Palette -> Text -> Image'
parseIrcText' Bool
False
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)
| 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
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
, Color
black
, Color
blue
, Color
green
, Color
red
, Int -> Int -> Int -> Color
rgbColor' Int
127 Int
0 Int
0
, Int -> Int -> Int -> Color
rgbColor' Int
156 Int
0 Int
156
, Int -> Int -> Int -> Color
rgbColor' Int
252 Int
127 Int
0
, Color
yellow
, Color
brightGreen
, Color
cyan
, Color
brightCyan
, Color
brightBlue
, Int -> Int -> Int -> Color
rgbColor' Int
255 Int
0 Int
255
, Int -> Int -> Int -> Color
rgbColor' Int
127 Int
127 Int
127
, Int -> Int -> Int -> Color
rgbColor' Int
210 Int
210 Int
210
] 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) [
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
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
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
'!'
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