{-# Language BangPatterns #-}
module Client.Image.Textbox
( textboxImage
) where
import Client.Configuration
import Client.Commands
import Client.Commands.Arguments.Renderer
import Client.Commands.Arguments.Parser
import Client.Commands.Interpolation
import Client.Commands.Recognizer
import Client.Image.Message
import Client.Image.MircFormatting
import Client.Image.PackedImage
import Client.Image.Palette
import Client.State
import Client.State.Focus
import qualified Client.State.EditBox as Edit
import Control.Lens
import Data.Char
import qualified Data.HashSet as HashSet
import Data.HashSet (HashSet)
import Data.List
import Data.Semigroup
import qualified Data.Text as Text
import Graphics.Vty.Attributes
import qualified Graphics.Vty.Image as Vty
import Irc.Identifier
textboxImage :: Int -> ClientState -> (Int, Int, Vty.Image)
textboxImage width st
= (newPos, newOffset, croppedImage)
where
macros = views (clientConfig . configMacros) (fmap macroSpec) st
(txt, content) =
views (clientTextBox . Edit.content) (renderContent st myNick nicks macros pal) st
lineImage = unpackImage (beginning <> content <> ending)
leftOfCurWidth = myWcswidth ('^':txt)
croppedImage = Vty.resizeWidth width
$ Vty.cropLeft (Vty.imageWidth lineImage - newOffset) lineImage
cursorAnchor = width * 3 `quot` 4
oldOffset = view clientTextBoxOffset st
oldPos = leftOfCurWidth - oldOffset
newOffset
| 0 <= oldPos, oldPos < width = oldOffset
| otherwise = max 0 (leftOfCurWidth - cursorAnchor)
newPos = leftOfCurWidth - newOffset
pal = clientPalette st
attr = view palTextBox pal
beginning = char attr '^'
ending = char attr '$'
(myNick,nicks) =
case view clientFocus st of
ChannelFocus network channel ->
(clientHighlightsNetwork network st,
HashSet.fromList (channelUserList network channel st)
)
_ -> (HashSet.empty, HashSet.empty)
renderContent ::
ClientState ->
HashSet Identifier ->
HashSet Identifier ->
Recognizer MacroSpec ->
Palette ->
Edit.Content ->
(String, Image')
renderContent st myNick nicks macros pal c = (txt, wholeImg)
where
as = reverse (view Edit.above c)
bs = view Edit.below c
cur = view Edit.line c
curTxt = view Edit.text cur
leftCur = take (view Edit.pos cur) (view Edit.text cur)
txt = foldl (\acc x -> x ++ ' ' : acc) leftCur as
rndr = renderLine st pal myNick nicks macros
wholeImg = mconcat
$ intersperse (plainText "\n")
$ map (rndr False) as
++ rndr True curTxt
: map (rndr False) bs
myWcwidth :: Char -> Int
myWcwidth x
| isControl x = 1
| otherwise = Vty.wcwidth x
myWcswidth :: String -> Int
myWcswidth = sum . map myWcwidth
renderLine ::
ClientState ->
Palette ->
HashSet Identifier ->
HashSet Identifier ->
Recognizer MacroSpec ->
Bool ->
String ->
Image'
renderLine st pal myNick nicks macros focused ('/':xs) =
char defAttr '/' <> string attr cleanCmd <> continue rest
where
specAttr spec =
case parse st spec rest of
Nothing -> view palCommand pal
Just{} -> view palCommandReady pal
(cmd, rest) = break isSpace xs
cleanCmd = map cleanChar cmd
allCommands = (Left <$> macros) <> (Right <$> commands)
(attr, continue)
= case recognize (Text.pack cmd) allCommands of
Exact (Right Command{cmdArgumentSpec = spec}) ->
( specAttr spec
, render pal st focused spec
)
Exact (Left (MacroSpec spec)) ->
( specAttr spec
, render pal st focused spec
)
Prefix _ ->
( view palCommandPrefix pal
, parseIrcTextWithNicks pal myNick nicks focused . Text.pack
)
Invalid ->
( view palCommandError pal
, parseIrcTextWithNicks pal myNick nicks focused . Text.pack
)
renderLine _ pal myNick nicks _ focused xs = parseIrcTextWithNicks pal myNick nicks focused (Text.pack xs)