{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE StandaloneDeriving #-}
{-|
Description: An unambiguous parser with symmetric choice and location tracking
* Parser
* Parsing locations
* Parsing brackets
* Parsing lists
-}
module Parser.Parser (
(<+>),
Parse_error' (..),
Parser',
add_location,
parse,
parse_brackets,
parse_empty_list,
parse_line_and_char,
parse_list,
parse_many,
parse_non_empty_list,
parse_some,
parse_token,
parse_token') where
import Control.Monad.Except (ExceptT (..), MonadError (..), runExceptT, withExceptT)
import Control.Monad.State.Strict (MonadState (..), StateT (..), evalStateT, modify)
import Data.Set (Set, empty, singleton, union)
import Parser.Errors (Error (..))
import Parser.Line_and_char (L (..), Line_and_char)
import Parser.Tokeniser (Tokeniser', Tokens', current_line_and_char, get_token, take_token, tokenise, tokens_ended)
-- | The types of tokens that were expected at a certain location and the token that was actually found instead (or @Nothing@
-- if the end of file was reached unexpectedly).
data Parse_error' token = Parse_error Line_and_char (Set String) (Maybe token)
-- | A parser that works with any kind of tokens.
newtype Parser' token t = Parser {run_parser :: StateT (State token) (ExceptT (Parse_error' token) (Either Error)) t}
data State token = State {state_tokens :: Tokens' token, state_error :: Parse_error' token}
-- | Symmetric choice between two parsers that selects the longest match. Note that if both parsers successfully reach the
-- same location it will result in an ambiguity error that, unlike a normal parse error, is not recoverable by backtracking.
-- Also note that while this operator is normally associative it is not when ambiguity errors are involved.
infixr 3 <+>
(<+>) :: Eq token => Parser' token t -> Parser' token t -> Parser' token t
Parser (StateT parse_0) <+> Parser (StateT parse_1) =
Parser
(StateT
(\st ->
ExceptT
(do
(err_0, result_0) <- deconstruct_result <$> runExceptT (parse_0 st)
(err_1, result_1) <- deconstruct_result <$> runExceptT (parse_1 st)
(
construct_result (add_errors err_0 err_1) <$>
case (result_0, result_1) of
(Nothing, Nothing) -> Right Nothing
(Nothing, Just _) -> Right result_1
(Just _, Nothing) -> Right result_0
(Just (_, tokens_0), Just (_, tokens_1)) ->
case compare (current_line_and_char tokens_0) (current_line_and_char tokens_1) of
LT -> Right result_1
EQ -> Left Ambiguity
GT -> Right result_0))))
infixr 4 ===
(===) :: Eq t => t -> t -> t
x === y =
case x == y of
False -> undefined
True -> x
instance Applicative (Parser' token) where
Parser parse_0 <*> Parser parse_1 = Parser (parse_0 <*> parse_1)
pure x = Parser (return x)
instance Functor (Parser' token) where
fmap f (Parser parse') = Parser (f <$> parse')
instance Monad (Parser' token) where
Parser parse' >>= f = Parser (parse' >>= run_parser <$> f)
deriving instance Show token => Show (Parse_error' token)
deriving instance Show token => Show (State token)
-- | Parse something with an added location from the first token.
add_location :: Parser' token t -> Parser' token (L t)
add_location parse_t = L <$> parse_line_and_char <*> parse_t
add_errors :: Eq token => Parse_error' token -> Parse_error' token -> Parse_error' token
add_errors
lookahead_0 @ (Parse_error line_and_char_0 expected_0 found_token_0)
lookahead_1 @ (Parse_error line_and_char_1 expected_1 found_token_1) =
case compare line_and_char_0 line_and_char_1 of
LT -> lookahead_1
EQ -> Parse_error (line_and_char_0 === line_and_char_1) (union expected_0 expected_1) (found_token_0 === found_token_1)
GT -> lookahead_0
construct_result :: Parse_error' token -> Maybe (t, Tokens' token) -> Either (Parse_error' token) (t, State token)
construct_result err result =
case result of
Nothing -> Left err
Just (x, tokens) -> Right (x, State tokens err)
deconstruct_result :: Either (Parse_error' token) (t, State token) -> (Parse_error' token, Maybe (t, Tokens' token))
deconstruct_result result =
case result of
Left err -> (err, Nothing)
Right (x, State tokens err) -> (err, Just (x, tokens))
get_Parser :: Parser' token (State token)
get_Parser = Parser get
modify_Parser :: (State token -> State token) -> Parser' token ()
modify_Parser f = Parser (modify f)
-- | Parse the text. You have to provide a function that classifies characters, a function that tells how to update the
-- location depending on the character, a tokeniser, a parser and a function that converts parse errors to your preferred
-- type.
parse ::
(
Eq token =>
(Char -> char) ->
(char -> Line_and_char -> Line_and_char) ->
Tokeniser' char token err () ->
Parser' token t ->
(Parse_error' token -> err) ->
String ->
Either Error (Either err t))
parse classify_char next_line_and_char tokenise' parse' transform_parse_error text =
runExceptT
(do
tokens <- ExceptT (tokenise classify_char next_line_and_char tokenise' text)
withExceptT
transform_parse_error
(evalStateT
(run_parser (parse_end parse'))
(State tokens (Parse_error (current_line_and_char tokens) empty (get_token tokens)))))
-- | Parse a term in brackets.
parse_brackets :: Parser' token () -> Parser' token () -> Parser' token t -> Parser' token t
parse_brackets parse_left_bracket parse_right_bracket parse_t =
do
parse_left_bracket
x <- parse_t
parse_right_bracket
return x
parse_certain_token :: Eq token => token -> token -> Maybe ()
parse_certain_token token token' =
case token == token' of
False -> Nothing
True -> Just ()
parse_element :: Parser' token () -> Parser' token t -> Parser' token t
parse_element parse_separator parse_t =
do
parse_separator
parse_t
-- | Returns an empty list.
parse_empty_list :: Parser' token [t]
parse_empty_list = return []
parse_end :: Eq token => Parser' token t -> Parser' token t
parse_end parse_t =
do
x <- parse_t
parse_end'
return x
parse_end' :: Eq token => Parser' token ()
parse_end' =
do
tokens <- state_tokens <$> get_Parser
case tokens_ended tokens of
False -> parse_error "end of text"
True -> return ()
parse_error :: Eq token => String -> Parser' token t
parse_error expected =
do
State tokens err <- get_Parser
throwError_Parser (add_errors err (Parse_error (current_line_and_char tokens) (singleton expected) (get_token tokens)))
-- | Get the current location.
parse_line_and_char :: Parser' token Line_and_char
parse_line_and_char = current_line_and_char <$> state_tokens <$> get_Parser
-- | Parse a (possibly empty) list with separators.
parse_list :: Eq token => Parser' token () -> Parser' token t -> Parser' token [t]
parse_list parse_separator parse_t = parse_empty_list <+> parse_non_empty_list parse_separator parse_t
-- | Parse a (possibly empty) list without separators.
parse_many :: Eq token => Parser' token t -> Parser' token [t]
parse_many parse_t = parse_empty_list <+> parse_some parse_t
-- | Parse a non-empty list with separators.
parse_non_empty_list :: Eq token => Parser' token () -> Parser' token t -> Parser' token [t]
parse_non_empty_list parse_separator parse_t = (:) <$> parse_t <*> parse_many (parse_element parse_separator parse_t)
-- | Parse a non-empty list without separators.
parse_some :: Eq token => Parser' token t -> Parser' token [t]
parse_some parse_t = (:) <$> parse_t <*> parse_many parse_t
-- | Parse a certain token (for example, a delimiter or a keyword) without returning any results. You also have to provide a
-- string that briefly describes the kind of token that is expected - it is used to provide detailed parse errors.
parse_token :: Eq token => token -> String -> Parser' token ()
parse_token token = parse_token' (parse_certain_token token)
-- | Parses tokens that fit a certain pattern and transforms them into something more useful - for example, a string or an
-- integer. You also have to provide a string that briefly describes the kind of token that is expected - it is used to
-- provide detailed parse errors.
parse_token' :: Eq token => (token -> Maybe t) -> String -> Parser' token t
parse_token' f expected =
do
tokens <- state_tokens <$> get_Parser
case take_token f tokens of
Nothing -> parse_error expected
Just (x, tokens') ->
do
modify_Parser (\st -> st {state_tokens = tokens'})
return x
throwError_Parser :: Parse_error' token -> Parser' token t
throwError_Parser err = Parser (throwError err)