elna/lib/Language/Elna/Parser.hs

module Language.Elna.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.AST
    ( Declaration(..)
    , Expression(..)
    , Identifier(..)
    , Literal(..)
    , Parameter(..)
    , Program(..)
    , Statement(..)
    , TypeExpression(..)
    , VariableDeclaration(..)
    )
import Text.Megaparsec
    ( Parsec
    , (<?>)
    , optional
    , between
    , sepBy
    , choice
    , MonadParsec(..)
    )
import Text.Megaparsec.Char
    ( alphaNumChar
    , char
    , letterChar
    , space1
    , string
    )
import qualified Text.Megaparsec.Char.Lexer as Lexer
import Control.Applicative (Alternative(..))
import Data.Maybe (isJust)
import Data.Functor (($>))

type Parser = Parsec Void Text

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

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

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

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

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

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 ":"

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

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

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

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

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

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

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

literalP :: Parser Literal
literalP
    = HexadecimalLiteral <$> (string "0x" *> lexeme Lexer.hexadecimal)
    <|> IntegerLiteral <$> lexeme Lexer.decimal
    <|> CharacterLiteral <$> lexeme charP
    <|> BooleanLiteral <$> (symbol "true" $> True)
    <|> BooleanLiteral <$> (symbol "false" $> False)
  where
    charP = fromIntegral . fromEnum
        <$> between (char '\'') (char '\'') Lexer.charLiteral

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

operatorTable :: [[Operator Parser Expression]]
operatorTable =
    [ [Postfix (flip ArrayExpression <$> bracketsP expressionP)]
    , unaryOperator
    , factorOperator
    , termOperator
    , comparisonOperator
    ]
  where
    unaryOperator = 
        [ prefix "-" NegationExpression
        , prefix "+" id
        ]
    factorOperator =
        [ binary "*" ProductExpression
        , binary "/" DivisionExpression
        ]
    termOperator =
        [ binary "+" SumExpression
        , binary "-" SubtractionExpression
        ]
    comparisonOperator =
        [ binary "<" LessExpression
        , binary "<=" LessOrEqualExpression
        , binary ">" GreaterExpression
        , binary ">=" GreaterOrEqualExpression
        , binary "=" EqualExpression
        , binary "#" NonEqualExpression
        ]
    prefix name f = Prefix (f <$ symbol name)
    binary name f = InfixL (f <$ symbol name)

expressionP :: Parser Expression
expressionP = makeExprParser termP operatorTable

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

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

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

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