bookhound-0.1.4.0: src/Parser.hs

module Parser (Parser, ParseResult(..), ParseError(..), runParser, errorParser,
               andThen, exactly, isMatch, check, except, anyOf, allOf, char,
               withTransform)  where

import Data.Either (fromRight)

type Input = String

data Parser a = P { parse :: Input -> ParseResult a
                  , transform :: forall b. Parser b -> Parser b
                  }

data ParseResult a = Result Input a | Error ParseError
  deriving Eq

data ParseError = UnexpectedEof       | ExpectedEof Input       |
                  UnexpectedChar Char | UnexpectedString String |
                  NoMatch String
  deriving (Eq, Show)


instance Show a => Show (ParseResult a) where
  show (Result i a)                 = "Pending: " ++ " >" ++ i ++ "< " ++
                                      "\n\nResult: \n" ++ show a
  show (Error UnexpectedEof)        = "Unexpected end of stream"
  show (Error (ExpectedEof i))      = "Expected end of stream, but got >" ++ show i ++ "<"
  show (Error (UnexpectedChar c))   = "Unexpected character: " ++ show c
  show (Error (UnexpectedString s)) = "Unexpected string: " ++ show s
  show (Error (NoMatch s))          = "Did not match condition: " ++ s


instance Functor ParseResult where
  fmap f (Result i a) = Result i (f a)
  fmap _ (Error pe) = Error pe


instance Functor Parser where
  fmap f (P p t) = P (fmap f . p) t

instance Applicative Parser where
  pure a = P (`Result` a) id
  (<*>) mf ma = mf >>= (<$> ma)

instance Monad Parser where
  (>>=) (P p t) f = t $ P (
    \x -> case p x of
      Result i a -> (parse) (f a) i
      Error pe -> Error pe)
    t

withTransform :: (forall b. Parser b -> Parser b) -> Parser a -> Parser a
withTransform f p = p{transform = f}


runParser :: Parser a -> Input -> Either ParseError a
runParser p i = toEither $ (parse) (exactly p) i where

  toEither = \case
    Error pe -> Left pe
    Result _ a -> Right a

errorParser :: ParseError -> Parser a
errorParser = mkParser . const . Error


char :: Parser Char
char = mkParser parseIt  where
  parseIt [] = Error UnexpectedEof
  parseIt (ch : rest) = Result rest ch



andThen :: Parser Input -> Parser a -> Parser a
andThen p1 p2@(P _ t) = t $ P (\i -> (parse) p2 $ fromRight i $ runParser p1 i) t


exactly :: Parser a -> Parser a
exactly (P p t) = t $ P (
  \x -> case p x of
    result@(Result "" _) -> result
    Result i _           -> Error $ ExpectedEof i
    err@(Error _)        -> err) t


anyOf :: [Parser a] -> Parser a
anyOf [] = errorParser UnexpectedEof
anyOf [x] = x
anyOf ((P p t) : rest) = t $ P (
  \x -> case p x of
    result@(Result _ _) -> result
    Error _             -> (parse) (anyOf rest) x) t


allOf :: [Parser a] -> Parser a
allOf [] = errorParser UnexpectedEof
allOf [x] = x
allOf ((P p t) : rest) = t $ P (
  \x -> case p x of
    Result i _    -> (parse) (allOf rest) i
    err@(Error _) -> err) t


isMatch :: (Char -> Char -> Bool) -> Parser Char -> Char -> Parser Char
isMatch cond parser c1 = do
  c2 <- parser
  let next = if cond c1 c2
             then pure
             else const . errorParser $ UnexpectedChar c2
  next c2


check :: String -> (a -> Bool) -> Parser a -> Parser a
check condName cond parser = do
  c2 <- parser
  let next = if cond c2
             then pure
             else const . errorParser $ NoMatch condName
  next c2


except :: Show a => Parser a -> Parser a -> Parser a
except alt (P p t) = t $ P (
  \x -> case p x of
    Result _ a -> Error $ UnexpectedString (show a)
    Error _     -> (parse) alt x) t


mkParser :: (Input -> ParseResult a) -> Parser a
mkParser p = P {parse = p, transform = id}