Kawaii-Parser-2.0.0: Parser/Tokeniser.hs

{-# 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