diff options
Diffstat (limited to 'DSL/BaseParsers.hs')
| -rw-r--r-- | DSL/BaseParsers.hs | 108 |
1 files changed, 77 insertions, 31 deletions
diff --git a/DSL/BaseParsers.hs b/DSL/BaseParsers.hs index 4da9c38..05eb509 100644 --- a/DSL/BaseParsers.hs +++ b/DSL/BaseParsers.hs @@ -5,9 +5,15 @@ module DSL.BaseParsers where import Control.Applicative (Alternative(..), liftA2) import Control.Monad (MonadPlus(..), guard) import Data.Maybe (catMaybes) +import Data.Void + +data ParserError + = ErrorLeaf String + | ErrorBranch String [ParserError] + deriving (Show) newtype Parser t a = - Parser { parse :: [t] -> Maybe ([t], a) } + Parser { parse :: [t] -> Either ParserError ([t], a) } instance Semigroup a => Semigroup (Parser t a) where (<>) = liftA2 (<>) @@ -33,7 +39,7 @@ instance Monad (Parser t) where parse (f x) inp' instance Alternative (Parser t) where - empty = flunk + empty = flunkWith "Flunked: empty Alternative" (<|>) = alt @@ -42,47 +48,87 @@ instance MonadPlus (Parser t) instance MonadFail (Parser t) where fail _ = mzero +type ErrorChanger t a = String -> Parser t a -> Parser t a + +nicePrintParserError :: ParserError -> String +nicePrintParserError = unlines . go 0 + where + indentSize = 4 + go indent (ErrorLeaf s) = [replicate indent ' ' ++ s] + go indent (ErrorBranch s es) = s':es' + where + s' = replicate indent ' ' ++ s + es' = es >>= go (indent + indentSize) + ----------------------------------------------------------------------------- +perr :: String -> Either ParserError Void +perr = Left . ErrorLeaf + +overwriteError :: ErrorChanger t a +overwriteError s p = Parser $ \ inp -> case parse p inp of + Left _ -> absurd <$> perr s + Right x -> Right x + +setError :: ErrorChanger t a +setError s p = Parser $ \ inp -> case parse p inp of + Left (ErrorLeaf _) -> absurd <$> perr s + Left (ErrorBranch _ es) -> Left $ ErrorBranch s es + Right x -> Right x + +prependError :: ErrorChanger t a +prependError s p = Parser $ \ inp -> case parse p inp of + Left e -> Left $ ErrorBranch s [e] + Right x -> Right x + flunk :: Parser t a -flunk = Parser $ \ _ -> Nothing +flunk = flunkWith "Flunked parser" + +flunkWith :: String -> Parser t a +flunkWith e = Parser $ \ _ -> absurd <$> perr e result :: a -> Parser t a -result x = Parser $ \ inp -> Just (inp, x) +result x = Parser $ \ inp -> Right (inp, x) peek :: Parser t a -> Parser t a -peek p = Parser $ \ inp -> do +peek p = prependError "peek:" $ Parser $ \ inp -> do (_, x) <- parse p inp return (inp, x) anyToken :: Parser t t anyToken = Parser $ \ inp -> case inp of - t:ts -> Just (ts, t) - _ -> Nothing + t:ts -> Right (ts, t) + _ -> absurd <$> perr "anyToken: Expected a token, got EOF" eof :: Parser t () eof = Parser $ \ inp -> case inp of - [] -> Just ([], ()) - _ -> Nothing + [] -> Right ([], ()) + _ -> absurd <$> perr "eof: Expected EOF, got a token" infixl 3 `alt` alt :: Parser t a -> Parser t a -> Parser t a -alt (Parser p) (Parser q) = Parser $ \ inp -> p inp <|> q inp +alt p q = Parser $ \ inp -> case (parse p inp, parse q inp) of + (Right x, _) -> Right x + (_, Right x) -> Right x + (Left e1, Left e2) -> Left $ case (e1, e2) of + (ErrorLeaf s, ErrorBranch b es) -> ErrorBranch b (ErrorLeaf s:es) + (ErrorBranch b es, ErrorLeaf s) -> ErrorBranch b (es ++ [ErrorLeaf s]) + _ -> ErrorBranch "alt:" [e1, e2] chain :: Parser s [t] -> Parser t a -> Parser s a -chain p q = do - ts <- p - case parse q ts of - Nothing -> flunk - Just (_, x) -> result x +chain p q = prependError "chain:" $ Parser $ \ inp1 -> case parse p inp1 of + Left e1 -> Left e1 + Right (inp1', inp2) -> case parse q inp2 of + Left e2 -> Left e2 + Right (_, x) -> Right (inp1', x) ----------------------------------------------------------------------------- phrase :: Parser t a -> Parser t a -phrase = (<* eof) +phrase = prependError "phrase:" . (<* eof) plus :: Parser t a -> Parser t b -> Parser t (a, b) -plus = liftA2 (,) +plus p q = prependError "plus:" $ liftA2 (,) p q recover :: a -> Parser t a -> Parser t a recover x p = p <|> pure x @@ -97,55 +143,55 @@ optional :: Parser t a -> Parser t () optional p = () <$ optionalMaybe p assert :: (a -> Bool) -> Parser t a -> Parser t a -assert f p = do +assert f p = prependError "assert:" $ do x <- p guard $ f x return x satisfy :: (t -> Bool) -> Parser t t -satisfy f = assert f anyToken +satisfy f = prependError "satisfy:" $ assert f anyToken token :: Eq t => t -> Parser t t -token t = satisfy (==t) +token t = prependError "token:" $ satisfy (==t) list :: Eq t => [t] -> Parser t [t] -list = traverse token +list = prependError "list:" . traverse token mult :: Parser t a -> Parser t [a] -mult = many +mult = prependError "mult:" . many mult1 :: Parser t a -> Parser t [a] -mult1 = some +mult1 = prependError "mult1:" . some exactly :: Int -> Parser t a -> Parser t [a] -exactly i = sequence . replicate i +exactly i = prependError "exactly:" . sequence . replicate i atLeast :: Int -> Parser t a -> Parser t [a] -atLeast i p = exactly i p <> mult p +atLeast i p = prependError "atLeast:" $ exactly i p <> mult p atMost :: Int -> Parser t a -> Parser t [a] -atMost i = fmap catMaybes . exactly i . optionalMaybe +atMost i = prependError "atMost" . fmap catMaybes . exactly i . optionalMaybe between :: Int -> Int -> Parser t a -> Parser t [a] -between x y p = exactly (min x y) p <> atMost (abs $ x - y) p +between x y p = prependError "between:" $ exactly (min x y) p <> atMost (abs $ x - y) p stopAt :: Parser t a -> Parser t [t] -stopAt p = go +stopAt p = setError "stopAt: failed to find stop point" $ go where p' = ([] <$ peek p) go = p' <|> liftA2 (:) anyToken go stopAfter :: Parser t a -> Parser t ([t], a) -stopAfter p = (,) <$> stopAt p <*> p +stopAfter p = prependError "stopAfter:" $ stopAt p `plus` p stopIf :: Parser t a -> Parser t [t] stopIf p = stopAt $ () <$ p <|> eof firstOf :: [Parser t a] -> Parser t a -firstOf = foldr1 (<|>) +firstOf = prependError "firstOf:" . foldr1 (<|>) sepBy1 :: Parser t a -> Parser t b -> Parser t [a] -sepBy1 a b = do +sepBy1 a b = prependError "sepBy1:" $ do x <- a xs <- mult $ b >> a return $ x:xs |