mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

update for yesod-form-1.4.0.2

Browse source
This commit is contained in:
Joey Hess 2014-10-13 17:09:12 -04:00
parent a1186238dc
commit 5cd59f896d
1 changed files with 68 additions and 114 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

182
standalone/no-th/haskell-patches/yesod-form_spliced-TH.patch
View file

@ -1,20 +1,5 @@
From 6aabd510081681f81f4259190be32fbb2819b46c Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Fri, 12 Sep 2014 21:30:27 -0400
Subject: [PATCH] splice TH
---
Yesod/Form/Bootstrap3.hs | 183 +++++++++---
Yesod/Form/Fields.hs | 753 ++++++++++++++++++++++++++++++++++++++---------
Yesod/Form/Functions.hs | 257 +++++++++++++---
Yesod/Form/Jquery.hs | 134 +++++++--
Yesod/Form/MassInput.hs | 226 +++++++++++---
Yesod/Form/Nic.hs | 67 ++++-
yesod-form.cabal | 1 -
7 files changed, 1319 insertions(+), 302 deletions(-)
diff --git a/Yesod/Form/Bootstrap3.hs b/Yesod/Form/Bootstrap3.hs
index 84e85fc..943c416 100644
index 84e85fc..1954fb4 100644
--- a/Yesod/Form/Bootstrap3.hs
+++ b/Yesod/Form/Bootstrap3.hs
@@ -26,6 +26,9 @@ import Data.String (IsString(..))
@ -27,7 +12,7 @@ index 84e85fc..943c416 100644
import Yesod.Form.Types
import Yesod.Form.Functions
@@ -152,44 +152,144 @@ renderBootstrap3 formLayout aform fragment = do
@@ -152,44 +155,144 @@ renderBootstrap3 formLayout aform fragment = do
let views = views' []
has (Just _) = True
has Nothing = False
@ -205,7 +190,7 @@ index 84e85fc..943c416 100644
-- | How the 'bootstrapSubmit' button should be rendered.
@@ -244,7 +344,22 @@ mbootstrapSubmit
@@ -244,7 +347,22 @@ mbootstrapSubmit
=> BootstrapSubmit msg -> MForm m (FormResult (), FieldView site)
mbootstrapSubmit (BootstrapSubmit msg classes attrs) =
let res = FormSuccess ()
@ -230,7 +215,7 @@ index 84e85fc..943c416 100644
, fvTooltip = Nothing
, fvId = bootstrapSubmitId
diff --git a/Yesod/Form/Fields.hs b/Yesod/Form/Fields.hs
index c6091a9..3d7b267 100644
index 8173e78..8ee847d 100644
--- a/Yesod/Form/Fields.hs
+++ b/Yesod/Form/Fields.hs
@@ -1,4 +1,3 @@
@ -280,7 +265,7 @@ index c6091a9..3d7b267 100644
import qualified Blaze.ByteString.Builder.Html.Utf8 as B
import Blaze.ByteString.Builder (writeByteString, toLazyByteString)
import Blaze.ByteString.Builder.Internal.Write (fromWriteList)
@@ -91,15 +92,12 @@ import qualified Data.Text as T (drop, dropWhile)
@@ -87,15 +88,12 @@ import qualified Data.Text as T (drop, dropWhile)
import qualified Data.Text.Read
import qualified Data.Map as Map
@ -296,7 +281,7 @@ index c6091a9..3d7b267 100644
defaultFormMessage :: FormMessage -> Text
defaultFormMessage = englishFormMessage
@@ -111,10 +109,25 @@ intField = Field
@@ -107,10 +105,25 @@ intField = Field
Right (a, "") -> Right a
_ -> Left $ MsgInvalidInteger s
@ -326,7 +311,7 @@ index c6091a9..3d7b267 100644
, fieldEnctype = UrlEncoded
}
where
@@ -128,10 +141,25 @@ doubleField = Field
@@ -124,10 +137,25 @@ doubleField = Field
Right (a, "") -> Right a
_ -> Left $ MsgInvalidNumber s
@ -356,7 +341,7 @@ index c6091a9..3d7b267 100644
, fieldEnctype = UrlEncoded
}
where showVal = either id (pack . show)
@@ -139,10 +167,24 @@ $newline never
@@ -135,10 +163,24 @@ $newline never
dayField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Day
dayField = Field
{ fieldParse = parseHelper $ parseDate . unpack
@ -385,7 +370,7 @@ index c6091a9..3d7b267 100644
, fieldEnctype = UrlEncoded
}
where showVal = either id (pack . show)
@@ -150,10 +192,23 @@ $newline never
@@ -146,10 +188,23 @@ $newline never
timeField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m TimeOfDay
timeField = Field
{ fieldParse = parseHelper parseTime
@ -413,7 +398,7 @@ index c6091a9..3d7b267 100644
, fieldEnctype = UrlEncoded
}
where
@@ -166,10 +221,23 @@ $newline never
@@ -162,10 +217,23 @@ $newline never
htmlField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Html
htmlField = Field
{ fieldParse = parseHelper $ Right . preEscapedText . sanitizeBalance
@ -441,13 +426,12 @@ index c6091a9..3d7b267 100644
, fieldEnctype = UrlEncoded
}
where showVal = either id (pack . renderHtml)
@@ -197,10 +265,18 @@ instance ToHtml Textarea where
textareaField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Textarea
@@ -194,9 +262,17 @@ textareaField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m
textareaField = Field
{ fieldParse = parseHelper $ Right . Textarea
- , fieldView = \theId name attrs val _isReq -> toWidget [hamlet|
, fieldView = \theId name attrs val isReq -> toWidget [hamlet|
-$newline never
-<textarea id="#{theId}" name="#{name}" *{attrs}>#{either id unTextarea val}
-<textarea id="#{theId}" name="#{name}" :isReq:required="" *{attrs}>#{either id unTextarea val}
-|]
+ , fieldView = \theId name attrs val _isReq -> toWidget $ \ _render_aJKe
+ -> do { id
@ -460,11 +444,10 @@ index c6091a9..3d7b267 100644
+ id ((Text.Blaze.Internal.preEscapedText . pack) ">");
+ id (toHtml (either id unTextarea val));
+ id ((Text.Blaze.Internal.preEscapedText . pack) "</textarea>") }
+
, fieldEnctype = UrlEncoded
}
@@ -208,10 +284,19 @@ hiddenField :: (Monad m, PathPiece p, RenderMessage (HandlerSite m) FormMessage)
@@ -204,10 +280,19 @@ hiddenField :: (Monad m, PathPiece p, RenderMessage (HandlerSite m) FormMessage)
=> Field m p
hiddenField = Field
{ fieldParse = parseHelper $ maybe (Left MsgValueRequired) Right . fromPathPiece
@ -488,7 +471,7 @@ index c6091a9..3d7b267 100644
, fieldEnctype = UrlEncoded
}
@@ -219,20 +304,53 @@ textField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Tex
@@ -215,20 +300,53 @@ textField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Tex
textField = Field
{ fieldParse = parseHelper $ Right
, fieldView = \theId name attrs val isReq ->
@ -550,7 +533,7 @@ index c6091a9..3d7b267 100644
, fieldEnctype = UrlEncoded
}
@@ -304,10 +422,24 @@ emailField = Field
@@ -300,10 +418,24 @@ emailField = Field
case Email.canonicalizeEmail $ encodeUtf8 s of
Just e -> Right $ decodeUtf8With lenientDecode e
Nothing -> Left $ MsgInvalidEmail s
@ -579,7 +562,7 @@ index c6091a9..3d7b267 100644
, fieldEnctype = UrlEncoded
}
@@ -322,10 +454,25 @@ multiEmailField = Field
@@ -318,10 +450,25 @@ multiEmailField = Field
in case partitionEithers addrs of
([], good) -> Right good
(bad, _) -> Left $ MsgInvalidEmail $ cat bad
@ -609,7 +592,7 @@ index c6091a9..3d7b267 100644
, fieldEnctype = UrlEncoded
}
where
@@ -341,20 +488,75 @@ searchField :: Monad m => RenderMessage (HandlerSite m) FormMessage => AutoFocus
@@ -337,20 +484,75 @@ searchField :: Monad m => RenderMessage (HandlerSite m) FormMessage => AutoFocus
searchField autoFocus = Field
{ fieldParse = parseHelper Right
, fieldView = \theId name attrs val isReq -> do
@ -697,7 +680,7 @@ index c6091a9..3d7b267 100644
, fieldEnctype = UrlEncoded
}
@@ -365,7 +567,28 @@ urlField = Field
@@ -361,7 +563,28 @@ urlField = Field
Nothing -> Left $ MsgInvalidUrl s
Just _ -> Right s
, fieldView = \theId name attrs val isReq ->
@ -727,7 +710,7 @@ index c6091a9..3d7b267 100644
, fieldEnctype = UrlEncoded
}
@@ -378,18 +601,54 @@ selectField :: (Eq a, RenderMessage site FormMessage)
@@ -374,18 +597,54 @@ selectField :: (Eq a, RenderMessage site FormMessage)
=> HandlerT site IO (OptionList a)
-> Field (HandlerT site IO) a
selectField = selectFieldHelper
@ -794,7 +777,7 @@ index c6091a9..3d7b267 100644
multiSelectFieldList :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg)
=> [(msg, a)]
@@ -412,11 +671,45 @@ multiSelectField ioptlist =
@@ -408,11 +667,45 @@ multiSelectField ioptlist =
view theId name attrs val isReq = do
opts <- fmap olOptions $ handlerToWidget ioptlist
let selOpts = map (id &&& (optselected val)) opts
@ -845,7 +828,7 @@ index c6091a9..3d7b267 100644
where
optselected (Left _) _ = False
optselected (Right vals) opt = (optionInternalValue opt) `elem` vals
@@ -439,54 +732,196 @@ checkboxesField ioptlist = (multiSelectField ioptlist)
@@ -435,54 +728,196 @@ checkboxesField ioptlist = (multiSelectField ioptlist)
opts <- fmap olOptions $ handlerToWidget ioptlist
let optselected (Left _) _ = False
optselected (Right vals) opt = (optionInternalValue opt) `elem` vals
@ -993,6 +976,9 @@ index c6091a9..3d7b267 100644
- <input id=#{theId}-none *{attrs} type=radio name=#{name} value=none checked>
- <label for=#{theId}-none>_{MsgSelectNone}
-
-
-<input id=#{theId}-yes *{attrs} type=radio name=#{name} value=yes :showVal id val:checked>
-<label for=#{theId}-yes>_{MsgBoolYes}
+ , fieldView = \theId name attrs val isReq -> do { condH
+ [(not isReq,
+ do { (asWidgetT . toWidget)
@ -1070,16 +1056,13 @@ index c6091a9..3d7b267 100644
+ (asWidgetT . toWidget)
+ ((Text.Blaze.Internal.preEscapedText . pack) "</label>") }
-<input id=#{theId}-yes *{attrs} type=radio name=#{name} value=yes :showVal id val:checked>
-<label for=#{theId}-yes>_{MsgBoolYes}
-
-<input id=#{theId}-no *{attrs} type=radio name=#{name} value=no :showVal not val:checked>
-<label for=#{theId}-no>_{MsgBoolNo}
-|]
, fieldEnctype = UrlEncoded
}
where
@@ -512,10 +947,24 @@ $newline never
@@ -508,10 +943,24 @@ $newline never
checkBoxField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Bool
checkBoxField = Field
{ fieldParse = \e _ -> return $ checkBoxParser e
@ -1108,7 +1091,7 @@ index c6091a9..3d7b267 100644
, fieldEnctype = UrlEncoded
}
@@ -665,9 +1114,21 @@ fileField = Field
@@ -642,9 +1091,21 @@ fileField = Field
case files of
[] -> Right Nothing
file:_ -> Right $ Just file
@ -1133,7 +1116,7 @@ index c6091a9..3d7b267 100644
, fieldEnctype = Multipart
}
@@ -694,10 +1155,19 @@ fileAFormReq fs = AForm $ \(site, langs) menvs ints -> do
@@ -671,10 +1132,19 @@ fileAFormReq fs = AForm $ \(site, langs) menvs ints -> do
{ fvLabel = toHtml $ renderMessage site langs $ fsLabel fs
, fvTooltip = fmap (toHtml . renderMessage site langs) $ fsTooltip fs
, fvId = id'
@ -1157,7 +1140,7 @@ index c6091a9..3d7b267 100644
, fvErrors = errs
, fvRequired = True
}
@@ -726,10 +1196,19 @@ fileAFormOpt fs = AForm $ \(master, langs) menvs ints -> do
@@ -703,10 +1173,19 @@ fileAFormOpt fs = AForm $ \(master, langs) menvs ints -> do
{ fvLabel = toHtml $ renderMessage master langs $ fsLabel fs
, fvTooltip = fmap (toHtml . renderMessage master langs) $ fsTooltip fs
, fvId = id'
@ -1182,10 +1165,10 @@ index c6091a9..3d7b267 100644
, fvRequired = False
}
diff --git a/Yesod/Form/Functions.hs b/Yesod/Form/Functions.hs
index 5fd03e6..b14d900 100644
index 9e6abaf..0c2a0ce 100644
--- a/Yesod/Form/Functions.hs
+++ b/Yesod/Form/Functions.hs
@@ -59,12 +59,16 @@ import Text.Blaze (Markup, toMarkup)
@@ -60,12 +60,16 @@ import Text.Blaze (Markup, toMarkup)
#define toHtml toMarkup
import Yesod.Core
import Network.Wai (requestMethod)
@ -1203,7 +1186,7 @@ index 5fd03e6..b14d900 100644
-- | Get a unique identifier.
newFormIdent :: Monad m => MForm m Text
@@ -216,7 +220,14 @@ postHelper form env = do
@@ -217,7 +221,14 @@ postHelper form env = do
let token =
case reqToken req of
Nothing -> mempty
@ -1219,7 +1202,7 @@ index 5fd03e6..b14d900 100644
m <- getYesod
langs <- languages
((res, xml), enctype) <- runFormGeneric (form token) m langs env
@@ -296,7 +307,12 @@ getHelper :: MonadHandler m
@@ -297,7 +308,12 @@ getHelper :: MonadHandler m
-> Maybe (Env, FileEnv)
-> m (a, Enctype)
getHelper form env = do
@ -1233,7 +1216,7 @@ index 5fd03e6..b14d900 100644
langs <- languages
m <- getYesod
runFormGeneric (form fragment) m langs env
@@ -331,10 +347,15 @@ identifyForm
@@ -332,10 +348,15 @@ identifyForm
identifyForm identVal form = \fragment -> do
-- Create hidden <input>.
let fragment' =
@ -1253,7 +1236,7 @@ index 5fd03e6..b14d900 100644
-- Check if we got its value back.
mp <- askParams
@@ -364,22 +385,70 @@ renderTable, renderDivs, renderDivsNoLabels :: Monad m => FormRender m a
@@ -365,22 +386,70 @@ renderTable, renderDivs, renderDivsNoLabels :: Monad m => FormRender m a
renderTable aform fragment = do
(res, views') <- aFormToForm aform
let views = views' []
@ -1340,7 +1323,7 @@ index 5fd03e6..b14d900 100644
return (res, widget)
where
addIsFirst [] = []
@@ -395,19 +464,66 @@ renderDivsMaybeLabels :: Monad m => Bool -> FormRender m a
@@ -396,19 +465,66 @@ renderDivsMaybeLabels :: Monad m => Bool -> FormRender m a
renderDivsMaybeLabels withLabels aform fragment = do
(res, views') <- aFormToForm aform
let views = views' []
@ -1420,7 +1403,7 @@ index 5fd03e6..b14d900 100644
return (res, widget)
-- | Render a form using Bootstrap v2-friendly shamlet syntax.
@@ -435,19 +551,62 @@ renderBootstrap2 aform fragment = do
@@ -436,19 +552,62 @@ renderBootstrap2 aform fragment = do
let views = views' []
has (Just _) = True
has Nothing = False
@ -1921,11 +1904,14 @@ index a2b434d..75eb484 100644
- <td .errors>#{err}
-|]
diff --git a/Yesod/Form/Nic.hs b/Yesod/Form/Nic.hs
index 7e4af07..b59745a 100644
index 2862678..7a0f25a 100644
--- a/Yesod/Form/Nic.hs
+++ b/Yesod/Form/Nic.hs
@@ -9,11 +9,22 @@ module Yesod.Form.Nic
, nicHtmlField
@@ -6,14 +6,24 @@
-- | Provide the user with a rich text editor.
module Yesod.Form.Nic
( YesodNic (..)
- , nicHtmlField
) where
+import qualified Text.Blaze as Text.Blaze.Internal
@ -1949,69 +1935,37 @@ index 7e4af07..b59745a 100644
import Text.Blaze.Html.Renderer.String (renderHtml)
import Data.Text (Text, pack)
import Data.Maybe (listToMaybe)
@@ -27,20 +38,52 @@ nicHtmlField :: YesodNic site => Field (HandlerT site IO) Html
nicHtmlField = Field
{ fieldParse = \e _ -> return . Right . fmap (preEscapedToMarkup . sanitizeBalance) . listToMaybe $ e
, fieldView = \theId name attrs val isReq -> do
@@ -22,33 +32,3 @@ class Yesod a => YesodNic a where
-- | NIC Editor Javascript file.
urlNicEdit :: a -> Either (Route a) Text
urlNicEdit _ = Right "http://js.nicedit.com/nicEdit-latest.js"
-
-nicHtmlField :: YesodNic site => Field (HandlerT site IO) Html
-nicHtmlField = Field
- { 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}" :isReq:required .html>#{showVal val}
- <textarea id="#{theId}" *{attrs} name="#{name}" .html>#{showVal val}
-|]
+ toWidget $ do { id
+ ((Text.Blaze.Internal.preEscapedText . pack)
+ "<textarea class=\"html\" id=\"");
+ id (toHtml theId);
+ id ((Text.Blaze.Internal.preEscapedText . pack) "\" name=\"");
+ id (toHtml name);
+ id ((Text.Blaze.Internal.preEscapedText . pack) "\"");
+ Text.Hamlet.condH
+ [(isReq,
+ id ((Text.Blaze.Internal.preEscapedText . pack) " required"))]
+ Nothing;
+ id ((Text.Hamlet.attrsToHtml . Text.Hamlet.toAttributes) attrs);
+ id ((Text.Blaze.Internal.preEscapedText . pack) ">");
+ id (toHtml (showVal val));
+ id ((Text.Blaze.Internal.preEscapedText . pack) "</textarea>") }
+
addScript' urlNicEdit
master <- getYesod
toWidget $
case jsLoader master of
- addScript' urlNicEdit
- master <- getYesod
- toWidget $
- case jsLoader master of
- BottomOfHeadBlocking -> [julius|
-bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("#{rawJS theId}")});
-|]
- _ -> [julius|
-(function(){new nicEditor({fullPanel:true}).panelInstance("#{rawJS theId}")})();
-|]
+ BottomOfHeadBlocking -> Text.Julius.asJavascriptUrl
+ (\ _render_a2rMh
+ -> Data.Monoid.mconcat
+ [Text.Julius.Javascript
+ ((Data.Text.Lazy.Builder.fromText
+ . Text.Shakespeare.pack')
+ "\nbkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance(\""),
+ Text.Julius.toJavascript (rawJS theId),
+ Text.Julius.Javascript
+ ((Data.Text.Lazy.Builder.fromText
+ . Text.Shakespeare.pack')
+ "\")});")])
+
+ _ -> Text.Julius.asJavascriptUrl
+ (\ _render_a2rMm
+ -> Data.Monoid.mconcat
+ [Text.Julius.Javascript
+ ((Data.Text.Lazy.Builder.fromText
+ . Text.Shakespeare.pack')
+ "\n(function(){new nicEditor({fullPanel:true}).panelInstance(\""),
+ Text.Julius.toJavascript (rawJS theId),
+ Text.Julius.Javascript
+ ((Data.Text.Lazy.Builder.fromText
+ . Text.Shakespeare.pack')
+ "\")})();")])
+
, fieldEnctype = UrlEncoded
}
where
--
2.1.0
- , fieldEnctype = UrlEncoded
- }
- where
- showVal = either id (pack . renderHtml)
-
-addScript' :: (MonadWidget m, HandlerSite m ~ site)
- => (site -> Either (Route site) Text)
- -> m ()
-addScript' f = do
- y <- getYesod
- addScriptEither $ f y