X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FParser.hs;h=34953f58c9dc5de637759c671f672b02815aa59e;hp=174a28997e04b85641392ea6062662f3705ed67d;hb=8bdd1da1ee1f3e453dbe2bce246618e12e26d30c;hpb=8e78bc83bfe67a376293c346ae0b30f1a684c787 diff --git a/Network/HTTP/Lucu/Parser.hs b/Network/HTTP/Lucu/Parser.hs index 174a289..34953f5 100644 --- a/Network/HTTP/Lucu/Parser.hs +++ b/Network/HTTP/Lucu/Parser.hs @@ -1,7 +1,8 @@ --- |Yet another parser combinator. This is mostly a subset of Parsec --- but there are some differences: +-- |Yet another parser combinator. This is mostly a subset of +-- "Text.ParserCombinators.Parsec" but there are some differences: -- --- * This parser works on ByteString instead of String. +-- * This parser works on 'Data.ByteString.Base.LazyByteString' +-- instead of 'Prelude.String'. -- -- * Backtracking is the only possible behavior so there is no \"try\" -- action. @@ -20,6 +21,8 @@ module Network.HTTP.Lucu.Parser ( Parser , ParserResult(..) + , failP + , parse , parseStr @@ -30,14 +33,14 @@ module Network.HTTP.Lucu.Parser , char , string , (<|>) + , choice , oneOf , digit , hexDigit , notFollowedBy , many + , manyChar , many1 - , manyTill - , many1Till , count , option , sepBy @@ -49,18 +52,27 @@ module Network.HTTP.Lucu.Parser ) where -import Control.Monad.State -import qualified Data.ByteString.Lazy.Char8 as B -import Data.ByteString.Lazy.Char8 (ByteString) +import Control.Monad.State.Strict hiding (state) +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 Data.Int +import qualified Data.Sequence as Seq +import Data.Sequence (Seq, (|>)) --- |@Parser a@ is obviously a parser which parses and returns @a@. +-- |@'Parser' a@ is obviously a parser which parses and returns @a@. newtype Parser a = Parser { runParser :: State ParserState (ParserResult a) } -type ParserState = (ByteString, IsEOFFatal) -type IsEOFFatal = Bool +data ParserState + = PST { + pstInput :: Lazy.ByteString + , pstIsEOFFatal :: !Bool + } + deriving (Eq, Show) + data ParserResult a = Success !a | IllegalInput -- 受理出來ない入力があった @@ -70,82 +82,101 @@ data ParserResult a = Success !a -- (>>=) :: Parser a -> (a -> Parser b) -> Parser b instance Monad Parser where - p >>= f = Parser $! do saved@(_, isEOFFatal) <- get -- 失敗した時の爲に状態を保存 + p >>= f = Parser $! do saved <- get -- 失敗した時の爲に状態を保存 result <- runParser p case result of - Success a -> a `seq` runParser (f a) + Success a -> runParser (f a) IllegalInput -> do put saved -- 状態を復歸 return IllegalInput - ReachedEOF -> do unless isEOFFatal - $ put saved -- 状態を復歸 + ReachedEOF -> do put saved -- 状態を復歸 return ReachedEOF - return x = x `seq` Parser $! return $! Success x - fail _ = Parser $! return $! IllegalInput - --- |@'parse' p bstr@ parses @bstr@ with @p@ and returns @(result, --- remaining)@. -parse :: Parser a -> ByteString -> (ParserResult a, ByteString) -parse p input -- input は lazy である必要有り。 - = p `seq` - let (result, (input', _)) = runState (runParser p) (input, True) + return !x = Parser $! return $! Success x + fail _ = Parser $! return $! IllegalInput + +instance Functor Parser where + fmap f p = p >>= return . f + +-- |@'failP'@ is just a synonym for @'Prelude.fail' +-- 'Prelude.undefined'@. +failP :: Parser a +failP = fail undefined + +-- |@'parse' p bstr@ parses @bstr@ with @p@ and returns @(# result, +-- remaining #)@. +parse :: Parser a -> Lazy.ByteString -> (# ParserResult a, Lazy.ByteString #) +parse !p input -- input は lazy である必要有り。 + = let (!result, state') = runState (runParser p) (PST input True) in - result `seq` (result, input') -- input' も lazy である必要有り。 + (# result, pstInput state' #) -- pstInput state' も lazy である必要有り。 -- |@'parseStr' p str@ packs @str@ and parses it. -parseStr :: Parser a -> String -> (ParserResult a, ByteString) -parseStr p input - = p `seq` -- input は lazy である必要有り。 - parse p $! B.pack input +parseStr :: Parser a -> String -> (# ParserResult a, Lazy.ByteString #) +parseStr !p input -- input は lazy である必要有り。 + = parse p (B.pack input) anyChar :: Parser Char anyChar = Parser $! - do (input, isEOFFatal) <- get + do state@(PST input _) <- get if B.null input then return ReachedEOF else - do let c = B.head input - put (B.tail input, isEOFFatal) - return (Success c) + do put $! state { pstInput = B.tail input } + return (Success $! B.head input) eof :: Parser () eof = Parser $! - do (input, _) <- get + do PST input _ <- get if B.null input then - return $ Success () + return $! Success () else return IllegalInput -- |@'allowEOF' p@ makes @p@ treat reaching EOF a normal failure. allowEOF :: Parser a -> Parser a -allowEOF f = f `seq` - Parser $! do (input, isEOFFatal) <- get - put (input, False) +allowEOF !f + = Parser $! do saved@(PST _ isEOFFatal) <- get + put $! saved { pstIsEOFFatal = False } - result <- runParser f + result <- runParser f - (input', _) <- get - put (input', isEOFFatal) + state <- get + put $! state { pstIsEOFFatal = isEOFFatal } - return result + return result satisfy :: (Char -> Bool) -> Parser Char -satisfy f = f `seq` - do c <- anyChar - unless (f c) (fail "") - return c +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 + = let bs = B.pack str + len = B.length bs + in + Parser $! + do st <- get + let (bs', rest) = B.splitAt len $ pstInput st + st' = st { pstInput = rest } + if B.length bs' < len then + return ReachedEOF + else + if bs == bs' then + do put st' + return $ Success str + else + return IllegalInput infixr 0 <|> @@ -153,28 +184,40 @@ infixr 0 <|> -- |This is the backtracking alternation. There is no non-backtracking -- equivalent. (<|>) :: Parser a -> Parser a -> Parser a -f <|> g - = f `seq` g `seq` - Parser $! do saved@(_, isEOFFatal) <- get -- 状態を保存 +(!f) <|> (!g) + = Parser $! do saved <- get -- 状態を保存 result <- runParser f case result of - Success a -> return $ Success a + Success a -> return $! Success a IllegalInput -> do put saved -- 状態を復歸 runParser g - ReachedEOF -> if isEOFFatal then - return ReachedEOF + ReachedEOF -> if pstIsEOFFatal saved then + 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 (<|>) (fail "") . map char +oneOf = foldl (<|>) failP . map char notFollowedBy :: Parser a -> Parser () -notFollowedBy p = p `seq` - p >>= fail "" <|> return () +notFollowedBy !p + = Parser $! do saved <- get -- 状態を保存 + result <- runParser p + case result of + Success _ -> do put saved -- 状態を復歸 + return IllegalInput + IllegalInput -> do put saved -- 状態を復歸 + return $! Success () + ReachedEOF -> do put saved -- 状態を復歸 + return $! Success () digit :: Parser Char @@ -182,7 +225,7 @@ digit = do c <- anyChar if c >= '0' && c <= '9' then return c else - fail "" + failP hexDigit :: Parser Char @@ -192,65 +235,90 @@ hexDigit = do c <- anyChar (c >= 'A' && c <= 'F') then return c else - fail "" + failP -many :: Parser a -> Parser [a] -many p = p `seq` - do x <- p - xs <- many p - return (x:xs) - <|> - return [] +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 #) + +manyChar :: Parser Char -> Parser Lazy.ByteString +manyChar !p = Parser $! + do state <- get + case scan' state 0 of + Success len + -> do let (bs, rest) = B.splitAt len (pstInput state) + state' = state { pstInput = rest } + put state' + return $ Success bs + ReachedEOF + -> if pstIsEOFFatal state then + return ReachedEOF + else + error "internal error" + _ -> error "internal error" + where + scan' :: ParserState -> Int64 -> ParserResult Int64 + scan' !st !soFar + = case runState (runParser p) st of + (Success _ , st') -> scan' st' (soFar + 1) + (IllegalInput, _ ) -> Success soFar + (ReachedEOF , _ ) -> if pstIsEOFFatal st then + ReachedEOF + else + Success soFar many1 :: Parser a -> Parser [a] -many1 p = p `seq` - do ret <- many p - case ret of - [] -> fail "" - xs -> return xs - - -manyTill :: Parser a -> Parser end -> Parser [a] -manyTill p end - = p `seq` end `seq` - many $! do x <- p - end - return x - - -many1Till :: Parser a -> Parser end -> Parser [a] -many1Till p end - = p `seq` end `seq` - many1 $! do x <- p - end - return x +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 Seq.empty + +-- This implementation is rather ugly but we need to make it +-- tail-recursive to avoid stack overflow. +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 (soFar |> a) + IllegalInput -> do put saved + return IllegalInput + ReachedEOF -> do put saved + return ReachedEOF + -- def may be a _|_ option :: a -> Parser a -> Parser a -option def p = p `seq` - p <|> return def +option def !p = p <|> return def sepBy :: Parser a -> Parser sep -> Parser [a] -sepBy p sep = p `seq` sep `seq` - sepBy1 p sep <|> return [] +sepBy !p !sep = sepBy1 p sep <|> return [] sepBy1 :: Parser a -> Parser sep -> Parser [a] -sepBy1 p sep = p `seq` sep `seq` - do x <- p - xs <- many $! sep >> p - return (x:xs) +sepBy1 !p !sep + = do x <- p + xs <- many $! sep >> p + return (x:xs) sp :: Parser Char