FlexibleInstances
, GeneralizedNewtypeDeriving
, MultiParamTypeClasses
+ , TemplateHaskell
, TypeSynonymInstances
, OverloadedStrings
, UnicodeSyntax
#-}
+{-# OPTIONS_GHC -fno-warn-missing-methods #-}
-- |An internal module for HTTP headers.
module Network.HTTP.Lucu.Headers
( Headers
where
import Control.Applicative hiding (empty)
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.Collections.Newtype.TH as C
import Data.List (intersperse)
import qualified Data.Map as M (Map)
import Data.Collections
import Data.Monoid
import Data.Monoid.Unicode
import Network.HTTP.Lucu.Parser.Http
-import Prelude hiding (filter, foldr, lookup, null)
+import Prelude hiding (lookup, null)
import Prelude.Unicode
newtype Headers
getHeaders = id
setHeaders _ = id
+C.derive [d| instance Foldable Headers (CIAscii, Ascii)
+ instance Collection Headers (CIAscii, Ascii)
+ instance Indexed Headers CIAscii Ascii
+ instance Map Headers CIAscii Ascii
+ instance SortingCollection Headers (CIAscii, Ascii)
+ |]
+
-- |@'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
{-# INLINE empty #-}
- empty
- = Headers empty
+ empty = Headers empty
{-# INLINE singleton #-}
- singleton p
- = Headers $ singleton p
- {-# INLINE insertMany #-}
- insertMany f (Headers m)
- = Headers $ insertMany f m
- {-# INLINE insertManySorted #-}
- insertManySorted f (Headers m)
- = Headers $ insertManySorted f m
-
-instance Foldable Headers (CIAscii, Ascii) where
- {-# INLINE null #-}
- null (Headers m) = null m
- {-# INLINE size #-}
- size (Headers m) = size m
- {-# INLINE foldr #-}
- foldr f b (Headers m) = foldr f b 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
+ singleton = Headers ∘ singleton
instance Monoid Headers where
{-# INLINE mempty #-}
- mempty = empty
+ mempty = empty
{-# INLINE mappend #-}
- mappend (Headers α) (Headers β)
- = Headers $ insertManySorted β α
-
--- FIXME: override every methods
-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
+ mappend = insertMany
merge ∷ Ascii → Ascii → Ascii
{-# INLINE merge #-}
joinValues = A.fromAsciiBuilder
∘ mconcat
∘ intersperse (A.toAsciiBuilder "\x20")
- ∘ map A.toAsciiBuilder
+ ∘ (A.toAsciiBuilder <$>)
printHeaders ∷ Headers → AsciiBuilder
printHeaders (Headers m)
- = mconcat (map printHeader (fromFoldable m)) ⊕
+ = mconcat (printHeader <$> fromFoldable m) ⊕
A.toAsciiBuilder "\x0D\x0A"
where
printHeader ∷ (CIAscii, Ascii) → AsciiBuilder