%{
open MiniML
(* 1 [2; 3] -> App(1,2) [3] -> A(A(1,2),3) [] *)
let rec make_appl x = function
    [] -> x
  | y::ys -> make_appl (App(x,y)) ys
let rec make_list = function
    [] -> Const(Nil)
  | y::ys -> ConsExp(y,make_list ys)
let rec make_list_ptn = function
    [] -> ConstPtn(Nil)
  | y::ys -> ConsPtn(y,make_list_ptn ys)
let rec make_fun e = function
    [] -> e
  | y::ys -> LambdaExp([y, make_fun e ys])

(* checkes well-formedness of let-rec bindings *)
let check_letrec bindings =
  let vars = 
    List.fold_right
      (fun patt acc ->
	match patt with
	  IdentPtn x, _ -> 
	    x :: acc
	| _ ->
	    failwith "only variables are allowed as left-hand side of let rec")
      bindings []
  in
  let rec subtract l s = 
    match l with 
      [] -> []
    | h::t ->
	if List.mem h s then subtract t s else h :: subtract t s
  in
  let rec pat_vars = function
    ConstPtn _ -> []
  | IdentPtn i -> [i]
  | ConsPtn(p1,p2) | PairPtn(p1,p2) ->
      pat_vars p1 @ pat_vars p2
  in
  let rec subtract_vars u = function
      [] -> u
    | h::t ->
	subtract_vars (subtract u (pat_vars h)) t
  in
  let rec iter u = function
      Const _ -> ()
    | Plus(x1,x2) | Minus(x1,x2) | Times(x1,x2) | Div(x1,x2)
    | Equal(x1,x2) | PairExp(x1,x2) | ConsExp(x1,x2)
    | App(x1,x2) ->
	iter u x1; iter u x2
    | IfExp(x1,x2,x3) -> iter u x1; iter u x2; iter u x3
    | Var(i) ->
	if List.mem i u then
	  failwith ("invalid occurence of variable " ^ i ^ " in right-hand side of let rec")
    | LambdaExp(l) -> ()
    | LetExp(l,e) ->
	List.iter (fun (pat, exp) -> iter u exp) l;
	iter (subtract_vars u (List.map fst l)) e
    | LetRecExp(l,e) ->
	let vars = (subtract_vars u (List.map fst l)) in
	List.iter (fun (pat, exp) -> iter vars exp) l;
	iter vars e
    | MatchExp(e1,l) ->
	iter u e1;
	List.iter
	  (fun (pat, exp) ->
	    iter (subtract_vars u [pat]) exp) l
    | TopLetExp _ | TopLetRecExp _ ->
	assert false
  in
  List.iter (fun (_,e) -> iter vars e) bindings
%}

%token <int> INT
%token <string> IDENT

%token LPAREN RPAREN
%token LBRACKET RBRACKET
%token BAR
%token PLUS MINUS TIMES DIV EQUAL
%token EOD
%token IF THEN ELSE
%token LET REC IN AND
%token CONS SEMICOLON COMMA
%token FUN FUNCTION ARROW
%token MATCH WITH
%token FALSE TRUE

%right prec_let
%right prec_fun prec_match prec_try
%right prec_list
%right prec_if
%left BAR
%left COMMA
%left EQUAL
%right CONS
%left PLUS MINUS
%left TIMES DIV
%left prec_appl
%start main
%type <MiniML.expr> main
%%
main:
  toplevel_phrase EOD { $1 }
| error { failwith("parse failed.") }
;
toplevel_phrase:
  expr { $1 }
| LET let_bindings 
    { TopLetExp(List.rev $2) }
| LET REC let_bindings 
    { 
      check_letrec $3;
      TopLetRecExp(List.rev $3) 
    }
  
simple_expr:
  INT { Const(Int $1) }
| TRUE { Const(Bool true) }
| FALSE { Const(Bool false) }
| IDENT { Var($1) }
| LPAREN expr RPAREN { $2 }
| LBRACKET RBRACKET { Const(Nil) }
| LBRACKET expr_semi_list RBRACKET { make_list(List.rev $2) }
;
expr:
  simple_expr { $1 }
| expr COMMA expr { PairExp($1,$3) }
| expr CONS expr { ConsExp($1,$3) }
| expr PLUS expr { Plus($1,$3) }
| expr MINUS expr { Minus($1,$3) }
| expr TIMES expr { Times($1,$3) }
| expr DIV expr { Div($1,$3) }
| expr EQUAL expr { Equal($1,$3) }
| FUN patterns ARROW expr %prec prec_fun
    { make_fun $4 (List.rev $2) }
| FUNCTION multiple_matches %prec prec_fun
    { LambdaExp(List.rev $2) }
| simple_expr expr_list %prec prec_appl 
    { make_appl $1 (List.rev $2) }
| IF expr THEN expr ELSE expr %prec prec_if
    { IfExp($2,$4,$6) }
| MATCH expr WITH multiple_matches %prec prec_match
    { MatchExp($2,List.rev $4) }
| LET let_bindings IN expr %prec prec_let
    { LetExp(List.rev $2,$4) }
| LET REC let_bindings IN expr %prec prec_let
    { 
      check_letrec $3;
      LetRecExp(List.rev $3,$5)
    }
;
let_bindings:
  let_binding { [$1] }
| let_bindings AND let_binding { $3 :: $1 }
let_binding:
  patterns EQUAL expr { 
    match List.rev $1 with
      [p] -> p, $3 
    | (IdentPtn i as p1)::ps -> p1, make_fun $3 ps 
    | _ -> failwith "parse failed at let_binding" }
multiple_matches:
  multiple_matches BAR sgl_match { $3 :: $1 }
| sgl_match { [$1] }
;
sgl_match:
  pattern ARROW expr { $1, $3 }
; 
expr_semi_list:
  expr { [$1] }
| expr_semi_list SEMICOLON expr { $3 :: $1 }
;
expr_list:
  simple_expr { [$1] }
| expr_list simple_expr { $2 :: $1 }
;
patterns:
  pattern { [$1] }
| patterns pattern { $2 :: $1 }
;
pattern:
  LPAREN pattern RPAREN { $2 }
| INT { ConstPtn(Int $1) }
| TRUE { ConstPtn(Bool true) }
| FALSE { ConstPtn(Bool false) }
| LBRACKET RBRACKET { ConstPtn(Nil) }
| IDENT { IdentPtn($1) }
| pattern CONS pattern { ConsPtn($1,$3) }
| pattern COMMA pattern { PairPtn($1,$3) }
| LBRACKET pattern_semi_list RBRACKET { make_list_ptn(List.rev $2) }
pattern_semi_list:
  pattern { [$1] }
| pattern_semi_list SEMICOLON pattern { $3 :: $1 }
;