Network/HTTP/Lucu/Parser.hs

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