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