Switch to Map

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|<input type=hidden name=#{nonceKey} value=#{n}>|]
-    env <- if requestMethod (reqWaiRequest req) == "GET"
+    env <- postEnv
-                then return Nothing
-                else fmap Just runRequestBody
     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

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

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
+                    let toAdd = maybe False (const True) $ Map.lookup addName env
-                        count' = fromMaybe 0 $ lookup countName env >>= readInt
+                        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
+    res <- case menv >>= Map.lookup deleteName . fst of
-        Just "yes" -> return $ Left [WHAMLET|<input type=hidden name=#{deleteName} value=yes>|]
+        Just ("yes":_) -> return $ Left [WHAMLET|<input type=hidden name=#{deleteName} value=yes>|]
         _ -> do
             (_, xml2) <- aFormToForm $ areq boolField FieldSettings
                 { fsLabel = "Delete?" :: Text -- FIXME

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 Env = Map.Map Text [Text]
-type FileEnv = [(Text, FileInfo)]
+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

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