Refactor Forms

marlowe-dashboard-client/src/Component/ContractSetupForm.purs

@@ -24,8 +24,9 @@ import Effect.Aff.Class (class MonadAff)
 import Forms (InputSlots)
 import Forms as Forms
 import Halogen as H
-import Halogen.Form (Form, subform, useForm)
+import Halogen.Form (Form, subform)
 import Halogen.Form as Form
+import Halogen.Form.Hook (useDerivedForm)
 import Halogen.Hooks as Hooks
 import Marlowe.Semantics (TokenName)
 import Polyform.Validator (liftFnV)
@@ -76,8 +77,11 @@ type Component q m =
 contractNicknameForm
   :: forall s m. Monad m => Form (InputSlots s) m String ContractNickname
 contractNicknameForm =
-  Forms.input "contract-nickname" "Contract title" CN.validator case _ of
-    CN.Empty -> "Required."
+  Form.mkForm
+    { validator: CN.validator
+    , render: Forms.input "contract-nickname" "Contract title" case _ of
+        CN.Empty -> "Required."
+    }
 
 roleAssignmentForm
   :: forall s m
@@ -86,11 +90,14 @@ roleAssignmentForm
   -> TokenName
   -> Form (InputSlots s) m String Address
 roleAssignmentForm addressBook roleName =
-  Forms.input ("role-input-" <> roleName) roleName validator case _ of
-    WN.Empty -> "Required."
-    WN.Exists -> "Already exists."
-    WN.DoesNotExist -> "Not found."
-    WN.ContainsNonAlphaNumeric -> "Can only contain letters and digits."
+  Form.mkForm
+    { validator
+    , render: Forms.input ("role-input-" <> roleName) roleName case _ of
+        WN.Empty -> "Required."
+        WN.Exists -> "Already exists."
+        WN.DoesNotExist -> "Not found."
+        WN.ContainsNonAlphaNumeric -> "Can only contain letters and digits."
+    }
   where
   validator =
     liftFnV $
@@ -113,36 +120,42 @@ timeoutForm
   => String
   -> Form (InputSlots s) m String ContractTimeout
 timeoutForm name =
-  Forms.input ("slot-input-" <> name) name CT.validator case _ of
-    CT.Empty -> "Required."
-    CT.Past -> "Must be in the future."
-    CT.Invalid -> "Must be a number of slots from contract start."
+  Form.mkForm
+    { validator: CT.validator
+    , render: Forms.input ("slot-input-" <> name) name case _ of
+        CT.Empty -> "Required."
+        CT.Past -> "Must be in the future."
+        CT.Invalid -> "Must be a number of slots from contract start."
+    }
 
 valueForm
   :: forall s m
    . Monad m
   => String
   -> Form (InputSlots s) m String ContractValue
 valueForm name =
-  Forms.input ("value-input-" <> name) name CV.validator case _ of
-    CV.Empty -> "Required."
-    CV.Negative -> "Must by positive."
-    CV.Invalid -> "Must by a number."
-
-mkForm
+  Form.mkForm
+    { validator: CV.validator
+    , render: Forms.input ("value-input-" <> name) name case _ of
+        CV.Empty -> "Required."
+        CV.Negative -> "Must by positive."
+        CV.Invalid -> "Must by a number."
+    }
+
+form
   :: forall slots m
    . Monad m
   => AddressBook
   -> Form (InputSlots slots) m ContractInput ContractParams
-mkForm addressBook =
+form addressBook =
   ContractParams
     <$> subform _nickname contractNicknameForm
     <*> subform _roles (roleForms addressBook)
     <*> subform _timeouts (Form.multiWithIndex timeoutForm)
     <*> subform _values (Form.multiWithIndex valueForm)
 
-initialFormInput :: Set TokenName -> Set String -> Set String -> ContractInput
-initialFormInput roles timeouts values =
+initialInput :: Set TokenName -> Set String -> Set String -> ContractInput
+initialInput roles timeouts values =
   { nickname: ""
   , roles: Map.fromFoldable $ Set.map (flip Tuple "") roles
   , timeouts: Map.fromFoldable $ Set.map (flip Tuple "") timeouts
@@ -152,8 +165,9 @@ initialFormInput roles timeouts values =
 component :: forall q m. MonadAff m => Component q m
 component = Hooks.component \{ outputToken } input -> Hooks.do
   let { addressBook, roles, timeouts, values } = input
-  form <- Hooks.captures { addressBook } Hooks.useMemo \_ -> mkForm addressBook
-  { result, html } <- useForm form (initialFormInput roles timeouts values)
+  { result, html } <-
+    useDerivedForm { addressBook } (initialInput roles timeouts values)
+      $ form <<< _.addressBook
   let _back = Hooks.raise outputToken Back
   let _next = Hooks.raise outputToken <<< Next <$> result
   Hooks.pure do

marlowe-dashboard-client/src/Component/RestoreWalletForm.purs

@@ -16,12 +16,13 @@ import Data.Set (Set)
 import Data.Tuple (uncurry)
 import Data.WalletNickname (WalletNickname)
 import Effect.Aff.Class (class MonadAff)
-import Forms (AsyncInput(..), MnemonicPhraseInput)
+import Forms (InputSlots, MnemonicPhraseInput)
 import Forms as Forms
 import Halogen as H
 import Halogen.Css (classNames)
-import Halogen.Form (useForm)
+import Halogen.Form (AsyncInput(..), Form)
 import Halogen.Form as Form
+import Halogen.Form.Hook (useDerivedForm)
 import Halogen.HTML as HH
 import Halogen.Hooks as Hooks
 import Network.RemoteData (RemoteData(..))
@@ -39,16 +40,26 @@ data Msg
 type Component q m =
   H.Component q Input Msg m
 
+initialInput :: RestoreWalletInput
+initialInput = Tuple "" $ AsyncInput "" NotAsked
+
+form
+  :: forall slots m
+   . Monad m
+  => CheckMnemonic m
+  => Set WalletNickname
+  -> Form (InputSlots slots) m RestoreWalletInput RestoreWalletOutput
+form used = Form.split (Forms.walletNickname used) Forms.mnemonicPhrase
+
 component
   :: forall q m
    . MonadAff m
   => CheckMnemonic m
   => ManageMarlowe m
   => Component q m
-component = Hooks.component \{ outputToken } input -> Hooks.do
-  form <- Hooks.captures { input } Hooks.useMemo \_ ->
-    Form.split (Forms.walletNickname input) Forms.mnemonicPhrase
-  { result, html } <- useForm form $ Tuple "" $ AsyncInput "" NotAsked
+component = Hooks.component \{ outputToken } used -> Hooks.do
+  { result, html } <-
+    useDerivedForm { used } initialInput $ form <<< _.used
   Tuple canRestore canRestoreId <- Hooks.useState true
   Tuple serverError serverErrorId <- Hooks.useState ""
   let cancel = Hooks.raise outputToken Closed

marlowe-dashboard-client/src/Forms.purs

@@ -4,10 +4,8 @@ import Prologue hiding (div)
 
 import Component.Input.View as Input
 import Component.Label.View as Label
-import Control.Monad.Trans.Class (lift)
 import Css as Css
 import Data.Filterable (filter)
-import Data.Generic.Rep (class Generic)
 import Data.Maybe (fromMaybe, isJust, maybe)
 import Data.MnemonicPhrase
   ( class CheckMnemonic
@@ -16,31 +14,18 @@ import Data.MnemonicPhrase
   )
 import Data.MnemonicPhrase as MP
 import Data.Set (Set)
-import Data.Show.Generic (genericShow)
-import Data.Validation.Semigroup (V(..))
 import Data.WalletNickname (WalletNickname)
 import Data.WalletNickname as WN
 import Halogen as H
 import Halogen.Css (classNames)
-import Halogen.Form (Form)
+import Halogen.Form (AsyncInput, Form, FormHTML, FormM)
 import Halogen.Form as Form
-import Halogen.Form.FormM (update)
 import Halogen.HTML as HH
 import Halogen.HTML.Properties as HP
 import Halogen.Hooks as Hooks
-import Network.RemoteData (RemoteData(..), fromEither)
-import Polyform (Validator)
-import Polyform.Validator as Validator
+import Network.RemoteData (RemoteData(..))
 import Type.Proxy (Proxy(..))
 
-data AsyncInput i e a = AsyncInput i (RemoteData e a)
-
-derive instance eqAsyncInput :: (Eq i, Eq e, Eq a) => Eq (AsyncInput i e a)
-derive instance genericAsyncInput :: Generic (AsyncInput i e a) _
-derive instance functorAsyncInput :: Functor (AsyncInput i e)
-instance showAsyncInput :: (Show i, Show e, Show a) => Show (AsyncInput i e a) where
-  show = genericShow
-
 type InputSlots slots =
   (input :: forall query. H.Slot query String String | slots)
 
@@ -93,89 +78,55 @@ inputAsync
    . Monad m
   => String
   -> String
-  -> Validator m e String a
   -> (e -> String)
-  -> Form (InputSlots s) m (AsyncInput String e a) a
-inputAsync id label validator renderError =
-  Form.form \(AsyncInput value remote) -> do
-    remote' <- case remote of
-      NotAsked -> do
-        case value of
-          "" -> pure $ NotAsked
-          _ -> do
-            update (AsyncInput value Loading)
-            V result <- lift $ Validator.runValidator validator value
-            let newRemote = fromEither result
-            update (AsyncInput value newRemote)
-            pure newRemote
-      r -> pure r
-    case remote' of
-      Loading ->
-        mkResult value Nothing $ Just "Checking..."
-      Failure e ->
-        mkResult value Nothing $ Just $ renderError e
-      NotAsked ->
-        mkResult value Nothing Nothing
-      Success a ->
-        mkResult value (Just a) Nothing
-
+  -> String
+  -> RemoteData e a
+  -> FormM String m (FormHTML String (InputSlots s) m)
+inputAsync id label renderError value = case _ of
+  Loading ->
+    render $ Just "Checking..."
+  Failure e ->
+    render $ Just $ renderError e
+  NotAsked ->
+    render Nothing
+  Success _ ->
+    render Nothing
   where
-  mkResult value output error = do
-    let
-      componentInput =
-        { value
-        , id
-        , label
-        , error
-        }
-    pure $ Tuple output
-      [ HH.slot
-          _input
-          id
-          inputComponent
-          componentInput
-          \value' -> AsyncInput value' NotAsked
-      ]
+  render error = pure
+    [ HH.slot _input id inputComponent { value, id, label, error } identity ]
 
 input
   :: forall s m e a
    . Monad m
   => String
   -> String
-  -> Validator m e String a
   -> (e -> String)
-  -> Form (InputSlots s) m String a
-input id label validator renderError = Form.form \value -> do
-  V result <- lift $ Validator.runValidator validator value
-  case result of
-    Left e ->
-      mkResult value Nothing $ Just $ renderError e
-    Right a ->
-      mkResult value (Just a) Nothing
+  -> String
+  -> Either e a
+  -> FormM String m (FormHTML String (InputSlots s) m)
+input id label renderError value = case _ of
+  Left e ->
+    render $ Just $ renderError e
+  Right _ ->
+    render Nothing
   where
-  mkResult value output error = do
-    let
-      componentInput =
-        { value
-        , id
-        , label
-        , error
-        }
-    pure $ Tuple output
-      [ HH.slot _input id inputComponent componentInput identity ]
+  render error = pure
+    [ HH.slot _input id inputComponent { value, id, label, error } identity ]
 
 walletNickname
   :: forall s m
    . Monad m
   => Set WalletNickname
   -> Form (InputSlots s) m String WalletNickname
 walletNickname used =
-  input "wallet-nickname" "Wallet nickname" (WN.validatorExclusive used)
-    case _ of
-      WN.Empty -> "Required."
-      WN.Exists -> "Already exists."
-      WN.DoesNotExist -> "Not found."
-      WN.ContainsNonAlphaNumeric -> "Can only contain letters and digits."
+  Form.mkForm
+    { validator: WN.validatorExclusive used
+    , render: input "wallet-nickname" "Wallet nickname" case _ of
+        WN.Empty -> "Required."
+        WN.Exists -> "Already exists."
+        WN.DoesNotExist -> "Not found."
+        WN.ContainsNonAlphaNumeric -> "Can only contain letters and digits."
+    }
 
 type MnemonicPhraseInput = AsyncInput String MnemonicPhraseError MnemonicPhrase
 
@@ -184,7 +135,10 @@ mnemonicPhrase
    . CheckMnemonic m
   => Form (InputSlots s) m MnemonicPhraseInput MnemonicPhrase
 mnemonicPhrase =
-  inputAsync "wallet-mnemonic" "Mnemonic phrase" MP.validator case _ of
-    MP.Empty -> "Required."
-    MP.WrongWordCount -> "24 words required."
-    MP.ContainsInvalidWords -> "Mnemonic phrase contains invalid words."
+  Form.mkAsyncForm
+    { validator: MP.validator
+    , render: inputAsync "wallet-mnemonic" "Mnemonic phrase" case _ of
+        MP.Empty -> "Required."
+        MP.WrongWordCount -> "24 words required."
+        MP.ContainsInvalidWords -> "Mnemonic phrase contains invalid words."
+    }