From 19043d7882f936be9b073cae34b52905016c3ad7 Mon Sep 17 00:00:00 2001
From: PHO <pho@cielonegro.org>
Date: Sun, 6 Nov 2011 17:49:48 +0900
Subject: [PATCH] Code cleanup

Ditz-issue: c566a8433e8af700655680f53e99cfe9f563ed32
---
 Network/HTTP/Lucu/MIMEType/Guess.hs | 82 +++++++++++++++--------------
 Network/HTTP/Lucu/Parser.hs         | 31 ++++++++++-
 2 files changed, 72 insertions(+), 41 deletions(-)

diff --git a/Network/HTTP/Lucu/MIMEType/Guess.hs b/Network/HTTP/Lucu/MIMEType/Guess.hs
index 8cddcba..edf1772 100644
--- a/Network/HTTP/Lucu/MIMEType/Guess.hs
+++ b/Network/HTTP/Lucu/MIMEType/Guess.hs
@@ -17,15 +17,13 @@ module Network.HTTP.Lucu.MIMEType.Guess
     )
     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.Lazy as LP
+import qualified Data.ByteString.Lazy.Char8 as Lazy
 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)
@@ -64,54 +62,60 @@ 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"
-
       unsupported ∷ Monad m ⇒ m α
       unsupported = fail "Unsupported usage of extMap quasi-quoter."
 
 -- |Parse Apache @mime.types@.
-parseExtMap ∷ Ascii → ExtMap
+parseExtMap ∷ Lazy.ByteString → 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)
-
-extMapP ∷ Parser [(MIMEType, [Text])]
-extMapP = catMaybes <$> P.many (try comment <|> try validLine <|> emptyLine)
+    = 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
-      isSpc ∷ Char → Bool
-      isSpc c = c ≡ '\x20' ∨ c ≡ '\x09'
-
-      comment ∷ Parser (Maybe (MIMEType, [Text]))
-      comment = do skipWhile isSpc
-                   void $ char '#'
-                   skipWhile (≢ '\x0A')
-                   return Nothing
+      pairs ∷ Parser [(MIMEType, [Text])]
+      pairs = do skipMany linebreak
+                 xs ← sepBy pair (skipMany1 linebreak)
+                 skipMany linebreak
+                 endOfInput
+                 return xs
+              <?>
+              "pairs"
 
-      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 ← mimeType
+                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 <$> P.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
diff --git a/Network/HTTP/Lucu/Parser.hs b/Network/HTTP/Lucu/Parser.hs
index ac1bf02..660f550 100644
--- a/Network/HTTP/Lucu/Parser.hs
+++ b/Network/HTTP/Lucu/Parser.hs
@@ -6,18 +6,22 @@
 module Network.HTTP.Lucu.Parser
     ( atMost
     , finishOff
+    , skipManyTill
+    , skipWhile1
+    , skipSpace1
+    , isAlphaNum
     )
     where
 import Control.Applicative
 import Control.Applicative.Unicode
 import Control.Monad.Unicode
-import Data.Attoparsec
+import Data.Attoparsec.Char8
 import Prelude.Unicode
 
 -- |@'atMost' n v@ is like @'P.many' v@ but accumulates @v@ at most
 -- @n@ times.
 atMost ∷ Alternative f ⇒ Int → f α → f [α]
-{-# INLINE atMost #-}
+{-# INLINEABLE atMost #-}
 atMost 0 _ = pure []
 atMost n v = ( (:) <$> v ⊛ atMost (n-1) v )
              <|>
@@ -28,3 +32,26 @@ atMost n v = ( (:) <$> v ⊛ atMost (n-1) v )
 finishOff ∷ Parser α → Parser α
 {-# INLINE finishOff #-}
 finishOff = ((endOfInput *>) ∘ return =≪)
+
+-- |Similar to 'manyTill' but discards the result.
+skipManyTill ∷ Alternative f ⇒ f α → f β → f ()
+{-# INLINEABLE skipManyTill #-}
+skipManyTill p end = go
+    where
+      go = (end *> pure ()) <|> (p *> go)
+
+-- |Similar to 'skipWhile' but consumes at least one character.
+skipWhile1 ∷ (Char → Bool) → Parser ()
+{-# INLINE skipWhile1 #-}
+skipWhile1 p = takeWhile1 p *> pure ()
+
+-- |Similar to 'skipSpace' but consumes at least one whitespace.
+skipSpace1 ∷ Parser ()
+{-# INLINE skipSpace1 #-}
+skipSpace1 = skipMany1 space
+
+-- |@'isAlphaNum' c@ returns 'True' iff @'isDigit' c ||
+-- 'isAlpha_ascii' c@.
+isAlphaNum ∷ Char → Bool
+{-# INLINE isAlphaNum #-}
+isAlphaNum c = isDigit c ∨ isAlpha_ascii c
-- 
2.40.0