File: odoc_dep.ml

package info (click to toggle)
ocaml 4.05.0-11
  • links: PTS, VCS
  • area: main
  • in suites: buster
  • size: 27,060 kB
  • sloc: ml: 199,255; ansic: 44,187; sh: 5,611; makefile: 4,958; lisp: 4,223; asm: 4,220; awk: 306; perl: 87; fortran: 21; cs: 9; sed: 9
file content (220 lines) | stat: -rw-r--r-- 6,478 bytes parent folder | download | duplicates (2)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             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 GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(** Top modules dependencies. *)

module StrS = Depend.StringSet
module StrM = Depend.StringMap
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 StrM.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 StrM.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 ; (** direct children *)
        mutable far : (id * S.t) list ; (** indirect children, from which children path *)
        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
        (* potential optimisation: use far field if nonempty? *)
        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
  let ty t =
    let s = Odoc_print.string_of_type_expr t in
    ignore (Str.global_substitute re f s)
  in
  (match t.T.ty_kind with
    T.Type_abstract -> ()
  | T.Type_variant cl ->
      List.iter
        (fun c ->
           match c.T.vc_args with
           | T.Cstr_tuple l -> List.iter ty l
           | T.Cstr_record l -> List.iter (fun r -> ty r.T.rf_type) l
        )
        cl
  | T.Type_record rl ->
      List.iter (fun r -> ty r.T.rf_type) rl
  | T.Type_open -> ()
  );

  (match t.T.ty_manifest with
    None -> ()
  | Some (T.Object_type fields) ->
      List.iter (fun r -> ty r.T.of_type) fields
  | Some (T.Other e) ->
      ty e
  );

  !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
  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