Text.hs

-- |
-- Module: Reflex.Vty.Widget.Input.Text
-- Description: Widgets for accepting text input from users and manipulating text within those inputs
module Reflex.Vty.Widget.Input.Text
  ( module Reflex.Vty.Widget.Input.Text
  , def
  ) where

import Control.Monad.Fix (MonadFix)
import Data.Default (Default (..))
import Data.Function ((&))
import Data.Text (Text)
import qualified Data.Text.Encoding as TE
import Data.Text.Encoding.Error (lenientDecode)
import qualified Graphics.Vty as V
import Reflex

import Data.Text.Zipper
import Reflex.Vty.Style (Style, applyAttr)
import Reflex.Vty.Theme (Theme (..))
import Reflex.Vty.Widget
import Reflex.Vty.Widget.Input.Mouse
import Reflex.Vty.Widget.Layout

-- | Configuration options for a 'textInput'. For more information on
-- 'TextZipper', see 'Data.Text.Zipper'.
data TextInputConfig t = 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,
  --   by choosing appropriate values for '_textZipper_before' and '_textZipper_after'.
  , _textInputConfig_modify :: Event t (TextZipper -> TextZipper)
  -- ^ Event to update the value of the 'textInput'.
  --
  --   Event is applied after other Input sources have been applied to the 'TextZipper',
  --   thus you may modify the final value that is displayed to the user.
  --
  --   You may set the value of the displayed text in 'textInput' by ignoring the input parameter.
  --
  --   Additionally, you can modify the updated value before displaying it to the user.
  --   For example, the following 'TextInputConfig' inserts an additional 'a'
  --   when the letter 'b' is entered into 'textInput':
  --
  --   @
  --   i <- input
  --   textInput def
  --     { _textInputConfig_modify = fforMaybe i $ \case
  --         V.EvKey (V.KChar 'b') _ -> Just (insert "a")
  --         _ -> Nothing
  --     }
  --   @
  , _textInputConfig_tabWidth :: Int
  -- ^ Number of columns a tab character occupies when @'acceptTab'@ is enabled.
  , _textInputConfig_acceptTab :: Bool
  -- ^ Whether the Tab key inserts a tab character into the input. Defaults to
  --   'False', so Tab is left available for focus cycling (e.g.
  --   'Reflex.Vty.Widget.Input.tabNavigation'). Set to 'True' for editors that
  --   should insert tabs.
  , _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_alignment :: TextAlignment
  -- ^ How to align the entered text within the input region. Defaults to
  --   'TextAlignment_Left'. See 'Data.Text.Zipper.displayLinesWithAlignment'.
  }

instance Reflex t => Default (TextInputConfig t) where
  def = TextInputConfig empty never 4 False (pure id) TextAlignment_Left

-- | 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
  -- ^ 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
  }

-- | 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)
textInput cfg = do
  i <- input
  f <- focus
  dh <- viewportHeight
  dw <- viewportWidth
  bt <- themeAttr
  th <- theme
  rec -- 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
          -- Unless tab insertion is enabled, drop Tab/BackTab so they remain
          -- available for focus cycling instead of being typed into the field.
          keyForZipper =
            if _textInputConfig_acceptTab cfg
              then i
              else ffilter notTabKey i
      let valueChangedByUI =
            mergeWith
              (.)
              [ uncurry (updateTextZipper (_textInputConfig_tabWidth cfg)) <$> attach (current dh) keyForZipper
              , let displayInfo = (,) <$> current rows <*> scrollTop
                in ffor (attach displayInfo click) $ \((dl, st), MouseDown _ (mx, my) _) ->
                     goToDisplayLinePosition mx (st + my) dl
              , fforMaybe i $ \case
                  V.EvPaste bs -> Just (insert (TE.decodeUtf8With lenientDecode bs))
                  _ -> Nothing
              ]
      v <-
        foldDyn ($) (_textInputConfig_initialValue cfg) $
          mergeWith
            (.)
            [ valueChangedByCaller
            , valueChangedByUI
            ]
      click <- mouseDown V.BLeft

      -- The layout rows carry a marker tag instead of a resolved
      -- attribute. The tag is @False@ for ordinary spans and @True@
      -- for the cursor span (which exists only while focused).
      -- Rendering maps those tags onto the /current/ theme attribute
      -- and cursor style. A theme change then re-renders without any
      -- input event.
      let rows =
            (\w s x -> displayLinesWithAlignment (_textInputConfig_alignment cfg) w False x s)
              <$> dw
              <*> (mapZipper <$> _textInputConfig_display cfg <*> v)
              <*> f
          img =
            ( \dl attr cursorStyle ->
                images . fmap (fmap (retagSpan attr cursorStyle)) $ _displayLines_spans dl
            )
              <$> current rows
              <*> bt
              <*> (fmap _theme_textInputCursor th)
      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) <$> img <*> scrollTop
  return $
    TextInput
      { _textInput_value = value <$> v
      , _textInput_userInput = attachWith (&) (current v) valueChangedByUI
      , _textInput_lines = length . _displayLines_spans <$> rows
      }

-- | Resolve a tagged span against the current theme. A cursor span
-- applies the text-input cursor style over the theme attribute.
retagSpan :: V.Attr -> Style -> Span Bool -> Span V.Attr
retagSpan attr cursorStyle (Span isCursor txt) =
  Span (if isCursor then applyAttr cursorStyle attr else attr) txt

-- | 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)
multilineTextInput cfg = do
  i <- input
  textInput $
    cfg
      { _textInputConfig_modify =
          mergeWith
            (.)
            [ fforMaybe i $ \case
                V.EvKey V.KEnter [] -> Just $ insert "\n"
                _ -> Nothing
            , _textInputConfig_modify cfg
            ]
      }

-- | Wraps a 'textInput' or 'multilineTextInput' in a tile. Uses
-- the computed line count to greedily size the tile when vertically
-- oriented, and uses the fallback width when horizontally oriented.
-- The size is sampled after post-build and after content or width
-- changes. This avoids demanding the recursive layout solution during
-- construction.
textInputTile
  :: (MonadFix m, MonadHold t m, PostBuild t m, PerformEvent t m, MonadSample t (Performable 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
  -- The tile's size depends on its own region (the line count is a
  -- function of the allocated width). The orientation is itself part
  -- of the solved layout. Reading those during construction or during
  -- a frame therefore deadlocks the layout knot. Seed a constant size
  -- instead. Re-read the true size in post-frame IO: at post-build and
  -- after every line-count or width change. The result is
  -- deduplicated, so a stable size cannot re-trigger the solver.
  o <- askOrientation
  pb <- getPostBuild
  rec t <- tile (Constraint_Fixed <$> sz) txt
      let readSize = do
            occ <- sample (current o)
            case occ of
              Orientation_Column -> sample (current (_textInput_lines t))
              Orientation_Row -> sample (current width)
          sizeMayChange =
            leftmost
              [ () <$ pb
              , () <$ updated (_textInput_lines t)
              , () <$ updated width
              ]
      reads <- performEvent $ ffor sizeMayChange $ \_ -> readSize
      sz <- holdUniqDyn =<< holdDyn 1 reads
  pure t

-- | Turn a set of display line rows into a list of images (one per line)
images :: [[Span V.Attr]] -> [V.Image]
images = map (V.horizCat . map spanToImage)

-- | Turn a set of display line rows into a single image
image :: [[Span V.Attr]] -> V.Image
image = V.vertCat . images

-- | Turn a 'Span' into an 'Graphics.Vty.Image'
spanToImage :: Span V.Attr -> V.Image
spanToImage (Span attrs t) = V.text' attrs t

-- | Default vty event handler for text inputs
updateTextZipper
  :: Int
  -- ^ Tab width
  -> Int
  -- ^ Page size
  -> V.Event
  -- ^ The vty event to handle
  -> TextZipper
  -- ^ The zipper to modify
  -> TextZipper
updateTextZipper tabWidth pageSize ev = case ev of
  -- Special characters
  V.EvKey (V.KChar '\t') [] -> tab tabWidth
  -- Regular characters
  V.EvKey (V.KChar k) [] -> insertChar k
  -- Deletion buttons
  V.EvKey V.KBS [] -> deleteLeft
  V.EvKey V.KDel [] -> deleteRight
  -- Key combinations
  V.EvKey (V.KChar 'u') [V.MCtrl] -> const empty
  V.EvKey (V.KChar 'w') [V.MCtrl] -> 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

-- | 'True' unless the event is a (possibly shifted) Tab keypress. Used to keep
-- Tab available for focus cycling when '_textInputConfig_acceptTab' is off.
notTabKey :: V.Event -> Bool
notTabKey = \case
  V.EvKey (V.KChar '\t') _ -> False
  V.EvKey V.KBackTab _ -> False
  _ -> True