Destroy Data.Attoparsec.Parsable; use Data.Default instead

[Lucu.git] / Network / HTTP / Lucu / MIMEType / Guess.hs

diff --git a/Network/HTTP/Lucu/MIMEType/Guess.hs b/Network/HTTP/Lucu/MIMEType/Guess.hs
index 6a791e4d15792a5aaff5a4504ceb6e10930e7a22..05d0cd606f383eccdbef688a39dfa4f1e215b3d5 100644 (file)
--- a/Network/HTTP/Lucu/MIMEType/Guess.hs
+++ b/Network/HTTP/Lucu/MIMEType/Guess.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE
     DeriveDataTypeable
   , GeneralizedNewtypeDeriving
+  , MultiParamTypeClasses
   , TemplateHaskell
   , UnicodeSyntax
   , ViewPatterns
@@ -12,7 +13,6 @@
 module Network.HTTP.Lucu.MIMEType.Guess
     ( ExtMap(..)
     , extMap
-    , parseExtMap
     , guessTypeByFileName
     )
     where
@@ -20,6 +20,9 @@ import Control.Applicative
 import Data.Attoparsec.Char8
 import qualified Data.Attoparsec.Lazy as LP
 import qualified Data.ByteString.Lazy.Char8 as Lazy
+import Data.Convertible.Base
+import Data.Convertible.Instances.Text ()
+import Data.Default
 import qualified Data.Map as M
 import Data.Map (Map)
 import Data.Typeable
@@ -27,7 +30,6 @@ import Data.List
 import Data.Monoid
 import Data.Monoid.Unicode
 import Data.Text (Text)
-import qualified Data.Text as T
 import Data.Text.Encoding
 import Language.Haskell.TH.Syntax
 import Language.Haskell.TH.Quote
@@ -67,54 +69,56 @@ extMap = QuasiQuoter {
            , quoteDec  = const unsupported
          }
     where
+      parseExtMap ∷ Lazy.ByteString → ExtMap
+      parseExtMap = convertUnsafe
+
       unsupported ∷ Monad m ⇒ m α
       unsupported = fail "Unsupported usage of extMap quasi-quoter."
 
--- |Parse Apache @mime.types@.
-parseExtMap ∷ Lazy.ByteString → ExtMap
-parseExtMap src
-    = case LP.parse pairs src of
-        LP.Fail _ eCtx e
-            → error $ "Unparsable extension map: "
-                    ⧺ intercalate ", " eCtx
-                    ⧺ ": "
-                    ⧺ e
-        LP.Done _ xs
-            → case compile xs of
-                 Right m → ExtMap m
-                 Left  e → error ("Duplicate extension: " ⧺ show e)
-    where
-      pairs ∷ Parser [(MIMEType, [Text])]
-      pairs = do skipMany linebreak
-                 xs ← sepBy pair (skipMany1 linebreak)
-                 skipMany linebreak
-                 endOfInput
-                 return xs
-              <?>
-              "pairs"
+instance ConvertAttempt Lazy.ByteString ExtMap where
+    convertAttempt src
+        = case LP.parse pairs src of
+            LP.Fail _ eCtx e
+                → fail $ "Unparsable extension map: "
+                       ⊕ intercalate ", " eCtx
+                       ⊕ ": "
+                       ⊕ e
+            LP.Done _ xs
+                → case compile xs of
+                     Right m → return $ ExtMap m
+                     Left  e → fail $ "Duplicate extension: " ⊕ show e
+        where
+          pairs ∷ Parser [(MIMEType, [Text])]
+          pairs = do skipMany linebreak
+                     xs ← sepBy pair (skipMany1 linebreak)
+                     skipMany linebreak
+                     endOfInput
+                     return xs
+                  <?>
+                  "pairs"
 
-      pair ∷ Parser (MIMEType, [Text])
-      pair = do skipSpace
-                mime ← mimeType
-                skipSpace1
-                exts ← sepBy1 ext $ skipWhile1 (≡ '\x20')
-                return (mime, exts)
-             <?>
-             "pair"
+          pair ∷ Parser (MIMEType, [Text])
+          pair = do skipSpace
+                    mime ← def
+                    skipSpace1
+                    exts ← sepBy1 ext $ skipWhile1 (≡ '\x20')
+                    return (mime, exts)
+                 <?>
+                 "pair"
 
-      ext ∷ Parser Text
-      ext = (decodeUtf8 <$> takeWhile1 isAlphaNum)
-            <?>
-            "ext"
+          ext ∷ Parser Text
+          ext = (decodeUtf8 <$> takeWhile1 isAlphaNum)
+                <?>
+                "ext"
 
-      linebreak ∷ Parser ()
-      linebreak
-          = ( endOfLine
-              <|>
-              try (skipSpace *> char '#' *> skipManyTill anyChar endOfLine)
-            )
-            <?>
-            "linebreak"
+          linebreak ∷ Parser ()
+          linebreak
+              = ( endOfLine
+                  <|>
+                  try (skipSpace *> char '#' *> skipManyTill anyChar endOfLine)
+                )
+                <?>
+                "linebreak"
 
 compile ∷ Ord k ⇒ [(v, [k])] → Either (k, v, v) (Map k v)
 compile = go (∅) ∘ concat ∘ (tr <$>)
@@ -137,4 +141,4 @@ guessTypeByFileName ∷ ExtMap → FilePath → Maybe MIMEType
 guessTypeByFileName (ExtMap m) fpath
     = case takeExtension fpath of
         []      → Nothing
-        (_:ext) → M.lookup (T.pack ext) m
+        (_:ext) → M.lookup (cs ext) m