#load "q_MLast.cmo";;
#load "pa_extend.cmo";;

open Pcaml;;

let loc = (0,0);;        (* toploop only *)

let prepend_id name labels =
  let helper2 v =
    match v with
    <:patt<$lid:x$>> ->
      let y = name ^ "_" ^ x in
      <:patt<$lid:y$>>
  | _ -> v in
  let helper1 = fun
    (patt,expr) -> (helper2 patt,expr) in
  List.map helper1 labels;;



let make_record_constructor name =
  let lname = String.uncapitalize name in
  let uname = String.capitalize name in
  let lbl_expr_list =
    (Obj.magic (Grammar.Entry.find expr "lbl_expr_list") :
       (MLast.patt * MLast.expr) list Grammar.Entry.e) in
  let lbl_patt_list =
    (Obj.magic (Grammar.Entry.find patt "lbl_patt_list") :
       (MLast.patt * MLast.patt) list Grammar.Entry.e) in
  EXTEND
    expr: LEVEL "simple"
    [ [ $uname$; "{"; memb = LIST1 lbl_expr_list SEP ";" ; "}" ->
          (let memb0= prepend_id lname (List.hd memb) in
          <:expr<{$list:memb0$}>>) ] ];
    patt: LEVEL "simple"
    [ [ $uname$; "{"; memb = LIST1 lbl_patt_list SEP ";" ; "}" ->
          (let memb0= prepend_id lname (List.hd memb) in
          <:patt<{$list:memb0$}>>) ] ];
  END;
;;

(* test:
make_record_constructor "bogus";;

type bogus = {bogus_foo:string;bogus_bar:string};;

Bogus{foo="happy";bar="sad"};;
*)

let type_declaration =
    (Obj.magic (Grammar.Entry.find str_item "type_declaration") :
       MLast.type_decl Grammar.Entry.e);;
let type_parameters =
    (Obj.magic (Grammar.Entry.find type_declaration "type_parameters") :
       ((string * (bool * bool)) list) Grammar.Entry.e);;
let type_patt =
    (Obj.magic (Grammar.Entry.find type_declaration "type_patt") :
       (MLast.loc * string) Grammar.Entry.e);;
let type_kind =
    (Obj.magic (Grammar.Entry.find type_declaration "type_kind") :
        MLast.ctyp Grammar.Entry.e);;
let constrain =
    (Obj.magic (Grammar.Entry.find type_declaration "constrain") :
        ((MLast.ctyp * MLast.ctyp)) Grammar.Entry.e);;


let prepend_id_t name tk =
  let helper = fun
    (loc,s,b,t) -> (loc,name ^ "_" ^ s,b,t) in
  match tk with
    <:ctyp< { $list:ldl$ }>> ->
      let ldl2 = List.map helper ldl in <:ctyp< { $list:ldl2$ }>>
  | _ -> tk;;



EXTEND
  type_declaration:
    [ [ tpl = type_parameters; n = type_patt; "="; "LOCAL"; tk = type_kind;
        cl = LIST0 constrain ->
	  match n with (loc,s) ->
	    make_record_constructor s;
	    (n, tpl, prepend_id_t s tk,  cl) ] ]
  ;
END;;