diff --git a/src/Main.hs b/src/Main.hs index 60ffc72..3be7626 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -3,10 +3,13 @@ module Main where import qualified Data.Text.IO as T -import Text.Megaparsec (parseTest) +import Prettyprinter +import Text.Megaparsec (parse) import Windows12.Parser (programP) main :: IO () main = do test <- T.readFile "test/hello.w12" - parseTest programP test + case parse programP "test/hello.w12" test of + Left err -> print err + Right ast -> print (pretty ast) diff --git a/src/Windows12/Ast.hs b/src/Windows12/Ast.hs index a2651ed..ad64f53 100644 --- a/src/Windows12/Ast.hs +++ b/src/Windows12/Ast.hs @@ -1,6 +1,9 @@ +{-# LANGUAGE OverloadedStrings #-} + module Windows12.Ast where import Data.Text (Text) +import Prettyprinter data BinOp = Add @@ -31,6 +34,20 @@ data UnOp | AddrOf deriving (Show, Eq) +data AssignOp + = BaseAssign + | AddAssign + | SubAssign + | MulAssign + | DivAssign + | ModAssign + | BitAndAssign + | BitOrAssign + | BitXorAssign + | ShiftLAssign + | ShiftRAssign + deriving (Show, Eq) + data Expr = Id Text | IntLit Int @@ -41,7 +58,7 @@ data Expr | CharLit Char | BinOp BinOp Expr Expr | UnOp UnOp Expr - | Call Text [Expr] + | Call Expr [Expr] | Index Expr Expr | Member Expr Expr | Cast Type Expr @@ -52,12 +69,11 @@ data Expr data Stmt = Expr Expr | Return Expr - | If Expr Stmt (Maybe Stmt) - | While Expr Stmt - | For (Maybe Stmt) (Maybe Expr) (Maybe Expr) Stmt - | Assign Expr Expr + | If Expr [Stmt] (Maybe [Stmt]) + | While Expr [Stmt] + | Assign AssignOp Expr Expr | Block [Stmt] - | Var Bind Expr + | Var Text (Maybe Type) (Maybe Expr) deriving (Show, Eq) data Type @@ -86,11 +102,112 @@ data TLEnum = Enum {enumName :: Text, enumFields :: [Text]} data TLFunc = Func {funcName :: Text, funcArgs :: [Bind], funcRetType :: Type, funcBody :: [Stmt]} deriving (Show, Eq) -data TLMemberFunc = MemberFunc {memberFuncSelf :: Type, memberFuncName :: Text, memberFuncArgs :: [Bind], memberFuncRetType :: Type, memberFuncBody :: [Stmt]} +data TL = TLStruct TLStruct | TLEnum TLEnum | TLFunc TLFunc deriving (Show, Eq) -data TL = TLStruct TLStruct | TLEnum TLEnum | TLFunc TLFunc | TLMemberFunc TLMemberFunc +data Program = Program [TLStruct] [TLEnum] [TLFunc] deriving (Show, Eq) -data Program = Program [TLStruct] [TLEnum] [TLFunc] [TLMemberFunc] - deriving (Show, Eq) \ No newline at end of file +-- Pretty printing +instance Pretty BinOp where + pretty Add = "+" + pretty Sub = "-" + pretty Mul = "*" + pretty Div = "/" + pretty Mod = "%" + pretty Eq = "==" + pretty Ne = "!=" + pretty Lt = "<" + pretty Gt = ">" + pretty Le = "<=" + pretty Ge = ">=" + pretty And = "&&" + pretty Or = "||" + pretty BitAnd = "&" + pretty BitOr = "|" + pretty BitXor = "^" + pretty ShiftL = "<<" + pretty ShiftR = ">>" + +instance Pretty UnOp where + pretty Neg = "-" + pretty Not = "!" + pretty BitNot = "~" + pretty Deref = "*" + pretty AddrOf = "&" + +instance Pretty AssignOp where + pretty BaseAssign = "=" + pretty AddAssign = "+=" + pretty SubAssign = "-=" + pretty MulAssign = "*=" + pretty DivAssign = "/=" + pretty ModAssign = "%=" + pretty BitAndAssign = "&=" + pretty BitOrAssign = "|=" + pretty BitXorAssign = "^=" + pretty ShiftLAssign = "<<=" + pretty ShiftRAssign = ">>=" + +instance Pretty Expr where + pretty (Id x) = pretty x + pretty (IntLit x) = pretty x + pretty (UIntLit x) = pretty x + pretty (FloatLit x) = pretty x + pretty (StrLit x) = dquotes (pretty x) + pretty (BoolLit x) = pretty x + pretty (CharLit x) = squotes (pretty x) + pretty (BinOp op l r) = parens (pretty l <+> pretty op <+> pretty r) + pretty (UnOp op e) = pretty op <> parens (pretty e) + pretty (Call f args) = parens (pretty f) <> parens (hsep (punctuate comma (map pretty args))) + pretty (Index arr idx) = parens (pretty arr) <> brackets (pretty idx) + pretty (Member e m) = pretty e <> "." <> pretty m + pretty (Cast t e) = parens (pretty t) <> parens (pretty e) + pretty (Sizeof t) = "sizeof" <> parens (pretty t) + pretty (StructInit s fields) = pretty s <+> lbrace <> line <> indent 4 (vsep (punctuate comma (map (\(n, e) -> pretty n <+> "=" <+> pretty e) fields))) <> line <> rbrace + +instance Pretty Stmt where + pretty (Expr e) = pretty e <> semi + pretty (Return e) = "return" <+> pretty e <> semi + pretty (If cond t f) = "if" <+> pretty cond <+> prettyBlock t <+> maybe "" (\f' -> "else" <+> prettyBlock f') f + pretty (While cond body) = "while" <+> pretty cond <+> prettyBlock body + pretty (Assign op l r) = pretty l <+> pretty op <+> pretty r <> semi + pretty (Block stmts) = braces (vsep (map pretty stmts)) + pretty (Var n t e) = pretty n <+> maybe "" (\t' -> ":" <+> pretty t') t <+> maybe "" (\e' -> "=" <+> pretty e') e <> semi + +instance Pretty Type where + pretty IntType = "int" + pretty UIntType = "uint" + pretty FloatType = "float" + pretty StrType = "str" + pretty BoolType = "bool" + pretty CharType = "char" + pretty (PtrType t) = pretty t <> "*" + pretty (ArrayType t) = pretty t <> "[]" + pretty (StructType s) = pretty s + pretty (EnumType e) = pretty e + pretty VoidType = "void" + +instance Pretty Bind where + pretty (Bind n t) = pretty n <+> ":" <+> pretty t + +instance Pretty TLStruct where + pretty (Struct n fields) = "struct" <+> pretty n <+> prettyBlock fields + +instance Pretty TLEnum where + pretty (Enum n fields) = "enum" <+> pretty n <+> prettyBlock fields + +instance Pretty TLFunc where + pretty (Func n args ret body) = + pretty n <> parens (hsep (punctuate comma (map pretty args))) <+> "->" <+> pretty ret <+> prettyBlock body + +instance Pretty TL where + pretty (TLStruct s) = pretty s + pretty (TLEnum e) = pretty e + pretty (TLFunc f) = pretty f + +instance Pretty Program where + pretty (Program structs enums funcs) = vsep (map pretty structs) <> line <> vsep (map pretty enums) <> line <> vsep (map pretty funcs) + +prettyBlock :: (Pretty a) => [a] -> Doc ann +prettyBlock stmts = lbrace <> line <> indent 4 (vsep (map pretty stmts)) <> line <> rbrace diff --git a/src/Windows12/Parser.hs b/src/Windows12/Parser.hs index 6d2ec84..4559f53 100644 --- a/src/Windows12/Parser.hs +++ b/src/Windows12/Parser.hs @@ -2,55 +2,62 @@ 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 "]") + InfixL $ (\l r -> Member (UnOp Deref l) r) <$ symbol "->" ], - [ Prefix (UnOp Neg <$ symbol "-"), - Prefix (UnOp Not <$ symbol "!"), - Prefix (UnOp BitNot <$ symbol "~"), - Prefix (UnOp Deref <$ symbol "*"), - Prefix (UnOp AddrOf <$ symbol "&") + [ unary (UnOp Neg) "-", + unary (UnOp Not) "!", + unary (UnOp BitNot) "~", + unary (UnOp Deref) "*", + unary (UnOp AddrOf) "&" ], - [ InfixL (BinOp Mul <$ symbol "*"), - InfixL (BinOp Div <$ symbol "/"), - InfixL (BinOp Mod <$ symbol "%") + [ Postfix $ flip Index <$> (symbol "[" *> exprP <* symbol "]") ], - [ InfixL (BinOp Add <$ symbol "+"), - InfixL (BinOp Sub <$ symbol "-") + [ Postfix $ flip Call <$> parens (sepBy exprP (symbol ",")) ], - [ InfixL (BinOp ShiftL <$ symbol "<<"), - InfixL (BinOp ShiftR <$ symbol ">>") + [ infixL' Mul "*", + infixL' Div "/", + infixL' Mod "%" ], - [ InfixL (BinOp Lt <$ symbol "<"), - InfixL (BinOp Gt <$ symbol ">"), - InfixL (BinOp Le <$ symbol "<="), - InfixL (BinOp Ge <$ symbol ">=") + [ infixL' Add "+", + infixL' Sub "-" ], - [ InfixL (BinOp Eq <$ symbol "=="), - InfixL (BinOp Ne <$ symbol "!=") + [ infixL' ShiftL "<<", + infixL' ShiftR ">>" ], - [ InfixL (BinOp BitAnd <$ symbol "&") + [ infixL Le "<=", + infixL Lt "<", + infixL Ge ">=", + infixL Gt ">" ], - [ InfixL (BinOp BitXor <$ symbol "^") + [ infixL Eq "==", + infixL Ne "!=" ], - [ InfixL (BinOp BitOr <$ symbol "|") + [ infixL' BitAnd "&" ], - [ InfixL (BinOp And <$ symbol "&&") + [ infixL' BitXor "^" ], - [ InfixL (BinOp Or <$ symbol "||") + [ infixL' BitOr "|" + ], + [ infixL And "&&" + ], + [ infixL Or "||" ] ] + where + unary op sym = Prefix $ foldr1 (.) <$> some (op <$ symbol sym) + infixL op sym = InfixL $ BinOp op <$ symbol sym + 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 ("+-*/%<>&|^=!~" :: [Char]) termP :: Parser Expr termP = @@ -62,8 +69,7 @@ termP = <|> 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 (Cast <$> (parens typeP) <*> termP) <|> try (StructInit <$> identifier <*> braces (sepEndBy1 ((,) <$> identifier <* symbol ":" <*> exprP) (symbol ","))) <|> Id <$> identifier @@ -90,21 +96,32 @@ typeP = do <|> StructType <$> identifier foldr (const PtrType) t <$> many (symbol "*") +assignP :: Parser Stmt +assignP = do + lhs <- exprP + op <- + AddAssign <$ symbol "+=" + <|> SubAssign <$ symbol "-=" + <|> MulAssign <$ symbol "*=" + <|> DivAssign <$ symbol "/=" + <|> ModAssign <$ symbol "%=" + <|> BitAndAssign <$ symbol "&=" + <|> BitOrAssign <$ symbol "|=" + <|> BitXorAssign <$ symbol "^=" + <|> ShiftLAssign <$ symbol "<<=" + <|> ShiftRAssign <$ symbol ">>=" + <|> BaseAssign <$ symbol "=" + Assign op lhs <$> exprP <* 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) + <|> (If <$> (reserved "if" *> exprP) <*> braces (many stmtP) <*> optional (reserved "else" *> braces (many stmtP))) + <|> (While <$> (reserved "while" *> parens exprP) <*> braces (many stmtP)) + <|> (Var <$> (reserved "var" *> identifier) <*> optional (symbol ":" *> typeP) <*> optional (symbol "=" *> exprP) <* symbol ";") + <|> try assignP + <|> Expr <$> exprP <* symbol ";" + <|> Block <$> braces (many stmtP) funcP :: Parser TLFunc funcP = do @@ -122,7 +139,7 @@ enumP = do fields <- braces (sepEndBy1 identifier (symbol ",")) return $ Enum name fields -memberFuncP :: Parser TLMemberFunc +memberFuncP :: Parser TLFunc memberFuncP = do reserved "fn" reserved "on" @@ -131,17 +148,16 @@ memberFuncP = do args <- parens (sepBy (Bind <$> identifier <* symbol ":" <*> typeP) (symbol ",")) retType <- (symbol "->" *> typeP) <|> pure VoidType body <- braces (many stmtP) - return $ MemberFunc self name args retType body + return $ Func name (Bind "self" self : args) retType body organize :: [TL] -> Program -organize tls = Program structs enums funcs memberFuncs +organize tls = Program structs enums funcs 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) + tls <- many (TLStruct <$> structP <|> TLEnum <$> enumP <|> try (TLFunc <$> memberFuncP) <|> TLFunc <$> funcP) return $ organize tls \ No newline at end of file diff --git a/test/hello.w12 b/test/hello.w12 index 4b456e8..e2ba15c 100644 --- a/test/hello.w12 +++ b/test/hello.w12 @@ -1,16 +1,64 @@ # Create an enum enum AnimalType { -Dog, -Cat, + Dog, + Cat, } + # Create a struct struct Pet { -name: [char], # A list of characters -age: uint, # An unsigned 32-bit integer -type: AnimalType, -living: bool, + name: [char], # A list of characters + age: uint, # An unsigned 32-bit integer + type: AnimalType, + living: bool, } + # Create a function that can be called on a Pet fn on Pet rename(newName: [char]) { - return "test"; + self.name = newName; +} + +# Create another struct +struct Person { + pet: Pet, + name: [char], + age: uint, + living: bool, +} + +fn on Person growUp() { + self.age += 1; +} +fn main() -> int { + # Create an instance of Pet + # "let" creates an immutable binding + var dog = Pet { + name: "Fido", + age: 3, + type: AnimalType.Dog, + }; + + # Create a (variable) instance of Person + # "var" creates a mutable binding + var person = Person { + pet: dog, + name: "Fred", + age: 41, + }; + + # Create a new name for the Pet + var new_name = "George"; + person.pet.rename(new_name); + + # Print out the person's name and age + # Uses C for I/O + printf("Person %s is %u years old.\n", person.name, person.age); + if person.age % 2 == 0 { + printf("Age is even\n"); + } else { + printf("Age is odd\n"); + } + + *test[12](3); + + return 0; } \ No newline at end of file diff --git a/windows12.cabal b/windows12.cabal index cd5a1f5..d365b80 100644 --- a/windows12.cabal +++ b/windows12.cabal @@ -79,6 +79,7 @@ executable windows12 megaparsec >= 9.6.1 && < 9.7, text >= 1.2.5 && < 1.3, parser-combinators >= 1.3.0 && < 1.4, + prettyprinter >= 1.7.1 && < 1.8, -- Directories containing source files. hs-source-dirs: src