Merge branch 'convertible'

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

diff --git a/Network/HTTP/Lucu/MIMEParams.hs b/Network/HTTP/Lucu/MIMEParams.hs
index 89b2bfda4e0ecb15beb5781f7d45a88e48e2bd4a..6f9eb7e1b8a9f4055b0bc878578d6b2679952991 100644 (file)
--- a/Network/HTTP/Lucu/MIMEParams.hs
+++ b/Network/HTTP/Lucu/MIMEParams.hs
@@ -16,7 +16,6 @@
 -- (<http://tools.ietf.org/html/rfc2231>).
 module Network.HTTP.Lucu.MIMEParams
     ( MIMEParams
-    , printMIMEParams
     , mimeParams
     )
     where
@@ -25,13 +24,16 @@ import Control.Monad hiding (mapM)
 import Control.Monad.Unicode
 import Data.Ascii (Ascii, CIAscii, AsciiBuilder)
 import qualified Data.Ascii as A
-import Data.Attoparsec.Char8 as P
+import Data.Attoparsec.Char8
 import Data.Bits
 import qualified Data.ByteString.Char8 as BS
 import Data.Char
 import Data.Collections
 import Data.Collections.BaseInstances ()
 import qualified Data.Collections.Newtype.TH as C
+import Data.Convertible.Base
+import Data.Convertible.Instances.Ascii ()
+import Data.Convertible.Utils
 import qualified Data.Map as M (Map)
 import Data.Monoid.Unicode
 import Data.Sequence (Seq)
@@ -55,14 +57,17 @@ C.derive [d| instance Unfoldable MIMEParams (CIAscii, Text)
              instance SortingCollection MIMEParams (CIAscii, Text)
            |]
 
--- |Convert MIME parameter values to an 'AsciiBuilder'.
-printMIMEParams ∷ MIMEParams → AsciiBuilder
-{-# INLINEABLE printMIMEParams #-}
-printMIMEParams = foldl' f (∅)
-    where
-      f ∷ AsciiBuilder → (CIAscii, Text) → AsciiBuilder
-      {-# INLINE f #-}
-      f ab (k, v) = ab ⊕ A.toAsciiBuilder "; " ⊕ printPair k v
+instance ConvertSuccess MIMEParams Ascii where
+    {-# INLINE convertSuccess #-}
+    convertSuccess = convertSuccessVia ((⊥) ∷ AsciiBuilder)
+
+instance ConvertSuccess MIMEParams AsciiBuilder where
+    {-# INLINEABLE convertSuccess #-}
+    convertSuccess = foldl' f (∅)
+        where
+          f ∷ AsciiBuilder → (CIAscii, Text) → AsciiBuilder
+          {-# INLINE f #-}
+          f ab (k, v) = ab ⊕ cs ("; " ∷ Ascii) ⊕ printPair k v
 
 printPair ∷ CIAscii → Text → AsciiBuilder
 {-# INLINEABLE printPair #-}
@@ -75,19 +80,19 @@ printPair name value
 printPairInUTF8 ∷ CIAscii → Text → AsciiBuilder
 {-# INLINEABLE printPairInUTF8 #-}
 printPairInUTF8 name value
-    = A.toAsciiBuilder (A.fromCIAscii name) ⊕
-      A.toAsciiBuilder "*=utf-8''" ⊕
+    = cs name ⊕
+      cs ("*=utf-8''" ∷ Ascii) ⊕
       escapeUnsafeChars (encodeUtf8 value) (∅)
 
 printPairInAscii ∷ CIAscii → Ascii → AsciiBuilder
 {-# INLINEABLE printPairInAscii #-}
 printPairInAscii name value
-    = A.toAsciiBuilder (A.fromCIAscii name) ⊕
-      A.toAsciiBuilder "=" ⊕
-      if BS.any ((¬) ∘ isToken) (A.toByteString value) then
+    = cs name ⊕
+      cs ("=" ∷ Ascii) ⊕
+      if BS.any ((¬) ∘ isToken) (cs value) then
           quoteStr value
       else
-          A.toAsciiBuilder value
+          cs value
 
 escapeUnsafeChars ∷ BS.ByteString → AsciiBuilder → AsciiBuilder
 {-# INLINEABLE escapeUnsafeChars #-}
@@ -96,15 +101,15 @@ escapeUnsafeChars bs b
         Nothing         → b
         Just (c, bs')
             | isToken c → escapeUnsafeChars bs' $
-                          b ⊕ A.toAsciiBuilder (A.unsafeFromString [c])
+                          b ⊕ cs (A.unsafeFromString [c])
             | otherwise → escapeUnsafeChars bs' $
                           b ⊕ toHex (fromIntegral $ fromEnum c)
 
 toHex ∷ Word8 → AsciiBuilder
 {-# INLINEABLE toHex #-}
-toHex o = A.toAsciiBuilder "%" ⊕
-          A.toAsciiBuilder (A.unsafeFromString [ toHex' (o `shiftR` 8)
-                                               , toHex' (o .&.   0x0F) ])
+toHex o = cs ("%" ∷ Ascii) ⊕
+          cs (A.unsafeFromString [ toHex' (o `shiftR` 8)
+                                 , toHex' (o .&.   0x0F) ])
     where
       toHex' ∷ Word8 → Char
       {-# INLINEABLE toHex' #-}
@@ -114,6 +119,10 @@ toHex o = A.toAsciiBuilder "%" ⊕
           | otherwise = toEnum $ fromIntegral
                                $ fromEnum 'A' + fromIntegral (h - 0x0A)
 
+deriveAttempts [ ([t| MIMEParams |], [t| Ascii        |])
+               , ([t| MIMEParams |], [t| AsciiBuilder |])
+               ]
+
 data ExtendedParam
     = InitialEncodedParam {
         epName    ∷ !CIAscii
@@ -139,7 +148,7 @@ section ep                         = epSection ep
 -- |'Parser' for MIME parameter values.
 mimeParams ∷ Parser MIMEParams
 {-# INLINEABLE mimeParams #-}
-mimeParams = decodeParams =≪ P.many (try paramP)
+mimeParams = decodeParams =≪ many (try paramP)
 
 paramP ∷ Parser ExtendedParam
 paramP = do skipMany lws
@@ -159,7 +168,7 @@ paramP = do skipMany lws
                        return $ AsciiParam name sect payload
 
 nameP ∷ Parser (CIAscii, Integer, Bool)
-nameP = do name      ← (A.toCIAscii ∘ A.unsafeFromByteString) <$>
+nameP = do name      ← (cs ∘ A.unsafeFromByteString) <$>
                        takeWhile1 (\c → isToken c ∧ c ≢ '*')
            sect      ← option 0     $ try (char '*' *> decimal  )
            isEncoded ← option False $ try (char '*' *> pure True)
@@ -181,12 +190,12 @@ initialEncodedValue
              return (charset, payload)
     where
       metadata ∷ Parser CIAscii
-      metadata = (A.toCIAscii ∘ A.unsafeFromByteString) <$>
+      metadata = (cs ∘ A.unsafeFromByteString) <$>
                  takeWhile (\c → c ≢ '\'' ∧ isToken c)
 
 encodedPayload ∷ Parser BS.ByteString
 {-# INLINE encodedPayload #-}
-encodedPayload = BS.concat <$> P.many (hexChar <|> rawChars)
+encodedPayload = BS.concat <$> many (hexChar <|> rawChars)
 
 hexChar ∷ Parser BS.ByteString
 {-# INLINEABLE hexChar #-}
@@ -248,7 +257,7 @@ sortBySection = flip go (∅)
                            → fail (concat [ "Duplicate section "
                                           , show $ section x
                                           , " for parameter '"
-                                          , A.toString $ A.fromCIAscii $ epName x
+                                          , cs $ epName x
                                           , "'"
                                           ])
 
@@ -271,7 +280,7 @@ decodeSections = (decodeSeq =≪) ∘ flip (flip toSeq 0) (∅)
                         → fail (concat [ "Missing section "
                                        , show $ section p
                                        , " for parameter '"
-                                       , A.toString $ A.fromCIAscii $ epName p
+                                       , cs $ epName p
                                        , "'"
                                        ])
 
@@ -287,9 +296,7 @@ decodeSections = (decodeSeq =≪) ∘ flip (flip toSeq 0) (∅)
               Just (ContinuedEncodedParam {..}, _)
                   → fail "decodeSeq: internal error: CEP at section 0"
               Just (AsciiParam {..}, xs)
-                  → let t = A.toText apPayload
-                    in
-                      decodeSeq' Nothing xs $ singleton t
+                  → decodeSeq' Nothing xs $ singleton $ cs apPayload
 
       decodeSeq' ∷ Monad m
                  ⇒ Maybe Decoder
@@ -311,13 +318,11 @@ decodeSections = (decodeSeq =≪) ∘ flip (flip toSeq 0) (∅)
                            → fail (concat [ "Section "
                                           , show epSection
                                           , " for parameter '"
-                                          , A.toString $ A.fromCIAscii epName
+                                          , cs epName
                                           , "' is encoded but its first section is not"
                                           ])
               Just (AsciiParam {..}, xs)
-                  → let t = A.toText apPayload
-                    in
-                      decodeSeq' decoder xs $ chunks ⊳ t
+                  → decodeSeq' decoder xs $ chunks ⊳ cs apPayload
 
 type Decoder = BS.ByteString → Either UnicodeException Text
 
@@ -331,5 +336,4 @@ getDecoder ∷ Monad m ⇒ CIAscii → m Decoder
 getDecoder charset
     | charset ≡ "UTF-8"    = return decodeUtf8'
     | charset ≡ "US-ASCII" = return decodeUtf8'
-    | otherwise            = fail $ "No decoders found for charset: "
-                                  ⧺ A.toString (A.fromCIAscii charset)
+    | otherwise            = fail $ "No decoders found for charset: " ⊕ cs charset