Added Multi Input Form Functionality (#1601)

stack-lts-9.yaml

@@ -5,6 +5,7 @@ packages:
 - ./yesod-persistent
 - ./yesod-newsfeed
 - ./yesod-form
+- ./yesod-form-multi
 - ./yesod-auth
 - ./yesod-auth-oauth
 - ./yesod-sitemap

stack-persistent-2-10.yaml

@@ -5,6 +5,7 @@ packages:
 - ./yesod-persistent
 - ./yesod-newsfeed
 - ./yesod-form
+- ./yesod-form-multi
 - ./yesod-auth
 - ./yesod-auth-oauth
 - ./yesod-sitemap

stack-persistent-2-9.yaml

@@ -5,6 +5,7 @@ packages:
 - ./yesod-persistent
 - ./yesod-newsfeed
 - ./yesod-form
+- ./yesod-form-multi
 - ./yesod-auth
 - ./yesod-auth-oauth
 - ./yesod-sitemap

stack.yaml

@@ -5,6 +5,7 @@ packages:
 - ./yesod-persistent
 - ./yesod-newsfeed
 - ./yesod-form
+- ./yesod-form-multi
 - ./yesod-auth
 - ./yesod-auth-oauth
 - ./yesod-sitemap

stack.yaml.lock

@@ -0,0 +1,12 @@
+# This file was autogenerated by Stack.
+# You should not edit this file by hand.
+# For more information, please see the documentation at:
+#   https://docs.haskellstack.org/en/stable/lock_files
+
+packages: []
+snapshots:
+- completed:
+    size: 494984
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/13/4.yaml
+    sha256: ba80f9f1f517b9c79a3f32944558fa29837a152eae8dcd0891317338920c2ed8
+  original: lts-13.4

yesod-form-multi/ChangeLog.md

@@ -0,0 +1,5 @@
+# Changelog
+
+## 1.6.0
+
+* Added `Yesod.Form.MultiInput` which supports multi-input forms without needing to submit the form to add an input field [#1601](https://github.com/yesodweb/yesod/pull/1601)

yesod-form-multi/LICENSE

@@ -0,0 +1,20 @@
+Copyright (c) 2019 James Burton
+
+Permission is hereby granted, free of charge, to any person obtaining
+a copy of this software and associated documentation files (the
+"Software"), to deal in the Software without restriction, including
+without limitation the rights to use, copy, modify, merge, publish,
+distribute, sublicense, and/or sell copies of the Software, and to
+permit persons to whom the Software is furnished to do so, subject to
+the following conditions:
+
+The above copyright notice and this permission notice shall be
+included in all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

yesod-form-multi/README.md

@@ -0,0 +1,7 @@
+## yesod-form-multi
+
+Support for creating forms in which the user can specify how many inputs to submit. Includes support for enforcing a minimum number of values.
+Intended as an alternative to `Yesod.Form.MassInput`.
+
+# Limitations
+- If the user adds too many fields then there is currently no support for a "delete button" although fields submitted empty are considered to be deleted.

yesod-form-multi/Setup.lhs

@@ -0,0 +1,7 @@
+#!/usr/bin/env runhaskell
+
+> module Main where
+> import Distribution.Simple
+
+> main :: IO ()
+> main = defaultMain

yesod-form-multi/Yesod/Form/MultiInput.hs

@@ -0,0 +1,294 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE QuasiQuotes  #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE CPP #-}
+
+-- | A module providing a means of creating multiple input forms without
+-- the need to submit the form to generate a new input field unlike
+-- in "MassInput".
+module Yesod.Form.MultiInput
+    ( MultiSettings (..)
+    , MultiView (..)
+    , mmulti
+    , amulti
+    , bs3Settings
+    , bs4Settings
+    ) where
+
+import Control.Arrow (second)
+import Control.Monad (liftM)
+import Control.Monad.Trans.RWS (ask, tell)
+import qualified Data.Map as Map
+import Data.Maybe (fromJust, listToMaybe, fromMaybe)
+import Data.Text (Text)
+import qualified Data.Text as T
+import Yesod.Core
+import Yesod.Form.Fields (intField)
+import Yesod.Form.Functions
+import Yesod.Form.Types
+
+#ifdef MIN_VERSION_shakespeare(2,0,18)
+#if MIN_VERSION_shakespeare(2,0,18)
+#else
+import Text.Julius (ToJavascript (..))
+instance ToJavascript String where toJavascript = toJavascript . toJSON
+instance ToJavascript Text where toJavascript = toJavascript . toJSON
+#endif
+#endif
+
+-- @since 1.6.0
+data MultiSettings site = MultiSettings
+    { msAddClass :: Text -- ^ Class to be applied to the "add another" button.
+    , msErrWidget :: Maybe (Html -> WidgetFor site ()) -- ^ Only used in applicative forms. Create a widget for displaying errors.
+    }
+
+-- @since 1.6.0
+data MultiView site = MultiView
+    { mvCounter :: FieldView site -- ^ Hidden counter field.
+    , mvFields :: [FieldView site] -- ^ Input fields.
+    , mvAddBtn :: FieldView site -- ^ Button to add another field.
+    }
+
+-- | 'MultiSettings' for Bootstrap 3.
+--
+-- @since 1.6.0
+bs3Settings :: MultiSettings site
+bs3Settings = MultiSettings "btn btn-default" (Just errW)
+    where
+        errW err = 
+            [whamlet|
+                <span .help-block .error-block>#{err}
+            |]
+
+-- | 'MultiSettings' for Bootstrap 4.
+--
+-- @since 1.6.0
+bs4Settings :: MultiSettings site
+bs4Settings = MultiSettings "btn btn-basic" (Just errW)
+    where
+        errW err =
+            [whamlet|
+                <div .invalid-feedback>#{err}
+            |]
+
+-- | Applicative equivalent of 'mmulti'.
+--
+-- @since 1.6.0
+amulti :: (site ~ HandlerSite m, MonadHandler m, RenderMessage site FormMessage)
+    => Field m a
+    -> FieldSettings site
+    -> [a]
+    -> Int
+    -> MultiSettings site
+    -> AForm m [a]
+amulti field fs defs minVals ms = formToAForm $
+    liftM (second return) mform
+    where
+        mform = do
+            (fr, MultiView {..}) <- mmulti field fs defs minVals ms
+
+            let widget = do
+                    [whamlet|
+                        ^{fvInput mvCounter}
+
+                        $forall fv <- mvFields
+                            ^{fvInput fv}
+
+                            $maybe err <- fvErrors fv
+                                $maybe errW <- msErrWidget ms
+                                    ^{errW err}
+
+                        ^{fvInput mvAddBtn}
+                    |]
+                (fv : _) = mvFields
+                view = FieldView
+                    { fvLabel = fvLabel fv
+                    , fvTooltip = Nothing
+                    , fvId = fvId fv
+                    , fvInput = widget
+                    , fvErrors = fvErrors mvAddBtn
+                    , fvRequired = False
+                    }
+
+            return (fr, view)
+
+-- | Converts a form field into a monadic form containing an arbitrary
+-- number of the given fields as specified by the user. Returns a list
+-- of results, failing if the length of the list is less than the minimum
+-- requested values.
+--
+-- @since 1.6.0
+mmulti :: (site ~ HandlerSite m, MonadHandler m, RenderMessage site FormMessage)
+    => Field m a
+    -> FieldSettings site
+    -> [a]
+    -> Int
+    -> MultiSettings site
+    -> MForm m (FormResult [a], MultiView site)
+mmulti field fs@FieldSettings {..} defs minVals ms = do
+    fieldClass <- newFormIdent
+    let fs' = fs {fsAttrs = addClass fieldClass fsAttrs}
+        minVals' = if minVals < 0 then 0 else minVals
+    mhelperMulti field fs' fieldClass defs minVals' ms
+
+-- Helper function, does most of the work for mmulti.
+mhelperMulti :: (site ~ HandlerSite m, MonadHandler m, RenderMessage site FormMessage)
+    => Field m a
+    -> FieldSettings site
+    -> Text
+    -> [a]
+    -> Int
+    -> MultiSettings site
+    -> MForm m (FormResult [a], MultiView site)
+mhelperMulti field@Field {..} fs@FieldSettings {..} fieldClass defs minVals MultiSettings {..} = do
+    mp <- askParams
+    (_, site, langs) <- ask
+    name <- maybe newFormIdent return fsName
+    theId <- maybe newFormIdent return fsId
+    cName <- newFormIdent
+    cid <- newFormIdent
+    addBtnId <- newFormIdent 
+
+    let mr2 = renderMessage site langs
+        cDef = length defs
+        cfs = FieldSettings "" Nothing (Just cid) (Just cName) [("hidden", "true")]
+        mkName i = name `T.append` (T.pack $ '-' : show i)
+        mkId i = theId `T.append` (T.pack $ '-' : show i)
+        mkNames c = [(mkName i, mkId i) | i <- [0 .. c]]
+        onMissingSucc _ _ = FormSuccess Nothing
+        onMissingFail m l = FormFailure [renderMessage m l MsgValueRequired]
+        isSuccNothing r = case r of
+            FormSuccess Nothing -> True
+            _ -> False
+
+    mfs <- askFiles
+
+    -- get counter value (starts counting from 0)
+    cr@(cRes, _) <- case mp of
+        Nothing -> return (FormMissing, Right cDef)
+        Just p -> mkRes intField cfs p mfs cName onMissingFail FormSuccess
+
+    -- generate counter view
+    cView <- mkView intField cfs cr cid cName True
+
+    let counter = case cRes of
+            FormSuccess c -> c
+            _             -> cDef
+
+    -- get results of fields
+    results <- case mp of
+        Nothing -> return $
+            if cDef == 0
+                then [(FormMissing, Left "")]
+                else [(FormMissing, Right d) | d <- defs]
+        Just p -> mapM (\n -> mkRes field fs p mfs n onMissingSucc (FormSuccess . Just)) (map fst $ mkNames counter)
+
+    -- generate field views
+    (rs, fvs) <- do
+        let mkView' ((n,i), r@(res, _)) = do
+                fv <- mkView field fs r i n False
+                return (res, fv)
+            xs = zip (mkNames counter) results
+            notSuccNothing (_, (r,_)) = not $ isSuccNothing r
+            ys = case filter notSuccNothing xs of
+                [] -> [((mkName 0, mkId 0), (FormSuccess Nothing, Left ""))] -- always need at least one value to generate a field
+                zs -> zs
+        rvs <- mapM mkView' ys
+        return $ unzip rvs
+
+    -- check values
+    let rs' = [ fmap fromJust r | r <- rs
+                                , not $ isSuccNothing r ]
+        err = T.pack $ "Please enter at least " ++ show minVals ++ " values."
+        (res, tooFewVals) = 
+            case foldr (<*>) (FormSuccess []) (map (fmap $ (:)) rs') of
+                FormSuccess xs ->
+                    if length xs < minVals
+                        then (FormFailure [err], True)
+                        else (FormSuccess xs, False)
+                fRes -> (fRes, False)
+
+        -- create add button
+        btnWidget = do
+            [whamlet|
+                <button ##{addBtnId} .#{msAddClass} type="button">Add Another
+            |]
+            toWidget
+                [julius|
+                    var extraFields = 0;
+                    $("#" + #{addBtnId}).click(function() {
+                        extraFields++;
+                        var newNumber = parseInt(#{show counter}) + extraFields;
+                        $("#" + #{cid}).val(newNumber);
+                        var newName = #{name} + "-" + newNumber;
+                        var newId = #{theId} + "-" + newNumber;
+
+                        var newElem = $("." + #{fieldClass}).first().clone();
+                        newElem.val("").attr('name', newName).attr('id', newId);
+                        newElem.insertBefore("#" + #{addBtnId})
+                    });
+                |]
+
+        btnView = FieldView
+            { fvLabel = toHtml $ mr2 ("" :: Text)
+            , fvTooltip = Nothing
+            , fvId = addBtnId
+            , fvInput = btnWidget
+            , fvErrors = if tooFewVals then Just $ toHtml err else Nothing
+            , fvRequired = False
+            }
+
+    return (res, MultiView cView fvs btnView)
+
+-- Search for the given field's name in the environment,
+-- parse any values found and construct a FormResult.
+mkRes :: (site ~ HandlerSite m, MonadHandler m)
+    => Field m a
+    -> FieldSettings site
+    -> Env
+    -> Maybe FileEnv
+    -> Text
+    -> (site -> [Text] -> FormResult b)
+    -> (a -> FormResult b)
+    -> MForm m (FormResult b, Either Text a)
+mkRes Field {..} FieldSettings {..} p mfs name onMissing onFound = do
+    tell fieldEnctype
+    (_, site, langs) <- ask
+    let mvals = fromMaybe [] $ Map.lookup name p
+        files = fromMaybe [] $ mfs >>= Map.lookup name
+    emx <- lift $ fieldParse mvals files
+    return $ case emx of
+        Left msg -> (FormFailure [renderMessage site langs msg], maybe (Left "") Left (listToMaybe mvals))
+        Right mx ->
+            case mx of
+                Nothing -> (onMissing site langs, Left "") 
+                Just x -> (onFound x, Right x)
+
+-- Generate a FieldView for the given field with the given result.
+mkView :: (site ~ HandlerSite m, MonadHandler m)
+    => Field m a
+    -> FieldSettings site
+    -> (FormResult b, Either Text a)
+    -> Text
+    -> Text
+    -> Bool
+    -> MForm m (FieldView site)
+mkView Field {..} FieldSettings {..} (res, val) theId name isReq = do
+    (_, site, langs) <- ask
+    let mr2 = renderMessage site langs
+    return $ FieldView
+        { fvLabel = toHtml $ mr2 fsLabel
+        , fvTooltip = fmap toHtml $ fmap mr2 fsTooltip
+        , fvId = theId
+        , fvInput = fieldView theId name fsAttrs val isReq
+        , fvErrors =
+            case res of
+                FormFailure [e] -> Just $ toHtml e
+                _ -> Nothing
+        , fvRequired = isReq
+        }