{-# Language BangPatterns #-}
module Client.Image.Textbox
( textboxImage
) where
import Client.Configuration
import Client.Commands
import Client.Commands.Arguments
import Client.Commands.Interpolation
import Client.Commands.Recognizer
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 Data.Monoid
import qualified Data.Text as Text
import Graphics.Vty.Attributes
import Graphics.Vty.Image
textboxImage :: ClientState -> (Int, Int, Image)
textboxImage st
= (newPos, newOffset, croppedImage)
where
width = view clientWidth st
macros = views (clientConfig . configMacros) (fmap macroSpec) st
(txt, content) =
views (clientTextBox . Edit.content) (renderContent macros pal) st
lineImage = beginning <|> content <|> ending
leftOfCurWidth = myWcswidth ('^':txt)
croppedImage = cropLeft (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 '$'
renderContent ::
Recognizer MacroSpec ->
Palette ->
Edit.Content ->
(String, Image)
renderContent 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
wholeImg = horizCat
$ intersperse (plainText "\n")
$ map renderOtherLine as
++ renderLine macros pal curTxt
: map renderOtherLine bs
myWcwidth :: Char -> Int
myWcwidth x
| isControl x = 1
| otherwise = wcwidth x
myWcswidth :: String -> Int
myWcswidth = sum . map myWcwidth
renderOtherLine :: String -> Image
renderOtherLine = parseIrcTextExplicit . Text.pack
renderLine :: Recognizer MacroSpec -> Palette -> String -> Image
renderLine macros pal ('/':xs)
= char defAttr '/' <|> string attr cmd <|> continue rest
where
specAttr spec =
case parseArguments spec rest of
Nothing -> view palCommand pal
Just{} -> view palCommandReady pal
(cmd, rest) = break isSpace xs
allCommands = (Left <$> macros) <> (Right <$> commands)
(attr, continue)
= case recognize (Text.pack cmd) allCommands of
Exact (Right Command{cmdArgumentSpec = spec}) ->
( specAttr spec
, argumentsImage pal spec
)
Exact (Left (MacroSpec spec)) ->
( specAttr spec
, argumentsImage pal spec
)
Prefix _ ->
( view palCommandPrefix pal
, renderOtherLine
)
Invalid ->
( view palCommandError pal
, renderOtherLine
)
renderLine _ _ xs = parseIrcTextExplicit (Text.pack xs)