Merge branch 'parsable'

[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 cd178dec2afb18402169b2f316dd8c067f65b88e..3149859026d9a28d3feeb99a2286961f1c74eca6 100644 (file)
--- a/Network/HTTP/Lucu/MIMEType/Guess.hs
+++ b/Network/HTTP/Lucu/MIMEType/Guess.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE
     DeriveDataTypeable
   , GeneralizedNewtypeDeriving
 {-# LANGUAGE
     DeriveDataTypeable
   , GeneralizedNewtypeDeriving

+  , MultiParamTypeClasses

   , TemplateHaskell
   , UnicodeSyntax
   , ViewPatterns
   , TemplateHaskell
   , UnicodeSyntax
   , ViewPatterns


@@ -12,13 +13,13 @@
 module Network.HTTP.Lucu.MIMEType.Guess
     ( ExtMap(..)
     , extMap
 module Network.HTTP.Lucu.MIMEType.Guess
     ( ExtMap(..)
     , extMap

-    , parseExtMap

     , guessTypeByFileName
     )
     where
 import Control.Applicative
 import Data.Attoparsec.Char8
 import qualified Data.Attoparsec.Lazy as LP
     , guessTypeByFileName
     )
     where
 import Control.Applicative
 import Data.Attoparsec.Char8
 import qualified Data.Attoparsec.Lazy as LP

+import Data.Attoparsec.Parsable

 import qualified Data.ByteString.Lazy.Char8 as Lazy
 import Data.Convertible.Base
 import Data.Convertible.Instances.Text ()
 import qualified Data.ByteString.Lazy.Char8 as Lazy
 import Data.Convertible.Base
 import Data.Convertible.Instances.Text ()


@@ -68,54 +69,56 @@ extMap = QuasiQuoter {
            , quoteDec  = const unsupported
          }
     where
            , quoteDec  = const unsupported
          }
     where

+      parseExtMap ∷ Lazy.ByteString → ExtMap
+      parseExtMap = convertUnsafe
+

       unsupported ∷ Monad m ⇒ m α
       unsupported = fail "Unsupported usage of extMap quasi-quoter."
 
       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 ← parser
+                    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 <$>)
 
 compile ∷ Ord k ⇒ [(v, [k])] → Either (k, v, v) (Map k v)
 compile = go (∅) ∘ concat ∘ (tr <$>)