(************************************************************
   treat_type.ml	Created      : Thu Nov 28 00:07:45 2002
  			Last modified: Tue Dec 17 10:35:07 2002
  Compile: make #
  FTP Directory: sources/ocaml #
************************************************************)
(**
  @author Takashi Masuyama <mamewo@dk9.so-net.ne.jp>
  やりたいこと
  
{ol
   {- 型 t の定義があったときにその型定義がどの型に関連するか }
   {- あるコンストラクタがどの型と関係するか }
}

を視覚化したい。まず前者のみを作ってみる。

2002/12/16
  レコードのフィールドの型に関係するのが Ptyp_poly であることが判明
  parser.mly の中。
poly_type: ...
label_declaration:
    mutable_flag label COLON poly_type          { ($2, $1, $4) }
;
method_type:
    METHOD private_flag label COLON poly_type
      { $3, $2, $5, symbol_rloc () }
;
他にもある。メソッド関係に多い。

2002/12/15
  type_declaration は type t = string における string の部分に
対応し、型がレコードであるか、バリアントであるか、abstract (他の
型名。型に別名をつけるとか)であるかを ptype_kind フィールドに
書いている。おそらく、それと連動して、 type_declaration の
ptype_manifest が書かれる。このフィールドは type_declaration が
Ptype_abstract ならば何か書かれ Some ... そうでなければ書かれない
(None) と推測した。がとりあえず、いつも ptype_kind に書いてある
コンストラクタ情報を集め、それから、 ptype_manifest 部分に書かれた
型名を集めている。レコードのフィールド名はまだ集めていない。
  やりたいこと
    型名 -> すべてのコンストラクタ名
    コンストラクタ名 -> 型
    Ptype_abstract のときの 型名 -> 型

2002/12/12 
  久々にさわった。使い方
Xmamewo:~/project/analyze_ocaml/customized_parsing> ocaml
        Objective Caml version 3.06
# #use "init.ml";;
val l : Lexing.lexbuf =
...
# let f = face ();;
print expression
type a = int;;
val f : Parsetree.signature =
  [{Parsetree.psig_desc =
     Parsetree.Psig_type
...
# dump (visit_signature f);;
a
- : unit = ()

あら、期待した結果と違う
*)

(**
{v core_type_desc = 
    Ptyp_any
  | Ptyp_var of string
  | Ptyp_arrow of label * core_type * core_type
  | Ptyp_tuple of core_type list
  | Ptyp_constr of Longident.t * core_type list
  | Ptyp_object of core_field_type list
  | Ptyp_class of Longident.t * core_type list * label list
  | Ptyp_alias of core_type * string
  | Ptyp_variant of row_field list * bool * label list option
  | Ptyp_poly of string list * core_type
v}

{v
About Longident.t
type t =
    Lident of string
  | Ldot of t * string
  | Lapply of t * t (** functor application *)
v}

{v
type 'b t = A of string * in_channel * 'b | B;;
     {ptype_params = ["b"]; ptype_cstrs = [];
      ptype_kind =
       Ptype_variant
        [("A",
         [{ptyp_desc = Ptyp_constr (Longident.Lident "string", []);
           ptyp_loc =
            {Location.loc_start = 229; Location.loc_end = 235;
             Location.loc_ghost = false}};
          {ptyp_desc = Ptyp_constr (Longident.Lident "in_channel", []);
           ptyp_loc =
            {Location.loc_start = 238; Location.loc_end = 248;
             Location.loc_ghost = false}};
          {ptyp_desc = Ptyp_var "b";
           ptyp_loc =
            {Location.loc_start = 251; Location.loc_end = 253;
             Location.loc_ghost = false}}]);
         ("B", [])];
      ptype_manifest = None; ptype_variance = [(false, false)];
      ptype_loc =
       {Location.loc_start = 216; Location.loc_end = 257;
        Location.loc_ghost = false}}
v}
*)
open Parsetree
open Longident
(**
  Constr -> type
  Lindent -> type
*)
(*let abstract_tag = "#abstract#"*)
module NodeSet = Set.Make(String)

module MultiMap =
  struct 
    module Make = functor (Ord : Map.OrderedType)  ->
      struct
	module M = Map.Make(Ord)
	let empty = M.empty
	    (* 単に値の部分をリストにするだけ。 *)
	let add k v mm =
	  try
	    let lst = M.find k mm in
	    M.add k (v::lst) mm
	  with
	    Not_found -> M.add k [v] mm
	let find = M.find
	let iter = M.iter
      end
  end

(*module EdgeSet = Set.Make(Edge)*)
module EdgeMap = Map.Make(String)
module EdgeMultiMap = MultiMap.Make(String)

(* tとしてぶちこむのを何にするか? *)

type type_def_value = Constructor of string | OtherType of string | Field of string
let get_name_of_type_def_value = function 
    Constructor t 
  | OtherType t 
  | Field t -> t

(* 結果 *)

(* この複雑な touple 本当は型で制限できます *)
let make_add_function f =
  (fun t (node_set, t_to_constr, constr_to_t, t_to_t, field_to_t) ->
    let new_node_set = NodeSet.add (get_name_of_type_def_value t) node_set in
    (* letにパターンが書ける爽快感 *)
    let new_t_to_constr, new_constr_to_t, new_t_to_t, new_field_to_t = 
      match t with 
	Constructor t -> (EdgeMultiMap.add f t t_to_constr,
			  EdgeMap.add t f constr_to_t,
			  t_to_t,
			  field_to_t)
      | Field t -> (t_to_constr,
		    constr_to_t,
		    t_to_t,
		    EdgeMap.add t f field_to_t)
      | OtherType t -> (t_to_constr,
			constr_to_t,
			EdgeMultiMap.add f t t_to_t,
			field_to_t) in
    (new_node_set, new_t_to_constr, new_constr_to_t, new_t_to_t, new_field_to_t))

let visit_signature sil =
  let rec ident_to_string = function
    Lident(s) -> s
  | Ldot(t,s) -> s^"."^(ident_to_string t)
  | Lapply(f,a) -> (ident_to_string f)^"("^(ident_to_string a)^")" in

  let rec visit_core_type f t p =
    visit_core_type_desc f t.ptyp_desc p					    
      
  and visit_core_type_desc f td p =
    match td with
      Ptyp_any -> prerr_endline "Ptyp_any occured\n"; p
    | Ptyp_var(s) -> (* 型変数 *) p
    | Ptyp_arrow(l, domain, range) -> (* オプション引数などのラベルのこと *)
	visit_core_type f range (visit_core_type f domain p)
    | Ptyp_tuple(ctl) -> (* *)
	List.fold_right (visit_core_type f) ctl p
    | Ptyp_constr(ident, tl) -> (* int, string などもここに含まれるのだよ *)
	f (OtherType(ident_to_string ident)) p
    | Ptyp_object(cftl) -> prerr_endline "objects are not supported"; p
    | Ptyp_class(ident, ctl, ll) ->
	prerr_endline "objects(class) are not supported\n"; p
    | Ptyp_alias(ct, s) -> prerr_endline "Aliases are not supported"; p
    | Ptyp_variant(rfl, b, llopt) ->
	(* OO関係 無視 *)
	prerr_endline "I don't know about variant"; p
    | Ptyp_poly(sl, ct) -> 
	(* ラベルの直後にくる? *)
	(* とりあえずは何もしない *)
	prerr_endline "I don't know about polymorphic type\n"; p

  and visit_type_declaration f td p = 
    (* Parsetree.Psig_type の引数のリストの要素 *)
    let from_kind = visit_type_kind f td.ptype_kind p in
    match td.ptype_manifest with
      Some t -> visit_core_type f t from_kind 
    | None -> from_kind
      
  and visit_type_kind f tk p =
    match tk with
      Ptype_abstract -> p
    | Ptype_record (l) ->
	List.fold_right
	  (fun (name, is_mutable, t) p ->
	    let new_p = f (Field(name)) p in
	    visit_core_type f t new_p) l p
    | Ptype_variant(l) ->
	(* コンストラクタと引数の型情報 *)
	List.fold_right (fun (name, t) p ->
	  List.fold_right (visit_core_type f)
	    t (f (Constructor(name)) p)) l p
	  
  and visit_signature_item si p =
    visit_signature_item_desc "" si.psig_desc p
      
(* current module 情報 *)
(* こういうときのレコードでしょう *) 
  and visit_signature_item_desc prefix sid
      ((node_set, t_to_constr, constr_to_t, t_to_t, field_to_t) as p) =
    match sid with
      Psig_type(l) ->
	List.fold_right
	(fun (name, td) (node_set, t_to_constr, constr_to_t, t_to_t, field_to_t) ->
	  (* 定義部の左辺 (新たに定義された型名) を集合に入れておいて、右を見に行く *)
	  let new_node_set = NodeSet.add name node_set in
	  visit_type_declaration (make_add_function name) td 
	    (new_node_set, t_to_constr, constr_to_t, t_to_t, field_to_t)) l p
    | _ -> p in
  List.fold_right visit_signature_item sil
    (NodeSet.empty, EdgeMultiMap.empty, EdgeMap.empty, EdgeMultiMap.empty, EdgeMap.empty)
    
let dump (node_set, t_to_constr, constr_to_t, t_to_t, field_to_t) =
  NodeSet.iter print_endline node_set;
  print_endline "constr_to_t -----------------------";
  EdgeMap.iter (fun x y ->  Printf.printf "(%s, %s)\n" x y) constr_to_t;
  print_endline "field_to_t -----------------------";
  EdgeMap.iter (fun x y ->  Printf.printf "(%s, %s)\n" x y) field_to_t;
  List.iter (fun (name, s) -> print_endline (name^" ---------------");
    EdgeMultiMap.iter (fun x y ->
      List.iter (fun y -> Printf.printf "(%s, %s)\n" x y) y) s)
    [("t_to_constr", t_to_constr); ("t_to_t", t_to_t) ]

let parse_from_string s =
  Parse.interface (Lexing.from_string s)

let parse_from_channel c =
  Parse.interface (Lexing.from_channel c)

let print_t_to_constr_vcg (node_set, t_to_constr, _, _, _) =
  print_endline "graph: {";
  NodeSet.iter (fun e ->
    Printf.printf "  node: { label: \"%s\" title: \"%s\"}\n" e e) node_set;
  EdgeMultiMap.iter
    (fun s tl ->
      List.iter (fun t ->
	Printf.printf "  edge: { sourcename: \"%s\" targetname: \"%s\"}\n" s t) tl)
    t_to_constr;
  print_endline "}"

let _ =
  let print_usage () =
    Printf.printf "usage: %s [ocaml_filename]\n" Sys.argv.(0) in
  if Array.length Sys.argv != 2 then
    begin
      print_usage (); exit 1
    end
  else
    let filename = Sys.argv.(1) in
    print_endline filename;
    let t = parse_from_channel (open_in filename) in
    print_t_to_constr_vcg (visit_signature t)