Split Yesod.Form into subfiles
This commit is contained in:
Michael Snoyman
parent
280aa5d543
commit
2a19d1a4e8
679
Yesod/Form.hs
679
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 (..)
|
||||
, Form
|
||||
, Formlet
|
||||
, FormField
|
||||
, FormletField
|
||||
, FormInput
|
||||
GForm
|
||||
, 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
|
||||
-- * 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
|
||||
, module Yesod.Form.Fields
|
||||
-- * 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 Data.Monoid (Monoid (..))
|
||||
import Control.Monad ((<=<))
|
||||
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
|
||||
|
||||
54
Yesod/Form/Class.hs
Normal file
54
Yesod/Form/Class.hs
Normal file
@ -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
|
||||
103
Yesod/Form/Core.hs
Normal file
103
Yesod/Form/Core.hs
Normal file
@ -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)
|
||||
376
Yesod/Form/Fields.hs
Normal file
376
Yesod/Form/Fields.hs
Normal file
@ -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
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
181
Yesod/Form/Profiles.hs
Normal file
181
Yesod/Form/Profiles.hs
Normal file
@ -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 ()
|
||||
}
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user