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
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)
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]
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
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
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
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
data CheckboxStyle = CheckboxStyle
{ CheckboxStyle -> Text
_checkboxStyle_unchecked :: Text
, CheckboxStyle -> Text
_checkboxStyle_checked :: Text
}
instance Default CheckboxStyle where
def :: CheckboxStyle
def = CheckboxStyle
checkboxStyleTick
checkboxStyleX :: CheckboxStyle
checkboxStyleX :: CheckboxStyle
checkboxStyleX = CheckboxStyle :: Text -> Text -> CheckboxStyle
CheckboxStyle
{ _checkboxStyle_unchecked :: Text
_checkboxStyle_unchecked = Text
"[ ]"
, _checkboxStyle_checked :: Text
_checkboxStyle_checked = Text
"[x]"
}
checkboxStyleTick :: CheckboxStyle
checkboxStyleTick :: CheckboxStyle
checkboxStyleTick = CheckboxStyle :: Text -> Text -> CheckboxStyle
CheckboxStyle
{ _checkboxStyle_unchecked :: Text
_checkboxStyle_unchecked = Text
"[ ]"
, _checkboxStyle_checked :: Text
_checkboxStyle_checked = Text
"[✓]"
}
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
, 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
}
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
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