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
[@@@ocaml.text "/*"]
(** Copyright 2021-2025, Kakadu. *)
(** SPDX-License-Identifier: LGPL-3.0-or-later *)
[@@@ocaml.text "/*"]
open Utils
open Dune_project
type w =
| Wrapped of string
| Non_wrapped
let pp_w ppf = function
| Non_wrapped -> Format.fprintf ppf "Non_wrapped"
| Wrapped s -> Format.fprintf ppf "Wrapped %S" s
;;
let fine_module { impl } =
match impl with
| Some s when String.ends_with s ~suffix:".ml-gen" -> false
| _ -> true
;;
let to_module_name name =
if Base.Char.is_uppercase name.[0]
then name
else String.mapi (fun i c -> if i = 0 then Base.Char.uppercase c else c) name
;;
let discover_wrappness modules =
let module W = struct
type w =
| W of string * string
| NW of string
let pp_w ppf = function
| NW s -> Format.fprintf ppf "NW %S" s
| W (pref, suf) -> Format.fprintf ppf "W (%s __ %s)" pref suf
;;
let is_NW = function
| NW _ -> true
| _ -> false
;;
let is_W_with name = function
| W (s, _) when String.equal s name -> true
| _ -> false
;;
end
in
let str =
let pos_slash = String.rindex str '/' in
let pos_dot = String.rindex str '.' in
let len = pos_dot - pos_slash - 1 in
assert (len > 0);
let name = StringLabels.sub str ~pos:(1 + pos_slash) ~len in
match Base.String.substr_index name ~pattern:"__" with
| None -> [ W.NW name ]
| Some i ->
[ W.W
(Base.String.prefix name i, Base.String.suffix name (String.length name - i - 2))
]
in
let mm = List.concat_map (fun m -> Option.fold m.cmt ~none:[] ~some:extract) modules in
let nonw, wrapp = Base.List.partition_tf ~f:W.is_NW mm in
if List.for_all W.is_NW mm
then Some Non_wrapped
else (
match nonw with
| [ W.NW libname ] when List.for_all (W.is_W_with libname) wrapp ->
Some (Wrapped (to_module_name libname))
| _ -> None)
;;
let pp_maybe_wrapped ppf = function
| None -> Format.pp_print_string ppf "None"
| Some x -> Format.fprintf ppf "Some %a" pp_w x
;;
let%expect_test _ =
let ans =
discover_wrappness
[ Dune_project.module_ "a" ~cmt:"/a.cmt" ~cmti:"/a.cmti"
; Dune_project.module_ "b" ~cmt:"/b.cmt" ~cmti:"/b.cmti"
]
in
Format.printf "%a\n%!" pp_maybe_wrapped ans;
[%expect {| Some Non_wrapped |}]
;;
let%expect_test _ =
let ans =
discover_wrappness
[ Dune_project.module_ "a" ~cmt:"/libname__a.cmt" ~cmti:"/libname__a.cmti"
; Dune_project.module_ "b" ~cmt:"/libname__b.cmt" ~cmti:"/libname__b.cmti"
]
in
Format.printf "%a\n%!" pp_maybe_wrapped ans;
[%expect {| None |}]
;;
let%expect_test _ =
let ans =
discover_wrappness
[ Dune_project.module_ "libname" ~cmt:"/libname.cmt"
; Dune_project.module_ "a" ~cmt:"/libname__a.cmt" ~cmti:"/libname__a.cmti"
]
in
Format.printf "%a\n%!" pp_maybe_wrapped ans;
[%expect {| Some Wrapped "Libname" |}]
;;
let analyze_dir ~untyped:analyze_untyped ~cmt:analyze_cmt ~cmti:analyze_cmti path =
Unix.chdir path;
let s =
let ch = Unix.open_process_in "dune describe" in
let s = Sexplib.Sexp.input_sexp ch in
close_in ch;
s
in
let db = [%of_sexp: t Base.list] s in
Lint_filesystem.check db;
let on_module (is_wrapped : w) m =
let try_untyped filename =
try analyze_untyped filename with
| Syntaxerr.Error _e ->
Format.eprintf "Syntaxerr.Error in analysis of '%s'. Skipped.\n%!" filename
in
Option.iter try_untyped m.impl;
Option.iter try_untyped m.intf;
let on_cmti source_file (_cmi_info, cmt_info) =
cmt_info
|> Option.iter (fun cmt ->
Collected_lints.clear_tdecls ();
match cmt.Cmt_format.cmt_annots with
| Cmt_format.Implementation stru -> analyze_cmt is_wrapped source_file stru
| Interface sign -> analyze_cmti is_wrapped source_file sign
| Packed _ | Partial_implementation _ | Partial_interface _ ->
printfn "%s %d" __FILE__ __LINE__;
exit 1)
in
ListLabels.iter
[ m.impl, m.cmt; m.intf, m.cmti ]
~f:(function
| None, None ->
()
| Some filename, None ->
Format.printf "Found ml[i] file '%s' without cmt[i] file\n" filename
| None, Some filename ->
Format.printf "Found ml[i] file '%s' without cmt[i] file\n" filename
| Some source_filename, Some cmt_filename ->
let build_dir = "_build/default/" in
let wrap =
if String.starts_with ~prefix:build_dir cmt_filename
then
if Stdlib.Sys.file_exists cmt_filename
then (
fun f ->
Unix.chdir build_dir;
let infos =
if Config.verbose ()
then printfn "Reading cmt[i] file '%s'" cmt_filename;
Cmt_format.read
(Base.String.drop_prefix cmt_filename (String.length build_dir))
in
f infos;
Unix.chdir "../..")
else
fun _ ->
Format.eprintf
"File '%s' doesn't exist. Maybe some of source files are not compiled?\n\
%!"
cmt_filename
else
fun f ->
printfn "Loading CMT %S" cmt_filename;
let cmt = Cmt_format.read cmt_filename in
f cmt
in
wrap (on_cmti source_filename))
in
let loop_database () =
ListLabels.iter db ~f:(function
| Build_context _ | Root _ -> ()
| Executables { modules; requires = _ } ->
ListLabels.iter modules ~f:(fun m ->
if fine_module m then on_module Non_wrapped m)
| Library { Library.modules; name; _ } ->
let wrappedness = discover_wrappness modules in
(match wrappedness with
| None -> Stdlib.Printf.eprintf "Can't detect wrappedness for a library %S" name
| Some wrappedness ->
ListLabels.iter modules ~f:(fun m ->
if fine_module m
then on_module wrappedness m
else if
not (String.equal name (String.lowercase_ascii m.name))
then if Config.verbose () then printfn "module %S is omitted" m.name)))
in
loop_database ()
;;