yesod-form-multi (empty) → 1.6.0
raw patch · 6 files changed
+371/−0 lines, 6 filesdep +basedep +containersdep +network-urisetup-changed
Dependencies added: base, containers, network-uri, shakespeare, text, transformers, yesod-core, yesod-form
Files
- ChangeLog.md +5/−0
- LICENSE +20/−0
- README.md +7/−0
- Setup.lhs +7/−0
- Yesod/Form/MultiInput.hs +294/−0
- yesod-form-multi.cabal +38/−0
+ ChangeLog.md view
@@ -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)
+ LICENSE view
@@ -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.
+ README.md view
@@ -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.
+ Setup.lhs view
@@ -0,0 +1,7 @@+#!/usr/bin/env runhaskell + +> module Main where +> import Distribution.Simple + +> main :: IO () +> main = defaultMain
+ Yesod/Form/MultiInput.hs view
@@ -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 + }
+ yesod-form-multi.cabal view
@@ -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