From c29f5af95cf53edf3a2bdd4df9580c18b0d7dc3b Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 18 Oct 2010 23:19:35 +0200 Subject: [PATCH] Support for free-forms This adds a whole bunch of polymorphism to the forms library, and opens up a monad approach which exposes the FieldInfos generated. This allows you to layout your form however you want without mucking around with guessing the location of the fieldinfos in a list. --- Yesod/Form.hs | 30 +++++++----- Yesod/Form/Core.hs | 114 +++++++++++++++++++++++++++++++++++-------- Yesod/Form/Fields.hs | 92 +++++++++++++++++++++------------- freeform.hs | 40 +++++++++++++++ 4 files changed, 211 insertions(+), 65 deletions(-) create mode 100644 freeform.hs diff --git a/Yesod/Form.hs b/Yesod/Form.hs index ae260350..4f85368e 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -11,6 +11,7 @@ module Yesod.Form , Enctype (..) , FormFieldSettings (..) , Textarea (..) + , FieldInfo (..) -- * Type synonyms , Form , Formlet @@ -19,7 +20,9 @@ module Yesod.Form , FormInput -- * Unwrapping functions , runFormGet + , runFormMonadGet , runFormPost + , runFormMonadPost , runFormGet' , runFormPost' -- * Field/form helpers @@ -46,8 +49,6 @@ import Control.Applicative hiding (optional) import Data.Maybe (fromMaybe, mapMaybe) import "transformers" Control.Monad.IO.Class import Control.Monad ((<=<)) -import Control.Monad.Trans.State -import Control.Monad.Trans.Reader import Language.Haskell.TH.Syntax import Database.Persist.Base (EntityDef (..), PersistEntity (entityDef)) import Data.Char (toUpper, isUpper) @@ -89,17 +90,16 @@ fieldsToDivs = mapFormXml $ mapM_ go |] clazz fi = if fiRequired fi then "required" else "optional" -runFormGeneric :: Env - -> FileEnv - -> GForm sub y xml a - -> GHandler sub y (FormResult a, xml, Enctype) -runFormGeneric env fe (GForm f) = - runReaderT (runReaderT (evalStateT f $ IntSingle 1) env) fe +-- | Run a form against POST parameters. +runFormPost :: GForm s m xml a -> GHandler s m (FormResult a, xml, Enctype) +runFormPost f = do + rr <- getRequest + (pp, files) <- liftIO $ reqRequestBody rr + runFormGeneric pp files f -- | Run a form against POST parameters. -runFormPost :: GForm sub y xml a - -> GHandler sub y (FormResult a, xml, Enctype) -runFormPost f = do +runFormMonadPost :: GFormMonad s m a -> GHandler s m (a, Enctype) +runFormMonadPost f = do rr <- getRequest (pp, files) <- liftIO $ reqRequestBody rr runFormGeneric pp files f @@ -120,12 +120,16 @@ helper (FormFailure e, _, _) = invalidArgs e helper (FormMissing, _, _) = invalidArgs ["No input found"] -- | Run a form against GET parameters. -runFormGet :: GForm sub y xml a - -> GHandler sub y (FormResult a, xml, Enctype) +runFormGet :: GForm s m xml a -> GHandler s m (FormResult a, xml, Enctype) runFormGet f = do gs <- reqGetParams `fmap` getRequest runFormGeneric gs [] f +runFormMonadGet :: GFormMonad s m a -> GHandler s m (a, Enctype) +runFormMonadGet f = do + gs <- reqGetParams `fmap` getRequest + runFormGeneric gs [] f + -- | Create 'ToForm' instances for the given entity. In addition to regular 'EntityDef' attributes understood by persistent, it also understands label= and tooltip=. mkToForm :: PersistEntity v => v -> Q [Dec] mkToForm = diff --git a/Yesod/Form/Core.hs b/Yesod/Form/Core.hs index 50227baa..cbacbcbf 100644 --- a/Yesod/Form/Core.hs +++ b/Yesod/Form/Core.hs @@ -1,4 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} module Yesod.Form.Core ( FormResult (..) , GForm (..) @@ -18,6 +21,9 @@ module Yesod.Form.Core , askParams , askFiles , liftForm + , IsForm (..) + , RunForm (..) + , GFormMonad -- * Data types , FieldInfo (..) , FormFieldSettings (..) @@ -32,6 +38,7 @@ module Yesod.Form.Core import Control.Monad.Trans.State import Control.Monad.Trans.Reader +import Control.Monad.Trans.Writer import Control.Monad.Trans.Class (lift) import Yesod.Handler import Yesod.Widget @@ -90,14 +97,19 @@ incrInts (IntCons i is) = (i + 1) `IntCons` is -- | A generic form, allowing you to specifying the subsite datatype, master -- site datatype, a datatype for the form XML and the return type. -newtype GForm sub y xml a = GForm - { deform :: StateT Ints ( - ReaderT Env ( - ReaderT FileEnv ( - (GHandler sub y) - ))) (FormResult a, xml, Enctype) +newtype GForm s m xml a = GForm + { deform :: FormInner s m (FormResult a, xml, Enctype) } +type GFormMonad s m a = WriterT Enctype (FormInner s m) a + +type FormInner s m = + StateT Ints ( + ReaderT Env ( + ReaderT FileEnv ( + GHandler s m + ))) + type Env = [(String, String)] type FileEnv = [(String, FileInfo)] @@ -134,10 +146,14 @@ instance Monoid xml => Applicative (GForm sub url xml) where return (f1 <*> g1, f2 `mappend` g2, f3 `mappend` g3) -- | Create a required field (ie, one that cannot be blank) from a --- 'FieldProfile'.ngs -requiredFieldHelper :: FieldProfile sub y a -> FormFieldSettings - -> Maybe a -> FormField sub y a -requiredFieldHelper (FieldProfile parse render mkWidget) ffs orig = GForm $ do +-- 'FieldProfile'. +requiredFieldHelper + :: IsForm f + => FieldProfile (FormSub f) (FormMaster f) (FormType f) + -> FormFieldSettings + -> Maybe (FormType f) + -> f +requiredFieldHelper (FieldProfile parse render mkWidget) ffs orig = toForm $ do env <- lift ask let (FormFieldSettings label tooltip theId' name') = ffs name <- maybe newFormIdent return name' @@ -153,7 +169,7 @@ requiredFieldHelper (FieldProfile parse render mkWidget) ffs orig = GForm $ do Left e -> (FormFailure [e], x) Right y -> (FormSuccess y, x) let fi = FieldInfo - { fiLabel = label + { fiLabel = string label , fiTooltip = tooltip , fiIdent = theId , fiInput = mkWidget theId name val True @@ -162,13 +178,70 @@ requiredFieldHelper (FieldProfile parse render mkWidget) ffs orig = GForm $ do _ -> Nothing , fiRequired = True } - return (res, [fi], UrlEncoded) + let res' = case res of + FormFailure [e] -> FormFailure [label ++ ": " ++ e] + _ -> res + return (res', fi, UrlEncoded) + +class IsForm f where + type FormSub f + type FormMaster f + type FormType f + toForm :: FormInner + (FormSub f) + (FormMaster f) + (FormResult (FormType f), + FieldInfo (FormSub f) (FormMaster f), + Enctype) -> f +instance IsForm (FormField s m a) where + type FormSub (FormField s m a) = s + type FormMaster (FormField s m a) = m + type FormType (FormField s m a) = a + toForm x = GForm $ do + (a, b, c) <- x + return (a, [b], c) +instance IsForm (GFormMonad s m (FormResult a, FieldInfo s m)) where + type FormSub (GFormMonad s m (FormResult a, FieldInfo s m)) = s + type FormMaster (GFormMonad s m (FormResult a, FieldInfo s m)) = m + type FormType (GFormMonad s m (FormResult a, FieldInfo s m)) = a + toForm x = do + (res, fi, enctype) <- lift x + tell enctype + return (res, fi) + +class RunForm f where + type RunFormSub f + type RunFormMaster f + type RunFormType f + runFormGeneric :: Env -> FileEnv -> f + -> GHandler (RunFormSub f) + (RunFormMaster f) + (RunFormType f) + +instance RunForm (GForm s m xml a) where + type RunFormSub (GForm s m xml a) = s + type RunFormMaster (GForm s m xml a) = m + type RunFormType (GForm s m xml a) = + (FormResult a, xml, Enctype) + runFormGeneric env fe (GForm f) = + runReaderT (runReaderT (evalStateT f $ IntSingle 1) env) fe + +instance RunForm (GFormMonad s m a) where + type RunFormSub (GFormMonad s m a) = s + type RunFormMaster (GFormMonad s m a) = m + type RunFormType (GFormMonad s m a) = (a, Enctype) + runFormGeneric e fe f = + runReaderT (runReaderT (evalStateT (runWriterT f) $ IntSingle 1) e) fe -- | Create an optional field (ie, one that can be blank) from a -- 'FieldProfile'. -optionalFieldHelper :: FieldProfile sub y a -> FormFieldSettings - -> FormletField sub y (Maybe a) -optionalFieldHelper (FieldProfile parse render mkWidget) ffs orig' = GForm $ do +optionalFieldHelper + :: (IsForm f, Maybe b ~ FormType f) + => FieldProfile (FormSub f) (FormMaster f) b + -> FormFieldSettings + -> Maybe (Maybe b) + -> f +optionalFieldHelper (FieldProfile parse render mkWidget) ffs orig' = toForm $ do env <- lift ask let (FormFieldSettings label tooltip theId' name') = ffs let orig = join orig' @@ -185,7 +258,7 @@ optionalFieldHelper (FieldProfile parse render mkWidget) ffs orig' = GForm $ do Left e -> (FormFailure [e], x) Right y -> (FormSuccess $ Just y, x) let fi = FieldInfo - { fiLabel = label + { fiLabel = string label , fiTooltip = tooltip , fiIdent = theId , fiInput = mkWidget theId name val False @@ -194,7 +267,10 @@ optionalFieldHelper (FieldProfile parse render mkWidget) ffs orig' = GForm $ do _ -> Nothing , fiRequired = False } - return (res, [fi], UrlEncoded) + let res' = case res of + FormFailure [e] -> FormFailure [label ++ ": " ++ e] + _ -> res + return (res', fi, UrlEncoded) fieldsToInput :: [FieldInfo sub y] -> [GWidget sub y ()] fieldsToInput = map fiInput @@ -218,13 +294,13 @@ data FieldInfo sub y = FieldInfo } data FormFieldSettings = FormFieldSettings - { ffsLabel :: Html + { ffsLabel :: String , ffsTooltip :: Html , ffsId :: Maybe String , ffsName :: Maybe String } instance IsString FormFieldSettings where - fromString s = FormFieldSettings (string s) mempty Nothing Nothing + fromString s = FormFieldSettings s mempty Nothing Nothing -- | A generic definition of a form field that can be used for generating both -- required and optional fields. See 'requiredFieldHelper and diff --git a/Yesod/Form/Fields.hs b/Yesod/Form/Fields.hs index 00efc901..79fb0c65 100644 --- a/Yesod/Form/Fields.hs +++ b/Yesod/Form/Fields.hs @@ -1,4 +1,6 @@ {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} module Yesod.Form.Fields ( -- * Fields -- ** Required @@ -49,10 +51,12 @@ import Data.Monoid import Control.Monad (join) import Data.Maybe (fromMaybe) -stringField :: FormFieldSettings -> FormletField sub y String +stringField :: (IsForm f, FormType f ~ String) + => FormFieldSettings -> Maybe String -> f stringField = requiredFieldHelper stringFieldProfile -maybeStringField :: FormFieldSettings -> FormletField sub y (Maybe String) +maybeStringField :: (IsForm f, FormType f ~ Maybe String) + => FormFieldSettings -> Maybe (Maybe String) -> f maybeStringField = optionalFieldHelper stringFieldProfile intInput :: Integral i => String -> FormInput sub master i @@ -65,32 +69,41 @@ maybeIntInput n = mapFormXml fieldsToInput $ optionalFieldHelper intFieldProfile (nameSettings n) Nothing -intField :: Integral i => FormFieldSettings -> FormletField sub y i +intField :: (Integral (FormType f), IsForm f) + => FormFieldSettings -> Maybe (FormType f) -> f intField = requiredFieldHelper intFieldProfile -maybeIntField :: Integral i => FormFieldSettings -> FormletField sub y (Maybe i) +maybeIntField :: (Integral i, FormType f ~ Maybe i, IsForm f) + => FormFieldSettings -> Maybe (FormType f) -> f maybeIntField = optionalFieldHelper intFieldProfile -doubleField :: FormFieldSettings -> FormletField sub y Double +doubleField :: (IsForm f, FormType f ~ Double) + => FormFieldSettings -> Maybe Double -> f doubleField = requiredFieldHelper doubleFieldProfile -maybeDoubleField :: FormFieldSettings -> FormletField sub y (Maybe Double) +maybeDoubleField :: (IsForm f, FormType f ~ Maybe Double) + => FormFieldSettings -> Maybe (Maybe Double) -> f maybeDoubleField = optionalFieldHelper doubleFieldProfile -dayField :: FormFieldSettings -> FormletField sub y Day +dayField :: (IsForm f, FormType f ~ Day) + => FormFieldSettings -> Maybe Day -> f dayField = requiredFieldHelper dayFieldProfile -maybeDayField :: FormFieldSettings -> FormletField sub y (Maybe Day) +maybeDayField :: (IsForm f, FormType f ~ Maybe Day) + => FormFieldSettings -> Maybe (Maybe Day) -> f maybeDayField = optionalFieldHelper dayFieldProfile -timeField :: FormFieldSettings -> FormletField sub y TimeOfDay +timeField :: (IsForm f, FormType f ~ TimeOfDay) + => FormFieldSettings -> Maybe TimeOfDay -> f timeField = requiredFieldHelper timeFieldProfile -maybeTimeField :: FormFieldSettings -> FormletField sub y (Maybe TimeOfDay) +maybeTimeField :: (IsForm f, FormType f ~ Maybe TimeOfDay) + => FormFieldSettings -> Maybe (Maybe TimeOfDay) -> f maybeTimeField = optionalFieldHelper timeFieldProfile -boolField :: FormFieldSettings -> Maybe Bool -> FormField sub y Bool -boolField ffs orig = GForm $ do +boolField :: (IsForm f, FormType f ~ Bool) + => FormFieldSettings -> Maybe Bool -> f +boolField ffs orig = toForm $ do env <- askParams let label = ffsLabel ffs tooltip = ffsTooltip ffs @@ -105,7 +118,7 @@ boolField ffs orig = GForm $ do Just "false" -> (FormSuccess False, False) Just _ -> (FormSuccess True, True) let fi = FieldInfo - { fiLabel = label + { fiLabel = string label , fiTooltip = tooltip , fiIdent = theId , fiInput = addBody [$hamlet| @@ -116,18 +129,22 @@ boolField ffs orig = GForm $ do _ -> Nothing , fiRequired = True } - return (res, [fi], UrlEncoded) + return (res, fi, UrlEncoded) -htmlField :: FormFieldSettings -> FormletField sub y Html +htmlField :: (IsForm f, FormType f ~ Html) + => FormFieldSettings -> Maybe Html -> f htmlField = requiredFieldHelper htmlFieldProfile -maybeHtmlField :: FormFieldSettings -> FormletField sub y (Maybe Html) +maybeHtmlField :: (IsForm f, FormType f ~ Maybe Html) + => FormFieldSettings -> Maybe (Maybe Html) -> f maybeHtmlField = optionalFieldHelper htmlFieldProfile -selectField :: Eq x => [(x, String)] +selectField :: (Eq x, IsForm f, FormType f ~ x) + => [(x, String)] -> FormFieldSettings - -> Maybe x -> FormField sub master x -selectField pairs ffs initial = GForm $ do + -> Maybe x + -> f +selectField pairs ffs initial = toForm $ do env <- askParams let label = ffsLabel ffs tooltip = ffsTooltip ffs @@ -155,7 +172,7 @@ selectField pairs ffs initial = GForm $ do %option!value=$show.fst.pair$!:isSelected.fst.snd.pair:selected $snd.snd.pair$ |] let fi = FieldInfo - { fiLabel = label + { fiLabel = string label , fiTooltip = tooltip , fiIdent = theId , fiInput = addBody input @@ -164,12 +181,14 @@ selectField pairs ffs initial = GForm $ do _ -> Nothing , fiRequired = True } - return (res, [fi], UrlEncoded) + return (res, fi, UrlEncoded) -maybeSelectField :: Eq x => [(x, String)] +maybeSelectField :: (Eq x, IsForm f, Maybe x ~ FormType f) + => [(x, String)] -> FormFieldSettings - -> FormletField sub master (Maybe x) -maybeSelectField pairs ffs initial' = GForm $ do + -> Maybe (FormType f) + -> f +maybeSelectField pairs ffs initial' = toForm $ do env <- askParams let initial = join initial' label = ffsLabel ffs @@ -198,7 +217,7 @@ maybeSelectField pairs ffs initial' = GForm $ do %option!value=$show.fst.pair$!:isSelected.fst.snd.pair:selected $snd.snd.pair$ |] let fi = FieldInfo - { fiLabel = label + { fiLabel = string label , fiTooltip = tooltip , fiIdent = theId , fiInput = addBody input @@ -207,7 +226,7 @@ maybeSelectField pairs ffs initial' = GForm $ do _ -> Nothing , fiRequired = False } - return (res, [fi], UrlEncoded) + return (res, fi, UrlEncoded) stringInput :: String -> FormInput sub master String stringInput n = @@ -245,10 +264,12 @@ maybeDayInput n = nameSettings :: String -> FormFieldSettings nameSettings n = FormFieldSettings mempty mempty (Just n) (Just n) -urlField :: FormFieldSettings -> FormletField sub y String +urlField :: (IsForm f, FormType f ~ String) + => FormFieldSettings -> Maybe String -> f urlField = requiredFieldHelper urlFieldProfile -maybeUrlField :: FormFieldSettings -> FormletField sub y (Maybe String) +maybeUrlField :: (IsForm f, FormType f ~ Maybe String) + => FormFieldSettings -> Maybe (Maybe String) -> f maybeUrlField = optionalFieldHelper urlFieldProfile urlInput :: String -> FormInput sub master String @@ -256,10 +277,12 @@ urlInput n = mapFormXml fieldsToInput $ requiredFieldHelper urlFieldProfile (nameSettings n) Nothing -emailField :: FormFieldSettings -> FormletField sub y String +emailField :: (IsForm f, FormType f ~ String) + => FormFieldSettings -> Maybe String -> f emailField = requiredFieldHelper emailFieldProfile -maybeEmailField :: FormFieldSettings -> FormletField sub y (Maybe String) +maybeEmailField :: (IsForm f, FormType f ~ Maybe String) + => FormFieldSettings -> Maybe (Maybe String) -> f maybeEmailField = optionalFieldHelper emailFieldProfile emailInput :: String -> FormInput sub master String @@ -267,14 +290,17 @@ emailInput n = mapFormXml fieldsToInput $ requiredFieldHelper emailFieldProfile (nameSettings n) Nothing -textareaField :: FormFieldSettings -> FormletField sub y Textarea +textareaField :: (IsForm f, FormType f ~ Textarea) + => FormFieldSettings -> Maybe Textarea -> f textareaField = requiredFieldHelper textareaFieldProfile maybeTextareaField :: FormFieldSettings -> FormletField sub y (Maybe Textarea) maybeTextareaField = optionalFieldHelper textareaFieldProfile -hiddenField :: FormFieldSettings -> FormletField sub y String +hiddenField :: (IsForm f, FormType f ~ String) + => FormFieldSettings -> Maybe String -> f hiddenField = requiredFieldHelper hiddenFieldProfile -maybeHiddenField :: FormFieldSettings -> FormletField sub y (Maybe String) +maybeHiddenField :: (IsForm f, FormType f ~ Maybe String) + => FormFieldSettings -> Maybe (Maybe String) -> f maybeHiddenField = optionalFieldHelper hiddenFieldProfile diff --git a/freeform.hs b/freeform.hs new file mode 100644 index 00000000..3f8b263a --- /dev/null +++ b/freeform.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE QuasiQuotes, TypeFamilies, OverloadedStrings #-} +import Yesod +import Control.Applicative + +data FreeForm = FreeForm +mkYesod "FreeForm" [$parseRoutes| +/ RootR GET +|] +instance Yesod FreeForm where approot _ = "" + +data Person = Person String Int String + deriving Show + +getRootR = do + ((merr, mperson, form), enctype) <- runFormMonadGet $ do + (name, namef) <- stringField "Name" Nothing + (age, agef) <- intField "Age" $ Just 25 + (color, colorf) <- stringField "Color" Nothing + let (merr, mperson) = + case Person <$> name <*> age <*> color of + FormSuccess p -> (Nothing, Just p) + FormFailure e -> (Just e, Nothing) + FormMissing -> (Nothing, Nothing) + let form = [$hamlet| +Hey, my name is ^fiInput.namef^ and I'm ^fiInput.agef^ years old and my favorite color is ^fiInput.colorf^. +|] + return (merr, mperson, form) + defaultLayout [$hamlet| +$maybe merr err + %ul!style=color:red + $forall err e + %li $e$ +$maybe mperson person + %p Last person: $show.person$ +%form!method=get!action=@RootR@!enctype=$enctype$ + %p ^form^ + %input!type=submit!value=Submit +|] + +main = basicHandler 3000 FreeForm