{-# Language BangPatterns #-}

{-|
Module      : Client.Image.Textbox
Description : Textbox renderer
Copyright   : (c) Eric Mertens, 2016
License     : ISC
Maintainer  : emertens@gmail.com

This module provides the renderer for the client's text box input.

-}

module Client.Image.Textbox
  ( textboxImage
  ) where

import Client.Configuration
import Client.Commands (Command(Command, cmdArgumentSpec), commands)
import Client.Commands.Arguments.Renderer (render)
import Client.Commands.Arguments.Parser (parse)
import Client.Commands.Interpolation (Macro(macroSpec), MacroSpec(..))
import Client.Commands.Recognizer
import Client.Image.LineWrap (fullLineWrap, terminate)
import Client.Image.Message (cleanChar, parseIrcTextWithNicks, Highlight)
import Client.Image.MircFormatting (parseIrcText', plainText)
import Client.Image.PackedImage (char, imageWidth, string, unpackImage, Image')
import Client.Image.Palette
import Client.State
import Client.State.EditBox qualified as Edit
import Control.Lens (view, views)
import Data.HashMap.Strict (HashMap)
import Data.List (intersperse)
import Data.Text qualified as Text
import Graphics.Vty.Attributes (defAttr)
import Graphics.Vty.Image qualified as Vty
import Irc.Identifier (Identifier)

textboxImage :: Int -> Int -> ClientState -> (Int, Int, Int, Vty.Image) -- ^ cursor column, new offset, image
textboxImage :: Int -> Int -> ClientState -> (Int, Int, Int, Image)
textboxImage Int
maxHeight Int
width ClientState
st =
  case forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' ClientState EditMode
clientEditMode ClientState
st of
    EditMode
SingleLineEditor -> Int -> Int -> ClientState -> (Int, Int, Int, Image)
singleLineTextboxImage Int
maxHeight Int
width ClientState
st
    EditMode
MultiLineEditor  -> Int -> Int -> ClientState -> (Int, Int, Int, Image)
multiLineTextboxImage  Int
maxHeight Int
width ClientState
st

multiLineTextboxImage :: Int -> Int -> ClientState -> (Int, Int, Int, Vty.Image) -- ^ cursor column, new offset, image
multiLineTextboxImage :: Int -> Int -> ClientState -> (Int, Int, Int, Image)
multiLineTextboxImage Int
_maxHeight Int
width ClientState
st = (Int
cursorRow, Int
cursorCol, forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' ClientState Int
clientTextBoxOffset ClientState
st, Image
output)
  where
  output :: Image
output = [Image] -> Image
Vty.vertCat (Int -> Image -> Image
terminate Int
width forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image' -> Image
unpackImage forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Image']
imgs)

  imgs :: [Image']
imgs = [Image']
as forall a. [a] -> [a] -> [a]
++ [Image']
c forall a. [a] -> [a] -> [a]
++ [Image']
bs

  content :: Content
content = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Lens' ClientState EditBox
clientTextBox forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' EditBox Content
Edit.content) ClientState
st

  as :: [Image']
as  = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Int -> Image' -> [Image']
fullLineWrap Int
width)
      forall a b. (a -> b) -> a -> b
$ forall a. (a -> a) -> [a] -> [a]
mapHead (Image'
beginning forall a. Semigroup a => a -> a -> a
<>)
      forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a. Semigroup a => a -> a -> a
<> String -> Image'
plainText String
"\n")
      forall a b. (a -> b) -> a -> b
$ Bool -> String -> Image'
rndr Bool
False forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. [a] -> [a]
reverse (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Content [String]
Edit.above Content
content)

  bs :: [Image']
bs  = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Int -> Image' -> [Image']
fullLineWrap Int
width)
      forall a b. (a -> b) -> a -> b
$ [Image'] -> [Image']
endAfters
      forall a b. (a -> b) -> a -> b
$ Bool -> String -> Image'
rndr Bool
False forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Content [String]
Edit.below Content
content

  cur :: Line
cur = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall c. HasLine c => Lens' c Line
Edit.line Content
content
  curTxt :: String
curTxt  = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall c. HasLine c => Lens' c String
Edit.text Line
cur

  cursorBase :: Int
cursorBase
    = Image' -> Int
imageWidth forall a b. (a -> b) -> a -> b
$ Bool -> Palette -> Text -> Image'
parseIrcText' Bool
True Palette
pal
    forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack
    forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
take (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall c. HasLine c => Lens' c Int
Edit.pos Line
cur) String
curTxt

  (Int
cursorRow, Int
cursorCol) =
    forall {t}. Num t => t -> [Image'] -> Int -> (t, Int)
calcCol (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Image']
c forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> Int
length [Image']
bs) [Image']
c (if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Image']
as then Int
1 forall a. Num a => a -> a -> a
+ Int
cursorBase else Int
cursorBase)

  c :: [Image']
c = Int -> Image' -> [Image']
fullLineWrap Int
width
    forall a b. (a -> b) -> a -> b
$ (if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Image']
as then Image'
beginning else forall a. Monoid a => a
mempty)
   forall a. Semigroup a => a -> a -> a
<> Bool -> String -> Image'
rndr Bool
True String
curTxt
   forall a. Semigroup a => a -> a -> a
<> (if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Image']
bs then Image'
ending else String -> Image'
plainText String
"\n")

  rndr :: Bool -> String -> Image'
rndr = ClientState
-> Palette
-> HashMap Identifier Highlight
-> Recognizer MacroSpec
-> Bool
-> String
-> Image'
renderLine ClientState
st Palette
pal HashMap Identifier Highlight
hilites Recognizer MacroSpec
macros
  pal :: Palette
pal = ClientState -> Palette
clientPalette ClientState
st
  hilites :: HashMap Identifier Highlight
hilites = Focus -> ClientState -> HashMap Identifier Highlight
clientHighlightsFocus (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' ClientState Focus
clientFocus ClientState
st) ClientState
st
  macros :: Recognizer MacroSpec
macros = forall s (m :: * -> *) r a.
MonadReader s m =>
LensLike' (Const r) s a -> (a -> r) -> m r
views (Lens' ClientState Configuration
clientConfig forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Configuration (Recognizer Macro)
configMacros) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Macro -> MacroSpec
macroSpec) ClientState
st

  attr :: Attr
attr      = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Palette Attr
palTextBox Palette
pal
  beginning :: Image'
beginning = Attr -> Char -> Image'
char Attr
attr Char
'^'
  ending :: Image'
ending    = Attr -> Char -> Image'
char Attr
attr Char
'$'

  endAfters :: [Image'] -> [Image']
endAfters [] = []
  endAfters [Image'
x] = [Image'
x forall a. Semigroup a => a -> a -> a
<> Image'
ending]
  endAfters (Image'
x:[Image']
xs) = Image'
x forall a. Semigroup a => a -> a -> a
<> String -> Image'
plainText String
"\n" forall a. a -> [a] -> [a]
: [Image'] -> [Image']
endAfters [Image']
xs

  -- Using fullLineWrap make calculating the cursor much easier
  -- to switch to word-breaking lineWrap we'll need some extra
  -- logic to count skipped spaces.
  calcCol :: t -> [Image'] -> Int -> (t, Int)
calcCol t
row [] Int
_ = (t
row, Int
0)
  calcCol t
row (Image'
i:[Image']
is) Int
n
    | Int
n forall a. Ord a => a -> a -> Bool
< Int
w = (t
row, Int
n)
    | Bool
otherwise = t -> [Image'] -> Int -> (t, Int)
calcCol (t
rowforall a. Num a => a -> a -> a
-t
1) [Image']
is (Int
nforall a. Num a => a -> a -> a
-Int
w)
    where
      w :: Int
w = Image' -> Int
imageWidth Image'
i

mapHead :: (a -> a) -> [a] -> [a]
mapHead :: forall a. (a -> a) -> [a] -> [a]
mapHead a -> a
f (a
x:[a]
xs) = a -> a
f a
x forall a. a -> [a] -> [a]
: [a]
xs
mapHead a -> a
_ []     = []

-- | Compute the UI image for the text input box. This computes
-- the logical cursor position on the screen to compensate for
-- VTY's cursor placement behavior.
singleLineTextboxImage :: Int -> Int -> ClientState -> (Int, Int, Int, Vty.Image) -- ^ cursor column, new offset, image
singleLineTextboxImage :: Int -> Int -> ClientState -> (Int, Int, Int, Image)
singleLineTextboxImage Int
_maxHeight Int
width ClientState
st
  = (Int
1, Int
newPos, Int
newOffset, Image
croppedImage)
  where
  macros :: Recognizer MacroSpec
macros = forall s (m :: * -> *) r a.
MonadReader s m =>
LensLike' (Const r) s a -> (a -> r) -> m r
views (Lens' ClientState Configuration
clientConfig forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Configuration (Recognizer Macro)
configMacros) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Macro -> MacroSpec
macroSpec) ClientState
st
  (Int
txt, Image'
content) =
     ClientState
-> HashMap Identifier Highlight
-> Recognizer MacroSpec
-> Palette
-> Content
-> (Int, Image')
renderContent ClientState
st HashMap Identifier Highlight
hilites Recognizer MacroSpec
macros Palette
pal
       (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Lens' ClientState EditBox
clientTextBox forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' EditBox Content
Edit.content) ClientState
st)

  lineImage :: Image
lineImage = Image' -> Image
unpackImage (Image'
beginning forall a. Semigroup a => a -> a -> a
<> Image'
content forall a. Semigroup a => a -> a -> a
<> Image'
ending)

  leftOfCurWidth :: Int
leftOfCurWidth = Int
1 forall a. Num a => a -> a -> a
+ Int
txt

  croppedImage :: Image
croppedImage = Int -> Image -> Image
Vty.resizeWidth Int
width
               forall a b. (a -> b) -> a -> b
$ Int -> Image -> Image
Vty.cropLeft (Image -> Int
Vty.imageWidth Image
lineImage forall a. Num a => a -> a -> a
- Int
newOffset) Image
lineImage

  cursorAnchor :: Int
cursorAnchor = Int
width forall a. Num a => a -> a -> a
* Int
3 forall a. Integral a => a -> a -> a
`quot` Int
4

  -- previous offset value
  oldOffset :: Int
oldOffset = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' ClientState Int
clientTextBoxOffset ClientState
st

  -- position based on old offset
  oldPos :: Int
oldPos = Int
leftOfCurWidth forall a. Num a => a -> a -> a
- Int
oldOffset

  -- new offset (number of columns to trim from left side of text box)
  newOffset :: Int
newOffset
    | Int
0 forall a. Ord a => a -> a -> Bool
<= Int
oldPos, Int
oldPos forall a. Ord a => a -> a -> Bool
< Int
width = Int
oldOffset
    | Bool
otherwise                   = forall a. Ord a => a -> a -> a
max Int
0 (Int
leftOfCurWidth forall a. Num a => a -> a -> a
- Int
cursorAnchor)

  newPos :: Int
newPos = Int
leftOfCurWidth forall a. Num a => a -> a -> a
- Int
newOffset

  pal :: Palette
pal       = ClientState -> Palette
clientPalette ClientState
st
  attr :: Attr
attr      = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Palette Attr
palTextBox Palette
pal
  beginning :: Image'
beginning = Attr -> Char -> Image'
char Attr
attr Char
'^'
  ending :: Image'
ending    = Attr -> Char -> Image'
char Attr
attr Char
'$'

  hilites :: HashMap Identifier Highlight
hilites = Focus -> ClientState -> HashMap Identifier Highlight
clientHighlightsFocus (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' ClientState Focus
clientFocus ClientState
st) ClientState
st


-- | Renders the whole, uncropped text box as well as the 'String'
-- corresponding to the rendered image which can be used for computing
-- the logical cursor position of the cropped version of the text box.
renderContent ::
  ClientState          {- ^ client state                          -} ->
  HashMap Identifier Highlight {- ^ highlights                    -} ->
  Recognizer MacroSpec {- ^ macro completions                     -} ->
  Palette              {- ^ palette                               -} ->
  Edit.Content         {- ^ content                               -} ->
  (Int, Image')        {- ^ left-of-cursor width, image rendering -}
renderContent :: ClientState
-> HashMap Identifier Highlight
-> Recognizer MacroSpec
-> Palette
-> Content
-> (Int, Image')
renderContent ClientState
st HashMap Identifier Highlight
hilites Recognizer MacroSpec
macros Palette
pal Content
c = (Int
leftLen, Image'
wholeImg)
  where
  as :: [String]
as  = forall a. [a] -> [a]
reverse (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Content [String]
Edit.above Content
c)
  bs :: [String]
bs  = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Content [String]
Edit.below Content
c
  cur :: Line
cur = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall c. HasLine c => Lens' c Line
Edit.line Content
c

  curTxt :: String
curTxt  = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall c. HasLine c => Lens' c String
Edit.text Line
cur
  leftCur :: String
leftCur = forall a. Int -> [a] -> [a]
take (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall c. HasLine c => Lens' c Int
Edit.pos Line
cur) (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall c. HasLine c => Lens' c String
Edit.text Line
cur)

  -- ["one","two"] "three" --> "two one three"
  leftLen :: Int
leftLen = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Image']
leftImgs -- separators
          forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (forall a b. (a -> b) -> [a] -> [b]
map Image' -> Int
imageWidth [Image']
leftImgs)
          forall a. Num a => a -> a -> a
+ Image' -> Int
imageWidth (Bool -> Palette -> Text -> Image'
parseIrcText' Bool
True Palette
pal (String -> Text
Text.pack String
leftCur))

  rndr :: Bool -> String -> Image'
rndr = ClientState
-> Palette
-> HashMap Identifier Highlight
-> Recognizer MacroSpec
-> Bool
-> String
-> Image'
renderLine ClientState
st Palette
pal HashMap Identifier Highlight
hilites Recognizer MacroSpec
macros

  leftImgs :: [Image']
leftImgs = forall a b. (a -> b) -> [a] -> [b]
map (Bool -> String -> Image'
rndr Bool
False) [String]
as

  wholeImg :: Image'
wholeImg = forall a. Monoid a => [a] -> a
mconcat
           forall a b. (a -> b) -> a -> b
$ forall a. a -> [a] -> [a]
intersperse (String -> Image'
plainText String
"\n")
           forall a b. (a -> b) -> a -> b
$ [Image']
leftImgs
          forall a. [a] -> [a] -> [a]
++ Bool -> String -> Image'
rndr Bool
True String
curTxt
           forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (Bool -> String -> Image'
rndr Bool
False) [String]
bs


-- | Render the active text box line using command highlighting and
-- placeholders, and WYSIWYG mIRC formatting control characters.
renderLine ::
  ClientState ->
  Palette ->
  HashMap Identifier Highlight ->
  Recognizer MacroSpec {- ^ commands     -} ->
  Bool                 {- ^ focused      -} ->
  String               {- ^ input text   -} ->
  Image'               {- ^ output image -}
renderLine :: ClientState
-> Palette
-> HashMap Identifier Highlight
-> Recognizer MacroSpec
-> Bool
-> String
-> Image'
renderLine ClientState
st Palette
pal HashMap Identifier Highlight
hilites Recognizer MacroSpec
macros Bool
focused String
input =

  case forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char
' 'forall a. Eq a => a -> a -> Bool
==) String
input of
    (String
spcs, Char
'/':String
xs) -> Attr -> String -> Image'
string Attr
defAttr String
spcs forall a. Semigroup a => a -> a -> a
<> Attr -> Char -> Image'
char Attr
defAttr Char
'/'
                   forall a. Semigroup a => a -> a -> a
<> Attr -> String -> Image'
string Attr
attr String
cleanCmd forall a. Semigroup a => a -> a -> a
<> String -> Image'
continue String
rest
      where
        specAttr :: Args ClientState a -> Attr
specAttr Args ClientState a
spec =
          case forall r a. r -> Args r a -> String -> Maybe a
parse ClientState
st Args ClientState a
spec String
rest of
            Maybe a
Nothing -> forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Palette Attr
palCommand      Palette
pal
            Just{}  -> forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Palette Attr
palCommandReady Palette
pal

        (String
cmd, String
rest) = forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char
' 'forall a. Eq a => a -> a -> Bool
==) String
xs
        cleanCmd :: String
cleanCmd = forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
cleanChar String
cmd

        allCommands :: Recognizer (Either MacroSpec Command)
allCommands = (forall a b. a -> Either a b
Left forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Recognizer MacroSpec
macros) forall a. Semigroup a => a -> a -> a
<> (forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Recognizer Command
commands)
        (Attr
attr, String -> Image'
continue)
          = case forall a. Text -> Recognizer a -> Recognition a
recognize (Text -> Text
Text.toLower (String -> Text
Text.pack String
cmd)) Recognizer (Either MacroSpec Command)
allCommands of
              Exact (Right Command{cmdArgumentSpec :: ()
cmdArgumentSpec = Args ClientState a
spec}) ->
                ( forall {a}. Args ClientState a -> Attr
specAttr Args ClientState a
spec
                , forall r a. Palette -> r -> Bool -> Args r a -> String -> Image'
render Palette
pal ClientState
st Bool
focused Args ClientState a
spec
                )
              Exact (Left (MacroSpec forall r. Args r [String]
spec)) ->
                ( forall {a}. Args ClientState a -> Attr
specAttr forall r. Args r [String]
spec
                , forall r a. Palette -> r -> Bool -> Args r a -> String -> Image'
render Palette
pal ClientState
st Bool
focused forall r. Args r [String]
spec
                )
              Prefix [Text]
_ ->
                ( forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Palette Attr
palCommandPrefix Palette
pal
                , Palette -> HashMap Identifier Highlight -> Bool -> Text -> Image'
parseIrcTextWithNicks Palette
pal HashMap Identifier Highlight
hilites Bool
focused forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack
                )
              Recognition (Either MacroSpec Command)
Invalid ->
                ( forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Palette Attr
palCommandError Palette
pal
                , Palette -> HashMap Identifier Highlight -> Bool -> Text -> Image'
parseIrcTextWithNicks Palette
pal HashMap Identifier Highlight
hilites Bool
focused forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack
                )
    (String, String)
_ -> Palette -> HashMap Identifier Highlight -> Bool -> Text -> Image'
parseIrcTextWithNicks Palette
pal HashMap Identifier Highlight
hilites Bool
focused (String -> Text
Text.pack String
input)