{-|
Module      : Hlex
Description : Lexer creation tools
Copyright   : (c) Sebastian Tee, 2023
License     : MIT

Tools needed to create a 'Lexer' from a lexical 'Grammar'.
-}
module Hlex
     ( -- * Example
       -- $example

       -- * Types
       Grammar
     , GrammarRule(..)
     , Lexer
       -- ** Exceptions
     , LexException(..)
       -- * Functions
     , hlex
     ) where

import Text.Regex.TDFA ((=~))
import Data.Maybe (maybeToList)

-- | Exception thrown when a 'Lexer' encounters an error when lexxing a string.
data LexException 
  = UnmatchedException -- ^ Exception thrown when a substring cannot be matched.
    Int -- ^ The line number where the substring that couldn't be lexed is located.
    Int -- ^ The column where the substring that couldn't be lexed is located.
    String -- ^ The subtring that couldn't be lexed.
  | MatchedException -- ^ Exception thrown when a macth is found on the 'Error' 'GrammarRule'.
    Int -- ^ The line number where the matched string is located.
    Int -- ^ The column where the matched string is located.
    String -- ^ The matched string.
    String -- ^ Error message.
  deriving(ReadPrec [LexException]
ReadPrec LexException
Int -> ReadS LexException
ReadS [LexException]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [LexException]
$creadListPrec :: ReadPrec [LexException]
readPrec :: ReadPrec LexException
$creadPrec :: ReadPrec LexException
readList :: ReadS [LexException]
$creadList :: ReadS [LexException]
readsPrec :: Int -> ReadS LexException
$creadsPrec :: Int -> ReadS LexException
Read, Int -> LexException -> ShowS
[LexException] -> ShowS
LexException -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LexException] -> ShowS
$cshowList :: [LexException] -> ShowS
show :: LexException -> String
$cshow :: LexException -> String
showsPrec :: Int -> LexException -> ShowS
$cshowsPrec :: Int -> LexException -> ShowS
Show, LexException -> LexException -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LexException -> LexException -> Bool
$c/= :: LexException -> LexException -> Bool
== :: LexException -> LexException -> Bool
$c== :: LexException -> LexException -> Bool
Eq)

-- | These are the individual rules that make up a 'Grammar'.
--
-- Takes a __POSIX regular expression__ then converts it to a token or skips it.
data GrammarRule token
  = Skip -- ^ Skips over any matches.
    String -- ^ Regular expression.
  | Tokenize -- ^ Takes a function that converts the matched string to a token.
    String -- ^ Regular expression.
    (String -> token) -- ^ Function that converts the matched string into a token.
  | JustToken -- ^ Converts any regular expression matches to a given token.
    String -- ^ Regular expression.
    token -- ^ Given token.
  | Error -- ^ Returns an error with a message when a match occurs.
    String -- ^ Regular expression.
    String -- ^ Error message.

-- | Lexical grammar made up of 'GrammarRule's.
--
-- The __order is important__. The 'Lexer' will apply each 'GrammarRule' rule in the order listed.
type Grammar token = [GrammarRule token]

-- | Converts a string into a list of tokens.
-- If the string does not follow the Lexer's 'Grammar' a 'LexException' will be returned.
type Lexer token = String -> Either LexException [token]

-- | Takes a given 'Grammar' and turns it into a 'Lexer'.
hlex :: Grammar token -> Lexer token
hlex :: forall token. Grammar token -> Lexer token
hlex = forall token. Int -> Int -> Grammar token -> Lexer token
hlex' Int
1 Int
1

hlex' :: Int -> Int -> Grammar token -> Lexer token
hlex' :: forall token. Int -> Int -> Grammar token -> Lexer token
hlex' Int
_ Int
_ Grammar token
_ [] = forall a b. b -> Either a b
Right []
hlex' Int
row Int
col tzss :: Grammar token
tzss@(GrammarRule token
tz:Grammar token
tzs) String
program =
  if forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
matchedText
  then forall token. Int -> Int -> Grammar token -> Lexer token
hlex' Int
row Int
col Grammar token
tzs String
program
  else case GrammarRule token
tz of
    Error String
_ String
errMessage -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Int -> Int -> String -> String -> LexException
MatchedException (Int -> Int -> String -> (Int, Int)
getLastCharPos Int
row Int
col String
beforeProgram) String
matchedText String
errMessage
    Skip String
_ -> Maybe token -> Either LexException [token]
lexCont forall a. Maybe a
Nothing
    Tokenize String
_ String -> token
f -> Maybe token -> Either LexException [token]
lexCont forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ String -> token
f String
matchedText
    JustToken String
_ token
token -> Maybe token -> Either LexException [token]
lexCont forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just token
token
  where
    (String
beforeProgram, String
matchedText, String
afterProgram) = String
program forall source source1 target.
(RegexMaker Regex CompOption ExecOption source,
 RegexContext Regex source1 target) =>
source1 -> source -> target
=~ forall token. GrammarRule token -> String
getRegex GrammarRule token
tz :: (String, String, String)
    lexCont :: Maybe token -> Either LexException [token]
lexCont Maybe token
t = do
      [token]
before <- forall token. Int -> Int -> Grammar token -> Lexer token
hlex' Int
row Int
col Grammar token
tzs String
beforeProgram
      [token]
after <- forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall token. Int -> Int -> Grammar token -> Lexer token
hlex' (Int -> Int -> String -> (Int, Int)
getLastCharPos Int
row Int
col (String
beforeProgram forall a. [a] -> [a] -> [a]
++ String
matchedText)) Grammar token
tzss String
afterProgram
      forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ [token]
before forall a. [a] -> [a] -> [a]
++ forall a. Maybe a -> [a]
maybeToList Maybe token
t forall a. [a] -> [a] -> [a]
++ [token]
after
hlex' Int
row Int
col Grammar token
_ String
invalidString = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Int -> Int -> String -> LexException
UnmatchedException Int
row Int
col String
invalidString

getLastCharPos :: Int -> Int -> String -> (Int, Int)
getLastCharPos :: Int -> Int -> String -> (Int, Int)
getLastCharPos Int
startRow Int
startCol String
x = (Int
startRow forall a. Num a => a -> a -> a
+ Int
addRow, Int
addCol forall a. Num a => a -> a -> a
+ if Int
addRow forall a. Eq a => a -> a -> Bool
== Int
0 then Int
startCol else Int
1)
  where
    ls :: [String]
ls = String -> [String]
lines String
x
    addRow :: Int
addRow = forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
ls forall a. Num a => a -> a -> a
- Int
1
    addCol :: Int
addCol = forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
last [String]
ls

getRegex :: GrammarRule token -> String
getRegex :: forall token. GrammarRule token -> String
getRegex (Skip String
regex) = String
regex
getRegex (Tokenize String
regex String -> token
_) = String
regex
getRegex (JustToken String
regex token
_) = String
regex
getRegex (Error String
regex String
_) = String
regex

{- $example
Here is an example module for a simple language.

@
  module ExampleLang
       ( MyToken(..) -- Export the language's tokens and the lexer
       , myLexer
       ) where

  import Hlex

  data MyToken = Ident String -- String identifier token
               | Number Float -- Number token and numeric value
               | Assign       -- Assignment operator token
               deriving(Show)

  myGrammar :: Grammar MyToken
  myGrammar = [ Error "\"[^\"]*\n" "Can't have a new line in a string"        -- Return Exception when a new line occurs in a string
              , Tokenize "\"[^\"]*\"" $ Str . init . tail                     -- Encode string and strip the containing quotes
              , JustToken "=" Assign                                       -- "=" Operator becomes the assign token
              , Tokenize "[a-zA-Z]+" (\match -> Ident match)                -- Identifier token with string
              , Tokenize "[0-9]+(\\.[0-9]+)?" (\match -> Number (read match) -- Number token with the parsed numeric value stored as a Float
              , Skip "[ \\n\\r\\t]+"                                          -- Skip whitespace
              ]

  myLexer :: Lexer MyToken
  myLexer = hlex myGrammar -- hlex turns a Grammar into a Lexer
@

Here is the lexer being used on a simple program.

>>> lexer "x = 1.2"
Right [Ident "x", Assign, Number 1.2]

Here is the lexer being used on an program with a syntax error.

>>> lexer "x = \"a\nb\""
Left (MatchedException 1 5 "\"a\n" "Can't have a new line in a string")

The lexer uses 'Either'. Right means the lexer successfully parsed the program to a list of MyTokens.
If Left was returned it would be a 'LexException'.
-}