yesod-form 0.3.4.2 → 0.4.1
raw patch · 9 files changed
+277/−213 lines, 9 filesdep ~persistentdep ~shakespeare-jsdep ~text
Dependency ranges changed: persistent, shakespeare-js, text, wai, yesod-core, yesod-persistent
Files
- Yesod/Form/Fields.hs +137/−99
- Yesod/Form/Functions.hs +62/−13
- Yesod/Form/I18n/German.hs +26/−0
- Yesod/Form/Input.hs +4/−4
- Yesod/Form/Jquery.hs +20/−69
- Yesod/Form/MassInput.hs +6/−6
- Yesod/Form/Nic.hs +4/−3
- Yesod/Form/Types.hs +8/−9
- yesod-form.cabal +10/−10
Yesod/Form/Fields.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE CPP #-}@@ -18,22 +19,24 @@ , htmlField , emailField , searchField- , selectField- , multiSelectField , AutoFocus , urlField , doubleField , parseDate , parseTime , Textarea (..)- , radioField , boolField+ , checkBoxField -- * File 'AForm's , fileAFormReq , fileAFormOpt -- * Options- , selectField'- , radioField'+ , selectField+ , selectFieldList+ , radioField+ , radioFieldList+ , multiSelectField+ , multiSelectFieldList , Option (..) , OptionList (..) , mkOptionList@@ -44,6 +47,7 @@ import Yesod.Form.Types import Yesod.Form.I18n.English+import Yesod.Handler (getMessageRender) import Yesod.Widget import Yesod.Message (RenderMessage (renderMessage), SomeMessage (..)) import Text.Hamlet@@ -53,30 +57,29 @@ import qualified Text.Email.Validate as Email import Network.URI (parseURI) import Database.Persist (PersistField)+import Database.Persist.Store (Entity (..)) import Text.HTML.SanitizeXSS (sanitizeBalance) import Control.Monad (when, unless)-import Data.List (intersect, nub)-import Data.Either (rights)-import Data.Maybe (catMaybes, listToMaybe)+import Data.Maybe (listToMaybe) 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) import Text.Blaze.Renderer.String (renderHtml) import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import Data.Text (Text, unpack, pack)+import qualified Data.Text as T import qualified Data.Text.Read-import Control.Monad.Trans.Class (lift) -import Control.Applicative ((<$>)) import qualified Data.Map as Map-import Yesod.Handler (newIdent, liftIOHandler)+import Yesod.Handler (newIdent, lift) import Yesod.Request (FileInfo) -import Yesod.Core (toSinglePiece, GGHandler, SinglePiece)-import Yesod.Persist (selectList, runDB, Filter, SelectOpt, YesodPersistBackend, Key, YesodPersist, PersistEntity, PersistBackend)+import Yesod.Core (toPathPiece, GHandler, PathPiece)+import Yesod.Persist (selectList, runDB, Filter, SelectOpt, YesodPersistBackend, Key, YesodPersist, PersistEntity, PersistQuery) import Control.Arrow ((&&&)) #if __GLASGOW_HASKELL__ >= 700@@ -93,6 +96,7 @@ #define HTML $html #endif +import Control.Applicative ((<$>)) defaultFormMessage :: FormMessage -> Text defaultFormMessage = englishFormMessage@@ -110,9 +114,9 @@ Right (a, "") -> Right a _ -> Left $ MsgInvalidInteger s - , fieldView = \theId name val isReq -> addHamlet+ , fieldView = \theId name theClass val isReq -> addHamlet [HAMLET|\-<input id="#{theId}" name="#{name}" type="number" :isReq:required="" value="#{showVal val}">+<input id="#{theId}" name="#{name}" :not (null theClass):class="#{T.intercalate " " theClass}" type="number" :isReq:required="" value="#{showVal val}"> |] } where@@ -126,9 +130,9 @@ Right (a, "") -> Right a _ -> Left $ MsgInvalidNumber s - , fieldView = \theId name val isReq -> addHamlet+ , fieldView = \theId name theClass val isReq -> addHamlet [HAMLET|\-<input id="#{theId}" name="#{name}" type="text" :isReq:required="" value="#{showVal val}">+<input id="#{theId}" name="#{name}" :not (null theClass):class="#{T.intercalate " " theClass}" type="text" :isReq:required="" value="#{showVal val}"> |] } where showVal = either id (pack . show)@@ -136,9 +140,9 @@ dayField :: RenderMessage master FormMessage => Field sub master Day dayField = Field { fieldParse = blank $ parseDate . unpack- , fieldView = \theId name val isReq -> addHamlet+ , fieldView = \theId name theClass val isReq -> addHamlet [HAMLET|\-<input id="#{theId}" name="#{name}" type="date" :isReq:required="" value="#{showVal val}">+<input id="#{theId}" name="#{name}" :not (null theClass):class="#{T.intercalate " " theClass}" type="date" :isReq:required="" value="#{showVal val}"> |] } where showVal = either id (pack . show)@@ -146,9 +150,9 @@ timeField :: RenderMessage master FormMessage => Field sub master TimeOfDay timeField = Field { fieldParse = blank $ parseTime . unpack- , fieldView = \theId name val isReq -> addHamlet+ , fieldView = \theId name theClass val isReq -> addHamlet [HAMLET|\-<input id="#{theId}" name="#{name}" :isReq:required="" value="#{showVal val}">+<input id="#{theId}" name="#{name}" :not (null theClass):class="#{T.intercalate "" theClass}" :isReq:required="" value="#{showVal val}"> |] } where@@ -161,9 +165,10 @@ htmlField :: RenderMessage master FormMessage => Field sub master Html htmlField = Field { fieldParse = blank $ Right . preEscapedText . sanitizeBalance- , fieldView = \theId name val _isReq -> addHamlet+ , fieldView = \theId name theClass val _isReq -> addHamlet+ -- FIXME: There was a class="html" attribute, for what purpose? [HAMLET|\-<textarea id="#{theId}" name="#{name}" .html>#{showVal val}+<textarea id="#{theId}" name="#{name}" :not (null theClass):class=#{T.intercalate " " theClass}>#{showVal val} |] } where showVal = either id (pack . renderHtml)@@ -189,36 +194,36 @@ textareaField :: RenderMessage master FormMessage => Field sub master Textarea textareaField = Field { fieldParse = blank $ Right . Textarea- , fieldView = \theId name val _isReq -> addHamlet+ , fieldView = \theId name theClass val _isReq -> addHamlet [HAMLET|\-<textarea id="#{theId}" name="#{name}">#{either id unTextarea val}+<textarea id="#{theId}" name="#{name}" :not (null theClass):class="#{T.intercalate " " theClass}">#{either id unTextarea val} |] } hiddenField :: RenderMessage master FormMessage => Field sub master Text hiddenField = Field { fieldParse = blank $ Right- , fieldView = \theId name val _isReq -> addHamlet+ , fieldView = \theId name theClass val _isReq -> addHamlet [HAMLET|\-<input type="hidden" id="#{theId}" name="#{name}" value="#{either id id val}">+<input type="hidden" id="#{theId}" name="#{name}" :not (null theClass):class="#{T.intercalate " " theClass}" value="#{either id id val}"> |] } textField :: RenderMessage master FormMessage => Field sub master Text textField = Field { fieldParse = blank $ Right- , fieldView = \theId name val isReq ->+ , fieldView = \theId name theClass val isReq -> [WHAMLET|-<input id="#{theId}" name="#{name}" type="text" :isReq:required value="#{either id id val}">+<input id="#{theId}" name="#{name}" :not (null theClass):class="#{T.intercalate " " theClass}" type="text" :isReq:required value="#{either id id val}"> |] } passwordField :: RenderMessage master FormMessage => Field sub master Text passwordField = Field { fieldParse = blank $ Right- , fieldView = \theId name val isReq -> addHamlet+ , fieldView = \theId name theClass val isReq -> addHamlet [HAMLET|\-<input id="#{theId}" name="#{name}" type="password" :isReq:required="" value="#{either id id val}">+<input id="#{theId}" name="#{name}" :not (null theClass):class="#{T.intercalate " " theClass}" type="password" :isReq:required="" value="#{either id id val}"> |] } @@ -266,9 +271,9 @@ \s -> if Email.isValid (unpack s) then Right s else Left $ MsgInvalidEmail s- , fieldView = \theId name val isReq -> addHamlet+ , fieldView = \theId name theClass val isReq -> addHamlet [HAMLET|\-<input id="#{theId}" name="#{name}" type="email" :isReq:required="" value="#{either id id val}">+<input id="#{theId}" name="#{name}" :not (null theClass):class="#{T.intercalate " " theClass}" type="email" :isReq:required="" value="#{either id id val}"> |] } @@ -276,9 +281,9 @@ searchField :: RenderMessage master FormMessage => AutoFocus -> Field sub master Text searchField autoFocus = Field { fieldParse = blank Right- , fieldView = \theId name val isReq -> do+ , fieldView = \theId name theClass val isReq -> do [WHAMLET|\-<input id="#{theId}" name="#{name}" type="search" :isReq:required="" :autoFocus:autofocus="" value="#{either id id val}">+<input id="#{theId}" name="#{name}" :not (null theClass):class="#{T.intercalate " " theClass}" type="search" :isReq:required="" :autoFocus:autofocus="" value="#{either id id val}"> |] when autoFocus $ do -- we want this javascript to be placed immediately after the field@@ -296,56 +301,79 @@ case parseURI $ unpack s of Nothing -> Left $ MsgInvalidUrl s Just _ -> Right s- , fieldView = \theId name val isReq ->+ , fieldView = \theId name theClass val isReq -> [WHAMLET|-<input ##{theId} name=#{name} type=url :isReq:required value=#{either id id val}>+<input ##{theId} name=#{name} :not (null theClass):class="#{T.intercalate " " theClass}" type=url :isReq:required value=#{either id id val}> |] } -selectField :: (Eq a, RenderMessage master FormMessage) => [(Text, a)] -> Field sub master a-selectField = selectField' . optionsPairs+selectFieldList :: (Eq a, RenderMessage master FormMessage, RenderMessage master msg) => [(msg, a)] -> Field sub master a+selectFieldList = selectField . optionsPairs -selectField' :: (Eq a, RenderMessage master FormMessage) => GGHandler sub master IO (OptionList a) -> Field sub master a-selectField' = selectFieldHelper+selectField :: (Eq a, RenderMessage master FormMessage) => GHandler sub master (OptionList a) -> Field sub master a+selectField = selectFieldHelper (\theId name inside -> [WHAMLET|<select ##{theId} name=#{name}>^{inside}|]) -- outside (\_theId _name isSel -> [WHAMLET|<option value=none :isSel:selected>_{MsgSelectNone}|]) -- onOpt- (\_theId _name value isSel text -> [WHAMLET|<option value=#{value} :isSel:selected>#{text}|]) -- inside+ (\_theId _name theClass value isSel text -> [WHAMLET|<option value=#{value} :isSel:selected :not (null theClass):class="#{T.intercalate " " theClass}">#{text}|]) -- inside -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}|])+multiSelectFieldList :: (Eq a, RenderMessage master FormMessage, RenderMessage master msg) => [(msg, a)] -> Field sub master [a]+multiSelectFieldList = multiSelectField . optionsPairs -radioField :: (Eq a, RenderMessage master FormMessage) => [(Text, a)] -> Field sub master a-radioField = radioField' . optionsPairs+multiSelectField :: (Eq a, RenderMessage master FormMessage)+ => GHandler sub master (OptionList a)+ -> Field sub master [a]+multiSelectField ioptlist =+ Field parse view+ where+ parse [] = return $ Right Nothing+ parse optlist = do+ mapopt <- olReadExternal <$> ioptlist+ case mapM mapopt optlist of+ Nothing -> return $ Left "Error parsing values"+ Just res -> return $ Right $ Just res -radioField' :: (Eq a, RenderMessage master FormMessage) => GGHandler sub master IO (OptionList a) -> Field sub master a-radioField' = selectFieldHelper+ view theId name theClass val isReq = do+ opts <- fmap olOptions $ lift ioptlist+ let selOpts = map (id &&& (optselected val)) opts+ [whamlet|+ <select ##{theId} name=#{name} :isReq:required multiple :not (null theClass):class=#{T.intercalate " " theClass}>+ $forall (opt, optsel) <- selOpts+ <option value=#{optionExternalValue opt} :optsel:selected>#{optionDisplay opt}+ |]+ where+ 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 = radioField . optionsPairs++radioField :: (Eq a, RenderMessage master FormMessage) => GHandler sub master (OptionList a) -> Field sub master a+radioField = selectFieldHelper (\theId _name inside -> [WHAMLET|<div ##{theId}>^{inside}|]) (\theId name isSel -> [WHAMLET| <div> <input id=#{theId}-none type=radio name=#{name} value=none :isSel:checked> <label for=#{theId}-none>_{MsgSelectNone} |])- (\theId name value isSel text -> [WHAMLET|+ (\theId name theClass value isSel text -> [WHAMLET| <div>- <input id=#{theId}-#{value} type=radio name=#{name} value=#{value} :isSel:checked>+ <input id=#{theId}-#{value} type=radio name=#{name} value=#{value} :isSel:checked :not (null theClass):class="#{T.intercalate " " theClass}"> <label for=#{theId}-#{value}>#{text} |]) boolField :: RenderMessage master FormMessage => Field sub master Bool boolField = Field { fieldParse = return . boolParser- , fieldView = \theId name val isReq -> [WHAMLET|+ , fieldView = \theId name theClass val isReq -> [WHAMLET| $if not isReq- <input id=#{theId}-none type=radio name=#{name} value=none checked>+ <input id=#{theId}-none :not (null theClass):class="#{T.intercalate " " theClass}" type=radio name=#{name} value=none checked> <label for=#{theId}-none>_{MsgSelectNone} -<input id=#{theId}-yes type=radio name=#{name} value=yes :showVal id val:checked>+<input id=#{theId}-yes :not (null theClass):class="#{T.intercalate " " theClass}" type=radio name=#{name} value=yes :showVal id val:checked> <label for=#{theId}-yes>_{MsgBoolYes} -<input id=#{theId}-no type=radio name=#{name} value=no :showVal not val:checked>+<input id=#{theId}-no :not (null theClass):class="#{T.intercalate " " theClass}" type=radio name=#{name} value=no :showVal not val:checked> <label for=#{theId}-no>_{MsgBoolNo} |] }@@ -359,29 +387,29 @@ t -> Left $ SomeMessage $ MsgInvalidBool t showVal = either (\_ -> False) -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 _ ->- outside theId name $ do- flip mapM_ pairs $ \pair -> inside- theId- name- (pack $ show $ fst pair)- ((fst pair) `elem` (either (\_ -> []) selectedVals vals)) -- We are presuming that select fields can't hold invalid values- (fst $ snd pair)+-- | While the default @'boolField'@ implements a radio button so you+-- can differentiate between an empty response (Nothing) and a no+-- response (Just False), this simpler checkbox field returns an empty+-- response as Just False.+--+-- Note that this makes the field always optional.+--+checkBoxField :: RenderMessage m FormMessage => Field s m Bool+checkBoxField = Field+ { fieldParse = return . checkBoxParser+ , fieldView = \theId name theClass val _ -> [whamlet|+<input id=#{theId} :not (null theClass):class="#{T.intercalate " " theClass}" type=checkbox name=#{name} value=yes :showVal id val:checked>+|] }- where- pairs = zip [1 :: Int ..] opts -- FIXME use IntMap- rpairs = zip (map snd opts) [1 :: Int ..]- selectedVals vals = map snd $ filter (\y -> fst y `elem` vals) rpairs- selectParser [] = 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 + where+ checkBoxParser [] = Right $ Just False+ checkBoxParser (x:_) = case x of+ "yes" -> Right $ Just True+ _ -> Right $ Just False++ showVal = either (\_ -> False)+ data OptionList a = OptionList { olOptions :: [Option a] , olReadExternal :: Text -> Maybe a@@ -399,45 +427,53 @@ , optionExternalValue :: Text } -optionsPairs :: [(Text, a)] -> GGHandler sub master IO (OptionList a)-optionsPairs = return . mkOptionList . zipWith (\external (display, internal) -> Option- { optionDisplay = display- , optionInternalValue = internal- , optionExternalValue = pack $ show external- }) [1 :: Int ..]+optionsPairs :: RenderMessage master msg => [(msg, a)] -> GHandler sub master (OptionList a)+optionsPairs opts = do+ mr <- getMessageRender+ let mkOption external (display, internal) =+ Option { optionDisplay = mr display+ , optionInternalValue = internal+ , optionExternalValue = pack $ show external+ }+ return $ mkOptionList (zipWith mkOption [1 :: Int ..] opts) -optionsEnum :: (Show a, Enum a, Bounded a) => GGHandler sub master IO (OptionList a)+optionsEnum :: (Show a, Enum a, Bounded a) => GHandler sub master (OptionList a) optionsEnum = optionsPairs $ map (\x -> (pack $ show x, x)) [minBound..maxBound] -optionsPersist :: ( YesodPersist master, PersistEntity a, PersistBackend (YesodPersistBackend master) (GGHandler sub master IO)- , SinglePiece (Key (YesodPersistBackend master) a)+optionsPersist :: ( YesodPersist master, PersistEntity a+ , PersistQuery (YesodPersistBackend master) (GHandler sub master)+ , PathPiece (Key (YesodPersistBackend master) a)+ , RenderMessage master msg+ , PersistEntityBackend a ~ YesodPersistBackend master )- => [Filter a] -> [SelectOpt a] -> (a -> Text) -> GGHandler sub master IO (OptionList (Key (YesodPersistBackend master) a, a))+ => [Filter a] -> [SelectOpt a] -> (a -> msg) -> GHandler sub master (OptionList (Entity a)) optionsPersist filts ords toDisplay = fmap mkOptionList $ do+ mr <- getMessageRender pairs <- runDB $ selectList filts ords- return $ map (\(key, value) -> Option- { optionDisplay = toDisplay value- , optionInternalValue = (key, value)- , optionExternalValue = toSinglePiece key+ return $ map (\(Entity key value) -> Option+ { optionDisplay = mr (toDisplay value)+ , optionInternalValue = Entity key value+ , optionExternalValue = toPathPiece key }) pairs 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 ())- -> GGHandler sub master IO (OptionList a) -> Field sub master a+ -> (Text -> Text -> [Text] -> Text -> Bool -> Text -> GWidget sub master ())+ -> GHandler sub master (OptionList a) -> Field sub master a selectFieldHelper outside onOpt inside opts' = Field { fieldParse = \x -> do opts <- opts' return $ selectParser opts x- , fieldView = \theId name val isReq -> do- opts <- fmap olOptions $ lift $ liftIOHandler opts'+ , fieldView = \theId name theClass val isReq -> do+ opts <- fmap olOptions $ lift opts' outside theId name $ do unless isReq $ onOpt theId name $ not $ render opts val `elem` map optionExternalValue opts flip mapM_ opts $ \opt -> inside theId name+ theClass (optionExternalValue opt) ((render opts val) == optionExternalValue opt) (optionDisplay opt)@@ -461,7 +497,7 @@ Nothing -> let i' = incrInts ints in (pack $ 'f' : show i', i')- id' <- maybe (pack <$> newIdent) return $ fsId fs+ id' <- maybe newIdent return $ fsId fs let (res, errs) = case menvs of Nothing -> (FormMissing, Nothing)@@ -471,12 +507,13 @@ let t = renderMessage master langs MsgValueRequired in (FormFailure [t], Just $ toHtml t) Just fi -> (FormSuccess fi, Nothing)+ let theClass = fsClass fs let fv = FieldView { fvLabel = toHtml $ renderMessage master langs $ fsLabel fs , fvTooltip = fmap (toHtml . renderMessage master langs) $ fsTooltip fs , fvId = id' , fvInput = [WHAMLET|-<input type=file name=#{name} ##{id'}>+<input type=file name=#{name} ##{id'} :not (null theClass):class="#{T.intercalate " " theClass}"> |] , fvErrors = errs , fvRequired = True@@ -491,7 +528,7 @@ Nothing -> let i' = incrInts ints in (pack $ 'f' : show i', i')- id' <- maybe (pack <$> newIdent) return $ fsId fs+ id' <- maybe newIdent return $ fsId fs let (res, errs) = case menvs of Nothing -> (FormMissing, Nothing)@@ -499,12 +536,13 @@ case Map.lookup name fenv of Nothing -> (FormSuccess Nothing, Nothing) Just fi -> (FormSuccess $ Just fi, Nothing)+ let theClass = fsClass fs let fv = FieldView { fvLabel = toHtml $ renderMessage master langs $ fsLabel fs , fvTooltip = fmap (toHtml . renderMessage master langs) $ fsTooltip fs , fvId = id' , fvInput = [WHAMLET|-<input type=file name=#{name} ##{id'}>+<input type=file name=#{name} ##{id'} :not (null theClass):class="#{T.intercalate " " theClass}"> |] , fvErrors = errs , fvRequired = False
Yesod/Form/Functions.hs view
@@ -27,21 +27,26 @@ , FormRender , renderTable , renderDivs+ , renderBootstrap -- * Validation , check , checkBool , checkM , customErrorMessage+ -- * Utilities+ , fieldSettingsLabel+ , aformM ) where import Yesod.Form.Types 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 (liftM, join) import Text.Blaze (Html, toHtml)-import Yesod.Handler (GHandler, GGHandler, getRequest, runRequestBody, newIdent, getYesod)-import Yesod.Core (RenderMessage, liftIOHandler, SomeMessage (..))+import Yesod.Handler (GHandler, getRequest, runRequestBody, newIdent, getYesod)+import Yesod.Core (RenderMessage, SomeMessage (..)) import Yesod.Widget (GWidget, whamlet) import Yesod.Request (reqNonce, reqWaiRequest, reqGetParams, languages, FileInfo (..)) import Network.Wai (requestMethod)@@ -49,7 +54,6 @@ import Data.Monoid (mempty) import Data.Maybe (listToMaybe, fromMaybe) import Yesod.Message (RenderMessage (..))-import Control.Monad.IO.Class (MonadIO) import qualified Data.Map as Map import qualified Data.ByteString.Lazy as L @@ -72,10 +76,10 @@ 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 :: MForm 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)+ ((a, xmls), ints', enc) <- runRWST form (env, master, langs) ints+ return (a, (++) xmls, ints', enc) aFormToForm :: AForm sub master a -> MForm sub master (FormResult a, [FieldView sub master] -> [FieldView sub master]) aFormToForm (AForm aform) = do@@ -118,7 +122,7 @@ mhelper Field {..} FieldSettings {..} mdef onMissing onFound isReq = do mp <- askParams name <- maybe newFormIdent return fsName- theId <- lift $ maybe (liftM pack newIdent) return fsId+ theId <- lift $ maybe newIdent return fsId (_, master, langs) <- ask let mr2 = renderMessage master langs (res, val) <-@@ -137,7 +141,7 @@ { fvLabel = toHtml $ mr2 fsLabel , fvTooltip = fmap toHtml $ fmap mr2 fsTooltip , fvId = theId- , fvInput = fieldView theId name val isReq+ , fvInput = fieldView theId name fsClass val isReq , fvErrors = case res of FormFailure [e] -> Just $ toHtml e@@ -148,17 +152,17 @@ 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+areq a b = formToAForm . fmap (second return) . mreq a b 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+aopt a b = formToAForm . fmap (second return) . mopt a b -runFormGeneric :: MonadIO m => MForm 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)+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) -- | 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,@@ -289,6 +293,41 @@ |] return (res, widget) +-- | Render a form using Bootstrap-friendly HTML syntax.+--+-- Sample Hamlet:+--+-- > <form method=post action=@{ActionR} enctype=#{formEnctype}>+-- > <fieldset>+-- > <legend>_{MsgLegend}+-- > $case result+-- > $of FormFailure reasons+-- > $forall reason <- reasons+-- > <div .alert-message .error>#{reason}+-- > $of _+-- > ^{formWidget}+-- > <div .actions>+-- > <input .btn .primary type=submit value=_{MsgSubmit}>+renderBootstrap :: FormRender sub master a+renderBootstrap aform fragment = do+ (res, views') <- aFormToForm aform+ let views = views' []+ has (Just _) = True+ has Nothing = False+ let widget = [whamlet|+\#{fragment}+$forall view <- views+ <div .clearfix :fvRequired view:.required :not $ fvRequired view:.optional :has $ fvErrors view:.error>+ <label for=#{fvId view}>#{fvLabel view}+ <div.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 f = checkM $ return . f@@ -299,7 +338,7 @@ checkBool b s = check $ \x -> if b x then Right x else Left s checkM :: RenderMessage master msg- => (a -> GGHandler sub master IO (Either msg a))+ => (a -> GHandler sub master (Either msg a)) -> Field sub master a -> Field sub master a checkM f field = field@@ -315,3 +354,13 @@ customErrorMessage :: SomeMessage master -> Field sub master a -> Field sub master a customErrorMessage msg field = field { fieldParse = \ts -> fmap (either (const $ Left msg) Right) $ fieldParse field ts }++-- | Generate a 'FieldSettings' from the given label.+fieldSettingsLabel :: msg -> FieldSettings msg+fieldSettingsLabel msg = FieldSettings 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)
+ Yesod/Form/I18n/German.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE OverloadedStrings #-}+module Yesod.Form.I18n.German where++import Yesod.Form.Types (FormMessage (..))+import Data.Monoid (mappend)+import Data.Text (Text)++germanFormMessage :: FormMessage -> Text+germanFormMessage (MsgInvalidInteger t) = "Ungültige Ganzzahl: " `mappend` t+germanFormMessage (MsgInvalidNumber t) = "Ungültige Zahl: " `mappend` t+germanFormMessage (MsgInvalidEntry t) = "Ungültiger Eintrag: " `mappend` t+germanFormMessage MsgInvalidTimeFormat = "Ungültiges Zeitformat, HH:MM[:SS] Format erwartet"+germanFormMessage MsgInvalidDay = "Ungültiges Datum, JJJJ-MM-TT Format erwartet"+germanFormMessage (MsgInvalidUrl t) = "Ungültige URL: " `mappend` t+germanFormMessage (MsgInvalidEmail t) = "Ungültige e-Mail Adresse: " `mappend` t+germanFormMessage (MsgInvalidHour t) = "Ungültige Stunde: " `mappend` t+germanFormMessage (MsgInvalidMinute t) = "Ungültige Minute: " `mappend` t+germanFormMessage (MsgInvalidSecond t) = "Ungültige Sekunde: " `mappend` t+germanFormMessage MsgCsrfWarning = "Bitte bestätigen Sie ihre Eingabe, als Schutz gegen Cross-Site Forgery Angriffen"+germanFormMessage MsgValueRequired = "Wert wird benötigt"+germanFormMessage (MsgInputNotFound t) = "Eingabe nicht gefunden: " `mappend` t+germanFormMessage MsgSelectNone = "<Nichts>"+germanFormMessage (MsgInvalidBool t) = "Ungültiger Wahrheitswert: " `mappend` t+germanFormMessage MsgBoolYes = "Ja"+germanFormMessage MsgBoolNo = "Nein"+germanFormMessage MsgDelete = "Löschen?"
Yesod/Form/Input.hs view
@@ -11,7 +11,7 @@ import Yesod.Form.Types import Data.Text (Text) import Control.Applicative (Applicative (..))-import Yesod.Handler (GHandler, GGHandler, invalidArgs, runRequestBody, getRequest, getYesod, liftIOHandler)+import Yesod.Handler (GHandler, invalidArgs, runRequestBody, getRequest, getYesod) import Yesod.Request (reqGetParams, languages) import Control.Monad (liftM) import Yesod.Message (RenderMessage (..), SomeMessage (..))@@ -19,7 +19,7 @@ import Data.Maybe (fromMaybe) type DText = [Text] -> [Text]-newtype FormInput sub master a = FormInput { unFormInput :: master -> [Text] -> Env -> GGHandler sub master IO (Either DText a) }+newtype FormInput sub master a = FormInput { unFormInput :: master -> [Text] -> Env -> GHandler sub master (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 sub master) where@@ -55,7 +55,7 @@ env <- liftM (toMap . reqGetParams) getRequest m <- getYesod l <- languages- emx <- liftIOHandler $ f m l env+ emx <- f m l env case emx of Left errs -> invalidArgs $ errs [] Right x -> return x@@ -68,7 +68,7 @@ env <- liftM (toMap . fst) runRequestBody m <- getYesod l <- languages- emx <- liftIOHandler $ f m l env+ emx <- f m l env case emx of Left errs -> invalidArgs $ errs [] Right x -> return x
Yesod/Form/Jquery.hs view
@@ -8,7 +8,6 @@ module Yesod.Form.Jquery ( YesodJquery (..) , jqueryDayField- , jqueryDayTimeField , jqueryAutocompleteField , googleHostedJqueryUiCss , JqueryDaySettings (..)@@ -16,15 +15,14 @@ ) where import Yesod.Handler+import Yesod.Core (Route) import Yesod.Form import Yesod.Widget-import Data.Time (UTCTime (..), Day, TimeOfDay (..), timeOfDayToTime,- timeToTimeOfDay)-import Data.Char (isSpace)+import Data.Time (Day)+import qualified Data.Text as T import Data.Default import Text.Hamlet (shamlet) import Text.Julius (julius)-import Control.Monad.Trans.Class (lift) import Data.Text (Text, pack, unpack) import Data.Monoid (mconcat) import Yesod.Core (RenderMessage, SomeMessage (..))@@ -78,21 +76,26 @@ Right . readMay . unpack- , fieldView = \theId name val isReq -> do+ , fieldView = \theId name theClass val isReq -> do addHtml [HTML|\-<input id="#{theId}" name="#{name}" type="date" :isReq:required="" value="#{showVal val}">+<input id="#{theId}" name="#{name}" :not (null theClass):class="#{T.intercalate " " theClass}" type="date" :isReq:required="" value="#{showVal val}"> |] addScript' urlJqueryJs addScript' urlJqueryUiJs addStylesheet' urlJqueryUiCss addJulius [JULIUS|-$(function(){$("##{theId}").datepicker({- dateFormat:'yy-mm-dd',- changeMonth:#{jsBool $ jdsChangeMonth jds},- changeYear:#{jsBool $ jdsChangeYear jds},- numberOfMonths:#{mos $ jdsNumberOfMonths jds},- yearRange:"#{jdsYearRange jds}"-})});+$(function(){+ var i = $("##{theId}");+ if (i.attr("type") != "date") {+ i.datepicker({+ dateFormat:'yy-mm-dd',+ changeMonth:#{jsBool $ jdsChangeMonth jds},+ changeYear:#{jsBool $ jdsChangeYear jds},+ numberOfMonths:#{mos $ jdsNumberOfMonths jds},+ yearRange:"#{jdsYearRange jds}"+ });+ }+}); |] } where@@ -108,60 +111,13 @@ , "]" ] -ifRight :: Either a b -> (b -> c) -> Either a c-ifRight e f = case e of- Left l -> Left l- Right r -> Right $ f r--showLeadingZero :: (Show a) => a -> String-showLeadingZero time = let t = show time in if length t == 1 then "0" ++ t else t---- use A.M/P.M and drop seconds and "UTC" (as opposed to normal UTCTime show)-jqueryDayTimeUTCTime :: UTCTime -> String-jqueryDayTimeUTCTime (UTCTime day utcTime) =- let timeOfDay = timeToTimeOfDay utcTime- in (replace '-' '/' (show day)) ++ " " ++ showTimeOfDay timeOfDay- where- showTimeOfDay (TimeOfDay hour minute _) =- let (h, apm) = if hour < 12 then (hour, "AM") else (hour - 12, "PM")- in (showLeadingZero h) ++ ":" ++ (showLeadingZero minute) ++ " " ++ apm--jqueryDayTimeField :: (RenderMessage master FormMessage, YesodJquery master) => Field sub master UTCTime-jqueryDayTimeField = Field- { fieldParse = blank $ parseUTCTime . unpack- , fieldView = \theId name val isReq -> do- addHtml [HTML|\-<input id="#{theId}" name="#{name}" :isReq:required="" value="#{showVal val}">-|]- addScript' urlJqueryJs- addScript' urlJqueryUiJs- addScript' urlJqueryUiDateTimePicker- addStylesheet' urlJqueryUiCss- addJulius [JULIUS|-$(function(){$("##{theId}").datetimepicker({dateFormat : "yyyy/mm/dd hh:MM TT"})});-|]- }- where- showVal = either id (pack . jqueryDayTimeUTCTime)--parseUTCTime :: String -> Either FormMessage UTCTime-parseUTCTime s =- let (dateS, timeS') = break isSpace (dropWhile isSpace s)- timeS = drop 1 timeS'- dateE = parseDate dateS- in case dateE of- Left l -> Left l- Right date ->- ifRight (parseTime timeS)- (UTCTime date . timeOfDayToTime)- jqueryAutocompleteField :: (RenderMessage master FormMessage, YesodJquery master) => Route master -> Field sub master Text jqueryAutocompleteField src = Field { fieldParse = blank $ Right- , fieldView = \theId name val isReq -> do+ , fieldView = \theId name theClass val isReq -> do addHtml [HTML|\-<input id="#{theId}" name="#{name}" type="text" :isReq:required="" value="#{either id id val}" .autocomplete>+<input id="#{theId}" name="#{name}" :not (null theClass):class="#{T.intercalate " " theClass}" type="text" :isReq:required="" value="#{either id id val}" .autocomplete> |] addScript' urlJqueryJs addScript' urlJqueryUiJs@@ -171,7 +127,7 @@ |] } -addScript' :: Monad m => (t -> Either (Route master) Text) -> GGWidget master (GGHandler sub t m) ()+addScript' :: (master -> Either (Route master) Text) -> GWidget sub master () addScript' f = do y <- lift getYesod addScriptEither $ f y@@ -185,11 +141,6 @@ readMay s = case reads s of (x, _):_ -> Just x [] -> Nothing---- | Replaces all instances of a value in a list by another value.--- from http://hackage.haskell.org/packages/archive/cgi/3001.1.7.1/doc/html/src/Network-CGI-Protocol.html#replace-replace :: Eq a => a -> a -> [a] -> [a]-replace x y = map (\z -> if z == x then y else z) data JqueryDaySettings = JqueryDaySettings { jdsChangeMonth :: Bool
Yesod/Form/MassInput.hs view
@@ -14,10 +14,9 @@ import Yesod.Form.Fields (boolField) import Yesod.Widget (GWidget, whamlet) import Yesod.Message (RenderMessage)-import Yesod.Handler (newIdent, GGHandler)+import Yesod.Handler (newIdent, GHandler) import Text.Blaze (Html) import Control.Monad.Trans.Class (lift)-import Data.Text (pack) import Control.Monad.Trans.RWS (get, put, ask) import Data.Maybe (fromMaybe) import Data.Text.Read (decimal)@@ -53,7 +52,7 @@ IntCons _ is' -> put is' >> newFormIdent >> return () up $ i - 1 -inputList :: (m ~ GGHandler sub master IO, xml ~ GWidget sub master (), RenderMessage master FormMessage)+inputList :: (m ~ GHandler sub master, xml ~ GWidget sub master (), RenderMessage master FormMessage) => Html -> ([[FieldView sub master]] -> xml) -> (Maybe a -> AForm sub master a)@@ -79,10 +78,10 @@ let count = length vals (res, xmls, views) <- liftM fixme $ mapM (withDelete . single) vals up 1- return (res, FieldView+ return (res, [FieldView { fvLabel = label , fvTooltip = Nothing- , fvId = pack theId+ , fvId = theId , fvInput = [WHAMLET| ^{fixXml views} <p>@@ -94,7 +93,7 @@ |] , fvErrors = Nothing , fvRequired = False- })+ }]) withDelete :: (xml ~ GWidget sub master (), RenderMessage master FormMessage) => AForm sub master a@@ -111,6 +110,7 @@ , fsTooltip = Nothing , fsName = Just deleteName , fsId = Nothing+ , fsClass = [] } $ Just False (res, xml) <- aFormToForm af return $ Right (res, xml $ xml2 [])
Yesod/Form/Nic.hs view
@@ -11,6 +11,7 @@ ) where import Yesod.Handler+import Yesod.Core (Route) import Yesod.Form import Yesod.Widget import Text.HTML.SanitizeXSS (sanitizeBalance)@@ -18,8 +19,8 @@ import Text.Julius (julius) import Text.Blaze.Renderer.String (renderHtml) import Text.Blaze (preEscapedText)-import Control.Monad.Trans.Class (lift) import Data.Text (Text, pack)+import qualified Data.Text as T import Data.Maybe (listToMaybe) class YesodNic a where@@ -30,14 +31,14 @@ nicHtmlField :: YesodNic master => Field sub master Html nicHtmlField = Field { fieldParse = return . Right . fmap (preEscapedText . sanitizeBalance) . listToMaybe- , fieldView = \theId name val _isReq -> do+ , fieldView = \theId name theClass val _isReq -> do addHtml #if __GLASGOW_HASKELL__ >= 700 [shamlet| #else [$shamlet| #endif- <textarea id="#{theId}" name="#{name}" .html>#{showVal val}+ <textarea id="#{theId}" :not (null theClass):class="#{T.intercalate " " theClass}" name="#{name}" .html>#{showVal val} |] addScript' urlNicEdit addJulius
Yesod/Form/Types.hs view
@@ -10,7 +10,6 @@ , FileEnv , Ints (..) -- * Form- , Form , MForm , AForm (..) -- * Build forms@@ -27,7 +26,7 @@ import Control.Applicative ((<$>), Applicative (..)) import Control.Monad (liftM) import Data.String (IsString (..))-import Yesod.Core (GGHandler, GWidget, SomeMessage)+import Yesod.Core (GHandler, GWidget, SomeMessage) import qualified Data.Map as Map -- | A form can produce three different results: there was no data available,@@ -75,12 +74,10 @@ type FileEnv = Map.Map Text FileInfo type Lang = Text-type Form sub master a = RWST (Maybe (Env, FileEnv), master, [Lang]) Enctype Ints (GGHandler sub master IO) a-{-# DEPRECATED Form "Use MForm instead" #-}-type MForm sub master a = RWST (Maybe (Env, FileEnv), master, [Lang]) Enctype Ints (GGHandler sub master IO) a+type MForm sub master a = RWST (Maybe (Env, FileEnv), master, [Lang]) Enctype Ints (GHandler sub master) a 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)+ { unAForm :: (master, [Text]) -> Maybe (Env, FileEnv) -> Ints -> GHandler sub master (FormResult a, [FieldView sub master] -> [FieldView sub master], Ints, Enctype) } instance Functor (AForm sub master) where fmap f (AForm a) =@@ -102,10 +99,11 @@ , fsTooltip :: Maybe msg , fsId :: Maybe Text , fsName :: Maybe Text+ , fsClass :: [Text] } 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 sub master = FieldView { fvLabel :: Html@@ -117,10 +115,11 @@ } 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?+ { fieldParse :: [Text] -> GHandler sub master (Either (SomeMessage master) (Maybe a))+ -- | ID, name, class, (invalid text OR legimiate result), required? , fieldView :: Text -> Text+ -> [Text] -> Either Text a -> Bool -> GWidget sub master ()
yesod-form.cabal view
@@ -1,5 +1,5 @@ name: yesod-form-version: 0.3.4.2+version: 0.4.1 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -14,25 +14,24 @@ library build-depends: base >= 4 && < 5- , yesod-core >= 0.9 && < 0.10- , yesod-persistent >= 0.2 && < 0.3+ , yesod-core >= 0.10.1 && < 0.11+ , yesod-persistent >= 0.3.1 && < 0.4 , time >= 1.1.4 , hamlet >= 0.10 && < 0.11 , shakespeare-css >= 0.10 && < 0.11- , shakespeare-js >= 0.10 && < 0.11- , persistent >= 0.6 && < 0.7- , yesod-persistent >= 0.2 && < 0.3+ , shakespeare-js >= 0.11 && < 0.12+ , persistent >= 0.8 && < 0.9 , template-haskell , transformers >= 0.2.2 && < 0.3 , data-default >= 0.3 && < 0.4 , xss-sanitize >= 0.3.0.1 && < 0.4- , blaze-builder >= 0.2.1.4 && < 0.4+ , blaze-builder >= 0.2.1.4 && < 0.4 , network >= 2.2 && < 2.4 , email-validate >= 0.2.6 && < 0.3 , blaze-html >= 0.4.1.3 && < 0.5 , bytestring >= 0.9.1.4 && < 0.10- , text >= 0.9 && < 0.12- , wai >= 0.4 && < 0.5+ , text >= 0.9 && < 1.0+ , wai >= 1.1 && < 1.2 , containers >= 0.2 && < 0.5 exposed-modules: Yesod.Form Yesod.Form.Class@@ -46,9 +45,10 @@ Yesod.Form.I18n.English Yesod.Form.I18n.Portuguese Yesod.Form.I18n.Swedish+ Yesod.Form.I18n.German -- FIXME Yesod.Helpers.Crud ghc-options: -Wall source-repository head type: git- location: git://github.com/yesodweb/yesod.git+ location: https://github.com/yesodweb/yesod