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