Split Yesod.Form into subfiles

Yesod/Form.hs

@@ -1,211 +1,50 @@
 {-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE PackageImports #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE TypeSynonymInstances #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
 -- | Parse forms (and query strings).
 module Yesod.Form
     ( -- * Data types
-      GForm (..)
+      GForm
-    , Form
-    , Formlet
-    , FormField
-    , FormletField
-    , FormInput
     , FormResult (..)
     , Enctype (..)
-    , FieldInfo (..)
       -- * Unwrapping functions
     , runFormGet
     , runFormPost
     , runFormGet'
     , runFormPost'
-      -- * Type classes
-    , ToForm (..)
-    , ToFormField (..)
       -- * Field/form helpers
-    , requiredFieldHelper
-    , optionalFieldHelper
-    , mapFormXml
-    , newFormIdent
-    , deeperFormIdent
-    , shallowerFormIdent
     , fieldsToTable
     , fieldsToPlain
-    , fieldsToInput
+    , module Yesod.Form.Fields
-      -- * Field profiles
-    , FieldProfile (..)
-    , stringFieldProfile
-    , textareaFieldProfile
-    , hiddenFieldProfile
-    , intFieldProfile
-    , dayFieldProfile
-    , timeFieldProfile
-    , htmlFieldProfile
-    , emailFieldProfile
-    , urlFieldProfile
-    , FormFieldSettings (..)
-      -- * Pre-built fields
-    , stringField
-    , maybeStringField
-    , textareaField
-    , maybeTextareaField
-    , hiddenField
-    , maybeHiddenField
-    , intField
-    , maybeIntField
-    , doubleField
-    , maybeDoubleField
-    , dayField
-    , maybeDayField
-    , timeField
-    , maybeTimeField
-    , htmlField
-    , maybeHtmlField
-    , selectField
-    , maybeSelectField
-    , boolField
-    , emailField
-    , maybeEmailField
-    , urlField
-    , maybeUrlField
-      -- * Pre-built inputs
-    , stringInput
-    , maybeStringInput
-    , intInput
-    , boolInput
-    , dayInput
-    , maybeDayInput
-    , emailInput
-    , urlInput
       -- * Template Haskell
     , mkToForm
-      -- * Utilities
-    , parseDate
-    , parseTime
     ) where
 
+import Yesod.Form.Core
+import Yesod.Form.Fields
+import Yesod.Form.Class
+
 import Text.Hamlet
 import Yesod.Request
 import Yesod.Handler
 import Control.Applicative hiding (optional)
-import Data.Time (Day, TimeOfDay(..))
 import Data.Maybe (fromMaybe, mapMaybe)
 import "transformers" Control.Monad.IO.Class
-import Control.Monad ((<=<), liftM, join)
+import Control.Monad ((<=<))
-import Data.Monoid (Monoid (..))
 import Control.Monad.Trans.State
 import Language.Haskell.TH.Syntax
 import Database.Persist.Base (EntityDef (..))
 import Data.Char (toUpper, isUpper)
-import Data.Int (Int64)
-import qualified Data.ByteString.Lazy.UTF8 as U
 import Yesod.Widget
 import Control.Arrow ((&&&))
-import qualified Text.Email.Validate as Email
 import Data.List (group, sort)
-import Network.URI (parseURI)
-import Data.String (IsString (..))
-
--- | 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 [String]
-                  | 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
-instance Show Enctype where
-    show UrlEncoded = "application/x-www-form-urlencoded"
-    show Multipart = "multipart/form-data"
-instance Monoid Enctype where
-    mempty = UrlEncoded
-    mappend UrlEncoded UrlEncoded = UrlEncoded
-    mappend _ _ = Multipart
-
-data Ints = IntCons Int Ints | IntSingle Int
-instance Show Ints where
-    show (IntSingle i) = show i
-    show (IntCons i is) = show i ++ '-' : show is
-
-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 sub y xml a = GForm
-    { deform :: Env -> FileEnv -> StateT Ints (GHandler sub y) (FormResult a, xml, Enctype)
-    }
-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 ()]
-
--- | Convert the XML in a 'GForm'.
-mapFormXml :: (xml1 -> xml2) -> GForm s y xml1 a -> GForm s y xml2 a
-mapFormXml f (GForm g) = GForm $ \e fe -> do
-    (res, xml, enc) <- g e fe
-    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 :: String
-    , fiName :: String
-    , fiInput :: GWidget sub y ()
-    , fiErrors :: Maybe Html
-    }
-
-type Env = [(String, String)]
-type FileEnv = [(String, FileInfo)]
-
-instance Monoid xml => Functor (GForm sub url xml) where
-    fmap f (GForm g) =
-        GForm $ \env fe -> liftM (first3 $ fmap f) (g env fe)
-      where
-        first3 f' (x, y, z) = (f' x, y, z)
-
-instance Monoid xml => Applicative (GForm sub url xml) where
-    pure a = GForm $ const $ const $ return (pure a, mempty, mempty)
-    (GForm f) <*> (GForm g) = GForm $ \env fe -> do
-        (f1, f2, f3) <- f env fe
-        (g1, g2, g3) <- g env fe
-        return (f1 <*> g1, f2 `mappend` g2, f3 `mappend` g3)
 
 -- | Display only the actual input widget code, without any decoration.
 fieldsToPlain :: [FieldInfo sub y] -> GWidget sub y ()
 fieldsToPlain = mapM_ fiInput
 
-fieldsToInput :: [FieldInfo sub y] -> [GWidget sub y ()]
-fieldsToInput = map fiInput
-
 -- | Display the label, tooltip, input code and errors in a single row of a
 -- table.
 fieldsToTable :: [FieldInfo sub y] -> GWidget sub y ()
@@ -223,429 +62,6 @@ fieldsToTable = mapM_ go
         %td.errors $err$
 |]
 
-class ToForm a y where
-    toForm :: Maybe a -> Form sub y a
-class ToFormField a y where
-    toFormField :: FormFieldSettings -> Maybe a -> FormField sub y a
-
-data FormFieldSettings = FormFieldSettings
-    { ffsLabel :: Html
-    , ffsTooltip :: Html
-    , ffsId :: Maybe String
-    , ffsName :: Maybe String
-    }
-instance IsString FormFieldSettings where
-    fromString s = FormFieldSettings (string s) mempty Nothing Nothing
-
--- | Create a required field (ie, one that cannot be blank) from a
--- 'FieldProfile'.ngs
-requiredFieldHelper :: FieldProfile sub y a -> FormFieldSettings
-                    -> Maybe a -> FormField sub y a
-requiredFieldHelper (FieldProfile parse render mkXml w) ffs orig =
-  GForm $ \env _ -> do
-    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 = label
-            , fiTooltip = tooltip
-            , fiIdent = theId
-            , fiName = name
-            , fiInput = w theId >> addBody (mkXml theId name val True)
-            , fiErrors = case res of
-                            FormFailure [x] -> Just $ string x
-                            _ -> Nothing
-            }
-    return (res, [fi], UrlEncoded)
-
--- | Create an optional field (ie, one that can be blank) from a
--- 'FieldProfile'.
-optionalFieldHelper :: FieldProfile sub y a -> FormFieldSettings
-                    -> FormletField sub y (Maybe a)
-optionalFieldHelper (FieldProfile parse render mkXml w) ffs orig' =
-  GForm $ \env _ -> do
-    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 = label
-            , fiTooltip = tooltip
-            , fiIdent = theId
-            , fiName = name
-            , fiInput = w theId >> addBody (mkXml theId name val False)
-            , fiErrors = case res of
-                            FormFailure [x] -> Just $ string x
-                            _ -> Nothing
-            }
-    return (res, [fi], UrlEncoded)
-
--- | 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 :: String -> Either String a
-    , fpRender :: a -> String
-    , fpHamlet :: String -> String -> String -> Bool -> Hamlet (Route y)
-    , fpWidget :: String -> GWidget sub y ()
-    }
-
---------------------- Begin prebuilt forms
-
-stringField :: FormFieldSettings -> FormletField sub y String
-stringField = requiredFieldHelper stringFieldProfile
-
-maybeStringField :: FormFieldSettings -> FormletField sub y (Maybe String)
-maybeStringField = optionalFieldHelper stringFieldProfile
-
-stringFieldProfile :: FieldProfile sub y String
-stringFieldProfile = FieldProfile
-    { fpParse = Right
-    , fpRender = id
-    , fpHamlet = \theId name val isReq -> [$hamlet|
-%input#$theId$!name=$name$!type=text!:isReq:required!value=$val$
-|]
-    , fpWidget = \_name -> return ()
-    }
-instance ToFormField String y where
-    toFormField = stringField
-instance ToFormField (Maybe String) y where
-    toFormField = maybeStringField
-
-intInput :: Integral i => String -> FormInput sub master i
-intInput n =
-    mapFormXml fieldsToInput $
-    requiredFieldHelper intFieldProfile (nameSettings n) Nothing
-
-intField :: Integral i => FormFieldSettings -> FormletField sub y i
-intField = requiredFieldHelper intFieldProfile
-
-maybeIntField :: Integral i => FormFieldSettings -> FormletField sub y (Maybe i)
-maybeIntField = optionalFieldHelper intFieldProfile
-
-intFieldProfile :: Integral i => FieldProfile sub y i
-intFieldProfile = FieldProfile
-    { fpParse = maybe (Left "Invalid integer") Right . readMayI
-    , fpRender = showI
-    , fpHamlet = \theId name val isReq -> [$hamlet|
-%input#$theId$!name=$name$!type=number!:isReq:required!value=$val$
-|]
-    , fpWidget = \_name -> return ()
-    }
-  where
-    showI x = show (fromIntegral x :: Integer)
-    readMayI s = case reads s of
-                    (x, _):_ -> Just $ fromInteger x
-                    [] -> Nothing
-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
-
-doubleField :: FormFieldSettings -> FormletField sub y Double
-doubleField = requiredFieldHelper doubleFieldProfile
-
-maybeDoubleField :: FormFieldSettings -> FormletField sub y (Maybe Double)
-maybeDoubleField = optionalFieldHelper doubleFieldProfile
-
-doubleFieldProfile :: FieldProfile sub y Double
-doubleFieldProfile = FieldProfile
-    { fpParse = maybe (Left "Invalid number") Right . readMay
-    , fpRender = show
-    , fpHamlet = \theId name val isReq -> [$hamlet|
-%input#$theId$!name=$name$!type=number!:isReq:required!value=$val$
-|]
-    , fpWidget = \_name -> return ()
-    }
-instance ToFormField Double y where
-    toFormField = doubleField
-instance ToFormField (Maybe Double) y where
-    toFormField = maybeDoubleField
-
-dayField :: FormFieldSettings -> FormletField sub y Day
-dayField = requiredFieldHelper dayFieldProfile
-
-maybeDayField :: FormFieldSettings -> FormletField sub y (Maybe Day)
-maybeDayField = optionalFieldHelper dayFieldProfile
-
-dayFieldProfile :: FieldProfile sub y Day
-dayFieldProfile = FieldProfile
-    { fpParse = parseDate
-    , fpRender = show
-    , fpHamlet = \theId name val isReq -> [$hamlet|
-%input#$theId$!name=$name$!type=date!:isReq:required!value=$val$
-|]
-    , fpWidget = const $ return ()
-    }
-instance ToFormField Day y where
-    toFormField = dayField
-instance ToFormField (Maybe Day) y where
-    toFormField = maybeDayField
-
-parseDate :: String -> Either String 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 String 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 [Char] TimeOfDay
-parseTimeHelper (h1, h2, m1, m2, s1, s2)
-    | h < 0 || h > 23 = Left $ "Invalid hour: " ++ show h
-    | m < 0 || m > 59 = Left $ "Invalid minute: " ++ show m
-    | s < 0 || s > 59 = Left $ "Invalid second: " ++ show s
-    | otherwise = Right $ TimeOfDay h m s
-  where
-    h = read [h1, h2]
-    m = read [m1, m2]
-    s = fromInteger $ read [s1, s2]
-
-timeField :: FormFieldSettings -> FormletField sub y TimeOfDay
-timeField = requiredFieldHelper timeFieldProfile
-
-maybeTimeField :: FormFieldSettings -> FormletField sub y (Maybe TimeOfDay)
-maybeTimeField = optionalFieldHelper timeFieldProfile
-
-timeFieldProfile :: FieldProfile sub y TimeOfDay
-timeFieldProfile = FieldProfile
-    { fpParse = parseTime
-    , fpRender = show
-    , fpHamlet = \theId name val isReq -> [$hamlet|
-%input#$theId$!name=$name$!:isReq:required!value=$val$
-|]
-    , fpWidget = const $ return ()
-    }
-instance ToFormField TimeOfDay y where
-    toFormField = timeField
-instance ToFormField (Maybe TimeOfDay) y where
-    toFormField = maybeTimeField
-
-boolField :: FormFieldSettings -> Maybe Bool -> FormField sub y Bool
-boolField ffs orig = GForm $ \env _ -> do
-    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 True, True)
-    let fi = FieldInfo
-            { fiLabel = label
-            , fiTooltip = tooltip
-            , fiIdent = theId
-            , fiName = name
-            , fiInput = addBody [$hamlet|
-%input#$theId$!type=checkbox!name=$name$!:val:checked
-|]
-            , fiErrors = case res of
-                            FormFailure [x] -> Just $ string x
-                            _ -> Nothing
-            }
-    return (res, [fi], UrlEncoded)
-instance ToFormField Bool y where
-    toFormField = boolField
-
-htmlField :: FormFieldSettings -> FormletField sub y Html
-htmlField = requiredFieldHelper htmlFieldProfile
-
-maybeHtmlField :: FormFieldSettings -> FormletField sub y (Maybe Html)
-maybeHtmlField = optionalFieldHelper htmlFieldProfile
-
-htmlFieldProfile :: FieldProfile sub y Html
-htmlFieldProfile = FieldProfile
-    { fpParse = Right . preEscapedString
-    , fpRender = U.toString . renderHtml
-    , fpHamlet = \theId name val _isReq -> [$hamlet|
-%textarea.html#$theId$!name=$name$ $val$
-|]
-    , fpWidget = const $ return ()
-    }
-instance ToFormField Html y where
-    toFormField = htmlField
-instance ToFormField (Maybe Html) y where
-    toFormField = maybeHtmlField
-
-readMay :: Read a => String -> Maybe a
-readMay s = case reads s of
-                (x, _):_ -> Just x
-                [] -> Nothing
-
-selectField :: Eq x => [(x, String)]
-            -> FormFieldSettings
-            -> Maybe x -> FormField sub master x
-selectField pairs ffs initial = GForm $ \env _ -> do
-    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 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|
-%select#$theId$!name=$name$
-    %option!value=none
-    $forall pairs' pair
-        %option!value=$show.fst.pair$!:isSelected.fst.snd.pair:selected $snd.snd.pair$
-|]
-    let fi = FieldInfo
-            { fiLabel = label
-            , fiTooltip = tooltip
-            , fiIdent = theId
-            , fiName = name
-            , fiInput = addBody input
-            , fiErrors = case res of
-                            FormFailure [x] -> Just $ string x
-                            _ -> Nothing
-            }
-    return (res, [fi], UrlEncoded)
-
-maybeSelectField :: Eq x => [(x, String)]
-                 -> FormFieldSettings
-                 -> FormletField sub master (Maybe x)
-maybeSelectField pairs ffs initial' = GForm $ \env _ -> do
-    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 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 = [$hamlet|
-%select#$theId$!name=$name$
-    %option!value=none
-    $forall pairs' pair
-        %option!value=$show.fst.pair$!:isSelected.fst.snd.pair:selected $snd.snd.pair$
-|]
-    let fi = FieldInfo
-            { fiLabel = label
-            , fiTooltip = tooltip
-            , fiIdent = theId
-            , fiName = name
-            , fiInput = addBody input
-            , fiErrors = case res of
-                            FormFailure [x] -> Just $ string x
-                            _ -> Nothing
-            }
-    return (res, [fi], UrlEncoded)
-
---------------------- End prebuilt forms
-
---------------------- Begin prebuilt inputs
-
-stringInput :: String -> FormInput sub master String
-stringInput n =
-    mapFormXml fieldsToInput $
-    requiredFieldHelper stringFieldProfile (nameSettings n) Nothing
-
-maybeStringInput :: String -> FormInput sub master (Maybe String)
-maybeStringInput n =
-    mapFormXml fieldsToInput $
-    optionalFieldHelper stringFieldProfile (nameSettings n) Nothing
-
-boolInput :: String -> FormInput sub master Bool
-boolInput n = GForm $ \env _ -> return
-    (FormSuccess $ fromMaybe "" (lookup n env) /= "", return $ addBody [$hamlet|
-%input#$n$!type=checkbox!name=$n$
-|], UrlEncoded)
-
-dayInput :: String -> FormInput sub master Day
-dayInput n =
-    mapFormXml fieldsToInput $
-    requiredFieldHelper dayFieldProfile (nameSettings n) Nothing
-
-maybeDayInput :: String -> FormInput sub master (Maybe Day)
-maybeDayInput n =
-    mapFormXml fieldsToInput $
-    optionalFieldHelper dayFieldProfile (nameSettings n) Nothing
-
---------------------- End prebuilt inputs
-
--- | Get a unique identifier.
-newFormIdent :: Monad m => StateT Ints m String
-newFormIdent = do
-    i <- get
-    let i' = incrInts i
-    put i'
-    return $ '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
-
 runFormGeneric :: Env
                -> FileEnv
                -> GForm sub y xml a
@@ -770,84 +186,3 @@ toLabel (x:rest) = toUpper x : go rest
     go (c:cs)
         | isUpper c = ' ' : c : go cs
         | otherwise = c : go cs
-
-urlFieldProfile :: FieldProfile s y String
-urlFieldProfile = FieldProfile
-    { fpParse = \s -> case parseURI s of
-                        Nothing -> Left "Invalid URL"
-                        Just _ -> Right s
-    , fpRender = id
-    , fpHamlet = \theId name val isReq -> [$hamlet|
-%input#$theId$!name=$name$!type=url!:isReq:required!value=$val$
-|]
-    , fpWidget = const $ return ()
-    }
-
-urlField :: FormFieldSettings -> FormletField sub y String
-urlField = requiredFieldHelper urlFieldProfile
-
-maybeUrlField :: FormFieldSettings -> FormletField sub y (Maybe String)
-maybeUrlField = optionalFieldHelper urlFieldProfile
-
-urlInput :: String -> FormInput sub master String
-urlInput n =
-    mapFormXml fieldsToInput $
-    requiredFieldHelper urlFieldProfile (nameSettings n) Nothing
-
-emailFieldProfile :: FieldProfile s y String
-emailFieldProfile = FieldProfile
-    { fpParse = \s -> if Email.isValid s
-                        then Right s
-                        else Left "Invalid e-mail address"
-    , fpRender = id
-    , fpHamlet = \theId name val isReq -> [$hamlet|
-%input#$theId$!name=$name$!type=email!:isReq:required!value=$val$
-|]
-    , fpWidget = const $ return ()
-    }
-
-emailField :: FormFieldSettings -> FormletField sub y String
-emailField = requiredFieldHelper emailFieldProfile
-
-maybeEmailField :: FormFieldSettings -> FormletField sub y (Maybe String)
-maybeEmailField = optionalFieldHelper emailFieldProfile
-
-emailInput :: String -> FormInput sub master String
-emailInput n =
-    mapFormXml fieldsToInput $
-    requiredFieldHelper emailFieldProfile (nameSettings n) Nothing
-
-nameSettings :: String -> FormFieldSettings
-nameSettings n = FormFieldSettings mempty mempty (Just n) (Just n)
-
-textareaFieldProfile :: FieldProfile sub y String
-textareaFieldProfile = FieldProfile
-    { fpParse = Right
-    , fpRender = id
-    , fpHamlet = \theId name val _isReq -> [$hamlet|
-%textarea#$theId$!name=$name$ $val$
-|]
-    , fpWidget = const $ return ()
-    }
-
-textareaField :: FormFieldSettings -> FormletField sub y String
-textareaField = requiredFieldHelper textareaFieldProfile
-
-maybeTextareaField :: FormFieldSettings -> FormletField sub y (Maybe String)
-maybeTextareaField = optionalFieldHelper textareaFieldProfile
-
-hiddenFieldProfile :: FieldProfile sub y String
-hiddenFieldProfile = FieldProfile
-    { fpParse = Right
-    , fpRender = id
-    , fpHamlet = \theId name val _isReq -> [$hamlet|
-%input!type=hidden#$theId$!name=$name$!value=$val$
-|]
-    , fpWidget = const $ return ()
-    }
-
-hiddenField :: FormFieldSettings -> FormletField sub y String
-hiddenField = requiredFieldHelper hiddenFieldProfile
-
-maybeHiddenField :: FormFieldSettings -> FormletField sub y (Maybe String)
-maybeHiddenField = optionalFieldHelper hiddenFieldProfile

Yesod/Form/Class.hs

@@ -0,0 +1,54 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+module Yesod.Form.Class
+    ( ToForm (..)
+    , ToFormField (..)
+    ) where
+
+import Text.Hamlet
+import Yesod.Form.Fields
+import Data.Int (Int64)
+import Data.Time (Day, TimeOfDay)
+
+class ToForm a y where
+    toForm :: Maybe a -> Form sub y a
+class ToFormField a y where
+    toFormField :: FormFieldSettings -> Maybe a -> FormField sub y a
+
+instance ToFormField String y where
+    toFormField = stringField
+instance ToFormField (Maybe String) 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

Yesod/Form/Core.hs

@@ -0,0 +1,103 @@
+module Yesod.Form.Core
+    ( FormResult (..)
+    , GForm (..)
+    , newFormIdent
+    , deeperFormIdent
+    , shallowerFormIdent
+    , Env
+    , FileEnv
+    , Enctype (..)
+    , Ints (..)
+    ) where
+
+import Control.Monad.Trans.State
+import Yesod.Handler
+import Data.Monoid (Monoid (..))
+import Control.Applicative
+import Yesod.Request
+import Control.Monad (liftM)
+
+-- | 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 [String]
+                  | 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
+instance Show Enctype where
+    show UrlEncoded = "application/x-www-form-urlencoded"
+    show Multipart = "multipart/form-data"
+instance Monoid Enctype where
+    mempty = UrlEncoded
+    mappend UrlEncoded UrlEncoded = UrlEncoded
+    mappend _ _ = Multipart
+
+data Ints = IntCons Int Ints | IntSingle Int
+instance Show Ints where
+    show (IntSingle i) = show i
+    show (IntCons i is) = show i ++ '-' : show is
+
+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 sub y xml a = GForm
+    { deform :: Env -> FileEnv -> StateT Ints (GHandler sub y) (FormResult a, xml, Enctype)
+    }
+
+type Env = [(String, String)]
+type FileEnv = [(String, FileInfo)]
+
+-- | Get a unique identifier.
+newFormIdent :: Monad m => StateT Ints m String
+newFormIdent = do
+    i <- get
+    let i' = incrInts i
+    put i'
+    return $ '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 $ \env fe -> liftM (first3 $ fmap f) (g env fe)
+      where
+        first3 f' (x, y, z) = (f' x, y, z)
+
+instance Monoid xml => Applicative (GForm sub url xml) where
+    pure a = GForm $ const $ const $ return (pure a, mempty, mempty)
+    (GForm f) <*> (GForm g) = GForm $ \env fe -> do
+        (f1, f2, f3) <- f env fe
+        (g1, g2, g3) <- g env fe
+        return (f1 <*> g1, f2 `mappend` g2, f3 `mappend` g3)

Yesod/Form/Fields.hs

@@ -0,0 +1,376 @@
+{-# LANGUAGE QuasiQuotes #-}
+module Yesod.Form.Fields
+    ( -- * Type synonyms
+      Form
+    , Formlet
+    , FormField
+    , FormletField
+    , FormInput
+      -- * Data types
+    , FieldInfo (..)
+    , FormFieldSettings (..)
+      -- * Fields
+      -- ** Required
+    , stringField
+    , textareaField
+    , hiddenField
+    , intField
+    , doubleField
+    , dayField
+    , timeField
+    , htmlField
+    , selectField
+    , boolField
+    , emailField
+    , urlField
+      -- ** Optional
+    , maybeStringField
+    , maybeTextareaField
+    , maybeHiddenField
+    , maybeIntField
+    , maybeDoubleField
+    , maybeDayField
+    , maybeTimeField
+    , maybeHtmlField
+    , maybeSelectField
+    , maybeEmailField
+    , maybeUrlField
+      -- * Inputs
+      -- ** Required
+    , stringInput
+    , intInput
+    , boolInput
+    , dayInput
+    , emailInput
+    , urlInput
+      -- ** Optional
+    , maybeStringInput
+    , maybeDayInput
+      -- * Utils
+    , requiredFieldHelper
+    , optionalFieldHelper
+    , fieldsToInput
+    , mapFormXml
+    ) where
+
+import Yesod.Form.Core
+import Yesod.Form.Profiles
+import Yesod.Widget
+import Data.Time (Day, TimeOfDay)
+import Text.Hamlet
+import Data.Monoid
+import Control.Monad (join)
+import Data.Maybe (fromMaybe)
+import Data.String
+
+data FormFieldSettings = FormFieldSettings
+    { ffsLabel :: Html
+    , ffsTooltip :: Html
+    , ffsId :: Maybe String
+    , ffsName :: Maybe String
+    }
+instance IsString FormFieldSettings where
+    fromString s = FormFieldSettings (string s) mempty Nothing Nothing
+
+-- | 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 :: String
+    , fiName :: String
+    , fiInput :: GWidget sub y ()
+    , fiErrors :: Maybe Html
+    }
+
+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 ()]
+
+stringField :: FormFieldSettings -> FormletField sub y String
+stringField = requiredFieldHelper stringFieldProfile
+
+maybeStringField :: FormFieldSettings -> FormletField sub y (Maybe String)
+maybeStringField = optionalFieldHelper stringFieldProfile
+
+intInput :: Integral i => String -> FormInput sub master i
+intInput n =
+    mapFormXml fieldsToInput $
+    requiredFieldHelper intFieldProfile (nameSettings n) Nothing
+
+intField :: Integral i => FormFieldSettings -> FormletField sub y i
+intField = requiredFieldHelper intFieldProfile
+
+maybeIntField :: Integral i => FormFieldSettings -> FormletField sub y (Maybe i)
+maybeIntField = optionalFieldHelper intFieldProfile
+
+doubleField :: FormFieldSettings -> FormletField sub y Double
+doubleField = requiredFieldHelper doubleFieldProfile
+
+maybeDoubleField :: FormFieldSettings -> FormletField sub y (Maybe Double)
+maybeDoubleField = optionalFieldHelper doubleFieldProfile
+
+dayField :: FormFieldSettings -> FormletField sub y Day
+dayField = requiredFieldHelper dayFieldProfile
+
+maybeDayField :: FormFieldSettings -> FormletField sub y (Maybe Day)
+maybeDayField = optionalFieldHelper dayFieldProfile
+
+timeField :: FormFieldSettings -> FormletField sub y TimeOfDay
+timeField = requiredFieldHelper timeFieldProfile
+
+maybeTimeField :: FormFieldSettings -> FormletField sub y (Maybe TimeOfDay)
+maybeTimeField = optionalFieldHelper timeFieldProfile
+
+boolField :: FormFieldSettings -> Maybe Bool -> FormField sub y Bool
+boolField ffs orig = GForm $ \env _ -> do
+    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 True, True)
+    let fi = FieldInfo
+            { fiLabel = label
+            , fiTooltip = tooltip
+            , fiIdent = theId
+            , fiName = name
+            , fiInput = addBody [$hamlet|
+%input#$theId$!type=checkbox!name=$name$!:val:checked
+|]
+            , fiErrors = case res of
+                            FormFailure [x] -> Just $ string x
+                            _ -> Nothing
+            }
+    return (res, [fi], UrlEncoded)
+
+htmlField :: FormFieldSettings -> FormletField sub y Html
+htmlField = requiredFieldHelper htmlFieldProfile
+
+maybeHtmlField :: FormFieldSettings -> FormletField sub y (Maybe Html)
+maybeHtmlField = optionalFieldHelper htmlFieldProfile
+
+selectField :: Eq x => [(x, String)]
+            -> FormFieldSettings
+            -> Maybe x -> FormField sub master x
+selectField pairs ffs initial = GForm $ \env _ -> do
+    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 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|
+%select#$theId$!name=$name$
+    %option!value=none
+    $forall pairs' pair
+        %option!value=$show.fst.pair$!:isSelected.fst.snd.pair:selected $snd.snd.pair$
+|]
+    let fi = FieldInfo
+            { fiLabel = label
+            , fiTooltip = tooltip
+            , fiIdent = theId
+            , fiName = name
+            , fiInput = addBody input
+            , fiErrors = case res of
+                            FormFailure [x] -> Just $ string x
+                            _ -> Nothing
+            }
+    return (res, [fi], UrlEncoded)
+
+maybeSelectField :: Eq x => [(x, String)]
+                 -> FormFieldSettings
+                 -> FormletField sub master (Maybe x)
+maybeSelectField pairs ffs initial' = GForm $ \env _ -> do
+    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 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 = [$hamlet|
+%select#$theId$!name=$name$
+    %option!value=none
+    $forall pairs' pair
+        %option!value=$show.fst.pair$!:isSelected.fst.snd.pair:selected $snd.snd.pair$
+|]
+    let fi = FieldInfo
+            { fiLabel = label
+            , fiTooltip = tooltip
+            , fiIdent = theId
+            , fiName = name
+            , fiInput = addBody input
+            , fiErrors = case res of
+                            FormFailure [x] -> Just $ string x
+                            _ -> Nothing
+            }
+    return (res, [fi], UrlEncoded)
+
+stringInput :: String -> FormInput sub master String
+stringInput n =
+    mapFormXml fieldsToInput $
+    requiredFieldHelper stringFieldProfile (nameSettings n) Nothing
+
+maybeStringInput :: String -> FormInput sub master (Maybe String)
+maybeStringInput n =
+    mapFormXml fieldsToInput $
+    optionalFieldHelper stringFieldProfile (nameSettings n) Nothing
+
+boolInput :: String -> FormInput sub master Bool
+boolInput n = GForm $ \env _ -> return
+    (FormSuccess $ fromMaybe "" (lookup n env) /= "", return $ addBody [$hamlet|
+%input#$n$!type=checkbox!name=$n$
+|], UrlEncoded)
+
+dayInput :: String -> FormInput sub master Day
+dayInput n =
+    mapFormXml fieldsToInput $
+    requiredFieldHelper dayFieldProfile (nameSettings n) Nothing
+
+maybeDayInput :: String -> FormInput sub master (Maybe Day)
+maybeDayInput n =
+    mapFormXml fieldsToInput $
+    optionalFieldHelper dayFieldProfile (nameSettings n) Nothing
+
+nameSettings :: String -> FormFieldSettings
+nameSettings n = FormFieldSettings mempty mempty (Just n) (Just n)
+
+-- | Create a required field (ie, one that cannot be blank) from a
+-- 'FieldProfile'.ngs
+requiredFieldHelper :: FieldProfile sub y a -> FormFieldSettings
+                    -> Maybe a -> FormField sub y a
+requiredFieldHelper (FieldProfile parse render mkXml w) ffs orig =
+  GForm $ \env _ -> do
+    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 = label
+            , fiTooltip = tooltip
+            , fiIdent = theId
+            , fiName = name
+            , fiInput = w theId >> addBody (mkXml theId name val True)
+            , fiErrors = case res of
+                            FormFailure [x] -> Just $ string x
+                            _ -> Nothing
+            }
+    return (res, [fi], UrlEncoded)
+
+-- | Create an optional field (ie, one that can be blank) from a
+-- 'FieldProfile'.
+optionalFieldHelper :: FieldProfile sub y a -> FormFieldSettings
+                    -> FormletField sub y (Maybe a)
+optionalFieldHelper (FieldProfile parse render mkXml w) ffs orig' =
+  GForm $ \env _ -> do
+    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 = label
+            , fiTooltip = tooltip
+            , fiIdent = theId
+            , fiName = name
+            , fiInput = w theId >> addBody (mkXml theId name val False)
+            , fiErrors = case res of
+                            FormFailure [x] -> Just $ string x
+                            _ -> Nothing
+            }
+    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 $ \e fe -> do
+    (res, xml, enc) <- g e fe
+    return (res, f xml, enc)
+
+urlField :: FormFieldSettings -> FormletField sub y String
+urlField = requiredFieldHelper urlFieldProfile
+
+maybeUrlField :: FormFieldSettings -> FormletField sub y (Maybe String)
+maybeUrlField = optionalFieldHelper urlFieldProfile
+
+urlInput :: String -> FormInput sub master String
+urlInput n =
+    mapFormXml fieldsToInput $
+    requiredFieldHelper urlFieldProfile (nameSettings n) Nothing
+
+emailField :: FormFieldSettings -> FormletField sub y String
+emailField = requiredFieldHelper emailFieldProfile
+
+maybeEmailField :: FormFieldSettings -> FormletField sub y (Maybe String)
+maybeEmailField = optionalFieldHelper emailFieldProfile
+
+emailInput :: String -> FormInput sub master String
+emailInput n =
+    mapFormXml fieldsToInput $
+    requiredFieldHelper emailFieldProfile (nameSettings n) Nothing
+
+textareaField :: FormFieldSettings -> FormletField sub y String
+textareaField = requiredFieldHelper textareaFieldProfile
+
+maybeTextareaField :: FormFieldSettings -> FormletField sub y (Maybe String)
+maybeTextareaField = optionalFieldHelper textareaFieldProfile
+
+hiddenField :: FormFieldSettings -> FormletField sub y String
+hiddenField = requiredFieldHelper hiddenFieldProfile
+
+maybeHiddenField :: FormFieldSettings -> FormletField sub y (Maybe String)
+maybeHiddenField = optionalFieldHelper hiddenFieldProfile

Yesod/Form/Jquery.hs

@@ -12,6 +12,7 @@ module Yesod.Form.Jquery
 
 import Yesod.Handler
 import Yesod.Form
+import Yesod.Form.Profiles
 import Yesod.Widget
 import Data.Time (UTCTime (..), Day, TimeOfDay (..), timeOfDayToTime,
                   timeToTimeOfDay)

Yesod/Form/Nic.hs

@@ -7,6 +7,7 @@ module Yesod.Form.Nic
 
 import Yesod.Handler
 import Yesod.Form
+import Yesod.Form.Profiles
 import Yesod.Hamlet
 import Yesod.Widget
 import qualified Data.ByteString.Lazy.UTF8 as U

Yesod/Form/Profiles.hs

@@ -0,0 +1,181 @@
+{-# LANGUAGE QuasiQuotes #-}
+module Yesod.Form.Profiles
+    ( FieldProfile (..)
+    , stringFieldProfile
+    , textareaFieldProfile
+    , hiddenFieldProfile
+    , intFieldProfile
+    , dayFieldProfile
+    , timeFieldProfile
+    , htmlFieldProfile
+    , emailFieldProfile
+    , urlFieldProfile
+    , doubleFieldProfile
+    , parseDate
+    , parseTime
+    ) where
+
+import Yesod.Widget
+import Yesod.Handler
+import Text.Hamlet
+import Data.Time (Day, TimeOfDay(..))
+import qualified Data.ByteString.Lazy.UTF8 as U
+import qualified Text.Email.Validate as Email
+import Network.URI (parseURI)
+
+-- | 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 :: String -> Either String a
+    , fpRender :: a -> String
+    , fpHamlet :: String -> String -> String -> Bool -> Hamlet (Route y)
+    , fpWidget :: String -> GWidget sub y ()
+    }
+
+intFieldProfile :: Integral i => FieldProfile sub y i
+intFieldProfile = FieldProfile
+    { fpParse = maybe (Left "Invalid integer") Right . readMayI
+    , fpRender = showI
+    , fpHamlet = \theId name val isReq -> [$hamlet|
+%input#$theId$!name=$name$!type=number!:isReq:required!value=$val$
+|]
+    , fpWidget = \_name -> return ()
+    }
+  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
+    , fpRender = show
+    , fpHamlet = \theId name val isReq -> [$hamlet|
+%input#$theId$!name=$name$!type=number!:isReq:required!value=$val$
+|]
+    , fpWidget = \_name -> return ()
+    }
+
+dayFieldProfile :: FieldProfile sub y Day
+dayFieldProfile = FieldProfile
+    { fpParse = parseDate
+    , fpRender = show
+    , fpHamlet = \theId name val isReq -> [$hamlet|
+%input#$theId$!name=$name$!type=date!:isReq:required!value=$val$
+|]
+    , fpWidget = const $ return ()
+    }
+
+timeFieldProfile :: FieldProfile sub y TimeOfDay
+timeFieldProfile = FieldProfile
+    { fpParse = parseTime
+    , fpRender = show
+    , fpHamlet = \theId name val isReq -> [$hamlet|
+%input#$theId$!name=$name$!:isReq:required!value=$val$
+|]
+    , fpWidget = const $ return ()
+    }
+
+htmlFieldProfile :: FieldProfile sub y Html
+htmlFieldProfile = FieldProfile
+    { fpParse = Right . preEscapedString
+    , fpRender = U.toString . renderHtml
+    , fpHamlet = \theId name val _isReq -> [$hamlet|
+%textarea.html#$theId$!name=$name$ $val$
+|]
+    , fpWidget = const $ return ()
+    }
+
+textareaFieldProfile :: FieldProfile sub y String
+textareaFieldProfile = FieldProfile
+    { fpParse = Right
+    , fpRender = id
+    , fpHamlet = \theId name val _isReq -> [$hamlet|
+%textarea#$theId$!name=$name$ $val$
+|]
+    , fpWidget = const $ return ()
+    }
+
+hiddenFieldProfile :: FieldProfile sub y String
+hiddenFieldProfile = FieldProfile
+    { fpParse = Right
+    , fpRender = id
+    , fpHamlet = \theId name val _isReq -> [$hamlet|
+%input!type=hidden#$theId$!name=$name$!value=$val$
+|]
+    , fpWidget = const $ return ()
+    }
+
+stringFieldProfile :: FieldProfile sub y String
+stringFieldProfile = FieldProfile
+    { fpParse = Right
+    , fpRender = id
+    , fpHamlet = \theId name val isReq -> [$hamlet|
+%input#$theId$!name=$name$!type=text!:isReq:required!value=$val$
+|]
+    , fpWidget = \_name -> return ()
+    }
+
+readMay :: Read a => String -> Maybe a
+readMay s = case reads s of
+                (x, _):_ -> Just x
+                [] -> Nothing
+
+parseDate :: String -> Either String 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 String 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 [Char] TimeOfDay
+parseTimeHelper (h1, h2, m1, m2, s1, s2)
+    | h < 0 || h > 23 = Left $ "Invalid hour: " ++ show h
+    | m < 0 || m > 59 = Left $ "Invalid minute: " ++ show m
+    | s < 0 || s > 59 = Left $ "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 String
+emailFieldProfile = FieldProfile
+    { fpParse = \s -> if Email.isValid s
+                        then Right s
+                        else Left "Invalid e-mail address"
+    , fpRender = id
+    , fpHamlet = \theId name val isReq -> [$hamlet|
+%input#$theId$!name=$name$!type=email!:isReq:required!value=$val$
+|]
+    , fpWidget = const $ return ()
+    }
+
+urlFieldProfile :: FieldProfile s y String
+urlFieldProfile = FieldProfile
+    { fpParse = \s -> case parseURI s of
+                        Nothing -> Left "Invalid URL"
+                        Just _ -> Right s
+    , fpRender = id
+    , fpHamlet = \theId name val isReq -> [$hamlet|
+%input#$theId$!name=$name$!type=url!:isReq:required!value=$val$
+|]
+    , fpWidget = const $ return ()
+    }

Yesod/Helpers/Crud.hs

@@ -17,6 +17,7 @@ import Yesod.Content
 import Yesod.Handler
 import Text.Hamlet
 import Yesod.Form
+import Yesod.Form.Class
 import Data.Monoid (mempty)
 import Language.Haskell.TH.Syntax
 

yesod.cabal

@@ -52,6 +52,10 @@ library
                      Yesod.Content
                      Yesod.Dispatch
                      Yesod.Form
+                     Yesod.Form.Class
+                     Yesod.Form.Core
+                     Yesod.Form.Fields
+                     Yesod.Form.Profiles
                      Yesod.Form.Jquery
                      Yesod.Form.Nic
                      Yesod.Hamlet