From d8ebb95c96d9219d4deb9604194ab1e80dbc840b Mon Sep 17 00:00:00 2001 From: James Burton Date: Fri, 16 Aug 2019 04:30:20 +0100 Subject: [PATCH] Added Multi Input Form Functionality (#1601) --- stack-lts-9.yaml | 1 + stack-persistent-2-10.yaml | 1 + stack-persistent-2-9.yaml | 1 + stack.yaml | 1 + stack.yaml.lock | 12 + yesod-form-multi/ChangeLog.md | 5 + yesod-form-multi/LICENSE | 20 ++ yesod-form-multi/README.md | 7 + yesod-form-multi/Setup.lhs | 7 + yesod-form-multi/Yesod/Form/MultiInput.hs | 294 ++++++++++++++++++++++ yesod-form-multi/yesod-form-multi.cabal | 38 +++ 11 files changed, 387 insertions(+) create mode 100644 stack.yaml.lock create mode 100644 yesod-form-multi/ChangeLog.md create mode 100644 yesod-form-multi/LICENSE create mode 100644 yesod-form-multi/README.md create mode 100644 yesod-form-multi/Setup.lhs create mode 100644 yesod-form-multi/Yesod/Form/MultiInput.hs create mode 100644 yesod-form-multi/yesod-form-multi.cabal diff --git a/stack-lts-9.yaml b/stack-lts-9.yaml index 3f5f1a7b..bceb5f4a 100644 --- a/stack-lts-9.yaml +++ b/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 diff --git a/stack-persistent-2-10.yaml b/stack-persistent-2-10.yaml index d1e28093..6a4dd98a 100644 --- a/stack-persistent-2-10.yaml +++ b/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 diff --git a/stack-persistent-2-9.yaml b/stack-persistent-2-9.yaml index c043213f..998398ae 100644 --- a/stack-persistent-2-9.yaml +++ b/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 diff --git a/stack.yaml b/stack.yaml index 81f227c9..180301b8 100644 --- a/stack.yaml +++ b/stack.yaml @@ -5,6 +5,7 @@ packages: - ./yesod-persistent - ./yesod-newsfeed - ./yesod-form +- ./yesod-form-multi - ./yesod-auth - ./yesod-auth-oauth - ./yesod-sitemap diff --git a/stack.yaml.lock b/stack.yaml.lock new file mode 100644 index 00000000..1e8cde0b --- /dev/null +++ b/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 diff --git a/yesod-form-multi/ChangeLog.md b/yesod-form-multi/ChangeLog.md new file mode 100644 index 00000000..c2dfe41b --- /dev/null +++ b/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) \ No newline at end of file diff --git a/yesod-form-multi/LICENSE b/yesod-form-multi/LICENSE new file mode 100644 index 00000000..bbd77be0 --- /dev/null +++ b/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. diff --git a/yesod-form-multi/README.md b/yesod-form-multi/README.md new file mode 100644 index 00000000..58282125 --- /dev/null +++ b/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. \ No newline at end of file diff --git a/yesod-form-multi/Setup.lhs b/yesod-form-multi/Setup.lhs new file mode 100644 index 00000000..06e2708f --- /dev/null +++ b/yesod-form-multi/Setup.lhs @@ -0,0 +1,7 @@ +#!/usr/bin/env runhaskell + +> module Main where +> import Distribution.Simple + +> main :: IO () +> main = defaultMain diff --git a/yesod-form-multi/Yesod/Form/MultiInput.hs b/yesod-form-multi/Yesod/Form/MultiInput.hs new file mode 100644 index 00000000..80079947 --- /dev/null +++ b/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| + #{err} + |] + +-- | 'MultiSettings' for Bootstrap 4. +-- +-- @since 1.6.0 +bs4Settings :: MultiSettings site +bs4Settings = MultiSettings "btn btn-basic" (Just errW) + where + errW err = + [whamlet| +
#{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| +