module Bookhound.Parser (Parser, ParseResult, ParseError(..), runParser, errorParser, andThen, exactly, isMatch, check, anyOf, allOf, char, withTransform, withError, withErrorN, withErrorFrom, mapError, except) where import Bookhound.Utils.Foldable (findJust) import Control.Applicative (liftA2) import Data.Either (fromRight) import Data.Set (Set) import qualified Data.Set as Set 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 -> Set (Int, ParseError) errors :: Set (Int, 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, 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 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 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 (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 (UnexpectedString String s) = String "Unexpected string: " forall a. Semigroup a => a -> a -> a <> String "[" forall a. Semigroup a => a -> a -> a <> String s forall a. Semigroup a => a -> a -> a <> String "]" show (NoMatch String s) = String "Did not match condition: " forall a. Semigroup a => a -> a -> a <> String s show (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 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 ) 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 = 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 Result Input _ a a -> forall a b. b -> Either a b Right a 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] hasPriorityError :: ParseError -> Bool hasPriorityError :: ParseError -> Bool hasPriorityError (ErrorAt String _) = Bool True hasPriorityError ParseError _ = Bool False 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 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) -> (forall b. Maybe (Parser b -> Parser b)) -> Set (Int, 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 Set (Int, 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 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 :: 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 ParseResult a err -> 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)) -> Set (Int, ParseError) -> Parser a anyOfHelper [Parser a] ps forall a. Maybe a Nothing forall a. Monoid a => a mempty 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)) -> Set (Int, ParseError) -> Parser a allOfHelper [Parser a] ps forall a. Maybe a Nothing forall a. Monoid a => a mempty anyOfHelper :: [Parser a] -> (forall b. Maybe (Parser b -> Parser b)) -> Set (Int, ParseError) -> Parser a anyOfHelper :: forall a. [Parser a] -> (forall b. Maybe (Parser b -> Parser b)) -> Set (Int, ParseError) -> Parser a anyOfHelper [] forall b. Maybe (Parser b -> Parser b) _ Set (Int, 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) _ Set (Int, ParseError) _ = Parser a p anyOfHelper ((P Input -> ParseResult a p forall b. Maybe (Parser b -> Parser b) t Set (Int, ParseError) e) : [Parser a] rest) 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 Error ParseError _ -> forall a. Parser a -> Input -> ParseResult a parse (forall a. [Parser a] -> (forall b. Maybe (Parser b -> Parser b)) -> Set (Int, ParseError) -> Parser a anyOfHelper [Parser a] rest forall b. Maybe (Parser b -> Parser b) t Set (Int, ParseError) e) Input x ParseResult a result -> ParseResult a result ) allOfHelper :: [Parser a] -> (forall b. Maybe (Parser b -> Parser b)) -> Set (Int, ParseError) -> Parser a allOfHelper :: forall a. [Parser a] -> (forall b. Maybe (Parser b -> Parser b)) -> Set (Int, ParseError) -> Parser a allOfHelper [] forall b. Maybe (Parser b -> Parser b) _ Set (Int, 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) _ Set (Int, ParseError) _ = Parser a p allOfHelper ((P Input -> ParseResult a p forall b. Maybe (Parser b -> Parser b) t Set (Int, ParseError) e) : [Parser a] rest) 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 _ -> forall a. Parser a -> Input -> ParseResult a parse (forall a. [Parser a] -> (forall b. Maybe (Parser b -> Parser b)) -> Set (Int, ParseError) -> Parser a allOfHelper [Parser a] rest forall b. Maybe (Parser b -> Parser b) t Set (Int, ParseError) e) Input x ParseResult a err -> 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 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 $ 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. Int -> String -> Parser a -> Parser a withErrorN Int 0 withErrorN :: Int -> String -> Parser a -> Parser a withErrorN :: forall a. Int -> String -> Parser a -> Parser a withErrorN Int n String 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, String -> ParseError ErrorAt String str) withErrorFrom :: (a -> String) -> Parser a -> Parser a withErrorFrom :: forall a. (a -> String) -> Parser a -> Parser a withErrorFrom a -> String errFn Parser a p = do a value <- Parser a p forall a. (ParseError -> ParseError) -> Parser a -> Parser a mapError (forall a b. a -> b -> a const forall a b. (a -> b) -> a -> b $ String -> ParseError ErrorAt forall a b. (a -> b) -> a -> b $ a -> String errFn a value) forall a b. (a -> b) -> a -> b $ forall (f :: * -> *) a. Applicative f => a -> f a pure a value mapError :: (ParseError -> ParseError) -> Parser a -> Parser a mapError :: forall a. (ParseError -> ParseError) -> Parser a -> Parser a mapError ParseError -> ParseError 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 ( \Input x -> case Input -> ParseResult a p Input x of Error ParseError pe -> forall a. ParseError -> ParseResult a Error forall a b. (a -> b) -> a -> b $ ParseError -> ParseError f ParseError pe ParseResult a result -> ParseResult a result ) 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}