parser.hs

import Control.Monad (liftM, ap)

newtype Parser a = P (String -> [(a, String)])

doParse :: Parser a -> String -> [(a, String)]
doParse (P p) input = p input

instance Functor Parser where
  fmap = liftM

instance Applicative Parser where
  pure v = P (\inp -> [(v, inp)])
  (<*>) = ap

instance Monad Parser where
  return = pure
  p >>= f = P $ \inp -> concat [doParse (f v) inp' | (v, inp') <- doParse p inp]

class Monad m => MonadOPlus m where
  zero :: m a
  (<+>) :: m a -> m a -> m a

instance MonadOPlus Parser where
  zero = P $ const []
  p1 <+> p2 = P $ \inp -> concat [doParse p1 inp, doParse p2 inp]

(<++>) :: Parser a -> Parser a -> Parser a
p1 <++> p2 = P $ \inp -> case (doParse (p1 <+> p2) inp) of
  (r:_) -> [r]
  _ -> []

item :: Parser Char
item = P $ \inp -> case inp of
    (x:xs) -> [(x, xs)]
    _ -> []

satisfy :: (Char -> Bool) -> Parser Char 
satisfy predict = do
  x <- item
  if predict x then return x else zero


char :: Char -> Parser Char
char x = satisfy (== x)

alphaChar :: Parser Char
alphaChar = satisfy $ \x -> 
      (('a' <= x) && (x <= 'z')) 
  ||  (('A' <= x) && (x <= 'Z'))

digitChar :: Parser Char
digitChar = satisfy $ \x -> ('0' <= x) && (x <= '9')

string :: String -> Parser String
string = mapM char

many :: Parser a -> Parser [a]
many p = many1 <+> many2
  where many1 = return []
        many2 = do  x <- p
                    xs <- many p
                    return (x:xs)

mmany :: Parser a -> Parser [a]
mmany p = many2 <++> many1  
  where many1 = return []
        many2 = do  x <- p
                    xs <- mmany p
                    return (x:xs)

digitInt :: Parser Integer
digitInt = do
  num <- digitChar
  return (read [num] :: Integer)

integer :: Parser Integer 
integer = do
  nums <- mmany digitChar
  return $ ((read nums) :: Integer)