0

    {-# LANGUAGE LambdaCase #-}
    module Parser
      ( Parser()
      , module X
      , Parser.any
      , satisfy
      , string
      , digit
      , number
      , spaces
      , reserved
      , lexeme
      , (<?>)
      , runParser
      , between ) where

    import Control.Applicative as X
    import Control.Monad as X

    import Data.Char

    newtype Parser a
      = Parser { parse :: String -> Either String (a, String) }

    runParser :: Parser a -> String -> Either String a
    runParser (Parser p) s = fst <$> p s

    (<?>) :: Parser a -> String -> Parser a
    p <?> err = p <|> fail err
    infixl 2 <?>

    instance Functor Parser where
      fn `fmap` (Parser p) = Parser go where
        go st = case p st of
          Left e            -> Left e
          Right (res, str') -> Right (fn res, str')

    instance Applicative Parser where
      pure x = Parser $ \str -> Right (x, str)
      (Parser p) <*> (Parser p') = Parser go where
        go st = case p st of
          Left e -> Left e
          Right (fn, st') -> case p' st' of
            Left e' -> Left e'
            Right (v, st'') -> Right (fn v, st'')

    instance Alternative Parser where
      empty = fail "nothing"
      (Parser p) <|> (Parser p') = Parser go where
        go st = case p st of
          Left _  -> p' st
          Right x -> Right x

    instance Monad Parser where
      return = pure
      (Parser p) >>= f = Parser go where
        go s = case p s of
          Left e -> Left e
          Right (x, s') -> parse (f x) s'
      fail m = Parser go where
        go = Left . go'
        go' []     = "expected " ++ m ++ ", got to the end of stream"
        go' (x:xs) = "expected " ++ m ++ ", got '" ++ x:"'"

    any :: Parser Char
    any = Parser go where
      go []     = Left "any: end of file"
      go (x:xs) = Right (x,xs)

    satisfy :: (Char -> Bool) -> Parser Char
    satisfy f = do x <- Parser.any
                   if f x
                     then return x
                     else fail "a solution to the function"

    char :: Char -> Parser Char
    char c = satisfy (c ==) <?> "literal " ++ [c]

    oneOf :: String -> Parser Char
    oneOf s = satisfy (`elem` s) <?> "one of '" ++ s ++ "'"

    string :: String -> Parser String
    string [] = return []
    string (x:xs) = do char   x
                       string xs
                       return $ x:xs

    natural :: Parser Integer
    natural = read <$> some (satisfy isDigit)

    lexeme :: Parser a -> Parser a
    lexeme = (<* spaces)

    reserved :: String -> Parser String
    reserved = lexeme . string

    spaces :: Parser String
    spaces = many $ oneOf " \n\r"

    digit :: Parser Char
    digit = satisfy isDigit

    number :: Parser Int
    number = do
      s <- string "-" <|> empty
      cs <- some digit
      return $ read (s ++ cs)

    between :: Parser b -> Parser c -> Parser a -> Parser a
    between o c x = o *> x <* c

    contents :: Parser a -> Parser a
    contents x = spaces *> x <* spaces

    sep :: Parser b -> Parser a -> Parser [a]
    sep s c = sep1 s c <|> return []

    sep1 :: Parser b -> Parser a -> Parser [a]
    sep1 s c = do x <- c
                  xs <- many $ s >> c
                  return $ x:xs

    option :: a -> Parser a -> Parser a
    option x p = p <|> return x

    optionMaybe :: Parser a -> Parser (Maybe a)
    optionMaybe p = option Nothing $ Just <$> p

    optional :: Parser a -> Parser ()
    optional p = void p <|> return ()

    eof :: Parser ()
    eof = Parser go where
      go (x:_) = Left $ "expected eof, got '" ++ x:"'"
      go []    = Right ((), [])