From fbd8f048c239e34625e438a24213534f6f68c3e8 Mon Sep 17 00:00:00 2001 From: dummy Date: Tue, 17 Dec 2013 18:34:25 +0000 Subject: [PATCH] spliced TH --- Yesod/Form/Fields.hs | 771 ++++++++++++++++++++++++++++++++++++------------ Yesod/Form/Functions.hs | 239 ++++++++++++--- Yesod/Form/Jquery.hs | 129 ++++++-- Yesod/Form/MassInput.hs | 233 ++++++++++++--- Yesod/Form/Nic.hs | 65 +++- yesod-form.cabal | 1 + 6 files changed, 1127 insertions(+), 311 deletions(-) diff --git a/Yesod/Form/Fields.hs b/Yesod/Form/Fields.hs index b2a47c6..016c98b 100644 --- a/Yesod/Form/Fields.hs +++ b/Yesod/Form/Fields.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -36,15 +35,11 @@ module Yesod.Form.Fields , selectFieldList , radioField , radioFieldList - , checkboxesFieldList - , checkboxesField , multiSelectField , multiSelectFieldList , Option (..) , OptionList (..) , mkOptionList - , optionsPersist - , optionsPersistKey , optionsPairs , optionsEnum ) where @@ -70,6 +65,15 @@ import Text.HTML.SanitizeXSS (sanitizeBalance) import Control.Monad (when, unless) import Data.Maybe (listToMaybe, fromMaybe) +import qualified Text.Blaze as Text.Blaze.Internal +import qualified Text.Blaze.Internal +import qualified Text.Hamlet +import qualified Yesod.Core.Widget +import qualified Text.Css +import qualified Data.Monoid +import qualified Data.Foldable +import qualified Control.Monad + import qualified Blaze.ByteString.Builder.Html.Utf8 as B import Blaze.ByteString.Builder (writeByteString, toLazyByteString) import Blaze.ByteString.Builder.Internal.Write (fromWriteList) @@ -82,14 +86,12 @@ import Data.Text (Text, unpack, pack) import qualified Data.Text.Read import qualified Data.Map as Map -import Yesod.Persist (selectList, runDB, Filter, SelectOpt, Key, YesodPersist, PersistEntity, PersistQuery, YesodDB) import Control.Arrow ((&&&)) import Control.Applicative ((<$>), (<|>)) import Data.Attoparsec.Text (Parser, char, string, digit, skipSpace, endOfInput, parseOnly) -import Yesod.Persist.Core defaultFormMessage :: FormMessage -> Text defaultFormMessage = englishFormMessage @@ -102,10 +104,24 @@ intField = Field Right (a, "") -> Right a _ -> Left $ MsgInvalidInteger s - , fieldView = \theId name attrs val isReq -> toWidget [hamlet| -$newline never - -|] + , fieldView = \theId name attrs val isReq -> toWidget $ \ _render_arOn + -> do { id + ((Text.Blaze.Internal.preEscapedText . pack) "") } + , fieldEnctype = UrlEncoded } where @@ -119,10 +135,24 @@ doubleField = Field Right (a, "") -> Right a _ -> Left $ MsgInvalidNumber s - , fieldView = \theId name attrs val isReq -> toWidget [hamlet| -$newline never - -|] + , fieldView = \theId name attrs val isReq -> toWidget $ \ _render_arOz + -> do { id + ((Text.Blaze.Internal.preEscapedText . pack) "") } + , fieldEnctype = UrlEncoded } where showVal = either id (pack . show) @@ -130,10 +160,24 @@ $newline never dayField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Day dayField = Field { fieldParse = parseHelper $ parseDate . unpack - , fieldView = \theId name attrs val isReq -> toWidget [hamlet| -$newline never - -|] + , fieldView = \theId name attrs val isReq -> toWidget $ \ _render_arOJ + -> do { id + ((Text.Blaze.Internal.preEscapedText . pack) "") } + , fieldEnctype = UrlEncoded } where showVal = either id (pack . show) @@ -141,10 +185,23 @@ $newline never timeField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m TimeOfDay timeField = Field { fieldParse = parseHelper parseTime - , fieldView = \theId name attrs val isReq -> toWidget [hamlet| -$newline never - -|] + , fieldView = \theId name attrs val isReq -> toWidget $ \ _render_arOW + -> do { id + ((Text.Blaze.Internal.preEscapedText . pack) "") } + , fieldEnctype = UrlEncoded } where @@ -157,10 +214,18 @@ $newline never 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| -$newline never -") } + , fieldEnctype = UrlEncoded } where showVal = either id (pack . renderHtml) @@ -169,8 +234,6 @@ $newline never -- br-tags. newtype Textarea = Textarea { unTextarea :: Text } deriving (Show, Read, Eq, PersistField, Ord) -instance PersistFieldSql Textarea where - sqlType _ = SqlString instance ToHtml Textarea where toHtml = unsafeByteString @@ -188,10 +251,18 @@ instance ToHtml Textarea where textareaField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Textarea textareaField = Field { fieldParse = parseHelper $ Right . Textarea - , fieldView = \theId name attrs val _isReq -> toWidget [hamlet| -$newline never -") } + , fieldEnctype = UrlEncoded } @@ -199,10 +270,19 @@ 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| -$newline never - -|] + , fieldView = \theId name attrs val _isReq -> toWidget $ \ _render_arPo + -> do { id + ((Text.Blaze.Internal.preEscapedText . pack) + "") } + , fieldEnctype = UrlEncoded } @@ -210,20 +290,55 @@ textField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Tex textField = Field { fieldParse = parseHelper $ Right , fieldView = \theId name attrs val isReq -> - [whamlet| -$newline never - -|] + do { (Yesod.Core.Widget.asWidgetT . toWidget) + ((Text.Blaze.Internal.preEscapedText . pack) "") } + , fieldEnctype = UrlEncoded } passwordField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Text passwordField = Field { fieldParse = parseHelper $ Right - , fieldView = \theId name attrs val isReq -> toWidget [hamlet| -$newline never - -|] + , fieldView = \theId name attrs val isReq -> toWidget $ \ _render_arPF + -> do { id + ((Text.Blaze.Internal.preEscapedText . pack) "") } + , fieldEnctype = UrlEncoded } @@ -295,10 +410,24 @@ emailField = Field case Email.canonicalizeEmail $ encodeUtf8 s of Just e -> Right $ decodeUtf8With lenientDecode e Nothing -> Left $ MsgInvalidEmail s - , fieldView = \theId name attrs val isReq -> toWidget [hamlet| -$newline never - -|] + , fieldView = \theId name attrs val isReq -> toWidget $ \ _render_arQe + -> do { id + ((Text.Blaze.Internal.preEscapedText . pack) "") } + , fieldEnctype = UrlEncoded } @@ -307,20 +436,78 @@ searchField :: Monad m => RenderMessage (HandlerSite m) FormMessage => AutoFocus searchField autoFocus = Field { fieldParse = parseHelper Right , fieldView = \theId name attrs val isReq -> do - [whamlet|\ -$newline never - -|] + do { (Yesod.Core.Widget.asWidgetT . toWidget) + ((Text.Blaze.Internal.preEscapedText . pack) "") } + when autoFocus $ do -- we want this javascript to be placed immediately after the field - [whamlet| -$newline never -") } + + toWidget $ \ _render_arQv + -> (Text.Css.CssNoWhitespace + . (foldr ($) [])) + [((++) + $ (map + Text.Css.TopBlock + (((Text.Css.Block + {Text.Css.blockSelector = Data.Monoid.mconcat + [(Text.Css.fromText + . Text.Css.pack) + "#", + toCss theId], + Text.Css.blockAttrs = (concat + $ ([Text.Css.Attr + (Data.Monoid.mconcat + [(Text.Css.fromText + . Text.Css.pack) + "-webkit-appearance"]) + (Data.Monoid.mconcat + [(Text.Css.fromText + . Text.Css.pack) + "textfield"])] + : + (map + Text.Css.mixinAttrs + []))), + Text.Css.blockBlocks = (), + Text.Css.blockMixins = ()} + :) + . ((foldr (.) id []) + . (concatMap Text.Css.mixinBlocks [] ++))) + [])))] + , fieldEnctype = UrlEncoded } @@ -331,7 +518,30 @@ urlField = Field Nothing -> Left $ MsgInvalidUrl s Just _ -> Right s , fieldView = \theId name attrs val isReq -> - [whamlet||] + do { (Yesod.Core.Widget.asWidgetT . toWidget) + ((Text.Blaze.Internal.preEscapedText . pack) "") } + , fieldEnctype = UrlEncoded } @@ -344,18 +554,56 @@ 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 -"); + (Yesod.Core.Widget.asWidgetT . toWidget) inside; + (Yesod.Core.Widget.asWidgetT . toWidget) + ((Text.Blaze.Internal.preEscapedText . pack) "") }) + -- outside + (\_theId _name isSel -> do { (Yesod.Core.Widget.asWidgetT . toWidget) + ((Text.Blaze.Internal.preEscapedText . pack) + "") }) + -- onOpt + (\_theId _name _attrs value isSel text -> do { (Yesod.Core.Widget.asWidgetT . toWidget) + ((Text.Blaze.Internal.preEscapedText . pack) "") }) + -- inside multiSelectFieldList :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg) => [(msg, a)] @@ -378,11 +626,48 @@ multiSelectField ioptlist = view theId name attrs val isReq = do opts <- fmap olOptions $ handlerToWidget ioptlist let selOpts = map (id &&& (optselected val)) opts - [whamlet| - "); + Data.Foldable.mapM_ + (\ (opt_arRl, optsel_arRm) + -> do { (Yesod.Core.Widget.asWidgetT . toWidget) + ((Text.Blaze.Internal.preEscapedText . pack) "") }) + selOpts; + (Yesod.Core.Widget.asWidgetT . toWidget) + ((Text.Blaze.Internal.preEscapedText . pack) "") } + where optselected (Left _) _ = False optselected (Right vals) opt = (optionInternalValue opt) `elem` vals @@ -392,67 +677,172 @@ radioFieldList :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg) -> Field (HandlerT site IO) a radioFieldList = radioField . optionsPairs -checkboxesFieldList :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg) => [(msg, a)] - -> Field (HandlerT site IO) [a] -checkboxesFieldList = checkboxesField . optionsPairs - -checkboxesField :: (Eq a, RenderMessage site FormMessage) - => HandlerT site IO (OptionList a) - -> Field (HandlerT site IO) [a] -checkboxesField ioptlist = (multiSelectField ioptlist) - { fieldView = - \theId name attrs val isReq -> do - opts <- fmap olOptions $ handlerToWidget ioptlist - let optselected (Left _) _ = False - optselected (Right vals) opt = (optionInternalValue opt) `elem` vals - [whamlet| - - $forall opt <- opts -