{-# 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
    , checkboxesField
    , checkboxesFieldList
    , multiSelectField
    , multiSelectFieldList
    , Option (..)
    , OptionList (..)
    , mkOptionList
    , mkOptionListGrouped
    , optionsPersist
    , optionsPersistKey
    , optionsPairs
    , optionsPairsGrouped
    , optionsEnum
    ) 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

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 :: Field m i
intField = Field :: forall (m :: * -> *) a.
([Text]
 -> [FileInfo]
 -> m (Either (SomeMessage (HandlerSite m)) (Maybe a)))
-> FieldViewFunc m a -> Enctype -> Field m a
Field
    { fieldParse :: [Text]
-> [FileInfo] -> m (Either (SomeMessage (HandlerSite m)) (Maybe i))
fieldParse = (Text -> Either FormMessage i)
-> [Text]
-> [FileInfo]
-> m (Either (SomeMessage (HandlerSite m)) (Maybe i))
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 i)
 -> [Text]
 -> [FileInfo]
 -> m (Either (SomeMessage (HandlerSite m)) (Maybe i)))
-> (Text -> Either FormMessage i)
-> [Text]
-> [FileInfo]
-> m (Either (SomeMessage (HandlerSite m)) (Maybe i))
forall a b. (a -> b) -> a -> b
$ \Text
s ->
        case Reader i -> Reader i
forall a. Num a => Reader a -> Reader a
Data.Text.Read.signed Reader i
forall a. Integral a => Reader a
Data.Text.Read.decimal Text
s of
            Right (i
a, Text
"") -> i -> Either FormMessage i
forall a b. b -> Either a b
Right i
a
            Either String (i, Text)
_ -> FormMessage -> Either FormMessage i
forall a b. a -> Either a b
Left (FormMessage -> Either FormMessage i)
-> FormMessage -> Either FormMessage i
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 -> (RY (HandlerSite m) -> MarkupM ()) -> WidgetFor (HandlerSite m) ()
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 = (Text -> Text) -> (i -> Text) -> Either Text i -> Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Text -> Text
forall a. a -> a
id (String -> Text
pack (String -> Text) -> (i -> String) -> i -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. i -> String
forall a. Integral a => a -> String
showI)
    showI :: a -> String
showI a
x = Integer -> String
forall a. Show a => a -> String
show (a -> Integer
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 :: Field m Double
doubleField = Field :: forall (m :: * -> *) a.
([Text]
 -> [FileInfo]
 -> m (Either (SomeMessage (HandlerSite m)) (Maybe a)))
-> FieldViewFunc m a -> Enctype -> Field m a
Field
    { fieldParse :: [Text]
-> [FileInfo]
-> m (Either (SomeMessage (HandlerSite m)) (Maybe Double))
fieldParse = (Text -> Either FormMessage Double)
-> [Text]
-> [FileInfo]
-> m (Either (SomeMessage (HandlerSite m)) (Maybe Double))
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 Double)
 -> [Text]
 -> [FileInfo]
 -> m (Either (SomeMessage (HandlerSite m)) (Maybe Double)))
-> (Text -> Either FormMessage Double)
-> [Text]
-> [FileInfo]
-> m (Either (SomeMessage (HandlerSite m)) (Maybe Double))
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
"") -> Double -> Either FormMessage Double
forall a b. b -> Either a b
Right Double
a
            Either String (Double, Text)
_ -> FormMessage -> Either FormMessage Double
forall a b. a -> Either a b
Left (FormMessage -> Either FormMessage Double)
-> FormMessage -> Either FormMessage Double
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 -> (RY (HandlerSite m) -> MarkupM ()) -> WidgetFor (HandlerSite m) ()
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 = (Text -> Text) -> (Double -> Text) -> Either Text Double -> Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Text -> Text
forall a. a -> a
id (String -> Text
pack (String -> Text) -> (Double -> String) -> Double -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> String
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 :: Field m Day
dayField = Field :: forall (m :: * -> *) a.
([Text]
 -> [FileInfo]
 -> m (Either (SomeMessage (HandlerSite m)) (Maybe a)))
-> FieldViewFunc m a -> Enctype -> Field m a
Field
    { fieldParse :: [Text]
-> [FileInfo]
-> m (Either (SomeMessage (HandlerSite m)) (Maybe Day))
fieldParse = (Text -> Either FormMessage Day)
-> [Text]
-> [FileInfo]
-> m (Either (SomeMessage (HandlerSite m)) (Maybe Day))
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 Day)
 -> [Text]
 -> [FileInfo]
 -> m (Either (SomeMessage (HandlerSite m)) (Maybe Day)))
-> (Text -> Either FormMessage Day)
-> [Text]
-> [FileInfo]
-> m (Either (SomeMessage (HandlerSite m)) (Maybe Day))
forall a b. (a -> b) -> a -> b
$ String -> Either FormMessage Day
parseDate (String -> Either FormMessage Day)
-> (Text -> String) -> Text -> Either FormMessage Day
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 -> (RY (HandlerSite m) -> MarkupM ()) -> WidgetFor (HandlerSite m) ()
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 = (Text -> Text) -> (Day -> Text) -> Either Text Day -> Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Text -> Text
forall a. a -> a
id (String -> Text
pack (String -> Text) -> (Day -> String) -> Day -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day -> String
forall a. Show a => a -> String
show)

-- | An alias for 'timeFieldTypeTime'.
timeField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m TimeOfDay
timeField :: Field m TimeOfDay
timeField = Field m TimeOfDay
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 :: Field m TimeOfDay
timeFieldTypeTime = Text -> Field m TimeOfDay
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 :: Field m TimeOfDay
timeFieldTypeText = Text -> Field m TimeOfDay
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 :: Text -> Field m TimeOfDay
timeFieldOfType Text
inputType = Field :: forall (m :: * -> *) a.
([Text]
 -> [FileInfo]
 -> m (Either (SomeMessage (HandlerSite m)) (Maybe a)))
-> FieldViewFunc m a -> Enctype -> Field m a
Field
    { fieldParse :: [Text]
-> [FileInfo]
-> m (Either (SomeMessage (HandlerSite m)) (Maybe TimeOfDay))
fieldParse = (Text -> Either FormMessage TimeOfDay)
-> [Text]
-> [FileInfo]
-> m (Either (SomeMessage (HandlerSite m)) (Maybe TimeOfDay))
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 -> (RY (HandlerSite m) -> MarkupM ()) -> WidgetFor (HandlerSite m) ()
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 = (Text -> Text)
-> (TimeOfDay -> Text) -> Either Text TimeOfDay -> Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Text -> Text
forall a. a -> a
id (String -> Text
pack (String -> Text) -> (TimeOfDay -> String) -> TimeOfDay -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimeOfDay -> String
forall a. Show a => a -> String
show (TimeOfDay -> String)
-> (TimeOfDay -> TimeOfDay) -> TimeOfDay -> String
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 = Integer -> Pico
forall a. Num a => Integer -> a
fromInteger (Integer -> Pico) -> Integer -> Pico
forall a b. (a -> b) -> a -> b
$ Pico -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
floor (Pico -> Integer) -> Pico -> Integer
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 :: Field m (MarkupM ())
htmlField = Field :: forall (m :: * -> *) a.
([Text]
 -> [FileInfo]
 -> m (Either (SomeMessage (HandlerSite m)) (Maybe a)))
-> FieldViewFunc m a -> Enctype -> Field m a
Field
    { fieldParse :: [Text]
-> [FileInfo]
-> m (Either (SomeMessage (HandlerSite m)) (Maybe (MarkupM ())))
fieldParse = (Text -> Either FormMessage (MarkupM ()))
-> [Text]
-> [FileInfo]
-> m (Either (SomeMessage (HandlerSite m)) (Maybe (MarkupM ())))
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 (MarkupM ()))
 -> [Text]
 -> [FileInfo]
 -> m (Either (SomeMessage (HandlerSite m)) (Maybe (MarkupM ()))))
-> (Text -> Either FormMessage (MarkupM ()))
-> [Text]
-> [FileInfo]
-> m (Either (SomeMessage (HandlerSite m)) (Maybe (MarkupM ())))
forall a b. (a -> b) -> a -> b
$ MarkupM () -> Either FormMessage (MarkupM ())
forall a b. b -> Either a b
Right (MarkupM () -> Either FormMessage (MarkupM ()))
-> (Text -> MarkupM ()) -> Text -> Either FormMessage (MarkupM ())
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 -> (RY (HandlerSite m) -> MarkupM ()) -> WidgetFor (HandlerSite m) ()
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 = (Text -> Text)
-> (MarkupM () -> Text) -> Either Text (MarkupM ()) -> Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Text -> Text
forall a. a -> a
id (String -> Text
pack (String -> Text) -> (MarkupM () -> String) -> MarkupM () -> Text
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
(Int -> Textarea -> ShowS)
-> (Textarea -> String) -> ([Textarea] -> ShowS) -> Show Textarea
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]
(Int -> ReadS Textarea)
-> ReadS [Textarea]
-> ReadPrec Textarea
-> ReadPrec [Textarea]
-> Read 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
(Textarea -> Textarea -> Bool)
-> (Textarea -> Textarea -> Bool) -> Eq Textarea
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
(Textarea -> PersistValue)
-> (PersistValue -> Either Text Textarea) -> PersistField Textarea
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
Eq Textarea
-> (Textarea -> Textarea -> Ordering)
-> (Textarea -> Textarea -> Bool)
-> (Textarea -> Textarea -> Bool)
-> (Textarea -> Textarea -> Bool)
-> (Textarea -> Textarea -> Bool)
-> (Textarea -> Textarea -> Textarea)
-> (Textarea -> Textarea -> Textarea)
-> Ord 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
$cp1Ord :: Eq Textarea
Ord, [Textarea] -> Encoding
[Textarea] -> Value
Textarea -> Encoding
Textarea -> Value
(Textarea -> Value)
-> (Textarea -> Encoding)
-> ([Textarea] -> Value)
-> ([Textarea] -> Encoding)
-> ToJSON Textarea
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
(Value -> Parser Textarea)
-> (Value -> Parser [Textarea]) -> FromJSON 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
(String -> Textarea) -> IsString 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 :: Field m Textarea
textareaField = Field :: forall (m :: * -> *) a.
([Text]
 -> [FileInfo]
 -> m (Either (SomeMessage (HandlerSite m)) (Maybe a)))
-> FieldViewFunc m a -> Enctype -> Field m a
Field
    { fieldParse :: [Text]
-> [FileInfo]
-> m (Either (SomeMessage (HandlerSite m)) (Maybe Textarea))
fieldParse = (Text -> Either FormMessage Textarea)
-> [Text]
-> [FileInfo]
-> m (Either (SomeMessage (HandlerSite m)) (Maybe Textarea))
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 Textarea)
 -> [Text]
 -> [FileInfo]
 -> m (Either (SomeMessage (HandlerSite m)) (Maybe Textarea)))
-> (Text -> Either FormMessage Textarea)
-> [Text]
-> [FileInfo]
-> m (Either (SomeMessage (HandlerSite m)) (Maybe Textarea))
forall a b. (a -> b) -> a -> b
$ Textarea -> Either FormMessage Textarea
forall a b. b -> Either a b
Right (Textarea -> Either FormMessage Textarea)
-> (Text -> Textarea) -> Text -> Either FormMessage Textarea
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 -> (RY (HandlerSite m) -> MarkupM ()) -> WidgetFor (HandlerSite m) ()
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 :: Field m p
hiddenField = Field :: forall (m :: * -> *) a.
([Text]
 -> [FileInfo]
 -> m (Either (SomeMessage (HandlerSite m)) (Maybe a)))
-> FieldViewFunc m a -> Enctype -> Field m a
Field
    { fieldParse :: [Text]
-> [FileInfo] -> m (Either (SomeMessage (HandlerSite m)) (Maybe p))
fieldParse = (Text -> Either FormMessage p)
-> [Text]
-> [FileInfo]
-> m (Either (SomeMessage (HandlerSite m)) (Maybe p))
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 p)
 -> [Text]
 -> [FileInfo]
 -> m (Either (SomeMessage (HandlerSite m)) (Maybe p)))
-> (Text -> Either FormMessage p)
-> [Text]
-> [FileInfo]
-> m (Either (SomeMessage (HandlerSite m)) (Maybe p))
forall a b. (a -> b) -> a -> b
$ Either FormMessage p
-> (p -> Either FormMessage p) -> Maybe p -> Either FormMessage p
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (FormMessage -> Either FormMessage p
forall a b. a -> Either a b
Left FormMessage
MsgValueRequired) p -> Either FormMessage p
forall a b. b -> Either a b
Right (Maybe p -> Either FormMessage p)
-> (Text -> Maybe p) -> Text -> Either FormMessage p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe p
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 -> (RY (HandlerSite m) -> MarkupM ()) -> WidgetFor (HandlerSite m) ()
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 :: Field m Text
textField = Field :: forall (m :: * -> *) a.
([Text]
 -> [FileInfo]
 -> m (Either (SomeMessage (HandlerSite m)) (Maybe a)))
-> FieldViewFunc m a -> Enctype -> Field m a
Field
    { fieldParse :: [Text]
-> [FileInfo]
-> m (Either (SomeMessage (HandlerSite m)) (Maybe Text))
fieldParse = (Text -> Either FormMessage Text)
-> [Text]
-> [FileInfo]
-> m (Either (SomeMessage (HandlerSite m)) (Maybe Text))
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 Text)
 -> [Text]
 -> [FileInfo]
 -> m (Either (SomeMessage (HandlerSite m)) (Maybe Text)))
-> (Text -> Either FormMessage Text)
-> [Text]
-> [FileInfo]
-> m (Either (SomeMessage (HandlerSite m)) (Maybe Text))
forall a b. (a -> b) -> a -> b
$ Text -> Either FormMessage Text
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 :: Field m Text
passwordField = Field :: forall (m :: * -> *) a.
([Text]
 -> [FileInfo]
 -> m (Either (SomeMessage (HandlerSite m)) (Maybe a)))
-> FieldViewFunc m a -> Enctype -> Field m a
Field
    { fieldParse :: [Text]
-> [FileInfo]
-> m (Either (SomeMessage (HandlerSite m)) (Maybe Text))
fieldParse = (Text -> Either FormMessage Text)
-> [Text]
-> [FileInfo]
-> m (Either (SomeMessage (HandlerSite m)) (Maybe Text))
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 Text)
 -> [Text]
 -> [FileInfo]
 -> m (Either (SomeMessage (HandlerSite m)) (Maybe Text)))
-> (Text -> Either FormMessage Text)
-> [Text]
-> [FileInfo]
-> m (Either (SomeMessage (HandlerSite m)) (Maybe Text))
forall a b. (a -> b) -> a -> b
$ Text -> Either FormMessage Text
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 -> (RY (HandlerSite m) -> MarkupM ()) -> WidgetFor (HandlerSite m) ()
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 :: String -> Maybe a
readMay String
s = case ((a, String) -> Bool) -> [(a, String)] -> [(a, String)]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
Prelude.null (String -> Bool) -> ((a, String) -> String) -> (a, String) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, String) -> String
forall a b. (a, b) -> b
snd) ([(a, String)] -> [(a, String)]) -> [(a, String)] -> [(a, String)]
forall a b. (a -> b) -> a -> b
$ ReadS a
forall a. Read a => ReadS a
reads String
s of
                (a
x, String
_):[(a, String)]
_ -> a -> Maybe a
forall a. a -> Maybe a
Just a
x
                [] -> Maybe a
forall a. Maybe a
Nothing

-- | Parses a 'Day' from a 'String'.
parseDate :: String -> Either FormMessage Day
parseDate :: String -> Either FormMessage Day
parseDate = Either FormMessage Day
-> (Day -> Either FormMessage Day)
-> Maybe Day
-> Either FormMessage Day
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (FormMessage -> Either FormMessage Day
forall a b. a -> Either a b
Left FormMessage
MsgInvalidDay) Day -> Either FormMessage Day
forall a b. b -> Either a b
Right
              (Maybe Day -> Either FormMessage Day)
-> (String -> Maybe Day) -> String -> Either FormMessage Day
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe Day
forall a. Read a => String -> Maybe a
readMay (String -> Maybe Day) -> ShowS -> String -> Maybe Day
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Char -> ShowS
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 :: a -> a -> [a] -> [a]
replace a
x a
y = (a -> a) -> [a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (\a
z -> if a
z a -> a -> Bool
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 = (String -> Either FormMessage TimeOfDay)
-> (TimeOfDay -> Either FormMessage TimeOfDay)
-> Either String TimeOfDay
-> Either FormMessage TimeOfDay
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (FormMessage -> Either FormMessage TimeOfDay
forall a b. a -> Either a b
Left (FormMessage -> Either FormMessage TimeOfDay)
-> (String -> FormMessage)
-> String
-> Either FormMessage TimeOfDay
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FormMessage -> Maybe FormMessage -> FormMessage
forall a. a -> Maybe a -> a
fromMaybe FormMessage
MsgInvalidTimeFormat (Maybe FormMessage -> FormMessage)
-> (String -> Maybe FormMessage) -> String -> FormMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe FormMessage
forall a. Read a => String -> Maybe a
readMay (String -> Maybe FormMessage)
-> ShowS -> String -> Maybe FormMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
2 ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
':')) TimeOfDay -> Either FormMessage TimeOfDay
forall a b. b -> Either a b
Right (Either String TimeOfDay -> Either FormMessage TimeOfDay)
-> (Text -> Either String TimeOfDay)
-> Text
-> Either FormMessage TimeOfDay
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser TimeOfDay -> Text -> Either String TimeOfDay
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 <- (Text -> FormMessage) -> Parser Text Int
forall a. Num a => (Text -> FormMessage) -> Parser a
minsec Text -> FormMessage
MsgInvalidMinute
    Bool
hasSec <- (Char -> Parser Char
char Char
':' Parser Char -> Parser Text Bool -> Parser Text Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> Parser Text Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True) Parser Text Bool -> Parser Text Bool -> Parser Text Bool
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Bool -> Parser Text Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    Pico
s <- if Bool
hasSec then (Text -> FormMessage) -> Parser Pico
forall a. Num a => (Text -> FormMessage) -> Parser a
minsec Text -> FormMessage
MsgInvalidSecond else Pico -> Parser Pico
forall (m :: * -> *) a. Monad m => a -> m a
return Pico
0
    Parser ()
skipSpace
    Maybe Bool
isPM <-
        (Text -> Parser Text
string Text
"am" Parser Text -> Parser Text (Maybe Bool) -> Parser Text (Maybe Bool)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe Bool -> Parser Text (Maybe Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False)) Parser Text (Maybe Bool)
-> Parser Text (Maybe Bool) -> Parser Text (Maybe Bool)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
        (Text -> Parser Text
string Text
"AM" Parser Text -> Parser Text (Maybe Bool) -> Parser Text (Maybe Bool)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe Bool -> Parser Text (Maybe Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False)) Parser Text (Maybe Bool)
-> Parser Text (Maybe Bool) -> Parser Text (Maybe Bool)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
        (Text -> Parser Text
string Text
"pm" Parser Text -> Parser Text (Maybe Bool) -> Parser Text (Maybe Bool)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe Bool -> Parser Text (Maybe Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True)) Parser Text (Maybe Bool)
-> Parser Text (Maybe Bool) -> Parser Text (Maybe Bool)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
        (Text -> Parser Text
string Text
"PM" Parser Text -> Parser Text (Maybe Bool) -> Parser Text (Maybe Bool)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe Bool -> Parser Text (Maybe Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True)) Parser Text (Maybe Bool)
-> Parser Text (Maybe Bool) -> Parser Text (Maybe Bool)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
        Maybe Bool -> Parser Text (Maybe Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Bool
forall a. Maybe a
Nothing
    Int
h' <-
        case Maybe Bool
isPM of
            Maybe Bool
Nothing -> Int -> Parser Text Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
h
            Just Bool
x
                | Int
h Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 Bool -> Bool -> Bool
|| Int
h Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
12 -> String -> Parser Text Int
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser Text Int) -> String -> Parser Text Int
forall a b. (a -> b) -> a -> b
$ FormMessage -> String
forall a. Show a => a -> String
show (FormMessage -> String) -> FormMessage -> String
forall a b. (a -> b) -> a -> b
$ Text -> FormMessage
MsgInvalidHour (Text -> FormMessage) -> Text -> FormMessage
forall a b. (a -> b) -> a -> b
$ String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
h
                | Int
h Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
12 -> Int -> Parser Text Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Parser Text Int) -> Int -> Parser Text Int
forall a b. (a -> b) -> a -> b
$ if Bool
x then Int
12 else Int
0
                | Bool
otherwise -> Int -> Parser Text Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Parser Text Int) -> Int -> Parser Text Int
forall a b. (a -> b) -> a -> b
$ Int
h Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (if Bool
x then Int
12 else Int
0)
    Parser ()
skipSpace
    Parser ()
forall t. Chunk t => Parser t ()
endOfInput
    TimeOfDay -> Parser TimeOfDay
forall (m :: * -> *) a. Monad m => a -> m a
return (TimeOfDay -> Parser TimeOfDay) -> TimeOfDay -> Parser TimeOfDay
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 <- (Char -> String
forall (m :: * -> *) a. Monad m => a -> m a
return (Char -> String) -> Parser Char -> Parser Text String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
Control.Applicative.<$> Parser Char
digit) Parser Text String -> Parser Text String -> Parser Text String
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> Parser Text String
forall (m :: * -> *) a. Monad m => a -> m a
return []
        let xy :: String
xy = Char
x Char -> ShowS
forall a. a -> [a] -> [a]
: String
y
        let i :: Int
i = String -> Int
forall a. Read a => String -> a
read String
xy
        if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
24
            then String -> Parser Text Int
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser Text Int) -> String -> Parser Text Int
forall a b. (a -> b) -> a -> b
$ FormMessage -> String
forall a. Show a => a -> String
show (FormMessage -> String) -> FormMessage -> String
forall a b. (a -> b) -> a -> b
$ Text -> FormMessage
MsgInvalidHour (Text -> FormMessage) -> Text -> FormMessage
forall a b. (a -> b) -> a -> b
$ String -> Text
pack String
xy
            else Int -> Parser Text Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
i
    minsec :: Num a => (Text -> FormMessage) -> Parser a
    minsec :: (Text -> FormMessage) -> Parser a
minsec Text -> FormMessage
msg = do
        Char
x <- Parser Char
digit
        Char
y <- Parser Char
digit Parser Char -> Parser Char -> Parser Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> Parser Char
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (FormMessage -> String
forall a. Show a => a -> String
show (FormMessage -> String) -> FormMessage -> String
forall a b. (a -> b) -> a -> b
$ Text -> FormMessage
msg (Text -> FormMessage) -> Text -> FormMessage
forall a b. (a -> b) -> a -> b
$ String -> Text
pack [Char
x])
        let xy :: String
xy = [Char
x, Char
y]
        let i :: Int
i = String -> Int
forall a. Read a => String -> a
read String
xy
        if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
60
            then String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser a) -> String -> Parser a
forall a b. (a -> b) -> a -> b
$ FormMessage -> String
forall a. Show a => a -> String
show (FormMessage -> String) -> FormMessage -> String
forall a b. (a -> b) -> a -> b
$ Text -> FormMessage
msg (Text -> FormMessage) -> Text -> FormMessage
forall a b. (a -> b) -> a -> b
$ String -> Text
pack String
xy
            else a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Parser a) -> a -> Parser a
forall a b. (a -> b) -> a -> b
$ Int -> a
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 :: Field m Text
emailField = Field :: forall (m :: * -> *) a.
([Text]
 -> [FileInfo]
 -> m (Either (SomeMessage (HandlerSite m)) (Maybe a)))
-> FieldViewFunc m a -> Enctype -> Field m a
Field
    { fieldParse :: [Text]
-> [FileInfo]
-> m (Either (SomeMessage (HandlerSite m)) (Maybe Text))
fieldParse = (Text -> Either FormMessage Text)
-> [Text]
-> [FileInfo]
-> m (Either (SomeMessage (HandlerSite m)) (Maybe Text))
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 Text)
 -> [Text]
 -> [FileInfo]
 -> m (Either (SomeMessage (HandlerSite m)) (Maybe Text)))
-> (Text -> Either FormMessage Text)
-> [Text]
-> [FileInfo]
-> m (Either (SomeMessage (HandlerSite m)) (Maybe Text))
forall a b. (a -> b) -> a -> b
$
        \Text
s ->
            case ByteString -> Maybe ByteString
Email.canonicalizeEmail (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 Text
s of
                Just ByteString
e -> Text -> Either FormMessage Text
forall a b. b -> Either a b
Right (Text -> Either FormMessage Text)
-> Text -> Either FormMessage Text
forall a b. (a -> b) -> a -> b
$ OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode ByteString
e
                Maybe ByteString
Nothing -> FormMessage -> Either FormMessage Text
forall a b. a -> Either a b
Left (FormMessage -> Either FormMessage Text)
-> FormMessage -> Either FormMessage Text
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 -> (RY (HandlerSite m) -> MarkupM ()) -> WidgetFor (HandlerSite m) ()
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 :: Field m [Text]
multiEmailField = Field :: forall (m :: * -> *) a.
([Text]
 -> [FileInfo]
 -> m (Either (SomeMessage (HandlerSite m)) (Maybe a)))
-> FieldViewFunc m a -> Enctype -> Field m a
Field
    { fieldParse :: [Text]
-> [FileInfo]
-> m (Either (SomeMessage (HandlerSite m)) (Maybe [Text]))
fieldParse = (Text -> Either FormMessage [Text])
-> [Text]
-> [FileInfo]
-> m (Either (SomeMessage (HandlerSite m)) (Maybe [Text]))
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 [Text])
 -> [Text]
 -> [FileInfo]
 -> m (Either (SomeMessage (HandlerSite m)) (Maybe [Text])))
-> (Text -> Either FormMessage [Text])
-> [Text]
-> [FileInfo]
-> m (Either (SomeMessage (HandlerSite m)) (Maybe [Text]))
forall a b. (a -> b) -> a -> b
$
        \Text
s ->
            let addrs :: [Either Text Text]
addrs = (Text -> Either Text Text) -> [Text] -> [Either Text Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Either Text Text
validate ([Text] -> [Either Text Text]) -> [Text] -> [Either Text Text]
forall a b. (a -> b) -> a -> b
$ Text -> Text -> [Text]
splitOn Text
"," Text
s
            in case [Either Text Text] -> ([Text], [Text])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either Text Text]
addrs of
                ([], [Text]
good) -> [Text] -> Either FormMessage [Text]
forall a b. b -> Either a b
Right [Text]
good
                ([Text]
bad, [Text]
_) -> FormMessage -> Either FormMessage [Text]
forall a b. a -> Either a b
Left (FormMessage -> Either FormMessage [Text])
-> FormMessage -> Either FormMessage [Text]
forall a b. (a -> b) -> a -> b
$ Text -> FormMessage
MsgInvalidEmail (Text -> FormMessage) -> Text -> FormMessage
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 -> (RY (HandlerSite m) -> MarkupM ()) -> WidgetFor (HandlerSite m) ()
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 (ByteString -> Either String EmailAddress)
-> ByteString -> Either String EmailAddress
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 Text
a of
                        Left String
e -> Text -> Either Text Text
forall a b. a -> Either a b
Left (Text -> Either Text Text) -> Text -> Either Text Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat [Text
a, Text
" (",  String -> Text
pack String
e, Text
")"]
                        Right EmailAddress
r -> Text -> Either Text Text
forall a b. b -> Either a b
Right (Text -> Either Text Text) -> Text -> Either Text Text
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 (ByteString -> Text)
-> (EmailAddress -> ByteString) -> EmailAddress -> Text
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 :: Bool -> Field m Text
searchField Bool
autoFocus = Field :: forall (m :: * -> *) a.
([Text]
 -> [FileInfo]
 -> m (Either (SomeMessage (HandlerSite m)) (Maybe a)))
-> FieldViewFunc m a -> Enctype -> Field m a
Field
    { fieldParse :: [Text]
-> [FileInfo]
-> m (Either (SomeMessage (HandlerSite m)) (Maybe Text))
fieldParse = (Text -> Either FormMessage Text)
-> [Text]
-> [FileInfo]
-> m (Either (SomeMessage (HandlerSite m)) (Maybe Text))
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 Text
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}">
|]
        Bool
-> WidgetFor (HandlerSite m) () -> WidgetFor (HandlerSite m) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
autoFocus (WidgetFor (HandlerSite m) () -> WidgetFor (HandlerSite m) ())
-> WidgetFor (HandlerSite m) () -> WidgetFor (HandlerSite m) ()
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();}
|]
          (RY (HandlerSite m) -> Css) -> WidgetFor (HandlerSite m) ()
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 :: Field m Text
urlField = Field :: forall (m :: * -> *) a.
([Text]
 -> [FileInfo]
 -> m (Either (SomeMessage (HandlerSite m)) (Maybe a)))
-> FieldViewFunc m a -> Enctype -> Field m a
Field
    { fieldParse :: [Text]
-> [FileInfo]
-> m (Either (SomeMessage (HandlerSite m)) (Maybe Text))
fieldParse = (Text -> Either FormMessage Text)
-> [Text]
-> [FileInfo]
-> m (Either (SomeMessage (HandlerSite m)) (Maybe Text))
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 Text)
 -> [Text]
 -> [FileInfo]
 -> m (Either (SomeMessage (HandlerSite m)) (Maybe Text)))
-> (Text -> Either FormMessage Text)
-> [Text]
-> [FileInfo]
-> m (Either (SomeMessage (HandlerSite m)) (Maybe Text))
forall a b. (a -> b) -> a -> b
$ \Text
s ->
        case String -> Maybe URI
parseURI (String -> Maybe URI) -> String -> Maybe URI
forall a b. (a -> b) -> a -> b
$ Text -> String
unpack Text
s of
            Maybe URI
Nothing -> FormMessage -> Either FormMessage Text
forall a b. a -> Either a b
Left (FormMessage -> Either FormMessage Text)
-> FormMessage -> Either FormMessage Text
forall a b. (a -> b) -> a -> b
$ Text -> FormMessage
MsgInvalidUrl Text
s
            Just URI
_ -> Text -> Either FormMessage Text
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 :: [(msg, a)] -> Field (HandlerFor site) a
selectFieldList = HandlerFor site (OptionList a) -> Field (HandlerFor site) a
forall a site.
(Eq a, RenderMessage site FormMessage) =>
HandlerFor site (OptionList a) -> Field (HandlerFor site) a
selectField (HandlerFor site (OptionList a) -> Field (HandlerFor site) a)
-> ([(msg, a)] -> HandlerFor site (OptionList a))
-> [(msg, a)]
-> Field (HandlerFor site) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(msg, a)] -> HandlerFor site (OptionList a)
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 :: [(msg, [(msg, a)])] -> Field (HandlerFor site) a
selectFieldListGrouped = HandlerFor site (OptionList a) -> Field (HandlerFor site) a
forall a site.
(Eq a, RenderMessage site FormMessage) =>
HandlerFor site (OptionList a) -> Field (HandlerFor site) a
selectField (HandlerFor site (OptionList a) -> Field (HandlerFor site) a)
-> ([(msg, [(msg, a)])] -> HandlerFor site (OptionList a))
-> [(msg, [(msg, a)])]
-> Field (HandlerFor site) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(msg, [(msg, a)])] -> HandlerFor site (OptionList a)
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 :: HandlerFor site (OptionList a) -> Field (HandlerFor site) a
selectField = (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
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
    ((Text -> WidgetFor site ()) -> Maybe (Text -> WidgetFor site ())
forall a. a -> Maybe a
Just ((Text -> WidgetFor site ()) -> Maybe (Text -> WidgetFor site ()))
-> (Text -> WidgetFor site ()) -> Maybe (Text -> WidgetFor site ())
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 :: [(msg, a)] -> Field (HandlerFor site) [a]
multiSelectFieldList = HandlerFor site (OptionList a) -> Field (HandlerFor site) [a]
forall a site.
Eq a =>
HandlerFor site (OptionList a) -> Field (HandlerFor site) [a]
multiSelectField (HandlerFor site (OptionList a) -> Field (HandlerFor site) [a])
-> ([(msg, a)] -> HandlerFor site (OptionList a))
-> [(msg, a)]
-> Field (HandlerFor site) [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(msg, a)] -> HandlerFor site (OptionList a)
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 :: HandlerFor site (OptionList a) -> Field (HandlerFor site) [a]
multiSelectField HandlerFor site (OptionList a)
ioptlist =
    ([Text]
 -> [FileInfo]
 -> HandlerFor
      site
      (Either (SomeMessage (HandlerSite (HandlerFor site))) (Maybe [a])))
-> FieldViewFunc (HandlerFor site) [a]
-> Enctype
-> Field (HandlerFor site) [a]
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]))
[Text]
-> [FileInfo]
-> HandlerFor
     site
     (Either (SomeMessage (HandlerSite (HandlerFor site))) (Maybe [a]))
parse Text
-> Text
-> [(Text, Text)]
-> Either Text [a]
-> Bool
-> WidgetFor site ()
FieldViewFunc (HandlerFor site) [a]
view Enctype
UrlEncoded
  where
    parse :: [Text]
-> [FileInfo]
-> HandlerFor site (Either (SomeMessage site) (Maybe [a]))
parse [] [FileInfo]
_ = Either (SomeMessage site) (Maybe [a])
-> HandlerFor site (Either (SomeMessage site) (Maybe [a]))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (SomeMessage site) (Maybe [a])
 -> HandlerFor site (Either (SomeMessage site) (Maybe [a])))
-> Either (SomeMessage site) (Maybe [a])
-> HandlerFor site (Either (SomeMessage site) (Maybe [a]))
forall a b. (a -> b) -> a -> b
$ Maybe [a] -> Either (SomeMessage site) (Maybe [a])
forall a b. b -> Either a b
Right Maybe [a]
forall a. Maybe a
Nothing
    parse [Text]
optlist [FileInfo]
_ = do
        Text -> Maybe a
mapopt <- OptionList a -> Text -> Maybe a
forall a. OptionList a -> Text -> Maybe a
olReadExternal (OptionList a -> Text -> Maybe a)
-> HandlerFor site (OptionList a)
-> HandlerFor site (Text -> Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HandlerFor site (OptionList a)
ioptlist
        case (Text -> Maybe a) -> [Text] -> Maybe [a]
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 -> Either (SomeMessage site) (Maybe [a])
-> HandlerFor site (Either (SomeMessage site) (Maybe [a]))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (SomeMessage site) (Maybe [a])
 -> HandlerFor site (Either (SomeMessage site) (Maybe [a])))
-> Either (SomeMessage site) (Maybe [a])
-> HandlerFor site (Either (SomeMessage site) (Maybe [a]))
forall a b. (a -> b) -> a -> b
$ SomeMessage site -> Either (SomeMessage site) (Maybe [a])
forall a b. a -> Either a b
Left SomeMessage site
"Error parsing values"
             Just [a]
res -> Either (SomeMessage site) (Maybe [a])
-> HandlerFor site (Either (SomeMessage site) (Maybe [a]))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (SomeMessage site) (Maybe [a])
 -> HandlerFor site (Either (SomeMessage site) (Maybe [a])))
-> Either (SomeMessage site) (Maybe [a])
-> HandlerFor site (Either (SomeMessage site) (Maybe [a]))
forall a b. (a -> b) -> a -> b
$ Maybe [a] -> Either (SomeMessage site) (Maybe [a])
forall a b. b -> Either a b
Right (Maybe [a] -> Either (SomeMessage site) (Maybe [a]))
-> Maybe [a] -> Either (SomeMessage site) (Maybe [a])
forall a b. (a -> b) -> a -> b
$ [a] -> Maybe [a]
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 <- (OptionList a -> [Option a])
-> WidgetFor site (OptionList a) -> WidgetFor site [Option a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap OptionList a -> [Option a]
forall a. OptionList a -> [Option a]
olOptions (WidgetFor site (OptionList a) -> WidgetFor site [Option a])
-> WidgetFor site (OptionList a) -> WidgetFor site [Option a]
forall a b. (a -> b) -> a -> b
$ HandlerFor site (OptionList a) -> WidgetFor site (OptionList a)
forall site a. HandlerFor site a -> WidgetFor site a
handlerToWidget HandlerFor site (OptionList a)
ioptlist
        let selOpts :: [(Option a, Bool)]
selOpts = (Option a -> (Option a, Bool)) -> [Option a] -> [(Option a, Bool)]
forall a b. (a -> b) -> [a] -> [b]
map (Option a -> Option a
forall a. a -> a
id (Option a -> Option a)
-> (Option a -> Bool) -> Option a -> (Option a, Bool)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (Either Text [a] -> Option a -> Bool
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 = (Option a -> a
forall a. Option a -> a
optionInternalValue Option a
opt) a -> t a -> Bool
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 :: [(msg, a)] -> Field (HandlerFor site) a
radioFieldList = HandlerFor site (OptionList a) -> Field (HandlerFor site) a
forall a site.
(Eq a, RenderMessage site FormMessage) =>
HandlerFor site (OptionList a) -> Field (HandlerFor site) a
radioField (HandlerFor site (OptionList a) -> Field (HandlerFor site) a)
-> ([(msg, a)] -> HandlerFor site (OptionList a))
-> [(msg, a)]
-> Field (HandlerFor site) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(msg, a)] -> HandlerFor site (OptionList a)
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 :: [(msg, a)] -> Field (HandlerFor site) [a]
checkboxesFieldList = HandlerFor site (OptionList a) -> Field (HandlerFor site) [a]
forall a site.
Eq a =>
HandlerFor site (OptionList a) -> Field (HandlerFor site) [a]
checkboxesField (HandlerFor site (OptionList a) -> Field (HandlerFor site) [a])
-> ([(msg, a)] -> HandlerFor site (OptionList a))
-> [(msg, a)]
-> Field (HandlerFor site) [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(msg, a)] -> HandlerFor site (OptionList a)
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 :: HandlerFor site (OptionList a) -> Field (HandlerFor site) [a]
checkboxesField HandlerFor site (OptionList a)
ioptlist = (HandlerFor site (OptionList a) -> Field (HandlerFor site) [a]
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 <- (OptionList a -> [Option a])
-> WidgetFor site (OptionList a) -> WidgetFor site [Option a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap OptionList a -> [Option a]
forall a. OptionList a -> [Option a]
olOptions (WidgetFor site (OptionList a) -> WidgetFor site [Option a])
-> WidgetFor site (OptionList a) -> WidgetFor site [Option a]
forall a b. (a -> b) -> a -> b
$ HandlerFor site (OptionList a) -> WidgetFor site (OptionList a)
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 = (Option a -> a
forall a. Option a -> a
optionInternalValue Option a
opt) a -> t a -> Bool
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 :: HandlerFor site (OptionList a) -> Field (HandlerFor site) a
radioField = (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
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
<div ##{theId}>^{inside}
|])
    (\Text
theId Text
name Bool
isSel -> [whamlet|
$newline never
<label .radio for=#{theId}-none>
    <div>
        <input id=#{theId}-none type=radio name=#{name} value=none :isSel:checked>
        _{MsgSelectNone}
|])
    (\Text
theId Text
name [(Text, Text)]
attrs Text
value Bool
isSel Text
text -> [whamlet|
$newline never
<label .radio for=#{theId}-#{value}>
    <div>
        <input id=#{theId}-#{value} type=radio name=#{name} value=#{value} :isSel:checked *{attrs}>
        \#{text}
|])
     Maybe (Text -> WidgetFor site ())
forall a. Maybe a
Nothing

-- | 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 :: Field m Bool
boolField = Field :: forall (m :: * -> *) a.
([Text]
 -> [FileInfo]
 -> m (Either (SomeMessage (HandlerSite m)) (Maybe a)))
-> FieldViewFunc m a -> Enctype -> Field m a
Field
      { fieldParse :: [Text]
-> [FileInfo]
-> m (Either (SomeMessage (HandlerSite m)) (Maybe Bool))
fieldParse = \[Text]
e [FileInfo]
_ -> Either (SomeMessage (HandlerSite m)) (Maybe Bool)
-> m (Either (SomeMessage (HandlerSite m)) (Maybe Bool))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (SomeMessage (HandlerSite m)) (Maybe Bool)
 -> m (Either (SomeMessage (HandlerSite m)) (Maybe Bool)))
-> Either (SomeMessage (HandlerSite m)) (Maybe Bool)
-> m (Either (SomeMessage (HandlerSite m)) (Maybe Bool))
forall a b. (a -> b) -> a -> b
$ [Text] -> Either (SomeMessage (HandlerSite m)) (Maybe Bool)
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 [] = Maybe Bool -> Either (SomeMessage master) (Maybe Bool)
forall a b. b -> Either a b
Right Maybe Bool
forall a. Maybe a
Nothing
    boolParser (Text
x:[Text]
_) = case Text
x of
      Text
"" -> Maybe Bool -> Either (SomeMessage master) (Maybe Bool)
forall a b. b -> Either a b
Right Maybe Bool
forall a. Maybe a
Nothing
      Text
"none" -> Maybe Bool -> Either (SomeMessage master) (Maybe Bool)
forall a b. b -> Either a b
Right Maybe Bool
forall a. Maybe a
Nothing
      Text
"yes" -> Maybe Bool -> Either (SomeMessage master) (Maybe Bool)
forall a b. b -> Either a b
Right (Maybe Bool -> Either (SomeMessage master) (Maybe Bool))
-> Maybe Bool -> Either (SomeMessage master) (Maybe Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
      Text
"on" -> Maybe Bool -> Either (SomeMessage master) (Maybe Bool)
forall a b. b -> Either a b
Right (Maybe Bool -> Either (SomeMessage master) (Maybe Bool))
-> Maybe Bool -> Either (SomeMessage master) (Maybe Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
      Text
"no" -> Maybe Bool -> Either (SomeMessage master) (Maybe Bool)
forall a b. b -> Either a b
Right (Maybe Bool -> Either (SomeMessage master) (Maybe Bool))
-> Maybe Bool -> Either (SomeMessage master) (Maybe Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
      Text
"true" -> Maybe Bool -> Either (SomeMessage master) (Maybe Bool)
forall a b. b -> Either a b
Right (Maybe Bool -> Either (SomeMessage master) (Maybe Bool))
-> Maybe Bool -> Either (SomeMessage master) (Maybe Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
      Text
"false" -> Maybe Bool -> Either (SomeMessage master) (Maybe Bool)
forall a b. b -> Either a b
Right (Maybe Bool -> Either (SomeMessage master) (Maybe Bool))
-> Maybe Bool -> Either (SomeMessage master) (Maybe Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
      Text
t -> SomeMessage master -> Either (SomeMessage master) (Maybe Bool)
forall a b. a -> Either a b
Left (SomeMessage master -> Either (SomeMessage master) (Maybe Bool))
-> SomeMessage master -> Either (SomeMessage master) (Maybe Bool)
forall a b. (a -> b) -> a -> b
$ FormMessage -> SomeMessage master
forall master msg.
RenderMessage master msg =>
msg -> SomeMessage master
SomeMessage (FormMessage -> SomeMessage master)
-> FormMessage -> SomeMessage master
forall a b. (a -> b) -> a -> b
$ Text -> FormMessage
MsgInvalidBool Text
t
    showVal :: (b -> Bool) -> Either a b -> Bool
showVal = (a -> Bool) -> (b -> Bool) -> Either a b -> Bool
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 :: Field m Bool
checkBoxField = Field :: forall (m :: * -> *) a.
([Text]
 -> [FileInfo]
 -> m (Either (SomeMessage (HandlerSite m)) (Maybe a)))
-> FieldViewFunc m a -> Enctype -> Field m a
Field
    { fieldParse :: [Text]
-> [FileInfo]
-> m (Either (SomeMessage (HandlerSite m)) (Maybe Bool))
fieldParse = \[Text]
e [FileInfo]
_ -> Either (SomeMessage (HandlerSite m)) (Maybe Bool)
-> m (Either (SomeMessage (HandlerSite m)) (Maybe Bool))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (SomeMessage (HandlerSite m)) (Maybe Bool)
 -> m (Either (SomeMessage (HandlerSite m)) (Maybe Bool)))
-> Either (SomeMessage (HandlerSite m)) (Maybe Bool)
-> m (Either (SomeMessage (HandlerSite m)) (Maybe Bool))
forall a b. (a -> b) -> a -> b
$ [Text] -> Either (SomeMessage (HandlerSite m)) (Maybe Bool)
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 [] = Maybe Bool -> Either a (Maybe Bool)
forall a b. b -> Either a b
Right (Maybe Bool -> Either a (Maybe Bool))
-> Maybe Bool -> Either a (Maybe Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
        checkBoxParser (a
x:[a]
_) = case a
x of
            a
"yes" -> Maybe Bool -> Either a (Maybe Bool)
forall a b. b -> Either a b
Right (Maybe Bool -> Either a (Maybe Bool))
-> Maybe Bool -> Either a (Maybe Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
            a
"on" -> Maybe Bool -> Either a (Maybe Bool)
forall a b. b -> Either a b
Right (Maybe Bool -> Either a (Maybe Bool))
-> Maybe Bool -> Either a (Maybe Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
            a
_     -> Maybe Bool -> Either a (Maybe Bool)
forall a b. b -> Either a b
Right (Maybe Bool -> Either a (Maybe Bool))
-> Maybe Bool -> Either a (Maybe Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False

        showVal :: (b -> Bool) -> Either a b -> Bool
showVal = (a -> Bool) -> (b -> Bool) -> Either a b -> Bool
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
    { OptionList a -> [Option a]
olOptions :: [Option 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
    { OptionList a -> [(Text, [Option a])]
olOptionsGrouped :: [(Text, [Option 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 :: OptionList a -> OptionList a
flattenOptionList (OptionListGrouped [(Text, [Option a])]
os Text -> Maybe a
re) = [Option a] -> (Text -> Maybe a) -> OptionList a
forall a. [Option a] -> (Text -> Maybe a) -> OptionList a
OptionList (((Text, [Option a]) -> [Option a])
-> [(Text, [Option a])] -> [Option a]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Text, [Option a]) -> [Option a]
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 :: (a -> b) -> OptionList a -> OptionList b
fmap a -> b
f (OptionList [Option a]
options Text -> Maybe a
readExternal) =
      [Option b] -> (Text -> Maybe b) -> OptionList b
forall a. [Option a] -> (Text -> Maybe a) -> OptionList a
OptionList (((Option a -> Option b) -> [Option a] -> [Option b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap((Option a -> Option b) -> [Option a] -> [Option b])
-> ((a -> b) -> Option a -> Option b)
-> (a -> b)
-> [Option a]
-> [Option b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(a -> b) -> Option a -> Option b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) a -> b
f [Option a]
options) ((a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (Maybe a -> Maybe b) -> (Text -> Maybe a) -> Text -> Maybe b
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) =
      [(Text, [Option b])] -> (Text -> Maybe b) -> OptionList b
forall a. [(Text, [Option a])] -> (Text -> Maybe a) -> OptionList a
OptionListGrouped (((Text, [Option a]) -> (Text, [Option b]))
-> [(Text, [Option a])] -> [(Text, [Option b])]
forall a b. (a -> b) -> [a] -> [b]
map (\(Text
g, [Option a]
os) -> (Text
g, ((Option a -> Option b) -> [Option a] -> [Option b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap((Option a -> Option b) -> [Option a] -> [Option b])
-> ((a -> b) -> Option a -> Option b)
-> (a -> b)
-> [Option a]
-> [Option b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(a -> b) -> Option a -> Option b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) a -> b
f [Option a]
os)) [(Text, [Option a])]
options) ((a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (Maybe a -> Maybe b) -> (Text -> Maybe a) -> Text -> Maybe b
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 :: [Option a] -> OptionList a
mkOptionList [Option a]
os = OptionList :: forall a. [Option a] -> (Text -> Maybe a) -> OptionList a
OptionList
    { olOptions :: [Option a]
olOptions = [Option a]
os
    , olReadExternal :: Text -> Maybe a
olReadExternal = (Text -> Map Text a -> Maybe a) -> Map Text a -> Text -> Maybe a
forall a b c. (a -> b -> c) -> b -> a -> c
flip Text -> Map Text a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Map Text a -> Text -> Maybe a) -> Map Text a -> Text -> Maybe a
forall a b. (a -> b) -> a -> b
$ [(Text, a)] -> Map Text a
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Text, a)] -> Map Text a) -> [(Text, a)] -> Map Text a
forall a b. (a -> b) -> a -> b
$ (Option a -> (Text, a)) -> [Option a] -> [(Text, a)]
forall a b. (a -> b) -> [a] -> [b]
map (Option a -> Text
forall a. Option a -> Text
optionExternalValue (Option a -> Text) -> (Option a -> a) -> Option a -> (Text, a)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Option a -> a
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 :: [(Text, [Option a])] -> OptionList a
mkOptionListGrouped [(Text, [Option a])]
os = OptionListGrouped :: forall a. [(Text, [Option a])] -> (Text -> Maybe a) -> OptionList a
OptionListGrouped
    { olOptionsGrouped :: [(Text, [Option a])]
olOptionsGrouped = [(Text, [Option a])]
os
    , olReadExternalGrouped :: Text -> Maybe a
olReadExternalGrouped = (Text -> Map Text a -> Maybe a) -> Map Text a -> Text -> Maybe a
forall a b c. (a -> b -> c) -> b -> a -> c
flip Text -> Map Text a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Map Text a -> Text -> Maybe a) -> Map Text a -> Text -> Maybe a
forall a b. (a -> b) -> a -> b
$ [(Text, a)] -> Map Text a
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Text, a)] -> Map Text a) -> [(Text, a)] -> Map Text a
forall a b. (a -> b) -> a -> b
$ (Option a -> (Text, a)) -> [Option a] -> [(Text, a)]
forall a b. (a -> b) -> [a] -> [b]
map (Option a -> Text
forall a. Option a -> Text
optionExternalValue (Option a -> Text) -> (Option a -> a) -> Option a -> (Text, a)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Option a -> a
forall a. Option a -> a
optionInternalValue) ([Option a] -> [(Text, a)]) -> [Option a] -> [(Text, a)]
forall a b. (a -> b) -> a -> b
$ ((Text, [Option a]) -> [Option a])
-> [(Text, [Option a])] -> [Option a]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Text, [Option a]) -> [Option a]
forall a b. (a, b) -> b
snd [(Text, [Option a])]
os
    }

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

-- | @since 1.4.6
instance Functor Option where
    fmap :: (a -> b) -> Option a -> Option b
fmap a -> b
f (Option Text
display a
internal Text
external) = Text -> b -> Text -> Option b
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 :: [(msg, a)] -> m (OptionList a)
optionsPairs [(msg, a)]
opts = do
  msg -> Text
mr <- m (msg -> Text)
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 :: forall a. Text -> a -> Text -> Option a
Option { optionDisplay :: Text
optionDisplay       = msg -> Text
mr msg
display
                 , optionInternalValue :: a
optionInternalValue = a
internal
                 , optionExternalValue :: Text
optionExternalValue = String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
external
                 }
  OptionList a -> m (OptionList a)
forall (m :: * -> *) a. Monad m => a -> m a
return (OptionList a -> m (OptionList a))
-> OptionList a -> m (OptionList a)
forall a b. (a -> b) -> a -> b
$ [Option a] -> OptionList a
forall a. [Option a] -> OptionList a
mkOptionList ((Int -> (msg, a) -> Option a) -> [Int] -> [(msg, a)] -> [Option a]
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 :: [(msg, [(msg, a)])] -> m (OptionList a)
optionsPairsGrouped [(msg, [(msg, a)])]
opts = do
  msg -> Text
mr <- m (msg -> Text)
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 :: forall a. Text -> a -> Text -> Option a
Option { optionDisplay :: Text
optionDisplay       = msg -> Text
mr msg
display
                 , optionInternalValue :: a
optionInternalValue = a
internal
                 , optionExternalValue :: Text
optionExternalValue = String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
external
                 }
      opts' :: [(msg, [(Int, (msg, a))])]
opts' = [(msg, [(msg, a)])] -> [(msg, [(Int, (msg, a))])]
forall a b. [(a, [b])] -> [(a, [(Int, b)])]
enumerateSublists [(msg, [(msg, a)])]
opts :: [(msg, [(Int, (msg, a))])]
      opts'' :: [(Text, [Option a])]
opts'' = ((msg, [(Int, (msg, a))]) -> (Text, [Option a]))
-> [(msg, [(Int, (msg, a))])] -> [(Text, [Option a])]
forall a b. (a -> b) -> [a] -> [b]
map (\(msg
x, [(Int, (msg, a))]
ys) -> (msg -> Text
mr msg
x, ((Int, (msg, a)) -> Option a) -> [(Int, (msg, a))] -> [Option a]
forall a b. (a -> b) -> [a] -> [b]
map (Int, (msg, a)) -> Option a
mkOption [(Int, (msg, a))]
ys)) [(msg, [(Int, (msg, a))])]
opts'
  OptionList a -> m (OptionList a)
forall (m :: * -> *) a. Monad m => a -> m a
return (OptionList a -> m (OptionList a))
-> OptionList a -> m (OptionList a)
forall a b. (a -> b) -> a -> b
$ [(Text, [Option a])] -> OptionList a
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 :: [(a, [b])] -> [(a, [(Int, b)])]
enumerateSublists [(a, [b])]
xss =
  let yss :: [(Int, (a, [b]))]
      yss :: [(Int, (a, [b]))]
yss = (Int, [(Int, (a, [b]))]) -> [(Int, (a, [b]))]
forall a b. (a, b) -> b
snd ((Int, [(Int, (a, [b]))]) -> [(Int, (a, [b]))])
-> (Int, [(Int, (a, [b]))]) -> [(Int, (a, [b]))]
forall a b. (a -> b) -> a -> b
$ ((Int, [(Int, (a, [b]))]) -> (a, [b]) -> (Int, [(Int, (a, [b]))]))
-> (Int, [(Int, (a, [b]))])
-> [(a, [b])]
-> (Int, [(Int, (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 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ([b] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length([b] -> Int) -> ((a, [b]) -> [b]) -> (a, [b]) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(a, [b]) -> [b]
forall a b. (a, b) -> b
snd) (a, [b])
xs, [(Int, (a, [b]))]
res [(Int, (a, [b]))] -> [(Int, (a, [b]))] -> [(Int, (a, [b]))]
forall a. [a] -> [a] -> [a]
++ [(Int
i, (a, [b])
xs)])) (Int
1, []) [(a, [b])]
xss
   in ((Int, (a, [b])) -> (a, [(Int, b)]))
-> [(Int, (a, [b]))] -> [(a, [(Int, b)])]
forall a b. (a -> b) -> [a] -> [b]
map (\(Int
i, (a
x, [b]
ys)) -> (a
x, [Int] -> [b] -> [(Int, b)]
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 :: m (OptionList a)
optionsEnum = [(Text, a)] -> m (OptionList a)
forall (m :: * -> *) msg a.
(MonadHandler m, RenderMessage (HandlerSite m) msg) =>
[(msg, a)] -> m (OptionList a)
optionsPairs ([(Text, a)] -> m (OptionList a))
-> [(Text, a)] -> m (OptionList a)
forall a b. (a -> b) -> a -> b
$ (a -> (Text, a)) -> [a] -> [(Text, a)]
forall a b. (a -> b) -> [a] -> [b]
map (\a
x -> (String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ a -> String
forall a. Show a => a -> String
show a
x, a
x)) [a
forall a. Bounded a => a
minBound..a
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 :: [Filter a]
-> [SelectOpt a]
-> (a -> msg)
-> HandlerFor site (OptionList (Entity a))
optionsPersist [Filter a]
filts [SelectOpt a]
ords a -> msg
toDisplay = ([Option (Entity a)] -> OptionList (Entity a))
-> HandlerFor site [Option (Entity a)]
-> HandlerFor site (OptionList (Entity a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Option (Entity a)] -> OptionList (Entity a)
forall a. [Option a] -> OptionList a
mkOptionList (HandlerFor site [Option (Entity a)]
 -> HandlerFor site (OptionList (Entity a)))
-> HandlerFor site [Option (Entity a)]
-> HandlerFor site (OptionList (Entity a))
forall a b. (a -> b) -> a -> b
$ do
    msg -> Text
mr <- HandlerFor site (msg -> Text)
forall (m :: * -> *) message.
(MonadHandler m, RenderMessage (HandlerSite m) message) =>
m (message -> Text)
getMessageRender
    [Entity a]
pairs <- YesodDB site [Entity a] -> HandlerFor site [Entity a]
forall site a.
YesodPersist site =>
YesodDB site a -> HandlerFor site a
runDB (YesodDB site [Entity a] -> HandlerFor site [Entity a])
-> YesodDB site [Entity a] -> HandlerFor site [Entity a]
forall a b. (a -> b) -> a -> b
$ [Filter a]
-> [SelectOpt a] -> ReaderT backend (HandlerFor site) [Entity a]
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
    [Option (Entity a)] -> HandlerFor site [Option (Entity a)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Option (Entity a)] -> HandlerFor site [Option (Entity a)])
-> [Option (Entity a)] -> HandlerFor site [Option (Entity a)]
forall a b. (a -> b) -> a -> b
$ (Entity a -> Option (Entity a))
-> [Entity a] -> [Option (Entity a)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Entity Key a
key a
value) -> Option :: forall a. Text -> a -> Text -> Option a
Option
        { optionDisplay :: Text
optionDisplay = msg -> Text
mr (a -> msg
toDisplay a
value)
        , optionInternalValue :: Entity a
optionInternalValue = Key a -> a -> Entity a
forall record. Key record -> record -> Entity record
Entity Key a
key a
value
        , optionExternalValue :: Text
optionExternalValue = Key a -> Text
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 :: [Filter a]
-> [SelectOpt a]
-> (a -> msg)
-> HandlerFor site (OptionList (Key a))
optionsPersistKey [Filter a]
filts [SelectOpt a]
ords a -> msg
toDisplay = ([Option (Key a)] -> OptionList (Key a))
-> HandlerFor site [Option (Key a)]
-> HandlerFor site (OptionList (Key a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Option (Key a)] -> OptionList (Key a)
forall a. [Option a] -> OptionList a
mkOptionList (HandlerFor site [Option (Key a)]
 -> HandlerFor site (OptionList (Key a)))
-> HandlerFor site [Option (Key a)]
-> HandlerFor site (OptionList (Key a))
forall a b. (a -> b) -> a -> b
$ do
    msg -> Text
mr <- HandlerFor site (msg -> Text)
forall (m :: * -> *) message.
(MonadHandler m, RenderMessage (HandlerSite m) message) =>
m (message -> Text)
getMessageRender
    [Entity a]
pairs <- YesodDB site [Entity a] -> HandlerFor site [Entity a]
forall site a.
YesodPersist site =>
YesodDB site a -> HandlerFor site a
runDB (YesodDB site [Entity a] -> HandlerFor site [Entity a])
-> YesodDB site [Entity a] -> HandlerFor site [Entity a]
forall a b. (a -> b) -> a -> b
$ [Filter a]
-> [SelectOpt a] -> ReaderT backend (HandlerFor site) [Entity a]
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
    [Option (Key a)] -> HandlerFor site [Option (Key a)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Option (Key a)] -> HandlerFor site [Option (Key a)])
-> [Option (Key a)] -> HandlerFor site [Option (Key a)]
forall a b. (a -> b) -> a -> b
$ (Entity a -> Option (Key a)) -> [Entity a] -> [Option (Key a)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Entity Key a
key a
value) -> Option :: forall a. Text -> a -> Text -> Option a
Option
        { optionDisplay :: Text
optionDisplay = msg -> Text
mr (a -> msg
toDisplay a
value)
        , optionInternalValue :: Key a
optionInternalValue = Key a
key
        , optionExternalValue :: Text
optionExternalValue = Key a -> Text
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 :: (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 :: forall (m :: * -> *) a.
([Text]
 -> [FileInfo]
 -> m (Either (SomeMessage (HandlerSite m)) (Maybe a)))
-> FieldViewFunc m a -> Enctype -> Field m a
Field
    { fieldParse :: [Text]
-> [FileInfo]
-> HandlerFor
     site
     (Either (SomeMessage (HandlerSite (HandlerFor site))) (Maybe a))
fieldParse = \[Text]
x [FileInfo]
_ -> do
        OptionList a
opts <- (OptionList a -> OptionList a)
-> HandlerFor site (OptionList a) -> HandlerFor site (OptionList a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap OptionList a -> OptionList a
forall a. OptionList a -> OptionList a
flattenOptionList HandlerFor site (OptionList a)
opts'
        Either (SomeMessage site) (Maybe a)
-> HandlerFor site (Either (SomeMessage site) (Maybe a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (SomeMessage site) (Maybe a)
 -> HandlerFor site (Either (SomeMessage site) (Maybe a)))
-> Either (SomeMessage site) (Maybe a)
-> HandlerFor site (Either (SomeMessage site) (Maybe a))
forall a b. (a -> b) -> a -> b
$ OptionList a -> [Text] -> Either (SomeMessage site) (Maybe a)
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 (WidgetFor site () -> WidgetFor site ())
-> WidgetFor site () -> WidgetFor site ()
forall a b. (a -> b) -> a -> b
$ do
          [Option a]
optsFlat <- (OptionList a -> [Option a])
-> WidgetFor site (OptionList a) -> WidgetFor site [Option a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (OptionList a -> [Option a]
forall a. OptionList a -> [Option a]
olOptions(OptionList a -> [Option a])
-> (OptionList a -> OptionList a) -> OptionList a -> [Option a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.OptionList a -> OptionList a
forall a. OptionList a -> OptionList a
flattenOptionList) (WidgetFor site (OptionList a) -> WidgetFor site [Option a])
-> WidgetFor site (OptionList a) -> WidgetFor site [Option a]
forall a b. (a -> b) -> a -> b
$ HandlerFor site (OptionList a) -> WidgetFor site (OptionList a)
forall site a. HandlerFor site a -> WidgetFor site a
handlerToWidget HandlerFor site (OptionList a)
opts'
          Bool -> WidgetFor site () -> WidgetFor site ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
isReq (WidgetFor site () -> WidgetFor site ())
-> WidgetFor site () -> WidgetFor site ()
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Bool -> WidgetFor site ()
onOpt Text
theId Text
name (Bool -> WidgetFor site ()) -> Bool -> WidgetFor site ()
forall a b. (a -> b) -> a -> b
$ [Option a] -> Either Text a -> Text
forall a. Eq a => [Option a] -> Either Text a -> Text
render [Option a]
optsFlat Either Text a
val Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` (Option a -> Text) -> [Option a] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Option a -> Text
forall a. Option a -> Text
optionExternalValue [Option a]
optsFlat
          OptionList a
opts'' <- HandlerFor site (OptionList a) -> WidgetFor site (OptionList a)
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
                  [(Text, [Option a])]
-> ((Text, [Option a]) -> WidgetFor site ()) -> WidgetFor site ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Text, [Option a])]
grps (((Text, [Option a]) -> WidgetFor site ()) -> WidgetFor site ())
-> ((Text, [Option a]) -> WidgetFor site ()) -> WidgetFor site ()
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 -> () -> WidgetFor site ()
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 a] -> Either Text a -> Text
render [Option a]
_ (Left Text
x) = Text
x
    render [Option a]
opts (Right a
a) = Text -> (Option a -> Text) -> Maybe (Option a) -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" Option a -> Text
forall a. Option a -> Text
optionExternalValue (Maybe (Option a) -> Text) -> Maybe (Option a) -> Text
forall a b. (a -> b) -> a -> b
$ [Option a] -> Maybe (Option a)
forall a. [a] -> Maybe a
listToMaybe ([Option a] -> Maybe (Option a)) -> [Option a] -> Maybe (Option a)
forall a b. (a -> b) -> a -> b
$ (Option a -> Bool) -> [Option a] -> [Option a]
forall a. (a -> Bool) -> [a] -> [a]
filter ((a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
a) (a -> Bool) -> (Option a -> a) -> Option a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Option a -> a
forall a. Option a -> a
optionInternalValue) [Option a]
opts
    selectParser :: OptionList a -> [Text] -> Either (SomeMessage master) (Maybe a)
selectParser OptionList a
_ [] = Maybe a -> Either (SomeMessage master) (Maybe a)
forall a b. b -> Either a b
Right Maybe a
forall a. Maybe a
Nothing
    selectParser OptionList a
opts (Text
s:[Text]
_) = case Text
s of
            Text
"" -> Maybe a -> Either (SomeMessage master) (Maybe a)
forall a b. b -> Either a b
Right Maybe a
forall a. Maybe a
Nothing
            Text
"none" -> Maybe a -> Either (SomeMessage master) (Maybe a)
forall a b. b -> Either a b
Right Maybe a
forall a. Maybe a
Nothing
            Text
x -> case OptionList a -> Text -> Maybe a
forall a. OptionList a -> Text -> Maybe a
olReadExternal OptionList a
opts Text
x of
                    Maybe a
Nothing -> SomeMessage master -> Either (SomeMessage master) (Maybe a)
forall a b. a -> Either a b
Left (SomeMessage master -> Either (SomeMessage master) (Maybe a))
-> SomeMessage master -> Either (SomeMessage master) (Maybe a)
forall a b. (a -> b) -> a -> b
$ FormMessage -> SomeMessage master
forall master msg.
RenderMessage master msg =>
msg -> SomeMessage master
SomeMessage (FormMessage -> SomeMessage master)
-> FormMessage -> SomeMessage master
forall a b. (a -> b) -> a -> b
$ Text -> FormMessage
MsgInvalidEntry Text
x
                    Just a
y -> Maybe a -> Either (SomeMessage master) (Maybe a)
forall a b. b -> Either a b
Right (Maybe a -> Either (SomeMessage master) (Maybe a))
-> Maybe a -> Either (SomeMessage master) (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
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 =
      [Option a] -> (Option a -> WidgetFor site ()) -> WidgetFor site ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Option a]
opts ((Option a -> WidgetFor site ()) -> WidgetFor site ())
-> (Option a -> WidgetFor site ()) -> WidgetFor site ()
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")(Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
:) else [(Text, Text)] -> [(Text, Text)]
forall a. a -> a
id) [(Text, Text)]
attrs)
                           (Option a -> Text
forall a. Option a -> Text
optionExternalValue Option a
opt)
                           ([Option a] -> Either Text a -> Text
forall a. Eq a => [Option a] -> Either Text a -> Text
render [Option a]
opts Either Text a
val Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Option a -> Text
forall a. Option a -> Text
optionExternalValue Option a
opt)
                           (Option a -> Text
forall a. Option a -> Text
optionDisplay Option a
opt)

-- | Creates an input with @type="file"@.
fileField :: Monad m
          => Field m FileInfo
fileField :: Field m FileInfo
fileField = Field :: forall (m :: * -> *) a.
([Text]
 -> [FileInfo]
 -> m (Either (SomeMessage (HandlerSite m)) (Maybe a)))
-> FieldViewFunc m a -> Enctype -> Field m a
Field
    { fieldParse :: [Text]
-> [FileInfo]
-> m (Either (SomeMessage (HandlerSite m)) (Maybe FileInfo))
fieldParse = \[Text]
_ [FileInfo]
files -> Either (SomeMessage (HandlerSite m)) (Maybe FileInfo)
-> m (Either (SomeMessage (HandlerSite m)) (Maybe FileInfo))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (SomeMessage (HandlerSite m)) (Maybe FileInfo)
 -> m (Either (SomeMessage (HandlerSite m)) (Maybe FileInfo)))
-> Either (SomeMessage (HandlerSite m)) (Maybe FileInfo)
-> m (Either (SomeMessage (HandlerSite m)) (Maybe FileInfo))
forall a b. (a -> b) -> a -> b
$
        case [FileInfo]
files of
            [] -> Maybe FileInfo
-> Either (SomeMessage (HandlerSite m)) (Maybe FileInfo)
forall a b. b -> Either a b
Right Maybe FileInfo
forall a. Maybe a
Nothing
            FileInfo
file:[FileInfo]
_ -> Maybe FileInfo
-> Either (SomeMessage (HandlerSite m)) (Maybe FileInfo)
forall a b. b -> Either a b
Right (Maybe FileInfo
 -> Either (SomeMessage (HandlerSite m)) (Maybe FileInfo))
-> Maybe FileInfo
-> Either (SomeMessage (HandlerSite m)) (Maybe FileInfo)
forall a b. (a -> b) -> a -> b
$ FileInfo -> Maybe FileInfo
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 -> (RY (HandlerSite m) -> MarkupM ()) -> WidgetFor (HandlerSite m) ()
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 :: FieldSettings (HandlerSite m) -> AForm m FileInfo
fileAFormReq FieldSettings (HandlerSite m)
fs = ((HandlerSite m, [Text])
 -> Maybe (Env, FileEnv)
 -> Ints
 -> m (FormResult FileInfo,
       [FieldView (HandlerSite m)] -> [FieldView (HandlerSite m)], Ints,
       Enctype))
-> AForm m FileInfo
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 (((HandlerSite m, [Text])
  -> Maybe (Env, FileEnv)
  -> Ints
  -> m (FormResult FileInfo,
        [FieldView (HandlerSite m)] -> [FieldView (HandlerSite m)], Ints,
        Enctype))
 -> AForm m FileInfo)
-> ((HandlerSite m, [Text])
    -> Maybe (Env, FileEnv)
    -> Ints
    -> m (FormResult FileInfo,
          [FieldView (HandlerSite m)] -> [FieldView (HandlerSite m)], Ints,
          Enctype))
-> AForm m FileInfo
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 FieldSettings (HandlerSite m) -> Maybe Text
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 (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Char
'f' Char -> ShowS
forall a. a -> [a] -> [a]
: Ints -> String
forall a. Show a => a -> String
show Ints
i', Ints
i')
    Text
id' <- m Text -> (Text -> m Text) -> Maybe Text -> m Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m Text
forall (m :: * -> *). MonadHandler m => m Text
newIdent Text -> m Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Text -> m Text) -> Maybe Text -> m Text
forall a b. (a -> b) -> a -> b
$ FieldSettings (HandlerSite m) -> Maybe Text
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 -> (FormResult FileInfo
forall a. FormResult a
FormMissing, Maybe (MarkupM ())
forall a. Maybe a
Nothing)
                Just (Env
_, FileEnv
fenv) ->
                    case Text -> FileEnv -> Maybe [FileInfo]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
name FileEnv
fenv of
                        Just (FileInfo
fi:[FileInfo]
_) -> (FileInfo -> FormResult FileInfo
forall a. a -> FormResult a
FormSuccess FileInfo
fi, Maybe (MarkupM ())
forall a. Maybe a
Nothing)
                        Maybe [FileInfo]
_ ->
                            let t :: Text
t = HandlerSite m -> [Text] -> FormMessage -> Text
forall master message.
RenderMessage master message =>
master -> [Text] -> message -> Text
renderMessage HandlerSite m
site [Text]
langs FormMessage
MsgValueRequired
                             in ([Text] -> FormResult FileInfo
forall a. [Text] -> FormResult a
FormFailure [Text
t], MarkupM () -> Maybe (MarkupM ())
forall a. a -> Maybe a
Just (MarkupM () -> Maybe (MarkupM ()))
-> MarkupM () -> Maybe (MarkupM ())
forall a b. (a -> b) -> a -> b
$ toHtml t)
    let fv :: FieldView (HandlerSite m)
fv = FieldView :: forall site.
MarkupM ()
-> Maybe (MarkupM ())
-> Text
-> WidgetFor site ()
-> Maybe (MarkupM ())
-> Bool
-> FieldView site
FieldView
            { fvLabel :: MarkupM ()
fvLabel = toHtml $ renderMessage site langs $ fsLabel fs
            , fvTooltip :: Maybe (MarkupM ())
fvTooltip = (SomeMessage (HandlerSite m) -> MarkupM ())
-> Maybe (SomeMessage (HandlerSite m)) -> Maybe (MarkupM ())
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
            }
    (FormResult FileInfo,
 [FieldView (HandlerSite m)] -> [FieldView (HandlerSite m)], Ints,
 Enctype)
-> m (FormResult FileInfo,
      [FieldView (HandlerSite m)] -> [FieldView (HandlerSite m)], Ints,
      Enctype)
forall (m :: * -> *) a. Monad m => a -> m a
return (FormResult FileInfo
res, (FieldView (HandlerSite m)
fv FieldView (HandlerSite m)
-> [FieldView (HandlerSite m)] -> [FieldView (HandlerSite m)]
forall a. a -> [a] -> [a]
:), Ints
ints', Enctype
Multipart)

fileAFormOpt :: MonadHandler m
             => FieldSettings (HandlerSite m)
             -> AForm m (Maybe FileInfo)
fileAFormOpt :: FieldSettings (HandlerSite m) -> AForm m (Maybe FileInfo)
fileAFormOpt FieldSettings (HandlerSite m)
fs = ((HandlerSite m, [Text])
 -> Maybe (Env, FileEnv)
 -> Ints
 -> m (FormResult (Maybe FileInfo),
       [FieldView (HandlerSite m)] -> [FieldView (HandlerSite m)], Ints,
       Enctype))
-> AForm m (Maybe FileInfo)
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 (((HandlerSite m, [Text])
  -> Maybe (Env, FileEnv)
  -> Ints
  -> m (FormResult (Maybe FileInfo),
        [FieldView (HandlerSite m)] -> [FieldView (HandlerSite m)], Ints,
        Enctype))
 -> AForm m (Maybe FileInfo))
-> ((HandlerSite m, [Text])
    -> Maybe (Env, FileEnv)
    -> Ints
    -> m (FormResult (Maybe FileInfo),
          [FieldView (HandlerSite m)] -> [FieldView (HandlerSite m)], Ints,
          Enctype))
-> AForm m (Maybe FileInfo)
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 FieldSettings (HandlerSite m) -> Maybe Text
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 (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Char
'f' Char -> ShowS
forall a. a -> [a] -> [a]
: Ints -> String
forall a. Show a => a -> String
show Ints
i', Ints
i')
    Text
id' <- m Text -> (Text -> m Text) -> Maybe Text -> m Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m Text
forall (m :: * -> *). MonadHandler m => m Text
newIdent Text -> m Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Text -> m Text) -> Maybe Text -> m Text
forall a b. (a -> b) -> a -> b
$ FieldSettings (HandlerSite m) -> Maybe Text
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 -> (FormResult (Maybe FileInfo)
forall a. FormResult a
FormMissing, Maybe (MarkupM ())
forall a. Maybe a
Nothing)
                Just (Env
_, FileEnv
fenv) ->
                    case Text -> FileEnv -> Maybe [FileInfo]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
name FileEnv
fenv of
                        Just (FileInfo
fi:[FileInfo]
_) -> (Maybe FileInfo -> FormResult (Maybe FileInfo)
forall a. a -> FormResult a
FormSuccess (Maybe FileInfo -> FormResult (Maybe FileInfo))
-> Maybe FileInfo -> FormResult (Maybe FileInfo)
forall a b. (a -> b) -> a -> b
$ FileInfo -> Maybe FileInfo
forall a. a -> Maybe a
Just FileInfo
fi, Maybe (MarkupM ())
forall a. Maybe a
Nothing)
                        Maybe [FileInfo]
_ -> (Maybe FileInfo -> FormResult (Maybe FileInfo)
forall a. a -> FormResult a
FormSuccess Maybe FileInfo
forall a. Maybe a
Nothing, Maybe (MarkupM ())
forall a. Maybe a
Nothing)
    let fv :: FieldView (HandlerSite m)
fv = FieldView :: forall site.
MarkupM ()
-> Maybe (MarkupM ())
-> Text
-> WidgetFor site ()
-> Maybe (MarkupM ())
-> Bool
-> FieldView site
FieldView
            { fvLabel :: MarkupM ()
fvLabel = toHtml $ renderMessage master langs $ fsLabel fs
            , fvTooltip :: Maybe (MarkupM ())
fvTooltip = (SomeMessage (HandlerSite m) -> MarkupM ())
-> Maybe (SomeMessage (HandlerSite m)) -> Maybe (MarkupM ())
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
            }
    (FormResult (Maybe FileInfo),
 [FieldView (HandlerSite m)] -> [FieldView (HandlerSite m)], Ints,
 Enctype)
-> m (FormResult (Maybe FileInfo),
      [FieldView (HandlerSite m)] -> [FieldView (HandlerSite m)], Ints,
      Enctype)
forall (m :: * -> *) a. Monad m => a -> m a
return (FormResult (Maybe FileInfo)
res, (FieldView (HandlerSite m)
fv FieldView (HandlerSite m)
-> [FieldView (HandlerSite m)] -> [FieldView (HandlerSite m)]
forall a. a -> [a] -> [a]
:), Ints
ints', Enctype
Multipart)

incrInts :: Ints -> Ints
incrInts :: Ints -> Ints
incrInts (IntSingle Int
i) = Int -> Ints
IntSingle (Int -> Ints) -> Int -> Ints
forall a b. (a -> b) -> a -> b
$ Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
incrInts (IntCons Int
i Ints
is) = (Int
i Int -> Int -> Int
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 Char -> Char -> Bool
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 (Char -> Char -> Bool
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.