Major typing overhaul.
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
parent
4a951ad39d
commit
f62f513c63
@ -3,12 +3,12 @@
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
module Yesod.Form.Class
|
||||
( ToForm (..)
|
||||
, ToField (..)
|
||||
( {- FIXME ToForm (..)
|
||||
, -} ToField (..)
|
||||
) where
|
||||
|
||||
import Text.Hamlet
|
||||
import Yesod.Widget (GGWidget)
|
||||
import Yesod.Widget (GGWidget, GWidget)
|
||||
import Yesod.Form.Fields
|
||||
import Yesod.Form.Types
|
||||
import Yesod.Form.Functions (areq, aopt)
|
||||
@ -19,11 +19,14 @@ import Yesod.Handler (GGHandler)
|
||||
import Yesod.Message (RenderMessage)
|
||||
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
|
||||
toField :: RenderMessage master msg => FieldSettings msg -> Maybe a -> AForm ([FieldView (GGWidget master monad ())] -> [FieldView (GGWidget master monad ())]) master monad a
|
||||
class ToField a master where
|
||||
toField :: (RenderMessage master msg, RenderMessage master FormMessage)
|
||||
=> FieldSettings msg -> Maybe a -> AForm sub master a
|
||||
|
||||
{- FIXME
|
||||
instance ToFormField String y where
|
||||
@ -32,44 +35,44 @@ instance ToFormField (Maybe String) y where
|
||||
toFormField = maybeStringField
|
||||
-}
|
||||
|
||||
instance (MonadIO m, RenderMessage master FormMessage) => ToField Text master (GGHandler sub master m) where
|
||||
instance ToField Text master where
|
||||
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
|
||||
|
||||
instance (MonadIO m, RenderMessage master FormMessage) => ToField Int master (GGHandler sub master m) where
|
||||
instance ToField Int master where
|
||||
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
|
||||
|
||||
instance (MonadIO m, RenderMessage master FormMessage) => ToField Int64 master (GGHandler sub master m) where
|
||||
instance ToField Int64 master where
|
||||
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
|
||||
|
||||
instance (MonadIO m, RenderMessage master FormMessage) => ToField Double master (GGHandler sub master m) where
|
||||
instance ToField Double master where
|
||||
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
|
||||
|
||||
instance (MonadIO m, RenderMessage master FormMessage) => ToField Day master (GGHandler sub master m) where
|
||||
instance ToField Day master where
|
||||
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
|
||||
|
||||
instance (MonadIO m, RenderMessage master FormMessage) => ToField TimeOfDay master (GGHandler sub master m) where
|
||||
instance ToField TimeOfDay master where
|
||||
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
|
||||
|
||||
instance (MonadIO m, RenderMessage master FormMessage) => ToField Html master (GGHandler sub master m) where
|
||||
instance ToField Html master where
|
||||
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
|
||||
|
||||
instance (MonadIO m, RenderMessage master FormMessage) => ToField Textarea master (GGHandler sub master m) where
|
||||
instance ToField Textarea master where
|
||||
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
|
||||
|
||||
{- FIXME
|
||||
|
||||
@ -44,7 +44,6 @@ import Control.Monad (when, unless)
|
||||
import Data.List (intersect, nub)
|
||||
import Data.Either (rights)
|
||||
import Data.Maybe (catMaybes)
|
||||
import Data.String (IsString (..))
|
||||
|
||||
import qualified Blaze.ByteString.Builder.Html.Utf8 as B
|
||||
import Blaze.ByteString.Builder (writeByteString, toLazyByteString)
|
||||
@ -89,7 +88,6 @@ data FormMessage = MsgInvalidInteger Text
|
||||
| MsgInvalidBool Text
|
||||
| MsgBoolYes
|
||||
| MsgBoolNo
|
||||
| MsgOther Text
|
||||
|
||||
defaultFormMessage :: FormMessage -> Text
|
||||
defaultFormMessage (MsgInvalidInteger t) = "Invalid integer: " `mappend` t
|
||||
@ -109,19 +107,14 @@ defaultFormMessage MsgSelectNone = "<None>"
|
||||
defaultFormMessage (MsgInvalidBool t) = "Invalid boolean: " `mappend` t
|
||||
defaultFormMessage MsgBoolYes = "Yes"
|
||||
defaultFormMessage MsgBoolNo = "No"
|
||||
defaultFormMessage (MsgOther t) = t
|
||||
|
||||
instance IsString FormMessage where
|
||||
fromString = MsgOther . fromString
|
||||
|
||||
blank :: (Text -> Either msg a) -> [Text] -> IO (Either msg (Maybe a))
|
||||
blank :: (Monad m, RenderMessage master FormMessage)
|
||||
=> (Text -> Either FormMessage a) -> [Text] -> m (Either (SomeMessage master) (Maybe a))
|
||||
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 :: (Monad monad, Integral i) => Field (GGWidget master monad ()) FormMessage i
|
||||
intField :: (Integral i, RenderMessage master FormMessage) => Field sub master i
|
||||
intField = Field
|
||||
{ fieldParse = blank $ \s ->
|
||||
case Data.Text.Read.signed Data.Text.Read.decimal s of
|
||||
@ -137,7 +130,7 @@ intField = Field
|
||||
showVal = either id (pack . showI)
|
||||
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
|
||||
{ fieldParse = blank $ \s ->
|
||||
case Data.Text.Read.double s of
|
||||
@ -151,7 +144,7 @@ doubleField = Field
|
||||
}
|
||||
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
|
||||
{ fieldParse = blank $ parseDate . unpack
|
||||
, fieldView = \theId name val isReq -> addHamlet
|
||||
@ -161,7 +154,7 @@ dayField = Field
|
||||
}
|
||||
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
|
||||
{ fieldParse = blank $ parseTime . unpack
|
||||
, fieldView = \theId name val isReq -> addHamlet
|
||||
@ -176,7 +169,7 @@ timeField = Field
|
||||
where
|
||||
fullSec = fromInteger $ floor $ todSec tod
|
||||
|
||||
htmlField :: Monad monad => Field (GGWidget master monad ()) FormMessage Html
|
||||
htmlField :: RenderMessage master FormMessage => Field sub master Html
|
||||
htmlField = Field
|
||||
{ fieldParse = blank $ Right . preEscapedString . sanitizeBalance . unpack -- FIXME make changes to xss-sanitize
|
||||
, fieldView = \theId name val _isReq -> addHamlet
|
||||
@ -204,7 +197,7 @@ instance ToHtml Textarea where
|
||||
writeHtmlEscapedChar '\n' = writeByteString "<br>"
|
||||
writeHtmlEscapedChar c = B.writeHtmlEscapedChar c
|
||||
|
||||
textareaField :: Monad monad => Field (GGWidget master monad ()) FormMessage Textarea
|
||||
textareaField :: RenderMessage master FormMessage => Field sub master Textarea
|
||||
textareaField = Field
|
||||
{ fieldParse = blank $ Right . Textarea
|
||||
, 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
|
||||
{ fieldParse = blank $ Right
|
||||
, 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
|
||||
{ fieldParse = blank $ Right
|
||||
, 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
|
||||
{ fieldParse = blank $ Right
|
||||
, fieldView = \theId name val isReq -> addHamlet
|
||||
@ -278,7 +271,7 @@ parseTimeHelper (h1, h2, m1, m2, s1, s2)
|
||||
m = read [m1, m2]
|
||||
s = fromInteger $ read [s1, s2]
|
||||
|
||||
emailField :: Monad monad => Field (GGWidget master monad ()) FormMessage Text
|
||||
emailField :: RenderMessage master FormMessage => Field sub master Text
|
||||
emailField = Field
|
||||
{ fieldParse = blank $
|
||||
\s -> if Email.isValid (unpack s)
|
||||
@ -291,9 +284,9 @@ emailField = Field
|
||||
}
|
||||
|
||||
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
|
||||
{ fieldParse = blank Right
|
||||
{ fieldParse = blank Right
|
||||
, fieldView = \theId name val isReq -> do
|
||||
[WHAMLET|\
|
||||
<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
|
||||
{ fieldParse = blank $ \s ->
|
||||
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
|
||||
(\theId name inside -> [WHAMLET|<select ##{theId} name=#{name}>^{inside}|])
|
||||
(\_theId _name isSel -> [WHAMLET|<option value=none :isSel:selected>_{MsgSelectNone}|])
|
||||
(\_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
|
||||
(\theId name inside -> [WHAMLET|<select ##{theId} multiple name=#{name}>^{inside}|])
|
||||
(\_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
|
||||
(\theId _name inside -> [WHAMLET|<div ##{theId}>^{inside}|])
|
||||
(\theId name isSel -> [WHAMLET|
|
||||
@ -344,7 +337,7 @@ radioField = selectFieldHelper
|
||||
<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
|
||||
{ fieldParse = return . boolParser
|
||||
, fieldView = \theId name val isReq -> [WHAMLET|
|
||||
@ -367,13 +360,13 @@ boolField = Field
|
||||
"none" -> Right Nothing
|
||||
"yes" -> Right $ Just True
|
||||
"no" -> Right $ Just False
|
||||
t -> Left $ MsgInvalidBool t
|
||||
t -> Left $ SomeMessage $ MsgInvalidBool t
|
||||
showVal = either (\_ -> False)
|
||||
|
||||
multiSelectFieldHelper :: (Show a, Eq a, Monad monad)
|
||||
=> (Text -> Text -> GGWidget master monad () -> GGWidget master monad ())
|
||||
-> (Text -> Text -> Text -> Bool -> Text -> GGWidget master monad ())
|
||||
-> [(Text, a)] -> Field (GGWidget master monad ()) FormMessage [a]
|
||||
multiSelectFieldHelper :: (Show a, Eq a)
|
||||
=> (Text -> Text -> GWidget sub master () -> GWidget sub master ())
|
||||
-> (Text -> Text -> Text -> Bool -> Text -> GWidget sub master ())
|
||||
-> [(Text, a)] -> Field sub master [a]
|
||||
multiSelectFieldHelper outside inside opts = Field
|
||||
{ fieldParse = return . selectParser
|
||||
, fieldView = \theId name vals _ ->
|
||||
@ -393,11 +386,12 @@ multiSelectFieldHelper outside inside opts = Field
|
||||
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
|
||||
|
||||
selectFieldHelper :: (Eq a, Monad monad)
|
||||
=> (Text -> Text -> GGWidget master monad () -> GGWidget master monad ())
|
||||
-> (Text -> Text -> Bool -> GGWidget master monad ())
|
||||
-> (Text -> Text -> Text -> Bool -> Text -> GGWidget master monad ())
|
||||
-> [(Text, a)] -> Field (GGWidget master monad ()) FormMessage a
|
||||
selectFieldHelper
|
||||
:: (Eq a, RenderMessage master FormMessage)
|
||||
=> (Text -> Text -> GWidget sub master () -> GWidget sub master ())
|
||||
-> (Text -> Text -> Bool -> GWidget sub master ())
|
||||
-> (Text -> Text -> Text -> Bool -> Text -> GWidget sub master ())
|
||||
-> [(Text, a)] -> Field sub master a
|
||||
selectFieldHelper outside onOpt inside opts = Field
|
||||
{ fieldParse = return . selectParser
|
||||
, fieldView = \theId name val isReq ->
|
||||
@ -422,6 +416,6 @@ selectFieldHelper outside onOpt inside opts = Field
|
||||
x -> case Data.Text.Read.decimal x of
|
||||
Right (a, "") ->
|
||||
case lookup a pairs of
|
||||
Nothing -> Left $ MsgInvalidEntry x
|
||||
Nothing -> Left $ SomeMessage $ MsgInvalidEntry x
|
||||
Just y -> Right $ Just $ snd y
|
||||
_ -> Left $ MsgInvalidNumber x
|
||||
_ -> Left $ SomeMessage $ MsgInvalidNumber x
|
||||
|
||||
@ -38,15 +38,15 @@ import Control.Monad.Trans.Class (lift)
|
||||
import Control.Monad (liftM, join)
|
||||
import Text.Blaze (Html, toHtml)
|
||||
import Yesod.Handler (GHandler, GGHandler, getRequest, runRequestBody, newIdent, getYesod)
|
||||
import Yesod.Core (RenderMessage)
|
||||
import Yesod.Widget (GGWidget, whamlet)
|
||||
import Yesod.Core (RenderMessage, liftIOHandler)
|
||||
import Yesod.Widget (GWidget, GGWidget, whamlet)
|
||||
import Yesod.Request (reqNonce, reqWaiRequest, reqGetParams, languages)
|
||||
import Network.Wai (requestMethod)
|
||||
import Text.Hamlet (html)
|
||||
import Data.Monoid (mempty)
|
||||
import Data.Maybe (listToMaybe)
|
||||
import Yesod.Message (RenderMessage (..))
|
||||
import Control.Monad.IO.Class (MonadIO, liftIO) -- FIXME
|
||||
import Control.Monad.IO.Class (MonadIO, liftIO)
|
||||
|
||||
#if __GLASGOW_HASKELL__ >= 700
|
||||
#define WHAMLET whamlet
|
||||
@ -57,7 +57,7 @@ import Control.Monad.IO.Class (MonadIO, liftIO) -- FIXME
|
||||
#endif
|
||||
|
||||
-- | Get a unique identifier.
|
||||
newFormIdent :: Monad m => Form msg m Text
|
||||
newFormIdent :: Form sub master Text
|
||||
newFormIdent = do
|
||||
i <- get
|
||||
let i' = incrInts i
|
||||
@ -67,12 +67,12 @@ newFormIdent = do
|
||||
incrInts (IntSingle i) = IntSingle $ i + 1
|
||||
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
|
||||
((a, xml), ints', enc) <- runRWST form (env, master, langs) ints
|
||||
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
|
||||
ints <- get
|
||||
(env, master, langs) <- ask
|
||||
@ -81,34 +81,34 @@ aFormToForm (AForm aform) = do
|
||||
tell enc
|
||||
return (a, xml)
|
||||
|
||||
askParams :: Monad m => Form msg m (Maybe Env)
|
||||
askParams :: Form sub master (Maybe Env)
|
||||
askParams = do
|
||||
(x, _, _) <- ask
|
||||
return $ liftM fst x
|
||||
|
||||
askFiles :: Monad m => Form msg m (Maybe FileEnv)
|
||||
askFiles :: Form sub master (Maybe FileEnv)
|
||||
askFiles = do
|
||||
(x, _, _) <- ask
|
||||
return $ liftM snd x
|
||||
|
||||
mreq :: (MonadIO m, RenderMessage master msg, RenderMessage master msg2, RenderMessage master FormMessage)
|
||||
=> Field xml msg a -> FieldSettings msg2 -> Maybe a
|
||||
-> Form master (GGHandler sub master m) (FormResult a, FieldView xml)
|
||||
mreq :: (RenderMessage master msg, RenderMessage master FormMessage)
|
||||
=> Field sub master a -> FieldSettings msg -> Maybe a
|
||||
-> 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
|
||||
|
||||
mopt :: (MonadIO m, RenderMessage master msg, RenderMessage master msg2)
|
||||
=> Field xml msg a -> FieldSettings msg2 -> Maybe (Maybe a)
|
||||
-> Form master (GGHandler sub master m) (FormResult (Maybe a), FieldView xml)
|
||||
mopt :: RenderMessage master msg
|
||||
=> Field sub master a -> FieldSettings msg -> Maybe (Maybe a)
|
||||
-> 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
|
||||
|
||||
mhelper :: (MonadIO m, RenderMessage master msg, RenderMessage master msg2)
|
||||
=> Field xml msg a
|
||||
-> FieldSettings msg2
|
||||
mhelper :: RenderMessage master msg
|
||||
=> Field sub master a
|
||||
-> FieldSettings msg
|
||||
-> Maybe a
|
||||
-> (master -> [Text] -> FormResult b) -- ^ on missing
|
||||
-> (a -> FormResult b) -- ^ on success
|
||||
-> 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
|
||||
mp <- askParams
|
||||
@ -121,9 +121,9 @@ mhelper Field {..} FieldSettings {..} mdef onMissing onFound isReq = do
|
||||
Nothing -> return (FormMissing, maybe (Left "") Right mdef)
|
||||
Just p -> do
|
||||
let mvals = map snd $ filter (\(n,_) -> n == name) p
|
||||
emx <- liftIO $ fieldParse mvals
|
||||
emx <- lift $ fieldParse mvals
|
||||
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 ->
|
||||
case mx of
|
||||
Nothing -> (onMissing master langs, Left "")
|
||||
@ -140,18 +140,20 @@ mhelper Field {..} FieldSettings {..} mdef onMissing onFound isReq = do
|
||||
, fvRequired = isReq
|
||||
})
|
||||
|
||||
areq :: (MonadIO m, RenderMessage master msg1, RenderMessage master msg2, RenderMessage master FormMessage)
|
||||
=> Field xml msg1 a -> FieldSettings msg2 -> Maybe a
|
||||
-> AForm ([FieldView xml] -> [FieldView xml]) master (GGHandler sub master m) a
|
||||
areq :: (RenderMessage master msg, RenderMessage master FormMessage)
|
||||
=> Field sub master a -> FieldSettings msg -> Maybe a
|
||||
-> AForm sub master a
|
||||
areq a b = formToAForm . mreq a b
|
||||
|
||||
aopt :: (MonadIO m, RenderMessage master msg1, RenderMessage master msg2)
|
||||
=> Field xml msg1 a -> FieldSettings msg2 -> Maybe (Maybe a)
|
||||
-> AForm ([FieldView xml] -> [FieldView xml]) master (GGHandler sub master m) (Maybe a)
|
||||
aopt :: RenderMessage master msg
|
||||
=> Field sub master a
|
||||
-> FieldSettings msg
|
||||
-> Maybe (Maybe a)
|
||||
-> AForm sub master (Maybe a)
|
||||
aopt a b = formToAForm . mopt a b
|
||||
|
||||
runFormGeneric :: Monad m => Form master m a -> master -> [Text] -> Maybe (Env, FileEnv) -> m (a, Enctype)
|
||||
runFormGeneric form master langs env = evalRWST form (env, master, langs) (IntSingle 1)
|
||||
runFormGeneric :: MonadIO m => Form sub master a -> master -> [Text] -> Maybe (Env, FileEnv) -> GGHandler sub master m (a, Enctype)
|
||||
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
|
||||
-- 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
|
||||
-- handlers should use 'runFormPost'.
|
||||
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
|
||||
req <- getRequest
|
||||
let nonceKey = "_nonce"
|
||||
@ -185,7 +188,7 @@ runFormPost form = do
|
||||
_ -> res
|
||||
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
|
||||
req <- getRequest
|
||||
env <- if requestMethod (reqWaiRequest req) == "GET"
|
||||
@ -195,7 +198,7 @@ runFormPostNoNonce form = do
|
||||
m <- getYesod
|
||||
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
|
||||
let key = "_hasdata"
|
||||
let fragment = [HTML|<input type=hidden name=#{key}>|]
|
||||
@ -208,12 +211,12 @@ runFormGet form = do
|
||||
m <- getYesod
|
||||
runFormGeneric (form fragment) m langs env
|
||||
|
||||
type FormRender master msg m a =
|
||||
AForm ([FieldView (GGWidget master m ())] -> [FieldView (GGWidget master m ())]) msg m a
|
||||
type FormRender sub master a =
|
||||
AForm sub master a
|
||||
-> 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
|
||||
(res, views') <- aFormToForm aform
|
||||
let views = views' []
|
||||
@ -248,19 +251,24 @@ $forall view <- views
|
||||
|]
|
||||
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
|
||||
|
||||
-- | 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
|
||||
|
||||
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
|
||||
{ fieldParse = \ts -> do
|
||||
e1 <- fieldParse field ts
|
||||
case e1 of
|
||||
Left msg -> return $ Left msg
|
||||
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
|
||||
}
|
||||
|
||||
@ -12,18 +12,17 @@ import Yesod.Form.Types
|
||||
import Yesod.Form.Fields (FormMessage (MsgInputNotFound))
|
||||
import Data.Text (Text)
|
||||
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 Control.Monad (liftM)
|
||||
import Yesod.Widget (GWidget)
|
||||
import Yesod.Message (RenderMessage (..))
|
||||
import Control.Monad.IO.Class (MonadIO, liftIO) -- FIXME
|
||||
|
||||
type DText = [Text] -> [Text]
|
||||
newtype FormInput master a = FormInput { unFormInput :: master -> [Text] -> Env -> IO (Either DText a) }
|
||||
instance Functor (FormInput master) where
|
||||
newtype FormInput sub master a = FormInput { unFormInput :: master -> [Text] -> Env -> GGHandler sub master IO (Either DText a) }
|
||||
instance Functor (FormInput sub master) where
|
||||
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
|
||||
(FormInput f) <*> (FormInput x) = FormInput $ \c d e -> do
|
||||
res1 <- f c d e
|
||||
@ -34,39 +33,39 @@ instance Applicative (FormInput master) where
|
||||
(_, Left b) -> Left 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
|
||||
let filteredEnv = map snd $ filter (\y -> fst y == name) env
|
||||
emx <- fieldParse field $ filteredEnv
|
||||
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 (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
|
||||
let filteredEnv = map snd $ filter (\y -> fst y == name) env
|
||||
emx <- fieldParse field $ filteredEnv
|
||||
return $ case emx of
|
||||
Left e -> Left $ (:) $ renderMessage m l e
|
||||
Left (SomeMessage e) -> Left $ (:) $ renderMessage m l e
|
||||
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
|
||||
env <- liftM reqGetParams getRequest
|
||||
m <- getYesod
|
||||
l <- languages
|
||||
emx <- liftIO $ f m l env
|
||||
emx <- liftIOHandler $ f m l env
|
||||
case emx of
|
||||
Left errs -> invalidArgs $ errs []
|
||||
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
|
||||
env <- liftM fst runRequestBody
|
||||
m <- getYesod
|
||||
l <- languages
|
||||
emx <- liftIO $ f m l env
|
||||
emx <- liftIOHandler $ f m l env
|
||||
case emx of
|
||||
Left errs -> invalidArgs $ errs []
|
||||
Right x -> return x
|
||||
|
||||
@ -12,9 +12,9 @@ module Yesod.Form.MassInput
|
||||
import Yesod.Form.Types
|
||||
import Yesod.Form.Functions
|
||||
import Yesod.Form.Fields (boolField, FormMessage)
|
||||
import Yesod.Widget (GGWidget, whamlet)
|
||||
import Yesod.Widget (GWidget, GGWidget, whamlet)
|
||||
import Yesod.Message (RenderMessage)
|
||||
import Yesod.Handler (newIdent, GGHandler)
|
||||
import Yesod.Handler (newIdent, GHandler, GGHandler)
|
||||
import Text.Blaze (Html)
|
||||
import Control.Monad.Trans.Class (lift)
|
||||
import Data.Text (pack, Text)
|
||||
@ -50,11 +50,11 @@ up i = do
|
||||
IntCons _ is' -> put is' >> newFormIdent >> return ()
|
||||
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
|
||||
-> ([[FieldView xml]] -> xml)
|
||||
-> (Maybe a -> AForm ([FieldView xml] -> [FieldView xml]) master m a)
|
||||
-> (Maybe [a] -> AForm ([FieldView xml] -> [FieldView xml]) master m [a])
|
||||
-> ([[FieldView sub master]] -> xml)
|
||||
-> (Maybe a -> AForm sub master a)
|
||||
-> (Maybe [a] -> AForm sub master [a])
|
||||
inputList label fixXml single mdef = formToAForm $ do
|
||||
theId <- lift newIdent
|
||||
down 1
|
||||
@ -93,9 +93,9 @@ inputList label fixXml single mdef = formToAForm $ do
|
||||
, fvRequired = False
|
||||
})
|
||||
|
||||
withDelete :: (MonadIO mo, xml ~ GGWidget master m (), m ~ GGHandler sub master mo, Monad mo, RenderMessage master FormMessage)
|
||||
=> AForm ([FieldView xml] -> [FieldView xml]) master m a
|
||||
-> Form master m (Either xml (FormResult a, [FieldView xml]))
|
||||
withDelete :: (xml ~ GWidget sub master (), RenderMessage master FormMessage)
|
||||
=> AForm sub master a
|
||||
-> Form sub master (Either xml (FormResult a, [FieldView sub master]))
|
||||
withDelete af = do
|
||||
down 1
|
||||
deleteName <- newFormIdent
|
||||
@ -114,9 +114,9 @@ withDelete af = do
|
||||
up 1
|
||||
return res
|
||||
|
||||
fixme :: (xml ~ GGWidget master (GGHandler sub master mo) ())
|
||||
=> [Either xml (FormResult a, [FieldView xml])]
|
||||
-> (FormResult [a], [xml], [[FieldView xml]])
|
||||
fixme :: (xml ~ GWidget sub master ())
|
||||
=> [Either xml (FormResult a, [FieldView sub master])]
|
||||
-> (FormResult [a], [xml], [[FieldView sub master]])
|
||||
fixme eithers =
|
||||
(res, xmls, map snd rest)
|
||||
where
|
||||
@ -124,9 +124,8 @@ fixme eithers =
|
||||
res = sequenceA $ map fst rest
|
||||
|
||||
massDivs, massTable
|
||||
:: Monad m
|
||||
=> [[FieldView (GGWidget master m ())]]
|
||||
-> GGWidget master m ()
|
||||
:: [[FieldView sub master]]
|
||||
-> GWidget sub master ()
|
||||
massDivs viewss = [WHAMLET|
|
||||
$forall views <- viewss
|
||||
<fieldset>
|
||||
|
||||
@ -1,5 +1,6 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE ExistentialQuantification #-}
|
||||
module Yesod.Form.Types
|
||||
( -- * Helpers
|
||||
Enctype (..)
|
||||
@ -11,6 +12,7 @@ module Yesod.Form.Types
|
||||
, Form
|
||||
, AForm (..)
|
||||
-- * Build forms
|
||||
, SomeMessage (..)
|
||||
, Field (..)
|
||||
, FieldSettings (..)
|
||||
, FieldView (..)
|
||||
@ -24,7 +26,7 @@ import Text.Blaze (Html, ToHtml (toHtml))
|
||||
import Control.Applicative ((<$>), Applicative (..))
|
||||
import Control.Monad (liftM)
|
||||
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,
|
||||
-- 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 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
|
||||
{ unAForm :: (master, [Text]) -> Maybe (Env, FileEnv) -> Ints -> m (FormResult a, xml, Ints, Enctype)
|
||||
newtype AForm sub master a = AForm
|
||||
{ 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) =
|
||||
AForm $ \x y z -> liftM go $ a x y z
|
||||
where
|
||||
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)
|
||||
(AForm f) <*> (AForm g) = AForm $ \mr env ints -> do
|
||||
(a, b, ints', c) <- f mr env ints
|
||||
(x, y, ints'', z) <- g mr env ints'
|
||||
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
|
||||
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
|
||||
{ fsLabel :: msg
|
||||
{ fsLabel :: msg -- FIXME switch to SomeMessage?
|
||||
, fsTooltip :: Maybe msg
|
||||
, fsId :: Maybe Text
|
||||
, fsName :: Maybe Text
|
||||
@ -104,21 +103,23 @@ data FieldSettings msg = FieldSettings
|
||||
instance (a ~ Text) => IsString (FieldSettings a) where
|
||||
fromString s = FieldSettings (fromString s) Nothing Nothing Nothing
|
||||
|
||||
data FieldView xml = FieldView
|
||||
data FieldView sub master = FieldView
|
||||
{ fvLabel :: Html
|
||||
, fvTooltip :: Maybe Html
|
||||
, fvId :: Text
|
||||
, fvInput :: xml
|
||||
, fvInput :: GWidget sub master ()
|
||||
, fvErrors :: Maybe Html
|
||||
, fvRequired :: Bool
|
||||
}
|
||||
|
||||
data Field xml msg a = Field
|
||||
{ fieldParse :: [Text] -> IO (Either msg (Maybe a)) -- FIXME
|
||||
data SomeMessage master = forall msg. RenderMessage master msg => SomeMessage msg
|
||||
|
||||
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?
|
||||
, fieldView :: Text
|
||||
-> Text
|
||||
-> Either Text a
|
||||
-> Bool
|
||||
-> xml
|
||||
-> GWidget sub master ()
|
||||
}
|
||||
|
||||
@ -8,6 +8,7 @@ import Data.Text (Text, pack)
|
||||
import Network.Wai.Handler.Warp (run)
|
||||
import Data.Time (utctDay, getCurrentTime)
|
||||
import qualified Data.Text as T
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
|
||||
data Fruit = Apple | Banana | Pear
|
||||
deriving (Show, Enum, Bounded, Eq)
|
||||
@ -77,13 +78,13 @@ getMassR = do
|
||||
|]
|
||||
|
||||
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 (checkBool (>= 18) "Must be 18 or older" intField) "Age" 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" :: Text) intField) "Age" Nothing
|
||||
<*> areq (checkM inPast dayField) "Anniversary" Nothing
|
||||
where
|
||||
inPast x = do
|
||||
now <- getCurrentTime
|
||||
return $ if utctDay now < x then Left "Need a date in the past" else Right x
|
||||
now <- liftIO $ getCurrentTime
|
||||
return $ if utctDay now < x then Left ("Need a date in the past" :: Text) else Right x
|
||||
|
||||
getValidR = do
|
||||
((res, form), enctype) <- myValidForm
|
||||
|
||||
Loading…
Reference in New Issue
Block a user