{-|
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 t -> TextZipper
_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 t -> Event t (TextZipper -> TextZipper)
_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 t -> Int
_textInputConfig_tabWidth :: Int
  , TextInputConfig t -> Dynamic t (Char -> Char)
_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 t
def = TextZipper
-> Event t (TextZipper -> TextZipper)
-> Int
-> Dynamic t (Char -> Char)
-> TextInputConfig t
forall k (t :: k).
TextZipper
-> Event t (TextZipper -> TextZipper)
-> Int
-> Dynamic t (Char -> Char)
-> TextInputConfig t
TextInputConfig TextZipper
empty Event t (TextZipper -> TextZipper)
forall k (t :: k) a. Reflex t => Event t a
never Int
4 ((Char -> Char) -> Dynamic t (Char -> Char)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Char -> Char
forall a. a -> a
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 t -> Dynamic t Text
_textInput_value :: Dynamic t Text
  -- ^ The current value of the textInput as Text.
  , TextInput t -> Event t TextZipper
_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 t -> Dynamic t Int
_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 :: TextInputConfig t -> m (TextInput t)
textInput TextInputConfig t
cfg = do
  Event t VtyEvent
i <- m (Event t VtyEvent)
forall k (t :: k) (m :: * -> *).
HasInput t m =>
m (Event t VtyEvent)
input
  Dynamic t Bool
f <- m (Dynamic t Bool)
forall k (t :: k) (m :: * -> *).
HasFocusReader t m =>
m (Dynamic t Bool)
focus
  Dynamic t Int
dh <- m (Dynamic t Int)
forall k (t :: k) (m :: * -> *).
HasDisplayRegion t m =>
m (Dynamic t Int)
displayHeight
  Dynamic t Int
dw <- m (Dynamic t Int)
forall k (t :: k) (m :: * -> *).
HasDisplayRegion t m =>
m (Dynamic t Int)
displayWidth
  Behavior t Attr
bt <- m (Behavior t Attr)
forall k (t :: k) (m :: * -> *).
HasTheme t m =>
m (Behavior t Attr)
theme
  Attr
attr0 <- Behavior t Attr -> m Attr
forall k (t :: k) (m :: * -> *) a.
MonadSample t m =>
Behavior t a -> m a
sample Behavior t Attr
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 :: Event t (TextZipper -> TextZipper)
valueChangedByCaller = TextInputConfig t -> Event t (TextZipper -> TextZipper)
forall k (t :: k).
TextInputConfig t -> Event t (TextZipper -> TextZipper)
_textInputConfig_modify TextInputConfig t
cfg
      let valueChangedByUI :: Event t (TextZipper -> TextZipper)
valueChangedByUI = ((TextZipper -> TextZipper)
 -> (TextZipper -> TextZipper) -> TextZipper -> TextZipper)
-> [Event t (TextZipper -> TextZipper)]
-> Event t (TextZipper -> TextZipper)
forall k (t :: k) a.
Reflex t =>
(a -> a -> a) -> [Event t a] -> Event t a
mergeWith (TextZipper -> TextZipper)
-> (TextZipper -> TextZipper) -> TextZipper -> TextZipper
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.)
            [ (Int -> VtyEvent -> TextZipper -> TextZipper)
-> (Int, VtyEvent) -> TextZipper -> TextZipper
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Int -> Int -> VtyEvent -> TextZipper -> TextZipper
updateTextZipper (TextInputConfig t -> Int
forall k (t :: k). TextInputConfig t -> Int
_textInputConfig_tabWidth TextInputConfig t
cfg)) ((Int, VtyEvent) -> TextZipper -> TextZipper)
-> Event t (Int, VtyEvent) -> Event t (TextZipper -> TextZipper)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Behavior t Int -> Event t VtyEvent -> Event t (Int, VtyEvent)
forall k (t :: k) a b.
Reflex t =>
Behavior t a -> Event t b -> Event t (a, b)
attach (Dynamic t Int -> Behavior t Int
forall k (t :: k) a. Reflex t => Dynamic t a -> Behavior t a
current Dynamic t Int
dh) Event t VtyEvent
i
            , let displayInfo :: Behavior t (DisplayLines Attr, Int)
displayInfo = (,) (DisplayLines Attr -> Int -> (DisplayLines Attr, Int))
-> Behavior t (DisplayLines Attr)
-> Behavior t (Int -> (DisplayLines Attr, Int))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dynamic t (DisplayLines Attr) -> Behavior t (DisplayLines Attr)
forall k (t :: k) a. Reflex t => Dynamic t a -> Behavior t a
current Dynamic t (DisplayLines Attr)
rows Behavior t (Int -> (DisplayLines Attr, Int))
-> Behavior t Int -> Behavior t (DisplayLines Attr, Int)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Behavior t Int
scrollTop
              in Event t ((DisplayLines Attr, Int), MouseDown)
-> (((DisplayLines Attr, Int), MouseDown)
    -> TextZipper -> TextZipper)
-> Event t (TextZipper -> TextZipper)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
ffor (Behavior t (DisplayLines Attr, Int)
-> Event t MouseDown
-> Event t ((DisplayLines Attr, Int), MouseDown)
forall k (t :: k) a b.
Reflex t =>
Behavior t a -> Event t b -> Event t (a, b)
attach Behavior t (DisplayLines Attr, Int)
displayInfo Event t MouseDown
click) ((((DisplayLines Attr, Int), MouseDown)
  -> TextZipper -> TextZipper)
 -> Event t (TextZipper -> TextZipper))
-> (((DisplayLines Attr, Int), MouseDown)
    -> TextZipper -> TextZipper)
-> Event t (TextZipper -> TextZipper)
forall a b. (a -> b) -> a -> b
$ \((DisplayLines Attr
dl, Int
st), MouseDown Button
_ (Int
mx, Int
my) [Modifier]
_) ->
                Int -> Int -> DisplayLines Attr -> TextZipper -> TextZipper
forall tag.
Int -> Int -> DisplayLines tag -> TextZipper -> TextZipper
goToDisplayLinePosition Int
mx (Int
st Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
my) DisplayLines Attr
dl
            ]
      Dynamic t TextZipper
v <- ((TextZipper -> TextZipper) -> TextZipper -> TextZipper)
-> TextZipper
-> Event t (TextZipper -> TextZipper)
-> m (Dynamic t TextZipper)
forall k (t :: k) (m :: * -> *) a b.
(Reflex t, MonadHold t m, MonadFix m) =>
(a -> b -> b) -> b -> Event t a -> m (Dynamic t b)
foldDyn (TextZipper -> TextZipper) -> TextZipper -> TextZipper
forall a b. (a -> b) -> a -> b
($) (TextInputConfig t -> TextZipper
forall k (t :: k). TextInputConfig t -> TextZipper
_textInputConfig_initialValue TextInputConfig t
cfg) (Event t (TextZipper -> TextZipper) -> m (Dynamic t TextZipper))
-> Event t (TextZipper -> TextZipper) -> m (Dynamic t TextZipper)
forall a b. (a -> b) -> a -> b
$ ((TextZipper -> TextZipper)
 -> (TextZipper -> TextZipper) -> TextZipper -> TextZipper)
-> [Event t (TextZipper -> TextZipper)]
-> Event t (TextZipper -> TextZipper)
forall k (t :: k) a.
Reflex t =>
(a -> a -> a) -> [Event t a] -> Event t a
mergeWith (TextZipper -> TextZipper)
-> (TextZipper -> TextZipper) -> TextZipper -> TextZipper
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.)
        [ Event t (TextZipper -> TextZipper)
valueChangedByCaller
        , Event t (TextZipper -> TextZipper)
valueChangedByUI
        ]
      Event t MouseDown
click <- Button -> m (Event t MouseDown)
forall k (t :: k) (m :: * -> *).
(Reflex t, Monad m, HasInput t m) =>
Button -> m (Event t MouseDown)
mouseDown Button
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 -> Attr
toCursorAttrs Attr
attr = Attr -> Style -> Attr
V.withStyle Attr
attr Style
V.reverseVideo
          rowInputDyn :: Dynamic t (Int, TextZipper, Bool)
rowInputDyn = (,,)
            (Int -> TextZipper -> Bool -> (Int, TextZipper, Bool))
-> Dynamic t Int
-> Dynamic t (TextZipper -> Bool -> (Int, TextZipper, Bool))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dynamic t Int
dw
            Dynamic t (TextZipper -> Bool -> (Int, TextZipper, Bool))
-> Dynamic t TextZipper
-> Dynamic t (Bool -> (Int, TextZipper, Bool))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((Char -> Char) -> TextZipper -> TextZipper
mapZipper ((Char -> Char) -> TextZipper -> TextZipper)
-> Dynamic t (Char -> Char) -> Dynamic t (TextZipper -> TextZipper)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TextInputConfig t -> Dynamic t (Char -> Char)
forall k (t :: k). TextInputConfig t -> Dynamic t (Char -> Char)
_textInputConfig_display TextInputConfig t
cfg Dynamic t (TextZipper -> TextZipper)
-> Dynamic t TextZipper -> Dynamic t TextZipper
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Dynamic t TextZipper
v)
            Dynamic t (Bool -> (Int, TextZipper, Bool))
-> Dynamic t Bool -> Dynamic t (Int, TextZipper, Bool)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Dynamic t Bool
f
          toDisplayLines :: Attr -> (Int, TextZipper, Bool) -> DisplayLines Attr
toDisplayLines Attr
attr (Int
w, TextZipper
s, Bool
x)  =
            let c :: Attr
c = if Bool
x then Attr -> Attr
toCursorAttrs Attr
attr else Attr
attr
            in Int -> Attr -> Attr -> TextZipper -> DisplayLines Attr
forall tag. Int -> tag -> tag -> TextZipper -> DisplayLines tag
displayLines Int
w Attr
attr Attr
c TextZipper
s
      Dynamic t Attr
attrDyn <- Attr -> Event t Attr -> m (Dynamic t Attr)
forall k (t :: k) (m :: * -> *) a.
MonadHold t m =>
a -> Event t a -> m (Dynamic t a)
holdDyn Attr
attr0 (Event t Attr -> m (Dynamic t Attr))
-> Event t Attr -> m (Dynamic t Attr)
forall a b. (a -> b) -> a -> b
$ ((Int, TextZipper, Bool) -> PushM t Attr)
-> Event t (Int, TextZipper, Bool) -> Event t Attr
forall k (t :: k) a b.
Reflex t =>
(a -> PushM t b) -> Event t a -> Event t b
pushAlways (\(Int, TextZipper, Bool)
_ -> Behavior t Attr -> PushM t Attr
forall k (t :: k) (m :: * -> *) a.
MonadSample t m =>
Behavior t a -> m a
sample Behavior t Attr
bt) (Dynamic t (Int, TextZipper, Bool)
-> Event t (Int, TextZipper, Bool)
forall k (t :: k) a. Reflex t => Dynamic t a -> Event t a
updated Dynamic t (Int, TextZipper, Bool)
rowInputDyn)
      let rows :: Dynamic t (DisplayLines Attr)
rows = Dynamic t Attr
-> Dynamic t (Int, TextZipper, Bool)
-> (Attr -> (Int, TextZipper, Bool) -> DisplayLines Attr)
-> Dynamic t (DisplayLines Attr)
forall (f :: * -> *) a b c.
Applicative f =>
f a -> f b -> (a -> b -> c) -> f c
ffor2 Dynamic t Attr
attrDyn Dynamic t (Int, TextZipper, Bool)
rowInputDyn Attr -> (Int, TextZipper, Bool) -> DisplayLines Attr
toDisplayLines
          img :: Dynamic t [Image]
img = [[Span Attr]] -> [Image]
images ([[Span Attr]] -> [Image])
-> (DisplayLines Attr -> [[Span Attr]])
-> DisplayLines Attr
-> [Image]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DisplayLines Attr -> [[Span Attr]]
forall tag. DisplayLines tag -> [[Span tag]]
_displayLines_spans (DisplayLines Attr -> [Image])
-> Dynamic t (DisplayLines Attr) -> Dynamic t [Image]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dynamic t (DisplayLines Attr)
rows
      Dynamic t Int
y <- Dynamic t Int -> m (Dynamic t Int)
forall k (t :: k) (m :: * -> *) a.
(Reflex t, MonadHold t m, MonadFix m, Eq a) =>
Dynamic t a -> m (Dynamic t a)
holdUniqDyn (Dynamic t Int -> m (Dynamic t Int))
-> Dynamic t Int -> m (Dynamic t Int)
forall a b. (a -> b) -> a -> b
$ ((Int, Int) -> Int)
-> (DisplayLines Attr -> (Int, Int)) -> DisplayLines Attr -> Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, Int) -> Int
forall a b. (a, b) -> b
snd DisplayLines Attr -> (Int, Int)
forall tag. DisplayLines tag -> (Int, Int)
_displayLines_cursorPos (DisplayLines Attr -> Int)
-> Dynamic t (DisplayLines Attr) -> Dynamic t Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dynamic t (DisplayLines Attr)
rows
      let newScrollTop :: Int -> (Int, Int) -> Int
          newScrollTop :: Int -> (Int, Int) -> Int
newScrollTop Int
st (Int
h, Int
cursorY)
            | Int
cursorY Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
st = Int
cursorY
            | Int
cursorY Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
st Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
h = Int
cursorY Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
h Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
            | Bool
otherwise = Int
st
      let hy :: Event t Int
hy = (Int -> (Int, Int) -> Int)
-> Behavior t Int -> Event t (Int, Int) -> Event t Int
forall k (t :: k) a b c.
Reflex t =>
(a -> b -> c) -> Behavior t a -> Event t b -> Event t c
attachWith Int -> (Int, Int) -> Int
newScrollTop Behavior t Int
scrollTop (Event t (Int, Int) -> Event t Int)
-> Event t (Int, Int) -> Event t Int
forall a b. (a -> b) -> a -> b
$ Dynamic t (Int, Int) -> Event t (Int, Int)
forall k (t :: k) a. Reflex t => Dynamic t a -> Event t a
updated (Dynamic t (Int, Int) -> Event t (Int, Int))
-> Dynamic t (Int, Int) -> Event t (Int, Int)
forall a b. (a -> b) -> a -> b
$ Dynamic t Int -> Dynamic t Int -> Dynamic t (Int, Int)
forall k (t :: k) a b.
Reflex t =>
Dynamic t a -> Dynamic t b -> Dynamic t (a, b)
zipDyn Dynamic t Int
dh Dynamic t Int
y
      Behavior t Int
scrollTop <- Int -> Event t Int -> m (Behavior t Int)
forall k (t :: k) (m :: * -> *) a.
MonadHold t m =>
a -> Event t a -> m (Behavior t a)
hold Int
0 Event t Int
hy
      Behavior t [Image] -> m ()
forall k (t :: k) (m :: * -> *).
HasImageWriter t m =>
Behavior t [Image] -> m ()
tellImages (Behavior t [Image] -> m ()) -> Behavior t [Image] -> m ()
forall a b. (a -> b) -> a -> b
$ (\[Image]
imgs Int
st -> (Image -> [Image] -> [Image]
forall a. a -> [a] -> [a]
:[]) (Image -> [Image]) -> ([Image] -> Image) -> [Image] -> [Image]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Image] -> Image
V.vertCat ([Image] -> [Image]) -> [Image] -> [Image]
forall a b. (a -> b) -> a -> b
$ Int -> [Image] -> [Image]
forall a. Int -> [a] -> [a]
drop Int
st [Image]
imgs) ([Image] -> Int -> [Image])
-> Behavior t [Image] -> Behavior t (Int -> [Image])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dynamic t [Image] -> Behavior t [Image]
forall k (t :: k) a. Reflex t => Dynamic t a -> Behavior t a
current Dynamic t [Image]
img Behavior t (Int -> [Image]) -> Behavior t Int -> Behavior t [Image]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Behavior t Int
scrollTop
  TextInput t -> m (TextInput t)
forall (m :: * -> *) a. Monad m => a -> m a
return (TextInput t -> m (TextInput t)) -> TextInput t -> m (TextInput t)
forall a b. (a -> b) -> a -> b
$ TextInput :: forall k (t :: k).
Dynamic t Text
-> Event t TextZipper -> Dynamic t Int -> TextInput t
TextInput
    { _textInput_value :: Dynamic t Text
_textInput_value = TextZipper -> Text
value (TextZipper -> Text) -> Dynamic t TextZipper -> Dynamic t Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dynamic t TextZipper
v
    , _textInput_userInput :: Event t TextZipper
_textInput_userInput = (TextZipper -> (TextZipper -> TextZipper) -> TextZipper)
-> Behavior t TextZipper
-> Event t (TextZipper -> TextZipper)
-> Event t TextZipper
forall k (t :: k) a b c.
Reflex t =>
(a -> b -> c) -> Behavior t a -> Event t b -> Event t c
attachWith TextZipper -> (TextZipper -> TextZipper) -> TextZipper
forall a b. a -> (a -> b) -> b
(&) (Dynamic t TextZipper -> Behavior t TextZipper
forall k (t :: k) a. Reflex t => Dynamic t a -> Behavior t a
current Dynamic t TextZipper
v) Event t (TextZipper -> TextZipper)
valueChangedByUI
    , _textInput_lines :: Dynamic t Int
_textInput_lines = [[Span Attr]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([[Span Attr]] -> Int)
-> (DisplayLines Attr -> [[Span Attr]]) -> DisplayLines Attr -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DisplayLines Attr -> [[Span Attr]]
forall tag. DisplayLines tag -> [[Span tag]]
_displayLines_spans (DisplayLines Attr -> Int)
-> Dynamic t (DisplayLines Attr) -> Dynamic t Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dynamic t (DisplayLines Attr)
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 :: TextInputConfig t -> m (TextInput t)
multilineTextInput TextInputConfig t
cfg = do
  Event t VtyEvent
i <- m (Event t VtyEvent)
forall k (t :: k) (m :: * -> *).
HasInput t m =>
m (Event t VtyEvent)
input
  TextInputConfig t -> m (TextInput t)
forall k (t :: k) (m :: * -> *).
(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 (TextInputConfig t -> m (TextInput t))
-> TextInputConfig t -> m (TextInput t)
forall a b. (a -> b) -> a -> b
$ TextInputConfig t
cfg
    { _textInputConfig_modify :: Event t (TextZipper -> TextZipper)
_textInputConfig_modify = ((TextZipper -> TextZipper)
 -> (TextZipper -> TextZipper) -> TextZipper -> TextZipper)
-> [Event t (TextZipper -> TextZipper)]
-> Event t (TextZipper -> TextZipper)
forall k (t :: k) a.
Reflex t =>
(a -> a -> a) -> [Event t a] -> Event t a
mergeWith (TextZipper -> TextZipper)
-> (TextZipper -> TextZipper) -> TextZipper -> TextZipper
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.)
      [ Event t VtyEvent
-> (VtyEvent -> Maybe (TextZipper -> TextZipper))
-> Event t (TextZipper -> TextZipper)
forall (f :: * -> *) a b.
Filterable f =>
f a -> (a -> Maybe b) -> f b
fforMaybe Event t VtyEvent
i ((VtyEvent -> Maybe (TextZipper -> TextZipper))
 -> Event t (TextZipper -> TextZipper))
-> (VtyEvent -> Maybe (TextZipper -> TextZipper))
-> Event t (TextZipper -> TextZipper)
forall a b. (a -> b) -> a -> b
$ \case
          V.EvKey Key
V.KEnter [] -> (TextZipper -> TextZipper) -> Maybe (TextZipper -> TextZipper)
forall a. a -> Maybe a
Just ((TextZipper -> TextZipper) -> Maybe (TextZipper -> TextZipper))
-> (TextZipper -> TextZipper) -> Maybe (TextZipper -> TextZipper)
forall a b. (a -> b) -> a -> b
$ Text -> TextZipper -> TextZipper
insert Text
"\n"
          VtyEvent
_ -> Maybe (TextZipper -> TextZipper)
forall a. Maybe a
Nothing
      , TextInputConfig t -> Event t (TextZipper -> TextZipper)
forall k (t :: k).
TextInputConfig t -> Event t (TextZipper -> TextZipper)
_textInputConfig_modify TextInputConfig t
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 :: m (TextInput t) -> Dynamic t Int -> m (TextInput t)
textInputTile m (TextInput t)
txt Dynamic t Int
width = do
  Dynamic t Orientation
o <- m (Dynamic t Orientation)
forall k (t :: k) (m :: * -> *).
HasLayout t m =>
m (Dynamic t Orientation)
askOrientation
  rec TextInput t
t <- Dynamic t Constraint -> m (TextInput t) -> m (TextInput t)
forall k (m :: * -> *) (t :: k) a.
(MonadFix m, MonadHold t m, HasInput t m, HasFocus t m,
 HasLayout t m, HasImageWriter t m, HasDisplayRegion t m,
 HasFocusReader t m) =>
Dynamic t Constraint -> m a -> m a
tile (Int -> Constraint
Constraint_Fixed (Int -> Constraint) -> Dynamic t Int -> Dynamic t Constraint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dynamic t Int
sz) m (TextInput t)
txt
      let sz :: Dynamic t Int
sz = Dynamic t (Dynamic t Int) -> Dynamic t Int
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Dynamic t (Dynamic t Int) -> Dynamic t Int)
-> Dynamic t (Dynamic t Int) -> Dynamic t Int
forall a b. (a -> b) -> a -> b
$ Dynamic t Orientation
-> (Orientation -> Dynamic t Int) -> Dynamic t (Dynamic t Int)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
ffor Dynamic t Orientation
o ((Orientation -> Dynamic t Int) -> Dynamic t (Dynamic t Int))
-> (Orientation -> Dynamic t Int) -> Dynamic t (Dynamic t Int)
forall a b. (a -> b) -> a -> b
$ \case
            Orientation
Orientation_Column -> TextInput t -> Dynamic t Int
forall k (t :: k). TextInput t -> Dynamic t Int
_textInput_lines TextInput t
t
            Orientation
Orientation_Row -> Dynamic t Int
width
  TextInput t -> m (TextInput t)
forall (m :: * -> *) a. Monad m => a -> m a
return TextInput t
t

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

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

-- | Turn a 'Span' into an 'Graphics.Vty.Image'
spanToImage :: Span V.Attr -> V.Image
spanToImage :: Span Attr -> Image
spanToImage (Span Attr
attrs Text
t) = Attr -> Text -> Image
V.text' Attr
attrs Text
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 :: Int -> Int -> VtyEvent -> TextZipper -> TextZipper
updateTextZipper Int
tabWidth Int
pageSize VtyEvent
ev = case VtyEvent
ev of
  -- Special characters
  V.EvKey (V.KChar Char
'\t') [] -> Int -> TextZipper -> TextZipper
tab Int
tabWidth
  -- Regular characters
  V.EvKey (V.KChar Char
k) [] -> Char -> TextZipper -> TextZipper
insertChar Char
k
  -- Deletion buttons
  V.EvKey Key
V.KBS [] -> TextZipper -> TextZipper
deleteLeft
  V.EvKey Key
V.KDel [] -> TextZipper -> TextZipper
deleteRight
  -- Key combinations
  V.EvKey (V.KChar Char
'u') [Modifier
V.MCtrl] -> TextZipper -> TextZipper -> TextZipper
forall a b. a -> b -> a
const TextZipper
empty
  V.EvKey (V.KChar Char
'w') [Modifier
V.MCtrl] -> TextZipper -> TextZipper
deleteLeftWord
  -- Arrow keys
  V.EvKey Key
V.KLeft [] -> TextZipper -> TextZipper
left
  V.EvKey Key
V.KRight [] -> TextZipper -> TextZipper
right
  V.EvKey Key
V.KUp [] -> TextZipper -> TextZipper
up
  V.EvKey Key
V.KDown [] -> TextZipper -> TextZipper
down
  V.EvKey Key
V.KHome [] -> TextZipper -> TextZipper
home
  V.EvKey Key
V.KEnd [] -> TextZipper -> TextZipper
end
  V.EvKey Key
V.KPageUp [] -> Int -> TextZipper -> TextZipper
pageUp Int
pageSize
  V.EvKey Key
V.KPageDown [] -> Int -> TextZipper -> TextZipper
pageDown Int
pageSize
  VtyEvent
_ -> TextZipper -> TextZipper
forall a. a -> a
id