X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FParser%2FHttp.hs;h=fe54bde4c5d9f08b10ce443dd029f6d5bd838aa2;hb=70bf5bd248aa426ca4e410b3fb9a0529354aedaf;hp=ae09522b3807c65c6bca94dc6355727e52f81c38;hpb=30fcb38426696db8b80d322196cc594431e30407;p=Lucu.git

diff --git a/Network/HTTP/Lucu/Parser/Http.hs b/Network/HTTP/Lucu/Parser/Http.hs
index ae09522..fe54bde 100644
--- a/Network/HTTP/Lucu/Parser/Http.hs
+++ b/Network/HTTP/Lucu/Parser/Http.hs
@@ -1,3 +1,7 @@
+{-# LANGUAGE
+    BangPatterns
+  , UnicodeSyntax
+  #-}
 -- |This is an auxiliary parser utilities for parsing things related
 -- on HTTP protocol.
 --
@@ -13,26 +17,44 @@ module Network.HTTP.Lucu.Parser.Http
     , text
     , separator
     , quotedStr
+    , qvalue
     )
     where
 
-import qualified Data.ByteString.Lazy.Char8 as B
-import           Data.ByteString.Lazy.Char8 (ByteString)
-import           Data.List
 import           Network.HTTP.Lucu.Parser
 
--- |@'isCtl' c@ is True iff @0x20 <= @c@ < 0x7F@.
+-- |@'isCtl' c@ is 'Prelude.False' iff @0x20 <= @c@ < 0x7F@.
 isCtl :: Char -> Bool
 isCtl c
     | c <  '\x1f' = True
     | c >= '\x7f' = True
-    | otherwise  = False
+    | otherwise   = False
 
--- |@'isSeparator' c@ is True iff c is one of HTTP separators.
+-- |@'isSeparator' c@ is 'Prelude.True' iff c is one of HTTP
+-- separators.
 isSeparator :: Char -> Bool
-isSeparator c = elem c "()<>@,;:\\\"/[]?={} \t"
+isSeparator '('  = True
+isSeparator ')'  = True
+isSeparator '<'  = True
+isSeparator '>'  = True
+isSeparator '@'  = True
+isSeparator ','  = True
+isSeparator ';'  = True
+isSeparator ':'  = True
+isSeparator '\\' = True
+isSeparator '"'  = True
+isSeparator '/'  = True
+isSeparator '['  = True
+isSeparator ']'  = True
+isSeparator '?'  = True
+isSeparator '='  = True
+isSeparator '{'  = True
+isSeparator '}'  = True
+isSeparator ' '  = True
+isSeparator '\t' = True
+isSeparator _    = False
 
--- |@'isChar' c@ is True iff @c <= 0x7f@.
+-- |@'isChar' c@ is 'Prelude.True' iff @c <= 0x7f@.
 isChar :: Char -> Bool
 isChar c
     | c <= '\x7f' = True
@@ -41,21 +63,22 @@ isChar c
 -- |@'isToken' c@ is equivalent to @not ('isCtl' c || 'isSeparator'
 -- c)@
 isToken :: Char -> Bool
-isToken c = not (isCtl c || isSeparator c)
+isToken c = c `seq`
+            not (isCtl c || isSeparator c)
 
 -- |@'listOf' p@ is similar to @'Network.HTTP.Lucu.Parser.sepBy' p
 -- ('Network.HTTP.Lucu.Parser.char' \',\')@ but it allows any
 -- occurrences of LWS before and after each tokens.
 listOf :: Parser a -> Parser [a]
-listOf p = do many lws
-              sepBy p (do many lws
-                          char ','
-                          many lws)
+listOf !p = do _ <- many lws
+               sepBy p $! do _ <- many lws
+                             _ <- char ','
+                             many lws
 
 -- |'token' is equivalent to @'Network.HTTP.Lucu.Parser.many1' $
 -- 'Network.HTTP.Lucu.Parser.satisfy' 'isToken'@
 token :: Parser String
-token = many1 $ satisfy isToken
+token = many1 $! satisfy isToken
 
 -- |'lws' is an HTTP LWS: @'Network.HTTP.Lucu.Parser.crlf'?
 -- ('Network.HTTP.Lucu.Parser.sp' | 'Network.HTTP.Lucu.Parser.ht')+@
@@ -66,7 +89,7 @@ lws = do s  <- option "" crlf
 
 -- |'text' accepts one character which doesn't satisfy 'isCtl'.
 text :: Parser Char
-text = satisfy (\ c -> not (isCtl c))
+text = satisfy (not . isCtl)
 
 -- |'separator' accepts one character which satisfies 'isSeparator'.
 separator :: Parser Char
@@ -75,14 +98,30 @@ separator = satisfy isSeparator
 -- |'quotedStr' accepts a string surrounded by double quotation
 -- marks. Quotes can be escaped by backslashes.
 quotedStr :: Parser String
-quotedStr = do char '"'
+quotedStr = do _  <- char '"'
                xs <- many (qdtext <|> quotedPair)
-               char '"'
+               _  <- char '"'
                return $ foldr (++) "" xs
     where
       qdtext = do c <- satisfy (/= '"')
                   return [c]
 
-      quotedPair = do q <- char '\\'
+      quotedPair = do _ <- char '\\'
                       c <- satisfy isChar
                       return [c]
+
+-- |'qvalue' accepts a so-called qvalue.
+qvalue :: Parser Double
+qvalue = do x  <- char '0'
+            xs <- option ""
+                  $ do y  <- char '.'
+                       ys <- many digit -- 本當は三文字までに制限
+                       return (y:ys)
+            return $ read (x:xs)
+         <|>
+         do x  <- char '1'
+            xs <- option ""
+                  $ do y  <- char '.'
+                       ys <- many (char '0') -- 本當は三文字までに制限
+                       return (y:ys)
+            return $ read (x:xs)