From 8551d5fb56d17faeddeaa5d6f17618328684937e Mon Sep 17 00:00:00 2001
From: Jamie Bertram <jamie.bertram@tweag.io>
Date: Tue, 18 Jan 2022 10:57:10 -0500
Subject: [PATCH] Refactor Forms

---
 .../src/Component/ContractSetupForm.purs      |  60 +++++---
 .../src/Component/RestoreWalletForm.purs      |  23 ++-
 marlowe-dashboard-client/src/Forms.purs       | 128 ++++++-----------
 .../src/Halogen/Form.purs                     | 107 ++------------
 .../src/Halogen/Form/Hook.purs                | 131 ++++++++++++++++++
 5 files changed, 238 insertions(+), 211 deletions(-)
 create mode 100644 marlowe-dashboard-client/src/Halogen/Form/Hook.purs

diff --git a/marlowe-dashboard-client/src/Component/ContractSetupForm.purs b/marlowe-dashboard-client/src/Component/ContractSetupForm.purs
index 3a5953ea44..1c9817c94d 100644
--- a/marlowe-dashboard-client/src/Component/ContractSetupForm.purs
+++ b/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,10 +120,13 @@ 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
@@ -124,25 +134,28 @@ valueForm
   => 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
diff --git a/marlowe-dashboard-client/src/Component/RestoreWalletForm.purs b/marlowe-dashboard-client/src/Component/RestoreWalletForm.purs
index 19c1aeeb02..4bada2150d 100644
--- a/marlowe-dashboard-client/src/Component/RestoreWalletForm.purs
+++ b/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
diff --git a/marlowe-dashboard-client/src/Forms.purs b/marlowe-dashboard-client/src/Forms.purs
index b153d31f2e..fa870c08bc 100644
--- a/marlowe-dashboard-client/src/Forms.purs
+++ b/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,76 +78,40 @@ 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
@@ -170,12 +119,14 @@ walletNickname
   => 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."
+    }
diff --git a/marlowe-dashboard-client/src/Halogen/Form.purs b/marlowe-dashboard-client/src/Halogen/Form.purs
index 1c70a41929..c301e76b4a 100644
--- a/marlowe-dashboard-client/src/Halogen/Form.purs
+++ b/marlowe-dashboard-client/src/Halogen/Form.purs
@@ -5,7 +5,6 @@ module Halogen.Form
   , AsyncInput(..)
   , Form(..)
   , FormHTML
-  , FormResult
   , FormSpec
   , mkForm
   , mkAsyncForm
@@ -13,36 +12,31 @@ module Halogen.Form
   , module FormM
   , multi
   , multiWithIndex
+  , runForm
   , split
   , subform
-  , useForm
   ) where
 
 import Prelude
 
-import Control.Monad.Free (Free, substFree)
+import Control.Monad.Free (Free)
 import Control.Monad.Maybe.Trans (MaybeT(..), mapMaybeT)
 import Control.Monad.Trans.Class (lift)
 import Control.Monad.Writer (WriterT(..), mapWriterT)
 import Data.Bifunctor (bimap, lmap)
 import Data.Either (Either, hush)
-import Data.Foldable (for_)
+import Data.Generic.Rep (class Generic)
 import Data.Lens (Lens', _1, _2, set, view)
 import Data.Lens.Index (class Index, ix)
-import Data.Maybe (Maybe(..))
+import Data.Maybe (Maybe)
 import Data.Newtype (over, unwrap)
 import Data.Profunctor.Star (Star(..))
+import Data.Show.Generic (genericShow)
 import Data.TraversableWithIndex (class TraversableWithIndex, traverseWithIndex)
 import Data.Tuple (Tuple(..))
 import Data.Validation.Semigroup (V(..))
-import Effect.AVar (AVar)
-import Effect.Aff.AVar as AVar
-import Effect.Aff.Class (class MonadAff, liftAff)
-import Effect.Class (liftEffect)
-import Effect.Ref as Ref
 import Halogen as H
 import Halogen.Component (hoistSlot)
-import Halogen.Css as HC
 import Halogen.Form.FormM
   ( FormF(..)
   , FormM(..)
@@ -51,16 +45,11 @@ import Halogen.Form.FormM
   , mapInput
   , update
   ) as FormM
-import Halogen.Form.FormM (FormF(..), FormM, hoistFormM, mapInput, update)
-import Halogen.HTML as HH
-import Halogen.HTML.Events as HE
-import Halogen.Hooks (type (<>), Hook)
-import Halogen.Hooks as Hooks
+import Halogen.Form.FormM (FormF, FormM, hoistFormM, mapInput, update)
 import Network.RemoteData (RemoteData(..), fromEither, toMaybe)
 import Polyform (Reporter(..), Validator)
 import Polyform.Reporter as Reporter
 import Polyform.Validator (runValidator)
-import Web.Event.Event (preventDefault)
 
 -- | An array of HTML nodes used to render a form. The action type is the input
 -- | type.
@@ -77,6 +66,12 @@ type Form slots m input a =
 -- | call.
 data AsyncInput input error output = AsyncInput input (RemoteData error output)
 
+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
+
 -- | A form which adds additional information to its input that carries the
 -- | status of an asynchronous call.
 type AsyncForm slots m input error output =
@@ -247,81 +242,3 @@ hoistFormEvalResult
   -> FormEvalResult slots m1 input ~> FormEvalResult slots m2 input
 hoistFormEvalResult alpha =
   mapMaybeT $ mapWriterT $ hoistFormM alpha <<< map (map (hoistFormHTML alpha))
-
-type UseForm slots m input output =
-  Hooks.UseState input
-    <> Hooks.UseState (Maybe output)
-    <> Hooks.UseState (Array (H.ComponentHTML input slots m))
-    <> Hooks.UseState (Maybe (AVar Int))
-    <> Hooks.UseEffect
-    <> Hooks.UseEffect
-    <> Hooks.Pure
-
-type FormResult slots m a =
-  { html :: Array String -> H.ComponentHTML (Hooks.HookM m Unit) slots m
-  , result :: Maybe a
-  }
-
-useForm
-  :: forall slots m input output
-   . MonadAff m
-  => Eq input
-  => Eq output
-  => Form slots m input output
-  -> input
-  -> Hook m (UseForm slots m input output) (FormResult slots m output)
-useForm f initialInput = Hooks.do
-  Tuple input inputId <- Hooks.useState initialInput
-  Tuple result resultId <- Hooks.useState Nothing
-  Tuple children childrenId <- Hooks.useState []
-  Tuple versionAVar versionAVarId <- Hooks.useState Nothing
-  Hooks.useLifecycleEffect do
-    versionAVar' <- liftAff $ AVar.new 0
-    Hooks.put versionAVarId $ Just versionAVar'
-    pure Nothing
-  handleInputChange { input, versionAVar, inputId, resultId, childrenId }
-  let handleAction = Hooks.put inputId
-  Hooks.pure
-    { html: \classNames ->
-        HH.form
-          [ HC.classNames classNames
-          , HE.onSubmit $ liftEffect <<< preventDefault
-          ]
-          $ bimap (map handleAction) handleAction <$> children
-    , result
-    }
-  where
-  eqInputDeps { versionAVar: Nothing } { versionAVar: Just _ } = false
-  eqInputDeps { versionAVar: Just _ } { versionAVar: Nothing } = false
-  eqInputDeps deps1 deps2 = deps1.input == deps2.input
-  handleInputChange deps =
-    Hooks.capturesWith eqInputDeps deps Hooks.useTickEffect do
-      for_ deps.versionAVar \versionAVar -> do
-        let { input, inputId, resultId, childrenId } = deps
-        initialVersion <- liftAff $ AVar.read versionAVar
-        nextVersionRef <- liftEffect $ Ref.new initialVersion
-        let
-          interpretFormF :: FormF input m ~> Hooks.HookM m
-          interpretFormF (Update newInput next) = do
-            withVersionCheck initialVersion 0 versionAVar do
-              Hooks.put inputId newInput
-              liftEffect $ Ref.modify_ (add 1) nextVersionRef
-            pure next
-
-          interpretFormF (Lift m) = lift m
-
-        Tuple result children <- Hooks.HookM
-          $ substFree (interpretFormF >>> case _ of Hooks.HookM free -> free)
-          $ runForm f input
-        nextVersion <- liftEffect $ Ref.read nextVersionRef
-        withVersionCheck initialVersion (nextVersion + 1) versionAVar do
-          Hooks.put childrenId children
-          Hooks.put resultId result
-      pure Nothing
-
-  withVersionCheck
-    :: forall n. MonadAff n => Int -> Int -> AVar Int -> n Unit -> n Unit
-  withVersionCheck initialVersion increment versionAVar g = do
-    version <- liftAff $ AVar.take versionAVar
-    when (version == initialVersion) g
-    liftAff $ AVar.put (version + increment) versionAVar
diff --git a/marlowe-dashboard-client/src/Halogen/Form/Hook.purs b/marlowe-dashboard-client/src/Halogen/Form/Hook.purs
new file mode 100644
index 0000000000..4740464053
--- /dev/null
+++ b/marlowe-dashboard-client/src/Halogen/Form/Hook.purs
@@ -0,0 +1,131 @@
+-- TODO move this to its own library
+module Halogen.Form.Hook
+  ( FormResult
+  , useDerivedForm
+  , useForm
+  ) where
+
+import Prelude
+
+import Control.Monad.Free (substFree)
+import Control.Monad.Trans.Class (lift)
+import Data.Bifunctor (bimap)
+import Data.Foldable (for_)
+import Data.Maybe (Maybe(..))
+import Data.Tuple (Tuple(..))
+import Effect.AVar (AVar)
+import Effect.Aff.AVar as AVar
+import Effect.Aff.Class (class MonadAff, liftAff)
+import Effect.Class (liftEffect)
+import Effect.Ref as Ref
+import Halogen as H
+import Halogen.Css as HC
+import Halogen.Form (Form, runForm)
+import Halogen.Form.FormM (FormF(..))
+import Halogen.HTML as HH
+import Halogen.HTML.Events as HE
+import Halogen.Hooks (type (<>), Hook)
+import Halogen.Hooks as Hooks
+import Web.Event.Event (preventDefault)
+
+type UseForm slots m input output =
+  Hooks.UseState input
+    <> Hooks.UseState (Maybe output)
+    <> Hooks.UseState (Array (H.ComponentHTML input slots m))
+    <> Hooks.UseState (Maybe (AVar Int))
+    <> Hooks.UseEffect
+    <> Hooks.UseEffect
+    <> Hooks.Pure
+
+type UseDerivedForm slots m input output =
+  Hooks.UseMemo (Form slots m input output) <> UseForm slots m input output
+
+-- | The results of evaluating the useForm hook.
+type FormResult slots m a =
+  { html :: Array String -> H.ComponentHTML (Hooks.HookM m Unit) slots m
+  , result :: Maybe a
+  }
+
+-- | A hook to run a form as a stateful computation over its input. Accepts a
+-- | form and an initial input and returns the current form result and html
+-- | view.
+useDerivedForm
+  :: forall params slots m input output
+   . MonadAff m
+  => Eq input
+  => Eq output
+  => Eq { | params }
+  => { | params }
+  -> input
+  -> ({ | params } -> Form slots m input output)
+  -> Hook m (UseDerivedForm slots m input output) (FormResult slots m output)
+useDerivedForm params initialInput deriveForm = Hooks.do
+  form <- Hooks.captures params Hooks.useMemo \_ -> deriveForm params
+  useForm initialInput form
+
+-- | A hook to run a form as a stateful computation over its input. Accepts a
+-- | form and an initial input and returns the current form result and html
+-- | view.
+useForm
+  :: forall slots m input output
+   . MonadAff m
+  => Eq input
+  => Eq output
+  => input
+  -> Form slots m input output
+  -> Hook m (UseForm slots m input output) (FormResult slots m output)
+useForm initialInput form = Hooks.do
+  Tuple input inputId <- Hooks.useState initialInput
+  Tuple result resultId <- Hooks.useState Nothing
+  Tuple children childrenId <- Hooks.useState []
+  Tuple versionAVar versionAVarId <- Hooks.useState Nothing
+  Hooks.useLifecycleEffect do
+    versionAVar' <- liftAff $ AVar.new 0
+    Hooks.put versionAVarId $ Just versionAVar'
+    pure Nothing
+  handleInputChange { input, versionAVar, inputId, resultId, childrenId }
+  let handleAction = Hooks.put inputId
+  Hooks.pure
+    { html: \classNames ->
+        HH.form
+          [ HC.classNames classNames
+          , HE.onSubmit $ liftEffect <<< preventDefault
+          ]
+          $ bimap (map handleAction) handleAction <$> children
+    , result
+    }
+  where
+  eqInputDeps { versionAVar: Nothing } { versionAVar: Just _ } = false
+  eqInputDeps { versionAVar: Just _ } { versionAVar: Nothing } = false
+  eqInputDeps deps1 deps2 = deps1.input == deps2.input
+  handleInputChange deps =
+    Hooks.capturesWith eqInputDeps deps Hooks.useTickEffect do
+      for_ deps.versionAVar \versionAVar -> do
+        let { input, inputId, resultId, childrenId } = deps
+        initialVersion <- liftAff $ AVar.read versionAVar
+        nextVersionRef <- liftEffect $ Ref.new initialVersion
+        let
+          interpretFormF :: FormF input m ~> Hooks.HookM m
+          interpretFormF (Update newInput next) = do
+            withVersionCheck initialVersion 0 versionAVar do
+              Hooks.put inputId newInput
+              liftEffect $ Ref.modify_ (add 1) nextVersionRef
+            pure next
+
+          interpretFormF (Lift m) = lift m
+
+        Tuple result children <- Hooks.HookM
+          $ substFree (interpretFormF >>> case _ of Hooks.HookM free -> free)
+          $ runForm form input
+        nextVersion <- liftEffect $ Ref.read nextVersionRef
+        withVersionCheck initialVersion (nextVersion + 1) versionAVar do
+          Hooks.put childrenId children
+          Hooks.put resultId result
+      pure Nothing
+
+  withVersionCheck
+    :: forall n. MonadAff n => Int -> Int -> AVar Int -> n Unit -> n Unit
+  withVersionCheck initialVersion increment versionAVar g = do
+    version <- liftAff $ AVar.take versionAVar
+    when (version == initialVersion) g
+    liftAff $ AVar.put (version + increment) versionAVar