{-# LANGUAGE DuplicateRecordFields #-}
{-# OPTIONS_GHC -Wno-orphans #-}
{-# OPTIONS_GHC -Wno-unused-local-binds #-}
{-# OPTIONS_GHC -Wno-unused-matches #-}
module Hydra.TUI.Forms where
import Hydra.Prelude hiding (Down, State, padLeft)
import Hydra.Cardano.Api
import Brick (BrickEvent (..), vBox, withDefAttr)
import Brick.Forms (
Form (..),
FormField (..),
FormFieldState (..),
FormFieldVisibilityMode (..),
focusedFormInputAttr,
newForm,
radioField,
)
import Brick.Types (Location (..), Widget)
import Brick.Widgets.Core (clickable, putCursor, txt, (<+>))
import Cardano.Api.UTxO qualified as UTxO
import Data.Map.Strict qualified as Map
import Data.Text qualified as Text
import Graphics.Vty (Event (..), Key (..))
import Hydra.Chain.Direct.State ()
import Lens.Micro (Lens', (^.))
import Prelude qualified
utxoCheckboxField ::
forall s e n.
( s ~ Map TxIn (TxOut CtxUTxO, Bool)
, n ~ Text
) =>
Map TxIn (TxOut CtxUTxO) ->
Form s e n
utxoCheckboxField :: forall s e n.
(s ~ Map TxIn (TxOut CtxUTxO, Bool), n ~ Text) =>
Map TxIn (TxOut CtxUTxO) -> Form s e n
utxoCheckboxField Map TxIn (TxOut CtxUTxO)
u =
let items :: Map TxIn (TxOut CtxUTxO, Bool)
items = (TxOut CtxUTxO -> (TxOut CtxUTxO, Bool))
-> Map TxIn (TxOut CtxUTxO) -> Map TxIn (TxOut CtxUTxO, Bool)
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (,Bool
False) Map TxIn (TxOut CtxUTxO)
u
in [s -> FormFieldState s e n] -> s -> Form s e n
forall s e n. [s -> FormFieldState s e n] -> s -> Form s e n
newForm
[ LeftBracketChar
-> LeftBracketChar
-> LeftBracketChar
-> Lens'
(Map TxIn (TxOut CtxUTxO, Bool)) (Map TxIn (TxOut CtxUTxO, Bool))
-> [((TxIn, TxOut CtxUTxO, Bool), n, Text)]
-> Map TxIn (TxOut CtxUTxO, Bool)
-> FormFieldState (Map TxIn (TxOut CtxUTxO, Bool)) e n
forall k n a e.
(Ord k, Ord n) =>
LeftBracketChar
-> LeftBracketChar
-> LeftBracketChar
-> Lens' (Map k (a, Bool)) (Map k (a, Bool))
-> [((k, a, Bool), n, Text)]
-> Map k (a, Bool)
-> FormFieldState (Map k (a, Bool)) e n
checkboxGroupField LeftBracketChar
'[' LeftBracketChar
'X' LeftBracketChar
']' (Map TxIn (TxOut CtxUTxO, Bool)
-> f (Map TxIn (TxOut CtxUTxO, Bool)))
-> Map TxIn (TxOut CtxUTxO, Bool)
-> f (Map TxIn (TxOut CtxUTxO, Bool))
forall a. a -> a
Lens'
(Map TxIn (TxOut CtxUTxO, Bool)) (Map TxIn (TxOut CtxUTxO, Bool))
id ([((TxIn, TxOut CtxUTxO, Bool), n, Text)]
-> Map TxIn (TxOut CtxUTxO, Bool)
-> FormFieldState (Map TxIn (TxOut CtxUTxO, Bool)) e n)
-> [((TxIn, TxOut CtxUTxO, Bool), n, Text)]
-> Map TxIn (TxOut CtxUTxO, Bool)
-> FormFieldState (Map TxIn (TxOut CtxUTxO, Bool)) e n
forall a b. (a -> b) -> a -> b
$
[ ((TxIn
k, TxOut CtxUTxO
v, Bool
b), TxIn -> n
forall b a. (Show a, IsString b) => a -> b
show TxIn
k, (TxIn, TxOut CtxUTxO) -> Text
forall ctx era. (TxIn, TxOut ctx era) -> Text
UTxO.render (TxIn
k, TxOut CtxUTxO
v))
| (TxIn
k, (TxOut CtxUTxO
v, Bool
b)) <- Map TxIn (TxOut CtxUTxO, Bool) -> [(TxIn, (TxOut CtxUTxO, Bool))]
forall k a. Map k a -> [(k, a)]
Map.toList Map TxIn (TxOut CtxUTxO, Bool)
items
]
]
s
Map TxIn (TxOut CtxUTxO, Bool)
items
utxoRadioField ::
forall s e n.
( s ~ (TxIn, TxOut CtxUTxO)
, n ~ Text
) =>
Map TxIn (TxOut CtxUTxO) ->
Form s e n
utxoRadioField :: forall s e n.
(s ~ (TxIn, TxOut CtxUTxO), n ~ Text) =>
Map TxIn (TxOut CtxUTxO) -> Form s e n
utxoRadioField Map TxIn (TxOut CtxUTxO)
u =
[s -> FormFieldState s e n] -> s -> Form s e n
forall s e n. [s -> FormFieldState s e n] -> s -> Form s e n
newForm
[ Lens' s (TxIn, TxOut CtxUTxO)
-> [((TxIn, TxOut CtxUTxO), n, Text)] -> s -> FormFieldState s e n
forall n a s e.
(Ord n, Show n, Eq a) =>
Lens' s a -> [(a, n, Text)] -> s -> FormFieldState s e n
radioField
((TxIn, TxOut CtxUTxO) -> f (TxIn, TxOut CtxUTxO)) -> s -> f s
((TxIn, TxOut CtxUTxO) -> f (TxIn, TxOut CtxUTxO))
-> (TxIn, TxOut CtxUTxO) -> f (TxIn, TxOut CtxUTxO)
forall a. a -> a
Lens' s (TxIn, TxOut CtxUTxO)
id
[ ((TxIn, TxOut CtxUTxO)
i, (TxIn, TxOut CtxUTxO) -> n
forall b a. (Show a, IsString b) => a -> b
show (TxIn, TxOut CtxUTxO)
i, (TxIn, TxOut CtxUTxO) -> Text
forall ctx era. (TxIn, TxOut ctx era) -> Text
UTxO.render (TxIn, TxOut CtxUTxO)
i)
| (TxIn, TxOut CtxUTxO)
i <- Map TxIn (TxOut CtxUTxO) -> [(TxIn, TxOut CtxUTxO)]
forall k a. Map k a -> [(k, a)]
Map.toList Map TxIn (TxOut CtxUTxO)
u
]
]
([s] -> s
forall a. HasCallStack => [a] -> a
Prelude.head ([s] -> s) -> [s] -> s
forall a b. (a -> b) -> a -> b
$ Map TxIn (TxOut CtxUTxO) -> [(TxIn, TxOut CtxUTxO)]
forall k a. Map k a -> [(k, a)]
Map.toList Map TxIn (TxOut CtxUTxO)
u)
confirmRadioField ::
forall s e n.
( s ~ Bool
, n ~ Text
) =>
Form s e n
confirmRadioField :: forall s e n. (s ~ Bool, n ~ Text) => Form s e n
confirmRadioField =
[s -> FormFieldState s e n] -> s -> Form s e n
forall s e n. [s -> FormFieldState s e n] -> s -> Form s e n
newForm
[ Lens' s Bool -> [(Bool, n, Text)] -> s -> FormFieldState s e n
forall n a s e.
(Ord n, Show n, Eq a) =>
Lens' s a -> [(a, n, Text)] -> s -> FormFieldState s e n
radioField
(Bool -> f Bool) -> s -> f s
(Bool -> f Bool) -> Bool -> f Bool
forall a. a -> a
Lens' s Bool
id
[ ((n, Bool) -> Bool
forall a b. (a, b) -> b
snd (n, Bool)
opt, (n, Bool) -> n
forall a b. (a, b) -> a
fst (n, Bool)
opt, (Text, Bool) -> Text
forall a b. (a, b) -> a
fst (n, Bool)
(Text, Bool)
opt)
| (n, Bool)
opt <- [(n, Bool)]
options
]
]
s
Bool
True
where
options :: [(n, Bool)]
options = [(n
"yes", Bool
True), (n
"no", Bool
False)]
radioFields :: (Text, Bool) -> FormFieldState (Text, Bool) Any n
radioFields = Lens' (Text, Bool) (n, Bool)
-> [((n, Bool), n, Text)]
-> (Text, Bool)
-> FormFieldState (Text, Bool) Any n
forall n a s e.
(Ord n, Show n, Eq a) =>
Lens' s a -> [(a, n, Text)] -> s -> FormFieldState s e n
radioField ((n, Bool) -> f (n, Bool)) -> (n, Bool) -> f (n, Bool)
((n, Bool) -> f (n, Bool)) -> (Text, Bool) -> f (Text, Bool)
forall a. a -> a
Lens' (Text, Bool) (n, Bool)
id [((n, Bool)
opt, (n, Bool) -> n
forall a b. (a, b) -> a
fst (n, Bool)
opt, n -> Text
forall b a. (Show a, IsString b) => a -> b
show (n -> Text) -> n -> Text
forall a b. (a -> b) -> a -> b
$ (n, Bool) -> n
forall a b. (a, b) -> a
fst (n, Bool)
opt) | (n, Bool)
opt <- [(n, Bool)]
options]
type LeftBracketChar = Char
type CheckmarkChar = Char
type RightBracketChar = Char
checkboxGroupField ::
(Ord k, Ord n) =>
LeftBracketChar ->
CheckmarkChar ->
RightBracketChar ->
Lens' (Map k (a, Bool)) (Map k (a, Bool)) ->
[((k, a, Bool), n, Text)] ->
Map k (a, Bool) ->
FormFieldState (Map k (a, Bool)) e n
checkboxGroupField :: forall k n a e.
(Ord k, Ord n) =>
LeftBracketChar
-> LeftBracketChar
-> LeftBracketChar
-> Lens' (Map k (a, Bool)) (Map k (a, Bool))
-> [((k, a, Bool), n, Text)]
-> Map k (a, Bool)
-> FormFieldState (Map k (a, Bool)) e n
checkboxGroupField LeftBracketChar
lb LeftBracketChar
check LeftBracketChar
rb Lens' (Map k (a, Bool)) (Map k (a, Bool))
stLens [((k, a, Bool), n, Text)]
options Map k (a, Bool)
initialState =
FormFieldState
{ formFieldState :: Map k (a, Bool)
formFieldState = Map k (a, Bool)
initialState
, formFields :: [FormField (Map k (a, Bool)) (Map k (a, Bool)) e n]
formFields = ((k, a, Bool), n, Text)
-> FormField (Map k (a, Bool)) (Map k (a, Bool)) e n
mkFormField (((k, a, Bool), n, Text)
-> FormField (Map k (a, Bool)) (Map k (a, Bool)) e n)
-> [((k, a, Bool), n, Text)]
-> [FormField (Map k (a, Bool)) (Map k (a, Bool)) e n]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [((k, a, Bool), n, Text)]
options
, formFieldLens :: Lens' (Map k (a, Bool)) (Map k (a, Bool))
formFieldLens = (Map k (a, Bool) -> f (Map k (a, Bool)))
-> Map k (a, Bool) -> f (Map k (a, Bool))
Lens' (Map k (a, Bool)) (Map k (a, Bool))
stLens
, formFieldUpdate :: Map k (a, Bool) -> Map k (a, Bool) -> Map k (a, Bool)
formFieldUpdate = \Map k (a, Bool)
_ Map k (a, Bool)
tuple -> Map k (a, Bool)
tuple
, formFieldRenderHelper :: Widget n -> Widget n
formFieldRenderHelper = Widget n -> Widget n
forall a. a -> a
id
, formFieldConcat :: [Widget n] -> Widget n
formFieldConcat = [Widget n] -> Widget n
forall n. [Widget n] -> Widget n
vBox
, formFieldVisibilityMode :: FormFieldVisibilityMode
formFieldVisibilityMode = FormFieldVisibilityMode
ShowFocusedFieldOnly
}
where
mkFormField :: ((k, a, Bool), n, Text)
-> FormField (Map k (a, Bool)) (Map k (a, Bool)) e n
mkFormField ((k
k, a
a, Bool
b), n
name, Text
lbl) =
n
-> (Map k (a, Bool) -> Maybe (Map k (a, Bool)))
-> Bool
-> (Bool -> Map k (a, Bool) -> Widget n)
-> (BrickEvent n e -> EventM n (Map k (a, Bool)) ())
-> FormField (Map k (a, Bool)) (Map k (a, Bool)) e n
forall a b e n.
n
-> (b -> Maybe a)
-> Bool
-> (Bool -> b -> Widget n)
-> (BrickEvent n e -> EventM n b ())
-> FormField a b e n
FormField
n
name
Map k (a, Bool) -> Maybe (Map k (a, Bool))
forall a. a -> Maybe a
Just
Bool
True
((k, Bool) -> Text -> n -> Bool -> Map k (a, Bool) -> Widget n
renderCheckbox (k
k, Bool
b) Text
lbl n
name)
(k -> BrickEvent n e -> EventM n (Map k (a, Bool)) ()
forall {k} {p :: * -> * -> *} {a} {m :: * -> *} {n} {e}.
(Ord k, Bifunctor p, MonadState (Map k (p a Bool)) m) =>
k -> BrickEvent n e -> m ()
handleCheckboxEvent k
k)
renderCheckbox :: (k, Bool) -> Text -> n -> Bool -> Map k (a, Bool) -> Widget n
renderCheckbox (k
k, Bool
boolOption) Text
lbl n
name Bool
foc Map k (a, Bool)
opts =
let addAttr :: Widget n -> Widget n
addAttr = if Bool
foc then AttrName -> Widget n -> Widget n
forall n. AttrName -> Widget n -> Widget n
withDefAttr AttrName
focusedFormInputAttr else Widget n -> Widget n
forall a. a -> a
id
csr :: Widget n -> Widget n
csr = if Bool
foc then n -> Location -> Widget n -> Widget n
forall n. n -> Location -> Widget n -> Widget n
putCursor n
name ((Int, Int) -> Location
Location (Int
1, Int
0)) else Widget n -> Widget n
forall a. a -> a
id
val :: Bool
val = case k -> Map k (a, Bool) -> Maybe (a, Bool)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
k Map k (a, Bool)
opts of
Maybe (a, Bool)
Nothing -> Bool
boolOption
Just (a
_, Bool
b) -> Bool
b
in n -> Widget n -> Widget n
forall n. Ord n => n -> Widget n -> Widget n
clickable n
name (Widget n -> Widget n) -> Widget n -> Widget n
forall a b. (a -> b) -> a -> b
$
Widget n -> Widget n
addAttr (Widget n -> Widget n) -> Widget n -> Widget n
forall a b. (a -> b) -> a -> b
$
Widget n -> Widget n
csr (Widget n -> Widget n) -> Widget n -> Widget n
forall a b. (a -> b) -> a -> b
$
Text -> Widget n
forall n. Text -> Widget n
txt
( LeftBracketChar -> Text
Text.singleton LeftBracketChar
lb
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (if Bool
val then LeftBracketChar -> Text
Text.singleton LeftBracketChar
check else Text
" ")
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> LeftBracketChar -> Text
Text.singleton LeftBracketChar
rb
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" "
)
Widget n -> Widget n -> Widget n
forall n. Widget n -> Widget n -> Widget n
<+> Text -> Widget n
forall n. Text -> Widget n
txt Text
lbl
handleCheckboxEvent :: k -> BrickEvent n e -> m ()
handleCheckboxEvent k
k = \case
(MouseDown n
n Button
_ [Modifier]
_ Location
_) -> k -> m ()
forall {m :: * -> *} {k} {p :: * -> * -> *} {a}.
(MonadState (Map k (p a Bool)) m, Ord k, Bifunctor p) =>
k -> m ()
updateCheckbox k
k
(VtyEvent (EvKey (KChar LeftBracketChar
' ') [])) -> k -> m ()
forall {m :: * -> *} {k} {p :: * -> * -> *} {a}.
(MonadState (Map k (p a Bool)) m, Ord k, Bifunctor p) =>
k -> m ()
updateCheckbox k
k
BrickEvent n e
_ -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
updateCheckbox :: k -> m ()
updateCheckbox k
k = do
Map k (p a Bool)
cur <- m (Map k (p a Bool))
forall s (m :: * -> *). MonadState s m => m s
get
case k -> Map k (p a Bool) -> Maybe (p a Bool)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
k Map k (p a Bool)
cur of
Maybe (p a Bool)
Nothing -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just p a Bool
_ -> Map k (p a Bool) -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (Map k (p a Bool) -> m ()) -> Map k (p a Bool) -> m ()
forall a b. (a -> b) -> a -> b
$ (p a Bool -> p a Bool) -> k -> Map k (p a Bool) -> Map k (p a Bool)
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust ((Bool -> Bool) -> p a Bool -> p a Bool
forall b c a. (b -> c) -> p a b -> p a c
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Bool -> Bool
not) k
k Map k (p a Bool)
cur
type FormFieldRenderHelper a n = (a -> Text -> Bool -> Widget n -> Widget n)
customRadioField ::
(Ord n, Eq a) =>
LeftBracketChar ->
CheckmarkChar ->
RightBracketChar ->
Lens' s a ->
[(a, n, Text.Text)] ->
FormFieldRenderHelper a n ->
s ->
FormFieldState s e n
customRadioField :: forall n a s e.
(Ord n, Eq a) =>
LeftBracketChar
-> LeftBracketChar
-> LeftBracketChar
-> Lens' s a
-> [(a, n, Text)]
-> FormFieldRenderHelper a n
-> s
-> FormFieldState s e n
customRadioField LeftBracketChar
lb LeftBracketChar
check LeftBracketChar
rb Lens' s a
stLens [(a, n, Text)]
options FormFieldRenderHelper a n
decorator s
initialState =
let initVal :: a
initVal = s
initialState s -> Getting a s a -> a
forall s a. s -> Getting a s a -> a
^. Getting a s a
Lens' s a
stLens
lookupOptionValue :: n -> Maybe a
lookupOptionValue n
n =
let results :: [(a, n, Text)]
results = ((a, n, Text) -> Bool) -> [(a, n, Text)] -> [(a, n, Text)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(a
_, n
n', Text
_) -> n
n' n -> n -> Bool
forall a. Eq a => a -> a -> Bool
== n
n) [(a, n, Text)]
options
in case [(a, n, Text)]
results of
[(a
val, n
_, Text
_)] -> a -> Maybe a
forall a. a -> Maybe a
Just a
val
[(a, n, Text)]
_ -> Maybe a
forall a. Maybe a
Nothing
handleEvent :: a -> BrickEvent n e -> EventM n a ()
handleEvent a
_ (MouseDown n
n Button
_ [Modifier]
_ Location
_) = Maybe a -> (a -> EventM n a ()) -> EventM n a ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (n -> Maybe a
lookupOptionValue n
n) a -> EventM n a ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put
handleEvent a
new (VtyEvent (EvKey (KChar LeftBracketChar
' ') [])) = a -> EventM n a ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put a
new
handleEvent a
_ BrickEvent n e
_ = () -> EventM n a ()
forall a. a -> EventM n a a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
optionFields :: [FormField a a e n]
optionFields = (a, n, Text) -> FormField a a e n
mkOptionField ((a, n, Text) -> FormField a a e n)
-> [(a, n, Text)] -> [FormField a a e n]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(a, n, Text)]
options
mkOptionField :: (a, n, Text) -> FormField a a e n
mkOptionField (a
val, n
name, Text
lbl) =
n
-> (a -> Maybe a)
-> Bool
-> (Bool -> a -> Widget n)
-> (BrickEvent n e -> EventM n a ())
-> FormField a a e n
forall a b e n.
n
-> (b -> Maybe a)
-> Bool
-> (Bool -> b -> Widget n)
-> (BrickEvent n e -> EventM n b ())
-> FormField a b e n
FormField
n
name
a -> Maybe a
forall a. a -> Maybe a
Just
Bool
True
(a -> n -> Text -> Bool -> a -> Widget n
renderRadio a
val n
name Text
lbl)
(a -> BrickEvent n e -> EventM n a ()
handleEvent a
val)
in FormFieldState
{ formFieldState :: a
formFieldState = a
initVal
, formFields :: [FormField a a e n]
formFields = [FormField a a e n]
optionFields
, formFieldLens :: Lens' s a
formFieldLens = (a -> f a) -> s -> f s
Lens' s a
stLens
, formFieldUpdate :: a -> a -> a
formFieldUpdate = a -> a -> a
forall a b. a -> b -> a
const
, formFieldRenderHelper :: Widget n -> Widget n
formFieldRenderHelper = Widget n -> Widget n
forall a. a -> a
id
, formFieldConcat :: [Widget n] -> Widget n
formFieldConcat = [Widget n] -> Widget n
forall n. [Widget n] -> Widget n
vBox
, formFieldVisibilityMode :: FormFieldVisibilityMode
formFieldVisibilityMode = FormFieldVisibilityMode
ShowFocusedFieldOnly
}
where
renderRadio :: a -> n -> Text -> Bool -> a -> Widget n
renderRadio a
val n
name Text
lbl Bool
foc a
cur =
let addAttr :: Widget n -> Widget n
addAttr =
if Bool
foc
then AttrName -> Widget n -> Widget n
forall n. AttrName -> Widget n -> Widget n
withDefAttr AttrName
focusedFormInputAttr
else Widget n -> Widget n
forall a. a -> a
id
isSet :: Bool
isSet = a
val a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
cur
csr :: Widget n -> Widget n
csr = if Bool
foc then n -> Location -> Widget n -> Widget n
forall n. n -> Location -> Widget n -> Widget n
putCursor n
name ((Int, Int) -> Location
Location (Int
1, Int
0)) else Widget n -> Widget n
forall a. a -> a
id
in n -> Widget n -> Widget n
forall n. Ord n => n -> Widget n -> Widget n
clickable n
name (Widget n -> Widget n) -> Widget n -> Widget n
forall a b. (a -> b) -> a -> b
$
Widget n -> Widget n
addAttr (Widget n -> Widget n) -> Widget n -> Widget n
forall a b. (a -> b) -> a -> b
$
Widget n -> Widget n
csr (Widget n -> Widget n) -> Widget n -> Widget n
forall a b. (a -> b) -> a -> b
$
FormFieldRenderHelper a n
decorator a
val Text
lbl Bool
isSet (Widget n -> Widget n) -> Widget n -> Widget n
forall a b. (a -> b) -> a -> b
$
Text -> Widget n
forall n. Text -> Widget n
txt (Text -> Widget n) -> Text -> Widget n
forall a b. (a -> b) -> a -> b
$
[Text] -> Text
Text.concat
[ LeftBracketChar -> Text
Text.singleton LeftBracketChar
lb
, if Bool
isSet then LeftBracketChar -> Text
Text.singleton LeftBracketChar
check else Text
" "
, LeftBracketChar -> Text
Text.singleton LeftBracketChar
rb Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
lbl
]