X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FParser.hs;h=8c591defd4be602e13db5534567637039b0679bb;hb=e2a6ee839c0ca27b25b32656a5c080e4b464e7c9;hp=bbe16a3d80b8bd3d4da6f2263fbe995f9cf3fd75;hpb=e53a2f3202f763e844de725712f1bf26b82cd41f;p=Lucu.git

diff --git a/Network/HTTP/Lucu/Parser.hs b/Network/HTTP/Lucu/Parser.hs
index bbe16a3..8c591de 100644
--- a/Network/HTTP/Lucu/Parser.hs
+++ b/Network/HTTP/Lucu/Parser.hs
@@ -33,6 +33,7 @@ module Network.HTTP.Lucu.Parser
     , char
     , string
     , (<|>)
+    , choice
     , oneOf
     , digit
     , hexDigit
@@ -51,9 +52,8 @@ module Network.HTTP.Lucu.Parser
     where
 
 import           Control.Monad.State.Strict
-import           Data.ByteString.Base (LazyByteString)
-import           Data.ByteString.Lazy ()
-import qualified Data.ByteString.Lazy.Char8 as B
+import qualified Data.ByteString.Lazy as Lazy (ByteString)
+import qualified Data.ByteString.Lazy.Char8 as B hiding (ByteString)
 
 -- |@'Parser' a@ is obviously a parser which parses and returns @a@.
 newtype Parser a = Parser {
@@ -63,7 +63,7 @@ newtype Parser a = Parser {
 
 data ParserState
     = PST {
-        pstInput      :: LazyByteString
+        pstInput      :: Lazy.ByteString
       , pstIsEOFFatal :: !Bool
       }
     deriving (Eq, Show)
@@ -95,7 +95,7 @@ failP = fail undefined
 
 -- |@'parse' p bstr@ parses @bstr@ with @p@ and returns @(# result,
 -- remaining #)@.
-parse :: Parser a -> LazyByteString -> (# ParserResult a, LazyByteString #)
+parse :: Parser a -> Lazy.ByteString -> (# ParserResult a, Lazy.ByteString #)
 parse p input -- input は lazy である必要有り。
     = p `seq`
       let (result, state') = runState (runParser p) (PST input True)
@@ -103,7 +103,7 @@ parse p input -- input は lazy である必要有り。
         result `seq` (# result, pstInput state' #) -- pstInput state' も lazy である必要有り。
 
 -- |@'parseStr' p str@ packs @str@ and parses it.
-parseStr :: Parser a -> String -> (# ParserResult a, LazyByteString #)
+parseStr :: Parser a -> String -> (# ParserResult a, Lazy.ByteString #)
 parseStr p input
     = p `seq` -- input は lazy である必要有り。
       parse p (B.pack input)
@@ -174,12 +174,17 @@ f <|> g
                      IllegalInput -> do put saved -- 状態を復歸
                                         runParser g
                      ReachedEOF   -> if pstIsEOFFatal saved then
-                                         return ReachedEOF
+                                         do put saved
+                                            return ReachedEOF
                                      else
                                          do put saved
                                             runParser g
 
 
+choice :: [Parser a] -> Parser a
+choice = foldl (<|>) failP
+
+
 oneOf :: [Char] -> Parser Char
 oneOf = foldl (<|>) failP . map char
 
@@ -190,7 +195,7 @@ notFollowedBy p
       Parser $! do saved  <- get -- 状態を保存
                    result <- runParser p
                    case result of
-                     Success a    -> do put saved -- 状態を復歸
+                     Success _    -> do put saved -- 状態を復歸
                                         return IllegalInput
                      IllegalInput -> do put saved -- 状態を復歸
                                         return $! Success ()
@@ -217,27 +222,48 @@ hexDigit = do c <- anyChar
 
 
 many :: Parser a -> Parser [a]
-many p = p `seq`
-         do x  <- p
-            xs <- many p
-            return (x:xs)
-         <|>
-         return []
+many !p = Parser $! many' p []
+
+-- This implementation is rather ugly but we need to make it
+-- tail-recursive to avoid stack overflow.
+many' :: Parser a -> [a] -> State ParserState (ParserResult [a])
+many' !p !soFar
+    = do saved  <- get
+         result <- runParser p
+         case result of
+           Success a    -> many' p (a:soFar)
+           IllegalInput -> do put saved
+                              return $! Success $ reverse soFar
+           ReachedEOF   -> if pstIsEOFFatal saved then
+                               do put saved
+                                  return ReachedEOF
+                           else
+                               do put saved
+                                  return $! Success $ reverse soFar
 
 
 many1 :: Parser a -> Parser [a]
-many1 p = p `seq`
-          do x  <- p
-             xs <- many p
-             return (x:xs)
+many1 !p = do x  <- p
+              xs <- many p
+              return (x:xs)
 
 
 count :: Int -> Parser a -> Parser [a]
-count 0 _ = return []
-count n p = n `seq` p `seq`
-            do x  <- p
-               xs <- count (n-1) p
-               return (x:xs)
+count !n !p = Parser $! count' n p []
+
+-- This implementation is rather ugly but we need to make it
+-- tail-recursive to avoid stack overflow.
+count' :: Int -> Parser a -> [a] -> State ParserState (ParserResult [a])
+count' 0  _  !soFar = return $! Success $ reverse soFar
+count' !n !p !soFar = do saved  <- get
+                         result <- runParser p
+                         case result of
+                           Success a    -> count' (n-1) p (a:soFar)
+                           IllegalInput -> do put saved
+                                              return IllegalInput
+                           ReachedEOF   -> do put saved
+                                              return ReachedEOF
+
 
 -- def may be a _|_
 option :: a -> Parser a -> Parser a