Network/HTTP/Lucu/Parser.hs

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