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

import Bookhound.Utils.Foldable (findJust)
import Control.Applicative      (liftA2)
import Data.Either              (fromRight)
import Data.Maybe               (fromMaybe)
import Data.Text                (Text, pack, uncons, unpack)

type Input = Text

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

data ParseResult a
  = Result Input a
  | Error ParseError
  deriving (ParseResult a -> ParseResult a -> Bool
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
  | ErrorAt String
  deriving (ParseError -> ParseError -> Bool
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 -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ParseError] -> ShowS
$cshowList :: [ParseError] -> ShowS
show :: ParseError -> String
$cshow :: ParseError -> String
showsPrec :: Int -> ParseError -> ShowS
$cshowsPrec :: Int -> ParseError -> ShowS
Show)


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


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


instance Functor Parser where
  fmap :: forall a b. (a -> b) -> Parser a -> Parser b
fmap a -> b
f (P Input -> ParseResult a
p forall b. Maybe (Parser b -> Parser b)
t Maybe ParseError
e) = forall a.
(forall b. Maybe (Parser b -> Parser b))
-> Maybe ParseError -> Parser a -> Parser a
applyTransformError forall b. Maybe (Parser b -> Parser b)
t Maybe ParseError
e forall a b. (a -> b) -> a -> b
$
    forall a. (Input -> ParseResult a) -> Parser a
mkParser (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. Input -> ParseResult a
p)

instance Applicative Parser where
  pure :: forall a. a -> Parser a
pure a
a      = forall a. (Input -> ParseResult a) -> Parser a
mkParser (forall a. Input -> a -> ParseResult a
`Result` a
a)
  liftA2 :: forall a b c. (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 Maybe ParseError
e) mb :: Parser b
mb@(P Input -> ParseResult b
_ forall b. Maybe (Parser b -> Parser b)
t' Maybe ParseError
e') =
    forall a.
(forall b. [Maybe (Parser b -> Parser b)])
-> [Maybe ParseError] -> Parser a -> Parser a
applyTransformsErrors [forall b. Maybe (Parser b -> Parser b)
t, forall b. Maybe (Parser b -> Parser b)
t'] [Maybe ParseError
e, Maybe ParseError
e'] Parser c
combinedParser
    where
      combinedParser :: Parser c
combinedParser = forall a. (Input -> ParseResult a) -> Parser a
mkParser \Input
x ->
        case Input -> ParseResult a
p Input
x of
          Result Input
i a
a -> forall a. Parser a -> Input -> ParseResult a
parse ((a -> b -> c
f a
a) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser b
mb) Input
i
          Error ParseError
pe   -> forall a. ParseError -> ParseResult a
Error ParseError
pe

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

runParser :: Parser a -> Input -> Either ParseError a
runParser :: forall a. Parser a -> Input -> Either ParseError a
runParser p :: Parser a
p@(P Input -> ParseResult a
_ forall b. Maybe (Parser b -> Parser b)
_ Maybe ParseError
err) Input
i = ParseResult a -> Either ParseError a
toEither forall a b. (a -> b) -> a -> b
$ forall a. Parser a -> Input -> ParseResult a
parse (forall a. Parser a -> Parser a
exactly Parser a
p) Input
i
  where
    toEither :: ParseResult a -> Either ParseError a
toEither = \case
      Error ParseError
pe   -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe ParseError
pe Maybe ParseError
err
      Result Input
_ a
a -> forall a b. b -> Either a b
Right a
a

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

andThen :: Parser String -> Parser a -> Parser a
andThen :: forall a. Parser String -> Parser a -> Parser a
andThen Parser String
p1 p2 :: Parser a
p2@(P Input -> ParseResult a
_ forall b. Maybe (Parser b -> Parser b)
t Maybe ParseError
e) = forall a.
(forall b. Maybe (Parser b -> Parser b))
-> Maybe ParseError -> Parser a -> Parser a
applyTransformError forall b. Maybe (Parser b -> Parser b)
t Maybe ParseError
e forall a b. (a -> b) -> a -> b
$
  forall a.
(Input -> ParseResult a)
-> (forall b. Maybe (Parser b -> Parser b))
-> Maybe ParseError
-> Parser a
P (\Input
i -> forall a. Parser a -> Input -> ParseResult a
parse Parser a
p2 forall a b. (a -> b) -> a -> b
$ forall b a. b -> Either a b -> b
fromRight Input
i forall a b. (a -> b) -> a -> b
$ String -> Input
pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Parser a -> Input -> Either ParseError a
runParser Parser String
p1 Input
i) forall b. Maybe (Parser b -> Parser b)
t Maybe ParseError
e

char :: Parser Char
char :: Parser Char
char = forall a. (Input -> ParseResult a) -> Parser a
mkParser forall a b. (a -> b) -> a -> b
$
   forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. ParseError -> ParseResult a
Error ParseError
UnexpectedEof) (\(Char
ch, Input
rest) -> forall a. Input -> a -> ParseResult a
Result Input
rest Char
ch) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Input -> Maybe (Char, Input)
uncons


exactly :: Parser a -> Parser a
exactly :: forall a. Parser a -> Parser a
exactly (P Input -> ParseResult a
p forall b. Maybe (Parser b -> Parser b)
t Maybe ParseError
e) = forall a.
(forall b. Maybe (Parser b -> Parser b))
-> Maybe ParseError -> Parser a -> Parser a
applyTransformError forall b. Maybe (Parser b -> Parser b)
t Maybe ParseError
e forall a b. (a -> b) -> a -> b
$
  forall a. (Input -> ParseResult a) -> Parser a
mkParser (\Input
x ->
    case Input -> ParseResult a
p Input
x of
      result :: ParseResult a
result@(Result Input
i a
_) | Input
i forall a. Eq a => a -> a -> Bool
== forall a. Monoid a => a
mempty -> ParseResult a
result
      Result Input
i a
_                        -> forall a. ParseError -> ParseResult a
Error 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 :: forall a. [Parser a] -> Parser a
anyOf [Parser a]
ps = forall a.
[Parser a]
-> (forall b. Maybe (Parser b -> Parser b))
-> Maybe ParseError
-> Parser a
anyOfHelper [Parser a]
ps forall a. Maybe a
Nothing forall a. Maybe a
Nothing

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


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



allOfHelper :: [Parser a]
            -> (forall b. Maybe (Parser b -> Parser b))
            -> Maybe ParseError
            -> Parser a
allOfHelper :: forall a.
[Parser a]
-> (forall b. Maybe (Parser b -> Parser b))
-> Maybe ParseError
-> Parser a
allOfHelper [] forall b. Maybe (Parser b -> Parser b)
_ Maybe ParseError
_ = forall a. ParseError -> Parser a
errorParser forall a b. (a -> b) -> a -> b
$ String -> ParseError
NoMatch String
"allOf"
allOfHelper [Parser a
p] forall b. Maybe (Parser b -> Parser b)
_ Maybe ParseError
_ = Parser a
p
allOfHelper ((P Input -> ParseResult a
p forall b. Maybe (Parser b -> Parser b)
t Maybe ParseError
e) : [Parser a]
rest) forall b. Maybe (Parser b -> Parser b)
t' Maybe ParseError
e' = forall a.
(forall b. [Maybe (Parser b -> Parser b)])
-> [Maybe ParseError] -> Parser a -> Parser a
applyTransformsErrors [forall b. Maybe (Parser b -> Parser b)
t, forall b. Maybe (Parser b -> Parser b)
t'] [Maybe ParseError
e, Maybe ParseError
e'] forall a b. (a -> b) -> a -> b
$
  forall a. (Input -> ParseResult a) -> Parser a
mkParser (\Input
x ->
    case Input -> ParseResult a
p Input
x of
      Result Input
_ a
_    -> forall a. Parser a -> Input -> ParseResult a
parse (forall a.
[Parser a]
-> (forall b. Maybe (Parser b -> Parser b))
-> Maybe ParseError
-> Parser a
allOfHelper [Parser a]
rest forall b. Maybe (Parser b -> Parser b)
t Maybe ParseError
e) Input
x
      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 forall (f :: * -> *) a. Applicative f => a -> f a
pure Char
c2
       else forall a. ParseError -> Parser a
errorParser forall a b. (a -> b) -> a -> b
$ Char -> ParseError
UnexpectedChar Char
c2

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


except :: Parser a -> Parser a -> Parser a
except :: forall a. Parser a -> Parser a -> Parser a
except (P Input -> ParseResult a
p forall b. Maybe (Parser b -> Parser b)
t Maybe ParseError
e) (P Input -> ParseResult a
p' forall b. Maybe (Parser b -> Parser b)
_ Maybe ParseError
_) = forall a.
(forall b. Maybe (Parser b -> Parser b))
-> Maybe ParseError -> Parser a -> Parser a
applyTransformError forall b. Maybe (Parser b -> Parser b)
t Maybe ParseError
e forall a b. (a -> b) -> a -> b
$ forall a. (Input -> ParseResult a) -> Parser a
mkParser (
  \Input
x -> case Input -> ParseResult a
p' Input
x of
    Result Input
_ a
_ -> forall a. ParseError -> ParseResult a
Error forall a b. (a -> b) -> a -> b
$ String -> ParseError
NoMatch String
"except"
    Error ParseError
_    -> Input -> ParseResult a
p Input
x
  )

withError :: String -> Parser a -> Parser a
withError :: forall a. String -> Parser a -> Parser a
withError = forall a. Maybe ParseError -> Parser a -> Parser a
applyError forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ParseError
ErrorAt

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


applyTransformError :: (forall b. Maybe (Parser b -> Parser b))
                    -> Maybe ParseError
                    -> Parser a
                    -> Parser a
applyTransformError :: forall a.
(forall b. Maybe (Parser b -> Parser b))
-> Maybe ParseError -> Parser a -> Parser a
applyTransformError forall b. Maybe (Parser b -> Parser b)
t Maybe ParseError
e = forall a.
(forall b. Maybe (Parser b -> Parser b)) -> Parser a -> Parser a
applyTransform forall b. Maybe (Parser b -> Parser b)
t forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Maybe ParseError -> Parser a -> Parser a
applyError Maybe ParseError
e


applyTransformsErrors :: (forall b. [Maybe (Parser b -> Parser b)])
                      -> [Maybe ParseError]
                      -> Parser a
                      -> Parser a
applyTransformsErrors :: forall a.
(forall b. [Maybe (Parser b -> Parser b)])
-> [Maybe ParseError] -> Parser a -> Parser a
applyTransformsErrors forall b. [Maybe (Parser b -> Parser b)]
ts [Maybe ParseError]
es =
  forall a.
(forall b. Maybe (Parser b -> Parser b))
-> Maybe ParseError -> Parser a -> Parser a
applyTransformError (forall (t :: * -> *) a. Foldable t => t (Maybe a) -> Maybe a
findJust forall b. [Maybe (Parser b -> Parser b)]
ts) (forall (t :: * -> *) a. Foldable t => t (Maybe a) -> Maybe a
findJust [Maybe ParseError]
es)


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

applyError :: Maybe ParseError -> Parser a -> Parser a
applyError :: forall a. Maybe ParseError -> Parser a -> Parser a
applyError Maybe ParseError
e Parser a
p = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Parser a
p (\ParseError
_ -> Parser a
p {$sel:error:P :: Maybe ParseError
error = Maybe ParseError
e}) Maybe ParseError
e

mkParser :: (Input -> ParseResult a) -> Parser a
mkParser :: forall a. (Input -> ParseResult a) -> Parser a
mkParser Input -> ParseResult a
p = 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
Nothing, $sel:error:P :: Maybe ParseError
error = forall a. Maybe a
Nothing}