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


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

import Control.Monad (join)
import Control.Monad.Fix (MonadFix)
import Control.Monad.NodeId (MonadNodeId)
import Data.Default (Default(..))
import Data.Text (Text)
import qualified Graphics.Vty as V
import Reflex
import Reflex.Vty.Widget

-- | 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 t.
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
  :: (Reflex t, Monad m, MonadNodeId m)
  => ButtonConfig t
  -> VtyWidget t m ()
  -> VtyWidget t m (Event t ())
button :: ButtonConfig t -> VtyWidget t m () -> VtyWidget t m (Event t ())
button cfg :: ButtonConfig t
cfg child :: VtyWidget t m ()
child = do
  Dynamic t Bool
f <- VtyWidget t m (Dynamic t Bool)
forall t (m :: * -> *). HasFocus 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 t. ButtonConfig t -> Behavior t BoxStyle
_buttonConfig_focusStyle ButtonConfig t
cfg
          else ButtonConfig t -> Behavior t BoxStyle
forall t. ButtonConfig t -> Behavior t BoxStyle
_buttonConfig_boxStyle ButtonConfig t
cfg
  Behavior t BoxStyle -> VtyWidget t m () -> VtyWidget t m ()
forall (m :: * -> *) t a.
(Monad m, Reflex t, MonadNodeId m) =>
Behavior t BoxStyle -> VtyWidget t m a -> VtyWidget t m a
box Behavior t BoxStyle
style VtyWidget t m ()
child
  Event t MouseUp
m <- VtyWidget t m (Event t MouseUp)
forall t (m :: * -> *).
(Reflex t, Monad m) =>
VtyWidget t m (Event t MouseUp)
mouseUp
  Event t KeyCombo
k <- Key -> VtyWidget t m (Event t KeyCombo)
forall (m :: * -> *) t.
(Monad m, Reflex t) =>
Key -> VtyWidget t m (Event t KeyCombo)
key Key
V.KEnter
  Event t () -> VtyWidget t m (Event t ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Event t () -> VtyWidget t m (Event t ()))
-> Event t () -> VtyWidget 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
  :: (Reflex t, Monad m, MonadNodeId m)
  => ButtonConfig t
  -> Behavior t Text
  -> VtyWidget t m (Event t ())
textButton :: ButtonConfig t -> Behavior t Text -> VtyWidget t m (Event t ())
textButton cfg :: ButtonConfig t
cfg = ButtonConfig t -> VtyWidget t m () -> VtyWidget t m (Event t ())
forall t (m :: * -> *).
(Reflex t, Monad m, MonadNodeId m) =>
ButtonConfig t -> VtyWidget t m () -> VtyWidget t m (Event t ())
button ButtonConfig t
cfg (VtyWidget t m () -> VtyWidget t m (Event t ()))
-> (Behavior t Text -> VtyWidget t m ())
-> Behavior t Text
-> VtyWidget t m (Event t ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Behavior t Text -> VtyWidget t m ()
forall t (m :: * -> *).
(Reflex t, Monad m) =>
Behavior t Text -> VtyWidget t m ()
text -- TODO Centering etc.

-- | A button widget that displays a static bit of text
textButtonStatic
  :: (Reflex t, Monad m, MonadNodeId m)
  => ButtonConfig t
  -> Text
  -> VtyWidget t m (Event t ())
textButtonStatic :: ButtonConfig t -> Text -> VtyWidget t m (Event t ())
textButtonStatic cfg :: ButtonConfig t
cfg = ButtonConfig t -> Behavior t Text -> VtyWidget t m (Event t ())
forall t (m :: * -> *).
(Reflex t, Monad m, MonadNodeId m) =>
ButtonConfig t -> Behavior t Text -> VtyWidget t m (Event t ())
textButton ButtonConfig t
cfg (Behavior t Text -> VtyWidget t m (Event t ()))
-> (Text -> Behavior t Text) -> Text -> VtyWidget t 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

-- | A clickable link widget
link
  :: (Reflex t, Monad m)
  => Behavior t Text
  -> VtyWidget t m (Event t MouseUp)
link :: Behavior t Text -> VtyWidget t m (Event t MouseUp)
link t :: Behavior t Text
t = do
  let cfg :: RichTextConfig t
cfg = RichTextConfig :: forall t. Behavior t Attr -> RichTextConfig t
RichTextConfig
        { _richTextConfig_attributes :: Behavior t Attr
_richTextConfig_attributes = Attr -> Behavior t Attr
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Attr -> Behavior t Attr) -> Attr -> Behavior t Attr
forall a b. (a -> b) -> a -> b
$ Attr -> Style -> Attr
V.withStyle Attr
V.defAttr Style
V.underline
        }
  RichTextConfig t -> Behavior t Text -> VtyWidget t m ()
forall t (m :: * -> *).
(Reflex t, Monad m) =>
RichTextConfig t -> Behavior t Text -> VtyWidget t m ()
richText RichTextConfig t
cfg Behavior t Text
t
  VtyWidget t m (Event t MouseUp)
forall t (m :: * -> *).
(Reflex t, Monad m) =>
VtyWidget t m (Event t MouseUp)
mouseUp

-- | A clickable link widget with a static label
linkStatic
  :: (Reflex t, Monad m)
  => Text
  -> VtyWidget t m (Event t MouseUp)
linkStatic :: Text -> VtyWidget t m (Event t MouseUp)
linkStatic = Behavior t Text -> VtyWidget t m (Event t MouseUp)
forall t (m :: * -> *).
(Reflex t, Monad m) =>
Behavior t Text -> VtyWidget t m (Event t MouseUp)
link (Behavior t Text -> VtyWidget t m (Event t MouseUp))
-> (Text -> Behavior t Text)
-> Text
-> VtyWidget t 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

-- | 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 = "[ ]"
  , _checkboxStyle_checked :: Text
_checkboxStyle_checked = "[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 = "[ ]"
  , _checkboxStyle_checked :: Text
_checkboxStyle_checked = "[✓]"
  }

-- | Configuration options for a checkbox
data CheckboxConfig t = CheckboxConfig
  { CheckboxConfig t -> Behavior t CheckboxStyle
_checkboxConfig_checkboxStyle :: Behavior t CheckboxStyle
  , CheckboxConfig t -> Behavior t Attr
_checkboxConfig_attributes :: Behavior t V.Attr
  }

instance (Reflex t) => Default (CheckboxConfig t) where
  def :: CheckboxConfig t
def = CheckboxConfig :: forall t.
Behavior t CheckboxStyle -> Behavior t Attr -> 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
    }

-- | A checkbox widget
checkbox
  :: (MonadHold t m, MonadFix m, Reflex t)
  => CheckboxConfig t
  -> Bool
  -> VtyWidget t m (Dynamic t Bool)
checkbox :: CheckboxConfig t -> Bool -> VtyWidget t m (Dynamic t Bool)
checkbox cfg :: CheckboxConfig t
cfg v0 :: Bool
v0 = do
  Event t MouseDown
md <- Button -> VtyWidget t m (Event t MouseDown)
forall t (m :: * -> *).
(Reflex t, Monad m) =>
Button -> VtyWidget t m (Event t MouseDown)
mouseDown Button
V.BLeft
  Event t MouseUp
mu <- VtyWidget t m (Event t MouseUp)
forall t (m :: * -> *).
(Reflex t, Monad m) =>
VtyWidget t m (Event t MouseUp)
mouseUp
  Dynamic t Bool
v <- Bool -> Event t () -> VtyWidget t m (Dynamic t Bool)
forall k (t :: k) (m :: * -> *) a.
(Reflex t, MonadHold t m, MonadFix m) =>
Bool -> Event t a -> m (Dynamic t Bool)
toggle Bool
v0 (Event t () -> VtyWidget t m (Dynamic t Bool))
-> Event t () -> VtyWidget t m (Dynamic t Bool)
forall a b. (a -> b) -> a -> b
$ () () -> Event t MouseUp -> Event t ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t MouseUp
mu
  Behavior t Attr
depressed <- Attr -> Event t Attr -> VtyWidget t m (Behavior t Attr)
forall k (t :: k) (m :: * -> *) a.
MonadHold t m =>
a -> Event t a -> m (Behavior t a)
hold Attr
forall a. Monoid a => a
mempty (Event t Attr -> VtyWidget t m (Behavior t Attr))
-> Event t Attr -> VtyWidget t m (Behavior t Attr)
forall a b. (a -> b) -> a -> b
$ [Event t Attr] -> Event t Attr
forall k (t :: k) a. Reflex t => [Event t a] -> Event t a
leftmost
    [ Attr -> Style -> Attr
V.withStyle Attr
forall a. Monoid a => a
mempty Style
V.bold Attr -> Event t MouseDown -> Event t Attr
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t MouseDown
md
    , Attr
forall a. Monoid a => a
mempty Attr -> Event t MouseUp -> Event t Attr
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t MouseUp
mu
    ]
  let attrs :: Behavior t Attr
attrs = Attr -> Attr -> Attr
forall a. Semigroup a => a -> a -> a
(<>) (Attr -> Attr -> Attr)
-> Behavior t Attr -> Behavior t (Attr -> Attr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (CheckboxConfig t -> Behavior t Attr
forall t. CheckboxConfig t -> Behavior t Attr
_checkboxConfig_attributes CheckboxConfig t
cfg) Behavior t (Attr -> Attr) -> Behavior t Attr -> Behavior t Attr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Behavior t Attr
depressed
  RichTextConfig t -> Behavior t Text -> VtyWidget t m ()
forall t (m :: * -> *).
(Reflex t, Monad m) =>
RichTextConfig t -> Behavior t Text -> VtyWidget t m ()
richText (Behavior t Attr -> RichTextConfig t
forall t. Behavior t Attr -> RichTextConfig t
RichTextConfig Behavior t Attr
attrs) (Behavior t Text -> VtyWidget t m ())
-> Behavior t Text -> VtyWidget t 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
$ \checked :: Bool
checked ->
    if Bool
checked
      then (CheckboxStyle -> Text)
-> Behavior t CheckboxStyle -> Behavior t Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CheckboxStyle -> Text
_checkboxStyle_checked (Behavior t CheckboxStyle -> Behavior t Text)
-> Behavior t CheckboxStyle -> Behavior t Text
forall a b. (a -> b) -> a -> b
$ CheckboxConfig t -> Behavior t CheckboxStyle
forall t. CheckboxConfig t -> Behavior t CheckboxStyle
_checkboxConfig_checkboxStyle CheckboxConfig t
cfg
      else (CheckboxStyle -> Text)
-> Behavior t CheckboxStyle -> Behavior t Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CheckboxStyle -> Text
_checkboxStyle_unchecked (Behavior t CheckboxStyle -> Behavior t Text)
-> Behavior t CheckboxStyle -> Behavior t Text
forall a b. (a -> b) -> a -> b
$ CheckboxConfig t -> Behavior t CheckboxStyle
forall t. CheckboxConfig t -> Behavior t CheckboxStyle
_checkboxConfig_checkboxStyle CheckboxConfig t
cfg
  Dynamic t Bool -> VtyWidget t m (Dynamic t Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return Dynamic t Bool
v