{-# Language BangPatterns #-}
module Client.Image.Textbox where
import Client.Configuration
import Client.Commands
import Client.Commands.Arguments
import Client.Image.Arguments
import Client.Image.MircFormatting
import Client.Image.Palette
import Client.State
import qualified Client.State.EditBox as Edit
import Control.Lens
import Data.Char
import Data.List
import qualified Data.Text as Text
import Graphics.Vty.Image
textboxImage :: ClientState -> (Int, Image)
textboxImage st
= (pos, croppedImage)
where
width = view clientWidth st
(txt, content) =
views (clientTextBox . Edit.content) (renderContent pal) st
pos = computeCharWidth (width-1) txt
pal = view (clientConfig . configPalette) st
lineImage = beginning <|> content <|> ending
leftOfCurWidth = myWcswidth txt
croppedImage
| leftOfCurWidth < width = lineImage
| otherwise = cropLeft width (cropRight (leftOfCurWidth+1) lineImage)
attr = view (clientConfig . configPalette . palTextBox) st
beginning = char attr '^'
ending = char attr '$'
renderContent :: Palette -> Edit.Content -> (String, Image)
renderContent pal c = (txt, wholeImg)
where
as = reverse (view Edit.above c)
bs = view Edit.below c
cur = view Edit.line c
leftCur = take (view Edit.pos cur) (view Edit.text cur)
txt = '^' : foldl (\acc x -> x ++ ' ' : acc) leftCur as
wholeImg = horizCat
$ intersperse (plainText "\n")
$ map (parseIrcTextExplicit . Text.pack) as
++ renderLine pal (view Edit.text cur)
: map (parseIrcTextExplicit . Text.pack) bs
computeCharWidth ::
Int ->
String ->
Int
computeCharWidth = go 0
where
go !acc _ [] = acc
go acc 0 _ = acc
go acc w (x:xs)
| z > w = acc + w
| otherwise = go (acc+1) (w-z) xs
where
z = myWcwidth x
myWcwidth :: Char -> Int
myWcwidth x
| isControl x = 1
| otherwise = wcwidth x
myWcswidth :: String -> Int
myWcswidth = sum . map myWcwidth
renderLine :: Palette -> String -> Image
renderLine pal ('/':xs)
| (cmd,rest) <- break isSpace xs
, Just (Command spec _) <- view (at (Text.pack cmd)) commands
, let attr =
case parseArguments spec rest of
Nothing -> view palCommand pal
Just{} -> view palCommandReady pal
= char defAttr '/' <|>
string attr cmd <|>
argumentsImage pal spec rest
renderLine _ xs = parseIrcTextExplicit (Text.pack xs)