yesod-form 0.4.2.1 → 1.0.0
raw patch · 8 files changed
+123/−200 lines, 8 filesdep ~hamletdep ~persistentdep ~shakespeare-css
Dependency ranges changed: hamlet, persistent, shakespeare-css, shakespeare-js, transformers, wai, yesod-core, yesod-persistent
Files
- Yesod/Form/Class.hs +2/−2
- Yesod/Form/Fields.hs +54/−82
- Yesod/Form/Functions.hs +29/−39
- Yesod/Form/Jquery.hs +8/−22
- Yesod/Form/MassInput.hs +7/−15
- Yesod/Form/Nic.hs +6/−23
- Yesod/Form/Types.hs +7/−7
- yesod-form.cabal +10/−10
Yesod/Form/Class.hs view
@@ -22,8 +22,8 @@ -} class ToField a master where- toField :: (RenderMessage master msg, RenderMessage master FormMessage)- => FieldSettings msg -> Maybe a -> AForm sub master a+ toField :: RenderMessage master FormMessage+ => FieldSettings master -> Maybe a -> AForm sub master a {- FIXME instance ToFormField String y where
Yesod/Form/Fields.hs view
@@ -2,7 +2,6 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} module Yesod.Form.Fields ( -- * i18n@@ -48,7 +47,7 @@ import Yesod.Form.Types import Yesod.Form.I18n.English import Yesod.Handler (getMessageRender)-import Yesod.Widget+import Yesod.Widget (toWidget, whamlet, GWidget) import Yesod.Message (RenderMessage (renderMessage), SomeMessage (..)) import Text.Hamlet import Text.Blaze (ToHtml (..), preEscapedText, unsafeByteString)@@ -71,7 +70,6 @@ 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 qualified Data.Map as Map@@ -82,20 +80,6 @@ import Yesod.Persist (selectList, runDB, Filter, SelectOpt, YesodPersistBackend, Key, YesodPersist, PersistEntity, PersistQuery) import Control.Arrow ((&&&)) -#if __GLASGOW_HASKELL__ >= 700-#define WHAMLET whamlet-#define HAMLET hamlet-#define CASSIUS cassius-#define JULIUS julius-#define HTML html-#else-#define WHAMLET $whamlet-#define HAMLET $hamlet-#define CASSIUS $cassius-#define JULIUS $julius-#define HTML $html-#endif- import Control.Applicative ((<$>)) defaultFormMessage :: FormMessage -> Text@@ -114,9 +98,8 @@ Right (a, "") -> Right a _ -> Left $ MsgInvalidInteger s - , fieldView = \theId name theClass val isReq -> addHamlet- [HAMLET|\-<input id="#{theId}" name="#{name}" :not (null theClass):class="#{T.intercalate " " theClass}" type="number" :isReq:required="" value="#{showVal val}">+ , fieldView = \theId name attrs val isReq -> toWidget [hamlet|+<input id="#{theId}" name="#{name}" *{attrs} type="number" :isReq:required="" value="#{showVal val}"> |] } where@@ -130,9 +113,8 @@ Right (a, "") -> Right a _ -> Left $ MsgInvalidNumber s - , fieldView = \theId name theClass val isReq -> addHamlet- [HAMLET|\-<input id="#{theId}" name="#{name}" :not (null theClass):class="#{T.intercalate " " theClass}" type="text" :isReq:required="" value="#{showVal val}">+ , fieldView = \theId name attrs val isReq -> toWidget [hamlet|+<input id="#{theId}" name="#{name}" *{attrs} type="text" :isReq:required="" value="#{showVal val}"> |] } where showVal = either id (pack . show)@@ -140,9 +122,8 @@ dayField :: RenderMessage master FormMessage => Field sub master Day dayField = Field { fieldParse = blank $ parseDate . unpack- , fieldView = \theId name theClass val isReq -> addHamlet- [HAMLET|\-<input id="#{theId}" name="#{name}" :not (null theClass):class="#{T.intercalate " " theClass}" type="date" :isReq:required="" value="#{showVal val}">+ , fieldView = \theId name attrs val isReq -> toWidget [hamlet|+<input id="#{theId}" name="#{name}" *{attrs} type="date" :isReq:required="" value="#{showVal val}"> |] } where showVal = either id (pack . show)@@ -150,9 +131,8 @@ timeField :: RenderMessage master FormMessage => Field sub master TimeOfDay timeField = Field { fieldParse = blank $ parseTime . unpack- , fieldView = \theId name theClass val isReq -> addHamlet- [HAMLET|\-<input id="#{theId}" name="#{name}" :not (null theClass):class="#{T.intercalate "" theClass}" :isReq:required="" value="#{showVal val}">+ , fieldView = \theId name attrs val isReq -> toWidget [hamlet|+<input id="#{theId}" name="#{name}" *{attrs} :isReq:required="" value="#{showVal val}"> |] } where@@ -165,10 +145,9 @@ htmlField :: RenderMessage master FormMessage => Field sub master Html htmlField = Field { fieldParse = blank $ Right . preEscapedText . sanitizeBalance- , fieldView = \theId name theClass val _isReq -> addHamlet+ , fieldView = \theId name attrs val _isReq -> toWidget [hamlet| -- FIXME: There was a class="html" attribute, for what purpose?- [HAMLET|\-<textarea id="#{theId}" name="#{name}" :not (null theClass):class=#{T.intercalate " " theClass}>#{showVal val}+<textarea id="#{theId}" name="#{name}" *{attrs}>#{showVal val} |] } where showVal = either id (pack . renderHtml)@@ -194,36 +173,33 @@ textareaField :: RenderMessage master FormMessage => Field sub master Textarea textareaField = Field { fieldParse = blank $ Right . Textarea- , fieldView = \theId name theClass val _isReq -> addHamlet- [HAMLET|\-<textarea id="#{theId}" name="#{name}" :not (null theClass):class="#{T.intercalate " " theClass}">#{either id unTextarea val}+ , fieldView = \theId name attrs val _isReq -> toWidget [hamlet|+<textarea id="#{theId}" name="#{name}" *{attrs}>#{either id unTextarea val} |] } hiddenField :: RenderMessage master FormMessage => Field sub master Text hiddenField = Field { fieldParse = blank $ Right- , fieldView = \theId name theClass val _isReq -> addHamlet- [HAMLET|\-<input type="hidden" id="#{theId}" name="#{name}" :not (null theClass):class="#{T.intercalate " " theClass}" value="#{either id id val}">+ , fieldView = \theId name attrs val _isReq -> toWidget [hamlet|+<input type="hidden" id="#{theId}" name="#{name}" *{attrs} value="#{either id id val}"> |] } textField :: RenderMessage master FormMessage => Field sub master Text textField = Field { fieldParse = blank $ Right- , fieldView = \theId name theClass val isReq ->- [WHAMLET|-<input id="#{theId}" name="#{name}" :not (null theClass):class="#{T.intercalate " " theClass}" type="text" :isReq:required value="#{either id id val}">+ , fieldView = \theId name attrs val isReq ->+ [whamlet|+<input id="#{theId}" name="#{name}" *{attrs} 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 theClass val isReq -> addHamlet- [HAMLET|\-<input id="#{theId}" name="#{name}" :not (null theClass):class="#{T.intercalate " " theClass}" type="password" :isReq:required="" value="#{either id id val}">+ , fieldView = \theId name attrs val isReq -> toWidget [hamlet|+<input id="#{theId}" name="#{name}" *{attrs} type="password" :isReq:required="" value="#{either id id val}"> |] } @@ -271,9 +247,8 @@ \s -> if Email.isValid (unpack s) then Right s else Left $ MsgInvalidEmail s- , fieldView = \theId name theClass val isReq -> addHamlet- [HAMLET|\-<input id="#{theId}" name="#{name}" :not (null theClass):class="#{T.intercalate " " theClass}" type="email" :isReq:required="" value="#{either id id val}">+ , fieldView = \theId name attrs val isReq -> toWidget [hamlet|+<input id="#{theId}" name="#{name}" *{attrs} type="email" :isReq:required="" value="#{either id id val}"> |] } @@ -281,15 +256,14 @@ searchField :: RenderMessage master FormMessage => AutoFocus -> Field sub master Text searchField autoFocus = Field { fieldParse = blank Right- , fieldView = \theId name theClass val isReq -> do- [WHAMLET|\-<input id="#{theId}" name="#{name}" :not (null theClass):class="#{T.intercalate " " theClass}" type="search" :isReq:required="" :autoFocus:autofocus="" value="#{either id id val}">+ , fieldView = \theId name attrs val isReq -> do+ [whamlet|\+<input id="#{theId}" name="#{name}" *{attrs} 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- [WHAMLET|\<script>if (!('autofocus' in document.createElement('input'))) {document.getElementById('#{theId}').focus();}</script> -|]- addCassius [CASSIUS|+ [whamlet|<script>if (!('autofocus' in document.createElement('input'))) {document.getElementById('#{theId}').focus();}|]+ toWidget [cassius| #{theId} -webkit-appearance: textfield |]@@ -301,9 +275,9 @@ case parseURI $ unpack s of Nothing -> Left $ MsgInvalidUrl s Just _ -> Right s- , fieldView = \theId name theClass val isReq ->- [WHAMLET|-<input ##{theId} name=#{name} :not (null theClass):class="#{T.intercalate " " theClass}" type=url :isReq:required value=#{either id id val}>+ , fieldView = \theId name attrs val isReq ->+ [whamlet|+<input ##{theId} name=#{name} *{attrs} type=url :isReq:required value=#{either id id val}> |] } @@ -312,9 +286,9 @@ 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 theClass value isSel text -> [WHAMLET|<option value=#{value} :isSel:selected :not (null theClass):class="#{T.intercalate " " theClass}">#{text}|]) -- inside+ (\theId name inside -> [whamlet|<select ##{theId} name=#{name}>^{inside}|]) -- outside+ (\_theId _name isSel -> [whamlet|<option value=none :isSel:selected>_{MsgSelectNone}|]) -- onOpt+ (\_theId _name attrs value isSel text -> [whamlet|<option value=#{value} :isSel:selected *{attrs}>#{text}|]) -- inside multiSelectFieldList :: (Eq a, RenderMessage master FormMessage, RenderMessage master msg) => [(msg, a)] -> Field sub master [a] multiSelectFieldList = multiSelectField . optionsPairs@@ -332,11 +306,11 @@ Nothing -> return $ Left "Error parsing values" Just res -> return $ Right $ Just res - view theId name theClass val isReq = do+ view theId name attrs 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}>+ <select ##{theId} name=#{name} :isReq:required multiple *{attrs}> $forall (opt, optsel) <- selOpts <option value=#{optionExternalValue opt} :optsel:selected>#{optionDisplay opt} |]@@ -349,31 +323,31 @@ 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|+ (\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 theClass value isSel text -> [WHAMLET|+ (\theId name attrs value isSel text -> [whamlet| <div>- <input id=#{theId}-#{value} type=radio name=#{name} value=#{value} :isSel:checked :not (null theClass):class="#{T.intercalate " " theClass}">+ <input id=#{theId}-#{value} type=radio name=#{name} value=#{value} :isSel:checked *{attrs}> <label for=#{theId}-#{value}>#{text} |]) boolField :: RenderMessage master FormMessage => Field sub master Bool boolField = Field { fieldParse = return . boolParser- , fieldView = \theId name theClass val isReq -> [WHAMLET|+ , fieldView = \theId name attrs val isReq -> [whamlet| $if not isReq- <input id=#{theId}-none :not (null theClass):class="#{T.intercalate " " theClass}" type=radio name=#{name} value=none checked>+ <input id=#{theId}-none *{attrs} type=radio name=#{name} value=none checked> <label for=#{theId}-none>_{MsgSelectNone} -<input id=#{theId}-yes :not (null theClass):class="#{T.intercalate " " theClass}" type=radio name=#{name} value=yes :showVal id val:checked>+<input id=#{theId}-yes *{attrs} type=radio name=#{name} value=yes :showVal id val:checked> <label for=#{theId}-yes>_{MsgBoolYes} -<input id=#{theId}-no :not (null theClass):class="#{T.intercalate " " theClass}" type=radio name=#{name} value=no :showVal not val:checked>+<input id=#{theId}-no *{attrs} type=radio name=#{name} value=no :showVal not val:checked> <label for=#{theId}-no>_{MsgBoolNo} |] }@@ -397,8 +371,8 @@ 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>+ , fieldView = \theId name attrs val _ -> [whamlet|+<input id=#{theId} *{attrs} type=checkbox name=#{name} value=yes :showVal id val:checked> |] } @@ -460,20 +434,20 @@ :: (Eq a, RenderMessage master FormMessage) => (Text -> Text -> GWidget sub master () -> GWidget sub master ()) -> (Text -> Text -> Bool -> GWidget sub master ())- -> (Text -> Text -> [Text] -> Text -> Bool -> Text -> GWidget sub master ())+ -> (Text -> 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 theClass val isReq -> do+ , fieldView = \theId name attrs 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+ attrs (optionExternalValue opt) ((render opts val) == optionExternalValue opt) (optionDisplay opt)@@ -489,7 +463,7 @@ Nothing -> Left $ SomeMessage $ MsgInvalidEntry x Just y -> Right $ Just y -fileAFormReq :: (RenderMessage master msg, RenderMessage master FormMessage) => FieldSettings msg -> AForm sub master FileInfo+fileAFormReq :: RenderMessage master FormMessage => FieldSettings master -> AForm sub master FileInfo fileAFormReq fs = AForm $ \(master, langs) menvs ints -> do let (name, ints') = case fsName fs of@@ -507,20 +481,19 @@ 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'} :not (null theClass):class="#{T.intercalate " " theClass}">+ , fvInput = [whamlet|+<input type=file name=#{name} ##{id'} *{fsAttrs fs}> |] , fvErrors = errs , fvRequired = True } return (res, (fv :), ints', Multipart) -fileAFormOpt :: (RenderMessage master msg, RenderMessage master FormMessage) => FieldSettings msg -> AForm sub master (Maybe FileInfo)+fileAFormOpt :: RenderMessage master FormMessage => FieldSettings master -> AForm sub master (Maybe FileInfo) fileAFormOpt fs = AForm $ \(master, langs) menvs ints -> do let (name, ints') = case fsName fs of@@ -536,13 +509,12 @@ 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'} :not (null theClass):class="#{T.intercalate " " theClass}">+ , fvInput = [whamlet|+<input type=file name=#{name} ##{id'} *{fsAttrs fs}> |] , fvErrors = errs , fvRequired = False
Yesod/Form/Functions.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}@@ -18,7 +17,7 @@ , aopt -- * Run a form , runFormPost- , runFormPostNoNonce+ , runFormPostNoToken , runFormGet -- * Generate a blank form , generateFormPost@@ -48,7 +47,7 @@ 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 Yesod.Request (reqToken, reqWaiRequest, reqGetParams, languages, FileInfo (..)) import Network.Wai (requestMethod) import Text.Hamlet (shamlet) import Data.Monoid (mempty)@@ -56,14 +55,8 @@ import Yesod.Message (RenderMessage (..)) import qualified Data.Map as Map import qualified Data.ByteString.Lazy as L--#if __GLASGOW_HASKELL__ >= 700-#define WHAMLET whamlet-#define HTML shamlet-#else-#define HTML $shamlet-#define WHAMLET $whamlet-#endif+import Control.Applicative ((<$>))+import Control.Arrow (first) -- | Get a unique identifier. newFormIdent :: MForm sub master Text@@ -100,19 +93,17 @@ (x, _, _) <- ask return $ liftM snd x -mreq :: (RenderMessage master msg, RenderMessage master FormMessage)- => Field sub master a -> FieldSettings msg -> Maybe a+mreq :: RenderMessage master FormMessage+ => Field sub master a -> FieldSettings master -> Maybe a -> MForm 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 :: RenderMessage master msg- => Field sub master a -> FieldSettings msg -> Maybe (Maybe a)+mopt :: Field sub master a -> FieldSettings master -> Maybe (Maybe a) -> MForm 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 :: RenderMessage master msg- => Field sub master a- -> FieldSettings msg+mhelper :: Field sub master a+ -> FieldSettings master -> Maybe a -> (master -> [Text] -> FormResult b) -- ^ on missing -> (a -> FormResult b) -- ^ on success@@ -141,7 +132,7 @@ { fvLabel = toHtml $ mr2 fsLabel , fvTooltip = fmap toHtml $ fmap mr2 fsTooltip , fvId = theId- , fvInput = fieldView theId name fsClass val isReq+ , fvInput = fieldView theId name fsAttrs val isReq , fvErrors = case res of FormFailure [e] -> Just $ toHtml e@@ -149,14 +140,13 @@ , fvRequired = isReq }) -areq :: (RenderMessage master msg, RenderMessage master FormMessage)- => Field sub master a -> FieldSettings msg -> Maybe a+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 -aopt :: RenderMessage master msg- => Field sub master a- -> FieldSettings msg+aopt :: Field sub master a+ -> FieldSettings master -> Maybe (Maybe a) -> AForm sub master (Maybe a) aopt a b = formToAForm . fmap (second return) . mopt a b@@ -186,18 +176,18 @@ -> GHandler sub master ((FormResult a, xml), Enctype) postHelper form env = do req <- getRequest- let nonceKey = "_nonce"- let nonce =- case reqNonce req of+ let tokenKey = "_token"+ let token =+ case reqToken req of Nothing -> mempty- Just n -> [HTML|<input type=hidden name=#{nonceKey} value=#{n}>|]+ Just n -> [shamlet|<input type=hidden name=#{tokenKey} value=#{n}>|] m <- getYesod langs <- languages- ((res, xml), enctype) <- runFormGeneric (form nonce) m langs env+ ((res, xml), enctype) <- runFormGeneric (form token) m langs env let res' = case (res, env) of (FormSuccess{}, Just (params, _))- | Map.lookup nonceKey params /= fmap return (reqNonce req) ->+ | Map.lookup tokenKey params /= fmap return (reqToken req) -> FormFailure [renderMessage m langs MsgCsrfWarning] _ -> res return ((res', xml), enctype)@@ -209,8 +199,8 @@ generateFormPost :: RenderMessage master FormMessage => (Html -> MForm sub master (FormResult a, xml))- -> GHandler sub master ((FormResult a, xml), Enctype)-generateFormPost form = postHelper form Nothing+ -> GHandler sub master (xml, Enctype)+generateFormPost form = first snd <$> postHelper form Nothing postEnv :: GHandler sub master (Maybe (Env, FileEnv)) postEnv = do@@ -224,8 +214,8 @@ where notEmpty = not . L.null . fileContent -runFormPostNoNonce :: (Html -> MForm sub master (FormResult a, xml)) -> GHandler sub master ((FormResult a, xml), Enctype)-runFormPostNoNonce form = do+runFormPostNoToken :: (Html -> MForm sub master (FormResult a, xml)) -> GHandler sub master ((FormResult a, xml), Enctype)+runFormPostNoToken form = do langs <- languages m <- getYesod env <- postEnv@@ -248,7 +238,7 @@ getHelper :: (Html -> MForm sub master a) -> Maybe (Env, FileEnv) -> GHandler sub master (a, Enctype) getHelper form env = do- let fragment = [HTML|<input type=hidden name=#{getKey}>|]+ let fragment = [shamlet|<input type=hidden name=#{getKey}>|] langs <- languages m <- getYesod runFormGeneric (form fragment) m langs env@@ -263,7 +253,7 @@ (res, views') <- aFormToForm aform let views = views' [] -- FIXME non-valid HTML- let widget = [WHAMLET|+ let widget = [whamlet| \#{fragment} $forall view <- views <tr :fvRequired view:.required :not $ fvRequired view:.optional>@@ -280,7 +270,7 @@ renderDivs aform fragment = do (res, views') <- aFormToForm aform let views = views' []- let widget = [WHAMLET|+ let widget = [whamlet| \#{fragment} $forall view <- views <div :fvRequired view:.required :not $ fvRequired view:.optional>@@ -293,7 +283,7 @@ |] return (res, widget) --- | Render a form using Bootstrap-friendly HTML syntax.+-- | Render a form using Bootstrap-friendly shamlet syntax. -- -- Sample Hamlet: --@@ -356,7 +346,7 @@ (const $ Left msg) Right) $ fieldParse field ts } -- | Generate a 'FieldSettings' from the given label.-fieldSettingsLabel :: msg -> FieldSettings msg+fieldSettingsLabel :: SomeMessage master -> FieldSettings master fieldSettingsLabel msg = FieldSettings msg Nothing Nothing Nothing [] -- | Generate an 'AForm' that gets its value from the given action.
Yesod/Form/Jquery.hs view
@@ -1,7 +1,6 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NoMonomorphismRestriction #-} -- FIXME remove -- | Some fields spiced up with jQuery UI.@@ -19,7 +18,6 @@ import Yesod.Form import Yesod.Widget import Data.Time (Day)-import qualified Data.Text as T import Data.Default import Text.Hamlet (shamlet) import Text.Julius (julius)@@ -27,18 +25,6 @@ import Data.Monoid (mconcat) import Yesod.Core (RenderMessage, SomeMessage (..)) -#if __GLASGOW_HASKELL__ >= 700-#define HTML shamlet-#define HAMLET hamlet-#define CASSIUS cassius-#define JULIUS julius-#else-#define HTML $shamlet-#define HAMLET $hamlet-#define CASSIUS $cassius-#define JULIUS $julius-#endif- -- | Gets the Google hosted jQuery UI 1.8 CSS file with the given theme. googleHostedJqueryUiCss :: Text -> Text googleHostedJqueryUiCss theme = mconcat@@ -76,14 +62,14 @@ Right . readMay . unpack- , fieldView = \theId name theClass val isReq -> do- addHtml [HTML|\-<input id="#{theId}" name="#{name}" :not (null theClass):class="#{T.intercalate " " theClass}" type="date" :isReq:required="" value="#{showVal val}">+ , fieldView = \theId name attrs val isReq -> do+ toWidget [shamlet|+<input id="#{theId}" name="#{name}" *{attrs} type="date" :isReq:required="" value="#{showVal val}"> |] addScript' urlJqueryJs addScript' urlJqueryUiJs addStylesheet' urlJqueryUiCss- addJulius [JULIUS|+ toWidget [julius| $(function(){ var i = $("##{theId}"); if (i.attr("type") != "date") {@@ -115,14 +101,14 @@ => Route master -> Field sub master Text jqueryAutocompleteField src = Field { fieldParse = blank $ Right- , fieldView = \theId name theClass val isReq -> do- addHtml [HTML|\-<input id="#{theId}" name="#{name}" :not (null theClass):class="#{T.intercalate " " theClass}" type="text" :isReq:required="" value="#{either id id val}" .autocomplete>+ , fieldView = \theId name attrs val isReq -> do+ toWidget [shamlet|+<input id="#{theId}" name="#{name}" *{attrs} type="text" :isReq:required="" value="#{either id id val}" .autocomplete> |] addScript' urlJqueryJs addScript' urlJqueryUiJs addStylesheet' urlJqueryUiCss- addJulius [JULIUS|+ toWidget [julius| $(function(){$("##{theId}").autocomplete({source:"@{src}",minLength:2})}); |] }
Yesod/Form/MassInput.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-}@@ -25,14 +24,7 @@ import Data.Traversable (sequenceA) import qualified Data.Map as Map import Data.Maybe (listToMaybe)--#if __GLASGOW_HASKELL__ >= 700-#define WHAMLET whamlet-#define HTML html-#else-#define HTML $html-#define WHAMLET $whamlet-#endif+import Yesod.Core (SomeMessage (SomeMessage)) down :: Int -> MForm sub master () down 0 = return ()@@ -82,7 +74,7 @@ { fvLabel = label , fvTooltip = Nothing , fvId = theId- , fvInput = [WHAMLET|+ , fvInput = [whamlet| ^{fixXml views} <p> $forall xml <- xmls@@ -103,14 +95,14 @@ deleteName <- newFormIdent (menv, _, _) <- ask res <- case menv >>= Map.lookup deleteName . fst of- Just ("yes":_) -> return $ Left [WHAMLET|<input type=hidden name=#{deleteName} value=yes>|]+ Just ("yes":_) -> return $ Left [whamlet|<input type=hidden name=#{deleteName} value=yes>|] _ -> do (_, xml2) <- aFormToForm $ areq boolField FieldSettings- { fsLabel = MsgDelete+ { fsLabel = SomeMessage MsgDelete , fsTooltip = Nothing , fsName = Just deleteName , fsId = Nothing- , fsClass = []+ , fsAttrs = [] } $ Just False (res, xml) <- aFormToForm af return $ Right (res, xml $ xml2 [])@@ -129,7 +121,7 @@ massDivs, massTable :: [[FieldView sub master]] -> GWidget sub master ()-massDivs viewss = [WHAMLET|+massDivs viewss = [whamlet| $forall views <- viewss <fieldset> $forall view <- views@@ -142,7 +134,7 @@ <div .errors>#{err} |] -massTable viewss = [WHAMLET|+massTable viewss = [whamlet| $forall views <- viewss <fieldset> <table>
Yesod/Form/Nic.hs view
@@ -1,7 +1,6 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NoMonomorphismRestriction #-} -- FIXME remove -- | Provide the user with a rich text editor.@@ -20,7 +19,6 @@ import Text.Blaze.Renderer.String (renderHtml) import Text.Blaze (preEscapedText) import Data.Text (Text, pack)-import qualified Data.Text as T import Data.Maybe (listToMaybe) class Yesod a => YesodNic a where@@ -31,33 +29,18 @@ nicHtmlField :: YesodNic master => Field sub master Html nicHtmlField = Field { fieldParse = return . Right . fmap (preEscapedText . sanitizeBalance) . listToMaybe- , fieldView = \theId name theClass val _isReq -> do- addHtml-#if __GLASGOW_HASKELL__ >= 700- [shamlet|-#else- [$shamlet|-#endif- <textarea id="#{theId}" :not (null theClass):class="#{T.intercalate " " theClass}" name="#{name}" .html>#{showVal val}+ , fieldView = \theId name attrs val _isReq -> do+ toWidget [shamlet|+ <textarea id="#{theId}" *{attrs} name="#{name}" .html>#{showVal val} |] addScript' urlNicEdit master <- lift getYesod- addJulius $+ toWidget $ case jsLoader master of- BottomOfHeadBlocking ->-#if __GLASGOW_HASKELL__ >= 700- [julius|-#else- [$julius|-#endif+ BottomOfHeadBlocking -> [julius| bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("#{theId}")}); |]- _ ->-#if __GLASGOW_HASKELL__ >= 700- [julius|-#else- [$julius|-#endif+ _ -> [julius| (function(){new nicEditor({fullPanel:true}).panelInstance("#{theId}")})(); |] }
Yesod/Form/Types.hs view
@@ -94,15 +94,15 @@ mempty = pure mempty mappend a b = mappend <$> a <*> b -data FieldSettings msg = FieldSettings- { fsLabel :: msg -- FIXME switch to SomeMessage?- , fsTooltip :: Maybe msg+data FieldSettings master = FieldSettings+ { fsLabel :: SomeMessage master+ , fsTooltip :: Maybe (SomeMessage master) , fsId :: Maybe Text , fsName :: Maybe Text- , fsClass :: [Text]+ , fsAttrs :: [(Text, Text)] } -instance (a ~ Text) => IsString (FieldSettings a) where+instance IsString (FieldSettings a) where fromString s = FieldSettings (fromString s) Nothing Nothing Nothing [] data FieldView sub master = FieldView@@ -116,10 +116,10 @@ data Field sub master a = Field { fieldParse :: [Text] -> GHandler sub master (Either (SomeMessage master) (Maybe a))- -- | ID, name, class, (invalid text OR legimiate result), required?+ -- | ID, name, attrs, (invalid text OR legimiate result), required? , fieldView :: Text -> Text- -> [Text]+ -> [(Text, Text)] -> Either Text a -> Bool -> GWidget sub master ()
yesod-form.cabal view
@@ -1,6 +1,6 @@ name: yesod-form-version: 0.4.2.1-license: BSD3+version: 1.0.0+license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com> maintainer: Michael Snoyman <michael@snoyman.com>@@ -14,15 +14,15 @@ library build-depends: base >= 4 && < 5- , yesod-core >= 0.10.2 && < 0.11- , yesod-persistent >= 0.3.1 && < 0.4+ , yesod-core >= 1.0 && < 1.1+ , yesod-persistent >= 1.0 && < 1.1 , time >= 1.1.4- , hamlet >= 0.10 && < 0.11- , shakespeare-css >= 0.10 && < 0.11- , shakespeare-js >= 0.11 && < 0.12- , persistent >= 0.8 && < 0.9+ , hamlet >= 1.0 && < 1.1+ , shakespeare-css >= 1.0 && < 1.1+ , shakespeare-js >= 1.0 && < 1.1+ , persistent >= 0.9 && < 0.10 , template-haskell- , transformers >= 0.2.2 && < 0.3+ , transformers >= 0.2.2 && < 0.4 , data-default >= 0.3 && < 0.4 , xss-sanitize >= 0.3.0.1 && < 0.4 , blaze-builder >= 0.2.1.4 && < 0.4@@ -31,7 +31,7 @@ , blaze-html >= 0.4.1.3 && < 0.5 , bytestring >= 0.9.1.4 && < 0.10 , text >= 0.9 && < 1.0- , wai >= 1.1 && < 1.2+ , wai >= 1.2 && < 1.3 , containers >= 0.2 && < 0.5 exposed-modules: Yesod.Form Yesod.Form.Class