(************************************************************
   ocamlXML.ml	Created      : Tue Dec 24 21:03:33 2002
  			Last modified: Thu Oct 16 04:06:46 2003
  Compile: ocamlc str.cma parse.cma ocamlXML.ml -o ocamlXML #
  コンパイル前に ocaml-3.06 の parsing ディレクトリないでこれを実行↓
  (存在しないファイルは util とかから適当にコピー)
ocamlc -a -o parse.cma config.mli config.ml clflags.ml misc.mli misc.ml warnings.mli warnings.ml longident.mli longident.ml location.mli linenum.mli linenum.ml location.ml asttypes.mli parsetree.mli syntaxerr.mli syntaxerr.ml parser.mli parser.ml lexer.mli lexer.ml parse.mli parse.ml
  FTP Directory: sources/ocaml #
************************************************************)
(**
  
  @author Takashi Masuyama <mamewo@dk9.so-net.ne.jp>

*)

open Parsetree
open Longident
open Printf
open Location
exception ErrorMessage of string

let verbose_mode = ref false

let print_verbose_message message =
  if !verbose_mode then
    prerr_endline message
;;

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

let string_of_expression_constr = function
    Pexp_ident (id) -> sprintf "Pexp_ident (%s)" (ident_to_string id)
  | Pexp_constant (_) -> "Pexp_constant"
  | Pexp_let (_,_,_) -> "Pexp_let"
  | Pexp_function (_,_,_) -> "Pexp_function"
  | Pexp_apply (_,_) -> "Pexp_apply"
  | Pexp_match (_,_) -> "Pexp_match"
  | Pexp_poly (_,_) -> "Pexp_poly"
  | Pexp_construct (id,_,b) -> 
      sprintf "Pexp_construct(%s,_,%b)" (ident_to_string id) b
  | Pexp_variant (_,_) -> "Pexp_variant"
  | _ -> "mmmmm....(string_of_expression_constr)" 
;;

let rec visit_pexp_expression filename call_list f e =
  (* pel は patternと式のtoupleのリスト*)
  (* カリー化 引数を一つもらって関数を返す *)
  (* なんでもかんでもいれてみる *)
  match e.pexp_desc with
    Pexp_function(_, _, pel) ->
      (* pel は引数即 match に対応 function A -> ... | B -> ... のような *)
      List.fold_right (fun (p, e) call_list -> visit_pexp_expression filename call_list f e)
	pel call_list
  | Pexp_apply(e, lel) ->
      let call_list = 
	(match e.pexp_desc with
	  Pexp_ident id ->
	    (* longident -> string *)
	    (* やっぱり set が無難 /home/tak/lib/ocaml/graph.ml *)
	    print_verbose_message ("ocamlXML: Pexp_apply -> Pexp_ident: "^(ident_to_string id));
	    (ident_to_string id, e.pexp_loc.loc_start)::call_list
	| _ -> 
	    visit_pexp_expression filename call_list f e) in
      let call_list =
	List.fold_right (fun (_, e) call_list -> visit_pexp_expression filename call_list f e) lel call_list in
      call_list
(*      | Pexp_function (_, _, pel) as func ->*)
(*	  List.fold_right (fun (p, e) sg -> visit_pexp_expression sg f e)*)
(*	    pel sg*)
(*      | _ ->*)
(*	  prerr_endline "sorry I can't understand (apply)";*)
(*	  sg)*)
  | Pexp_record (iel, eoption) ->
      let new_sg = 
	List.fold_right (fun (_, e) call_list -> visit_pexp_expression filename call_list f e) iel call_list in
      (match eoption with
	Some e -> visit_pexp_expression filename new_sg f e
      | None -> new_sg)
  | Pexp_let(_, pel, e) ->
      (* pelのところはどうしようかねぇ *)
      let call_list = 
	List.fold_right (fun (_, e) call_list -> visit_pexp_expression filename call_list f e) pel call_list in
      visit_pexp_expression filename call_list f e
  | Pexp_ifthenelse(b, thenpart, elsepartoption) ->
      let lst = match elsepartoption with
	Some elsepart -> [b; thenpart; elsepart]
      | None -> [b; thenpart] in
      List.fold_right (fun e call_list -> visit_pexp_expression filename call_list f e) lst call_list
  | Pexp_try (target_exp, pel) 
  | Pexp_match (target_exp, pel) ->
      let call_list = visit_pexp_expression filename call_list f target_exp in
      List.fold_right (fun (_,e) call_list -> visit_pexp_expression filename call_list f e) pel call_list
  | Pexp_tuple el
  | Pexp_array el ->
      List.fold_right (fun e call_list -> visit_pexp_expression filename call_list f e) el call_list
  | Pexp_construct(_, Some(e), _) 
  | Pexp_variant(_, Some(e))
  | Pexp_letmodule (_, _, e)
  | Pexp_lazy e 
  | Pexp_assert e (* 微妙 *)
  | Pexp_field (e,_)
  | Pexp_poly (e, _) ->
      visit_pexp_expression filename call_list f e
  | Pexp_when (e1, e2)
  | Pexp_sequence(e1, e2) ->
      visit_pexp_expression filename (visit_pexp_expression filename call_list f e1) f e2
  | Pexp_for(_, e1, e2, _, e3) ->
      List.fold_right (fun e call_list -> visit_pexp_expression filename call_list f e) [e1; e2; e3] call_list
(*  | Pexp_setfield*)
  | Pexp_constant _ | Pexp_ident _ 
  | Pexp_variant(_, _)
  | Pexp_construct(_,_,_) | Pexp_assertfalse -> call_list
  | _ -> print_verbose_message 
	("sorry I'm considering: "^(string_of_expression_constr e.pexp_desc)); 
      call_list
;;

let visit_pstr_value_element filename (p, e) =
  match (p.ppat_desc, e.pexp_desc) with 
    (* 関数定義であることを確認しよう *)
    (Ppat_var f, Pexp_function (_, _, _) as func) -> 
      Some (f, visit_pexp_expression filename [] f e)
  | _ -> None (* 保留 *)
;;

let rec visit_structure_item_desc filename t result = 
  match t with
    Pstr_value(_, pel) ->
      List.fold_right (fun pe lst -> 
	let result = visit_pstr_value_element filename pe in 
	match result with 
	  Some p -> p::lst
	| None -> lst) pel result
  | Pstr_module(_, me) ->
      visit_module_expr_desc filename me.pmod_desc result
  | _ -> result

and visit_module_expr_desc filename t sp =
  match t with
    Pmod_structure (str) ->
      List.fold_right (fun x -> visit_structure_item_desc filename x.pstr_desc) str sp
  | _ -> 
      print_verbose_message "i'm considering about sub module especially about functor (visit_module_expr_desc)";
      sp

(* entry point *)
let visit_structure filename tree =
  List.fold_right (fun e -> visit_structure_item_desc filename e.pstr_desc) tree []

let string_of_location l =
  Printf.sprintf "%d - %d" l.Location.loc_start l.Location.loc_end

let parse_with_error_report l =
  try 
    Parse.implementation l
  with
    Syntaxerr.Error e ->
      raise (ErrorMessage (match e with
	Syntaxerr.Other loc -> 
	  ("Syntax error occured "^(string_of_location loc)^"\n\t"^(Lexing.lexeme l))
      | _ -> 
	  "Sorry I don't know (syntax error)"))
;;
  
let parse_from_channel c = parse_with_error_report (Lexing.from_channel c)

let main () =
  let eliminate_primitives = ref false in
  let files = ref [] in 
  let primitive_operators = 
    [ "^"; "!="; "+"; "+."; "-"; "-."; "||"; "&&"; "<>"; "=="; ":="; "raise";
      "assert"; "ignore"; "not"; "!"; "ref"; "@"] in
  let specs =
    [ ("-elim", Arg.Set(eliminate_primitives), "eliminate primitives");
      ("-v", Arg.Set(verbose_mode), "print verbose messages") ] in  
  let devel_path = "/home/tak/project/analyze_ocaml/customized_parsing/ocamlXML.ml" in
  let usage_line = (Sys.argv.(0) ^ " [filenames]\n  draw static call graph of ocaml (for version 3.06)\n  developping in \"" ^ devel_path ^ "\"") in
   let _ = Arg.parse specs (fun x -> files := x::!files) usage_line in
  match !files with
    [] ->
      begin prerr_endline "no filename!!"; Arg.usage specs usage_line; exit 1 end;
  | lst -> 
      let parse filename = 
	let in_channel = open_in filename in
	let t = parse_from_channel in_channel in
	close_in in_channel;
	(filename, visit_structure filename t) in
      List.iter (fun (filename, f_call_list) ->
	print_endline ("<file filename=\""^filename^"\">");
	List.iter (fun (f, call_list) ->
	  print_endline ("  <function name=\""^f^"\" filename=\""^filename^"\">");
	  List.iter (fun (call, pos) ->
	    print_endline ("    <call name=\""^call^"\" position=\""^(string_of_int pos)^"\" />"))
	    call_list;
	  print_endline "  </function>") f_call_list;
	print_endline "</file>")
	(List.map parse !files)
;;

let _ = main ()