Kakadu / zanuda / 27

Committed 18 Sep 2025 07:20AM UTC coverage: 86.255% (+0.01%) from 86.245%

Build # 27

Build Type

push

github

Committed by

Kakadu

Commit Message

Enable alpine and opensuse back

Signed-off-by: Kakadu <Kakadu@pm.me>

Run Details

2209 of 2561 relevant lines covered (86.26%)

523.98 hits per line

Source File
Press 'n' to go to next uncovered line, 'b' for previous

81.82

/src/Load_dune.ml

[@@@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 extract 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
;;

(* TODO: move these tests to a separate library *)

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
  (* List.iter db ~f:(fun x -> Format.printf "%a\n%!" Sexplib.Sexp.pp_hum (sexp_of_t x)); *)
  Lint_filesystem.check db;
  let on_module (is_wrapped : w) m =
    (* printf "\t Working on module %S (wrapped = %b)\n%!" m.name is_wrapped; *)
    (* we analyze syntax tree without expanding syntax extensions *)
    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;
    (* Now analyze Typedtree extracted from cmt[i] *)
    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 ->
          (* TODO: I'm not 100% sure when it happens *)
          (* Format.printf "%s %d\n%!" __FILE__ __LINE__; *)
          ()
        | 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 =
            (* Format.printf "checking for prefix %S in %s\n%!" build_dir cmt_filename; *)
            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
          (* Format.printf "%s %d src=%S\n%!" __FILE__ __LINE__ source_filename; *)
          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 ->
          (* Dune doesn't allow to specify 'wrapped' for executables *)
          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 ->
           (* printfn "Discovered wrappedness: %a" pp_w wrappedness; *)
           ListLabels.iter modules ~f:(fun m ->
             (* Format.printf "Trying module %a...\n%!" Sexp.pp (Dune_project.sexp_of_module_ m); *)
             if fine_module m
             then on_module wrappedness m
             else if
               (* Usually this happend with 'fake' wrapped modules from dune *)
               not (String.equal name (String.lowercase_ascii m.name))
             then if Config.verbose () then printfn "module %S is omitted" m.name)))
  in
  loop_database ()
;;

1	[@@@ocaml.text "/*"]
2
3	(** Copyright 2021-2025, Kakadu. *)
4
5	(** SPDX-License-Identifier: LGPL-3.0-or-later *)
6
7	[@@@ocaml.text "/*"]
8
9	open Utils
10	open Dune_project
11
12	type w =
13	\| Wrapped of string
14	\| Non_wrapped
15
16	let pp_w ppf = function
17	\| Non_wrapped -> Format.fprintf ppf "Non_wrapped"	1✔
18	\| Wrapped s -> Format.fprintf ppf "Wrapped %S" s	1✔
19	;;
20
21	let fine_module { impl } =
22	match impl with	69✔
23	\| Some s when String.ends_with s ~suffix:".ml-gen" -> false	7✔
24	\| _ -> true	62✔
25	;;
26
27	let to_module_name name =
28	if Base.Char.is_uppercase name.[0]	7✔
29	then name	×
30	else String.mapi (fun i c -> if i = 0 then Base.Char.uppercase c else c) name	7✔
31	;;
32
33	let discover_wrappness modules =
34	let module W = struct	160✔
35	type w =
36	\| W of string * string
37	\| NW of string
38
39	let pp_w ppf = function
40	\| NW s -> Format.fprintf ppf "NW %S" s	×
41	\| W (pref, suf) -> Format.fprintf ppf "W (%s __ %s)" pref suf	×
42	;;
43
44	let is_NW = function
45	\| NW _ -> true	109✔
46	\| _ -> false	18✔
47	;;
48
49	let is_W_with name = function
50	\| W (s, _) when String.equal s name -> true	8✔
51	\| _ -> false	×
52	;;
53	end
54	in
55	let extract str =
56	let pos_slash = String.rindex str '/' in	67✔
57	let pos_dot = String.rindex str '.' in	67✔
58	let len = pos_dot - pos_slash - 1 in	67✔
59	assert (len > 0);	67✔
60	let name = StringLabels.sub str ~pos:(1 + pos_slash) ~len in
61	match Base.String.substr_index name ~pattern:"__" with	67✔
62	\| None -> [ W.NW name ]	57✔
63	\| Some i ->	10✔
64	[ W.W
65	(Base.String.prefix name i, Base.String.suffix name (String.length name - i - 2))	10✔
66	]
67	in
68	let mm = List.concat_map (fun m -> Option.fold m.cmt ~none:[] ~some:extract) modules in	72✔
69	let nonw, wrapp = Base.List.partition_tf ~f:W.is_NW mm in	160✔
70	if List.for_all W.is_NW mm	160✔
71	then Some Non_wrapped	152✔
72	else (	8✔
73	match nonw with
74	\| [ W.NW libname ] when List.for_all (W.is_W_with libname) wrapp ->	7✔
75	Some (Wrapped (to_module_name libname))	7✔
76	\| _ -> None)	1✔
77	;;
78
79	let pp_maybe_wrapped ppf = function
80	\| None -> Format.pp_print_string ppf "None"	1✔
81	\| Some x -> Format.fprintf ppf "Some %a" pp_w x	2✔
82	;;
83
84	(* TODO: move these tests to a separate library *)
85
86	let%expect_test _ =
87	let ans =	1✔
88	discover_wrappness
89	[ Dune_project.module_ "a" ~cmt:"/a.cmt" ~cmti:"/a.cmti"	1✔
90	; Dune_project.module_ "b" ~cmt:"/b.cmt" ~cmti:"/b.cmti"	1✔
91	]
92	in
93	Format.printf "%a\n%!" pp_maybe_wrapped ans;	1✔
94	[%expect {\| Some Non_wrapped \|}]	1✔
95	;;
96
97	let%expect_test _ =
98	let ans =	1✔
99	discover_wrappness
100	[ Dune_project.module_ "a" ~cmt:"/libname__a.cmt" ~cmti:"/libname__a.cmti"	1✔
101	; Dune_project.module_ "b" ~cmt:"/libname__b.cmt" ~cmti:"/libname__b.cmti"	1✔
102	]
103	in
104	Format.printf "%a\n%!" pp_maybe_wrapped ans;	1✔
105	[%expect {\| None \|}]	1✔
106	;;
107
108	let%expect_test _ =
109	let ans =	1✔
110	discover_wrappness
111	[ Dune_project.module_ "libname" ~cmt:"/libname.cmt"	1✔
112	; Dune_project.module_ "a" ~cmt:"/libname__a.cmt" ~cmti:"/libname__a.cmti"	1✔
113	]
114	in
115	Format.printf "%a\n%!" pp_maybe_wrapped ans;	1✔
116	[%expect {\| Some Wrapped "Libname" \|}]	1✔
117	;;
118
119	let analyze_dir ~untyped:analyze_untyped ~cmt:analyze_cmt ~cmti:analyze_cmti path =
120	Unix.chdir path;	38✔
121	let s =	38✔
122	let ch = Unix.open_process_in "dune describe" in
123	let s = Sexplib.Sexp.input_sexp ch in	38✔
124	close_in ch;	38✔
125	s	38✔
126	in
127	let db = [%of_sexp: t Base.list] s in
128	(* List.iter db ~f:(fun x -> Format.printf "%a\n%!" Sexplib.Sexp.pp_hum (sexp_of_t x)); *)
129	Lint_filesystem.check db;	38✔
130	let on_module (is_wrapped : w) m =	38✔
131	(* printf "\t Working on module %S (wrapped = %b)\n%!" m.name is_wrapped; *)
132	(* we analyze syntax tree without expanding syntax extensions *)
133	let try_untyped filename =	62✔
134	try analyze_untyped filename with	72✔
135	\| Syntaxerr.Error _e ->	×
136	Format.eprintf "Syntaxerr.Error in analysis of '%s'. Skipped.\n%!" filename
137	in
138	Option.iter try_untyped m.impl;
139	Option.iter try_untyped m.intf;	62✔
140	(* Now analyze Typedtree extracted from cmt[i] *)
141	let on_cmti source_file (_cmi_info, cmt_info) =	62✔
142	cmt_info	72✔
143	\|> Option.iter (fun cmt ->
144	Collected_lints.clear_tdecls ();	72✔
145	match cmt.Cmt_format.cmt_annots with	72✔
146	\| Cmt_format.Implementation stru -> analyze_cmt is_wrapped source_file stru	57✔
147	\| Interface sign -> analyze_cmti is_wrapped source_file sign	15✔
148	\| Packed _ \| Partial_implementation _ \| Partial_interface _ ->	×
149	printfn "%s %d" __FILE__ __LINE__;
150	exit 1)	×
151	in
152	ListLabels.iter
153	[ m.impl, m.cmt; m.intf, m.cmti ]
154	~f:(function
155	\| None, None ->	52✔
156	(* TODO: I'm not 100% sure when it happens *)
157	(* Format.printf "%s %d\n%!" __FILE__ __LINE__; *)
158	()
159	\| Some filename, None ->	×
160	Format.printf "Found ml[i] file '%s' without cmt[i] file\n" filename
161	\| None, Some filename ->	×
162	Format.printf "Found ml[i] file '%s' without cmt[i] file\n" filename
163	\| Some source_filename, Some cmt_filename ->	72✔
164	let build_dir = "_build/default/" in
165	let wrap =
166	(* Format.printf "checking for prefix %S in %s\n%!" build_dir cmt_filename; *)
167	if String.starts_with ~prefix:build_dir cmt_filename
168	then
169	if Stdlib.Sys.file_exists cmt_filename	72✔
170	then (	72✔
171	fun f ->
172	Unix.chdir build_dir;	72✔
173	let infos =	72✔
174	if Config.verbose ()
175	then printfn "Reading cmt[i] file '%s'" cmt_filename;	×
176	Cmt_format.read	72✔
177	(Base.String.drop_prefix cmt_filename (String.length build_dir))	72✔
178	in
179	f infos;
180	Unix.chdir "../..")	72✔
181	else
182	fun _ ->	×
183	Format.eprintf	×
184	"File '%s' doesn't exist. Maybe some of source files are not compiled?\n\
185	%!"
186	cmt_filename
187	else
188	fun f ->	×
189	printfn "Loading CMT %S" cmt_filename;	×
190	let cmt = Cmt_format.read cmt_filename in	×
191	f cmt	×
192	in
193	(* Format.printf "%s %d src=%S\n%!" __FILE__ __LINE__ source_filename; *)
194	wrap (on_cmti source_filename))	72✔
195	in
196	let loop_database () =
197	ListLabels.iter db ~f:(function	38✔
198	\| Build_context _ \| Root _ -> ()	38✔
199	\| Executables { modules; requires = _ } ->	3✔
200	ListLabels.iter modules ~f:(fun m ->
201	(* Dune doesn't allow to specify 'wrapped' for executables *)
202	if fine_module m then on_module Non_wrapped m)	3✔
203	\| Library { Library.modules; name; _ } ->	157✔
204	let wrappedness = discover_wrappness modules in
205	(match wrappedness with	157✔
206	\| None -> Stdlib.Printf.eprintf "Can't detect wrappedness for a library %S" name	×
207	\| Some wrappedness ->	157✔
208	(* printfn "Discovered wrappedness: %a" pp_w wrappedness; *)
209	ListLabels.iter modules ~f:(fun m ->
210	(* Format.printf "Trying module %a...\n%!" Sexp.pp (Dune_project.sexp_of_module_ m); *)
211	if fine_module m	66✔
212	then on_module wrappedness m	59✔
213	else if	7✔
214	(* Usually this happend with 'fake' wrapped modules from dune *)
215	not (String.equal name (String.lowercase_ascii m.name))	7✔
216	then if Config.verbose () then printfn "module %S is omitted" m.name)))	×
217	in
218	loop_database ()
219	;;

Kakadu / zanuda / 27

Source File Press 'n' to go to next uncovered line, 'b' for previous

Source File
Press 'n' to go to next uncovered line, 'b' for previous