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
  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 newtype 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    -> a `seq` runParser (f a)
  78                              IllegalInput -> do put saved -- 状態を復歸
  79                                                 return IllegalInput
  80                              ReachedEOF   -> do unless isEOFFatal
  81                                                            $ put saved -- 状態を復歸
  82                                                 return ReachedEOF
  83     return x = x `seq` Parser $! return $! Success x
  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 -- input は lazy である必要有り。
  90     = p `seq`
  91       let (result, (input', _)) = runState (runParser p) (input, True)
  92       in
  93         result `seq` (result, input') -- input' も lazy である必要有り。
  94
  95 -- |@'parseStr' p str@ packs @str@ and parses it.
  96 parseStr :: Parser a -> String -> (ParserResult a, ByteString)
  97 parseStr p input
  98     = p `seq` -- input は lazy である必要有り。
  99       parse p $! B.pack input
 100
 101
 102 anyChar :: Parser Char
 103 anyChar = Parser $!
 104           do (input, isEOFFatal) <- get
 105              if B.null input then
 106                  return ReachedEOF
 107                else
 108                  do let c = B.head input
 109                     put (B.tail input, isEOFFatal)
 110                     return (Success c)
 111
 112
 113 eof :: Parser ()
 114 eof = Parser $!
 115       do (input, _) <- get
 116          if B.null input then
 117              return $ Success ()
 118            else
 119              return IllegalInput
 120
 121 -- |@'allowEOF' p@ makes @p@ treat reaching EOF a normal failure.
 122 allowEOF :: Parser a -> Parser a
 123 allowEOF f = f `seq`
 124              Parser $! do (input, isEOFFatal) <- get
 125                           put (input, False)
 126
 127                           result <- runParser f
 128
 129                           (input', _) <- get
 130                           put (input', isEOFFatal)
 131
 132                           return result
 133
 134
 135 satisfy :: (Char -> Bool) -> Parser Char
 136 satisfy f = f `seq`
 137             do c <- anyChar
 138                unless (f c) (fail "")
 139                return c
 140
 141
 142 char :: Char -> Parser Char
 143 char c = c `seq` satisfy (== c)
 144
 145
 146 string :: String -> Parser String
 147 string str = str `seq`
 148              do mapM_ char str
 149                 return str
 150
 151
 152 infixr 0 <|>
 153
 154 -- |This is the backtracking alternation. There is no non-backtracking
 155 -- equivalent.
 156 (<|>) :: Parser a -> Parser a -> Parser a
 157 f <|> g
 158     = f `seq` g `seq`
 159       Parser $! do saved@(_, isEOFFatal) <- get -- 状態を保存
 160                    result <- runParser f
 161                    case result of
 162                      Success a    -> return $ Success a
 163                      IllegalInput -> do put saved -- 状態を復歸
 164                                         runParser g
 165                      ReachedEOF   -> if isEOFFatal then
 166                                          return ReachedEOF
 167                                      else
 168                                          do put saved
 169                                             runParser g
 170
 171
 172 oneOf :: [Char] -> Parser Char
 173 oneOf = foldl (<|>) (fail "") . map char
 174
 175
 176 notFollowedBy :: Parser a -> Parser ()
 177 notFollowedBy p = p `seq`
 178                   p >>= fail "" <|> return ()
 179
 180
 181 digit :: Parser Char
 182 digit = do c <- anyChar
 183            if c >= '0' && c <= '9' then
 184                return c
 185              else
 186                fail ""
 187
 188
 189 hexDigit :: Parser Char
 190 hexDigit = do c <- anyChar
 191               if (c >= '0' && c <= '9') ||
 192                  (c >= 'a' && c <= 'f') ||
 193                  (c >= 'A' && c <= 'F') then
 194                   return c
 195                 else
 196                   fail ""
 197
 198
 199 many :: Parser a -> Parser [a]
 200 many p = p `seq`
 201          do x  <- p
 202             xs <- many p
 203             return (x:xs)
 204          <|>
 205          return []
 206
 207
 208 many1 :: Parser a -> Parser [a]
 209 many1 p = p `seq`
 210           do ret <- many p
 211              case ret of
 212                [] -> fail ""
 213                xs -> return xs
 214
 215
 216 manyTill :: Parser a -> Parser end -> Parser [a]
 217 manyTill p end
 218     = p `seq` end `seq`
 219       many $! do x <- p
 220                  end
 221                  return x
 222
 223
 224 many1Till :: Parser a -> Parser end -> Parser [a]
 225 many1Till p end
 226     = p `seq` end `seq`
 227       many1 $! do x <- p
 228                   end
 229                   return x
 230
 231
 232 count :: Int -> Parser a -> Parser [a]
 233 count 0 _ = return []
 234 count n p = n `seq` p `seq`
 235             do x  <- p
 236                xs <- count (n-1) p
 237                return (x:xs)
 238
 239 -- def may be a _|_
 240 option :: a -> Parser a -> Parser a
 241 option def p = p `seq`
 242                p <|> return def
 243
 244
 245 sepBy :: Parser a -> Parser sep -> Parser [a]
 246 sepBy p sep = p `seq` sep `seq`
 247               sepBy1 p sep <|> return []
 248
 249
 250 sepBy1 :: Parser a -> Parser sep -> Parser [a]
 251 sepBy1 p sep = p `seq` sep `seq`
 252                do x  <- p
 253                   xs <- many $! sep >> p
 254                   return (x:xs)
 255
 256
 257 sp :: Parser Char
 258 sp = char ' '
 259
 260
 261 ht :: Parser Char
 262 ht = char '\t'
 263
 264
 265 crlf :: Parser String
 266 crlf = string "\x0d\x0a"