Skip to content
Permalink
master
Switch branches/tags
Go to file
 
 
Cannot retrieve contributors at this time
module Microc.Parser.Combinator
( programP
, runParser
, errorBundlePretty
)
where
import Microc.Ast
import Microc.Scanner.Combinator
import Text.Megaparsec
import Control.Monad.Combinators.Expr
import Control.Applicative ( liftA2
, liftA3
)
import Data.Either
opTable :: [[Operator Parser Expr]]
opTable =
[ [ InfixL $ Access <$ symbol "."
, InfixL $ (\lhs rhs -> Access (Deref lhs) rhs) <$ symbol "->"
]
, [ unary (Unop Neg) "-"
, unary (Unop Not) "!"
, unary Deref "*"
, unary Addr "&"
, Prefix (try $ Cast <$> (parens typeP))
]
, [infixR Power "**"]
, [infixL Mult "*", infixL Div "/"]
, [infixL Add "+", infixL Sub "-"]
, [infixL Leq "<=", infixL Geq ">=", infixL Less "<", infixL Greater ">"]
, [infixL' Equal "==", infixL Neq "!="]
, [infixL' BitAnd "&"]
, [infixL' BitOr "|"]
, [infixL' And "&&"]
, [infixL' Or "||"]
, [InfixR $ Assign <$ symbol "="]
]
where
-- Megaparsec doesn't support multiple prefix operators by default,
-- but we need this in order to parse things like double negatives,
-- nots, and dereferences
unary op sym = Prefix $ foldr1 (.) <$> some (op <$ symbol sym)
infixL op sym = InfixL $ Binop op <$ symbol sym
-- Primed infixL' is useful for operators which are prefixes of other operators
infixL' op sym = InfixL $ Binop op <$ operator sym
infixR op sym = InfixR $ Binop op <$ symbol sym
operator sym = lexeme $ try (symbol sym <* notFollowedBy opChar)
opChar = oneOf ("!#$%&*+./<=>?@\\^|-~" :: String)
termP :: Parser Expr
termP = parens exprP
<|> Null <$ rword "NULL"
<|> try (Fliteral <$> float)
<|> Literal <$> int
<|> BoolLit <$> (True <$ rword "true" <|> False <$ rword "false")
<|> Sizeof <$> (rword "sizeof" *> parens typeP)
<|> try (Call <$> identifier <*> parens (exprP `sepBy` comma))
<|> CharLit <$> charlit
<|> StrLit <$> strlit
<|> Id <$> identifier
exprP :: Parser Expr
exprP = makeExprParser termP opTable
structP :: Parser Struct
structP = Struct <$> (rword "struct" *> identifier) <*> braces (many vdeclP) <* semi
typeP :: Parser Type
typeP = do
baseType <- TyInt <$ rword "int"
<|> TyBool <$ rword "bool"
<|> TyFloat <$ rword "float"
<|> TyChar <$ rword "char"
<|> TyVoid <$ rword "void"
<|> TyStruct <$> (rword "struct" *> identifier)
foldr (const Pointer) baseType <$> many star
vdeclP :: Parser Bind
vdeclP = Bind <$> typeP <*> identifier <* semi
statementP :: Parser Statement
statementP = Expr <$> exprP <* semi
<|> Return <$> (rword "return" *> exprMaybe <* semi)
<|> Block <$> braces (many statementP)
<|> ifP
<|> forP
<|> whileP
exprMaybe :: Parser Expr
exprMaybe = option Noexpr exprP
ifP :: Parser Statement
ifP = liftA3 If (rword "if" *> parens exprP) statementP maybeElse
where maybeElse = option (Block []) (rword "else" *> statementP)
forP :: Parser Statement
forP = do
rword "for"
(e1, e2, e3) <- parens
$ liftA3 (,,) (exprMaybe <* semi) (exprP <* semi) exprMaybe
For e1 e2 e3 <$> statementP
whileP :: Parser Statement
whileP = liftA2 While (rword "while" *> parens exprP) statementP
fdeclP :: Parser Function
fdeclP = Function <$> typeP <*> identifier <*> formalsP
<*> (symbol "{" *> many vdeclP)
<*> (many statementP <* symbol "}")
formalsP :: Parser [Bind]
formalsP = parens $ formalP `sepBy` comma
where formalP = liftA2 Bind typeP identifier
programP :: Parser Program
programP = between sc eof $ do
structsOrGlobals <- many $ try (Left <$> structP) <|> (Right <$> try vdeclP)
let structs = lefts structsOrGlobals
globals = rights structsOrGlobals
Program structs globals <$> many fdeclP