Network/HTTP/Lucu/Parser.hs

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