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

import Control.Applicative (liftA2)
import Control.Monad (join)
import Data.Maybe (isJust)
import Data.Either (fromRight)
import Data.List (find)

type Input = String

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

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]
++ Input
i Input -> ShowS
forall a. [a] -> [a] -> [a]
++ Input
"<"
  show (Error (UnexpectedChar Char
c))   = Input
"Unexpected char: "   Input -> ShowS
forall a. [a] -> [a] -> [a]
++ Input
"[" Input -> ShowS
forall a. [a] -> [a] -> [a]
++ Char -> Input
forall a. Show a => a -> Input
show Char
c Input -> ShowS
forall a. [a] -> [a] -> [a]
++ Input
"]"
  show (Error (UnexpectedString Input
s)) = Input
"Unexpected string: " Input -> ShowS
forall a. [a] -> [a] -> [a]
++ Input
"[" Input -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> Input
show Input
s Input -> ShowS
forall a. [a] -> [a] -> [a]
++ Input
"]"
  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 forall b. Maybe (Parser b -> Parser b)
t) = (forall b. Maybe (Parser b -> Parser b)) -> Parser b -> Parser b
forall b.
(forall b. Maybe (Parser b -> Parser b)) -> Parser b -> Parser b
applyTransform forall b. Maybe (Parser b -> Parser b)
t (Parser b -> Parser b) -> Parser b -> Parser b
forall a b. (a -> b) -> a -> b
$ (Input -> ParseResult b) -> Parser b
forall a. (Input -> ParseResult a) -> Parser a
mkParser ((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
mkParser (Input -> a -> ParseResult a
forall a. Input -> a -> ParseResult a
`Result` a
a)
  (liftA2 :: (a -> b -> c) -> Parser a -> Parser b -> Parser c
liftA2) a -> b -> c
f (P Input -> ParseResult a
p forall b. Maybe (Parser b -> Parser b)
t) mb :: Parser b
mb@(P Input -> ParseResult b
_ forall b. Maybe (Parser b -> Parser b)
t') =
    (forall b. Maybe (Parser b -> Parser b)) -> Parser c -> Parser c
forall b.
(forall b. Maybe (Parser b -> Parser b)) -> Parser b -> Parser b
applyTransform (Maybe (Parser a -> Parser a)
-> Maybe (Parser a -> Parser a) -> Maybe (Parser a -> Parser a)
forall a. Maybe a -> Maybe a -> Maybe a
findJust Maybe (Parser a -> Parser a)
forall b. Maybe (Parser b -> Parser b)
t Maybe (Parser a -> Parser a)
forall b. Maybe (Parser b -> Parser b)
t') Parser c
combinedParser
    where
      combinedParser :: Parser c
combinedParser = (Input -> ParseResult c) -> Parser c
forall a. (Input -> ParseResult a) -> Parser a
mkParser (
        \Input
x -> case Input -> ParseResult a
p Input
x of
        Result Input
i a
a -> Parser c -> Input -> ParseResult c
forall a. Parser a -> Input -> ParseResult a
parse ((a -> b -> c
f a
a) (b -> c) -> Parser b -> Parser c
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser b
mb) Input
i
        Error ParseError
pe -> ParseError -> ParseResult c
forall a. ParseError -> ParseResult a
Error ParseError
pe)

instance Monad Parser where
  >>= :: Parser a -> (a -> Parser b) -> Parser b
(>>=) (P Input -> ParseResult a
p forall b. Maybe (Parser b -> Parser b)
t) a -> Parser b
f = (forall b. Maybe (Parser b -> Parser b)) -> Parser b -> Parser b
forall b.
(forall b. Maybe (Parser b -> Parser b)) -> Parser b -> Parser b
applyTransform forall b. Maybe (Parser b -> Parser b)
t Parser b
combinedParser
    where
      combinedParser :: Parser b
combinedParser = (Input -> ParseResult b) -> Parser b
forall a. (Input -> ParseResult a) -> Parser a
mkParser (
        \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 -> Parser a
forall a. Parser a -> Parser a
exactly 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
_ b
a -> b -> Either ParseError b
forall a b. b -> Either a b
Right b
a

errorParser :: ParseError -> Parser a
errorParser :: ParseError -> Parser a
errorParser = (Input -> ParseResult a) -> Parser a
forall a. (Input -> ParseResult a) -> Parser a
mkParser ((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
mkParser 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 p2 :: Parser a
p2@(P Input -> ParseResult a
_ forall b. Maybe (Parser b -> Parser b)
t) = (forall b. Maybe (Parser b -> Parser b)) -> Parser a -> Parser a
forall b.
(forall b. Maybe (Parser b -> Parser b)) -> Parser b -> Parser b
applyTransform forall b. Maybe (Parser b -> Parser b)
t (Parser a -> Parser a) -> Parser a -> Parser a
forall a b. (a -> b) -> a -> b
$ (Input -> ParseResult a)
-> (forall b. Maybe (Parser b -> Parser b)) -> Parser a
forall a.
(Input -> ParseResult a)
-> (forall b. Maybe (Parser b -> Parser b)) -> 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) forall b. Maybe (Parser b -> Parser b)
t


exactly :: Parser a -> Parser a
exactly :: Parser a -> Parser a
exactly (P Input -> ParseResult a
p forall b. Maybe (Parser b -> Parser b)
t) = (forall b. Maybe (Parser b -> Parser b)) -> Parser a -> Parser a
forall b.
(forall b. Maybe (Parser b -> Parser b)) -> Parser b -> Parser b
applyTransform forall b. Maybe (Parser b -> Parser b)
t (Parser a -> Parser a) -> Parser a -> Parser a
forall a b. (a -> b) -> a -> b
$ (Input -> ParseResult a) -> Parser a
forall a. (Input -> ParseResult a) -> Parser a
mkParser (
  \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 [Parser a]
ps = [Parser a] -> (forall b. Maybe (Parser b -> Parser b)) -> Parser a
forall a.
[Parser a] -> (forall b. Maybe (Parser b -> Parser b)) -> Parser a
anyOfHelper [Parser a]
ps forall a. Maybe a
forall b. Maybe (Parser b -> Parser b)
Nothing

allOf :: [Parser a] -> Parser a
allOf :: [Parser a] -> Parser a
allOf [Parser a]
ps = [Parser a] -> (forall b. Maybe (Parser b -> Parser b)) -> Parser a
forall a.
[Parser a] -> (forall b. Maybe (Parser b -> Parser b)) -> Parser a
allOfHelper [Parser a]
ps forall a. Maybe a
forall b. Maybe (Parser b -> Parser b)
Nothing


anyOfHelper :: [Parser a] -> (forall b. Maybe (Parser b -> Parser b)) -> Parser a
anyOfHelper :: [Parser a] -> (forall b. Maybe (Parser b -> Parser b)) -> Parser a
anyOfHelper [] forall b. Maybe (Parser b -> Parser b)
_  = ParseError -> Parser a
forall a. ParseError -> Parser a
errorParser (ParseError -> Parser a) -> ParseError -> Parser a
forall a b. (a -> b) -> a -> b
$ Input -> ParseError
NoMatch Input
"anyOf"
anyOfHelper [Parser a
p] forall b. Maybe (Parser b -> Parser b)
_ = Parser a
p
anyOfHelper ((P Input -> ParseResult a
p forall b. Maybe (Parser b -> Parser b)
t) : [Parser a]
rest) forall b. Maybe (Parser b -> Parser b)
t' = (forall b. Maybe (Parser b -> Parser b)) -> Parser a -> Parser a
forall b.
(forall b. Maybe (Parser b -> Parser b)) -> Parser b -> Parser b
applyTransform (Maybe (Parser a -> Parser a)
-> Maybe (Parser a -> Parser a) -> Maybe (Parser a -> Parser a)
forall a. Maybe a -> Maybe a -> Maybe a
findJust Maybe (Parser a -> Parser a)
forall b. Maybe (Parser b -> Parser b)
t Maybe (Parser a -> Parser a)
forall b. Maybe (Parser b -> Parser b)
t') (Parser a -> Parser a) -> Parser a -> Parser a
forall a b. (a -> b) -> a -> b
$ (Input -> ParseResult a) -> Parser a
forall a. (Input -> ParseResult a) -> Parser a
mkParser (
   \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] -> (forall b. Maybe (Parser b -> Parser b)) -> Parser a
forall a.
[Parser a] -> (forall b. Maybe (Parser b -> Parser b)) -> Parser a
anyOfHelper [Parser a]
rest forall b. Maybe (Parser b -> Parser b)
t) Input
x)



allOfHelper :: [Parser a] -> (forall b. Maybe (Parser b -> Parser b)) -> Parser a
allOfHelper :: [Parser a] -> (forall b. Maybe (Parser b -> Parser b)) -> Parser a
allOfHelper [] forall b. Maybe (Parser b -> Parser b)
_ = ParseError -> Parser a
forall a. ParseError -> Parser a
errorParser (ParseError -> Parser a) -> ParseError -> Parser a
forall a b. (a -> b) -> a -> b
$ Input -> ParseError
NoMatch Input
"allOf"
allOfHelper [Parser a
p] forall b. Maybe (Parser b -> Parser b)
_ = Parser a
p
allOfHelper ((P Input -> ParseResult a
p forall b. Maybe (Parser b -> Parser b)
t) : [Parser a]
rest) forall b. Maybe (Parser b -> Parser b)
t' = (forall b. Maybe (Parser b -> Parser b)) -> Parser a -> Parser a
forall b.
(forall b. Maybe (Parser b -> Parser b)) -> Parser b -> Parser b
applyTransform (Maybe (Parser a -> Parser a)
-> Maybe (Parser a -> Parser a) -> Maybe (Parser a -> Parser a)
forall a. Maybe a -> Maybe a -> Maybe a
findJust Maybe (Parser a -> Parser a)
forall b. Maybe (Parser b -> Parser b)
t Maybe (Parser a -> Parser a)
forall b. Maybe (Parser b -> Parser b)
t') (Parser a -> Parser a) -> Parser a -> Parser a
forall a b. (a -> b) -> a -> b
$ (Input -> ParseResult a) -> Parser a
forall a. (Input -> ParseResult a) -> Parser a
mkParser (
   \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] -> (forall b. Maybe (Parser b -> Parser b)) -> Parser a
forall a.
[Parser a] -> (forall b. Maybe (Parser b -> Parser b)) -> Parser a
allOfHelper [Parser a]
rest forall b. Maybe (Parser b -> Parser b)
t) 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
     if Char -> Char -> Bool
cond Char
c1 Char
c2
       then Char -> Parser Char
forall (f :: * -> *) a. Applicative f => a -> f a
pure Char
c2
       else ParseError -> Parser Char
forall a. ParseError -> Parser a
errorParser (ParseError -> Parser Char) -> ParseError -> Parser Char
forall a b. (a -> b) -> a -> b
$ Char -> ParseError
UnexpectedChar 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
     if a -> Bool
cond a
c2
       then a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
c2
       else  ParseError -> Parser a
forall a. ParseError -> Parser a
errorParser (ParseError -> Parser a) -> ParseError -> Parser a
forall a b. (a -> b) -> a -> b
$ Input -> ParseError
NoMatch Input
condName


except :: Show a => Parser a -> Parser a -> Parser a
except :: Parser a -> Parser a -> Parser a
except (P Input -> ParseResult a
p forall b. Maybe (Parser b -> Parser b)
t) (P Input -> ParseResult a
p' forall b. Maybe (Parser b -> Parser b)
_) = (forall b. Maybe (Parser b -> Parser b)) -> Parser a -> Parser a
forall b.
(forall b. Maybe (Parser b -> Parser b)) -> Parser b -> Parser b
applyTransform forall b. Maybe (Parser b -> Parser b)
t (Parser a -> Parser a) -> Parser a -> Parser a
forall a b. (a -> b) -> a -> b
$ (Input -> ParseResult a) -> Parser a
forall a. (Input -> ParseResult a) -> Parser a
mkParser (
  \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
_     -> Input -> ParseResult a
p Input
x)

withTransform :: (forall b. Parser b -> Parser b) -> Parser a -> Parser a
withTransform :: (forall a. Parser a -> Parser a) -> Parser a -> Parser a
withTransform forall a. Parser a -> Parser a
f = (forall b. Maybe (Parser b -> Parser b)) -> Parser a -> Parser a
forall b.
(forall b. Maybe (Parser b -> Parser b)) -> Parser b -> Parser b
applyTransform ((forall b. Maybe (Parser b -> Parser b)) -> Parser a -> Parser a)
-> (forall b. Maybe (Parser b -> Parser b)) -> Parser a -> Parser a
forall a b. (a -> b) -> a -> b
$ (Parser a -> Parser a) -> Maybe (Parser a -> Parser a)
forall a. a -> Maybe a
Just Parser a -> Parser a
forall a. Parser a -> Parser a
f


applyTransform :: (forall a. Maybe (Parser a -> Parser a)) -> Parser b -> Parser b
applyTransform :: (forall b. Maybe (Parser b -> Parser b)) -> Parser b -> Parser b
applyTransform forall b. Maybe (Parser b -> Parser b)
f Parser b
p =  Parser b
-> ((Parser b -> Parser b) -> Parser b)
-> Maybe (Parser b -> Parser b)
-> Parser b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Parser b
p (\Parser b -> Parser b
f' -> (Parser b -> Parser b
f' Parser b
p){$sel:transform:P :: forall b. Maybe (Parser b -> Parser b)
transform = forall b. Maybe (Parser b -> Parser b)
f} ) Maybe (Parser b -> Parser b)
forall b. Maybe (Parser b -> Parser b)
f

mkParser :: (Input -> ParseResult a) -> Parser a
mkParser :: (Input -> ParseResult a) -> Parser a
mkParser Input -> ParseResult a
p = P :: forall a.
(Input -> ParseResult a)
-> (forall b. Maybe (Parser b -> Parser b)) -> Parser a
P {$sel:parse:P :: Input -> ParseResult a
parse = Input -> ParseResult a
p, $sel:transform:P :: forall b. Maybe (Parser b -> Parser b)
transform = forall a. Maybe a
forall b. Maybe (Parser b -> Parser b)
Nothing}

findJust :: forall a. Maybe a -> Maybe a -> Maybe a
findJust :: Maybe a -> Maybe a -> Maybe a
findJust Maybe a
ma Maybe a
mb = Maybe (Maybe a) -> Maybe a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe a) -> Maybe a) -> Maybe (Maybe a) -> Maybe a
forall a b. (a -> b) -> a -> b
$ (Maybe a -> Bool) -> [Maybe a] -> Maybe (Maybe a)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find Maybe a -> Bool
forall a. Maybe a -> Bool
isJust [Maybe a
ma, Maybe a
mb]