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