Dynamic form generation with yesod

Question

How do I dynamically generate forms with a varying number of input fields?

The closest I managed is:

listEditForm :: [String] -> Html -> MForm App App (FormResult Text, Widget)
listEditForm xs = renderDivs $ mconcat [ areq textField (String.fromString x) Nothing | x <- xs]

but this has the result type Text and not [Text] as intended, owning to the coincidence that Text is an instance of Monoid, e.g. it fails with Int.

I have a working alternate attempt, which combines several forms, but somehow it only works for this toy example, while the real attempt fails strangely. Anyhow, I don't think this is the correct approach:

data MapPair = MapPair { mpKey :: T.Text, mpValue :: Maybe T.Text }

editForm mmp = renderTable $ MapPair
  <$> areq textField "Key"   (mpKey  <$> mmp)
  <*> aopt textField "Value" (mpValue <$> mmp)

pair2mp (v,k) = MapPair { mpKey = v, mpValue = Just k }

getEditR = do
  sess <- getSession
  let sesslist = Map.toList $ Map.map (decodeUtf8With lenientDecode) sess  
  forms <- forM sesslist (\a -> generateFormPost $ editForm $ Just $ pair2mp a)

  defaultLayout [whamlet|
    <h1>Edit Value Pairs
    $forall (widget,enctype) <- forms
      <form method=post action=@{EditR} enctype=#{enctype}>
        ^{widget}
        <input type=submit>
  |]

  postEditR = do
    sess <- getSession
    let sesslist = Map.toList $ Map.map (decodeUtf8With lenientDecode) sess
    forM_ sesslist (\a -> do
        ((res,_),_) <- runFormPost $ editForm $ Just $ pair2mp a
        case res of
          (FormSuccess (MapPair {mpKey=mk, mpValue=(Just mv)})) -> setSession mk mv
          _ -> return ()
      )
    defaultLayout [whamlet|ok|]

Answer 1

Duh, it is actually easy using monadic forms (see code below).

My major headache is the extra text fields to make sure that the handler which receives the answer may also infer the corresponding question. Maybe I can hide those text fields, make them uneditable, or find another way around that (but I don't know much about Html yet).

listEditMForm :: [(String,Int)] -> Html -> MForm App App (FormResult [(FormResult Int, FormResult Text)], Widget)
listEditMForm xs extra = do
    ifields <- forM xs (\(s,i) -> mreq intField  (String.fromString s) (Just i))
    tfields <- forM xs (\(s,i) -> mreq textField (String.fromString s) (Just $ pack s))
    let (iresults,iviews) = unzip ifields
    let (tresults,tviews) = unzip tfields
    let results = zip iresults tresults
    let views   = zip iviews tviews
    let widget = [whamlet|
        #{extra}
        <h1>Multi Field Form
        $forall (iv,tv) <- views
          Field #
          #{fvLabel iv}: #
          ^{fvInput tv} #
          ^{fvInput iv}
          <div>
      |]
    return ((FormSuccess results), widget)

There are also still some ugly things that I have no clue about, like always wrapping the result always in an outermost FormSuccess constructor, but I guess that really depends on each use-case (e.g. a single FormFailure or FormMissing should probably make the whole form fail/missing as well, but maybe in some case this is not wanted.)

All the zipping and unzipping can probably be done more neatly, but I guess in my case I just create a combined field textintField. I think I know how to do it, but it would be neat if there were a function to combine fields.

Answer 2

The tricky thing with having a dynamic number of fields is that the number of rows/fields need to be known when the form is parsed in the handler.

Let's say we have a regular form that looks like this:

type Form m a b =
    (MonadHandler m, m ~ HandlerFor App) =>
    Maybe a ->
    Html ->
    MForm m (FormResult b, Widget)

nameAndAgeForm :: Form m (Text, Int) (Text, Int)
nameAndAgeForm mPair extra = do
    let nameSettings =
            FieldSettings
                { fsLabel = "name"
                , fsTooltip = Nothing
                , fsId = Nothing
                , fsName = Nothing
                , fsAttrs = []
                }
    (nameResult, nameField) <- mreq textField nameSettings (fst <$> mPair)

    let ageSettings =
            FieldSettings
                { fsLabel = "age"
                , fsTooltip = Nothing
                , fsId = Nothing
                , fsName = Nothing
                , fsAttrs = []
                }

    (ageResult, ageField) <- mreq intField ageSettings (snd <$> mPair)

    let result = (,) <$> nameResult <*> ageResult
    let widget = [whamlet|age: ^{fvInput nameField}, age: ^{fvInput ageField}^{extra}|]

    pure (result, widget)

NOTE it's important that fsName = Nothing in all of the fields or they will collide with themselves when we try to repeat the form in a list.

We can turn it into a form of lists of pairs with a function with that has the following signature Form m a b -> Form m [a] [b].

We can write such a function if we use a trick to get around the problem that the number of fields must be known when parsing. We can send the number of rows as the first field to be parsed.

listifyForm :: Form m a b -> Form m [a] [b]
listifyForm form items csrf = do
    let countSettings =
            FieldSettings
                { fsLabel = "rowCount"
                , fsTooltip = Nothing
                , fsId = Nothing
                , fsName = Just "listifiedFormRowCount"
                , fsAttrs = []
                }

    (rowCountResult, rowCountField) <- mreq hiddenField countSettings (length <$> items)

    case (rowCountResult, items) of
        (FormSuccess rowCount, _) -> constructForms rowCountField $ replicate rowCount Nothing
        (FormMissing, Just items') -> constructForms rowCountField $ Just <$> items'
        (FormFailure err, _) -> pure (FormFailure err, [whamlet|Something went wrong with the form. Do all the fields have unique ID's?|])
        (FormMissing, _) -> pure (FormMissing, [whamlet|Something went wrong with the form|])
  where
    constructForms rowCountField mItems =
        fmap ([whamlet|^{csrf}^{fvInput rowCountField}|] <>) . bimap sequenceA mconcat . unzip
            <$> traverse (flip form mempty) mItems

Now we can convert the nameAndAgeForm into a nameAndAgeListForm:

nameAndAgeListForm :: Form m [(Text, Int)] [(Text, Int)]
nameAndAgeListForm = listifyForm nameAndAgeForm

That can then be called like this in the handler that displays the form:

((_, namesAndAgesWidget), _) <- runFormPost $ nameAndAgeListForm $ Just [("Alice", 12), ("Bob", 34)]

And like this in the handler that handles the input:

((result, _), _) <- runFormPost $ nameAndAgeListForm Nothing