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

Simplified Formable type class again

Browse Source
This commit is contained in:
Michael Snoyman 2010-06-09 16:39:16 +03:00
parent 758b647de6
commit f8c157bb42
1 changed files with 25 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

55
Yesod/Formable.hs
View File

@ -119,8 +119,8 @@ check (Form form) f = Form $ \env -> liftM (first go) (form env)
Left errs -> FormFailure errs Left errs -> FormFailure errs
Right b -> FormSuccess b Right b -> FormSuccess b
class Formable y param a where class Formable a where
formable :: param -> Formlet y y a formable :: Formlet sub master a
wrapperRow :: String -> [String] -> Hamlet url -> Hamlet url wrapperRow :: String -> [String] -> Hamlet url -> Hamlet url
wrapperRow label errs control = [$hamlet| wrapperRow label errs control = [$hamlet|
@ -134,22 +134,22 @@ wrapperRow label errs control = [$hamlet|
%li $string.err$ %li $string.err$
|] |]
instance Formable y param [Char] where instance Formable [Char] where
formable _ = input' go formable = input' go
where where
go name val = [$hamlet| go name val = [$hamlet|
%input!type=text!name=$string.name$!value=$string.val$ %input!type=text!name=$string.name$!value=$string.val$
|] |]
instance Formable y param Html where instance Formable Html where
formable _ = fmap preEscapedString formable = fmap preEscapedString
. input' go . input' go
. fmap (Data.ByteString.Lazy.UTF8.toString . renderHtml) . fmap (Data.ByteString.Lazy.UTF8.toString . renderHtml)
where where
go name val = [$hamlet|%textarea!name=$string.name$ $string.val$|] go name val = [$hamlet|%textarea!name=$string.name$ $string.val$|]
instance Formable y param Day where instance Formable Day where
formable _ x = input' go (fmap show x) `check` asDay formable x = input' go (fmap show x) `check` asDay
where where
go name val = [$hamlet| go name val = [$hamlet|
%input!type=date!name=$string.name$!value=$string.val$ %input!type=date!name=$string.name$!value=$string.val$
@ -158,8 +158,8 @@ instance Formable y param Day where
(y, _):_ -> Right y (y, _):_ -> Right y
[] -> Left ["Invalid day"] [] -> Left ["Invalid day"]
instance Formable y param Bool where instance Formable Bool where
formable _ x = Form $ \env -> do formable x = Form $ \env -> do
i <- incr i <- incr
let i' = show i let i' = show i
let param = lookup i' env let param = lookup i' env
@ -170,8 +170,8 @@ instance Formable y param Bool where
%input!type=checkbox!name=$string.name$!:val:checked %input!type=checkbox!name=$string.name$!:val:checked
|] |]
instance Formable y param Int where instance Formable Int where
formable _ x = input' go (fmap show x) `check` asInt formable x = input' go (fmap show x) `check` asInt
where where
go name val = [$hamlet| go name val = [$hamlet|
%input!type=number!name=$string.name$!value=$string.val$ %input!type=number!name=$string.name$!value=$string.val$
@ -183,8 +183,8 @@ instance Formable y param Int where
newtype Slug = Slug { unSlug :: String } newtype Slug = Slug { unSlug :: String }
deriving (Read, Eq, Show, SinglePiece, Persistable) deriving (Read, Eq, Show, SinglePiece, Persistable)
instance Formable y param Slug where instance Formable Slug where
formable _ x = input' go (fmap unSlug x) `check` asSlug formable x = input' go (fmap unSlug x) `check` asSlug
where where
go name val = [$hamlet| go name val = [$hamlet|
%input!type=text!name=$string.name$!value=$string.val$ %input!type=text!name=$string.name$!value=$string.val$
@ -197,8 +197,8 @@ instance Formable y param Slug where
newtype NonEmptyString = NonEmptyString { unNonEmptyString :: String } newtype NonEmptyString = NonEmptyString { unNonEmptyString :: String }
deriving (Read, Eq, Show, SinglePiece, Persistable) deriving (Read, Eq, Show, SinglePiece, Persistable)
instance Formable y param NonEmptyString where instance Formable NonEmptyString where
formable _ x = input' go (fmap unNonEmptyString x) `check` notEmpty formable x = input' go (fmap unNonEmptyString x) `check` notEmpty
where where
go name val = [$hamlet| go name val = [$hamlet|
%input!type=text!name=$string.name$!value=$string.val$ %input!type=text!name=$string.name$!value=$string.val$
@ -212,8 +212,8 @@ share2 f g a = do
g' <- g a g' <- g a
return $ f' ++ g' return $ f' ++ g'
deriveFormable :: String -> String -> [Table] -> Q [Dec] deriveFormable :: [Table] -> Q [Dec]
deriveFormable yesod param = mapM derive deriveFormable = mapM derive
where where
derive :: Table -> Q Dec derive :: Table -> Q Dec
derive t = do derive t = do
@ -222,29 +222,24 @@ deriveFormable yesod param = mapM derive
just <- [|pure|] just <- [|pure|]
nothing <- [|Nothing|] nothing <- [|Nothing|]
let just' = just `AppE` ConE (mkName $ tableName t) let just' = just `AppE` ConE (mkName $ tableName t)
param' <- newName "param" let c1 = Clause [ ConP (mkName "Nothing") []
let c1 = Clause [ VarP param'
, ConP (mkName "Nothing") []
] ]
(NormalB $ go param' ap just' $ zip cols $ map (const nothing) cols) (NormalB $ go ap just' $ zip cols $ map (const nothing) cols)
[] []
xs <- mapM (const $ newName "x") cols xs <- mapM (const $ newName "x") cols
let xs' = map (AppE just . VarE) xs let xs' = map (AppE just . VarE) xs
let c2 = Clause [ VarP param' let c2 = Clause [ ConP (mkName "Just") [ConP (mkName $ tableName t)
, ConP (mkName "Just") [ConP (mkName $ tableName t)
$ map VarP xs]] $ map VarP xs]]
(NormalB $ go param' ap just' $ zip cols xs') (NormalB $ go ap just' $ zip cols xs')
[] []
return $ InstanceD [] (ConT ''Formable return $ InstanceD [] (ConT ''Formable
`AppT` ConT (mkName yesod)
`AppT` ConT (mkName param)
`AppT` ConT (mkName $ tableName t)) `AppT` ConT (mkName $ tableName t))
[FunD (mkName "formable") [c1, c2]] [FunD (mkName "formable") [c1, c2]]
go param' ap just' = foldl (ap' ap) just' . map (go' param') go ap just' = foldl (ap' ap) just' . map go'
go' param' (label, ex) = go' (label, ex) =
VarE (mkName "sealForm") `AppE` VarE (mkName "sealForm") `AppE`
(VarE (mkName "wrapperRow") `AppE` LitE (StringL label)) `AppE` (VarE (mkName "wrapperRow") `AppE` LitE (StringL label)) `AppE`
(VarE (mkName "formable") `AppE` VarE param' `AppE` ex) (VarE (mkName "formable") `AppE` ex)
ap' ap x y = InfixE (Just x) ap (Just y) ap' ap x y = InfixE (Just x) ap (Just y)
toLabel :: String -> String toLabel :: String -> String