Network/HTTP/Lucu/Parser.hs

   1 -- |Yet another parser combinator. This is mostly a subset of Parsec
   2 -- but there are some differences:
   3 --
   4 -- * This parser works on ByteString instead of String.
   5 --
   6 -- * Backtracking is the only possible behavior so there is no \"try\"
   7 --   action.
   8 --
   9 -- * On success, the remaining string is returned as well as the
  10 --   parser result.
  11 --
  12 -- * You can treat reaching EOF (trying to eat one more letter at the
  13 --   end of string) a fatal error or a normal failure. If a fatal
  14 --   error occurs, the entire parsing process immediately fails
  15 --   without trying any backtracks. The default behavior is to treat
  16 --   EOF fatal.
  17 --
  18 -- In general, you don't have to use this module directly.
  19 module Network.HTTP.Lucu.Parser
  20     ( Parser
  21     , ParserResult(..)
  22
  23     , parse
  24     , parseStr
  25
  26     , anyChar
  27     , eof
  28     , allowEOF
  29     , satisfy
  30     , char
  31     , string
  32     , (<|>)
  33     , oneOf
  34     , digit
  35     , hexDigit
  36     , notFollowedBy
  37     , many
  38     , many1
  39     , manyTill
  40     , many1Till
  41     , count
  42     , option
  43     , sepBy
  44     , sepBy1
  45
  46     , sp
  47     , ht
  48     , crlf
  49     )
  50     where
  51
  52 import           Control.Monad
  53 import           Control.Monad.State
  54 import qualified Data.ByteString.Lazy.Char8 as B
  55 import           Data.ByteString.Lazy.Char8 (ByteString)
  56
  57 -- |@Parser a@ is obviously a parser which parses and returns @a@.
  58 data Parser a = Parser {
  59       runParser :: State ParserState (ParserResult a)
  60     }
  61
  62 type ParserState = (ByteString, IsEOFFatal)
  63
  64 type IsEOFFatal = Bool
  65
  66 data ParserResult a = Success a
  67                     | IllegalInput -- 受理出來ない入力があった
  68                     | ReachedEOF   -- 限界を越えて讀まうとした
  69                       deriving (Eq, Show)
  70
  71
  72 --  (>>=) :: Parser a -> (a -> Parser b) -> Parser b
  73 instance Monad Parser where
  74     p >>= f = Parser $ do saved@(_, isEOFFatal) <- get -- 失敗した時の爲に状態を保存
  75                           result <- runParser p
  76                           case result of
  77                             Success a    -> runParser (f a)
  78                             IllegalInput -> do put saved -- 状態を復歸
  79                                                return IllegalInput
  80                             ReachedEOF   -> do unless isEOFFatal
  81                                                           $ put saved -- 状態を復歸
  82                                                return ReachedEOF
  83     return = Parser . return . Success
  84     fail _ = Parser $ return IllegalInput
  85
  86 -- |@'parse' p bstr@ parses @bstr@ with @p@ and returns @(result,
  87 -- remaining)@.
  88 parse :: Parser a -> ByteString -> (ParserResult a, ByteString)
  89 parse p input = let (result, (input', _)) = runState (runParser p) (input, True)
  90                 in
  91                   (result, input')
  92
  93 -- |@'parseStr' p str@ packs @str@ and parses it.
  94 parseStr :: Parser a -> String -> (ParserResult a, ByteString)
  95 parseStr p input = parse p $ B.pack input
  96
  97
  98 anyChar :: Parser Char
  99 anyChar = Parser $ do (input, isEOFFatal) <- get
 100                       if B.null input then
 101                           return ReachedEOF
 102                         else
 103                           do let c = B.head input
 104                              put (B.tail input, isEOFFatal)
 105                              return (Success c)
 106
 107
 108 eof :: Parser ()
 109 eof = Parser $ do (input, _) <- get
 110                   if B.null input then
 111                       return $ Success ()
 112                     else
 113                       return IllegalInput
 114
 115 -- |@'allowEOF' p@ makes @p@ treat reaching EOF a normal failure.
 116 allowEOF :: Parser a -> Parser a
 117 allowEOF f = Parser $ do (input, isEOFFatal) <- get
 118                          put (input, False)
 119
 120                          result <- runParser f
 121
 122                          (input', _) <- get
 123                          put (input', isEOFFatal)
 124
 125                          return result
 126
 127
 128 satisfy :: (Char -> Bool) -> Parser Char
 129 satisfy f = do c <- anyChar
 130                unless (f c) (fail "")
 131                return c
 132
 133
 134 char :: Char -> Parser Char
 135 char c = satisfy (== c)
 136
 137
 138 string :: String -> Parser String
 139 string str = do mapM_ char str
 140                 return str
 141
 142
 143 infixr 0 <|>
 144
 145 -- |This is the backtracking alternation. There is no non-backtracking
 146 -- equivalent.
 147 (<|>) :: Parser a -> Parser a -> Parser a
 148 f <|> g = Parser $ do saved@(_, isEOFFatal) <- get -- 状態を保存
 149                       result <- runParser f
 150                       case result of
 151                         Success a    -> return $ Success a
 152                         IllegalInput -> do put saved -- 状態を復歸
 153                                            runParser g
 154                         ReachedEOF   -> if isEOFFatal then
 155                                             return ReachedEOF
 156                                         else
 157                                             do put saved
 158                                                runParser g
 159
 160
 161 oneOf :: [Char] -> Parser Char
 162 oneOf = foldl (<|>) (fail "") . map char
 163
 164
 165 notFollowedBy :: Parser a -> Parser ()
 166 notFollowedBy p = p >>= fail "" <|> return ()
 167
 168
 169 digit :: Parser Char
 170 digit = do c <- anyChar
 171            if c >= '0' && c <= '9' then
 172                return c
 173              else
 174                fail ""
 175
 176
 177 hexDigit :: Parser Char
 178 hexDigit = do c <- anyChar
 179               if (c >= '0' && c <= '9') ||
 180                  (c >= 'a' && c <= 'f') ||
 181                  (c >= 'A' && c <= 'F') then
 182                   return c
 183                 else
 184                   fail ""
 185
 186
 187 many :: Parser a -> Parser [a]
 188 many p = do x  <- p
 189             xs <- many p
 190             return (x:xs)
 191          <|>
 192          return []
 193
 194
 195 many1 :: Parser a -> Parser [a]
 196 many1 p = do ret <- many p
 197              case ret of
 198                [] -> fail ""
 199                xs -> return xs
 200
 201
 202 manyTill :: Parser a -> Parser end -> Parser [a]
 203 manyTill p end = many $ do x <- p
 204                            end
 205                            return x
 206
 207
 208 many1Till :: Parser a -> Parser end -> Parser [a]
 209 many1Till p end = many1 $ do x <- p
 210                              end
 211                              return x
 212
 213
 214 count :: Int -> Parser a -> Parser [a]
 215 count 0 _ = return []
 216 count n p = do x  <- p
 217                xs <- count (n-1) p
 218                return (x:xs)
 219
 220
 221 option :: a -> Parser a -> Parser a
 222 option def p = p <|> return def
 223
 224
 225 sepBy :: Parser a -> Parser sep -> Parser [a]
 226 sepBy p sep = sepBy1 p sep <|> return []
 227
 228
 229 sepBy1 :: Parser a -> Parser sep -> Parser [a]
 230 sepBy1 p sep = do x  <- p
 231                   xs <- many $ sep >> p
 232                   return (x:xs)
 233
 234
 235 sp :: Parser Char
 236 sp = char ' '
 237
 238
 239 ht :: Parser Char
 240 ht = char '\t'
 241
 242
 243 crlf :: Parser String
 244 crlf = string "\x0d\x0a"