{-# 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
  = (String -> Image')
-> (Image' -> Image') -> Either String Image' -> Image'
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Image'
plainText Image' -> Image'
forall a. a -> a
id
  (Either String Image' -> Image')
-> (Text -> Either String Image') -> Text -> Image'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser Image' -> Text -> Either String Image'
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    (Text -> Segment) -> Parser Text Text -> Parser Segment
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser Text Text
takeWhile1 (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isControl)
       Parser Segment -> Parser Segment -> Parser Segment
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> Segment
ControlSegment (Char -> Segment) -> Parser Text Char -> Parser Segment
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser Text 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 <- Maybe Segment
-> Parser Text (Maybe Segment) -> Parser Text (Maybe Segment)
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option Maybe Segment
forall a. Maybe a
Nothing (Segment -> Maybe Segment
forall a. a -> Maybe a
Just (Segment -> Maybe Segment)
-> Parser Segment -> Parser Text (Maybe Segment)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Segment
pSegment)
     case Maybe Segment
seg of
       Maybe Segment
Nothing -> Image' -> Parser Image'
forall a. a -> Parser Text a
forall (m :: * -> *) a. Monad m => a -> m a
return Image'
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
              Image' -> Parser Image'
forall a. a -> Parser Text a
forall (m :: * -> *) a. Monad m => a -> m a
return (Attr -> Text -> Image'
text' Attr
fmt Text
txt Image' -> Image' -> Image'
forall a. Semigroup a => a -> a -> a
<> Image'
rest)
       Just (ControlSegment Char
'\^C') ->
           do (Text
numberText, Maybe (MaybeDefault Color, Maybe (MaybeDefault Color))
colorNumbers) <- Parser (Maybe (MaybeDefault Color, Maybe (MaybeDefault Color)))
-> Parser
     (Text, Maybe (MaybeDefault Color, Maybe (MaybeDefault Color)))
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)
              Image' -> Parser Image'
forall a. a -> Parser Text a
forall (m :: * -> *) a. Monad m => a -> m a
return (Image' -> Parser Image') -> Image' -> Parser Image'
forall a b. (a -> b) -> a -> b
$ if Bool
explicit
                         then Char -> Image'
controlImage Char
'\^C'
                              Image' -> Image' -> Image'
forall a. Semigroup a => a -> a -> a
<> Attr -> Text -> Image'
text' Attr
defAttr Text
numberText
                              Image' -> Image' -> Image'
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) <- Parser (Maybe (MaybeDefault Color, Maybe (MaybeDefault Color)))
-> Parser
     (Text, Maybe (MaybeDefault Color, Maybe (MaybeDefault Color)))
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)
              Image' -> Parser Image'
forall a. a -> Parser Text a
forall (m :: * -> *) a. Monad m => a -> m a
return (Image' -> Parser Image') -> Image' -> Parser Image'
forall a b. (a -> b) -> a -> b
$ if Bool
explicit
                         then Char -> Image'
controlImage Char
'\^D'
                              Image' -> Image' -> Image'
forall a. Semigroup a => a -> a -> a
<> Attr -> Text -> Image'
text' Attr
defAttr Text
numberText
                              Image' -> Image' -> Image'
forall a. Semigroup a => a -> a -> a
<> Image'
rest
                          else Image'
rest
       Just (ControlSegment Char
'\^Q')
         | Bool
explicit -> (Char -> Image'
controlImage Char
'\^Q' Image' -> Image' -> Image'
forall a. Semigroup a => a -> a -> a
<>) (Image' -> Image') -> Parser Image' -> Parser Image'
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 Getting Attr Palette Attr -> Palette -> Attr
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Attr Palette Attr
Lens' Palette Attr
palMonospace Palette
pal)
       Just (ControlSegment Char
c)
          -- always render control codes that we don't understand
          | Maybe Attr -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Attr
mbFmt' Bool -> Bool -> Bool
|| Bool
explicit ->
                do Image'
rest <- Parser Image'
next
                   Image' -> Parser Image'
forall a. a -> Parser Text a
forall (m :: * -> *) a. Monad m => a -> m a
return (Char -> Image'
controlImage Char
c Image' -> Image' -> Image'
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 (Attr -> Maybe Attr -> Attr
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 = Maybe (MaybeDefault Color, Maybe (MaybeDefault Color))
-> Parser (Maybe (MaybeDefault Color, Maybe (MaybeDefault Color)))
-> Parser (Maybe (MaybeDefault Color, Maybe (MaybeDefault Color)))
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option Maybe (MaybeDefault Color, Maybe (MaybeDefault Color))
forall a. Maybe a
Nothing (Parser (Maybe (MaybeDefault Color, Maybe (MaybeDefault Color)))
 -> Parser (Maybe (MaybeDefault Color, Maybe (MaybeDefault Color))))
-> Parser (Maybe (MaybeDefault Color, Maybe (MaybeDefault Color)))
-> Parser (Maybe (MaybeDefault Color, Maybe (MaybeDefault Color)))
forall a b. (a -> b) -> a -> b
$
  do MaybeDefault Color
fc <- Parser (MaybeDefault Color)
color
     Maybe (MaybeDefault Color)
bc <- Parser (MaybeDefault Color) -> Parser (Maybe (MaybeDefault Color))
forall a. Parser a -> Parser (Maybe a)
optional (Char -> Parser Text Char
Parse.char Char
',' Parser Text Char
-> Parser (MaybeDefault Color) -> Parser (MaybeDefault Color)
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser (MaybeDefault Color)
color)
     Maybe (MaybeDefault Color, Maybe (MaybeDefault Color))
-> Parser (Maybe (MaybeDefault Color, Maybe (MaybeDefault Color)))
forall a. a -> Parser Text a
forall (m :: * -> *) a. Monad m => a -> m a
return ((MaybeDefault Color, Maybe (MaybeDefault Color))
-> Maybe (MaybeDefault Color, Maybe (MaybeDefault Color))
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 Text Char
digit
     String
ds <- String -> Parser Text String -> Parser Text String
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option [] (Char -> String
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (Char -> String) -> Parser Text Char -> Parser Text String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text Char
digit)
     case Int -> Maybe (MaybeDefault Color)
mircColor (String -> Int
forall a. Read a => String -> a
read (Char
d1Char -> String -> String
forall a. a -> [a] -> [a]
:String
ds)) of
       Just MaybeDefault Color
c -> MaybeDefault Color -> Parser (MaybeDefault Color)
forall a. a -> Parser Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MaybeDefault Color
c
       Maybe (MaybeDefault Color)
Nothing -> Parser (MaybeDefault Color)
forall a. Parser Text a
forall (f :: * -> *) a. Alternative f => f a
empty

pColorHex :: Parser (MaybeDefault Color)
pColorHex :: Parser (MaybeDefault Color)
pColorHex = Color -> MaybeDefault Color
forall v. v -> MaybeDefault v
SetTo (Color -> MaybeDefault Color)
-> Parser Text Color -> Parser (MaybeDefault Color)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> Int -> Int -> Color
rgbColor' (Int -> Int -> Int -> Color)
-> Parser Text Int -> Parser Text (Int -> Int -> Color)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text Int
p Parser Text (Int -> Int -> Color)
-> Parser Text Int -> Parser Text (Int -> Color)
forall a b. Parser Text (a -> b) -> Parser Text a -> Parser Text b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Text Int
p Parser Text (Int -> Color) -> Parser Text Int -> Parser Text Color
forall a b. Parser Text (a -> b) -> Parser Text a -> Parser Text b
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 Text Char
satisfy Char -> Bool
isHexDigit
           Char
y <- (Char -> Bool) -> Parser Text Char
satisfy Char -> Bool
isHexDigit
           Int -> Parser Text Int
forall a. a -> Parser Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Int, String) -> Int
forall a b. (a, b) -> a
fst ([(Int, String)] -> (Int, String)
forall a. HasCallStack => [a] -> a
head (ReadS Int
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 = Maybe a -> Parser Text (Maybe a) -> Parser Text (Maybe a)
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option Maybe a
forall a. Maybe a
Nothing (a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> Parser a -> Parser Text (Maybe a)
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 = ASetter Attr Attr (MaybeDefault Color) (MaybeDefault Color)
-> MaybeDefault Color -> Attr -> Attr
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Attr Attr (MaybeDefault Color) (MaybeDefault Color)
Lens' Attr (MaybeDefault Color)
foreColorLens MaybeDefault Color
forall v. MaybeDefault v
Default
                    (Attr -> Attr) -> (Attr -> Attr) -> Attr -> Attr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASetter Attr Attr (MaybeDefault Color) (MaybeDefault Color)
-> MaybeDefault Color -> Attr -> Attr
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Attr Attr (MaybeDefault Color) (MaybeDefault Color)
Lens' Attr (MaybeDefault Color)
backColorLens MaybeDefault Color
forall v. MaybeDefault v
Default
applyColors (Just (MaybeDefault Color
c1, Maybe (MaybeDefault Color)
Nothing)) = ASetter Attr Attr (MaybeDefault Color) (MaybeDefault Color)
-> MaybeDefault Color -> Attr -> Attr
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Attr Attr (MaybeDefault Color) (MaybeDefault Color)
Lens' Attr (MaybeDefault Color)
foreColorLens MaybeDefault Color
c1 -- preserve background
applyColors (Just (MaybeDefault Color
c1, Just MaybeDefault Color
c2)) = ASetter Attr Attr (MaybeDefault Color) (MaybeDefault Color)
-> MaybeDefault Color -> Attr -> Attr
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Attr Attr (MaybeDefault Color) (MaybeDefault Color)
Lens' Attr (MaybeDefault Color)
foreColorLens MaybeDefault Color
c1
                                 (Attr -> Attr) -> (Attr -> Attr) -> Attr -> Attr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASetter Attr Attr (MaybeDefault Color) (MaybeDefault Color)
-> MaybeDefault Color -> Attr -> Attr
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Attr Attr (MaybeDefault Color) (MaybeDefault Color)
Lens' Attr (MaybeDefault Color)
backColorLens MaybeDefault Color
c2

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

mircColors :: Vector Color
mircColors :: Vector Color
mircColors =
  [Color] -> Vector Color
forall a. [a] -> Vector a
Vector.fromList ([Color] -> Vector Color) -> [Color] -> Vector Color
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
    ] [Color] -> [Color] -> [Color]
forall a. [a] -> [a] -> [a]
++
    (Word8 -> Color) -> [Word8] -> [Color]
forall a b. (a -> b) -> [a] -> [b]
map (Word8 -> Color
Color240 (Word8 -> Color) -> (Word8 -> Word8) -> Word8 -> Color
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Word8 -> Word8
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' = Int -> Int -> Int -> Color
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 = Attr -> Maybe Attr
forall a. a -> Maybe a
Just (Attr -> Maybe Attr) -> Attr -> Maybe Attr
forall a b. (a -> b) -> a -> b
$! Word8 -> Attr -> Attr
toggleStyle Word8
bold Attr
attr
applyControlEffect Char
'\^V' Attr
attr = Attr -> Maybe Attr
forall a. a -> Maybe a
Just (Attr -> Maybe Attr) -> Attr -> Maybe Attr
forall a b. (a -> b) -> a -> b
$! Word8 -> Attr -> Attr
toggleStyle Word8
reverseVideo Attr
attr
applyControlEffect Char
'\^_' Attr
attr = Attr -> Maybe Attr
forall a. a -> Maybe a
Just (Attr -> Maybe Attr) -> Attr -> Maybe Attr
forall a b. (a -> b) -> a -> b
$! Word8 -> Attr -> Attr
toggleStyle Word8
underline Attr
attr
applyControlEffect Char
'\^^' Attr
attr = Attr -> Maybe Attr
forall a. a -> Maybe a
Just (Attr -> Maybe Attr) -> Attr -> Maybe Attr
forall a b. (a -> b) -> a -> b
$! Word8 -> Attr -> Attr
toggleStyle Word8
strikethrough Attr
attr
applyControlEffect Char
'\^]' Attr
attr = Attr -> Maybe Attr
forall a. a -> Maybe a
Just (Attr -> Maybe Attr) -> Attr -> Maybe Attr
forall a b. (a -> b) -> a -> b
$! Word8 -> Attr -> Attr
toggleStyle Word8
italic Attr
attr
applyControlEffect Char
'\^O' Attr
_    = Attr -> Maybe Attr
forall a. a -> Maybe a
Just Attr
defAttr
applyControlEffect Char
_     Attr
_    = Maybe Attr
forall a. Maybe a
Nothing

toggleStyle :: Style -> Attr -> Attr
toggleStyle :: Word8 -> Attr -> Attr
toggleStyle Word8
s1 = ASetter Attr Attr (MaybeDefault Word8) (MaybeDefault Word8)
-> (MaybeDefault Word8 -> MaybeDefault Word8) -> Attr -> Attr
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter Attr Attr (MaybeDefault Word8) (MaybeDefault Word8)
Lens' Attr (MaybeDefault Word8)
styleLens ((MaybeDefault Word8 -> MaybeDefault Word8) -> Attr -> Attr)
-> (MaybeDefault Word8 -> MaybeDefault Word8) -> Attr -> Attr
forall a b. (a -> b) -> a -> b
$ \MaybeDefault Word8
old ->
  case MaybeDefault Word8
old of
    SetTo Word8
s2 -> Word8 -> MaybeDefault Word8
forall v. v -> MaybeDefault v
SetTo (Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
xor Word8
s1 Word8
s2)
    MaybeDefault Word8
_        -> Word8 -> 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 (Char -> Image') -> (Char -> Char) -> Char -> Image'
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 Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
< Char
'\128' = Int -> Char
chr (Int
0x40 Int -> Int -> Int
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
"" = Image'
forall a. Monoid a => a
mempty
plainText String
xs =
  case (Char -> Bool) -> String -> (String, String)
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 Image' -> Image' -> Image'
forall a. Semigroup a => a -> a -> a
<>
                          Char -> Image'
controlImage Char
cntl Image' -> Image' -> Image'
forall a. Semigroup a => a -> a -> a
<>
                          String -> Image'
plainText String
rest