update for yesod-form-1.4.0.2

1 files changed, 68 insertions, 114 deletions

diff --git a/standalone/no-th/haskell-patches/yesod-form_spliced-TH.patch b/standalone/no-th/haskell-patches/yesod-form_spliced-TH.patch
index c5662a85b..e29c7de11 100644
--- a/standalone/no-th/haskell-patches/yesod-form_spliced-TH.patch
+++ b/standalone/no-th/haskell-patches/yesod-form_spliced-TH.patch
@@ -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