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

ToForm and ToFormField take master site param

Browse Source
This commit is contained in:
Michael Snoyman 2010-07-22 12:27:26 +03:00
parent 71c8355698
commit 0db163aea8
3 changed files with 40 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
Yesod/Dispatch.hs
View File

@ -93,7 +93,7 @@ mkYesod name = fmap (uncurry (++)) . mkYesodGeneral name [] [] False
-- executable by itself, but instead provides functionality to -- executable by itself, but instead provides functionality to
-- be embedded in other sites. -- be embedded in other sites.
mkYesodSub :: String -- ^ name of the argument datatype mkYesodSub :: String -- ^ name of the argument datatype
-> [(String, [Name])] -> Cxt
-> [Resource] -> [Resource]
-> Q [Dec] -> Q [Dec]
mkYesodSub name clazzes = mkYesodSub name clazzes =
@ -130,7 +130,7 @@ typeHelper =
mkYesodGeneral :: String -- ^ argument name mkYesodGeneral :: String -- ^ argument name
-> [String] -- ^ parameters for site argument -> [String] -- ^ parameters for site argument
-> [(String, [Name])] -- ^ classes -> Cxt -- ^ classes
-> Bool -- ^ is subsite? -> Bool -- ^ is subsite?
-> [Resource] -> [Resource]
-> Q ([Dec], [Dec]) -> Q ([Dec], [Dec])
@ -138,10 +138,6 @@ mkYesodGeneral name args clazzes isSub res = do
let name' = mkName name let name' = mkName name
args' = map mkName args args' = map mkName args
arg = foldl AppT (ConT name') $ map VarT args' arg = foldl AppT (ConT name') $ map VarT args'
let clazzes' = map (\(x, y) -> ClassP x [typeHelper y])
$ concatMap (\(x, y) -> zip y $ repeat x)
$ compact
$ map (\x -> (x, [])) ("master" : args) ++ clazzes
th <- mapM (thResourceFromResource arg) res -- FIXME now we cannot have multi-nested subsites th <- mapM (thResourceFromResource arg) res -- FIXME now we cannot have multi-nested subsites
w' <- createRoutes th w' <- createRoutes th
let routesName = mkName $ name ++ "Route" let routesName = mkName $ name ++ "Route"
@ -166,7 +162,7 @@ mkYesodGeneral name args clazzes isSub res = do
let site' = site `AppE` dispatch `AppE` render `AppE` parse let site' = site `AppE` dispatch `AppE` render `AppE` parse
let (ctx, ytyp, yfunc) = let (ctx, ytyp, yfunc) =
if isSub if isSub
then (clazzes', ConT ''YesodSubSite `AppT` arg `AppT` VarT (mkName "master"), "getSubSite") then (clazzes, ConT ''YesodSubSite `AppT` arg `AppT` VarT (mkName "master"), "getSubSite")
else ([], ConT ''YesodSite `AppT` arg, "getSite") else ([], ConT ''YesodSite `AppT` arg, "getSite")
let y = InstanceD ctx ytyp let y = InstanceD ctx ytyp
[ FunD (mkName yfunc) [Clause [] (NormalB site') []] [ FunD (mkName yfunc) [Clause [] (NormalB site') []]

42
Yesod/Form.hs
View File

@ -5,6 +5,7 @@
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
-- | Parse forms (and query strings). -- | Parse forms (and query strings).
module Yesod.Form module Yesod.Form
( -- * Data types ( -- * Data types
@ -204,9 +205,9 @@ fieldsToTable = mapM_ go
%td.errors $err$ %td.errors $err$
|] |]
class ToForm a where class ToForm a y where
toForm :: Maybe a -> Form sub y a toForm :: Maybe a -> Form sub y a
class ToFormField a where class ToFormField a y where
toFormField :: Html () -> Html () -> Maybe a -> FormField sub y a toFormField :: Html () -> Html () -> Maybe a -> FormField sub y a
-- | Create a required field (ie, one that cannot be blank) from a -- | Create a required field (ie, one that cannot be blank) from a
@ -304,9 +305,9 @@ stringFieldProfile = FieldProfile
, fpLabel = mempty , fpLabel = mempty
, fpTooltip = mempty , fpTooltip = mempty
} }
instance ToFormField String where instance ToFormField String y where
toFormField = stringField toFormField = stringField
instance ToFormField (Maybe String) where instance ToFormField (Maybe String) y where
toFormField = maybeStringField toFormField = maybeStringField
intInput :: Integral i => String -> FormInput sub master i intInput :: Integral i => String -> FormInput sub master i
@ -346,13 +347,13 @@ intFieldProfile = FieldProfile
readMayI s = case reads s of readMayI s = case reads s of
(x, _):_ -> Just $ fromInteger x (x, _):_ -> Just $ fromInteger x
[] -> Nothing [] -> Nothing
instance ToFormField Int where instance ToFormField Int y where
toFormField = intField toFormField = intField
instance ToFormField (Maybe Int) where instance ToFormField (Maybe Int) y where
toFormField = maybeIntField toFormField = maybeIntField
instance ToFormField Int64 where instance ToFormField Int64 y where
toFormField = intField toFormField = intField
instance ToFormField (Maybe Int64) where instance ToFormField (Maybe Int64) y where
toFormField = maybeIntField toFormField = maybeIntField
doubleField :: Html () -> Html () -> FormletField sub y Double doubleField :: Html () -> Html () -> FormletField sub y Double
@ -379,9 +380,9 @@ doubleFieldProfile = FieldProfile
, fpLabel = mempty , fpLabel = mempty
, fpTooltip = mempty , fpTooltip = mempty
} }
instance ToFormField Double where instance ToFormField Double y where
toFormField = doubleField toFormField = doubleField
instance ToFormField (Maybe Double) where instance ToFormField (Maybe Double) y where
toFormField = maybeDoubleField toFormField = maybeDoubleField
dayField :: Html () -> Html () -> FormletField sub y Day dayField :: Html () -> Html () -> FormletField sub y Day
@ -408,9 +409,9 @@ dayFieldProfile = FieldProfile
, fpLabel = mempty , fpLabel = mempty
, fpTooltip = mempty , fpTooltip = mempty
} }
instance ToFormField Day where instance ToFormField Day y where
toFormField = dayField toFormField = dayField
instance ToFormField (Maybe Day) where instance ToFormField (Maybe Day) y where
toFormField = maybeDayField toFormField = maybeDayField
jqueryDayField :: Yesod y => Html () -> Html () -> FormletField sub y Day jqueryDayField :: Yesod y => Html () -> Html () -> FormletField sub y Day
@ -556,9 +557,9 @@ timeFieldProfile = FieldProfile
, fpLabel = mempty , fpLabel = mempty
, fpTooltip = mempty , fpTooltip = mempty
} }
instance ToFormField TimeOfDay where instance ToFormField TimeOfDay y where
toFormField = timeField toFormField = timeField
instance ToFormField (Maybe TimeOfDay) where instance ToFormField (Maybe TimeOfDay) y where
toFormField = maybeTimeField toFormField = maybeTimeField
boolField :: Html () -> Html () -> Maybe Bool -> FormField sub y Bool boolField :: Html () -> Html () -> Maybe Bool -> FormField sub y Bool
@ -582,7 +583,7 @@ boolField label tooltip orig = GForm $ \env _ -> do
_ -> Nothing _ -> Nothing
} }
return (res, [fi], UrlEncoded) return (res, [fi], UrlEncoded)
instance ToFormField Bool where instance ToFormField Bool y where
toFormField = boolField toFormField = boolField
htmlField :: Html () -> Html () -> FormletField sub y (Html ()) htmlField :: Html () -> Html () -> FormletField sub y (Html ())
@ -609,9 +610,9 @@ htmlFieldProfile = FieldProfile
, fpLabel = mempty , fpLabel = mempty
, fpTooltip = mempty , fpTooltip = mempty
} }
instance ToFormField (Html ()) where instance ToFormField (Html ()) y where
toFormField = htmlField toFormField = htmlField
instance ToFormField (Maybe (Html ())) where instance ToFormField (Maybe (Html ())) y where
toFormField = maybeHtmlField toFormField = maybeHtmlField
type Html' = Html () type Html' = Html ()
@ -816,8 +817,8 @@ share2 f g a = do
return $ f' ++ g' return $ f' ++ g'
-- | Create 'ToForm' instances for the entities given. In addition to regular 'EntityDef' attributes understood by persistent, it also understands label= and tooltip=. -- | Create 'ToForm' instances for the entities given. In addition to regular 'EntityDef' attributes understood by persistent, it also understands label= and tooltip=.
mkToForm :: [EntityDef] -> Q [Dec] mkToForm :: String -> [EntityDef] -> Q [Dec]
mkToForm = mapM derive mkToForm name = mapM derive
where where
getTFF (_, _, z) = fromMaybe "toFormField" $ getTFF' z getTFF (_, _, z) = fromMaybe "toFormField" $ getTFF' z
getTFF' [] = Nothing getTFF' [] = Nothing
@ -853,7 +854,8 @@ mkToForm = mapM derive
(NormalB $ go_ $ zip cols xs') (NormalB $ go_ $ zip cols xs')
[] []
return $ InstanceD [] (ConT ''ToForm return $ InstanceD [] (ConT ''ToForm
`AppT` ConT (mkName $ entityName t)) `AppT` ConT (mkName $ entityName t)
`AppT` ConT (mkName name))
[FunD (mkName "toForm") [c1, c2]] [FunD (mkName "toForm") [c1, c2]]
go ap just' string' mfx ftt a = go ap just' string' mfx ftt a =
let x = foldl (ap' ap) just' $ map (go' string') a let x = foldl (ap' ap) just' $ map (go' string') a

24
Yesod/Helpers/Crud.hs
View File

@ -18,9 +18,10 @@ import Yesod.Handler
import Text.Hamlet import Text.Hamlet
import Yesod.Form import Yesod.Form
import Data.Monoid (mempty) import Data.Monoid (mempty)
import Language.Haskell.TH.Syntax
-- | An entity which can be displayed by the Crud subsite. -- | An entity which can be displayed by the Crud subsite.
class ToForm a => Item a where class Item a where
-- | The title of an entity, to be displayed in the list of all entities. -- | The title of an entity, to be displayed in the list of all entities.
itemTitle :: a -> String itemTitle :: a -> String
@ -36,9 +37,10 @@ data Crud master item = Crud
} }
mkYesodSub "Crud master item" mkYesodSub "Crud master item"
[ ("master", [''Yesod]) [ ClassP ''Yesod [VarT $ mkName "master"]
, ("item", [''Item]) , ClassP ''Item [VarT $ mkName "item"]
, ("Key item", [''SinglePiece]) , ClassP ''SinglePiece [ConT ''Key `AppT` VarT (mkName "item")]
, ClassP ''ToForm [VarT $ mkName "item", VarT $ mkName "master"]
] [$parseRoutes| ] [$parseRoutes|
/ CrudListR GET / CrudListR GET
/add CrudAddR GET POST /add CrudAddR GET POST
@ -62,21 +64,24 @@ getCrudListR = do
%a!href=@toMaster.CrudAddR@ Add new item %a!href=@toMaster.CrudAddR@ Add new item
|] |]
getCrudAddR :: (Yesod master, Item item, SinglePiece (Key item)) getCrudAddR :: (Yesod master, Item item, SinglePiece (Key item),
ToForm item master)
=> GHandler (Crud master item) master RepHtml => GHandler (Crud master item) master RepHtml
getCrudAddR = crudHelper getCrudAddR = crudHelper
"Add new" "Add new"
(Nothing :: Maybe (Key item, item)) (Nothing :: Maybe (Key item, item))
False False
postCrudAddR :: (Yesod master, Item item, SinglePiece (Key item)) postCrudAddR :: (Yesod master, Item item, SinglePiece (Key item),
ToForm item master)
=> GHandler (Crud master item) master RepHtml => GHandler (Crud master item) master RepHtml
postCrudAddR = crudHelper postCrudAddR = crudHelper
"Add new" "Add new"
(Nothing :: Maybe (Key item, item)) (Nothing :: Maybe (Key item, item))
True True
getCrudEditR :: (Yesod master, Item item, SinglePiece (Key item)) getCrudEditR :: (Yesod master, Item item, SinglePiece (Key item),
ToForm item master)
=> String -> GHandler (Crud master item) master RepHtml => String -> GHandler (Crud master item) master RepHtml
getCrudEditR s = do getCrudEditR s = do
itemId <- maybe notFound return $ itemReadId s itemId <- maybe notFound return $ itemReadId s
@ -87,7 +92,8 @@ getCrudEditR s = do
(Just (itemId, item)) (Just (itemId, item))
False False
postCrudEditR :: (Yesod master, Item item, SinglePiece (Key item)) postCrudEditR :: (Yesod master, Item item, SinglePiece (Key item),
ToForm item master)
=> String -> GHandler (Crud master item) master RepHtml => String -> GHandler (Crud master item) master RepHtml
postCrudEditR s = do postCrudEditR s = do
itemId <- maybe notFound return $ itemReadId s itemId <- maybe notFound return $ itemReadId s
@ -128,7 +134,7 @@ itemReadId :: SinglePiece x => String -> Maybe x
itemReadId = either (const Nothing) Just . fromSinglePiece itemReadId = either (const Nothing) Just . fromSinglePiece
crudHelper crudHelper
:: (Item a, Yesod master, SinglePiece (Key a)) :: (Item a, Yesod master, SinglePiece (Key a), ToForm a master)
=> String -> Maybe (Key a, a) -> Bool => String -> Maybe (Key a, a) -> Bool
-> GHandler (Crud master a) master RepHtml -> GHandler (Crud master a) master RepHtml
crudHelper title me isPost = do crudHelper title me isPost = do