(* $Id: rename.ml 1873 2013-07-31 19:11:09Z gerd $
 * ----------------------------------------------------------------------
 *
 *)


open Syntax;;

let name_mapping
      ~rename_constant
      ~rename_enum
      ~rename_type
      ~rename_union_component
      ~rename_struct_component
      ~rename_program
      ~rename_version
      ~rename_procedure
      dl =

  let rec check_type t =
    match t with
	T_option t'          -> check_type t'
      | T_array_fixed(_,t')  -> check_type t'
      | T_array(_,t')        -> check_type t'
      | T_array_unlimited t' -> check_type t'
      | T_enum l ->
	  List.iter (fun (id,_) -> rename_enum id) l
      | T_struct (opts,tdl) ->
          if not (List.mem `Tuple opts) then
	    List.iter (fun td -> rename_struct_component td.decl_symbol) tdl;
	  List.iter (fun td -> check_type td.decl_type) tdl;
      | T_union u ->
	  let decls =
	    List.map (fun (_,_,td) -> td) u.cases @
	    match u.default with Some d -> [d] | None -> [] in
	  List.iter (fun td -> rename_union_component td.decl_symbol) decls;
	  List.iter (fun td -> check_type td.decl_type) decls;
      | _ ->
	  ()
  in

  List.iter
    (function
	 Typedef td ->
	   rename_type td.decl_symbol;
	   check_type td.decl_type
       | Constdef (id,_) ->
	   rename_constant id
       | Progdef p ->
	   rename_program p.prog_symbol;
	   List.iter
	     (fun v ->
		rename_version p.prog_symbol v.version_symbol;
		List.iter
		  (fun proc ->
		     rename_procedure
		       p.prog_symbol v.version_symbol proc.proc_symbol;
		     List.iter check_type proc.proc_params;
		     check_type proc.proc_result
		  )
		  v.version_def
	     )
	     p.prog_def
    )
    dl
;;


let reserved =
  [ (* Reserved by ocamlrpcgen: *)
    "create_client";
    "create_portmapped_client";
    "create_server";
    "create_async_server";
    (* O'Caml keywords: *)
    "and";
    "as";
    "assert";
    "asr";
    "begin";
    "class";
    "closed";
    "constraint";
    "do";
    "done";
    "downto";
    "else";
    "end";
    "exception";
    "external";
    "false";
    "for";
    "fun";
    "function";
    "functor";
    "if";
    "in";
    "include";
    "inherit";
    "land";
    "lazy";
    "let";
    "lor";
    "lsl";
    "lsr";
    "lxor";
    "match";
    "method";
    "mod";
    "module";
    "mutable";
    "new";
    "object";
    "of";
    "open";
    "or";
    "parser";
    "private";
    "rec";
    "sig";
    "struct";
    "then";
    "to";
    "true";
    "try";
    "type";
    "val";
    "virtual";
    "when";
    "while";
    "with";
  ]
;;


let reserved_table =
  let t = Hashtbl.create 100 in
  List.iter
    (fun n -> Hashtbl.add t n ())
    reserved;
  t
;;


let simple_name_mapping dl =
  (* names of constants => lowercase     [value namespace]
   * names of enums => lowercase         [same namespace as constants]
   * names of types => lowercase         [type namespace]
   * names of union components => Capitalized    [no namespace]
   * names of struct components => lowercase     [component namespace]
   * names of programs and versions => Capitalized [==> modules]
   * names of procedures => lowercase    [value namespace within version module]
   *
   * names of discriminants do not occur in O'Caml
   *)

  (* Every list enumerates the names already used: *)
  let value_ns = ref [] in
  let type_ns = ref [] in
  let comp_ns = ref [] in
  let module_ns = ref [] in

  (* --- ROUND 1: Assign requested names ---------------------------------- *)
  let check_lowercase id =
    let c = id.ocaml_name.[0] in
    if c <> Char.lowercase c then
      error ("Name mapping fails for requested O'Caml name `" ^
	     id.ocaml_name ^ "': name must be lowercase");
  in

  let check_uppercase id =
    let c = id.ocaml_name.[0] in
    if c <> Char.uppercase c then
      error ("Name mapping fails for requested O'Caml name `" ^
	     id.ocaml_name ^ "': name must be uppercase");
  in

  let assign_requested_name ?(prefix = (fun s->s)) ns uc id =
    if id.ocaml_name_requested then begin
      if Hashtbl.mem reserved_table id.ocaml_name then
	error ("Name mapping fails for requested O'Caml name `" ^
	       id.ocaml_name ^ "': name is reserved");
      if List.mem (prefix id.ocaml_name) !ns then
	error ("Name mapping fails for requested O'Caml name `" ^
	       id.ocaml_name ^ "': name has been assigned twice");
      (if uc then check_uppercase else check_lowercase) id;
      ns := (prefix id.ocaml_name) :: !ns
    end
  in

  let assign_requested_version_name prog_id vers_id =
    assign_requested_name
      ~prefix: (fun n -> prog_id.ocaml_name ^ "." ^ n)
      module_ns
      true
      vers_id
  in

  let assign_requested_procedure_name prog_id vers_id proc_id =
    assign_requested_name
      ~prefix: (fun n -> prog_id.ocaml_name ^ "." ^
		         vers_id.ocaml_name ^ "." ^ n)
      module_ns
      false
      proc_id
  in

  name_mapping
    ~rename_constant:        (assign_requested_name value_ns false)
    ~rename_enum:            (assign_requested_name value_ns false)
    ~rename_type:            (assign_requested_name type_ns false)
    ~rename_union_component: (fun _ -> ())
    ~rename_struct_component:(assign_requested_name comp_ns false)
    ~rename_program:         (assign_requested_name module_ns true)
    ~rename_version:         assign_requested_version_name
    ~rename_procedure:       assign_requested_procedure_name
    dl;

  (* --- ROUND 2: Map other names somehow --------------------------------- *)

  let get_lowercase id = String.lowercase id.xdr_name in
  let get_uppercase id = String.capitalize id.xdr_name in

  let map_name ?(prefix = (fun s -> s)) ns uc id =
    if not id.ocaml_name_requested then begin
      let n = ref ((if uc then get_uppercase else get_lowercase) id) in
      let renamed = ref false in
      while List.mem (prefix !n) !ns || Hashtbl.mem reserved_table !n do
	n := !n ^ "'";
	renamed := true
      done;
      if !renamed then
	prerr_endline("Warning: Renamed \"" ^
		      prefix id.xdr_name ^ "\" to \"" ^
		      prefix !n ^ "\"");
      id.ocaml_name <- !n;
      ns := (prefix !n) :: !ns
    end
  in

  let map_version_name prog_id vers_id =
    map_name
      ~prefix: (fun n -> prog_id.ocaml_name ^ "." ^ n)
      module_ns
      true
      vers_id
  in

  let map_procedure_name prog_id vers_id proc_id =
    map_name
      ~prefix: (fun n -> prog_id.ocaml_name ^ "." ^
		         vers_id.ocaml_name ^ "." ^ n)
      module_ns
      false
      proc_id
  in

  let retain_name id =
    if not id.ocaml_name_requested then
      id.ocaml_name <- id.xdr_name
  in

  name_mapping
    ~rename_constant:        (map_name value_ns false)
    ~rename_enum:            (map_name value_ns false)
    ~rename_type:            (map_name type_ns false)
    ~rename_union_component: retain_name
    ~rename_struct_component:(map_name comp_ns false)
    ~rename_program:         (map_name module_ns true)
    ~rename_version:         map_version_name
    ~rename_procedure:       map_procedure_name
    dl;
;;

