haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Major typing overhaul.

Browse Source 
Types are less polymorphic and hopefully much easier to use/understand.

Also, introduced SomeMessage existential type, should make field reuse
much simpler.
This commit is contained in:
Michael Snoyman 2011-08-03 07:58:41 +03:00
parent 4a951ad39d
commit f62f513c63
7 changed files with 155 additions and 150 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

49
yesod-form/Yesod/Form/Class.hs
View File

@ -3,12 +3,12 @@
{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
module Yesod.Form.Class module Yesod.Form.Class
( ToForm (..) ( {- FIXME ToForm (..)
, ToField (..) , -} ToField (..)
) where ) where
import Text.Hamlet import Text.Hamlet
import Yesod.Widget (GGWidget) import Yesod.Widget (GGWidget, GWidget)
import Yesod.Form.Fields import Yesod.Form.Fields
import Yesod.Form.Types import Yesod.Form.Types
import Yesod.Form.Functions (areq, aopt) import Yesod.Form.Functions (areq, aopt)
@ -19,11 +19,14 @@ import Yesod.Handler (GGHandler)
import Yesod.Message (RenderMessage) import Yesod.Message (RenderMessage)
import Control.Monad.IO.Class (MonadIO) -- FIXME import Control.Monad.IO.Class (MonadIO) -- FIXME
class ToForm a master monad where {-
toForm :: AForm ([FieldView (GGWidget master monad ())] -> [FieldView (GGWidget master monad ())]) master monad a class ToForm a where
toForm :: AForm sub master a
-}
class ToField a master monad where class ToField a master where
toField :: RenderMessage master msg => FieldSettings msg -> Maybe a -> AForm ([FieldView (GGWidget master monad ())] -> [FieldView (GGWidget master monad ())]) master monad a toField :: (RenderMessage master msg, RenderMessage master FormMessage)
=> FieldSettings msg -> Maybe a -> AForm sub master a
{- FIXME {- FIXME
instance ToFormField String y where instance ToFormField String y where
@ -32,44 +35,44 @@ instance ToFormField (Maybe String) y where
toFormField = maybeStringField toFormField = maybeStringField
-} -}
instance (MonadIO m, RenderMessage master FormMessage) => ToField Text master (GGHandler sub master m) where instance ToField Text master where
toField = areq textField toField = areq textField
instance (MonadIO m, RenderMessage master FormMessage) => ToField (Maybe Text) master (GGHandler sub master m) where instance ToField (Maybe Text) master where
toField = aopt textField toField = aopt textField
instance (MonadIO m, RenderMessage master FormMessage) => ToField Int master (GGHandler sub master m) where instance ToField Int master where
toField = areq intField toField = areq intField
instance (MonadIO m, RenderMessage master FormMessage) => ToField (Maybe Int) master (GGHandler sub master m) where instance ToField (Maybe Int) master where
toField = aopt intField toField = aopt intField
instance (MonadIO m, RenderMessage master FormMessage) => ToField Int64 master (GGHandler sub master m) where instance ToField Int64 master where
toField = areq intField toField = areq intField
instance (MonadIO m, RenderMessage master FormMessage) => ToField (Maybe Int64) master (GGHandler sub master m) where instance ToField (Maybe Int64) master where
toField = aopt intField toField = aopt intField
instance (MonadIO m, RenderMessage master FormMessage) => ToField Double master (GGHandler sub master m) where instance ToField Double master where
toField = areq doubleField toField = areq doubleField
instance (MonadIO m, RenderMessage master FormMessage) => ToField (Maybe Double) master (GGHandler sub master m) where instance ToField (Maybe Double) master where
toField = aopt doubleField toField = aopt doubleField
instance (MonadIO m, RenderMessage master FormMessage) => ToField Day master (GGHandler sub master m) where instance ToField Day master where
toField = areq dayField toField = areq dayField
instance (MonadIO m, RenderMessage master FormMessage) => ToField (Maybe Day) master (GGHandler sub master m) where instance ToField (Maybe Day) master where
toField = aopt dayField toField = aopt dayField
instance (MonadIO m, RenderMessage master FormMessage) => ToField TimeOfDay master (GGHandler sub master m) where instance ToField TimeOfDay master where
toField = areq timeField toField = areq timeField
instance (MonadIO m, RenderMessage master FormMessage) => ToField (Maybe TimeOfDay) master (GGHandler sub master m) where instance ToField (Maybe TimeOfDay) master where
toField = aopt timeField toField = aopt timeField
instance (MonadIO m, RenderMessage master FormMessage) => ToField Html master (GGHandler sub master m) where instance ToField Html master where
toField = areq htmlField toField = areq htmlField
instance (MonadIO m, RenderMessage master FormMessage) => ToField (Maybe Html) master (GGHandler sub master m) where instance ToField (Maybe Html) master where
toField = aopt htmlField toField = aopt htmlField
instance (MonadIO m, RenderMessage master FormMessage) => ToField Textarea master (GGHandler sub master m) where instance ToField Textarea master where
toField = areq textareaField toField = areq textareaField
instance (MonadIO m, RenderMessage master FormMessage) => ToField (Maybe Textarea) master (GGHandler sub master m) where instance ToField (Maybe Textarea) master where
toField = aopt textareaField toField = aopt textareaField
{- FIXME {- FIXME

72
yesod-form/Yesod/Form/Fields.hs
View File

@ -44,7 +44,6 @@ import Control.Monad (when, unless)
import Data.List (intersect, nub) import Data.List (intersect, nub)
import Data.Either (rights) import Data.Either (rights)
import Data.Maybe (catMaybes) import Data.Maybe (catMaybes)
import Data.String (IsString (..))
import qualified Blaze.ByteString.Builder.Html.Utf8 as B import qualified Blaze.ByteString.Builder.Html.Utf8 as B
import Blaze.ByteString.Builder (writeByteString, toLazyByteString) import Blaze.ByteString.Builder (writeByteString, toLazyByteString)
@ -89,7 +88,6 @@ data FormMessage = MsgInvalidInteger Text
| MsgInvalidBool Text | MsgInvalidBool Text
| MsgBoolYes | MsgBoolYes
| MsgBoolNo | MsgBoolNo
| MsgOther Text
defaultFormMessage :: FormMessage -> Text defaultFormMessage :: FormMessage -> Text
defaultFormMessage (MsgInvalidInteger t) = "Invalid integer: " `mappend` t defaultFormMessage (MsgInvalidInteger t) = "Invalid integer: " `mappend` t
@ -109,19 +107,14 @@ defaultFormMessage MsgSelectNone = "<None>"
defaultFormMessage (MsgInvalidBool t) = "Invalid boolean: " `mappend` t defaultFormMessage (MsgInvalidBool t) = "Invalid boolean: " `mappend` t
defaultFormMessage MsgBoolYes = "Yes" defaultFormMessage MsgBoolYes = "Yes"
defaultFormMessage MsgBoolNo = "No" defaultFormMessage MsgBoolNo = "No"
defaultFormMessage (MsgOther t) = t
instance IsString FormMessage where blank :: (Monad m, RenderMessage master FormMessage)
fromString = MsgOther . fromString => (Text -> Either FormMessage a) -> [Text] -> m (Either (SomeMessage master) (Maybe a))
blank :: (Text -> Either msg a) -> [Text] -> IO (Either msg (Maybe a))
blank _ [] = return $ Right Nothing blank _ [] = return $ Right Nothing
blank _ ("":_) = return $ Right Nothing blank _ ("":_) = return $ Right Nothing
blank f (x:_) = return $ either Left (Right . Just) $ f x blank f (x:_) = return $ either (Left . SomeMessage) (Right . Just) $ f x
intField :: (Integral i, RenderMessage master FormMessage) => Field sub master i
intField :: (Monad monad, Integral i) => Field (GGWidget master monad ()) FormMessage i
intField = Field intField = Field
{ fieldParse = blank $ \s -> { fieldParse = blank $ \s ->
case Data.Text.Read.signed Data.Text.Read.decimal s of case Data.Text.Read.signed Data.Text.Read.decimal s of
@ -137,7 +130,7 @@ intField = Field
showVal = either id (pack . showI) showVal = either id (pack . showI)
showI x = show (fromIntegral x :: Integer) showI x = show (fromIntegral x :: Integer)
doubleField :: Monad monad => Field (GGWidget master monad ()) FormMessage Double doubleField :: RenderMessage master FormMessage => Field sub master Double
doubleField = Field doubleField = Field
{ fieldParse = blank $ \s -> { fieldParse = blank $ \s ->
case Data.Text.Read.double s of case Data.Text.Read.double s of
@ -151,7 +144,7 @@ doubleField = Field
} }
where showVal = either id (pack . show) where showVal = either id (pack . show)
dayField :: Monad monad => Field (GGWidget master monad ()) FormMessage Day dayField :: RenderMessage master FormMessage => Field sub master Day
dayField = Field dayField = Field
{ fieldParse = blank $ parseDate . unpack { fieldParse = blank $ parseDate . unpack
, fieldView = \theId name val isReq -> addHamlet , fieldView = \theId name val isReq -> addHamlet
@ -161,7 +154,7 @@ dayField = Field
} }
where showVal = either id (pack . show) where showVal = either id (pack . show)
timeField :: Monad monad => Field (GGWidget master monad ()) FormMessage TimeOfDay timeField :: RenderMessage master FormMessage => Field sub master TimeOfDay
timeField = Field timeField = Field
{ fieldParse = blank $ parseTime . unpack { fieldParse = blank $ parseTime . unpack
, fieldView = \theId name val isReq -> addHamlet , fieldView = \theId name val isReq -> addHamlet
@ -176,7 +169,7 @@ timeField = Field
where where
fullSec = fromInteger $ floor $ todSec tod fullSec = fromInteger $ floor $ todSec tod
htmlField :: Monad monad => Field (GGWidget master monad ()) FormMessage Html htmlField :: RenderMessage master FormMessage => Field sub master Html
htmlField = Field htmlField = Field
{ fieldParse = blank $ Right . preEscapedString . sanitizeBalance . unpack -- FIXME make changes to xss-sanitize { fieldParse = blank $ Right . preEscapedString . sanitizeBalance . unpack -- FIXME make changes to xss-sanitize
, fieldView = \theId name val _isReq -> addHamlet , fieldView = \theId name val _isReq -> addHamlet
@ -204,7 +197,7 @@ instance ToHtml Textarea where
writeHtmlEscapedChar '\n' = writeByteString "<br>" writeHtmlEscapedChar '\n' = writeByteString "<br>"
writeHtmlEscapedChar c = B.writeHtmlEscapedChar c writeHtmlEscapedChar c = B.writeHtmlEscapedChar c
textareaField :: Monad monad => Field (GGWidget master monad ()) FormMessage Textarea textareaField :: RenderMessage master FormMessage => Field sub master Textarea
textareaField = Field textareaField = Field
{ fieldParse = blank $ Right . Textarea { fieldParse = blank $ Right . Textarea
, fieldView = \theId name val _isReq -> addHamlet , fieldView = \theId name val _isReq -> addHamlet
@ -213,7 +206,7 @@ textareaField = Field
|] |]
} }
hiddenField :: Monad monad => Field (GGWidget master monad ()) FormMessage Text hiddenField :: RenderMessage master FormMessage => Field sub master Text
hiddenField = Field hiddenField = Field
{ fieldParse = blank $ Right { fieldParse = blank $ Right
, fieldView = \theId name val _isReq -> addHamlet , fieldView = \theId name val _isReq -> addHamlet
@ -222,7 +215,7 @@ hiddenField = Field
|] |]
} }
textField :: Monad monad => Field (GGWidget master monad ()) FormMessage Text textField :: RenderMessage master FormMessage => Field sub master Text
textField = Field textField = Field
{ fieldParse = blank $ Right { fieldParse = blank $ Right
, fieldView = \theId name val isReq -> , fieldView = \theId name val isReq ->
@ -231,7 +224,7 @@ textField = Field
|] |]
} }
passwordField :: Monad monad => Field (GGWidget master monad ()) FormMessage Text passwordField :: RenderMessage master FormMessage => Field sub master Text
passwordField = Field passwordField = Field
{ fieldParse = blank $ Right { fieldParse = blank $ Right
, fieldView = \theId name val isReq -> addHamlet , fieldView = \theId name val isReq -> addHamlet
@ -278,7 +271,7 @@ parseTimeHelper (h1, h2, m1, m2, s1, s2)
m = read [m1, m2] m = read [m1, m2]
s = fromInteger $ read [s1, s2] s = fromInteger $ read [s1, s2]
emailField :: Monad monad => Field (GGWidget master monad ()) FormMessage Text emailField :: RenderMessage master FormMessage => Field sub master Text
emailField = Field emailField = Field
{ fieldParse = blank $ { fieldParse = blank $
\s -> if Email.isValid (unpack s) \s -> if Email.isValid (unpack s)
@ -291,9 +284,9 @@ emailField = Field
} }
type AutoFocus = Bool type AutoFocus = Bool
searchField :: Monad monad => AutoFocus -> Field (GGWidget master monad ()) FormMessage Text searchField :: RenderMessage master FormMessage => AutoFocus -> Field sub master Text
searchField autoFocus = Field searchField autoFocus = Field
{ fieldParse = blank Right { fieldParse = blank Right
, fieldView = \theId name val isReq -> do , fieldView = \theId name val isReq -> do
[WHAMLET|\ [WHAMLET|\
<input id="#{theId}" name="#{name}" type="search" :isReq:required="" :autoFocus:autofocus="" value="#{either id id val}"> <input id="#{theId}" name="#{name}" type="search" :isReq:required="" :autoFocus:autofocus="" value="#{either id id val}">
@ -307,7 +300,7 @@ searchField autoFocus = Field
|] |]
} }
urlField :: Monad monad => Field (GGWidget master monad ()) FormMessage Text urlField :: RenderMessage master FormMessage => Field sub master Text
urlField = Field urlField = Field
{ fieldParse = blank $ \s -> { fieldParse = blank $ \s ->
case parseURI $ unpack s of case parseURI $ unpack s of
@ -319,18 +312,18 @@ urlField = Field
|] |]
} }
selectField :: (Eq a, Monad monad, RenderMessage master FormMessage) => [(Text, a)] -> Field (GGWidget master (GGHandler sub master monad) ()) FormMessage a selectField :: (Eq a, RenderMessage master FormMessage) => [(Text, a)] -> Field sub master a
selectField = selectFieldHelper selectField = selectFieldHelper
(\theId name inside -> [WHAMLET|<select ##{theId} name=#{name}>^{inside}|]) (\theId name inside -> [WHAMLET|<select ##{theId} name=#{name}>^{inside}|])
(\_theId _name isSel -> [WHAMLET|<option value=none :isSel:selected>_{MsgSelectNone}|]) (\_theId _name isSel -> [WHAMLET|<option value=none :isSel:selected>_{MsgSelectNone}|])
(\_theId _name value isSel text -> [WHAMLET|<option value=#{value} :isSel:selected>#{text}|]) (\_theId _name value isSel text -> [WHAMLET|<option value=#{value} :isSel:selected>#{text}|])
multiSelectField :: (Show a, Eq a, Monad monad, RenderMessage master FormMessage) => [(Text, a)] -> Field (GGWidget master (GGHandler sub master monad) ()) FormMessage [a] multiSelectField :: (Show a, Eq a, RenderMessage master FormMessage) => [(Text, a)] -> Field sub master [a]
multiSelectField = multiSelectFieldHelper multiSelectField = multiSelectFieldHelper
(\theId name inside -> [WHAMLET|<select ##{theId} multiple name=#{name}>^{inside}|]) (\theId name inside -> [WHAMLET|<select ##{theId} multiple name=#{name}>^{inside}|])
(\_theId _name value isSel text -> [WHAMLET|<option value=#{value} :isSel:selected>#{text}|]) (\_theId _name value isSel text -> [WHAMLET|<option value=#{value} :isSel:selected>#{text}|])
radioField :: (Eq a, Monad monad, RenderMessage master FormMessage) => [(Text, a)] -> Field (GGWidget master (GGHandler sub master monad) ()) FormMessage a radioField :: (Eq a, RenderMessage master FormMessage) => [(Text, a)] -> Field sub master a
radioField = selectFieldHelper radioField = selectFieldHelper
(\theId _name inside -> [WHAMLET|<div ##{theId}>^{inside}|]) (\theId _name inside -> [WHAMLET|<div ##{theId}>^{inside}|])
(\theId name isSel -> [WHAMLET| (\theId name isSel -> [WHAMLET|
@ -344,7 +337,7 @@ radioField = selectFieldHelper
<label for=#{theId}-#{value}>#{text} <label for=#{theId}-#{value}>#{text}
|]) |])
boolField :: (Monad monad, RenderMessage master FormMessage) => Field (GGWidget master (GGHandler sub master monad) ()) FormMessage Bool boolField :: RenderMessage master FormMessage => Field sub master Bool
boolField = Field boolField = Field
{ fieldParse = return . boolParser { fieldParse = return . boolParser
, fieldView = \theId name val isReq -> [WHAMLET| , fieldView = \theId name val isReq -> [WHAMLET|
@ -367,13 +360,13 @@ boolField = Field
"none" -> Right Nothing "none" -> Right Nothing
"yes" -> Right $ Just True "yes" -> Right $ Just True
"no" -> Right $ Just False "no" -> Right $ Just False
t -> Left $ MsgInvalidBool t t -> Left $ SomeMessage $ MsgInvalidBool t
showVal = either (\_ -> False) showVal = either (\_ -> False)
multiSelectFieldHelper :: (Show a, Eq a, Monad monad) multiSelectFieldHelper :: (Show a, Eq a)
=> (Text -> Text -> GGWidget master monad () -> GGWidget master monad ()) => (Text -> Text -> GWidget sub master () -> GWidget sub master ())
-> (Text -> Text -> Text -> Bool -> Text -> GGWidget master monad ()) -> (Text -> Text -> Text -> Bool -> Text -> GWidget sub master ())
-> [(Text, a)] -> Field (GGWidget master monad ()) FormMessage [a] -> [(Text, a)] -> Field sub master [a]
multiSelectFieldHelper outside inside opts = Field multiSelectFieldHelper outside inside opts = Field
{ fieldParse = return . selectParser { fieldParse = return . selectParser
, fieldView = \theId name vals _ -> , fieldView = \theId name vals _ ->
@ -393,11 +386,12 @@ multiSelectFieldHelper outside inside opts = Field
selectParser xs | not $ null (["", "none"] `intersect` xs) = Right Nothing selectParser xs | not $ null (["", "none"] `intersect` xs) = Right Nothing
| otherwise = (Right . Just . map snd . catMaybes . map (\y -> lookup y pairs) . nub . map fst . rights . map Data.Text.Read.decimal) xs | otherwise = (Right . Just . map snd . catMaybes . map (\y -> lookup y pairs) . nub . map fst . rights . map Data.Text.Read.decimal) xs
selectFieldHelper :: (Eq a, Monad monad) selectFieldHelper
=> (Text -> Text -> GGWidget master monad () -> GGWidget master monad ()) :: (Eq a, RenderMessage master FormMessage)
-> (Text -> Text -> Bool -> GGWidget master monad ()) => (Text -> Text -> GWidget sub master () -> GWidget sub master ())
-> (Text -> Text -> Text -> Bool -> Text -> GGWidget master monad ()) -> (Text -> Text -> Bool -> GWidget sub master ())
-> [(Text, a)] -> Field (GGWidget master monad ()) FormMessage a -> (Text -> Text -> Text -> Bool -> Text -> GWidget sub master ())
-> [(Text, a)] -> Field sub master a
selectFieldHelper outside onOpt inside opts = Field selectFieldHelper outside onOpt inside opts = Field
{ fieldParse = return . selectParser { fieldParse = return . selectParser
, fieldView = \theId name val isReq -> , fieldView = \theId name val isReq ->
@ -422,6 +416,6 @@ selectFieldHelper outside onOpt inside opts = Field
x -> case Data.Text.Read.decimal x of x -> case Data.Text.Read.decimal x of
Right (a, "") -> Right (a, "") ->
case lookup a pairs of case lookup a pairs of
Nothing -> Left $ MsgInvalidEntry x Nothing -> Left $ SomeMessage $ MsgInvalidEntry x
Just y -> Right $ Just $ snd y Just y -> Right $ Just $ snd y
_ -> Left $ MsgInvalidNumber x _ -> Left $ SomeMessage $ MsgInvalidNumber x

86
yesod-form/Yesod/Form/Functions.hs
View File

@ -38,15 +38,15 @@ import Control.Monad.Trans.Class (lift)
import Control.Monad (liftM, join) import Control.Monad (liftM, join)
import Text.Blaze (Html, toHtml) import Text.Blaze (Html, toHtml)
import Yesod.Handler (GHandler, GGHandler, getRequest, runRequestBody, newIdent, getYesod) import Yesod.Handler (GHandler, GGHandler, getRequest, runRequestBody, newIdent, getYesod)
import Yesod.Core (RenderMessage) import Yesod.Core (RenderMessage, liftIOHandler)
import Yesod.Widget (GGWidget, whamlet) import Yesod.Widget (GWidget, GGWidget, whamlet)
import Yesod.Request (reqNonce, reqWaiRequest, reqGetParams, languages) import Yesod.Request (reqNonce, reqWaiRequest, reqGetParams, languages)
import Network.Wai (requestMethod) import Network.Wai (requestMethod)
import Text.Hamlet (html) import Text.Hamlet (html)
import Data.Monoid (mempty) import Data.Monoid (mempty)
import Data.Maybe (listToMaybe) import Data.Maybe (listToMaybe)
import Yesod.Message (RenderMessage (..)) import Yesod.Message (RenderMessage (..))
import Control.Monad.IO.Class (MonadIO, liftIO) -- FIXME import Control.Monad.IO.Class (MonadIO, liftIO)
#if __GLASGOW_HASKELL__ >= 700 #if __GLASGOW_HASKELL__ >= 700
#define WHAMLET whamlet #define WHAMLET whamlet
@ -57,7 +57,7 @@ import Control.Monad.IO.Class (MonadIO, liftIO) -- FIXME
#endif #endif
-- | Get a unique identifier. -- | Get a unique identifier.
newFormIdent :: Monad m => Form msg m Text newFormIdent :: Form sub master Text
newFormIdent = do newFormIdent = do
i <- get i <- get
let i' = incrInts i let i' = incrInts i
@ -67,12 +67,12 @@ newFormIdent = do
incrInts (IntSingle i) = IntSingle $ i + 1 incrInts (IntSingle i) = IntSingle $ i + 1
incrInts (IntCons i is) = (i + 1) `IntCons` is incrInts (IntCons i is) = (i + 1) `IntCons` is
formToAForm :: Monad m => Form msg m (FormResult a, xml) -> AForm ([xml] -> [xml]) msg m a formToAForm :: Form sub master (FormResult a, FieldView sub master) -> AForm sub master a
formToAForm form = AForm $ \(master, langs) env ints -> do formToAForm form = AForm $ \(master, langs) env ints -> do
((a, xml), ints', enc) <- runRWST form (env, master, langs) ints ((a, xml), ints', enc) <- runRWST form (env, master, langs) ints
return (a, (:) xml, ints', enc) return (a, (:) xml, ints', enc)
aFormToForm :: Monad m => AForm xml msg m a -> Form msg m (FormResult a, xml) aFormToForm :: AForm sub master a -> Form sub master (FormResult a, [FieldView sub master] -> [FieldView sub master])
aFormToForm (AForm aform) = do aFormToForm (AForm aform) = do
ints <- get ints <- get
(env, master, langs) <- ask (env, master, langs) <- ask
@ -81,34 +81,34 @@ aFormToForm (AForm aform) = do
tell enc tell enc
return (a, xml) return (a, xml)
askParams :: Monad m => Form msg m (Maybe Env) askParams :: Form sub master (Maybe Env)
askParams = do askParams = do
(x, _, _) <- ask (x, _, _) <- ask
return $ liftM fst x return $ liftM fst x
askFiles :: Monad m => Form msg m (Maybe FileEnv) askFiles :: Form sub master (Maybe FileEnv)
askFiles = do askFiles = do
(x, _, _) <- ask (x, _, _) <- ask
return $ liftM snd x return $ liftM snd x
mreq :: (MonadIO m, RenderMessage master msg, RenderMessage master msg2, RenderMessage master FormMessage) mreq :: (RenderMessage master msg, RenderMessage master FormMessage)
=> Field xml msg a -> FieldSettings msg2 -> Maybe a => Field sub master a -> FieldSettings msg -> Maybe a
-> Form master (GGHandler sub master m) (FormResult a, FieldView xml) -> Form sub master (FormResult a, FieldView sub master)
mreq field fs mdef = mhelper field fs mdef (\m l -> FormFailure [renderMessage m l MsgValueRequired]) FormSuccess True mreq field fs mdef = mhelper field fs mdef (\m l -> FormFailure [renderMessage m l MsgValueRequired]) FormSuccess True
mopt :: (MonadIO m, RenderMessage master msg, RenderMessage master msg2) mopt :: RenderMessage master msg
=> Field xml msg a -> FieldSettings msg2 -> Maybe (Maybe a) => Field sub master a -> FieldSettings msg -> Maybe (Maybe a)
-> Form master (GGHandler sub master m) (FormResult (Maybe a), FieldView xml) -> Form sub master (FormResult (Maybe a), FieldView sub master)
mopt field fs mdef = mhelper field fs (join mdef) (const $ const $ FormSuccess Nothing) (FormSuccess . Just) False mopt field fs mdef = mhelper field fs (join mdef) (const $ const $ FormSuccess Nothing) (FormSuccess . Just) False
mhelper :: (MonadIO m, RenderMessage master msg, RenderMessage master msg2) mhelper :: RenderMessage master msg
=> Field xml msg a => Field sub master a
-> FieldSettings msg2 -> FieldSettings msg
-> Maybe a -> Maybe a
-> (master -> [Text] -> FormResult b) -- ^ on missing -> (master -> [Text] -> FormResult b) -- ^ on missing
-> (a -> FormResult b) -- ^ on success -> (a -> FormResult b) -- ^ on success
-> Bool -- ^ is it required? -> Bool -- ^ is it required?
-> Form master (GGHandler sub master m) (FormResult b, FieldView xml) -> Form sub master (FormResult b, FieldView sub master)
mhelper Field {..} FieldSettings {..} mdef onMissing onFound isReq = do mhelper Field {..} FieldSettings {..} mdef onMissing onFound isReq = do
mp <- askParams mp <- askParams
@ -121,9 +121,9 @@ mhelper Field {..} FieldSettings {..} mdef onMissing onFound isReq = do
Nothing -> return (FormMissing, maybe (Left "") Right mdef) Nothing -> return (FormMissing, maybe (Left "") Right mdef)
Just p -> do Just p -> do
let mvals = map snd $ filter (\(n,_) -> n == name) p let mvals = map snd $ filter (\(n,_) -> n == name) p
emx <- liftIO $ fieldParse mvals emx <- lift $ fieldParse mvals
return $ case emx of return $ case emx of
Left e -> (FormFailure [renderMessage master langs e], maybe (Left "") Left (listToMaybe mvals)) Left (SomeMessage e) -> (FormFailure [renderMessage master langs e], maybe (Left "") Left (listToMaybe mvals))
Right mx -> Right mx ->
case mx of case mx of
Nothing -> (onMissing master langs, Left "") Nothing -> (onMissing master langs, Left "")
@ -140,18 +140,20 @@ mhelper Field {..} FieldSettings {..} mdef onMissing onFound isReq = do
, fvRequired = isReq , fvRequired = isReq
}) })
areq :: (MonadIO m, RenderMessage master msg1, RenderMessage master msg2, RenderMessage master FormMessage) areq :: (RenderMessage master msg, RenderMessage master FormMessage)
=> Field xml msg1 a -> FieldSettings msg2 -> Maybe a => Field sub master a -> FieldSettings msg -> Maybe a
-> AForm ([FieldView xml] -> [FieldView xml]) master (GGHandler sub master m) a -> AForm sub master a
areq a b = formToAForm . mreq a b areq a b = formToAForm . mreq a b
aopt :: (MonadIO m, RenderMessage master msg1, RenderMessage master msg2) aopt :: RenderMessage master msg
=> Field xml msg1 a -> FieldSettings msg2 -> Maybe (Maybe a) => Field sub master a
-> AForm ([FieldView xml] -> [FieldView xml]) master (GGHandler sub master m) (Maybe a) -> FieldSettings msg
-> Maybe (Maybe a)
-> AForm sub master (Maybe a)
aopt a b = formToAForm . mopt a b aopt a b = formToAForm . mopt a b
runFormGeneric :: Monad m => Form master m a -> master -> [Text] -> Maybe (Env, FileEnv) -> m (a, Enctype) runFormGeneric :: MonadIO m => Form sub master a -> master -> [Text] -> Maybe (Env, FileEnv) -> GGHandler sub master m (a, Enctype)
runFormGeneric form master langs env = evalRWST form (env, master, langs) (IntSingle 1) runFormGeneric form master langs env = liftIOHandler $ evalRWST form (env, master, langs) (IntSingle 1)
-- | This function is used to both initially render a form and to later extract -- | This function is used to both initially render a form and to later extract
-- results from it. Note that, due to CSRF protection and a few other issues, -- results from it. Note that, due to CSRF protection and a few other issues,
@ -163,7 +165,8 @@ runFormGeneric form master langs env = evalRWST form (env, master, langs) (IntSi
-- the form submit to a POST page. In such a case, both the GET and POST -- the form submit to a POST page. In such a case, both the GET and POST
-- handlers should use 'runFormPost'. -- handlers should use 'runFormPost'.
runFormPost :: RenderMessage master FormMessage runFormPost :: RenderMessage master FormMessage
=> (Html -> Form master (GHandler sub master) (FormResult a, xml)) -> GHandler sub master ((FormResult a, xml), Enctype) => (Html -> Form sub master (FormResult a, xml))
-> GHandler sub master ((FormResult a, xml), Enctype)
runFormPost form = do runFormPost form = do
req <- getRequest req <- getRequest
let nonceKey = "_nonce" let nonceKey = "_nonce"
@ -185,7 +188,7 @@ runFormPost form = do
_ -> res _ -> res
return ((res', xml), enctype) return ((res', xml), enctype)
runFormPostNoNonce :: (Html -> Form master (GHandler sub master) (FormResult a, xml)) -> GHandler sub master ((FormResult a, xml), Enctype) runFormPostNoNonce :: (Html -> Form sub master (FormResult a, xml)) -> GHandler sub master ((FormResult a, xml), Enctype)
runFormPostNoNonce form = do runFormPostNoNonce form = do
req <- getRequest req <- getRequest
env <- if requestMethod (reqWaiRequest req) == "GET" env <- if requestMethod (reqWaiRequest req) == "GET"
@ -195,7 +198,7 @@ runFormPostNoNonce form = do
m <- getYesod m <- getYesod
runFormGeneric (form mempty) m langs env runFormGeneric (form mempty) m langs env
runFormGet :: Monad m => (Html -> Form master (GGHandler sub master m) a) -> GGHandler sub master m (a, Enctype) runFormGet :: (Html -> Form sub master a) -> GHandler sub master (a, Enctype)
runFormGet form = do runFormGet form = do
let key = "_hasdata" let key = "_hasdata"
let fragment = [HTML|<input type=hidden name=#{key}>|] let fragment = [HTML|<input type=hidden name=#{key}>|]
@ -208,12 +211,12 @@ runFormGet form = do
m <- getYesod m <- getYesod
runFormGeneric (form fragment) m langs env runFormGeneric (form fragment) m langs env
type FormRender master msg m a = type FormRender sub master a =
AForm ([FieldView (GGWidget master m ())] -> [FieldView (GGWidget master m ())]) msg m a AForm sub master a
-> Html -> Html
-> Form msg m (FormResult a, GGWidget master m ()) -> Form sub master (FormResult a, GWidget sub master ())
renderTable, renderDivs :: Monad m => FormRender master msg m a renderTable, renderDivs :: FormRender sub master a
renderTable aform fragment = do renderTable aform fragment = do
(res, views') <- aFormToForm aform (res, views') <- aFormToForm aform
let views = views' [] let views = views' []
@ -248,19 +251,24 @@ $forall view <- views
|] |]
return (res, widget) return (res, widget)
check :: (a -> Either msg a) -> Field xml msg a -> Field xml msg a check :: RenderMessage master msg
=> (a -> Either msg a) -> Field sub master a -> Field sub master a
check f = checkM $ return . f check f = checkM $ return . f
-- | Return the given error message if the predicate is false. -- | Return the given error message if the predicate is false.
checkBool :: (a -> Bool) -> msg -> Field xml msg a -> Field xml msg a checkBool :: RenderMessage master msg
=> (a -> Bool) -> msg -> Field sub master a -> Field sub master a
checkBool b s = check $ \x -> if b x then Right x else Left s checkBool b s = check $ \x -> if b x then Right x else Left s
checkM :: (a -> IO (Either msg a)) -> Field xml msg a -> Field xml msg a checkM :: RenderMessage master msg
=> (a -> GGHandler sub master IO (Either msg a))
-> Field sub master a
-> Field sub master a
checkM f field = field checkM f field = field
{ fieldParse = \ts -> do { fieldParse = \ts -> do
e1 <- fieldParse field ts e1 <- fieldParse field ts
case e1 of case e1 of
Left msg -> return $ Left msg Left msg -> return $ Left msg
Right Nothing -> return $ Right Nothing Right Nothing -> return $ Right Nothing
Right (Just a) -> fmap (either Left (Right . Just)) $ f a Right (Just a) -> fmap (either (Left . SomeMessage) (Right . Just)) $ f a
} }

25
yesod-form/Yesod/Form/Input.hs
View File

@ -12,18 +12,17 @@ import Yesod.Form.Types
import Yesod.Form.Fields (FormMessage (MsgInputNotFound)) import Yesod.Form.Fields (FormMessage (MsgInputNotFound))
import Data.Text (Text) import Data.Text (Text)
import Control.Applicative (Applicative (..)) import Control.Applicative (Applicative (..))
import Yesod.Handler (GHandler, GGHandler, invalidArgs, runRequestBody, getRequest, getYesod) import Yesod.Handler (GHandler, GGHandler, invalidArgs, runRequestBody, getRequest, getYesod, liftIOHandler)
import Yesod.Request (reqGetParams, languages) import Yesod.Request (reqGetParams, languages)
import Control.Monad (liftM) import Control.Monad (liftM)
import Yesod.Widget (GWidget) import Yesod.Widget (GWidget)
import Yesod.Message (RenderMessage (..)) import Yesod.Message (RenderMessage (..))
import Control.Monad.IO.Class (MonadIO, liftIO) -- FIXME
type DText = [Text] -> [Text] type DText = [Text] -> [Text]
newtype FormInput master a = FormInput { unFormInput :: master -> [Text] -> Env -> IO (Either DText a) } newtype FormInput sub master a = FormInput { unFormInput :: master -> [Text] -> Env -> GGHandler sub master IO (Either DText a) }
instance Functor (FormInput master) where instance Functor (FormInput sub master) where
fmap a (FormInput f) = FormInput $ \c d e -> fmap (either Left (Right . a)) $ f c d e fmap a (FormInput f) = FormInput $ \c d e -> fmap (either Left (Right . a)) $ f c d e
instance Applicative (FormInput master) where instance Applicative (FormInput sub master) where
pure = FormInput . const . const . const . return . Right pure = FormInput . const . const . const . return . Right
(FormInput f) <*> (FormInput x) = FormInput $ \c d e -> do (FormInput f) <*> (FormInput x) = FormInput $ \c d e -> do
res1 <- f c d e res1 <- f c d e
@ -34,39 +33,39 @@ instance Applicative (FormInput master) where
(_, Left b) -> Left b (_, Left b) -> Left b
(Right a, Right b) -> Right $ a b (Right a, Right b) -> Right $ a b
ireq :: (RenderMessage master msg, RenderMessage master FormMessage) => Field (GWidget sub master ()) msg a -> Text -> FormInput master a ireq :: (RenderMessage master msg, RenderMessage master FormMessage) => Field sub master a -> Text -> FormInput sub master a
ireq field name = FormInput $ \m l env -> do ireq field name = FormInput $ \m l env -> do
let filteredEnv = map snd $ filter (\y -> fst y == name) env let filteredEnv = map snd $ filter (\y -> fst y == name) env
emx <- fieldParse field $ filteredEnv emx <- fieldParse field $ filteredEnv
return $ case emx of return $ case emx of
Left e -> Left $ (:) $ renderMessage m l e Left (SomeMessage e) -> Left $ (:) $ renderMessage m l e
Right Nothing -> Left $ (:) $ renderMessage m l $ MsgInputNotFound name Right Nothing -> Left $ (:) $ renderMessage m l $ MsgInputNotFound name
Right (Just a) -> Right a Right (Just a) -> Right a
iopt :: RenderMessage master msg => Field (GWidget sub master ()) msg a -> Text -> FormInput master (Maybe a) iopt :: RenderMessage master msg => Field sub master a -> Text -> FormInput sub master (Maybe a)
iopt field name = FormInput $ \m l env -> do iopt field name = FormInput $ \m l env -> do
let filteredEnv = map snd $ filter (\y -> fst y == name) env let filteredEnv = map snd $ filter (\y -> fst y == name) env
emx <- fieldParse field $ filteredEnv emx <- fieldParse field $ filteredEnv
return $ case emx of return $ case emx of
Left e -> Left $ (:) $ renderMessage m l e Left (SomeMessage e) -> Left $ (:) $ renderMessage m l e
Right x -> Right x Right x -> Right x
runInputGet :: MonadIO monad => FormInput master a -> GGHandler sub master monad a runInputGet :: FormInput sub master a -> GHandler sub master a
runInputGet (FormInput f) = do runInputGet (FormInput f) = do
env <- liftM reqGetParams getRequest env <- liftM reqGetParams getRequest
m <- getYesod m <- getYesod
l <- languages l <- languages
emx <- liftIO $ f m l env emx <- liftIOHandler $ f m l env
case emx of case emx of
Left errs -> invalidArgs $ errs [] Left errs -> invalidArgs $ errs []
Right x -> return x Right x -> return x
runInputPost :: FormInput master a -> GHandler sub master a runInputPost :: FormInput sub master a -> GHandler sub master a
runInputPost (FormInput f) = do runInputPost (FormInput f) = do
env <- liftM fst runRequestBody env <- liftM fst runRequestBody
m <- getYesod m <- getYesod
l <- languages l <- languages
emx <- liftIO $ f m l env emx <- liftIOHandler $ f m l env
case emx of case emx of
Left errs -> invalidArgs $ errs [] Left errs -> invalidArgs $ errs []
Right x -> return x Right x -> return x

29
yesod-form/Yesod/Form/MassInput.hs
View File

@ -12,9 +12,9 @@ module Yesod.Form.MassInput
import Yesod.Form.Types import Yesod.Form.Types
import Yesod.Form.Functions import Yesod.Form.Functions
import Yesod.Form.Fields (boolField, FormMessage) import Yesod.Form.Fields (boolField, FormMessage)
import Yesod.Widget (GGWidget, whamlet) import Yesod.Widget (GWidget, GGWidget, whamlet)
import Yesod.Message (RenderMessage) import Yesod.Message (RenderMessage)
import Yesod.Handler (newIdent, GGHandler) import Yesod.Handler (newIdent, GHandler, GGHandler)
import Text.Blaze (Html) import Text.Blaze (Html)
import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Class (lift)
import Data.Text (pack, Text) import Data.Text (pack, Text)
@ -50,11 +50,11 @@ up i = do
IntCons _ is' -> put is' >> newFormIdent >> return () IntCons _ is' -> put is' >> newFormIdent >> return ()
up $ i - 1 up $ i - 1
inputList :: (MonadIO mo, m ~ GGHandler sub master mo, xml ~ GGWidget master (GGHandler sub master mo) (), RenderMessage master FormMessage) inputList :: (m ~ GGHandler sub master IO, xml ~ GWidget sub master (), RenderMessage master FormMessage)
=> Html => Html
-> ([[FieldView xml]] -> xml) -> ([[FieldView sub master]] -> xml)
-> (Maybe a -> AForm ([FieldView xml] -> [FieldView xml]) master m a) -> (Maybe a -> AForm sub master a)
-> (Maybe [a] -> AForm ([FieldView xml] -> [FieldView xml]) master m [a]) -> (Maybe [a] -> AForm sub master [a])
inputList label fixXml single mdef = formToAForm $ do inputList label fixXml single mdef = formToAForm $ do
theId <- lift newIdent theId <- lift newIdent
down 1 down 1
@ -93,9 +93,9 @@ inputList label fixXml single mdef = formToAForm $ do
, fvRequired = False , fvRequired = False
}) })
withDelete :: (MonadIO mo, xml ~ GGWidget master m (), m ~ GGHandler sub master mo, Monad mo, RenderMessage master FormMessage) withDelete :: (xml ~ GWidget sub master (), RenderMessage master FormMessage)
=> AForm ([FieldView xml] -> [FieldView xml]) master m a => AForm sub master a
-> Form master m (Either xml (FormResult a, [FieldView xml])) -> Form sub master (Either xml (FormResult a, [FieldView sub master]))
withDelete af = do withDelete af = do
down 1 down 1
deleteName <- newFormIdent deleteName <- newFormIdent
@ -114,9 +114,9 @@ withDelete af = do
up 1 up 1
return res return res
fixme :: (xml ~ GGWidget master (GGHandler sub master mo) ()) fixme :: (xml ~ GWidget sub master ())
=> [Either xml (FormResult a, [FieldView xml])] => [Either xml (FormResult a, [FieldView sub master])]
-> (FormResult [a], [xml], [[FieldView xml]]) -> (FormResult [a], [xml], [[FieldView sub master]])
fixme eithers = fixme eithers =
(res, xmls, map snd rest) (res, xmls, map snd rest)
where where
@ -124,9 +124,8 @@ fixme eithers =
res = sequenceA $ map fst rest res = sequenceA $ map fst rest
massDivs, massTable massDivs, massTable
:: Monad m :: [[FieldView sub master]]
=> [[FieldView (GGWidget master m ())]] -> GWidget sub master ()
-> GGWidget master m ()
massDivs viewss = [WHAMLET| massDivs viewss = [WHAMLET|
$forall views <- viewss $forall views <- viewss
<fieldset> <fieldset>

35
yesod-form/Yesod/Form/Types.hs
View File

@ -1,5 +1,6 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ExistentialQuantification #-}
module Yesod.Form.Types module Yesod.Form.Types
( -- * Helpers ( -- * Helpers
Enctype (..) Enctype (..)
@ -11,6 +12,7 @@ module Yesod.Form.Types
, Form , Form
, AForm (..) , AForm (..)
-- * Build forms -- * Build forms
, SomeMessage (..)
, Field (..) , Field (..)
, FieldSettings (..) , FieldSettings (..)
, FieldView (..) , FieldView (..)
@ -24,7 +26,7 @@ import Text.Blaze (Html, ToHtml (toHtml))
import Control.Applicative ((<$>), Applicative (..)) import Control.Applicative ((<$>), Applicative (..))
import Control.Monad (liftM) import Control.Monad (liftM)
import Data.String (IsString (..)) import Data.String (IsString (..))
import Control.Monad.Trans.Class (MonadTrans (..)) import Yesod.Core (RenderMessage, GGHandler, GWidget)
-- | A form can produce three different results: there was no data available, -- | A form can produce three different results: there was no data available,
-- the data was invalid, or there was a successful parse. -- the data was invalid, or there was a successful parse.
@ -70,32 +72,29 @@ instance Show Ints where
type Env = [(Text, Text)] -- FIXME use a Map type Env = [(Text, Text)] -- FIXME use a Map
type FileEnv = [(Text, FileInfo)] type FileEnv = [(Text, FileInfo)]
type Form master m a = RWST (Maybe (Env, FileEnv), master, [Text]) Enctype Ints m a type Lang = Text
type Form sub master a = RWST (Maybe (Env, FileEnv), master, [Lang]) Enctype Ints (GGHandler sub master IO) a
newtype AForm xml master m a = AForm newtype AForm sub master a = AForm
{ unAForm :: (master, [Text]) -> Maybe (Env, FileEnv) -> Ints -> m (FormResult a, xml, Ints, Enctype) { unAForm :: (master, [Text]) -> Maybe (Env, FileEnv) -> Ints -> GGHandler sub master IO (FormResult a, [FieldView sub master] -> [FieldView sub master], Ints, Enctype)
} }
instance Monad m => Functor (AForm xml msg m) where instance Functor (AForm sub master) where
fmap f (AForm a) = fmap f (AForm a) =
AForm $ \x y z -> liftM go $ a x y z AForm $ \x y z -> liftM go $ a x y z
where where
go (w, x, y, z) = (fmap f w, x, y, z) go (w, x, y, z) = (fmap f w, x, y, z)
instance (Monad m, Monoid xml) => Applicative (AForm xml msg m) where instance Applicative (AForm sub master) where
pure x = AForm $ const $ const $ \ints -> return (FormSuccess x, mempty, ints, mempty) pure x = AForm $ const $ const $ \ints -> return (FormSuccess x, mempty, ints, mempty)
(AForm f) <*> (AForm g) = AForm $ \mr env ints -> do (AForm f) <*> (AForm g) = AForm $ \mr env ints -> do
(a, b, ints', c) <- f mr env ints (a, b, ints', c) <- f mr env ints
(x, y, ints'', z) <- g mr env ints' (x, y, ints'', z) <- g mr env ints'
return (a <*> x, b `mappend` y, ints'', c `mappend` z) return (a <*> x, b `mappend` y, ints'', c `mappend` z)
instance (Monad m, Monoid xml, Monoid a) => Monoid (AForm xml msg m a) where instance Monoid a => Monoid (AForm sub master a) where
mempty = pure mempty mempty = pure mempty
mappend a b = mappend <$> a <*> b mappend a b = mappend <$> a <*> b
instance Monoid xml => MonadTrans (AForm xml msg) where
lift mx = AForm $ const $ const $ \ints -> do
x <- mx
return (pure x, mempty, ints, mempty)
data FieldSettings msg = FieldSettings data FieldSettings msg = FieldSettings
{ fsLabel :: msg { fsLabel :: msg -- FIXME switch to SomeMessage?
, fsTooltip :: Maybe msg , fsTooltip :: Maybe msg
, fsId :: Maybe Text , fsId :: Maybe Text
, fsName :: Maybe Text , fsName :: Maybe Text
@ -104,21 +103,23 @@ data FieldSettings msg = FieldSettings
instance (a ~ Text) => IsString (FieldSettings a) where instance (a ~ Text) => IsString (FieldSettings a) where
fromString s = FieldSettings (fromString s) Nothing Nothing Nothing fromString s = FieldSettings (fromString s) Nothing Nothing Nothing
data FieldView xml = FieldView data FieldView sub master = FieldView
{ fvLabel :: Html { fvLabel :: Html
, fvTooltip :: Maybe Html , fvTooltip :: Maybe Html
, fvId :: Text , fvId :: Text
, fvInput :: xml , fvInput :: GWidget sub master ()
, fvErrors :: Maybe Html , fvErrors :: Maybe Html
, fvRequired :: Bool , fvRequired :: Bool
} }
data Field xml msg a = Field data SomeMessage master = forall msg. RenderMessage master msg => SomeMessage msg
{ fieldParse :: [Text] -> IO (Either msg (Maybe a)) -- FIXME
data Field sub master a = Field
{ fieldParse :: [Text] -> GGHandler sub master IO (Either (SomeMessage master) (Maybe a))
-- | ID, name, (invalid text OR legimiate result), required? -- | ID, name, (invalid text OR legimiate result), required?
, fieldView :: Text , fieldView :: Text
-> Text -> Text
-> Either Text a -> Either Text a
-> Bool -> Bool
-> xml -> GWidget sub master ()
} }

9
yesod-form/hello-forms.hs
View File

@ -8,6 +8,7 @@ import Data.Text (Text, pack)
import Network.Wai.Handler.Warp (run) import Network.Wai.Handler.Warp (run)
import Data.Time (utctDay, getCurrentTime) import Data.Time (utctDay, getCurrentTime)
import qualified Data.Text as T import qualified Data.Text as T
import Control.Monad.IO.Class (liftIO)
data Fruit = Apple | Banana | Pear data Fruit = Apple | Banana | Pear
deriving (Show, Enum, Bounded, Eq) deriving (Show, Enum, Bounded, Eq)
@ -77,13 +78,13 @@ getMassR = do
|] |]
myValidForm = fixType $ runFormGet $ renderTable $ pure (,,) myValidForm = fixType $ runFormGet $ renderTable $ pure (,,)
<*> areq (check (\x -> if T.length x < 3 then Left "Need at least 3 letters" else Right x) textField) "Name" Nothing <*> areq (check (\x -> if T.length x < 3 then Left ("Need at least 3 letters" :: Text) else Right x) textField) "Name" Nothing
<*> areq (checkBool (>= 18) "Must be 18 or older" intField) "Age" Nothing <*> areq (checkBool (>= 18) ("Must be 18 or older" :: Text) intField) "Age" Nothing
<*> areq (checkM inPast dayField) "Anniversary" Nothing <*> areq (checkM inPast dayField) "Anniversary" Nothing
where where
inPast x = do inPast x = do
now <- getCurrentTime now <- liftIO $ getCurrentTime
return $ if utctDay now < x then Left "Need a date in the past" else Right x return $ if utctDay now < x then Left ("Need a date in the past" :: Text) else Right x
getValidR = do getValidR = do
((res, form), enctype) <- myValidForm ((res, form), enctype) <- myValidForm