Network/HTTP/Lucu/Parser.hs

   1 -- |Yet another parser combinator. This is mostly a subset of Parsec
   2 -- but there are some differences:
   3 --
   4 -- * This parser works on ByteString instead of String.
   5 --
   6 -- * Backtracking is the only possible behavior so there is no \"try\"
   7 --   action.
   8 --
   9 -- * On success, the remaining string is returned as well as the
  10 --   parser result.
  11 --
  12 -- * You can choose whether to treat reaching EOF (trying to eat one
  13 --   more letter at the end of string) a fatal error or to treat it a
  14 --   normal failure. If a fatal error occurs, the entire parsing
  15 --   process immediately fails without trying any backtracks. The
  16 --   default behavior is to treat EOF fatal.
  17 --
  18 -- In general, you don't have to use this module directly.
  19 module Network.HTTP.Lucu.Parser
  20     ( Parser
  21     , ParserResult(..)
  22
  23     , failP
  24
  25     , parse
  26     , parseStr
  27
  28     , anyChar
  29     , eof
  30     , allowEOF
  31     , satisfy
  32     , char
  33     , string
  34     , (<|>)
  35     , oneOf
  36     , digit
  37     , hexDigit
  38     , notFollowedBy
  39     , many
  40     , many1
  41     , count
  42     , option
  43     , sepBy
  44     , sepBy1
  45
  46     , sp
  47     , ht
  48     , crlf
  49     )
  50     where
  51
  52 import           Control.Monad.State.Strict
  53 import qualified Data.ByteString.Lazy.Char8 as B
  54 import           Data.ByteString.Lazy.Char8 (ByteString)
  55
  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      :: 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 Prelude.undefined'@.
  91 failP :: Parser a
  92 failP = fail undefined
  93
  94 -- |@'parse' p bstr@ parses @bstr@ with @p@ and returns @(result,
  95 -- remaining)@.
  96 parse :: Parser a -> ByteString -> (ParserResult a, ByteString)
  97 parse p input -- input は lazy である必要有り。
  98     = p `seq`
  99       let (result, state') = runState (runParser p) (PST input True)
 100       in
 101         result `seq` (result, pstInput state') -- pstInput state' も lazy である必要有り。
 102
 103 -- |@'parseStr' p str@ packs @str@ and parses it.
 104 parseStr :: Parser a -> String -> (ParserResult a, ByteString)
 105 parseStr p input
 106     = p `seq` -- input は lazy である必要有り。
 107       parse p $! B.pack input
 108
 109
 110 anyChar :: Parser Char
 111 anyChar = Parser $!
 112           do state@(PST input _) <- get
 113              if B.null input then
 114                  return ReachedEOF
 115                else
 116                  do put $! state { pstInput = B.tail input }
 117                     return (Success $! B.head input)
 118
 119
 120 eof :: Parser ()
 121 eof = Parser $!
 122       do PST input _ <- get
 123          if B.null input then
 124              return $! Success ()
 125            else
 126              return IllegalInput
 127
 128 -- |@'allowEOF' p@ makes @p@ treat reaching EOF a normal failure.
 129 allowEOF :: Parser a -> Parser a
 130 allowEOF f = f `seq`
 131              Parser $! do saved@(PST _ isEOFFatal) <- get
 132                           put $! saved { pstIsEOFFatal = False }
 133
 134                           result <- runParser f
 135
 136                           state <- get
 137                           put $! state { pstIsEOFFatal = isEOFFatal }
 138
 139                           return result
 140
 141
 142 satisfy :: (Char -> Bool) -> Parser Char
 143 satisfy f = f `seq`
 144             do c <- anyChar
 145                if f c then
 146                    return c
 147                  else
 148                    failP
 149
 150
 151 char :: Char -> Parser Char
 152 char c = c `seq` satisfy (== c)
 153
 154
 155 string :: String -> Parser String
 156 string str = str `seq`
 157              do mapM_ char str
 158                 return str
 159
 160
 161 infixr 0 <|>
 162
 163 -- |This is the backtracking alternation. There is no non-backtracking
 164 -- equivalent.
 165 (<|>) :: Parser a -> Parser a -> Parser a
 166 f <|> g
 167     = f `seq` g `seq`
 168       Parser $! do saved <- get -- 状態を保存
 169                    result <- runParser f
 170                    case result of
 171                      Success a    -> return $! Success a
 172                      IllegalInput -> do put saved -- 状態を復歸
 173                                         runParser g
 174                      ReachedEOF   -> if pstIsEOFFatal saved then
 175                                          return ReachedEOF
 176                                      else
 177                                          do put saved
 178                                             runParser g
 179
 180
 181 oneOf :: [Char] -> Parser Char
 182 oneOf = foldl (<|>) failP . map char
 183
 184
 185 notFollowedBy :: Parser a -> Parser ()
 186 notFollowedBy p = p `seq`
 187                   (p >> failP) <|> return ()
 188
 189
 190 digit :: Parser Char
 191 digit = do c <- anyChar
 192            if c >= '0' && c <= '9' then
 193                return c
 194              else
 195                failP
 196
 197
 198 hexDigit :: Parser Char
 199 hexDigit = do c <- anyChar
 200               if (c >= '0' && c <= '9') ||
 201                  (c >= 'a' && c <= 'f') ||
 202                  (c >= 'A' && c <= 'F') then
 203                   return c
 204                 else
 205                   failP
 206
 207
 208 many :: Parser a -> Parser [a]
 209 many p = p `seq`
 210          do x  <- p
 211             xs <- many p
 212             return (x:xs)
 213          <|>
 214          return []
 215
 216
 217 many1 :: Parser a -> Parser [a]
 218 many1 p = p `seq`
 219           do x  <- p
 220              xs <- many p
 221              return (x:xs)
 222
 223
 224 count :: Int -> Parser a -> Parser [a]
 225 count 0 _ = return []
 226 count n p = n `seq` p `seq`
 227             do x  <- p
 228                xs <- count (n-1) p
 229                return (x:xs)
 230
 231 -- def may be a _|_
 232 option :: a -> Parser a -> Parser a
 233 option def p = p `seq`
 234                p <|> return def
 235
 236
 237 sepBy :: Parser a -> Parser sep -> Parser [a]
 238 sepBy p sep = p `seq` sep `seq`
 239               sepBy1 p sep <|> return []
 240
 241
 242 sepBy1 :: Parser a -> Parser sep -> Parser [a]
 243 sepBy1 p sep = p `seq` sep `seq`
 244                do x  <- p
 245                   xs <- many $! sep >> p
 246                   return (x:xs)
 247
 248
 249 sp :: Parser Char
 250 sp = char ' '
 251
 252
 253 ht :: Parser Char
 254 ht = char '\t'
 255
 256
 257 crlf :: Parser String
 258 crlf = string "\x0d\x0a"