From 1cd722fe4012ac8623b9202c4d1395928e677b78 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 3 Aug 2011 08:12:36 +0300 Subject: [PATCH] Switch to Map --- yesod-form/Yesod/Form/Functions.hs | 27 ++++++++++++++++----------- yesod-form/Yesod/Form/Input.hs | 12 ++++++++---- yesod-form/Yesod/Form/MassInput.hs | 10 ++++++---- yesod-form/Yesod/Form/Types.hs | 5 +++-- yesod-form/yesod-form.cabal | 1 + 5 files changed, 34 insertions(+), 21 deletions(-) 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