Tokenizer.hs

module Tokenizer where

import System.IO
import Control.Monad
import Text.ParserCombinators.Parsec
import Text.ParserCombinators.Parsec.Expr
import Text.ParserCombinators.Parsec.Language
import qualified Text.ParserCombinators.Parsec.Token as Token
import StringParse

data PHPValue = PHPString String
              | PHPInt Integer
              | PHPFloat Double
              | PHPBool Bool
              | PHPNull
              deriving (Show)

data PHPVariable = PHPVariable String | PHPVariableVariable String deriving (Show)
data FunctionCall = FunctionCall String | FunctionCallVar PHPVariable deriving (Show)

data PHPExpr = Literal PHPValue
             | Variable PHPVariable
             | Assign PHPVariable PHPExpr
             | Neg PHPExpr
             | Not PHPExpr
             | BinaryExpr BinOp PHPExpr PHPExpr
             | UnaryExpr UnaryType UnaryOp PHPVariable
             | Call FunctionCall [PHPExpr]
             | Isset [PHPVariable]
             | Print PHPExpr
             deriving (Show)

data UnaryType = Before | After deriving (Show)
data UnaryOp = Increment | Decrement deriving (Show)

mkUnaryOp :: String -> UnaryOp
mkUnaryOp "++" = Increment
mkUnaryOp "--" = Decrement
mkUnaryOp _ = error "Invalid unary op"

data BinOp = Add | Subtract | Multiply | Divide | Modulo | And | Or | Greater | Less | Equals | StrictEquals | Concat deriving (Show)

data ElseExpr = Else PHPStmt
              | ElseIf PHPExpr PHPStmt (Maybe ElseExpr)
              deriving (Show)

data FunctionArgumentDef = FunctionArgumentDef { argName :: String
                                               , argDefault :: Maybe PHPValue
                                               }
                                               deriving (Show)

data ParseResult = PlainText String | PHPCode PHPStmt deriving (Show)

data StaticVar = StaticVar String (Maybe PHPValue) deriving (Show)

data PHPStmt = Seq [PHPStmt]
             | Expression PHPExpr
             | If PHPExpr PHPStmt (Maybe ElseExpr)
             | Function String [FunctionArgumentDef] PHPStmt
             | Return PHPExpr
             | While PHPExpr PHPStmt
             | For [PHPExpr] [PHPExpr] [PHPExpr] PHPStmt
             | Echo [PHPExpr]
             | Global PHPVariable
             | Static [StaticVar]
             deriving (Show)


langDef = emptyDef { Token.commentStart = "/*"
                   , Token.commentEnd = "*/"
                   , Token.commentLine = "//"
                   , Token.identStart = letter
                   , Token.identLetter = alphaNum <|> char '_'
                   , Token.reservedNames = [ "if", "else", "elseif", "while", "break", "do", "for", "continue"
                                           , "true", "false", "null", "and", "or", "class", "function", "return"
                                           , "<?php", "?>", "echo", "print"
                                           ]
                   , Token.reservedOpNames = [ "=", "==", "===", "->", ".", "+", "-", "*", "/", "%", "<", ">"
                                             , "and", "or", "||", "&&", "!", "++", "--" 
                                             ]
                   }

lexer = Token.makeTokenParser langDef

phpString = stringLit lexer '"' <|> stringLit lexer '\''

identifier = Token.identifier lexer
reserved = Token.reserved lexer
float = Token.float lexer
stringTok = phpString
reservedOp = (Token.lexeme lexer) . string
parens = Token.parens lexer
braces = Token.braces lexer
integer = Token.integer lexer
semi = Token.semi lexer
whiteSpace = Token.whiteSpace lexer

whileParser :: Parser [ParseResult]
whileParser = many (parsePHPCode <|> parsePlainText)

phpEof = try $ do
    optional $ char '\n'
    eof

parsePlainText :: Parser ParseResult
parsePlainText = liftM PlainText $ do
    c <- anyChar
    har <- manyTill anyChar ((lookAhead $ reserved "<?php") <|> phpEof)
    return (c : har)

parsePHPCode :: Parser ParseResult
parsePHPCode = do
    reserved "<?php"
    seq <- sequenceOfStmt
    (optional $ string "?>") <|> phpEof
    return $ PHPCode seq

sequenceOfStmt = do
    list <- many1 oneStatement
    return $ Seq list

statementZeroOrMore = liftM Seq $ many oneStatement

statementZeroOrOne = liftM Seq $ option [] (liftM (:[]) oneStatement)

-- Match a valid PHP end of statement.
-- Must have ; after expression, unless closing tag
-- ?> comes immediately after
phpEnd = semi <|> try (string "?>")

-- Parse a single PHP statement
oneStatement :: Parser PHPStmt
oneStatement = ifStmt
            <|> functionStmt
            <|> returnStmt
            <|> whileStmt
            <|> forStmt
            <|> echoStmt
            <|> globalStmt
            <|> staticStmt
            <|> stmtExpr
    -- Special case for an expression that's a statement
    -- Expressions can be used without a semicolon in the end in ifs or whatever, 
    -- but a valid statement expression needs a semi in the end
    where stmtExpr = do
              expr <- phpExpression
              phpEnd
              return $ Expression expr

staticStmt :: Parser PHPStmt
staticStmt = do
        stmt <- reserved "static" >> (liftM Static $ sepBy staticArg (Token.symbol lexer ","))
        semi
        return stmt
    where staticArg = do
                char '$'
                name <- identifier
                defValue <- optionMaybe $ do
                    Token.symbol lexer "="
                    phpValue

                return $ StaticVar name defValue

globalStmt :: Parser PHPStmt
globalStmt = do
    global <- reserved "global" >> liftM Global plainVariableExpr
    semi
    return global

echoStmt :: Parser PHPStmt
echoStmt = do
        reserved "echo"
        -- echo take one arg only if parens are used, otherwise 1 or more
        args <- (liftM (:[]) $ parens phpExpression) <|> argList
        phpEnd
        return $ Echo args
    where argList = sepBy phpExpression (Token.symbol lexer ",")

returnStmt :: Parser PHPStmt
returnStmt = do
    reserved "return" 
    ret <- liftM Return phpExpression
    phpEnd
    return $ ret

functionStmt :: Parser PHPStmt
functionStmt = do
        reserved "function"
        name <- identifier
        argDefs <- parens $ sepBy argDefExpr (optional (Token.symbol lexer ","))
        body <- braces statementZeroOrMore
        return $ Function name argDefs body
    where
        argDefExpr = do
            char '$'
            name <- identifier
            defValue <- optionMaybe $ do
                Token.symbol lexer "="
                phpValue

            return $ FunctionArgumentDef name defValue

whileStmt :: Parser PHPStmt
whileStmt = do
    reserved "while"
    cond <- parens phpExpression
    stmt <- (braces statementZeroOrMore) <|> oneStatement
    return $ While cond stmt

forStmt :: Parser PHPStmt
forStmt = do
    reserved "for"
    (init, cond, iter) <- parens $ do
        minit <- sepBy phpExpression (Token.symbol lexer ",")
        semi
        mcond <- sepBy phpExpression (Token.symbol lexer ",")
        semi
        miter <- sepBy phpExpression (Token.symbol lexer ",")
        return (minit, mcond, miter)
    body <- (braces statementZeroOrMore) <|> do { s <- statementZeroOrOne; semi; return s }
    return $ For init cond iter body

ifStmt :: Parser PHPStmt
ifStmt = do
    reserved "if"
    cond <- parens phpExpression
    stmt1 <- (braces statementZeroOrMore) <|> oneStatement
    cont <- optionMaybe (elseIfStmt <|> elseStmt)
    return $ If cond stmt1 cont

elseStmt :: Parser ElseExpr
elseStmt = do
    reserved "else"
    stmt <- (braces statementZeroOrMore) <|> oneStatement
    return $ Else stmt

elseIfStmt :: Parser ElseExpr
elseIfStmt = do
    reserved "elseif"
    cond <- parens phpExpression
    stmt <- (braces statementZeroOrMore) <|> oneStatement
    cont <- optionMaybe (elseIfStmt <|> elseStmt)
    return $ ElseIf cond stmt cont

assignExpr :: Parser PHPExpr
assignExpr = do
    var <- plainVariableExpr
    reservedOp "="
    expr <- phpExpression
    return $ Assign var expr

plainVariableExpr :: Parser PHPVariable
plainVariableExpr = try varVarExpr <|> normalVariableExpr
    where
        varVarExpr = char '$' >> char '$' >> fmap PHPVariableVariable identifier

normalVariableExpr :: Parser PHPVariable
normalVariableExpr = char '$' >> fmap PHPVariable identifier

phpExpression :: Parser PHPExpr
phpExpression = buildExpressionParser phpOperators phpTerm

phpOperators = [ [Infix (reservedOp "*" >> return (BinaryExpr Multiply)) AssocLeft]
               , [Infix (reservedOp "/" >> return (BinaryExpr Divide)) AssocLeft]
               , [Infix (reservedOp "+" >> return (BinaryExpr Add)) AssocLeft]
               , [Infix (reservedOp "-" >> return (BinaryExpr Subtract)) AssocLeft]
               , [Infix (reservedOp "." >> return (BinaryExpr Concat)) AssocLeft]
               , [Infix (reservedOp "==" >> return (BinaryExpr Equals)) AssocLeft]
               , [Infix (reservedOp "===" >> return (BinaryExpr StrictEquals)) AssocLeft]
               , [Prefix (reservedOp "!" >> return (Not))]
               , [Infix (reservedOp "&&" >> return (BinaryExpr And)) AssocLeft]
               , [Infix (reservedOp "||" >> return (BinaryExpr Or)) AssocLeft]
               , [Infix (reservedOp "<" >> return (BinaryExpr Less)) AssocLeft]
               , [Infix (reservedOp ">" >> return (BinaryExpr Greater)) AssocLeft]
               ]

phpTerm = parens phpExpression
       <|> try issetExpr
       <|> try printExpr
       <|> try functionCallExpr
       <|> try assignExpr
       <|> variableExpr
       <|> liftM Literal phpValue

issetExpr :: Parser PHPExpr
issetExpr = do
    reserved "isset"
    vars <- parens $ sepBy1 plainVariableExpr (Token.symbol lexer ",")
    return $ Isset vars

variableExpr :: Parser PHPExpr
variableExpr = do
        prefixOp <- unaryOp
        var <- plainVariableExpr
        case prefixOp of
          Just op -> return $ UnaryExpr Before (mkUnaryOp op) var
          Nothing -> do
              postOp <- unaryOp
              case postOp of
                Nothing -> return $ Variable var
                Just op -> return $ UnaryExpr After (mkUnaryOp op) var
    where
        unaryOp = optionMaybe (try (reservedOp "++") <|> try (reservedOp "--"))

functionCallExpr :: Parser PHPExpr
functionCallExpr = try varCall <|> nameCall
    where
        varCall = do
            var <- plainVariableExpr
            args <- parens argList
            return $ Call (FunctionCallVar var) args
        nameCall = do
            name <- identifier
            args <- parens argList
            return $ Call (FunctionCall name) args
        argList = sepBy phpExpression (Token.symbol lexer ",")

printExpr :: Parser PHPExpr
printExpr = do
        reserved "print"
        arg <- parens phpExpression <|> phpExpression
        return $ Print arg

phpValue :: Parser PHPValue
phpValue = (reserved "true" >> return (PHPBool True))
        <|> (reserved "false" >> return (PHPBool False))
        <|> (reserved "null" >> return PHPNull)
        <|> (Token.naturalOrFloat lexer >>= return . either PHPInt PHPFloat)
        <|> (stringTok >>= return . PHPString)

parseString :: String -> [ParseResult]
parseString str = case parse whileParser "" str of
                    Left e -> error $ show e
                    Right r -> case last r of
                                 PlainText "\n" -> init r
                                 _              -> r