{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE CPP #-}
-- | Field functions allow you to easily create and validate forms, cleanly handling the uncertainty of parsing user input.
--
-- When possible, the field functions use a specific input type (e.g. "number"), allowing supporting browsers to validate the input before form submission. Browsers can also improve usability with this information; for example, mobile browsers might present a specialized keyboard for an input of type "email" or "number".
--
-- See the Yesod book <http://www.yesodweb.com/book/forms chapter on forms> for a broader overview of forms in Yesod.
module Yesod.Form.Fields
    ( -- * i18n
      FormMessage (..)
    , defaultFormMessage
      -- * Fields
    , textField
    , passwordField
    , textareaField
    , hiddenField
    , intField
    , dayField
    , timeField
    , timeFieldTypeTime
    , timeFieldTypeText
    , htmlField
    , emailField
    , multiEmailField
    , searchField
    , AutoFocus
    , urlField
    , doubleField
    , parseDate
    , parseTime
    , Textarea (..)
    , boolField
    , checkBoxField
    , fileField
      -- * File 'AForm's
    , fileAFormReq
    , fileAFormOpt
      -- * Options
      -- $optionsOverview
    , selectFieldHelper
    , selectField
    , selectFieldList
    , selectFieldListGrouped
    , radioField
    , radioFieldList
    , withRadioField
    , checkboxesField
    , checkboxesFieldList
    , multiSelectField
    , multiSelectFieldList
    , Option (..)
    , OptionList (..)
    , mkOptionList
    , mkOptionListGrouped
    , optionsPersist
    , optionsPersistKey
    , optionsPairs
    , optionsPairsGrouped
    , optionsEnum
    , colorField
    ) where

import Yesod.Form.Types
import Yesod.Form.I18n.English
import Yesod.Form.Functions (parseHelper)
import Yesod.Core
import Text.Blaze (ToMarkup (toMarkup), unsafeByteString)
#define ToHtml ToMarkup
#define toHtml toMarkup
#define preEscapedText preEscapedToMarkup
import Data.Time (Day, TimeOfDay(..))
import qualified Text.Email.Validate as Email
import Data.Text.Encoding (encodeUtf8, decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
import Network.URI (parseURI)
import Database.Persist.Sql (PersistField, PersistFieldSql (..))
#if MIN_VERSION_persistent(2,5,0)
import Database.Persist (Entity (..), SqlType (SqlString), PersistRecordBackend, PersistQueryRead)
#else
import Database.Persist (Entity (..), SqlType (SqlString), PersistEntity, PersistQuery, PersistEntityBackend)
#endif
import Text.HTML.SanitizeXSS (sanitizeBalance)
import Control.Monad (when, unless, forM_)
import Data.Either (partitionEithers)
import Data.Maybe (listToMaybe, fromMaybe)

import qualified Blaze.ByteString.Builder.Html.Utf8 as B
import Blaze.ByteString.Builder (writeByteString, toLazyByteString)
import Blaze.ByteString.Builder.Internal.Write (fromWriteList)

import Text.Blaze.Html.Renderer.String (renderHtml)
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
import Data.Text as T ( Text, append, concat, cons, head
                      , intercalate, isPrefixOf, null, unpack, pack, splitOn
                      )
import qualified Data.Text as T (drop, dropWhile)
import qualified Data.Text.Read

import qualified Data.Map as Map
import Yesod.Persist (selectList, Filter, SelectOpt, Key)
import Control.Arrow ((&&&))

import Control.Applicative ((<$>), (<|>))

import Data.Attoparsec.Text (Parser, char, string, digit, skipSpace, endOfInput, parseOnly)

import Yesod.Persist.Core

import Data.String (IsString)

#if !MIN_VERSION_base(4,8,0)
import Data.Monoid
#endif

import Data.Char (isHexDigit)

defaultFormMessage :: FormMessage -> Text
defaultFormMessage :: FormMessage -> Text
defaultFormMessage = FormMessage -> Text
englishFormMessage

-- | Creates a input with @type="number"@ and @step=1@.
intField :: (Monad m, Integral i, RenderMessage (HandlerSite m) FormMessage) => Field m i
intField :: forall (m :: * -> *) i.
(Monad m, Integral i, RenderMessage (HandlerSite m) FormMessage) =>
Field m i
intField = Field
    { fieldParse :: [Text]
-> [FileInfo] -> m (Either (SomeMessage (HandlerSite m)) (Maybe i))
fieldParse = forall (m :: * -> *) site a.
(Monad m, RenderMessage site FormMessage) =>
(Text -> Either FormMessage a)
-> [Text] -> [FileInfo] -> m (Either (SomeMessage site) (Maybe a))
parseHelper forall a b. (a -> b) -> a -> b
$ \Text
s ->
        case forall a. Num a => Reader a -> Reader a
Data.Text.Read.signed forall a. Integral a => Reader a
Data.Text.Read.decimal Text
s of
            Right (i
a, Text
"") -> forall a b. b -> Either a b
Right i
a
            Either String (i, Text)
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text -> FormMessage
MsgInvalidInteger Text
s

    , fieldView :: FieldViewFunc m i
fieldView = \Text
theId Text
name [(Text, Text)]
attrs Either Text i
val Bool
isReq -> forall site a (m :: * -> *).
(ToWidget site a, MonadWidget m, HandlerSite m ~ site) =>
a -> m ()
toWidget [hamlet|
$newline never
<input id="#{theId}" name="#{name}" *{attrs} type="number" step=1 :isReq:required="" value="#{showVal val}">
|]
    , fieldEnctype :: Enctype
fieldEnctype = Enctype
UrlEncoded
    }
  where
    showVal :: Either Text i -> Text
showVal = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. a -> a
id (String -> Text
pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. Integral a => a -> String
showI)
    showI :: a -> String
showI a
x = forall a. Show a => a -> String
show (forall a b. (Integral a, Num b) => a -> b
fromIntegral a
x :: Integer)

-- | Creates a input with @type="number"@ and @step=any@.
doubleField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Double
doubleField :: forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m Double
doubleField = Field
    { fieldParse :: [Text]
-> [FileInfo]
-> m (Either (SomeMessage (HandlerSite m)) (Maybe Double))
fieldParse = forall (m :: * -> *) site a.
(Monad m, RenderMessage site FormMessage) =>
(Text -> Either FormMessage a)
-> [Text] -> [FileInfo] -> m (Either (SomeMessage site) (Maybe a))
parseHelper forall a b. (a -> b) -> a -> b
$ \Text
s ->
        case Reader Double
Data.Text.Read.double (Text -> Text
prependZero Text
s) of
            Right (Double
a, Text
"") -> forall a b. b -> Either a b
Right Double
a
            Either String (Double, Text)
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text -> FormMessage
MsgInvalidNumber Text
s

    , fieldView :: FieldViewFunc m Double
fieldView = \Text
theId Text
name [(Text, Text)]
attrs Either Text Double
val Bool
isReq -> forall site a (m :: * -> *).
(ToWidget site a, MonadWidget m, HandlerSite m ~ site) =>
a -> m ()
toWidget [hamlet|
$newline never
<input id="#{theId}" name="#{name}" *{attrs} type="number" step=any :isReq:required="" value="#{showVal val}">
|]
    , fieldEnctype :: Enctype
fieldEnctype = Enctype
UrlEncoded
    }
  where showVal :: Either Text Double -> Text
showVal = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. a -> a
id (String -> Text
pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show)

-- | Creates an input with @type="date"@, validating the input using the 'parseDate' function.
--
-- Add the @time@ package and import the "Data.Time.Calendar" module to use this function.
dayField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Day
dayField :: forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m Day
dayField = Field
    { fieldParse :: [Text]
-> [FileInfo]
-> m (Either (SomeMessage (HandlerSite m)) (Maybe Day))
fieldParse = forall (m :: * -> *) site a.
(Monad m, RenderMessage site FormMessage) =>
(Text -> Either FormMessage a)
-> [Text] -> [FileInfo] -> m (Either (SomeMessage site) (Maybe a))
parseHelper forall a b. (a -> b) -> a -> b
$ String -> Either FormMessage Day
parseDate forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
unpack
    , fieldView :: FieldViewFunc m Day
fieldView = \Text
theId Text
name [(Text, Text)]
attrs Either Text Day
val Bool
isReq -> forall site a (m :: * -> *).
(ToWidget site a, MonadWidget m, HandlerSite m ~ site) =>
a -> m ()
toWidget [hamlet|
$newline never
<input id="#{theId}" name="#{name}" *{attrs} type="date" :isReq:required="" value="#{showVal val}">
|]
    , fieldEnctype :: Enctype
fieldEnctype = Enctype
UrlEncoded
    }
  where showVal :: Either Text Day -> Text
showVal = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. a -> a
id (String -> Text
pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show)

-- | An alias for 'timeFieldTypeTime'.
timeField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m TimeOfDay
timeField :: forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m TimeOfDay
timeField = forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m TimeOfDay
timeFieldTypeTime

-- | Creates an input with @type="time"@. <http://caniuse.com/#search=time%20input%20type Browsers not supporting this type> will fallback to a text field, and Yesod will parse the time as described in 'timeFieldTypeText'.
--
-- Add the @time@ package and import the "Data.Time.LocalTime" module to use this function.
--
-- @since 1.4.2
timeFieldTypeTime :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m TimeOfDay
timeFieldTypeTime :: forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m TimeOfDay
timeFieldTypeTime = forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Text -> Field m TimeOfDay
timeFieldOfType Text
"time"

-- | Creates an input with @type="text"@, parsing the time from an [H]H:MM[:SS] format, with an optional AM or PM (if not given, AM is assumed for compatibility with the 24 hour clock system).
--
-- This function exists for backwards compatibility with the old implementation of 'timeField', which used to use @type="text"@. Consider using 'timeField' or 'timeFieldTypeTime' for improved UX and validation from the browser.
--
-- Add the @time@ package and import the "Data.Time.LocalTime" module to use this function.
--
-- @since 1.4.2
timeFieldTypeText :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m TimeOfDay
timeFieldTypeText :: forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m TimeOfDay
timeFieldTypeText = forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Text -> Field m TimeOfDay
timeFieldOfType Text
"text"

timeFieldOfType :: Monad m => RenderMessage (HandlerSite m) FormMessage => Text -> Field m TimeOfDay
timeFieldOfType :: forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Text -> Field m TimeOfDay
timeFieldOfType Text
inputType = Field
    { fieldParse :: [Text]
-> [FileInfo]
-> m (Either (SomeMessage (HandlerSite m)) (Maybe TimeOfDay))
fieldParse = forall (m :: * -> *) site a.
(Monad m, RenderMessage site FormMessage) =>
(Text -> Either FormMessage a)
-> [Text] -> [FileInfo] -> m (Either (SomeMessage site) (Maybe a))
parseHelper Text -> Either FormMessage TimeOfDay
parseTime
    , fieldView :: FieldViewFunc m TimeOfDay
fieldView = \Text
theId Text
name [(Text, Text)]
attrs Either Text TimeOfDay
val Bool
isReq -> forall site a (m :: * -> *).
(ToWidget site a, MonadWidget m, HandlerSite m ~ site) =>
a -> m ()
toWidget [hamlet|
$newline never
<input id="#{theId}" name="#{name}" *{attrs} type="#{inputType}" :isReq:required="" value="#{showVal val}">
|]
    , fieldEnctype :: Enctype
fieldEnctype = Enctype
UrlEncoded
    }
  where
    showVal :: Either Text TimeOfDay -> Text
showVal = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. a -> a
id (String -> Text
pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimeOfDay -> TimeOfDay
roundFullSeconds)
    roundFullSeconds :: TimeOfDay -> TimeOfDay
roundFullSeconds TimeOfDay
tod =
        Int -> Int -> Pico -> TimeOfDay
TimeOfDay (TimeOfDay -> Int
todHour TimeOfDay
tod) (TimeOfDay -> Int
todMin TimeOfDay
tod) Pico
fullSec
      where
        fullSec :: Pico
fullSec = forall a. Num a => Integer -> a
fromInteger forall a b. (a -> b) -> a -> b
$ forall a b. (RealFrac a, Integral b) => a -> b
floor forall a b. (a -> b) -> a -> b
$ TimeOfDay -> Pico
todSec TimeOfDay
tod

-- | Creates a @\<textarea>@ tag whose input is sanitized to prevent XSS attacks and is validated for having balanced tags.
htmlField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Html
htmlField :: forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m (MarkupM ())
htmlField = Field
    { fieldParse :: [Text]
-> [FileInfo]
-> m (Either (SomeMessage (HandlerSite m)) (Maybe (MarkupM ())))
fieldParse = forall (m :: * -> *) site a.
(Monad m, RenderMessage site FormMessage) =>
(Text -> Either FormMessage a)
-> [Text] -> [FileInfo] -> m (Either (SomeMessage site) (Maybe a))
parseHelper forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. preEscapedText . sanitizeBalance
    , fieldView :: FieldViewFunc m (MarkupM ())
fieldView = \Text
theId Text
name [(Text, Text)]
attrs Either Text (MarkupM ())
val Bool
isReq -> forall site a (m :: * -> *).
(ToWidget site a, MonadWidget m, HandlerSite m ~ site) =>
a -> m ()
toWidget [hamlet|
$newline never
<textarea :isReq:required="" id="#{theId}" name="#{name}" *{attrs}>#{showVal val}
|]
    , fieldEnctype :: Enctype
fieldEnctype = Enctype
UrlEncoded
    }
  where showVal :: Either Text (MarkupM ()) -> Text
showVal = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. a -> a
id (String -> Text
pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. MarkupM () -> String
renderHtml)

-- | A newtype wrapper around a 'Text' whose 'ToMarkup' instance converts newlines to HTML @\<br>@ tags.
--
-- (When text is entered into a @\<textarea>@, newline characters are used to separate lines.
-- If this text is then placed verbatim into HTML, the lines won't be separated, thus the need for replacing with @\<br>@ tags).
-- If you don't need this functionality, simply use 'unTextarea' to access the raw text.
newtype Textarea = Textarea { Textarea -> Text
unTextarea :: Text }
    deriving (Int -> Textarea -> ShowS
[Textarea] -> ShowS
Textarea -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Textarea] -> ShowS
$cshowList :: [Textarea] -> ShowS
show :: Textarea -> String
$cshow :: Textarea -> String
showsPrec :: Int -> Textarea -> ShowS
$cshowsPrec :: Int -> Textarea -> ShowS
Show, ReadPrec [Textarea]
ReadPrec Textarea
Int -> ReadS Textarea
ReadS [Textarea]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Textarea]
$creadListPrec :: ReadPrec [Textarea]
readPrec :: ReadPrec Textarea
$creadPrec :: ReadPrec Textarea
readList :: ReadS [Textarea]
$creadList :: ReadS [Textarea]
readsPrec :: Int -> ReadS Textarea
$creadsPrec :: Int -> ReadS Textarea
Read, Textarea -> Textarea -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Textarea -> Textarea -> Bool
$c/= :: Textarea -> Textarea -> Bool
== :: Textarea -> Textarea -> Bool
$c== :: Textarea -> Textarea -> Bool
Eq, PersistValue -> Either Text Textarea
Textarea -> PersistValue
forall a.
(a -> PersistValue)
-> (PersistValue -> Either Text a) -> PersistField a
fromPersistValue :: PersistValue -> Either Text Textarea
$cfromPersistValue :: PersistValue -> Either Text Textarea
toPersistValue :: Textarea -> PersistValue
$ctoPersistValue :: Textarea -> PersistValue
PersistField, Eq Textarea
Textarea -> Textarea -> Bool
Textarea -> Textarea -> Ordering
Textarea -> Textarea -> Textarea
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Textarea -> Textarea -> Textarea
$cmin :: Textarea -> Textarea -> Textarea
max :: Textarea -> Textarea -> Textarea
$cmax :: Textarea -> Textarea -> Textarea
>= :: Textarea -> Textarea -> Bool
$c>= :: Textarea -> Textarea -> Bool
> :: Textarea -> Textarea -> Bool
$c> :: Textarea -> Textarea -> Bool
<= :: Textarea -> Textarea -> Bool
$c<= :: Textarea -> Textarea -> Bool
< :: Textarea -> Textarea -> Bool
$c< :: Textarea -> Textarea -> Bool
compare :: Textarea -> Textarea -> Ordering
$ccompare :: Textarea -> Textarea -> Ordering
Ord, [Textarea] -> Encoding
[Textarea] -> Value
Textarea -> Encoding
Textarea -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [Textarea] -> Encoding
$ctoEncodingList :: [Textarea] -> Encoding
toJSONList :: [Textarea] -> Value
$ctoJSONList :: [Textarea] -> Value
toEncoding :: Textarea -> Encoding
$ctoEncoding :: Textarea -> Encoding
toJSON :: Textarea -> Value
$ctoJSON :: Textarea -> Value
ToJSON, Value -> Parser [Textarea]
Value -> Parser Textarea
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [Textarea]
$cparseJSONList :: Value -> Parser [Textarea]
parseJSON :: Value -> Parser Textarea
$cparseJSON :: Value -> Parser Textarea
FromJSON, String -> Textarea
forall a. (String -> a) -> IsString a
fromString :: String -> Textarea
$cfromString :: String -> Textarea
IsString)
instance PersistFieldSql Textarea where
    sqlType :: Proxy Textarea -> SqlType
sqlType Proxy Textarea
_ = SqlType
SqlString
instance ToHtml Textarea where
    toHtml =
        unsafeByteString
        . S.concat
        . L.toChunks
        . toLazyByteString
        . fromWriteList writeHtmlEscapedChar
        . unpack
        . unTextarea
      where
        -- Taken from blaze-builder and modified with newline handling.
        writeHtmlEscapedChar '\r' = mempty
        writeHtmlEscapedChar '\n' = writeByteString "<br>"
        writeHtmlEscapedChar c    = B.writeHtmlEscapedChar c

-- | Creates a @\<textarea>@ tag whose returned value is wrapped in a 'Textarea'; see 'Textarea' for details.
textareaField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Textarea
textareaField :: forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m Textarea
textareaField = Field
    { fieldParse :: [Text]
-> [FileInfo]
-> m (Either (SomeMessage (HandlerSite m)) (Maybe Textarea))
fieldParse = forall (m :: * -> *) site a.
(Monad m, RenderMessage site FormMessage) =>
(Text -> Either FormMessage a)
-> [Text] -> [FileInfo] -> m (Either (SomeMessage site) (Maybe a))
parseHelper forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Textarea
Textarea
    , fieldView :: FieldViewFunc m Textarea
fieldView = \Text
theId Text
name [(Text, Text)]
attrs Either Text Textarea
val Bool
isReq -> forall site a (m :: * -> *).
(ToWidget site a, MonadWidget m, HandlerSite m ~ site) =>
a -> m ()
toWidget [hamlet|
$newline never
<textarea id="#{theId}" name="#{name}" :isReq:required="" *{attrs}>#{either id unTextarea val}
|]
    , fieldEnctype :: Enctype
fieldEnctype = Enctype
UrlEncoded
    }

-- | Creates an input with @type="hidden"@; you can use this to store information in a form that users shouldn't see (for example, Yesod stores CSRF tokens in a hidden field).
hiddenField :: (Monad m, PathPiece p, RenderMessage (HandlerSite m) FormMessage)
            => Field m p
hiddenField :: forall (m :: * -> *) p.
(Monad m, PathPiece p,
 RenderMessage (HandlerSite m) FormMessage) =>
Field m p
hiddenField = Field
    { fieldParse :: [Text]
-> [FileInfo] -> m (Either (SomeMessage (HandlerSite m)) (Maybe p))
fieldParse = forall (m :: * -> *) site a.
(Monad m, RenderMessage site FormMessage) =>
(Text -> Either FormMessage a)
-> [Text] -> [FileInfo] -> m (Either (SomeMessage site) (Maybe a))
parseHelper forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left FormMessage
MsgValueRequired) forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s. PathPiece s => Text -> Maybe s
fromPathPiece
    , fieldView :: FieldViewFunc m p
fieldView = \Text
theId Text
name [(Text, Text)]
attrs Either Text p
val Bool
_isReq -> forall site a (m :: * -> *).
(ToWidget site a, MonadWidget m, HandlerSite m ~ site) =>
a -> m ()
toWidget [hamlet|
$newline never
<input type="hidden" id="#{theId}" name="#{name}" *{attrs} value="#{either id toPathPiece val}">
|]
    , fieldEnctype :: Enctype
fieldEnctype = Enctype
UrlEncoded
    }

-- | Creates a input with @type="text"@.
textField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Text
textField :: forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m Text
textField = Field
    { fieldParse :: [Text]
-> [FileInfo]
-> m (Either (SomeMessage (HandlerSite m)) (Maybe Text))
fieldParse = forall (m :: * -> *) site a.
(Monad m, RenderMessage site FormMessage) =>
(Text -> Either FormMessage a)
-> [Text] -> [FileInfo] -> m (Either (SomeMessage site) (Maybe a))
parseHelper forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right
    , fieldView :: FieldViewFunc m Text
fieldView = \Text
theId Text
name [(Text, Text)]
attrs Either Text Text
val Bool
isReq ->
        [whamlet|
$newline never
<input id="#{theId}" name="#{name}" *{attrs} type="text" :isReq:required value="#{either id id val}">
|]
    , fieldEnctype :: Enctype
fieldEnctype = Enctype
UrlEncoded
    }
-- | Creates an input with @type="password"@.
passwordField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Text
passwordField :: forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m Text
passwordField = Field
    { fieldParse :: [Text]
-> [FileInfo]
-> m (Either (SomeMessage (HandlerSite m)) (Maybe Text))
fieldParse = forall (m :: * -> *) site a.
(Monad m, RenderMessage site FormMessage) =>
(Text -> Either FormMessage a)
-> [Text] -> [FileInfo] -> m (Either (SomeMessage site) (Maybe a))
parseHelper forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right
    , fieldView :: FieldViewFunc m Text
fieldView = \Text
theId Text
name [(Text, Text)]
attrs Either Text Text
_ Bool
isReq -> forall site a (m :: * -> *).
(ToWidget site a, MonadWidget m, HandlerSite m ~ site) =>
a -> m ()
toWidget [hamlet|
$newline never
<input id="#{theId}" name="#{name}" *{attrs} type="password" :isReq:required="">
|]
    , fieldEnctype :: Enctype
fieldEnctype = Enctype
UrlEncoded
    }

readMay :: Read a => String -> Maybe a
readMay :: forall a. Read a => String -> Maybe a
readMay String
s = case forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. Foldable t => t a -> Bool
Prelude.null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall a b. (a -> b) -> a -> b
$ forall a. Read a => ReadS a
reads String
s of
                (a
x, String
_):[(a, String)]
_ -> forall a. a -> Maybe a
Just a
x
                [] -> forall a. Maybe a
Nothing

-- | Parses a 'Day' from a 'String'.
parseDate :: String -> Either FormMessage Day
parseDate :: String -> Either FormMessage Day
parseDate = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left FormMessage
MsgInvalidDay) forall a b. b -> Either a b
Right
              forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Read a => String -> Maybe a
readMay forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => a -> a -> [a] -> [a]
replace Char
'/' Char
'-'

-- | Replaces all instances of a value in a list by another value.
-- from http://hackage.haskell.org/packages/archive/cgi/3001.1.7.1/doc/html/src/Network-CGI-Protocol.html#replace
replace :: Eq a => a -> a -> [a] -> [a]
replace :: forall a. Eq a => a -> a -> [a] -> [a]
replace a
x a
y = forall a b. (a -> b) -> [a] -> [b]
map (\a
z -> if a
z forall a. Eq a => a -> a -> Bool
== a
x then a
y else a
z)

parseTime :: Text -> Either FormMessage TimeOfDay
parseTime :: Text -> Either FormMessage TimeOfDay
parseTime = 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 a. a -> Maybe a -> a
fromMaybe FormMessage
MsgInvalidTimeFormat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Read a => String -> Maybe a
readMay forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
drop Int
2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Eq a => a -> a -> Bool
/= Char
':')) forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Parser a -> Text -> Either String a
parseOnly Parser TimeOfDay
timeParser

timeParser :: Parser TimeOfDay
timeParser :: Parser TimeOfDay
timeParser = do
    Parser ()
skipSpace
    Int
h <- Parser Text Int
hour
    Char
_ <- Char -> Parser Char
char Char
':'
    Int
m <- forall a. Num a => (Text -> FormMessage) -> Parser a
minsec Text -> FormMessage
MsgInvalidMinute
    Bool
hasSec <- (Char -> Parser Char
char Char
':' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    Pico
s <- if Bool
hasSec then forall a. Num a => (Text -> FormMessage) -> Parser a
minsec Text -> FormMessage
MsgInvalidSecond else forall (m :: * -> *) a. Monad m => a -> m a
return Pico
0
    Parser ()
skipSpace
    Maybe Bool
isPM <-
        (Text -> Parser Text
string Text
"am" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just Bool
False)) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
        (Text -> Parser Text
string Text
"AM" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just Bool
False)) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
        (Text -> Parser Text
string Text
"pm" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just Bool
True)) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
        (Text -> Parser Text
string Text
"PM" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just Bool
True)) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    Int
h' <-
        case Maybe Bool
isPM of
            Maybe Bool
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return Int
h
            Just Bool
x
                | Int
h forall a. Ord a => a -> a -> Bool
<= Int
0 Bool -> Bool -> Bool
|| Int
h forall a. Ord a => a -> a -> Bool
> Int
12 -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Text -> FormMessage
MsgInvalidHour forall a b. (a -> b) -> a -> b
$ String -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Int
h
                | Int
h forall a. Eq a => a -> a -> Bool
== Int
12 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if Bool
x then Int
12 else Int
0
                | Bool
otherwise -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int
h forall a. Num a => a -> a -> a
+ (if Bool
x then Int
12 else Int
0)
    Parser ()
skipSpace
    forall t. Chunk t => Parser t ()
endOfInput
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int -> Int -> Pico -> TimeOfDay
TimeOfDay Int
h' Int
m Pico
s
  where
    hour :: Parser Text Int
hour = do
        Char
x <- Parser Char
digit
        String
y <- (forall (m :: * -> *) a. Monad m => a -> m a
return forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
Control.Applicative.<$> Parser Char
digit) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. Monad m => a -> m a
return []
        let xy :: String
xy = Char
x forall a. a -> [a] -> [a]
: String
y
        let i :: Int
i = forall a. Read a => String -> a
read String
xy
        if Int
i forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| Int
i forall a. Ord a => a -> a -> Bool
>= Int
24
            then forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Text -> FormMessage
MsgInvalidHour forall a b. (a -> b) -> a -> b
$ String -> Text
pack String
xy
            else forall (m :: * -> *) a. Monad m => a -> m a
return Int
i
    minsec :: Num a => (Text -> FormMessage) -> Parser a
    minsec :: forall a. Num a => (Text -> FormMessage) -> Parser a
minsec Text -> FormMessage
msg = do
        Char
x <- Parser Char
digit
        Char
y <- Parser Char
digit forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. MonadFail m => String -> m a
fail (forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Text -> FormMessage
msg forall a b. (a -> b) -> a -> b
$ String -> Text
pack [Char
x])
        let xy :: String
xy = [Char
x, Char
y]
        let i :: Int
i = forall a. Read a => String -> a
read String
xy
        if Int
i forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| Int
i forall a. Ord a => a -> a -> Bool
>= Int
60
            then forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Text -> FormMessage
msg forall a b. (a -> b) -> a -> b
$ String -> Text
pack String
xy
            else forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
i :: Int)

-- | Creates an input with @type="email"@. Yesod will validate the email's correctness according to RFC5322 and canonicalize it by removing comments and whitespace (see "Text.Email.Validate").
emailField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Text
emailField :: forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m Text
emailField = Field
    { fieldParse :: [Text]
-> [FileInfo]
-> m (Either (SomeMessage (HandlerSite m)) (Maybe Text))
fieldParse = forall (m :: * -> *) site a.
(Monad m, RenderMessage site FormMessage) =>
(Text -> Either FormMessage a)
-> [Text] -> [FileInfo] -> m (Either (SomeMessage site) (Maybe a))
parseHelper forall a b. (a -> b) -> a -> b
$
        \Text
s ->
            case ByteString -> Maybe ByteString
Email.canonicalizeEmail forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 Text
s of
                Just ByteString
e -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode ByteString
e
                Maybe ByteString
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text -> FormMessage
MsgInvalidEmail Text
s
    , fieldView :: FieldViewFunc m Text
fieldView = \Text
theId Text
name [(Text, Text)]
attrs Either Text Text
val Bool
isReq -> forall site a (m :: * -> *).
(ToWidget site a, MonadWidget m, HandlerSite m ~ site) =>
a -> m ()
toWidget [hamlet|
$newline never
<input id="#{theId}" name="#{name}" *{attrs} type="email" :isReq:required="" value="#{either id id val}">
|]
    , fieldEnctype :: Enctype
fieldEnctype = Enctype
UrlEncoded
    }

-- | Creates an input with @type="email"@ with the <http://w3c.github.io/html/sec-forms.html#the-multiple-attribute multiple> attribute; browsers might implement this as taking a comma separated list of emails. Each email address is validated as described in 'emailField'.
--
-- @since 1.3.7
multiEmailField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m [Text]
multiEmailField :: forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m [Text]
multiEmailField = Field
    { fieldParse :: [Text]
-> [FileInfo]
-> m (Either (SomeMessage (HandlerSite m)) (Maybe [Text]))
fieldParse = forall (m :: * -> *) site a.
(Monad m, RenderMessage site FormMessage) =>
(Text -> Either FormMessage a)
-> [Text] -> [FileInfo] -> m (Either (SomeMessage site) (Maybe a))
parseHelper forall a b. (a -> b) -> a -> b
$
        \Text
s ->
            let addrs :: [Either Text Text]
addrs = forall a b. (a -> b) -> [a] -> [b]
map Text -> Either Text Text
validate forall a b. (a -> b) -> a -> b
$ Text -> Text -> [Text]
splitOn Text
"," Text
s
            in case forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either Text Text]
addrs of
                ([], [Text]
good) -> forall a b. b -> Either a b
Right [Text]
good
                ([Text]
bad, [Text]
_) -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text -> FormMessage
MsgInvalidEmail forall a b. (a -> b) -> a -> b
$ [Text] -> Text
cat [Text]
bad
    , fieldView :: FieldViewFunc m [Text]
fieldView = \Text
theId Text
name [(Text, Text)]
attrs Either Text [Text]
val Bool
isReq -> forall site a (m :: * -> *).
(ToWidget site a, MonadWidget m, HandlerSite m ~ site) =>
a -> m ()
toWidget [hamlet|
$newline never
<input id="#{theId}" name="#{name}" *{attrs} type="email" multiple :isReq:required="" value="#{either id cat val}">
|]
    , fieldEnctype :: Enctype
fieldEnctype = Enctype
UrlEncoded
    }
    where
        -- report offending address along with error
        validate :: Text -> Either Text Text
validate Text
a = case ByteString -> Either String EmailAddress
Email.validate forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 Text
a of
                        Left String
e -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat [Text
a, Text
" (",  String -> Text
pack String
e, Text
")"]
                        Right EmailAddress
r -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ EmailAddress -> Text
emailToText EmailAddress
r
        cat :: [Text] -> Text
cat = Text -> [Text] -> Text
intercalate Text
", "
        emailToText :: EmailAddress -> Text
emailToText = OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode forall b c a. (b -> c) -> (a -> b) -> a -> c
. EmailAddress -> ByteString
Email.toByteString

type AutoFocus = Bool
-- | Creates an input with @type="search"@. For <http://caniuse.com/#search=autofocus browsers without autofocus support>, a JS fallback is used if @AutoFocus@ is true.
searchField :: Monad m => RenderMessage (HandlerSite m) FormMessage => AutoFocus -> Field m Text
searchField :: forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Bool -> Field m Text
searchField Bool
autoFocus = Field
    { fieldParse :: [Text]
-> [FileInfo]
-> m (Either (SomeMessage (HandlerSite m)) (Maybe Text))
fieldParse = forall (m :: * -> *) site a.
(Monad m, RenderMessage site FormMessage) =>
(Text -> Either FormMessage a)
-> [Text] -> [FileInfo] -> m (Either (SomeMessage site) (Maybe a))
parseHelper forall a b. b -> Either a b
Right
    , fieldView :: FieldViewFunc m Text
fieldView = \Text
theId Text
name [(Text, Text)]
attrs Either Text Text
val Bool
isReq -> do
        [whamlet|
$newline never
<input id="#{theId}" name="#{name}" *{attrs} type="search" :isReq:required="" :autoFocus:autofocus="" value="#{either id id val}">
|]
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
autoFocus forall a b. (a -> b) -> a -> b
$ do
          -- we want this javascript to be placed immediately after the field
          [whamlet|
$newline never
<script>if (!('autofocus' in document.createElement('input'))) {document.getElementById('#{theId}').focus();}
|]
          forall site a (m :: * -> *).
(ToWidget site a, MonadWidget m, HandlerSite m ~ site) =>
a -> m ()
toWidget [cassius|
            ##{theId}
              -webkit-appearance: textfield
            |]
    , fieldEnctype :: Enctype
fieldEnctype = Enctype
UrlEncoded
    }
-- | Creates an input with @type="url"@, validating the URL according to RFC3986.
urlField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Text
urlField :: forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m Text
urlField = Field
    { fieldParse :: [Text]
-> [FileInfo]
-> m (Either (SomeMessage (HandlerSite m)) (Maybe Text))
fieldParse = forall (m :: * -> *) site a.
(Monad m, RenderMessage site FormMessage) =>
(Text -> Either FormMessage a)
-> [Text] -> [FileInfo] -> m (Either (SomeMessage site) (Maybe a))
parseHelper forall a b. (a -> b) -> a -> b
$ \Text
s ->
        case String -> Maybe URI
parseURI forall a b. (a -> b) -> a -> b
$ Text -> String
unpack Text
s of
            Maybe URI
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text -> FormMessage
MsgInvalidUrl Text
s
            Just URI
_ -> forall a b. b -> Either a b
Right Text
s
    , fieldView :: FieldViewFunc m Text
fieldView = \Text
theId Text
name [(Text, Text)]
attrs Either Text Text
val Bool
isReq ->
        [whamlet|<input ##{theId} name=#{name} *{attrs} type=url :isReq:required value=#{either id id val}>|]
    , fieldEnctype :: Enctype
fieldEnctype = Enctype
UrlEncoded
    }

-- | Creates a @\<select>@ tag for selecting one option. Example usage:
--
-- > areq (selectFieldList [("Value 1" :: Text, "value1"),("Value 2", "value2")]) "Which value?" Nothing
selectFieldList :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg)
                => [(msg, a)]
                -> Field (HandlerFor site) a
selectFieldList :: forall a site msg.
(Eq a, RenderMessage site FormMessage, RenderMessage site msg) =>
[(msg, a)] -> Field (HandlerFor site) a
selectFieldList = forall a site.
(Eq a, RenderMessage site FormMessage) =>
HandlerFor site (OptionList a) -> Field (HandlerFor site) a
selectField forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) msg a.
(MonadHandler m, RenderMessage (HandlerSite m) msg) =>
[(msg, a)] -> m (OptionList a)
optionsPairs

-- | Creates a @\<select>@ tag with @\<optgroup>@s for selecting one option.
--
-- @since 1.7.0
selectFieldListGrouped :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg)
                => [(msg, [(msg, a)])]
                -> Field (HandlerFor site) a
selectFieldListGrouped :: forall a site msg.
(Eq a, RenderMessage site FormMessage, RenderMessage site msg) =>
[(msg, [(msg, a)])] -> Field (HandlerFor site) a
selectFieldListGrouped = forall a site.
(Eq a, RenderMessage site FormMessage) =>
HandlerFor site (OptionList a) -> Field (HandlerFor site) a
selectField forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) msg a.
(MonadHandler m, RenderMessage (HandlerSite m) msg) =>
[(msg, [(msg, a)])] -> m (OptionList a)
optionsPairsGrouped

-- | Creates a @\<select>@ tag with optional @\<optgroup>@s for selecting one option. Example usage:
--
-- > areq (selectField $ optionsPairs [(MsgValue1, "value1"),(MsgValue2, "value2")]) "Which value?" Nothing
selectField :: (Eq a, RenderMessage site FormMessage)
            => HandlerFor site (OptionList a)
            -> Field (HandlerFor site) a
selectField :: forall a site.
(Eq a, RenderMessage site FormMessage) =>
HandlerFor site (OptionList a) -> Field (HandlerFor site) a
selectField = forall a site.
(Eq a, RenderMessage site FormMessage) =>
(Text
 -> Text
 -> [(Text, Text)]
 -> WidgetFor site ()
 -> WidgetFor site ())
-> (Text -> Text -> Bool -> WidgetFor site ())
-> (Text
    -> Text
    -> [(Text, Text)]
    -> Text
    -> Bool
    -> Text
    -> WidgetFor site ())
-> Maybe (Text -> WidgetFor site ())
-> HandlerFor site (OptionList a)
-> Field (HandlerFor site) a
selectFieldHelper
    (\Text
theId Text
name [(Text, Text)]
attrs WidgetFor site ()
inside -> [whamlet|
$newline never
<select ##{theId} name=#{name} *{attrs}>^{inside}
|]) -- outside
    (\Text
_theId Text
_name Bool
isSel -> [whamlet|
$newline never
<option value=none :isSel:selected>_{MsgSelectNone}
|]) -- onOpt
    (\Text
_theId Text
_name [(Text, Text)]
_attrs Text
value Bool
isSel Text
text -> [whamlet|
$newline never
<option value=#{value} :isSel:selected>#{text}
|]) -- inside
    (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ \Text
label -> [whamlet|
<optgroup label=#{label}>
|]) -- group label

-- | Creates a @\<select>@ tag for selecting multiple options.
multiSelectFieldList :: (Eq a, RenderMessage site msg)
                     => [(msg, a)]
                     -> Field (HandlerFor site) [a]
multiSelectFieldList :: forall a site msg.
(Eq a, RenderMessage site msg) =>
[(msg, a)] -> Field (HandlerFor site) [a]
multiSelectFieldList = forall a site.
Eq a =>
HandlerFor site (OptionList a) -> Field (HandlerFor site) [a]
multiSelectField forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) msg a.
(MonadHandler m, RenderMessage (HandlerSite m) msg) =>
[(msg, a)] -> m (OptionList a)
optionsPairs

-- | Creates a @\<select>@ tag for selecting multiple options.
multiSelectField :: Eq a
                 => HandlerFor site (OptionList a)
                 -> Field (HandlerFor site) [a]
multiSelectField :: forall a site.
Eq a =>
HandlerFor site (OptionList a) -> Field (HandlerFor site) [a]
multiSelectField HandlerFor site (OptionList a)
ioptlist =
    forall (m :: * -> *) a.
([Text]
 -> [FileInfo]
 -> m (Either (SomeMessage (HandlerSite m)) (Maybe a)))
-> FieldViewFunc m a -> Enctype -> Field m a
Field [Text]
-> [FileInfo]
-> HandlerFor site (Either (SomeMessage site) (Maybe [a]))
parse Text
-> Text
-> [(Text, Text)]
-> Either Text [a]
-> Bool
-> WidgetFor site ()
view Enctype
UrlEncoded
  where
    parse :: [Text]
-> [FileInfo]
-> HandlerFor site (Either (SomeMessage site) (Maybe [a]))
parse [] [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
    parse [Text]
optlist [FileInfo]
_ = do
        Text -> Maybe a
mapopt <- forall a. OptionList a -> Text -> Maybe a
olReadExternal forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HandlerFor site (OptionList a)
ioptlist
        case forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Text -> Maybe a
mapopt [Text]
optlist of
             Maybe [a]
Nothing -> 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 site
"Error parsing values"
             Just [a]
res -> 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 b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just [a]
res

    view :: Text
-> Text
-> [(Text, Text)]
-> Either Text [a]
-> Bool
-> WidgetFor site ()
view Text
theId Text
name [(Text, Text)]
attrs Either Text [a]
val Bool
isReq = do
        [Option a]
opts <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. OptionList a -> [Option a]
olOptions forall a b. (a -> b) -> a -> b
$ forall site a. HandlerFor site a -> WidgetFor site a
handlerToWidget HandlerFor site (OptionList a)
ioptlist
        let selOpts :: [(Option a, Bool)]
selOpts = forall a b. (a -> b) -> [a] -> [b]
map (forall a. a -> a
id forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (forall {t :: * -> *} {a} {a}.
(Foldable t, Eq a) =>
Either a (t a) -> Option a -> Bool
optselected Either Text [a]
val)) [Option a]
opts
        [whamlet|
            <select ##{theId} name=#{name} :isReq:required multiple *{attrs}>
                $forall (opt, optsel) <- selOpts
                    <option value=#{optionExternalValue opt} :optsel:selected>#{optionDisplay opt}
                |]
        where
            optselected :: Either a (t a) -> Option a -> Bool
optselected (Left a
_) Option a
_ = Bool
False
            optselected (Right t a
vals) Option a
opt = (forall a. Option a -> a
optionInternalValue Option a
opt) forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t a
vals

-- | Creates an input with @type="radio"@ for selecting one option.
radioFieldList :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg)
               => [(msg, a)]
               -> Field (HandlerFor site) a
radioFieldList :: forall a site msg.
(Eq a, RenderMessage site FormMessage, RenderMessage site msg) =>
[(msg, a)] -> Field (HandlerFor site) a
radioFieldList = forall a site.
(Eq a, RenderMessage site FormMessage) =>
HandlerFor site (OptionList a) -> Field (HandlerFor site) a
radioField forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) msg a.
(MonadHandler m, RenderMessage (HandlerSite m) msg) =>
[(msg, a)] -> m (OptionList a)
optionsPairs

-- | Creates an input with @type="checkbox"@ for selecting multiple options.
checkboxesFieldList :: (Eq a, RenderMessage site msg) => [(msg, a)]
                     -> Field (HandlerFor site) [a]
checkboxesFieldList :: forall a site msg.
(Eq a, RenderMessage site msg) =>
[(msg, a)] -> Field (HandlerFor site) [a]
checkboxesFieldList = forall a site.
Eq a =>
HandlerFor site (OptionList a) -> Field (HandlerFor site) [a]
checkboxesField forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) msg a.
(MonadHandler m, RenderMessage (HandlerSite m) msg) =>
[(msg, a)] -> m (OptionList a)
optionsPairs

-- | Creates an input with @type="checkbox"@ for selecting multiple options.
checkboxesField :: Eq a
                 => HandlerFor site (OptionList a)
                 -> Field (HandlerFor site) [a]
checkboxesField :: forall a site.
Eq a =>
HandlerFor site (OptionList a) -> Field (HandlerFor site) [a]
checkboxesField HandlerFor site (OptionList a)
ioptlist = (forall a site.
Eq a =>
HandlerFor site (OptionList a) -> Field (HandlerFor site) [a]
multiSelectField HandlerFor site (OptionList a)
ioptlist)
    { fieldView :: FieldViewFunc (HandlerFor site) [a]
fieldView =
        \Text
theId Text
name [(Text, Text)]
attrs Either Text [a]
val Bool
_isReq -> do
            [Option a]
opts <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. OptionList a -> [Option a]
olOptions forall a b. (a -> b) -> a -> b
$ forall site a. HandlerFor site a -> WidgetFor site a
handlerToWidget HandlerFor site (OptionList a)
ioptlist
            let optselected :: Either a (t a) -> Option a -> Bool
optselected (Left a
_) Option a
_ = Bool
False
                optselected (Right t a
vals) Option a
opt = (forall a. Option a -> a
optionInternalValue Option a
opt) forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t a
vals
            [whamlet|
                <span ##{theId}>
                    $forall opt <- opts
                        <label>
                            <input type=checkbox name=#{name} value=#{optionExternalValue opt} *{attrs} :optselected val opt:checked>
                            #{optionDisplay opt}
                |]
    }
-- | Creates an input with @type="radio"@ for selecting one option.
radioField :: (Eq a, RenderMessage site FormMessage)
           => HandlerFor site (OptionList a)
           -> Field (HandlerFor site) a
radioField :: forall a site.
(Eq a, RenderMessage site FormMessage) =>
HandlerFor site (OptionList a) -> Field (HandlerFor site) a
radioField = forall a site.
(Eq a, RenderMessage site FormMessage) =>
(Text -> WidgetFor site () -> WidgetFor site ())
-> (Text
    -> Text -> Bool -> Text -> WidgetFor site () -> WidgetFor site ())
-> HandlerFor site (OptionList a)
-> Field (HandlerFor site) a
withRadioField
    (\Text
theId WidgetFor site ()
optionWidget -> [whamlet|
$newline never
<div .radio>
    <label for=#{theId}-none>
        <div>
            ^{optionWidget}
            _{MsgSelectNone}
|])
    (\Text
theId Text
value Bool
_isSel Text
text WidgetFor site ()
optionWidget -> [whamlet|
$newline never
<div .radio>
    <label for=#{theId}-#{value}>
        <div>
            ^{optionWidget}
            \#{text}
|])


-- | Allows the user to place the option radio widget somewhere in
--   the template.
--   For example: If you want a table of radio options to select.
--   'radioField' is an example on how to use this function.
--
--   @since 1.7.2
withRadioField :: (Eq a, RenderMessage site FormMessage)
           => (Text -> WidgetFor site ()-> WidgetFor site ()) -- ^ nothing case for mopt
           -> (Text ->  Text -> Bool -> Text -> WidgetFor site () -> WidgetFor site ()) -- ^ cases for values
           -> HandlerFor site (OptionList a)
           -> Field (HandlerFor site) a
withRadioField :: forall a site.
(Eq a, RenderMessage site FormMessage) =>
(Text -> WidgetFor site () -> WidgetFor site ())
-> (Text
    -> Text -> Bool -> Text -> WidgetFor site () -> WidgetFor site ())
-> HandlerFor site (OptionList a)
-> Field (HandlerFor site) a
withRadioField Text -> WidgetFor site () -> WidgetFor site ()
nothingFun Text
-> Text -> Bool -> Text -> WidgetFor site () -> WidgetFor site ()
optFun =
  forall a site.
(Eq a, RenderMessage site FormMessage) =>
(Text
 -> Text
 -> [(Text, Text)]
 -> WidgetFor site ()
 -> WidgetFor site ())
-> (Text -> Text -> Bool -> WidgetFor site ())
-> (Text
    -> Text
    -> [(Text, Text)]
    -> Text
    -> Bool
    -> Text
    -> WidgetFor site ())
-> Maybe (Text -> WidgetFor site ())
-> HandlerFor site (OptionList a)
-> Field (HandlerFor site) a
selectFieldHelper forall {a} {site} {a} {p} {p}.
(ToMarkup a, ToWidget site a) =>
a -> p -> p -> a -> WidgetFor site ()
outside Text -> Text -> Bool -> WidgetFor site ()
onOpt Text
-> Text
-> [(Text, Text)]
-> Text
-> Bool
-> Text
-> WidgetFor site ()
inside forall a. Maybe a
Nothing
  where
    outside :: a -> p -> p -> a -> WidgetFor site ()
outside a
theId p
_name p
_attrs a
inside' = [whamlet|
$newline never
<div ##{theId}>^{inside'}
|]
    onOpt :: Text -> Text -> Bool -> WidgetFor site ()
onOpt Text
theId Text
name Bool
isSel = Text -> WidgetFor site () -> WidgetFor site ()
nothingFun Text
theId forall a b. (a -> b) -> a -> b
$ [whamlet|
$newline never
<input id=#{theId}-none type=radio name=#{name} value=none :isSel:checked>
|]
    inside :: Text
-> Text
-> [(Text, Text)]
-> Text
-> Bool
-> Text
-> WidgetFor site ()
inside Text
theId Text
name [(Text, Text)]
attrs Text
value Bool
isSel Text
display =
       Text
-> Text -> Bool -> Text -> WidgetFor site () -> WidgetFor site ()
optFun Text
theId Text
value Bool
isSel Text
display [whamlet|
<input id=#{theId}-#{(value)} type=radio name=#{name} value=#{(value)} :isSel:checked *{attrs}>
|]


-- | Creates a group of radio buttons to answer the question given in the message. Radio buttons are used to allow differentiating between an empty response (@Nothing@) and a no response (@Just False@). Consider using the simpler 'checkBoxField' if you don't need to make this distinction.
--
-- If this field is optional, the first radio button is labeled "\<None>", the second \"Yes" and the third \"No".
--
-- If this field is required, the first radio button is labeled \"Yes" and the second \"No".
--
-- (Exact label titles will depend on localization).
boolField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Bool
boolField :: forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m Bool
boolField = Field
      { fieldParse :: [Text]
-> [FileInfo]
-> m (Either (SomeMessage (HandlerSite m)) (Maybe Bool))
fieldParse = \[Text]
e [FileInfo]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall {master}.
RenderMessage master FormMessage =>
[Text] -> Either (SomeMessage master) (Maybe Bool)
boolParser [Text]
e
      , fieldView :: FieldViewFunc m Bool
fieldView = \Text
theId Text
name [(Text, Text)]
attrs Either Text Bool
val Bool
isReq -> [whamlet|
$newline never
  $if not isReq
      <input id=#{theId}-none *{attrs} type=radio name=#{name} value=none checked>
      <label for=#{theId}-none>_{MsgSelectNone}


<input id=#{theId}-yes *{attrs} type=radio name=#{name} value=yes :showVal id val:checked>
<label for=#{theId}-yes>_{MsgBoolYes}

<input id=#{theId}-no *{attrs} type=radio name=#{name} value=no :showVal not val:checked>
<label for=#{theId}-no>_{MsgBoolNo}
|]
    , fieldEnctype :: Enctype
fieldEnctype = Enctype
UrlEncoded
    }
  where
    boolParser :: [Text] -> Either (SomeMessage master) (Maybe Bool)
boolParser [] = forall a b. b -> Either a b
Right forall a. Maybe a
Nothing
    boolParser (Text
x:[Text]
_) = case Text
x of
      Text
"" -> forall a b. b -> Either a b
Right forall a. Maybe a
Nothing
      Text
"none" -> forall a b. b -> Either a b
Right forall a. Maybe a
Nothing
      Text
"yes" -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Bool
True
      Text
"on" -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Bool
True
      Text
"no" -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Bool
False
      Text
"true" -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Bool
True
      Text
"false" -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Bool
False
      Text
t -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall master msg.
RenderMessage master msg =>
msg -> SomeMessage master
SomeMessage forall a b. (a -> b) -> a -> b
$ Text -> FormMessage
MsgInvalidBool Text
t
    showVal :: (b -> Bool) -> Either a b -> Bool
showVal = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\a
_ -> Bool
False)

-- | Creates an input with @type="checkbox"@.
--   While the default @'boolField'@ implements a radio button so you
--   can differentiate between an empty response (@Nothing@) and a no
--   response (@Just False@), this simpler checkbox field returns an empty
--   response as @Just False@.
--
--   Note that this makes the field always optional.
--
checkBoxField :: Monad m => Field m Bool
checkBoxField :: forall (m :: * -> *). Monad m => Field m Bool
checkBoxField = Field
    { fieldParse :: [Text]
-> [FileInfo]
-> m (Either (SomeMessage (HandlerSite m)) (Maybe Bool))
fieldParse = \[Text]
e [FileInfo]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall {a} {a}. (Eq a, IsString a) => [a] -> Either a (Maybe Bool)
checkBoxParser [Text]
e
    , fieldView :: FieldViewFunc m Bool
fieldView  = \Text
theId Text
name [(Text, Text)]
attrs Either Text Bool
val Bool
_ -> [whamlet|
$newline never
<input id=#{theId} *{attrs} type=checkbox name=#{name} value=yes :showVal id val:checked>
|]
    , fieldEnctype :: Enctype
fieldEnctype = Enctype
UrlEncoded
    }

    where
        checkBoxParser :: [a] -> Either a (Maybe Bool)
checkBoxParser [] = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Bool
False
        checkBoxParser (a
x:[a]
_) = case a
x of
            a
"yes" -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Bool
True
            a
"on" -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Bool
True
            a
_     -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Bool
False

        showVal :: (b -> Bool) -> Either a b -> Bool
showVal = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\a
_ -> Bool
False)

-- | A structure holding a list of options. Typically you can use a convenience function like 'mkOptionList' or 'optionsPairs' instead of creating this directly.
--
-- Extended by 'OptionListGrouped' in 1.7.0.
data OptionList a
  = OptionList
    { forall a. OptionList a -> [Option a]
olOptions :: [Option a]
    , forall a. OptionList a -> Text -> Maybe a
olReadExternal :: Text -> Maybe a -- ^ A function mapping from the form's value ('optionExternalValue') to the selected Haskell value ('optionInternalValue').
    }
  | OptionListGrouped
    { forall a. OptionList a -> [(Text, [Option a])]
olOptionsGrouped :: [(Text, [Option a])]
    , forall a. OptionList a -> Text -> Maybe a
olReadExternalGrouped :: Text -> Maybe a -- ^ A function mapping from the form's value ('optionExternalValue') to the selected Haskell value ('optionInternalValue').
    }

-- | Convert grouped 'OptionList' to a normal one.
--
-- @since 1.7.0
flattenOptionList :: OptionList a -> OptionList a
flattenOptionList :: forall a. OptionList a -> OptionList a
flattenOptionList (OptionListGrouped [(Text, [Option a])]
os Text -> Maybe a
re) = forall a. [Option a] -> (Text -> Maybe a) -> OptionList a
OptionList (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a b. (a, b) -> b
snd [(Text, [Option a])]
os) Text -> Maybe a
re
flattenOptionList OptionList a
ol = OptionList a
ol

-- | @since 1.4.6
instance Functor OptionList where
    fmap :: forall a b. (a -> b) -> OptionList a -> OptionList b
fmap a -> b
f (OptionList [Option a]
options Text -> Maybe a
readExternal) =
      forall a. [Option a] -> (Text -> Maybe a) -> OptionList a
OptionList ((forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmapforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) a -> b
f [Option a]
options) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe a
readExternal)
    fmap a -> b
f (OptionListGrouped [(Text, [Option a])]
options Text -> Maybe a
readExternal) =
      forall a. [(Text, [Option a])] -> (Text -> Maybe a) -> OptionList a
OptionListGrouped (forall a b. (a -> b) -> [a] -> [b]
map (\(Text
g, [Option a]
os) -> (Text
g, (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmapforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) a -> b
f [Option a]
os)) [(Text, [Option a])]
options) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe a
readExternal)

-- | Creates an 'OptionList', using a 'Map' to implement the 'olReadExternal' function.
mkOptionList :: [Option a] -> OptionList a
mkOptionList :: forall a. [Option a] -> OptionList a
mkOptionList [Option a]
os = OptionList
    { olOptions :: [Option a]
olOptions = [Option a]
os
    , olReadExternal :: Text -> Maybe a
olReadExternal = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a. Option a -> Text
optionExternalValue forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall a. Option a -> a
optionInternalValue) [Option a]
os
    }

-- | Creates an 'OptionList', using a 'Map' to implement the 'olReadExternalGrouped' function.
--
-- @since 1.7.0
mkOptionListGrouped :: [(Text, [Option a])] -> OptionList a
mkOptionListGrouped :: forall a. [(Text, [Option a])] -> OptionList a
mkOptionListGrouped [(Text, [Option a])]
os = OptionListGrouped
    { olOptionsGrouped :: [(Text, [Option a])]
olOptionsGrouped = [(Text, [Option a])]
os
    , olReadExternalGrouped :: Text -> Maybe a
olReadExternalGrouped = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a. Option a -> Text
optionExternalValue forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall a. Option a -> a
optionInternalValue) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a b. (a, b) -> b
snd [(Text, [Option a])]
os
    }

data Option a = Option
    { forall a. Option a -> Text
optionDisplay :: Text -- ^ The user-facing label.
    , forall a. Option a -> a
optionInternalValue :: a -- ^ The Haskell value being selected.
    , forall a. Option a -> Text
optionExternalValue :: Text -- ^ The representation of this value stored in the form.
    }

-- | @since 1.4.6
instance Functor Option where
    fmap :: forall a b. (a -> b) -> Option a -> Option b
fmap a -> b
f (Option Text
display a
internal Text
external) = forall a. Text -> a -> Text -> Option a
Option Text
display (a -> b
f a
internal) Text
external

-- | Creates an 'OptionList' from a list of (display-value, internal value) pairs.
optionsPairs :: (MonadHandler m, RenderMessage (HandlerSite m) msg)
             => [(msg, a)] -> m (OptionList a)
optionsPairs :: forall (m :: * -> *) msg a.
(MonadHandler m, RenderMessage (HandlerSite m) msg) =>
[(msg, a)] -> m (OptionList a)
optionsPairs [(msg, a)]
opts = do
  msg -> Text
mr <- forall (m :: * -> *) message.
(MonadHandler m, RenderMessage (HandlerSite m) message) =>
m (message -> Text)
getMessageRender
  let mkOption :: Int -> (msg, a) -> Option a
mkOption Int
external (msg
display, a
internal) =
          Option { optionDisplay :: Text
optionDisplay       = msg -> Text
mr msg
display
                 , optionInternalValue :: a
optionInternalValue = a
internal
                 , optionExternalValue :: Text
optionExternalValue = String -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Int
external
                 }
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. [Option a] -> OptionList a
mkOptionList (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> (msg, a) -> Option a
mkOption [Int
1 :: Int ..] [(msg, a)]
opts)

-- | Creates an 'OptionList' from a list of (display-value, internal value) pairs.
--
-- @since 1.7.0
optionsPairsGrouped
  :: forall m msg a. (MonadHandler m, RenderMessage (HandlerSite m) msg)
  => [(msg, [(msg, a)])] -> m (OptionList a)
optionsPairsGrouped :: forall (m :: * -> *) msg a.
(MonadHandler m, RenderMessage (HandlerSite m) msg) =>
[(msg, [(msg, a)])] -> m (OptionList a)
optionsPairsGrouped [(msg, [(msg, a)])]
opts = do
  msg -> Text
mr <- forall (m :: * -> *) message.
(MonadHandler m, RenderMessage (HandlerSite m) message) =>
m (message -> Text)
getMessageRender
  let mkOption :: (Int, (msg, a)) -> Option a
mkOption (Int
external, (msg
display, a
internal)) =
          Option { optionDisplay :: Text
optionDisplay       = msg -> Text
mr msg
display
                 , optionInternalValue :: a
optionInternalValue = a
internal
                 , optionExternalValue :: Text
optionExternalValue = String -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Int
external
                 }
      opts' :: [(msg, [(Int, (msg, a))])]
opts' = forall a b. [(a, [b])] -> [(a, [(Int, b)])]
enumerateSublists [(msg, [(msg, a)])]
opts :: [(msg, [(Int, (msg, a))])]
      opts'' :: [(Text, [Option a])]
opts'' = forall a b. (a -> b) -> [a] -> [b]
map (\(msg
x, [(Int, (msg, a))]
ys) -> (msg -> Text
mr msg
x, forall a b. (a -> b) -> [a] -> [b]
map (Int, (msg, a)) -> Option a
mkOption [(Int, (msg, a))]
ys)) [(msg, [(Int, (msg, a))])]
opts'
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. [(Text, [Option a])] -> OptionList a
mkOptionListGrouped [(Text, [Option a])]
opts''

-- | Helper to enumerate sublists with one consecutive index.
enumerateSublists :: forall a b. [(a, [b])] -> [(a, [(Int, b)])]
enumerateSublists :: forall a b. [(a, [b])] -> [(a, [(Int, b)])]
enumerateSublists [(a, [b])]
xss =
  let yss :: [(Int, (a, [b]))]
      yss :: [(Int, (a, [b]))]
yss = forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\(Int
i, [(Int, (a, [b]))]
res) (a, [b])
xs -> (Int
i forall a. Num a => a -> a -> a
+ (forall (t :: * -> *) a. Foldable t => t a -> Int
lengthforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a b. (a, b) -> b
snd) (a, [b])
xs, [(Int, (a, [b]))]
res forall a. [a] -> [a] -> [a]
++ [(Int
i, (a, [b])
xs)])) (Int
1, []) [(a, [b])]
xss
   in forall a b. (a -> b) -> [a] -> [b]
map (\(Int
i, (a
x, [b]
ys)) -> (a
x, forall a b. [a] -> [b] -> [(a, b)]
zip [Int
i :: Int ..] [b]
ys)) [(Int, (a, [b]))]
yss

-- | Creates an 'OptionList' from an 'Enum', using its 'Show' instance for the user-facing value.
optionsEnum :: (MonadHandler m, Show a, Enum a, Bounded a) => m (OptionList a)
optionsEnum :: forall (m :: * -> *) a.
(MonadHandler m, Show a, Enum a, Bounded a) =>
m (OptionList a)
optionsEnum = forall (m :: * -> *) msg a.
(MonadHandler m, RenderMessage (HandlerSite m) msg) =>
[(msg, a)] -> m (OptionList a)
optionsPairs forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\a
x -> (String -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show a
x, a
x)) [forall a. Bounded a => a
minBound..forall a. Bounded a => a
maxBound]

-- | Selects a list of 'Entity's with the given 'Filter' and 'SelectOpt's. The @(a -> msg)@ function is then used to derive the display value for an 'OptionList'. Example usage:
--
-- > Country
-- >    name Text
-- >    deriving Eq -- Must derive Eq
--
-- > data CountryForm = CountryForm
-- >   { country :: Entity Country
-- >   }
-- >
-- > countryNameForm :: AForm Handler CountryForm
-- > countryNameForm = CountryForm
-- >         <$> areq (selectField countries) "Which country do you live in?" Nothing
-- >         where
-- >           countries = optionsPersist [] [Asc CountryName] countryName
#if MIN_VERSION_persistent(2,5,0)
optionsPersist :: ( YesodPersist site
                  , PersistQueryRead backend
                  , PathPiece (Key a)
                  , RenderMessage site msg
                  , YesodPersistBackend site ~ backend
                  , PersistRecordBackend a backend
                  )
               => [Filter a]
               -> [SelectOpt a]
               -> (a -> msg)
               -> HandlerFor site (OptionList (Entity a))
#else
optionsPersist :: ( YesodPersist site, PersistEntity a
                  , PersistQuery (PersistEntityBackend a)
                  , PathPiece (Key a)
                  , RenderMessage site msg
                  , YesodPersistBackend site ~ PersistEntityBackend a
                  )
               => [Filter a]
               -> [SelectOpt a]
               -> (a -> msg)
               -> HandlerFor site (OptionList (Entity a))
#endif
optionsPersist :: forall site backend a msg.
(YesodPersist site, PersistQueryRead backend, PathPiece (Key a),
 RenderMessage site msg, YesodPersistBackend site ~ backend,
 PersistRecordBackend a backend) =>
[Filter a]
-> [SelectOpt a]
-> (a -> msg)
-> HandlerFor site (OptionList (Entity a))
optionsPersist [Filter a]
filts [SelectOpt a]
ords a -> msg
toDisplay = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [Option a] -> OptionList a
mkOptionList forall a b. (a -> b) -> a -> b
$ do
    msg -> Text
mr <- forall (m :: * -> *) message.
(MonadHandler m, RenderMessage (HandlerSite m) message) =>
m (message -> Text)
getMessageRender
    [Entity a]
pairs <- forall site a.
YesodPersist site =>
YesodDB site a -> HandlerFor site a
runDB forall a b. (a -> b) -> a -> b
$ forall record backend (m :: * -> *).
(MonadIO m, PersistQueryRead backend,
 PersistRecordBackend record backend) =>
[Filter record]
-> [SelectOpt record] -> ReaderT backend m [Entity record]
selectList [Filter a]
filts [SelectOpt a]
ords
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\(Entity Key a
key a
value) -> Option
        { optionDisplay :: Text
optionDisplay = msg -> Text
mr (a -> msg
toDisplay a
value)
        , optionInternalValue :: Entity a
optionInternalValue = forall record. Key record -> record -> Entity record
Entity Key a
key a
value
        , optionExternalValue :: Text
optionExternalValue = forall s. PathPiece s => s -> Text
toPathPiece Key a
key
        }) [Entity a]
pairs

-- | An alternative to 'optionsPersist' which returns just the 'Key' instead of
-- the entire 'Entity'.
--
-- @since 1.3.2
#if MIN_VERSION_persistent(2,5,0)
optionsPersistKey
  :: (YesodPersist site
     , PersistQueryRead backend
     , PathPiece (Key a)
     , RenderMessage site msg
     , backend ~ YesodPersistBackend site
     , PersistRecordBackend a backend
     )
  => [Filter a]
  -> [SelectOpt a]
  -> (a -> msg)
  -> HandlerFor site (OptionList (Key a))
#else
optionsPersistKey
  :: (YesodPersist site
     , PersistEntity a
     , PersistQuery (PersistEntityBackend a)
     , PathPiece (Key a)
     , RenderMessage site msg
     , YesodPersistBackend site ~ PersistEntityBackend a
     )
  => [Filter a]
  -> [SelectOpt a]
  -> (a -> msg)
  -> HandlerFor site (OptionList (Key a))
#endif

optionsPersistKey :: forall site backend a msg.
(YesodPersist site, PersistQueryRead backend, PathPiece (Key a),
 RenderMessage site msg, backend ~ YesodPersistBackend site,
 PersistRecordBackend a backend) =>
[Filter a]
-> [SelectOpt a]
-> (a -> msg)
-> HandlerFor site (OptionList (Key a))
optionsPersistKey [Filter a]
filts [SelectOpt a]
ords a -> msg
toDisplay = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [Option a] -> OptionList a
mkOptionList forall a b. (a -> b) -> a -> b
$ do
    msg -> Text
mr <- forall (m :: * -> *) message.
(MonadHandler m, RenderMessage (HandlerSite m) message) =>
m (message -> Text)
getMessageRender
    [Entity a]
pairs <- forall site a.
YesodPersist site =>
YesodDB site a -> HandlerFor site a
runDB forall a b. (a -> b) -> a -> b
$ forall record backend (m :: * -> *).
(MonadIO m, PersistQueryRead backend,
 PersistRecordBackend record backend) =>
[Filter record]
-> [SelectOpt record] -> ReaderT backend m [Entity record]
selectList [Filter a]
filts [SelectOpt a]
ords
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\(Entity Key a
key a
value) -> Option
        { optionDisplay :: Text
optionDisplay = msg -> Text
mr (a -> msg
toDisplay a
value)
        , optionInternalValue :: Key a
optionInternalValue = Key a
key
        , optionExternalValue :: Text
optionExternalValue = forall s. PathPiece s => s -> Text
toPathPiece Key a
key
        }) [Entity a]
pairs

-- |
-- A helper function for constucting 'selectField's with optional option groups. You may want to use this when you define your custom 'selectField's or 'radioField's.
--
-- @since 1.6.2
selectFieldHelper
        :: (Eq a, RenderMessage site FormMessage)
        => (Text -> Text -> [(Text, Text)] -> WidgetFor site () -> WidgetFor site ()) -- ^ Outermost part of the field
        -> (Text -> Text -> Bool -> WidgetFor site ()) -- ^ An option for None if the field is optional
        -> (Text -> Text -> [(Text, Text)] -> Text -> Bool -> Text -> WidgetFor site ()) -- ^ Other options
        -> (Maybe (Text -> WidgetFor site ())) -- ^ Group headers placed inbetween options
        -> HandlerFor site (OptionList a)
        -> Field (HandlerFor site) a
selectFieldHelper :: forall a site.
(Eq a, RenderMessage site FormMessage) =>
(Text
 -> Text
 -> [(Text, Text)]
 -> WidgetFor site ()
 -> WidgetFor site ())
-> (Text -> Text -> Bool -> WidgetFor site ())
-> (Text
    -> Text
    -> [(Text, Text)]
    -> Text
    -> Bool
    -> Text
    -> WidgetFor site ())
-> Maybe (Text -> WidgetFor site ())
-> HandlerFor site (OptionList a)
-> Field (HandlerFor site) a
selectFieldHelper Text
-> Text -> [(Text, Text)] -> WidgetFor site () -> WidgetFor site ()
outside Text -> Text -> Bool -> WidgetFor site ()
onOpt Text
-> Text
-> [(Text, Text)]
-> Text
-> Bool
-> Text
-> WidgetFor site ()
inside Maybe (Text -> WidgetFor site ())
grpHdr HandlerFor site (OptionList a)
opts' = Field
    { fieldParse :: [Text]
-> [FileInfo]
-> HandlerFor
     site
     (Either (SomeMessage (HandlerSite (HandlerFor site))) (Maybe a))
fieldParse = \[Text]
x [FileInfo]
_ -> do
        OptionList a
opts <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. OptionList a -> OptionList a
flattenOptionList HandlerFor site (OptionList a)
opts'
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall {master} {a}.
RenderMessage master FormMessage =>
OptionList a -> [Text] -> Either (SomeMessage master) (Maybe a)
selectParser OptionList a
opts [Text]
x
    , fieldView :: FieldViewFunc (HandlerFor site) a
fieldView = \Text
theId Text
name [(Text, Text)]
attrs Either Text a
val Bool
isReq -> do
        Text
-> Text -> [(Text, Text)] -> WidgetFor site () -> WidgetFor site ()
outside Text
theId Text
name [(Text, Text)]
attrs forall a b. (a -> b) -> a -> b
$ do
          [Option a]
optsFlat <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. OptionList a -> [Option a]
olOptionsforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a. OptionList a -> OptionList a
flattenOptionList) forall a b. (a -> b) -> a -> b
$ forall site a. HandlerFor site a -> WidgetFor site a
handlerToWidget HandlerFor site (OptionList a)
opts'
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
isReq forall a b. (a -> b) -> a -> b
$ Text -> Text -> Bool -> WidgetFor site ()
onOpt Text
theId Text
name forall a b. (a -> b) -> a -> b
$ forall {b}. Eq b => [Option b] -> Either Text b -> Text
render [Option a]
optsFlat Either Text a
val forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` forall a b. (a -> b) -> [a] -> [b]
map forall a. Option a -> Text
optionExternalValue [Option a]
optsFlat
          OptionList a
opts'' <- forall site a. HandlerFor site a -> WidgetFor site a
handlerToWidget HandlerFor site (OptionList a)
opts'
          case OptionList a
opts'' of
            OptionList{} -> Text
-> Text
-> [(Text, Text)]
-> Either Text a
-> Bool
-> [Option a]
-> WidgetFor site ()
constructOptions Text
theId Text
name [(Text, Text)]
attrs Either Text a
val Bool
isReq [Option a]
optsFlat
            OptionListGrouped{olOptionsGrouped :: forall a. OptionList a -> [(Text, [Option a])]
olOptionsGrouped=[(Text, [Option a])]
grps} -> do
                  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Text, [Option a])]
grps forall a b. (a -> b) -> a -> b
$ \(Text
grp, [Option a]
opts) -> do
                    case Maybe (Text -> WidgetFor site ())
grpHdr of
                      Just Text -> WidgetFor site ()
hdr -> Text -> WidgetFor site ()
hdr Text
grp
                      Maybe (Text -> WidgetFor site ())
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                    Text
-> Text
-> [(Text, Text)]
-> Either Text a
-> Bool
-> [Option a]
-> WidgetFor site ()
constructOptions Text
theId Text
name [(Text, Text)]
attrs Either Text a
val Bool
isReq [Option a]
opts
    , fieldEnctype :: Enctype
fieldEnctype = Enctype
UrlEncoded
    }
  where
    render :: [Option b] -> Either Text b -> Text
render [Option b]
_ (Left Text
x) = Text
x
    render [Option b]
opts (Right b
a) = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" forall a. Option a -> Text
optionExternalValue forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
== b
a) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Option a -> a
optionInternalValue) [Option b]
opts
    selectParser :: OptionList a -> [Text] -> Either (SomeMessage master) (Maybe a)
selectParser OptionList a
_ [] = forall a b. b -> Either a b
Right forall a. Maybe a
Nothing
    selectParser OptionList a
opts (Text
s:[Text]
_) = case Text
s of
            Text
"" -> forall a b. b -> Either a b
Right forall a. Maybe a
Nothing
            Text
"none" -> forall a b. b -> Either a b
Right forall a. Maybe a
Nothing
            Text
x -> case forall a. OptionList a -> Text -> Maybe a
olReadExternal OptionList a
opts Text
x of
                    Maybe a
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall master msg.
RenderMessage master msg =>
msg -> SomeMessage master
SomeMessage forall a b. (a -> b) -> a -> b
$ Text -> FormMessage
MsgInvalidEntry Text
x
                    Just a
y -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just a
y
    constructOptions :: Text
-> Text
-> [(Text, Text)]
-> Either Text a
-> Bool
-> [Option a]
-> WidgetFor site ()
constructOptions Text
theId Text
name [(Text, Text)]
attrs Either Text a
val Bool
isReq [Option a]
opts =
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Option a]
opts forall a b. (a -> b) -> a -> b
$ \Option a
opt -> Text
-> Text
-> [(Text, Text)]
-> Text
-> Bool
-> Text
-> WidgetFor site ()
inside
                           Text
theId
                           Text
name
                           ((if Bool
isReq then ((Text
"required", Text
"required")forall a. a -> [a] -> [a]
:) else forall a. a -> a
id) [(Text, Text)]
attrs)
                           (forall a. Option a -> Text
optionExternalValue Option a
opt)
                           (forall {b}. Eq b => [Option b] -> Either Text b -> Text
render [Option a]
opts Either Text a
val forall a. Eq a => a -> a -> Bool
== forall a. Option a -> Text
optionExternalValue Option a
opt)
                           (forall a. Option a -> Text
optionDisplay Option a
opt)

-- | Creates an input with @type="file"@.
fileField :: Monad m
          => Field m FileInfo
fileField :: forall (m :: * -> *). Monad m => Field m FileInfo
fileField = Field
    { fieldParse :: [Text]
-> [FileInfo]
-> m (Either (SomeMessage (HandlerSite m)) (Maybe FileInfo))
fieldParse = \[Text]
_ [FileInfo]
files -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
        case [FileInfo]
files of
            [] -> forall a b. b -> Either a b
Right forall a. Maybe a
Nothing
            FileInfo
file:[FileInfo]
_ -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just FileInfo
file
    , fieldView :: FieldViewFunc m FileInfo
fieldView = \Text
id' Text
name [(Text, Text)]
attrs Either Text FileInfo
_ Bool
isReq -> forall site a (m :: * -> *).
(ToWidget site a, MonadWidget m, HandlerSite m ~ site) =>
a -> m ()
toWidget [hamlet|
            <input id=#{id'} name=#{name} *{attrs} type=file :isReq:required>
        |]
    , fieldEnctype :: Enctype
fieldEnctype = Enctype
Multipart
    }

fileAFormReq :: (MonadHandler m, RenderMessage (HandlerSite m) FormMessage)
             => FieldSettings (HandlerSite m) -> AForm m FileInfo
fileAFormReq :: forall (m :: * -> *).
(MonadHandler m, RenderMessage (HandlerSite m) FormMessage) =>
FieldSettings (HandlerSite m) -> AForm m FileInfo
fileAFormReq FieldSettings (HandlerSite m)
fs = 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)
menvs Ints
ints -> do
    let (Text
name, Ints
ints') =
            case forall master. FieldSettings master -> Maybe Text
fsName FieldSettings (HandlerSite m)
fs of
                Just Text
x -> (Text
x, Ints
ints)
                Maybe Text
Nothing ->
                    let i' :: Ints
i' = Ints -> Ints
incrInts Ints
ints
                     in (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', Ints
i')
    Text
id' <- 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 forall a b. (a -> b) -> a -> b
$ forall master. FieldSettings master -> Maybe Text
fsId FieldSettings (HandlerSite m)
fs
    let (FormResult FileInfo
res, Maybe (MarkupM ())
errs) =
            case Maybe (Env, FileEnv)
menvs of
                Maybe (Env, FileEnv)
Nothing -> (forall a. FormResult a
FormMissing, forall a. Maybe a
Nothing)
                Just (Env
_, FileEnv
fenv) ->
                    case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
name FileEnv
fenv of
                        Just (FileInfo
fi:[FileInfo]
_) -> (forall a. a -> FormResult a
FormSuccess FileInfo
fi, forall a. Maybe a
Nothing)
                        Maybe [FileInfo]
_ ->
                            let t :: Text
t = forall master message.
RenderMessage master message =>
master -> [Text] -> message -> Text
renderMessage HandlerSite m
site [Text]
langs FormMessage
MsgValueRequired
                             in (forall a. [Text] -> FormResult a
FormFailure [Text
t], forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ toHtml t)
    let fv :: FieldView (HandlerSite m)
fv = FieldView
            { fvLabel :: MarkupM ()
fvLabel = toHtml $ renderMessage site langs $ fsLabel fs
            , fvTooltip :: Maybe (MarkupM ())
fvTooltip = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (toHtml . renderMessage site langs) $ fsTooltip fs
            , fvId :: Text
fvId = Text
id'
            , fvInput :: WidgetFor (HandlerSite m) ()
fvInput = [whamlet|
$newline never
<input type=file name=#{name} ##{id'} *{fsAttrs fs}>
|]
            , fvErrors :: Maybe (MarkupM ())
fvErrors = Maybe (MarkupM ())
errs
            , fvRequired :: Bool
fvRequired = Bool
True
            }
    forall (m :: * -> *) a. Monad m => a -> m a
return (FormResult FileInfo
res, (FieldView (HandlerSite m)
fv forall a. a -> [a] -> [a]
:), Ints
ints', Enctype
Multipart)

fileAFormOpt :: MonadHandler m
             => FieldSettings (HandlerSite m)
             -> AForm m (Maybe FileInfo)
fileAFormOpt :: forall (m :: * -> *).
MonadHandler m =>
FieldSettings (HandlerSite m) -> AForm m (Maybe FileInfo)
fileAFormOpt FieldSettings (HandlerSite m)
fs = 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
master, [Text]
langs) Maybe (Env, FileEnv)
menvs Ints
ints -> do
    let (Text
name, Ints
ints') =
            case forall master. FieldSettings master -> Maybe Text
fsName FieldSettings (HandlerSite m)
fs of
                Just Text
x -> (Text
x, Ints
ints)
                Maybe Text
Nothing ->
                    let i' :: Ints
i' = Ints -> Ints
incrInts Ints
ints
                     in (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', Ints
i')
    Text
id' <- 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 forall a b. (a -> b) -> a -> b
$ forall master. FieldSettings master -> Maybe Text
fsId FieldSettings (HandlerSite m)
fs
    let (FormResult (Maybe FileInfo)
res, Maybe (MarkupM ())
errs) =
            case Maybe (Env, FileEnv)
menvs of
                Maybe (Env, FileEnv)
Nothing -> (forall a. FormResult a
FormMissing, forall a. Maybe a
Nothing)
                Just (Env
_, FileEnv
fenv) ->
                    case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
name FileEnv
fenv of
                        Just (FileInfo
fi:[FileInfo]
_) -> (forall a. a -> FormResult a
FormSuccess forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just FileInfo
fi, forall a. Maybe a
Nothing)
                        Maybe [FileInfo]
_ -> (forall a. a -> FormResult a
FormSuccess forall a. Maybe a
Nothing, forall a. Maybe a
Nothing)
    let fv :: FieldView (HandlerSite m)
fv = FieldView
            { fvLabel :: MarkupM ()
fvLabel = toHtml $ renderMessage master langs $ fsLabel fs
            , fvTooltip :: Maybe (MarkupM ())
fvTooltip = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (toHtml . renderMessage master langs) $ fsTooltip fs
            , fvId :: Text
fvId = Text
id'
            , fvInput :: WidgetFor (HandlerSite m) ()
fvInput = [whamlet|
$newline never
<input type=file name=#{name} ##{id'} *{fsAttrs fs}>
|]
            , fvErrors :: Maybe (MarkupM ())
fvErrors = Maybe (MarkupM ())
errs
            , fvRequired :: Bool
fvRequired = Bool
False
            }
    forall (m :: * -> *) a. Monad m => a -> m a
return (FormResult (Maybe FileInfo)
res, (FieldView (HandlerSite m)
fv forall a. a -> [a] -> [a]
:), Ints
ints', Enctype
Multipart)

incrInts :: Ints -> Ints
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


-- | Adds a '0' to some text so that it may be recognized as a double.
--   The read ftn does not recognize ".3" as 0.3 nor "-.3" as -0.3, so this
--   function changes ".xxx" to "0.xxx" and "-.xxx" to "-0.xxx"

prependZero :: Text -> Text
prependZero :: Text -> Text
prependZero Text
t0 = if Text -> Bool
T.null Text
t1
                 then Text
t1
                 else if Text -> Char
T.head Text
t1 forall a. Eq a => a -> a -> Bool
== Char
'.'
                      then Char
'0' Char -> Text -> Text
`T.cons` Text
t1
                      else if Text
"-." Text -> Text -> Bool
`T.isPrefixOf` Text
t1
                           then Text
"-0." Text -> Text -> Text
`T.append` (Int -> Text -> Text
T.drop Int
2 Text
t1)
                           else Text
t1

  where t1 :: Text
t1 = (Char -> Bool) -> Text -> Text
T.dropWhile (forall a. Eq a => a -> a -> Bool
==Char
' ') Text
t0

-- $optionsOverview
-- These functions create inputs where one or more options can be selected from a list.
--
-- The basic datastructure used is an 'Option', which combines a user-facing display value, the internal Haskell value being selected, and an external 'Text' stored as the @value@ in the form (used to map back to the internal value). A list of these, together with a function mapping from an external value back to a Haskell value, form an 'OptionList', which several of these functions take as an argument.
--
-- Typically, you won't need to create an 'OptionList' directly and can instead make one with functions like 'optionsPairs' or 'optionsEnum'. Alternatively, you can use functions like 'selectFieldList', which use their @[(msg, a)]@ parameter to create an 'OptionList' themselves.

-- | Creates an input with @type="color"@.
--   The input value must be provided in hexadecimal format #rrggbb.
--
-- @since 1.7.1
colorField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Text
colorField :: forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m Text
colorField = Field
    { fieldParse :: [Text]
-> [FileInfo]
-> m (Either (SomeMessage (HandlerSite m)) (Maybe Text))
fieldParse = forall (m :: * -> *) site a.
(Monad m, RenderMessage site FormMessage) =>
(Text -> Either FormMessage a)
-> [Text] -> [FileInfo] -> m (Either (SomeMessage site) (Maybe a))
parseHelper forall a b. (a -> b) -> a -> b
$ \Text
s ->
        if String -> Bool
isHexColor forall a b. (a -> b) -> a -> b
$ Text -> String
unpack Text
s then forall a b. b -> Either a b
Right Text
s
        else forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text -> FormMessage
MsgInvalidHexColorFormat Text
s
    , fieldView :: FieldViewFunc m Text
fieldView = \Text
theId Text
name [(Text, Text)]
attrs Either Text Text
val Bool
_ -> [whamlet|
$newline never
<input ##{theId} name=#{name} *{attrs} type=color value=#{either id id val}>
|]
    , fieldEnctype :: Enctype
fieldEnctype = Enctype
UrlEncoded
    }
  where
      isHexColor :: String -> Bool
      isHexColor :: String -> Bool
isHexColor [Char
'#',Char
a,Char
b,Char
c,Char
d,Char
e,Char
f] = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isHexDigit [Char
a,Char
b,Char
c,Char
d,Char
e,Char
f]
      isHexColor String
_ = Bool
False