Network/HTTP/Lucu/Parser.hs

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