module Language.Qux.Annotated.Parser (
Parser, ParseError, SourcePos,
sourceName, sourceLine, sourceColumn,
parse,
program, decl, stmt, expr, value, type_
) where
import Control.Monad.State
import Control.Monad.Trans.Except
import Language.Qux.Annotated.Syntax
import Language.Qux.Lexer
import Text.Parsec hiding (State, parse)
import Text.Parsec.Expr
import Text.Parsec.Indent
type Parser a = ParsecT String () (State SourcePos) a
parse :: Parser a -> SourceName -> String -> Except ParseError a
parse parser sourceName input = except $ runIndent sourceName (runParserT parser () sourceName input)
id_ :: Parser (Id SourcePos)
id_ = Id <$> getPosition <*> identifier <?> "identifier"
program :: Parser (Program SourcePos)
program = do
pos <- getPosition
whiteSpace
checkIndent
decls <- block decl
eof
return $ Program pos decls
decl :: Parser (Decl SourcePos)
decl = do
pos <- getPosition
name <- id_
symbol "::"
parameters <- (try $ (,) <$> type_ <*> id_) `endBy` rightArrow
returnType <- type_
colon
indented
stmts <- block stmt
return $ FunctionDecl pos name (parameters ++ [(returnType, Id pos "@")]) stmts
<?> "function declaration"
stmt :: Parser (Stmt SourcePos)
stmt = choice [
ifStmt,
returnStmt,
whileStmt
] <?> "statement"
where
ifStmt = do
pos <- getPosition
reserved "if"
condition <- expr
colon
indented
trueStmts <- block stmt
falseStmts <- option [] (checkIndent >> withBlock' (do { reserved "else"; colon }) stmt)
return $ IfStmt pos condition trueStmts falseStmts
returnStmt = ReturnStmt <$> getPosition <* reserved "return" <*> expr
whileStmt = do
pos <- getPosition
withBlock (WhileStmt pos) (reserved "while" *> expr <* colon) stmt
expr :: Parser (Expr SourcePos)
expr = buildExpressionParser table (try application <|> term) <?> "expression"
application :: Parser (Expr SourcePos)
application = ApplicationExpr <$> getPosition <*> id_ <*> many (sameOrIndented >> term)
term :: Parser (Expr SourcePos)
term = getPosition >>= \pos -> choice [
parens expr,
ApplicationExpr pos <$> id_ <*> return [],
ListExpr pos <$> brackets (expr `sepEndBy` comma),
UnaryExpr pos Len <$> pipes expr,
ValueExpr pos <$> value
]
table :: OperatorTable String () (State SourcePos) (Expr SourcePos)
table = [
[
Prefix (unaryExpr Neg "-")
],
[
Infix (binaryExpr Acc "!!") AssocLeft
],
[
Infix (binaryExpr Mul "*") AssocLeft,
Infix (binaryExpr Div "/") AssocLeft,
Infix (binaryExpr Mod "%") AssocLeft
],
[
Infix (binaryExpr Add "+") AssocLeft,
Infix (binaryExpr Sub "-") AssocLeft
],
[
Infix (binaryExpr Lte "<=") AssocLeft,
Infix (binaryExpr Lt "<") AssocLeft,
Infix (binaryExpr Gte ">=") AssocLeft,
Infix (binaryExpr Gt ">") AssocLeft
],
[
Infix (binaryExpr Eq "==") AssocLeft,
Infix (binaryExpr Neq "!=") AssocLeft
]
]
binaryExpr :: BinaryOp -> String -> Parser ((Expr SourcePos) -> (Expr SourcePos) -> (Expr SourcePos))
binaryExpr op sym = getPosition >>= \pos -> BinaryExpr pos op <$ operator sym
unaryExpr :: UnaryOp -> String -> Parser ((Expr SourcePos) -> (Expr SourcePos))
unaryExpr op sym = getPosition >>= \pos -> UnaryExpr pos op <$ operator sym
value :: Parser Value
value = choice [
BoolValue False <$ reserved "false",
BoolValue True <$ reserved "true",
IntValue <$> natural,
NilValue <$ reserved "nil"
] <?> "value"
type_ :: Parser (Type SourcePos)
type_ = getPosition >>= \pos -> choice [
BoolType pos <$ reserved "Bool",
IntType pos <$ reserved "Int",
ListType pos <$> brackets type_,
NilType pos <$ reserved "Nil"
] <?> "type"