Many bugfixes

[Lucu.git] / Network / HTTP / Lucu / Parser / Http.hs

diff --git a/Network/HTTP/Lucu/Parser/Http.hs b/Network/HTTP/Lucu/Parser/Http.hs
index e3fbf3501b1cc50800bf1af90f88b123beee0030..72d8ca1721ae7908a94cd1b2445eff1aaa16e1c8 100644 (file)
--- a/Network/HTTP/Lucu/Parser/Http.hs
+++ b/Network/HTTP/Lucu/Parser/Http.hs
@@ -1,6 +1,5 @@
 {-# LANGUAGE
     OverloadedStrings
-  , ScopedTypeVariables
   , UnicodeSyntax
   #-}
 -- |This is an auxiliary parser utilities for parsing things related
@@ -25,26 +24,16 @@ module Network.HTTP.Lucu.Parser.Http
     , separators
     , quotedStr
     , qvalue
-
-    , atMost
-    , manyCharsTill
     )
     where
 import Control.Applicative
-import Control.Applicative.Unicode hiding ((∅))
-import Control.Monad.Unicode
+import Control.Monad
 import Data.Ascii (Ascii)
 import qualified Data.Ascii as A
 import Data.Attoparsec.Char8 as P hiding (scan)
 import qualified Data.Attoparsec.FastSet as FS
 import qualified Data.ByteString.Char8 as BS
-import qualified Data.ByteString.Lazy.Char8 as LS
-import qualified Data.ByteString.Lazy.Internal as LS
-import Data.Foldable
-import Data.Monoid
-import Data.Monoid.Unicode
-import qualified Data.Sequence as S
-import Data.Sequence.Unicode hiding ((∅))
+import Network.HTTP.Lucu.Parser
 import Prelude.Unicode
 
 -- |@'isCtl' c@ returns 'False' iff @0x20 <= c < 0x7F@.
@@ -84,20 +73,27 @@ isToken c = (¬) (isCtl c ∨ isSeparator c)
 -- allows any occurrences of 'lws' before and after each tokens.
 listOf ∷ Parser a → Parser [a]
 {-# INLINEABLE listOf #-}
-listOf p = do skipMany lws
-              sepBy p $ do skipMany lws
-                           _ ← char ','
-                           skipMany lws
+listOf p
+    = do skipMany lws
+         p `sepBy` do skipMany lws
+                      void $ char ','
+                      skipMany lws
+      <?>
+      "listOf"
 
 -- |'token' is almost the same as @'takeWhile1' 'isToken'@
 token ∷ Parser Ascii
 {-# INLINE token #-}
-token = A.unsafeFromByteString <$> takeWhile1 isToken
+token = (A.unsafeFromByteString <$> takeWhile1 isToken)
+        <?>
+        "token"
 
 -- |The CRLF: 0x0D 0x0A.
 crlf ∷ Parser ()
 {-# INLINE crlf #-}
-crlf = string "\x0D\x0A" *> return ()
+crlf = (string "\x0D\x0A" *> return ())
+       <?>
+       "crlf"
 
 -- |The SP: 0x20.
 sp ∷ Parser ()
@@ -107,9 +103,9 @@ sp = char '\x20' *> return ()
 -- |HTTP LWS: crlf? (sp | ht)+
 lws ∷ Parser ()
 {-# INLINEABLE lws #-}
-lws = do option () crlf
-         _ ← takeWhile1 isSPHT
-         return ()
+lws = (option () crlf *> void (takeWhile1 isSPHT))
+      <?>
+      "lws"
 
 -- |Returns 'True' for SP and HT.
 isSPHT ∷ Char → Bool
@@ -121,106 +117,49 @@ isSPHT _      = False
 -- |@'separators'@ is almost the same as @'takeWhile1' 'isSeparator'@.
 separators ∷ Parser Ascii
 {-# INLINE separators #-}
-separators = A.unsafeFromByteString <$> takeWhile1 isSeparator
+separators = (A.unsafeFromByteString <$> takeWhile1 isSeparator)
+             <?>
+             "separators"
 
 -- |'quotedStr' accepts a string surrounded by double quotation
 -- marks. Quotes can be escaped by backslashes.
 quotedStr ∷ Parser Ascii
 {-# INLINEABLE quotedStr #-}
-quotedStr = try $
-            do _  ← char '"'
+quotedStr = do void $ char '"'
                xs ← P.many (qdtext <|> quotedPair)
-               _  ← char '"'
+               void $ char '"'
                return $ A.unsafeFromByteString $ BS.pack xs
+            <?>
+            "quotedStr"
     where
       qdtext ∷ Parser Char
       {-# INLINE qdtext #-}
       qdtext = satisfy (\c → c ≢ '"' ∧ (¬) (isCtl c))
+               <?>
+               "qdtext"
 
       quotedPair ∷ Parser Char
       {-# INLINE quotedPair #-}
-      quotedPair = char '\\' *> satisfy isChar
+      quotedPair = (char '\\' *> satisfy isChar)
+                   <?>
+                   "quotedPair"
 
 -- |'qvalue' accepts a so-called qvalue.
 qvalue ∷ Parser Double
 {-# INLINEABLE qvalue #-}
-qvalue = do x  ← char '0'
-            xs ← option "" $
-                 do y  ← char '.'
-                    ys ← atMost 3 digit
-                    return (y:ys)
-            return $ read (x:xs)
-         <|>
-         do x  ← char '1'
-            xs ← option "" $
-                 do y  ← char '.'
-                    ys ← atMost 3 (char '0')
-                    return (y:ys)
-            return $ read (x:xs)
-
--- |@'atMost' n v@ is like @'P.many' v@ but accumulates @v@ at most
--- @n@ times.
-atMost ∷ Alternative f ⇒ Int → f a → f [a]
-{-# INLINE atMost #-}
-atMost 0 _ = pure []
-atMost n v = ( (:) <$> v ⊛ atMost (n-1) v )
-             <|>
-             pure []
-
-data CharAccumState
-    = CharAccumState {
-        casChunks    ∷ !(S.Seq BS.ByteString)
-      , casLastChunk ∷ !(S.Seq Char)
-      }
-
-instance Monoid CharAccumState where
-    mempty
-        = CharAccumState {
-            casChunks    = (∅)
-          , casLastChunk = (∅)
-          }
-    mappend a b
-        = b {
-            casChunks = (casChunks a ⊳ lastChunk a) ⋈ casChunks b
-          }
-
-lastChunk ∷ CharAccumState → BS.ByteString
-{-# INLINE lastChunk #-}
-lastChunk = BS.pack ∘ toList ∘ casLastChunk
-
-snoc ∷ CharAccumState → Char → CharAccumState
-{-# INLINEABLE snoc #-}
-snoc cas c
-    | S.length (casLastChunk cas) ≥ LS.defaultChunkSize
-        = cas {
-            casChunks    = casChunks cas ⊳ lastChunk cas
-          , casLastChunk = S.singleton c
-          }
-    | otherwise
-        = cas {
-            casLastChunk = casLastChunk cas ⊳ c
-          }
-
-finish ∷ CharAccumState → LS.ByteString
-{-# INLINEABLE finish #-}
-finish cas
-    = let chunks = toList $ casChunks cas ⊳ lastChunk cas
-          str    = LS.fromChunks chunks
-      in
-        str
-
--- |@'manyCharsTill' p end@ takes as many characters untill @p@
--- succeeds.
-manyCharsTill ∷ ∀m b. (Monad m, Alternative m)
-              ⇒ m Char
-              → m b
-              → m LS.ByteString
-{-# INLINEABLE manyCharsTill #-}
-manyCharsTill p end = scan (∅)
-    where
-      scan ∷ CharAccumState → m LS.ByteString
-      {-# INLINE scan #-}
-      scan s
-          = (end *> pure (finish s))
-            <|>
-            (scan =≪ (snoc s <$> p))
+qvalue = ( do x  ← char '0'
+              xs ← option "" $
+                   do y  ← char '.'
+                      ys ← atMost 3 digit
+                      return (y:ys)
+              return $ read (x:xs)
+           <|>
+           do x  ← char '1'
+              xs ← option "" $
+                   do y  ← char '.'
+                      ys ← atMost 3 (char '0')
+                      return (y:ys)
+              return $ read (x:xs)
+         )
+         <?>
+         "qvalue"