module Bookhound.Parser (Parser(parse), ParseResult(..), ParseError(..), mkParser, runParser, throwError, andThen, exactly, eof , lookAhead , notFollowedBy, both, choice, anyOf, allOf, anyChar, satisfy, withTransform, withError, withErrorN, except) where import Bookhound.Utils.Foldable (findJust) import Control.Applicative (Alternative (..), liftA2) import Control.Monad (MonadPlus) import Control.Monad.Error.Class (MonadError (..)) import Data.Either (fromRight) import Data.Foldable (foldl') import Data.Set (Set) import qualified Data.Set as Set import Data.Text (Text, unpack) import qualified Data.Text as 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 -> Set (Int, ParseError) errors :: Set (Int, ParseError) } 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 Set (Int, ParseError) e) = forall a. (forall b. Maybe (Parser b -> Parser b)) -> Set (Int, ParseError) -> Parser a -> Parser a applyTransformError forall b. Maybe (Parser b -> Parser b) t Set (Int, 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 Set (Int, ParseError) e) mb :: Parser b mb@(P Input -> ParseResult b _ forall b. Maybe (Parser b -> Parser b) t' Set (Int, ParseError) e') = forall a. (forall b. [Maybe (Parser b -> Parser b)]) -> [Set (Int, ParseError)] -> Parser a -> Parser a applyTransformsErrors [forall b. Maybe (Parser b -> Parser b) t, forall b. Maybe (Parser b -> Parser b) t'] [Set (Int, ParseError) e, Set (Int, 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 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 Set (Int, ParseError) e) a -> Parser b f = forall a. (forall b. Maybe (Parser b -> Parser b)) -> Set (Int, ParseError) -> Parser a -> Parser a applyTransformError forall b. Maybe (Parser b -> Parser b) t Set (Int, 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 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 instance Semigroup a => Semigroup (Parser a) where <> :: Parser a -> Parser a -> Parser a (<>) = forall (f :: * -> *) a b c. Applicative f => (a -> b -> c) -> f a -> f b -> f c liftA2 forall a. Semigroup a => a -> a -> a (<>) instance Monoid a => Monoid (Parser a) where mempty :: Parser a mempty = forall (f :: * -> *) a. Applicative f => a -> f a pure forall a. Monoid a => a mempty instance Alternative Parser where <|> :: forall a. Parser a -> Parser a -> Parser a (<|>) (P Input -> ParseResult a p forall b. Maybe (Parser b -> Parser b) t Set (Int, ParseError) e) Parser a p2 = forall a. (forall b. Maybe (Parser b -> Parser b)) -> Set (Int, ParseError) -> Parser a -> Parser a applyTransformError forall b. Maybe (Parser b -> Parser b) t Set (Int, 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 Error ParseError _ -> let (P Input -> ParseResult a _ forall b. Maybe (Parser b -> Parser b) t' Set (Int, ParseError) e') = Parser a p2 in forall a. Parser a -> Input -> ParseResult a parse (forall a. (forall b. [Maybe (Parser b -> Parser b)]) -> [Set (Int, ParseError)] -> Parser a -> Parser a applyTransformsErrors [forall b. Maybe (Parser b -> Parser b) t, forall b. Maybe (Parser b -> Parser b) t'] [Set (Int, ParseError) e, Set (Int, ParseError) e'] Parser a p2) Input x ParseResult a result -> ParseResult a result empty :: forall a. Parser a empty = forall a. (Input -> ParseResult a) -> Parser a mkParser \Input i -> if Input -> Bool Text.null Input i then forall a. ParseError -> ParseResult a Error ParseError UnexpectedEof else forall a. ParseError -> ParseResult a Error forall a b. (a -> b) -> a -> b $ Input -> ParseError ExpectedEof Input i instance MonadPlus Parser instance MonadError ParseError Parser where throwError :: forall a. ParseError -> Parser a throwError = 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 catchError :: forall a. Parser a -> (ParseError -> Parser a) -> Parser a catchError Parser a p ParseError -> Parser a errFn = forall a. (Input -> ParseResult a) -> Parser a mkParser \Input x -> case forall a. Parser a -> Input -> ParseResult a parse Parser a p Input x of Error ParseError err -> forall a. Parser a -> Input -> ParseResult a parse (ParseError -> Parser a errFn ParseError err) Input x ParseResult a result -> ParseResult a result anyChar :: Parser Char anyChar :: Parser Char anyChar = 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) (forall a b c. (a -> b -> c) -> (a, b) -> c uncurry forall a b. (a -> b) -> a -> b $ forall a b c. (a -> b -> c) -> b -> a -> c flip forall a. Input -> a -> ParseResult a Result) forall b c a. (b -> c) -> (a -> b) -> a -> c . Input -> Maybe (Char, Input) Text.uncons 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) _ Set (Int, ParseError) e) Input i = forall {b}. ParseResult b -> Either [ParseError] b 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 b -> Either [ParseError] b toEither = \case Result Input _ b a -> forall a b. b -> Either a b Right b a Error ParseError pe -> forall a b. a -> Either a b Left forall a b. (a -> b) -> a -> b $ forall a. (a -> Bool) -> [a] -> [a] filter ParseError -> Bool hasPriorityError [ParseError pe] forall a. Semigroup a => a -> a -> a <> (forall a b. (a, b) -> b snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall a. [a] -> [a] reverse (forall a. Set a -> [a] Set.toList Set (Int, ParseError) e)) forall a. Semigroup a => a -> a -> a <> forall a. (a -> Bool) -> [a] -> [a] filter (Bool -> Bool not forall b c a. (b -> c) -> (a -> b) -> a -> c . ParseError -> Bool hasPriorityError) [ParseError pe] andThen :: Parser Text -> Parser a -> Parser a andThen :: forall a. 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 Set (Int, ParseError) e) = forall a. (forall b. Maybe (Parser b -> Parser b)) -> Set (Int, ParseError) -> Parser a -> Parser a applyTransformError forall b. Maybe (Parser b -> Parser b) t Set (Int, ParseError) e forall a b. (a -> b) -> a -> b $ forall a. (Input -> ParseResult a) -> Parser a mkParser (\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. Parser a -> Input -> Either [ParseError] a runParser Parser Input p1 Input i)) exactly :: Parser a -> Parser a exactly :: forall a. Parser a -> Parser a exactly Parser a p = Parser a p forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a <* Parser () eof eof :: Parser () eof :: Parser () eof = forall a. (Input -> ParseResult a) -> Parser a mkParser \Input i -> if Input i forall a. Eq a => a -> a -> Bool == forall a. Monoid a => a mempty then forall a. Input -> a -> ParseResult a Result Input i () else forall a. ParseError -> ParseResult a Error forall a b. (a -> b) -> a -> b $ Input -> ParseError ExpectedEof Input i lookAhead :: Parser a -> Parser a lookAhead :: forall a. Parser a -> Parser a lookAhead (P Input -> ParseResult a p forall b. Maybe (Parser b -> Parser b) t Set (Int, ParseError) e) = forall a. (forall b. Maybe (Parser b -> Parser b)) -> Set (Int, ParseError) -> Parser a -> Parser a applyTransformError forall b. Maybe (Parser b -> Parser b) t Set (Int, 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 a -> forall a. Input -> a -> ParseResult a Result Input x a a ParseResult a err -> ParseResult a err notFollowedBy :: Parser a -> Parser () notFollowedBy :: forall a. Parser a -> Parser () notFollowedBy (P Input -> ParseResult a p forall b. Maybe (Parser b -> Parser b) t Set (Int, ParseError) e) = forall a. (forall b. Maybe (Parser b -> Parser b)) -> Set (Int, ParseError) -> Parser a -> Parser a applyTransformError forall b. Maybe (Parser b -> Parser b) t Set (Int, 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 ParseError UnexpectedEof ParseResult a _ -> forall a. Input -> a -> ParseResult a Result Input x () choice :: Foldable f => f (Parser a) -> Parser a choice :: forall (f :: * -> *) a. Foldable f => f (Parser a) -> Parser a choice = forall (f :: * -> *) a. Foldable f => f (Parser a) -> Parser a anyOf anyOf :: Foldable f => f (Parser a) -> Parser a anyOf :: forall (f :: * -> *) a. Foldable f => f (Parser a) -> Parser a anyOf = forall (t :: * -> *) b a. Foldable t => (b -> a -> b) -> b -> t a -> b foldl' forall (f :: * -> *) a. Alternative f => f a -> f a -> f a (<|>) forall (f :: * -> *) a. Alternative f => f a empty allOf :: Foldable f => f (Parser a) -> Parser a allOf :: forall (f :: * -> *) a. Foldable f => f (Parser a) -> Parser a allOf = forall (t :: * -> *) b a. Foldable t => (b -> a -> b) -> b -> t a -> b foldl' forall a. Parser a -> Parser a -> Parser a both (forall (f :: * -> *) a. Applicative f => a -> f a pure forall a. HasCallStack => a undefined) both :: Parser a -> Parser a -> Parser a both :: forall a. Parser a -> Parser a -> Parser a both (P Input -> ParseResult a p forall b. Maybe (Parser b -> Parser b) t Set (Int, ParseError) e) (P Input -> ParseResult a p' forall b. Maybe (Parser b -> Parser b) t' Set (Int, ParseError) e') = forall a. (forall b. [Maybe (Parser b -> Parser b)]) -> [Set (Int, ParseError)] -> Parser a -> Parser a applyTransformsErrors [ forall b. Maybe (Parser b -> Parser b) t, forall b. Maybe (Parser b -> Parser b) t' ] [ Set (Int, ParseError) e, Set (Int, 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 _ -> Input -> ParseResult a p' Input x ParseResult a err -> ParseResult a err 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 Set (Int, ParseError) e) (P Input -> ParseResult a p' forall b. Maybe (Parser b -> Parser b) _ Set (Int, ParseError) _) = forall a. (forall b. Maybe (Parser b -> Parser b)) -> Set (Int, ParseError) -> Parser a -> Parser a applyTransformError forall b. Maybe (Parser b -> Parser b) t Set (Int, 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 $ Input -> ParseError ExpectedEof Input x Error ParseError _ -> Input -> ParseResult a p Input x ) satisfy :: (a -> Bool) -> Parser a -> Parser a satisfy :: forall a. (a -> Bool) -> Parser a -> Parser a satisfy a -> Bool cond Parser a ma = do a c2 <- Parser a ma if a -> Bool cond a c2 then forall (f :: * -> *) a. Applicative f => a -> f a pure a c2 else forall (f :: * -> *) a. Alternative f => f a empty withError :: Text -> Parser a -> Parser a withError :: forall a. Input -> Parser a -> Parser a withError = forall a. Int -> Input -> Parser a -> Parser a withErrorN Int 0 withErrorN :: Int -> Text -> Parser a -> Parser a withErrorN :: forall a. Int -> Input -> Parser a -> Parser a withErrorN Int n Input str = forall a. Set (Int, ParseError) -> Parser a -> Parser a applyError forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. a -> Set a Set.singleton forall a b. (a -> b) -> a -> b $ (Int n, Input -> ParseError ErrorAt Input str) 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 applyTransformsErrors :: (forall b. [Maybe (Parser b -> Parser b)]) -> [Set (Int, ParseError)] -> Parser a -> Parser a applyTransformsErrors :: forall a. (forall b. [Maybe (Parser b -> Parser b)]) -> [Set (Int, ParseError)] -> Parser a -> Parser a applyTransformsErrors forall b. [Maybe (Parser b -> Parser b)] ts [Set (Int, ParseError)] es = forall a. (forall b. Maybe (Parser b -> Parser b)) -> Set (Int, 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 a. Monoid a => [a] -> a mconcat [Set (Int, ParseError)] es) applyTransformError :: (forall b. Maybe (Parser b -> Parser b)) -> Set (Int, ParseError) -> Parser a -> Parser a applyTransformError :: forall a. (forall b. Maybe (Parser b -> Parser b)) -> Set (Int, ParseError) -> Parser a -> Parser a applyTransformError forall b. Maybe (Parser b -> Parser b) t Set (Int, 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. Set (Int, ParseError) -> Parser a -> Parser a applyError Set (Int, ParseError) e 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 :: Set (Int, ParseError) -> Parser a -> Parser a applyError :: forall a. Set (Int, ParseError) -> Parser a -> Parser a applyError Set (Int, ParseError) e p :: Parser a p@(P Input -> ParseResult a _ forall b. Maybe (Parser b -> Parser b) _ Set (Int, ParseError) e') = Parser a p {$sel:errors:P :: Set (Int, ParseError) errors = Set (Int, ParseError) e forall a. Semigroup a => a -> a -> a <> Set (Int, 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:errors:P :: Set (Int, ParseError) errors = forall a. Set a Set.empty} hasPriorityError :: ParseError -> Bool hasPriorityError :: ParseError -> Bool hasPriorityError (ErrorAt Input _) = Bool True hasPriorityError ParseError _ = Bool False 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) 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 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 err) = forall a. Show a => a -> String show ParseError err data ParseError = UnexpectedEof | ExpectedEof Input | ErrorAt Text 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, Eq ParseError ParseError -> ParseError -> Bool ParseError -> ParseError -> Ordering ParseError -> ParseError -> ParseError forall a. Eq a -> (a -> a -> Ordering) -> (a -> a -> Bool) -> (a -> a -> Bool) -> (a -> a -> Bool) -> (a -> a -> Bool) -> (a -> a -> a) -> (a -> a -> a) -> Ord a min :: ParseError -> ParseError -> ParseError $cmin :: ParseError -> ParseError -> ParseError max :: ParseError -> ParseError -> ParseError $cmax :: ParseError -> ParseError -> ParseError >= :: ParseError -> ParseError -> Bool $c>= :: ParseError -> ParseError -> Bool > :: ParseError -> ParseError -> Bool $c> :: ParseError -> ParseError -> Bool <= :: ParseError -> ParseError -> Bool $c<= :: ParseError -> ParseError -> Bool < :: ParseError -> ParseError -> Bool $c< :: ParseError -> ParseError -> Bool compare :: ParseError -> ParseError -> Ordering $ccompare :: ParseError -> ParseError -> Ordering Ord) instance Show ParseError where show :: ParseError -> String show ParseError UnexpectedEof = String "Unexpected end of stream" show (ExpectedEof Input i) = String "Expected end of stream, but got " 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 "<" show (ErrorAt Input s) = String "Error at " forall a. Semigroup a => a -> a -> a <> Input -> String unpack Input s type Input = Text