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

More power Forms (getting ugly...)

Browse Source
This commit is contained in:
Michael Snoyman 2010-06-09 13:56:26 +03:00
parent 91da0ff1e5
commit 758b647de6
2 changed files with 94 additions and 50 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

143
Yesod/Formable.hs
View File

@ -3,54 +3,59 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Yesod.Formable
( Form (..)
, Formlet
, FormResult (..)
, runForm
, runIncr
, incr
, Formable (..)
, deriveFormable
, share2
, wrapperRow
, sealFormlet
, sealForm
, NonEmptyString (..)
, Slug (..)
) where
import Text.Hamlet
import Data.Time (Day)
import Control.Applicative
import Database.Persist (Persistable)
import Data.Char (isAlphaNum)
import Data.Char (isAlphaNum, toUpper, isUpper)
import Language.Haskell.TH.Syntax
import Database.Persist (Table (..))
import Database.Persist.Helper (upperFirst)
import Control.Monad (liftM)
import Control.Arrow (first)
import Data.Maybe (fromMaybe)
import Data.Maybe (fromMaybe, isJust)
import Data.Monoid (mempty, mappend)
import qualified Data.ByteString.Lazy.UTF8
import Yesod.Request
import Yesod.Handler
import Control.Monad.IO.Class (liftIO)
import Web.Routes.Quasi
import Control.Monad.Trans.State
import Web.Routes.Quasi (Routes, SinglePiece)
runForm :: Form (Routes y) a
runForm :: Form sub y a
-> GHandler sub y (FormResult a, Hamlet (Routes y))
runForm f = do
req <- getRequest
(pp, _) <- liftIO $ reqRequestBody req
return $ fst $ runIncr (deform f pp) 1
evalStateT (deform f pp) 1
type Env = [(String, String)]
newtype Incr a = Incr { runIncr :: Int -> (a, Int) }
incr :: Incr Int
incr = Incr $ \i -> (i + 1, i + 1)
instance Monad Incr where
return a = Incr $ \i -> (a, i)
Incr x >>= f = Incr $ \i ->
let (x', i') = x i
in runIncr (f x') i'
type Incr = StateT Int
incr :: Monad m => Incr m Int
incr = do
i <- get
let i' = i + 1
put i'
return i'
data FormResult a = FormMissing
| FormFailure [String]
@ -67,36 +72,36 @@ instance Applicative FormResult where
_ <*> (FormFailure y) = FormFailure y
_ <*> _ = FormMissing
newtype Form url a = Form
{ deform :: Env -> Incr (FormResult a, Hamlet url)
newtype Form sub y a = Form
{ deform :: Env -> Incr (GHandler sub y) (FormResult a, Hamlet (Routes y))
}
type Formlet url a = Maybe a -> Form url a
type Formlet sub y a = Maybe a -> Form sub y a
instance Functor (Form url) where
instance Functor (Form sub url) where
fmap f (Form g) = Form $ \env -> liftM (first $ fmap f) (g env)
instance Applicative (Form url) where
instance Applicative (Form sub url) where
pure a = Form $ const $ return (pure a, mempty)
(Form f) <*> (Form g) = Form $ \env -> do
(f1, f2) <- f env
(g1, g2) <- g env
return (f1 <*> g1, f2 `mappend` g2)
sealForm :: ([String] -> Hamlet url -> Hamlet url)
-> Form url a -> Form url a
sealForm :: ([String] -> Hamlet (Routes y) -> Hamlet (Routes y))
-> Form sub y a -> Form sub y a
sealForm wrapper (Form form) = Form $ \env -> liftM go (form env)
where
go (res, xml) = (res, wrapper (toList res) xml)
toList (FormFailure errs) = errs
toList _ = []
sealFormlet :: ([String] -> Hamlet url -> Hamlet url)
-> Formlet url a -> Formlet url a
sealFormlet :: ([String] -> Hamlet (Routes y) -> Hamlet (Routes y))
-> Formlet sub y a -> Formlet sub y a
sealFormlet wrapper formlet initVal = sealForm wrapper $ formlet initVal
input' :: (String -> String -> Hamlet url)
input' :: (String -> String -> Hamlet (Routes y))
-> Maybe String
-> Form url String
-> Form sub y String
input' mkXml val = Form $ \env -> do
i <- incr
let i' = show i
@ -104,7 +109,7 @@ input' mkXml val = Form $ \env -> do
let xml = mkXml i' $ fromMaybe (fromMaybe "" val) param
return (maybe FormMissing FormSuccess param, xml)
check :: Form url a -> (a -> Either [String] b) -> Form url b
check :: Form sub url a -> (a -> Either [String] b) -> Form sub url b
check (Form form) f = Form $ \env -> liftM (first go) (form env)
where
go FormMissing = FormMissing
@ -114,8 +119,8 @@ check (Form form) f = Form $ \env -> liftM (first go) (form env)
Left errs -> FormFailure errs
Right b -> FormSuccess b
class Formable a where
formable :: Formlet url a
class Formable y param a where
formable :: param -> Formlet y y a
wrapperRow :: String -> [String] -> Hamlet url -> Hamlet url
wrapperRow label errs control = [$hamlet|
@ -129,22 +134,22 @@ wrapperRow label errs control = [$hamlet|
%li $string.err$
|]
instance Formable [Char] where
formable = input' go
instance Formable y param [Char] where
formable _ = input' go
where
go name val = [$hamlet|
%input!type=text!name=$string.name$!value=$string.val$
|]
instance Formable Html where
formable = fmap preEscapedString
instance Formable y param Html where
formable _ = fmap preEscapedString
. input' go
. fmap (Data.ByteString.Lazy.UTF8.toString . renderHtml)
where
go name val = [$hamlet|%textarea!name=$string.name$ $string.val$|]
instance Formable Day where
formable x = input' go (fmap show x) `check` asDay
instance Formable y param Day where
formable _ x = input' go (fmap show x) `check` asDay
where
go name val = [$hamlet|
%input!type=date!name=$string.name$!value=$string.val$
@ -153,11 +158,33 @@ instance Formable Day where
(y, _):_ -> Right y
[] -> Left ["Invalid day"]
instance Formable y param Bool where
formable _ x = Form $ \env -> do
i <- incr
let i' = show i
let param = lookup i' env
let def = if null env then fromMaybe False x else isJust param
return (FormSuccess $ isJust param, go i' def)
where
go name val = [$hamlet|
%input!type=checkbox!name=$string.name$!:val:checked
|]
instance Formable y param Int where
formable _ x = input' go (fmap show x) `check` asInt
where
go name val = [$hamlet|
%input!type=number!name=$string.name$!value=$string.val$
|]
asInt s = case reads s of
(y, _):_ -> Right y
[] -> Left ["Invalid integer"]
newtype Slug = Slug { unSlug :: String }
deriving (Read, Eq, Show, SinglePiece, Persistable)
instance Formable Slug where
formable x = input' go (fmap unSlug x) `check` asSlug
instance Formable y param Slug where
formable _ x = input' go (fmap unSlug x) `check` asSlug
where
go name val = [$hamlet|
%input!type=text!name=$string.name$!value=$string.val$
@ -170,8 +197,8 @@ instance Formable Slug where
newtype NonEmptyString = NonEmptyString { unNonEmptyString :: String }
deriving (Read, Eq, Show, SinglePiece, Persistable)
instance Formable NonEmptyString where
formable x = input' go (fmap unNonEmptyString x) `check` notEmpty
instance Formable y param NonEmptyString where
formable _ x = input' go (fmap unNonEmptyString x) `check` notEmpty
where
go name val = [$hamlet|
%input!type=text!name=$string.name$!value=$string.val$
@ -185,30 +212,46 @@ share2 f g a = do
g' <- g a
return $ f' ++ g'
deriveFormable :: [Table] -> Q [Dec]
deriveFormable = mapM derive
deriveFormable :: String -> String -> [Table] -> Q [Dec]
deriveFormable yesod param = mapM derive
where
derive :: Table -> Q Dec
derive t = do
let cols = map (upperFirst . fst) $ tableColumns t
let cols = map (toLabel . fst) $ tableColumns t
ap <- [|(<*>)|]
just <- [|pure|]
nothing <- [|Nothing|]
let just' = just `AppE` ConE (mkName $ tableName t)
let c1 = Clause [ConP (mkName "Nothing") []]
(NormalB $ go ap just' $ zip cols $ map (const nothing) cols)
param' <- newName "param"
let c1 = Clause [ VarP param'
, ConP (mkName "Nothing") []
]
(NormalB $ go param' ap just' $ zip cols $ map (const nothing) cols)
[]
xs <- mapM (const $ newName "x") cols
let xs' = map (AppE just . VarE) xs
let c2 = Clause [ConP (mkName "Just") [ConP (mkName $ tableName t)
let c2 = Clause [ VarP param'
, ConP (mkName "Just") [ConP (mkName $ tableName t)
$ map VarP xs]]
(NormalB $ go ap just' $ zip cols xs')
(NormalB $ go param' ap just' $ zip cols xs')
[]
return $ InstanceD [] (ConT ''Formable `AppT` ConT (mkName $ tableName t))
return $ InstanceD [] (ConT ''Formable
`AppT` ConT (mkName yesod)
`AppT` ConT (mkName param)
`AppT` ConT (mkName $ tableName t))
[FunD (mkName "formable") [c1, c2]]
go ap just' = foldl (ap' ap) just' . map go'
go' (label, ex) =
go param' ap just' = foldl (ap' ap) just' . map (go' param')
go' param' (label, ex) =
VarE (mkName "sealForm") `AppE`
(VarE (mkName "wrapperRow") `AppE` LitE (StringL label)) `AppE`
(VarE (mkName "formable") `AppE` ex)
(VarE (mkName "formable") `AppE` VarE param' `AppE` ex)
ap' ap x y = InfixE (Just x) ap (Just y)
toLabel :: String -> String
toLabel "" = ""
toLabel (x:rest) = toUpper x : go rest
where
go "" = ""
go (c:cs)
| isUpper c = ' ' : c : go cs
| otherwise = c : go cs

1
Yesod/Helpers/Crud.hs
View File

@ -4,6 +4,7 @@
module Yesod.Helpers.Crud
( Item (..)
, Crud (..)
, CrudRoutes (..)
, defaultCrud
, siteCrud
) where