Added Multi Input Form Functionality (#1601)
This commit is contained in:
parent
37c0df8dc1
commit
d8ebb95c96
11 changed files with 387 additions and 0 deletions
|
@ -5,6 +5,7 @@ packages:
|
|||
- ./yesod-persistent
|
||||
- ./yesod-newsfeed
|
||||
- ./yesod-form
|
||||
- ./yesod-form-multi
|
||||
- ./yesod-auth
|
||||
- ./yesod-auth-oauth
|
||||
- ./yesod-sitemap
|
||||
|
|
|
@ -5,6 +5,7 @@ packages:
|
|||
- ./yesod-persistent
|
||||
- ./yesod-newsfeed
|
||||
- ./yesod-form
|
||||
- ./yesod-form-multi
|
||||
- ./yesod-auth
|
||||
- ./yesod-auth-oauth
|
||||
- ./yesod-sitemap
|
||||
|
|
|
@ -5,6 +5,7 @@ packages:
|
|||
- ./yesod-persistent
|
||||
- ./yesod-newsfeed
|
||||
- ./yesod-form
|
||||
- ./yesod-form-multi
|
||||
- ./yesod-auth
|
||||
- ./yesod-auth-oauth
|
||||
- ./yesod-sitemap
|
||||
|
|
|
@ -5,6 +5,7 @@ packages:
|
|||
- ./yesod-persistent
|
||||
- ./yesod-newsfeed
|
||||
- ./yesod-form
|
||||
- ./yesod-form-multi
|
||||
- ./yesod-auth
|
||||
- ./yesod-auth-oauth
|
||||
- ./yesod-sitemap
|
||||
|
|
12
stack.yaml.lock
Normal file
12
stack.yaml.lock
Normal file
|
@ -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
|
5
yesod-form-multi/ChangeLog.md
Normal file
5
yesod-form-multi/ChangeLog.md
Normal file
|
@ -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)
|
20
yesod-form-multi/LICENSE
Normal file
20
yesod-form-multi/LICENSE
Normal file
|
@ -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.
|
7
yesod-form-multi/README.md
Normal file
7
yesod-form-multi/README.md
Normal file
|
@ -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.
|
7
yesod-form-multi/Setup.lhs
Normal file
7
yesod-form-multi/Setup.lhs
Normal file
|
@ -0,0 +1,7 @@
|
|||
#!/usr/bin/env runhaskell
|
||||
|
||||
> module Main where
|
||||
> import Distribution.Simple
|
||||
|
||||
> main :: IO ()
|
||||
> main = defaultMain
|
294
yesod-form-multi/Yesod/Form/MultiInput.hs
Normal file
294
yesod-form-multi/Yesod/Form/MultiInput.hs
Normal file
|
@ -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
|
||||
}
|
38
yesod-form-multi/yesod-form-multi.cabal
Normal file
38
yesod-form-multi/yesod-form-multi.cabal
Normal file
|
@ -0,0 +1,38 @@
|
|||
name: yesod-form-multi
|
||||
version: 1.6.0
|
||||
license: MIT
|
||||
license-file: LICENSE
|
||||
author: James Burton <jamesejburton@gmail.com>
|
||||
maintainer: James Burton <jamesejburton@gmail.com>
|
||||
synopsis: Multi-input form handling for Yesod Web Framework
|
||||
category: Web, Yesod
|
||||
stability: Stable
|
||||
cabal-version: >= 1.8
|
||||
build-type: Simple
|
||||
homepage: http://www.yesodweb.com/
|
||||
description: API docs and the README are available at <http://www.stackage.org/package/yesod-form-multi>.
|
||||
extra-source-files: ChangeLog.md
|
||||
README.md
|
||||
|
||||
flag network-uri
|
||||
description: Get Network.URI from the network-uri package
|
||||
default: True
|
||||
|
||||
library
|
||||
build-depends: base >= 4 && < 5
|
||||
, containers >= 0.2
|
||||
, shakespeare >= 2.0
|
||||
, text >= 0.9
|
||||
, transformers >= 0.2.2
|
||||
, yesod-core >= 1.6 && < 1.7
|
||||
, yesod-form >= 1.6 && < 1.7
|
||||
|
||||
if flag(network-uri)
|
||||
build-depends: network-uri >= 2.6
|
||||
|
||||
exposed-modules: Yesod.Form.MultiInput
|
||||
ghc-options: -Wall
|
||||
|
||||
source-repository head
|
||||
type: git
|
||||
location: https://github.com/yesodweb/yesod
|
Loading…
Reference in a new issue