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)
import Text.Megaparsec.Char (alphaNumChar, char, letterChar, space1, asciiChar)
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 = flip ArrayType
        <$> (symbol "array" *> bracketsP (lexeme Lexer.decimal))
        <*> (symbol "of" *> typeExpressionP)

typeDefinitionP :: Parser Declaration
typeDefinitionP = TypeDefinition
    <$> (symbol "type" *> identifierP)
    <*> (symbol "=" *> typeExpressionP)
    <?> "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)

parametersP :: Parser [Parameter]
parametersP = parensP $ sepBy parameterP (symbol ",")

literalP :: Parser Literal
literalP
    = HexadecimalLiteral <$> Lexer.hexadecimal
    <|> IntegerLiteral <$> Lexer.decimal
    <|> CharacterLiteral <$> charP
    <|> BooleanLiteral <$> (symbol "true" $> True)
    <|> BooleanLiteral <$> (symbol "false" $> False)
  where
    -- TODO: Escape characters.
    charP = fromIntegral . fromEnum
        <$> between (char '\'') (char '\'') asciiChar

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

operatorTable :: [[Operator Parser Expression]]
operatorTable =
    [ [Postfix (ArrayExpression <$> bracketsP expressionP)]
    , unaryOperator
    , factoryOperator
    , termOperator
    , comparisonOperator
    ]
  where
    unaryOperator = 
        [ prefix "-" NegationExpression
        , prefix "+" id
        ]
    factoryOperator =
        [ 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
    <|> AssignmentStatement <$> expressionP <* symbol ":=" <*> expressionP
    <|> CompoundStatement <$> blockP (many statementP)
    <?> "statement" -- TODO: further statements

procedureDefinitionP :: Parser Declaration
procedureDefinitionP = ProcedureDefinition
    <$> (procedureP *> identifierP)
    <*> parametersP
    <*> blockP (many variableDeclarationP)
    <*> pure mempty -- TODO
    <?> "procedure definition"

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

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