irc-core-1.0: driver/ImageUtils.hs
{-# LANGUAGE TemplateHaskell #-}
module ImageUtils where
import Control.Lens
import Control.Monad (guard)
import Data.Array
import Data.ByteString (ByteString)
import Data.Char (isControl, isAlphaNum)
import Data.Set (Set)
import Data.Text (Text)
import Graphics.Vty.Image
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as B8
import qualified Data.Set as Set
import qualified Data.Text as Text
import Irc.Format
data Formatting = Formatting
{ _fmtFore :: Maybe Color
, _fmtBack :: Maybe Color
, _fmtBold, _fmtItalic, _fmtUnderline, _fmtReverse :: !Bool
}
makeLenses ''Formatting
lineWrap :: Int -> Image -> [Image]
lineWrap width img
| w <= width = [img <|> char defAttr ' '] -- vty forgets to turn off formatting
| otherwise = cropRight width img : lineWrap width (cropLeft (w-width) img)
where
w = imageWidth img
cleanText :: Text -> Image
cleanText = ircFormattedText
renderFullUsermask :: UserInfo -> Image
renderFullUsermask u
= utf8Bytestring' (withForeColor defAttr yellow) (idBytes (userNick u))
<|> userpart
<|> hostpart
where
userpart = case userName u of
Just x -> string defAttr "!"
<|> utf8Bytestring' (withForeColor defAttr green) x
Nothing -> emptyImage
hostpart = case userHost u of
Just x -> string defAttr "@"
<|> utf8Bytestring' (withForeColor defAttr red) x
Nothing -> emptyImage
ircFormattedText :: Text -> Image
ircFormattedText = ircFormattedText' defaultFormatting
ircFormattedText' :: Formatting -> Text -> Image
ircFormattedText' fmt t = text' (formattingAttr fmt) a <|> rest
where
(a,b) = Text.break isControl t
rest = case Text.uncons b of
Nothing -> emptyImage
Just ('\x02',xs) -> ircFormattedText' (over fmtBold not fmt) xs
Just ('\x0F',xs) -> ircFormattedText' defaultFormatting xs
Just ('\x16',xs) -> ircFormattedText' (over fmtReverse not fmt) xs
Just ('\x1D',xs) -> ircFormattedText' (over fmtItalic not fmt) xs
Just ('\x1F',xs) -> ircFormattedText' (over fmtUnderline not fmt) xs
Just ('\x03',xs)
| Just (fore,xs1) <- colorNumber xs ->
case Text.uncons xs1 of
Just (',',xs2)
| Just (back,xs3) <- colorNumber xs2 -> ircFormattedText'
(set fmtFore (Just fore)
(set fmtBack (Just back) fmt)) xs3
_ -> ircFormattedText' (set fmtFore (Just fore)
(set fmtBack Nothing fmt)) xs1
| otherwise -> ircFormattedText' (set fmtFore Nothing (set fmtBack Nothing fmt)) xs
Just (_,xs) -> ircFormattedText' fmt xs
colorNumber :: Text -> Maybe (Color, Text)
colorNumber t =
do (c1,c2,t1) <- splitNumber t
case (c1,c2) of
('0','0') -> Just (white , t1) -- white
('0','1') -> Just (black , t1) -- black
('0','2') -> Just (blue , t1) -- blue
('0','3') -> Just (green , t1) -- green
('0','4') -> Just (red , t1) -- red
('0','5') -> Just (rgbColor' 127 0 0 , t1) -- brown
('0','6') -> Just (rgbColor' 156 0 156 , t1) -- purple
('0','7') -> Just (rgbColor' 252 127 0 , t1) -- yellow
('0','8') -> Just (yellow , t1) -- yellow
('0','9') -> Just (brightGreen , t1) -- green
('1','0') -> Just (cyan , t1) -- brightBlue
('1','1') -> Just (brightCyan , t1) -- brightCyan
('1','2') -> Just (brightBlue , t1) -- brightBlue
('1','3') -> Just (rgbColor' 255 0 255 , t1) -- brightRed
('1','4') -> Just (rgbColor' 127 127 127, t1) -- brightBlack
('1','5') -> Just (rgbColor' 210 210 210, t1) -- brightWhite
_ -> Nothing
-- Take up to two digits off the front of a text. If there is only
-- a single digit pretend like the first digit was a 0
splitNumber :: Text -> Maybe (Char,Char,Text)
splitNumber t =
do let isNumber x = '0' <= x && x <= '9'
(c1,t1) <- Text.uncons t
guard (isNumber c1)
case Text.uncons t1 of
Just (c2,t2) | isNumber c2 -> Just (c1,c2,t2)
_ -> Just ('0',c1,t1)
rgbColor' :: Int -> Int -> Int -> Color
rgbColor' = rgbColor -- fix the type to Int
defaultFormatting :: Formatting
defaultFormatting = Formatting
{ _fmtFore = Nothing
, _fmtBack = Nothing
, _fmtBold = False
, _fmtItalic = False
, _fmtUnderline = False
, _fmtReverse = False
}
formattingAttr :: Formatting -> Attr
formattingAttr fmt
= addForeColor
$ addBackColor
$ flag (view fmtBold fmt) bold
$ flag (view fmtUnderline fmt) underline
$ flag (view fmtReverse fmt) reverseVideo
-- no italic support
$ defAttr
where
addForeColor x =
case view fmtFore fmt of
Nothing -> x
Just c -> withForeColor x c
addBackColor x =
case view fmtBack fmt of
Nothing -> x
Just c -> withBackColor x c
flag True s x = withStyle x s
flag False _ x = x
identImg :: Attr -> Identifier -> Image
identImg attr = utf8Bytestring' attr . idBytes
-- | Render a string and replace the control characters with
-- reversed video of the associated control key.
stringWithControls :: Attr -> String -> Image
stringWithControls _ [] = emptyImage
stringWithControls attr xs =
case break isControl xs of
(a,[]) -> string attr a
(a,b:bs) -> string attr a
<|> char (withStyle attr reverseVideo)
(controls ! fromEnum b)
<|> stringWithControls attr bs
where
controls = listArray (0,0x1f) ('@':['A'..'Z']++"[\\]^_")
nameHighlighter ::
ByteString -> Set Identifier -> Identifier -> [Color] -> Image
nameHighlighter msg users me colors = aux 0 0
where
lowmsg = ircFoldCase msg
n = B8.length lowmsg
ncolors = length colors
aux lo hi
| hi == n = utf8Bytestring' defAttr (B8.drop lo msg)
| otherwise =
case nameLookup identFromHi users of
Nothing -> aux lo (advance hi)
Just hit -> utf8Bytestring' defAttr
(B8.take (hi-lo) (B8.drop lo msg))
<|> utf8Bytestring' (withForeColor defAttr color) matchRegion
<|> aux hi' hi'
where
-- use the original match region to preserve original case
matchRegion = B8.take (B8.length (idBytes hit)) (B8.drop hi msg)
hi' = hi + B8.length (idDenote hit)
color | me == hit = red
| otherwise = colors
!! mod (nickHash (idDenote hit)) ncolors
where
identFromHi = mkId (B8.drop hi lowmsg)
advance curHi
| curHi + 1 == n = curHi + 1
| isAlphaNum (B8.index lowmsg curHi)
, isAlphaNum (B8.index lowmsg (curHi+1)) = advance (curHi+1)
| otherwise = curHi+1
nameLookup :: Identifier -> Set Identifier -> Maybe Identifier
nameLookup haystack s =
case Set.lookupLE haystack s of
Just x | idDenote x `B8.isPrefixOf` idDenote haystack
, boundaryCheck (idDenote x) -> Just x
_ -> Nothing
where
boundaryCheck needle =
B8.length needle == B8.length (idDenote haystack) ||
not (isAlphaNum (B8.index (idDenote haystack) (B8.length needle)))
nickHash :: ByteString -> Int
nickHash n =
let h1 = B.foldl' (\acc b -> fromIntegral b + 33 * acc) 0 n
in h1 + (h1 `quot` 32)