Lexer.hs

{-| Module  : FiniteCategories
Description : Lexer for parsers.
Copyright   : Guillaume Sabbagh 2021
License     : GPL-3
Maintainer  : guillaumesabbagh@protonmail.com
Stability   : experimental
Portability : portable

Lexer for parsers. The keywords are ' -', '-> ', ' = ', "#", '<ID/>', '<SRC>', '</SRC>', '<TGT>', '</TGT>', ' => '
-}
module IO.Parsers.Lexer where
    import Data.Text (Text, cons, singleton, unpack, pack)
    
    -- | A token for a scg or fscg file.
    data Token = Name Text | BeginArrow | EndArrow | Equals | Identity | BeginSrc | EndSrc | BeginTgt | EndTgt | MapsTo deriving (Eq, Show)
    
    -- | Strip a token of unnecessary spaces.
    strip :: Token -> Token
    strip (Name txt) = Name (pack.reverse.stripLeft.reverse.stripLeft $ str)
        where
            str = unpack txt
            stripLeft (' ':s) = s 
            stripLeft s = s 
    strip x = x
        
    -- | Transforms a string into a list of tokens.
    parserLex :: String -> [Token]
    parserLex str = strip <$> parserLexHelper str
        where
            parserLexHelper [] = [] 
            parserLexHelper ('#':str) = []
            parserLexHelper (' ':'-':str) = BeginArrow : (parserLexHelper str)
            parserLexHelper ('-':'>':' ':str) = EndArrow : (parserLexHelper str)
            parserLexHelper (' ':'=':' ':str) = Equals : (parserLexHelper str)
            parserLexHelper ('<':'I':'D':'/':'>':str) = Identity : (parserLexHelper str)
            parserLexHelper ('<':'S':'R':'C':'>':str) = BeginSrc : (parserLexHelper str)
            parserLexHelper ('<':'T':'G':'T':'>':str) = BeginTgt : (parserLexHelper str)
            parserLexHelper ('<':'/':'S':'R':'C':'>':str) = EndSrc : (parserLexHelper str)
            parserLexHelper ('<':'/':'T':'G':'T':'>':str) = EndTgt : (parserLexHelper str)
            parserLexHelper (' ':'=':'>':' ':str) = MapsTo : (parserLexHelper str)
            parserLexHelper (c:str) =  (result restLexed)
                where
                    restLexed = (parserLexHelper str)
                    result (Name txt:xs) = (Name (cons c txt):xs)
                    result a = ((Name (singleton c)):a)