X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FParser.hs;h=cc12cd73733b636ce3270e8518d137ade2eb3266;hb=7b3c7c2c5be4fc05ee03008aa0af56fab798e1bb;hp=ffbf6d13ff67f2c834529a850dc684bebe74af1a;hpb=1000bdc46cfe7b3ae550ff24ccea9f440f11b42a;p=Lucu.git diff --git a/Network/HTTP/Lucu/Parser.hs b/Network/HTTP/Lucu/Parser.hs index ffbf6d1..cc12cd7 100644 --- a/Network/HTTP/Lucu/Parser.hs +++ b/Network/HTTP/Lucu/Parser.hs @@ -1,49 +1,74 @@ +-- |Yet another parser combinator. This is mostly a subset of Parsec +-- but there are some differences: +-- +-- * This parser works on ByteString instead of String. +-- +-- * Backtracking is the only possible behavior so there is no \"try\" +-- action. +-- +-- * On success, the remaining string is returned as well as the +-- parser result. +-- +-- * You can choose whether to treat reaching EOF (trying to eat one +-- more letter at the end of string) a fatal error or to treat it a +-- normal failure. If a fatal error occurs, the entire parsing +-- process immediately fails without trying any backtracks. The +-- default behavior is to treat EOF fatal. +-- +-- In general, you don't have to use this module directly. module Network.HTTP.Lucu.Parser - ( Parser(..) + ( Parser , ParserResult(..) - , parse -- Parser a -> ByteString -> (ParserResult a, ByteString) - , parseStr -- Parser a -> String -> (ParserResult a, ByteString) - - , anyChar -- Parser Char - , eof -- Parser () - , allowEOF -- Parser a -> Parser a - , satisfy -- (Char -> Bool) -> Parser Char - , char -- Char -> Parser Char - , string -- String -> Parser String - , (<|>) -- Parser a -> Parser a -> Parser a - , oneOf -- [Char] -> Parser Char - , digit -- Parser Char - , hexDigit -- Parser Char - , notFollowedBy -- Parser a -> Parser () - , many -- Parser a -> Parser [a] - , many1 -- Parser a -> Parser [a] - , manyTill -- Parser a -> Parser end -> Parser [a] - , many1Till -- Parser a -> Parser end -> Parser [a] - , option -- a -> Parser a -> Parser a - , sepBy -- Parser a -> Parser sep -> Parser [a] - , sepBy1 -- Parser a -> Parser sep -> Parser [a] - - , sp -- Parser Char - , ht -- Parser Char - , crlf -- Parser String + , failP + + , parse + , parseStr + + , anyChar + , eof + , allowEOF + , satisfy + , char + , string + , (<|>) + , oneOf + , digit + , hexDigit + , notFollowedBy + , many + , many1 + , count + , option + , sepBy + , sepBy1 + + , sp + , ht + , crlf ) where -import Control.Monad -import Control.Monad.State +import Control.Monad.State.Strict import qualified Data.ByteString.Lazy.Char8 as B import Data.ByteString.Lazy.Char8 (ByteString) -data Parser a = Parser { + +-- |@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 :: ByteString + , pstIsEOFFatal :: !Bool + } + deriving (Eq, Show) + -data ParserResult a = Success a +data ParserResult a = Success !a | IllegalInput -- 受理出來ない入力があった | ReachedEOF -- 限界を越えて讀まうとした deriving (Eq, Show) @@ -51,98 +76,115 @@ data ParserResult a = Success a -- (>>=) :: Parser a -> (a -> Parser b) -> Parser b instance Monad Parser where - p >>= f = Parser $ do saved@(_, isEOFFatal) <- get -- 失敗した時の爲に状態を保存 - result <- runParser p - case result of - Success a -> runParser (f a) - IllegalInput -> do put saved -- 状態を復歸 - return IllegalInput - ReachedEOF -> if isEOFFatal then + p >>= f = Parser $! do saved <- get -- 失敗した時の爲に状態を保存 + result <- runParser p + case result of + Success a -> runParser (f a) + IllegalInput -> do put saved -- 状態を復歸 + return IllegalInput + ReachedEOF -> do put saved -- 状態を復歸 return ReachedEOF - else - do put saved - return IllegalInput - return = Parser . return . Success - fail _ = Parser $ return IllegalInput + return x = x `seq` Parser $! return $! Success x + fail _ = Parser $! return $! IllegalInput +-- |@'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 -> ByteString -> (ParserResult a, ByteString) -parse p input = let (result, (input', _)) = runState (runParser p) (input, True) - in - (result, input') - +parse p input -- input は lazy である必要有り。 + = p `seq` + let (result, state') = runState (runParser p) (PST input True) + in + result `seq` (result, pstInput state') -- pstInput state' も lazy である必要有り。 +-- |@'parseStr' p str@ packs @str@ and parses it. parseStr :: Parser a -> String -> (ParserResult a, ByteString) -parseStr p input = parse p $ B.pack input +parseStr p input + = p `seq` -- input は lazy である必要有り。 + parse p $! B.pack input anyChar :: Parser Char -anyChar = Parser $ do (input, isEOFFatal) <- get - if B.null input then - return ReachedEOF - else - do let c = B.head input - put (B.tail input, isEOFFatal) - return (Success c) +anyChar = Parser $! + do state@(PST input _) <- get + if B.null input then + return ReachedEOF + else + do put $! state { pstInput = B.tail input } + return (Success $! B.head input) eof :: Parser () -eof = Parser $ do (input, _) <- get - if B.null input then - return $ Success () - else - return IllegalInput - - +eof = Parser $! + do PST input _ <- get + if B.null input then + return $! Success () + else + return IllegalInput + +-- |@'allowEOF' p@ makes @p@ treat reaching EOF a normal failure. allowEOF :: Parser a -> Parser a -allowEOF f = Parser $ do (input, isEOFFatal) <- get - put (input, False) +allowEOF f = f `seq` + 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 = do c <- anyChar - unless (f c) (fail "") - return c +satisfy f = f `seq` + do c <- anyChar + if f c then + return c + else + failP char :: Char -> Parser Char -char c = satisfy (== c) +char c = c `seq` satisfy (== c) string :: String -> Parser String -string str = do mapM_ char str +string str = str `seq` + do mapM_ char str return str infixr 0 <|> +-- |This is the backtracking alternation. There is no non-backtracking +-- equivalent. (<|>) :: Parser a -> Parser a -> Parser a -f <|> g = Parser $ do saved@(_, isEOFFatal) <- get -- 状態を保存 - result <- runParser f - case result of - Success a -> return $ Success a - IllegalInput -> do put saved -- 状態を復歸 - runParser g - ReachedEOF -> if isEOFFatal then - return ReachedEOF - else - do put saved - runParser g +f <|> g + = f `seq` g `seq` + Parser $! do saved <- get -- 状態を保存 + result <- runParser f + case result of + Success a -> return $! Success a + IllegalInput -> do put saved -- 状態を復歸 + runParser g + ReachedEOF -> if pstIsEOFFatal saved then + return ReachedEOF + else + do put saved + runParser g oneOf :: [Char] -> Parser Char -oneOf = foldl (<|>) (fail "") . map char +oneOf = foldl (<|>) failP . map char notFollowedBy :: Parser a -> Parser () -notFollowedBy p = p >>= fail "" <|> return () +notFollowedBy p = p `seq` + (p >> failP) <|> return () digit :: Parser Char @@ -150,7 +192,7 @@ digit = do c <- anyChar if c >= '0' && c <= '9' then return c else - fail "" + failP hexDigit :: Parser Char @@ -160,11 +202,12 @@ hexDigit = do c <- anyChar (c >= 'A' && c <= 'F') then return c else - fail "" + failP many :: Parser a -> Parser [a] -many p = do x <- p +many p = p `seq` + do x <- p xs <- many p return (x:xs) <|> @@ -172,35 +215,34 @@ many p = do x <- p many1 :: Parser a -> Parser [a] -many1 p = do ret <- many p - case ret of - [] -> fail "" - xs -> return xs - - -manyTill :: Parser a -> Parser end -> Parser [a] -manyTill p end = many $ do x <- p - end - return x - +many1 p = p `seq` + do x <- p + xs <- many p + return (x:xs) -many1Till :: Parser a -> Parser end -> Parser [a] -many1Till p end = many1 $ do x <- p - end - return x +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) +-- def may be a _|_ option :: a -> Parser a -> Parser a -option def p = p <|> return def +option def p = p `seq` + p <|> return def sepBy :: Parser a -> Parser sep -> Parser [a] -sepBy p sep = sepBy1 p sep <|> return [] +sepBy p sep = p `seq` sep `seq` + sepBy1 p sep <|> return [] sepBy1 :: Parser a -> Parser sep -> Parser [a] -sepBy1 p sep = do x <- p - xs <- many $ sep >> p +sepBy1 p sep = p `seq` sep `seq` + do x <- p + xs <- many $! sep >> p return (x:xs)