{-# Language BangPatterns #-}
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)
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)
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
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
_ [] = []
singleLineTextboxImage :: Int -> Int -> ClientState -> (Int, Int, Int, Vty.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
oldOffset :: Int
oldOffset = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' ClientState Int
clientTextBoxOffset ClientState
st
oldPos :: Int
oldPos = Int
leftOfCurWidth forall a. Num a => a -> a -> a
- Int
oldOffset
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
renderContent ::
ClientState ->
HashMap Identifier Highlight ->
Recognizer MacroSpec ->
Palette ->
Edit.Content ->
(Int, Image')
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)
leftLen :: Int
leftLen = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Image']
leftImgs
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
renderLine ::
ClientState ->
Palette ->
HashMap Identifier Highlight ->
Recognizer MacroSpec ->
Bool ->
String ->
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)