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