module Reflex.Vty.Widget.Input.Text
( module Reflex.Vty.Widget.Input.Text
, def
) where
import Control.Monad (join)
import Control.Monad.Fix (MonadFix)
import Data.Default (Default(..))
import Data.Function ((&))
import Data.Text (Text)
import Data.Text.Zipper
import qualified Graphics.Vty as V
import Reflex
import Reflex.Vty.Widget
import Reflex.Vty.Widget.Layout
import Reflex.Vty.Widget.Input.Mouse
data TextInputConfig t = TextInputConfig
{ _textInputConfig_initialValue :: TextZipper
, _textInputConfig_modify :: Event t (TextZipper -> TextZipper)
, _textInputConfig_tabWidth :: Int
, _textInputConfig_display :: Dynamic t (Char -> Char)
}
instance Reflex t => Default (TextInputConfig t) where
def = TextInputConfig empty never 4 (pure id)
data TextInput t = TextInput
{ _textInput_value :: Dynamic t Text
, _textInput_userInput :: Event t TextZipper
, _textInput_lines :: Dynamic t Int
}
textInput
:: (Reflex t, MonadHold t m, MonadFix m, HasInput t m, HasFocusReader t m, HasTheme t m, HasDisplayRegion t m, HasImageWriter t m, HasDisplayRegion t m)
=> TextInputConfig t
-> m (TextInput t)
textInput cfg = do
i <- input
f <- focus
dh <- displayHeight
dw <- displayWidth
bt <- theme
attr0 <- sample bt
rec
let valueChangedByCaller = _textInputConfig_modify cfg
let valueChangedByUI = mergeWith (.)
[ uncurry (updateTextZipper (_textInputConfig_tabWidth cfg)) <$> attach (current dh) i
, let displayInfo = (,) <$> current rows <*> scrollTop
in ffor (attach displayInfo click) $ \((dl, st), MouseDown _ (mx, my) _) ->
goToDisplayLinePosition mx (st + my) dl
]
v <- foldDyn ($) (_textInputConfig_initialValue cfg) $ mergeWith (.)
[ valueChangedByCaller
, valueChangedByUI
]
click <- mouseDown V.BLeft
let toCursorAttrs attr = V.withStyle attr V.reverseVideo
rowInputDyn = (,,)
<$> dw
<*> (mapZipper <$> _textInputConfig_display cfg <*> v)
<*> f
toDisplayLines attr (w, s, x) =
let c = if x then toCursorAttrs attr else attr
in displayLines w attr c s
attrDyn <- holdDyn attr0 $ pushAlways (\_ -> sample bt) (updated rowInputDyn)
let rows = ffor2 attrDyn rowInputDyn toDisplayLines
img = images . _displayLines_spans <$> rows
y <- holdUniqDyn $ fmap snd _displayLines_cursorPos <$> rows
let newScrollTop :: Int -> (Int, Int) -> Int
newScrollTop st (h, cursorY)
| cursorY < st = cursorY
| cursorY >= st + h = cursorY - h + 1
| otherwise = st
let hy = attachWith newScrollTop scrollTop $ updated $ zipDyn dh y
scrollTop <- hold 0 hy
tellImages $ (\imgs st -> (:[]) . V.vertCat $ drop st imgs) <$> current img <*> scrollTop
return $ TextInput
{ _textInput_value = value <$> v
, _textInput_userInput = attachWith (&) (current v) valueChangedByUI
, _textInput_lines = length . _displayLines_spans <$> rows
}
multilineTextInput
:: (Reflex t, MonadHold t m, MonadFix m, HasInput t m, HasFocusReader t m, HasTheme t m, HasDisplayRegion t m, HasImageWriter t m)
=> TextInputConfig t
-> m (TextInput t)
multilineTextInput cfg = do
i <- input
textInput $ cfg
{ _textInputConfig_modify = mergeWith (.)
[ fforMaybe i $ \case
V.EvKey V.KEnter [] -> Just $ insert "\n"
_ -> Nothing
, _textInputConfig_modify cfg
]
}
textInputTile
:: (Monad m, Reflex t, MonadFix m, HasLayout t m, HasInput t m, HasFocus t m, HasImageWriter t m, HasDisplayRegion t m, HasFocusReader t m, HasTheme t m)
=> m (TextInput t)
-> Dynamic t Int
-> m (TextInput t)
textInputTile txt width = do
o <- askOrientation
rec t <- tile (Constraint_Fixed <$> sz) txt
let sz = join $ ffor o $ \case
Orientation_Column -> _textInput_lines t
Orientation_Row -> width
return t
images :: [[Span V.Attr]] -> [V.Image]
images = map (V.horizCat . map spanToImage)
image :: [[Span V.Attr]] -> V.Image
image = V.vertCat . images
spanToImage :: Span V.Attr -> V.Image
spanToImage (Span attrs t) = V.text' attrs t
updateTextZipper
:: Int
-> Int
-> V.Event
-> TextZipper
-> TextZipper
updateTextZipper tabWidth pageSize ev = case ev of
V.EvKey (V.KChar '\t') [] -> tab tabWidth
V.EvKey (V.KChar k) [] -> insertChar k
V.EvKey V.KBS [] -> deleteLeft
V.EvKey V.KDel [] -> deleteRight
V.EvKey (V.KChar 'u') [V.MCtrl] -> const empty
V.EvKey (V.KChar 'w') [V.MCtrl] -> deleteLeftWord
V.EvKey V.KLeft [] -> left
V.EvKey V.KRight [] -> right
V.EvKey V.KUp [] -> up
V.EvKey V.KDown [] -> down
V.EvKey V.KHome [] -> home
V.EvKey V.KEnd [] -> end
V.EvKey V.KPageUp [] -> pageUp pageSize
V.EvKey V.KPageDown [] -> pageDown pageSize
_ -> id