yesod-form 1.2.1.3 → 1.3.0
raw patch · 10 files changed
+270/−361 lines, 10 filesdep +resourcetdep ~email-validatedep ~persistentdep ~yesod-core
Dependencies added: resourcet
Dependency ranges changed: email-validate, persistent, yesod-core, yesod-persistent
Files
- Yesod/Form.hs +0/−2
- Yesod/Form/Class.hs +0/−78
- Yesod/Form/Fields.hs +72/−79
- Yesod/Form/Functions.hs +123/−120
- Yesod/Form/Input.hs +10/−11
- Yesod/Form/Jquery.hs +10/−12
- Yesod/Form/MassInput.hs +15/−20
- Yesod/Form/Nic.hs +9/−16
- Yesod/Form/Types.hs +25/−17
- yesod-form.cabal +6/−6
Yesod/Form.hs view
@@ -3,12 +3,10 @@ ( module Yesod.Form.Types , module Yesod.Form.Functions , module Yesod.Form.Fields- , module Yesod.Form.Class , module Yesod.Form.Input ) where import Yesod.Form.Types import Yesod.Form.Functions import Yesod.Form.Fields hiding (FormMessage (..))-import Yesod.Form.Class import Yesod.Form.Input
− Yesod/Form/Class.hs
@@ -1,78 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleContexts #-}-module Yesod.Form.Class- ( {- FIXME ToForm (..)- , -} ToField (..)- ) where--import Text.Hamlet-import Yesod.Form.Fields-import Yesod.Form.Types-import Yesod.Form.Functions (areq, aopt)-import Data.Int (Int64)-import Data.Time (Day, TimeOfDay)-import Data.Text (Text)-import Yesod.Message (RenderMessage)--{--class ToForm a where- toForm :: AForm sub master a--}--class ToField a master where- toField :: RenderMessage master FormMessage- => FieldSettings master -> Maybe a -> AForm sub master a--{- FIXME-instance ToFormField String y where- toFormField = stringField-instance ToFormField (Maybe String) y where- toFormField = maybeStringField--}--instance ToField Text master where- toField = areq textField-instance ToField (Maybe Text) master where- toField = aopt textField--instance ToField Int master where- toField = areq intField-instance ToField (Maybe Int) master where- toField = aopt intField--instance ToField Int64 master where- toField = areq intField-instance ToField (Maybe Int64) master where- toField = aopt intField--instance ToField Double master where- toField = areq doubleField-instance ToField (Maybe Double) master where- toField = aopt doubleField--instance ToField Day master where- toField = areq dayField-instance ToField (Maybe Day) master where- toField = aopt dayField--instance ToField TimeOfDay master where- toField = areq timeField-instance ToField (Maybe TimeOfDay) master where- toField = aopt timeField--instance ToField Html master where- toField = areq htmlField-instance ToField (Maybe Html) master where- toField = aopt htmlField--instance ToField Textarea master where- toField = areq textareaField-instance ToField (Maybe Textarea) master where- toField = aopt textareaField--{- FIXME-instance ToFormField Bool y where- toFormField = boolField--}
Yesod/Form/Fields.hs view
@@ -49,24 +49,20 @@ import Yesod.Form.Types import Yesod.Form.I18n.English import Yesod.Form.Functions (parseHelper)-import Yesod.Handler (getMessageRender)-import Yesod.Widget (toWidget, whamlet, GWidget)-import Yesod.Message (RenderMessage (renderMessage), SomeMessage (..))+import Yesod.Core import Text.Hamlet-import Text.Blaze (ToMarkup (toMarkup), preEscapedToMarkup, unsafeByteString)+import Text.Blaze (ToMarkup (toMarkup), unsafeByteString) #define ToHtml ToMarkup #define toHtml toMarkup #define preEscapedText preEscapedToMarkup import Text.Cassius import Data.Time (Day, TimeOfDay(..)) import qualified Text.Email.Validate as Email-#if MIN_VERSION_email_validate(1, 0, 0) import Data.Text.Encoding (encodeUtf8, decodeUtf8With) import Data.Text.Encoding.Error (lenientDecode)-#endif import Network.URI (parseURI)-import Database.Persist (PersistField)-import Database.Persist.Store (Entity (..))+import Database.Persist.Sql (PersistField, PersistFieldSql)+import Database.Persist (Entity (..)) import Text.HTML.SanitizeXSS (sanitizeBalance) import Control.Monad (when, unless) import Data.Maybe (listToMaybe, fromMaybe)@@ -74,10 +70,7 @@ import qualified Blaze.ByteString.Builder.Html.Utf8 as B import Blaze.ByteString.Builder (writeByteString, toLazyByteString) import Blaze.ByteString.Builder.Internal.Write (fromWriteList)-import Database.Persist.Store (PersistEntityBackend)-#if MIN_VERSION_persistent(1, 1, 0)-import Database.Persist.Store (PersistMonadBackend)-#endif+import Database.Persist (PersistMonadBackend, PersistEntityBackend) import Text.Blaze.Html.Renderer.String (renderHtml) import qualified Data.ByteString as S@@ -86,11 +79,7 @@ import qualified Data.Text.Read import qualified Data.Map as Map-import Yesod.Handler (newIdent, lift)-import Yesod.Request (FileInfo)--import Yesod.Core (toPathPiece, GHandler, PathPiece, fromPathPiece)-import Yesod.Persist (selectList, runDB, Filter, SelectOpt, YesodPersistBackend, Key, YesodPersist, PersistEntity, PersistQuery)+import Yesod.Persist (selectList, runDB, Filter, SelectOpt, Key, YesodPersist, PersistEntity, PersistQuery, YesodDB) import Control.Arrow ((&&&)) import Control.Applicative ((<$>), (<|>))@@ -101,7 +90,7 @@ defaultFormMessage = englishFormMessage -intField :: (Integral i, RenderMessage master FormMessage) => Field sub master i+intField :: (Monad m, Integral i, RenderMessage (HandlerSite m) FormMessage) => Field m i intField = Field { fieldParse = parseHelper $ \s -> case Data.Text.Read.signed Data.Text.Read.decimal s of@@ -118,7 +107,7 @@ showVal = either id (pack . showI) showI x = show (fromIntegral x :: Integer) -doubleField :: RenderMessage master FormMessage => Field sub master Double+doubleField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Double doubleField = Field { fieldParse = parseHelper $ \s -> case Data.Text.Read.double s of@@ -133,7 +122,7 @@ } where showVal = either id (pack . show) -dayField :: RenderMessage master FormMessage => Field sub master Day+dayField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Day dayField = Field { fieldParse = parseHelper $ parseDate . unpack , fieldView = \theId name attrs val isReq -> toWidget [hamlet|@@ -144,7 +133,7 @@ } where showVal = either id (pack . show) -timeField :: RenderMessage master FormMessage => Field sub master TimeOfDay+timeField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m TimeOfDay timeField = Field { fieldParse = parseHelper parseTime , fieldView = \theId name attrs val isReq -> toWidget [hamlet|@@ -160,7 +149,7 @@ where fullSec = fromInteger $ floor $ todSec tod -htmlField :: RenderMessage master FormMessage => Field sub master Html+htmlField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Html htmlField = Field { fieldParse = parseHelper $ Right . preEscapedText . sanitizeBalance , fieldView = \theId name attrs val _isReq -> toWidget [hamlet|@@ -174,7 +163,7 @@ -- | A newtype wrapper around a 'Text' that converts newlines to HTML -- br-tags. newtype Textarea = Textarea { unTextarea :: Text }- deriving (Show, Read, Eq, PersistField, Ord)+ deriving (Show, Read, Eq, PersistField, PersistFieldSql, Ord) instance ToHtml Textarea where toHtml = unsafeByteString@@ -189,7 +178,7 @@ writeHtmlEscapedChar '\n' = writeByteString "<br>" writeHtmlEscapedChar c = B.writeHtmlEscapedChar c -textareaField :: RenderMessage master FormMessage => Field sub master Textarea+textareaField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Textarea textareaField = Field { fieldParse = parseHelper $ Right . Textarea , fieldView = \theId name attrs val _isReq -> toWidget [hamlet|@@ -199,8 +188,8 @@ , fieldEnctype = UrlEncoded } -hiddenField :: (PathPiece p, RenderMessage master FormMessage)- => Field sub master p+hiddenField :: (Monad m, PathPiece p, RenderMessage (HandlerSite m) FormMessage)+ => Field m p hiddenField = Field { fieldParse = parseHelper $ maybe (Left MsgValueRequired) Right . fromPathPiece , fieldView = \theId name attrs val _isReq -> toWidget [hamlet|@@ -210,7 +199,7 @@ , fieldEnctype = UrlEncoded } -textField :: RenderMessage master FormMessage => Field sub master Text+textField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Text textField = Field { fieldParse = parseHelper $ Right , fieldView = \theId name attrs val isReq ->@@ -221,7 +210,7 @@ , fieldEnctype = UrlEncoded } -passwordField :: RenderMessage master FormMessage => Field sub master Text+passwordField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Text passwordField = Field { fieldParse = parseHelper $ Right , fieldView = \theId name attrs val isReq -> toWidget [hamlet|@@ -292,19 +281,13 @@ then fail $ show $ msg $ pack xy else return $ fromIntegral (i :: Int) -emailField :: RenderMessage master FormMessage => Field sub master Text+emailField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Text emailField = Field { fieldParse = parseHelper $-#if MIN_VERSION_email_validate(1, 0, 0) \s -> case Email.canonicalizeEmail $ encodeUtf8 s of Just e -> Right $ decodeUtf8With lenientDecode e Nothing -> Left $ MsgInvalidEmail s-#else- \s -> if Email.isValid (unpack s)- then Right s- else Left $ MsgInvalidEmail s-#endif , fieldView = \theId name attrs val isReq -> toWidget [hamlet| $newline never <input id="#{theId}" name="#{name}" *{attrs} type="email" :isReq:required="" value="#{either id id val}">@@ -313,7 +296,7 @@ } type AutoFocus = Bool-searchField :: RenderMessage master FormMessage => AutoFocus -> Field sub master Text+searchField :: Monad m => RenderMessage (HandlerSite m) FormMessage => AutoFocus -> Field m Text searchField autoFocus = Field { fieldParse = parseHelper Right , fieldView = \theId name attrs val isReq -> do@@ -334,24 +317,25 @@ , fieldEnctype = UrlEncoded } -urlField :: RenderMessage master FormMessage => Field sub master Text+urlField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Text urlField = Field { fieldParse = parseHelper $ \s -> case parseURI $ unpack s of Nothing -> Left $ MsgInvalidUrl s Just _ -> Right s , fieldView = \theId name attrs val isReq ->- [whamlet|-$newline never-<input ##{theId} name=#{name} *{attrs} type=url :isReq:required value=#{either id id val}>-|]+ [whamlet|<input ##{theId} name=#{name} *{attrs} type=url :isReq:required value=#{either id id val}>|] , fieldEnctype = UrlEncoded } -selectFieldList :: (Eq a, RenderMessage master FormMessage, RenderMessage master msg) => [(msg, a)] -> Field sub master a+selectFieldList :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg)+ => [(msg, a)]+ -> Field (HandlerT site IO) a selectFieldList = selectField . optionsPairs -selectField :: (Eq a, RenderMessage master FormMessage) => GHandler sub master (OptionList a) -> Field sub master a+selectField :: (Eq a, RenderMessage site FormMessage)+ => HandlerT site IO (OptionList a)+ -> Field (HandlerT site IO) a selectField = selectFieldHelper (\theId name attrs inside -> [whamlet| $newline never@@ -366,12 +350,14 @@ <option value=#{value} :isSel:selected>#{text} |]) -- inside -multiSelectFieldList :: (Eq a, RenderMessage master FormMessage, RenderMessage master msg) => [(msg, a)] -> Field sub master [a]+multiSelectFieldList :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg)+ => [(msg, a)]+ -> Field (HandlerT site IO) [a] multiSelectFieldList = multiSelectField . optionsPairs -multiSelectField :: (Eq a, RenderMessage master FormMessage)- => GHandler sub master (OptionList a)- -> Field sub master [a]+multiSelectField :: (Eq a, RenderMessage site FormMessage)+ => HandlerT site IO (OptionList a)+ -> Field (HandlerT site IO) [a] multiSelectField ioptlist = Field parse view UrlEncoded where@@ -383,10 +369,9 @@ Just res -> return $ Right $ Just res view theId name attrs val isReq = do- opts <- fmap olOptions $ lift ioptlist+ opts <- fmap olOptions $ handlerToWidget ioptlist let selOpts = map (id &&& (optselected val)) opts [whamlet|-$newline never <select ##{theId} name=#{name} :isReq:required multiple *{attrs}> $forall (opt, optsel) <- selOpts <option value=#{optionExternalValue opt} :optsel:selected>#{optionDisplay opt}@@ -395,10 +380,14 @@ optselected (Left _) _ = False optselected (Right vals) opt = (optionInternalValue opt) `elem` vals -radioFieldList :: (Eq a, RenderMessage master FormMessage, RenderMessage master msg) => [(msg, a)] -> Field sub master a+radioFieldList :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg)+ => [(msg, a)]+ -> Field (HandlerT site IO) a radioFieldList = radioField . optionsPairs -radioField :: (Eq a, RenderMessage master FormMessage) => GHandler sub master (OptionList a) -> Field sub master a+radioField :: (Eq a, RenderMessage site FormMessage)+ => HandlerT site IO (OptionList a)+ -> Field (HandlerT site IO) a radioField = selectFieldHelper (\theId _name _attrs inside -> [whamlet| $newline never@@ -419,7 +408,7 @@ \#{text} |]) -boolField :: RenderMessage master FormMessage => Field sub master Bool+boolField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Bool boolField = Field { fieldParse = \e _ -> return $ boolParser e , fieldView = \theId name attrs val isReq -> [whamlet|@@ -455,7 +444,7 @@ -- -- Note that this makes the field always optional. ---checkBoxField :: RenderMessage m FormMessage => Field s m Bool+checkBoxField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Bool checkBoxField = Field { fieldParse = \e _ -> return $ checkBoxParser e , fieldView = \theId name attrs val _ -> [whamlet|@@ -491,7 +480,8 @@ , optionExternalValue :: Text } -optionsPairs :: RenderMessage master msg => [(msg, a)] -> GHandler sub master (OptionList a)+optionsPairs :: (MonadHandler m, RenderMessage (HandlerSite m) msg)+ => [(msg, a)] -> m (OptionList a) optionsPairs opts = do mr <- getMessageRender let mkOption external (display, internal) =@@ -501,22 +491,19 @@ } return $ mkOptionList (zipWith mkOption [1 :: Int ..] opts) -optionsEnum :: (Show a, Enum a, Bounded a) => GHandler sub master (OptionList a)+optionsEnum :: (MonadHandler m, Show a, Enum a, Bounded a) => m (OptionList a) optionsEnum = optionsPairs $ map (\x -> (pack $ show x, x)) [minBound..maxBound] -optionsPersist :: ( YesodPersist master, PersistEntity a-#if MIN_VERSION_persistent(1, 1, 0)- , PersistQuery (YesodPersistBackend master (GHandler sub master))+optionsPersist :: ( YesodPersist site, PersistEntity a+ , PersistQuery (YesodDB site) , PathPiece (Key a)- , PersistEntityBackend a ~ PersistMonadBackend (YesodPersistBackend master (GHandler sub master))-#else- , PersistQuery (YesodPersistBackend master) (GHandler sub master)- , PathPiece (Key (YesodPersistBackend master) a)- , PersistEntityBackend a ~ YesodPersistBackend master-#endif- , RenderMessage master msg+ , PersistEntityBackend a ~ PersistMonadBackend (YesodDB site)+ , RenderMessage site msg )- => [Filter a] -> [SelectOpt a] -> (a -> msg) -> GHandler sub master (OptionList (Entity a))+ => [Filter a]+ -> [SelectOpt a]+ -> (a -> msg)+ -> HandlerT site IO (OptionList (Entity a)) optionsPersist filts ords toDisplay = fmap mkOptionList $ do mr <- getMessageRender pairs <- runDB $ selectList filts ords@@ -527,17 +514,18 @@ }) pairs selectFieldHelper- :: (Eq a, RenderMessage master FormMessage)- => (Text -> Text -> [(Text, Text)] -> GWidget sub master () -> GWidget sub master ())- -> (Text -> Text -> Bool -> GWidget sub master ())- -> (Text -> Text -> [(Text, Text)] -> Text -> Bool -> Text -> GWidget sub master ())- -> GHandler sub master (OptionList a) -> Field sub master a+ :: (Eq a, RenderMessage site FormMessage)+ => (Text -> Text -> [(Text, Text)] -> WidgetT site IO () -> WidgetT site IO ())+ -> (Text -> Text -> Bool -> WidgetT site IO ())+ -> (Text -> Text -> [(Text, Text)] -> Text -> Bool -> Text -> WidgetT site IO ())+ -> HandlerT site IO (OptionList a)+ -> Field (HandlerT site IO) a selectFieldHelper outside onOpt inside opts' = Field { fieldParse = \x _ -> do opts <- opts' return $ selectParser opts x , fieldView = \theId name attrs val isReq -> do- opts <- fmap olOptions $ lift opts'+ opts <- fmap olOptions $ handlerToWidget opts' outside theId name attrs $ do unless isReq $ onOpt theId name $ not $ render opts val `elem` map optionExternalValue opts flip mapM_ opts $ \opt -> inside@@ -560,7 +548,8 @@ Nothing -> Left $ SomeMessage $ MsgInvalidEntry x Just y -> Right $ Just y -fileField :: RenderMessage master FormMessage => Field sub master FileInfo+fileField :: (Monad m, RenderMessage (HandlerSite m) FormMessage)+ => Field m FileInfo fileField = Field { fieldParse = \_ files -> return $ case files of@@ -572,8 +561,9 @@ , fieldEnctype = Multipart } -fileAFormReq :: RenderMessage master FormMessage => FieldSettings master -> AForm sub master FileInfo-fileAFormReq fs = AForm $ \(master, langs) menvs ints -> do+fileAFormReq :: (MonadHandler m, RenderMessage (HandlerSite m) FormMessage)+ => FieldSettings (HandlerSite m) -> AForm m FileInfo+fileAFormReq fs = AForm $ \(site, langs) menvs ints -> do let (name, ints') = case fsName fs of Just x -> (x, ints)@@ -588,11 +578,11 @@ case Map.lookup name fenv of Just (fi:_) -> (FormSuccess fi, Nothing) _ ->- let t = renderMessage master langs MsgValueRequired+ let t = renderMessage site langs MsgValueRequired in (FormFailure [t], Just $ toHtml t) let fv = FieldView- { fvLabel = toHtml $ renderMessage master langs $ fsLabel fs- , fvTooltip = fmap (toHtml . renderMessage master langs) $ fsTooltip fs+ { fvLabel = toHtml $ renderMessage site langs $ fsLabel fs+ , fvTooltip = fmap (toHtml . renderMessage site langs) $ fsTooltip fs , fvId = id' , fvInput = [whamlet| $newline never@@ -603,7 +593,10 @@ } return (res, (fv :), ints', Multipart) -fileAFormOpt :: RenderMessage master FormMessage => FieldSettings master -> AForm sub master (Maybe FileInfo)+fileAFormOpt :: MonadHandler m+ => RenderMessage (HandlerSite m) FormMessage+ => FieldSettings (HandlerSite m)+ -> AForm m (Maybe FileInfo) fileAFormOpt fs = AForm $ \(master, langs) menvs ints -> do let (name, ints') = case fsName fs of
Yesod/Form/Functions.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE FlexibleContexts #-}@@ -27,18 +28,16 @@ , FormRender , renderTable , renderDivs- , renderDivsNoLabels + , renderDivsNoLabels , renderBootstrap -- * Validation , check , checkBool , checkM , checkMMap- , checkMMod , customErrorMessage -- * Utilities , fieldSettingsLabel- , aformM , parseHelper ) where @@ -46,29 +45,23 @@ import Data.Text (Text, pack) import Control.Arrow (second) import Control.Monad.Trans.RWS (ask, get, put, runRWST, tell, evalRWST)-import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Class import Control.Monad (liftM, join) import Crypto.Classes (constTimeEq) import Text.Blaze (Markup, toMarkup) #define Html Markup #define toHtml toMarkup-import Yesod.Handler (GHandler, getRequest, runRequestBody, newIdent, getYesod)-import Yesod.Core (RenderMessage, SomeMessage (..))-import Yesod.Widget (GWidget, whamlet)-import Yesod.Request (reqToken, reqWaiRequest, reqGetParams, languages)+import Yesod.Core import Network.Wai (requestMethod) import Text.Hamlet (shamlet) import Data.Monoid (mempty) import Data.Maybe (listToMaybe, fromMaybe)-import Yesod.Message (RenderMessage (..)) import qualified Data.Map as Map import qualified Data.Text.Encoding as TE-import Control.Applicative ((<$>)) import Control.Arrow (first)-import Yesod.Request (FileInfo) -- | Get a unique identifier.-newFormIdent :: MForm sub master Text+newFormIdent :: Monad m => MForm m Text newFormIdent = do i <- get let i' = incrInts i@@ -78,54 +71,64 @@ incrInts (IntSingle i) = IntSingle $ i + 1 incrInts (IntCons i is) = (i + 1) `IntCons` is -formToAForm :: MForm sub master (FormResult a, [FieldView sub master]) -> AForm sub master a-formToAForm form = AForm $ \(master, langs) env ints -> do- ((a, xmls), ints', enc) <- runRWST form (env, master, langs) ints+formToAForm :: (HandlerSite m ~ site, Monad m)+ => MForm m (FormResult a, [FieldView site])+ -> AForm m a+formToAForm form = AForm $ \(site, langs) env ints -> do+ ((a, xmls), ints', enc) <- runRWST form (env, site, langs) ints return (a, (++) xmls, ints', enc) -aFormToForm :: AForm sub master a -> MForm sub master (FormResult a, [FieldView sub master] -> [FieldView sub master])+aFormToForm :: (Monad m, HandlerSite m ~ site)+ => AForm m a+ -> MForm m (FormResult a, [FieldView site] -> [FieldView site]) aFormToForm (AForm aform) = do ints <- get- (env, master, langs) <- ask- (a, xml, ints', enc) <- lift $ aform (master, langs) env ints+ (env, site, langs) <- ask+ (a, xml, ints', enc) <- lift $ aform (site, langs) env ints put ints' tell enc return (a, xml) -askParams :: MForm sub master (Maybe Env)+askParams :: Monad m => MForm m (Maybe Env) askParams = do (x, _, _) <- ask return $ liftM fst x -askFiles :: MForm sub master (Maybe FileEnv)+askFiles :: Monad m => MForm m (Maybe FileEnv) askFiles = do (x, _, _) <- ask return $ liftM snd x -mreq :: RenderMessage master FormMessage- => Field sub master a -> FieldSettings master -> Maybe a- -> MForm sub master (FormResult a, FieldView sub master)+mreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)+ => Field m a+ -> FieldSettings site+ -> Maybe a+ -> MForm m (FormResult a, FieldView site) mreq field fs mdef = mhelper field fs mdef (\m l -> FormFailure [renderMessage m l MsgValueRequired]) FormSuccess True -mopt :: Field sub master a -> FieldSettings master -> Maybe (Maybe a)- -> MForm sub master (FormResult (Maybe a), FieldView sub master)+mopt :: (site ~ HandlerSite m, MonadHandler m)+ => Field m a+ -> FieldSettings site+ -> Maybe (Maybe a)+ -> MForm m (FormResult (Maybe a), FieldView site) mopt field fs mdef = mhelper field fs (join mdef) (const $ const $ FormSuccess Nothing) (FormSuccess . Just) False -mhelper :: Field sub master a- -> FieldSettings master+mhelper :: (site ~ HandlerSite m, MonadHandler m)+ => Field m a+ -> FieldSettings site -> Maybe a- -> (master -> [Text] -> FormResult b) -- ^ on missing+ -> (site -> [Text] -> FormResult b) -- ^ on missing -> (a -> FormResult b) -- ^ on success -> Bool -- ^ is it required?- -> MForm sub master (FormResult b, FieldView sub master)+ -> MForm m (FormResult b, FieldView site) mhelper Field {..} FieldSettings {..} mdef onMissing onFound isReq = do tell fieldEnctype mp <- askParams name <- maybe newFormIdent return fsName theId <- lift $ maybe newIdent return fsId- (_, master, langs) <- ask- let mr2 = renderMessage master langs+ (_, site, langs) <- ask+ let mr2 = renderMessage site langs (res, val) <- case mp of Nothing -> return (FormMissing, maybe (Left "") Right mdef)@@ -135,10 +138,10 @@ files = fromMaybe [] $ mfs >>= Map.lookup name emx <- lift $ fieldParse mvals files return $ case emx of- Left (SomeMessage e) -> (FormFailure [renderMessage master langs e], maybe (Left "") Left (listToMaybe mvals))+ Left (SomeMessage e) -> (FormFailure [renderMessage site langs e], maybe (Left "") Left (listToMaybe mvals)) Right mx -> case mx of- Nothing -> (onMissing master langs, Left "")+ Nothing -> (onMissing site langs, Left "") Just x -> (onFound x, Right x) return (res, FieldView { fvLabel = toHtml $ mr2 fsLabel@@ -152,19 +155,27 @@ , fvRequired = isReq }) -areq :: RenderMessage master FormMessage- => Field sub master a -> FieldSettings master -> Maybe a- -> AForm sub master a-areq a b = formToAForm . fmap (second return) . mreq a b+areq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)+ => Field m a+ -> FieldSettings site+ -> Maybe a+ -> AForm m a+areq a b = formToAForm . liftM (second return) . mreq a b -aopt :: Field sub master a- -> FieldSettings master+aopt :: MonadHandler m+ => Field m a+ -> FieldSettings (HandlerSite m) -> Maybe (Maybe a)- -> AForm sub master (Maybe a)-aopt a b = formToAForm . fmap (second return) . mopt a b+ -> AForm m (Maybe a)+aopt a b = formToAForm . liftM (second return) . mopt a b -runFormGeneric :: MForm sub master a -> master -> [Text] -> Maybe (Env, FileEnv) -> GHandler sub master (a, Enctype)-runFormGeneric form master langs env = evalRWST form (env, master, langs) (IntSingle 1)+runFormGeneric :: Monad m+ => MForm m a+ -> HandlerSite m+ -> [Text]+ -> Maybe (Env, FileEnv)+ -> m (a, Enctype)+runFormGeneric form site langs env = evalRWST form (env, site, 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,@@ -175,27 +186,24 @@ -- For example, a common case is displaying a form on a GET request and having -- 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 -> MForm sub master (FormResult a, xml))- -> GHandler sub master ((FormResult a, xml), Enctype)+runFormPost :: (RenderMessage (HandlerSite m) FormMessage, MonadResource m, MonadHandler m)+ => (Html -> MForm m (FormResult a, xml))+ -> m ((FormResult a, xml), Enctype) runFormPost form = do env <- postEnv postHelper form env -postHelper :: RenderMessage master FormMessage- => (Html -> MForm sub master (FormResult a, xml))+postHelper :: (MonadHandler m, RenderMessage (HandlerSite m) FormMessage)+ => (Html -> MForm m (FormResult a, xml)) -> Maybe (Env, FileEnv)- -> GHandler sub master ((FormResult a, xml), Enctype)+ -> m ((FormResult a, xml), Enctype) postHelper form env = do req <- getRequest let tokenKey = "_token" let token = case reqToken req of Nothing -> mempty- Just n -> [shamlet|-$newline never-<input type=hidden name=#{tokenKey} value=#{n}>-|]+ Just n -> [shamlet|<input type=hidden name=#{tokenKey} value=#{n}>|] m <- getYesod langs <- languages ((res, xml), enctype) <- runFormGeneric (form token) m langs env@@ -215,12 +223,13 @@ -- page will both receive and incoming form and produce a new, blank form. For -- general usage, you can stick with @runFormPost@. generateFormPost- :: RenderMessage master FormMessage- => (Html -> MForm sub master (FormResult a, xml))- -> GHandler sub master (xml, Enctype)-generateFormPost form = first snd <$> postHelper form Nothing+ :: (RenderMessage (HandlerSite m) FormMessage, MonadHandler m)+ => (Html -> MForm m (FormResult a, xml))+ -> m (xml, Enctype)+generateFormPost form = first snd `liftM` postHelper form Nothing -postEnv :: GHandler sub master (Maybe (Env, FileEnv))+postEnv :: (MonadHandler m, MonadResource m)+ => m (Maybe (Env, FileEnv)) postEnv = do req <- getRequest if requestMethod (reqWaiRequest req) == "GET"@@ -230,14 +239,18 @@ let p' = Map.unionsWith (++) $ map (\(x, y) -> Map.singleton x [y]) p return $ Just (p', Map.unionsWith (++) $ map (\(k, v) -> Map.singleton k [v]) f) -runFormPostNoToken :: (Html -> MForm sub master (FormResult a, xml)) -> GHandler sub master ((FormResult a, xml), Enctype)+runFormPostNoToken :: MonadHandler m+ => (Html -> MForm m (FormResult a, xml))+ -> m ((FormResult a, xml), Enctype) runFormPostNoToken form = do langs <- languages m <- getYesod env <- postEnv runFormGeneric (form mempty) m langs env -runFormGet :: (Html -> MForm sub master a) -> GHandler sub master (a, Enctype)+runFormGet :: MonadHandler m+ => (Html -> MForm m a)+ -> m (a, Enctype) runFormGet form = do gets <- liftM reqGetParams getRequest let env =@@ -246,28 +259,30 @@ Just _ -> Just (Map.unionsWith (++) $ map (\(x, y) -> Map.singleton x [y]) gets, Map.empty) getHelper form env -generateFormGet :: (Html -> MForm sub master a) -> GHandler sub master (a, Enctype)+generateFormGet :: MonadHandler m+ => (Html -> MForm m a)+ -> m (a, Enctype) generateFormGet form = getHelper form Nothing getKey :: Text getKey = "_hasdata" -getHelper :: (Html -> MForm sub master a) -> Maybe (Env, FileEnv) -> GHandler sub master (a, Enctype)+getHelper :: MonadHandler m+ => (Html -> MForm m a)+ -> Maybe (Env, FileEnv)+ -> m (a, Enctype) getHelper form env = do- let fragment = [shamlet|-$newline never-<input type=hidden name=#{getKey}>-|]+ let fragment = [shamlet|<input type=hidden name=#{getKey}>|] langs <- languages m <- getYesod runFormGeneric (form fragment) m langs env -type FormRender sub master a =- AForm sub master a+type FormRender m a =+ AForm m a -> Html- -> MForm sub master (FormResult a, GWidget sub master ())+ -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ()) -renderTable, renderDivs, renderDivsNoLabels :: FormRender sub master a+renderTable, renderDivs, renderDivsNoLabels :: Monad m => FormRender m a renderTable aform fragment = do (res, views') <- aFormToForm aform let views = views' []@@ -292,7 +307,7 @@ -- | render a field inside a div, not displaying any label renderDivsNoLabels = renderDivsMaybeLabels False -renderDivsMaybeLabels :: Bool -> FormRender sub master a+renderDivsMaybeLabels :: Monad m => Bool -> FormRender m a renderDivsMaybeLabels withLabels aform fragment = do (res, views') <- aFormToForm aform let views = views' []@@ -326,40 +341,42 @@ -- > ^{formWidget} -- > <div .form-actions> -- > <input .btn .primary type=submit value=_{MsgSubmit}>-renderBootstrap :: FormRender sub master a+renderBootstrap :: Monad m => FormRender m a renderBootstrap aform fragment = do (res, views') <- aFormToForm aform let views = views' [] has (Just _) = True has Nothing = False let widget = [whamlet|-$newline never-\#{fragment}-$forall view <- views- <div .control-group .clearfix :fvRequired view:.required :not $ fvRequired view:.optional :has $ fvErrors view:.error>- <label .control-label for=#{fvId view}>#{fvLabel view}- <div .controls .input>- ^{fvInput view}- $maybe tt <- fvTooltip view- <span .help-block>#{tt}- $maybe err <- fvErrors view- <span .help-block>#{err}-|]+ $newline never+ \#{fragment}+ $forall view <- views+ <div .control-group .clearfix :fvRequired view:.required :not $ fvRequired view:.optional :has $ fvErrors view:.error>+ <label .control-label for=#{fvId view}>#{fvLabel view}+ <div .controls .input>+ ^{fvInput view}+ $maybe tt <- fvTooltip view+ <span .help-block>#{tt}+ $maybe err <- fvErrors view+ <span .help-block>#{err}+ |] return (res, widget) -check :: RenderMessage master msg- => (a -> Either msg a) -> Field sub master a -> Field sub master a+check :: (Monad m, RenderMessage (HandlerSite m) msg)+ => (a -> Either msg a)+ -> Field m a+ -> Field m a check f = checkM $ return . f -- | Return the given error message if the predicate is false.-checkBool :: RenderMessage master msg- => (a -> Bool) -> msg -> Field sub master a -> Field sub master a+checkBool :: (Monad m, RenderMessage (HandlerSite m) msg)+ => (a -> Bool) -> msg -> Field m a -> Field m a checkBool b s = check $ \x -> if b x then Right x else Left s -checkM :: RenderMessage master msg- => (a -> GHandler sub master (Either msg a))- -> Field sub master a- -> Field sub master a+checkM :: (Monad m, RenderMessage (HandlerSite m) msg)+ => (a -> m (Either msg a))+ -> Field m a+ -> Field m a checkM f = checkMMap f id -- | Same as 'checkM', but modifies the datatype.@@ -368,56 +385,42 @@ -- the new datatype to the old one (the second argument to this function). -- -- Since 1.1.2-checkMMap :: RenderMessage master msg- => (a -> GHandler sub master (Either msg b))+checkMMap :: (Monad m, RenderMessage (HandlerSite m) msg)+ => (a -> m (Either msg b)) -> (b -> a)- -> Field sub master a- -> Field sub master b+ -> Field m a+ -> Field m b checkMMap f inv field = field { fieldParse = \ts fs -> do e1 <- fieldParse field ts fs case e1 of Left msg -> return $ Left msg Right Nothing -> return $ Right Nothing- Right (Just a) -> fmap (either (Left . SomeMessage) (Right . Just)) $ f a+ Right (Just a) -> liftM (either (Left . SomeMessage) (Right . Just)) $ f a , fieldView = \i n a eres req -> fieldView field i n a (fmap inv eres) req } --- | Deprecated synonym for 'checkMMap'.------ Since 1.1.1-checkMMod :: RenderMessage master msg- => (a -> GHandler sub master (Either msg b))- -> (b -> a)- -> Field sub master a- -> Field sub master b-checkMMod = checkMMap-{-# DEPRECATED checkMMod "Please use checkMMap instead" #-}- -- | Allows you to overwrite the error message on parse error.-customErrorMessage :: SomeMessage master -> Field sub master a -> Field sub master a-customErrorMessage msg field = field { fieldParse = \ts fs -> fmap (either-(const $ Left msg) Right) $ fieldParse field ts fs }+customErrorMessage :: Monad m => SomeMessage (HandlerSite m) -> Field m a -> Field m a+customErrorMessage msg field = field+ { fieldParse = \ts fs ->+ liftM (either (const $ Left msg) Right)+ $ fieldParse field ts fs+ } -- | Generate a 'FieldSettings' from the given label.-fieldSettingsLabel :: RenderMessage master msg => msg -> FieldSettings master+fieldSettingsLabel :: RenderMessage site msg => msg -> FieldSettings site fieldSettingsLabel msg = FieldSettings (SomeMessage msg) Nothing Nothing Nothing [] --- | Generate an 'AForm' that gets its value from the given action.-aformM :: GHandler sub master a -> AForm sub master a-aformM action = AForm $ \_ _ ints -> do- value <- action- return (FormSuccess value, id, ints, mempty)- -- | A helper function for creating custom fields. -- -- This is intended to help with the common case where a single input value is -- required, such as when parsing a text field. -- -- Since 1.1-parseHelper :: (Monad m, RenderMessage master FormMessage)+parseHelper :: (Monad m, RenderMessage site FormMessage) => (Text -> Either FormMessage a)- -> [Text] -> [FileInfo] -> m (Either (SomeMessage master) (Maybe a))+ -> [Text] -> [FileInfo] -> m (Either (SomeMessage site) (Maybe a)) parseHelper _ [] _ = return $ Right Nothing parseHelper _ ("":_) _ = return $ Right Nothing parseHelper f (x:_) _ = return $ either (Left . SomeMessage) (Right . Just) $ f x
Yesod/Form/Input.hs view
@@ -11,19 +11,17 @@ import Yesod.Form.Types import Data.Text (Text) import Control.Applicative (Applicative (..))-import Yesod.Handler (GHandler, invalidArgs, runRequestBody, getRequest, getYesod)-import Yesod.Request (reqGetParams, languages)+import Yesod.Core import Control.Monad (liftM)-import Yesod.Message (RenderMessage (..), SomeMessage (..)) import qualified Data.Map as Map import Data.Maybe (fromMaybe) import Control.Arrow ((***)) type DText = [Text] -> [Text]-newtype FormInput sub master a = FormInput { unFormInput :: master -> [Text] -> Env -> FileEnv -> GHandler sub master (Either DText a) }-instance Functor (FormInput sub master) where- fmap a (FormInput f) = FormInput $ \c d e e' -> fmap (either Left (Right . a)) $ f c d e e'-instance Applicative (FormInput sub master) where+newtype FormInput m a = FormInput { unFormInput :: HandlerSite m -> [Text] -> Env -> FileEnv -> m (Either DText a) }+instance Monad m => Functor (FormInput m) where+ fmap a (FormInput f) = FormInput $ \c d e e' -> liftM (either Left (Right . a)) $ f c d e e'+instance Monad m => Applicative (FormInput m) where pure = FormInput . const . const . const . const . return . Right (FormInput f) <*> (FormInput x) = FormInput $ \c d e e' -> do res1 <- f c d e e'@@ -34,7 +32,8 @@ (_, Left b) -> Left b (Right a, Right b) -> Right $ a b -ireq :: (RenderMessage master FormMessage) => Field sub master a -> Text -> FormInput sub master a+ireq :: (Monad m, RenderMessage (HandlerSite m) FormMessage)+ => Field m a -> Text -> FormInput m a ireq field name = FormInput $ \m l env fenv -> do let filteredEnv = fromMaybe [] $ Map.lookup name env filteredFEnv = fromMaybe [] $ Map.lookup name fenv@@ -44,7 +43,7 @@ Right Nothing -> Left $ (:) $ renderMessage m l $ MsgInputNotFound name Right (Just a) -> Right a -iopt :: Field sub master a -> Text -> FormInput sub master (Maybe a)+iopt :: Monad m => Field m a -> Text -> FormInput m (Maybe a) iopt field name = FormInput $ \m l env fenv -> do let filteredEnv = fromMaybe [] $ Map.lookup name env filteredFEnv = fromMaybe [] $ Map.lookup name fenv@@ -53,7 +52,7 @@ Left (SomeMessage e) -> Left $ (:) $ renderMessage m l e Right x -> Right x -runInputGet :: FormInput sub master a -> GHandler sub master a+runInputGet :: MonadHandler m => FormInput m a -> m a runInputGet (FormInput f) = do env <- liftM (toMap . reqGetParams) getRequest m <- getYesod@@ -66,7 +65,7 @@ toMap :: [(Text, a)] -> Map.Map Text [a] toMap = Map.unionsWith (++) . map (\(x, y) -> Map.singleton x [y]) -runInputPost :: FormInput sub master a -> GHandler sub master a+runInputPost :: MonadHandler m => FormInput m a -> m a runInputPost (FormInput f) = do (env, fenv) <- liftM (toMap *** toMap) runRequestBody m <- getYesod
Yesod/Form/Jquery.hs view
@@ -12,18 +12,14 @@ , Default (..) ) where -import Yesod.Handler-import Yesod.Core (Route)+import Yesod.Core import Yesod.Form-import Yesod.Widget import Data.Time (Day) import Data.Default import Text.Hamlet (shamlet) import Text.Julius (julius, rawJS) import Data.Text (Text, pack, unpack) import Data.Monoid (mconcat)-import Yesod.Core (RenderMessage)-import Data.Aeson (toJSON) -- | Gets the Google hosted jQuery UI 1.8 CSS file with the given theme. googleHostedJqueryUiCss :: Text -> Text@@ -56,7 +52,7 @@ urlJqueryUiDateTimePicker :: a -> Either (Route a) Text urlJqueryUiDateTimePicker _ = Right "http://github.com/gregwebs/jquery.ui.datetimepicker/raw/master/jquery.ui.datetimepicker.js" -jqueryDayField :: (RenderMessage master FormMessage, YesodJquery master) => JqueryDaySettings -> Field sub master Day+jqueryDayField :: (RenderMessage site FormMessage, YesodJquery site) => JqueryDaySettings -> Field (HandlerT site IO) Day jqueryDayField jds = Field { fieldParse = parseHelper $ maybe (Left MsgInvalidDay)@@ -100,8 +96,8 @@ , "]" ] -jqueryAutocompleteField :: (RenderMessage master FormMessage, YesodJquery master)- => Route master -> Field sub master Text+jqueryAutocompleteField :: (RenderMessage site FormMessage, YesodJquery site)+ => Route site -> Field (HandlerT site IO) Text jqueryAutocompleteField src = Field { fieldParse = parseHelper $ Right , fieldView = \theId name attrs val isReq -> do@@ -118,14 +114,16 @@ , fieldEnctype = UrlEncoded } -addScript' :: (master -> Either (Route master) Text) -> GWidget sub master ()+addScript' :: (HandlerSite m ~ site, MonadWidget m) => (site -> Either (Route site) Text) -> m () addScript' f = do- y <- lift getYesod+ y <- getYesod addScriptEither $ f y -addStylesheet' :: (y -> Either (Route y) Text) -> GWidget sub y ()+addStylesheet' :: (MonadWidget m, HandlerSite m ~ site)+ => (site -> Either (Route site) Text)+ -> m () addStylesheet' f = do- y <- lift getYesod+ y <- getYesod addStylesheetEither $ f y readMay :: Read a => String -> Maybe a
Yesod/Form/MassInput.hs view
@@ -12,11 +12,7 @@ import Yesod.Form.Types import Yesod.Form.Functions import Yesod.Form.Fields (boolField)-import Yesod.Widget (GWidget, whamlet)-import Yesod.Message (RenderMessage)-import Yesod.Handler (newIdent, GHandler)-import Text.Blaze.Html (Html)-import Control.Monad.Trans.Class (lift)+import Yesod.Core import Control.Monad.Trans.RWS (get, put, ask) import Data.Maybe (fromMaybe) import Data.Text.Read (decimal)@@ -25,9 +21,8 @@ import Data.Traversable (sequenceA) import qualified Data.Map as Map import Data.Maybe (listToMaybe)-import Yesod.Core (SomeMessage (SomeMessage)) -down :: Int -> MForm sub master ()+down :: Monad m => Int -> MForm m () down 0 = return () down i | i < 0 = error "called down with a negative number" down i = do@@ -35,7 +30,7 @@ put $ IntCons 0 is down $ i - 1 -up :: Int -> MForm sub master ()+up :: Monad m => Int -> MForm m () up 0 = return () up i | i < 0 = error "called down with a negative number" up i = do@@ -45,11 +40,11 @@ IntCons _ is' -> put is' >> newFormIdent >> return () up $ i - 1 -inputList :: (m ~ GHandler sub master, xml ~ GWidget sub master (), RenderMessage master FormMessage)+inputList :: (m ~ HandlerT site IO, xml ~ WidgetT site IO (), RenderMessage site FormMessage) => Html- -> ([[FieldView sub master]] -> xml)- -> (Maybe a -> AForm sub master a)- -> (Maybe [a] -> AForm sub master [a])+ -> ([[FieldView site]] -> xml)+ -> (Maybe a -> AForm (HandlerT site IO) a)+ -> (Maybe [a] -> AForm (HandlerT site IO) [a]) inputList label fixXml single mdef = formToAForm $ do theId <- lift newIdent down 1@@ -89,9 +84,9 @@ , fvRequired = False }]) -withDelete :: (xml ~ GWidget sub master (), RenderMessage master FormMessage)- => AForm sub master a- -> MForm sub master (Either xml (FormResult a, [FieldView sub master]))+withDelete :: (xml ~ WidgetT site IO (), RenderMessage site FormMessage)+ => AForm (HandlerT site IO) a+ -> MForm (HandlerT site IO) (Either xml (FormResult a, [FieldView site])) withDelete af = do down 1 deleteName <- newFormIdent@@ -114,9 +109,9 @@ up 1 return res -fixme :: (xml ~ GWidget sub master ())- => [Either xml (FormResult a, [FieldView sub master])]- -> (FormResult [a], [xml], [[FieldView sub master]])+fixme :: (xml ~ WidgetT site IO ())+ => [Either xml (FormResult a, [FieldView site])]+ -> (FormResult [a], [xml], [[FieldView site]]) fixme eithers = (res, xmls, map snd rest) where@@ -124,8 +119,8 @@ res = sequenceA $ map fst rest massDivs, massTable- :: [[FieldView sub master]]- -> GWidget sub master ()+ :: [[FieldView site]]+ -> WidgetT site IO () massDivs viewss = [whamlet| $newline never $forall views <- viewss
Yesod/Form/Nic.hs view
@@ -9,21 +9,12 @@ , nicHtmlField ) where -import Yesod.Handler-import Yesod.Core (Route, ScriptLoadPosition(..), jsLoader, Yesod)+import Yesod.Core import Yesod.Form-import Yesod.Widget import Text.HTML.SanitizeXSS (sanitizeBalance)-import Text.Hamlet (Html, shamlet)+import Text.Hamlet (shamlet) import Text.Julius (julius, rawJS)-#if MIN_VERSION_blaze_html(0, 5, 0)-import Text.Blaze (preEscapedToMarkup) import Text.Blaze.Html.Renderer.String (renderHtml)-#define preEscapedText preEscapedToMarkup-#else-import Text.Blaze (preEscapedText)-import Text.Blaze.Renderer.String (renderHtml)-#endif import Data.Text (Text, pack) import Data.Maybe (listToMaybe) @@ -32,16 +23,16 @@ urlNicEdit :: a -> Either (Route a) Text urlNicEdit _ = Right "http://js.nicedit.com/nicEdit-latest.js" -nicHtmlField :: YesodNic master => Field sub master Html+nicHtmlField :: YesodNic site => Field (HandlerT site IO) Html nicHtmlField = Field- { fieldParse = \e _ -> return . Right . fmap (preEscapedText . sanitizeBalance) . listToMaybe $ e+ { fieldParse = \e _ -> return . Right . fmap (preEscapedToMarkup . sanitizeBalance) . listToMaybe $ e , fieldView = \theId name attrs val _isReq -> do toWidget [shamlet| $newline never <textarea id="#{theId}" *{attrs} name="#{name}" .html>#{showVal val} |] addScript' urlNicEdit- master <- lift getYesod+ master <- getYesod toWidget $ case jsLoader master of BottomOfHeadBlocking -> [julius|@@ -55,7 +46,9 @@ where showVal = either id (pack . renderHtml) -addScript' :: (y -> Either (Route y) Text) -> GWidget sub y ()+addScript' :: (MonadWidget m, HandlerSite m ~ site)+ => (site -> Either (Route site) Text)+ -> m () addScript' f = do- y <- lift getYesod+ y <- getYesod addScriptEither $ f y
Yesod/Form/Types.hs view
@@ -22,7 +22,6 @@ ) where import Control.Monad.Trans.RWS (RWST)-import Yesod.Request (FileInfo) import Data.Text (Text) import Data.Monoid (Monoid (..)) import Text.Blaze (Markup, ToMarkup (toMarkup))@@ -31,8 +30,9 @@ #define toHtml toMarkup import Control.Applicative ((<$>), Applicative (..)) import Control.Monad (liftM)+import Control.Monad.Trans.Class import Data.String (IsString (..))-import Yesod.Core (GHandler, GWidget, SomeMessage, MonadLift (..))+import Yesod.Core import qualified Data.Map as Map -- | A form can produce three different results: there was no data available,@@ -79,27 +79,35 @@ type Env = Map.Map Text [Text] type FileEnv = Map.Map Text [FileInfo] -type Lang = Text-type MForm sub master a = RWST (Maybe (Env, FileEnv), master, [Lang]) Enctype Ints (GHandler sub master) a+type MForm m a = RWST+ (Maybe (Env, FileEnv), HandlerSite m, [Lang])+ Enctype+ Ints+ m+ a -newtype AForm sub master a = AForm- { unAForm :: (master, [Text]) -> Maybe (Env, FileEnv) -> Ints -> GHandler sub master (FormResult a, [FieldView sub master] -> [FieldView sub master], Ints, Enctype)+newtype AForm m a = AForm+ { unAForm :: (HandlerSite m, [Text])+ -> Maybe (Env, FileEnv)+ -> Ints+ -> m (FormResult a, [FieldView (HandlerSite m)] -> [FieldView (HandlerSite m)], Ints, Enctype) }-instance Functor (AForm sub master) where+instance Monad m => Functor (AForm m) 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 Applicative (AForm sub master) where+instance Monad m => Applicative (AForm m) 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 Monoid a => Monoid (AForm sub master a) where+instance (Monad m, Monoid a) => Monoid (AForm m a) where mempty = pure mempty mappend a b = mappend <$> a <*> b-instance MonadLift (GHandler sub master) (AForm sub master) where++instance MonadTrans AForm where lift f = AForm $ \_ _ ints -> do x <- f return (FormSuccess x, id, ints, mempty)@@ -115,26 +123,26 @@ instance IsString (FieldSettings a) where fromString s = FieldSettings (fromString s) Nothing Nothing Nothing [] -data FieldView sub master = FieldView+data FieldView site = FieldView { fvLabel :: Html , fvTooltip :: Maybe Html , fvId :: Text- , fvInput :: GWidget sub master ()+ , fvInput :: WidgetT site IO () , fvErrors :: Maybe Html , fvRequired :: Bool } -type FieldViewFunc sub master a+type FieldViewFunc m a = Text -- ^ ID -> Text -- ^ Name -> [(Text, Text)] -- ^ Attributes -> Either Text a -- ^ Either (invalid text) or (legitimate result) -> Bool -- ^ Required?- -> GWidget sub master ()+ -> WidgetT (HandlerSite m) IO () -data Field sub master a = Field- { fieldParse :: [Text] -> [FileInfo] -> GHandler sub master (Either (SomeMessage master) (Maybe a))- , fieldView :: FieldViewFunc sub master a+data Field m a = Field+ { fieldParse :: [Text] -> [FileInfo] -> m (Either (SomeMessage (HandlerSite m)) (Maybe a))+ , fieldView :: FieldViewFunc m a , fieldEnctype :: Enctype }
yesod-form.cabal view
@@ -1,5 +1,5 @@ name: yesod-form-version: 1.2.1.3+version: 1.3.0 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -14,20 +14,20 @@ library build-depends: base >= 4 && < 5- , yesod-core >= 1.1 && < 1.2- , yesod-persistent >= 1.1 && < 1.2+ , yesod-core >= 1.2 && < 1.3+ , yesod-persistent >= 1.2 && < 1.3 , time >= 1.1.4 , hamlet >= 1.1 && < 1.2 , shakespeare-css >= 1.0 && < 1.1 , shakespeare-js >= 1.0.2 && < 1.2- , persistent >= 1.0 && < 1.2+ , persistent >= 1.2 && < 1.3 , template-haskell , transformers >= 0.2.2 , data-default , xss-sanitize >= 0.3.0.1 , blaze-builder >= 0.2.1.4 , network >= 2.2- , email-validate >= 0.2.6+ , email-validate >= 1.0 , bytestring >= 0.9.1.4 , text >= 0.9 , wai >= 1.3@@ -37,9 +37,9 @@ , attoparsec >= 0.10 , crypto-api >= 0.8 , aeson+ , resourcet exposed-modules: Yesod.Form- Yesod.Form.Class Yesod.Form.Types Yesod.Form.Functions Yesod.Form.Input