Network/HTTP/Lucu/Parser.hs

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