content: {-|
  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 (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
  
  -- | 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
    , _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.
    }
  
  instance Reflex t => Default (TextInputConfig t) where
    def = TextInputConfig empty never 4 (pure id)
  
  -- | 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 <- displayHeight
    dw <- displayWidth
    bt <- theme
    attr0 <- sample bt
    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
        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
  
        -- TODO reverseVideo is prob not what we want. Does not work with `darkTheme` in example.hs (cursor is dark rather than light bg)
        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
      }
  
  -- | 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.
  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)
    -> 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
  
  -- | 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
  