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