Switch to Map

2011-08-03 08:12:36 +03:00 · 2011-08-03 08:12:36 +03:00 · 1cd722fe40
commit 1cd722fe40
parent f62f513c63
5 changed files with 34 additions and 21 deletions
--- 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|<input type=hidden name=#{nonceKey} value=#{n}>|]
-    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
--- 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
--- 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|<input type=hidden name=#{deleteName} value=yes>|]
+    res <- case menv >>= Map.lookup deleteName . fst of
+        Just ("yes":_) -> return $ Left [WHAMLET|<input type=hidden name=#{deleteName} value=yes>|]
        _ -> do
            (_, xml2) <- aFormToForm $ areq boolField FieldSettings
                { fsLabel = "Delete?" :: Text -- FIXME
--- 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
--- 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