packages feed

yesod-form 0.1.0 → 0.1.0.1

raw patch · 11 files changed

+2103/−2101 lines, 11 filesdep +web-routes-quasisetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: web-routes-quasi

API changes (from Hackage documentation)

Files

LICENSE view
@@ -1,25 +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.+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.
Setup.lhs view
@@ -1,7 +1,7 @@-#!/usr/bin/env runhaskell--> module Main where-> import Distribution.Simple--> main :: IO ()-> main = defaultMain+#!/usr/bin/env runhaskell
+
+> module Main where
+> import Distribution.Simple
+
+> main :: IO ()
+> main = defaultMain
Yesod/Form.hs view
@@ -1,313 +1,313 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE PackageImports #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}--- | Parse forms (and query strings).-module Yesod.Form-    ( -- * Data types-      GForm-    , FormResult (..)-    , Enctype (..)-    , FormFieldSettings (..)-    , Textarea (..)-    , FieldInfo (..)-      -- ** Utilities-    , formFailures-      -- * Type synonyms-    , Form-    , Formlet-    , FormField-    , FormletField-    , FormInput-      -- * Unwrapping functions-    , generateForm-    , runFormGet-    , runFormMonadGet-    , runFormPost-    , runFormPostNoNonce-    , runFormMonadPost-    , runFormGet'-    , runFormPost'-      -- ** High-level form post unwrappers-    , runFormTable-    , runFormDivs-      -- * Field/form helpers-    , fieldsToTable-    , fieldsToDivs-    , fieldsToPlain-    , checkForm-      -- * Type classes-    , module Yesod.Form.Class-      -- * Template Haskell-    , mkToForm-    , module Yesod.Form.Fields-    ) where--import Yesod.Form.Core-import Yesod.Form.Fields-import Yesod.Form.Class-import Yesod.Form.Profiles (Textarea (..))-import Yesod.Widget (GWidget)--import Text.Hamlet-import Yesod.Request-import Yesod.Handler-import Control.Applicative hiding (optional)-import Data.Maybe (fromMaybe, mapMaybe)-import Control.Monad ((<=<))-import Language.Haskell.TH.Syntax hiding (lift)-import Database.Persist.Base (EntityDef (..), PersistEntity (entityDef))-import Data.Char (toUpper, isUpper)-import Control.Arrow ((&&&))-import Data.List (group, sort)-import Data.Monoid (mempty)-import Data.Text (Text)--#if __GLASGOW_HASKELL__ >= 700-#define HAMLET hamlet-#else-#define HAMLET $hamlet-#endif--- | Display only the actual input widget code, without any decoration.-fieldsToPlain :: FormField sub y a -> Form sub y a-fieldsToPlain = mapFormXml $ mapM_ fiInput---- | Display the label, tooltip, input code and errors in a single row of a--- table.-fieldsToTable :: FormField sub y a -> Form sub y a-fieldsToTable = mapFormXml $ mapM_ go-  where-    go fi = [HAMLET|-<tr .#{clazz fi}>-    <td>-        <label for="#{fiIdent fi}">#{fiLabel fi}-        <div .tooltip>#{fiTooltip fi}-    <td>-        \^{fiInput fi}-    $maybe err <- fiErrors fi-        <td .errors>#{err}-|]-    clazz fi = if fiRequired fi then "required" else "optional" :: Text---- | Display the label, tooltip, input code and errors in a single div.-fieldsToDivs :: FormField sub y a -> Form sub y a-fieldsToDivs = mapFormXml $ mapM_ go-  where-    go fi = [HAMLET|-<div .#{clazz fi}>-    <label for="#{fiIdent fi}">#{fiLabel fi}-        <div .tooltip>#{fiTooltip fi}-    \^{fiInput fi}-    $maybe err <- fiErrors fi-        <div .errors>#{err}-|]-    clazz fi = if fiRequired fi then "required" else "optional" :: Text---- | Run a form against POST parameters, without CSRF protection.-runFormPostNoNonce :: GForm s m xml a -> GHandler s m (FormResult a, xml, Enctype)-runFormPostNoNonce f = do-    (pp, files) <- runRequestBody-    runFormGeneric pp files f---- | Run a form against POST parameters.------ This function includes CSRF protection by checking a nonce value. You must--- therefore embed this nonce in the form as a hidden field; that is the--- meaning of the fourth element in the tuple.-runFormPost :: GForm s m xml a -> GHandler s m (FormResult a, xml, Enctype, Html)-runFormPost f = do-    (pp, files) <- runRequestBody-    nonce <- fmap reqNonce getRequest-    (res, xml, enctype) <- runFormGeneric pp files f-    let res' =-            case res of-                FormSuccess x ->-                    if lookup nonceName pp == nonce-                        then FormSuccess x-                        else FormFailure ["As a protection against cross-site request forgery attacks, please confirm your form submission."]-                _ -> res-    return (res', xml, enctype, maybe mempty hidden nonce)-  where-    hidden nonce = [HAMLET|-    <input type="hidden" name="#{nonceName}" value="#{nonce}">-|]--nonceName :: Text-nonceName = "_nonce"---- | Run a form against POST parameters. Please note that this does not provide--- CSRF protection.-runFormMonadPost :: GFormMonad s m a -> GHandler s m (a, Enctype)-runFormMonadPost f = do-    (pp, files) <- runRequestBody-    runFormGeneric pp files f---- | Run a form against POST parameters, disregarding the resulting HTML and--- returning an error response on invalid input. Note: this does /not/ perform--- CSRF protection.-runFormPost' :: GForm sub y xml a -> GHandler sub y a-runFormPost' f = do-    (pp, files) <- runRequestBody-    x <- runFormGeneric pp files f-    helper x---- | Create a table-styled form.------ This function wraps around 'runFormPost' and 'fieldsToTable', taking care of--- some of the boiler-plate in creating forms. In particular, is automatically--- creates the form element, sets the method, action and enctype attributes,--- adds the CSRF-protection nonce hidden field and inserts a submit button.-runFormTable :: Route m -> String -> FormField s m a-             -> GHandler s m (FormResult a, GWidget s m ())-runFormTable dest inputLabel form = do-    (res, widget, enctype, nonce) <- runFormPost $ fieldsToTable form-    return (res, [HAMLET|-<form method="post" action="@{dest}" enctype="#{enctype}">-    <table>-        \^{widget}-        <tr>-            <td colspan="2">-                \#{nonce}-                <input type="submit" value="#{inputLabel}">-|])---- | Same as 'runFormPostTable', but uses 'fieldsToDivs' for styling.-runFormDivs :: Route m -> String -> FormField s m a-            -> GHandler s m (FormResult a, GWidget s m ())-runFormDivs dest inputLabel form = do-    (res, widget, enctype, nonce) <- runFormPost $ fieldsToDivs form-    return (res, [HAMLET|-<form method="post" action="@{dest}" enctype="#{enctype}">-    \^{widget}-    <div>-        \#{nonce}-        <input type="submit" value="#{inputLabel}">-|])---- | Run a form against GET parameters, disregarding the resulting HTML and--- returning an error response on invalid input.-runFormGet' :: GForm sub y xml a -> GHandler sub y a-runFormGet' = helper <=< runFormGet--helper :: (FormResult a, b, c) -> GHandler sub y a-helper (FormSuccess a, _, _) = return a-helper (FormFailure e, _, _) = invalidArgs e-helper (FormMissing, _, _) = invalidArgs ["No input found"]---- | Generate a form, feeding it no data. The third element in the result tuple--- is a nonce hidden field.-generateForm :: GForm s m xml a -> GHandler s m (xml, Enctype, Html)-generateForm f = do-    (_, b, c) <- runFormGeneric [] [] f-    nonce <- fmap reqNonce getRequest-    return (b, c, [HAMLET|\-$maybe n <- nonce-    <input type="hidden" name="#{nonceName}" value="#{n}">-|])---- | Run a form against GET parameters.-runFormGet :: GForm s m xml a -> GHandler s m (FormResult a, xml, Enctype)-runFormGet f = do-    gs <- reqGetParams `fmap` getRequest-    runFormGeneric gs [] f--runFormMonadGet :: GFormMonad s m a -> GHandler s m (a, Enctype)-runFormMonadGet f = do-    gs <- reqGetParams `fmap` getRequest-    runFormGeneric gs [] f---- | Create 'ToForm' instances for the given entity. In addition to regular 'EntityDef' attributes understood by persistent, it also understands label= and tooltip=.-mkToForm :: PersistEntity v => v -> Q [Dec]-mkToForm =-    fmap return . derive . entityDef-  where-    afterPeriod s =-        case dropWhile (/= '.') s of-            ('.':t) -> t-            _ -> s-    beforePeriod s =-        case break (== '.') s of-            (t, '.':_) -> Just t-            _ -> Nothing-    getSuperclass (_, _, z) = getTFF' z >>= beforePeriod-    getTFF (_, _, z) = maybe "toFormField" afterPeriod $ getTFF' z-    getTFF' [] = Nothing-    getTFF' (('t':'o':'F':'o':'r':'m':'F':'i':'e':'l':'d':'=':x):_) = Just x-    getTFF' (_:x) = getTFF' x-    getLabel (x, _, z) = fromMaybe (toLabel x) $ getLabel' z-    getLabel' [] = Nothing-    getLabel' (('l':'a':'b':'e':'l':'=':x):_) = Just x-    getLabel' (_:x) = getLabel' x-    getTooltip (_, _, z) = fromMaybe "" $ getTooltip' z-    getTooltip' (('t':'o':'o':'l':'t':'i':'p':'=':x):_) = Just x-    getTooltip' (_:x) = getTooltip' x-    getTooltip' [] = Nothing-    getId (_, _, z) = fromMaybe "" $ getId' z-    getId' (('i':'d':'=':x):_) = Just x-    getId' (_:x) = getId' x-    getId' [] = Nothing-    getName (_, _, z) = fromMaybe "" $ getName' z-    getName' (('n':'a':'m':'e':'=':x):_) = Just x-    getName' (_:x) = getName' x-    getName' [] = Nothing-    derive :: EntityDef -> Q Dec-    derive t = do-        let cols = map ((getId &&& getName) &&& ((getLabel &&& getTooltip) &&& getTFF)) $ entityColumns t-        ap <- [|(<*>)|]-        just <- [|pure|]-        nothing <- [|Nothing|]-        let just' = just `AppE` ConE (mkName $ entityName t)-        string' <- [|toHtml|]-        ftt <- [|fieldsToTable|]-        ffs' <- [|FormFieldSettings|]-        let stm "" = nothing-            stm x = just `AppE` LitE (StringL x)-        let go_ = go ap just' ffs' stm string' ftt-        let c1 = Clause [ ConP (mkName "Nothing") []-                        ]-                        (NormalB $ go_ $ zip cols $ map (const nothing) cols)-                        []-        xs <- mapM (const $ newName "x") cols-        let xs' = map (AppE just . VarE) xs-        let c2 = Clause [ ConP (mkName "Just") [ConP (mkName $ entityName t)-                            $ map VarP xs]]-                        (NormalB $ go_ $ zip cols xs')-                        []-        let y = mkName "y"-        let ctx = map (\x -> ClassP (mkName x) [VarT y])-                $ map head $ group $ sort-                $ mapMaybe getSuperclass-                $ entityColumns t-        return $ InstanceD ctx ( ConT ''ToForm-                              `AppT` ConT (mkName $ entityName t)-                              `AppT` VarT y)-            [FunD (mkName "toForm") [c1, c2]]-    go ap just' ffs' stm string' ftt a =-        let x = foldl (ap' ap) just' $ map (go' ffs' stm string') a-         in ftt `AppE` x-    go' ffs' stm string' (((theId, name), ((label, tooltip), tff)), ex) =-        let label' = LitE $ StringL label-            tooltip' = string' `AppE` LitE (StringL tooltip)-            ffs = ffs' `AppE`-                  label' `AppE`-                  tooltip' `AppE`-                  (stm theId) `AppE`-                  (stm name)-         in VarE (mkName tff) `AppE` ffs `AppE` ex-    ap' ap x y = InfixE (Just x) ap (Just y)--toLabel :: String -> String-toLabel "" = ""-toLabel (x:rest) = toUpper x : go rest-  where-    go "" = ""-    go (c:cs)-        | isUpper c = ' ' : c : go cs-        | otherwise = c : go cs--formFailures :: FormResult a -> Maybe [Text]-formFailures (FormFailure x) = Just x-formFailures _ = Nothing+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE PackageImports #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
+-- | Parse forms (and query strings).
+module Yesod.Form
+    ( -- * Data types
+      GForm
+    , FormResult (..)
+    , Enctype (..)
+    , FormFieldSettings (..)
+    , Textarea (..)
+    , FieldInfo (..)
+      -- ** Utilities
+    , formFailures
+      -- * Type synonyms
+    , Form
+    , Formlet
+    , FormField
+    , FormletField
+    , FormInput
+      -- * Unwrapping functions
+    , generateForm
+    , runFormGet
+    , runFormMonadGet
+    , runFormPost
+    , runFormPostNoNonce
+    , runFormMonadPost
+    , runFormGet'
+    , runFormPost'
+      -- ** High-level form post unwrappers
+    , runFormTable
+    , runFormDivs
+      -- * Field/form helpers
+    , fieldsToTable
+    , fieldsToDivs
+    , fieldsToPlain
+    , checkForm
+      -- * Type classes
+    , module Yesod.Form.Class
+      -- * Template Haskell
+    , mkToForm
+    , module Yesod.Form.Fields
+    ) where
+
+import Yesod.Form.Core
+import Yesod.Form.Fields
+import Yesod.Form.Class
+import Yesod.Form.Profiles (Textarea (..))
+import Yesod.Widget (GWidget)
+
+import Text.Hamlet
+import Yesod.Request
+import Yesod.Handler
+import Control.Applicative hiding (optional)
+import Data.Maybe (fromMaybe, mapMaybe)
+import Control.Monad ((<=<))
+import Language.Haskell.TH.Syntax hiding (lift)
+import Database.Persist.Base (EntityDef (..), PersistEntity (entityDef))
+import Data.Char (toUpper, isUpper)
+import Control.Arrow ((&&&))
+import Data.List (group, sort)
+import Data.Monoid (mempty)
+import Data.Text (Text)
+
+#if __GLASGOW_HASKELL__ >= 700
+#define HAMLET hamlet
+#else
+#define HAMLET $hamlet
+#endif
+-- | Display only the actual input widget code, without any decoration.
+fieldsToPlain :: FormField sub y a -> Form sub y a
+fieldsToPlain = mapFormXml $ mapM_ fiInput
+
+-- | Display the label, tooltip, input code and errors in a single row of a
+-- table.
+fieldsToTable :: FormField sub y a -> Form sub y a
+fieldsToTable = mapFormXml $ mapM_ go
+  where
+    go fi = [HAMLET|
+<tr .#{clazz fi}>
+    <td>
+        <label for="#{fiIdent fi}">#{fiLabel fi}
+        <div .tooltip>#{fiTooltip fi}
+    <td>
+        \^{fiInput fi}
+    $maybe err <- fiErrors fi
+        <td .errors>#{err}
+|]
+    clazz fi = if fiRequired fi then "required" else "optional" :: Text
+
+-- | Display the label, tooltip, input code and errors in a single div.
+fieldsToDivs :: FormField sub y a -> Form sub y a
+fieldsToDivs = mapFormXml $ mapM_ go
+  where
+    go fi = [HAMLET|
+<div .#{clazz fi}>
+    <label for="#{fiIdent fi}">#{fiLabel fi}
+        <div .tooltip>#{fiTooltip fi}
+    \^{fiInput fi}
+    $maybe err <- fiErrors fi
+        <div .errors>#{err}
+|]
+    clazz fi = if fiRequired fi then "required" else "optional" :: Text
+
+-- | Run a form against POST parameters, without CSRF protection.
+runFormPostNoNonce :: GForm s m xml a -> GHandler s m (FormResult a, xml, Enctype)
+runFormPostNoNonce f = do
+    (pp, files) <- runRequestBody
+    runFormGeneric pp files f
+
+-- | Run a form against POST parameters.
+--
+-- This function includes CSRF protection by checking a nonce value. You must
+-- therefore embed this nonce in the form as a hidden field; that is the
+-- meaning of the fourth element in the tuple.
+runFormPost :: GForm s m xml a -> GHandler s m (FormResult a, xml, Enctype, Html)
+runFormPost f = do
+    (pp, files) <- runRequestBody
+    nonce <- fmap reqNonce getRequest
+    (res, xml, enctype) <- runFormGeneric pp files f
+    let res' =
+            case res of
+                FormSuccess x ->
+                    if lookup nonceName pp == nonce
+                        then FormSuccess x
+                        else FormFailure ["As a protection against cross-site request forgery attacks, please confirm your form submission."]
+                _ -> res
+    return (res', xml, enctype, maybe mempty hidden nonce)
+  where
+    hidden nonce = [HAMLET|
+    <input type="hidden" name="#{nonceName}" value="#{nonce}">
+|]
+
+nonceName :: Text
+nonceName = "_nonce"
+
+-- | Run a form against POST parameters. Please note that this does not provide
+-- CSRF protection.
+runFormMonadPost :: GFormMonad s m a -> GHandler s m (a, Enctype)
+runFormMonadPost f = do
+    (pp, files) <- runRequestBody
+    runFormGeneric pp files f
+
+-- | Run a form against POST parameters, disregarding the resulting HTML and
+-- returning an error response on invalid input. Note: this does /not/ perform
+-- CSRF protection.
+runFormPost' :: GForm sub y xml a -> GHandler sub y a
+runFormPost' f = do
+    (pp, files) <- runRequestBody
+    x <- runFormGeneric pp files f
+    helper x
+
+-- | Create a table-styled form.
+--
+-- This function wraps around 'runFormPost' and 'fieldsToTable', taking care of
+-- some of the boiler-plate in creating forms. In particular, is automatically
+-- creates the form element, sets the method, action and enctype attributes,
+-- adds the CSRF-protection nonce hidden field and inserts a submit button.
+runFormTable :: Route m -> String -> FormField s m a
+             -> GHandler s m (FormResult a, GWidget s m ())
+runFormTable dest inputLabel form = do
+    (res, widget, enctype, nonce) <- runFormPost $ fieldsToTable form
+    return (res, [HAMLET|
+<form method="post" action="@{dest}" enctype="#{enctype}">
+    <table>
+        \^{widget}
+        <tr>
+            <td colspan="2">
+                \#{nonce}
+                <input type="submit" value="#{inputLabel}">
+|])
+
+-- | Same as 'runFormPostTable', but uses 'fieldsToDivs' for styling.
+runFormDivs :: Route m -> String -> FormField s m a
+            -> GHandler s m (FormResult a, GWidget s m ())
+runFormDivs dest inputLabel form = do
+    (res, widget, enctype, nonce) <- runFormPost $ fieldsToDivs form
+    return (res, [HAMLET|
+<form method="post" action="@{dest}" enctype="#{enctype}">
+    \^{widget}
+    <div>
+        \#{nonce}
+        <input type="submit" value="#{inputLabel}">
+|])
+
+-- | Run a form against GET parameters, disregarding the resulting HTML and
+-- returning an error response on invalid input.
+runFormGet' :: GForm sub y xml a -> GHandler sub y a
+runFormGet' = helper <=< runFormGet
+
+helper :: (FormResult a, b, c) -> GHandler sub y a
+helper (FormSuccess a, _, _) = return a
+helper (FormFailure e, _, _) = invalidArgs e
+helper (FormMissing, _, _) = invalidArgs ["No input found"]
+
+-- | Generate a form, feeding it no data. The third element in the result tuple
+-- is a nonce hidden field.
+generateForm :: GForm s m xml a -> GHandler s m (xml, Enctype, Html)
+generateForm f = do
+    (_, b, c) <- runFormGeneric [] [] f
+    nonce <- fmap reqNonce getRequest
+    return (b, c, [HAMLET|\
+$maybe n <- nonce
+    <input type="hidden" name="#{nonceName}" value="#{n}">
+|])
+
+-- | Run a form against GET parameters.
+runFormGet :: GForm s m xml a -> GHandler s m (FormResult a, xml, Enctype)
+runFormGet f = do
+    gs <- reqGetParams `fmap` getRequest
+    runFormGeneric gs [] f
+
+runFormMonadGet :: GFormMonad s m a -> GHandler s m (a, Enctype)
+runFormMonadGet f = do
+    gs <- reqGetParams `fmap` getRequest
+    runFormGeneric gs [] f
+
+-- | Create 'ToForm' instances for the given entity. In addition to regular 'EntityDef' attributes understood by persistent, it also understands label= and tooltip=.
+mkToForm :: PersistEntity v => v -> Q [Dec]
+mkToForm =
+    fmap return . derive . entityDef
+  where
+    afterPeriod s =
+        case dropWhile (/= '.') s of
+            ('.':t) -> t
+            _ -> s
+    beforePeriod s =
+        case break (== '.') s of
+            (t, '.':_) -> Just t
+            _ -> Nothing
+    getSuperclass (_, _, z) = getTFF' z >>= beforePeriod
+    getTFF (_, _, z) = maybe "toFormField" afterPeriod $ getTFF' z
+    getTFF' [] = Nothing
+    getTFF' (('t':'o':'F':'o':'r':'m':'F':'i':'e':'l':'d':'=':x):_) = Just x
+    getTFF' (_:x) = getTFF' x
+    getLabel (x, _, z) = fromMaybe (toLabel x) $ getLabel' z
+    getLabel' [] = Nothing
+    getLabel' (('l':'a':'b':'e':'l':'=':x):_) = Just x
+    getLabel' (_:x) = getLabel' x
+    getTooltip (_, _, z) = fromMaybe "" $ getTooltip' z
+    getTooltip' (('t':'o':'o':'l':'t':'i':'p':'=':x):_) = Just x
+    getTooltip' (_:x) = getTooltip' x
+    getTooltip' [] = Nothing
+    getId (_, _, z) = fromMaybe "" $ getId' z
+    getId' (('i':'d':'=':x):_) = Just x
+    getId' (_:x) = getId' x
+    getId' [] = Nothing
+    getName (_, _, z) = fromMaybe "" $ getName' z
+    getName' (('n':'a':'m':'e':'=':x):_) = Just x
+    getName' (_:x) = getName' x
+    getName' [] = Nothing
+    derive :: EntityDef -> Q Dec
+    derive t = do
+        let cols = map ((getId &&& getName) &&& ((getLabel &&& getTooltip) &&& getTFF)) $ entityColumns t
+        ap <- [|(<*>)|]
+        just <- [|pure|]
+        nothing <- [|Nothing|]
+        let just' = just `AppE` ConE (mkName $ entityName t)
+        string' <- [|toHtml|]
+        ftt <- [|fieldsToTable|]
+        ffs' <- [|FormFieldSettings|]
+        let stm "" = nothing
+            stm x = just `AppE` LitE (StringL x)
+        let go_ = go ap just' ffs' stm string' ftt
+        let c1 = Clause [ ConP (mkName "Nothing") []
+                        ]
+                        (NormalB $ go_ $ zip cols $ map (const nothing) cols)
+                        []
+        xs <- mapM (const $ newName "x") cols
+        let xs' = map (AppE just . VarE) xs
+        let c2 = Clause [ ConP (mkName "Just") [ConP (mkName $ entityName t)
+                            $ map VarP xs]]
+                        (NormalB $ go_ $ zip cols xs')
+                        []
+        let y = mkName "y"
+        let ctx = map (\x -> ClassP (mkName x) [VarT y])
+                $ map head $ group $ sort
+                $ mapMaybe getSuperclass
+                $ entityColumns t
+        return $ InstanceD ctx ( ConT ''ToForm
+                              `AppT` ConT (mkName $ entityName t)
+                              `AppT` VarT y)
+            [FunD (mkName "toForm") [c1, c2]]
+    go ap just' ffs' stm string' ftt a =
+        let x = foldl (ap' ap) just' $ map (go' ffs' stm string') a
+         in ftt `AppE` x
+    go' ffs' stm string' (((theId, name), ((label, tooltip), tff)), ex) =
+        let label' = LitE $ StringL label
+            tooltip' = string' `AppE` LitE (StringL tooltip)
+            ffs = ffs' `AppE`
+                  label' `AppE`
+                  tooltip' `AppE`
+                  (stm theId) `AppE`
+                  (stm name)
+         in VarE (mkName tff) `AppE` ffs `AppE` ex
+    ap' ap x y = InfixE (Just x) ap (Just y)
+
+toLabel :: String -> String
+toLabel "" = ""
+toLabel (x:rest) = toUpper x : go rest
+  where
+    go "" = ""
+    go (c:cs)
+        | isUpper c = ' ' : c : go cs
+        | otherwise = c : go cs
+
+formFailures :: FormResult a -> Maybe [Text]
+formFailures (FormFailure x) = Just x
+formFailures _ = Nothing
Yesod/Form/Class.hs view
@@ -1,69 +1,69 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeSynonymInstances #-}-module Yesod.Form.Class-    ( ToForm (..)-    , ToFormField (..)-    ) where--import Text.Hamlet-import Yesod.Form.Fields-import Yesod.Form.Core-import Yesod.Form.Profiles (Textarea)-import Data.Int (Int64)-import Data.Time (Day, TimeOfDay)-import Data.Text (Text)--class ToForm a y where-    toForm :: Formlet sub y a-class ToFormField a y where-    toFormField :: FormFieldSettings -> FormletField sub y a--{- FIXME-instance ToFormField String y where-    toFormField = stringField-instance ToFormField (Maybe String) y where-    toFormField = maybeStringField--}--instance ToFormField Text y where-    toFormField = stringField-instance ToFormField (Maybe Text) y where-    toFormField = maybeStringField--instance ToFormField Int y where-    toFormField = intField-instance ToFormField (Maybe Int) y where-    toFormField = maybeIntField-instance ToFormField Int64 y where-    toFormField = intField-instance ToFormField (Maybe Int64) y where-    toFormField = maybeIntField--instance ToFormField Double y where-    toFormField = doubleField-instance ToFormField (Maybe Double) y where-    toFormField = maybeDoubleField--instance ToFormField Day y where-    toFormField = dayField-instance ToFormField (Maybe Day) y where-    toFormField = maybeDayField--instance ToFormField TimeOfDay y where-    toFormField = timeField-instance ToFormField (Maybe TimeOfDay) y where-    toFormField = maybeTimeField--instance ToFormField Bool y where-    toFormField = boolField--instance ToFormField Html y where-    toFormField = htmlField-instance ToFormField (Maybe Html) y where-    toFormField = maybeHtmlField--instance ToFormField Textarea y where-    toFormField = textareaField-instance ToFormField (Maybe Textarea) y where-    toFormField = maybeTextareaField+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+module Yesod.Form.Class
+    ( ToForm (..)
+    , ToFormField (..)
+    ) where
+
+import Text.Hamlet
+import Yesod.Form.Fields
+import Yesod.Form.Core
+import Yesod.Form.Profiles (Textarea)
+import Data.Int (Int64)
+import Data.Time (Day, TimeOfDay)
+import Data.Text (Text)
+
+class ToForm a y where
+    toForm :: Formlet sub y a
+class ToFormField a y where
+    toFormField :: FormFieldSettings -> FormletField sub y a
+
+{- FIXME
+instance ToFormField String y where
+    toFormField = stringField
+instance ToFormField (Maybe String) y where
+    toFormField = maybeStringField
+-}
+
+instance ToFormField Text y where
+    toFormField = stringField
+instance ToFormField (Maybe Text) y where
+    toFormField = maybeStringField
+
+instance ToFormField Int y where
+    toFormField = intField
+instance ToFormField (Maybe Int) y where
+    toFormField = maybeIntField
+instance ToFormField Int64 y where
+    toFormField = intField
+instance ToFormField (Maybe Int64) y where
+    toFormField = maybeIntField
+
+instance ToFormField Double y where
+    toFormField = doubleField
+instance ToFormField (Maybe Double) y where
+    toFormField = maybeDoubleField
+
+instance ToFormField Day y where
+    toFormField = dayField
+instance ToFormField (Maybe Day) y where
+    toFormField = maybeDayField
+
+instance ToFormField TimeOfDay y where
+    toFormField = timeField
+instance ToFormField (Maybe TimeOfDay) y where
+    toFormField = maybeTimeField
+
+instance ToFormField Bool y where
+    toFormField = boolField
+
+instance ToFormField Html y where
+    toFormField = htmlField
+instance ToFormField (Maybe Html) y where
+    toFormField = maybeHtmlField
+
+instance ToFormField Textarea y where
+    toFormField = textareaField
+instance ToFormField (Maybe Textarea) y where
+    toFormField = maybeTextareaField
Yesod/Form/Core.hs view
@@ -1,376 +1,376 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeSynonymInstances #-}--- | Users of the forms library should not need to use this module in general.--- It is intended only for writing custom forms and form fields.-module Yesod.Form.Core-    ( FormResult (..)-    , GForm (..)-    , newFormIdent-    , deeperFormIdent-    , shallowerFormIdent-    , Env-    , FileEnv-    , Enctype (..)-    , Ints (..)-    , requiredFieldHelper-    , optionalFieldHelper-    , fieldsToInput-    , mapFormXml-    , checkForm-    , checkField-    , askParams-    , askFiles-    , liftForm-    , IsForm (..)-    , RunForm (..)-    , GFormMonad-      -- * Data types-    , FieldInfo (..)-    , FormFieldSettings (..)-    , FieldProfile (..)-      -- * Type synonyms-    , Form-    , Formlet-    , FormField-    , FormletField-    , FormInput-    ) where--import Control.Monad.Trans.State-import Control.Monad.Trans.Reader-import Control.Monad.Trans.Writer-import Control.Monad.Trans.Class (lift)-import Yesod.Handler-import Yesod.Widget-import Data.Monoid (Monoid (..))-import Control.Applicative-import Yesod.Request-import Control.Monad (liftM)-import Text.Hamlet-import Text.Blaze (ToHtml (..))-import Data.String-import Control.Monad (join)-import Data.Text (Text, pack)-import qualified Data.Text as T-import Prelude hiding ((++))--(++) :: Monoid a => a -> a -> a-(++) = mappend---- | 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 'Show' instance produces values--- that can be inserted directly into HTML.-data Enctype = UrlEncoded | Multipart-    deriving (Eq, Enum, Bounded)-instance ToHtml Enctype where-    toHtml UrlEncoded = unsafeByteString "application/x-www-form-urlencoded"-    toHtml Multipart = unsafeByteString "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)--incrInts :: Ints -> Ints-incrInts (IntSingle i) = IntSingle $ i + 1-incrInts (IntCons i is) = (i + 1) `IntCons` is---- | A generic form, allowing you to specifying the subsite datatype, master--- site datatype, a datatype for the form XML and the return type.-newtype GForm s m xml a = GForm-    { deform :: FormInner s m (FormResult a, xml, Enctype)-    }--type GFormMonad s m a = WriterT Enctype (FormInner s m) a--type FormInner s m =-    StateT Ints (-    ReaderT Env (-    ReaderT FileEnv (-    GHandler s m-    )))--type Env = [(Text, Text)]-type FileEnv = [(Text, FileInfo)]---- | Get a unique identifier.-newFormIdent :: Monad m => StateT Ints m Text-newFormIdent = do-    i <- get-    let i' = incrInts i-    put i'-    return $ pack $ 'f' : show i'--deeperFormIdent :: Monad m => StateT Ints m ()-deeperFormIdent = do-    i <- get-    let i' = 1 `IntCons` incrInts i-    put i'--shallowerFormIdent :: Monad m => StateT Ints m ()-shallowerFormIdent = do-    IntCons _ i <- get-    put i--instance Monoid xml => Functor (GForm sub url xml) where-    fmap f (GForm g) =-        GForm $ liftM (first3 $ fmap f) g-      where-        first3 f' (x, y, z) = (f' x, y, z)--instance Monoid xml => Applicative (GForm sub url xml) where-    pure a = GForm $ return (pure a, mempty, mempty)-    (GForm f) <*> (GForm g) = GForm $ do-        (f1, f2, f3) <- f-        (g1, g2, g3) <- g-        return (f1 <*> g1, f2 `mappend` g2, f3 `mappend` g3)---- | Create a required field (ie, one that cannot be blank) from a--- 'FieldProfile'.-requiredFieldHelper-    :: IsForm f-    => FieldProfile (FormSub f) (FormMaster f) (FormType f)-    -> FormFieldSettings-    -> Maybe (FormType f)-    -> f-requiredFieldHelper (FieldProfile parse render mkWidget) ffs orig = toForm $ do-    env <- lift ask-    let (FormFieldSettings label tooltip theId' name') = ffs-    name <- maybe newFormIdent return name'-    theId <- maybe newFormIdent return theId'-    let (res, val) =-            if null env-                then (FormMissing, maybe "" render orig)-                else case lookup name env of-                        Nothing -> (FormMissing, "")-                        Just "" -> (FormFailure ["Value is required"], "")-                        Just x ->-                            case parse x of-                                Left e -> (FormFailure [e], x)-                                Right y -> (FormSuccess y, x)-    let fi = FieldInfo-            { fiLabel = toHtml label-            , fiTooltip = tooltip-            , fiIdent = theId-            , fiInput = mkWidget theId name val True-            , fiErrors = case res of-                            FormFailure [x] -> Just $ toHtml x-                            _ -> Nothing-            , fiRequired = True-            }-    let res' = case res of-                FormFailure [e] -> FormFailure [label ++ ": " ++ e]-                _ -> res-    return (res', fi, UrlEncoded)--class IsForm f where-    type FormSub f-    type FormMaster f-    type FormType f-    toForm :: FormInner-                (FormSub f)-                (FormMaster f)-                (FormResult (FormType f),-                 FieldInfo (FormSub f) (FormMaster f),-                 Enctype) -> f-instance IsForm (FormField s m a) where-    type FormSub (FormField s m a) = s-    type FormMaster (FormField s m a) = m-    type FormType (FormField s m a) = a-    toForm x = GForm $ do-        (a, b, c) <- x-        return (a, [b], c)-instance (FormResult ~ formResult) => IsForm (GFormMonad s m (formResult a, FieldInfo s m)) where-    type FormSub (GFormMonad s m (formResult a, FieldInfo s m)) = s-    type FormMaster (GFormMonad s m (formResult a, FieldInfo s m)) = m-    type FormType (GFormMonad s m (formResult a, FieldInfo s m)) = a-    toForm x = do-        (res, fi, enctype) <- lift x-        tell enctype-        return (res, fi)--class RunForm f where-    type RunFormSub f-    type RunFormMaster f-    type RunFormType f-    runFormGeneric :: Env -> FileEnv -> f-                   -> GHandler (RunFormSub f)-                               (RunFormMaster f)-                               (RunFormType f)--instance RunForm (GForm s m xml a) where-    type RunFormSub (GForm s m xml a) = s-    type RunFormMaster (GForm s m xml a) = m-    type RunFormType (GForm s m xml a) =-        (FormResult a, xml, Enctype)-    runFormGeneric env fe (GForm f) =-        runReaderT (runReaderT (evalStateT f $ IntSingle 1) env) fe--instance RunForm (GFormMonad s m a) where-    type RunFormSub (GFormMonad s m a) = s-    type RunFormMaster (GFormMonad s m a) = m-    type RunFormType (GFormMonad s m a) = (a, Enctype)-    runFormGeneric e fe f =-        runReaderT (runReaderT (evalStateT (runWriterT f) $ IntSingle 1) e) fe---- | Create an optional field (ie, one that can be blank) from a--- 'FieldProfile'.-optionalFieldHelper-    :: (IsForm f, Maybe b ~ FormType f)-    => FieldProfile (FormSub f) (FormMaster f) b-    -> FormFieldSettings-    -> Maybe (Maybe b)-    -> f-optionalFieldHelper (FieldProfile parse render mkWidget) ffs orig' = toForm $ do-    env <- lift ask-    let (FormFieldSettings label tooltip theId' name') = ffs-    let orig = join orig'-    name <- maybe newFormIdent return name'-    theId <- maybe newFormIdent return theId'-    let (res, val) =-            if null env-                then (FormSuccess Nothing, maybe "" render orig)-                else case lookup name env of-                        Nothing -> (FormSuccess Nothing, "")-                        Just "" -> (FormSuccess Nothing, "")-                        Just x ->-                            case parse x of-                                Left e -> (FormFailure [e], x)-                                Right y -> (FormSuccess $ Just y, x)-    let fi = FieldInfo-            { fiLabel = toHtml label-            , fiTooltip = tooltip-            , fiIdent = theId-            , fiInput = mkWidget theId name val False-            , fiErrors = case res of-                            FormFailure x -> Just $ toHtml $ T.unlines x-                            _ -> Nothing-            , fiRequired = False-            }-    let res' = case res of-                FormFailure [e] -> FormFailure [label ++ ": " ++ e]-                _ -> res-    return (res', fi, UrlEncoded)--fieldsToInput :: [FieldInfo sub y] -> [GWidget sub y ()]-fieldsToInput = map fiInput---- | Convert the XML in a 'GForm'.-mapFormXml :: (xml1 -> xml2) -> GForm s y xml1 a -> GForm s y xml2 a-mapFormXml f (GForm g) = GForm $ do-    (res, xml, enc) <- g-    return (res, f xml, enc)---- | Using this as the intermediate XML representation for fields allows us to--- write generic field functions and then different functions for producing--- actual HTML. See, for example, 'fieldsToTable' and 'fieldsToPlain'.-data FieldInfo sub y = FieldInfo-    { fiLabel :: Html-    , fiTooltip :: Html-    , fiIdent :: Text-    , fiInput :: GWidget sub y ()-    , fiErrors :: Maybe Html-    , fiRequired :: Bool-    }--data FormFieldSettings = FormFieldSettings-    { ffsLabel :: Text-    , ffsTooltip :: Html-    , ffsId :: Maybe Text-    , ffsName :: Maybe Text-    }-instance IsString FormFieldSettings where-    fromString s = FormFieldSettings (pack s) mempty Nothing Nothing---- | A generic definition of a form field that can be used for generating both--- required and optional fields. See 'requiredFieldHelper and--- 'optionalFieldHelper'.-data FieldProfile sub y a = FieldProfile-    { fpParse :: Text -> Either Text a-    , fpRender :: a -> Text-    -- | ID, name, value, required-    , fpWidget :: Text -> Text -> Text -> Bool -> GWidget sub y ()-    }--type Form sub y = GForm sub y (GWidget sub y ())-type Formlet sub y a = Maybe a -> Form sub y a-type FormField sub y = GForm sub y [FieldInfo sub y]-type FormletField sub y a = Maybe a -> FormField sub y a-type FormInput sub y = GForm sub y [GWidget sub y ()]---- | Add a validation check to a form.------ Note that if there is a validation error, this message will /not/--- automatically appear on the form; for that, you need to use 'checkField'.-checkForm :: (a -> FormResult b) -> GForm s m x a -> GForm s m x b-checkForm f (GForm form) = GForm $ do-    (res, xml, enc) <- form-    let res' = case res of-                    FormSuccess a -> f a-                    FormFailure e -> FormFailure e-                    FormMissing -> FormMissing-    return (res', xml, enc)---- | Add a validation check to a 'FormField'.------ Unlike 'checkForm', the validation error will appear in the generated HTML--- of the form.-checkField :: (a -> Either Text b) -> FormField s m a -> FormField s m b-checkField f (GForm form) = GForm $ do-    (res, xml, enc) <- form-    let (res', merr) =-            case res of-                FormSuccess a ->-                    case f a of-                        Left e -> (FormFailure [e], Just e)-                        Right x -> (FormSuccess x, Nothing)-                FormFailure e -> (FormFailure e, Nothing)-                FormMissing -> (FormMissing, Nothing)-    let xml' =-            case merr of-                Nothing -> xml-                Just err -> flip map xml $ \fi -> fi-                    { fiErrors = Just $-                        case fiErrors fi of-                            Nothing -> toHtml err-                            Just x -> x-                    }-    return (res', xml', enc)--askParams :: Monad m => StateT Ints (ReaderT Env m) Env-askParams = lift ask--askFiles :: Monad m => StateT Ints (ReaderT Env (ReaderT FileEnv m)) FileEnv-askFiles = lift $ lift ask--liftForm :: Monad m => m a -> StateT Ints (ReaderT Env (ReaderT FileEnv m)) a-liftForm = lift . lift . lift+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+-- | Users of the forms library should not need to use this module in general.
+-- It is intended only for writing custom forms and form fields.
+module Yesod.Form.Core
+    ( FormResult (..)
+    , GForm (..)
+    , newFormIdent
+    , deeperFormIdent
+    , shallowerFormIdent
+    , Env
+    , FileEnv
+    , Enctype (..)
+    , Ints (..)
+    , requiredFieldHelper
+    , optionalFieldHelper
+    , fieldsToInput
+    , mapFormXml
+    , checkForm
+    , checkField
+    , askParams
+    , askFiles
+    , liftForm
+    , IsForm (..)
+    , RunForm (..)
+    , GFormMonad
+      -- * Data types
+    , FieldInfo (..)
+    , FormFieldSettings (..)
+    , FieldProfile (..)
+      -- * Type synonyms
+    , Form
+    , Formlet
+    , FormField
+    , FormletField
+    , FormInput
+    ) where
+
+import Control.Monad.Trans.State
+import Control.Monad.Trans.Reader
+import Control.Monad.Trans.Writer
+import Control.Monad.Trans.Class (lift)
+import Yesod.Handler
+import Yesod.Widget
+import Data.Monoid (Monoid (..))
+import Control.Applicative
+import Yesod.Request
+import Control.Monad (liftM)
+import Text.Hamlet
+import Text.Blaze (ToHtml (..))
+import Data.String
+import Control.Monad (join)
+import Data.Text (Text, pack)
+import qualified Data.Text as T
+import Prelude hiding ((++))
+
+(++) :: Monoid a => a -> a -> a
+(++) = mappend
+
+-- | 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 'Show' instance produces values
+-- that can be inserted directly into HTML.
+data Enctype = UrlEncoded | Multipart
+    deriving (Eq, Enum, Bounded)
+instance ToHtml Enctype where
+    toHtml UrlEncoded = unsafeByteString "application/x-www-form-urlencoded"
+    toHtml Multipart = unsafeByteString "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)
+
+incrInts :: Ints -> Ints
+incrInts (IntSingle i) = IntSingle $ i + 1
+incrInts (IntCons i is) = (i + 1) `IntCons` is
+
+-- | A generic form, allowing you to specifying the subsite datatype, master
+-- site datatype, a datatype for the form XML and the return type.
+newtype GForm s m xml a = GForm
+    { deform :: FormInner s m (FormResult a, xml, Enctype)
+    }
+
+type GFormMonad s m a = WriterT Enctype (FormInner s m) a
+
+type FormInner s m =
+    StateT Ints (
+    ReaderT Env (
+    ReaderT FileEnv (
+    GHandler s m
+    )))
+
+type Env = [(Text, Text)]
+type FileEnv = [(Text, FileInfo)]
+
+-- | Get a unique identifier.
+newFormIdent :: Monad m => StateT Ints m Text
+newFormIdent = do
+    i <- get
+    let i' = incrInts i
+    put i'
+    return $ pack $ 'f' : show i'
+
+deeperFormIdent :: Monad m => StateT Ints m ()
+deeperFormIdent = do
+    i <- get
+    let i' = 1 `IntCons` incrInts i
+    put i'
+
+shallowerFormIdent :: Monad m => StateT Ints m ()
+shallowerFormIdent = do
+    IntCons _ i <- get
+    put i
+
+instance Monoid xml => Functor (GForm sub url xml) where
+    fmap f (GForm g) =
+        GForm $ liftM (first3 $ fmap f) g
+      where
+        first3 f' (x, y, z) = (f' x, y, z)
+
+instance Monoid xml => Applicative (GForm sub url xml) where
+    pure a = GForm $ return (pure a, mempty, mempty)
+    (GForm f) <*> (GForm g) = GForm $ do
+        (f1, f2, f3) <- f
+        (g1, g2, g3) <- g
+        return (f1 <*> g1, f2 `mappend` g2, f3 `mappend` g3)
+
+-- | Create a required field (ie, one that cannot be blank) from a
+-- 'FieldProfile'.
+requiredFieldHelper
+    :: IsForm f
+    => FieldProfile (FormSub f) (FormMaster f) (FormType f)
+    -> FormFieldSettings
+    -> Maybe (FormType f)
+    -> f
+requiredFieldHelper (FieldProfile parse render mkWidget) ffs orig = toForm $ do
+    env <- lift ask
+    let (FormFieldSettings label tooltip theId' name') = ffs
+    name <- maybe newFormIdent return name'
+    theId <- maybe newFormIdent return theId'
+    let (res, val) =
+            if null env
+                then (FormMissing, maybe "" render orig)
+                else case lookup name env of
+                        Nothing -> (FormMissing, "")
+                        Just "" -> (FormFailure ["Value is required"], "")
+                        Just x ->
+                            case parse x of
+                                Left e -> (FormFailure [e], x)
+                                Right y -> (FormSuccess y, x)
+    let fi = FieldInfo
+            { fiLabel = toHtml label
+            , fiTooltip = tooltip
+            , fiIdent = theId
+            , fiInput = mkWidget theId name val True
+            , fiErrors = case res of
+                            FormFailure [x] -> Just $ toHtml x
+                            _ -> Nothing
+            , fiRequired = True
+            }
+    let res' = case res of
+                FormFailure [e] -> FormFailure [label ++ ": " ++ e]
+                _ -> res
+    return (res', fi, UrlEncoded)
+
+class IsForm f where
+    type FormSub f
+    type FormMaster f
+    type FormType f
+    toForm :: FormInner
+                (FormSub f)
+                (FormMaster f)
+                (FormResult (FormType f),
+                 FieldInfo (FormSub f) (FormMaster f),
+                 Enctype) -> f
+instance IsForm (FormField s m a) where
+    type FormSub (FormField s m a) = s
+    type FormMaster (FormField s m a) = m
+    type FormType (FormField s m a) = a
+    toForm x = GForm $ do
+        (a, b, c) <- x
+        return (a, [b], c)
+instance (FormResult ~ formResult) => IsForm (GFormMonad s m (formResult a, FieldInfo s m)) where
+    type FormSub (GFormMonad s m (formResult a, FieldInfo s m)) = s
+    type FormMaster (GFormMonad s m (formResult a, FieldInfo s m)) = m
+    type FormType (GFormMonad s m (formResult a, FieldInfo s m)) = a
+    toForm x = do
+        (res, fi, enctype) <- lift x
+        tell enctype
+        return (res, fi)
+
+class RunForm f where
+    type RunFormSub f
+    type RunFormMaster f
+    type RunFormType f
+    runFormGeneric :: Env -> FileEnv -> f
+                   -> GHandler (RunFormSub f)
+                               (RunFormMaster f)
+                               (RunFormType f)
+
+instance RunForm (GForm s m xml a) where
+    type RunFormSub (GForm s m xml a) = s
+    type RunFormMaster (GForm s m xml a) = m
+    type RunFormType (GForm s m xml a) =
+        (FormResult a, xml, Enctype)
+    runFormGeneric env fe (GForm f) =
+        runReaderT (runReaderT (evalStateT f $ IntSingle 1) env) fe
+
+instance RunForm (GFormMonad s m a) where
+    type RunFormSub (GFormMonad s m a) = s
+    type RunFormMaster (GFormMonad s m a) = m
+    type RunFormType (GFormMonad s m a) = (a, Enctype)
+    runFormGeneric e fe f =
+        runReaderT (runReaderT (evalStateT (runWriterT f) $ IntSingle 1) e) fe
+
+-- | Create an optional field (ie, one that can be blank) from a
+-- 'FieldProfile'.
+optionalFieldHelper
+    :: (IsForm f, Maybe b ~ FormType f)
+    => FieldProfile (FormSub f) (FormMaster f) b
+    -> FormFieldSettings
+    -> Maybe (Maybe b)
+    -> f
+optionalFieldHelper (FieldProfile parse render mkWidget) ffs orig' = toForm $ do
+    env <- lift ask
+    let (FormFieldSettings label tooltip theId' name') = ffs
+    let orig = join orig'
+    name <- maybe newFormIdent return name'
+    theId <- maybe newFormIdent return theId'
+    let (res, val) =
+            if null env
+                then (FormSuccess Nothing, maybe "" render orig)
+                else case lookup name env of
+                        Nothing -> (FormSuccess Nothing, "")
+                        Just "" -> (FormSuccess Nothing, "")
+                        Just x ->
+                            case parse x of
+                                Left e -> (FormFailure [e], x)
+                                Right y -> (FormSuccess $ Just y, x)
+    let fi = FieldInfo
+            { fiLabel = toHtml label
+            , fiTooltip = tooltip
+            , fiIdent = theId
+            , fiInput = mkWidget theId name val False
+            , fiErrors = case res of
+                            FormFailure x -> Just $ toHtml $ T.unlines x
+                            _ -> Nothing
+            , fiRequired = False
+            }
+    let res' = case res of
+                FormFailure [e] -> FormFailure [label ++ ": " ++ e]
+                _ -> res
+    return (res', fi, UrlEncoded)
+
+fieldsToInput :: [FieldInfo sub y] -> [GWidget sub y ()]
+fieldsToInput = map fiInput
+
+-- | Convert the XML in a 'GForm'.
+mapFormXml :: (xml1 -> xml2) -> GForm s y xml1 a -> GForm s y xml2 a
+mapFormXml f (GForm g) = GForm $ do
+    (res, xml, enc) <- g
+    return (res, f xml, enc)
+
+-- | Using this as the intermediate XML representation for fields allows us to
+-- write generic field functions and then different functions for producing
+-- actual HTML. See, for example, 'fieldsToTable' and 'fieldsToPlain'.
+data FieldInfo sub y = FieldInfo
+    { fiLabel :: Html
+    , fiTooltip :: Html
+    , fiIdent :: Text
+    , fiInput :: GWidget sub y ()
+    , fiErrors :: Maybe Html
+    , fiRequired :: Bool
+    }
+
+data FormFieldSettings = FormFieldSettings
+    { ffsLabel :: Text
+    , ffsTooltip :: Html
+    , ffsId :: Maybe Text
+    , ffsName :: Maybe Text
+    }
+instance IsString FormFieldSettings where
+    fromString s = FormFieldSettings (pack s) mempty Nothing Nothing
+
+-- | A generic definition of a form field that can be used for generating both
+-- required and optional fields. See 'requiredFieldHelper and
+-- 'optionalFieldHelper'.
+data FieldProfile sub y a = FieldProfile
+    { fpParse :: Text -> Either Text a
+    , fpRender :: a -> Text
+    -- | ID, name, value, required
+    , fpWidget :: Text -> Text -> Text -> Bool -> GWidget sub y ()
+    }
+
+type Form sub y = GForm sub y (GWidget sub y ())
+type Formlet sub y a = Maybe a -> Form sub y a
+type FormField sub y = GForm sub y [FieldInfo sub y]
+type FormletField sub y a = Maybe a -> FormField sub y a
+type FormInput sub y = GForm sub y [GWidget sub y ()]
+
+-- | Add a validation check to a form.
+--
+-- Note that if there is a validation error, this message will /not/
+-- automatically appear on the form; for that, you need to use 'checkField'.
+checkForm :: (a -> FormResult b) -> GForm s m x a -> GForm s m x b
+checkForm f (GForm form) = GForm $ do
+    (res, xml, enc) <- form
+    let res' = case res of
+                    FormSuccess a -> f a
+                    FormFailure e -> FormFailure e
+                    FormMissing -> FormMissing
+    return (res', xml, enc)
+
+-- | Add a validation check to a 'FormField'.
+--
+-- Unlike 'checkForm', the validation error will appear in the generated HTML
+-- of the form.
+checkField :: (a -> Either Text b) -> FormField s m a -> FormField s m b
+checkField f (GForm form) = GForm $ do
+    (res, xml, enc) <- form
+    let (res', merr) =
+            case res of
+                FormSuccess a ->
+                    case f a of
+                        Left e -> (FormFailure [e], Just e)
+                        Right x -> (FormSuccess x, Nothing)
+                FormFailure e -> (FormFailure e, Nothing)
+                FormMissing -> (FormMissing, Nothing)
+    let xml' =
+            case merr of
+                Nothing -> xml
+                Just err -> flip map xml $ \fi -> fi
+                    { fiErrors = Just $
+                        case fiErrors fi of
+                            Nothing -> toHtml err
+                            Just x -> x
+                    }
+    return (res', xml', enc)
+
+askParams :: Monad m => StateT Ints (ReaderT Env m) Env
+askParams = lift ask
+
+askFiles :: Monad m => StateT Ints (ReaderT Env (ReaderT FileEnv m)) FileEnv
+askFiles = lift $ lift ask
+
+liftForm :: Monad m => m a -> StateT Ints (ReaderT Env (ReaderT FileEnv m)) a
+liftForm = lift . lift . lift
Yesod/Form/Fields.hs view
@@ -1,509 +1,509 @@-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}-module Yesod.Form.Fields-    ( -- * Fields-      -- ** Required-      stringField-    , passwordField-    , textareaField-    , hiddenField-    , intField-    , doubleField-    , dayField-    , timeField-    , htmlField-    , selectField-    , radioField-    , boolField-    , emailField-    , searchField-    , urlField-    , fileField-      -- ** Optional-    , maybeStringField-    , maybePasswordField-    , maybeTextareaField-    , maybeHiddenField-    , maybeIntField-    , maybeDoubleField-    , maybeDayField-    , maybeTimeField-    , maybeHtmlField-    , maybeSelectField-    , maybeRadioField-    , maybeEmailField-    , maybeSearchField-    , maybeUrlField-    , maybeFileField-      -- * Inputs-      -- ** Required-    , stringInput-    , intInput-    , boolInput-    , dayInput-    , emailInput-    , urlInput-      -- ** Optional-    , maybeStringInput-    , maybeDayInput-    , maybeIntInput-    ) where--import Yesod.Form.Core-import Yesod.Form.Profiles-import Yesod.Request (FileInfo)-import Yesod.Widget (GWidget)-import Control.Monad.Trans.Class (lift)-import Control.Monad.Trans.Reader (ask)-import Data.Time (Day, TimeOfDay)-import Text.Hamlet-import Data.Monoid-import Control.Monad (join)-import Data.Maybe (fromMaybe, isNothing)-import Data.Text (Text, unpack)-import qualified Data.Text as T--#if __GLASGOW_HASKELL__ >= 700-#define HAMLET hamlet-#else-#define HAMLET $hamlet-#endif--stringField :: (IsForm f, FormType f ~ Text)-            => FormFieldSettings -> Maybe Text -> f-stringField = requiredFieldHelper stringFieldProfile--maybeStringField :: (IsForm f, FormType f ~ Maybe Text)-                 => FormFieldSettings -> Maybe (Maybe Text) -> f-maybeStringField = optionalFieldHelper stringFieldProfile--passwordField :: (IsForm f, FormType f ~ Text)-              => FormFieldSettings -> Maybe Text -> f-passwordField = requiredFieldHelper passwordFieldProfile--maybePasswordField :: (IsForm f, FormType f ~ Maybe Text)-                   => FormFieldSettings -> Maybe (Maybe Text) -> f-maybePasswordField = optionalFieldHelper passwordFieldProfile--intInput :: Integral i => Text -> FormInput sub master i-intInput n =-    mapFormXml fieldsToInput $-    requiredFieldHelper intFieldProfile (nameSettings n) Nothing--maybeIntInput :: Integral i => Text -> FormInput sub master (Maybe i)-maybeIntInput n =-    mapFormXml fieldsToInput $-    optionalFieldHelper intFieldProfile (nameSettings n) Nothing--intField :: (Integral (FormType f), IsForm f)-         => FormFieldSettings -> Maybe (FormType f) -> f-intField = requiredFieldHelper intFieldProfile--maybeIntField :: (Integral i, FormType f ~ Maybe i, IsForm f)-              => FormFieldSettings -> Maybe (FormType f) -> f-maybeIntField = optionalFieldHelper intFieldProfile--doubleField :: (IsForm f, FormType f ~ Double)-            => FormFieldSettings -> Maybe Double -> f-doubleField = requiredFieldHelper doubleFieldProfile--maybeDoubleField :: (IsForm f, FormType f ~ Maybe Double)-                 => FormFieldSettings -> Maybe (Maybe Double) -> f-maybeDoubleField = optionalFieldHelper doubleFieldProfile--dayField :: (IsForm f, FormType f ~ Day)-         => FormFieldSettings -> Maybe Day -> f-dayField = requiredFieldHelper dayFieldProfile--maybeDayField :: (IsForm f, FormType f ~ Maybe Day)-              => FormFieldSettings -> Maybe (Maybe Day) -> f-maybeDayField = optionalFieldHelper dayFieldProfile--timeField :: (IsForm f, FormType f ~ TimeOfDay)-          => FormFieldSettings -> Maybe TimeOfDay -> f-timeField = requiredFieldHelper timeFieldProfile--maybeTimeField :: (IsForm f, FormType f ~ Maybe TimeOfDay)-               => FormFieldSettings -> Maybe (Maybe TimeOfDay) -> f-maybeTimeField = optionalFieldHelper timeFieldProfile--boolField :: (IsForm f, FormType f ~ Bool)-          => FormFieldSettings -> Maybe Bool -> f-boolField ffs orig = toForm $ do-    env <- askParams-    let label = ffsLabel ffs-        tooltip = ffsTooltip ffs-    name <- maybe newFormIdent return $ ffsName ffs-    theId <- maybe newFormIdent return $ ffsId ffs-    let (res, val) =-            if null env-                then (FormMissing, fromMaybe False orig)-                else case lookup name env of-                        Nothing -> (FormSuccess False, False)-                        Just "" -> (FormSuccess False, False)-                        Just "false" -> (FormSuccess False, False)-                        Just _ -> (FormSuccess True, True)-    let fi = FieldInfo-            { fiLabel = toHtml label-            , fiTooltip = tooltip-            , fiIdent = theId-            , fiInput = [HAMLET|-<input id="#{theId}" type="checkbox" name="#{name}" :val:checked="">-|]-            , fiErrors = case res of-                            FormFailure [x] -> Just $ toHtml x-                            _ -> Nothing-            , fiRequired = True-            }-    return (res, fi, UrlEncoded)--htmlField :: (IsForm f, FormType f ~ Html)-          => FormFieldSettings -> Maybe Html -> f-htmlField = requiredFieldHelper htmlFieldProfile--maybeHtmlField :: (IsForm f, FormType f ~ Maybe Html)-               => FormFieldSettings -> Maybe (Maybe Html) -> f-maybeHtmlField = optionalFieldHelper htmlFieldProfile--selectField :: (Eq x, IsForm f, FormType f ~ x)-            => [(x, Text)]-            -> FormFieldSettings-            -> Maybe x-            -> f-selectField pairs ffs initial = toForm $ do-    env <- askParams-    let label = ffsLabel ffs-        tooltip = ffsTooltip ffs-    theId <- maybe newFormIdent return $ ffsId ffs-    name <- maybe newFormIdent return $ ffsName ffs-    let pairs' = zip [1 :: Int ..] pairs-    let res = case lookup name env of-                Nothing -> FormMissing-                Just "none" -> FormFailure ["Field is required"]-                Just x ->-                    case reads $ unpack x of-                        (x', _):_ ->-                            case lookup x' pairs' of-                                Nothing -> FormFailure ["Invalid entry"]-                                Just (y, _) -> FormSuccess y-                        [] -> FormFailure ["Invalid entry"]-    let isSelected x =-            case res of-                FormSuccess y -> x == y-                _ -> Just x == initial-    let input =-#if __GLASGOW_HASKELL__ >= 700-                [hamlet|-#else-                [$hamlet|-#endif-<select id="#{theId}" name="#{name}">-    <option value="none">-    $forall pair <- pairs'-        <option value="#{show (fst pair)}" :isSelected (fst (snd pair)):selected="">#{snd (snd pair)}-|]-    let fi = FieldInfo-            { fiLabel = toHtml label-            , fiTooltip = tooltip-            , fiIdent = theId-            , fiInput = input-            , fiErrors = case res of-                            FormFailure [x] -> Just $ toHtml x-                            _ -> Nothing-            , fiRequired = True-            }-    return (res, fi, UrlEncoded)--maybeSelectField :: (Eq x, IsForm f, Maybe x ~ FormType f)-                 => [(x, Text)]-                 -> FormFieldSettings-                 -> Maybe (FormType f)-                 -> f-maybeSelectField pairs ffs initial' = toForm $ do-    env <- askParams-    let initial = join initial'-        label = ffsLabel ffs-        tooltip = ffsTooltip ffs-    theId <- maybe newFormIdent return $ ffsId ffs-    name <- maybe newFormIdent return $ ffsName ffs-    let pairs' = zip [1 :: Int ..] pairs-    let res = case lookup name env of-                Nothing -> FormMissing-                Just "none" -> FormSuccess Nothing-                Just x ->-                    case reads $ unpack x of-                        (x', _):_ ->-                            case lookup x' pairs' of-                                Nothing -> FormFailure ["Invalid entry"]-                                Just (y, _) -> FormSuccess $ Just y-                        [] -> FormFailure ["Invalid entry"]-    let isSelected x =-            case res of-                FormSuccess y -> Just x == y-                _ -> Just x == initial-    let input =-#if __GLASGOW_HASKELL__ >= 700-                [hamlet|-#else-                [$hamlet|-#endif-<select id="#{theId}" name="#{name}">-    <option value="none">-    $forall pair <- pairs'-        <option value="#{show (fst pair)}" :isSelected (fst (snd pair)):selected="">#{snd (snd pair)}-|]-    let fi = FieldInfo-            { fiLabel = toHtml label-            , fiTooltip = tooltip-            , fiIdent = theId-            , fiInput = input-            , fiErrors = case res of-                            FormFailure [x] -> Just $ toHtml x-                            _ -> Nothing-            , fiRequired = False-            }-    return (res, fi, UrlEncoded)--stringInput :: Text -> FormInput sub master Text-stringInput n =-    mapFormXml fieldsToInput $-    requiredFieldHelper stringFieldProfile (nameSettings n) Nothing--maybeStringInput :: Text -> FormInput sub master (Maybe Text)-maybeStringInput n =-    mapFormXml fieldsToInput $-    optionalFieldHelper stringFieldProfile (nameSettings n) Nothing--boolInput :: Text -> FormInput sub master Bool-boolInput n = GForm $ do-    env <- askParams-    let res = case lookup n env of-                Nothing -> FormSuccess False-                Just "" -> FormSuccess False-                Just "false" -> FormSuccess False-                Just _ -> FormSuccess True-    let xml = [HAMLET|-    <input id="#{n}" type="checkbox" name="#{n}">-|]-    return (res, [xml], UrlEncoded)--dayInput :: Text -> FormInput sub master Day-dayInput n =-    mapFormXml fieldsToInput $-    requiredFieldHelper dayFieldProfile (nameSettings n) Nothing--maybeDayInput :: Text -> FormInput sub master (Maybe Day)-maybeDayInput n =-    mapFormXml fieldsToInput $-    optionalFieldHelper dayFieldProfile (nameSettings n) Nothing--nameSettings :: Text -> FormFieldSettings-nameSettings n = FormFieldSettings mempty mempty (Just n) (Just n)--urlField :: (IsForm f, FormType f ~ Text)-         => FormFieldSettings -> Maybe Text -> f-urlField = requiredFieldHelper urlFieldProfile--maybeUrlField :: (IsForm f, FormType f ~ Maybe Text)-               => FormFieldSettings -> Maybe (Maybe Text) -> f-maybeUrlField = optionalFieldHelper urlFieldProfile--urlInput :: Text -> FormInput sub master Text-urlInput n =-    mapFormXml fieldsToInput $-    requiredFieldHelper urlFieldProfile (nameSettings n) Nothing--emailField :: (IsForm f, FormType f ~ Text)-           => FormFieldSettings -> Maybe Text -> f-emailField = requiredFieldHelper emailFieldProfile--maybeEmailField :: (IsForm f, FormType f ~ Maybe Text)-                => FormFieldSettings -> Maybe (Maybe Text) -> f-maybeEmailField = optionalFieldHelper emailFieldProfile--emailInput :: Text -> FormInput sub master Text-emailInput n =-    mapFormXml fieldsToInput $-    requiredFieldHelper emailFieldProfile (nameSettings n) Nothing--searchField :: (IsForm f, FormType f ~ Text)-           => AutoFocus -> FormFieldSettings -> Maybe Text -> f-searchField = requiredFieldHelper . searchFieldProfile--maybeSearchField :: (IsForm f, FormType f ~ Maybe Text)-                => AutoFocus -> FormFieldSettings -> Maybe (Maybe Text) -> f-maybeSearchField = optionalFieldHelper . searchFieldProfile--textareaField :: (IsForm f, FormType f ~ Textarea)-              => FormFieldSettings -> Maybe Textarea -> f-textareaField = requiredFieldHelper textareaFieldProfile--maybeTextareaField :: FormFieldSettings -> FormletField sub y (Maybe Textarea)-maybeTextareaField = optionalFieldHelper textareaFieldProfile--hiddenField :: (IsForm f, FormType f ~ Text)-            => FormFieldSettings -> Maybe Text -> f-hiddenField = requiredFieldHelper hiddenFieldProfile--maybeHiddenField :: (IsForm f, FormType f ~ Maybe Text)-                 => FormFieldSettings -> Maybe (Maybe Text) -> f-maybeHiddenField = optionalFieldHelper hiddenFieldProfile--fileField :: (IsForm f, FormType f ~ FileInfo)-          => FormFieldSettings -> f-fileField ffs = toForm $ do-    env <- lift ask-    fenv <- lift $ lift ask-    let (FormFieldSettings label tooltip theId' name') = ffs-    name <- maybe newFormIdent return name'-    theId <- maybe newFormIdent return theId'-    let res =-            if null env && null fenv-                then FormMissing-                else case lookup name fenv of-                        Nothing -> FormFailure ["File is required"]-                        Just x -> FormSuccess x-    let fi = FieldInfo-            { fiLabel = toHtml label-            , fiTooltip = tooltip-            , fiIdent = theId-            , fiInput = fileWidget theId name True-            , fiErrors = case res of-                            FormFailure [x] -> Just $ toHtml x-                            _ -> Nothing-            , fiRequired = True-            }-    let res' = case res of-                FormFailure [e] -> FormFailure [T.concat [label, ": ", e]]-                _ -> res-    return (res', fi, Multipart)--maybeFileField :: (IsForm f, FormType f ~ Maybe FileInfo)-               => FormFieldSettings -> f-maybeFileField ffs = toForm $ do-    fenv <- lift $ lift ask-    let (FormFieldSettings label tooltip theId' name') = ffs-    name <- maybe newFormIdent return name'-    theId <- maybe newFormIdent return theId'-    let res = FormSuccess $ lookup name fenv-    let fi = FieldInfo-            { fiLabel = toHtml label-            , fiTooltip = tooltip-            , fiIdent = theId-            , fiInput = fileWidget theId name False-            , fiErrors = Nothing-            , fiRequired = True-            }-    return (res, fi, Multipart)--fileWidget :: Text -> Text -> Bool -> GWidget s m ()-fileWidget theId name isReq = [HAMLET|-<input id="#{theId}" type="file" name="#{name}" :isReq:required="">-|]--radioField :: (Eq x, IsForm f, FormType f ~ x)-           => [(x, Text)]-           -> FormFieldSettings-           -> Maybe x-           -> f-radioField pairs ffs initial = toForm $ do-    env <- askParams-    let label = ffsLabel ffs-        tooltip = ffsTooltip ffs-    theId <- maybe newFormIdent return $ ffsId ffs-    name <- maybe newFormIdent return $ ffsName ffs-    let pairs' = zip [1 :: Int ..] pairs-    let res = case lookup name env of-                Nothing -> FormMissing-                Just "none" -> FormFailure ["Field is required"]-                Just x ->-                    case reads $ unpack x of-                        (x', _):_ ->-                            case lookup x' pairs' of-                                Nothing -> FormFailure ["Invalid entry"]-                                Just (y, _) -> FormSuccess y-                        [] -> FormFailure ["Invalid entry"]-    let isSelected x =-            case res of-                FormSuccess y -> x == y-                _ -> Just x == initial-    let input = [HAMLET|-<div id="#{theId}">-   $forall pair <- pairs'-       <div>-           <input id="#{theId}-#{show (fst pair)}" type="radio" name="#{name}" value="#{show (fst pair)}" :isSelected (fst (snd pair)):checked="">-           <label for="#{name}-#{show (fst pair)}">#{snd (snd pair)}-|]-    let fi = FieldInfo-           { fiLabel = toHtml label-           , fiTooltip = tooltip-           , fiIdent = theId-           , fiInput = input-           , fiErrors = case res of-                           FormFailure [x] -> Just $ toHtml x-                           _ -> Nothing-           , fiRequired = True-           }-    return (res, fi, UrlEncoded)--maybeRadioField-    :: (Eq x, IsForm f, FormType f ~ Maybe x)-    => [(x, Text)]-    -> FormFieldSettings-    -> Maybe (FormType f)-    -> f-maybeRadioField pairs ffs initial' = toForm $ do-    env <- askParams-    let initial = join initial'-        label = ffsLabel ffs-        tooltip = ffsTooltip ffs-    theId <- maybe newFormIdent return $ ffsId ffs-    name <- maybe newFormIdent return $ ffsName ffs-    let pairs' = zip [1 :: Int ..] pairs-    let res = case lookup name env of-                Nothing -> FormMissing-                Just "none" -> FormSuccess Nothing-                Just x ->-                    case reads $ unpack x of-                        (x', _):_ ->-                            case lookup x' pairs' of-                                Nothing -> FormFailure ["Invalid entry"]-                                Just (y, _) -> FormSuccess $ Just y-                        [] -> FormFailure ["Invalid entry"]-    let isSelected x =-            case res of-                FormSuccess y -> Just x == y-                _ -> Just x == initial-    let isNone =-            case res of-                FormSuccess Nothing -> True-                FormSuccess Just{} -> False-                _ -> isNothing initial-    let input =-#if __GLASGOW_HASKELL__ >= 700-                [hamlet|-#else-                [$hamlet|-#endif-<div id="#{theId}">-   $forall pair <- pairs'-       <div>-           <input id="#{theId}-none" type="radio" name="#{name}" value="none" :isNone:checked="">None-       <div>-           <input id="#{theId}-#{show (fst pair)}" type="radio" name="#{name}" value="#{show (fst pair)}" :isSelected (fst (snd pair)):checked="">-           <label for="#{name}-#{show (fst pair)}">#{snd (snd pair)}-|]-    let fi = FieldInfo-           { fiLabel = toHtml label-           , fiTooltip = tooltip-           , fiIdent = theId-           , fiInput = input-           , fiErrors = case res of-                           FormFailure [x] -> Just $ toHtml x-                           _ -> Nothing-           , fiRequired = False-           }-    return (res, fi, UrlEncoded)+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Yesod.Form.Fields
+    ( -- * Fields
+      -- ** Required
+      stringField
+    , passwordField
+    , textareaField
+    , hiddenField
+    , intField
+    , doubleField
+    , dayField
+    , timeField
+    , htmlField
+    , selectField
+    , radioField
+    , boolField
+    , emailField
+    , searchField
+    , urlField
+    , fileField
+      -- ** Optional
+    , maybeStringField
+    , maybePasswordField
+    , maybeTextareaField
+    , maybeHiddenField
+    , maybeIntField
+    , maybeDoubleField
+    , maybeDayField
+    , maybeTimeField
+    , maybeHtmlField
+    , maybeSelectField
+    , maybeRadioField
+    , maybeEmailField
+    , maybeSearchField
+    , maybeUrlField
+    , maybeFileField
+      -- * Inputs
+      -- ** Required
+    , stringInput
+    , intInput
+    , boolInput
+    , dayInput
+    , emailInput
+    , urlInput
+      -- ** Optional
+    , maybeStringInput
+    , maybeDayInput
+    , maybeIntInput
+    ) where
+
+import Yesod.Form.Core
+import Yesod.Form.Profiles
+import Yesod.Request (FileInfo)
+import Yesod.Widget (GWidget)
+import Control.Monad.Trans.Class (lift)
+import Control.Monad.Trans.Reader (ask)
+import Data.Time (Day, TimeOfDay)
+import Text.Hamlet
+import Data.Monoid
+import Control.Monad (join)
+import Data.Maybe (fromMaybe, isNothing)
+import Data.Text (Text, unpack)
+import qualified Data.Text as T
+
+#if __GLASGOW_HASKELL__ >= 700
+#define HAMLET hamlet
+#else
+#define HAMLET $hamlet
+#endif
+
+stringField :: (IsForm f, FormType f ~ Text)
+            => FormFieldSettings -> Maybe Text -> f
+stringField = requiredFieldHelper stringFieldProfile
+
+maybeStringField :: (IsForm f, FormType f ~ Maybe Text)
+                 => FormFieldSettings -> Maybe (Maybe Text) -> f
+maybeStringField = optionalFieldHelper stringFieldProfile
+
+passwordField :: (IsForm f, FormType f ~ Text)
+              => FormFieldSettings -> Maybe Text -> f
+passwordField = requiredFieldHelper passwordFieldProfile
+
+maybePasswordField :: (IsForm f, FormType f ~ Maybe Text)
+                   => FormFieldSettings -> Maybe (Maybe Text) -> f
+maybePasswordField = optionalFieldHelper passwordFieldProfile
+
+intInput :: Integral i => Text -> FormInput sub master i
+intInput n =
+    mapFormXml fieldsToInput $
+    requiredFieldHelper intFieldProfile (nameSettings n) Nothing
+
+maybeIntInput :: Integral i => Text -> FormInput sub master (Maybe i)
+maybeIntInput n =
+    mapFormXml fieldsToInput $
+    optionalFieldHelper intFieldProfile (nameSettings n) Nothing
+
+intField :: (Integral (FormType f), IsForm f)
+         => FormFieldSettings -> Maybe (FormType f) -> f
+intField = requiredFieldHelper intFieldProfile
+
+maybeIntField :: (Integral i, FormType f ~ Maybe i, IsForm f)
+              => FormFieldSettings -> Maybe (FormType f) -> f
+maybeIntField = optionalFieldHelper intFieldProfile
+
+doubleField :: (IsForm f, FormType f ~ Double)
+            => FormFieldSettings -> Maybe Double -> f
+doubleField = requiredFieldHelper doubleFieldProfile
+
+maybeDoubleField :: (IsForm f, FormType f ~ Maybe Double)
+                 => FormFieldSettings -> Maybe (Maybe Double) -> f
+maybeDoubleField = optionalFieldHelper doubleFieldProfile
+
+dayField :: (IsForm f, FormType f ~ Day)
+         => FormFieldSettings -> Maybe Day -> f
+dayField = requiredFieldHelper dayFieldProfile
+
+maybeDayField :: (IsForm f, FormType f ~ Maybe Day)
+              => FormFieldSettings -> Maybe (Maybe Day) -> f
+maybeDayField = optionalFieldHelper dayFieldProfile
+
+timeField :: (IsForm f, FormType f ~ TimeOfDay)
+          => FormFieldSettings -> Maybe TimeOfDay -> f
+timeField = requiredFieldHelper timeFieldProfile
+
+maybeTimeField :: (IsForm f, FormType f ~ Maybe TimeOfDay)
+               => FormFieldSettings -> Maybe (Maybe TimeOfDay) -> f
+maybeTimeField = optionalFieldHelper timeFieldProfile
+
+boolField :: (IsForm f, FormType f ~ Bool)
+          => FormFieldSettings -> Maybe Bool -> f
+boolField ffs orig = toForm $ do
+    env <- askParams
+    let label = ffsLabel ffs
+        tooltip = ffsTooltip ffs
+    name <- maybe newFormIdent return $ ffsName ffs
+    theId <- maybe newFormIdent return $ ffsId ffs
+    let (res, val) =
+            if null env
+                then (FormMissing, fromMaybe False orig)
+                else case lookup name env of
+                        Nothing -> (FormSuccess False, False)
+                        Just "" -> (FormSuccess False, False)
+                        Just "false" -> (FormSuccess False, False)
+                        Just _ -> (FormSuccess True, True)
+    let fi = FieldInfo
+            { fiLabel = toHtml label
+            , fiTooltip = tooltip
+            , fiIdent = theId
+            , fiInput = [HAMLET|
+<input id="#{theId}" type="checkbox" name="#{name}" :val:checked="">
+|]
+            , fiErrors = case res of
+                            FormFailure [x] -> Just $ toHtml x
+                            _ -> Nothing
+            , fiRequired = True
+            }
+    return (res, fi, UrlEncoded)
+
+htmlField :: (IsForm f, FormType f ~ Html)
+          => FormFieldSettings -> Maybe Html -> f
+htmlField = requiredFieldHelper htmlFieldProfile
+
+maybeHtmlField :: (IsForm f, FormType f ~ Maybe Html)
+               => FormFieldSettings -> Maybe (Maybe Html) -> f
+maybeHtmlField = optionalFieldHelper htmlFieldProfile
+
+selectField :: (Eq x, IsForm f, FormType f ~ x)
+            => [(x, Text)]
+            -> FormFieldSettings
+            -> Maybe x
+            -> f
+selectField pairs ffs initial = toForm $ do
+    env <- askParams
+    let label = ffsLabel ffs
+        tooltip = ffsTooltip ffs
+    theId <- maybe newFormIdent return $ ffsId ffs
+    name <- maybe newFormIdent return $ ffsName ffs
+    let pairs' = zip [1 :: Int ..] pairs
+    let res = case lookup name env of
+                Nothing -> FormMissing
+                Just "none" -> FormFailure ["Field is required"]
+                Just x ->
+                    case reads $ unpack x of
+                        (x', _):_ ->
+                            case lookup x' pairs' of
+                                Nothing -> FormFailure ["Invalid entry"]
+                                Just (y, _) -> FormSuccess y
+                        [] -> FormFailure ["Invalid entry"]
+    let isSelected x =
+            case res of
+                FormSuccess y -> x == y
+                _ -> Just x == initial
+    let input =
+#if __GLASGOW_HASKELL__ >= 700
+                [hamlet|
+#else
+                [$hamlet|
+#endif
+<select id="#{theId}" name="#{name}">
+    <option value="none">
+    $forall pair <- pairs'
+        <option value="#{show (fst pair)}" :isSelected (fst (snd pair)):selected="">#{snd (snd pair)}
+|]
+    let fi = FieldInfo
+            { fiLabel = toHtml label
+            , fiTooltip = tooltip
+            , fiIdent = theId
+            , fiInput = input
+            , fiErrors = case res of
+                            FormFailure [x] -> Just $ toHtml x
+                            _ -> Nothing
+            , fiRequired = True
+            }
+    return (res, fi, UrlEncoded)
+
+maybeSelectField :: (Eq x, IsForm f, Maybe x ~ FormType f)
+                 => [(x, Text)]
+                 -> FormFieldSettings
+                 -> Maybe (FormType f)
+                 -> f
+maybeSelectField pairs ffs initial' = toForm $ do
+    env <- askParams
+    let initial = join initial'
+        label = ffsLabel ffs
+        tooltip = ffsTooltip ffs
+    theId <- maybe newFormIdent return $ ffsId ffs
+    name <- maybe newFormIdent return $ ffsName ffs
+    let pairs' = zip [1 :: Int ..] pairs
+    let res = case lookup name env of
+                Nothing -> FormMissing
+                Just "none" -> FormSuccess Nothing
+                Just x ->
+                    case reads $ unpack x of
+                        (x', _):_ ->
+                            case lookup x' pairs' of
+                                Nothing -> FormFailure ["Invalid entry"]
+                                Just (y, _) -> FormSuccess $ Just y
+                        [] -> FormFailure ["Invalid entry"]
+    let isSelected x =
+            case res of
+                FormSuccess y -> Just x == y
+                _ -> Just x == initial
+    let input =
+#if __GLASGOW_HASKELL__ >= 700
+                [hamlet|
+#else
+                [$hamlet|
+#endif
+<select id="#{theId}" name="#{name}">
+    <option value="none">
+    $forall pair <- pairs'
+        <option value="#{show (fst pair)}" :isSelected (fst (snd pair)):selected="">#{snd (snd pair)}
+|]
+    let fi = FieldInfo
+            { fiLabel = toHtml label
+            , fiTooltip = tooltip
+            , fiIdent = theId
+            , fiInput = input
+            , fiErrors = case res of
+                            FormFailure [x] -> Just $ toHtml x
+                            _ -> Nothing
+            , fiRequired = False
+            }
+    return (res, fi, UrlEncoded)
+
+stringInput :: Text -> FormInput sub master Text
+stringInput n =
+    mapFormXml fieldsToInput $
+    requiredFieldHelper stringFieldProfile (nameSettings n) Nothing
+
+maybeStringInput :: Text -> FormInput sub master (Maybe Text)
+maybeStringInput n =
+    mapFormXml fieldsToInput $
+    optionalFieldHelper stringFieldProfile (nameSettings n) Nothing
+
+boolInput :: Text -> FormInput sub master Bool
+boolInput n = GForm $ do
+    env <- askParams
+    let res = case lookup n env of
+                Nothing -> FormSuccess False
+                Just "" -> FormSuccess False
+                Just "false" -> FormSuccess False
+                Just _ -> FormSuccess True
+    let xml = [HAMLET|
+    <input id="#{n}" type="checkbox" name="#{n}">
+|]
+    return (res, [xml], UrlEncoded)
+
+dayInput :: Text -> FormInput sub master Day
+dayInput n =
+    mapFormXml fieldsToInput $
+    requiredFieldHelper dayFieldProfile (nameSettings n) Nothing
+
+maybeDayInput :: Text -> FormInput sub master (Maybe Day)
+maybeDayInput n =
+    mapFormXml fieldsToInput $
+    optionalFieldHelper dayFieldProfile (nameSettings n) Nothing
+
+nameSettings :: Text -> FormFieldSettings
+nameSettings n = FormFieldSettings mempty mempty (Just n) (Just n)
+
+urlField :: (IsForm f, FormType f ~ Text)
+         => FormFieldSettings -> Maybe Text -> f
+urlField = requiredFieldHelper urlFieldProfile
+
+maybeUrlField :: (IsForm f, FormType f ~ Maybe Text)
+               => FormFieldSettings -> Maybe (Maybe Text) -> f
+maybeUrlField = optionalFieldHelper urlFieldProfile
+
+urlInput :: Text -> FormInput sub master Text
+urlInput n =
+    mapFormXml fieldsToInput $
+    requiredFieldHelper urlFieldProfile (nameSettings n) Nothing
+
+emailField :: (IsForm f, FormType f ~ Text)
+           => FormFieldSettings -> Maybe Text -> f
+emailField = requiredFieldHelper emailFieldProfile
+
+maybeEmailField :: (IsForm f, FormType f ~ Maybe Text)
+                => FormFieldSettings -> Maybe (Maybe Text) -> f
+maybeEmailField = optionalFieldHelper emailFieldProfile
+
+emailInput :: Text -> FormInput sub master Text
+emailInput n =
+    mapFormXml fieldsToInput $
+    requiredFieldHelper emailFieldProfile (nameSettings n) Nothing
+
+searchField :: (IsForm f, FormType f ~ Text)
+           => AutoFocus -> FormFieldSettings -> Maybe Text -> f
+searchField = requiredFieldHelper . searchFieldProfile
+
+maybeSearchField :: (IsForm f, FormType f ~ Maybe Text)
+                => AutoFocus -> FormFieldSettings -> Maybe (Maybe Text) -> f
+maybeSearchField = optionalFieldHelper . searchFieldProfile
+
+textareaField :: (IsForm f, FormType f ~ Textarea)
+              => FormFieldSettings -> Maybe Textarea -> f
+textareaField = requiredFieldHelper textareaFieldProfile
+
+maybeTextareaField :: FormFieldSettings -> FormletField sub y (Maybe Textarea)
+maybeTextareaField = optionalFieldHelper textareaFieldProfile
+
+hiddenField :: (IsForm f, FormType f ~ Text)
+            => FormFieldSettings -> Maybe Text -> f
+hiddenField = requiredFieldHelper hiddenFieldProfile
+
+maybeHiddenField :: (IsForm f, FormType f ~ Maybe Text)
+                 => FormFieldSettings -> Maybe (Maybe Text) -> f
+maybeHiddenField = optionalFieldHelper hiddenFieldProfile
+
+fileField :: (IsForm f, FormType f ~ FileInfo)
+          => FormFieldSettings -> f
+fileField ffs = toForm $ do
+    env <- lift ask
+    fenv <- lift $ lift ask
+    let (FormFieldSettings label tooltip theId' name') = ffs
+    name <- maybe newFormIdent return name'
+    theId <- maybe newFormIdent return theId'
+    let res =
+            if null env && null fenv
+                then FormMissing
+                else case lookup name fenv of
+                        Nothing -> FormFailure ["File is required"]
+                        Just x -> FormSuccess x
+    let fi = FieldInfo
+            { fiLabel = toHtml label
+            , fiTooltip = tooltip
+            , fiIdent = theId
+            , fiInput = fileWidget theId name True
+            , fiErrors = case res of
+                            FormFailure [x] -> Just $ toHtml x
+                            _ -> Nothing
+            , fiRequired = True
+            }
+    let res' = case res of
+                FormFailure [e] -> FormFailure [T.concat [label, ": ", e]]
+                _ -> res
+    return (res', fi, Multipart)
+
+maybeFileField :: (IsForm f, FormType f ~ Maybe FileInfo)
+               => FormFieldSettings -> f
+maybeFileField ffs = toForm $ do
+    fenv <- lift $ lift ask
+    let (FormFieldSettings label tooltip theId' name') = ffs
+    name <- maybe newFormIdent return name'
+    theId <- maybe newFormIdent return theId'
+    let res = FormSuccess $ lookup name fenv
+    let fi = FieldInfo
+            { fiLabel = toHtml label
+            , fiTooltip = tooltip
+            , fiIdent = theId
+            , fiInput = fileWidget theId name False
+            , fiErrors = Nothing
+            , fiRequired = True
+            }
+    return (res, fi, Multipart)
+
+fileWidget :: Text -> Text -> Bool -> GWidget s m ()
+fileWidget theId name isReq = [HAMLET|
+<input id="#{theId}" type="file" name="#{name}" :isReq:required="">
+|]
+
+radioField :: (Eq x, IsForm f, FormType f ~ x)
+           => [(x, Text)]
+           -> FormFieldSettings
+           -> Maybe x
+           -> f
+radioField pairs ffs initial = toForm $ do
+    env <- askParams
+    let label = ffsLabel ffs
+        tooltip = ffsTooltip ffs
+    theId <- maybe newFormIdent return $ ffsId ffs
+    name <- maybe newFormIdent return $ ffsName ffs
+    let pairs' = zip [1 :: Int ..] pairs
+    let res = case lookup name env of
+                Nothing -> FormMissing
+                Just "none" -> FormFailure ["Field is required"]
+                Just x ->
+                    case reads $ unpack x of
+                        (x', _):_ ->
+                            case lookup x' pairs' of
+                                Nothing -> FormFailure ["Invalid entry"]
+                                Just (y, _) -> FormSuccess y
+                        [] -> FormFailure ["Invalid entry"]
+    let isSelected x =
+            case res of
+                FormSuccess y -> x == y
+                _ -> Just x == initial
+    let input = [HAMLET|
+<div id="#{theId}">
+   $forall pair <- pairs'
+       <div>
+           <input id="#{theId}-#{show (fst pair)}" type="radio" name="#{name}" value="#{show (fst pair)}" :isSelected (fst (snd pair)):checked="">
+           <label for="#{name}-#{show (fst pair)}">#{snd (snd pair)}
+|]
+    let fi = FieldInfo
+           { fiLabel = toHtml label
+           , fiTooltip = tooltip
+           , fiIdent = theId
+           , fiInput = input
+           , fiErrors = case res of
+                           FormFailure [x] -> Just $ toHtml x
+                           _ -> Nothing
+           , fiRequired = True
+           }
+    return (res, fi, UrlEncoded)
+
+maybeRadioField
+    :: (Eq x, IsForm f, FormType f ~ Maybe x)
+    => [(x, Text)]
+    -> FormFieldSettings
+    -> Maybe (FormType f)
+    -> f
+maybeRadioField pairs ffs initial' = toForm $ do
+    env <- askParams
+    let initial = join initial'
+        label = ffsLabel ffs
+        tooltip = ffsTooltip ffs
+    theId <- maybe newFormIdent return $ ffsId ffs
+    name <- maybe newFormIdent return $ ffsName ffs
+    let pairs' = zip [1 :: Int ..] pairs
+    let res = case lookup name env of
+                Nothing -> FormMissing
+                Just "none" -> FormSuccess Nothing
+                Just x ->
+                    case reads $ unpack x of
+                        (x', _):_ ->
+                            case lookup x' pairs' of
+                                Nothing -> FormFailure ["Invalid entry"]
+                                Just (y, _) -> FormSuccess $ Just y
+                        [] -> FormFailure ["Invalid entry"]
+    let isSelected x =
+            case res of
+                FormSuccess y -> Just x == y
+                _ -> Just x == initial
+    let isNone =
+            case res of
+                FormSuccess Nothing -> True
+                FormSuccess Just{} -> False
+                _ -> isNothing initial
+    let input =
+#if __GLASGOW_HASKELL__ >= 700
+                [hamlet|
+#else
+                [$hamlet|
+#endif
+<div id="#{theId}">
+   $forall pair <- pairs'
+       <div>
+           <input id="#{theId}-none" type="radio" name="#{name}" value="none" :isNone:checked="">None
+       <div>
+           <input id="#{theId}-#{show (fst pair)}" type="radio" name="#{name}" value="#{show (fst pair)}" :isSelected (fst (snd pair)):checked="">
+           <label for="#{name}-#{show (fst pair)}">#{snd (snd pair)}
+|]
+    let fi = FieldInfo
+           { fiLabel = toHtml label
+           , fiTooltip = tooltip
+           , fiIdent = theId
+           , fiInput = input
+           , fiErrors = case res of
+                           FormFailure [x] -> Just $ toHtml x
+                           _ -> Nothing
+           , fiRequired = False
+           }
+    return (res, fi, UrlEncoded)
Yesod/Form/Jquery.hs view
@@ -1,241 +1,241 @@-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}--- | Some fields spiced up with jQuery UI.-module Yesod.Form.Jquery-    ( YesodJquery (..)-    , jqueryDayField-    , maybeJqueryDayField-    , jqueryDayTimeField-    , jqueryDayTimeFieldProfile-    , jqueryAutocompleteField-    , maybeJqueryAutocompleteField-    , jqueryDayFieldProfile-    , googleHostedJqueryUiCss-    , JqueryDaySettings (..)-    , Default (..)-    ) where--import Yesod.Handler-import Yesod.Form.Core-import Yesod.Form.Profiles-import Yesod.Widget-import Data.Time (UTCTime (..), Day, TimeOfDay (..), timeOfDayToTime,-                  timeToTimeOfDay)-import Data.Char (isSpace)-import Data.Default-import Text.Hamlet (hamlet)-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 HAMLET hamlet-#define CASSIUS cassius-#define JULIUS julius-#else-#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"--jqueryDayField :: (IsForm f, FormType f ~ Day, YesodJquery (FormMaster f))-               => JqueryDaySettings-               -> FormFieldSettings-               -> Maybe (FormType f)-               -> f-jqueryDayField = requiredFieldHelper . jqueryDayFieldProfile--maybeJqueryDayField-    :: (IsForm f, FormType f ~ Maybe Day, YesodJquery (FormMaster f))-    => JqueryDaySettings-    -> FormFieldSettings-    -> Maybe (FormType f)-    -> f-maybeJqueryDayField = optionalFieldHelper . jqueryDayFieldProfile--jqueryDayFieldProfile :: YesodJquery y-                      => JqueryDaySettings -> FieldProfile sub y Day-jqueryDayFieldProfile jds = FieldProfile-    { fpParse = maybe-                  (Left "Invalid day, must be in YYYY-MM-DD format")-                  Right-              . readMay-              . unpack-    , fpRender = pack . show-    , fpWidget = \theId name val isReq -> do-        addHtml [HAMLET|\-<input id="#{theId}" name="#{name}" type="date" :isReq:required="" value="#{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-    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--jqueryDayTimeField-    :: (IsForm f, FormType f ~ UTCTime, YesodJquery (FormMaster f))-    => FormFieldSettings-    -> Maybe (FormType f)-    -> f-jqueryDayTimeField = requiredFieldHelper jqueryDayTimeFieldProfile---- 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 (show h) ++ ":" ++ (showLeadingZero minute) ++ " " ++ apm--jqueryDayTimeFieldProfile :: YesodJquery y => FieldProfile sub y UTCTime-jqueryDayTimeFieldProfile = FieldProfile-    { fpParse  = parseUTCTime . unpack-    , fpRender = pack . jqueryDayTimeUTCTime-    , fpWidget = \theId name val isReq -> do-        addHtml [HAMLET|\-<input id="#{theId}" name="#{name}" :isReq:required="" value="#{val}">-|]-        addScript' urlJqueryJs-        addScript' urlJqueryUiJs-        addScript' urlJqueryUiDateTimePicker-        addStylesheet' urlJqueryUiCss-        addJulius [JULIUS|-$(function(){$("##{theId}").datetimepicker({dateFormat : "yyyy/mm/dd h:MM TT"})});-|]-    }--parseUTCTime :: String -> Either Text UTCTime-parseUTCTime s =-    let (dateS, timeS) = break isSpace (dropWhile isSpace s)-        dateE = parseDate dateS-     in case dateE of-            Left l -> Left l-            Right date ->-                ifRight (parseTime timeS)-                    (UTCTime date . timeOfDayToTime)--jqueryAutocompleteField-    :: (IsForm f, FormType f ~ Text, YesodJquery (FormMaster f))-    => Route (FormMaster f)-    -> FormFieldSettings-    -> Maybe (FormType f)-    -> f-jqueryAutocompleteField = requiredFieldHelper . jqueryAutocompleteFieldProfile--maybeJqueryAutocompleteField-    :: (IsForm f, FormType f ~ Maybe Text, YesodJquery (FormMaster f))-    => Route (FormMaster f)-    -> FormFieldSettings-    -> Maybe (FormType f)-    -> f-maybeJqueryAutocompleteField src =-    optionalFieldHelper $ jqueryAutocompleteFieldProfile src--jqueryAutocompleteFieldProfile :: YesodJquery y => Route y -> FieldProfile sub y Text-jqueryAutocompleteFieldProfile src = FieldProfile-    { fpParse = Right-    , fpRender = id-    , fpWidget = \theId name val isReq -> do-        addHtml [HAMLET|\-<input id="#{theId}" name="#{name}" type="text" :isReq:required="" value="#{val}" .autocomplete>-|]-        addScript' urlJqueryJs-        addScript' urlJqueryUiJs-        addStylesheet' urlJqueryUiCss-        addJulius [JULIUS|-$(function(){$("##{theId}").autocomplete({source:"@{src}",minLength:2})});-|]-    }--addScript' :: (y -> Either (Route y) Text) -> GWidget sub y ()-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-        }+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
+-- | Some fields spiced up with jQuery UI.
+module Yesod.Form.Jquery
+    ( YesodJquery (..)
+    , jqueryDayField
+    , maybeJqueryDayField
+    , jqueryDayTimeField
+    , jqueryDayTimeFieldProfile
+    , jqueryAutocompleteField
+    , maybeJqueryAutocompleteField
+    , jqueryDayFieldProfile
+    , googleHostedJqueryUiCss
+    , JqueryDaySettings (..)
+    , Default (..)
+    ) where
+
+import Yesod.Handler
+import Yesod.Form.Core
+import Yesod.Form.Profiles
+import Yesod.Widget
+import Data.Time (UTCTime (..), Day, TimeOfDay (..), timeOfDayToTime,
+                  timeToTimeOfDay)
+import Data.Char (isSpace)
+import Data.Default
+import Text.Hamlet (hamlet)
+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 HAMLET hamlet
+#define CASSIUS cassius
+#define JULIUS julius
+#else
+#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"
+
+jqueryDayField :: (IsForm f, FormType f ~ Day, YesodJquery (FormMaster f))
+               => JqueryDaySettings
+               -> FormFieldSettings
+               -> Maybe (FormType f)
+               -> f
+jqueryDayField = requiredFieldHelper . jqueryDayFieldProfile
+
+maybeJqueryDayField
+    :: (IsForm f, FormType f ~ Maybe Day, YesodJquery (FormMaster f))
+    => JqueryDaySettings
+    -> FormFieldSettings
+    -> Maybe (FormType f)
+    -> f
+maybeJqueryDayField = optionalFieldHelper . jqueryDayFieldProfile
+
+jqueryDayFieldProfile :: YesodJquery y
+                      => JqueryDaySettings -> FieldProfile sub y Day
+jqueryDayFieldProfile jds = FieldProfile
+    { fpParse = maybe
+                  (Left "Invalid day, must be in YYYY-MM-DD format")
+                  Right
+              . readMay
+              . unpack
+    , fpRender = pack . show
+    , fpWidget = \theId name val isReq -> do
+        addHtml [HAMLET|\
+<input id="#{theId}" name="#{name}" type="date" :isReq:required="" value="#{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
+    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
+
+jqueryDayTimeField
+    :: (IsForm f, FormType f ~ UTCTime, YesodJquery (FormMaster f))
+    => FormFieldSettings
+    -> Maybe (FormType f)
+    -> f
+jqueryDayTimeField = requiredFieldHelper jqueryDayTimeFieldProfile
+
+-- 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 (show h) ++ ":" ++ (showLeadingZero minute) ++ " " ++ apm
+
+jqueryDayTimeFieldProfile :: YesodJquery y => FieldProfile sub y UTCTime
+jqueryDayTimeFieldProfile = FieldProfile
+    { fpParse  = parseUTCTime . unpack
+    , fpRender = pack . jqueryDayTimeUTCTime
+    , fpWidget = \theId name val isReq -> do
+        addHtml [HAMLET|\
+<input id="#{theId}" name="#{name}" :isReq:required="" value="#{val}">
+|]
+        addScript' urlJqueryJs
+        addScript' urlJqueryUiJs
+        addScript' urlJqueryUiDateTimePicker
+        addStylesheet' urlJqueryUiCss
+        addJulius [JULIUS|
+$(function(){$("##{theId}").datetimepicker({dateFormat : "yyyy/mm/dd h:MM TT"})});
+|]
+    }
+
+parseUTCTime :: String -> Either Text UTCTime
+parseUTCTime s =
+    let (dateS, timeS) = break isSpace (dropWhile isSpace s)
+        dateE = parseDate dateS
+     in case dateE of
+            Left l -> Left l
+            Right date ->
+                ifRight (parseTime timeS)
+                    (UTCTime date . timeOfDayToTime)
+
+jqueryAutocompleteField
+    :: (IsForm f, FormType f ~ Text, YesodJquery (FormMaster f))
+    => Route (FormMaster f)
+    -> FormFieldSettings
+    -> Maybe (FormType f)
+    -> f
+jqueryAutocompleteField = requiredFieldHelper . jqueryAutocompleteFieldProfile
+
+maybeJqueryAutocompleteField
+    :: (IsForm f, FormType f ~ Maybe Text, YesodJquery (FormMaster f))
+    => Route (FormMaster f)
+    -> FormFieldSettings
+    -> Maybe (FormType f)
+    -> f
+maybeJqueryAutocompleteField src =
+    optionalFieldHelper $ jqueryAutocompleteFieldProfile src
+
+jqueryAutocompleteFieldProfile :: YesodJquery y => Route y -> FieldProfile sub y Text
+jqueryAutocompleteFieldProfile src = FieldProfile
+    { fpParse = Right
+    , fpRender = id
+    , fpWidget = \theId name val isReq -> do
+        addHtml [HAMLET|\
+<input id="#{theId}" name="#{name}" type="text" :isReq:required="" value="#{val}" .autocomplete>
+|]
+        addScript' urlJqueryJs
+        addScript' urlJqueryUiJs
+        addStylesheet' urlJqueryUiCss
+        addJulius [JULIUS|
+$(function(){$("##{theId}").autocomplete({source:"@{src}",minLength:2})});
+|]
+    }
+
+addScript' :: (y -> Either (Route y) Text) -> GWidget sub y ()
+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/Nic.hs view
@@ -1,65 +1,65 @@-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}--- | Provide the user with a rich text editor.-module Yesod.Form.Nic-    ( YesodNic (..)-    , nicHtmlField-    , maybeNicHtmlField-    ) where--import Yesod.Handler-import Yesod.Form.Core-import Yesod.Widget-import Text.HTML.SanitizeXSS (sanitizeBalance)-import Text.Hamlet (Html, hamlet)-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"--nicHtmlField :: (IsForm f, FormType f ~ Html, YesodNic (FormMaster f))-             => FormFieldSettings -> Maybe Html -> f-nicHtmlField = requiredFieldHelper nicHtmlFieldProfile--maybeNicHtmlField-    :: (IsForm f, FormType f ~ Maybe Html, YesodNic (FormMaster f))-    => FormFieldSettings -> Maybe (FormType f) -> f-maybeNicHtmlField = optionalFieldHelper nicHtmlFieldProfile--nicHtmlFieldProfile :: YesodNic y => FieldProfile sub y Html-nicHtmlFieldProfile = FieldProfile-    { fpParse = Right . preEscapedString . sanitizeBalance . unpack -- FIXME-    , fpRender = pack . renderHtml-    , fpWidget = \theId name val _isReq -> do-        addHtml-#if __GLASGOW_HASKELL__ >= 700-                [hamlet|-#else-                [$hamlet|-#endif-    <textarea id="#{theId}" name="#{name}" .html>#{val}-|]-        addScript' urlNicEdit-        addJulius-#if __GLASGOW_HASKELL__ >= 700-                [julius|-#else-                [$julius|-#endif-bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("#{theId}")});-|]-    }--addScript' :: (y -> Either (Route y) Text) -> GWidget sub y ()-addScript' f = do-    y <- lift getYesod-    addScriptEither $ f y+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
+-- | Provide the user with a rich text editor.
+module Yesod.Form.Nic
+    ( YesodNic (..)
+    , nicHtmlField
+    , maybeNicHtmlField
+    ) where
+
+import Yesod.Handler
+import Yesod.Form.Core
+import Yesod.Widget
+import Text.HTML.SanitizeXSS (sanitizeBalance)
+import Text.Hamlet (Html, hamlet)
+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"
+
+nicHtmlField :: (IsForm f, FormType f ~ Html, YesodNic (FormMaster f))
+             => FormFieldSettings -> Maybe Html -> f
+nicHtmlField = requiredFieldHelper nicHtmlFieldProfile
+
+maybeNicHtmlField
+    :: (IsForm f, FormType f ~ Maybe Html, YesodNic (FormMaster f))
+    => FormFieldSettings -> Maybe (FormType f) -> f
+maybeNicHtmlField = optionalFieldHelper nicHtmlFieldProfile
+
+nicHtmlFieldProfile :: YesodNic y => FieldProfile sub y Html
+nicHtmlFieldProfile = FieldProfile
+    { fpParse = Right . preEscapedString . sanitizeBalance . unpack -- FIXME
+    , fpRender = pack . renderHtml
+    , fpWidget = \theId name val _isReq -> do
+        addHtml
+#if __GLASGOW_HASKELL__ >= 700
+                [hamlet|
+#else
+                [$hamlet|
+#endif
+    <textarea id="#{theId}" name="#{name}" .html>#{val}
+|]
+        addScript' urlNicEdit
+        addJulius
+#if __GLASGOW_HASKELL__ >= 700
+                [julius|
+#else
+                [$julius|
+#endif
+bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("#{theId}")});
+|]
+    }
+
+addScript' :: (y -> Either (Route y) Text) -> GWidget sub y ()
+addScript' f = do
+    y <- lift getYesod
+    addScriptEither $ f y
Yesod/Form/Profiles.hs view
@@ -1,251 +1,251 @@-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE CPP #-}-module Yesod.Form.Profiles-    ( stringFieldProfile-    , passwordFieldProfile-    , textareaFieldProfile-    , hiddenFieldProfile-    , intFieldProfile-    , dayFieldProfile-    , timeFieldProfile-    , htmlFieldProfile-    , emailFieldProfile-    , searchFieldProfile-    , AutoFocus-    , urlFieldProfile-    , doubleFieldProfile-    , parseDate-    , parseTime-    , Textarea (..)-    ) where--import Yesod.Form.Core-import Yesod.Widget-import Text.Hamlet hiding (renderHtml)-import Text.Blaze (ToHtml (..))-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)--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)--#if __GLASGOW_HASKELL__ >= 700-#define HAMLET hamlet-#define CASSIUS cassius-#define JULIUS julius-#else-#define HAMLET $hamlet-#define CASSIUS $cassius-#define JULIUS $julius-#endif--intFieldProfile :: Integral i => FieldProfile sub y i-intFieldProfile = FieldProfile-    { fpParse = maybe (Left "Invalid integer") Right . readMayI . unpack -- FIXME Data.Text.Read-    , fpRender = pack . showI-    , fpWidget = \theId name val isReq -> addHamlet-        [HAMLET|\-<input id="#{theId}" name="#{name}" type="number" :isReq:required="" value="#{val}">-|]-    }-  where-    showI x = show (fromIntegral x :: Integer)-    readMayI s = case reads s of-                    (x, _):_ -> Just $ fromInteger x-                    [] -> Nothing--doubleFieldProfile :: FieldProfile sub y Double-doubleFieldProfile = FieldProfile-    { fpParse = maybe (Left "Invalid number") Right . readMay . unpack -- FIXME use Data.Text.Read-    , fpRender = pack . show-    , fpWidget = \theId name val isReq -> addHamlet-        [HAMLET|\-<input id="#{theId}" name="#{name}" type="text" :isReq:required="" value="#{val}">-|]-    }--dayFieldProfile :: FieldProfile sub y Day-dayFieldProfile = FieldProfile-    { fpParse = parseDate . unpack-    , fpRender = pack . show-    , fpWidget = \theId name val isReq -> addHamlet-        [HAMLET|\-<input id="#{theId}" name="#{name}" type="date" :isReq:required="" value="#{val}">-|]-    }--timeFieldProfile :: FieldProfile sub y TimeOfDay-timeFieldProfile = FieldProfile-    { fpParse = parseTime . unpack-    , fpRender = pack . show . roundFullSeconds-    , fpWidget = \theId name val isReq -> addHamlet-        [HAMLET|\-<input id="#{theId}" name="#{name}" :isReq:required="" value="#{val}">-|]-    }-  where-    roundFullSeconds tod =-        TimeOfDay (todHour tod) (todMin tod) fullSec-      where-        fullSec = fromInteger $ floor $ todSec tod--htmlFieldProfile :: FieldProfile sub y Html-htmlFieldProfile = FieldProfile-    { fpParse = Right . preEscapedString . sanitizeBalance . unpack -- FIXME make changes to xss-sanitize-    , fpRender = pack . renderHtml-    , fpWidget = \theId name val _isReq -> addHamlet-        [HAMLET|\-<textarea id="#{theId}" name="#{name}" .html>#{val}-|]-    }---- | 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--textareaFieldProfile :: FieldProfile sub y Textarea-textareaFieldProfile = FieldProfile-    { fpParse = Right . Textarea-    , fpRender = unTextarea-    , fpWidget = \theId name val _isReq -> addHamlet-        [HAMLET|\-<textarea id="#{theId}" name="#{name}">#{val}-|]-    }--hiddenFieldProfile :: FieldProfile sub y Text-hiddenFieldProfile = FieldProfile-    { fpParse = Right-    , fpRender = id-    , fpWidget = \theId name val _isReq -> addHamlet-        [HAMLET|\-<input type="hidden" id="#{theId}" name="#{name}" value="#{val}">-|]-    }--stringFieldProfile :: FieldProfile sub y Text-stringFieldProfile = FieldProfile-    { fpParse = Right-    , fpRender = id-    , fpWidget = \theId name val isReq -> addHamlet-        [HAMLET|\-<input id="#{theId}" name="#{name}" type="text" :isReq:required="" value="#{val}">-|]-    }--passwordFieldProfile :: FieldProfile s m Text-passwordFieldProfile = FieldProfile-    { fpParse = Right-    , fpRender = id-    , fpWidget = \theId name val isReq -> addHamlet-        [HAMLET|\-<input id="#{theId}" name="#{name}" type="password" :isReq:required="" value="#{val}">-|]-    }--readMay :: Read a => String -> Maybe a-readMay s = case reads s of-                (x, _):_ -> Just x-                [] -> Nothing--parseDate :: String -> Either Text Day-parseDate = maybe (Left "Invalid day, must be in YYYY-MM-DD format") 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 Text 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 "Invalid time, must be in HH:MM[:SS] format"--parseTimeHelper :: (Char, Char, Char, Char, Char, Char)-                -> Either Text TimeOfDay-parseTimeHelper (h1, h2, m1, m2, s1, s2)-    | h < 0 || h > 23 = Left $ pack $ "Invalid hour: " ++ show h-    | m < 0 || m > 59 = Left $ pack $ "Invalid minute: " ++ show m-    | s < 0 || s > 59 = Left $ pack $ "Invalid second: " ++ show s-    | otherwise = Right $ TimeOfDay h m s-  where-    h = read [h1, h2]-    m = read [m1, m2]-    s = fromInteger $ read [s1, s2]--emailFieldProfile :: FieldProfile s y Text-emailFieldProfile = FieldProfile-    { fpParse = \s -> if Email.isValid (unpack s)-                        then Right s-                        else Left "Invalid e-mail address"-    , fpRender = id-    , fpWidget = \theId name val isReq -> addHamlet-        [HAMLET|\-<input id="#{theId}" name="#{name}" type="email" :isReq:required="" value="#{val}">-|]-    }--type AutoFocus = Bool-searchFieldProfile :: AutoFocus -> FieldProfile s y Text-searchFieldProfile autoFocus = FieldProfile-    { fpParse = Right-    , fpRender = id-    , fpWidget = \theId name val isReq -> do-        addHtml [HAMLET|\-<input id="#{theId}" name="#{name}" type="search" :isReq:required="" :autoFocus:autofocus="" value="#{val}">-|]-        when autoFocus $ do-          addHtml $ [HAMLET|\<script>if (!('autofocus' in document.createElement('input'))) {document.getElementById('#{theId}').focus();}</script> -|]-          addCassius [CASSIUS|-            #{theId}-              -webkit-appearance: textfield-            |]-    }--urlFieldProfile :: FieldProfile s y Text-urlFieldProfile = FieldProfile-    { fpParse = \s -> case parseURI $ unpack s of-                        Nothing -> Left "Invalid URL"-                        Just _ -> Right s-    , fpRender = id-    , fpWidget = \theId name val isReq -> addHamlet-        [HAMLET|\-<input id="#{theId}" name="#{name}" type="url" :isReq:required="" value="#{val}">-|]-    }+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE CPP #-}
+module Yesod.Form.Profiles
+    ( stringFieldProfile
+    , passwordFieldProfile
+    , textareaFieldProfile
+    , hiddenFieldProfile
+    , intFieldProfile
+    , dayFieldProfile
+    , timeFieldProfile
+    , htmlFieldProfile
+    , emailFieldProfile
+    , searchFieldProfile
+    , AutoFocus
+    , urlFieldProfile
+    , doubleFieldProfile
+    , parseDate
+    , parseTime
+    , Textarea (..)
+    ) where
+
+import Yesod.Form.Core
+import Yesod.Widget
+import Text.Hamlet hiding (renderHtml)
+import Text.Blaze (ToHtml (..))
+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)
+
+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)
+
+#if __GLASGOW_HASKELL__ >= 700
+#define HAMLET hamlet
+#define CASSIUS cassius
+#define JULIUS julius
+#else
+#define HAMLET $hamlet
+#define CASSIUS $cassius
+#define JULIUS $julius
+#endif
+
+intFieldProfile :: Integral i => FieldProfile sub y i
+intFieldProfile = FieldProfile
+    { fpParse = maybe (Left "Invalid integer") Right . readMayI . unpack -- FIXME Data.Text.Read
+    , fpRender = pack . showI
+    , fpWidget = \theId name val isReq -> addHamlet
+        [HAMLET|\
+<input id="#{theId}" name="#{name}" type="number" :isReq:required="" value="#{val}">
+|]
+    }
+  where
+    showI x = show (fromIntegral x :: Integer)
+    readMayI s = case reads s of
+                    (x, _):_ -> Just $ fromInteger x
+                    [] -> Nothing
+
+doubleFieldProfile :: FieldProfile sub y Double
+doubleFieldProfile = FieldProfile
+    { fpParse = maybe (Left "Invalid number") Right . readMay . unpack -- FIXME use Data.Text.Read
+    , fpRender = pack . show
+    , fpWidget = \theId name val isReq -> addHamlet
+        [HAMLET|\
+<input id="#{theId}" name="#{name}" type="text" :isReq:required="" value="#{val}">
+|]
+    }
+
+dayFieldProfile :: FieldProfile sub y Day
+dayFieldProfile = FieldProfile
+    { fpParse = parseDate . unpack
+    , fpRender = pack . show
+    , fpWidget = \theId name val isReq -> addHamlet
+        [HAMLET|\
+<input id="#{theId}" name="#{name}" type="date" :isReq:required="" value="#{val}">
+|]
+    }
+
+timeFieldProfile :: FieldProfile sub y TimeOfDay
+timeFieldProfile = FieldProfile
+    { fpParse = parseTime . unpack
+    , fpRender = pack . show . roundFullSeconds
+    , fpWidget = \theId name val isReq -> addHamlet
+        [HAMLET|\
+<input id="#{theId}" name="#{name}" :isReq:required="" value="#{val}">
+|]
+    }
+  where
+    roundFullSeconds tod =
+        TimeOfDay (todHour tod) (todMin tod) fullSec
+      where
+        fullSec = fromInteger $ floor $ todSec tod
+
+htmlFieldProfile :: FieldProfile sub y Html
+htmlFieldProfile = FieldProfile
+    { fpParse = Right . preEscapedString . sanitizeBalance . unpack -- FIXME make changes to xss-sanitize
+    , fpRender = pack . renderHtml
+    , fpWidget = \theId name val _isReq -> addHamlet
+        [HAMLET|\
+<textarea id="#{theId}" name="#{name}" .html>#{val}
+|]
+    }
+
+-- | 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
+
+textareaFieldProfile :: FieldProfile sub y Textarea
+textareaFieldProfile = FieldProfile
+    { fpParse = Right . Textarea
+    , fpRender = unTextarea
+    , fpWidget = \theId name val _isReq -> addHamlet
+        [HAMLET|\
+<textarea id="#{theId}" name="#{name}">#{val}
+|]
+    }
+
+hiddenFieldProfile :: FieldProfile sub y Text
+hiddenFieldProfile = FieldProfile
+    { fpParse = Right
+    , fpRender = id
+    , fpWidget = \theId name val _isReq -> addHamlet
+        [HAMLET|\
+<input type="hidden" id="#{theId}" name="#{name}" value="#{val}">
+|]
+    }
+
+stringFieldProfile :: FieldProfile sub y Text
+stringFieldProfile = FieldProfile
+    { fpParse = Right
+    , fpRender = id
+    , fpWidget = \theId name val isReq -> addHamlet
+        [HAMLET|\
+<input id="#{theId}" name="#{name}" type="text" :isReq:required="" value="#{val}">
+|]
+    }
+
+passwordFieldProfile :: FieldProfile s m Text
+passwordFieldProfile = FieldProfile
+    { fpParse = Right
+    , fpRender = id
+    , fpWidget = \theId name val isReq -> addHamlet
+        [HAMLET|\
+<input id="#{theId}" name="#{name}" type="password" :isReq:required="" value="#{val}">
+|]
+    }
+
+readMay :: Read a => String -> Maybe a
+readMay s = case reads s of
+                (x, _):_ -> Just x
+                [] -> Nothing
+
+parseDate :: String -> Either Text Day
+parseDate = maybe (Left "Invalid day, must be in YYYY-MM-DD format") 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 Text 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 "Invalid time, must be in HH:MM[:SS] format"
+
+parseTimeHelper :: (Char, Char, Char, Char, Char, Char)
+                -> Either Text TimeOfDay
+parseTimeHelper (h1, h2, m1, m2, s1, s2)
+    | h < 0 || h > 23 = Left $ pack $ "Invalid hour: " ++ show h
+    | m < 0 || m > 59 = Left $ pack $ "Invalid minute: " ++ show m
+    | s < 0 || s > 59 = Left $ pack $ "Invalid second: " ++ show s
+    | otherwise = Right $ TimeOfDay h m s
+  where
+    h = read [h1, h2]
+    m = read [m1, m2]
+    s = fromInteger $ read [s1, s2]
+
+emailFieldProfile :: FieldProfile s y Text
+emailFieldProfile = FieldProfile
+    { fpParse = \s -> if Email.isValid (unpack s)
+                        then Right s
+                        else Left "Invalid e-mail address"
+    , fpRender = id
+    , fpWidget = \theId name val isReq -> addHamlet
+        [HAMLET|\
+<input id="#{theId}" name="#{name}" type="email" :isReq:required="" value="#{val}">
+|]
+    }
+
+type AutoFocus = Bool
+searchFieldProfile :: AutoFocus -> FieldProfile s y Text
+searchFieldProfile autoFocus = FieldProfile
+    { fpParse = Right
+    , fpRender = id
+    , fpWidget = \theId name val isReq -> do
+        addHtml [HAMLET|\
+<input id="#{theId}" name="#{name}" type="search" :isReq:required="" :autoFocus:autofocus="" value="#{val}">
+|]
+        when autoFocus $ do
+          addHtml $ [HAMLET|\<script>if (!('autofocus' in document.createElement('input'))) {document.getElementById('#{theId}').focus();}</script> 
+|]
+          addCassius [CASSIUS|
+            #{theId}
+              -webkit-appearance: textfield
+            |]
+    }
+
+urlFieldProfile :: FieldProfile s y Text
+urlFieldProfile = FieldProfile
+    { fpParse = \s -> case parseURI $ unpack s of
+                        Nothing -> Left "Invalid URL"
+                        Just _ -> Right s
+    , fpRender = id
+    , fpWidget = \theId name val isReq -> addHamlet
+        [HAMLET|\
+<input id="#{theId}" name="#{name}" type="url" :isReq:required="" value="#{val}">
+|]
+    }
Yesod/Helpers/Crud.hs view
@@ -1,202 +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)---- | 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-    }+{-# 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.cabal view
@@ -1,43 +1,44 @@-name:            yesod-form-version:         0.1.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.8      && < 0.9-                   , time                      >= 1.1.4    && < 1.3-                   , hamlet                    >= 0.8      && < 0.9-                   , persistent                >= 0.5      && < 0.6-                   , yesod-persistent          >= 0.1      && < 0.2-                   , 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-    exposed-modules: Yesod.Form-                     Yesod.Form.Class-                     Yesod.Form.Core-                     Yesod.Form.Fields-                     Yesod.Form.Jquery-                     Yesod.Form.Nic-                     Yesod.Form.Profiles-                     Yesod.Helpers.Crud-    ghc-options:     -Wall--source-repository head-  type:     git-  location: git://github.com/snoyberg/yesod-form.git+name:            yesod-form
+version:         0.1.0.1
+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.8      && < 0.9
+                   , time                      >= 1.1.4    && < 1.3
+                   , hamlet                    >= 0.8      && < 0.9
+                   , persistent                >= 0.5      && < 0.6
+                   , yesod-persistent          >= 0.1      && < 0.2
+                   , 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
+    exposed-modules: Yesod.Form
+                     Yesod.Form.Class
+                     Yesod.Form.Core
+                     Yesod.Form.Fields
+                     Yesod.Form.Jquery
+                     Yesod.Form.Nic
+                     Yesod.Form.Profiles
+                     Yesod.Helpers.Crud
+    ghc-options:     -Wall
+
+source-repository head
+  type:     git
+  location: git://github.com/snoyberg/yesod-form.git