From 713304e7efaf7379fc44fbfbd543960105386110 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 6 May 2011 18:21:34 +0300 Subject: [PATCH] Initial refactoring work: no polymorphic insanity --- Yesod/Form.hs | 66 +++++++++------- Yesod/Form/Class.hs | 3 + Yesod/Form/Core.hs | 168 +++++++++++------------------------------ Yesod/Form/Fields.hs | 101 +++++-------------------- Yesod/Form/Jquery.hs | 35 +-------- Yesod/Form/Nic.hs | 8 +- Yesod/Form/Profiles.hs | 30 ++++---- yesod-form.cabal | 4 +- 8 files changed, 126 insertions(+), 289 deletions(-) diff --git a/Yesod/Form.hs b/Yesod/Form.hs index fb19cf94..e3afde84 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -16,33 +16,41 @@ module Yesod.Form , FieldInfo (..) -- ** Utilities , formFailures + {- -- * Type synonyms , Form , Formlet , FormField , FormletField , FormInput + -} -- * Unwrapping functions , generateForm , runFormGet - , runFormMonadGet + --, runFormMonadGet , runFormPost , runFormPostNoNonce + {- , runFormMonadPost , runFormGet' , runFormPost' + -} -- ** High-level form post unwrappers + {- , runFormTable , runFormDivs + -} -- * Field/form helpers , fieldsToTable , fieldsToDivs , fieldsToPlain + {- , checkForm + -} -- * Type classes , module Yesod.Form.Class -- * Template Haskell - , mkToForm + --, mkToForm , module Yesod.Form.Fields ) where @@ -50,14 +58,14 @@ import Yesod.Form.Core import Yesod.Form.Fields import Yesod.Form.Class import Yesod.Form.Profiles (Textarea (..)) -import Yesod.Widget (GWidget) +import Yesod.Widget (GWidget, GGWidget) import Text.Hamlet import Yesod.Request import Yesod.Handler import Control.Applicative hiding (optional) import Data.Maybe (fromMaybe, mapMaybe) -import Control.Monad ((<=<)) +import Control.Monad ((<=<), liftM) import Language.Haskell.TH.Syntax hiding (lift) import Database.Persist.Base (EntityDef (..), PersistEntity (entityDef)) import Data.Char (toUpper, isUpper) @@ -65,6 +73,7 @@ import Control.Arrow ((&&&)) import Data.List (group, sort) import Data.Monoid (mempty) import Data.Text (Text) +import Control.Monad.Trans.RWS (runRWST) #if __GLASGOW_HASKELL__ >= 700 #define HAMLET hamlet @@ -72,12 +81,12 @@ import Data.Text (Text) #define HAMLET $hamlet #endif -- | Display only the actual input widget code, without any decoration. -fieldsToPlain :: FormField sub y a -> Form sub y a +fieldsToPlain :: (Monad mo, Monad mo') => GForm [FieldInfo (GGWidget master mo' ())] mo a -> GForm (GGWidget master mo' ()) mo a fieldsToPlain = mapFormXml $ mapM_ fiInput -- | Display the label, tooltip, input code and errors in a single row of a -- table. -fieldsToTable :: FormField sub y a -> Form sub y a +fieldsToTable :: (Monad mo, Monad mo') => GForm [FieldInfo (GGWidget master mo' ())] mo a -> GForm (GGWidget master mo' ()) mo a fieldsToTable = mapFormXml $ mapM_ go where go fi = [HAMLET| @@ -93,7 +102,7 @@ fieldsToTable = mapFormXml $ mapM_ go clazz fi = if fiRequired fi then "required" else "optional" :: Text -- | Display the label, tooltip, input code and errors in a single div. -fieldsToDivs :: FormField sub y a -> Form sub y a +fieldsToDivs :: (Monad mo, Monad mo') => GForm [FieldInfo (GGWidget master mo' ())] mo a -> GForm (GGWidget master mo' ()) mo a fieldsToDivs = mapFormXml $ mapM_ go where go fi = [HAMLET| @@ -107,7 +116,7 @@ fieldsToDivs = mapFormXml $ mapM_ go clazz fi = if fiRequired fi then "required" else "optional" :: Text -- | Run a form against POST parameters, without CSRF protection. -runFormPostNoNonce :: GForm s m xml a -> GHandler s m (FormResult a, xml, Enctype) +runFormPostNoNonce :: GForm xml (GHandler s m) a -> GHandler s m (a, xml, Enctype) runFormPostNoNonce f = do (pp, files) <- runRequestBody runFormGeneric pp files f @@ -117,17 +126,17 @@ runFormPostNoNonce f = do -- This function includes CSRF protection by checking a nonce value. You must -- therefore embed this nonce in the form as a hidden field; that is the -- meaning of the fourth element in the tuple. -runFormPost :: GForm s m xml a -> GHandler s m (FormResult a, xml, Enctype, Html) +runFormPost :: GForm xml (GHandler s m) (FormResult a) -> GHandler s m (FormResult a, xml, Enctype, Html) runFormPost f = do (pp, files) <- runRequestBody - nonce <- fmap reqNonce getRequest + nonce <- liftM reqNonce getRequest (res, xml, enctype) <- runFormGeneric pp files f let res' = case res of FormSuccess x -> if lookup nonceName pp == nonce then FormSuccess x - else FormFailure ["As a protection against cross-site request forgery attacks, please confirm your form submission."] + else FormFailure ["As a protection against cross-site request forgery attacks, please confirm your form submission."] -- TRANS _ -> res return (res', xml, enctype, maybe mempty hidden nonce) where @@ -138,13 +147,7 @@ runFormPost f = do nonceName :: Text nonceName = "_nonce" --- | Run a form against POST parameters. Please note that this does not provide --- CSRF protection. -runFormMonadPost :: GFormMonad s m a -> GHandler s m (a, Enctype) -runFormMonadPost f = do - (pp, files) <- runRequestBody - runFormGeneric pp files f - +{- FIXME -- | Run a form against POST parameters, disregarding the resulting HTML and -- returning an error response on invalid input. Note: this does /not/ perform -- CSRF protection. @@ -153,7 +156,9 @@ runFormPost' f = do (pp, files) <- runRequestBody x <- runFormGeneric pp files f helper x +-} +{- FIXME -- | Create a table-styled form. -- -- This function wraps around 'runFormPost' and 'fieldsToTable', taking care of @@ -173,7 +178,9 @@ runFormTable dest inputLabel form = do \#{nonce} |]) +-} +{- FIXME -- | Same as 'runFormPostTable', but uses 'fieldsToDivs' for styling. runFormDivs :: Route m -> String -> FormField s m a -> GHandler s m (FormResult a, GWidget s m ()) @@ -186,11 +193,14 @@ runFormDivs dest inputLabel form = do \#{nonce} |]) +-} +{- FIXME -- | Run a form against GET parameters, disregarding the resulting HTML and -- returning an error response on invalid input. -runFormGet' :: GForm sub y xml a -> GHandler sub y a +runFormGet' :: GForm xml mo a -> GHandler sub y a runFormGet' = helper <=< runFormGet +-} helper :: (FormResult a, b, c) -> GHandler sub y a helper (FormSuccess a, _, _) = return a @@ -199,26 +209,27 @@ helper (FormMissing, _, _) = invalidArgs ["No input found"] -- | Generate a form, feeding it no data. The third element in the result tuple -- is a nonce hidden field. -generateForm :: GForm s m xml a -> GHandler s m (xml, Enctype, Html) +generateForm :: Monad mo => GForm xml (GGHandler s m mo) a -> GGHandler s m mo (xml, Enctype, Html) generateForm f = do (_, b, c) <- runFormGeneric [] [] f - nonce <- fmap reqNonce getRequest + nonce <- liftM reqNonce getRequest return (b, c, [HAMLET|\ $maybe n <- nonce |]) -- | Run a form against GET parameters. -runFormGet :: GForm s m xml a -> GHandler s m (FormResult a, xml, Enctype) +runFormGet :: Monad mo => GForm xml (GGHandler s m mo) a -> GGHandler s m mo (a, xml, Enctype) runFormGet f = do - gs <- reqGetParams `fmap` getRequest + gs <- reqGetParams `liftM` getRequest runFormGeneric gs [] f -runFormMonadGet :: GFormMonad s m a -> GHandler s m (a, Enctype) -runFormMonadGet f = do - gs <- reqGetParams `fmap` getRequest - runFormGeneric gs [] f +runFormGeneric :: Monad mo => Env -> FileEnv -> GForm xml mo a -> mo (a, xml, Enctype) +runFormGeneric e fe f = do + (a, _s, (enc, xml)) <- runRWST f (e, fe) (IntSingle 1) + return (a, xml, enc) +{- FIXME -- | 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 = @@ -298,6 +309,7 @@ mkToForm = (stm name) in VarE (mkName tff) `AppE` ffs `AppE` ex ap' ap x y = InfixE (Just x) ap (Just y) +-} toLabel :: String -> String toLabel "" = "" diff --git a/Yesod/Form/Class.hs b/Yesod/Form/Class.hs index d6af8096..9e0457fb 100644 --- a/Yesod/Form/Class.hs +++ b/Yesod/Form/Class.hs @@ -2,6 +2,8 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeSynonymInstances #-} module Yesod.Form.Class +() where +{- FIXME Maybe we should remove this module entirely... ( ToForm (..) , ToFormField (..) ) where @@ -67,3 +69,4 @@ instance ToFormField Textarea y where toFormField = textareaField instance ToFormField (Maybe Textarea) y where toFormField = maybeTextareaField +-} diff --git a/Yesod/Form/Core.hs b/Yesod/Form/Core.hs index ec3a3bcc..59c065fb 100644 --- a/Yesod/Form/Core.hs +++ b/Yesod/Form/Core.hs @@ -8,39 +8,38 @@ module Yesod.Form.Core ( FormResult (..) , GForm (..) , newFormIdent + {- FIXME , deeperFormIdent , shallowerFormIdent + -} , Env , FileEnv , Enctype (..) , Ints (..) , requiredFieldHelper , optionalFieldHelper - , fieldsToInput , mapFormXml + {- FIXME , checkForm , checkField + -} , askParams , askFiles - , liftForm - , IsForm (..) - , RunForm (..) - , GFormMonad -- * Data types , FieldInfo (..) , FormFieldSettings (..) , FieldProfile (..) -- * Type synonyms + {- FIXME , Form , Formlet , FormField , FormletField , FormInput + -} ) where -import Control.Monad.Trans.State -import Control.Monad.Trans.Reader -import Control.Monad.Trans.Writer +import Control.Monad.Trans.RWS import Control.Monad.Trans.Class (lift) import Yesod.Handler import Yesod.Widget @@ -83,7 +82,7 @@ instance Monoid m => Monoid (FormResult m) where mempty = pure mempty mappend x y = mappend <$> x <*> y --- | The encoding type required by a form. The 'Show' instance produces values +-- | The encoding type required by a form. The 'ToHtml' instance produces values -- that can be inserted directly into HTML. data Enctype = UrlEncoded | Multipart deriving (Eq, Enum, Bounded) @@ -104,32 +103,19 @@ incrInts :: Ints -> Ints incrInts (IntSingle i) = IntSingle $ i + 1 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 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 GForm xml m a = RWST (Env, FileEnv) (Enctype, xml) Ints m a -- FIXME rename to Form type Env = [(Text, Text)] type FileEnv = [(Text, FileInfo)] -- | Get a unique identifier. -newFormIdent :: Monad m => StateT Ints m Text +newFormIdent :: (Monoid xml, Monad m) => GForm xml m Text newFormIdent = do i <- get let i' = incrInts i put i' return $ pack $ 'f' : show i' +{- FIXME deeperFormIdent :: Monad m => StateT Ints m () deeperFormIdent = do i <- get @@ -140,30 +126,18 @@ shallowerFormIdent :: Monad m => StateT Ints m () shallowerFormIdent = do IntCons _ i <- get put i - -instance Monoid xml => Functor (GForm sub url xml) where - fmap f (GForm g) = - GForm $ liftM (first3 $ fmap f) g - where - first3 f' (x, y, z) = (f' x, y, z) - -instance Monoid xml => Applicative (GForm sub url xml) where - pure a = GForm $ return (pure a, mempty, mempty) - (GForm f) <*> (GForm g) = GForm $ do - (f1, f2, f3) <- f - (g1, g2, g3) <- g - return (f1 <*> g1, f2 `mappend` g2, f3 `mappend` g3) +-} -- | Create a required field (ie, one that cannot be blank) from a -- 'FieldProfile'. requiredFieldHelper - :: IsForm f - => FieldProfile (FormSub f) (FormMaster f) (FormType f) + :: (Monoid xml', Monad m) + => FieldProfile xml a -> FormFieldSettings - -> Maybe (FormType f) - -> f -requiredFieldHelper (FieldProfile parse render mkWidget) ffs orig = toForm $ do - env <- lift ask + -> Maybe a + -> GForm xml' m (FormResult a, FieldInfo xml) +requiredFieldHelper (FieldProfile parse render mkWidget) ffs orig = do + env <- askParams let (FormFieldSettings label tooltip theId' name') = ffs name <- maybe newFormIdent return name' theId <- maybe newFormIdent return theId' @@ -172,7 +146,7 @@ requiredFieldHelper (FieldProfile parse render mkWidget) ffs orig = toForm $ do then (FormMissing, maybe "" render orig) else case lookup name env of Nothing -> (FormMissing, "") - Just "" -> (FormFailure ["Value is required"], "") + Just "" -> (FormFailure ["Value is required"], "") -- TRANS Just x -> case parse x of Left e -> (FormFailure [e], x) @@ -190,68 +164,18 @@ requiredFieldHelper (FieldProfile parse render mkWidget) ffs orig = toForm $ do 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 (FormResult ~ formResult) => 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 + return (res', fi) -- | Create an optional field (ie, one that can be blank) from a -- 'FieldProfile'. optionalFieldHelper - :: (IsForm f, Maybe b ~ FormType f) - => FieldProfile (FormSub f) (FormMaster f) b + :: (Monad m, Monoid xml') + => FieldProfile xml b -> FormFieldSettings -> Maybe (Maybe b) - -> f -optionalFieldHelper (FieldProfile parse render mkWidget) ffs orig' = toForm $ do - env <- lift ask + -> GForm xml' m (FormResult (Maybe b), FieldInfo xml) +optionalFieldHelper (FieldProfile parse render mkWidget) ffs orig' = do + env <- askParams let (FormFieldSettings label tooltip theId' name') = ffs let orig = join orig' name <- maybe newFormIdent return name' @@ -279,25 +203,22 @@ optionalFieldHelper (FieldProfile parse render mkWidget) ffs orig' = toForm $ do 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 + return (res', fi) -- | Convert the XML in a 'GForm'. -mapFormXml :: (xml1 -> xml2) -> GForm s y xml1 a -> GForm s y xml2 a -mapFormXml f (GForm g) = GForm $ do - (res, xml, enc) <- g - return (res, f xml, enc) +mapFormXml :: Monad m => (xml1 -> xml2) -> GForm xml1 m a -> GForm xml2 m a +mapFormXml f = mapRWST $ \x -> do + (a, b, (c, d)) <- x + return (a, b, (c, f d)) -- | Using this as the intermediate XML representation for fields allows us to -- write generic field functions and then different functions for producing -- actual HTML. See, for example, 'fieldsToTable' and 'fieldsToPlain'. -data FieldInfo sub y = FieldInfo +data FieldInfo xml = FieldInfo { fiLabel :: Html , fiTooltip :: Html , fiIdent :: Text - , fiInput :: GWidget sub y () + , fiInput :: xml , fiErrors :: Maybe Html , fiRequired :: Bool } @@ -314,19 +235,22 @@ instance IsString FormFieldSettings where -- | A generic definition of a form field that can be used for generating both -- required and optional fields. See 'requiredFieldHelper and -- 'optionalFieldHelper'. -data FieldProfile sub y a = FieldProfile +data FieldProfile xml a = FieldProfile { fpParse :: Text -> Either Text a , fpRender :: a -> Text -- | ID, name, value, required - , fpWidget :: Text -> Text -> Text -> Bool -> GWidget sub y () + , fpWidget :: Text -> Text -> Text -> Bool -> xml } +{- FIXME type Form sub y = GForm sub y (GWidget sub y ()) type Formlet sub y a = Maybe a -> Form sub y a -type FormField sub y = GForm sub y [FieldInfo sub y] -type FormletField sub y a = Maybe a -> FormField sub y a type FormInput sub y = GForm sub y [GWidget sub y ()] +type FormField xml m = GForm xml m [FieldInfo xml] +type FormletField xml m a = Maybe a -> FormField xml a +-} +{- FIXME -- | Add a validation check to a form. -- -- Note that if there is a validation error, this message will /not/ @@ -345,7 +269,7 @@ checkForm f (GForm form) = GForm $ do -- Unlike 'checkForm', the validation error will appear in the generated HTML -- of the form. checkField :: (a -> Either Text b) -> FormField s m a -> FormField s m b -checkField f (GForm form) = GForm $ do +checkField f form = do (res, xml, enc) <- form let (res', merr) = case res of @@ -365,12 +289,10 @@ checkField f (GForm form) = GForm $ do Just x -> x } return (res', xml', enc) +-} -askParams :: Monad m => StateT Ints (ReaderT Env m) Env -askParams = lift ask +askParams :: (Monoid xml, Monad m) => GForm xml m Env +askParams = liftM fst ask -askFiles :: Monad m => StateT Ints (ReaderT Env (ReaderT FileEnv m)) FileEnv -askFiles = lift $ lift ask - -liftForm :: Monad m => m a -> StateT Ints (ReaderT Env (ReaderT FileEnv m)) a -liftForm = lift . lift . lift +askFiles :: (Monoid xml, Monad m) => GForm xml m FileEnv +askFiles = liftM snd ask diff --git a/Yesod/Form/Fields.hs b/Yesod/Form/Fields.hs index faf63846..98291d47 100644 --- a/Yesod/Form/Fields.hs +++ b/Yesod/Form/Fields.hs @@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoMonomorphismRestriction #-} -- FIXME remove module Yesod.Form.Fields ( -- * Fields -- ** Required @@ -38,6 +39,7 @@ module Yesod.Form.Fields , maybeSearchField , maybeUrlField , maybeFileField + {- FIXME -- * Inputs -- ** Required , stringInput @@ -50,6 +52,7 @@ module Yesod.Form.Fields , maybeStringInput , maybeDayInput , maybeIntInput + -} ) where import Yesod.Form.Core @@ -72,67 +75,41 @@ import qualified Data.Text as T #define HAMLET $hamlet #endif -stringField :: (IsForm f, FormType f ~ Text) - => FormFieldSettings -> Maybe Text -> f stringField = requiredFieldHelper stringFieldProfile -maybeStringField :: (IsForm f, FormType f ~ Maybe Text) - => FormFieldSettings -> Maybe (Maybe Text) -> f maybeStringField = optionalFieldHelper stringFieldProfile -passwordField :: (IsForm f, FormType f ~ Text) - => FormFieldSettings -> Maybe Text -> f passwordField = requiredFieldHelper passwordFieldProfile -maybePasswordField :: (IsForm f, FormType f ~ Maybe Text) - => FormFieldSettings -> Maybe (Maybe Text) -> f maybePasswordField = optionalFieldHelper passwordFieldProfile -intInput :: Integral i => Text -> FormInput sub master i +{- FIXME intInput n = mapFormXml fieldsToInput $ requiredFieldHelper intFieldProfile (nameSettings n) Nothing -maybeIntInput :: Integral i => Text -> FormInput sub master (Maybe i) maybeIntInput n = mapFormXml fieldsToInput $ optionalFieldHelper intFieldProfile (nameSettings n) Nothing +-} -intField :: (Integral (FormType f), IsForm f) - => FormFieldSettings -> Maybe (FormType f) -> f intField = requiredFieldHelper intFieldProfile -maybeIntField :: (Integral i, FormType f ~ Maybe i, IsForm f) - => FormFieldSettings -> Maybe (FormType f) -> f maybeIntField = optionalFieldHelper intFieldProfile -doubleField :: (IsForm f, FormType f ~ Double) - => FormFieldSettings -> Maybe Double -> f doubleField = requiredFieldHelper doubleFieldProfile -maybeDoubleField :: (IsForm f, FormType f ~ Maybe Double) - => FormFieldSettings -> Maybe (Maybe Double) -> f maybeDoubleField = optionalFieldHelper doubleFieldProfile -dayField :: (IsForm f, FormType f ~ Day) - => FormFieldSettings -> Maybe Day -> f dayField = requiredFieldHelper dayFieldProfile -maybeDayField :: (IsForm f, FormType f ~ Maybe Day) - => FormFieldSettings -> Maybe (Maybe Day) -> f maybeDayField = optionalFieldHelper dayFieldProfile -timeField :: (IsForm f, FormType f ~ TimeOfDay) - => FormFieldSettings -> Maybe TimeOfDay -> f timeField = requiredFieldHelper timeFieldProfile -maybeTimeField :: (IsForm f, FormType f ~ Maybe TimeOfDay) - => FormFieldSettings -> Maybe (Maybe TimeOfDay) -> f maybeTimeField = optionalFieldHelper timeFieldProfile -boolField :: (IsForm f, FormType f ~ Bool) - => FormFieldSettings -> Maybe Bool -> f -boolField ffs orig = toForm $ do +boolField ffs orig = do env <- askParams let label = ffsLabel ffs tooltip = ffsTooltip ffs @@ -160,20 +137,11 @@ boolField ffs orig = toForm $ do } return (res, fi, UrlEncoded) -htmlField :: (IsForm f, FormType f ~ Html) - => FormFieldSettings -> Maybe Html -> f htmlField = requiredFieldHelper htmlFieldProfile -maybeHtmlField :: (IsForm f, FormType f ~ Maybe Html) - => FormFieldSettings -> Maybe (Maybe Html) -> f maybeHtmlField = optionalFieldHelper htmlFieldProfile -selectField :: (Eq x, IsForm f, FormType f ~ x) - => [(x, Text)] - -> FormFieldSettings - -> Maybe x - -> f -selectField pairs ffs initial = toForm $ do +selectField pairs ffs initial = do env <- askParams let label = ffsLabel ffs tooltip = ffsTooltip ffs @@ -217,12 +185,7 @@ selectField pairs ffs initial = toForm $ do } return (res, fi, UrlEncoded) -maybeSelectField :: (Eq x, IsForm f, Maybe x ~ FormType f) - => [(x, Text)] - -> FormFieldSettings - -> Maybe (FormType f) - -> f -maybeSelectField pairs ffs initial' = toForm $ do +maybeSelectField pairs ffs initial' = do env <- askParams let initial = join initial' label = ffsLabel ffs @@ -267,6 +230,7 @@ maybeSelectField pairs ffs initial' = toForm $ do } return (res, fi, UrlEncoded) +{- FIXME stringInput :: Text -> FormInput sub master Text stringInput n = mapFormXml fieldsToInput $ @@ -299,62 +263,46 @@ maybeDayInput :: Text -> FormInput sub master (Maybe Day) maybeDayInput n = mapFormXml fieldsToInput $ optionalFieldHelper dayFieldProfile (nameSettings n) Nothing +-} nameSettings :: Text -> FormFieldSettings nameSettings n = FormFieldSettings mempty mempty (Just n) (Just n) -urlField :: (IsForm f, FormType f ~ Text) - => FormFieldSettings -> Maybe Text -> f urlField = requiredFieldHelper urlFieldProfile -maybeUrlField :: (IsForm f, FormType f ~ Maybe Text) - => FormFieldSettings -> Maybe (Maybe Text) -> f maybeUrlField = optionalFieldHelper urlFieldProfile +{- FIXME urlInput :: Text -> FormInput sub master Text urlInput n = mapFormXml fieldsToInput $ requiredFieldHelper urlFieldProfile (nameSettings n) Nothing +-} -emailField :: (IsForm f, FormType f ~ Text) - => FormFieldSettings -> Maybe Text -> f emailField = requiredFieldHelper emailFieldProfile -maybeEmailField :: (IsForm f, FormType f ~ Maybe Text) - => FormFieldSettings -> Maybe (Maybe Text) -> f maybeEmailField = optionalFieldHelper emailFieldProfile +{- FIXME emailInput :: Text -> FormInput sub master Text emailInput n = mapFormXml fieldsToInput $ requiredFieldHelper emailFieldProfile (nameSettings n) Nothing +-} -searchField :: (IsForm f, FormType f ~ Text) - => AutoFocus -> FormFieldSettings -> Maybe Text -> f searchField = requiredFieldHelper . searchFieldProfile -maybeSearchField :: (IsForm f, FormType f ~ Maybe Text) - => AutoFocus -> FormFieldSettings -> Maybe (Maybe Text) -> f maybeSearchField = optionalFieldHelper . searchFieldProfile -textareaField :: (IsForm f, FormType f ~ Textarea) - => FormFieldSettings -> Maybe Textarea -> f textareaField = requiredFieldHelper textareaFieldProfile -maybeTextareaField :: FormFieldSettings -> FormletField sub y (Maybe Textarea) maybeTextareaField = optionalFieldHelper textareaFieldProfile -hiddenField :: (IsForm f, FormType f ~ Text) - => FormFieldSettings -> Maybe Text -> f hiddenField = requiredFieldHelper hiddenFieldProfile -maybeHiddenField :: (IsForm f, FormType f ~ Maybe Text) - => FormFieldSettings -> Maybe (Maybe Text) -> f maybeHiddenField = optionalFieldHelper hiddenFieldProfile -fileField :: (IsForm f, FormType f ~ FileInfo) - => FormFieldSettings -> f -fileField ffs = toForm $ do +fileField ffs = do env <- lift ask fenv <- lift $ lift ask let (FormFieldSettings label tooltip theId' name') = ffs @@ -381,9 +329,7 @@ fileField ffs = toForm $ do _ -> res return (res', fi, Multipart) -maybeFileField :: (IsForm f, FormType f ~ Maybe FileInfo) - => FormFieldSettings -> f -maybeFileField ffs = toForm $ do +maybeFileField ffs = do fenv <- lift $ lift ask let (FormFieldSettings label tooltip theId' name') = ffs name <- maybe newFormIdent return name' @@ -404,12 +350,7 @@ fileWidget theId name isReq = [HAMLET| |] -radioField :: (Eq x, IsForm f, FormType f ~ x) - => [(x, Text)] - -> FormFieldSettings - -> Maybe x - -> f -radioField pairs ffs initial = toForm $ do +radioField pairs ffs initial = do env <- askParams let label = ffsLabel ffs tooltip = ffsTooltip ffs @@ -449,13 +390,7 @@ radioField pairs ffs initial = toForm $ do } return (res, fi, UrlEncoded) -maybeRadioField - :: (Eq x, IsForm f, FormType f ~ Maybe x) - => [(x, Text)] - -> FormFieldSettings - -> Maybe (FormType f) - -> f -maybeRadioField pairs ffs initial' = toForm $ do +maybeRadioField pairs ffs initial' = do env <- askParams let initial = join initial' label = ffsLabel ffs diff --git a/Yesod/Form/Jquery.hs b/Yesod/Form/Jquery.hs index 4520549d..78adf44d 100644 --- a/Yesod/Form/Jquery.hs +++ b/Yesod/Form/Jquery.hs @@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoMonomorphismRestriction #-} -- FIXME remove -- | Some fields spiced up with jQuery UI. module Yesod.Form.Jquery ( YesodJquery (..) @@ -67,23 +68,10 @@ class YesodJquery a where urlJqueryUiDateTimePicker :: a -> Either (Route a) Text urlJqueryUiDateTimePicker _ = Right "http://github.com/gregwebs/jquery.ui.datetimepicker/raw/master/jquery.ui.datetimepicker.js" -jqueryDayField :: (IsForm f, FormType f ~ Day, YesodJquery (FormMaster f)) - => JqueryDaySettings - -> FormFieldSettings - -> Maybe (FormType f) - -> f jqueryDayField = requiredFieldHelper . jqueryDayFieldProfile -maybeJqueryDayField - :: (IsForm f, FormType f ~ Maybe Day, YesodJquery (FormMaster f)) - => JqueryDaySettings - -> FormFieldSettings - -> Maybe (FormType f) - -> f maybeJqueryDayField = optionalFieldHelper . jqueryDayFieldProfile -jqueryDayFieldProfile :: YesodJquery y - => JqueryDaySettings -> FieldProfile sub y Day jqueryDayFieldProfile jds = FieldProfile { fpParse = maybe (Left "Invalid day, must be in YYYY-MM-DD format") @@ -128,11 +116,6 @@ ifRight e f = case e of showLeadingZero :: (Show a) => a -> String showLeadingZero time = let t = show time in if length t == 1 then "0" ++ t else t -jqueryDayTimeField - :: (IsForm f, FormType f ~ UTCTime, YesodJquery (FormMaster f)) - => FormFieldSettings - -> Maybe (FormType f) - -> f jqueryDayTimeField = requiredFieldHelper jqueryDayTimeFieldProfile -- use A.M/P.M and drop seconds and "UTC" (as opposed to normal UTCTime show) @@ -145,7 +128,6 @@ jqueryDayTimeUTCTime (UTCTime day utcTime) = let (h, apm) = if hour < 12 then (hour, "AM") else (hour - 12, "PM") in (show h) ++ ":" ++ (showLeadingZero minute) ++ " " ++ apm -jqueryDayTimeFieldProfile :: YesodJquery y => FieldProfile sub y UTCTime jqueryDayTimeFieldProfile = FieldProfile { fpParse = parseUTCTime . unpack , fpRender = pack . jqueryDayTimeUTCTime @@ -172,24 +154,12 @@ parseUTCTime s = ifRight (parseTime timeS) (UTCTime date . timeOfDayToTime) -jqueryAutocompleteField - :: (IsForm f, FormType f ~ Text, YesodJquery (FormMaster f)) - => Route (FormMaster f) - -> FormFieldSettings - -> Maybe (FormType f) - -> f jqueryAutocompleteField = requiredFieldHelper . jqueryAutocompleteFieldProfile -maybeJqueryAutocompleteField - :: (IsForm f, FormType f ~ Maybe Text, YesodJquery (FormMaster f)) - => Route (FormMaster f) - -> FormFieldSettings - -> Maybe (FormType f) - -> f maybeJqueryAutocompleteField src = optionalFieldHelper $ jqueryAutocompleteFieldProfile src -jqueryAutocompleteFieldProfile :: YesodJquery y => Route y -> FieldProfile sub y Text +jqueryAutocompleteFieldProfile :: YesodJquery master => Route master -> FieldProfile (GWidget sub master ()) Text jqueryAutocompleteFieldProfile src = FieldProfile { fpParse = Right , fpRender = id @@ -205,7 +175,6 @@ $(function(){$("##{theId}").autocomplete({source:"@{src}",minLength:2})}); |] } -addScript' :: (y -> Either (Route y) Text) -> GWidget sub y () addScript' f = do y <- lift getYesod addScriptEither $ f y diff --git a/Yesod/Form/Nic.hs b/Yesod/Form/Nic.hs index 121472c2..bd2bce58 100644 --- a/Yesod/Form/Nic.hs +++ b/Yesod/Form/Nic.hs @@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoMonomorphismRestriction #-} -- FIXME remove -- | Provide the user with a rich text editor. module Yesod.Form.Nic ( YesodNic (..) @@ -26,16 +27,11 @@ class YesodNic a where urlNicEdit :: a -> Either (Route a) Text urlNicEdit _ = Right "http://js.nicedit.com/nicEdit-latest.js" -nicHtmlField :: (IsForm f, FormType f ~ Html, YesodNic (FormMaster f)) - => FormFieldSettings -> Maybe Html -> f nicHtmlField = requiredFieldHelper nicHtmlFieldProfile -maybeNicHtmlField - :: (IsForm f, FormType f ~ Maybe Html, YesodNic (FormMaster f)) - => FormFieldSettings -> Maybe (FormType f) -> f maybeNicHtmlField = optionalFieldHelper nicHtmlFieldProfile -nicHtmlFieldProfile :: YesodNic y => FieldProfile sub y Html +--nicHtmlFieldProfile :: YesodNic y => FieldProfile sub y Html nicHtmlFieldProfile = FieldProfile { fpParse = Right . preEscapedString . sanitizeBalance . unpack -- FIXME , fpRender = pack . renderHtml diff --git a/Yesod/Form/Profiles.hs b/Yesod/Form/Profiles.hs index 6630cd7e..12c1ff3b 100644 --- a/Yesod/Form/Profiles.hs +++ b/Yesod/Form/Profiles.hs @@ -52,7 +52,7 @@ import Data.Text (Text, unpack, pack) #define JULIUS $julius #endif -intFieldProfile :: Integral i => FieldProfile sub y i +intFieldProfile :: (Monad monad, Integral i) => FieldProfile (GGWidget master monad ()) i intFieldProfile = FieldProfile { fpParse = maybe (Left "Invalid integer") Right . readMayI . unpack -- FIXME Data.Text.Read , fpRender = pack . showI @@ -67,7 +67,7 @@ intFieldProfile = FieldProfile (x, _):_ -> Just $ fromInteger x [] -> Nothing -doubleFieldProfile :: FieldProfile sub y Double +doubleFieldProfile :: Monad monad => FieldProfile (GGWidget master monad ()) Double doubleFieldProfile = FieldProfile { fpParse = maybe (Left "Invalid number") Right . readMay . unpack -- FIXME use Data.Text.Read , fpRender = pack . show @@ -77,7 +77,7 @@ doubleFieldProfile = FieldProfile |] } -dayFieldProfile :: FieldProfile sub y Day +dayFieldProfile :: Monad monad => FieldProfile (GGWidget master monad ()) Day dayFieldProfile = FieldProfile { fpParse = parseDate . unpack , fpRender = pack . show @@ -87,7 +87,7 @@ dayFieldProfile = FieldProfile |] } -timeFieldProfile :: FieldProfile sub y TimeOfDay +timeFieldProfile :: Monad monad => FieldProfile (GGWidget master monad ()) TimeOfDay timeFieldProfile = FieldProfile { fpParse = parseTime . unpack , fpRender = pack . show . roundFullSeconds @@ -102,7 +102,7 @@ timeFieldProfile = FieldProfile where fullSec = fromInteger $ floor $ todSec tod -htmlFieldProfile :: FieldProfile sub y Html +htmlFieldProfile :: Monad monad => FieldProfile (GGWidget master monad ()) Html htmlFieldProfile = FieldProfile { fpParse = Right . preEscapedString . sanitizeBalance . unpack -- FIXME make changes to xss-sanitize , fpRender = pack . renderHtml @@ -130,7 +130,7 @@ instance ToHtml Textarea where writeHtmlEscapedChar '\n' = writeByteString "
" writeHtmlEscapedChar c = B.writeHtmlEscapedChar c -textareaFieldProfile :: FieldProfile sub y Textarea +textareaFieldProfile :: Monad monad => FieldProfile (GGWidget master monad ()) Textarea textareaFieldProfile = FieldProfile { fpParse = Right . Textarea , fpRender = unTextarea @@ -140,7 +140,7 @@ textareaFieldProfile = FieldProfile |] } -hiddenFieldProfile :: FieldProfile sub y Text +hiddenFieldProfile :: Monad monad => FieldProfile (GGWidget master monad ()) Text hiddenFieldProfile = FieldProfile { fpParse = Right , fpRender = id @@ -150,7 +150,7 @@ hiddenFieldProfile = FieldProfile |] } -stringFieldProfile :: FieldProfile sub y Text +stringFieldProfile :: Monad monad => FieldProfile (GGWidget master monad ()) Text stringFieldProfile = FieldProfile { fpParse = Right , fpRender = id @@ -160,7 +160,7 @@ stringFieldProfile = FieldProfile |] } -passwordFieldProfile :: FieldProfile s m Text +passwordFieldProfile :: Monad monad => FieldProfile (GGWidget master monad ()) Text passwordFieldProfile = FieldProfile { fpParse = Right , fpRender = id @@ -208,7 +208,7 @@ parseTimeHelper (h1, h2, m1, m2, s1, s2) m = read [m1, m2] s = fromInteger $ read [s1, s2] -emailFieldProfile :: FieldProfile s y Text +emailFieldProfile :: Monad monad => FieldProfile (GGWidget master monad ()) Text emailFieldProfile = FieldProfile { fpParse = \s -> if Email.isValid (unpack s) then Right s @@ -221,7 +221,7 @@ emailFieldProfile = FieldProfile } type AutoFocus = Bool -searchFieldProfile :: AutoFocus -> FieldProfile s y Text +searchFieldProfile :: Monad monad => AutoFocus -> FieldProfile (GGWidget master monad ()) Text searchFieldProfile autoFocus = FieldProfile { fpParse = Right , fpRender = id @@ -238,14 +238,14 @@ searchFieldProfile autoFocus = FieldProfile |] } -urlFieldProfile :: FieldProfile s y Text +urlFieldProfile :: Monad monad => FieldProfile (GGWidget master monad ()) Text urlFieldProfile = FieldProfile { fpParse = \s -> case parseURI $ unpack s of Nothing -> Left "Invalid URL" Just _ -> Right s , fpRender = id - , fpWidget = \theId name val isReq -> addHamlet - [HAMLET|\ - + , fpWidget = \theId name val isReq -> addHtml + [HAMLET| + |] } diff --git a/yesod-form.cabal b/yesod-form.cabal index 6155af31..800165cc 100644 --- a/yesod-form.cabal +++ b/yesod-form.cabal @@ -1,5 +1,5 @@ name: yesod-form -version: 0.1.0.1 +version: 0.2.0 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -36,7 +36,7 @@ library Yesod.Form.Jquery Yesod.Form.Nic Yesod.Form.Profiles - Yesod.Helpers.Crud + -- FIXME Yesod.Helpers.Crud ghc-options: -Wall source-repository head