{-# 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