Network/HTTP/Lucu/Parser.hs

   1 module Network.HTTP.Lucu.Parser
   2     ( Parser(..)
   3     , ParserResult(..)
   4
   5     , parse     -- Parser a -> ByteString -> (ParserResult a, ByteString)
   6     , parseStr  -- Parser a -> String -> (ParserResult a, ByteString)
   7
   8     , anyChar   -- Parser Char
   9     , eof       -- Parser ()
  10     , allowEOF  -- Parser a -> Parser a
  11     , satisfy   -- (Char -> Bool) -> Parser Char
  12     , char      -- Char -> Parser Char
  13     , string    -- String -> Parser String
  14     , (<|>)     -- Parser a -> Parser a -> Parser a
  15     , oneOf     -- [Char] -> Parser Char
  16     , digit     -- Parser Char
  17     , hexDigit  -- Parser Char
  18     , notFollowedBy -- Parser a -> Parser ()
  19     , many      -- Parser a -> Parser [a]
  20     , many1     -- Parser a -> Parser [a]
  21     , manyTill  -- Parser a -> Parser end -> Parser [a]
  22     , many1Till -- Parser a -> Parser end -> Parser [a]
  23     , option    -- a -> Parser a -> Parser a
  24     , sepBy     -- Parser a -> Parser sep -> Parser [a]
  25     , sepBy1    -- Parser a -> Parser sep -> Parser [a]
  26
  27     , sp        -- Parser Char
  28     , ht        -- Parser Char
  29     , crlf      -- Parser String
  30     )
  31     where
  32
  33 import           Control.Monad
  34 import           Control.Monad.State
  35 import qualified Data.ByteString.Lazy.Char8 as B
  36 import           Data.ByteString.Lazy.Char8 (ByteString)
  37
  38 data Parser a = Parser {
  39       runParser :: State ParserState (ParserResult a)
  40     }
  41
  42 type ParserState = (ByteString, IsEOFFatal)
  43
  44 type IsEOFFatal = Bool
  45
  46 data ParserResult a = Success a
  47                     | IllegalInput -- 受理出來ない入力があった
  48                     | ReachedEOF   -- 限界を越えて讀まうとした
  49                       deriving (Eq, Show)
  50
  51
  52 --  (>>=) :: Parser a -> (a -> Parser b) -> Parser b
  53 instance Monad Parser where
  54     p >>= f = Parser $ do saved@(_, isEOFFatal) <- get -- 失敗した時の爲に状態を保存
  55                           result <- runParser p
  56                           case result of
  57                             Success a    -> runParser (f a)
  58                             IllegalInput -> do put saved -- 状態を復歸
  59                                                return IllegalInput
  60                             ReachedEOF   -> if isEOFFatal then
  61                                                 return ReachedEOF
  62                                             else
  63                                                 do put saved
  64                                                    return IllegalInput
  65     return = Parser . return . Success
  66     fail _ = Parser $ return IllegalInput
  67
  68
  69 parse :: Parser a -> ByteString -> (ParserResult a, ByteString)
  70 parse p input = let (result, (input', _)) = runState (runParser p) (input, True)
  71                 in
  72                   (result, input')
  73
  74
  75 parseStr :: Parser a -> String -> (ParserResult a, ByteString)
  76 parseStr p input = parse p $ B.pack input
  77
  78
  79 anyChar :: Parser Char
  80 anyChar = Parser $ do (input, isEOFFatal) <- get
  81                       if B.null input then
  82                           return ReachedEOF
  83                         else
  84                           do let c = B.head input
  85                              put (B.tail input, isEOFFatal)
  86                              return (Success c)
  87
  88
  89 eof :: Parser ()
  90 eof = Parser $ do (input, _) <- get
  91                   if B.null input then
  92                       return $ Success ()
  93                     else
  94                       return IllegalInput
  95
  96
  97 allowEOF :: Parser a -> Parser a
  98 allowEOF f = Parser $ do (input, isEOFFatal) <- get
  99                          put (input, False)
 100
 101                          result <- runParser f
 102
 103                          (input', _) <- get
 104                          put (input', isEOFFatal)
 105
 106                          return result
 107
 108
 109 satisfy :: (Char -> Bool) -> Parser Char
 110 satisfy f = do c <- anyChar
 111                unless (f c) (fail "")
 112                return c
 113
 114
 115 char :: Char -> Parser Char
 116 char c = satisfy (== c)
 117
 118
 119 string :: String -> Parser String
 120 string str = do mapM_ char str
 121                 return str
 122
 123
 124 infixr 0 <|>
 125
 126 (<|>) :: Parser a -> Parser a -> Parser a
 127 f <|> g = Parser $ do saved@(_, isEOFFatal) <- get -- 状態を保存
 128                       result <- runParser f
 129                       case result of
 130                         Success a    -> return $ Success a
 131                         IllegalInput -> do put saved -- 状態を復歸
 132                                            runParser g
 133                         ReachedEOF   -> if isEOFFatal then
 134                                             return ReachedEOF
 135                                         else
 136                                             do put saved
 137                                                runParser g
 138
 139
 140 oneOf :: [Char] -> Parser Char
 141 oneOf = foldl (<|>) (fail "") . map char
 142
 143
 144 notFollowedBy :: Parser a -> Parser ()
 145 notFollowedBy p = p >>= fail "" <|> return ()
 146
 147
 148 digit :: Parser Char
 149 digit = do c <- anyChar
 150            if c >= '0' && c <= '9' then
 151                return c
 152              else
 153                fail ""
 154
 155
 156 hexDigit :: Parser Char
 157 hexDigit = do c <- anyChar
 158               if (c >= '0' && c <= '9') ||
 159                  (c >= 'a' && c <= 'f') ||
 160                  (c >= 'A' && c <= 'F') then
 161                   return c
 162                 else
 163                   fail ""
 164
 165
 166 many :: Parser a -> Parser [a]
 167 many p = do x  <- p
 168             xs <- many p
 169             return (x:xs)
 170          <|>
 171          return []
 172
 173
 174 many1 :: Parser a -> Parser [a]
 175 many1 p = do ret <- many p
 176              case ret of
 177                [] -> fail ""
 178                xs -> return xs
 179
 180
 181 manyTill :: Parser a -> Parser end -> Parser [a]
 182 manyTill p end = many $ do x <- p
 183                            end
 184                            return x
 185
 186
 187 many1Till :: Parser a -> Parser end -> Parser [a]
 188 many1Till p end = many1 $ do x <- p
 189                              end
 190                              return x
 191
 192
 193 option :: a -> Parser a -> Parser a
 194 option def p = p <|> return def
 195
 196
 197 sepBy :: Parser a -> Parser sep -> Parser [a]
 198 sepBy p sep = sepBy1 p sep <|> return []
 199
 200
 201 sepBy1 :: Parser a -> Parser sep -> Parser [a]
 202 sepBy1 p sep = do x  <- p
 203                   xs <- many $ sep >> p
 204                   return (x:xs)
 205
 206
 207 sp :: Parser Char
 208 sp = char ' '
 209
 210
 211 ht :: Parser Char
 212 ht = char '\t'
 213
 214
 215 crlf :: Parser String
 216 crlf = string "\x0d\x0a"