Release 0.3.3

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

diff --git a/Network/HTTP/Lucu/Parser.hs b/Network/HTTP/Lucu/Parser.hs
index 8c591defd4be602e13db5534567637039b0679bb..6c66e7f42e3c02c7fc12b63ceab537dfda0774d1 100644 (file)
--- a/Network/HTTP/Lucu/Parser.hs
+++ b/Network/HTTP/Lucu/Parser.hs
@@ -54,6 +54,9 @@ module Network.HTTP.Lucu.Parser
 import           Control.Monad.State.Strict
 import qualified Data.ByteString.Lazy as Lazy (ByteString)
 import qualified Data.ByteString.Lazy.Char8 as B hiding (ByteString)
+import qualified Data.Foldable as Fold
+import qualified Data.Sequence as Seq
+import           Data.Sequence (Seq, (|>))
 
 -- |@'Parser' a@ is obviously a parser which parses and returns @a@.
 newtype Parser a = Parser {
@@ -142,22 +145,22 @@ allowEOF f = f `seq`
 
 
 satisfy :: (Char -> Bool) -> Parser Char
-satisfy f = f `seq`
-            do c <- anyChar
-               if f $! c then
-                   return c
-                 else
-                   failP
+satisfy !f
+    = do c <- anyChar
+         if f c then
+             return c
+           else
+             failP
 
 
 char :: Char -> Parser Char
-char c = c `seq` satisfy (== c)
+char !c = satisfy (== c)
 
 
 string :: String -> Parser String
-string str = str `seq`
-             do mapM_ char str
-                return str
+string !str = str `seq`
+              do mapM_ char str
+                 return str
 
 
 infixr 0 <|>
@@ -190,9 +193,8 @@ oneOf = foldl (<|>) failP . map char
 
 
 notFollowedBy :: Parser a -> Parser ()
-notFollowedBy p
-    = p `seq`
-      Parser $! do saved  <- get -- 状態を保存
+notFollowedBy !p
+    = Parser $! do saved  <- get -- 状態を保存
                    result <- runParser p
                    case result of
                      Success _    -> do put saved -- 状態を復歸
@@ -221,25 +223,22 @@ hexDigit = do c <- anyChar
                   failP
 
 
-many :: Parser a -> Parser [a]
-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
+many :: forall a. Parser a -> Parser [a]
+many !p = Parser $!
+          do state <- get
+             let (# result, state' #) = many' state Seq.empty
+             put state'
+             return result
+    where
+      many' :: ParserState -> Seq a -> (# ParserResult [a], ParserState #)
+      many' !st !soFar
+          = case runState (runParser p) st of
+              (Success a,  st') -> many' st' (soFar |> a)
+              (IllegalInput, _) -> (# Success (Fold.toList soFar), st #)
+              (ReachedEOF  , _) -> if pstIsEOFFatal st then
+                                       (# ReachedEOF, st #)
+                                   else
+                                       (# Success (Fold.toList soFar), st #)
 
 
 many1 :: Parser a -> Parser [a]
@@ -249,16 +248,16 @@ many1 !p = do x  <- p
 
 
 count :: Int -> Parser a -> Parser [a]
-count !n !p = Parser $! count' n p []
+count !n !p = Parser $! count' n p Seq.empty
 
 -- 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' :: Int -> Parser a -> Seq a -> State ParserState (ParserResult [a])
+count' 0  _  !soFar = return $! Success $! Fold.toList soFar
 count' !n !p !soFar = do saved  <- get
                          result <- runParser p
                          case result of
-                           Success a    -> count' (n-1) p (a:soFar)
+                           Success a    -> count' (n-1) p (soFar |> a)
                            IllegalInput -> do put saved
                                               return IllegalInput
                            ReachedEOF   -> do put saved