{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE CPP #-}
module Yesod.Form.Functions
    ( -- * Running in MForm monad
      newFormIdent
    , askParams
    , askFiles
      -- * Applicative/Monadic conversion
    , formToAForm
    , aFormToForm
    , mFormToWForm
    , wFormToAForm
    , wFormToMForm
      -- * Fields to Forms
    , wreq
    , wreqMsg
    , wopt
    , mreq
    , mreqMsg
    , mopt
    , areq
    , areqMsg
    , aopt
      -- * Run a form
    , runFormPost
    , runFormPostNoToken
    , runFormGet
      -- * Generate a blank form
    , generateFormPost
    , generateFormGet'
    , generateFormGet
      -- * More than one form on a handler
    , identifyForm
      -- * Rendering
    , FormRender
    , renderTable
    , renderDivs
    , renderDivsNoLabels
    , renderBootstrap
    , renderBootstrap2
      -- * Validation
    , check
    , checkBool
    , checkM
    , checkMMap
    , customErrorMessage
      -- * Utilities
    , fieldSettingsLabel
    , parseHelper
    , parseHelperGen
    , convertField
    , addClass
    , removeClass
    ) where

import Yesod.Form.Types
import Data.Text (Text, pack)
import qualified Data.Text as T
import Control.Arrow (second)
import Control.Monad.Trans.Class
import Control.Monad.Trans.RWS (ask, get, put, runRWST, tell, evalRWST, local, mapRWST)
import Control.Monad.Trans.Writer (runWriterT, writer)
import Control.Monad (liftM, join)
import Data.Byteable (constEqBytes)
import Text.Blaze (Markup, toMarkup)
#define Html Markup
#define toHtml toMarkup
import Yesod.Core
import Network.Wai (requestMethod)
import Data.Monoid (mempty, (<>))
import Data.Maybe (listToMaybe, fromMaybe)
import qualified Data.Map as Map
import qualified Data.Text.Encoding as TE
import Control.Arrow (first)

-- | Get a unique identifier.
newFormIdent :: Monad m => MForm m Text
newFormIdent :: forall (m :: * -> *). Monad m => MForm m Text
newFormIdent = do
    Ints
i <- forall w (m :: * -> *) r s. (Monoid w, Monad m) => RWST r w s m s
get
    let i' :: Ints
i' = Ints -> Ints
incrInts Ints
i
    forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
s -> RWST r w s m ()
put Ints
i'
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> Text
pack forall a b. (a -> b) -> a -> b
$ Char
'f' forall a. a -> [a] -> [a]
: forall a. Show a => a -> String
show Ints
i'
  where
    incrInts :: Ints -> Ints
incrInts (IntSingle Int
i) = Int -> Ints
IntSingle forall a b. (a -> b) -> a -> b
$ Int
i forall a. Num a => a -> a -> a
+ Int
1
    incrInts (IntCons Int
i Ints
is) = (Int
i forall a. Num a => a -> a -> a
+ Int
1) Int -> Ints -> Ints
`IntCons` Ints
is

formToAForm :: (HandlerSite m ~ site, Monad m)
            => MForm m (FormResult a, [FieldView site])
            -> AForm m a
formToAForm :: forall (m :: * -> *) site a.
(HandlerSite m ~ site, Monad m) =>
MForm m (FormResult a, [FieldView site]) -> AForm m a
formToAForm MForm m (FormResult a, [FieldView site])
form = forall (m :: * -> *) a.
((HandlerSite m, [Text])
 -> Maybe (Env, FileEnv)
 -> Ints
 -> m (FormResult a,
       [FieldView (HandlerSite m)] -> [FieldView (HandlerSite m)], Ints,
       Enctype))
-> AForm m a
AForm forall a b. (a -> b) -> a -> b
$ \(HandlerSite m
site, [Text]
langs) Maybe (Env, FileEnv)
env Ints
ints -> do
    ((FormResult a
a, [FieldView site]
xmls), Ints
ints', Enctype
enc) <- forall r w s (m :: * -> *) a.
RWST r w s m a -> r -> s -> m (a, s, w)
runRWST MForm m (FormResult a, [FieldView site])
form (Maybe (Env, FileEnv)
env, HandlerSite m
site, [Text]
langs) Ints
ints
    forall (m :: * -> *) a. Monad m => a -> m a
return (FormResult a
a, forall a. [a] -> [a] -> [a]
(++) [FieldView site]
xmls, Ints
ints', Enctype
enc)

aFormToForm :: (Monad m, HandlerSite m ~ site)
            => AForm m a
            -> MForm m (FormResult a, [FieldView site] -> [FieldView site])
aFormToForm :: forall (m :: * -> *) site a.
(Monad m, HandlerSite m ~ site) =>
AForm m a
-> MForm m (FormResult a, [FieldView site] -> [FieldView site])
aFormToForm (AForm (HandlerSite m, [Text])
-> Maybe (Env, FileEnv)
-> Ints
-> m (FormResult a,
      [FieldView (HandlerSite m)] -> [FieldView (HandlerSite m)], Ints,
      Enctype)
aform) = do
    Ints
ints <- forall w (m :: * -> *) r s. (Monoid w, Monad m) => RWST r w s m s
get
    (Maybe (Env, FileEnv)
env, site
site, [Text]
langs) <- forall w (m :: * -> *) r s. (Monoid w, Monad m) => RWST r w s m r
ask
    (FormResult a
a, [FieldView site] -> [FieldView site]
xml, Ints
ints', Enctype
enc) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ (HandlerSite m, [Text])
-> Maybe (Env, FileEnv)
-> Ints
-> m (FormResult a,
      [FieldView (HandlerSite m)] -> [FieldView (HandlerSite m)], Ints,
      Enctype)
aform (site
site, [Text]
langs) Maybe (Env, FileEnv)
env Ints
ints
    forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
s -> RWST r w s m ()
put Ints
ints'
    forall (m :: * -> *) w r s. Monad m => w -> RWST r w s m ()
tell Enctype
enc
    forall (m :: * -> *) a. Monad m => a -> m a
return (FormResult a
a, [FieldView site] -> [FieldView site]
xml)

askParams :: Monad m => MForm m (Maybe Env)
askParams :: forall (m :: * -> *). Monad m => MForm m (Maybe Env)
askParams = do
    (Maybe (Env, FileEnv)
x, HandlerSite m
_, [Text]
_) <- forall w (m :: * -> *) r s. (Monoid w, Monad m) => RWST r w s m r
ask
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a b. (a, b) -> a
fst Maybe (Env, FileEnv)
x

askFiles :: Monad m => MForm m (Maybe FileEnv)
askFiles :: forall (m :: * -> *). Monad m => MForm m (Maybe FileEnv)
askFiles = do
    (Maybe (Env, FileEnv)
x, HandlerSite m
_, [Text]
_) <- forall w (m :: * -> *) r s. (Monoid w, Monad m) => RWST r w s m r
ask
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a b. (a, b) -> b
snd Maybe (Env, FileEnv)
x

-- | Converts a form field into monadic form 'WForm'. This field requires a
-- value and will return 'FormFailure' if left empty.
--
-- @since 1.4.14
wreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
     => Field m a           -- ^ form field
     -> FieldSettings site  -- ^ settings for this field
     -> Maybe a             -- ^ optional default value
     -> WForm m (FormResult a)
wreq :: forall site (m :: * -> *) a.
(RenderMessage site FormMessage, HandlerSite m ~ site,
 MonadHandler m) =>
Field m a
-> FieldSettings site -> Maybe a -> WForm m (FormResult a)
wreq Field m a
f FieldSettings site
fs = forall site msg (m :: * -> *) a.
(RenderMessage site msg, HandlerSite m ~ site, MonadHandler m) =>
Field m a
-> FieldSettings site -> msg -> Maybe a -> WForm m (FormResult a)
wreqMsg Field m a
f FieldSettings site
fs FormMessage
MsgValueRequired

-- | Same as @wreq@ but with your own message to be rendered in case the value
-- is not provided.
--
-- This is useful when you have several required fields on the page and you
-- want to differentiate between which fields were left blank. Otherwise the
-- user sees "Value is required" multiple times, which is ambiguous.
--
-- @since 1.6.7
wreqMsg :: (RenderMessage site msg, HandlerSite m ~ site, MonadHandler m)
        => Field m a           -- ^ form field
        -> FieldSettings site  -- ^ settings for this field
        -> msg                 -- ^ message to use in case value is Nothing
        -> Maybe a             -- ^ optional default value
        -> WForm m (FormResult a)
wreqMsg :: forall site msg (m :: * -> *) a.
(RenderMessage site msg, HandlerSite m ~ site, MonadHandler m) =>
Field m a
-> FieldSettings site -> msg -> Maybe a -> WForm m (FormResult a)
wreqMsg Field m a
f FieldSettings site
fs msg
msg = forall (m :: * -> *) site a.
(MonadHandler m, HandlerSite m ~ site) =>
MForm m (a, FieldView site) -> WForm m a
mFormToWForm forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall site msg (m :: * -> *) a.
(RenderMessage site msg, HandlerSite m ~ site, MonadHandler m) =>
Field m a
-> FieldSettings site
-> msg
-> Maybe a
-> MForm m (FormResult a, FieldView site)
mreqMsg Field m a
f FieldSettings site
fs msg
msg

-- | Converts a form field into monadic form 'WForm'. This field is optional,
-- i.e.  if filled in, it returns 'Just a', if left empty, it returns
-- 'Nothing'.  Arguments are the same as for 'wreq' (apart from type of default
-- value).
--
-- @since 1.4.14
wopt :: (MonadHandler m, HandlerSite m ~ site)
     => Field m a           -- ^ form field
     -> FieldSettings site  -- ^ settings for this field
     -> Maybe (Maybe a)     -- ^ optional default value
     -> WForm m (FormResult (Maybe a))
wopt :: forall (m :: * -> *) site a.
(MonadHandler m, HandlerSite m ~ site) =>
Field m a
-> FieldSettings site
-> Maybe (Maybe a)
-> WForm m (FormResult (Maybe a))
wopt Field m a
f FieldSettings site
fs = forall (m :: * -> *) site a.
(MonadHandler m, HandlerSite m ~ site) =>
MForm m (a, FieldView site) -> WForm m a
mFormToWForm forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall site (m :: * -> *) a.
(site ~ HandlerSite m, MonadHandler m) =>
Field m a
-> FieldSettings site
-> Maybe (Maybe a)
-> MForm m (FormResult (Maybe a), FieldView site)
mopt Field m a
f FieldSettings site
fs

-- | Converts a monadic form 'WForm' into an applicative form 'AForm'.
--
-- @since 1.4.14
wFormToAForm :: MonadHandler m
             => WForm m (FormResult a)  -- ^ input form
             -> AForm m a               -- ^ output form
wFormToAForm :: forall (m :: * -> *) a.
MonadHandler m =>
WForm m (FormResult a) -> AForm m a
wFormToAForm = forall (m :: * -> *) site a.
(HandlerSite m ~ site, Monad m) =>
MForm m (FormResult a, [FieldView site]) -> AForm m a
formToAForm forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) site a.
(MonadHandler m, HandlerSite m ~ site) =>
WForm m a -> MForm m (a, [FieldView site])
wFormToMForm

-- | Converts a monadic form 'WForm' into another monadic form 'MForm'.
--
-- @since 1.4.14
wFormToMForm :: (MonadHandler m, HandlerSite m ~ site)
             => WForm m a                      -- ^ input form
             -> MForm m (a, [FieldView site])  -- ^ output form
wFormToMForm :: forall (m :: * -> *) site a.
(MonadHandler m, HandlerSite m ~ site) =>
WForm m a -> MForm m (a, [FieldView site])
wFormToMForm = forall (m :: * -> *) a s w (n :: * -> *) b w' r.
(m (a, s, w) -> n (b, s, w')) -> RWST r w s m a -> RWST r w' s n b
mapRWST (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {a} {b} {c} {b}. ((a, b, c), b) -> ((a, b), b, c)
group forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT)
  where
    group :: ((a, b, c), b) -> ((a, b), b, c)
group ((a
a, b
ints, c
enctype), b
views) = ((a
a, b
views), b
ints, c
enctype)

-- | Converts a monadic form 'MForm' into another monadic form 'WForm'.
--
-- @since 1.4.14
mFormToWForm :: (MonadHandler m, HandlerSite m ~ site)
             => MForm m (a, FieldView site)  -- ^ input form
             -> WForm m a                    -- ^ output form
mFormToWForm :: forall (m :: * -> *) site a.
(MonadHandler m, HandlerSite m ~ site) =>
MForm m (a, FieldView site) -> WForm m a
mFormToWForm = forall (m :: * -> *) a s w (n :: * -> *) b w' r.
(m (a, s, w) -> n (b, s, w')) -> RWST r w s m a -> RWST r w' s n b
mapRWST forall a b. (a -> b) -> a -> b
$ \m ((a, FieldView site), Ints, Enctype)
f -> do
  ((a
a, FieldView site
view), Ints
ints, Enctype
enctype) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m ((a, FieldView site), Ints, Enctype)
f
  forall (m :: * -> *) a w. Monad m => (a, w) -> WriterT w m a
writer ((a
a, Ints
ints, Enctype
enctype), [FieldView site
view])

-- | Converts a form field into monadic form. This field requires a value
-- and will return 'FormFailure' if left empty.
mreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
     => Field m a           -- ^ form field
     -> FieldSettings site  -- ^ settings for this field
     -> Maybe a             -- ^ optional default value
     -> MForm m (FormResult a, FieldView site)
mreq :: forall site (m :: * -> *) a.
(RenderMessage site FormMessage, HandlerSite m ~ site,
 MonadHandler m) =>
Field m a
-> FieldSettings site
-> Maybe a
-> MForm m (FormResult a, FieldView site)
mreq Field m a
field FieldSettings site
fs Maybe a
mdef = forall site msg (m :: * -> *) a.
(RenderMessage site msg, HandlerSite m ~ site, MonadHandler m) =>
Field m a
-> FieldSettings site
-> msg
-> Maybe a
-> MForm m (FormResult a, FieldView site)
mreqMsg Field m a
field FieldSettings site
fs FormMessage
MsgValueRequired Maybe a
mdef

-- | Same as @mreq@ but with your own message to be rendered in case the value
-- is not provided.
--
-- This is useful when you have several required fields on the page and you
-- want to differentiate between which fields were left blank. Otherwise the
-- user sees "Value is required" multiple times, which is ambiguous.
--
-- @since 1.6.6
mreqMsg :: (RenderMessage site msg, HandlerSite m ~ site, MonadHandler m)
        => Field m a           -- ^ form field
        -> FieldSettings site  -- ^ settings for this field
        -> msg                 -- ^ Message to use in case value is Nothing
        -> Maybe a             -- ^ optional default value
        -> MForm m (FormResult a, FieldView site)
mreqMsg :: forall site msg (m :: * -> *) a.
(RenderMessage site msg, HandlerSite m ~ site, MonadHandler m) =>
Field m a
-> FieldSettings site
-> msg
-> Maybe a
-> MForm m (FormResult a, FieldView site)
mreqMsg Field m a
field FieldSettings site
fs msg
msg Maybe a
mdef = forall site (m :: * -> *) a b.
(site ~ HandlerSite m, MonadHandler m) =>
Field m a
-> FieldSettings site
-> Maybe a
-> (site -> [Text] -> FormResult b)
-> (a -> FormResult b)
-> Bool
-> MForm m (FormResult b, FieldView site)
mhelper Field m a
field FieldSettings site
fs Maybe a
mdef site -> [Text] -> FormResult a
formFailure forall a. a -> FormResult a
FormSuccess Bool
True
  where formFailure :: site -> [Text] -> FormResult a
formFailure site
m [Text]
l = forall a. [Text] -> FormResult a
FormFailure [forall master message.
RenderMessage master message =>
master -> [Text] -> message -> Text
renderMessage site
m [Text]
l msg
msg]

-- | Converts a form field into monadic form. This field is optional, i.e.
-- if filled in, it returns 'Just a', if left empty, it returns 'Nothing'.
-- Arguments are the same as for 'mreq' (apart from type of default value).
mopt :: (site ~ HandlerSite m, MonadHandler m)
     => Field m a
     -> FieldSettings site
     -> Maybe (Maybe a)
     -> MForm m (FormResult (Maybe a), FieldView site)
mopt :: forall site (m :: * -> *) a.
(site ~ HandlerSite m, MonadHandler m) =>
Field m a
-> FieldSettings site
-> Maybe (Maybe a)
-> MForm m (FormResult (Maybe a), FieldView site)
mopt Field m a
field FieldSettings site
fs Maybe (Maybe a)
mdef = forall site (m :: * -> *) a b.
(site ~ HandlerSite m, MonadHandler m) =>
Field m a
-> FieldSettings site
-> Maybe a
-> (site -> [Text] -> FormResult b)
-> (a -> FormResult b)
-> Bool
-> MForm m (FormResult b, FieldView site)
mhelper Field m a
field FieldSettings site
fs (forall (m :: * -> *) a. Monad m => m (m a) -> m a
join Maybe (Maybe a)
mdef) (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall a. a -> FormResult a
FormSuccess forall a. Maybe a
Nothing) (forall a. a -> FormResult a
FormSuccess forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just) Bool
False

mhelper :: (site ~ HandlerSite m, MonadHandler m)
        => Field m a
        -> FieldSettings site
        -> Maybe a
        -> (site -> [Text] -> FormResult b) -- ^ on missing
        -> (a -> FormResult b) -- ^ on success
        -> Bool -- ^ is it required?
        -> MForm m (FormResult b, FieldView site)

mhelper :: forall site (m :: * -> *) a b.
(site ~ HandlerSite m, MonadHandler m) =>
Field m a
-> FieldSettings site
-> Maybe a
-> (site -> [Text] -> FormResult b)
-> (a -> FormResult b)
-> Bool
-> MForm m (FormResult b, FieldView site)
mhelper Field {Enctype
[Text]
-> [FileInfo] -> m (Either (SomeMessage (HandlerSite m)) (Maybe a))
FieldViewFunc m a
fieldEnctype :: forall (m :: * -> *) a. Field m a -> Enctype
fieldView :: forall (m :: * -> *) a. Field m a -> FieldViewFunc m a
fieldParse :: forall (m :: * -> *) a.
Field m a
-> [Text]
-> [FileInfo]
-> m (Either (SomeMessage (HandlerSite m)) (Maybe a))
fieldEnctype :: Enctype
fieldView :: FieldViewFunc m a
fieldParse :: [Text]
-> [FileInfo] -> m (Either (SomeMessage (HandlerSite m)) (Maybe a))
..} FieldSettings {[(Text, Text)]
Maybe Text
Maybe (SomeMessage site)
SomeMessage site
fsAttrs :: forall master. FieldSettings master -> [(Text, Text)]
fsName :: forall master. FieldSettings master -> Maybe Text
fsId :: forall master. FieldSettings master -> Maybe Text
fsTooltip :: forall master. FieldSettings master -> Maybe (SomeMessage master)
fsLabel :: forall master. FieldSettings master -> SomeMessage master
fsAttrs :: [(Text, Text)]
fsName :: Maybe Text
fsId :: Maybe Text
fsTooltip :: Maybe (SomeMessage site)
fsLabel :: SomeMessage site
..} Maybe a
mdef site -> [Text] -> FormResult b
onMissing a -> FormResult b
onFound Bool
isReq = do
    forall (m :: * -> *) w r s. Monad m => w -> RWST r w s m ()
tell Enctype
fieldEnctype
    Maybe Env
mp <- forall (m :: * -> *). Monad m => MForm m (Maybe Env)
askParams
    Text
name <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall (m :: * -> *). Monad m => MForm m Text
newFormIdent forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
fsName
    Text
theId <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall (m :: * -> *). MonadHandler m => m Text
newIdent forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
fsId
    (Maybe (Env, FileEnv)
_, site
site, [Text]
langs) <- forall w (m :: * -> *) r s. (Monoid w, Monad m) => RWST r w s m r
ask
    let mr2 :: SomeMessage site -> Text
mr2 = forall master message.
RenderMessage master message =>
master -> [Text] -> message -> Text
renderMessage site
site [Text]
langs
    (FormResult b
res, Either Text a
val) <-
        case Maybe Env
mp of
            Maybe Env
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. FormResult a
FormMissing, forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left Text
"") forall a b. b -> Either a b
Right Maybe a
mdef)
            Just Env
p -> do
                Maybe FileEnv
mfs <- forall (m :: * -> *). Monad m => MForm m (Maybe FileEnv)
askFiles
                let mvals :: [Text]
mvals = forall a. a -> Maybe a -> a
fromMaybe [] forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
name Env
p
                    files :: [FileInfo]
files = forall a. a -> Maybe a -> a
fromMaybe [] forall a b. (a -> b) -> a -> b
$ Maybe FileEnv
mfs forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
name
                Either (SomeMessage site) (Maybe a)
emx <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ [Text]
-> [FileInfo] -> m (Either (SomeMessage (HandlerSite m)) (Maybe a))
fieldParse [Text]
mvals [FileInfo]
files
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Either (SomeMessage site) (Maybe a)
emx of
                    Left (SomeMessage msg
e) -> (forall a. [Text] -> FormResult a
FormFailure [forall master message.
RenderMessage master message =>
master -> [Text] -> message -> Text
renderMessage site
site [Text]
langs msg
e], forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left Text
"") forall a b. a -> Either a b
Left (forall a. [a] -> Maybe a
listToMaybe [Text]
mvals))
                    Right Maybe a
mx ->
                        case Maybe a
mx of
                            Maybe a
Nothing -> (site -> [Text] -> FormResult b
onMissing site
site [Text]
langs, forall a b. a -> Either a b
Left Text
"")
                            Just a
x -> (a -> FormResult b
onFound a
x, forall a b. b -> Either a b
Right a
x)
    forall (m :: * -> *) a. Monad m => a -> m a
return (FormResult b
res, FieldView
        { fvLabel :: Markup
fvLabel = toHtml $ mr2 fsLabel
        , fvTooltip :: Maybe Markup
fvTooltip = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap toHtml $ fmap mr2 fsTooltip
        , fvId :: Text
fvId = Text
theId
        , fvInput :: WidgetFor site ()
fvInput = FieldViewFunc m a
fieldView Text
theId Text
name [(Text, Text)]
fsAttrs Either Text a
val Bool
isReq
        , fvErrors :: Maybe Markup
fvErrors =
            case FormResult b
res of
                FormFailure [Text
e] -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ toHtml e
                FormResult b
_ -> forall a. Maybe a
Nothing
        , fvRequired :: Bool
fvRequired = Bool
isReq
        })

-- | Applicative equivalent of 'mreq'.
areq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
     => Field m a           -- ^ form field
     -> FieldSettings site  -- ^ settings for this field
     -> Maybe a             -- ^ optional default value
     -> AForm m a
areq :: forall site (m :: * -> *) a.
(RenderMessage site FormMessage, HandlerSite m ~ site,
 MonadHandler m) =>
Field m a -> FieldSettings site -> Maybe a -> AForm m a
areq Field m a
f FieldSettings site
fs = forall site msg (m :: * -> *) a.
(RenderMessage site msg, HandlerSite m ~ site, MonadHandler m) =>
Field m a -> FieldSettings site -> msg -> Maybe a -> AForm m a
areqMsg Field m a
f FieldSettings site
fs FormMessage
MsgValueRequired

-- | Same as @areq@ but with your own message to be rendered in case the value
-- is not provided.
--
-- This is useful when you have several required fields on the page and you
-- want to differentiate between which fields were left blank. Otherwise the
-- user sees "Value is required" multiple times, which is ambiguous.
--
-- @since 1.6.7
areqMsg :: (RenderMessage site msg, HandlerSite m ~ site, MonadHandler m)
        => Field m a           -- ^ form field
        -> FieldSettings site  -- ^ settings for this field
        -> msg                 -- ^ message to use in case value is Nothing
        -> Maybe a             -- ^ optional default value
        -> AForm m a
areqMsg :: forall site msg (m :: * -> *) a.
(RenderMessage site msg, HandlerSite m ~ site, MonadHandler m) =>
Field m a -> FieldSettings site -> msg -> Maybe a -> AForm m a
areqMsg Field m a
f FieldSettings site
fs msg
msg = forall (m :: * -> *) site a.
(HandlerSite m ~ site, Monad m) =>
MForm m (FormResult a, [FieldView site]) -> AForm m a
formToAForm forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second forall (m :: * -> *) a. Monad m => a -> m a
return) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall site msg (m :: * -> *) a.
(RenderMessage site msg, HandlerSite m ~ site, MonadHandler m) =>
Field m a
-> FieldSettings site
-> msg
-> Maybe a
-> MForm m (FormResult a, FieldView site)
mreqMsg Field m a
f FieldSettings site
fs msg
msg

-- | Applicative equivalent of 'mopt'.
aopt :: MonadHandler m
     => Field m a
     -> FieldSettings (HandlerSite m)
     -> Maybe (Maybe a)
     -> AForm m (Maybe a)
aopt :: forall (m :: * -> *) a.
MonadHandler m =>
Field m a
-> FieldSettings (HandlerSite m)
-> Maybe (Maybe a)
-> AForm m (Maybe a)
aopt Field m a
a FieldSettings (HandlerSite m)
b = forall (m :: * -> *) site a.
(HandlerSite m ~ site, Monad m) =>
MForm m (FormResult a, [FieldView site]) -> AForm m a
formToAForm forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second forall (m :: * -> *) a. Monad m => a -> m a
return) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall site (m :: * -> *) a.
(site ~ HandlerSite m, MonadHandler m) =>
Field m a
-> FieldSettings site
-> Maybe (Maybe a)
-> MForm m (FormResult (Maybe a), FieldView site)
mopt Field m a
a FieldSettings (HandlerSite m)
b

runFormGeneric :: Monad m
               => MForm m a
               -> HandlerSite m
               -> [Text]
               -> Maybe (Env, FileEnv)
               -> m (a, Enctype)
runFormGeneric :: forall (m :: * -> *) a.
Monad m =>
MForm m a
-> HandlerSite m
-> [Text]
-> Maybe (Env, FileEnv)
-> m (a, Enctype)
runFormGeneric MForm m a
form HandlerSite m
site [Text]
langs Maybe (Env, FileEnv)
env = forall (m :: * -> *) r w s a.
Monad m =>
RWST r w s m a -> r -> s -> m (a, w)
evalRWST MForm m a
form (Maybe (Env, FileEnv)
env, HandlerSite m
site, [Text]
langs) (Int -> Ints
IntSingle Int
0)

-- | This function is used to both initially render a form and to later extract
-- results from it. Note that, due to CSRF protection and a few other issues,
-- forms submitted via GET and POST are slightly different. As such, be sure to
-- call the relevant function based on how the form will be submitted, /not/
-- the current request method.
--
-- For example, a common case is displaying a form on a GET request and having
-- the form submit to a POST page. In such a case, both the GET and POST
-- handlers should use 'runFormPost'.
runFormPost :: (RenderMessage (HandlerSite m) FormMessage, MonadResource m, MonadHandler m)
            => (Html -> MForm m (FormResult a, xml))
            -> m ((FormResult a, xml), Enctype)
runFormPost :: forall (m :: * -> *) a xml.
(RenderMessage (HandlerSite m) FormMessage, MonadResource m,
 MonadHandler m) =>
(Markup -> MForm m (FormResult a, xml))
-> m ((FormResult a, xml), Enctype)
runFormPost Markup -> MForm m (FormResult a, xml)
form = do
    Maybe (Env, FileEnv)
env <- forall (m :: * -> *). MonadHandler m => m (Maybe (Env, FileEnv))
postEnv
    forall (m :: * -> *) a xml.
(MonadHandler m, RenderMessage (HandlerSite m) FormMessage) =>
(Markup -> MForm m (FormResult a, xml))
-> Maybe (Env, FileEnv) -> m ((FormResult a, xml), Enctype)
postHelper Markup -> MForm m (FormResult a, xml)
form Maybe (Env, FileEnv)
env

postHelper  :: (MonadHandler m, RenderMessage (HandlerSite m) FormMessage)
            => (Html -> MForm m (FormResult a, xml))
            -> Maybe (Env, FileEnv)
            -> m ((FormResult a, xml), Enctype)
postHelper :: forall (m :: * -> *) a xml.
(MonadHandler m, RenderMessage (HandlerSite m) FormMessage) =>
(Markup -> MForm m (FormResult a, xml))
-> Maybe (Env, FileEnv) -> m ((FormResult a, xml), Enctype)
postHelper Markup -> MForm m (FormResult a, xml)
form Maybe (Env, FileEnv)
env = do
    YesodRequest
req <- forall (m :: * -> *). MonadHandler m => m YesodRequest
getRequest
    let tokenKey :: Text
tokenKey = Text
defaultCsrfParamName
    let token :: Markup
token =
            case YesodRequest -> Maybe Text
reqToken YesodRequest
req of
                Maybe Text
Nothing -> forall a. Monoid a => a
Data.Monoid.mempty
                Just Text
n -> [shamlet|<input type=hidden name=#{tokenKey} value=#{n}>|]
    HandlerSite m
m <- forall (m :: * -> *). MonadHandler m => m (HandlerSite m)
getYesod
    [Text]
langs <- forall (m :: * -> *). MonadHandler m => m [Text]
languages
    ((FormResult a
res, xml
xml), Enctype
enctype) <- forall (m :: * -> *) a.
Monad m =>
MForm m a
-> HandlerSite m
-> [Text]
-> Maybe (Env, FileEnv)
-> m (a, Enctype)
runFormGeneric (Markup -> MForm m (FormResult a, xml)
form Markup
token) HandlerSite m
m [Text]
langs Maybe (Env, FileEnv)
env
    let res' :: FormResult a
res' =
            case (FormResult a
res, Maybe (Env, FileEnv)
env) of
                (FormResult a
_, Maybe (Env, FileEnv)
Nothing) -> forall a. FormResult a
FormMissing
                (FormSuccess{}, Just (Env
params, FileEnv
_))
                    | Bool -> Bool
not (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
tokenKey Env
params Maybe [Text] -> Maybe Text -> Bool
=== YesodRequest -> Maybe Text
reqToken YesodRequest
req) ->
                        forall a. [Text] -> FormResult a
FormFailure [forall master message.
RenderMessage master message =>
master -> [Text] -> message -> Text
renderMessage HandlerSite m
m [Text]
langs FormMessage
MsgCsrfWarning]
                (FormResult a, Maybe (Env, FileEnv))
_ -> FormResult a
res
            -- It's important to use constant-time comparison (constEqBytes) in order to avoid timing attacks.
            where (Just [Text
t1]) === :: Maybe [Text] -> Maybe Text -> Bool
=== (Just Text
t2) = Text -> ByteString
TE.encodeUtf8 Text
t1 forall a. Byteable a => a -> a -> Bool
`constEqBytes` Text -> ByteString
TE.encodeUtf8 Text
t2
                  Maybe [Text]
Nothing     === Maybe Text
Nothing   = Bool
True
                  Maybe [Text]
_           === Maybe Text
_         = Bool
False
    forall (m :: * -> *) a. Monad m => a -> m a
return ((FormResult a
res', xml
xml), Enctype
enctype)

-- | Similar to 'runFormPost', except it always ignores the currently available
-- environment. This is necessary in cases like a wizard UI, where a single
-- page will both receive and incoming form and produce a new, blank form. For
-- general usage, you can stick with @runFormPost@.
generateFormPost
    :: (RenderMessage (HandlerSite m) FormMessage, MonadHandler m)
    => (Html -> MForm m (FormResult a, xml))
    -> m (xml, Enctype)
generateFormPost :: forall (m :: * -> *) a xml.
(RenderMessage (HandlerSite m) FormMessage, MonadHandler m) =>
(Markup -> MForm m (FormResult a, xml)) -> m (xml, Enctype)
generateFormPost Markup -> MForm m (FormResult a, xml)
form = forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first forall a b. (a, b) -> b
snd forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` forall (m :: * -> *) a xml.
(MonadHandler m, RenderMessage (HandlerSite m) FormMessage) =>
(Markup -> MForm m (FormResult a, xml))
-> Maybe (Env, FileEnv) -> m ((FormResult a, xml), Enctype)
postHelper Markup -> MForm m (FormResult a, xml)
form forall a. Maybe a
Nothing

postEnv :: MonadHandler m => m (Maybe (Env, FileEnv))
postEnv :: forall (m :: * -> *). MonadHandler m => m (Maybe (Env, FileEnv))
postEnv = do
    YesodRequest
req <- forall (m :: * -> *). MonadHandler m => m YesodRequest
getRequest
    if Request -> ByteString
requestMethod (YesodRequest -> Request
reqWaiRequest YesodRequest
req) forall a. Eq a => a -> a -> Bool
== ByteString
"GET"
        then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
        else do
            ([(Text, Text)]
p, [(Text, FileInfo)]
f) <- forall (m :: * -> *).
MonadHandler m =>
m ([(Text, Text)], [(Text, FileInfo)])
runRequestBody
            let p' :: Env
p' = forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith forall a. [a] -> [a] -> [a]
(++) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\(Text
x, Text
y) -> forall k a. k -> a -> Map k a
Map.singleton Text
x [Text
y]) [(Text, Text)]
p
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Env
p', forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith forall a. [a] -> [a] -> [a]
(++) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\(Text
k, FileInfo
v) -> forall k a. k -> a -> Map k a
Map.singleton Text
k [FileInfo
v]) [(Text, FileInfo)]
f)

runFormPostNoToken :: MonadHandler m
                   => (Html -> MForm m a)
                   -> m (a, Enctype)
runFormPostNoToken :: forall (m :: * -> *) a.
MonadHandler m =>
(Markup -> MForm m a) -> m (a, Enctype)
runFormPostNoToken Markup -> MForm m a
form = do
    [Text]
langs <- forall (m :: * -> *). MonadHandler m => m [Text]
languages
    HandlerSite m
m <- forall (m :: * -> *). MonadHandler m => m (HandlerSite m)
getYesod
    Maybe (Env, FileEnv)
env <- forall (m :: * -> *). MonadHandler m => m (Maybe (Env, FileEnv))
postEnv
    forall (m :: * -> *) a.
Monad m =>
MForm m a
-> HandlerSite m
-> [Text]
-> Maybe (Env, FileEnv)
-> m (a, Enctype)
runFormGeneric (Markup -> MForm m a
form forall a. Monoid a => a
mempty) HandlerSite m
m [Text]
langs Maybe (Env, FileEnv)
env

runFormGet :: MonadHandler m
           => (Html -> MForm m a)
           -> m (a, Enctype)
runFormGet :: forall (m :: * -> *) a.
MonadHandler m =>
(Markup -> MForm m a) -> m (a, Enctype)
runFormGet Markup -> MForm m a
form = do
    [(Text, Text)]
gets <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM YesodRequest -> [(Text, Text)]
reqGetParams forall (m :: * -> *). MonadHandler m => m YesodRequest
getRequest
    let env :: Maybe (Env, FileEnv)
env =
            case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
getKey [(Text, Text)]
gets of
                Maybe Text
Nothing -> forall a. Maybe a
Nothing
                Just Text
_ -> forall a. a -> Maybe a
Just (forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith forall a. [a] -> [a] -> [a]
(++) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\(Text
x, Text
y) -> forall k a. k -> a -> Map k a
Map.singleton Text
x [Text
y]) [(Text, Text)]
gets, forall k a. Map k a
Map.empty)
    forall (m :: * -> *) a.
MonadHandler m =>
(Markup -> MForm m a) -> Maybe (Env, FileEnv) -> m (a, Enctype)
getHelper Markup -> MForm m a
form Maybe (Env, FileEnv)
env

{- FIXME: generateFormGet' "Will be renamed to generateFormGet in next version of Yesod" -}
-- |
--
-- Since 1.3.11
generateFormGet'
    :: MonadHandler m
    => (Html -> MForm m (FormResult a, xml))
    -> m (xml, Enctype)
generateFormGet' :: forall (m :: * -> *) a xml.
MonadHandler m =>
(Markup -> MForm m (FormResult a, xml)) -> m (xml, Enctype)
generateFormGet' Markup -> MForm m (FormResult a, xml)
form = forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first forall a b. (a, b) -> b
snd forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` forall (m :: * -> *) a.
MonadHandler m =>
(Markup -> MForm m a) -> Maybe (Env, FileEnv) -> m (a, Enctype)
getHelper Markup -> MForm m (FormResult a, xml)
form forall a. Maybe a
Nothing

{-# DEPRECATED generateFormGet "Will require RenderMessage in next version of Yesod" #-}
generateFormGet :: MonadHandler m
                => (Html -> MForm m a)
                -> m (a, Enctype)
generateFormGet :: forall (m :: * -> *) a.
MonadHandler m =>
(Markup -> MForm m a) -> m (a, Enctype)
generateFormGet Markup -> MForm m a
form = forall (m :: * -> *) a.
MonadHandler m =>
(Markup -> MForm m a) -> Maybe (Env, FileEnv) -> m (a, Enctype)
getHelper Markup -> MForm m a
form forall a. Maybe a
Nothing

getKey :: Text
getKey :: Text
getKey = Text
"_hasdata"

getHelper :: MonadHandler m
          => (Html -> MForm m a)
          -> Maybe (Env, FileEnv)
          -> m (a, Enctype)
getHelper :: forall (m :: * -> *) a.
MonadHandler m =>
(Markup -> MForm m a) -> Maybe (Env, FileEnv) -> m (a, Enctype)
getHelper Markup -> MForm m a
form Maybe (Env, FileEnv)
env = do
    let fragment :: Markup
fragment = [shamlet|<input type=hidden name=#{getKey}>|]
    [Text]
langs <- forall (m :: * -> *). MonadHandler m => m [Text]
languages
    HandlerSite m
m <- forall (m :: * -> *). MonadHandler m => m (HandlerSite m)
getYesod
    forall (m :: * -> *) a.
Monad m =>
MForm m a
-> HandlerSite m
-> [Text]
-> Maybe (Env, FileEnv)
-> m (a, Enctype)
runFormGeneric (Markup -> MForm m a
form Markup
fragment) HandlerSite m
m [Text]
langs Maybe (Env, FileEnv)
env


-- | Creates a hidden field on the form that identifies it.  This
-- identification is then used to distinguish between /missing/
-- and /wrong/ form data when a single handler contains more than
-- one form.
--
-- For instance, if you have the following code on your handler:
--
-- > ((fooRes, fooWidget), fooEnctype) <- runFormPost fooForm
-- > ((barRes, barWidget), barEnctype) <- runFormPost barForm
--
-- Then replace it with
--
-- > ((fooRes, fooWidget), fooEnctype) <- runFormPost $ identifyForm "foo" fooForm
-- > ((barRes, barWidget), barEnctype) <- runFormPost $ identifyForm "bar" barForm
--
-- Note that it's your responsibility to ensure that the
-- identification strings are unique (using the same one twice on a
-- single handler will not generate any errors).  This allows you
-- to create a variable number of forms and still have them work
-- even if their number or order change between the HTML
-- generation and the form submission.
identifyForm
  :: Monad m
  => Text -- ^ Form identification string.
  -> (Html -> MForm m (FormResult a, WidgetFor (HandlerSite m) ()))
  -> (Html -> MForm m (FormResult a, WidgetFor (HandlerSite m) ()))
identifyForm :: forall (m :: * -> *) a.
Monad m =>
Text
-> (Markup -> MForm m (FormResult a, WidgetFor (HandlerSite m) ()))
-> Markup
-> MForm m (FormResult a, WidgetFor (HandlerSite m) ())
identifyForm Text
identVal Markup -> MForm m (FormResult a, WidgetFor (HandlerSite m) ())
form = \Markup
fragment -> do
    -- Create hidden <input>.
    let fragment' :: Markup
fragment' =
          [shamlet|
            <input type=hidden name=#{identifyFormKey} value=identify-#{identVal}>
            #{fragment}
          |]

    -- Check if we got its value back.
    Maybe Env
mp <- forall (m :: * -> *). Monad m => MForm m (Maybe Env)
askParams
    let missing :: Bool
missing = (Maybe Env
mp forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
identifyFormKey) forall a. Eq a => a -> a -> Bool
/= forall a. a -> Maybe a
Just [Text
"identify-" forall a. Semigroup a => a -> a -> a
<> Text
identVal]

    -- Run the form proper (with our hidden <input>).  If the
    -- data is missing, then do not provide any params to the
    -- form, which will turn its result into FormMissing.  Also,
    -- doing this avoids having lots of fields with red errors.
    let eraseParams :: MForm m (FormResult a, WidgetFor (HandlerSite m) ())
-> MForm m (FormResult a, WidgetFor (HandlerSite m) ())
eraseParams | Bool
missing   = forall r w s (m :: * -> *) a.
(r -> r) -> RWST r w s m a -> RWST r w s m a
local (\(Maybe (Env, FileEnv)
_, HandlerSite m
h, [Text]
l) -> (forall a. Maybe a
Nothing, HandlerSite m
h, [Text]
l))
                    | Bool
otherwise = forall a. a -> a
id
    ( FormResult a
res', WidgetFor (HandlerSite m) ()
w) <- MForm m (FormResult a, WidgetFor (HandlerSite m) ())
-> MForm m (FormResult a, WidgetFor (HandlerSite m) ())
eraseParams (Markup -> MForm m (FormResult a, WidgetFor (HandlerSite m) ())
form Markup
fragment')

    -- Empty forms now properly return FormMissing. [#1072](https://github.com/yesodweb/yesod/issues/1072)
    let res :: FormResult a
res = if Bool
missing then forall a. FormResult a
FormMissing else FormResult a
res'
    forall (m :: * -> *) a. Monad m => a -> m a
return ( FormResult a
res, WidgetFor (HandlerSite m) ()
w)

identifyFormKey :: Text
identifyFormKey :: Text
identifyFormKey = Text
"_formid"


type FormRender m a =
       AForm m a
    -> Html
    -> MForm m (FormResult a, WidgetFor (HandlerSite m) ())

renderTable, renderDivs, renderDivsNoLabels :: Monad m => FormRender m a
-- | Render a form into a series of tr tags. Note that, in order to allow
-- you to add extra rows to the table, this function does /not/ wrap up
-- the resulting HTML in a table tag; you must do that yourself.
renderTable :: forall (m :: * -> *) a. Monad m => FormRender m a
renderTable AForm m a
aform Markup
fragment = do
    (FormResult a
res, [FieldView (HandlerSite m)] -> [FieldView (HandlerSite m)]
views') <- forall (m :: * -> *) site a.
(Monad m, HandlerSite m ~ site) =>
AForm m a
-> MForm m (FormResult a, [FieldView site] -> [FieldView site])
aFormToForm AForm m a
aform
    let views :: [FieldView (HandlerSite m)]
views = [FieldView (HandlerSite m)] -> [FieldView (HandlerSite m)]
views' []
    let widget :: WidgetFor (HandlerSite m) ()
widget = [whamlet|
$newline never
$if null views
    \#{fragment}
$forall (isFirst, view) <- addIsFirst views
    <tr :fvRequired view:.required :not $ fvRequired view:.optional>
        <td>
            $if isFirst
                \#{fragment}
            <label for=#{fvId view}>#{fvLabel view}
            $maybe tt <- fvTooltip view
                <div .tooltip>#{tt}
        <td>^{fvInput view}
        $maybe err <- fvErrors view
            <td .errors>#{err}
|]
    forall (m :: * -> *) a. Monad m => a -> m a
return (FormResult a
res, WidgetFor (HandlerSite m) ()
widget)
  where
    addIsFirst :: [b] -> [(Bool, b)]
addIsFirst [] = []
    addIsFirst (b
x:[b]
y) = (Bool
True, b
x) forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (Bool
False, ) [b]
y

-- | render a field inside a div
renderDivs :: forall (m :: * -> *) a. Monad m => FormRender m a
renderDivs = forall (m :: * -> *) a. Monad m => Bool -> FormRender m a
renderDivsMaybeLabels Bool
True

-- | render a field inside a div, not displaying any label
renderDivsNoLabels :: forall (m :: * -> *) a. Monad m => FormRender m a
renderDivsNoLabels = forall (m :: * -> *) a. Monad m => Bool -> FormRender m a
renderDivsMaybeLabels Bool
False

renderDivsMaybeLabels :: Monad m => Bool -> FormRender m a
renderDivsMaybeLabels :: forall (m :: * -> *) a. Monad m => Bool -> FormRender m a
renderDivsMaybeLabels Bool
withLabels AForm m a
aform Markup
fragment = do
    (FormResult a
res, [FieldView (HandlerSite m)] -> [FieldView (HandlerSite m)]
views') <- forall (m :: * -> *) site a.
(Monad m, HandlerSite m ~ site) =>
AForm m a
-> MForm m (FormResult a, [FieldView site] -> [FieldView site])
aFormToForm AForm m a
aform
    let views :: [FieldView (HandlerSite m)]
views = [FieldView (HandlerSite m)] -> [FieldView (HandlerSite m)]
views' []
    let widget :: WidgetFor (HandlerSite m) ()
widget = [whamlet|
$newline never
\#{fragment}
$forall view <- views
    <div :fvRequired view:.required :not $ fvRequired view:.optional>
        $if withLabels
                <label for=#{fvId view}>#{fvLabel view}
        $maybe tt <- fvTooltip view
            <div .tooltip>#{tt}
        ^{fvInput view}
        $maybe err <- fvErrors view
            <div .errors>#{err}
|]
    forall (m :: * -> *) a. Monad m => a -> m a
return (FormResult a
res, WidgetFor (HandlerSite m) ()
widget)

-- | Render a form using Bootstrap v2-friendly shamlet syntax.
-- If you're using Bootstrap v3, then you should use the
-- functions from module "Yesod.Form.Bootstrap3".
--
-- Sample Hamlet:
--
-- >  <form .form-horizontal method=post action=@{ActionR} enctype=#{formEnctype}>
-- >    <fieldset>
-- >      <legend>_{MsgLegend}
-- >      $case result
-- >        $of FormFailure reasons
-- >          $forall reason <- reasons
-- >            <div .alert .alert-error>#{reason}
-- >        $of _
-- >      ^{formWidget}
-- >      <div .form-actions>
-- >        <input .btn .primary type=submit value=_{MsgSubmit}>
--
-- Since 1.3.14
renderBootstrap2 :: Monad m => FormRender m a
renderBootstrap2 :: forall (m :: * -> *) a. Monad m => FormRender m a
renderBootstrap2 AForm m a
aform Markup
fragment = do
    (FormResult a
res, [FieldView (HandlerSite m)] -> [FieldView (HandlerSite m)]
views') <- forall (m :: * -> *) site a.
(Monad m, HandlerSite m ~ site) =>
AForm m a
-> MForm m (FormResult a, [FieldView site] -> [FieldView site])
aFormToForm AForm m a
aform
    let views :: [FieldView (HandlerSite m)]
views = [FieldView (HandlerSite m)] -> [FieldView (HandlerSite m)]
views' []
        has :: Maybe a -> Bool
has (Just a
_) = Bool
True
        has Maybe a
Nothing  = Bool
False
    let widget :: WidgetFor (HandlerSite m) ()
widget = [whamlet|
                $newline never
                \#{fragment}
                $forall view <- views
                    <div .control-group .clearfix :fvRequired view:.required :not $ fvRequired view:.optional :has $ fvErrors view:.error>
                        <label .control-label for=#{fvId view}>#{fvLabel view}
                        <div .controls .input>
                            ^{fvInput view}
                            $maybe tt <- fvTooltip view
                                <span .help-block>#{tt}
                            $maybe err <- fvErrors view
                                <span .help-block>#{err}
                |]
    forall (m :: * -> *) a. Monad m => a -> m a
return (FormResult a
res, WidgetFor (HandlerSite m) ()
widget)

-- | Deprecated synonym for 'renderBootstrap2'.
renderBootstrap :: Monad m => FormRender m a
renderBootstrap :: forall (m :: * -> *) a. Monad m => FormRender m a
renderBootstrap = forall (m :: * -> *) a. Monad m => FormRender m a
renderBootstrap2
{-# DEPRECATED renderBootstrap "Please use the Yesod.Form.Bootstrap3 module." #-}

check :: (Monad m, RenderMessage (HandlerSite m) msg)
      => (a -> Either msg a)
      -> Field m a
      -> Field m a
check :: forall (m :: * -> *) msg a.
(Monad m, RenderMessage (HandlerSite m) msg) =>
(a -> Either msg a) -> Field m a -> Field m a
check a -> Either msg a
f = forall (m :: * -> *) msg a.
(Monad m, RenderMessage (HandlerSite m) msg) =>
(a -> m (Either msg a)) -> Field m a -> Field m a
checkM forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either msg a
f

-- | Return the given error message if the predicate is false.
checkBool :: (Monad m, RenderMessage (HandlerSite m) msg)
          => (a -> Bool) -> msg -> Field m a -> Field m a
checkBool :: forall (m :: * -> *) msg a.
(Monad m, RenderMessage (HandlerSite m) msg) =>
(a -> Bool) -> msg -> Field m a -> Field m a
checkBool a -> Bool
b msg
s = forall (m :: * -> *) msg a.
(Monad m, RenderMessage (HandlerSite m) msg) =>
(a -> Either msg a) -> Field m a -> Field m a
check forall a b. (a -> b) -> a -> b
$ \a
x -> if a -> Bool
b a
x then forall a b. b -> Either a b
Right a
x else forall a b. a -> Either a b
Left msg
s

checkM :: (Monad m, RenderMessage (HandlerSite m) msg)
       => (a -> m (Either msg a))
       -> Field m a
       -> Field m a
checkM :: forall (m :: * -> *) msg a.
(Monad m, RenderMessage (HandlerSite m) msg) =>
(a -> m (Either msg a)) -> Field m a -> Field m a
checkM a -> m (Either msg a)
f = forall (m :: * -> *) msg a b.
(Monad m, RenderMessage (HandlerSite m) msg) =>
(a -> m (Either msg b)) -> (b -> a) -> Field m a -> Field m b
checkMMap a -> m (Either msg a)
f forall a. a -> a
id

-- | Same as 'checkM', but modifies the datatype.
--
-- In order to make this work, you must provide a function to convert back from
-- the new datatype to the old one (the second argument to this function).
--
-- Since 1.1.2
checkMMap :: (Monad m, RenderMessage (HandlerSite m) msg)
          => (a -> m (Either msg b))
          -> (b -> a)
          -> Field m a
          -> Field m b
checkMMap :: forall (m :: * -> *) msg a b.
(Monad m, RenderMessage (HandlerSite m) msg) =>
(a -> m (Either msg b)) -> (b -> a) -> Field m a -> Field m b
checkMMap a -> m (Either msg b)
f b -> a
inv Field m a
field = Field m a
field
    { fieldParse :: [Text]
-> [FileInfo] -> m (Either (SomeMessage (HandlerSite m)) (Maybe b))
fieldParse = \[Text]
ts [FileInfo]
fs -> do
        Either (SomeMessage (HandlerSite m)) (Maybe a)
e1 <- forall (m :: * -> *) a.
Field m a
-> [Text]
-> [FileInfo]
-> m (Either (SomeMessage (HandlerSite m)) (Maybe a))
fieldParse Field m a
field [Text]
ts [FileInfo]
fs
        case Either (SomeMessage (HandlerSite m)) (Maybe a)
e1 of
            Left SomeMessage (HandlerSite m)
msg -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left SomeMessage (HandlerSite m)
msg
            Right Maybe a
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a. Maybe a
Nothing
            Right (Just a
a) -> forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall master msg.
RenderMessage master msg =>
msg -> SomeMessage master
SomeMessage) (forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just)) forall a b. (a -> b) -> a -> b
$ a -> m (Either msg b)
f a
a
    , fieldView :: FieldViewFunc m b
fieldView = \Text
i Text
n [(Text, Text)]
a Either Text b
eres Bool
req -> forall (m :: * -> *) a. Field m a -> FieldViewFunc m a
fieldView Field m a
field Text
i Text
n [(Text, Text)]
a (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> a
inv Either Text b
eres) Bool
req
    }

-- | Allows you to overwrite the error message on parse error.
customErrorMessage :: Monad m => SomeMessage (HandlerSite m) -> Field m a -> Field m a
customErrorMessage :: forall (m :: * -> *) a.
Monad m =>
SomeMessage (HandlerSite m) -> Field m a -> Field m a
customErrorMessage SomeMessage (HandlerSite m)
msg Field m a
field = Field m a
field
    { fieldParse :: [Text]
-> [FileInfo] -> m (Either (SomeMessage (HandlerSite m)) (Maybe a))
fieldParse = \[Text]
ts [FileInfo]
fs ->
        forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left SomeMessage (HandlerSite m)
msg) forall a b. b -> Either a b
Right)
      forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
Field m a
-> [Text]
-> [FileInfo]
-> m (Either (SomeMessage (HandlerSite m)) (Maybe a))
fieldParse Field m a
field [Text]
ts [FileInfo]
fs
    }

-- | Generate a 'FieldSettings' from the given label.
fieldSettingsLabel :: RenderMessage site msg => msg -> FieldSettings site
fieldSettingsLabel :: forall site msg.
RenderMessage site msg =>
msg -> FieldSettings site
fieldSettingsLabel msg
msg = forall master.
SomeMessage master
-> Maybe (SomeMessage master)
-> Maybe Text
-> Maybe Text
-> [(Text, Text)]
-> FieldSettings master
FieldSettings (forall master msg.
RenderMessage master msg =>
msg -> SomeMessage master
SomeMessage msg
msg) forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing []

-- | A helper function for creating custom fields.
--
-- This is intended to help with the common case where a single input value is
-- required, such as when parsing a text field.
--
-- Since 1.1
parseHelper :: (Monad m, RenderMessage site FormMessage)
            => (Text -> Either FormMessage a)
            -> [Text] -> [FileInfo] -> m (Either (SomeMessage site) (Maybe a))
parseHelper :: forall (m :: * -> *) site a.
(Monad m, RenderMessage site FormMessage) =>
(Text -> Either FormMessage a)
-> [Text] -> [FileInfo] -> m (Either (SomeMessage site) (Maybe a))
parseHelper = forall (m :: * -> *) site msg a.
(Monad m, RenderMessage site msg) =>
(Text -> Either msg a)
-> [Text] -> [FileInfo] -> m (Either (SomeMessage site) (Maybe a))
parseHelperGen

-- | A generalized version of 'parseHelper', allowing any type for the message
-- indicating a bad parse.
--
-- Since 1.3.6
parseHelperGen :: (Monad m, RenderMessage site msg)
               => (Text -> Either msg a)
               -> [Text] -> [FileInfo] -> m (Either (SomeMessage site) (Maybe a))
parseHelperGen :: forall (m :: * -> *) site msg a.
(Monad m, RenderMessage site msg) =>
(Text -> Either msg a)
-> [Text] -> [FileInfo] -> m (Either (SomeMessage site) (Maybe a))
parseHelperGen Text -> Either msg a
_ [] [FileInfo]
_ = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a. Maybe a
Nothing
parseHelperGen Text -> Either msg a
_ (Text
"":[Text]
_) [FileInfo]
_ = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a. Maybe a
Nothing
parseHelperGen Text -> Either msg a
f (Text
x:[Text]
_) [FileInfo]
_ = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall master msg.
RenderMessage master msg =>
msg -> SomeMessage master
SomeMessage) (forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just) forall a b. (a -> b) -> a -> b
$ Text -> Either msg a
f Text
x

-- | Since a 'Field' cannot be a 'Functor', it is not obvious how to "reuse" a Field
-- on a @newtype@ or otherwise equivalent type. This function allows you to convert
-- a @Field m a@ to a @Field m b@ assuming you provide a bidirectional
-- conversion between the two, through the first two functions.
--
-- A simple example:
--
-- > import Data.Monoid
-- > sumField :: (Functor m, Monad m, RenderMessage (HandlerSite m) FormMessage) => Field m (Sum Int)
-- > sumField = convertField Sum getSum intField
--
-- Another example, not using a newtype, but instead creating a Lazy Text field:
--
-- > import qualified Data.Text.Lazy as TL
-- > TextField :: (Functor m, Monad m, RenderMessage (HandlerSite m) FormMessage) => Field m TL.Text
-- > lazyTextField = convertField TL.fromStrict TL.toStrict textField
--
-- Since 1.3.16
convertField :: (Functor m)
             => (a -> b) -> (b -> a)
             -> Field m a -> Field m b
convertField :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> (b -> a) -> Field m a -> Field m b
convertField a -> b
to b -> a
from (Field [Text]
-> [FileInfo] -> m (Either (SomeMessage (HandlerSite m)) (Maybe a))
fParse FieldViewFunc m a
fView Enctype
fEnctype) = let
  fParse' :: [Text]
-> [FileInfo] -> m (Either (SomeMessage (HandlerSite m)) (Maybe b))
fParse' [Text]
ts = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
to)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text]
-> [FileInfo] -> m (Either (SomeMessage (HandlerSite m)) (Maybe a))
fParse [Text]
ts
  fView' :: Text
-> Text
-> [(Text, Text)]
-> Either Text b
-> Bool
-> WidgetFor (HandlerSite m) ()
fView' Text
ti Text
tn [(Text, Text)]
at Either Text b
ei = FieldViewFunc m a
fView Text
ti Text
tn [(Text, Text)]
at (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> a
from Either Text b
ei)
  in forall (m :: * -> *) a.
([Text]
 -> [FileInfo]
 -> m (Either (SomeMessage (HandlerSite m)) (Maybe a)))
-> FieldViewFunc m a -> Enctype -> Field m a
Field [Text]
-> [FileInfo] -> m (Either (SomeMessage (HandlerSite m)) (Maybe b))
fParse' Text
-> Text
-> [(Text, Text)]
-> Either Text b
-> Bool
-> WidgetFor (HandlerSite m) ()
fView' Enctype
fEnctype

-- | Removes a CSS class from the 'fsAttrs' in a 'FieldSettings'.
--
-- ==== __Examples__
--
-- >>> removeClass "form-control" [("class","form-control login-form"),("id","home-login")]
-- [("class","  login-form"),("id","home-login")]
--
-- @since 1.6.2
removeClass :: Text -- ^ The class to remove
            -> [(Text, Text)] -- ^ List of existing 'fsAttrs'
            -> [(Text, Text)]
removeClass :: Text -> [(Text, Text)] -> [(Text, Text)]
removeClass Text
_     []                    = []
removeClass Text
klass ((Text
"class", Text
old):[(Text, Text)]
rest) = (Text
"class", Text -> Text -> Text -> Text
T.replace Text
klass Text
" " Text
old) forall a. a -> [a] -> [a]
: [(Text, Text)]
rest
removeClass Text
klass ((Text, Text)
other         :[(Text, Text)]
rest) = (Text, Text)
other forall a. a -> [a] -> [a]
: Text -> [(Text, Text)] -> [(Text, Text)]
removeClass Text
klass [(Text, Text)]
rest

-- | Adds a CSS class to the 'fsAttrs' in a 'FieldSettings'.
--
-- ==== __Examples__
--
-- >>> addClass "login-form" [("class", "form-control"), ("id", "home-login")]
-- [("class","form-control login-form"),("id","home-login")]
--
-- @since 1.6.2
addClass :: Text -- ^ The class to add
         -> [(Text, Text)] -- ^ List of existing 'fsAttrs'
         -> [(Text, Text)]
addClass :: Text -> [(Text, Text)] -> [(Text, Text)]
addClass Text
klass []                    = [(Text
"class", Text
klass)]
addClass Text
klass ((Text
"class", Text
old):[(Text, Text)]
rest) = (Text
"class", [Text] -> Text
T.concat [Text
old, Text
" ", Text
klass]) forall a. a -> [a] -> [a]
: [(Text, Text)]
rest
addClass Text
klass ((Text, Text)
other         :[(Text, Text)]
rest) = (Text, Text)
other forall a. a -> [a] -> [a]
: Text -> [(Text, Text)] -> [(Text, Text)]
addClass Text
klass [(Text, Text)]
rest