ocamldoc/odoc_dep.ml

   1 (***********************************************************************)
   2 (*                               OCamldoc                              *)
   3 (*                                                                     *)
   4 (*            Maxence Guesdon, projet Cristal, INRIA Rocquencourt      *)
   5 (*                                                                     *)
   6 (*  Copyright 2001 Institut National de Recherche en Informatique et   *)
   7 (*  en Automatique.  All rights reserved.  This file is distributed    *)
   8 (*  under the terms of the Q Public License version 1.0.               *)
   9 (*                                                                     *)
  10 (***********************************************************************)
  11
  12 (* $Id$ *)
  13
  14 (** Top modules dependencies. *)
  15
  16 module StrS = Depend.StringSet
  17 module Module = Odoc_module
  18 module Type = Odoc_type
  19
  20 let set_to_list s =
  21   let l = ref [] in
  22   StrS.iter (fun e -> l := e :: !l) s;
  23   !l
  24
  25 let impl_dependencies ast =
  26   Depend.free_structure_names := StrS.empty;
  27   Depend.add_use_file StrS.empty [Parsetree.Ptop_def ast];
  28   set_to_list !Depend.free_structure_names
  29
  30 let intf_dependencies ast =
  31   Depend.free_structure_names := StrS.empty;
  32   Depend.add_signature StrS.empty ast;
  33   set_to_list !Depend.free_structure_names
  34
  35
  36 module Dep =
  37   struct
  38     type id = string
  39
  40     module S = Set.Make (struct type t = string let compare = compare end)
  41
  42     let set_to_list s =
  43       let l = ref [] in
  44       S.iter (fun e -> l := e :: !l) s;
  45       !l
  46
  47     type node = {
  48         id : id ;
  49         mutable near : S.t ; (** fils directs *)
  50         mutable far : (id * S.t) list ; (** fils indirects, par quel fils *)
  51         reflex : bool ; (** reflexive or not, we keep
  52                            information here to remove the node itself from its direct children *)
  53       }
  54
  55     type graph = node list
  56
  57     let make_node s children =
  58       let set = List.fold_right
  59           S.add
  60           children
  61           S.empty
  62       in
  63       { id = s;
  64         near = S.remove s set ;
  65         far = [] ;
  66         reflex = List.mem s children ;
  67       }
  68
  69     let get_node graph s =
  70       try List.find (fun n -> n.id = s) graph
  71       with Not_found ->
  72         make_node s []
  73
  74     let rec trans_closure graph acc n =
  75       if S.mem n.id acc then
  76         acc
  77       else
  78         (* optimisation plus tard : utiliser le champ far si non vide ? *)
  79         S.fold
  80           (fun child -> fun acc2 ->
  81             trans_closure graph acc2 (get_node graph child))
  82           n.near
  83           (S.add n.id acc)
  84
  85     let node_trans_closure graph n =
  86       let far = List.map
  87           (fun child ->
  88             let set = trans_closure graph S.empty (get_node graph child) in
  89             (child, set)
  90           )
  91           (set_to_list n.near)
  92       in
  93       n.far <- far
  94
  95     let compute_trans_closure graph =
  96       List.iter (node_trans_closure graph) graph
  97
  98     let prune_node graph node =
  99       S.iter
 100         (fun child ->
 101           let set_reachables = List.fold_left
 102               (fun acc -> fun (ch, reachables) ->
 103                 if child = ch then
 104                   acc
 105                 else
 106                   S.union acc reachables
 107               )
 108               S.empty
 109               node.far
 110           in
 111           let set = S.remove node.id set_reachables in
 112           if S.exists (fun n2 -> S.mem child (get_node graph n2).near) set then
 113             (
 114              node.near <- S.remove child node.near ;
 115              node.far <- List.filter (fun (ch,_) -> ch <> child) node.far
 116             )
 117           else
 118             ()
 119         )
 120         node.near;
 121       if node.reflex then
 122         node.near <- S.add node.id node.near
 123       else
 124         ()
 125
 126     let kernel graph =
 127       (* compute transitive closure *)
 128       compute_trans_closure graph ;
 129
 130       (* remove edges to keep a transitive kernel *)
 131       List.iter (prune_node graph) graph;
 132
 133       graph
 134
 135   end
 136
 137 (** [type_deps t] returns the list of fully qualified type names
 138    [t] depends on. *)
 139 let type_deps t =
 140   let module T = Odoc_type in
 141   let l = ref [] in
 142   let re = Str.regexp "\\([A-Z]\\([a-zA-Z_'0-9]\\)*\\.\\)+\\([a-z][a-zA-Z_'0-9]*\\)" in
 143   let f s =
 144     let s2 = Str.matched_string s in
 145     l := s2 :: !l ;
 146     s2
 147   in
 148   (match t.T.ty_kind with
 149     T.Type_abstract -> ()
 150   | T.Type_variant (cl, _) ->
 151       List.iter
 152         (fun c ->
 153           List.iter
 154             (fun e ->
 155               let s = Odoc_print.string_of_type_expr e in
 156               ignore (Str.global_substitute re f s)
 157             )
 158             c.T.vc_args
 159         )
 160         cl
 161   | T.Type_record (rl, _) ->
 162       List.iter
 163         (fun r ->
 164           let s = Odoc_print.string_of_type_expr r.T.rf_type in
 165           ignore (Str.global_substitute re f s)
 166         )
 167         rl
 168   );
 169
 170   (match t.T.ty_manifest with
 171     None -> ()
 172   | Some e ->
 173       let s = Odoc_print.string_of_type_expr e in
 174       ignore (Str.global_substitute re f s)
 175   );
 176
 177   !l
 178
 179 (** Modify the modules depencies of the given list of modules,
 180    to get the minimum transitivity kernel. *)
 181 let kernel_deps_of_modules modules =
 182   let graph = List.map
 183       (fun m -> Dep.make_node m.Module.m_name m.Module.m_top_deps)
 184       modules
 185   in
 186   let k = Dep.kernel graph in
 187   List.iter
 188     (fun m ->
 189       let node = Dep.get_node k m.Module.m_name in
 190       m.Module.m_top_deps <-
 191         List.filter (fun m2 -> Dep.S.mem m2 node.Dep.near) m.Module.m_top_deps)
 192     modules
 193
 194 (** Return the list of dependencies between the given types,
 195    in the form of a list [(type, names of types it depends on)].
 196    @param kernel indicates if we must keep only the transitivity kernel
 197    of the dependencies. Default is [false].
 198 *)
 199 let deps_of_types ?(kernel=false) types =
 200   let deps_pre = List.map (fun t -> (t, type_deps t)) types in
 201   let deps =
 202     if kernel then
 203       (
 204        let graph = List.map
 205            (fun (t, names) -> Dep.make_node t.Type.ty_name names)
 206            deps_pre
 207        in
 208        let k = Dep.kernel graph in
 209        List.map
 210          (fun t ->
 211            let node = Dep.get_node k t.Type.ty_name in
 212            (t, Dep.set_to_list node.Dep.near)
 213          )
 214          types
 215       )
 216     else
 217       deps_pre
 218   in
 219   deps