147 lines
4.6 KiB
Haskell
147 lines
4.6 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module Windows12.Parser (programP) where
|
|
|
|
import Control.Monad (void)
|
|
import Control.Monad.Combinators.Expr
|
|
import Data.Text (Text)
|
|
import Text.Megaparsec
|
|
import Windows12.Ast
|
|
import Windows12.Ast (Expr (UnOp))
|
|
import Windows12.Lexer
|
|
|
|
opTable :: [[Operator Parser Expr]]
|
|
opTable =
|
|
[ [ InfixL $ Member <$ symbol ".",
|
|
InfixL $ (\l r -> Member (UnOp Deref l) r) <$ symbol "->",
|
|
Postfix $ Index <$> (symbol "[" *> exprP <* symbol "]")
|
|
],
|
|
[ Prefix (UnOp Neg <$ symbol "-"),
|
|
Prefix (UnOp Not <$ symbol "!"),
|
|
Prefix (UnOp BitNot <$ symbol "~"),
|
|
Prefix (UnOp Deref <$ symbol "*"),
|
|
Prefix (UnOp AddrOf <$ symbol "&")
|
|
],
|
|
[ InfixL (BinOp Mul <$ symbol "*"),
|
|
InfixL (BinOp Div <$ symbol "/"),
|
|
InfixL (BinOp Mod <$ symbol "%")
|
|
],
|
|
[ InfixL (BinOp Add <$ symbol "+"),
|
|
InfixL (BinOp Sub <$ symbol "-")
|
|
],
|
|
[ InfixL (BinOp ShiftL <$ symbol "<<"),
|
|
InfixL (BinOp ShiftR <$ symbol ">>")
|
|
],
|
|
[ InfixL (BinOp Lt <$ symbol "<"),
|
|
InfixL (BinOp Gt <$ symbol ">"),
|
|
InfixL (BinOp Le <$ symbol "<="),
|
|
InfixL (BinOp Ge <$ symbol ">=")
|
|
],
|
|
[ InfixL (BinOp Eq <$ symbol "=="),
|
|
InfixL (BinOp Ne <$ symbol "!=")
|
|
],
|
|
[ InfixL (BinOp BitAnd <$ symbol "&")
|
|
],
|
|
[ InfixL (BinOp BitXor <$ symbol "^")
|
|
],
|
|
[ InfixL (BinOp BitOr <$ symbol "|")
|
|
],
|
|
[ InfixL (BinOp And <$ symbol "&&")
|
|
],
|
|
[ InfixL (BinOp Or <$ symbol "||")
|
|
]
|
|
]
|
|
|
|
termP :: Parser Expr
|
|
termP =
|
|
parens exprP
|
|
<|> IntLit <$> intLiteral
|
|
<|> UIntLit <$> uintLiteral
|
|
<|> try (FloatLit <$> floatLiteral)
|
|
<|> StrLit <$> stringLiteral
|
|
<|> BoolLit <$> (reserved "true" *> pure True <|> reserved "false" *> pure False)
|
|
<|> CharLit <$> charLiteral
|
|
<|> try (Sizeof <$> (reserved "sizeof" *> typeP))
|
|
<|> try (Cast <$> (reserved "cast" *> typeP) <*> parens exprP)
|
|
<|> try (Call <$> identifier <*> parens (sepBy exprP (symbol ",")))
|
|
<|> try (StructInit <$> identifier <*> braces (sepEndBy1 ((,) <$> identifier <* symbol ":" <*> exprP) (symbol ",")))
|
|
<|> Id <$> identifier
|
|
|
|
exprP :: Parser Expr
|
|
exprP = makeExprParser termP opTable
|
|
|
|
structP :: Parser TLStruct
|
|
structP = do
|
|
reserved "struct"
|
|
name <- identifier
|
|
fields <- braces (sepEndBy (Bind <$> identifier <* symbol ":" <*> typeP) (symbol ","))
|
|
return $ Struct name fields
|
|
|
|
typeP :: Parser Type
|
|
typeP = do
|
|
t <-
|
|
ArrayType <$> (brackets typeP)
|
|
<|> IntType <$ reserved "int"
|
|
<|> UIntType <$ reserved "uint"
|
|
<|> FloatType <$ reserved "float"
|
|
<|> StrType <$ reserved "str"
|
|
<|> BoolType <$ reserved "bool"
|
|
<|> CharType <$ reserved "char"
|
|
<|> StructType <$> identifier
|
|
foldr (const PtrType) t <$> many (symbol "*")
|
|
|
|
stmtP :: Parser Stmt
|
|
stmtP =
|
|
Return <$> (reserved "return" *> exprP <* symbol ";")
|
|
<|> (If <$> (reserved "if" *> parens exprP) <*> stmtP <*> optional (reserved "else" *> stmtP))
|
|
<|> (While <$> (reserved "while" *> parens exprP) <*> stmtP)
|
|
<|> ( For
|
|
<$> (reserved "for" *> symbol "(" *> optional stmtP <* symbol ";")
|
|
<*> (optional exprP <* symbol ";")
|
|
<*> (optional exprP <* symbol ")")
|
|
<*> stmtP
|
|
)
|
|
<|> (Var <$> (reserved "var" *> (Bind <$> identifier <* symbol ":" <*> typeP)) <* symbol "=" <*> exprP <* symbol ";")
|
|
<|> (Assign <$> exprP <* symbol "=" <*> exprP <* symbol ";")
|
|
|
|
-- <|> Block <$> braces (many stmtP)
|
|
|
|
funcP :: Parser TLFunc
|
|
funcP = do
|
|
reserved "fn"
|
|
name <- identifier
|
|
args <- parens (sepBy (Bind <$> identifier <* symbol ":" <*> typeP) (symbol ","))
|
|
retType <- (symbol "->" *> typeP) <|> pure VoidType
|
|
body <- braces (many stmtP)
|
|
return $ Func name args retType body
|
|
|
|
enumP :: Parser TLEnum
|
|
enumP = do
|
|
reserved "enum"
|
|
name <- identifier
|
|
fields <- braces (sepEndBy1 identifier (symbol ","))
|
|
return $ Enum name fields
|
|
|
|
memberFuncP :: Parser TLMemberFunc
|
|
memberFuncP = do
|
|
reserved "fn"
|
|
reserved "on"
|
|
self <- typeP
|
|
name <- identifier
|
|
args <- parens (sepBy (Bind <$> identifier <* symbol ":" <*> typeP) (symbol ","))
|
|
retType <- (symbol "->" *> typeP) <|> pure VoidType
|
|
body <- braces (many stmtP)
|
|
return $ MemberFunc self name args retType body
|
|
|
|
organize :: [TL] -> Program
|
|
organize tls = Program structs enums funcs memberFuncs
|
|
where
|
|
structs = [s | TLStruct s <- tls]
|
|
enums = [e | TLEnum e <- tls]
|
|
funcs = [f | TLFunc f <- tls]
|
|
memberFuncs = [mf | TLMemberFunc mf <- tls]
|
|
|
|
programP :: Parser Program
|
|
programP = between sc eof $ do
|
|
tls <- many (TLStruct <$> structP <|> TLEnum <$> enumP <|> TLMemberFunc <$> memberFuncP <|> TLFunc <$> funcP)
|
|
return $ organize tls |