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 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 (x:t) y = compare x y
    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_print.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_print.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_print.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