</> is better than +/+

[Lucu.git] / Network / HTTP / Lucu / Headers.hs

diff --git a/Network/HTTP/Lucu/Headers.hs b/Network/HTTP/Lucu/Headers.hs
index 655252cc4b656c39abcb92252a276ffc1d94e638..fee6fadec1b595ae189b0b9515b2543cb93b7171 100644 (file)
--- a/Network/HTTP/Lucu/Headers.hs
+++ b/Network/HTTP/Lucu/Headers.hs
@@ -1,9 +1,10 @@
+-- #hide
 module Network.HTTP.Lucu.Headers
     ( Headers
     , HasHeaders(..)
-    , emptyHeaders -- Headers
-    , headersP     -- Parser Headers
-    , hPutHeaders  -- Handle -> Headers -> IO ()
+    , emptyHeaders
+    , headersP
+    , hPutHeaders
     )
     where
 
@@ -20,20 +21,20 @@ class HasHeaders a where
     getHeaders :: a -> Headers
     setHeaders :: a -> Headers -> a
 
-    getHeader :: a -> String -> Maybe String
-    getHeader a key
+    getHeader :: String -> a -> Maybe String
+    getHeader key a
         = fmap snd $ find (noCaseEq key . fst) (getHeaders a)
 
-    deleteHeader :: a -> String -> a
-    deleteHeader a key
+    deleteHeader :: String -> a -> a
+    deleteHeader key a
         = setHeaders a $ filter (not . noCaseEq key . fst) (getHeaders a)
 
-    addHeader :: a -> String -> String -> a
-    addHeader a key val
+    addHeader :: String -> String -> a -> a
+    addHeader key val a
         = setHeaders a $ (getHeaders a) ++ [(key, val)]
 
-    setHeader :: a -> String -> String -> a
-    setHeader a key val
+    setHeader :: String -> String -> a -> a
+    setHeader key val a
         = let list    = getHeaders a
               deleted = filter (not . noCaseEq key . fst) list
               added   = deleted ++ [(key, val)]
@@ -77,7 +78,12 @@ headersP = do xs <- many header
       normalize :: String -> String
       normalize = trimBody . trim isWhiteSpace
 
-      trimBody = nubBy (\ a b -> a == ' ' && b == ' ')
+      trimBody = foldr (++) []
+                 . map (\ s -> if head s == ' ' then
+                                   " "
+                               else
+                                   s)
+                 . group
                  . map (\ c -> if isWhiteSpace c
                                then ' '
                                else c)