%{
open Symbol
open Fc_ast_type
open Fc_ast_util
open Fc_ast_state
open Fc_ast_exn

(*
 * Var name in a declaration.
 *)
type var_name =
   VarNameId of symbol option * pos
 | VarNameArray of var_name * expr option * pos
 | VarNameFun of var_name * (symbol option * ty) list * pos

let pos_of_var_name = function
   VarNameId (_, pos) -> pos
 | VarNameArray (_, _, pos) -> pos
 | VarNameFun (_, _, pos) -> pos

(*
 * Parameter declarations.
 *)
let rec make_param_decl ty = function
   VarNameId (id, _) ->
      id, ty
 | VarNameArray (v, e, pos) ->
      make_param_decl (TypeArray (ty, e, pos)) v
 | VarNameFun (v, args, pos) ->
      make_param_decl (TypeFun (make_param_decls args, ty, pos)) v

and make_param_decls args =
   List.map snd args

(*
 * Build a variable declaration from the syntax.
 *)
let make_var_init_decls ty defs =
   (* Build the declaration with an initializer *)
   let rec make_def ty e = function
      VarNameId (Some n, pos) ->
         n, ty, e, pos
    | VarNameId (None, pos) ->
         raise (ParseError (pos, "declaration must be named"))
    | VarNameArray (v, e', pos) ->
         make_def (TypeArray (ty, e', pos)) e v
    | VarNameFun (v, args, pos) ->
         make_def (TypeFun (make_param_decls args, ty, pos)) e v
   in

   (* Initial type *)
   let make_init_def (v, e) =
      make_def ty e v
   in
      List.map make_init_def defs

(*
 * Build a variable declaration from the syntax.
 *)
let rec make_var_decl ty = function
   VarNameId (Some n, pos) ->
      n, ty, pos
 | VarNameId (None, pos) ->
      raise (ParseError (pos, "declaration must be named"))
 | VarNameArray (v, e, pos) ->
      make_var_decl (TypeArray (ty, e, pos)) v
 | VarNameFun (v, args, pos) ->
      make_var_decl (TypeFun (make_param_decls args, ty, pos)) v

let make_var_decls ty decls =
   List.map (make_var_decl ty) decls

(*
 * Add pointers.
 *)
let make_pointer_decl i ty =
   let pos = pos_of_var_name ty in
   let rec loop i ty =
      if i = 0 then
         ty
      else
         loop (pred i) (VarNameArray (ty, None, pos))
   in
      loop i ty

(*
 * A function definition.
 *)
let get_fun_var (v, ty) =
   let v =
      match v with
         Some v -> v
       | None -> new_symbol_string "unnamed_parameter"
   in
      v, ty, pos_of_type ty

let make_fun_def ty decl body pos =
   let pos = union_pos (pos_of_type ty) pos in
      match decl with
         VarNameFun (res, vars, _) ->
            let vars = List.map get_fun_var vars in
            let f, ty, _ = make_var_decl ty res in
               FunDef (f, vars, ty, SeqExpr (body, pos), pos)
       | VarNameId _
       | VarNameArray _ ->
            raise (ParseError (pos, "not a function"))

(*
 * Add some type definitions.
 *)
let make_types pos types =
   let make_type (v, _, _) =
      add_type v
   in
      List.iter make_type types;
      TypeDefs (types, pos)

(*
 * Unary expression.
 *)
let make_unop op expr =
   UnOpExpr (op, expr, pos_of_expr expr)

let make_addr_of pos expr =
   let pos = union_pos pos (pos_of_expr expr) in
      AddrOfExpr (expr, pos)
(*
 * Binary expressions.
 *)
let make_binop op expr1 expr2 =
   let pos = union_pos (pos_of_expr expr1) (pos_of_expr expr2) in
      BinOpExpr (op, expr1, expr2, pos)

let make_boolop op expr1 expr2 =
   let pos = union_pos (pos_of_expr expr1) (pos_of_expr expr2) in
      BoolOpExpr (op, expr1, expr2, pos)

(*
 * Pre and pos increment.
 *)
let make_uarith_op pos op expr =
   let pos = union_pos pos (pos_of_expr expr) in
      UArithExpr (op, expr, pos)
(*
 * Optional expression.
 *)
let make_opt_expr opt_expr def_expr =
   match opt_expr with
      Some expr -> expr
    | None -> def_expr
%}

/*
 * End-of-file is a token.
 */
%token TokEof

/*
 * Binary operators return position.
 */
%token <Fc_ast_type.pos> TokPlus
%token <Fc_ast_type.pos> TokMinus
%token <Fc_ast_type.pos> TokPlusPlus
%token <Fc_ast_type.pos> TokMinusMinus
%token <Fc_ast_type.pos> TokStar
%token <Fc_ast_type.pos> TokSlash
%token <Fc_ast_type.pos> TokPercent
%token <Fc_ast_type.pos> TokLAnd
%token <Fc_ast_type.pos> TokLOr
%token <Fc_ast_type.pos> TokLShift
%token <Fc_ast_type.pos> TokRShift
%token <Fc_ast_type.pos> TokEq
%token <Fc_ast_type.pos> TokEqEq
%token <Fc_ast_type.pos> TokNotEq
%token <Fc_ast_type.pos> TokLt
%token <Fc_ast_type.pos> TokLe
%token <Fc_ast_type.pos> TokGe
%token <Fc_ast_type.pos> TokGt
%token <Fc_ast_type.pos> TokAmp
%token <Fc_ast_type.pos> TokPipe
%token <Fc_ast_type.pos> TokHat
%token <Fc_ast_type.binop * Fc_ast_type.pos> TokAssign

/*
 * Keywords.
 */
%token <Fc_ast_type.pos> TokTypedef
%token <Fc_ast_type.pos> TokIf
%token <Fc_ast_type.pos> TokElse
%token <Fc_ast_type.pos> TokFor
%token <Fc_ast_type.pos> TokWhile
%token <Fc_ast_type.pos> TokReturn
%token <Fc_ast_type.pos> TokBreak
%token <Fc_ast_type.pos> TokStruct

%token <Fc_ast_type.pos> TokBang
%token <Fc_ast_type.pos> TokQuest
%token <Fc_ast_type.pos> TokColon
%token <Fc_ast_type.pos> TokSemi
%token <Fc_ast_type.pos> TokComma
%token <Fc_ast_type.pos> TokDot
%token <Fc_ast_type.pos> TokRightArrow
%token <Fc_ast_type.pos> TokLeftParen
%token <Fc_ast_type.pos> TokRightParen
%token <Fc_ast_type.pos> TokLeftBrack
%token <Fc_ast_type.pos> TokRightBrack
%token <Fc_ast_type.pos> TokLeftBrace
%token <Fc_ast_type.pos> TokRightBrace

/*
 * Terminal tokens.
 */
%token <Symbol.symbol * Fc_ast_type.pos> TokId
%token <Symbol.symbol * Fc_ast_type.pos> TokTypeId
%token <string * Fc_ast_type.pos> TokString
%token <char * Fc_ast_type.pos> TokChar
%token <int * Fc_ast_type.pos> TokInt
%token <float * Fc_ast_type.pos> TokFloat

/*
 * Precedences.
 */
%left TokComma
%right TokEq
%left TokLOr
%left TokLAnd
%left TokPipe
%left TokHat
%left TokAmp
%left TokEqEq TokNotEq
%left TokLe TokLt TokGe TokGt
%left TokLShift TokRShift
%left TokPlus TokMinus
%left TokStar TokSlash TokPercent
%right prec_unary TokPlusPlus TokMinusMinus
%left prec_apply prec_subscript TokDot TokRightArrow TokLeftParen TokLeftBrack

/*
 * A complete program.
 */
%start prog
%start topstmt
%type <Fc_ast_type.prog> prog
%type <Fc_ast_type.expr option> topstmt

%%

/************************************************************************
 * TOPLEVEL PRODUCTIONS
 ************************************************************************/

/*
 * A program is a sequence of str_items.
 */
prog:     all_defs TokEof
          { $1 }
        ;

/*
 * A toploop statement.
 */
topstmt:
          stmt
          { Some $1 }
        | TokEof
          { None }
        ;

/************************************************************************
 * DECLARATIONS AND DEFINITIONS
 ************************************************************************/

/*
 * Definitions.
 */
all_defs:
          rev_all_defs
          { List.rev $1 }
        ;

rev_all_defs:
          /* empty */
          { [] }
        | rev_all_defs all_def
          { $2 :: $1 }
        ;

all_def:  var_defs
          { $1 }
        | fun_def
          { $1 }
        | type_defs
          { $1 }
        ;

/************************************************************************
 * TYPE SPECIFIERS
 ************************************************************************/

type_spec:
          TokTypeId
          { let id, pos = $1 in
               TypeId (id, pos)
          }
        | struct_spec
          { $1 }
        ;

struct_spec:
          TokStruct TokLeftBrace struct_decl_list TokRightBrace
          { let pos = union_pos $1 $4 in
               TypeStruct ($3, pos)
          }
        | TokStruct id TokLeftBrace struct_decl_list TokRightBrace
          { let id, _ = $2 in
            let pos = union_pos $1 $5 in
               Fc_ast_state.add_typedef id pos (TypeStruct ($4, pos));
               TypeId (id, pos)
          }
        | TokStruct id
          { let id, pos = $2 in
            let pos = union_pos $1 pos in
               Fc_ast_state.add_type id;
               TypeId (id, pos)
          }
        ;

struct_decl_list:
          /* empty */
          { [] }
        | struct_decl_list struct_decl
          { $1 @ $2 }
        ;

struct_decl:
          type_spec decl_list TokSemi
          { make_var_decls $1 $2 }
        ;

/************************************************************************
 * VARIABLE DEFINITIONS
 ************************************************************************/

/*
 * Variable definitions.
 */
var_defs:
          type_spec init_decl_list TokSemi
          { let pos = union_pos (pos_of_type $1) $3 in
               VarDefs (make_var_init_decls $1 $2, pos)
          }
        ;

/*
 * Declarator with an optional initializer.
 */
init_decl_list:
          rev_init_decl_list
          { List.rev $1 }
        ;

rev_init_decl_list:
          init_decl
          { [$1] }
        | rev_init_decl_list TokComma init_decl
          { $3 :: $1 }
        ;

init_decl:
          decl
          { $1, None }
        | decl TokEq expr
          { $1, Some $3 }
        ;

/*
 * Declarators without initializers.
 */
decl_list:
          rev_decl_list
          { List.rev $1 }
        ;

rev_decl_list:
          decl
          { [$1] }
        | rev_decl_list TokComma decl
          { $3 :: $1 }
        ;

decl:     opt_pointer direct_decl
          { make_pointer_decl $1 $2 }
        ;

opt_pointer:
          /* empty */
          { 0 }
        | pointer
          { fst $1 }
        ;

pointer:  TokStar
          { 1, $1 }
        | pointer TokStar
          { let index, pos = $1 in
            let pos = union_pos pos $2 in
               succ index, pos
          }
        ;

direct_decl:
          TokId
          { let id, pos = $1 in
               VarNameId (Some id, pos)
          }
        | TokLeftParen decl TokRightParen
          { $2 }
        | direct_decl TokLeftBrack opt_expr TokRightBrack %prec prec_subscript
          { let pos = union_pos (pos_of_var_name $1) $4 in
               VarNameArray ($1, $3, pos)
          }
        | direct_decl TokLeftParen opt_param_list TokRightParen %prec prec_apply
          { let pos = union_pos (pos_of_var_name $1) $4 in
               VarNameFun ($1, $3, pos)
          }
        ;

/*
 * Function parameters.
 */
opt_param_list:
          /* empty */
          { [] }
        | param_list
          { $1 }
        ;

param_list:
          rev_param_list
          { List.rev $1 }
        ;

rev_param_list:
          param_decl
          { [$1] }
        | rev_param_list TokComma param_decl
          { $3 :: $1 }
        ;

param_decl:
          type_spec decl
          { make_param_decl $1 $2 }
        | type_spec abstract_decl
          { make_param_decl $1 $2 }
        | type_spec
          { None, $1 }
        ;

abstract_decl:
          pointer
          { let index, pos = $1 in
               make_pointer_decl index (VarNameId (None, pos))
          }
        | opt_pointer direct_abstract_decl
          { let pos = pos_of_var_name $2 in
               make_pointer_decl $1 $2
          }
        ;

direct_abstract_decl:
          TokLeftParen abstract_decl TokRightParen
          { $2 }
        | direct_abstract_decl TokLeftBrack opt_expr TokRightBrack %prec prec_subscript
          { let pos = union_pos (pos_of_var_name $1) $4 in
               VarNameArray ($1, $3, pos)
          }
        | TokLeftBrack opt_expr TokRightBrack %prec prec_subscript
          { let pos = union_pos $1 $3 in
               VarNameArray (VarNameId (None, pos), $2, pos)
          }
        | direct_abstract_decl TokLeftParen opt_param_list TokRightParen %prec prec_apply
          { let pos = union_pos (pos_of_var_name $1) $4 in
               VarNameFun ($1, $3, pos)
          }
        | TokLeftParen param_list TokRightParen %prec prec_apply
          { let pos = union_pos $1 $3 in
               VarNameFun (VarNameId (None, pos), $2, pos)
          }
        ;

/*
 * Declare mutually recursive functions.
 */
fun_def:  type_spec decl TokLeftBrace stmt_list TokRightBrace
          { make_fun_def $1 $2 $4 $5 }
        ;

/*
 * Declare some mutually recursive types.
 */
type_defs:
          TokTypedef type_spec decl_list TokSemi
          { let pos = union_pos $1 $4 in
            let decls = make_var_decls $2 $3 in
               make_types pos decls
          }
        | type_spec TokSemi
          { (* Ignore them *)
            TypeDefs ([], pos_of_type $1)
          }
        ;

/************************************************************************
 * EXPRESSIONS
 ************************************************************************/

/*
 * Expressions.
 */
expr:     TokInt
          { let i, pos = $1 in
               IntExpr (i, pos)
          }
        | TokFloat
          { let x, pos = $1 in
               FloatExpr (x, pos)
          }
        | TokChar
          { let c, pos = $1 in
               CharExpr (c, pos)
          }
        | TokString
          { let s, pos = $1 in
               StringExpr (s, pos)
          }
        | TokId
          { let v, pos = $1 in
               VarExpr (v, pos)
          }
        | TokMinus expr %prec prec_unary
          { make_unop UMinusOp $2 }
        | TokBang expr %prec prec_unary
          { make_unop UNotOp $2 }
        | TokStar expr %prec prec_unary
          { make_unop UStarOp $2 }
	| TokAmp expr %prec prec_unary
	  { make_addr_of $1 $2 }
        | TokPlusPlus expr %prec prec_unary
          { make_uarith_op $1 PreIncrOp $2 }
        | TokMinusMinus expr %prec prec_unary
          { make_uarith_op $1 PreDecrOp $2 }
        | expr TokPlusPlus %prec prec_unary
          { make_uarith_op $2 PostIncrOp $1 }
        | expr TokMinusMinus %prec prec_unary
          { make_uarith_op $2 PostDecrOp $1 }
        | expr TokPlus expr
          { make_binop PlusOp $1 $3 }
        | expr TokMinus expr
          { make_binop MinusOp $1 $3 }
        | expr TokStar expr
          { make_binop TimesOp $1 $3 }
        | expr TokSlash expr
          { make_binop DivideOp $1 $3 }
        | expr TokPercent expr
          { make_binop ModOp $1 $3 }
        | expr TokLShift expr
          { make_binop LShiftOp $1 $3 }
        | expr TokRShift expr
          { make_binop RShiftOp $1 $3 }
        | expr TokLAnd expr
          { make_boolop LAndOp $1 $3 }
        | expr TokLOr expr
          { make_boolop LOrOp $1 $3 }
        | expr TokEqEq expr
          { make_binop EqOp $1 $3 }
        | expr TokNotEq expr
          { make_binop NotEqOp $1 $3 }
        | expr TokLe expr
          { make_binop LeOp $1 $3 }
        | expr TokLt expr
          { make_binop LtOp $1 $3 }
        | expr TokGe expr
          { make_binop GeOp $1 $3 }
        | expr TokGt expr
          { make_binop GtOp $1 $3 }
        | expr TokDot id
          { let pos = union_pos (pos_of_expr $1) (snd $3) in
               ProjectExpr ($1, fst $3, pos)
          }
	| expr TokRightArrow id
	  { let pos = union_pos (pos_of_expr $1) (snd $3) in
	       ProjectExpr (UnOpExpr (UStarOp, $1, pos), fst $3, pos)
          }
        | expr TokEq expr
          { let pos = union_pos (pos_of_expr $1) (pos_of_expr $3) in
               AssignExpr (None, $1, $3, pos)
          }
        | expr binop TokEq expr %prec TokEq
          { let pos = union_pos (pos_of_expr $1) (pos_of_expr $4) in
               AssignExpr (Some $2, $1, $4, pos)
          }
        | TokLeftParen expr TokRightParen
          { $2 }
        | expr TokLeftBrack expr TokRightBrack %prec prec_subscript
          { let pos = union_pos (pos_of_expr $1) $4 in
               SubscriptExpr ($1, $3, pos)
          }
        | expr TokLeftParen args TokRightParen %prec prec_apply
          { let pos = union_pos (pos_of_expr $1) $4 in
               ApplyExpr ($1, $3, pos)
          }
        ;

/*
 * An optional expression.
 */
opt_expr: /* empty */
          { None }
        | expr
          { Some $1 }
        ;

/*
 * A statement is a terminated expression.
 * We do the unmatched/matched statement trick to
 * get rid of the "if" shift/reduce conflict.  I
 * really don't think that this is worth it.
 */
stmt:     mstmt
          { $1 }
        | ustmt
          { $1 }
        ;

mstmt:    TokSemi
          { SeqExpr ([], $1) }
        | expr TokSemi
          { $1 }
        | TokIf TokLeftParen expr TokRightParen mstmt TokElse mstmt
          { let pos = union_pos $1 (pos_of_expr $7) in
               IfExpr ($3, $5, Some $7, pos)
          }
        | TokFor TokLeftParen opt_expr TokSemi opt_expr TokSemi opt_expr TokRightParen mstmt
          { let pos = union_pos $1 (pos_of_expr $9) in
            let def_expr = IntExpr (1, pos) in
            let init = make_opt_expr $3 def_expr in
            let test = make_opt_expr $5 def_expr in
            let step = make_opt_expr $7 def_expr in
               ForExpr (init, test, step, $9, pos)
          }
        | TokWhile TokLeftParen expr TokRightParen mstmt
          { let pos = union_pos $1 (pos_of_expr $5) in
               WhileExpr ($3, $5, pos)
          }
        | TokReturn expr TokSemi
          { let pos = union_pos $1 (pos_of_expr $2) in
               ReturnExpr ($2, pos)
          }
        | TokBreak TokSemi
          { let pos = union_pos $1 $2 in
               BreakExpr pos
          }
        | open_block stmt_list close_block
          { let defs, pos = $3 in
            let pos = union_pos $1 pos in
            let body =
               match defs with
                  [] -> $2
                | _ -> TypeDefs (defs, pos) :: $2
            in
               SeqExpr (body, pos)
          }
        | all_def
          { $1 }
        ;

ustmt:    TokIf TokLeftParen expr TokRightParen stmt
          { let pos = union_pos $1 (pos_of_expr $5) in
                 IfExpr ($3, $5, None, pos)
          }
        | TokIf TokLeftParen expr TokRightParen mstmt TokElse ustmt
          { let pos = union_pos $1 (pos_of_expr $7) in
               IfExpr ($3, $5, Some $7, pos)
          }
        | TokFor TokLeftParen opt_expr TokSemi opt_expr TokSemi opt_expr TokRightParen ustmt
          { let pos = union_pos $1 (pos_of_expr $9) in
            let def_expr = IntExpr (1, pos) in
            let init = make_opt_expr $3 def_expr in
            let test = make_opt_expr $5 def_expr in
            let step = make_opt_expr $7 def_expr in
               ForExpr (init, test, step, $9, pos)
          }
        | TokWhile TokLeftParen expr TokRightParen ustmt
          { let pos = union_pos $1 (pos_of_expr $5) in
               WhileExpr ($3, $5, pos)
          }
        ;

stmt_list:
          rev_stmt_list
          { List.rev $1 }
        ;

rev_stmt_list:
          /* empty */
          { [] }
        | rev_stmt_list stmt
          { $2 :: $1 }
        ;

/*
 * Environment pushing.
 */
open_block:
	  TokLeftBrace
          { Fc_ast_state.push_tenv ();
            $1
          }
        ;

close_block:
          TokRightBrace
          { Fc_ast_state.pop_tenv (), $1 }
        ;

/*
 * Arguments are comma-separated list of expressions.
 */
args:     /* empty */
          { [] }
        | rev_args
          { List.rev $1 }
        ;

rev_args: expr
          { [$1] }
        | rev_args TokComma expr
          { $3 :: $1 }
        ;

/*
 * binary operator.
 */
binop:    TokPlus
          { PlusOp }
        | TokMinus
          { MinusOp }
        | TokStar
          { TimesOp }
        | TokSlash
          { DivideOp }
        | TokPercent
          { ModOp }
        | TokAmp
          { BAndOp }
        | TokPipe
          { BOrOp }
        | TokHat
          { BXorOp }
        | TokLShift
          { LShiftOp }
        | TokRShift
          { RShiftOp }
        ;

/*
 * Identifiers.
 */
id:       TokId
          { $1 }
        | TokTypeId
          { $1 }
        ;