elna/lib/Language/Elna/Frontend/Parser.hs

module Language.Elna.Frontend.Parser
    ( Parser
    , programP
    ) where

import Control.Monad (void)
import Control.Monad.Combinators.Expr (Operator(..), makeExprParser)
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Void (Void)
import Language.Elna.Frontend.AST
    ( Declaration(..)
    , Identifier(..)
    , Parameter(..)
    , Program(..)
    , Statement(..)
    , TypeExpression(..)
    , VariableDeclaration(..)
    , VariableAccess(..)
    , Condition(..)
    , Expression(..)
    , Literal(..)
    )
import Text.Megaparsec
    ( Parsec
    , (<?>)
    , MonadParsec(..)
    , eof
    , optional
    , between
    , sepBy
    , choice
    )
import qualified Text.Megaparsec.Char.Lexer as Lexer
import Text.Megaparsec.Char
    ( alphaNumChar
    , char
    , letterChar
    , space1
    , string
    )
import Control.Applicative (Alternative(..))
import Data.Maybe (isJust)

type Parser = Parsec Void Text

literalP :: Parser Literal
literalP
    = HexadecimalLiteral <$> Lexer.signed space hexadecimalP
    <|> DecimalLiteral <$> Lexer.signed space decimalP
    <|> CharacterLiteral <$> lexeme charP
  where
    charP = fromIntegral . fromEnum
        <$> between (char '\'') (char '\'') Lexer.charLiteral

typeDefinitionP :: Parser Declaration
typeDefinitionP = TypeDefinition
    <$> (symbol "type" *> identifierP)
    <*> (symbol "=" *> typeExpressionP)
    <* semicolonP
    <?> "type definition"

termP :: Parser Expression
termP = choice
    [ parensP expressionP
    , LiteralExpression <$> literalP
    , VariableExpression <$> variableAccessP
    ]

operatorTable :: [[Operator Parser Expression]]
operatorTable =
    [ unaryOperator
    , factorOperator
    , termOperator
    ]
  where
    unaryOperator =
        [ prefix "-" NegationExpression
        , prefix "+" id
        ]
    factorOperator =
        [ binary "*" ProductExpression
        , binary "/" DivisionExpression
        ]
    termOperator =
        [ binary "+" SumExpression
        , binary "-" SubtractionExpression
        ]
    prefix name f = Prefix (f <$ symbol name)
    binary name f = InfixL (f <$ symbol name)

expressionP :: Parser Expression
expressionP = makeExprParser termP operatorTable

variableAccessP :: Parser VariableAccess
variableAccessP = VariableAccess <$> identifierP {- do
    identifier <- identifierP
    indices <- many $ bracketsP expressionP
    pure $ foldr (flip ArrayAccess) (VariableAccess identifier) indices -}

conditionP :: Parser Condition
conditionP = do
    lhs <- expressionP
    conditionCons <- choice comparisonOperator
    conditionCons lhs <$> expressionP
  where
    comparisonOperator =
        [ symbol "<=" >> pure LessOrEqualCondition
        , symbol "<" >> pure LessCondition
        , symbol ">=" >> pure GreaterOrEqualCondition
        , symbol ">" >> pure GreaterCondition
        , symbol "=" >> pure EqualCondition
        , symbol "#" >> pure NonEqualCondition
        ]

symbol :: Text -> Parser Text
symbol = Lexer.symbol space

space :: Parser ()
space = Lexer.space space1 (Lexer.skipLineComment "//")
    $ Lexer.skipBlockComment "/*" "*/"

lexeme :: forall a. Parser a -> Parser a
lexeme = Lexer.lexeme space

blockP :: forall a. Parser a -> Parser a
blockP = between (symbol "{") (symbol "}")

parensP :: forall a. Parser a -> Parser a
parensP = between (symbol "(")  (symbol ")")

bracketsP :: forall a. Parser a -> Parser a
bracketsP = between (symbol "[") (symbol "]")

colonP :: Parser ()
colonP = void $ symbol ":"

commaP :: Parser ()
commaP = void $ symbol ","

semicolonP :: Parser ()
semicolonP = void $ symbol ";"

decimalP :: Integral a => Parser a
decimalP = lexeme Lexer.decimal

hexadecimalP :: Integral a => Parser a
hexadecimalP = string "0x" *> lexeme Lexer.hexadecimal

identifierP :: Parser Identifier
identifierP =
    let wordParser = (:) <$> letterChar <*> many alphaNumChar <?> "identifier"
     in fmap Identifier $ lexeme $ Text.pack <$> wordParser

procedureP :: Parser ()
procedureP = void $ symbol "proc"

parameterP :: Parser Parameter
parameterP = paramCons
    <$> optional (symbol "ref")
    <*> identifierP
    <*> (colonP *> typeExpressionP)
  where
    paramCons ref name typeName = Parameter name typeName (isJust ref)

typeExpressionP :: Parser TypeExpression
typeExpressionP = arrayTypeExpression
    <|> NamedType <$> identifierP
    <?> "type expression"
  where
    arrayTypeExpression = ArrayType
        <$> (symbol "array" *> bracketsP literalP)
        <*> (symbol "of" *> typeExpressionP)

procedureDeclarationP :: Parser Declaration
procedureDeclarationP = procedureCons
    <$> (procedureP *> identifierP)
    <*> parensP (sepBy parameterP commaP)
    <*> blockP ((,) <$> many variableDeclarationP <*> many statementP)
    <?> "procedure definition"
  where
    procedureCons procedureName parameters (variables, body) =
        ProcedureDeclaration procedureName parameters variables body

statementP :: Parser Statement
statementP
    = EmptyStatement <$ semicolonP
    <|> ifElseP
    <|> CompoundStatement <$> blockP (many statementP)
    <|> try assignmentP
    -- <|> try whileP
    <|> callP
    <?> "statement"
  where
    callP = CallStatement
        <$> identifierP
        <*> parensP (sepBy expressionP commaP)
        <* semicolonP
    ifElseP = IfStatement
        <$> (symbol "if" *> parensP conditionP)
        <*> statementP
        <*> optional (symbol "else" *> statementP)
    {-whileP = WhileStatement
        <$> (symbol "while" *> parensP conditionP)
        <*> statementP -}
    assignmentP = AssignmentStatement
        <$> variableAccessP
        <* symbol ":="
        <*> expressionP
        <* semicolonP

variableDeclarationP :: Parser VariableDeclaration
variableDeclarationP = VariableDeclaration
    <$> (symbol "var" *> identifierP)
    <*> (colonP *> typeExpressionP)
    <* semicolonP
    <?> "variable declaration"

declarationP :: Parser Declaration
declarationP = procedureDeclarationP <|> typeDefinitionP

programP :: Parser Program
programP = Program <$> many declarationP <* eof