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 choose whether to treat reaching EOF (trying to eat one
  13 --   more letter at the end of string) a fatal error or to treat it a
  14 --   normal failure. If a fatal error occurs, the entire parsing
  15 --   process immediately fails without trying any backtracks. The
  16 --   default behavior is to treat 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.State
  53 import qualified Data.ByteString.Lazy.Char8 as B
  54 import           Data.ByteString.Lazy.Char8 (ByteString)
  55
  56 -- |@Parser a@ is obviously a parser which parses and returns @a@.
  57 newtype Parser a = Parser {
  58       runParser :: State ParserState (ParserResult a)
  59     }
  60
  61 type ParserState = (ByteString, IsEOFFatal)
  62
  63 type IsEOFFatal = Bool
  64
  65 data ParserResult a = Success !a
  66                     | IllegalInput -- 受理出來ない入力があった
  67                     | ReachedEOF   -- 限界を越えて讀まうとした
  68                       deriving (Eq, Show)
  69
  70
  71 --  (>>=) :: Parser a -> (a -> Parser b) -> Parser b
  72 instance Monad Parser where
  73     p >>= f = Parser $! do saved@(_, isEOFFatal) <- get -- 失敗した時の爲に状態を保存
  74                            result <- runParser p
  75                            case result of
  76                              Success a    -> a `seq` runParser (f a)
  77                              IllegalInput -> do put saved -- 状態を復歸
  78                                                 return IllegalInput
  79                              ReachedEOF   -> do unless isEOFFatal
  80                                                            $ put saved -- 状態を復歸
  81                                                 return ReachedEOF
  82     return x = x `seq` Parser $! return $! Success x
  83     fail _   = Parser $! return $! IllegalInput
  84
  85 -- |@'parse' p bstr@ parses @bstr@ with @p@ and returns @(result,
  86 -- remaining)@.
  87 parse :: Parser a -> ByteString -> (ParserResult a, ByteString)
  88 parse p input -- input は lazy である必要有り。
  89     = p `seq`
  90       let (result, (input', _)) = runState (runParser p) (input, True)
  91       in
  92         result `seq` (result, input') -- input' も lazy である必要有り。
  93
  94 -- |@'parseStr' p str@ packs @str@ and parses it.
  95 parseStr :: Parser a -> String -> (ParserResult a, ByteString)
  96 parseStr p input
  97     = p `seq` -- input は lazy である必要有り。
  98       parse p $! B.pack input
  99
 100
 101 anyChar :: Parser Char
 102 anyChar = Parser $!
 103           do (input, isEOFFatal) <- get
 104              if B.null input then
 105                  return ReachedEOF
 106                else
 107                  do let c = B.head input
 108                     put (B.tail input, isEOFFatal)
 109                     return (Success c)
 110
 111
 112 eof :: Parser ()
 113 eof = Parser $!
 114       do (input, _) <- get
 115          if B.null input then
 116              return $ Success ()
 117            else
 118              return IllegalInput
 119
 120 -- |@'allowEOF' p@ makes @p@ treat reaching EOF a normal failure.
 121 allowEOF :: Parser a -> Parser a
 122 allowEOF f = f `seq`
 123              Parser $! do (input, isEOFFatal) <- get
 124                           put (input, False)
 125
 126                           result <- runParser f
 127
 128                           (input', _) <- get
 129                           put (input', isEOFFatal)
 130
 131                           return result
 132
 133
 134 satisfy :: (Char -> Bool) -> Parser Char
 135 satisfy f = f `seq`
 136             do c <- anyChar
 137                unless (f c) (fail "")
 138                return c
 139
 140
 141 char :: Char -> Parser Char
 142 char c = c `seq` satisfy (== c)
 143
 144
 145 string :: String -> Parser String
 146 string str = str `seq`
 147              do mapM_ char str
 148                 return str
 149
 150
 151 infixr 0 <|>
 152
 153 -- |This is the backtracking alternation. There is no non-backtracking
 154 -- equivalent.
 155 (<|>) :: Parser a -> Parser a -> Parser a
 156 f <|> g
 157     = f `seq` g `seq`
 158       Parser $! do saved@(_, isEOFFatal) <- get -- 状態を保存
 159                    result <- runParser f
 160                    case result of
 161                      Success a    -> return $ Success a
 162                      IllegalInput -> do put saved -- 状態を復歸
 163                                         runParser g
 164                      ReachedEOF   -> if isEOFFatal then
 165                                          return ReachedEOF
 166                                      else
 167                                          do put saved
 168                                             runParser g
 169
 170
 171 oneOf :: [Char] -> Parser Char
 172 oneOf = foldl (<|>) (fail "") . map char
 173
 174
 175 notFollowedBy :: Parser a -> Parser ()
 176 notFollowedBy p = p `seq`
 177                   p >>= fail "" <|> return ()
 178
 179
 180 digit :: Parser Char
 181 digit = do c <- anyChar
 182            if c >= '0' && c <= '9' then
 183                return c
 184              else
 185                fail ""
 186
 187
 188 hexDigit :: Parser Char
 189 hexDigit = do c <- anyChar
 190               if (c >= '0' && c <= '9') ||
 191                  (c >= 'a' && c <= 'f') ||
 192                  (c >= 'A' && c <= 'F') then
 193                   return c
 194                 else
 195                   fail ""
 196
 197
 198 many :: Parser a -> Parser [a]
 199 many p = p `seq`
 200          do x  <- p
 201             xs <- many p
 202             return (x:xs)
 203          <|>
 204          return []
 205
 206
 207 many1 :: Parser a -> Parser [a]
 208 many1 p = p `seq`
 209           do ret <- many p
 210              case ret of
 211                [] -> fail ""
 212                xs -> return xs
 213
 214
 215 manyTill :: Parser a -> Parser end -> Parser [a]
 216 manyTill p end
 217     = p `seq` end `seq`
 218       many $! do x <- p
 219                  end
 220                  return x
 221
 222
 223 many1Till :: Parser a -> Parser end -> Parser [a]
 224 many1Till p end
 225     = p `seq` end `seq`
 226       many1 $! do x <- p
 227                   end
 228                   return x
 229
 230
 231 count :: Int -> Parser a -> Parser [a]
 232 count 0 _ = return []
 233 count n p = n `seq` p `seq`
 234             do x  <- p
 235                xs <- count (n-1) p
 236                return (x:xs)
 237
 238 -- def may be a _|_
 239 option :: a -> Parser a -> Parser a
 240 option def p = p `seq`
 241                p <|> return def
 242
 243
 244 sepBy :: Parser a -> Parser sep -> Parser [a]
 245 sepBy p sep = p `seq` sep `seq`
 246               sepBy1 p sep <|> return []
 247
 248
 249 sepBy1 :: Parser a -> Parser sep -> Parser [a]
 250 sepBy1 p sep = p `seq` sep `seq`
 251                do x  <- p
 252                   xs <- many $! sep >> p
 253                   return (x:xs)
 254
 255
 256 sp :: Parser Char
 257 sp = char ' '
 258
 259
 260 ht :: Parser Char
 261 ht = char '\t'
 262
 263
 264 crlf :: Parser String
 265 crlf = string "\x0d\x0a"