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     , manyChar
  43     , many1
  44     , count
  45     , option
  46     , sepBy
  47     , sepBy1
  48
  49     , sp
  50     , ht
  51     , crlf
  52     )
  53     where
  54
  55 import           Control.Monad.State.Strict hiding (state)
  56 import qualified Data.ByteString.Lazy as Lazy (ByteString)
  57 import qualified Data.ByteString.Lazy.Char8 as B hiding (ByteString)
  58 import qualified Data.Foldable as Fold
  59 import           Data.Int
  60 import qualified Data.Sequence as Seq
  61 import           Data.Sequence (Seq, (|>))
  62
  63 -- |@'Parser' a@ is obviously a parser which parses and returns @a@.
  64 newtype Parser a = Parser {
  65       runParser :: State ParserState (ParserResult a)
  66     }
  67
  68
  69 data ParserState
  70     = PST {
  71         pstInput      :: Lazy.ByteString
  72       , pstIsEOFFatal :: !Bool
  73       }
  74     deriving (Eq, Show)
  75
  76
  77 data ParserResult a = Success !a
  78                     | IllegalInput -- 受理出來ない入力があった
  79                     | ReachedEOF   -- 限界を越えて讀まうとした
  80                       deriving (Eq, Show)
  81
  82
  83 --  (>>=) :: Parser a -> (a -> Parser b) -> Parser b
  84 instance Monad Parser where
  85     p >>= f = Parser $! do saved <- get -- 失敗した時の爲に状態を保存
  86                            result <- runParser p
  87                            case result of
  88                              Success a    -> runParser (f a)
  89                              IllegalInput -> do put saved -- 状態を復歸
  90                                                 return IllegalInput
  91                              ReachedEOF   -> do put saved -- 状態を復歸
  92                                                 return ReachedEOF
  93     return !x = Parser $! return $! Success x
  94     fail _    = Parser $! return $! IllegalInput
  95
  96 instance Functor Parser where
  97     fmap f p = p >>= return . f
  98
  99 -- |@'failP'@ is just a synonym for @'Prelude.fail'
 100 -- 'Prelude.undefined'@.
 101 failP :: Parser a
 102 failP = fail undefined
 103
 104 -- |@'parse' p bstr@ parses @bstr@ with @p@ and returns @(# result,
 105 -- remaining #)@.
 106 parse :: Parser a -> Lazy.ByteString -> (# ParserResult a, Lazy.ByteString #)
 107 parse !p input -- input は lazy である必要有り。
 108     = let (!result, state') = runState (runParser p) (PST input True)
 109       in
 110         (# result, pstInput state' #) -- pstInput state' も lazy である必要有り。
 111
 112 -- |@'parseStr' p str@ packs @str@ and parses it.
 113 parseStr :: Parser a -> String -> (# ParserResult a, Lazy.ByteString #)
 114 parseStr !p input -- input は lazy である必要有り。
 115     = parse p (B.pack input)
 116
 117
 118 anyChar :: Parser Char
 119 anyChar = Parser $!
 120           do state@(PST input _) <- get
 121              if B.null input then
 122                  return ReachedEOF
 123                else
 124                  do put $! state { pstInput = B.tail input }
 125                     return (Success $! B.head input)
 126
 127
 128 eof :: Parser ()
 129 eof = Parser $!
 130       do PST input _ <- get
 131          if B.null input then
 132              return $! Success ()
 133            else
 134              return IllegalInput
 135
 136 -- |@'allowEOF' p@ makes @p@ treat reaching EOF a normal failure.
 137 allowEOF :: Parser a -> Parser a
 138 allowEOF !f
 139     = Parser $! do saved@(PST _ isEOFFatal) <- get
 140                    put $! saved { pstIsEOFFatal = False }
 141
 142                    result <- runParser f
 143
 144                    state <- get
 145                    put $! state { pstIsEOFFatal = isEOFFatal }
 146
 147                    return result
 148
 149
 150 satisfy :: (Char -> Bool) -> Parser Char
 151 satisfy !f
 152     = do c <- anyChar
 153          if f c then
 154              return c
 155            else
 156              failP
 157
 158
 159 char :: Char -> Parser Char
 160 char !c = satisfy (== c)
 161
 162
 163 string :: String -> Parser String
 164 string !str
 165     = let bs  = B.pack str
 166           len = B.length bs
 167       in
 168         Parser $!
 169         do st <- get
 170            let (bs', rest) = B.splitAt len $ pstInput st
 171                st'         = st { pstInput = rest }
 172            if B.length bs' < len then
 173                return ReachedEOF
 174              else
 175                if bs == bs' then
 176                    do put st'
 177                       return $ Success str
 178                else
 179                    return IllegalInput
 180
 181
 182 infixr 0 <|>
 183
 184 -- |This is the backtracking alternation. There is no non-backtracking
 185 -- equivalent.
 186 (<|>) :: Parser a -> Parser a -> Parser a
 187 (!f) <|> (!g)
 188     = Parser $! do saved  <- get -- 状態を保存
 189                    result <- runParser f
 190                    case result of
 191                      Success a    -> return $! Success a
 192                      IllegalInput -> do put saved -- 状態を復歸
 193                                         runParser g
 194                      ReachedEOF   -> if pstIsEOFFatal saved then
 195                                          do put saved
 196                                             return ReachedEOF
 197                                      else
 198                                          do put saved
 199                                             runParser g
 200
 201
 202 choice :: [Parser a] -> Parser a
 203 choice = foldl (<|>) failP
 204
 205
 206 oneOf :: [Char] -> Parser Char
 207 oneOf = foldl (<|>) failP . map char
 208
 209
 210 notFollowedBy :: Parser a -> Parser ()
 211 notFollowedBy !p
 212     = Parser $! do saved  <- get -- 状態を保存
 213                    result <- runParser p
 214                    case result of
 215                      Success _    -> do put saved -- 状態を復歸
 216                                         return IllegalInput
 217                      IllegalInput -> do put saved -- 状態を復歸
 218                                         return $! Success ()
 219                      ReachedEOF   -> do put saved -- 状態を復歸
 220                                         return $! Success ()
 221
 222
 223 digit :: Parser Char
 224 digit = do c <- anyChar
 225            if c >= '0' && c <= '9' then
 226                return c
 227              else
 228                failP
 229
 230
 231 hexDigit :: Parser Char
 232 hexDigit = do c <- anyChar
 233               if (c >= '0' && c <= '9') ||
 234                  (c >= 'a' && c <= 'f') ||
 235                  (c >= 'A' && c <= 'F') then
 236                   return c
 237                 else
 238                   failP
 239
 240
 241 many :: forall a. Parser a -> Parser [a]
 242 many !p = Parser $!
 243           do state <- get
 244              let (# result, state' #) = many' state Seq.empty
 245              put state'
 246              return result
 247     where
 248       many' :: ParserState -> Seq a -> (# ParserResult [a], ParserState #)
 249       many' !st !soFar
 250           = case runState (runParser p) st of
 251               (Success a,  st') -> many' st' (soFar |> a)
 252               (IllegalInput, _) -> (# Success (Fold.toList soFar), st #)
 253               (ReachedEOF  , _) -> if pstIsEOFFatal st then
 254                                        (# ReachedEOF, st #)
 255                                    else
 256                                        (# Success (Fold.toList soFar), st #)
 257
 258 manyChar :: Parser Char -> Parser Lazy.ByteString
 259 manyChar !p = Parser $!
 260               do state <- get
 261                  case scan' state 0 of
 262                    Success len
 263                        -> do let (bs, rest) = B.splitAt len (pstInput state)
 264                                  state'     = state { pstInput = rest }
 265                              put state'
 266                              return $ Success bs
 267                    ReachedEOF
 268                        -> if pstIsEOFFatal state then
 269                               return ReachedEOF
 270                           else
 271                               error "internal error"
 272                    _   -> error "internal error"
 273     where
 274       scan' :: ParserState -> Int64 -> ParserResult Int64
 275       scan' !st !soFar
 276           = case runState (runParser p) st of
 277               (Success _   , st') -> scan' st' (soFar + 1)
 278               (IllegalInput, _  ) -> Success soFar
 279               (ReachedEOF  , _  ) -> if pstIsEOFFatal st then
 280                                          ReachedEOF
 281                                      else
 282                                          Success soFar
 283
 284
 285 many1 :: Parser a -> Parser [a]
 286 many1 !p = do x  <- p
 287               xs <- many p
 288               return (x:xs)
 289
 290
 291 count :: Int -> Parser a -> Parser [a]
 292 count !n !p = Parser $! count' n p Seq.empty
 293
 294 -- This implementation is rather ugly but we need to make it
 295 -- tail-recursive to avoid stack overflow.
 296 count' :: Int -> Parser a -> Seq a -> State ParserState (ParserResult [a])
 297 count' 0  _  !soFar = return $! Success $! Fold.toList soFar
 298 count' !n !p !soFar = do saved  <- get
 299                          result <- runParser p
 300                          case result of
 301                            Success a    -> count' (n-1) p (soFar |> a)
 302                            IllegalInput -> do put saved
 303                                               return IllegalInput
 304                            ReachedEOF   -> do put saved
 305                                               return ReachedEOF
 306
 307
 308 -- def may be a _|_
 309 option :: a -> Parser a -> Parser a
 310 option def !p = p <|> return def
 311
 312
 313 sepBy :: Parser a -> Parser sep -> Parser [a]
 314 sepBy !p !sep = sepBy1 p sep <|> return []
 315
 316
 317 sepBy1 :: Parser a -> Parser sep -> Parser [a]
 318 sepBy1 !p !sep
 319     = do x  <- p
 320          xs <- many $! sep >> p
 321          return (x:xs)
 322
 323
 324 sp :: Parser Char
 325 sp = char ' '
 326
 327
 328 ht :: Parser Char
 329 ht = char '\t'
 330
 331
 332 crlf :: Parser String
 333 crlf = string "\x0d\x0a"