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