From: PHO <pho@cielonegro.org>
Date: Mon, 14 Nov 2011 15:41:07 +0000 (+0900)
Subject: Headers is now instances of collections-api's type classes.
X-Git-Url: https://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=09fe5429b2a1bcea6d6e57ab1c4a5178807cbacd;p=Lucu.git

Headers is now instances of collections-api's type classes.

Ditz-issue: e0312227f40a0fa92d4c5d69a64dad473f54389a
---

diff --git a/Network/HTTP/Lucu/Abortion.hs b/Network/HTTP/Lucu/Abortion.hs
index 064a97e..7b69fb5 100644
--- a/Network/HTTP/Lucu/Abortion.hs
+++ b/Network/HTTP/Lucu/Abortion.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE
-    UnicodeSyntax
+    FlexibleContexts
+  , UnicodeSyntax
   #-}
 -- |Aborting the computation of 'Network.HTTP.Lucu.Resource.Resource'
 -- in any 'Prelude.IO' monads or arrows.
@@ -14,21 +15,25 @@ module Network.HTTP.Lucu.Abortion
 import Control.Exception
 import Control.Monad.Trans
 import Data.Ascii (Ascii, CIAscii)
+import Data.Collections
 import Data.Monoid.Unicode
 import Data.Text (Text)
 import Network.HTTP.Lucu.Abortion.Internal
-import Network.HTTP.Lucu.Headers
 import Network.HTTP.Lucu.Response
 import Prelude.Unicode
 
 -- |Construct an 'Abortion' with additional headers and an optional
 -- message text.
-mkAbortion ∷ StatusCode sc ⇒ sc → [(CIAscii, Ascii)] → Maybe Text → Abortion
+mkAbortion ∷ (StatusCode sc, Foldable f (CIAscii, Ascii))
+           ⇒ sc
+           → f
+           → Maybe Text
+           → Abortion
 {-# INLINE mkAbortion #-}
-mkAbortion sc hdr msg
+mkAbortion sc hdrs msg
     = Abortion {
         aboStatus  = fromStatusCode sc
-      , aboHeaders = toHeaders hdr
+      , aboHeaders = fromFoldable hdrs
       , aboMessage = msg
       }
 
diff --git a/Network/HTTP/Lucu/Abortion/Internal.hs b/Network/HTTP/Lucu/Abortion/Internal.hs
index 6142c23..93fb8da 100644
--- a/Network/HTTP/Lucu/Abortion/Internal.hs
+++ b/Network/HTTP/Lucu/Abortion/Internal.hs
@@ -12,6 +12,7 @@ import qualified Blaze.ByteString.Builder.Char.Utf8 as BB
 import Control.Arrow.ListArrow
 import Control.Arrow.Unicode
 import Control.Exception
+import Data.Collections
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Typeable
@@ -20,7 +21,6 @@ import Network.HTTP.Lucu.DefaultPage
 import Network.HTTP.Lucu.Headers
 import Network.HTTP.Lucu.Request
 import Network.HTTP.Lucu.Response
-import Prelude.Unicode
 import Text.XML.HXT.Arrow.WriteDocument
 import Text.XML.HXT.Arrow.XmlArrow
 import Text.XML.HXT.Arrow.XmlState
@@ -67,8 +67,9 @@ abortPage conf reqM res abo
               in
                 BB.fromString html
         Nothing
-            → let res'  = res { resStatus = aboStatus abo }
-                  res'' = foldl (∘) id [setHeader name value
-                                            | (name, value) ← fromHeaders $ aboHeaders abo] res'
+            → let res' = res {
+                            resStatus  = aboStatus abo
+                          , resHeaders = insertMany (aboHeaders abo) (resHeaders res)
+                          }
                in
-                 getDefaultPage conf reqM res''
+                 getDefaultPage conf reqM res'
diff --git a/Network/HTTP/Lucu/Headers.hs b/Network/HTTP/Lucu/Headers.hs
index 80b9b13..8219624 100644
--- a/Network/HTTP/Lucu/Headers.hs
+++ b/Network/HTTP/Lucu/Headers.hs
@@ -1,5 +1,8 @@
 {-# LANGUAGE
-    GeneralizedNewtypeDeriving
+    FlexibleInstances
+  , GeneralizedNewtypeDeriving
+  , MultiParamTypeClasses
+  , TypeSynonymInstances
   , OverloadedStrings
   , UnicodeSyntax
   #-}
@@ -8,103 +11,125 @@ module Network.HTTP.Lucu.Headers
     ( Headers
     , HasHeaders(..)
 
-    , singleton
-
-    , toHeaders
-    , fromHeaders
-
     , headers
     , printHeaders
     )
     where
 import Control.Applicative
+import Control.Applicative.Unicode hiding ((∅))
+import Control.Arrow
 import Control.Monad
 import Data.Ascii (Ascii, AsciiBuilder, CIAscii)
 import qualified Data.Ascii as A
 import Data.Attoparsec.Char8 as P
-import qualified Data.ByteString as BS
-import Data.List
-import Data.Map (Map)
+import Data.List (intersperse)
 import qualified Data.Map as M
-import qualified Data.Map.Unicode as M
+import Data.Collections
+import Data.Collections.BaseInstances ()
 import Data.Monoid
 import Data.Monoid.Unicode
 import Network.HTTP.Lucu.Parser.Http
+import Prelude hiding (filter, lookup, null)
 import Prelude.Unicode
 
 newtype Headers
-    = Headers (Map CIAscii Ascii)
-      deriving (Eq, Show, Monoid)
+    = Headers (M.Map CIAscii Ascii)
+      deriving (Eq, Monoid, Show)
 
 class HasHeaders a where
     getHeaders ∷ a → Headers
     setHeaders ∷ a → Headers → a
 
+    modifyHeaders ∷ (Headers → Headers) → a → a
+    {-# INLINE modifyHeaders #-}
+    modifyHeaders = (setHeaders ⊛) ∘ (∘ getHeaders)
+
     getHeader ∷ CIAscii → a → Maybe Ascii
-    getHeader key a
-        = case getHeaders a of
-            Headers m → M.lookup key m
+    {-# INLINE getHeader #-}
+    getHeader = (∘ getHeaders) ∘ lookup
 
     hasHeader ∷ CIAscii → a → Bool
     {-# INLINE hasHeader #-}
-    hasHeader key a
-        = case getHeaders a of
-            Headers m → key M.∈ m
+    hasHeader = (∘ getHeaders) ∘ member
 
     getCIHeader ∷ CIAscii → a → Maybe CIAscii
     {-# INLINE getCIHeader #-}
-    getCIHeader key a
-        = A.toCIAscii <$> getHeader key a
+    getCIHeader = ((A.toCIAscii <$>) ∘) ∘ getHeader
 
     deleteHeader ∷ CIAscii → a → a
     {-# INLINE deleteHeader #-}
-    deleteHeader key a
-        = case getHeaders a of
-            Headers m
-              → setHeaders a $ Headers $ M.delete key m
+    deleteHeader = modifyHeaders ∘ delete
 
     setHeader ∷ CIAscii → Ascii → a → a
     {-# INLINE setHeader #-}
-    setHeader key val a
-        = case getHeaders a of
-            Headers m
-              → setHeaders a $ Headers $ M.insert key val m
+    setHeader = (modifyHeaders ∘) ∘ insertWith const
 
 instance HasHeaders Headers where
     getHeaders   = id
     setHeaders _ = id
 
-singleton ∷ CIAscii → Ascii → Headers
-{-# INLINE singleton #-}
-singleton key val
-    = Headers $ M.singleton key val
-
-toHeaders ∷ [(CIAscii, Ascii)] → Headers
-{-# INLINE toHeaders #-}
-toHeaders = flip mkHeaders (∅)
-
-mkHeaders ∷ [(CIAscii, Ascii)] → Headers → Headers
-mkHeaders []              (Headers m) = Headers m
-mkHeaders ((key, val):xs) (Headers m)
-    = mkHeaders xs $ Headers $
-      case M.lookup key m of
-        Nothing  → M.insert key val m
-        Just old → M.insert key (merge old val) m
+-- |@'insert' (key, val)@ merges @val@ with an existing one if any.
+instance Unfoldable Headers (CIAscii, Ascii) where
+    {-# INLINE insert #-}
+    insert (key, val) (Headers m)
+        = Headers $ insertWith merge key val m
+
+instance Foldable Headers (CIAscii, Ascii) where
+    {-# INLINE foldMap #-}
+    foldMap f (Headers m) = foldMap f m
+
+instance Collection Headers (CIAscii, Ascii) where
+    {-# INLINE filter #-}
+    filter f (Headers m) = Headers $ filter f m
+
+instance Indexed Headers CIAscii Ascii where
+    {-# INLINE index #-}
+    index k (Headers m) = index k m
+    {-# INLINE adjust #-}
+    adjust f k (Headers m) = Headers $ adjust f k m
+    {-# INLINE inDomain #-}
+    inDomain k (Headers m) = inDomain k m
+
+instance Map Headers CIAscii Ascii where
+    {-# INLINE lookup #-}
+    lookup k (Headers m) = lookup k m
+    {-# INLINE insertWith #-}
+    insertWith f k v (Headers m)
+        = Headers $ insertWith f k v m
+    {-# INLINE mapWithKey #-}
+    mapWithKey f (Headers m)
+        = Headers $ mapWithKey f m
+    {-# INLINE unionWith #-}
+    unionWith f (Headers α) (Headers β)
+        = Headers $ unionWith f α β
+    {-# INLINE intersectionWith #-}
+    intersectionWith f (Headers α) (Headers β)
+        = Headers $ intersectionWith f α β
+    {-# INLINE differenceWith #-}
+    differenceWith f (Headers α) (Headers β)
+        = Headers $ differenceWith f α β
+    {-# INLINE isSubmapBy #-}
+    isSubmapBy f (Headers α) (Headers β)
+        = isSubmapBy f α β
+    {-# INLINE isProperSubmapBy #-}
+    isProperSubmapBy f (Headers α) (Headers β)
+        = isProperSubmapBy f α β
+
+instance SortingCollection Headers (CIAscii, Ascii) where
+    {-# INLINE minView #-}
+    minView (Headers m) = second Headers <$> minView m
+
+merge ∷ Ascii → Ascii → Ascii
+{-# INLINE merge #-}
+merge a b
+    | nullA a ∧ nullA b = (∅)
+    | nullA a           = b
+    |           nullA b = a
+    | otherwise         = a ⊕ ", " ⊕ b
     where
-      merge ∷ Ascii → Ascii → Ascii
-      {-# INLINE merge #-}
-      merge a b
-          | nullA a ∧ nullA b = (∅)
-          | nullA a           = b
-          |           nullA b = a
-          | otherwise         = a ⊕ ", " ⊕ b
-
       nullA ∷ Ascii → Bool
       {-# INLINE nullA #-}
-      nullA = BS.null ∘ A.toByteString
-
-fromHeaders ∷ Headers → [(CIAscii, Ascii)]
-fromHeaders (Headers m) = M.toList m
+      nullA = null ∘ A.toByteString
 
 {-
   message-header = field-name ":" [ field-value ]
@@ -121,7 +146,7 @@ headers ∷ Parser Headers
 {-# INLINEABLE headers #-}
 headers = do xs ← P.many header
              crlf
-             return $ toHeaders xs
+             return $ fromFoldable xs
     where
       header ∷ Parser (CIAscii, Ascii)
       header = do name ← A.toCIAscii <$> token
@@ -147,7 +172,7 @@ headers = do xs ← P.many header
 
 printHeaders ∷ Headers → AsciiBuilder
 printHeaders (Headers m)
-    = mconcat (map printHeader (M.toList m)) ⊕
+    = mconcat (map printHeader (fromFoldable m)) ⊕
       A.toAsciiBuilder "\x0D\x0A"
     where
       printHeader ∷ (CIAscii, Ascii) → AsciiBuilder
diff --git a/Network/HTTP/Lucu/Resource/Internal.hs b/Network/HTTP/Lucu/Resource/Internal.hs
index 54be5f3..b5fad59 100644
--- a/Network/HTTP/Lucu/Resource/Internal.hs
+++ b/Network/HTTP/Lucu/Resource/Internal.hs
@@ -36,13 +36,15 @@ import Control.Applicative
 import Control.Concurrent
 import Control.Concurrent.STM
 import Control.Exception
+import Control.Monad hiding (mapM_)
 import Control.Monad.IO.Class
-import Control.Monad.Reader
+import Control.Monad.Reader (ReaderT, runReaderT, ask)
 import Control.Monad.Unicode
 import Data.Ascii (Ascii, CIAscii)
 import qualified Data.Ascii as A
 import qualified Data.ByteString as Strict
-import Data.List
+import Data.Collections
+import Data.List (intersperse, nub)
 import Data.Maybe
 import Data.Monoid
 import Data.Monoid.Unicode
@@ -60,7 +62,7 @@ import Network.Socket
 #if defined(HAVE_SSL)
 import OpenSSL.X509
 #endif
-import Prelude hiding (catch)
+import Prelude hiding (catch, concat, mapM_, tail)
 import Prelude.Unicode
 import System.IO
 
@@ -207,7 +209,7 @@ spawnResource (ResourceDef {..}) ni@(NI {..})
                    -- in the response. Hooray!
                    flip runResource ni $
                        do setStatus $ aboStatus abo
-                          mapM_ (uncurry setHeader) $ H.fromHeaders $ aboHeaders abo
+                          mapM_ (uncurry setHeader) (aboHeaders abo)
                           setHeader "Content-Type" defaultPageContentType
                           deleteHeader "Content-Encoding"
                           putBuilder $ abortPage niConfig (Just niRequest) res abo