module Parser
where
import Text.ParserCombinators.Parsec
import Text.ParserCombinators.Parsec.Expr

data Exp
  = Sum Exp Exp
  | Diff Exp Exp
  | Prod Exp Exp
  | Quot Exp Exp
  | Neg Exp
  | Equal Exp Exp
  | NEqual Exp Exp
  | Ident String
  | Const Integer
  deriving (Show,Eq)

data Stmt
  = Assign String Exp
  | Print Exp
  | While Exp SBlock
  | If Exp SBlock (Maybe SBlock)
  deriving (Show,Eq)

type SBlock = [Stmt]

whiteSpace :: Parser Char
whiteSpace = space <|> tab <|> newline

skipWs :: Parser a -> Parser a
skipWs x = do
  xval <- x
  many whiteSpace
  return xval

lexSym :: String -> Parser String
lexSym s = skipWs $ string s

lexKey :: String -> Parser ()
lexKey s = try $ skipWs $ do
  string s
  notFollowedBy alphaNum

parseIdent :: Parser String
parseIdent = skipWs $ do
  h <- letter
  r <- many alphaNum
  return (h:r)

intLit :: Parser Integer
intLit = skipWs $ do
  s <- many1 digit
  return ((read s)::Integer)

baseExp :: Parser Exp
baseExp = 
  between (lexSym "(") (lexSym ")") parseExp
  <|> do
    lexSym "-"
    e <- baseExp
    return $ Neg e
  <|> do
    i <- intLit
    return $ Const i
  <|> do
    i <- parseIdent
    return $ Ident i

opList :: [[Operator Char () Exp]]
opList = [
  [ Infix (binOp "*" Prod) AssocLeft
  , Infix (binOp "/" Quot) AssocLeft
  ],
  [ Infix (binOp "+" Sum) AssocLeft
  , Infix (binOp "-" Diff) AssocLeft
  ],
  [ Infix (binOp "==" Equal) AssocLeft
  , Infix (binOp "!=" NEqual) AssocLeft
  ]
 ]

binOp :: String -> (Exp -> Exp -> Exp )
  -> Parser (Exp -> Exp -> Exp)
binOp sym constr= do
  lexSym sym
  return (\ x y -> constr x y)

parseExp :: Parser Exp
parseExp = buildExpressionParser opList baseExp

parseStmt :: Parser Stmt
parseStmt =
  do
    lexKey "let"
    ident <- parseIdent
    lexSym "="
    e<-parseExp
    return $ Assign ident e
  <|> do
    lexKey "print"
    e <- parseExp
    return $ Print e
  <|> do
    lexKey "while"
    e <- parseExp
    bl <- parseSBlock
    return $ While e bl
  <|> do
    lexKey "if"
    e <- parseExp
    lexKey "then"
    bl1 <- parseSBlock
    ebl <- option Nothing $ do
       lexKey "else"
       bl2 <- parseSBlock
       return $ Just bl2
    return $ If e bl1 ebl

parseSBlock :: Parser SBlock
parseSBlock = do
  lexKey "begin"
  stmtl <- sepBy parseStmt (lexSym ";")
  lexKey "end"
  return stmtl

parsePrg :: Parser SBlock
parsePrg = do
  many whiteSpace
  prg <- parseSBlock
  lexSym "."
  eof
  return prg

testSrc :: String
testSrc =
     "begin\n  let x=10;\n  let y=x*x;\n  while (x!=0) begin\n"
  ++ "let x=x-1;\n    let y=-(x+y)*z+4\n  end\nend."

test :: IO ()
test = do
  putStrLn ""
  putStrLn testSrc
  putStrLn ""
  parseTest parsePrg testSrc