(* $Id$ *)

open StdLabels
open Asttypes
open Parsetree

let norec = ref false

let input_file file =
  let ic = try open_in file with _ -> failwith ("input_file : " ^ file) in
  let b = Buffer.create 1024 in
  let buf = String.create 1024 and len = ref 0 in
  while len := input ic buf 0 1024; !len > 0 do
    Buffer.add_substring b buf 0 !len
  done;
  close_in ic;
  Buffer.contents b

module SMap = struct
  include Map.Make(struct type t = string let compare = compare end)
  let rec removes l m =
    match l with [] -> m
    | k::l ->
        let m = try remove k m with Not_found -> m in
        removes l m
end

let rec labels_of_sty sty =
  match sty.ptyp_desc with
    Ptyp_arrow (lab, _, rem) -> lab :: labels_of_sty rem
  | Ptyp_alias (rem, _)      -> labels_of_sty rem
  |  _                       -> []

let rec labels_of_cty cty =
  match cty.pcty_desc with
    Pcty_fun (lab, _, rem) ->
      let (labs, meths) = labels_of_cty rem in
      (lab :: labs, meths)
  | Pcty_signature (_, fields) ->
      ([],
       List.fold_left fields ~init:[] ~f:
          begin fun meths -> function
              Pctf_meth (s, _, sty, _) -> (s, labels_of_sty sty)::meths
            | _ -> meths
          end)
  |  _ ->
      ([],[])

let rec pattern_vars pat =
  match pat.ppat_desc with
    Ppat_var s -> [s]
  | Ppat_alias (pat, s) ->
      s :: pattern_vars pat
  | Ppat_tuple l
  | Ppat_array l ->
      List.concat (List.map pattern_vars l)
  | Ppat_construct (_, Some pat, _)
  | Ppat_variant (_, Some pat)
  | Ppat_constraint (pat, _) ->
      pattern_vars pat
  | Ppat_record(l, _) ->
      List.concat (List.map l ~f:(fun (_,p) -> pattern_vars p))
  | Ppat_or (pat1, pat2) ->
      pattern_vars pat1 @ pattern_vars pat2
  | Ppat_lazy pat -> pattern_vars pat
  | Ppat_any | Ppat_constant _ | Ppat_construct _ | Ppat_variant _
  | Ppat_type _ ->
      []

let pattern_name pat =
  match pat.ppat_desc with
    Ppat_var s -> Some s
  | Ppat_constraint ({ppat_desc = Ppat_var s}, _) -> Some s
  | _ -> None

let insertions = ref []
let add_insertion pos s = insertions := (pos,s) :: !insertions
let sort_insertions () =
  List.sort !insertions ~cmp:(fun (pos1,_) (pos2,_) -> pos1 - pos2)

let is_space = function ' '|'\t'|'\n'|'\r' -> true | _ -> false
let is_alphanum = function 'A'..'Z'|'a'..'z'|'_'|'\192'..'\214'|'\216'..'\246'
  | '\248'..'\255'|'\''|'0'..'9' -> true
  | _ -> false

(* Remove "(" or "begin" before a pattern *)
let rec insertion_point pos ~text =
  let pos' = ref (pos-1) in
  while is_space text.[!pos'] do decr pos' done;
  if text.[!pos'] = '(' then insertion_point !pos' ~text else
  if !pos' >= 5 && String.sub text ~pos:(!pos'-4) ~len:5 = "begin"
  && not (is_alphanum text.[!pos'-5]) then insertion_point (!pos'-4) ~text
  else pos

(* Search "=" or "->" before "function" *)
let rec insertion_point2 pos ~text =
  let pos' = ref (pos-1) in
  while is_space text.[!pos'] do decr pos' done;
  if text.[!pos'] = '(' then insertion_point2 !pos' ~text else
  if !pos' >= 5 && String.sub text ~pos:(!pos'-4) ~len:5 = "begin"
  && not (is_alphanum text.[!pos'-5]) then insertion_point2 (!pos'-4) ~text
  else if text.[!pos'] = '=' then Some !pos' else
  if !pos' >= 1 && text.[!pos'-1] = '-' && text.[!pos'] = '>'
  then Some (!pos' - 1)
  else None

let rec insert_labels ~labels ~text expr =
  match labels, expr.pexp_desc with
    l::labels, Pexp_function(l', _, [pat, rem]) ->
      if l <> "" && l.[0] <> '?' && l' = "" then begin
        let start_c = pat.ppat_loc.Location.loc_start.Lexing.pos_cnum in
        let pos = insertion_point start_c ~text in
        match pattern_name pat with
        | Some name when l = name -> add_insertion pos "~"
        | _ -> add_insertion pos ("~" ^ l ^ ":")
      end;
      insert_labels ~labels ~text rem
  | l::labels, Pexp_function(l', _, lst) ->
      let pos = expr.pexp_loc.Location.loc_start.Lexing.pos_cnum in
      if l <> "" && l.[0] <> '?' && l' = ""
      && String.sub text ~pos ~len:8 = "function" then begin
        String.blit ~src:"match th" ~src_pos:0 ~dst:text
          ~dst_pos:pos ~len:8;
        add_insertion (pos+6) (l ^ " wi");
        match insertion_point2 pos ~text with
          Some pos' ->
            add_insertion pos' ("~" ^ l ^ " ")
        | None ->
            add_insertion pos ("fun ~" ^ l ^ " -> ")
      end;
      List.iter lst ~f:(fun (p,e) -> insert_labels ~labels ~text e)
  | _, Pexp_match( _, lst) ->
      List.iter lst ~f:(fun (p,e) -> insert_labels ~labels ~text e)
  | _, Pexp_try(expr, lst) ->
      insert_labels ~labels ~text expr;
      List.iter lst ~f:(fun (p,e) -> insert_labels ~labels ~text e)
  | _, ( Pexp_let(_,_,e) | Pexp_sequence(_,e) | Pexp_when(_,e)
       | Pexp_constraint(e,_,_) | Pexp_letmodule(_,_,e)
       | Pexp_ifthenelse(_,e,None) ) ->
      insert_labels ~labels ~text e
  | _, Pexp_ifthenelse (_, e1, Some e2) ->
      insert_labels ~labels ~text e1;
      insert_labels ~labels ~text e2
  | _ ->
      ()

let rec insert_labels_class ~labels ~text expr =
  match labels, expr.pcl_desc with
    l::labels, Pcl_fun(l', _, pat, rem) ->
      if l <> "" && l.[0] <> '?' && l' = "" then begin
        let start_c = pat.ppat_loc.Location.loc_start.Lexing.pos_cnum in
        let pos = insertion_point start_c ~text in
        match pattern_name pat with
        | Some name when l = name -> add_insertion pos "~"
        | _ -> add_insertion pos ("~" ^ l ^ ":")
      end;
      insert_labels_class ~labels ~text rem
  | labels, (Pcl_constraint (expr, _) | Pcl_let (_, _, expr)) ->
      insert_labels_class ~labels ~text expr
  | _ ->
      ()

let rec insert_labels_type ~labels ~text ty =
  match labels, ty.ptyp_desc with
    l::labels, Ptyp_arrow(l', _, rem) ->
      if l <> "" && l.[0] <> '?' && l' = "" then begin
        let start_c = ty.ptyp_loc.Location.loc_start.Lexing.pos_cnum in
        let pos = insertion_point start_c ~text in
        add_insertion pos (l ^ ":")
      end;
      insert_labels_type ~labels ~text rem
  | _ ->
      ()

let rec insert_labels_app ~labels ~text args =
  match labels, args with
    l::labels, (l',arg)::args ->
      if l <> "" && l.[0] <> '?' && l' = "" then begin
        let pos0 = arg.pexp_loc.Location.loc_start.Lexing.pos_cnum in
        let pos = insertion_point pos0 ~text in
        match arg.pexp_desc with
        | Pexp_ident(Longident.Lident name) when l = name && pos = pos0 ->
            add_insertion pos "~"
        | _ -> add_insertion pos ("~" ^ l ^ ":")
      end;
      insert_labels_app ~labels ~text args
  | _ ->
      ()

let insert_labels_app ~labels ~text args =
  let labels, opt_labels =
    List.partition labels ~f:(fun l -> l = "" || l.[0] <> '?') in
  let nopt_labels =
    List.map opt_labels
      ~f:(fun l -> String.sub l ~pos:1 ~len:(String.length l - 1)) in
  (* avoid ambiguous labels *)
  if List.exists labels ~f:(List.mem ~set:nopt_labels) then () else
  let aopt_labels = opt_labels @ nopt_labels in
  let args, lab_args = List.partition args ~f:(fun (l,_) -> l = "") in
  (* only optional arguments are labeled *)
  if List.for_all lab_args ~f:(fun (l,_) -> List.mem l ~set:aopt_labels)
  then insert_labels_app ~labels ~text args

let rec add_labels_expr ~text ~values ~classes expr =
  let add_labels_rec ?(values=values) expr =
    add_labels_expr ~text ~values ~classes expr in
  match expr.pexp_desc with
    Pexp_apply ({pexp_desc=Pexp_ident(Longident.Lident s)}, args) ->
      begin try
        let labels = SMap.find s values in
        insert_labels_app ~labels ~text args
      with Not_found -> ()
      end;
      List.iter args ~f:(fun (_,e) -> add_labels_rec e)
  | Pexp_apply ({pexp_desc=Pexp_send
                   ({pexp_desc=Pexp_ident(Longident.Lident s)},meth)}, args) ->
      begin try
        if SMap.find s values = ["<object>"] then
          let labels = SMap.find (s ^ "#" ^ meth) values in
          insert_labels_app ~labels ~text args
      with Not_found -> ()
      end
  | Pexp_apply ({pexp_desc=Pexp_new (Longident.Lident s)}, args) ->
      begin try
        let labels = SMap.find s classes in
        insert_labels_app ~labels ~text args
      with Not_found -> ()
      end
  | Pexp_let (recp, lst, expr) ->
      let vars = List.concat (List.map lst ~f:(fun (p,_) -> pattern_vars p)) in
      let vals = SMap.removes vars values in
      List.iter lst ~f:
        begin fun (_,e) ->
          add_labels_rec e ~values:(if recp = Recursive then vals else values)
        end;
      add_labels_rec expr ~values:vals
  | Pexp_function (_, None, lst) ->
      List.iter lst ~f:
        (fun (p,e) ->
          add_labels_rec e ~values:(SMap.removes (pattern_vars p) values))
  | Pexp_function (_, Some e, lst)
  | Pexp_match (e, lst)
  | Pexp_try (e, lst) ->
      add_labels_rec e;
      List.iter lst ~f:
        (fun (p,e) ->
          add_labels_rec e ~values:(SMap.removes (pattern_vars p) values))
  | Pexp_apply (e, args) ->
      List.iter add_labels_rec (e :: List.map snd args)
  | Pexp_tuple l | Pexp_array l ->
      List.iter add_labels_rec l
  | Pexp_construct (_, Some e, _)
  | Pexp_variant (_, Some e)
  | Pexp_field (e, _)
  | Pexp_constraint (e, _, _)
  | Pexp_send (e, _)
  | Pexp_setinstvar (_, e)
  | Pexp_letmodule (_, _, e)
  | Pexp_assert e
  | Pexp_lazy e
  | Pexp_poly (e, _)
  | Pexp_newtype (_, e)
  | Pexp_open (_, e) ->
      add_labels_rec e
  | Pexp_record (lst, opt) ->
      List.iter lst ~f:(fun (_,e) -> add_labels_rec e);
      begin match opt with Some e -> add_labels_rec e | None -> () end
  | Pexp_setfield (e1, _, e2)
  | Pexp_ifthenelse (e1, e2, None)
  | Pexp_sequence (e1, e2)
  | Pexp_while (e1, e2)
  | Pexp_when (e1, e2) ->
      add_labels_rec e1; add_labels_rec e2
  | Pexp_ifthenelse (e1, e2, Some e3) ->
      add_labels_rec e1; add_labels_rec e2; add_labels_rec e3
  | Pexp_for (s, e1, e2, _, e3) ->
      add_labels_rec e1; add_labels_rec e2;
      add_labels_rec e3 ~values:(SMap.removes [s] values)
  | Pexp_override lst ->
      List.iter lst ~f:(fun (_,e) -> add_labels_rec e)
  | Pexp_ident _ | Pexp_constant _ | Pexp_construct _ | Pexp_variant _
  | Pexp_new _ | Pexp_assertfalse | Pexp_object _ | Pexp_pack _ ->
      ()

let rec add_labels_class ~text ~classes ~values ~methods cl =
  match cl.pcl_desc with
    Pcl_constr _ -> ()
  | Pcl_structure (p, l) ->
      let values = SMap.removes (pattern_vars p) values in
      let values =
        match pattern_name p with None -> values
        | Some s ->
            List.fold_left methods
              ~init:(SMap.add s ["<object>"] values)
              ~f:(fun m (k,l) -> SMap.add (s^"#"^k) l m)
      in
      ignore (List.fold_left l ~init:values ~f:
        begin fun values -> function
          | Pcf_val (s, _, _, e, _) ->
              add_labels_expr ~text ~classes ~values e;
              SMap.removes [s] values
          | Pcf_meth (s, _, _, e, _) ->
              begin try
                let labels = List.assoc s methods in
                insert_labels ~labels ~text e
              with Not_found -> ()
              end;
              add_labels_expr ~text ~classes ~values e;
              values
          | Pcf_init e ->
              add_labels_expr ~text ~classes ~values e;
              values
          | Pcf_inher _ | Pcf_valvirt _ | Pcf_virt _ | Pcf_cstr _ -> values
          | Pcf_let _ -> values (* not in the grammar *)
        end)
  | Pcl_fun (_, opt, pat, cl) ->
      begin match opt with None -> ()
      | Some e -> add_labels_expr ~text ~classes ~values e
      end;
      let values = SMap.removes (pattern_vars pat) values in
      add_labels_class ~text ~classes ~values ~methods cl
  | Pcl_apply (cl, args) ->
      List.iter args ~f:(fun (_,e) -> add_labels_expr ~text ~classes ~values e);
      add_labels_class ~text ~classes ~values ~methods cl
  | Pcl_let (recp, lst, cl) ->
      let vars = List.concat (List.map lst ~f:(fun (p,_) -> pattern_vars p)) in
      let vals = SMap.removes vars values in
      List.iter lst ~f:
        begin fun (_,e) ->
          add_labels_expr e ~text ~classes
            ~values:(if recp = Recursive then vals else values)
        end;
      add_labels_class cl ~text ~classes ~values:vals ~methods
  | Pcl_constraint (cl, _) ->
      add_labels_class ~text ~classes ~values ~methods cl

let add_labels ~intf ~impl ~file =
  insertions := [];
  let values, classes =
    List.fold_left intf ~init:(SMap.empty, SMap.empty) ~f:
      begin fun (values, classes as acc) item ->
        match item.psig_desc with
          Psig_value (name, {pval_type = sty}) ->
            (SMap.add name (labels_of_sty sty) values, classes)
        | Psig_class l ->
          (values,
           List.fold_left l ~init:classes ~f:
             begin fun classes {pci_name=name; pci_expr=cty} ->
               SMap.add name (labels_of_cty cty) classes
             end)
        | _ ->
            acc
      end
  in
  let text = input_file file in
  ignore (List.fold_right impl ~init:(values, classes) ~f:
    begin fun item (values, classes as acc) ->
      match item.pstr_desc with
        Pstr_value (recp, l) ->
          let names =
            List.concat (List.map l ~f:(fun (p,_) -> pattern_vars p)) in
          List.iter l ~f:
            begin fun (pat, expr) ->
              begin match pattern_name pat with
              | Some s ->
                  begin try
                    let labels = SMap.find s values in
                    insert_labels ~labels ~text expr;
                    if !norec then () else
                    let values =
                      SMap.fold
                        (fun s l m ->
                          if List.mem s names then SMap.add s l m else m)
                        values SMap.empty in
                    add_labels_expr expr ~text ~values ~classes:SMap.empty
                  with Not_found -> ()
                  end
              | None -> ()
              end;
            end;
          (SMap.removes names values, classes)
      | Pstr_primitive (s, {pval_type=sty}) ->
          begin try
            let labels = SMap.find s values in
            insert_labels_type ~labels ~text sty;
            (SMap.removes [s] values, classes)
          with Not_found -> acc
          end
      | Pstr_class l ->
          let names = List.map l ~f:(fun pci -> pci.pci_name) in
          List.iter l ~f:
            begin fun {pci_name=name; pci_expr=expr} ->
              try
                let (labels, methods) = SMap.find name classes in
                insert_labels_class ~labels ~text expr;
                if !norec then () else
                let classes =
                  SMap.fold
                    (fun s (l,_) m ->
                      if List.mem s names then SMap.add s l m else m)
                    classes SMap.empty in
                add_labels_class expr ~text ~classes ~methods
                  ~values:SMap.empty
              with Not_found -> ()
            end;
          (values, SMap.removes names classes)
      | _ ->
          acc
    end);
  if !insertions <> [] then begin
    let backup = file ^ ".bak" in
    if Sys.file_exists backup then Sys.remove file
    else Sys.rename file backup;
    let oc = open_out file in
    let last_pos =
      List.fold_left (sort_insertions ()) ~init:0 ~f:
        begin fun pos (pos', s) ->
          output oc text pos (pos'-pos);
          output_string oc s;
          pos'
        end in
    if last_pos < String.length text then
      output oc text last_pos (String.length text - last_pos);
    close_out oc
  end
  else prerr_endline ("No labels to insert in " ^ file)

let process_file file =
  prerr_endline ("Processing " ^ file);
  if Filename.check_suffix file ".ml" then
    let intf = Filename.chop_suffix file ".ml" ^ ".mli" in
    let ic = open_in intf in
    let lexbuf = Lexing.from_channel ic in
    Location.init lexbuf intf;
    let intf = Parse.interface lexbuf in
    close_in ic;
    let ic = open_in file in
    let lexbuf = Lexing.from_channel ic in
    Location.init lexbuf file;
    let impl = Parse.implementation lexbuf in
    close_in ic;
    add_labels ~intf ~impl ~file
  else prerr_endline (file ^ " is not an implementation")

let main () =
  let files = ref [] in
  Arg.parse ["-norec", Arg.Set norec, "do not labelize recursive calls"]
    (fun f -> files := f :: !files)
    "addlabels [-norec] <files>";
  let files = List.rev !files in
  List.iter files ~f:process_file

let () = main ()