Tokenizer.hs

-- | Finds and tokenizes BASIC keywords, in preparation for parsing. This allows
-- keywords to be read even if there are no spaces around them. Even though
-- the standard disallows it, many BASIC implementations allowed this to save
-- memory or screen real estate. The down side is that longer variable names
-- are not practical, since they might contain keywords.

module Language.VintageBasic.Tokenizer
    (Token(..),TokenizedLine,isDataTok,isRemTok,charTokTest,taggedCharToksToString,isStringTok,
     isBuiltinTok,taggedTokensP,tokenP,printToken) where

import Data.Char(toLower,toUpper)
import Language.VintageBasic.Builtins(Builtin,builtinToStrAssoc)
import Language.VintageBasic.LexCommon
import Text.ParserCombinators.Parsec

type TokenizedLine = Tagged [Tagged Token]

-- | Parses one or more whitespace characters, producing a space token.
spaceTokP :: Parser Token
spaceTokP = whiteSpaceChar >> whiteSpace >> return SpaceTok

data Token = StringTok { getStringTokString :: String } | RemTok { getRemTokString :: String }
           | DataTok { getDataTokString :: String }
           | CommaTok | ColonTok | SemiTok | LParenTok | RParenTok
           | DollarTok | PercentTok
           | EqTok | NETok | LETok | LTTok | GETok | GTTok
           | PlusTok | MinusTok | MulTok | DivTok | PowTok
           | AndTok | OrTok | NotTok
           | BuiltinTok Builtin
           | LetTok | DimTok | OnTok | GoTok | SubTok | ReturnTok
           | IfTok | ThenTok | ForTok | ToTok | StepTok | NextTok
           | PrintTok | InputTok | RandomizeTok | ReadTok | RestoreTok
           | DefTok | FnTok | EndTok | StopTok
           | SpaceTok | DotTok | CharTok { getCharTokChar :: Char }
             deriving (Eq,Show)

caseInsensitiveChar :: Char -> Parser Char
caseInsensitiveChar c = char (toLower c) <|> char (toUpper c)

keyword :: String -> Parser String
keyword s = try (mapM caseInsensitiveChar s) <?> ("keyword " ++ s)

stringTokP :: Parser Token
-- no special escape chars allowed
stringTokP =
    do _ <- char '"'
       s <- manyTill anyChar (char '"')
       whiteSpace
       return (StringTok s)

isStringTok :: Token -> Bool
isStringTok (StringTok _) = True
isStringTok _ = False

remTokP :: Parser Token
remTokP = do _ <- keyword "REM"
             s <- many anyChar
             return (RemTok s)

isRemTok :: Token -> Bool
isRemTok (RemTok _) = True
isRemTok _ = False

dataTokP :: Parser Token
dataTokP =
    do _ <- keyword "DATA"
       s <- many anyChar
       return (DataTok s)

isDataTok :: Token -> Bool
isDataTok (DataTok _) = True
isDataTok _ = False

charTokP :: Parser Token
charTokP = do c <- legalChar; return (CharTok (toUpper c))

charTokTest :: (Char -> Bool) -> Token -> Bool
charTokTest f (CharTok c) = f c
charTokTest _ _ = False

taggedCharToksToString :: [Tagged Token] -> String
taggedCharToksToString = map (getCharTokChar . getTaggedVal)

strToTokAssoc :: [(String, Token)]
strToTokAssoc =
    [
     (",",         CommaTok),
     (":",         ColonTok),
     (";",         SemiTok),
     ("(",         LParenTok),
     (")",         RParenTok),
     ("$",         DollarTok),
     ("%",         PercentTok),
     ("=",         EqTok),
     ("<>",        NETok),
     ("<=",        LETok),
     ("<",         LTTok),
     (">=",        GETok),
     (">",         GTTok),
     ("+",         PlusTok),
     ("-",         MinusTok),
     ("*",         MulTok),
     ("/",         DivTok),
     ("^",         PowTok),
     (".",         DotTok),
     ("AND",       AndTok),
     ("OR",        OrTok),
     ("NOT",       NotTok),
     ("LET",       LetTok),
     ("DIM",       DimTok),
     ("ON",        OnTok),
     ("GO",        GoTok),
     ("SUB",       SubTok),
     ("RETURN",    ReturnTok),
     ("IF",        IfTok),
     ("THEN",      ThenTok),
     ("FOR",       ForTok),
     ("TO",        ToTok),
     ("STEP",      StepTok),
     ("NEXT",      NextTok),
     ("PRINT",     PrintTok),
     ("?",         PrintTok),
     ("INPUT",     InputTok),
     ("RANDOMIZE", RandomizeTok),
     ("READ",      ReadTok),
     ("RESTORE",   RestoreTok),
     ("DEF",       DefTok),
     ("FN",        FnTok),
     ("END",       EndTok),
     ("STOP",      StopTok)
  ] ++ [(s, BuiltinTok b) | (b,s) <- builtinToStrAssoc]

tokToStrAssoc :: [(Token, String)]
tokToStrAssoc = [(t,s) | (s,t) <- strToTokAssoc]

anyTokP :: Parser Token
anyTokP = choice ([spaceTokP, stringTokP, remTokP, dataTokP]
                  ++ [do _ <- keyword s; whiteSpace; return t | (s,t) <- strToTokAssoc]
                  ++ [charTokP]) <?> "LEGAL BASIC CHARACTER"

isBuiltinTok :: Token -> Bool
isBuiltinTok (BuiltinTok _) = True
isBuiltinTok _              = False

taggedTokenP :: Parser (Tagged Token)
taggedTokenP =
    do pos <- getPosition
       tok <- anyTokP
       return (Tagged pos tok)

-- | The main parser used to read a series of tokens from a string.
taggedTokensP :: Parser [Tagged Token]
taggedTokensP =
    do toks <- many taggedTokenP
       eof <?> ""
       return toks

-- | The single-token parser used at the parser level
tokenP :: (Token -> Bool) -> GenParser (Tagged Token) () (Tagged Token)
tokenP test = token (printToken . getTaggedVal) getPosTag testTaggedToken
    where testTaggedToken (Tagged pos tok) =
            if test tok then Just (Tagged pos tok) else Nothing

-- | Prettyprint a token for error reporting or debugging.
printToken :: Token -> String
printToken tok =
    case (lookup tok tokToStrAssoc) of
        (Just s) -> s
        Nothing ->
            case tok of
                (CharTok c) -> [c]
                (DataTok s) -> "DATA" ++ s
                (RemTok s) -> "REM" ++ s
                SpaceTok -> " "
                (StringTok s) -> "\"" ++ s ++ "\""
                _ -> error "printToken: unrecognized token."