Provide better ergonomics for nested forms / array of fields

Environment

purescript-halogen v5.0.0-rc.7
purescript-halogen-formless v1.0.0-rc.1

Current behavior

Formless does not provide a type that can be used in the row of fields to indicate that the row is a collection of fields. To workaround this limitation, one can use a nested form based on the example in this repo.

However, the above example is not as "real world" as it could be in the following ways:

the "Submit All" button is clickable regardless of whether a member form has been added or not. I had to write my own queries to deal with this issue.
The form's submission can contain an empty array of member data. That works for that example, but in my example, all entities fields are required. To implement that logic, I need to use Halogen queries that must return a Maybe (Array entity) rather than an Array entity.

Here's my use case. I have a form with a dynamic array of entities that need to be submitted. On one run, there might only be one entity. In another, it might be as many as 6. Each entity has two fields. The submit button should only be clickable when all of the entities' 2 fields are valid. When the submit button is clicked, it should raise a Array entity, not a Maybe (Array entity).

Expected behavior

The developer can use a custom Formless-provided type that indicates that a given row is a collection of fields.

type MyRows f =
 ( entities :: collection (f Error Input Output) )

render st =
 mapWithIndex st.entities \idx entity -> -- render code

I'm not sure how the above could be supported. While collection could be Identity in normal situations and Array/List/Maybe in other situations, the definition also allows a weird sort of case (e.g. Map someKey) that might not make sense.

Example Code

Note: I haven't actually run this code to verify whether it works as intended. I do know that it compiles.

module Form.Example where

import Prelude

import Data.Array (all, catMaybes, cons, elem, mapWithIndex)
import Data.Const (Const)
import Data.Either (Either(..))
import Data.Foldable (for_)
import Data.Int (fromString)
import Data.Lens as Lens
import Data.Lens.Index (ix)
import Data.List (toUnfoldable)
import Data.Map as M
import Data.Maybe (Maybe(..), isNothing, maybe)
import Data.Newtype (class Newtype)
import Data.String.NonEmpty.Internal (NonEmptyString)
import Data.String.NonEmpty.Internal as NonEmpty
import Data.Symbol (SProxy(..))
import Effect.Aff.Class (class MonadAff)
import Eportfolio.Component.HTML.Utils (whenElem)
import Formless (ValidStatus(..))
import Formless as F
import Halogen (RefLabel(..), liftEffect)
import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Web.HTML.HTMLSelectElement as SE
import Web.HTML.HTMLTextAreaElement as TA

-- Types used in form and page
type LikertScaleData = { score :: Int, meaning :: String }

type SubmissionInfo =
  { submissionID :: Int
  , label :: String
  , description :: String
  }

-- Parent component

type SubmissionData =
  { submissionID :: Int
  , score :: Int
  , comment :: NonEmptyString
  }

type ParentFormRow f =
  ( entities :: f Void (Array SubmissionData) (Array SubmissionData)
  )

type ParentFormFields = { | ParentFormRow F.OutputType }

newtype ParentForm r f = ParentForm (r (ParentFormRow f))
derive instance newtypeParentForm :: Newtype (ParentForm r f) _

-- Form component types

type ParentFormInput = { likertScale :: Array LikertScaleData, entities :: Array SubmissionInfo }
type ParentFormState = ( likertScale :: Array LikertScaleData, entities :: Array SubmissionInfo, entitiesValid :: Array ValidStatus )
type ParentChildSlots = ( entity :: ChildFormSlot Int )
type ParentFormSlot = H.Slot (F.Query' ParentForm) ParentFormFields
data ParentFormAction
  = SubmitParentForm
  | UpdateValidity Int ValidStatus

parentForm
  :: forall m
   . MonadAff m
  => F.Component ParentForm (Const Void) ParentChildSlots ParentFormInput ParentFormFields m
parentForm = F.component mkInput $ F.defaultSpec
  { render = render
  , handleAction = handleAction
  , handleEvent = handleEvent
  }
  where
  mkInput :: ParentFormInput -> F.Input ParentForm ParentFormState m
  mkInput { likertScale, entities } =
    { validators: ParentForm
        { entities: F.hoistFn_ identity
        }
    , initialInputs: Nothing -- when Nothing, will use `Initial` type class

    , entities
    , likertScale
    , entitiesValid: map (const Invalid) entities
    }

  _entity = SProxy :: SProxy "entity"
  _entities = SProxy :: SProxy "entities"

  render
    :: F.PublicState ParentForm ParentFormState
    -> F.ComponentHTML ParentForm ParentFormAction ParentChildSlots m
  render st =
    HH.form_
      [ HH.div_ $
        st.entities # mapWithIndex \idx entity ->
          HH.slot _entity idx childForm { likertScale: st.likertScale, entity } (Just <<< F.injAction <<< UpdateValidity idx)
      , HH.button
        [ if st.submitting || st.validity /= F.Valid
            then HP.disabled true
            else HE.onClick \_ -> Just $ F.injAction SubmitParentForm
        ]
        [ HH.text "Submit Reflections" ]
      ]

  handleEvent = F.raiseResult
  evalA act = F.handleAction handleAction handleEvent act

  handleAction :: ParentFormAction -> F.HalogenM _ _ _ _ _ m Unit
  handleAction = case _ of
    UpdateValidity idx entityValidity -> do
      state <- H.get
      let updatedValidEntities = Lens.set (ix idx) entityValidity state.entitiesValid
      let original = all (_ == Valid) state.entitiesValid
      let next = all (_ == Valid) updatedValidEntities
      when (original /= next) do
        let validity = if next then Valid else Invalid
        H.modify_ \s -> s { entitiesValid = updatedValidEntities, validity = validity }

    SubmitParentForm -> do
      st <- H.get
      res <- H.queryAll _entity $ F.injQuery $ H.request GetFields
      case catMaybes $ toUnfoldable $ M.values res of
        [] -> pure unit
        entities -> do
          evalA (F.set _entities entities) *> evalA F.submit

-----------------------------------------------------------------------------

type ChildFormRow f =
  ( score :: f String String Int
  , comment :: f String String NonEmptyString
  )

type ChildFormFields = { | ChildFormRow F.OutputType }

newtype ChildForm r f = ChildForm (r (ChildFormRow f))
derive instance newtypeChildForm :: Newtype (ChildForm r f) _

-- Form component types

type ChildFormInput = { likertScale :: Array LikertScaleData, entity :: SubmissionInfo }
type ChildFormState = ( likertScale :: Array LikertScaleData, entity :: SubmissionInfo )
type ChildFormSlot = H.Slot (F.Query ChildForm ChildFormQuery ()) ValidStatus
data ChildAction
  = UpdateTextArea
  | UpdateDropdown

data ChildFormQuery a
  = GetFields (Maybe SubmissionData -> a)
derive instance functorChildFormQuery :: Functor ChildFormQuery

childForm
  :: forall m
   . MonadAff m
  => F.Component ChildForm ChildFormQuery () ChildFormInput ValidStatus m
childForm = F.component mkInput $ F.defaultSpec
  { render = render
  , handleAction = handleAction
  , handleQuery = handleQuery
  }
  where
  mkInput :: ChildFormInput -> F.Input ChildForm ChildFormState m
  mkInput { likertScale, entity } =
    { validators: ChildForm
        { score: F.hoistFnE_ \str ->
          case fromString str of
            Nothing -> Left "Not an integer"
            Just i ->
              if i `elem` validScores
                then Right i
                else Left "invalid choice"

        , comment: F.hoistFnE_ $
            maybe (Left "field is required") Right <<< NonEmpty.fromString
        }
    , initialInputs: Nothing -- when Nothing, will use `Initial` type class

    -- everything else below comes from our `AddedState` rows:
    , likertScale
    , entity
    }
    where
      validScores = map _.score likertScale

  _score = SProxy :: SProxy "score"
  _comment = SProxy :: SProxy "comment"

  handleEvent = const $ pure unit
  evalA act = F.handleAction handleAction handleEvent act
  evalQ q = F.handleQuery handleQuery handleEvent q

  dropdownRef = RefLabel "dropdown"
  textAreaRef = RefLabel "textArea"

  handleQuery :: forall a. ChildFormQuery a -> H.HalogenM _ _ _ _ m (Maybe a)
  handleQuery = case _ of
    GetFields reply -> do
      subId <- H.gets _.entity.submissionID
      mbRecord <- map (produceRecord subId) $ evalQ $ H.request F.submitReply
      pure (Just (reply mbRecord))
    where
      produceRecord submissionID maybeContainer = do
        mbShell <- maybeContainer
        form <- mbShell
        let { score, comment } = F.unwrapOutputFields form
        pure { score, comment, submissionID }

  handleAction :: ChildAction -> H.HalogenM _ _ _ _ m Unit
  handleAction = case _ of
    UpdateDropdown -> do
      mbEl <- H.getHTMLElementRef dropdownRef
      for_ mbEl \el -> do
        for_ (SE.fromHTMLElement el) \selectEl -> do
          valueAsString <- liftEffect $ SE.value selectEl
          evalA (F.setValidate _score valueAsString)
          validity <- H.gets _.validity
          H.raise validity

    UpdateTextArea -> do
      mbEl <- H.getHTMLElementRef textAreaRef
      for_ mbEl \el -> do
        for_ (TA.fromHTMLElement el) \textArea -> do
          valueAsString <- liftEffect $ TA.value textArea
          evalA (F.setValidate _comment valueAsString)
          validity <- H.gets _.validity
          H.raise validity

  render
    :: F.PublicState ChildForm ChildFormState
    -> F.ComponentHTML ChildForm ChildAction () m
  render st =
    HH.div_
      [ HH.div_
        [ HH.span_
          [ HH.text st.entity.label ]
        , HH.span_
          [ HH.text $ ": " <> st.entity.description]
        ]
      , whenElem ((st.validity /= Valid) && (isNothing $ F.getOutput _score st.form)) \_ ->
          HH.div_ [ HH.text "You did not provide a valid score below."]
      , HH.select
        [ HP.ref dropdownRef
        , HE.onChange (\_ -> Just $ F.injAction UpdateDropdown)
        ]
        $ cons
          (HH.option
            [ HP.selected (maybe true (const false) $ F.getOutput _score st.form)
            ]
            [ HH.text "-- Select --"
            ])
        $ st.likertScale <#> \{ score, meaning} ->
          HH.option
            [ HP.value (show score)
            , HP.selected (maybe false (\i -> i == score) $ F.getOutput _score st.form)
            ]
            [ HH.text meaning ]
      , whenElem ((st.validity /= Valid) && (isNothing $ F.getOutput _comment st.form)) \_ ->
          HH.div_ [ HH.text "You did not provide a comment below."]
      , HH.textarea
        [ HP.ref textAreaRef
        , HP.placeholder "Please explain your above score"
        , HP.value (F.getInput _comment st.form)
        , HE.onChange (\_ -> Just $ F.injAction UpdateTextArea)
        ]
      ]

thomashoneyman / purescript-halogen-formless