From c994bee286ebe93551f9a7c1ebb4c1043472a689 Mon Sep 17 00:00:00 2001 From: Kosyrev Serge Date: Sun, 15 Sep 2024 04:52:20 +0300 Subject: [PATCH] TextInput: allow input interpretation, user input error reporting, input completion --- ChangeLog.md | 8 ++ src-bin/example.hs | 4 +- src/Reflex/Vty/Widget/Input/Text.hs | 113 ++++++++++++++++++---------- 3 files changed, 83 insertions(+), 42 deletions(-) diff --git a/ChangeLog.md b/ChangeLog.md index b95cd07..c704355 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,13 @@ # Revision history for reflex-vty +## Unreleased + +* Extend `textInput`, `TextInput` and `TextInputConfig`. + * Expose the current input position. + * Give the user control over input event interpretation. + * Allow the now-exposed input interpreter signal input errors. + * Provide means for input completion by the now-exposed interpreter. + ## 0.5.2.1 * Extend version bounds diff --git a/src-bin/example.hs b/src-bin/example.hs index 9a2a2ea..735790c 100644 --- a/src-bin/example.hs +++ b/src-bin/example.hs @@ -185,10 +185,10 @@ todo t0 = row $ do i <- input v <- textInput $ def { _textInputConfig_initialValue = TZ.fromText $ _todo_label t0 } - let deleteSelf = attachWithMaybe backspaceOnEmpty (current $ _textInput_value v) i + let deleteSelf = attachWithMaybe backspaceOnEmpty (fmap snd . current $ _textInput_value v) i return (v, deleteSelf) return $ TodoOutput - { _todoOutput_todo = Todo <$> _textInput_value ti <*> value + { _todoOutput_todo = Todo <$> fmap snd (_textInput_value ti) <*> value , _todoOutput_delete = d , _todoOutput_height = _textInput_lines ti , _todoOutput_focusId = fid diff --git a/src/Reflex/Vty/Widget/Input/Text.hs b/src/Reflex/Vty/Widget/Input/Text.hs index 7296ddb..963db00 100644 --- a/src/Reflex/Vty/Widget/Input/Text.hs +++ b/src/Reflex/Vty/Widget/Input/Text.hs @@ -9,9 +9,12 @@ module Reflex.Vty.Widget.Input.Text import Control.Monad (join) import Control.Monad.Fix (MonadFix) +import Data.Bifunctor (bimap) import Data.Default (Default(..)) import Data.Function ((&)) +import Data.Functor ((<&>)) import Data.Text (Text) +import qualified Data.Text as T import Data.Text.Zipper import qualified Graphics.Vty as V import Reflex @@ -22,7 +25,7 @@ import Reflex.Vty.Widget.Input.Mouse -- | Configuration options for a 'textInput'. For more information on -- 'TextZipper', see 'Data.Text.Zipper'. -data TextInputConfig t = TextInputConfig +data TextInputConfig t e = TextInputConfig { _textInputConfig_initialValue :: TextZipper -- ^ Initial value. This is a 'TextZipper' because it is more flexible -- than plain 'Text'. For example, this allows to set the Cursor position, @@ -51,29 +54,43 @@ data TextInputConfig t = TextInputConfig , _textInputConfig_display :: Dynamic t (Char -> Char) -- ^ Transform the characters in a text input before displaying them. This is useful, e.g., for -- masking characters when entering passwords. + , _textInputConfig_interpreter :: Int -> Int -> Maybe Text -> V.Event -> TextZipper -> Either e TextZipper + -- ^ Interpret input edit events, optionally by refusing to modify the text and signalling and error. + -- The interpreter takes: + -- - the current tab width and page size, + -- - the input event to be interpreted, + -- - the currently possible completion, and + -- - the state to be modified by the event. + , _textInputConfig_completion :: Behavior t (Maybe Text) + -- ^ An optional suitable completion, that the user can choose to insert, } -instance Reflex t => Default (TextInputConfig t) where - def = TextInputConfig empty never 4 (pure id) +instance Reflex t => Default (TextInputConfig t e) where + def = TextInputConfig empty never 4 (pure id) updateTextZipper (pure Nothing) -- | The output produced by text input widgets, including the text -- value and the number of display lines (post-wrapping). Note that some -- display lines may not be visible due to scrolling. -data TextInput t = TextInput - { _textInput_value :: Dynamic t Text - -- ^ The current value of the textInput as Text. - , _textInput_userInput :: Event t TextZipper +-- The text value is accompanied by an optional error state, +-- as produced by the configured input event handler. +data TextInput t e = TextInput + { _textInput_value :: Dynamic t (Maybe e, Text) + -- ^ The current value of the textInput as Text, with an optional error status. + , _textInput_userInput :: Event t (Maybe e, TextZipper) -- ^ UI Event updates with the current 'TextZipper'. -- This does not include Events added by '_textInputConfig_setValue', but -- it does include '_textInputConfig_modify' Events. , _textInput_lines :: Dynamic t Int + , _textInput_position :: Dynamic t (Int, Int) + -- ^ Current cursor row and column. } -- | A widget that allows text input 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) + :: forall t m e. + (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 e + -> m (TextInput t e) textInput cfg = do i <- input f <- focus @@ -85,14 +102,27 @@ textInput cfg = do -- we split up the events from vty and the one users provide to avoid cyclical -- update dependencies. This way, users may subscribe only to UI updates. let valueChangedByCaller = _textInputConfig_modify cfg - let valueChangedByUI = mergeWith (.) - [ uncurry (updateTextZipper (_textInputConfig_tabWidth cfg)) <$> attach (current dh) i - , let displayInfo = (,) <$> current rows <*> scrollTop + let valueChangedByKeys :: Event t ((Maybe e, TextZipper) -> (Maybe e, TextZipper)) + valueChangedByKeys = + attach (_textInputConfig_completion cfg) (attach (current dh) i) <&> + (\(curCompletion, (curDisplayHeight, inputE)) (_, old) -> + case (_textInputConfig_interpreter cfg) (_textInputConfig_tabWidth cfg) curDisplayHeight curCompletion inputE old of + Left err -> (Just err, old) + Right new -> (Nothing, new)) + let valueChangeByClick :: Event t (TextZipper -> TextZipper) + valueChangeByClick = + let displayInfo = (,) <$> current rows <*> scrollTop in ffor (attach displayInfo click) $ \((dl, st), MouseDown _ (mx, my) _) -> goToDisplayLinePosition mx (st + my) dl + let valueChangedByUI :: Event t ((Maybe e, TextZipper) -> (Maybe e, TextZipper)) + valueChangedByUI = mergeWith (.) + [ valueChangedByKeys + , valueChangeByClick <&> bimap (const Nothing) -- Clicks discard input errors, which should seem logical. ] - v <- foldDyn ($) (_textInputConfig_initialValue cfg) $ mergeWith (.) - [ valueChangedByCaller + let fullInitialState = (,) Nothing (_textInputConfig_initialValue cfg) + v :: Dynamic t (Maybe e, TextZipper) <- foldDyn ($) fullInitialState $ mergeWith (.) + [ valueChangedByCaller <&> bimap id -- Keep the interpreter-produced error state unaffected by the forced input changes. + -- This is clearly suboptimal, but we need an API discussion to resolve the model issues. , valueChangedByUI ] click <- mouseDown V.BLeft @@ -101,14 +131,15 @@ textInput cfg = do let toCursorAttrs attr = V.withStyle attr V.reverseVideo rowInputDyn = (,,) <$> dw - <*> (mapZipper <$> _textInputConfig_display cfg <*> v) + <*> (mapZipper <$> _textInputConfig_display cfg <*> fmap snd v) <*> f - toDisplayLines attr (w, s, x) = - let c = if x then toCursorAttrs attr else attr + toDisplayLines attr (w, s, posx) = + let c = if posx 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 + x <- holdUniqDyn $ T.length . _textZipper_before . snd <$> v y <- holdUniqDyn $ fmap snd _displayLines_cursorPos <$> rows let newScrollTop :: Int -> (Int, Int) -> Int newScrollTop st (h, cursorY) @@ -119,16 +150,17 @@ textInput cfg = do scrollTop <- hold 0 hy tellImages $ (\imgs st -> (:[]) . V.vertCat $ drop st imgs) <$> current img <*> scrollTop return $ TextInput - { _textInput_value = value <$> v + { _textInput_value = bimap id value <$> v , _textInput_userInput = attachWith (&) (current v) valueChangedByUI , _textInput_lines = length . _displayLines_spans <$> rows + , _textInput_position = zipDyn x y } -- | A widget that allows multiline text input 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) + => TextInputConfig t e + -> m (TextInput t e) multilineTextInput cfg = do i <- input textInput $ cfg @@ -145,9 +177,9 @@ multilineTextInput cfg = do -- oriented, and uses the fallback width when horizontally oriented. textInputTile :: (MonadFix m, MonadHold t 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) + => m (TextInput t e) -> Dynamic t Int - -> m (TextInput t) + -> m (TextInput t e) textInputTile txt width = do o <- askOrientation rec t <- tile (Constraint_Fixed <$> sz) txt @@ -172,27 +204,28 @@ spanToImage (Span attrs t) = V.text' attrs t updateTextZipper :: Int -- ^ Tab width -> Int -- ^ Page size + -> Maybe Text -- ^ Completion -> V.Event -- ^ The vty event to handle -> TextZipper -- ^ The zipper to modify - -> TextZipper -updateTextZipper tabWidth pageSize ev = case ev of + -> Either e TextZipper +updateTextZipper tabWidth pageSize _completion ev = case ev of -- Special characters - V.EvKey (V.KChar '\t') [] -> tab tabWidth + V.EvKey (V.KChar '\t') [] -> Right . tab tabWidth -- Regular characters - V.EvKey (V.KChar k) [] -> insertChar k + V.EvKey (V.KChar k) [] -> Right . insertChar k -- Deletion buttons - V.EvKey V.KBS [] -> deleteLeft - V.EvKey V.KDel [] -> deleteRight + V.EvKey V.KBS [] -> Right . deleteLeft + V.EvKey V.KDel [] -> Right . deleteRight -- Key combinations - V.EvKey (V.KChar 'u') [V.MCtrl] -> const empty - V.EvKey (V.KChar 'w') [V.MCtrl] -> deleteLeftWord + V.EvKey (V.KChar 'u') [V.MCtrl] -> Right . const empty + V.EvKey (V.KChar 'w') [V.MCtrl] -> Right . deleteLeftWord -- Arrow keys - 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 + V.EvKey V.KLeft [] -> Right . left + V.EvKey V.KRight [] -> Right . right + V.EvKey V.KUp [] -> Right . up + V.EvKey V.KDown [] -> Right . down + V.EvKey V.KHome [] -> Right . home + V.EvKey V.KEnd [] -> Right . end + V.EvKey V.KPageUp [] -> Right . pageUp pageSize + V.EvKey V.KPageDown [] -> Right . pageDown pageSize + _ -> Right . id