(************************************************************
   drawMakefile.ml	Created      : Sat Aug 24 01:28:13 2002
  			Last modified: Thu Oct 17 20:22:04 2002
  Compile: ocamlopt.opt -I /home/tak/lib/ocaml str.cmxa mylib.cmxa drawMakefile.ml -o drawMakefile #
  Compile: ocamlc str.cma drawMakefile.ml -g -o drawMakefile #
  Compile: ocamldoc -html -d doc -warn-error drawMakefile.ml
************************************************************)
(** 
   {{: http://www.gaertner.de/~lindig/software/ocamldoc.html} ocamldoc} を使ってみた

  使いやすくするためにすべきこと
   {ul
   {- オプションを整備していない。メイン部分を書き換える必要あり}
   {- 枝は一番外のグラフにかためてあるがこれで良いか?}
   }

   ocamldocについてのコメント
{v
   (**
    *
    *)
v}
  のようなコメントを書くと途中の*が表示されてかっちょわるくなる。

  @author 増山隆
  @version $Id: drawMakefile.ml,v 1.1.1.1 2002/10/17 11:06:27 tak Exp $
  @see <http://www002.upp.so-net.ne.jp/mamewo/ml.html#Pervasives> Pervasivesモジュールの説明
  @see <http://www002.upp.so-net.ne.jp/mamewo/ml.html> 作者のウェブページ
*)

exception Error of string
(* 設定すべき変数たち *)
let title = "Makefile test"
let edge_class = 2
let path_delimiter_regexp = Str.regexp "/"

(** 
  実験。実験
  名前とIDのペアを要素とする木
 *)
module NameTree =
  struct
    type elt = string * string
    type t =
	Node of string * (t list) | Leaf of elt
    let empty = Node(("."),[])
    let get_name = function
	Node(name,_) -> name
      | Leaf(name,_) -> name
    let rec dig id = function
	[] -> raise (Error "assert no reached\n")
      | [file] -> Leaf(file,id)
      | head::tail ->
	  Node(head,[(dig id tail)]) 

	    (** 
	       @param path パスを文字列リストで表したもの
	       @param tree 要素を足す木
	     *)
    let add id path tree =
      let rec sub path tree =
	match path with 
	  [leaf] -> 
	    (match tree with 
	      Leaf(_) -> raise (Error "can't add to leaf\n")
	    | Node(dir_name,file_list) ->
		Node(dir_name,(try
		  ignore (List.find (fun x -> leaf = (get_name x)) file_list);
		  file_list
		with 
		  Not_found ->
		    (Leaf(leaf,id)::file_list))))
	| [] ->
	    raise (Error "assert no reached\n")
	| head::tail ->
	    match tree with
	      Leaf(_) -> raise (Error "can't add to leaf\n")
	    | Node(root_name , file_list) ->
		let (next,remain) = 
		  List.partition (fun x -> head = (get_name x)) file_list in
		(match next with 
		  [] ->
		  (* 一直線に掘っていく mkdir -p みたいに*)
		    Node(root_name,(dig id path)::remain)
		| [dir] ->
		     Node(root_name,(sub tail dir)::remain)
		| _ ->
		    raise 
		      (Error ("directorys with a same name detected: " ^ head ^ "\n"))) in
      sub path tree
  end

(* Application *)

let print_vcg tree =
  let rec sub space = function
      NameTree.Leaf(name,id) ->
	Printf.printf "%snode: { title:\"%s\" label: \"%s\" }\n" space id name
    | NameTree.Node(name,file_list) ->
	Printf.printf "%sgraph: { title:\"%s\"\n" space name;
	List.iter (fun x -> sub ("  "^space) x)  file_list;
	print_string (space ^ "}\n") in
  sub "  " tree

let grouping in_channel =
  let edge_list = ref [] in
  let root = ref (NameTree.Node(".",[])) in
  begin
    try
      while true do
	let (head,tail_list) = Mylib.read_dependency_file in_channel in
	begin 
	  (* ディレクトリベースのグループ化 (サブグラフに対応づける) *)
	  root := NameTree.add head (Str.split path_delimiter_regexp head) !root;
	  List.iter (fun x -> edge_list := (head,x)::!edge_list) tail_list;
	  List.iter (fun x -> root := NameTree.add (snd x) (fst x) !root)
	    (List.map (fun x -> (Str.split path_delimiter_regexp x),x) tail_list)
	end
      done;
      ()
    with
      End_of_file -> 
	(match !root with
	  NameTree.Node(name,list) ->
	    begin
	      Printf.printf "graph: { title: \"%s\"\n" name;
	      List.iter (fun x -> print_vcg x) list;
	      List.iter
		(fun x -> (Printf.printf 
			     "  edge: { sourcename: \"%s\" targetname: \"%s\" class: 2}\n"
			     (fst x) (snd x))) !edge_list;
	      print_string "}\n";	      
	    end
	| NameTree.Leaf(name,_)
	  -> ());
  end

let _ =
  let print_usage () = Printf.printf "Usage: %s [filename]\n" Sys.argv.(0) in
  (* 引数チェックします *)
  (** ふつうのシェルと同様でプログラム名が0番めに入る
     Array.iter (fun x -> print_string x; print_string "\n") Sys.argv;
   **)
  if Array.length Sys.argv != 2 then
    begin print_usage (); exit 1 end;
  let input = open_in Sys.argv.(1) in
  begin
    grouping input;
    close_in input
  end

(*open NameTree*)
(*let a = add ["hoge"; "soge"] empty;;*)