X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FMIMEParams.hs;h=f4b503ee6ddd176d3febb9e61aa0691967844070;hp=9e5b938b384f4b3e24157a8ead92e24fb94041a1;hb=bb121f1189d01b5089aa5c29f0d390fad36ade48;hpb=fc6b68927991072aeb36fe6cd28d2e6c5193427b

diff --git a/Network/HTTP/Lucu/MIMEParams.hs b/Network/HTTP/Lucu/MIMEParams.hs
index 9e5b938..f4b503e 100644
--- a/Network/HTTP/Lucu/MIMEParams.hs
+++ b/Network/HTTP/Lucu/MIMEParams.hs
@@ -1,22 +1,25 @@
 {-# LANGUAGE
-    CPP
-  , DeriveDataTypeable
+    DeriveDataTypeable
   , DoAndIfThenElse
+  , FlexibleInstances
   , GeneralizedNewtypeDeriving
+  , MultiParamTypeClasses
   , OverloadedStrings
   , RecordWildCards
   , TemplateHaskell
+  , TypeSynonymInstances
   , UnicodeSyntax
   #-}
 -- |Parsing and printing MIME parameter values
 -- (<http://tools.ietf.org/html/rfc2231>).
 module Network.HTTP.Lucu.MIMEParams
-    ( MIMEParams(..)
+    ( MIMEParams
     , printMIMEParams
     , mimeParams
     )
     where
-import Control.Applicative
+import Control.Applicative hiding (empty)
+import Control.Arrow
 import Control.Monad hiding (mapM)
 import Control.Monad.Unicode
 import Data.Ascii (Ascii, CIAscii, AsciiBuilder)
@@ -25,52 +28,106 @@ import Data.Attoparsec.Char8 as P
 import Data.Bits
 import qualified Data.ByteString.Char8 as BS
 import Data.Char
-import Data.Data
-import Data.Foldable
-import Data.Map (Map)
-import qualified Data.Map as M
+import Data.Collections
+import Data.Collections.BaseInstances ()
+import qualified Data.Map as M (Map)
 import Data.Monoid
 import Data.Monoid.Unicode
-import Data.Sequence (Seq, ViewL(..))
-import qualified Data.Sequence as S
-import Data.Sequence.Unicode hiding ((∅))
+import Data.Sequence (Seq)
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Text.Encoding
 import Data.Text.Encoding.Error
-import Data.Traversable
+import Data.Typeable
 import Data.Word
 import Language.Haskell.TH.Syntax
+import Network.HTTP.Lucu.OrphanInstances ()
 import Network.HTTP.Lucu.Parser.Http
 import Network.HTTP.Lucu.Utils
-import Prelude hiding (concat, mapM, takeWhile)
+import Prelude hiding (concat, filter, foldr, lookup, mapM, null, takeWhile)
 import Prelude.Unicode
 
 -- |A 'Map' from MIME parameter attributes to values. Attributes are
 -- always case-insensitive according to RFC 2045
 -- (<http://tools.ietf.org/html/rfc2045#section-5.1>).
 newtype MIMEParams
-    = MIMEParams (Map CIAscii Text)
+    = MIMEParams (M.Map CIAscii Text)
     deriving (Eq, Show, Read, Monoid, Typeable)
 
 instance Lift MIMEParams where
-    lift (MIMEParams m) = [| MIMEParams $(liftParams m) |]
-        where
-          liftParams ∷ Map CIAscii Text → Q Exp
-          liftParams = liftMap liftCIAscii liftText
+    lift (MIMEParams m) = [| MIMEParams $(lift m) |]
+
+instance Unfoldable MIMEParams (CIAscii, Text) where
+    {-# INLINE insert #-}
+    insert p (MIMEParams m)
+        = MIMEParams $ insert p m
+    {-# INLINE empty #-}
+    empty
+        = MIMEParams empty
+    {-# INLINE singleton #-}
+    singleton p
+        = MIMEParams $ singleton p
+    {-# INLINE insertMany #-}
+    insertMany f (MIMEParams m)
+        = MIMEParams $ insertMany f m
+    {-# INLINE insertManySorted #-}
+    insertManySorted f (MIMEParams m)
+        = MIMEParams $ insertManySorted f m
+
+instance Foldable MIMEParams (CIAscii, Text) where
+    {-# INLINE null #-}
+    null (MIMEParams m) = null m
+    {-# INLINE size #-}
+    size (MIMEParams m) = size m
+    {-# INLINE foldr #-}
+    foldr f b (MIMEParams m) = foldr f b m
+
+instance Collection MIMEParams (CIAscii, Text) where
+    {-# INLINE filter #-}
+    filter f (MIMEParams m) = MIMEParams $ filter f m
+
+instance Indexed MIMEParams CIAscii Text where
+    {-# INLINE index #-}
+    index k (MIMEParams m) = index k m
+    {-# INLINE adjust #-}
+    adjust f k (MIMEParams m) = MIMEParams $ adjust f k m
+    {-# INLINE inDomain #-}
+    inDomain k (MIMEParams m) = inDomain k m
+
+instance Map MIMEParams CIAscii Text where
+    {-# INLINE lookup #-}
+    lookup k (MIMEParams m) = lookup k m
+    {-# INLINE mapWithKey #-}
+    mapWithKey f (MIMEParams m)
+        = MIMEParams $ mapWithKey f m
+    {-# INLINE unionWith #-}
+    unionWith f (MIMEParams α) (MIMEParams β)
+        = MIMEParams $ unionWith f α β
+    {-# INLINE intersectionWith #-}
+    intersectionWith f (MIMEParams α) (MIMEParams β)
+        = MIMEParams $ intersectionWith f α β
+    {-# INLINE differenceWith #-}
+    differenceWith f (MIMEParams α) (MIMEParams β)
+        = MIMEParams $ differenceWith f α β
+    {-# INLINE isSubmapBy #-}
+    isSubmapBy f (MIMEParams α) (MIMEParams β)
+        = isSubmapBy f α β
+    {-# INLINE isProperSubmapBy #-}
+    isProperSubmapBy f (MIMEParams α) (MIMEParams β)
+        = isProperSubmapBy f α β
+
+instance SortingCollection MIMEParams (CIAscii, Text) where
+    {-# INLINE minView #-}
+    minView (MIMEParams m) = second MIMEParams <$> minView m
 
 -- |Convert MIME parameter values to an 'AsciiBuilder'.
 printMIMEParams ∷ MIMEParams → AsciiBuilder
 {-# INLINEABLE printMIMEParams #-}
-#if MIN_VERSION_containers(0, 4, 1)
-printMIMEParams (MIMEParams m) = M.foldlWithKey' f (∅) m
-#else
-printMIMEParams (MIMEParams m) = M.foldlWithKey f (∅) m
-#endif
+printMIMEParams = foldl' f (∅)
     where
-      f ∷ AsciiBuilder → CIAscii → Text → AsciiBuilder
+      f ∷ AsciiBuilder → (CIAscii, Text) → AsciiBuilder
       {-# INLINE f #-}
-      f ab k v = ab ⊕ A.toAsciiBuilder "; " ⊕ printPair k v
+      f ab (k, v) = ab ⊕ A.toAsciiBuilder "; " ⊕ printPair k v
 
 printPair ∷ CIAscii → Text → AsciiBuilder
 {-# INLINEABLE printPair #-}
@@ -224,30 +281,32 @@ rawChars = takeWhile1 (\c → isToken c ∧ c ≢ '%')
 
 decodeParams ∷ (Functor m, Monad m) ⇒ [ExtendedParam] → m MIMEParams
 {-# INLINE decodeParams #-}
-decodeParams = (MIMEParams <$>) ∘ (mapM decodeSections =≪) ∘ sortBySection
+decodeParams = (MIMEParams <$>)
+               ∘ (mapM (\(k, v) → ((,) k) <$> decodeSections v) =≪)
+               ∘ sortBySection
 
 sortBySection ∷ Monad m
               ⇒ [ExtendedParam]
-              → m (Map CIAscii (Map Integer ExtendedParam))
+              → m (M.Map CIAscii (M.Map Integer ExtendedParam))
 sortBySection = flip go (∅)
     where
       go ∷ Monad m
          ⇒ [ExtendedParam]
-         → Map CIAscii (Map Integer ExtendedParam)
-         → m (Map CIAscii (Map Integer ExtendedParam))
+         → M.Map CIAscii (M.Map Integer ExtendedParam)
+         → m (M.Map CIAscii (M.Map Integer ExtendedParam))
       go []     m = return m
       go (x:xs) m
-          = case M.lookup (epName x) m of
+          = case lookup (epName x) m of
               Nothing
-                  → let s  = M.singleton (section x) x
-                        m' = M.insert (epName x) s m
+                  → let s  = singleton (section x, x)
+                        m' = insert (epName x, s) m
                     in
                       go xs m'
               Just s
-                  → case M.lookup (section x) s of
+                  → case lookup (section x) s of
                        Nothing
-                           → let s' = M.insert (section x) x  s
-                                 m' = M.insert (epName  x) s' m
+                           → let s' = insert (section x, x ) s
+                                 m' = insert (epName  x, s') m
                              in
                                go xs m'
                        Just _
@@ -258,16 +317,16 @@ sortBySection = flip go (∅)
                                           , "'"
                                           ])
 
-decodeSections ∷ Monad m ⇒ Map Integer ExtendedParam → m Text
+decodeSections ∷ Monad m ⇒ M.Map Integer ExtendedParam → m Text
 decodeSections = (decodeSeq =≪) ∘ flip (flip toSeq 0) (∅)
     where
       toSeq ∷ Monad m
-            ⇒ Map Integer ExtendedParam
+            ⇒ M.Map Integer ExtendedParam
             → Integer
             → Seq ExtendedParam
             → m (Seq ExtendedParam)
       toSeq m expectedSect sects
-          = case M.minViewWithKey m of
+          = case minView m of
               Nothing
                   → return sects
               Just ((sect, p), m')
@@ -283,19 +342,19 @@ decodeSections = (decodeSeq =≪) ∘ flip (flip toSeq 0) (∅)
 
       decodeSeq ∷ Monad m ⇒ Seq ExtendedParam → m Text
       decodeSeq sects
-          = case S.viewl sects of
-              EmptyL
+          = case front sects of
+              Nothing
                   → fail "decodeSeq: internal error: empty seq"
-              InitialEncodedParam {..} :< xs
+              Just (InitialEncodedParam {..}, xs)
                   → do d ← getDecoder epCharset
                        t ← decodeStr d epPayload
-                       decodeSeq' (Just d) xs $ S.singleton t
-              ContinuedEncodedParam {..} :< _
+                       decodeSeq' (Just d) xs $ singleton t
+              Just (ContinuedEncodedParam {..}, _)
                   → fail "decodeSeq: internal error: CEP at section 0"
-              AsciiParam {..} :< xs
+              Just (AsciiParam {..}, xs)
                   → let t = A.toText apPayload
                     in
-                      decodeSeq' Nothing xs $ S.singleton t
+                      decodeSeq' Nothing xs $ singleton t
 
       decodeSeq' ∷ Monad m
                  ⇒ Maybe Decoder
@@ -303,12 +362,12 @@ decodeSections = (decodeSeq =≪) ∘ flip (flip toSeq 0) (∅)
                  → Seq Text
                  → m Text
       decodeSeq' decoder sects chunks
-          = case S.viewl sects of
-              EmptyL
+          = case front sects of
+              Nothing
                   → return $ T.concat $ toList chunks
-              InitialEncodedParam {..} :< _
+              Just (InitialEncodedParam {}, _)
                   → fail "decodeSeq': internal error: IEP at section > 0"
-              ContinuedEncodedParam {..} :< xs
+              Just (ContinuedEncodedParam {..}, xs)
                   → case decoder of
                        Just d
                            → do t ← decodeStr d epPayload
@@ -320,7 +379,7 @@ decodeSections = (decodeSeq =≪) ∘ flip (flip toSeq 0) (∅)
                                           , A.toString $ A.fromCIAscii epName
                                           , "' is encoded but its first section is not"
                                           ])
-              AsciiParam {..} :< xs
+              Just (AsciiParam {..}, xs)
                   → let t = A.toText apPayload
                     in
                       decodeSeq' decoder xs $ chunks ⊳ t