diff --git a/Kawaii-Parser.cabal b/Kawaii-Parser.cabal --- a/Kawaii-Parser.cabal +++ b/Kawaii-Parser.cabal @@ -1,25 +1,30 @@ -author: Liisi Kerik -build-type: Simple -cabal-version: >= 1.10 -category: Monad transformers, Parsing, Tokenisation -description: - This library provides a simple tokeniser and parser. Its main focus is not efficiency but simplicity of implementation and - use. The choice operator for parsers is symmetric, avoiding the need to think about the order in which the alternatives are - listed. The library supports adding locations to the parse tree and aims to provide reasonably detailed information about - parse errors with minimal user involvement. It also contains a module with type synonyms for some compositions of monad - transformers. -homepage: https://github.com/liisikerik/kawaii_parser -license: BSD3 -license-file: LICENSE -maintainer: liisikerik@hotmail.com -name: Kawaii-Parser -synopsis: A simple parsing library. -version: 2.0.0 -library - build-depends: base < 4.15, containers, mtl - default-language: Haskell2010 - exposed-modules: Parser.Errors, Parser.Line_and_char, Parser.Parser, Parser.Tokeniser, Parser.Transf - other-extensions: StandaloneDeriving -source-repository head - location: https://github.com/liisikerik/kawaii_parser.git +cabal-version: 3.8 +author: Liisi Kerik +category: Parsing, Tokenisation, Utilities +description: + The library provides a tiny general utilities module, and a simple combinator-based tokeniser and parser. Its main focus is + not efficiency but simplicity of implementation and use. The choice operator for parsers is symmetric, avoiding the need to + think about the order in which the alternatives are listed. The library provides error locations and supports adding locations + to the parse tree. +license: BSD-3-Clause +license-file: LICENSE +maintainer: liisikerik@hotmail.com +name: Kawaii-Parser +synopsis: A simple parsing library and some additional utilities. +version: 3.0.0 +library + build-depends: + base >= 3.0.3.1 && < 4.22, + containers >= 0.1.0.0 && < 0.9, + directory >= 1.0.0.0 && < 1.4, + generic-lens >= 0.1.0.0 && < 2.3, + lens >= 0.1 && < 5.4, + mtl >= 1.0 && < 2.4 + default-extensions: + DeriveGeneric, FlexibleInstances, MultiParamTypeClasses, OverloadedLabels, ScopedTypeVariables, StandaloneDeriving + default-language: Haskell2010 + exposed-modules: Parser.Locations, Parser.Parser, Parser.Utilities + ghc-options: -Wall +source-repository head + location: https://github.com/liisikerik/kawaii_parser.git type: git diff --git a/Parser/Errors.hs b/Parser/Errors.hs deleted file mode 100644 --- a/Parser/Errors.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE StandaloneDeriving #-} -{-| -Description: Errors. - -* Errors --} -module Parser.Errors (Error (..)) where - -- | Errors that indicate that the issue is not with the text but with incorrect use of the parsing library. - data Error = Ambiguity | Attempt_to_recover_a_filter_error | Incomplete_tokenisation - deriving instance Show Error diff --git a/Parser/Line_and_char.hs b/Parser/Line_and_char.hs deleted file mode 100644 --- a/Parser/Line_and_char.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE StandaloneDeriving #-} -{-| -Description: Locations. - -* Locations -* Writing locations --} -module Parser.Line_and_char ( - L (..), - Line_and_char, - init_line_and_char, - next_char, - next_line, - write_file_name_and_line_and_char, - write_line_and_char) where - -- | Add a location to any type. - data L t = L Line_and_char t - -- | Locations. - data Line_and_char = Line_and_char Integer Integer - deriving instance Eq Line_and_char - deriving instance Ord Line_and_char - deriving instance Show t => Show (L t) - deriving instance Show Line_and_char - -- | First line, first character. - init_line_and_char :: Line_and_char - init_line_and_char = Line_and_char 1 1 - -- | Move one character to the right. - next_char :: Line_and_char -> Line_and_char - next_char (Line_and_char line char) = Line_and_char line (1 + char) - -- | Move to the beginning of the next line. - next_line :: Line_and_char -> Line_and_char - next_line (Line_and_char line _) = Line_and_char (1 + line) 1 - -- | Write the location with the file name. - write_file_name_and_line_and_char :: String -> Line_and_char -> String - write_file_name_and_line_and_char file_name (Line_and_char line char) = file_name ++ ":" ++ show line ++ ":" ++ show char - -- | Write the location without a file name. - write_line_and_char :: Line_and_char -> String - write_line_and_char (Line_and_char line char) = show line ++ ":" ++ show char diff --git a/Parser/Locations.hs b/Parser/Locations.hs new file mode 100644 --- /dev/null +++ b/Parser/Locations.hs @@ -0,0 +1,41 @@ +{-| +Description: Locations. + +* Locations. +-} +module Parser.Locations ( + File_path_and_location (..), + Location, + With_location (..), + init_location, + next_char, + next_line, + write_file_path_and_location, + write_location) where + import Parser.Utilities + deriving instance Eq Location + deriving instance Ord Location + deriving instance Show File_path_and_location + deriving instance Show Location + deriving instance Show t => Show (With_location t) + -- | Locations with a file path. + data File_path_and_location = File_path_and_location File_path Location + -- | Locations. + data Location = Location Integer Integer + -- | Add a location to any type. + data With_location t = With_location Location t + -- | First line, first character. + init_location :: Location + init_location = Location 1 1 + -- | Move one character to the right. + next_char :: Location -> Location + next_char (Location line char) = Location line (1 + char) + -- | Move to the next line. + next_line :: Location -> Location + next_line (Location line _) = Location (1 + line) 1 + -- | Write the location with the file path. + write_file_path_and_location :: File_path -> Location -> String + write_file_path_and_location file_path location = write_file_path file_path <> ":" <> write_location location + -- | Write the location. + write_location :: Location -> String + write_location (Location line char) = show line <> ":" <> show char diff --git a/Parser/Parser.hs b/Parser/Parser.hs --- a/Parser/Parser.hs +++ b/Parser/Parser.hs @@ -1,242 +1,309 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE StandaloneDeriving #-} -{-| -Description: An unambiguous parser with symmetric choice and location tracking. - -* Parser -* Filter -* Parsing locations -* Parsing brackets -* Parsing lists --} -module Parser.Parser ( - (<+>), - Parse_error', - Parser', - add_location, - filter_Parser, - fmap_filter_Parser, - parse, - parse_brackets, - parse_empty_list, - parse_line_and_char, - parse_list, - parse_many, - parse_non_empty_list, - parse_some, - parse_token, - parse_token', - write_parse_error) where - import Control.Monad.Except (ExceptT (..), MonadError (..), runExceptT, withExceptT) - import Control.Monad.State.Strict (MonadState (..), StateT (..), evalStateT, modify) - import Data.List (intercalate) - import Data.Set (Set, elems, empty, singleton, union) - import Parser.Errors (Error (..)) - import Parser.Line_and_char (L (..), Line_and_char, write_file_name_and_line_and_char) - import Parser.Tokeniser (Tokeniser', Tokens', current_line_and_char, get_token, take_token, tokenise, tokens_ended) - data Lookahead token = Lookahead Line_and_char (Set String) (Maybe token) - -- | Parse errors. - data Parse_error' token = Filter_error Line_and_char String | Match_error (Lookahead token) - -- | A parser that works on 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_lookahead :: Lookahead token} - infixr 4 === - (===) :: Eq t => t -> t -> t - x === y = - case x == y of - False -> undefined - True -> x - -- | 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 you should not attempt to recover a filter error. While this operator is normally associative this property - -- does not hold 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 - (lookahead_0, result_0) <- runExceptT (parse_0 st) >>= deconstruct_result - (lookahead_1, result_1) <- runExceptT (parse_1 st) >>= deconstruct_result - ( - construct_result (add_lookaheads lookahead_0 lookahead_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)))) - 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 (Lookahead token) - 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_lookaheads :: Eq token => Lookahead token -> Lookahead token -> Lookahead token - add_lookaheads - (lookahead_0 @ (Lookahead line_and_char_0 expected_0 found_0)) - (lookahead_1 @ (Lookahead line_and_char_1 expected_1 found_1)) = - case compare line_and_char_0 line_and_char_1 of - LT -> lookahead_1 - EQ -> Lookahead (line_and_char_0 === line_and_char_1) (union expected_0 expected_1) (found_0 === found_1) - GT -> lookahead_0 - certain_token :: Eq token => token -> token -> Maybe () - certain_token token token' = - case token == token' of - False -> Nothing - True -> Just () - construct_result :: Lookahead token -> Maybe (t, Tokens' token) -> Either (Parse_error' token) (t, State token) - construct_result lookahead result = - case result of - Nothing -> Left (Match_error lookahead) - Just (x, tokens) -> Right (x, State tokens lookahead) - deconstruct_result :: Either (Parse_error' token) (t, State token) -> Either Error (Lookahead token, Maybe (t, Tokens' token)) - deconstruct_result result = - case result of - Left err -> - case err of - Filter_error _ _ -> Left Attempt_to_recover_a_filter_error - Match_error lookahead -> Right (lookahead, Nothing) - Right (x, State tokens lookahead) -> Right (lookahead, Just (x, tokens)) - -- | Filter the parse results - for example, restrict an integer parser to positive numbers. You also have to provide an error - -- string. Note that filter errors, unlike token matching errors, are non-recoverable. - filter_Parser :: Ord token => String -> (t -> Bool) -> Parser' token t -> Parser' token t - filter_Parser err f = - fmap_filter_Parser - err - (\x -> - case f x of - False -> Nothing - True -> Just x) - -- | Filter and transform the parse results. You also have to provide an error string. Note that filter errors, unlike token - -- matching errors, are non-recoverable. - fmap_filter_Parser :: Ord token => String -> (t -> Maybe u) -> Parser' token t -> Parser' token u - fmap_filter_Parser err f parse_t = - do - line_and_char <- parse_line_and_char - x <- parse_t - case f x of - Nothing -> Parser (throwError (Filter_error line_and_char err)) - Just y -> return y - match_error :: Eq token => String -> Parser' token t - match_error expected = - do - State tokens lookahead <- Parser get - Parser - (throwError - (Match_error - (add_lookaheads lookahead (Lookahead (current_line_and_char tokens) (singleton expected) (get_token tokens))))) - -- | 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_class) -> - (char_class -> Line_and_char -> Line_and_char) -> - Tokeniser' char_class token err () -> - Parser' token t -> - (Parse_error' token -> err) -> - String -> - Either Error (Either err t)) - parse classify_char next_line_and_char tokenise_t parse_t transform_parse_error text = - runExceptT - (do - tokens <- ExceptT (tokenise classify_char next_line_and_char tokenise_t text) - withExceptT - transform_parse_error - (evalStateT - (run_Parser (parse_end parse_t)) - (State tokens (Lookahead (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_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 <$> Parser get - case tokens_ended tokens of - False -> match_error "end of text" - True -> return () - 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 = pure [] - -- | Get the current location. - parse_line_and_char :: Parser' token Line_and_char - parse_line_and_char = current_line_and_char <$> state_tokens <$> Parser get - -- | 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' (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 <$> Parser get - case take_token f tokens of - Nothing -> match_error expected - Just (x, tokens') -> - do - Parser (modify (\st -> st {state_tokens = tokens'})) - return x - write_maybe_token :: (token -> String) -> Maybe token -> String - write_maybe_token write_token maybe_token = - case maybe_token of - Nothing -> "end of file" - Just token -> write_token token - -- | Write parse errors. You have to provide a function that converts tokens to strings and the file name. - write_parse_error :: (token -> String) -> String -> Parse_error' token -> String - write_parse_error write_token file_name err = - case err of - Filter_error line_and_char err' -> err' ++ " at " ++ write_file_name_and_line_and_char file_name line_and_char ++ "." - Match_error (Lookahead line_and_char expected found) -> - ( - "Parse error at " ++ - write_file_name_and_line_and_char file_name line_and_char ++ - ". Expected [" ++ - intercalate ", " (elems expected) ++ - "], found " ++ - write_maybe_token write_token found ++ - ".") +{-| +Description: Tokenising and parsing. + +* A combinator-based tokeniser with symmetric choice and location tracking. +* An unambiguous parser with symmetric choice and location tracking. +-} +module Parser.Parser ( + Parse_error (..), + Parser', + Tokeniser', + Usage_error (..), + (<+>), + add_location, + add_token, + filter_parser, + fmap_filter_parser, + parse', + parse_brackets, + parse_default, + parse_file_path', + parse_list, + parse_location, + parse_many, + parse_non_empty_list, + parse_not, + parse_some, + parse_token, + parse_token', + parse_with_location) where + import Control.Lens.Combinators + import Control.Lens.Operators + import Control.Monad.Except + import Control.Monad.RWS.Strict + import Data.Generics.Labels () + import GHC.Generics + import Parser.Locations + import Parser.Utilities + newtype Parser token output error t = + Parser {run_parser' :: RWST () output (Parser.Parser.State token) (ExceptT (Parse_error error) (Either Usage_error)) t} + -- | A parser that works on any kind of tokens. + type Parser' token error = Parser token () error + -- | Parse errors. + data Parse_error error = Filter_error error | Parse_error' Location + data State token = State {state_tokens :: Tokens token, state_lookahead :: Location} + -- | A tokeniser that works on any kind of custom characters and tokens. The custom character type is useful if you need to + -- classify characters before tokenisation to simplify patternmatching. + type Tokeniser' char_class token error = Parser char_class [With_location token] error + -- | A sequence of tokens with locations. For internal use in the parser. + data Tokens token = Tokens [With_location token] Location + -- | Errors that indicate that the parsing library has been used incorrectly. + data Usage_error = Ambiguity | Attempt_to_recover_a_filter_error | Filter_error_encountered_in_parse_not + -- | 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. Also note that you should not attempt to recover a filter error. This + -- operator is normally associative unless you make a mistake and write an ambiguous parser. + infixr 3 <+> + (<+>) :: Parser token output error t -> Parser token output error t -> Parser token output error t + Parser (RWST parse_0) <+> Parser (RWST parse_1) = + Parser + (RWST + (\ () st -> + ExceptT + (do + (lookahead_0, result_0) <- deconstruct_result (parse_0 () st) + (lookahead_1, result_1) <- deconstruct_result (parse_1 () st) + ( + construct_result (max lookahead_0 lookahead_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_location tokens_0) (current_location tokens_1) of + LT -> Right result_1 + EQ -> Left Ambiguity + GT -> Right result_0)))) + instance Monoid output => Applicative (Parser token output error) where + Parser parse_0 <*> Parser parse_1 = Parser (parse_0 <*> parse_1) + pure x = Parser (return x) + instance Functor (Parser token output error) where + fmap f (Parser parse_t) = Parser (f <$> parse_t) + deriving instance Generic (Parser.Parser.State token) + instance Monoid output => Monad (Parser token output error) where + Parser parse_t >>= f = Parser (parse_t >>= run_parser' <$> f) + deriving instance Show error => Show (Parse_error error) + deriving instance Show token => Show (Parser.Parser.State token) + deriving instance Show token => Show (Tokens token) + deriving instance Show Usage_error + -- | Parse with location. + add_location :: Monoid output => Parser token output error t -> Parser token output error (With_location t) + add_location parse_t = With_location <$> parse_location <*> parse_t + -- | Add the token to the output. + add_token :: Tokeniser' char_class token error token -> Tokeniser' char_class token error () + add_token tokenise = + do + location <- parse_location + token <- tokenise + Parser (tell [With_location location token]) + certain_token :: Eq token => token -> token -> Maybe () + certain_token token token' = + do + check () (token == token') + return () + construct_result :: + Location -> Maybe (t, Tokens token, output) -> Either (Parse_error error) (t, Parser.Parser.State token, output) + construct_result lookahead result = + case result of + Nothing -> Left (Parse_error' lookahead) + Just (x, tokens, output) -> Right (x, State tokens lookahead, output) + -- | Get the location of first token or, if there are none, the end of file. For internal use in the parser. + current_location :: Tokens token -> Location + current_location (Tokens tokens end_location) = + case tokens of + [] -> end_location + With_location location _ : _ -> location + deconstruct_result :: + ( + ExceptT (Parse_error error) (Either Usage_error) (t, Parser.Parser.State token, output) -> + Either Usage_error (Location, Maybe (t, Tokens token, output))) + deconstruct_result (ExceptT maybe_result) = + do + result <- maybe_result + case result of + Left err -> + case err of + Filter_error _ -> Left Attempt_to_recover_a_filter_error + Parse_error' lookahead -> Right (lookahead, Nothing) + Right (x, State tokens lookahead, output) -> Right (lookahead, Just (x, tokens, output)) + -- | Filter the parse results - for example, restrict an integer parser to positive numbers. You also have to provide an + -- error. Note that filter errors, unlike token matching errors, are non-recoverable. + filter_parser :: (Eq token, Monoid output) => + (t -> Bool) -> (Location -> error) -> Parser token output error t -> Parser token output error t + filter_parser f err = + fmap_filter_parser + (\ x -> + do + check err (f x) + Right x) + -- | Filter and transform the parse results in one operation. You also have to provide an error. Note that filter errors, + -- unlike matching errors, are non-recoverable. + fmap_filter_parser :: (Eq token, Monoid output) => + (t -> Either (Location -> error) u) -> Parser token output error t -> Parser token output error u + fmap_filter_parser f parse_t = + do + location <- parse_location + x <- parse_t + case f x of + Left err -> Parser (throwError (Filter_error (err location))) + Right y -> return y + get_tokens :: Monoid output => Parser token output error (Tokens token) + get_tokens = + do + tokens <- Parser (use #state_tokens) + Parser (#state_lookahead %= max (current_location tokens)) + return tokens + -- | Parse the text. You have to provide a function that classifies characters, a function that updates the location after + -- each character, a tokeniser, a parser and a function that converts parse errors to your preferred type. + parse' :: forall char_class token error t . + ( + (Char -> char_class) -> + (char_class -> Location -> Location) -> + Tokeniser' char_class token error () -> + Parser' token error t -> + (Location -> error) -> + String -> + Either Usage_error (Either error t)) + parse' classify_char next_location tokenise_t parse_t parse_error text = + runExceptT + (withExceptT + transform_error + (do + let (end_location, text') = execRWS (classify_chars text) () init_location + ((), tokens) <- run_parser tokenise_t (Tokens text' end_location) + fst <$> run_parser parse_t (Tokens tokens end_location))) + where + classify_chars :: String -> RWS () [With_location char_class] Location () + classify_chars text' = + case text' of + [] -> return () + c : text'' -> + do + location <- get + let char_class = classify_char c + tell [With_location location char_class] + modify (next_location char_class) + classify_chars text'' + transform_error :: Parse_error error -> error + transform_error err = + case err of + Filter_error err' -> err' + Parse_error' location -> parse_error location + -- | Parse a term in brackets. + parse_brackets :: (Eq token, Monoid output) => token -> token -> Parser token output error t -> Parser token output error t + parse_brackets left_bracket right_bracket parse_t = + do + parse_token left_bracket + x <- parse_t + parse_token right_bracket + return x + -- | Parse something optional or return the default value. + parse_default :: Monoid output => Parser token output error t -> t -> Parser token output error t + parse_default parse_t x = return x <+> parse_t + parse_directory :: + Eq token => Parser' token error [Back] -> Parser' token error String -> token -> Parser' token error Directory + parse_directory parse_back parse_name slash_token = + Directory <$> parse_back <*> parse_many (parse_one_directory parse_name slash_token) + parse_element :: (Eq token, Monoid output) => token -> Parser token output error t -> Parser token output error t + parse_element separator parse_t = + do + parse_token separator + parse_t + parse_end :: Monoid output => Parser token output error t -> Parser token output error t + parse_end parse_t = + do + x <- parse_t + parse_end' + return x + parse_end' :: Monoid output => Parser token output error () + parse_end' = + do + tokens <- get_tokens + case tokens_ended tokens of + False -> parse_error' + True -> return () + parse_error' :: Monoid output => Parser token output error t + parse_error' = + do + lookahead <- Parser (use #state_lookahead) + Parser (throwError (Parse_error' lookahead)) + -- | Parse a file path. You have to provide a parent directory counter parser, a name parser, the slash token, the dot token, + -- a function that converts strings to name tokens and the file extension. + parse_file_path' :: Eq token => + ( + Parser' token error [Back] -> + Parser' token error String -> + token -> + token -> + (String -> token) -> + String -> + Parser' token error File_path) + parse_file_path' parse_back parse_name slash_token dot_token name_token ext = + do + directory <- parse_directory parse_back parse_name slash_token + file_name <- parse_name + parse_token dot_token + parse_token (name_token ext) + return (File_path directory file_name ext) + -- | Parse a (possibly empty) list with separators. + parse_list :: (Eq token, Monoid output) => token -> Parser token output error t -> Parser token output error [t] + parse_list separator parse_t = parse_default (parse_non_empty_list separator parse_t) [] + -- | Get the current location. + parse_location :: Monoid output => Parser token output error Location + parse_location = current_location <$> Parser (use #state_tokens) + -- | Parse a (possibly empty) list without separators. + parse_many :: Monoid output => Parser token output error t -> Parser token output error [t] + parse_many parse_t = parse_default (parse_some parse_t) [] + -- | Parse a non-empty list with separators. + parse_non_empty_list :: (Eq token, Monoid output) => token -> Parser token output error t -> Parser token output error [t] + parse_non_empty_list separator parse_t = (:) <$> parse_t <*> parse_many (parse_element separator parse_t) + -- | Succeed if the parser fails. + parse_not :: Monoid output => Parser token output error t -> Parser token output error () + parse_not (Parser (RWST parse_t)) = + Parser + (RWST + (\ () st -> + ExceptT + (do + result <- runExceptT (parse_t () st) + case result of + Left err -> + case err of + Filter_error _ -> Left Filter_error_encountered_in_parse_not + Parse_error' location -> Right (Right ((), st {state_lookahead = location}, mempty)) + Right (_, State _ lookahead', _) -> Right (Left (Parse_error' lookahead'))))) + parse_one_directory :: Eq token => Parser' token error t -> token -> Parser' token error t + parse_one_directory parse_name slash_token = + do + directory <- parse_name + parse_token slash_token + return directory + -- | Parse a non-empty list without separators. + parse_some :: Monoid output => Parser token output error t -> Parser token output error [t] + parse_some parse_t = (:) <$> parse_t <*> parse_many parse_t + -- | Parse a certain token (for example, a delimiter or a keyword) without returning a result. + parse_token :: (Eq token, Monoid output) => token -> Parser token output error () + parse_token token = parse_token' (certain_token token) + -- | Parse tokens that fit a certain pattern and transform them into something more useful - for example, an int or a string. + parse_token' :: Monoid output => (token -> Maybe t) -> Parser token output error t + parse_token' f = + do + tokens <- get_tokens + case take_token f tokens of + Nothing -> parse_error' + Just (x, tokens') -> + do + Parser (#state_tokens .= tokens') + return x + -- | Parse data with location. + parse_with_location :: Monoid output => Parser token output error t -> Parser token output error (With_location t) + parse_with_location parse_t = With_location <$> parse_location <*> parse_t + run_parser :: Monoid output => + Parser token output error t -> Tokens token -> ExceptT (Parse_error error) (Either Usage_error) (t, output) + run_parser parse_t tokens = evalRWST (run_parser' (parse_end parse_t)) () (Parser.Parser.State tokens init_location) + take_token :: (token -> Maybe t) -> Tokens token -> Maybe (t, Tokens token) + take_token f (Tokens tokens end_location) = + case tokens of + [] -> Nothing + With_location _ token : tokens' -> flip (,) (Tokens tokens' end_location) <$> f token + tokens_ended :: Tokens token -> Bool + tokens_ended (Tokens tokens _) = null tokens diff --git a/Parser/Tokeniser.hs b/Parser/Tokeniser.hs deleted file mode 100644 --- a/Parser/Tokeniser.hs +++ /dev/null @@ -1,141 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE StandaloneDeriving #-} -{-| -Description: A simple state- and transition-based tokeniser with location tracking. - -* Tokeniser --} -module Parser.Tokeniser ( - Tokeniser', - Tokens', - add_token, - current_line_and_char, - delete_char, - gather_token, - get_char, - get_token, - take_token, - tokenisation_error, - tokenise, - tokens_ended) where - import Control.Monad.Except (MonadError (..)) - import Control.Monad.RWS.Strict (RWST, execRWST) - import Control.Monad.Reader (MonadReader (..)) - import Control.Monad.State.Strict (MonadState (..)) - import Control.Monad.Writer.Strict (MonadWriter (..)) - import Parser.Errors (Error (..)) - import Parser.Line_and_char (L (..), Line_and_char, init_line_and_char) - data State char_class = State {state_line_and_char :: Line_and_char, state_text :: [char_class]} - -- | A tokeniser that works with any kind of custom characters, tokens and errors. The custom character type is useful if you - -- need to classify characters according to their behavior before tokenisation - for example, wrap all operators, letters, - -- delimiters or digits in the same constructor to simplify pattern matching. - data Tokeniser' char_class token err t = - Tokeniser {run_tokeniser :: RWST (char_class -> Line_and_char -> Line_and_char) [L token] (State char_class) (Either err) t} - -- | A sequence of tokens with locations. For internal use in the parser. - data Tokens' token = Tokens [L token] Line_and_char - instance Applicative (Tokeniser' char_class token err) where - Tokeniser tokenise_0 <*> Tokeniser tokenise_1 = Tokeniser (tokenise_0 <*> tokenise_1) - pure x = Tokeniser (return x) - instance Functor (Tokeniser' char_class token err) where - fmap f (Tokeniser tokenise') = Tokeniser (f <$> tokenise') - instance Monad (Tokeniser' char_class token err) where - Tokeniser tokenise' >>= f = Tokeniser (tokenise' >>= run_tokeniser <$> f) - deriving instance Show char_class => Show (State char_class) - deriving instance Show token => Show (Tokens' token) - -- | Add the token to the output. Note that the order of adding tokens is important and you have to add the token before - -- deleting the respective characters to get the correct location. - add_token :: token -> Tokeniser' char_class token err () - add_token token = - do - line_and_char <- state_line_and_char <$> Tokeniser get - add_token' line_and_char token - add_token' :: Line_and_char -> token -> Tokeniser' char_class token err () - add_token' line_and_char token = Tokeniser (tell [L line_and_char token]) - -- | Get the location of the first token or, if there are none, the end of file. For internal use in the parser. - current_line_and_char :: Tokens' token -> Line_and_char - current_line_and_char (Tokens tokens end_line_and_char) = - case tokens of - [] -> end_line_and_char - L line_and_char _ : _ -> line_and_char - -- | Delete the first character from the remaining text. Automatically updates the location. - delete_char :: Tokeniser' char_class token err () - delete_char = - do - next_line_and_char <- Tokeniser ask - State line_and_char text <- Tokeniser get - case text of - [] -> return () - char_class : text' -> Tokeniser (put (State (next_line_and_char char_class line_and_char) text')) - -- | Add a token that consists of several characters - for example, an operator, a word or a number. You have to provide a - -- function that recognises suitable characters and a function that transforms the resulting string into a token. - gather_token :: (char_class -> Maybe Char) -> (String -> token) -> Tokeniser' char_class token err () - gather_token recognise_char string_to_token = - do - line_and_char <- state_line_and_char <$> Tokeniser get - token <- gather_token' recognise_char - add_token' line_and_char (string_to_token token) - gather_token' :: (char_class -> Maybe Char) -> Tokeniser' char_class token err String - gather_token' recognise_char = - let - f = gather_token' recognise_char - in - do - maybe_char_class <- get_char 0 - case maybe_char_class >>= recognise_char of - Nothing -> return "" - Just char -> - do - delete_char - token <- f - return (char : token) - -- | Take a look at a character without deleting it. Returns @Nothing@ if the index is negative or if the remaining text is - -- too short. - get_char :: Int -> Tokeniser' char_class token err (Maybe char_class) - get_char i = - do - text <- state_text <$> Tokeniser get - return - (case 0 <= i && i < length text of - False -> Nothing - True -> Just (text !! i)) - -- | Get the first token without deleting it. For internal use in the parser. - get_token :: Tokens' token -> Maybe token - get_token (Tokens tokens _) = - case tokens of - [] -> Nothing - L _ token : _ -> Just token - -- | Recognises tokens that fit a certain pattern and transforms them into something more useful - for example, a string or an - -- integer. Returns @Nothing@ if the first token does not fit the pattern, and returns the transformed token and the rest of - -- the sequence if it does fit. For internal use in the parser. - take_token :: (token -> Maybe t) -> Tokens' token -> Maybe (t, Tokens' token) - take_token f (Tokens tokens end_line_and_char) = - case tokens of - [] -> Nothing - L _ token : tokens' -> - do - x <- f token - return (x, Tokens tokens' end_line_and_char) - -- | Throw a tokenisation error at the current location. - tokenisation_error :: (Line_and_char -> err) -> Tokeniser' char_class token err t - tokenisation_error err = - do - line_and_char <- state_line_and_char <$> Tokeniser get - Tokeniser (throwError (err line_and_char)) - -- | Tokenise the text. For internal use in the parser. - tokenise :: - ( - (Char -> char_class) -> - (char_class -> Line_and_char -> Line_and_char) -> - Tokeniser' char_class token err () -> - String -> - Either Error (Either err (Tokens' token))) - tokenise classify_char next_line_and_char (Tokeniser tokenise') text = - case execRWST tokenise' next_line_and_char (State init_line_and_char (classify_char <$> text)) of - Left err -> Right (Left err) - Right (State line_and_char text', tokens) -> - case text' of - [] -> Right (Right (Tokens tokens line_and_char)) - _ -> Left Incomplete_tokenisation - -- | Check whether the sequence of tokens has ended. For internal use in the parser. - tokens_ended :: Tokens' token -> Bool - tokens_ended (Tokens tokens _) = null tokens diff --git a/Parser/Transf.hs b/Parser/Transf.hs deleted file mode 100644 --- a/Parser/Transf.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-| -Description: Type synonyms and run functions for pairwise compositions of reader, writer and state transformers. - -* RST -* RWT -* WST --} -module Parser.Transf (RST, RWT, WST, evalRST, evalWST, execRST, execRWT, execWST, runRST, runRWT, runWST) where - import Control.Monad.RWS.Strict (RWST (..)) - -- | The composition of reader and state transformers. - type RST env = RWST env () - -- | The composition of reader and writer transformers. - type RWT env res = RWST env res () - -- | The composition of writer and state transformers. - type WST = RWST () - -- | Discards the end state. - evalRST :: Functor f => RST env state f t -> env -> state -> f t - evalRST (RWST f) env st = (\(x, _, _) -> x) <$> f env st - -- | Discards the end state. - evalWST :: Functor f => WST res state f t -> state -> f (t, res) - evalWST (RWST f) st = (\(x, _, res) -> (x, res)) <$> f () st - -- | Discards the output. - execRST :: Functor f => RST env state f t -> env -> state -> f state - execRST (RWST f) env st = (\(_, st', _) -> st') <$> f env st - -- | Discards the output. - execRWT :: Functor f => RWT env res f t -> env -> f res - execRWT (RWST f) env = (\(_, (), res) -> res) <$> f env () - -- | Discards the output. - execWST :: Functor f => WST res state f t -> state -> f (state, res) - execWST (RWST f) st = (\(_, st', res) -> (st', res)) <$> f () st - -- | Runs the RS transformer. - runRST :: Functor f => RST env state f t -> env -> state -> f (t, state) - runRST (RWST f) env st = (\(x, st', ()) -> (x, st')) <$> f env st - -- | Runs the RW transformer. - runRWT :: Functor f => RWT env res f t -> env -> f (t, res) - runRWT (RWST f) env = (\(x, (), res) -> (x, res)) <$> f env () - -- | Runs the WS transformer. - runWST :: WST res state f t -> state -> f (t, state, res) - runWST (RWST f) = f () diff --git a/Parser/Utilities.hs b/Parser/Utilities.hs new file mode 100644 --- /dev/null +++ b/Parser/Utilities.hs @@ -0,0 +1,131 @@ +{-| +Description: Assorted utilities. + +* Assorted utilities. +* Relative directories and file paths. +-} +module Parser.Utilities ( + Back (..), + Directory (..), + File_path (..), + (<->), + (), + all_equal, + between, + check, + check_ext, + construct_map, + construct_set, + drop_file_name, + element_at, + lcm_all, + read_file, + swap_either, + write_file_path) where + import Control.Monad.Except + import Data.Foldable as Foldable + import Data.List as List + import Data.Map as Map + import Data.Set as Set + import System.Directory + -- | Parent directory. + data Back = Back + -- | Relative directory. + data Directory = Directory [Back] [String] + -- | Relative file path. + data File_path = File_path Directory String String + -- | Concatenate strings with a whitespace in between. + infixr 5 <-> + (<->) :: String -> String -> String + s <-> t = s <> " " <> t + -- | Prepend a directory to file path. + infixr 6 + () :: Directory -> File_path -> File_path + directory_0 File_path directory_1 file_name ext = File_path (directory_0 <> directory_1) file_name ext + deriving instance Eq Back + deriving instance Eq Directory + deriving instance Eq File_path + instance Monoid Directory where + mempty = Directory [] [] + deriving instance Ord Back + deriving instance Ord Directory + deriving instance Ord File_path + instance Semigroup Directory where + Directory back_0 directories_0 <> Directory back_1 directories_1 = + case (Foldable.length directories_0, Foldable.length back_1) of + (0, 0) -> Directory back_0 directories_1 + (0, _) -> Directory (back_0 <> back_1) directories_1 + (_, 0) -> Directory back_0 (directories_0 <> directories_1) + (_, _) -> Directory back_0 (init directories_0) <> Directory (List.drop 1 back_1) directories_1 + deriving instance Show Back + deriving instance Show Directory + deriving instance Show File_path + -- | Checks if all elements of a list are equal. Returns @Nothing@ if all elements aren't equal, @Just Nothing@ if the list is + -- empty and @Just (Just x)@ if all elements are equal to @x@. + all_equal :: Eq t => [t] -> Maybe (Maybe t) + all_equal x = + case x of + [] -> Just Nothing + y : x' -> + do + check () (all ((==) y) x') + Just (Just y) + -- | Check if the value is in bounds. + between :: Ord t => t -> t -> t -> Bool + between lowest highest x = lowest <= x && highest >= x + -- | Throw an error if the condition is not satisfied. + check :: MonadError error f => error -> Bool -> f () + check err condition = + case condition of + False -> throwError err + True -> return () + -- | Check file path extension. + check_ext :: String -> File_path -> Bool + check_ext ext (File_path _ _ ext') = ext == ext' + -- | Construct a map if all keys are different. Otherwise return @Nothing@. + construct_map :: Ord t => [(t, u)] -> Maybe (Map t u) + construct_map x = + do + let y = Map.fromList x + check () (Foldable.length x == Map.size y) + Just y + -- | Construct a set if all elements are different. Otherwise return @Nothing@. + construct_set :: Ord t => [t] -> Maybe (Set t) + construct_set x = + do + let y = Set.fromList x + check () (Foldable.length x == Set.size y) + Just y + -- | Get the directory part of a file path. + drop_file_name :: File_path -> Directory + drop_file_name (File_path directory _ _) = directory + -- | Safe list indexation. + element_at :: Int -> [t] -> Maybe t + element_at j x = + do + check () (between 0 (Foldable.length x - 1) j) + return (x !! j) + -- | Aggregate least common denominator. + lcm_all :: (Foldable f, Integral t) => f t -> t + lcm_all = Foldable.foldr lcm 1 + -- | Read a file. + read_file :: File_path -> IO (Maybe String) + read_file file_path = + do + let file_path' = write_file_path file_path + pathExists <- doesPathExist file_path' + case pathExists of + False -> return Nothing + True -> Just <$> readFile file_path' + -- | Swap Left and Right. + swap_either :: Either t u -> Either u t + swap_either x = + case x of + Left y -> Right y + Right y -> Left y + write_back :: Back -> String + write_back Back = ".." + -- | Convert a file path to text. + write_file_path :: File_path -> FilePath + write_file_path (File_path (Directory back directories) file_name ext) = + intercalate "/" ((write_back <$> back) <> directories <> [file_name <> "." <> ext])