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 8cddcba19bd60934b934f07dd520c97ef9c7fad9..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,30 +13,29 @@
 module Network.HTTP.Lucu.MIMEType.Guess
     ( ExtMap(..)
     , extMap
-    , parseExtMap
     , guessTypeByFileName
     )
     where
 import Control.Applicative
-import Control.Monad
-import Control.Monad.Unicode
-import Data.Ascii (Ascii)
-import qualified Data.Ascii as A
-import Data.Attoparsec.Char8 as P
+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.Maybe
 import Data.Typeable
+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
 import Network.HTTP.Lucu.MIMEType
+import Network.HTTP.Lucu.OrphanInstances ()
 import Network.HTTP.Lucu.Parser
-import Network.HTTP.Lucu.Utils
 import Prelude.Unicode
 import System.FilePath
 
@@ -45,8 +45,7 @@ newtype ExtMap
     deriving (Eq, Show, Read, Monoid, Typeable)
 
 instance Lift ExtMap where
-    lift (ExtMap m)
-        = [| ExtMap $(liftMap liftText lift m) |]
+    lift (ExtMap m) = [| ExtMap $(lift m) |]
 
 -- |'QuasiQuoter' for 'ExtMap' reading Apache @mime.types@.
 --
@@ -64,57 +63,65 @@ instance Lift ExtMap where
 -- @
 extMap ∷ QuasiQuoter
 extMap = QuasiQuoter {
-             quoteExp  = (lift ∘ parseExtMap =≪) ∘ toAscii
+             quoteExp  = lift ∘ parseExtMap ∘ Lazy.pack
            , quotePat  = const unsupported
            , quoteType = const unsupported
            , quoteDec  = const unsupported
          }
     where
-      toAscii ∷ Monad m ⇒ String → m Ascii
-      toAscii (A.fromChars → Just a) = return a
-      toAscii _ = fail "Malformed extension map"
+      parseExtMap ∷ Lazy.ByteString → ExtMap
+      parseExtMap = convertUnsafe
 
       unsupported ∷ Monad m ⇒ m α
       unsupported = fail "Unsupported usage of extMap quasi-quoter."
 
--- |Parse Apache @mime.types@.
-parseExtMap ∷ Ascii → ExtMap
-parseExtMap src
-    = case parseOnly (finishOff extMapP) $ A.toByteString src of
-        Right xs → case compile xs of
-                      Right m → ExtMap m
-                      Left  e → error ("Duplicate extension: " ⧺ show e)
-        Left err → error ("Unparsable extension map: " ⧺ err)
+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"
 
-extMapP ∷ Parser [(MIMEType, [Text])]
-extMapP = catMaybes <$> P.many (try comment <|> try validLine <|> emptyLine)
-    where
-      isSpc ∷ Char → Bool
-      isSpc c = c ≡ '\x20' ∨ c ≡ '\x09'
-
-      comment ∷ Parser (Maybe (MIMEType, [Text]))
-      comment = do skipWhile isSpc
-                   void $ char '#'
-                   skipWhile (≢ '\x0A')
-                   return Nothing
-
-      validLine ∷ Parser (Maybe (MIMEType, [Text]))
-      validLine = do skipWhile isSpc
-                     mime ← mimeType
-                     skipWhile isSpc
-                     exts ← sepBy extP (skipWhile isSpc)
-                     return $ Just (mime, exts)
+          pair ∷ Parser (MIMEType, [Text])
+          pair = do skipSpace
+                    mime ← def
+                    skipSpace1
+                    exts ← sepBy1 ext $ skipWhile1 (≡ '\x20')
+                    return (mime, exts)
+                 <?>
+                 "pair"
 
-      extP ∷ Parser Text
-      extP = decodeUtf8 <$> takeWhile1 (\c → (¬) (isSpc c ∨ c ≡ '\x0A'))
+          ext ∷ Parser Text
+          ext = (decodeUtf8 <$> takeWhile1 isAlphaNum)
+                <?>
+                "ext"
 
-      emptyLine ∷ Parser (Maybe (MIMEType, [Text]))
-      emptyLine = do skipWhile isSpc
-                     void $ char '\x0A'
-                     return Nothing
+          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 ∘ map tr
+compile = go (∅) ∘ concat ∘ (tr <$>)
     where
       tr ∷ (v, [k]) → [(k, v)]
       tr (v, ks) = [(k, v) | k ← ks]
@@ -134,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