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