{-|
Module: Reflex.Vty.Widget.Input
Description: User input widgets for reflex-vty
-}
module Reflex.Vty.Widget.Input
  ( module Export
  , module Reflex.Vty.Widget.Input
  ) where


import Reflex.Vty.Widget.Input.Mouse as Export
import Reflex.Vty.Widget.Input.Text as Export

import Control.Monad (join)
import Control.Monad.Fix (MonadFix)
import Data.Default (Default(..))
import Data.List (foldl')
import Data.Text (Text)
import qualified Graphics.Vty as V
import Reflex
import Reflex.Vty.Widget
import Reflex.Vty.Widget.Box
import Reflex.Vty.Widget.Text

-- * Buttons

-- | Configuration options for the 'button' widget
data ButtonConfig t = ButtonConfig
  { ButtonConfig t -> Behavior t BoxStyle
_buttonConfig_boxStyle :: Behavior t BoxStyle
  , ButtonConfig t -> Behavior t BoxStyle
_buttonConfig_focusStyle :: Behavior t BoxStyle
  }

instance Reflex t => Default (ButtonConfig t) where
  def :: ButtonConfig t
def = Behavior t BoxStyle -> Behavior t BoxStyle -> ButtonConfig t
forall k (t :: k).
Behavior t BoxStyle -> Behavior t BoxStyle -> ButtonConfig t
ButtonConfig (BoxStyle -> Behavior t BoxStyle
forall (f :: * -> *) a. Applicative f => a -> f a
pure BoxStyle
singleBoxStyle) (BoxStyle -> Behavior t BoxStyle
forall (f :: * -> *) a. Applicative f => a -> f a
pure BoxStyle
thickBoxStyle)

-- | A button widget that contains a sub-widget
button
  :: (MonadFix m, MonadHold t m, HasFocusReader t m, HasTheme t m, HasDisplayRegion t m, HasImageWriter t m, HasInput t m)
  => ButtonConfig t
  -> m ()
  -> m (Event t ())
button :: ButtonConfig t -> m () -> m (Event t ())
button ButtonConfig t
cfg m ()
child = do
  Dynamic t Bool
f <- m (Dynamic t Bool)
forall k (t :: k) (m :: * -> *).
HasFocusReader t m =>
m (Dynamic t Bool)
focus
  let style :: Behavior t BoxStyle
style = do
        Bool
isFocused <- Dynamic t Bool -> Behavior t Bool
forall k (t :: k) a. Reflex t => Dynamic t a -> Behavior t a
current Dynamic t Bool
f
        if Bool
isFocused
          then ButtonConfig t -> Behavior t BoxStyle
forall k (t :: k). ButtonConfig t -> Behavior t BoxStyle
_buttonConfig_focusStyle ButtonConfig t
cfg
          else ButtonConfig t -> Behavior t BoxStyle
forall k (t :: k). ButtonConfig t -> Behavior t BoxStyle
_buttonConfig_boxStyle ButtonConfig t
cfg
  Behavior t BoxStyle -> m () -> m ()
forall k (m :: * -> *) (t :: k) a.
(MonadFix m, MonadHold t m, HasDisplayRegion t m,
 HasImageWriter t m, HasInput t m, HasFocusReader t m,
 HasTheme t m) =>
Behavior t BoxStyle -> m a -> m a
box Behavior t BoxStyle
style m ()
child
  Event t MouseUp
m <- m (Event t MouseUp)
forall k (t :: k) (m :: * -> *).
(Reflex t, Monad m, HasInput t m) =>
m (Event t MouseUp)
mouseUp
  Event t KeyCombo
k <- Key -> m (Event t KeyCombo)
forall k (m :: * -> *) (t :: k).
(Monad m, Reflex t, HasInput t m) =>
Key -> m (Event t KeyCombo)
key Key
V.KEnter
  Event t () -> m (Event t ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Event t () -> m (Event t ())) -> Event t () -> m (Event t ())
forall a b. (a -> b) -> a -> b
$ [Event t ()] -> Event t ()
forall k (t :: k) a. Reflex t => [Event t a] -> Event t a
leftmost [() () -> Event t KeyCombo -> Event t ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t KeyCombo
k, () () -> Event t MouseUp -> Event t ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t MouseUp
m]

-- | A button widget that displays text that can change
textButton
  :: (MonadFix m, MonadHold t m, HasDisplayRegion t m, HasFocusReader t m, HasTheme t m, HasImageWriter t m, HasInput t m)
  => ButtonConfig t
  -> Behavior t Text
  -> m (Event t ())
textButton :: ButtonConfig t -> Behavior t Text -> m (Event t ())
textButton ButtonConfig t
cfg = ButtonConfig t -> m () -> m (Event t ())
forall k (m :: * -> *) (t :: k).
(MonadFix m, MonadHold t m, HasFocusReader t m, HasTheme t m,
 HasDisplayRegion t m, HasImageWriter t m, HasInput t m) =>
ButtonConfig t -> m () -> m (Event t ())
button ButtonConfig t
cfg (m () -> m (Event t ()))
-> (Behavior t Text -> m ()) -> Behavior t Text -> m (Event t ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Behavior t Text -> m ()
forall k (t :: k) (m :: * -> *).
(Reflex t, Monad m, HasDisplayRegion t m, HasImageWriter t m,
 HasTheme t m) =>
Behavior t Text -> m ()
text -- TODO Centering etc.

-- | A button widget that displays a static bit of text
textButtonStatic
  :: (MonadFix m, MonadHold t m, HasDisplayRegion t m, HasFocusReader t m, HasTheme t m, HasImageWriter t m, HasInput t m)
  => ButtonConfig t
  -> Text
  -> m (Event t ())
textButtonStatic :: ButtonConfig t -> Text -> m (Event t ())
textButtonStatic ButtonConfig t
cfg = ButtonConfig t -> Behavior t Text -> m (Event t ())
forall k (m :: * -> *) (t :: k).
(MonadFix m, MonadHold t m, HasDisplayRegion t m,
 HasFocusReader t m, HasTheme t m, HasImageWriter t m,
 HasInput t m) =>
ButtonConfig t -> Behavior t Text -> m (Event t ())
textButton ButtonConfig t
cfg (Behavior t Text -> m (Event t ()))
-> (Text -> Behavior t Text) -> Text -> m (Event t ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Behavior t Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- * Links

-- | A clickable link widget
link
  :: (Reflex t, Monad m, HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasTheme t m)
  => Behavior t Text
  -> m (Event t MouseUp)
link :: Behavior t Text -> m (Event t MouseUp)
link Behavior t Text
t = do
  Behavior t Attr
bt <- m (Behavior t Attr)
forall k (t :: k) (m :: * -> *).
HasTheme t m =>
m (Behavior t Attr)
theme
  let cfg :: RichTextConfig t
cfg = RichTextConfig :: forall k (t :: k). Behavior t Attr -> RichTextConfig t
RichTextConfig
        { _richTextConfig_attributes :: Behavior t Attr
_richTextConfig_attributes = (Attr -> Attr) -> Behavior t Attr -> Behavior t Attr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Attr
attr -> Attr -> Style -> Attr
V.withStyle Attr
attr Style
V.underline) Behavior t Attr
bt
        }
  RichTextConfig t -> Behavior t Text -> m ()
forall k (t :: k) (m :: * -> *).
(Reflex t, Monad m, HasDisplayRegion t m, HasImageWriter t m,
 HasTheme t m) =>
RichTextConfig t -> Behavior t Text -> m ()
richText RichTextConfig t
cfg Behavior t Text
t
  m (Event t MouseUp)
forall k (t :: k) (m :: * -> *).
(Reflex t, Monad m, HasInput t m) =>
m (Event t MouseUp)
mouseUp

-- | A clickable link widget with a static label
linkStatic
  :: (Reflex t, Monad m, HasImageWriter t m, HasDisplayRegion t m, HasInput t m, HasTheme t m)
  => Text
  -> m (Event t MouseUp)
linkStatic :: Text -> m (Event t MouseUp)
linkStatic = Behavior t Text -> m (Event t MouseUp)
forall k (t :: k) (m :: * -> *).
(Reflex t, Monad m, HasDisplayRegion t m, HasImageWriter t m,
 HasInput t m, HasTheme t m) =>
Behavior t Text -> m (Event t MouseUp)
link (Behavior t Text -> m (Event t MouseUp))
-> (Text -> Behavior t Text) -> Text -> m (Event t MouseUp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Behavior t Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- * Checkboxes

-- | Characters used to render checked and unchecked textboxes
data CheckboxStyle = CheckboxStyle
  { CheckboxStyle -> Text
_checkboxStyle_unchecked :: Text
  , CheckboxStyle -> Text
_checkboxStyle_checked :: Text
  }

instance Default CheckboxStyle where
  def :: CheckboxStyle
def = CheckboxStyle
checkboxStyleTick

-- | This checkbox style uses an "x" to indicate the checked state
checkboxStyleX :: CheckboxStyle
checkboxStyleX :: CheckboxStyle
checkboxStyleX = CheckboxStyle :: Text -> Text -> CheckboxStyle
CheckboxStyle
  { _checkboxStyle_unchecked :: Text
_checkboxStyle_unchecked = Text
"[ ]"
  , _checkboxStyle_checked :: Text
_checkboxStyle_checked = Text
"[x]"
  }

-- | This checkbox style uses a unicode tick mark to indicate the checked state
checkboxStyleTick :: CheckboxStyle
checkboxStyleTick :: CheckboxStyle
checkboxStyleTick = CheckboxStyle :: Text -> Text -> CheckboxStyle
CheckboxStyle
  { _checkboxStyle_unchecked :: Text
_checkboxStyle_unchecked = Text
"[ ]"
  , _checkboxStyle_checked :: Text
_checkboxStyle_checked = Text
"[✓]"
  }

-- | Configuration options for a checkbox
data CheckboxConfig t = CheckboxConfig
  { CheckboxConfig t -> Behavior t CheckboxStyle
_checkboxConfig_checkboxStyle :: Behavior t CheckboxStyle
  -- TODO DELETE and use HasTheme instead
  , CheckboxConfig t -> Behavior t Attr
_checkboxConfig_attributes :: Behavior t V.Attr
  , CheckboxConfig t -> Event t Bool
_checkboxConfig_setValue :: Event t Bool
  }

instance (Reflex t) => Default (CheckboxConfig t) where
  def :: CheckboxConfig t
def = CheckboxConfig :: forall k (t :: k).
Behavior t CheckboxStyle
-> Behavior t Attr -> Event t Bool -> CheckboxConfig t
CheckboxConfig
    { _checkboxConfig_checkboxStyle :: Behavior t CheckboxStyle
_checkboxConfig_checkboxStyle = CheckboxStyle -> Behavior t CheckboxStyle
forall (f :: * -> *) a. Applicative f => a -> f a
pure CheckboxStyle
forall a. Default a => a
def
    , _checkboxConfig_attributes :: Behavior t Attr
_checkboxConfig_attributes = Attr -> Behavior t Attr
forall (f :: * -> *) a. Applicative f => a -> f a
pure Attr
V.defAttr
    , _checkboxConfig_setValue :: Event t Bool
_checkboxConfig_setValue = Event t Bool
forall k (t :: k) a. Reflex t => Event t a
never
    }

-- | A checkbox widget
checkbox
  :: (MonadHold t m, MonadFix m, Reflex t, HasInput t m, HasDisplayRegion t m, HasImageWriter t m, HasFocusReader t m, HasTheme t m)
  => CheckboxConfig t
  -> Bool
  -> m (Dynamic t Bool)
checkbox :: CheckboxConfig t -> Bool -> m (Dynamic t Bool)
checkbox CheckboxConfig t
cfg Bool
v0 = do
  Event t MouseDown
md <- 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
  Event t MouseUp
mu <- m (Event t MouseUp)
forall k (t :: k) (m :: * -> *).
(Reflex t, Monad m, HasInput t m) =>
m (Event t MouseUp)
mouseUp
  Event t KeyCombo
space <- Key -> m (Event t KeyCombo)
forall k (m :: * -> *) (t :: k).
(Monad m, Reflex t, HasInput t m) =>
Key -> m (Event t KeyCombo)
key (Char -> Key
V.KChar Char
' ')
  Dynamic t Bool
f <- m (Dynamic t Bool)
forall k (t :: k) (m :: * -> *).
HasFocusReader t m =>
m (Dynamic t Bool)
focus
  Dynamic t Bool
v <- ((Bool -> Bool) -> Bool -> Bool)
-> Bool -> Event t (Bool -> Bool) -> m (Dynamic t Bool)
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 (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
($) Bool
v0 (Event t (Bool -> Bool) -> m (Dynamic t Bool))
-> Event t (Bool -> Bool) -> m (Dynamic t Bool)
forall a b. (a -> b) -> a -> b
$ [Event t (Bool -> Bool)] -> Event t (Bool -> Bool)
forall k (t :: k) a. Reflex t => [Event t a] -> Event t a
leftmost
    [ Bool -> Bool
not (Bool -> Bool) -> Event t MouseUp -> Event t (Bool -> Bool)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t MouseUp
mu
    , Bool -> Bool
not (Bool -> Bool) -> Event t KeyCombo -> Event t (Bool -> Bool)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t KeyCombo
space
    , Bool -> Bool -> Bool
forall a b. a -> b -> a
const (Bool -> Bool -> Bool) -> Event t Bool -> Event t (Bool -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CheckboxConfig t -> Event t Bool
forall k (t :: k). CheckboxConfig t -> Event t Bool
_checkboxConfig_setValue CheckboxConfig t
cfg
    ]
  Behavior t Style
depressed <- Style -> Event t Style -> m (Behavior t Style)
forall k (t :: k) (m :: * -> *) a.
MonadHold t m =>
a -> Event t a -> m (Behavior t a)
hold Style
V.defaultStyleMask (Event t Style -> m (Behavior t Style))
-> Event t Style -> m (Behavior t Style)
forall a b. (a -> b) -> a -> b
$ [Event t Style] -> Event t Style
forall k (t :: k) a. Reflex t => [Event t a] -> Event t a
leftmost
    [ Style
V.bold Style -> Event t MouseDown -> Event t Style
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t MouseDown
md
    , Style
V.defaultStyleMask Style -> Event t MouseUp -> Event t Style
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t MouseUp
mu
    ]
  let focused :: Behavior t Style
focused = Behavior t Bool -> (Bool -> Style) -> Behavior t Style
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
ffor (Dynamic t Bool -> Behavior t Bool
forall k (t :: k) a. Reflex t => Dynamic t a -> Behavior t a
current Dynamic t Bool
f) ((Bool -> Style) -> Behavior t Style)
-> (Bool -> Style) -> Behavior t Style
forall a b. (a -> b) -> a -> b
$ \Bool
x -> if Bool
x then Style
V.bold else Style
V.defaultStyleMask
  let attrs :: Behavior t Attr
attrs = Attr -> [Style] -> Attr
combineStyles
        (Attr -> [Style] -> Attr)
-> Behavior t Attr -> Behavior t ([Style] -> Attr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CheckboxConfig t -> Behavior t Attr
forall k (t :: k). CheckboxConfig t -> Behavior t Attr
_checkboxConfig_attributes CheckboxConfig t
cfg
        Behavior t ([Style] -> Attr)
-> Behavior t [Style] -> Behavior t Attr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Behavior t Style] -> Behavior t [Style]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Behavior t Style
depressed, Behavior t Style
focused]
  RichTextConfig t -> Behavior t Text -> m ()
forall k (t :: k) (m :: * -> *).
(Reflex t, Monad m, HasDisplayRegion t m, HasImageWriter t m,
 HasTheme t m) =>
RichTextConfig t -> Behavior t Text -> m ()
richText (Behavior t Attr -> RichTextConfig t
forall k (t :: k). Behavior t Attr -> RichTextConfig t
RichTextConfig Behavior t Attr
attrs) (Behavior t Text -> m ()) -> Behavior t Text -> m ()
forall a b. (a -> b) -> a -> b
$ Behavior t (Behavior t Text) -> Behavior t Text
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Behavior t (Behavior t Text) -> Behavior t Text)
-> (Dynamic t (Behavior t Text) -> Behavior t (Behavior t Text))
-> Dynamic t (Behavior t Text)
-> Behavior t Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dynamic t (Behavior t Text) -> Behavior t (Behavior t Text)
forall k (t :: k) a. Reflex t => Dynamic t a -> Behavior t a
current (Dynamic t (Behavior t Text) -> Behavior t Text)
-> Dynamic t (Behavior t Text) -> Behavior t Text
forall a b. (a -> b) -> a -> b
$ Dynamic t Bool
-> (Bool -> Behavior t Text) -> Dynamic t (Behavior t Text)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
ffor Dynamic t Bool
v ((Bool -> Behavior t Text) -> Dynamic t (Behavior t Text))
-> (Bool -> Behavior t Text) -> Dynamic t (Behavior t Text)
forall a b. (a -> b) -> a -> b
$ \Bool
checked ->
    if Bool
checked
      then CheckboxStyle -> Text
_checkboxStyle_checked (CheckboxStyle -> Text)
-> Behavior t CheckboxStyle -> Behavior t Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CheckboxConfig t -> Behavior t CheckboxStyle
forall k (t :: k). CheckboxConfig t -> Behavior t CheckboxStyle
_checkboxConfig_checkboxStyle CheckboxConfig t
cfg
      else CheckboxStyle -> Text
_checkboxStyle_unchecked (CheckboxStyle -> Text)
-> Behavior t CheckboxStyle -> Behavior t Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CheckboxConfig t -> Behavior t CheckboxStyle
forall k (t :: k). CheckboxConfig t -> Behavior t CheckboxStyle
_checkboxConfig_checkboxStyle CheckboxConfig t
cfg
  Dynamic t Bool -> m (Dynamic t Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return Dynamic t Bool
v
  where
    combineStyles :: V.Attr -> [V.Style] -> V.Attr
    combineStyles :: Attr -> [Style] -> Attr
combineStyles Attr
x [Style]
xs = (Attr -> Style -> Attr) -> Attr -> [Style] -> Attr
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Attr -> Style -> Attr
V.withStyle Attr
x [Style]
xs

-- | The ctrl-c keypress event
ctrlc :: (Monad m, HasInput t m, Reflex t) => m (Event t ())
ctrlc :: m (Event t ())
ctrlc = do
  Event t VtyEvent
inp <- m (Event t VtyEvent)
forall k (t :: k) (m :: * -> *).
HasInput t m =>
m (Event t VtyEvent)
input
  Event t () -> m (Event t ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Event t () -> m (Event t ())) -> Event t () -> m (Event t ())
forall a b. (a -> b) -> a -> b
$ Event t VtyEvent -> (VtyEvent -> Maybe ()) -> Event t ()
forall (f :: * -> *) a b.
Filterable f =>
f a -> (a -> Maybe b) -> f b
fforMaybe Event t VtyEvent
inp ((VtyEvent -> Maybe ()) -> Event t ())
-> (VtyEvent -> Maybe ()) -> Event t ()
forall a b. (a -> b) -> a -> b
$ \case
    V.EvKey (V.KChar Char
'c') [Modifier
V.MCtrl] -> () -> Maybe ()
forall a. a -> Maybe a
Just ()
    VtyEvent
_ -> Maybe ()
forall a. Maybe a
Nothing