Add 'yesod-form/' from commit '53b7c3b81015e7f244c6b8961ca2f07979f932e2'

git-subtree-dir: yesod-form
git-subtree-mainline: 41faf62094
git-subtree-split: 53b7c3b810

yesod-form/LICENSE

@@ -0,0 +1,25 @@
+The following license covers this documentation, and the source code, except
+where otherwise indicated.
+
+Copyright 2010, Michael Snoyman. All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+* Redistributions of source code must retain the above copyright notice, this
+  list of conditions and the following disclaimer.
+
+* Redistributions in binary form must reproduce the above copyright notice,
+  this list of conditions and the following disclaimer in the documentation
+  and/or other materials provided with the distribution.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR
+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO
+EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,
+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,
+OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

yesod-form/Setup.lhs

@@ -0,0 +1,7 @@
+#!/usr/bin/env runhaskell
+
+> module Main where
+> import Distribution.Simple
+
+> main :: IO ()
+> main = defaultMain

yesod-form/Yesod/Form.hs

@@ -0,0 +1,14 @@
+-- | Parse forms (and query strings).
+module Yesod.Form
+    ( module Yesod.Form.Types
+    , module Yesod.Form.Functions
+    , module Yesod.Form.Fields
+    , module Yesod.Form.Class
+    , module Yesod.Form.Input
+    ) where
+
+import Yesod.Form.Types
+import Yesod.Form.Functions
+import Yesod.Form.Fields
+import Yesod.Form.Class
+import Yesod.Form.Input

yesod-form/Yesod/Form/Class.hs

@@ -0,0 +1,77 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+module Yesod.Form.Class
+    ( ToForm (..)
+    , ToField (..)
+    ) where
+
+import Text.Hamlet
+import Yesod.Widget (GGWidget)
+import Yesod.Form.Fields
+import Yesod.Form.Types
+import Yesod.Form.Functions (areq, aopt)
+import Data.Int (Int64)
+import Data.Time (Day, TimeOfDay)
+import Data.Text (Text)
+import Yesod.Handler (GGHandler)
+import Yesod.Message (RenderMessage)
+
+class ToForm a master monad where
+    toForm :: AForm ([FieldView (GGWidget master monad ())] -> [FieldView (GGWidget master monad ())]) master monad a
+
+class ToField a master monad where
+    toField :: RenderMessage master msg => FieldSettings msg -> Maybe a -> AForm ([FieldView (GGWidget master monad ())] -> [FieldView (GGWidget master monad ())]) master monad a
+
+{- FIXME
+instance ToFormField String y where
+    toFormField = stringField
+instance ToFormField (Maybe String) y where
+    toFormField = maybeStringField
+-}
+
+instance (Monad m, RenderMessage master FormMessage) => ToField Text master (GGHandler sub master m) where
+    toField = areq textField
+instance (Monad m, RenderMessage master FormMessage) => ToField (Maybe Text) master (GGHandler sub master m) where
+    toField = aopt textField
+
+instance (Monad m, RenderMessage master FormMessage) => ToField Int master (GGHandler sub master m) where
+    toField = areq intField
+instance (Monad m, RenderMessage master FormMessage) => ToField (Maybe Int) master (GGHandler sub master m) where
+    toField = aopt intField
+
+instance (Monad m, RenderMessage master FormMessage) => ToField Int64 master (GGHandler sub master m) where
+    toField = areq intField
+instance (Monad m, RenderMessage master FormMessage) => ToField (Maybe Int64) master (GGHandler sub master m) where
+    toField = aopt intField
+
+instance (Monad m, RenderMessage master FormMessage) => ToField Double master (GGHandler sub master m) where
+    toField = areq doubleField
+instance (Monad m, RenderMessage master FormMessage) => ToField (Maybe Double) master (GGHandler sub master m) where
+    toField = aopt doubleField
+
+instance (Monad m, RenderMessage master FormMessage) => ToField Day master (GGHandler sub master m) where
+    toField = areq dayField
+instance (Monad m, RenderMessage master FormMessage) => ToField (Maybe Day) master (GGHandler sub master m) where
+    toField = aopt dayField
+
+instance (Monad m, RenderMessage master FormMessage) => ToField TimeOfDay master (GGHandler sub master m) where
+    toField = areq timeField
+instance (Monad m, RenderMessage master FormMessage) => ToField (Maybe TimeOfDay) master (GGHandler sub master m) where
+    toField = aopt timeField
+
+instance (Monad m, RenderMessage master FormMessage) => ToField Html master (GGHandler sub master m) where
+    toField = areq htmlField
+instance (Monad m, RenderMessage master FormMessage) => ToField (Maybe Html) master (GGHandler sub master m) where
+    toField = aopt htmlField
+
+instance (Monad m, RenderMessage master FormMessage) => ToField Textarea master (GGHandler sub master m) where
+    toField = areq textareaField
+instance (Monad m, RenderMessage master FormMessage) => ToField (Maybe Textarea) master (GGHandler sub master m) where
+    toField = aopt textareaField
+
+{- FIXME
+instance ToFormField Bool y where
+    toFormField = boolField
+-}

yesod-form/Yesod/Form/Fields.hs

@@ -0,0 +1,421 @@
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
+module Yesod.Form.Fields
+    ( FormMessage (..)
+    , defaultFormMessage
+    , textField
+    , passwordField
+    , textareaField
+    , hiddenField
+    , intField
+    , dayField
+    , timeField
+    , htmlField
+    , emailField
+    , searchField
+    , selectField
+    , multiSelectField
+    , AutoFocus
+    , urlField
+    , doubleField
+    , parseDate
+    , parseTime
+    , Textarea (..)
+    , radioField
+    , boolField
+    ) where
+
+import Yesod.Form.Types
+import Yesod.Widget
+import Yesod.Message (RenderMessage)
+import Yesod.Handler (GGHandler)
+import Text.Hamlet
+import Text.Blaze (ToHtml (..), preEscapedString, unsafeByteString)
+import Text.Cassius
+import Data.Time (Day, TimeOfDay(..))
+import qualified Text.Email.Validate as Email
+import Network.URI (parseURI)
+import Database.Persist (PersistField)
+import Text.HTML.SanitizeXSS (sanitizeBalance)
+import Control.Monad (when, unless)
+import Data.List (intersect, nub)
+import Data.Either (rights)
+import Data.Maybe (catMaybes)
+
+import qualified Blaze.ByteString.Builder.Html.Utf8 as B
+import Blaze.ByteString.Builder (writeByteString, toLazyByteString)
+import Blaze.ByteString.Builder.Internal.Write (fromWriteList)
+
+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.Read
+import Data.Monoid (mappend)
+import Text.Hamlet (html)
+
+#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
+
+data FormMessage = MsgInvalidInteger Text
+                 | MsgInvalidNumber Text
+                 | MsgInvalidEntry Text
+                 | MsgInvalidUrl Text
+                 | MsgInvalidEmail Text
+                 | MsgInvalidTimeFormat
+                 | MsgInvalidHour Text
+                 | MsgInvalidMinute Text
+                 | MsgInvalidSecond Text
+                 | MsgInvalidDay
+                 | MsgCsrfWarning
+                 | MsgValueRequired
+                 | MsgInputNotFound Text
+                 | MsgSelectNone
+                 | MsgInvalidBool Text
+                 | MsgBoolYes
+                 | MsgBoolNo
+
+defaultFormMessage :: FormMessage -> Text
+defaultFormMessage (MsgInvalidInteger t) = "Invalid integer: " `mappend` t
+defaultFormMessage (MsgInvalidNumber t) = "Invalid number: " `mappend` t
+defaultFormMessage (MsgInvalidEntry t) = "Invalid entry: " `mappend` t
+defaultFormMessage MsgInvalidTimeFormat = "Invalid time, must be in HH:MM[:SS] format"
+defaultFormMessage MsgInvalidDay = "Invalid day, must be in YYYY-MM-DD format"
+defaultFormMessage (MsgInvalidUrl t) = "Invalid URL: " `mappend` t
+defaultFormMessage (MsgInvalidEmail t) = "Invalid e-mail address: " `mappend` t
+defaultFormMessage (MsgInvalidHour t) = "Invalid hour: " `mappend` t
+defaultFormMessage (MsgInvalidMinute t) = "Invalid minute: " `mappend` t
+defaultFormMessage (MsgInvalidSecond t) = "Invalid second: " `mappend` t
+defaultFormMessage MsgCsrfWarning = "As a protection against cross-site request forgery attacks, please confirm your form submission."
+defaultFormMessage MsgValueRequired = "Value is required"
+defaultFormMessage (MsgInputNotFound t) = "Input not found: " `mappend` t
+defaultFormMessage MsgSelectNone = "<None>"
+defaultFormMessage (MsgInvalidBool t) = "Invalid boolean: " `mappend` t
+defaultFormMessage MsgBoolYes = "Yes"
+defaultFormMessage MsgBoolNo = "No"
+
+blank :: (Text -> Either msg a) -> [Text] -> Either msg (Maybe a)
+blank _ [] = Right Nothing
+blank _ ("":_) = Right Nothing
+blank f (x:_) = either Left (Right . Just) $ f x
+
+
+
+intField :: (Monad monad, Integral i) => Field (GGWidget master monad ()) FormMessage i
+intField = Field
+    { fieldParse = blank $ \s ->
+        case Data.Text.Read.signed Data.Text.Read.decimal s of
+            Right (a, "") -> Right a
+            _ -> Left $ MsgInvalidInteger s
+
+    , fieldView = \theId name val isReq -> addHamlet
+        [HAMLET|\
+<input id="#{theId}" name="#{name}" type="number" :isReq:required="" value="#{showVal val}">
+|]
+    }
+  where
+    showVal = either id (pack . showI)
+    showI x = show (fromIntegral x :: Integer)
+
+doubleField :: Monad monad => Field (GGWidget master monad ()) FormMessage Double
+doubleField = Field
+    { fieldParse = blank $ \s ->
+        case Data.Text.Read.double s of
+            Right (a, "") -> Right a
+            _ -> Left $ MsgInvalidNumber s
+
+    , fieldView = \theId name val isReq -> addHamlet
+        [HAMLET|\
+<input id="#{theId}" name="#{name}" type="text" :isReq:required="" value="#{showVal val}">
+|]
+    }
+  where showVal = either id (pack . show)
+
+dayField :: Monad monad => Field (GGWidget master monad ()) FormMessage Day
+dayField = Field
+    { fieldParse = blank $ parseDate . unpack
+    , fieldView = \theId name val isReq -> addHamlet
+        [HAMLET|\
+<input id="#{theId}" name="#{name}" type="date" :isReq:required="" value="#{showVal val}">
+|]
+    }
+  where showVal = either id (pack . show)
+
+timeField :: Monad monad => Field (GGWidget master monad ()) FormMessage TimeOfDay
+timeField = Field
+    { fieldParse = blank $ parseTime . unpack
+    , fieldView = \theId name val isReq -> addHamlet
+        [HAMLET|\
+<input id="#{theId}" name="#{name}" :isReq:required="" value="#{showVal val}">
+|]
+    }
+  where
+    showVal = either id (pack . show . roundFullSeconds)
+    roundFullSeconds tod =
+        TimeOfDay (todHour tod) (todMin tod) fullSec
+      where
+        fullSec = fromInteger $ floor $ todSec tod
+
+htmlField :: Monad monad => Field (GGWidget master monad ()) FormMessage Html
+htmlField = Field
+    { fieldParse = blank $ Right . preEscapedString . sanitizeBalance . unpack -- FIXME make changes to xss-sanitize
+    , fieldView = \theId name val _isReq -> addHamlet
+        [HAMLET|\
+<textarea id="#{theId}" name="#{name}" .html>#{showVal val}
+|]
+    }
+  where showVal = either id (pack . renderHtml)
+
+-- | A newtype wrapper around a 'String' that converts newlines to HTML
+-- br-tags.
+newtype Textarea = Textarea { unTextarea :: Text }
+    deriving (Show, Read, Eq, PersistField)
+instance ToHtml Textarea where
+    toHtml =
+        unsafeByteString
+        . S.concat
+        . L.toChunks
+        . toLazyByteString
+        . fromWriteList writeHtmlEscapedChar
+        . unpack
+        . unTextarea
+      where
+        -- Taken from blaze-builder and modified with newline handling.
+        writeHtmlEscapedChar '\n' = writeByteString "<br>"
+        writeHtmlEscapedChar c    = B.writeHtmlEscapedChar c
+
+textareaField :: Monad monad => Field (GGWidget master monad ()) FormMessage Textarea
+textareaField = Field
+    { fieldParse =  blank $ Right . Textarea
+    , fieldView = \theId name val _isReq -> addHamlet
+        [HAMLET|\
+<textarea id="#{theId}" name="#{name}">#{either id unTextarea val}
+|]
+    }
+
+hiddenField :: Monad monad => Field (GGWidget master monad ()) FormMessage Text
+hiddenField = Field
+    { fieldParse = blank $ Right
+    , fieldView = \theId name val _isReq -> addHamlet
+        [HAMLET|\
+<input type="hidden" id="#{theId}" name="#{name}" value="#{either id id val}">
+|]
+    }
+
+textField :: Monad monad => Field (GGWidget master monad ()) FormMessage Text
+textField = Field
+    { fieldParse = blank $ Right
+    , fieldView = \theId name val isReq ->
+        [WHAMLET|
+<input id="#{theId}" name="#{name}" type="text" :isReq:required value="#{either id id val}">
+|]
+    }
+
+passwordField :: Monad monad => Field (GGWidget master monad ()) FormMessage Text
+passwordField = Field
+    { fieldParse = blank $ Right
+    , fieldView = \theId name val isReq -> addHamlet
+        [HAMLET|\
+<input id="#{theId}" name="#{name}" type="password" :isReq:required="" value="#{either id id val}">
+|]
+    }
+
+readMay :: Read a => String -> Maybe a
+readMay s = case reads s of
+                (x, _):_ -> Just x
+                [] -> Nothing
+
+parseDate :: String -> Either FormMessage Day
+parseDate = maybe (Left MsgInvalidDay) Right
+              . readMay . replace '/' '-'
+
+-- | 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)
+
+parseTime :: String -> Either FormMessage TimeOfDay
+parseTime (h2:':':m1:m2:[]) = parseTimeHelper ('0', h2, m1, m2, '0', '0')
+parseTime (h1:h2:':':m1:m2:[]) = parseTimeHelper (h1, h2, m1, m2, '0', '0')
+parseTime (h1:h2:':':m1:m2:' ':'A':'M':[]) =
+    parseTimeHelper (h1, h2, m1, m2, '0', '0')
+parseTime (h1:h2:':':m1:m2:' ':'P':'M':[]) =
+    let [h1', h2'] = show $ (read [h1, h2] :: Int) + 12
+    in parseTimeHelper (h1', h2', m1, m2, '0', '0')
+parseTime (h1:h2:':':m1:m2:':':s1:s2:[]) =
+    parseTimeHelper (h1, h2, m1, m2, s1, s2)
+parseTime _ = Left MsgInvalidTimeFormat
+
+parseTimeHelper :: (Char, Char, Char, Char, Char, Char)
+                -> Either FormMessage TimeOfDay
+parseTimeHelper (h1, h2, m1, m2, s1, s2)
+    | h < 0 || h > 23 = Left $ MsgInvalidHour $ pack [h1, h2]
+    | m < 0 || m > 59 = Left $ MsgInvalidMinute $ pack [m1, m2]
+    | s < 0 || s > 59 = Left $ MsgInvalidSecond $ pack [s1, s2]
+    | otherwise = Right $ TimeOfDay h m s
+  where
+    h = read [h1, h2] -- FIXME isn't this a really bad idea?
+    m = read [m1, m2]
+    s = fromInteger $ read [s1, s2]
+
+emailField :: Monad monad => Field (GGWidget master monad ()) FormMessage Text
+emailField = Field
+    { fieldParse = blank $
+        \s -> if Email.isValid (unpack s)
+                then Right s
+                else Left $ MsgInvalidEmail s
+    , fieldView = \theId name val isReq -> addHamlet
+        [HAMLET|\
+<input id="#{theId}" name="#{name}" type="email" :isReq:required="" value="#{either id id val}">
+|]
+    }
+
+type AutoFocus = Bool
+searchField :: Monad monad => AutoFocus -> Field (GGWidget master monad ()) FormMessage Text
+searchField autoFocus = Field
+    { fieldParse =  blank Right
+    , fieldView = \theId name val isReq -> do
+        [WHAMLET|\
+<input id="#{theId}" name="#{name}" type="search" :isReq:required="" :autoFocus:autofocus="" value="#{either id id val}">
+|]
+        when autoFocus $ do
+          [WHAMLET|\<script>if (!('autofocus' in document.createElement('input'))) {document.getElementById('#{theId}').focus();}</script> 
+|]
+          addCassius [CASSIUS|
+            #{theId}
+              -webkit-appearance: textfield
+            |]
+    }
+
+urlField :: Monad monad => Field (GGWidget master monad ()) FormMessage Text
+urlField = Field
+    { fieldParse = blank $ \s ->
+        case parseURI $ unpack s of
+            Nothing -> Left $ MsgInvalidUrl s
+            Just _ -> Right s
+    , fieldView = \theId name val isReq ->
+        [WHAMLET|
+<input ##{theId} name=#{name} type=url :isReq:required value=#{either id id val}>
+|]
+    }
+
+selectField :: (Eq a, Monad monad, RenderMessage master FormMessage) => [(Text, a)] -> Field (GGWidget master (GGHandler sub master monad) ()) FormMessage a
+selectField = selectFieldHelper
+    (\theId name inside -> [WHAMLET|<select ##{theId} name=#{name}>^{inside}|])
+    (\_theId _name isSel -> [WHAMLET|<option value=none :isSel:selected>_{MsgSelectNone}|])
+    (\_theId _name value isSel text -> [WHAMLET|<option value=#{value} :isSel:selected>#{text}|])
+
+multiSelectField :: (Show a, Eq a, Monad monad, RenderMessage master FormMessage) => [(Text, a)] -> Field (GGWidget master (GGHandler sub master monad) ()) FormMessage [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}|])
+
+radioField :: (Eq a, Monad monad, RenderMessage master FormMessage) => [(Text, a)] -> Field (GGWidget master (GGHandler sub master monad) ()) FormMessage 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|
+<div>
+    <input id=#{theId}-#{value} type=radio name=#{name} value=#{value} :isSel:checked>
+    <label for=#{theId}-#{value}>#{text}
+|])
+
+boolField :: (Monad monad, RenderMessage master FormMessage) => Field (GGWidget master (GGHandler sub master monad) ()) FormMessage Bool
+boolField = Field
+      { fieldParse = boolParser
+      , fieldView = \theId name val isReq -> [WHAMLET|
+  $if not isReq
+      <input id=#{theId}-none 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>
+<label for=#{theId}-yes>_{MsgBoolYes}
+
+<input id=#{theId}-no type=radio name=#{name} value=no :showVal not val:checked>
+<label for=#{theId}-no>_{MsgBoolNo}
+|]
+    }
+  where
+    boolParser [] = Right Nothing
+    boolParser (x:_) = case x of
+      "" -> Right Nothing
+      "none" -> Right Nothing
+      "yes" -> Right $ Just True
+      "no" -> Right $ Just False
+      t -> Left $ MsgInvalidBool t
+    showVal = either (\_ -> False)
+
+multiSelectFieldHelper :: (Show a, Eq a, Monad monad)
+        => (Text -> Text -> GGWidget master monad () -> GGWidget master monad ())
+        -> (Text -> Text -> Text -> Bool -> Text -> GGWidget master monad ())
+        -> [(Text, a)] -> Field (GGWidget master monad ()) FormMessage [a]
+multiSelectFieldHelper outside inside opts = Field
+    { fieldParse = 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)
+    }
+  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
+
+selectFieldHelper :: (Eq a, Monad monad)
+        => (Text -> Text -> GGWidget master monad () -> GGWidget master monad ())
+        -> (Text -> Text -> Bool -> GGWidget master monad ())
+        -> (Text -> Text -> Text -> Bool -> Text -> GGWidget master monad ())
+        -> [(Text, a)] -> Field (GGWidget master monad ()) FormMessage a
+selectFieldHelper outside onOpt inside opts = Field
+    { fieldParse = selectParser
+    , fieldView = \theId name val isReq ->
+        outside theId name $ do
+            unless isReq $ onOpt theId name $ not $ (render val) `elem` map (pack . show . fst) pairs
+            flip mapM_ pairs $ \pair -> inside
+                theId
+                name
+                (pack $ show $ fst pair)
+                ((render val) == pack (show $ fst pair))
+                (fst $ snd pair)
+    }
+  where
+    pairs = zip [1 :: Int ..] opts -- FIXME use IntMap
+    rpairs = zip (map snd opts) [1 :: Int ..]
+    render (Left _) = ""
+    render (Right a) = maybe "" (pack . show) $ lookup a rpairs
+    selectParser [] = Right Nothing
+    selectParser (s:_) = case s of
+            "" -> Right Nothing
+            "none" -> Right Nothing
+            x -> case Data.Text.Read.decimal x of
+                    Right (a, "") ->
+                        case lookup a pairs of
+                            Nothing -> Left $ MsgInvalidEntry x
+                            Just y -> Right $ Just $ snd y
+                    _ -> Left $ MsgInvalidNumber x

yesod-form/Yesod/Form/Functions.hs

@@ -0,0 +1,234 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE FlexibleContexts #-}
+module Yesod.Form.Functions
+    ( -- * Running in Form monad
+      newFormIdent
+    , askParams
+    , askFiles
+      -- * Applicative/Monadic conversion
+    , formToAForm
+    , aFormToForm
+      -- * Fields to Forms
+    , mreq
+    , mopt
+    , areq
+    , aopt
+      -- * Run a form
+    , runFormPost
+    , runFormPostNoNonce
+    , runFormGet
+      -- * Rendering
+    , FormRender
+    , renderTable
+    , renderDivs
+    ) where
+
+import Yesod.Form.Types
+import Yesod.Form.Fields (FormMessage (MsgCsrfWarning, MsgValueRequired))
+import Data.Text (Text, pack)
+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)
+import Yesod.Widget (GGWidget, whamlet)
+import Yesod.Request (reqNonce, reqWaiRequest, reqGetParams, languages)
+import Network.Wai (requestMethod)
+import Text.Hamlet (html)
+import Data.Monoid (mempty)
+import Data.Maybe (listToMaybe)
+import Yesod.Message (RenderMessage (..))
+
+#if __GLASGOW_HASKELL__ >= 700
+#define WHAMLET whamlet
+#define HTML html
+#else
+#define HTML $html
+#define WHAMLET $whamlet
+#endif
+
+-- | Get a unique identifier.
+newFormIdent :: Monad m => Form msg m Text
+newFormIdent = do
+    i <- get
+    let i' = incrInts i
+    put i'
+    return $ pack $ 'f' : show i'
+  where
+    incrInts (IntSingle i) = IntSingle $ i + 1
+    incrInts (IntCons i is) = (i + 1) `IntCons` is
+
+formToAForm :: Monad m => Form msg m (FormResult a, xml) -> AForm ([xml] -> [xml]) msg m a
+formToAForm form = AForm $ \(master, langs) env ints -> do
+    ((a, xml), ints', enc) <- runRWST form (env, master, langs) ints
+    return (a, (:) xml, ints', enc)
+
+aFormToForm :: Monad m => AForm xml msg m a -> Form msg m (FormResult a, xml)
+aFormToForm (AForm aform) = do
+    ints <- get
+    (env, master, langs) <- ask
+    (a, xml, ints', enc) <- lift $ aform (master, langs) env ints
+    put ints'
+    tell enc
+    return (a, xml)
+
+askParams :: Monad m => Form msg m (Maybe Env)
+askParams = do
+    (x, _, _) <- ask
+    return $ liftM fst x
+
+askFiles :: Monad m => Form msg m (Maybe FileEnv)
+askFiles = do
+    (x, _, _) <- ask
+    return $ liftM snd x
+
+mreq :: (Monad m, RenderMessage master msg, RenderMessage master msg2, RenderMessage master FormMessage)
+     => Field xml msg a -> FieldSettings msg2 -> Maybe a
+     -> Form master (GGHandler sub master m) (FormResult a, FieldView xml)
+mreq field fs mdef = mhelper field fs mdef (\m l -> FormFailure [renderMessage m l MsgValueRequired]) FormSuccess True
+
+mopt :: (Monad m, RenderMessage master msg, RenderMessage master msg2)
+     => Field xml msg a -> FieldSettings msg2 -> Maybe (Maybe a)
+     -> Form master (GGHandler sub master m) (FormResult (Maybe a), FieldView xml)
+mopt field fs mdef = mhelper field fs (join mdef) (const $ const $ FormSuccess Nothing) (FormSuccess . Just) False
+
+mhelper :: (Monad m, RenderMessage master msg, RenderMessage master msg2)
+        => Field xml msg a
+        -> FieldSettings msg2
+        -> Maybe a
+        -> (master -> [Text] -> FormResult b) -- ^ on missing
+        -> (a -> FormResult b) -- ^ on success
+        -> Bool -- ^ is it required?
+        -> Form master (GGHandler sub master m) (FormResult b, FieldView xml)
+
+mhelper Field {..} FieldSettings {..} mdef onMissing onFound isReq = do
+    mp <- askParams
+    name <- maybe newFormIdent return fsName
+    theId <- lift $ maybe (liftM pack newIdent) return fsId
+    (_, master, langs) <- ask
+    let mr2 = renderMessage master langs
+    let (res, val) =
+            case mp of
+                Nothing -> (FormMissing, maybe (Left "") Right mdef)
+                Just p ->
+                    let mvals = map snd $ filter (\(n,_) -> n == name) p
+                     in case fieldParse mvals of
+                            Left e -> (FormFailure [renderMessage master langs e], maybe (Left "") Left (listToMaybe mvals))
+                            Right mx ->
+                                case mx of
+                                    Nothing -> (onMissing master langs, Left "")
+                                    Just x -> (onFound x, Right x)
+    return (res, FieldView
+        { fvLabel = toHtml $ mr2 fsLabel
+        , fvTooltip = fmap toHtml $ fmap mr2 fsTooltip
+        , fvId = theId
+        , fvInput = fieldView theId name val isReq
+        , fvErrors =
+            case res of
+                FormFailure [e] -> Just $ toHtml e
+                _ -> Nothing
+        , fvRequired = isReq
+        })
+
+areq :: (Monad m, RenderMessage master msg1, RenderMessage master msg2, RenderMessage master FormMessage)
+     => Field xml msg1 a -> FieldSettings msg2 -> Maybe a
+     -> AForm ([FieldView xml] -> [FieldView xml]) master (GGHandler sub master m) a
+areq a b = formToAForm . mreq a b
+
+aopt :: (Monad m, RenderMessage master msg1, RenderMessage master msg2)
+     => Field xml msg1 a -> FieldSettings msg2 -> Maybe (Maybe a)
+     -> AForm ([FieldView xml] -> [FieldView xml]) master (GGHandler sub master m) (Maybe a)
+aopt a b = formToAForm . mopt a b
+
+runFormGeneric :: Monad m => Form master m a -> master -> [Text] -> Maybe (Env, FileEnv) -> m (a, Enctype)
+runFormGeneric form master langs env = evalRWST form (env, master, langs) (IntSingle 1)
+
+runFormPost :: RenderMessage master FormMessage
+            => (Html -> Form master (GHandler sub master) (FormResult a, xml)) -> GHandler sub master ((FormResult a, xml), Enctype)
+runFormPost form = do
+    req <- getRequest
+    let nonceKey = "_nonce"
+    let nonce =
+            case reqNonce req of
+                Nothing -> mempty
+                Just n -> [HTML|<input type=hidden name=#{nonceKey} value=#{n}>|]
+    env <- if requestMethod (reqWaiRequest req) == "GET"
+                then return Nothing
+                else fmap Just runRequestBody
+    m <- getYesod
+    langs <- languages
+    ((res, xml), enctype) <- runFormGeneric (form nonce) m langs env
+    let res' =
+            case (res, env) of
+                (FormSuccess{}, Just (params, _))
+                    | lookup nonceKey params /= reqNonce req ->
+                        FormFailure [renderMessage m langs MsgCsrfWarning]
+                _ -> res
+    return ((res', xml), enctype)
+
+runFormPostNoNonce :: (Html -> Form master (GHandler sub master) (FormResult a, xml)) -> GHandler sub master ((FormResult a, xml), Enctype)
+runFormPostNoNonce form = do
+    req <- getRequest
+    env <- if requestMethod (reqWaiRequest req) == "GET"
+                then return Nothing
+                else fmap Just runRequestBody
+    langs <- languages
+    m <- getYesod
+    runFormGeneric (form mempty) m langs env
+
+runFormGet :: Monad m => (Html -> Form master (GGHandler sub master m) a) -> GGHandler sub master m (a, Enctype)
+runFormGet form = do
+    let key = "_hasdata"
+    let fragment = [HTML|<input type=hidden name=#{key}>|]
+    gets <- liftM reqGetParams getRequest
+    let env =
+            case lookup key gets of
+                Nothing -> Nothing
+                Just _ -> Just (gets, [])
+    langs <- languages
+    m <- getYesod
+    runFormGeneric (form fragment) m langs env
+
+type FormRender master msg m a =
+       AForm ([FieldView (GGWidget master m ())] -> [FieldView (GGWidget master m ())]) msg m a
+    -> Html
+    -> Form msg m (FormResult a, GGWidget master m ())
+
+renderTable, renderDivs :: Monad m => FormRender master msg m a
+renderTable aform fragment = do
+    (res, views') <- aFormToForm aform
+    let views = views' []
+    -- FIXME non-valid HTML
+    let widget = [WHAMLET|
+\#{fragment}
+$forall view <- views
+    <tr :fvRequired view:.required :not $ fvRequired view:.optional>
+        <td>
+            <label for=#{fvId view}>#{fvLabel view}
+            $maybe tt <- fvTooltip view
+                <div .tooltip>#{tt}
+        <td>^{fvInput view}
+        $maybe err <- fvErrors view
+            <td .errors>#{err}
+|]
+    return (res, widget)
+
+renderDivs aform fragment = do
+    (res, views') <- aFormToForm aform
+    let views = views' []
+    let widget = [WHAMLET|
+\#{fragment}
+$forall view <- views
+    <div :fvRequired view:.required :not $ fvRequired view:.optional>
+        <label for=#{fvId view}>#{fvLabel view}
+        $maybe tt <- fvTooltip view
+            <div .tooltip>#{tt}
+        ^{fvInput view}
+        $maybe err <- fvErrors view
+            <div .errors>#{err}
+|]
+    return (res, widget)

yesod-form/Yesod/Form/Input.hs

@@ -0,0 +1,65 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleContexts #-}
+module Yesod.Form.Input
+    ( FormInput (..)
+    , runInputGet
+    , runInputPost
+    , ireq
+    , iopt
+    ) where
+
+import Yesod.Form.Types
+import Yesod.Form.Fields (FormMessage (MsgInputNotFound))
+import Data.Text (Text)
+import Control.Applicative (Applicative (..))
+import Yesod.Handler (GHandler, GGHandler, invalidArgs, runRequestBody, getRequest, getYesod)
+import Yesod.Request (reqGetParams, languages)
+import Control.Monad (liftM)
+import Yesod.Widget (GWidget)
+import Yesod.Message (RenderMessage (..))
+
+type DText = [Text] -> [Text]
+newtype FormInput master a = FormInput { unFormInput :: master -> [Text] -> Env -> Either DText a }
+instance Functor (FormInput master) where
+    fmap a (FormInput f) = FormInput $ \c d e -> either Left (Right . a) $ f c d e
+instance Applicative (FormInput master) where
+    pure = FormInput . const . const . const . Right
+    (FormInput f) <*> (FormInput x) = FormInput $ \c d e ->
+        case (f c d e, x c d e) of
+            (Left a, Left b) -> Left $ a . b
+            (Left a, _) -> Left a
+            (_, Left b) -> Left b
+            (Right a, Right b) -> Right $ a b
+
+ireq :: (RenderMessage master msg, RenderMessage master FormMessage) => Field (GWidget sub master ()) msg a -> Text -> FormInput master a
+ireq field name = FormInput $ \m l env ->
+      let filteredEnv = map snd $ filter (\y -> fst y == name) env
+      in case fieldParse field $ filteredEnv of
+          Left e -> Left $ (:) $ renderMessage m l e
+          Right Nothing -> Left $ (:) $ renderMessage m l $ MsgInputNotFound name
+          Right (Just a) -> Right a
+
+iopt :: RenderMessage master msg => Field (GWidget sub master ()) msg a -> Text -> FormInput master (Maybe a)
+iopt field name = FormInput $ \m l env ->
+      let filteredEnv = map snd $ filter (\y -> fst y == name) env
+      in case fieldParse field $ filteredEnv of
+        Left e -> Left $ (:) $ renderMessage m l e
+        Right x -> Right x
+
+runInputGet :: Monad monad => FormInput master a -> GGHandler sub master monad a
+runInputGet (FormInput f) = do
+    env <- liftM reqGetParams getRequest
+    m <- getYesod
+    l <- languages
+    case f m l env of
+        Left errs -> invalidArgs $ errs []
+        Right x -> return x
+
+runInputPost :: FormInput master a -> GHandler sub master a
+runInputPost (FormInput f) = do
+    env <- liftM fst runRequestBody
+    m <- getYesod
+    l <- languages
+    case f m l env of
+        Left errs -> invalidArgs $ errs []
+        Right x -> return x

yesod-form/Yesod/Form/Jquery.hs

@@ -0,0 +1,205 @@
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoMonomorphismRestriction #-} -- FIXME remove
+-- | Some fields spiced up with jQuery UI.
+module Yesod.Form.Jquery
+    ( YesodJquery (..)
+    , jqueryDayField
+    , jqueryDayTimeField
+    , jqueryAutocompleteField
+    , googleHostedJqueryUiCss
+    , JqueryDaySettings (..)
+    , Default (..)
+    ) where
+
+import Yesod.Handler
+import Yesod.Form
+import Yesod.Widget
+import Data.Time (UTCTime (..), Day, TimeOfDay (..), timeOfDayToTime,
+                  timeToTimeOfDay)
+import Data.Char (isSpace)
+import Data.Default
+import Text.Hamlet (html)
+import Text.Julius (julius)
+import Control.Monad.Trans.Class (lift)
+import Data.Text (Text, pack, unpack)
+import Data.Monoid (mconcat)
+
+#if __GLASGOW_HASKELL__ >= 700
+#define HTML html
+#define HAMLET hamlet
+#define CASSIUS cassius
+#define JULIUS julius
+#else
+#define HTML $html
+#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
+    [ "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8/themes/"
+    , theme
+    , "/jquery-ui.css"
+    ]
+
+class YesodJquery a where
+    -- | The jQuery 1.4 Javascript file.
+    urlJqueryJs :: a -> Either (Route a) Text
+    urlJqueryJs _ = Right "http://ajax.googleapis.com/ajax/libs/jquery/1.4/jquery.min.js"
+
+    -- | The jQuery UI 1.8 Javascript file.
+    urlJqueryUiJs :: a -> Either (Route a) Text
+    urlJqueryUiJs _ = Right "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8/jquery-ui.min.js"
+
+    -- | The jQuery UI 1.8 CSS file; defaults to cupertino theme.
+    urlJqueryUiCss :: a -> Either (Route a) Text
+    urlJqueryUiCss _ = Right $ googleHostedJqueryUiCss "cupertino"
+
+    -- | jQuery UI time picker add-on.
+    urlJqueryUiDateTimePicker :: a -> Either (Route a) Text
+    urlJqueryUiDateTimePicker _ = Right "http://github.com/gregwebs/jquery.ui.datetimepicker/raw/master/jquery.ui.datetimepicker.js"
+
+blank :: (Text -> Either msg a) -> [Text] -> Either msg (Maybe a)
+blank _ [] = Right Nothing
+blank _ ("":_) = Right Nothing
+blank f (x:_) = either Left (Right . Just) $ f x
+
+jqueryDayField :: (YesodJquery master) => JqueryDaySettings -> Field (GWidget sub master ()) FormMessage Day
+jqueryDayField jds = Field
+    { fieldParse = blank $ maybe
+                  (Left MsgInvalidDay)
+                  Right
+              . readMay
+              . unpack
+    , fieldView = \theId name val isReq -> do
+        addHtml [HTML|\
+<input id="#{theId}" name="#{name}" 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}"
+})});
+|]
+    }
+  where
+    showVal = either id (pack . show)
+    jsBool True = "true" :: Text
+    jsBool False = "false" :: Text
+    mos (Left i) = show i
+    mos (Right (x, y)) = concat
+        [ "["
+        , show x
+        , ","
+        , show y
+        , "]"
+        ]
+
+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 :: YesodJquery master => Field (GWidget sub master ()) FormMessage 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 :: YesodJquery master => Route master -> Field (GWidget sub master ()) FormMessage Text
+jqueryAutocompleteField src = Field
+    { fieldParse = blank $ Right
+    , fieldView = \theId name val isReq -> do
+        addHtml [HTML|\
+<input id="#{theId}" name="#{name}" type="text" :isReq:required="" value="#{either id id val}" .autocomplete>
+|]
+        addScript' urlJqueryJs
+        addScript' urlJqueryUiJs
+        addStylesheet' urlJqueryUiCss
+        addJulius [JULIUS|
+$(function(){$("##{theId}").autocomplete({source:"@{src}",minLength:2})});
+|]
+    }
+
+addScript' :: Monad m => (t -> Either (Route master) Text) -> GGWidget master (GGHandler sub t m) ()
+addScript' f = do
+    y <- lift getYesod
+    addScriptEither $ f y
+
+addStylesheet' :: (y -> Either (Route y) Text) -> GWidget sub y ()
+addStylesheet' f = do
+    y <- lift getYesod
+    addStylesheetEither $ f y
+
+readMay :: Read a => String -> Maybe a
+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
+    , jdsChangeYear :: Bool
+    , jdsYearRange :: String
+    , jdsNumberOfMonths :: Either Int (Int, Int)
+    }
+
+instance Default JqueryDaySettings where
+    def = JqueryDaySettings
+        { jdsChangeMonth = False
+        , jdsChangeYear = False
+        , jdsYearRange = "c-10:c+10"
+        , jdsNumberOfMonths = Left 1
+        }

yesod-form/Yesod/Form/MassInput.hs

@@ -0,0 +1,155 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+module Yesod.Form.MassInput
+    ( inputList
+    , massDivs
+    , massTable
+    ) where
+
+import Yesod.Form.Types
+import Yesod.Form.Functions
+import Yesod.Form.Fields (boolField, FormMessage)
+import Yesod.Widget (GGWidget, whamlet)
+import Yesod.Message (RenderMessage)
+import Yesod.Handler (newIdent, GGHandler)
+import Text.Blaze (Html)
+import Control.Monad.Trans.Class (lift)
+import Data.Text (pack, Text)
+import Control.Monad.Trans.RWS (get, put, ask)
+import Data.Maybe (fromMaybe, catMaybes)
+import Data.Text.Read (decimal)
+import Control.Monad (liftM)
+import Data.Either (partitionEithers)
+import Data.Traversable (sequenceA)
+
+#if __GLASGOW_HASKELL__ >= 700
+#define WHAMLET whamlet
+#define HTML html
+#else
+#define HTML $html
+#define WHAMLET $whamlet
+#endif
+
+down 0 = return ()
+down i | i < 0 = error "called down with a negative number"
+down i = do
+    is <- get
+    put $ IntCons 0 is
+    down $ i - 1
+
+up 0 = return ()
+up i | i < 0 = error "called down with a negative number"
+up i = do
+    is <- get
+    case is of
+        IntSingle _ -> error "up on IntSingle"
+        IntCons _ is' -> put is' >> newFormIdent >> return ()
+    up $ i - 1
+
+inputList :: (Monad mo, m ~ GGHandler sub master mo, xml ~ GGWidget master (GGHandler sub master mo) (), RenderMessage master FormMessage)
+          => Html
+          -> ([[FieldView xml]] -> xml)
+          -> (Maybe a -> AForm ([FieldView xml] -> [FieldView xml]) master m a)
+          -> (Maybe [a] -> AForm ([FieldView xml] -> [FieldView xml]) master m [a])
+inputList label fixXml single mdef = formToAForm $ do
+    theId <- lift newIdent
+    down 1
+    countName <- newFormIdent
+    addName <- newFormIdent
+    (menv, _, _) <- ask
+    let readInt t =
+            case decimal t of
+                Right (i, "") -> Just i
+                _ -> Nothing
+    let vals =
+            case menv of
+                Nothing -> map Just $ fromMaybe [] mdef
+                Just (env, _) ->
+                    let toAdd = maybe False (const True) $ lookup addName env
+                        count' = fromMaybe 0 $ lookup countName env >>= readInt
+                        count = (if toAdd then 1 else 0) + count'
+                     in replicate count Nothing
+    let count = length vals
+    (res, xmls, views) <- liftM fixme $ mapM (withDelete . single) vals
+    up 1
+    return (res, FieldView
+        { fvLabel = label
+        , fvTooltip = Nothing
+        , fvId = pack theId
+        , fvInput = [WHAMLET|
+^{fixXml views}
+<p>
+    $forall xml <- xmls
+        ^{xml}
+    <input .count type=hidden name=#{countName} value=#{count}>
+    <input type=checkbox name=#{addName}>
+    Add another row
+|]
+        , fvErrors = Nothing
+        , fvRequired = False
+        })
+
+withDelete :: (xml ~ GGWidget master m (), m ~ GGHandler sub master mo, Monad mo, RenderMessage master FormMessage)
+           => AForm ([FieldView xml] -> [FieldView xml]) master m a
+           -> Form master m (Either xml (FormResult a, [FieldView xml]))
+withDelete af = do
+    down 1
+    deleteName <- newFormIdent
+    (menv, _, _) <- ask
+    res <- case menv >>= lookup deleteName . fst of
+        Just "yes" -> return $ Left [WHAMLET|<input type=hidden name=#{deleteName} value=yes>|]
+        _ -> do
+            (_, xml2) <- aFormToForm $ areq boolField FieldSettings
+                { fsLabel = "Delete?" :: Text -- FIXME
+                , fsTooltip = Nothing
+                , fsName = Just deleteName
+                , fsId = Nothing
+                } $ Just False -- TRANS
+            (res, xml) <- aFormToForm af
+            return $ Right (res, xml [] ++ xml2 []) -- FIXME shouldn't need ++
+    up 1
+    return res
+
+fixme :: (xml ~ GGWidget master (GGHandler sub master mo) ())
+      => [Either xml (FormResult a, [FieldView xml])]
+      -> (FormResult [a], [xml], [[FieldView xml]])
+fixme eithers =
+    (res, xmls, map snd rest)
+  where
+    (xmls, rest) = partitionEithers eithers
+    res = sequenceA $ map fst rest
+
+massDivs, massTable
+         :: Monad m
+         => [[FieldView (GGWidget master m ())]]
+         -> GGWidget master m ()
+massDivs viewss = [WHAMLET|
+$forall views <- viewss
+    <fieldset>
+        $forall view <- views
+            <div :fvRequired view:.required :not $ fvRequired view:.optional>
+                <label for=#{fvId view}>#{fvLabel view}
+                $maybe tt <- fvTooltip view
+                    <div .tooltip>#{tt}
+                ^{fvInput view}
+                $maybe err <- fvErrors view
+                    <div .errors>#{err}
+|]
+
+massTable viewss = [WHAMLET|
+$forall views <- viewss
+    <fieldset>
+        <table>
+            $forall view <- views
+                <tr :fvRequired view:.required :not $ fvRequired view:.optional>
+                    <td>
+                        <label for=#{fvId view}>#{fvLabel view}
+                        $maybe tt <- fvTooltip view
+                            <div .tooltip>#{tt}
+                    <td>^{fvInput view}
+                    $maybe err <- fvErrors view
+                        <td .errors>#{err}
+|]

yesod-form/Yesod/Form/Nic.hs

@@ -0,0 +1,64 @@
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoMonomorphismRestriction #-} -- FIXME remove
+-- | Provide the user with a rich text editor.
+module Yesod.Form.Nic
+    ( YesodNic (..)
+    , nicHtmlField
+    ) where
+
+import Yesod.Handler
+import Yesod.Form
+import Yesod.Widget
+import Text.HTML.SanitizeXSS (sanitizeBalance)
+import Text.Hamlet (Html, html)
+import Text.Julius (julius)
+import Text.Blaze.Renderer.String (renderHtml)
+import Text.Blaze (preEscapedString)
+import Control.Monad.Trans.Class (lift)
+import Data.Text (Text, pack, unpack)
+
+class YesodNic a where
+    -- | NIC Editor Javascript file.
+    urlNicEdit :: a -> Either (Route a) Text
+    urlNicEdit _ = Right "http://js.nicedit.com/nicEdit-latest.js"
+
+blank :: (Text -> Either msg a) -> [Text] -> Either msg (Maybe a)
+blank _ [] = Right Nothing
+blank _ ("":_) = Right Nothing
+blank f (x:_) = either Left (Right . Just) $ f x
+
+
+
+nicHtmlField :: YesodNic master => Field (GWidget sub master ()) msg Html
+nicHtmlField = Field
+    { fieldParse = blank $ Right . preEscapedString . sanitizeBalance . unpack -- FIXME
+    , fieldView = \theId name val _isReq -> do
+        addHtml
+#if __GLASGOW_HASKELL__ >= 700
+                [html|
+#else
+                [$html|
+#endif
+    <textarea id="#{theId}" name="#{name}" .html>#{showVal val}
+|]
+        addScript' urlNicEdit
+        addJulius
+#if __GLASGOW_HASKELL__ >= 700
+                [julius|
+#else
+                [$julius|
+#endif
+bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("#{theId}")});
+|]
+    }
+  where
+    showVal = either id (pack . renderHtml)
+
+addScript' :: (y -> Either (Route y) Text) -> GWidget sub y ()
+addScript' f = do
+    y <- lift getYesod
+    addScriptEither $ f y

yesod-form/Yesod/Form/Types.hs

@@ -0,0 +1,123 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies #-}
+module Yesod.Form.Types
+    ( -- * Helpers
+      Enctype (..)
+    , FormResult (..)
+    , Env
+    , FileEnv
+    , Ints (..)
+      -- * Form
+    , Form
+    , AForm (..)
+      -- * Build forms
+    , Field (..)
+    , FieldSettings (..)
+    , FieldView (..)
+    ) where
+
+import Control.Monad.Trans.RWS (RWST)
+import Yesod.Request (FileInfo)
+import Data.Text (Text)
+import Data.Monoid (Monoid (..))
+import Text.Blaze (Html, ToHtml (toHtml))
+import Control.Applicative ((<$>), Applicative (..))
+import Control.Monad (liftM)
+import Data.String (IsString (..))
+import Control.Monad.Trans.Class (MonadTrans (..))
+
+-- | A form can produce three different results: there was no data available,
+-- the data was invalid, or there was a successful parse.
+--
+-- The 'Applicative' instance will concatenate the failure messages in two
+-- 'FormResult's.
+data FormResult a = FormMissing
+                  | FormFailure [Text]
+                  | FormSuccess a
+    deriving Show
+instance Functor FormResult where
+    fmap _ FormMissing = FormMissing
+    fmap _ (FormFailure errs) = FormFailure errs
+    fmap f (FormSuccess a) = FormSuccess $ f a
+instance Applicative FormResult where
+    pure = FormSuccess
+    (FormSuccess f) <*> (FormSuccess g) = FormSuccess $ f g
+    (FormFailure x) <*> (FormFailure y) = FormFailure $ x ++ y
+    (FormFailure x) <*> _ = FormFailure x
+    _ <*> (FormFailure y) = FormFailure y
+    _ <*> _ = FormMissing
+instance Monoid m => Monoid (FormResult m) where
+    mempty = pure mempty
+    mappend x y = mappend <$> x <*> y
+
+-- | The encoding type required by a form. The 'ToHtml' instance produces values
+-- that can be inserted directly into HTML.
+data Enctype = UrlEncoded | Multipart
+    deriving (Eq, Enum, Bounded)
+instance ToHtml Enctype where
+    toHtml UrlEncoded = "application/x-www-form-urlencoded"
+    toHtml Multipart = "multipart/form-data"
+instance Monoid Enctype where
+    mempty = UrlEncoded
+    mappend UrlEncoded UrlEncoded = UrlEncoded
+    mappend _ _ = Multipart
+
+data Ints = IntCons Int Ints | IntSingle Int
+instance Show Ints where
+    show (IntSingle i) = show i
+    show (IntCons i is) = show i ++ ('-' : show is)
+
+type Env = [(Text, Text)] -- FIXME use a Map
+type FileEnv = [(Text, FileInfo)]
+
+type Form master m a = RWST (Maybe (Env, FileEnv), master, [Text]) Enctype Ints m a
+
+newtype AForm xml master m a = AForm
+    { unAForm :: (master, [Text]) -> Maybe (Env, FileEnv) -> Ints -> m (FormResult a, xml, Ints, Enctype)
+    }
+instance Monad m => Functor (AForm xml msg m) where
+    fmap f (AForm a) =
+        AForm $ \x y z -> liftM go $ a x y z
+      where
+        go (w, x, y, z) = (fmap f w, x, y, z)
+instance (Monad m, Monoid xml) => Applicative (AForm xml msg m) where
+    pure x = AForm $ const $ const $ \ints -> return (FormSuccess x, mempty, ints, mempty)
+    (AForm f) <*> (AForm g) = AForm $ \mr env ints -> do
+        (a, b, ints', c) <- f mr env ints
+        (x, y, ints'', z) <- g mr env ints'
+        return (a <*> x, b `mappend` y, ints'', c `mappend` z)
+instance (Monad m, Monoid xml, Monoid a) => Monoid (AForm xml msg m a) where
+    mempty = pure mempty
+    mappend a b = mappend <$> a <*> b
+instance Monoid xml => MonadTrans (AForm xml msg) where
+    lift mx = AForm $ const $ const $ \ints -> do
+        x <- mx
+        return (pure x, mempty, ints, mempty)
+
+data FieldSettings msg = FieldSettings
+    { fsLabel :: msg
+    , fsTooltip :: Maybe msg
+    , fsId :: Maybe Text
+    , fsName :: Maybe Text
+    }
+
+instance (a ~ Text) => IsString (FieldSettings a) where
+    fromString s = FieldSettings (fromString s) Nothing Nothing Nothing
+
+data FieldView xml = FieldView
+    { fvLabel :: Html
+    , fvTooltip :: Maybe Html
+    , fvId :: Text
+    , fvInput :: xml
+    , fvErrors :: Maybe Html
+    , fvRequired :: Bool
+    }
+
+data Field xml msg a = Field
+    { fieldParse :: [Text] -> Either msg (Maybe a)
+    , fieldView :: Text -- ^ ID
+                -> Text -- ^ name
+                -> Either Text a -- ^ value could be invalid text or a legitimate a
+                -> Bool -- ^ required?
+                -> xml
+    }

yesod-form/Yesod/Helpers/Crud.hs

@@ -0,0 +1,203 @@
+{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE CPP #-}
+module Yesod.Helpers.Crud
+    ( Item (..)
+    , Crud (..)
+    , CrudRoute (..)
+    , defaultCrud
+    ) where
+
+import Yesod.Core
+import Text.Hamlet
+import Yesod.Form
+import Language.Haskell.TH.Syntax
+import Yesod.Persist
+import Data.Text (Text)
+import Web.Routes.Quasi (toSinglePiece, fromSinglePiece)
+
+-- | An entity which can be displayed by the Crud subsite.
+class Item a where
+    -- | The title of an entity, to be displayed in the list of all entities.
+    itemTitle :: a -> Text
+
+-- | Defines all of the CRUD operations (Create, Read, Update, Delete)
+-- necessary to implement this subsite. When using the "Yesod.Form" module and
+-- 'ToForm' typeclass, you can probably just use 'defaultCrud'.
+data Crud master item = Crud
+    { crudSelect :: GHandler (Crud master item) master [(Key item, item)]
+    , crudReplace :: Key item -> item -> GHandler (Crud master item) master ()
+    , crudInsert :: item -> GHandler (Crud master item) master (Key item)
+    , crudGet :: Key item -> GHandler (Crud master item) master (Maybe item)
+    , crudDelete :: Key item -> GHandler (Crud master item) master ()
+    }
+
+mkYesodSub "Crud master item"
+    [ ClassP ''Item [VarT $ mkName "item"]
+    , ClassP ''SinglePiece [ConT ''Key `AppT` VarT (mkName "item")]
+    , ClassP ''ToForm [VarT $ mkName "item", VarT $ mkName "master"]
+    ]
+#if __GLASGOW_HASKELL__ >= 700
+                [parseRoutes|
+#else
+                [$parseRoutes|
+#endif
+/               CrudListR        GET
+/add            CrudAddR         GET POST
+/edit/#Text     CrudEditR        GET POST
+/delete/#Text   CrudDeleteR      GET POST
+|]
+
+getCrudListR :: (Yesod master, Item item, SinglePiece (Key item))
+             => GHandler (Crud master item) master RepHtml
+getCrudListR = do
+    items <- getYesodSub >>= crudSelect
+    toMaster <- getRouteToMaster
+    defaultLayout $ do
+        setTitle "Items"
+        addWidget
+#if __GLASGOW_HASKELL__ >= 700
+                [hamlet|
+#else
+                [$hamlet|
+#endif
+<h1>Items
+<ul>
+    $forall item <- items
+        <li>
+            <a href="@{toMaster (CrudEditR (toSinglePiece (fst item)))}">
+                \#{itemTitle (snd item)}
+<p>
+    <a href="@{toMaster CrudAddR}">Add new item
+|]
+
+getCrudAddR :: (Yesod master, Item item, SinglePiece (Key item),
+                ToForm item master)
+            => GHandler (Crud master item) master RepHtml
+getCrudAddR = crudHelper
+                "Add new"
+                (Nothing :: Maybe (Key item, item))
+                False
+
+postCrudAddR :: (Yesod master, Item item, SinglePiece (Key item),
+                 ToForm item master)
+             => GHandler (Crud master item) master RepHtml
+postCrudAddR = crudHelper
+                "Add new"
+                (Nothing :: Maybe (Key item, item))
+                True
+
+getCrudEditR :: (Yesod master, Item item, SinglePiece (Key item),
+                 ToForm item master)
+             => Text -> GHandler (Crud master item) master RepHtml
+getCrudEditR s = do
+    itemId <- maybe notFound return $ fromSinglePiece s
+    crud <- getYesodSub
+    item <- crudGet crud itemId >>= maybe notFound return
+    crudHelper
+        "Edit item"
+        (Just (itemId, item))
+        False
+
+postCrudEditR :: (Yesod master, Item item, SinglePiece (Key item),
+                  ToForm item master)
+              => Text -> GHandler (Crud master item) master RepHtml
+postCrudEditR s = do
+    itemId <- maybe notFound return $ fromSinglePiece s
+    crud <- getYesodSub
+    item <- crudGet crud itemId >>= maybe notFound return
+    crudHelper
+        "Edit item"
+        (Just (itemId, item))
+        True
+
+getCrudDeleteR :: (Yesod master, Item item, SinglePiece (Key item))
+               => Text -> GHandler (Crud master item) master RepHtml
+getCrudDeleteR s = do
+    itemId <- maybe notFound return $ fromSinglePiece s
+    crud <- getYesodSub
+    item <- crudGet crud itemId >>= maybe notFound return -- Just ensure it exists
+    toMaster <- getRouteToMaster
+    defaultLayout $ do
+        setTitle "Confirm delete"
+        addWidget
+#if __GLASGOW_HASKELL__ >= 700
+                [hamlet|
+#else
+                [$hamlet|
+#endif
+<form method="post" action="@{toMaster (CrudDeleteR s)}">
+    <h1>Really delete?
+    <p>Do you really want to delete #{itemTitle item}?
+    <p>
+        <input type="submit" value="Yes">
+        \
+        <a href="@{toMaster CrudListR}">No
+|]
+
+postCrudDeleteR :: (Yesod master, Item item, SinglePiece (Key item))
+                => Text -> GHandler (Crud master item) master RepHtml
+postCrudDeleteR s = do
+    itemId <- maybe notFound return $ fromSinglePiece s
+    crud <- getYesodSub
+    toMaster <- getRouteToMaster
+    crudDelete crud itemId
+    redirect RedirectTemporary $ toMaster CrudListR
+
+crudHelper
+    :: (Item a, Yesod master, SinglePiece (Key a), ToForm a master)
+    => Text -> Maybe (Key a, a) -> Bool
+    -> GHandler (Crud master a) master RepHtml
+crudHelper title me isPost = do
+    crud <- getYesodSub
+    (errs, form, enctype, hidden) <- runFormPost $ toForm $ fmap snd me
+    toMaster <- getRouteToMaster
+    case (isPost, errs) of
+        (True, FormSuccess a) -> do
+            eid <- case me of
+                    Just (eid, _) -> do
+                        crudReplace crud eid a
+                        return eid
+                    Nothing -> crudInsert crud a
+            redirect RedirectTemporary $ toMaster $ CrudEditR
+                                       $ toSinglePiece eid
+        _ -> return ()
+    defaultLayout $ do
+        setTitle $ toHtml title
+        addWidget
+#if __GLASGOW_HASKELL__ >= 700
+                [hamlet|
+#else
+                [$hamlet|
+#endif
+<p>
+    <a href="@{toMaster CrudListR}">Return to list
+<h1>#{title}
+<form method="post" enctype="#{enctype}">
+    <table>
+        \^{form}
+        <tr>
+            <td colspan="2">
+                \#{hidden}
+                <input type="submit">
+                $maybe e <- me
+                    \
+                    <a href="@{toMaster (CrudDeleteR (toSinglePiece (fst e)))}">Delete
+|]
+
+-- | A default 'Crud' value which relies about persistent and "Yesod.Form".
+defaultCrud
+    :: (PersistEntity i, PersistBackend (YesodDB a (GGHandler (Crud a i) a IO)),
+        YesodPersist a)
+    => a -> Crud a i
+defaultCrud = const Crud
+    { crudSelect = runDB $ selectList [] [] 0 0
+    , crudReplace = \a -> runDB . replace a
+    , crudInsert = runDB . insert
+    , crudGet = runDB . get
+    , crudDelete = runDB . delete
+    }

yesod-form/hello-forms.hs

@@ -0,0 +1,74 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}
+import Yesod.Core
+import Yesod.Form
+import Yesod.Form.MassInput
+import Control.Applicative
+import Data.Text (Text, pack)
+import Network.Wai.Handler.Warp (run)
+
+data Fruit = Apple | Banana | Pear
+    deriving (Show, Enum, Bounded, Eq)
+
+fruits :: [(Text, Fruit)]
+fruits = map (\x -> (pack $ show x, x)) [minBound..maxBound]
+
+myForm = fixType $ runFormGet $ renderDivs $ pure (,,,,,,,,)
+    <*> areq boolField "Bool field" Nothing
+    <*> aopt boolField "Opt bool field" Nothing
+    <*> areq textField "Text field" Nothing
+    <*> areq (selectField fruits) "Select field" Nothing
+    <*> aopt (selectField fruits) "Opt select field" Nothing
+    <*> areq (multiSelectField fruits) "Multi select field" Nothing
+    <*> aopt (multiSelectField fruits) "Opt multi select field" Nothing
+    <*> aopt intField "Opt int field" Nothing
+    <*> aopt (radioField fruits) "Opt radio" Nothing
+
+data HelloForms = HelloForms
+type Handler = GHandler HelloForms HelloForms
+
+fixType :: Handler a -> Handler a
+fixType = id
+
+instance RenderMessage HelloForms FormMessage where
+    renderMessage _ _ = defaultFormMessage
+
+instance Yesod HelloForms where
+    approot _ = ""
+
+mkYesod "HelloForms" [parseRoutes|
+/ RootR GET
+/mass MassR GET
+|]
+
+getRootR = do
+    ((res, form), enctype) <- myForm
+    defaultLayout [whamlet|
+<p>Result: #{show res}
+<form enctype=#{enctype}>
+    ^{form}
+    <div>
+        <input type=submit>
+<p>
+    <a href=@{MassR}>See the mass form
+|]
+
+myMassForm = fixType $ runFormGet $ renderTable $ inputList "People" massTable
+    (\x -> (,)
+        <$> areq textField "Name" (fmap fst x)
+        <*> areq intField "Age" (fmap snd x)) (Just [("Michael", 26)])
+
+getMassR = do
+    ((res, form), enctype) <- myMassForm
+    defaultLayout [whamlet|
+<p>Result: #{show res}
+<form enctype=#{enctype}>
+    <table>
+        ^{form}
+    <div>
+        <input type=submit>
+<p>
+    <a href=@{RootR}>See the regular form
+|]
+
+main = toWaiApp HelloForms >>= run 3000

yesod-form/yesod-form.cabal

@@ -0,0 +1,46 @@
+name:            yesod-form
+version:         0.3.0
+license:         BSD3
+license-file:    LICENSE
+author:          Michael Snoyman <michael@snoyman.com>
+maintainer:      Michael Snoyman <michael@snoyman.com>
+synopsis:        Form handling support for Yesod Web Framework
+category:        Web, Yesod
+stability:       Stable
+cabal-version:   >= 1.6
+build-type:      Simple
+homepage:        http://www.yesodweb.com/
+
+library
+    build-depends:   base                      >= 4        && < 5
+                   , yesod-core                >= 0.9      && < 0.10
+                   , time                      >= 1.1.4    && < 1.3
+                   , hamlet                    >= 0.9      && < 0.10
+                   , persistent                >= 0.6      && < 0.7
+                   , yesod-persistent          >= 0.2      && < 0.3
+                   , template-haskell
+                   , transformers              >= 0.2.2    && < 0.3
+                   , data-default              >= 0.2      && < 0.3
+                   , xss-sanitize              >= 0.2.4    && < 0.3
+                   , blaze-builder             >= 0.2.1    && < 0.4
+                   , network                   >= 2.2      && < 2.4
+                   , email-validate            >= 0.2.6    && < 0.3
+                   , blaze-html                >= 0.4      && < 0.5
+                   , bytestring                >= 0.9      && < 0.10
+                   , text                      >= 0.7      && < 1.0
+                   , web-routes-quasi          >= 0.7      && < 0.8
+                   , wai                       >= 0.4      && < 0.5
+    exposed-modules: Yesod.Form
+                     Yesod.Form.Class
+                     Yesod.Form.Types
+                     Yesod.Form.Functions
+                     Yesod.Form.Input
+                     Yesod.Form.Fields
+                     Yesod.Form.Jquery
+                     Yesod.Form.Nic
+                     -- FIXME Yesod.Helpers.Crud
+    ghc-options:     -Wall
+
+source-repository head
+  type:     git
+  location: git://github.com/snoyberg/yesod-form.git