haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Renamings in Form

Browse Source
This commit is contained in:
Michael Snoyman 2010-07-06 10:42:58 +03:00
parent af46ece3ed
commit ef7d27df7c
2 changed files with 157 additions and 90 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

245
Yesod/Form.hs
View File

@ -12,10 +12,10 @@ module Yesod.Form
, Form , Form
, Formlet , Formlet
, FormField , FormField
, FormletField
, FormResult (..) , FormResult (..)
, Enctype (..) , Enctype (..)
, FieldInfo (..) , FieldInfo (..)
, FieldProfile (..)
-- * Newtype wrappers -- * Newtype wrappers
, JqueryDay (..) , JqueryDay (..)
, NicHtml (..) , NicHtml (..)
@ -25,30 +25,46 @@ module Yesod.Form
, runFormGet' , runFormGet'
, runFormPost' , runFormPost'
-- * Type classes -- * Type classes
, IsForm (..) , ToForm (..)
, IsFormField (..) , ToFormField (..)
-- * Field/form helpers -- * Field/form helpers
, requiredField , requiredFieldHelper
, optionalField , optionalFieldHelper
, mapFormXml , mapFormXml
, newFormIdent , newFormIdent
, fieldsToTable , fieldsToTable
-- * Field profiles
, FieldProfile (..)
, stringFieldProfile
, intFieldProfile
, dayFieldProfile
, timeFieldProfile
, htmlFieldProfile
-- * Pre-built fields -- * Pre-built fields
, stringField , stringField
, maybeStringField
, intField , intField
, maybeIntField
, doubleField
, maybeDoubleField
, dayField , dayField
, maybeDayField
, timeField , timeField
, boolField , maybeTimeField
, htmlField , htmlField
, maybeHtmlField
, selectField , selectField
, maybeSelectField , maybeSelectField
, boolField
-- * Pre-built inputs -- * Pre-built inputs
, stringInput , stringInput
, maybeStringInput , maybeStringInput
, boolInput , boolInput
, dayInput
, maybeDayInput
-- * Template Haskell -- * Template Haskell
, share2 , share2
, mkIsForm , mkToForm
) where ) where
import Text.Hamlet import Text.Hamlet
@ -100,6 +116,7 @@ newtype GForm sub y xml a = GForm
type Form sub y = GForm sub y (GWidget sub y ()) type Form sub y = GForm sub y (GWidget sub y ())
type Formlet sub y a = Maybe a -> Form sub y a type Formlet sub y a = Maybe a -> Form sub y a
type FormField sub y = GForm sub y [FieldInfo sub y] type FormField sub y = GForm sub y [FieldInfo sub y]
type FormletField sub y a = Maybe a -> FormField sub y a
mapFormXml :: (xml1 -> xml2) -> GForm s y xml1 a -> GForm s y xml2 a mapFormXml :: (xml1 -> xml2) -> GForm s y xml1 a -> GForm s y xml2 a
mapFormXml f (GForm g) = GForm $ \e fe -> do mapFormXml f (GForm g) = GForm $ \e fe -> do
@ -145,14 +162,14 @@ fieldsToTable = mapM_ go
%td.errors $err$ %td.errors $err$
|] |]
class IsForm a where class ToForm a where
toForm :: Maybe a -> Form sub y a toForm :: Maybe a -> Form sub y a
class IsFormField a where class ToFormField a where
toFormField :: Html () -> Html () -> Maybe a -> FormField sub y a toFormField :: Html () -> Html () -> Maybe a -> FormField sub y a
requiredField :: FieldProfile sub y a requiredFieldHelper :: FieldProfile sub y a
-> Html () -> Html () -> Maybe a -> FormField sub y a -> Html () -> Html () -> Maybe a -> FormField sub y a
requiredField (FieldProfile parse render mkXml w) label tooltip orig = requiredFieldHelper (FieldProfile parse render mkXml w) label tooltip orig =
GForm $ \env _ -> do GForm $ \env _ -> do
name <- newFormIdent name <- newFormIdent
let (res, val) = let (res, val) =
@ -176,10 +193,10 @@ requiredField (FieldProfile parse render mkXml w) label tooltip orig =
} }
return (res, [fi], UrlEncoded) return (res, [fi], UrlEncoded)
optionalField :: FieldProfile sub y a optionalFieldHelper :: FieldProfile sub y a
-> Html () -> Html () -> Maybe (Maybe a) -> Html () -> Html () -> Maybe (Maybe a)
-> FormField sub y (Maybe a) -> FormField sub y (Maybe a)
optionalField (FieldProfile parse render mkXml w) label tooltip orig' = optionalFieldHelper (FieldProfile parse render mkXml w) label tooltip orig' =
GForm $ \env _ -> do GForm $ \env _ -> do
let orig = join orig' let orig = join orig'
name <- newFormIdent name <- newFormIdent
@ -213,8 +230,14 @@ data FieldProfile sub y a = FieldProfile
--------------------- Begin prebuilt forms --------------------- Begin prebuilt forms
stringField :: FieldProfile sub y String stringField :: Html () -> Html () -> FormletField sub y String
stringField = FieldProfile stringField = requiredFieldHelper stringFieldProfile
maybeStringField :: Html () -> Html () -> FormletField sub y (Maybe String)
maybeStringField = optionalFieldHelper stringFieldProfile
stringFieldProfile :: FieldProfile sub y String
stringFieldProfile = FieldProfile
{ fpParse = Right { fpParse = Right
, fpRender = id , fpRender = id
, fpHamlet = \name val isReq -> [$hamlet| , fpHamlet = \name val isReq -> [$hamlet|
@ -222,13 +245,19 @@ stringField = FieldProfile
|] |]
, fpWidget = \_name -> return () , fpWidget = \_name -> return ()
} }
instance IsFormField String where instance ToFormField String where
toFormField = requiredField stringField toFormField = requiredFieldHelper stringFieldProfile
instance IsFormField (Maybe String) where instance ToFormField (Maybe String) where
toFormField = optionalField stringField toFormField = optionalFieldHelper stringFieldProfile
intField :: Integral i => FieldProfile sub y i intField :: Html () -> Html () -> FormletField sub y Int
intField = FieldProfile intField = requiredFieldHelper intFieldProfile
maybeIntField :: Html () -> Html () -> FormletField sub y (Maybe Int)
maybeIntField = optionalFieldHelper intFieldProfile
intFieldProfile :: Integral i => FieldProfile sub y i
intFieldProfile = FieldProfile
{ fpParse = maybe (Left "Invalid integer") Right . readMayI { fpParse = maybe (Left "Invalid integer") Right . readMayI
, fpRender = showI , fpRender = showI
, fpHamlet = \name val isReq -> [$hamlet| , fpHamlet = \name val isReq -> [$hamlet|
@ -241,17 +270,23 @@ intField = FieldProfile
readMayI s = case reads s of readMayI s = case reads s of
(x, _):_ -> Just $ fromInteger x (x, _):_ -> Just $ fromInteger x
[] -> Nothing [] -> Nothing
instance IsFormField Int where instance ToFormField Int where
toFormField = requiredField intField toFormField = requiredFieldHelper intFieldProfile
instance IsFormField (Maybe Int) where instance ToFormField (Maybe Int) where
toFormField = optionalField intField toFormField = optionalFieldHelper intFieldProfile
instance IsFormField Int64 where instance ToFormField Int64 where
toFormField = requiredField intField toFormField = requiredFieldHelper intFieldProfile
instance IsFormField (Maybe Int64) where instance ToFormField (Maybe Int64) where
toFormField = optionalField intField toFormField = optionalFieldHelper intFieldProfile
doubleField :: FieldProfile sub y Double doubleField :: Html () -> Html () -> FormletField sub y Double
doubleField = FieldProfile doubleField = requiredFieldHelper doubleFieldProfile
maybeDoubleField :: Html () -> Html () -> FormletField sub y (Maybe Double)
maybeDoubleField = optionalFieldHelper doubleFieldProfile
doubleFieldProfile :: FieldProfile sub y Double
doubleFieldProfile = FieldProfile
{ fpParse = maybe (Left "Invalid number") Right . readMay { fpParse = maybe (Left "Invalid number") Right . readMay
, fpRender = show , fpRender = show
, fpHamlet = \name val isReq -> [$hamlet| , fpHamlet = \name val isReq -> [$hamlet|
@ -259,13 +294,19 @@ doubleField = FieldProfile
|] |]
, fpWidget = \_name -> return () , fpWidget = \_name -> return ()
} }
instance IsFormField Double where instance ToFormField Double where
toFormField = requiredField doubleField toFormField = requiredFieldHelper doubleFieldProfile
instance IsFormField (Maybe Double) where instance ToFormField (Maybe Double) where
toFormField = optionalField doubleField toFormField = optionalFieldHelper doubleFieldProfile
dayField :: FieldProfile sub y Day dayField :: Html () -> Html () -> FormletField sub y Day
dayField = FieldProfile dayField = requiredFieldHelper dayFieldProfile
maybeDayField :: Html () -> Html () -> FormletField sub y (Maybe Day)
maybeDayField = optionalFieldHelper dayFieldProfile
dayFieldProfile :: FieldProfile sub y Day
dayFieldProfile = FieldProfile
{ fpParse = maybe (Left "Invalid day, must be in YYYY-MM-DD format") Right { fpParse = maybe (Left "Invalid day, must be in YYYY-MM-DD format") Right
. readMay . readMay
, fpRender = show , fpRender = show
@ -274,13 +315,13 @@ dayField = FieldProfile
|] |]
, fpWidget = const $ return () , fpWidget = const $ return ()
} }
instance IsFormField Day where instance ToFormField Day where
toFormField = requiredField dayField toFormField = requiredFieldHelper dayFieldProfile
instance IsFormField (Maybe Day) where instance ToFormField (Maybe Day) where
toFormField = optionalField dayField toFormField = optionalFieldHelper dayFieldProfile
jqueryDayField :: FieldProfile sub y JqueryDay jqueryDayFieldProfile :: FieldProfile sub y JqueryDay
jqueryDayField = dayField jqueryDayFieldProfile = FieldProfile
{ fpParse = maybe { fpParse = maybe
(Left "Invalid day, must be in YYYY-MM-DD format") (Left "Invalid day, must be in YYYY-MM-DD format")
(Right . JqueryDay) (Right . JqueryDay)
@ -297,23 +338,24 @@ jqueryDayField = dayField
} }
-- | A newtype wrapper around 'Day', using jQuery UI date picker for the -- | A newtype wrapper around 'Day', using jQuery UI date picker for the
-- 'IsFormField' instance. -- 'ToFormField' instance.
newtype JqueryDay = JqueryDay { unJqueryDay :: Day } newtype JqueryDay = JqueryDay { unJqueryDay :: Day }
deriving PersistField deriving PersistField
instance IsFormField JqueryDay where instance ToFormField JqueryDay where
toFormField = requiredField jqueryDayField toFormField = requiredFieldHelper jqueryDayFieldProfile
instance IsFormField (Maybe JqueryDay) where instance ToFormField (Maybe JqueryDay) where
toFormField = optionalField jqueryDayField toFormField = optionalFieldHelper jqueryDayFieldProfile
parseTime :: String -> Either String TimeOfDay parseTime :: String -> Either String TimeOfDay
parseTime (h2:':':m1:m2:[]) = parseTimeHelper ['0', h2, m1, m2, '0', '0'] 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:[]) = parseTimeHelper (h1, h2, m1, m2, '0', '0')
parseTime (h1:h2:':':m1:m2:':':s1:s2:[]) = parseTime (h1:h2:':':m1:m2:':':s1:s2:[]) =
parseTimeHelper [h1, h2, m1, m2, s1, s2] parseTimeHelper (h1, h2, m1, m2, s1, s2)
parseTime _ = Left "Invalid time, must be in HH:MM[:SS] format" parseTime _ = Left "Invalid time, must be in HH:MM[:SS] format"
parseTimeHelper :: String -> Either String TimeOfDay parseTimeHelper :: (Char, Char, Char, Char, Char, Char)
parseTimeHelper (h1:h2:m1:m2:s1:s2:[]) -> Either [Char] TimeOfDay
parseTimeHelper (h1, h2, m1, m2, s1, s2)
| h < 0 || h > 23 = Left $ "Invalid hour: " ++ show h | h < 0 || h > 23 = Left $ "Invalid hour: " ++ show h
| m < 0 || m > 59 = Left $ "Invalid minute: " ++ show m | m < 0 || m > 59 = Left $ "Invalid minute: " ++ show m
| s < 0 || s > 59 = Left $ "Invalid second: " ++ show s | s < 0 || s > 59 = Left $ "Invalid second: " ++ show s
@ -323,26 +365,25 @@ parseTimeHelper (h1:h2:m1:m2:s1:s2:[])
m = read [m1, m2] m = read [m1, m2]
s = fromInteger $ read [s1, s2] s = fromInteger $ read [s1, s2]
timeField :: FieldProfile sub y TimeOfDay timeField :: Html () -> Html () -> FormletField sub y TimeOfDay
timeField = FieldProfile timeField = requiredFieldHelper timeFieldProfile
maybeTimeField :: Html () -> Html () -> FormletField sub y (Maybe TimeOfDay)
maybeTimeField = optionalFieldHelper timeFieldProfile
timeFieldProfile :: FieldProfile sub y TimeOfDay
timeFieldProfile = FieldProfile
{ fpParse = parseTime { fpParse = parseTime
, fpRender = show , fpRender = show
, fpHamlet = \name val isReq -> [$hamlet| , fpHamlet = \name val isReq -> [$hamlet|
%input#$name$!name=$name$!:isReq:required!value=$val$ %input#$name$!name=$name$!:isReq:required!value=$val$
|] |]
, fpWidget = \name -> do , fpWidget = const $ return ()
return ()
{-
addScriptRemote "http://ajax.googleapis.com/ajax/libs/jquery/1.4.2/jquery.min.js"
addScriptRemote "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8.1/jquery-ui.min.js"
addStylesheetRemote "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8.1/themes/cupertino/jquery-ui.css"
addHead [$hamlet|%script $$(function(){$$("#$name$").datepicker({dateFormat:'yy-mm-dd'})})|]
-}
} }
instance IsFormField TimeOfDay where instance ToFormField TimeOfDay where
toFormField = requiredField timeField toFormField = requiredFieldHelper timeFieldProfile
instance IsFormField (Maybe TimeOfDay) where instance ToFormField (Maybe TimeOfDay) where
toFormField = optionalField timeField toFormField = optionalFieldHelper timeFieldProfile
boolField :: Html () -> Html () -> Maybe Bool -> FormField sub y Bool boolField :: Html () -> Html () -> Maybe Bool -> FormField sub y Bool
boolField label tooltip orig = GForm $ \env _ -> do boolField label tooltip orig = GForm $ \env _ -> do
@ -365,11 +406,17 @@ boolField label tooltip orig = GForm $ \env _ -> do
_ -> Nothing _ -> Nothing
} }
return (res, [fi], UrlEncoded) return (res, [fi], UrlEncoded)
instance IsFormField Bool where instance ToFormField Bool where
toFormField = boolField toFormField = boolField
htmlField :: FieldProfile sub y (Html ()) htmlField :: Html () -> Html () -> FormletField sub y (Html ())
htmlField = FieldProfile htmlField = requiredFieldHelper htmlFieldProfile
maybeHtmlField :: Html () -> Html () -> FormletField sub y (Maybe (Html ()))
maybeHtmlField = optionalFieldHelper htmlFieldProfile
htmlFieldProfile :: FieldProfile sub y (Html ())
htmlFieldProfile = FieldProfile
{ fpParse = Right . preEscapedString { fpParse = Right . preEscapedString
, fpRender = U.toString . renderHtml , fpRender = U.toString . renderHtml
, fpHamlet = \name val _isReq -> [$hamlet| , fpHamlet = \name val _isReq -> [$hamlet|
@ -377,16 +424,16 @@ htmlField = FieldProfile
|] |]
, fpWidget = const $ return () , fpWidget = const $ return ()
} }
instance IsFormField (Html ()) where instance ToFormField (Html ()) where
toFormField = requiredField htmlField toFormField = requiredFieldHelper htmlFieldProfile
instance IsFormField (Maybe (Html ())) where instance ToFormField (Maybe (Html ())) where
toFormField = optionalField htmlField toFormField = optionalFieldHelper htmlFieldProfile
newtype NicHtml = NicHtml { unNicHtml :: Html () } newtype NicHtml = NicHtml { unNicHtml :: Html () }
deriving PersistField deriving PersistField
nicHtmlField :: FieldProfile sub y NicHtml nicHtmlFieldProfile :: FieldProfile sub y NicHtml
nicHtmlField = FieldProfile nicHtmlFieldProfile = FieldProfile
{ fpParse = Right . NicHtml . preEscapedString { fpParse = Right . NicHtml . preEscapedString
, fpRender = U.toString . renderHtml . unNicHtml , fpRender = U.toString . renderHtml . unNicHtml
, fpHamlet = \name val _isReq -> [$hamlet| , fpHamlet = \name val _isReq -> [$hamlet|
@ -396,10 +443,10 @@ nicHtmlField = FieldProfile
addScriptRemote "http://js.nicedit.com/nicEdit-latest.js" addScriptRemote "http://js.nicedit.com/nicEdit-latest.js"
addHead [$hamlet|%script bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("$name$")})|] addHead [$hamlet|%script bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("$name$")})|]
} }
instance IsFormField NicHtml where instance ToFormField NicHtml where
toFormField = requiredField nicHtmlField toFormField = requiredFieldHelper nicHtmlFieldProfile
instance IsFormField (Maybe NicHtml) where instance ToFormField (Maybe NicHtml) where
toFormField = optionalField nicHtmlField toFormField = optionalFieldHelper nicHtmlFieldProfile
readMay :: Read a => String -> Maybe a readMay :: Read a => String -> Maybe a
readMay s = case reads s of readMay s = case reads s of
@ -502,6 +549,28 @@ boolInput :: String -> Form sub master Bool
boolInput n = GForm $ \env _ -> return boolInput n = GForm $ \env _ -> return
(FormSuccess $ isJust $ lookup n env, mempty, UrlEncoded) (FormSuccess $ isJust $ lookup n env, mempty, UrlEncoded)
dayInput :: String -> Form sub master Day
dayInput n = GForm $ \env _ -> return
(case lookup n env of
Nothing -> FormMissing
Just "" -> FormFailure [n ++ ": You must provide a non-empty string"]
Just x ->
case readMay x of
Just y -> FormSuccess y
Nothing -> FormFailure [n ++ ": Invalid date"]
, mempty, UrlEncoded)
maybeDayInput :: String -> Form sub master (Maybe Day)
maybeDayInput n = GForm $ \env _ -> return
(case lookup n env of
Nothing -> FormSuccess Nothing
Just "" -> FormSuccess Nothing
Just x ->
case readMay x of
Just y -> FormSuccess $ Just y
Nothing -> FormFailure [n ++ ": Invalid date"]
, mempty, UrlEncoded)
--------------------- End prebuilt inputs --------------------- End prebuilt inputs
newFormIdent :: Monad m => StateT Int m String newFormIdent :: Monad m => StateT Int m String
@ -553,8 +622,8 @@ share2 f g a = do
g' <- g a g' <- g a
return $ f' ++ g' return $ f' ++ g'
mkIsForm :: [EntityDef] -> Q [Dec] mkToForm :: [EntityDef] -> Q [Dec]
mkIsForm = mapM derive mkToForm = mapM derive
where where
getLabel (x, _, z) = fromMaybe (toLabel x) $ getLabel' z getLabel (x, _, z) = fromMaybe (toLabel x) $ getLabel' z
getLabel' [] = Nothing getLabel' [] = Nothing
@ -566,17 +635,15 @@ mkIsForm = mapM derive
getTooltip' [] = Nothing getTooltip' [] = Nothing
derive :: EntityDef -> Q Dec derive :: EntityDef -> Q Dec
derive t = do derive t = do
let fst3 (x, _, _) = x
let cols = map (getLabel &&& getTooltip) $ entityColumns t let cols = map (getLabel &&& getTooltip) $ entityColumns t
ap <- [|(<*>)|] ap <- [|(<*>)|]
just <- [|pure|] just <- [|pure|]
nothing <- [|Nothing|] nothing <- [|Nothing|]
let just' = just `AppE` ConE (mkName $ entityName t) let just' = just `AppE` ConE (mkName $ entityName t)
string' <- [|string|] string' <- [|string|]
mempty' <- [|mempty|]
mfx <- [|mapFormXml|] mfx <- [|mapFormXml|]
ftt <- [|fieldsToTable|] ftt <- [|fieldsToTable|]
let go_ = go ap just' string' mempty' mfx ftt let go_ = go ap just' string' mfx ftt
let c1 = Clause [ ConP (mkName "Nothing") [] let c1 = Clause [ ConP (mkName "Nothing") []
] ]
(NormalB $ go_ $ zip cols $ map (const nothing) cols) (NormalB $ go_ $ zip cols $ map (const nothing) cols)
@ -587,13 +654,13 @@ mkIsForm = mapM derive
$ map VarP xs]] $ map VarP xs]]
(NormalB $ go_ $ zip cols xs') (NormalB $ go_ $ zip cols xs')
[] []
return $ InstanceD [] (ConT ''IsForm return $ InstanceD [] (ConT ''ToForm
`AppT` ConT (mkName $ entityName t)) `AppT` ConT (mkName $ entityName t))
[FunD (mkName "toForm") [c1, c2]] [FunD (mkName "toForm") [c1, c2]]
go ap just' string' mem mfx ftt a = go ap just' string' mfx ftt a =
let x = foldl (ap' ap) just' $ map (go' string' mem) a let x = foldl (ap' ap) just' $ map (go' string') a
in mfx `AppE` ftt `AppE` x in mfx `AppE` ftt `AppE` x
go' string' mempty' ((label, tooltip), ex) = go' string' ((label, tooltip), ex) =
let label' = string' `AppE` LitE (StringL label) let label' = string' `AppE` LitE (StringL label)
tooltip' = string' `AppE` LitE (StringL tooltip) tooltip' = string' `AppE` LitE (StringL tooltip)
in VarE (mkName "toFormField") `AppE` label' in VarE (mkName "toFormField") `AppE` label'

2
Yesod/Helpers/Crud.hs
View File

@ -19,7 +19,7 @@ import Text.Hamlet
import Yesod.Form import Yesod.Form
import Data.Monoid (mempty) import Data.Monoid (mempty)
class IsForm a => Item a where class ToForm a => Item a where
itemTitle :: a -> String itemTitle :: a -> String
data Crud master item = Crud data Crud master item = Crud