From 758b647de618dc4b0afc4380231d625c77a09912 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 9 Jun 2010 13:56:26 +0300 Subject: [PATCH] More power Forms (getting ugly...) --- Yesod/Formable.hs | 143 +++++++++++++++++++++++++++--------------- Yesod/Helpers/Crud.hs | 1 + 2 files changed, 94 insertions(+), 50 deletions(-) diff --git a/Yesod/Formable.hs b/Yesod/Formable.hs index be462ecb..d22be498 100644 --- a/Yesod/Formable.hs +++ b/Yesod/Formable.hs @@ -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 diff --git a/Yesod/Helpers/Crud.hs b/Yesod/Helpers/Crud.hs index 2c3e4947..505f0bc2 100644 --- a/Yesod/Helpers/Crud.hs +++ b/Yesod/Helpers/Crud.hs @@ -4,6 +4,7 @@ module Yesod.Helpers.Crud ( Item (..) , Crud (..) + , CrudRoutes (..) , defaultCrud , siteCrud ) where