-----------------------------------------------------------------------------
-- Parser for the M language, which has:
--   exceptions polymorphism, existentials, recursive types, and
--   mutable references
--
-- Phillip Mates, 2014
-----------------------------------------------------------------------------

module Parser where

import Text.Parsec
import Text.Parsec.String (Parser)

import qualified Text.Parsec.Token as Tok

import Lexer
import MSyntax

-----------------------------------------------------------------------------
-- Type Parsing
-----------------------------------------------------------------------------
mtype :: Parser MType
mtype = try vart
  <|> try unitt
  <|> try intt
  <|> try arrowt
  <|> try existst
  <|> try mut
  <|> try reft
  <|> try tuplet

vart :: Parser MType
vart = do
  var <- identifier
  return $ MVarTyp var

unitt :: Parser MType
unitt = do
  reserved "unit"
  return MUnitTyp

intt :: Parser MType
intt = do
  reserved "int"
  return MIntTyp

arrowt :: Parser MType
arrowt = do
  reserved "forall"
  vars <- brackets $ many vart
  dom <- parens $ commaSep mtype
  reserved "->"
  range <- mtype
  return $ MArrowTyp vars dom range

existst :: Parser MType
existst = do
  reserved "exists"
  vt <- varAndType
  return $ uncurry MExistsTyp vt

mut :: Parser MType
mut = do
  reserved "mu"
  vt <- varAndType
  return $ uncurry MMuTyp vt

varAndType :: Parser (MType, MType)
varAndType = do
  var <- vart
  reserved "."
  typ <- mtype
  return (var, typ)

reft :: Parser MType
reft = do
  reserved "ref"
  typ <- mtype
  return $ MRefTyp typ

tuplet :: Parser MType
tuplet = do
  typs <- angles $ commaSep mtype
  return $ MTupleTyp typs

-----------------------------------------------------------------------------
-- Expression Parsing
-----------------------------------------------------------------------------
-- An expression is either an annotated expression or a non-annotated expression
-- we must make this distiction since we must avoid left recrusion in LL parsing
expr :: Parser MExpr
expr =  try anno <|> nonanno

anno :: Parser MExpr
anno = do
  e <- nonanno
  reservedOp ":"
  typ <- mtype
  return $ MAnno e typ

-- An nonanno is either an binary operation or a not-binary expression,
-- both excluding the possibility of being annotated.
-- Again, we make the binary, not-binary distinction to avoid left recursion
nonanno :: Parser MExpr
nonanno = try bin <|> nonbin

-- Parsing for binary arithmetic expressions
-- This can be built using buildExpressionParser and a table, but I wanted to do it by hand
bin :: Parser MExpr
bin = plus

plus :: Parser MExpr
plus =
  try $ do l <- minus
           reservedOp "+"
           r <- plus
           return (MBinOp Plus l r)
  <|> parens plus

minus :: Parser MExpr
minus =
  try $ do l <- times
           reservedOp "-"
           r <- minus
           return (MBinOp Minus l r)
  <|> parens minus

times :: Parser MExpr
times =
  try $ do l <- divide
           reservedOp "-"
           r <- times
           return (MBinOp Times l r)
  <|> parens times

divide :: Parser MExpr
divide =
  try $ do l <- nonbin
           reservedOp "-"
           r <- times
           return (MBinOp Divide l r)
  <|> parens divide

-- Expressions that aren't annotated or binary arithmetic expressions
nonbin :: Parser MExpr
nonbin = ifthen
     <|> letins
     <|> deref
     <|> new
     <|> unpack
     <|> unfold
     <|> handle
     <|> raise
     <|> fold
     <|> function
     <|> pack
     <|> caseof
     <|> datatype
     <|> try tuple
     <|> try (parens anno)
     <|> try (parens assign)
     <|> try int
     <|> try unit
     <|> try variable
     <|> try (parens app)
     <|> parens expr

deref :: Parser MExpr
deref = do
  reserved "!"
  e <- expr
  return $ MDeref e

new :: Parser MExpr
new = do
  reserved "new"
  e <- expr
  return $ MNew e

assign :: Parser MExpr
assign = do
  loc <- expr
  reserved ":"
  reserved "="
  e <- expr
  return $ MAssign loc e

unpack :: Parser MExpr
unpack = do
  reserved "unpack"
  tyvar <- vart
  var <- variable
  packedVal <- expr
  body <- expr
  return $ MUnpack tyvar var packedVal body

unfold :: Parser MExpr
unfold = do
  reserved "unfold"
  e <- expr
  return $ MUnfold e

handle :: Parser MExpr
handle = do
  reserved "handle"
  (body, var, handler) <-
    parens $ do
                body <- expr
                reserved ";"
                var <- expr
                _ <- dot
                handler <- expr
                return (body, var, handler)
  return $ MHandle body var handler

raise :: Parser MExpr
raise = do
  reserved "raise"
  typ <- brackets mtype
  e <- expr
  return $ MRaise typ e

app :: Parser MExpr
app = do
  func <- expr
  tyargs <- brackets $ many mtype
  args <- parens $ many expr
  return $ MApp func tyargs args

ifthen :: Parser MExpr
ifthen = do
  reserved "if0"
  cond <- expr
  reserved "then"
  tr <- expr
  reserved "else"
  fl <- expr
  return $ MIf0 cond tr fl

letins :: Parser MExpr
letins = do
  reserved "let"
  var <- identifier
  reservedOp "="
  e <- expr
  reserved "in"
  body <- expr
  return $ MLet (MVar var) e body

int :: Parser MExpr
int = do
  n <- integer
  return $ MInt (fromInteger n)

unit :: Parser MExpr
unit = do
  reserved "<"
  reserved ">"
  return MUnit

variable :: Parser MExpr
variable = do
  var <- identifier
  return $ MVar var

fold :: Parser MExpr
fold = do
  reserved "fold"
  ty <- mtype
  e <- expr
  return $ MFold ty e

function :: Parser MExpr
function = do
  reserved "func"
  tyargs <- brackets $ many vart
  args <- parens $ commaSep1 argument
  _ <- dot
  body <- expr
  return $ MFunc tyargs args body

pack :: Parser MExpr
pack = do
  reserved "pack"
  witness <- mtype
  e <- expr
  reserved "as"
  astyp <- mtype
  return $ MPack witness e astyp

tuple :: Parser MExpr
tuple = do
  entries <- angles $ commaSep1 expr
  return $ MTuple entries

caseof :: Parser MExpr
caseof = do
  reserved "case"
  discriminee <- parens expr
  reserved "of"
  cases <- sepBy1 casePatternBody (reservedOp "|")
  return $ MCase discriminee cases

casePatternBody :: Parser (MExpr,MExpr)
casePatternBody = do
  patt <- pattern
  reservedOp "=>"
  body <- expr
  return (patt, body)

pattern :: Parser MExpr
pattern = do
  typ <- identifier
  dataExprs <- many expr
  return $ MVariant typ dataExprs

datatype :: Parser MExpr
datatype = do
  reserved "datatype"
  typeName <- identifier
  reservedOp "="
  constructors <- sepBy1 typeConstructor (reservedOp "|")
  return $ MDatatype typeName constructors
  -- type intlist = Nil | Cons of (int * intlist)

typeConstructor :: Parser (Name, [MType])
typeConstructor =
  -- unit constructor
  do name <- identifier
     return (name, [])
  <|>
  -- constructor with multiple types
  do name <- identifier
     reserved "of"
     typs <- parens $ sepBy1 mtype (reservedOp "*")
     return (name, typs)

argument :: Parser (MExpr,MType)
argument = do
  var <- variable
  reservedOp ":"
  typ <- mtype
  return (var, typ)


-----------------------------------------------------------------------------
-- Helpers
-----------------------------------------------------------------------------
contents :: Parser a -> Parser a
contents p = do
  Tok.whiteSpace lexer
  r <- p
  eof
  return r

parseExpr :: String -> Either ParseError MExpr
parseExpr = parse (contents expr) "<stdin>"

parseType :: String -> Either ParseError MType
parseType = parse (contents mtype) "<stdin>"
