Initial refactoring work: no polymorphic insanity

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
+{- FIXME
--- CSRF protection.
-runFormMonadPost :: GFormMonad s m a -> GHandler s m (a, Enctype)
-runFormMonadPost f = do
-    (pp, files) <- runRequestBody
-    runFormGeneric pp files f
-
 -- | 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}
                 <input type="submit" value="#{inputLabel}">
 |])
+-}
 
+{- 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}
         <input type="submit" value="#{inputLabel}">
 |])
+-}
 
+{- 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
     <input type="hidden" name="#{nonceName}" value="#{n}">
 |])
 
 -- | 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)
+runFormGeneric :: Monad mo => Env -> FileEnv -> GForm xml mo a -> mo (a, xml, Enctype)
-runFormMonadGet f = do
+runFormGeneric e fe f = do
-    gs <- reqGetParams `fmap` getRequest
+    (a, _s, (enc, xml)) <- runRWST f (e, fe) (IntSingle 1)
-    runFormGeneric gs [] f
+    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 "" = ""

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
+-}

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.RWS
-import Control.Monad.Trans.Reader
-import Control.Monad.Trans.Writer
 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
+type GForm xml m a = RWST (Env, FileEnv) (Enctype, xml) Ints m a -- FIXME rename to Form
--- 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 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
+    :: (Monoid xml', Monad m)
-    => FieldProfile (FormSub f) (FormMaster f) (FormType f)
+    => FieldProfile xml a
     -> FormFieldSettings
-    -> Maybe (FormType f)
+    -> Maybe a
-    -> f
+    -> GForm xml' m (FormResult a, FieldInfo xml)
-requiredFieldHelper (FieldProfile parse render mkWidget) ffs orig = toForm $ do
+requiredFieldHelper (FieldProfile parse render mkWidget) ffs orig = do
-    env <- lift ask
+    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)
+    return (res', fi)
-
-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
 
 -- | Create an optional field (ie, one that can be blank) from a
 -- 'FieldProfile'.
 optionalFieldHelper
-    :: (IsForm f, Maybe b ~ FormType f)
+    :: (Monad m, Monoid xml')
-    => FieldProfile (FormSub f) (FormMaster f) b
+    => FieldProfile xml b
     -> FormFieldSettings
     -> Maybe (Maybe b)
-    -> f
+    -> GForm xml' m (FormResult (Maybe b), FieldInfo xml)
-optionalFieldHelper (FieldProfile parse render mkWidget) ffs orig' = toForm $ do
+optionalFieldHelper (FieldProfile parse render mkWidget) ffs orig' = do
-    env <- lift ask
+    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)
+    return (res', fi)
-
-fieldsToInput :: [FieldInfo sub y] -> [GWidget sub y ()]
-fieldsToInput = map fiInput
 
 -- | Convert the XML in a 'GForm'.
-mapFormXml :: (xml1 -> xml2) -> GForm s y xml1 a -> GForm s y xml2 a
+mapFormXml :: Monad m => (xml1 -> xml2) -> GForm xml1 m a -> GForm xml2 m a
-mapFormXml f (GForm g) = GForm $ do
+mapFormXml f = mapRWST $ \x -> do
-    (res, xml, enc) <- g
+    (a, b, (c, d)) <- x
-    return (res, f xml, enc)
+    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 :: (Monoid xml, Monad m) => GForm xml m Env
-askParams = lift ask
+askParams = liftM fst ask
 
-askFiles :: Monad m => StateT Ints (ReaderT Env (ReaderT FileEnv m)) FileEnv
+askFiles :: (Monoid xml, Monad m) => GForm xml m FileEnv
-askFiles = lift $ lift ask
+askFiles = liftM snd ask
-
-liftForm :: Monad m => m a -> StateT Ints (ReaderT Env (ReaderT FileEnv m)) a
-liftForm = lift . lift . lift

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)
+boolField ffs orig = do
-          => FormFieldSettings -> Maybe Bool -> f
-boolField ffs orig = toForm $ 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)
+selectField pairs ffs initial = do
-            => [(x, Text)]
-            -> FormFieldSettings
-            -> Maybe x
-            -> f
-selectField pairs ffs initial = toForm $ 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)
+maybeSelectField pairs ffs initial' = do
-                 => [(x, Text)]
-                 -> FormFieldSettings
-                 -> Maybe (FormType f)
-                 -> f
-maybeSelectField pairs ffs initial' = toForm $ 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)
+fileField ffs = do
-          => FormFieldSettings -> f
-fileField ffs = toForm $ 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)
+maybeFileField ffs = do
-               => FormFieldSettings -> f
-maybeFileField ffs = toForm $ 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|
 <input id="#{theId}" type="file" name="#{name}" :isReq:required="">
 |]
 
-radioField :: (Eq x, IsForm f, FormType f ~ x)
+radioField pairs ffs initial = do
-           => [(x, Text)]
-           -> FormFieldSettings
-           -> Maybe x
-           -> f
-radioField pairs ffs initial = toForm $ 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
+maybeRadioField pairs ffs initial' = do
-    :: (Eq x, IsForm f, FormType f ~ Maybe x)
-    => [(x, Text)]
-    -> FormFieldSettings
-    -> Maybe (FormType f)
-    -> f
-maybeRadioField pairs ffs initial' = toForm $ do
     env <- askParams
     let initial = join initial'
         label = ffsLabel ffs

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

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

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 "<br>"
         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
+    , fpWidget = \theId name val isReq -> addHtml
-        [HAMLET|\
+        [HAMLET|
-<input id="#{theId}" name="#{name}" type="url" :isReq:required="" value="#{val}">
+<input ##{theId} name=#{name} type=url :isReq:required value=#{val}>
 |]
     }

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 <michael@snoyman.com>
@@ -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