{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# 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
    , radioField
    , radioFieldList
    , checkboxesField
    , checkboxesFieldList
    , multiSelectField
    , multiSelectFieldList
    , Option (..)
    , OptionList (..)
    , mkOptionList
    , optionsPersist
    , optionsPersistKey
    , optionsPairs
    , 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)
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
$ \s :: 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 (a :: i
a, "") -> i -> Either FormMessage i
forall a b. b -> Either a b
Right i
a
            _ -> 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 = \theId :: Text
theId name :: Text
name attrs :: [(Text, Text)]
attrs val :: Either Text i
val isReq :: 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 x :: 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
$ \s :: Text
s ->
        case Reader Double
Data.Text.Read.double (Text -> Text
prependZero Text
s) of
            Right (a :: Double
a, "") -> Double -> Either FormMessage Double
forall a b. b -> Either a b
Right Double
a
            _ -> 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 = \theId :: Text
theId name :: Text
name attrs :: [(Text, Text)]
attrs val :: Either Text Double
val isReq :: 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 = \theId :: Text
theId name :: Text
name attrs :: [(Text, Text)]
attrs val :: Either Text Day
val isReq :: 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 "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"

timeFieldOfType :: Monad m => RenderMessage (HandlerSite m) FormMessage => Text -> Field m TimeOfDay
timeFieldOfType :: Text -> Field m TimeOfDay
timeFieldOfType inputType :: 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 = \theId :: Text
theId name :: Text
name attrs :: [(Text, Text)]
attrs val :: Either Text TimeOfDay
val isReq :: 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 tod :: 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 = \theId :: Text
theId name :: Text
name attrs :: [(Text, Text)]
attrs val :: Either Text (MarkupM ())
val isReq :: 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 _ = 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 = \theId :: Text
theId name :: Text
name attrs :: [(Text, Text)]
attrs val :: Either Text Textarea
val isReq :: 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 = \theId :: Text
theId name :: Text
name attrs :: [(Text, Text)]
attrs val :: Either Text p
val _isReq :: 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 = \theId :: Text
theId name :: Text
name attrs :: [(Text, Text)]
attrs val :: Either Text Text
val isReq :: 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 = \theId :: Text
theId name :: Text
name attrs :: [(Text, Text)]
attrs _ isReq :: 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 s :: 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
                (x :: a
x, _):_ -> 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 '/' '-'

-- | 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 x :: a
x y :: a
y = (a -> a) -> [a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (\z :: 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 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
/= ':')) 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 ':'
    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 ':' 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 0
    Parser ()
skipSpace
    Maybe Bool
isPM <-
        (Text -> Parser Text
string "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 "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 "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 "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
            Nothing -> Int -> Parser Text Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
h
            Just x :: Bool
x
                | Int
h Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 0 Bool -> Bool -> Bool
|| Int
h Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 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
== 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 12 else 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 12 else 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
< 0 Bool -> Bool -> Bool
|| Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 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 msg :: 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
< 0 Bool -> Bool -> Bool
|| Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 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
$
        \s :: 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 e :: 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
                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 = \theId :: Text
theId name :: Text
name attrs :: [(Text, Text)]
attrs val :: Either Text Text
val isReq :: 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
$
        \s :: 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
s
            in case [Either Text Text] -> ([Text], [Text])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either Text Text]
addrs of
                ([], good :: [Text]
good) -> [Text] -> Either FormMessage [Text]
forall a b. b -> Either a b
Right [Text]
good
                (bad :: [Text]
bad, _) -> 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 = \theId :: Text
theId name :: Text
name attrs :: [(Text, Text)]
attrs val :: Either Text [Text]
val isReq :: 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 a :: 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 e :: 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, " (",  String -> Text
pack String
e, ")"]
                        Right r :: 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 ", "
        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 autoFocus :: 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 = \theId :: Text
theId name :: Text
name attrs :: [(Text, Text)]
attrs val :: Either Text Text
val isReq :: 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
$ \s :: 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
            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 _ -> Text -> Either FormMessage Text
forall a b. b -> Either a b
Right Text
s
    , fieldView :: FieldViewFunc m Text
fieldView = \theId :: Text
theId name :: Text
name attrs :: [(Text, Text)]
attrs val :: Either Text Text
val isReq :: 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 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 ())
-> 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 ())
-> HandlerFor site (OptionList a)
-> Field (HandlerFor site) a
selectFieldHelper
    (\theId :: Text
theId name :: Text
name attrs :: [(Text, Text)]
attrs inside :: WidgetFor site ()
inside -> [whamlet|
$newline never
<select ##{theId} name=#{name} *{attrs}>^{inside}
|]) -- outside
    (\_theId :: Text
_theId _name :: Text
_name isSel :: Bool
isSel -> [whamlet|
$newline never
<option value=none :isSel:selected>_{MsgSelectNone}
|]) -- onOpt
    (\_theId :: Text
_theId _name :: Text
_name _attrs :: [(Text, Text)]
_attrs value :: Text
value isSel :: Bool
isSel text :: Text
text -> [whamlet|
$newline never
<option value=#{value} :isSel:selected>#{text}
|]) -- inside

-- | 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 ioptlist :: 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 [] _ = 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 optlist :: [Text]
optlist _ = 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
             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 "Error parsing values"
             Just res :: [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 theId :: Text
theId name :: Text
name attrs :: [(Text, Text)]
attrs val :: Either Text [a]
val isReq :: 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 _) _ = Bool
False
            optselected (Right vals :: t a
vals) opt :: 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 ioptlist :: 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 =
        \theId :: Text
theId name :: Text
name attrs :: [(Text, Text)]
attrs val :: Either Text [a]
val _isReq :: 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 _) _ = Bool
False
                optselected (Right vals :: t a
vals) opt :: 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 ())
-> 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 ())
-> HandlerFor site (OptionList a)
-> Field (HandlerFor site) a
selectFieldHelper
    (\theId :: Text
theId _name :: Text
_name _attrs :: [(Text, Text)]
_attrs inside :: WidgetFor site ()
inside -> [whamlet|
$newline never
<div ##{theId}>^{inside}
|])
    (\theId :: Text
theId name :: Text
name isSel :: Bool
isSel -> [whamlet|
$newline never
<label .radio for=#{theId}-none>
    <div>
        <input id=#{theId}-none type=radio name=#{name} value=none :isSel:checked>
        _{MsgSelectNone}
|])
    (\theId :: Text
theId name :: Text
name attrs :: [(Text, Text)]
attrs value :: Text
value isSel :: Bool
isSel text :: 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}
|])

-- | 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 = \e :: [Text]
e _ -> 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 = \theId :: Text
theId name :: Text
name attrs :: [(Text, Text)]
attrs val :: Either Text Bool
val isReq :: 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 (x :: Text
x:_) = case Text
x of
      "" -> Maybe Bool -> Either (SomeMessage master) (Maybe Bool)
forall a b. b -> Either a b
Right Maybe Bool
forall a. Maybe a
Nothing
      "none" -> Maybe Bool -> Either (SomeMessage master) (Maybe Bool)
forall a b. b -> Either a b
Right Maybe Bool
forall a. Maybe a
Nothing
      "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
      "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
      "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
      "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
      "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
      t :: 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 (\_ -> 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 = \e :: [Text]
e _ -> 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  = \theId :: Text
theId name :: Text
name attrs :: [(Text, Text)]
attrs val :: Either Text Bool
val _ -> [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 (x :: a
x:_) = case a
x of
            "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
            "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
            _     -> 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 (\_ -> 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.
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').
    }

-- | Since 1.4.6
instance Functor OptionList where
    fmap :: (a -> b) -> OptionList a -> OptionList b
fmap f :: a -> b
f (OptionList options :: [Option a]
options readExternal :: 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)

-- | Creates an 'OptionList', using a 'Map' to implement the 'olReadExternal' function.
mkOptionList :: [Option a] -> OptionList a
mkOptionList :: [Option a] -> OptionList a
mkOptionList os :: [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
    }

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 f :: a -> b
f (Option display :: Text
display internal :: a
internal external :: 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 opts :: [(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 external :: Int
external (display :: msg
display, internal :: 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 [1 :: Int ..] [(msg, a)]
opts)

-- | 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 (\x :: 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 filts :: [Filter a]
filts ords :: [SelectOpt a]
ords toDisplay :: 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 (m :: * -> *) backend record.
(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 :: Key a
key value :: 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 filts :: [Filter a]
filts ords :: [SelectOpt a]
ords toDisplay :: 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 (m :: * -> *) backend record.
(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 :: Key a
key value :: 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. 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
        -> 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 ())
-> HandlerFor site (OptionList a)
-> Field (HandlerFor site) a
selectFieldHelper outside :: Text
-> Text -> [(Text, Text)] -> WidgetFor site () -> WidgetFor site ()
outside onOpt :: Text -> Text -> Bool -> WidgetFor site ()
onOpt inside :: Text
-> Text
-> [(Text, Text)]
-> Text
-> Bool
-> Text
-> WidgetFor site ()
inside opts' :: 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 = \x :: [Text]
x _ -> do
        OptionList a
opts <- 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 = \theId :: Text
theId name :: Text
name attrs :: [(Text, Text)]
attrs val :: Either Text a
val isReq :: 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)
opts'
        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
            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
$ Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
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]
opts Either Text a
val Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (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]
opts
            ((Option a -> WidgetFor site ())
 -> [Option a] -> WidgetFor site ())
-> [Option a]
-> (Option a -> WidgetFor site ())
-> WidgetFor site ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Option a -> WidgetFor site ()) -> [Option a] -> WidgetFor site ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ [Option a]
opts ((Option a -> WidgetFor site ()) -> WidgetFor site ())
-> (Option a -> WidgetFor site ()) -> WidgetFor site ()
forall a b. (a -> b) -> a -> b
$ \opt :: Option a
opt -> Text
-> Text
-> [(Text, Text)]
-> Text
-> Bool
-> Text
-> WidgetFor site ()
inside
                Text
theId
                Text
name
                ((if Bool
isReq then (("required", "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)
    , fieldEnctype :: Enctype
fieldEnctype = Enctype
UrlEncoded
    }
  where
    render :: [Option a] -> Either Text a -> Text
render _ (Left x :: Text
x) = Text
x
    render opts :: [Option a]
opts (Right a :: a
a) = Text -> (Option a -> Text) -> Maybe (Option a) -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "" 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 _ [] = Maybe a -> Either (SomeMessage master) (Maybe a)
forall a b. b -> Either a b
Right Maybe a
forall a. Maybe a
Nothing
    selectParser opts :: OptionList a
opts (s :: Text
s:_) = case Text
s of
            "" -> Maybe a -> Either (SomeMessage master) (Maybe a)
forall a b. b -> Either a b
Right Maybe a
forall a. Maybe a
Nothing
            "none" -> Maybe a -> Either (SomeMessage master) (Maybe a)
forall a b. b -> Either a b
Right Maybe a
forall a. Maybe a
Nothing
            x :: Text
x -> case OptionList a -> Text -> Maybe a
forall a. OptionList a -> Text -> Maybe a
olReadExternal OptionList a
opts Text
x of
                    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 y :: 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

-- | 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 = \_ files :: [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
            file :: FileInfo
file:_ -> 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 = \id' :: Text
id' name :: Text
name attrs :: [(Text, Text)]
attrs _ isReq :: 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 fs :: 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
$ \(site :: HandlerSite m
site, langs :: [Text]
langs) menvs :: Maybe (Env, FileEnv)
menvs ints :: Ints
ints -> do
    let (name :: Text
name, ints' :: Ints
ints') =
            case FieldSettings (HandlerSite m) -> Maybe Text
forall master. FieldSettings master -> Maybe Text
fsName FieldSettings (HandlerSite m)
fs of
                Just x :: Text
x -> (Text
x, Ints
ints)
                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
$ '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 (res :: FormResult FileInfo
res, errs :: Maybe (MarkupM ())
errs) =
            case Maybe (Env, FileEnv)
menvs of
                Nothing -> (FormResult FileInfo
forall a. FormResult a
FormMissing, Maybe (MarkupM ())
forall a. Maybe a
Nothing)
                Just (_, fenv :: 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 (fi :: FileInfo
fi:_) -> (FileInfo -> FormResult FileInfo
forall a. a -> FormResult a
FormSuccess FileInfo
fi, Maybe (MarkupM ())
forall a. Maybe a
Nothing)
                        _ ->
                            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 fs :: 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
$ \(master :: HandlerSite m
master, langs :: [Text]
langs) menvs :: Maybe (Env, FileEnv)
menvs ints :: Ints
ints -> do
    let (name :: Text
name, ints' :: Ints
ints') =
            case FieldSettings (HandlerSite m) -> Maybe Text
forall master. FieldSettings master -> Maybe Text
fsName FieldSettings (HandlerSite m)
fs of
                Just x :: Text
x -> (Text
x, Ints
ints)
                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
$ '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 (res :: FormResult (Maybe FileInfo)
res, errs :: Maybe (MarkupM ())
errs) =
            case Maybe (Env, FileEnv)
menvs of
                Nothing -> (FormResult (Maybe FileInfo)
forall a. FormResult a
FormMissing, Maybe (MarkupM ())
forall a. Maybe a
Nothing)
                Just (_, fenv :: 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 (fi :: FileInfo
fi:_) -> (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 -> 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 i :: 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
+ 1
incrInts (IntCons i :: Int
i is :: Ints
is) = (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 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 t0 :: 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
== '.'
                      then '0' Char -> Text -> Text
`T.cons` Text
t1
                      else if "-." Text -> Text -> Bool
`T.isPrefixOf` Text
t1
                           then "-0." Text -> Text -> Text
`T.append` (Int -> Text -> Text
T.drop 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
(==) ' ') 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.