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

import Data.Either (fromRight)
import Data.Functor((<&>))

type Input = String

newtype Parser a = P { Parser a -> Input -> ParseResult a
parse :: Input -> ParseResult a}

data ParseResult a = Result Input a | Error ParseError
  deriving ParseResult a -> ParseResult a -> Bool
(ParseResult a -> ParseResult a -> Bool)
-> (ParseResult a -> ParseResult a -> Bool) -> Eq (ParseResult a)
forall a. Eq a => ParseResult a -> ParseResult a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ParseResult a -> ParseResult a -> Bool
$c/= :: forall a. Eq a => ParseResult a -> ParseResult a -> Bool
== :: ParseResult a -> ParseResult a -> Bool
$c== :: forall a. Eq a => ParseResult a -> ParseResult a -> Bool
Eq

data ParseError = UnexpectedEof       | ExpectedEof Input       |
                  UnexpectedChar Char | UnexpectedString String |
                  NoMatch String
  deriving (ParseError -> ParseError -> Bool
(ParseError -> ParseError -> Bool)
-> (ParseError -> ParseError -> Bool) -> Eq ParseError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ParseError -> ParseError -> Bool
$c/= :: ParseError -> ParseError -> Bool
== :: ParseError -> ParseError -> Bool
$c== :: ParseError -> ParseError -> Bool
Eq, Int -> ParseError -> ShowS
[ParseError] -> ShowS
ParseError -> Input
(Int -> ParseError -> ShowS)
-> (ParseError -> Input)
-> ([ParseError] -> ShowS)
-> Show ParseError
forall a.
(Int -> a -> ShowS) -> (a -> Input) -> ([a] -> ShowS) -> Show a
showList :: [ParseError] -> ShowS
$cshowList :: [ParseError] -> ShowS
show :: ParseError -> Input
$cshow :: ParseError -> Input
showsPrec :: Int -> ParseError -> ShowS
$cshowsPrec :: Int -> ParseError -> ShowS
Show)


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


instance Functor ParseResult where
  fmap :: (a -> b) -> ParseResult a -> ParseResult b
fmap a -> b
f (Result Input
i a
a) = Input -> b -> ParseResult b
forall a. Input -> a -> ParseResult a
Result Input
i (a -> b
f a
a)
  fmap a -> b
_ (Error ParseError
pe) = ParseError -> ParseResult b
forall a. ParseError -> ParseResult a
Error ParseError
pe


instance Functor Parser where
  fmap :: (a -> b) -> Parser a -> Parser b
fmap a -> b
f (P Input -> ParseResult a
p) = (Input -> ParseResult b) -> Parser b
forall a. (Input -> ParseResult a) -> Parser a
P ((a -> b) -> ParseResult a -> ParseResult b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (ParseResult a -> ParseResult b)
-> (Input -> ParseResult a) -> Input -> ParseResult b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Input -> ParseResult a
p)

instance Applicative Parser where
  pure :: a -> Parser a
pure a
a = (Input -> ParseResult a) -> Parser a
forall a. (Input -> ParseResult a) -> Parser a
P (Input -> a -> ParseResult a
forall a. Input -> a -> ParseResult a
`Result` a
a)
  <*> :: Parser (a -> b) -> Parser a -> Parser b
(<*>) Parser (a -> b)
mf Parser a
ma = Parser (a -> b)
mf Parser (a -> b) -> ((a -> b) -> Parser b) -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Parser a
ma Parser a -> (a -> b) -> Parser b
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&>)

instance Monad Parser where
  >>= :: Parser a -> (a -> Parser b) -> Parser b
(>>=) (P Input -> ParseResult a
p) a -> Parser b
f = (Input -> ParseResult b) -> Parser b
forall a. (Input -> ParseResult a) -> Parser a
P (
    \Input
x -> case Input -> ParseResult a
p Input
x of
      Result Input
i a
a -> Parser b -> Input -> ParseResult b
forall a. Parser a -> Input -> ParseResult a
parse (a -> Parser b
f a
a) Input
i
      Error ParseError
pe -> ParseError -> ParseResult b
forall a. ParseError -> ParseResult a
Error ParseError
pe)


runParser :: Parser a -> Input -> Either ParseError a
runParser :: Parser a -> Input -> Either ParseError a
runParser Parser a
p Input
i = ParseResult a -> Either ParseError a
forall b. ParseResult b -> Either ParseError b
toEither (ParseResult a -> Either ParseError a)
-> ParseResult a -> Either ParseError a
forall a b. (a -> b) -> a -> b
$ Parser a -> Input -> ParseResult a
forall a. Parser a -> Input -> ParseResult a
parse Parser a
p Input
i  where

  toEither :: ParseResult b -> Either ParseError b
toEither = \case
    Error ParseError
pe -> ParseError -> Either ParseError b
forall a b. a -> Either a b
Left ParseError
pe
    Result Input
input b
a -> if Input -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Input
input then b -> Either ParseError b
forall a b. b -> Either a b
Right b
a
                      else               ParseError -> Either ParseError b
forall a b. a -> Either a b
Left (ParseError -> Either ParseError b)
-> ParseError -> Either ParseError b
forall a b. (a -> b) -> a -> b
$ Input -> ParseError
ExpectedEof Input
input

errorParser :: ParseError -> Parser a
errorParser :: ParseError -> Parser a
errorParser = (Input -> ParseResult a) -> Parser a
forall a. (Input -> ParseResult a) -> Parser a
P ((Input -> ParseResult a) -> Parser a)
-> (ParseError -> Input -> ParseResult a) -> ParseError -> Parser a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseResult a -> Input -> ParseResult a
forall a b. a -> b -> a
const (ParseResult a -> Input -> ParseResult a)
-> (ParseError -> ParseResult a)
-> ParseError
-> Input
-> ParseResult a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseError -> ParseResult a
forall a. ParseError -> ParseResult a
Error


char :: Parser Char
char :: Parser Char
char = (Input -> ParseResult Char) -> Parser Char
forall a. (Input -> ParseResult a) -> Parser a
P Input -> ParseResult Char
parseIt where
  parseIt :: Input -> ParseResult Char
parseIt [] = ParseError -> ParseResult Char
forall a. ParseError -> ParseResult a
Error ParseError
UnexpectedEof
  parseIt (Char
ch : Input
rest) = Input -> Char -> ParseResult Char
forall a. Input -> a -> ParseResult a
Result Input
rest Char
ch



andThen :: Parser Input -> Parser a -> Parser a
andThen :: Parser Input -> Parser a -> Parser a
andThen Parser Input
p1 Parser a
p2 = (Input -> ParseResult a) -> Parser a
forall a. (Input -> ParseResult a) -> Parser a
P (\Input
i -> Parser a -> Input -> ParseResult a
forall a. Parser a -> Input -> ParseResult a
parse Parser a
p2 (Input -> ParseResult a) -> Input -> ParseResult a
forall a b. (a -> b) -> a -> b
$ Input -> Either ParseError Input -> Input
forall b a. b -> Either a b -> b
fromRight Input
i (Either ParseError Input -> Input)
-> Either ParseError Input -> Input
forall a b. (a -> b) -> a -> b
$ Parser Input -> Input -> Either ParseError Input
forall a. Parser a -> Input -> Either ParseError a
runParser Parser Input
p1 Input
i)


exactly :: Parser a -> Parser a
exactly :: Parser a -> Parser a
exactly (P Input -> ParseResult a
p) = (Input -> ParseResult a) -> Parser a
forall a. (Input -> ParseResult a) -> Parser a
P (
  \Input
x -> case Input -> ParseResult a
p Input
x of
    result :: ParseResult a
result@(Result Input
"" a
_) -> ParseResult a
result
    Result Input
i a
_           -> ParseError -> ParseResult a
forall a. ParseError -> ParseResult a
Error (ParseError -> ParseResult a) -> ParseError -> ParseResult a
forall a b. (a -> b) -> a -> b
$ Input -> ParseError
ExpectedEof Input
i
    err :: ParseResult a
err@(Error ParseError
_)        -> ParseResult a
err)


anyOf :: [Parser a] -> Parser a
anyOf :: [Parser a] -> Parser a
anyOf [] = ParseError -> Parser a
forall a. ParseError -> Parser a
errorParser ParseError
UnexpectedEof
anyOf [Parser a
x] = Parser a
x
anyOf ((P Input -> ParseResult a
p) : [Parser a]
rest) = (Input -> ParseResult a) -> Parser a
forall a. (Input -> ParseResult a) -> Parser a
P (
  \Input
x -> case Input -> ParseResult a
p Input
x of
    result :: ParseResult a
result@(Result Input
_ a
_) -> ParseResult a
result
    Error ParseError
_             -> Parser a -> Input -> ParseResult a
forall a. Parser a -> Input -> ParseResult a
parse ([Parser a] -> Parser a
forall a. [Parser a] -> Parser a
anyOf [Parser a]
rest) Input
x)


allOf :: [Parser a] -> Parser a
allOf :: [Parser a] -> Parser a
allOf [] = ParseError -> Parser a
forall a. ParseError -> Parser a
errorParser ParseError
UnexpectedEof
allOf [Parser a
x] = Parser a
x
allOf ((P Input -> ParseResult a
p) : [Parser a]
rest) = (Input -> ParseResult a) -> Parser a
forall a. (Input -> ParseResult a) -> Parser a
P (
  \Input
x -> case Input -> ParseResult a
p Input
x of
    Result Input
i a
_    -> Parser a -> Input -> ParseResult a
forall a. Parser a -> Input -> ParseResult a
parse ([Parser a] -> Parser a
forall a. [Parser a] -> Parser a
allOf [Parser a]
rest) Input
i
    err :: ParseResult a
err@(Error ParseError
_) -> ParseResult a
err)


isMatch :: (Char -> Char -> Bool) -> Parser Char -> Char -> Parser Char
isMatch :: (Char -> Char -> Bool) -> Parser Char -> Char -> Parser Char
isMatch Char -> Char -> Bool
cond Parser Char
parser Char
c1 = do
  Char
c2 <- Parser Char
parser
  let next :: Char -> Parser Char
next = if Char -> Char -> Bool
cond Char
c1 Char
c2
             then Char -> Parser Char
forall (f :: * -> *) a. Applicative f => a -> f a
pure
             else Parser Char -> Char -> Parser Char
forall a b. a -> b -> a
const (Parser Char -> Char -> Parser Char)
-> (ParseError -> Parser Char) -> ParseError -> Char -> Parser Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseError -> Parser Char
forall a. ParseError -> Parser a
errorParser (ParseError -> Char -> Parser Char)
-> ParseError -> Char -> Parser Char
forall a b. (a -> b) -> a -> b
$ Char -> ParseError
UnexpectedChar Char
c2
  Char -> Parser Char
next Char
c2


check :: String -> (a -> Bool) -> Parser a -> Parser a
check :: Input -> (a -> Bool) -> Parser a -> Parser a
check Input
condName a -> Bool
cond Parser a
parser = do
  a
c2 <- Parser a
parser
  let next :: a -> Parser a
next = if a -> Bool
cond a
c2
             then a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
             else Parser a -> a -> Parser a
forall a b. a -> b -> a
const (Parser a -> a -> Parser a)
-> (ParseError -> Parser a) -> ParseError -> a -> Parser a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseError -> Parser a
forall a. ParseError -> Parser a
errorParser (ParseError -> a -> Parser a) -> ParseError -> a -> Parser a
forall a b. (a -> b) -> a -> b
$ Input -> ParseError
NoMatch Input
condName
  a -> Parser a
next a
c2


except :: Show a => Parser a -> Parser a -> Parser a
except :: Parser a -> Parser a -> Parser a
except Parser a
alt (P Input -> ParseResult a
p) = (Input -> ParseResult a) -> Parser a
forall a. (Input -> ParseResult a) -> Parser a
P (
  \Input
x -> case Input -> ParseResult a
p Input
x of
    Result Input
_ a
a -> ParseError -> ParseResult a
forall a. ParseError -> ParseResult a
Error (ParseError -> ParseResult a) -> ParseError -> ParseResult a
forall a b. (a -> b) -> a -> b
$ Input -> ParseError
UnexpectedString (a -> Input
forall a. Show a => a -> Input
show a
a)
    Error ParseError
_     -> Parser a -> Input -> ParseResult a
forall a. Parser a -> Input -> ParseResult a
parse Parser a
alt Input
x)