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

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

diff --git a/Network/HTTP/Lucu/Headers.hs b/Network/HTTP/Lucu/Headers.hs
index 80b9b1339501d95a08c80511645e3603a5b1d9ea..8219624df47b052df0be224e37dbda10957927bc 100644 (file)
--- 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