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
module Style = Misc.Style
type compunit = string
type filename = string
type compunit_and_source = {
compunit : compunit;
filename : filename;
}
module Compunit_and_source = struct
type t = compunit_and_source
module Set = Set.Make(struct type nonrec t = t let compare = compare end)
end
type refs = Compunit_and_source.Set.t
type t = {
complete : bool;
missing_compunits : (compunit, refs) Hashtbl.t;
provided_compunits : (compunit, filename list) Hashtbl.t;
badly_ordered_deps : (Compunit_and_source.t, refs) Hashtbl.t;
}
type error =
| Missing_implementations of (compunit * compunit_and_source list) list
| Wrong_link_order of (compunit_and_source * compunit_and_source list) list
| Multiple_definitions of (compunit * filename list) list
let create ~complete = {
complete;
missing_compunits = Hashtbl.create 17;
provided_compunits = Hashtbl.create 17;
badly_ordered_deps = Hashtbl.create 17;
}
let required t compunit = Hashtbl.mem t.missing_compunits compunit
let update t k f =
let v = Hashtbl.find_opt t k in
Hashtbl.replace t k (f v)
let add_required t by (name : string) =
let add s =
Compunit_and_source.Set.add by
(Option.value s ~default:Compunit_and_source.Set.empty) in
(try
let filename = List.hd (Hashtbl.find t.provided_compunits name) in
update t.badly_ordered_deps {compunit = name; filename } add
with Not_found -> ());
update t.missing_compunits name add
let add t ~filename ~compunit ~provides ~requires =
List.iter (add_required t {compunit; filename}) requires;
List.iter (fun p ->
Hashtbl.remove t.missing_compunits p;
let l = Option.value ~default:[]
(Hashtbl.find_opt t.provided_compunits p) in
Hashtbl.replace t.provided_compunits p (filename :: l)) provides
let check t =
let of_seq s =
Seq.map (fun (k,v) -> k, Compunit_and_source.Set.elements v) s
|> List.of_seq
in
let missing = of_seq (Hashtbl.to_seq t.missing_compunits) in
let badly_ordered_deps = of_seq (Hashtbl.to_seq t.badly_ordered_deps) in
let duplicated =
Hashtbl.to_seq t.provided_compunits
|> Seq.filter (fun (_, files) -> List.compare_length_with files 1 > 0)
|> List.of_seq
in
match duplicated, badly_ordered_deps, missing with
| [], [], [] -> None
| [], [], l ->
if t.complete
then Some (Missing_implementations l)
else None
| [], l, _ ->
Some (Wrong_link_order l)
| l, _, _ ->
Some (Multiple_definitions l)
open Format_doc
let print_reference print_fname ppf {compunit; filename} =
fprintf ppf "%a (%a)" Style.inline_code compunit print_fname filename
let pp_list_comma f =
pp_print_list ~pp_sep:(fun ppf () -> fprintf ppf ",@ ") f
let report_error_doc ~print_filename ppf = function
| Missing_implementations l ->
let print_modules ppf =
List.iter
(fun (md, rq) ->
fprintf ppf "@ @[<hov 2>%a referenced from %a@]"
Style.inline_code md
(pp_list_comma (print_reference print_filename)) rq)
in
fprintf ppf
"@[<v 2>No implementation provided for the following modules:%a@]"
print_modules l
| Wrong_link_order l ->
let depends_on ppf (dep, depending) =
fprintf ppf "@ @[<hov 2>%a depends on %a@]"
(pp_list_comma (print_reference print_filename)) depending
(print_reference print_filename) dep
in
fprintf ppf "@[<hov 2>Wrong link order:%a@]"
(pp_list_comma depends_on) l
| Multiple_definitions l ->
let print ppf (compunit, files) =
fprintf ppf
"@ @[<hov>Multiple definitions of module %a in files %a@]"
Style.inline_code compunit
(pp_list_comma (Style.as_inline_code print_filename)) files
in
fprintf ppf "@[<hov 2> Duplicated implementations:%a@]"
(pp_list_comma print) l
let report_error ~print_filename =
Format_doc.compat (report_error_doc ~print_filename)