ocaml/ocamldoc/odoc_dep.ml

(***********************************************************************)
(*                               OCamldoc                              *)
(*                                                                     *)
(*            Maxence Guesdon, projet Cristal, INRIA Rocquencourt      *)
(*                                                                     *)
(*  Copyright 2001 Institut National de Recherche en Informatique et   *)
(*  en Automatique.  All rights reserved.  This file is distributed    *)
(*  under the terms of the Q Public License version 1.0.               *)
(*                                                                     *)
(***********************************************************************)

(** Top modules dependencies. *)

module StrS = Depend.StringSet
module Module = Odoc_module
module Type = Odoc_type

let dummy_loc = { 
  Location.loc_start = 0; 
  Location.loc_end = 1 ;
  Location.loc_ghost = true
} 

let set_to_list s =
  let l = ref [] in
  StrS.iter (fun e -> l := e :: !l) s;
  !l

let impl_dependencies ast =
  Depend.free_structure_names := StrS.empty;
  Depend.add_use_file StrS.empty [Parsetree.Ptop_def ast];
  set_to_list !Depend.free_structure_names

let intf_dependencies ast =
  Depend.free_structure_names := StrS.empty;
  Depend.add_signature StrS.empty ast;
  set_to_list !Depend.free_structure_names


module Dep = 
  struct
    type id = string

    module S = Set.Make (struct type t = string let compare = compare end)
  
    let set_to_list s =
      let l = ref [] in
      S.iter (fun e -> l := e :: !l) s;
      !l

    type node = {
	id : id ;
	mutable near : S.t ; (** fils directs *)
	mutable far : (id * S.t) list ; (** fils indirects, par quel fils *)
	reflex : bool ; (** reflexive or not, we keep 
			   information here to remove the node itself from its direct children *)
      }

    type graph = node list

    let make_node s children =
      let set = List.fold_right
	  S.add
	  children
	  S.empty 
      in
      { id = s; 
	near = S.remove s set ;
	far = [] ;
	reflex = List.mem s children ;
      }

    let get_node graph s = 
      try List.find (fun n -> n.id = s) graph
      with Not_found ->  
	make_node s []

    let rec trans_closure graph acc n =
      if S.mem n.id acc then
	acc
      else
	(* optimisation plus tard : utiliser le champ far si non vide ? *)
	S.fold
	  (fun child -> fun acc2 ->
	    trans_closure graph acc2 (get_node graph child))
	  n.near
	  (S.add n.id acc)
      
    let node_trans_closure graph n =
      let far = List.map
	  (fun child -> 
	    let set = trans_closure graph S.empty (get_node graph child) in
	    (child, set)
	  )
	  (set_to_list n.near)
      in
      n.far <- far

    let compute_trans_closure graph =
      List.iter (node_trans_closure graph) graph

    let prune_node graph node =
      S.iter
	(fun child ->
	  let set_reachables = List.fold_left
	      (fun acc -> fun (ch, reachables) ->
		if child = ch then
		  acc
		else
		  S.union acc reachables
	      )
	      S.empty
	      node.far
	  in
	  let set = S.remove node.id set_reachables in
	  if S.exists (fun n2 -> S.mem child (get_node graph n2).near) set then
	    (
	     node.near <- S.remove child node.near ;
	     node.far <- List.filter (fun (ch,_) -> ch <> child) node.far
	    )
	  else
	    ()
	)
	node.near;
      if node.reflex then 
	node.near <- S.add node.id node.near 
      else
	()

    let kernel graph =
      (* compute transitive closure *)
      compute_trans_closure graph ;

      (* remove edges to keep a transitive kernel *)
      List.iter (prune_node graph) graph;

      graph

  end

(** [type_deps t] returns the list of fully qualified type names
   [t] depends on. *)
let type_deps t =
  let module T = Odoc_type in
  let l = ref [] in
  let re = Str.regexp "\\([A-Z]\\([a-zA-Z_'0-9]\\)*\\.\\)+\\([a-z][a-zA-Z_'0-9]*\\)" in
  let f s = 
    let s2 = Str.matched_string s in
    l := s2 :: !l ; 
    s2
  in
  (match t.T.ty_kind with
    T.Type_abstract -> ()
  | T.Type_variant cl ->
      List.iter
	(fun c ->
	  List.iter 
	    (fun e -> 
	      let s = Odoc_misc.string_of_type_expr e in
	      ignore (Str.global_substitute re f s)
	    )
	    c.T.vc_args
	)
	cl
  | T.Type_record rl ->
      List.iter
	(fun r ->
	  let s = Odoc_misc.string_of_type_expr r.T.rf_type in
	  ignore (Str.global_substitute re f s)
	)
	rl
  );

  (match t.T.ty_manifest with
    None -> ()
  | Some e ->
      let s = Odoc_misc.string_of_type_expr e in
      ignore (Str.global_substitute re f s)
  );

  !l

(** Modify the modules depencies of the given list of modules,
   to get the minimum transitivity kernel. *)
let kernel_deps_of_modules modules =
  let graph = List.map
      (fun m -> Dep.make_node m.Module.m_name m.Module.m_top_deps)
      modules
  in
  let k = Dep.kernel graph in
  List.iter 
    (fun m ->
      let node = Dep.get_node k m.Module.m_name in
      m.Module.m_top_deps <- 
	List.filter (fun m2 -> Dep.S.mem m2 node.Dep.near) m.Module.m_top_deps)
    modules

(** Return the list of dependencies between the given types,
   in the form of a list [(type, names of types it depends on)].
   @param kernel indicates if we must keep only the transitivity kernel
   of the dependencies. Default is [false].
*)
let deps_of_types ?(kernel=false) types =
  let deps_pre = List.map (fun t -> (t, type_deps t)) types in
  let deps =
    if kernel then
      (
       let graph = List.map
	   (fun (t, names) -> Dep.make_node t.Type.ty_name names)
	   deps_pre
       in
       let k = Dep.kernel graph in
       List.map
	 (fun t ->
	   let node = Dep.get_node k t.Type.ty_name in
	   (t, Dep.set_to_list node.Dep.near)
	 )
	 types
      )
    else
      deps_pre
  in
  deps