Kakadu / zanuda / 18

Committed 17 Sep 2025 05:06PM UTC coverage: 85.847% (-1.5%) from 87.346%

Build # 18

Build Type

push

github

Committed by

Kakadu

Commit Message

Repair coverage testing

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

Run Details

2032 of 2367 relevant lines covered (85.85%)

477.23 hits per line

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

87.88

/src/utils.ml

(** Various helper functions. *)

[@@@ocaml.text "/*"]

(** Copyright 2021-2025, Kakadu. *)

(** SPDX-License-Identifier: LGPL-3.0-or-later *)

[@@@ocaml.text "/*"]

open Format

let printfn fmt = kfprintf (fun ppf -> fprintf ppf "\n%!") std_formatter fmt

module ErrorFormat = struct
  let pp ppf ~filename ~line ~col:_ msg x =
    fprintf ppf "%s:%d:%d:%a\n%!" filename line (* col *) 0 msg x
  ;;
end

type rdjsonl_code = string * string option

module RDJsonl : sig
  val pp
    :  formatter
    -> filename:string
    -> line:int
    -> ?code:rdjsonl_code
    -> (formatter -> 'a -> unit)
    -> 'a
    -> unit
end = struct
  let pp ppf ~filename ~line ?code msg x =
    let location file ~line ~col =
      `Assoc
        [ "path", `String file
        ; "range", `Assoc [ "start", `Assoc [ "line", `Int line; "column", `Int col ] ]
        ]
    in
    let j =
      `Assoc
        ([ "message", `String (asprintf "%a" msg x)
         ; "location", location filename ~line ~col:1
         ; "severity", `String "INFO"
         ]
         @
         match code with
         | None -> []
         | Some (desc, None) -> [ "code", `Assoc [ "value", `String desc ] ]
         | Some (desc, Some url) ->
           [ "code", `Assoc [ "value", `String desc; "url", `String url ] ])
    in
    fprintf ppf "%s\n%!" (Yojson.to_string j)
  ;;
  (* { "message": "Constructor 'XXX' has no documentation attribute",  "location": {    "path": "Lambda/lib/ast.mli",    "range": {      "start": { "line": 12, "column": 13 }, "end": { "line": 12, "column": 15      }    }  },  "severity": "INFO",  "code": {  "value": "RULE1",    "url": "https://example.com/url/to/super-lint/RULE1"  }}*)
end

let cut_build_dir s =
  let prefix = "_build/default/" in
  if String.starts_with ~prefix s
  then Base.String.drop_prefix s (String.length prefix)
  else s
;;

module Report = struct
  let txt ~loc ~filename ppf msg msg_arg =
    Option.iter Lexing.flush_input !Location.input_lexbuf;
    Location.input_name := cut_build_dir filename;
    let loc =
      let open Location in
      { loc with
        loc_start = { loc.loc_start with pos_fname = !input_name }
      ; loc_end = { loc.loc_end with pos_fname = !input_name }
      }
    in
    let main = Location.mkloc (fun ppf -> msg ppf msg_arg) loc in
    let r = Location.{ sub = []; main; kind = Report_alert "zanuda-linter" } in
    Location.print_report ppf r
  ;;

  let rdjsonl ~loc ~filename ~code ppf msg msg_arg =
    let code = code, Some "https://kakadu.github.io/zanuda/" in
    RDJsonl.pp ppf ~filename ~line:loc.Location.loc_start.pos_lnum ~code msg msg_arg
  ;;
end

let string_of_group : LINT.group -> string = function
  | LINT.Correctness -> "correctness"
  | Style -> "style"
  | Perf -> "perf"
  | Restriction -> "restriction"
  | Deprecated -> "deprecated"
  | Pedantic -> "pedantic"
  | Complexity -> "complexity"
  | Suspicious -> "suspicious"
  | Nursery -> "nursery"
;;

let string_of_level : LINT.level -> string = function
  | LINT.Allow -> "allow"
  | Warn -> "warn"
  | Deny -> "deny"
  | Deprecated -> "deprecated"
;;

let string_of_impl = function
  | LINT.Typed -> "typed"
  | _ -> "untyped"
;;

let describe_as_clippy_json
  ?(group = LINT.Correctness)
  ?(level = LINT.Deny)
  ?(impl = LINT.Typed)
  id
  ~docs
  : Yojson.Safe.t
  =
  (* List if clippy lints https://github.com/rust-lang/rust-clippy/blob/gh-pages/master/lints.json *)
  `Assoc
    [ "id", `String id
    ; "group", `String (string_of_group group)
    ; "level", `String (string_of_level level)
    ; "impl", `String (string_of_impl impl)
    ; "docs", `String docs
    ; ( "applicability"
      , `Assoc
          [ "is_multi_part_suggestion", `Bool false
          ; "applicability", `String "Unresolved"
          ] )
    ]
;;

exception Ident_is_found

let no_ident_iterator ident =
  let open Tast_iterator in
  let open Typedtree in
  { default_iterator with
    expr =
      (fun self e ->
        let rec ident_in_list = function
          | [] -> false
          | (_, (id, _)) :: _ when Ident.equal id ident -> true
          | _ :: tl -> ident_in_list tl
        in
        Tast_pattern.(
          let p1 =
            map2 (texp_function_body __ __) ~f:(fun args rhs -> `Function (args, rhs))
          in
          let p2 = map1 (texp_ident __) ~f:(fun x -> `Ident x) in
          parse
            (p1 ||| p2)
            (* TODO: should we check other patterns? *)
            e.exp_loc
            e
            ~on_error:(fun _ -> default_iterator.expr self e))
          (function
          | `Function (args, _rhs) when ident_in_list args -> ()
          | `Function (_, rhs) -> self.expr self rhs
          | `Ident (Pident id) when Ident.same id ident -> raise_notrace Ident_is_found
          | _ -> default_iterator.expr self e))
  ; case =
      (fun (type a) self (c : a case) ->
        match c.c_lhs.pat_desc with
        | Tpat_value v ->
          (match (v :> pattern) with
          | p ->
            Tast_pattern.(parse
              (tpat_id  __)
              Location.none
              p
              ~on_error:(fun _ -> default_iterator.case self c)
              (fun id -> if Ident.equal ident id then () else default_iterator.case self c)
              ))
        | _ -> default_iterator.case self c)
  }
;;

(* Checks that identifier is not used *)
let no_ident ident f =
  try
    f (no_ident_iterator ident);
    true
  with
  | Ident_is_found -> false
;;

[%%if ocaml_version < (5, 0, 0)]

type intf_or_impl =
  | Intf
  | Impl

let with_info _kind filename f =
  Compile_common.with_info
    ~native:false
    ~source_file:filename
    ~tool_name:"asdf" (* TODO: pass right tool name *)
    ~output_prefix:"asdf"
    ~dump_ext:"asdf"
    f
;;

[%%else]

type intf_or_impl = Unit_info.intf_or_impl

let with_info kind ~source_file =
  Compile_common.with_info
    ~native:false
    ~tool_name:"asdf" (* TODO: pass right tool name *)
    ~dump_ext:"asdf"
    (Unit_info.make ~source_file kind "")
;;

[%%endif]

1	(** Various helper functions. *)
2
3	[@@@ocaml.text "/*"]
4
5	(** Copyright 2021-2025, Kakadu. *)
6
7	(** SPDX-License-Identifier: LGPL-3.0-or-later *)
8
9	[@@@ocaml.text "/*"]
10
11	open Format
12
13	let printfn fmt = kfprintf (fun ppf -> fprintf ppf "\n%!") std_formatter fmt	3✔
14
15	module ErrorFormat = struct
16	let pp ppf ~filename ~line ~col:_ msg x =
17	fprintf ppf "%s:%d:%d:%a\n%!" filename line (* col *) 0 msg x	×
18	;;
19	end
20
21	type rdjsonl_code = string * string option
22
23	module RDJsonl : sig
24	val pp
25	: formatter
26	-> filename:string
27	-> line:int
28	-> ?code:rdjsonl_code
29	-> (formatter -> 'a -> unit)
30	-> 'a
31	-> unit
32	end = struct
33	let pp ppf ~filename ~line ?code msg x =
34	let location file ~line ~col =	111✔
35	`Assoc	111✔
36	[ "path", `String file
37	; "range", `Assoc [ "start", `Assoc [ "line", `Int line; "column", `Int col ] ]
38	]
39	in
40	let j =
41	`Assoc
42	([ "message", `String (asprintf "%a" msg x)	111✔
43	; "location", location filename ~line ~col:1	111✔
44	; "severity", `String "INFO"
45	]
46	@
47	match code with
48	\| None -> []	68✔
49	\| Some (desc, None) -> [ "code", `Assoc [ "value", `String desc ] ]	×
50	\| Some (desc, Some url) ->	43✔
51	[ "code", `Assoc [ "value", `String desc; "url", `String url ] ])
52	in
53	fprintf ppf "%s\n%!" (Yojson.to_string j)	111✔
54	;;
55	(* { "message": "Constructor 'XXX' has no documentation attribute", "location": { "path": "Lambda/lib/ast.mli", "range": { "start": { "line": 12, "column": 13 }, "end": { "line": 12, "column": 15 } } }, "severity": "INFO", "code": { "value": "RULE1", "url": "https://example.com/url/to/super-lint/RULE1" }}*)
56	end
57
58	let cut_build_dir s =
59	let prefix = "_build/default/" in	139✔
60	if String.starts_with ~prefix s
61	then Base.String.drop_prefix s (String.length prefix)	38✔
62	else s	101✔
63	;;
64
65	module Report = struct
66	let txt ~loc ~filename ppf msg msg_arg =
67	Option.iter Lexing.flush_input !Location.input_lexbuf;	139✔
68	Location.input_name := cut_build_dir filename;	139✔
69	let loc =
70	let open Location in
71	{ loc with
72	loc_start = { loc.loc_start with pos_fname = !input_name }
73	; loc_end = { loc.loc_end with pos_fname = !input_name }
74	}
75	in
76	let main = Location.mkloc (fun ppf -> msg ppf msg_arg) loc in	139✔
77	let r = Location.{ sub = []; main; kind = Report_alert "zanuda-linter" } in	139✔
78	Location.print_report ppf r
79	;;
80
81	let rdjsonl ~loc ~filename ~code ppf msg msg_arg =
82	let code = code, Some "https://kakadu.github.io/zanuda/" in	43✔
83	RDJsonl.pp ppf ~filename ~line:loc.Location.loc_start.pos_lnum ~code msg msg_arg
84	;;
85	end
86
87	let string_of_group : LINT.group -> string = function
88	\| LINT.Correctness -> "correctness"	5✔
89	\| Style -> "style"	20✔
90	\| Perf -> "perf"	4✔
91	\| Restriction -> "restriction"	×
92	\| Deprecated -> "deprecated"	×
93	\| Pedantic -> "pedantic"	×
94	\| Complexity -> "complexity"	×
95	\| Suspicious -> "suspicious"	3✔
96	\| Nursery -> "nursery"	1✔
97	;;
98
99	let string_of_level : LINT.level -> string = function
100	\| LINT.Allow -> "allow"	1✔
101	\| Warn -> "warn"	13✔
102	\| Deny -> "deny"	19✔
103	\| Deprecated -> "deprecated"	×
104	;;
105
106	let string_of_impl = function
107	\| LINT.Typed -> "typed"	23✔
108	\| _ -> "untyped"	10✔
109	;;
110
111	let describe_as_clippy_json
112	?(group = LINT.Correctness)	5✔
113	?(level = LINT.Deny)	18✔
114	?(impl = LINT.Typed)	23✔
115	id
116	~docs
117	: Yojson.Safe.t
118	=
119	(* List if clippy lints https://github.com/rust-lang/rust-clippy/blob/gh-pages/master/lints.json *)
120	`Assoc	33✔
121	[ "id", `String id
122	; "group", `String (string_of_group group)	33✔
123	; "level", `String (string_of_level level)	33✔
124	; "impl", `String (string_of_impl impl)	33✔
125	; "docs", `String docs
126	; ( "applicability"
127	, `Assoc
128	[ "is_multi_part_suggestion", `Bool false
129	; "applicability", `String "Unresolved"
130	] )
131	]
132	;;
133
134	exception Ident_is_found
135
136	let no_ident_iterator ident =
137	let open Tast_iterator in	74✔
138	let open Typedtree in
139	{ default_iterator with
140	expr =
141	(fun self e ->
142	let rec ident_in_list = function	1,348✔
143	\| [] -> false	149✔
144	\| (_, (id, _)) :: _ when Ident.equal id ident -> true	1✔
145	\| _ :: tl -> ident_in_list tl	200✔
146	in
147	Tast_pattern.(
148	let p1 =
149	map2 (texp_function_body __ __) ~f:(fun args rhs -> `Function (args, rhs))	150✔
150	in
151	let p2 = map1 (texp_ident __) ~f:(fun x -> `Ident x) in	575✔
152	parse	1,348✔
153	(p1 \|\|\| p2)	1,348✔
154	(* TODO: should we check other patterns? *)
155	e.exp_loc
156	e
157	~on_error:(fun _ -> default_iterator.expr self e))	623✔
158	(function
159	\| `Function (args, _rhs) when ident_in_list args -> ()	1✔
160	\| `Function (_, rhs) -> self.expr self rhs	149✔
161	\| `Ident (Pident id) when Ident.same id ident -> raise_notrace Ident_is_found	11✔
162	\| _ -> default_iterator.expr self e))	564✔
163	; case =
164	(fun (type a) self (c : a case) ->
165	match c.c_lhs.pat_desc with	79✔
166	\| Tpat_value v ->	11✔
167	(match (v :> pattern) with
168	\| p ->	11✔
169	Tast_pattern.(parse
170	(tpat_id __)	11✔
171	Location.none
172	p
173	~on_error:(fun _ -> default_iterator.case self c)	11✔
174	(fun id -> if Ident.equal ident id then () else default_iterator.case self c)	×
175	))
176	\| _ -> default_iterator.case self c)	68✔
177	}
178	;;
179
180	(* Checks that identifier is not used *)
181	let no_ident ident f =
182	try	43✔
183	f (no_ident_iterator ident);	43✔
184	true	34✔
185	with
186	\| Ident_is_found -> false	9✔
187	;;
188
189	[%%if ocaml_version < (5, 0, 0)]
190
191	type intf_or_impl =
192	\| Intf
193	\| Impl
194
195	let with_info _kind filename f =
196	Compile_common.with_info	131✔
197	~native:false
198	~source_file:filename
199	~tool_name:"asdf" (* TODO: pass right tool name *)
200	~output_prefix:"asdf"
201	~dump_ext:"asdf"
202	f
203	;;
204
205	[%%else]
206
207	type intf_or_impl = Unit_info.intf_or_impl
208
209	let with_info kind ~source_file =
210	Compile_common.with_info
211	~native:false
212	~tool_name:"asdf" (* TODO: pass right tool name *)
213	~dump_ext:"asdf"
214	(Unit_info.make ~source_file kind "")
215	;;
216
217	[%%endif]

Kakadu / zanuda / 18

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