TextInput: allow input interpretation, user input error reporting and input completion

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
 

src-bin/example.hs

@@ -185,10 +185,10 @@
             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
@@ -302,7 +302,7 @@
     div' = liftA2 div
 
 debugFocus :: (VtyExample t m) => m ()
 debugFocus = do
   f <- focus
   text $ T.pack . show <$> current f
 
@@ -317,5 +317,5 @@
   text $ T.pack <$> lastEvent
 
 testStringBox :: VtyExample t m => m ()
 testStringBox = boxStatic singleBoxStyle .
   text . pure . T.pack . take 500 $ cycle ('\n' : ['a'..'z'])

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