{-# 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
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
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 (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 (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 (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 (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 (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 (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 (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 (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 (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 (f :: * -> *) a. Applicative f => a -> f a
pure MaybeDefault Color
c
       Maybe (MaybeDefault Color)
Nothing -> Parser (MaybeDefault Color)
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 (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 (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 (f :: * -> *) a. Applicative f => a -> f a
pure ((Int, String) -> Int
forall a b. (a, b) -> a
fst ([(Int, String)] -> (Int, String)
forall a. [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 :: Parser a -> Parser (Maybe a)
optional Parser a
p = Maybe a -> Parser (Maybe a) -> Parser (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 (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]
++
    (Style -> Color) -> [Style] -> [Color]
forall a b. (a -> b) -> [a] -> [b]
map (Style -> Color
Color240 (Style -> Color) -> (Style -> Style) -> Style -> Color
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Style -> Style -> Style
forall a. Num a => a -> a -> a
subtract Style
16) [ -- https://modern.ircdocs.horse/formatting.html#colors-16-98
      Style
052, Style
094, Style
100, Style
058,
      Style
022, Style
029, Style
023, Style
024, Style
017, Style
054, Style
053, Style
089, Style
088, Style
130,
      Style
142, Style
064, Style
028, Style
035, Style
030, Style
025, Style
018, Style
091, Style
090, Style
125,
      Style
124, Style
166, Style
184, Style
106, Style
034, Style
049, Style
037, Style
033, Style
019, Style
129,
      Style
127, Style
161, Style
196, Style
208, Style
226, Style
154, Style
046, Style
086, Style
051, Style
075,
      Style
021, Style
171, Style
201, Style
198, Style
203, Style
215, Style
227, Style
191, Style
083, Style
122,
      Style
087, Style
111, Style
063, Style
177, Style
207, Style
205, Style
217, Style
223, Style
229, Style
193,
      Style
157, Style
158, Style
159, Style
153, Style
147, Style
183, Style
219, Style
212, Style
016, Style
233,
      Style
235, Style
237, Style
239, Style
241, Style
244, Style
247, Style
250, Style
254, Style
231 ]

rgbColor' :: Int -> Int -> Int -> Color
rgbColor' :: Int -> Int -> Int -> Color
rgbColor' = Int -> Int -> Int -> Color
forall i. Integral i => i -> i -> i -> Color
rgbColor -- 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
$! Style -> Attr -> Attr
toggleStyle Style
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
$! Style -> Attr -> Attr
toggleStyle Style
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
$! Style -> Attr -> Attr
toggleStyle Style
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
$! Style -> Attr -> Attr
toggleStyle Style
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
$! Style -> Attr -> Attr
toggleStyle Style
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 :: Style -> Attr -> Attr
toggleStyle Style
s1 = ASetter Attr Attr (MaybeDefault Style) (MaybeDefault Style)
-> (MaybeDefault Style -> MaybeDefault Style) -> Attr -> Attr
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter Attr Attr (MaybeDefault Style) (MaybeDefault Style)
Lens' Attr (MaybeDefault Style)
styleLens ((MaybeDefault Style -> MaybeDefault Style) -> Attr -> Attr)
-> (MaybeDefault Style -> MaybeDefault Style) -> Attr -> Attr
forall a b. (a -> b) -> a -> b
$ \MaybeDefault Style
old ->
  case MaybeDefault Style
old of
    SetTo Style
s2 -> Style -> MaybeDefault Style
forall v. v -> MaybeDefault v
SetTo (Style -> Style -> Style
forall a. Bits a => a -> a -> a
xor Style
s1 Style
s2)
    MaybeDefault Style
_        -> Style -> MaybeDefault Style
forall v. v -> MaybeDefault v
SetTo Style
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 -> Style -> Attr
withStyle Attr
defAttr Style
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