diff --git a/yesod-form/Yesod/Form/Functions.hs b/yesod-form/Yesod/Form/Functions.hs
index 3cd3e4a6..516ba22a 100644
--- a/yesod-form/Yesod/Form/Functions.hs
+++ b/yesod-form/Yesod/Form/Functions.hs
@@ -44,9 +44,10 @@ import Yesod.Request (reqNonce, reqWaiRequest, reqGetParams, languages)
import Network.Wai (requestMethod)
import Text.Hamlet (html)
import Data.Monoid (mempty)
-import Data.Maybe (listToMaybe)
+import Data.Maybe (listToMaybe, fromMaybe)
import Yesod.Message (RenderMessage (..))
import Control.Monad.IO.Class (MonadIO, liftIO)
+import qualified Data.Map as Map
#if __GLASGOW_HASKELL__ >= 700
#define WHAMLET whamlet
@@ -120,7 +121,7 @@ mhelper Field {..} FieldSettings {..} mdef onMissing onFound isReq = do
case mp of
Nothing -> return (FormMissing, maybe (Left "") Right mdef)
Just p -> do
- let mvals = map snd $ filter (\(n,_) -> n == name) p
+ let mvals = fromMaybe [] $ Map.lookup name p
emx <- lift $ fieldParse mvals
return $ case emx of
Left (SomeMessage e) -> (FormFailure [renderMessage master langs e], maybe (Left "") Left (listToMaybe mvals))
@@ -174,28 +175,32 @@ runFormPost form = do
case reqNonce req of
Nothing -> mempty
Just n -> [HTML||]
- env <- if requestMethod (reqWaiRequest req) == "GET"
- then return Nothing
- else fmap Just runRequestBody
+ env <- postEnv
m <- getYesod
langs <- languages
((res, xml), enctype) <- runFormGeneric (form nonce) m langs env
let res' =
case (res, env) of
(FormSuccess{}, Just (params, _))
- | lookup nonceKey params /= reqNonce req ->
+ | Map.lookup nonceKey params /= fmap return (reqNonce req) ->
FormFailure [renderMessage m langs MsgCsrfWarning]
_ -> res
return ((res', xml), enctype)
+postEnv = do
+ req <- getRequest
+ if requestMethod (reqWaiRequest req) == "GET"
+ then return Nothing
+ else do
+ (p, f) <- runRequestBody
+ let p' = Map.unionsWith (++) $ map (\(x, y) -> Map.singleton x [y]) p
+ return $ Just (p', Map.fromList f)
+
runFormPostNoNonce :: (Html -> Form sub master (FormResult a, xml)) -> GHandler sub master ((FormResult a, xml), Enctype)
runFormPostNoNonce form = do
- req <- getRequest
- env <- if requestMethod (reqWaiRequest req) == "GET"
- then return Nothing
- else fmap Just runRequestBody
langs <- languages
m <- getYesod
+ env <- postEnv
runFormGeneric (form mempty) m langs env
runFormGet :: (Html -> Form sub master a) -> GHandler sub master (a, Enctype)
@@ -206,7 +211,7 @@ runFormGet form = do
let env =
case lookup key gets of
Nothing -> Nothing
- Just _ -> Just (gets, [])
+ Just _ -> Just (Map.unionsWith (++) $ map (\(x, y) -> Map.singleton x [y]) gets, Map.empty)
langs <- languages
m <- getYesod
runFormGeneric (form fragment) m langs env
diff --git a/yesod-form/Yesod/Form/Input.hs b/yesod-form/Yesod/Form/Input.hs
index ba8eeec0..43b2ca41 100644
--- a/yesod-form/Yesod/Form/Input.hs
+++ b/yesod-form/Yesod/Form/Input.hs
@@ -17,6 +17,8 @@ import Yesod.Request (reqGetParams, languages)
import Control.Monad (liftM)
import Yesod.Widget (GWidget)
import Yesod.Message (RenderMessage (..))
+import qualified Data.Map as Map
+import Data.Maybe (fromMaybe)
type DText = [Text] -> [Text]
newtype FormInput sub master a = FormInput { unFormInput :: master -> [Text] -> Env -> GGHandler sub master IO (Either DText a) }
@@ -35,7 +37,7 @@ instance Applicative (FormInput sub master) where
ireq :: (RenderMessage master msg, RenderMessage master FormMessage) => Field sub master a -> Text -> FormInput sub master a
ireq field name = FormInput $ \m l env -> do
- let filteredEnv = map snd $ filter (\y -> fst y == name) env
+ let filteredEnv = fromMaybe [] $ Map.lookup name env
emx <- fieldParse field $ filteredEnv
return $ case emx of
Left (SomeMessage e) -> Left $ (:) $ renderMessage m l e
@@ -44,7 +46,7 @@ ireq field name = FormInput $ \m l env -> do
iopt :: RenderMessage master msg => Field sub master a -> Text -> FormInput sub master (Maybe a)
iopt field name = FormInput $ \m l env -> do
- let filteredEnv = map snd $ filter (\y -> fst y == name) env
+ let filteredEnv = fromMaybe [] $ Map.lookup name env
emx <- fieldParse field $ filteredEnv
return $ case emx of
Left (SomeMessage e) -> Left $ (:) $ renderMessage m l e
@@ -52,7 +54,7 @@ iopt field name = FormInput $ \m l env -> do
runInputGet :: FormInput sub master a -> GHandler sub master a
runInputGet (FormInput f) = do
- env <- liftM reqGetParams getRequest
+ env <- liftM (toMap . reqGetParams) getRequest
m <- getYesod
l <- languages
emx <- liftIOHandler $ f m l env
@@ -60,9 +62,11 @@ runInputGet (FormInput f) = do
Left errs -> invalidArgs $ errs []
Right x -> return x
+toMap = Map.unionsWith (++) . map (\(x, y) -> Map.singleton x [y])
+
runInputPost :: FormInput sub master a -> GHandler sub master a
runInputPost (FormInput f) = do
- env <- liftM fst runRequestBody
+ env <- liftM (toMap . fst) runRequestBody
m <- getYesod
l <- languages
emx <- liftIOHandler $ f m l env
diff --git a/yesod-form/Yesod/Form/MassInput.hs b/yesod-form/Yesod/Form/MassInput.hs
index 562fc84a..525c29f8 100644
--- a/yesod-form/Yesod/Form/MassInput.hs
+++ b/yesod-form/Yesod/Form/MassInput.hs
@@ -25,6 +25,8 @@ import Control.Monad (liftM)
import Data.Either (partitionEithers)
import Data.Traversable (sequenceA)
import Control.Monad.IO.Class (MonadIO)
+import qualified Data.Map as Map
+import Data.Maybe (listToMaybe)
#if __GLASGOW_HASKELL__ >= 700
#define WHAMLET whamlet
@@ -69,8 +71,8 @@ inputList label fixXml single mdef = formToAForm $ do
case menv of
Nothing -> map Just $ fromMaybe [] mdef
Just (env, _) ->
- let toAdd = maybe False (const True) $ lookup addName env
- count' = fromMaybe 0 $ lookup countName env >>= readInt
+ let toAdd = maybe False (const True) $ Map.lookup addName env
+ count' = fromMaybe 0 $ Map.lookup countName env >>= listToMaybe >>= readInt
count = (if toAdd then 1 else 0) + count'
in replicate count Nothing
let count = length vals
@@ -100,8 +102,8 @@ withDelete af = do
down 1
deleteName <- newFormIdent
(menv, _, _) <- ask
- res <- case menv >>= lookup deleteName . fst of
- Just "yes" -> return $ Left [WHAMLET||]
+ res <- case menv >>= Map.lookup deleteName . fst of
+ Just ("yes":_) -> return $ Left [WHAMLET||]
_ -> do
(_, xml2) <- aFormToForm $ areq boolField FieldSettings
{ fsLabel = "Delete?" :: Text -- FIXME
diff --git a/yesod-form/Yesod/Form/Types.hs b/yesod-form/Yesod/Form/Types.hs
index 52063d13..48f623fc 100644
--- a/yesod-form/Yesod/Form/Types.hs
+++ b/yesod-form/Yesod/Form/Types.hs
@@ -27,6 +27,7 @@ import Control.Applicative ((<$>), Applicative (..))
import Control.Monad (liftM)
import Data.String (IsString (..))
import Yesod.Core (RenderMessage, GGHandler, GWidget)
+import qualified Data.Map as Map
-- | A form can produce three different results: there was no data available,
-- the data was invalid, or there was a successful parse.
@@ -69,8 +70,8 @@ instance Show Ints where
show (IntSingle i) = show i
show (IntCons i is) = show i ++ ('-' : show is)
-type Env = [(Text, Text)] -- FIXME use a Map
-type FileEnv = [(Text, FileInfo)]
+type Env = Map.Map Text [Text]
+type FileEnv = Map.Map Text FileInfo
type Lang = Text
type Form sub master a = RWST (Maybe (Env, FileEnv), master, [Lang]) Enctype Ints (GGHandler sub master IO) a
diff --git a/yesod-form/yesod-form.cabal b/yesod-form/yesod-form.cabal
index c02342c1..851c543e 100644
--- a/yesod-form/yesod-form.cabal
+++ b/yesod-form/yesod-form.cabal
@@ -30,6 +30,7 @@ library
, text >= 0.7 && < 1.0
, web-routes-quasi >= 0.7 && < 0.8
, wai >= 0.4 && < 0.5
+ , containers >= 0.2 && < 0.5
exposed-modules: Yesod.Form
Yesod.Form.Class
Yesod.Form.Types