GForm uses ReaderT

Yesod/Form.hs

@@ -44,6 +44,7 @@ import Data.Maybe (fromMaybe, mapMaybe)
 import "transformers" Control.Monad.IO.Class
 import Control.Monad ((<=<))
 import Control.Monad.Trans.State
+import Control.Monad.Trans.Reader
 import Language.Haskell.TH.Syntax
 import Database.Persist.Base (EntityDef (..))
 import Data.Char (toUpper, isUpper)
@@ -76,7 +77,8 @@ runFormGeneric :: Env
                -> FileEnv
                -> GForm sub y xml a
                -> GHandler sub y (FormResult a, xml, Enctype)
-runFormGeneric env fe f = evalStateT (deform f env fe) $ IntSingle 1
+runFormGeneric env fe (GForm f) =
+    runReaderT (runReaderT (evalStateT f $ IntSingle 1) env) fe
 
 -- | Run a form against POST parameters.
 runFormPost :: GForm sub y xml a

Yesod/Form/Core.hs

@@ -14,6 +14,9 @@ module Yesod.Form.Core
     , fieldsToInput
     , mapFormXml
     , checkForm
+    , askParams
+    , askFiles
+    , liftForm
       -- * Data types
     , FieldInfo (..)
     , FormFieldSettings (..)
@@ -27,6 +30,8 @@ module Yesod.Form.Core
     ) where
 
 import Control.Monad.Trans.State
+import Control.Monad.Trans.Reader
+import Control.Monad.Trans.Class (lift)
 import Yesod.Handler
 import Yesod.Widget
 import Data.Monoid (Monoid (..))
@@ -85,7 +90,11 @@ incrInts (IntCons i is) = (i + 1) `IntCons` is
 -- | A generic form, allowing you to specifying the subsite datatype, master
 -- site datatype, a datatype for the form XML and the return type.
 newtype GForm sub y xml a = GForm
-    { deform :: Env -> FileEnv -> StateT Ints (GHandler sub y) (FormResult a, xml, Enctype)
+    { deform :: StateT Ints (
+                ReaderT Env (
+                ReaderT FileEnv (
+                (GHandler sub y)
+                ))) (FormResult a, xml, Enctype)
     }
 
 type Env = [(String, String)]
@@ -112,23 +121,23 @@ shallowerFormIdent = do
 
 instance Monoid xml => Functor (GForm sub url xml) where
     fmap f (GForm g) =
-        GForm $ \env fe -> liftM (first3 $ fmap f) (g env fe)
+        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 $ const $ const $ return (pure a, mempty, mempty)
+    pure a = GForm $ return (pure a, mempty, mempty)
-    (GForm f) <*> (GForm g) = GForm $ \env fe -> do
+    (GForm f) <*> (GForm g) = GForm $ do
-        (f1, f2, f3) <- f env fe
+        (f1, f2, f3) <- f
-        (g1, g2, g3) <- g env fe
+        (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'.ngs
 requiredFieldHelper :: FieldProfile sub y a -> FormFieldSettings
                     -> Maybe a -> FormField sub y a
-requiredFieldHelper (FieldProfile parse render mkWidget) ffs orig =
+requiredFieldHelper (FieldProfile parse render mkWidget) ffs orig = GForm $ do
-  GForm $ \env _ -> do
+    env <- lift ask
     let (FormFieldSettings label tooltip theId' name') = ffs
     name <- maybe newFormIdent return name'
     theId <- maybe newFormIdent return theId'
@@ -158,8 +167,8 @@ requiredFieldHelper (FieldProfile parse render mkWidget) ffs orig =
 -- 'FieldProfile'.
 optionalFieldHelper :: FieldProfile sub y a -> FormFieldSettings
                     -> FormletField sub y (Maybe a)
-optionalFieldHelper (FieldProfile parse render mkWidget) ffs orig' =
+optionalFieldHelper (FieldProfile parse render mkWidget) ffs orig' = GForm $ do
-  GForm $ \env _ -> do
+    env <- lift ask
     let (FormFieldSettings label tooltip theId' name') = ffs
     let orig = join orig'
     name <- maybe newFormIdent return name'
@@ -191,8 +200,8 @@ fieldsToInput = map fiInput
 
 -- | Convert the XML in a 'GForm'.
 mapFormXml :: (xml1 -> xml2) -> GForm s y xml1 a -> GForm s y xml2 a
-mapFormXml f (GForm g) = GForm $ \e fe -> do
+mapFormXml f (GForm g) = GForm $ do
-    (res, xml, enc) <- g e fe
+    (res, xml, enc) <- g
     return (res, f xml, enc)
 
 -- | Using this as the intermediate XML representation for fields allows us to
@@ -233,10 +242,19 @@ type FormletField sub y a = Maybe a -> FormField sub y a
 type FormInput sub y = GForm sub y [GWidget sub y ()]
 
 checkForm :: (a -> FormResult b) -> GForm s m x a -> GForm s m x b
-checkForm f (GForm form) = GForm $ \env fenv -> do
+checkForm f (GForm form) = GForm $ do
-    (res, xml, enc) <- form env fenv
+    (res, xml, enc) <- form
     let res' = case res of
                     FormSuccess a -> f a
                     FormFailure e -> FormFailure e
                     FormMissing -> FormMissing
     return (res', xml, enc)
+
+askParams :: Monad m => StateT Ints (ReaderT Env m) Env
+askParams = lift 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

Yesod/Form/Fields.hs

@@ -84,7 +84,8 @@ maybeTimeField :: FormFieldSettings -> FormletField sub y (Maybe TimeOfDay)
 maybeTimeField = optionalFieldHelper timeFieldProfile
 
 boolField :: FormFieldSettings -> Maybe Bool -> FormField sub y Bool
-boolField ffs orig = GForm $ \env _ -> do
+boolField ffs orig = GForm $ do
+    env <- askParams
     let label = ffsLabel ffs
         tooltip = ffsTooltip ffs
     name <- maybe newFormIdent return $ ffsName ffs
@@ -118,7 +119,8 @@ maybeHtmlField = optionalFieldHelper htmlFieldProfile
 selectField :: Eq x => [(x, String)]
             -> FormFieldSettings
             -> Maybe x -> FormField sub master x
-selectField pairs ffs initial = GForm $ \env _ -> do
+selectField pairs ffs initial = GForm $ do
+    env <- askParams
     let label = ffsLabel ffs
         tooltip = ffsTooltip ffs
     theId <- maybe newFormIdent return $ ffsId ffs
@@ -159,7 +161,8 @@ selectField pairs ffs initial = GForm $ \env _ -> do
 maybeSelectField :: Eq x => [(x, String)]
                  -> FormFieldSettings
                  -> FormletField sub master (Maybe x)
-maybeSelectField pairs ffs initial' = GForm $ \env _ -> do
+maybeSelectField pairs ffs initial' = GForm $ do
+    env <- askParams
     let initial = join initial'
         label = ffsLabel ffs
         tooltip = ffsTooltip ffs
@@ -209,10 +212,13 @@ maybeStringInput n =
     optionalFieldHelper stringFieldProfile (nameSettings n) Nothing
 
 boolInput :: String -> FormInput sub master Bool
-boolInput n = GForm $ \env _ -> return
+boolInput n = GForm $ do
-    (FormSuccess $ fromMaybe "" (lookup n env) /= "", return $ addBody [$hamlet|
+    env <- askParams
+    let res = FormSuccess $ fromMaybe "" (lookup n env) /= ""
+    let xml = addBody [$hamlet|
 %input#$n$!type=checkbox!name=$n$
-|], UrlEncoded)
+|]
+    return (res, [xml], UrlEncoded)
 
 dayInput :: String -> FormInput sub master Day
 dayInput n =

Yesod/Form/Profiles.hs

@@ -10,12 +10,14 @@ module Yesod.Form.Profiles
     , emailFieldProfile
     , urlFieldProfile
     , doubleFieldProfile
+    , fileFieldProfile
     , parseDate
     , parseTime
     ) where
 
 import Yesod.Form.Core
 import Yesod.Widget
+import Yesod.Request
 import Text.Hamlet
 import Data.Time (Day, TimeOfDay(..))
 import qualified Data.ByteString.Lazy.UTF8 as U
@@ -45,6 +47,9 @@ doubleFieldProfile = FieldProfile
 |]
     }
 
+fileFieldProfile :: FieldProfile s m FileInfo
+fileFieldProfile = undefined -- FIXME
+
 dayFieldProfile :: FieldProfile sub y Day
 dayFieldProfile = FieldProfile
     { fpParse = parseDate