packages feed

Kawaii-Parser (empty) → 0.0.0

raw patch · 7 files changed

+481/−0 lines, 7 filesdep +basedep +containersdep +mtl

Dependencies added: base, containers, mtl

Files

+ Kawaii-Parser.cabal view
@@ -0,0 +1,25 @@+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: 0.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
+  type: git
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2020, Liisi Kerik
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Liisi Kerik nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Parser/Errors.hs view
@@ -0,0 +1,11 @@+{-# OPTIONS_GHC -Wall #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-|
+Description: Errors for the tokeniser and the parser
+
+* Errors for the tokeniser and the parser
+-}
+module Parser.Errors (Error (..)) where
+  -- | Tokenisation and parsing errors that indicate not an issue with the text but a user error.
+  data Error = Ambiguity | Incomplete_tokenisation
+  deriving instance Show Error
+ Parser/Line_and_char.hs view
@@ -0,0 +1,29 @@+{-# OPTIONS_GHC -Wall #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-|
+Description: Locations of elements in a text file
+
+* Locations of elements in a text file
+* Writing locations
+-}
+module Parser.Line_and_char (L (..), Line_and_char, init_line_and_char, next_char, next_line, write_line_and_char) where
+  -- | Add a location to any type.
+  data L t = L Line_and_char t
+  -- | The location of an element in a text file.
+  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 a colon between line and character number.
+  write_line_and_char :: Line_and_char -> String
+  write_line_and_char (Line_and_char line char) = show line ++ ":" ++ show char
+ Parser/Parser.hs view
@@ -0,0 +1,196 @@+{-# 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)
+ Parser/Tokeniser.hs view
@@ -0,0 +1,150 @@+{-# OPTIONS_GHC -Wall #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-|
+Description: A simple state- and transition-based tokeniser with location tracking
+
+* Tokeniser
+* A data structure representing a sequence of tokens, for internal use in the parser
+-}
+module Parser.Tokeniser (
+  Tokeniser',
+  Tokens',
+  add_token,
+  current_line_and_char,
+  delete_char,
+  gather_token,
+  get_char,
+  get_line_and_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 = State {state_line_and_char :: Line_and_char, state_text :: [char]}
+  -- | A tokeniser that works with any kind of custom characters, tokens and errors. The custom character type is necessary
+  -- if you want 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 token err t =
+    Tokeniser {run_tokeniser :: RWST (char -> Line_and_char -> Line_and_char) [L token] (State char) (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 token err) where
+    Tokeniser tokenise_0 <*> Tokeniser tokenise_1 = Tokeniser (tokenise_0 <*> tokenise_1)
+    pure x = Tokeniser (return x)
+  instance Functor (Tokeniser' char token err) where
+    fmap f (Tokeniser tokenise') = Tokeniser (f <$> tokenise')
+  instance Monad (Tokeniser' char token err) where
+    Tokeniser tokenise' >>= f = Tokeniser (tokenise' >>= run_tokeniser <$> f)
+  deriving instance Show char => Show (State char)
+  deriving instance Show token => Show (Tokens' token)
+  -- | Add the token to the output. Note that the order of adding tokens is important.
+  add_token :: Line_and_char -> token -> Tokeniser' char token err ()
+  add_token line_and_char token = tell_Tokeniser [L line_and_char token]
+  ask_Tokeniser :: Tokeniser' char token err (char -> Line_and_char -> Line_and_char)
+  ask_Tokeniser = Tokeniser ask
+  -- | 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 token err ()
+  delete_char =
+    do
+      next_line_and_char <- ask_Tokeniser
+      State line_and_char text <- get_Tokeniser
+      case text of
+        [] -> return ()
+        char : text' -> put_Tokeniser (State (next_line_and_char char line_and_char) text')
+  -- | Add a token that consists of several characters - for example, an operator, a word or a natural 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 -> Maybe Char) -> (String -> token) -> Tokeniser' char token err ()
+  gather_token recognise_char string_to_token =
+    do
+      line_and_char <- get_line_and_char
+      token <- gather_token' recognise_char
+      add_token line_and_char (string_to_token token)
+  gather_token' :: (char -> Maybe Char) -> Tokeniser' char token err String
+  gather_token' recognise_char =
+    let
+      f = gather_token' recognise_char
+    in
+      do
+        maybe_char <- get_char 0
+        case maybe_char >>= recognise_char of
+          Nothing -> return ""
+          Just char ->
+            do
+              delete_char
+              token <- f
+              return (char : token)
+  get_Tokeniser :: Tokeniser' char token err (State char)
+  get_Tokeniser = Tokeniser get
+  -- | 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 token err (Maybe char)
+  get_char i =
+    do
+      text <- state_text <$> get_Tokeniser
+      return
+        (case 0 <= i && i < length text of
+          False -> Nothing
+          True -> Just (text !! i))
+  -- | Get the current location of the tokeniser.
+  get_line_and_char :: Tokeniser' char token err Line_and_char
+  get_line_and_char = state_line_and_char <$> get_Tokeniser
+  -- | 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
+  put_Tokeniser :: State char -> Tokeniser' char token err ()
+  put_Tokeniser st = Tokeniser (put st)
+  -- | 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)
+  tell_Tokeniser :: [L token] -> Tokeniser' char token err ()
+  tell_Tokeniser tokens = Tokeniser (tell tokens)
+  throwError_Tokeniser :: err -> Tokeniser' char token err t
+  throwError_Tokeniser err = Tokeniser (throwError err)
+  -- | Throw a tokenisation error at the current location.
+  tokenisation_error :: (Line_and_char -> err) -> Tokeniser' char token err t
+  tokenisation_error err =
+    do
+      line_and_char <- get_line_and_char
+      throwError_Tokeniser (err line_and_char)
+  -- | Tokenise the text. For internal use in the parser.
+  tokenise ::
+    (
+      (Char -> char) ->
+      (char -> Line_and_char -> Line_and_char) ->
+      Tokeniser' char 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
+ Parser/Transf.hs view
@@ -0,0 +1,40 @@+{-# 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 ()