Kakadu / zanuda / 41

Committed 19 Oct 2025 08:00PM UTC coverage: 86.475% (-0.2%) from 86.625%

Build # 41

Build Type

push

github

Committed by

Kakadu

Commit Message

Add tests about autogenerated file

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

Run Details

2225 of 2573 relevant lines covered (86.47%)

532.62 hits per line

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

78.73

/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
;;

include (
struct
  open Location
  open Lexing

  type input_line =
    { text : string
    ; start_pos : int
    }

  let infer_line_numbers (lines : (int option * input_line) list)
    : (int option * input_line) list
    =
    let _, offset, consistent =
      List.fold_left
        (fun (i, offset, consistent) (lnum, _) ->
          match lnum, offset with
          | None, _ -> i + 1, offset, consistent
          | Some n, None -> i + 1, Some (n - i), consistent
          | Some n, Some m -> i + 1, offset, consistent && n = m + i)
        (0, None, true)
        lines
    in
    match offset, consistent with
    | Some m, true -> List.mapi (fun i (_, line) -> Some (m + i), line) lines
    | _, _ -> lines
  ;;

  module ISet : sig
    type 'a bound = 'a * int
    type 'a t

    (* bounds are included *)
    val of_intervals : ('a bound * 'a bound) list -> 'a t
    val mem : 'a t -> pos:int -> bool
    val find_bound_in : 'a t -> range:int * int -> 'a bound option
    val is_start : 'a t -> pos:int -> 'a option
    val is_end : 'a t -> pos:int -> 'a option
    val extrema : 'a t -> ('a bound * 'a bound) option
  end = struct
    type 'a bound = 'a * int

    (* non overlapping intervals *)
    type 'a t = ('a bound * 'a bound) list

    let of_intervals intervals =
      let pos =
        List.map
          (fun ((a, x), (b, y)) -> if x > y then [] else [ (a, x), `S; (b, y), `E ])
          intervals
        |> List.flatten
        |> List.sort (fun ((_, x), k) ((_, y), k') ->
          (* Make `S come before `E so that consecutive intervals get merged
             together in the fold below *)
          let kn = function
            | `S -> 0
            | `E -> 1
          in
          compare (x, kn k) (y, kn k'))
      in
      let nesting, acc =
        List.fold_left
          (fun (nesting, acc) (a, kind) ->
            match kind, nesting with
            | `S, `Outside -> `Inside (a, 0), acc
            | `S, `Inside (s, n) -> `Inside (s, n + 1), acc
            | `E, `Outside -> assert false
            | `E, `Inside (s, 0) -> `Outside, (s, a) :: acc
            | `E, `Inside (s, n) -> `Inside (s, n - 1), acc)
          (`Outside, [])
          pos
      in
      assert (nesting = `Outside);
      List.rev acc
    ;;

    let mem iset ~pos = List.exists (fun ((_, s), (_, e)) -> s <= pos && pos <= e) iset

    let find_bound_in iset ~range:(start, end_) =
      List.find_map
        (fun ((a, x), (b, y)) ->
          if start <= x && x <= end_
          then Some (a, x)
          else if start <= y && y <= end_
          then Some (b, y)
          else None)
        iset
    ;;

    let is_start iset ~pos =
      List.find_map (fun ((a, x), _) -> if pos = x then Some a else None) iset
    ;;

    let is_end iset ~pos =
      List.find_map (fun (_, (b, y)) -> if pos = y then Some b else None) iset
    ;;

    let extrema iset =
      if iset = [] then None else Some (fst (List.hd iset), snd (List.hd (List.rev iset)))
    ;;
  end

  (* The number of lines already printed after input.

     This is used by [highlight_terminfo] to identify the current position of the
     input in the terminal. This would not be possible without this information,
     since printing several warnings/errors adds text between the user input and
     the bottom of the terminal.

     We also use for {!is_first_report}, see below.
  *)
  let num_loc_lines = ref 0

  (* We use [num_loc_lines] to determine if the report about to be
     printed is the first or a follow-up report of the current
     "batch" -- contiguous reports without user input in between, for
     example for the current toplevel phrase. We use this to print
     a blank line between messages of the same batch.
  *)
  let is_first_message () = !num_loc_lines = 0

  (* This is used by the toplevel to reset [num_loc_lines] before each phrase *)
  let reset () = num_loc_lines := 0

  (* This is used by the toplevel *)
  let echo_eof () =
    print_newline ();
    incr num_loc_lines
  ;;

  (* Code printing errors and warnings must be wrapped using this function, in
     order to update [num_loc_lines].

     [print_updating_num_loc_lines ppf f arg] is equivalent to calling [f ppf
   arg], and additionally updates [num_loc_lines]. *)
  let print_updating_num_loc_lines ppf f arg =
    let open Format in
    let out_functions = pp_get_formatter_out_functions ppf () in
    let out_string str start len =
      let rec count i c =
        if i = start + len
        then c
        else if String.get str i = '\n'
        then count (succ i) (succ c)
        else count (succ i) c
      in
      num_loc_lines := !num_loc_lines + count start 0;
      out_functions.out_string str start len
    in
    pp_set_formatter_out_functions ppf { out_functions with out_string };
    f ppf arg;
    pp_print_flush ppf ();
    pp_set_formatter_out_functions ppf out_functions
  ;;

  (* let setup_tags () = Misc.Style.setup !Clflags.color *)

  (* module Fmt = Format_doc *)
  module Fmt = Format

  let pp_two_columns ?(sep = "|") ?max_lines ppf (lines : (string * string) list) =
    let left_column_size =
      List.fold_left (fun acc (s, _) -> Int.max acc (String.length s)) 0 lines
    in
    let lines_nb = List.length lines in
    let ellipsed_first, ellipsed_last =
      match max_lines with
      | Some max_lines when lines_nb > max_lines ->
        let printed_lines = max_lines - 1 in
        (* the ellipsis uses one line *)
        let lines_before = (printed_lines / 2) + (printed_lines mod 2) in
        let lines_after = printed_lines / 2 in
        lines_before, lines_nb - lines_after - 1
      | _ -> -1, -1
    in
    Format.fprintf ppf "@[<v>";
    List.iteri
      (fun k (line_l, line_r) ->
        if k = ellipsed_first then Format.fprintf ppf "...@,";
        if ellipsed_first <= k && k <= ellipsed_last
        then ()
        else Format.fprintf ppf "%*s %s %s@," left_column_size line_l sep line_r)
      lines;
    Format.fprintf ppf "@]"
  ;;

  (* [get_lines] must return the lines to highlight, given starting and ending
     positions.

     See [lines_around_from_current_input] below for an instantiation of
     [get_lines] that reads from the current input.
  *)
  let highlight_quote
        ppf
        ~(get_lines : start_pos:position -> end_pos:position -> input_line list)
        ?(max_lines = 10)
        highlight_tag
        locs
    =
    let iset =
      ISet.of_intervals
      @@ List.filter_map
           (fun loc ->
             let s, e = loc.loc_start, loc.loc_end in
             if s.pos_cnum = -1 || e.pos_cnum = -1
             then None
             else Some ((s, s.pos_cnum), (e, e.pos_cnum - 1)))
           locs
    in
    match ISet.extrema iset with
    | None -> ()
    | Some ((leftmost, _), (rightmost, _)) ->
      let lines =
        get_lines ~start_pos:leftmost ~end_pos:rightmost
        |> List.map (fun ({ text; start_pos } as line) ->
          let end_pos = start_pos + String.length text - 1 in
          let line_nb =
            match ISet.find_bound_in iset ~range:(start_pos, end_pos) with
            | None -> None
            | Some (p, _) -> Some p.pos_lnum
          in
          line_nb, line)
        |> infer_line_numbers
        |> List.map (fun (lnum, { text; start_pos }) ->
          text, Option.fold ~some:Int.to_string ~none:"" lnum, start_pos)
      in
      Fmt.fprintf ppf "@[<v>";
      (match lines with
       | [] | [ ("", _, _) ] -> ()
       | [ (line, line_nb, line_start_cnum) ] ->
         (* Single-line error *)
         Fmt.fprintf ppf "%s | %s@," line_nb line;
         Fmt.fprintf ppf "%*s   " (String.length line_nb) "";
         (* Iterate up to [rightmost], which can be larger than the length of
            the line because we may point to a location after the end of the
            last token on the line, for instance:
            {[
              token
                        ^
              Did you forget ...
            ]} *)
         for i = 0 to rightmost.pos_cnum - line_start_cnum - 1 do
           let pos = line_start_cnum + i in
           if ISet.is_start iset ~pos <> None then Fmt.fprintf ppf "@{<%s>" highlight_tag;
           if ISet.mem iset ~pos
           then Fmt.pp_print_char ppf '^'
           else if i < String.length line
           then
             (* For alignment purposes, align using a tab for each tab in the
                source code *)
             if line.[i] = '\t'
             then Fmt.pp_print_char ppf '\t'
             else Fmt.pp_print_char ppf ' ';
           if ISet.is_end iset ~pos <> None then Fmt.fprintf ppf "@}"
         done;
         Fmt.fprintf ppf "@}@,"
       | _ ->
         (* Printf.eprintf "%s. %s %d\n%!" __FUNCTION__ __FILE__ __LINE__; *)
         (* Multi-line error *)
         pp_two_columns ~sep:"|" ~max_lines ppf
         @@ List.map
              (fun (line, line_nb, line_start_cnum) ->
                let line =
                  String.mapi
                    (fun i car ->
                      if ISet.mem iset ~pos:(line_start_cnum + i) then car else '.')
                    line
                in
                line_nb, line)
              lines);
      Fmt.fprintf ppf "@]"
  ;;

  let lines_around
        ~(start_pos : position)
        ~(end_pos : position)
        ~(seek : int -> unit)
        ~(read_char : unit -> char option)
    : input_line list
    =
    seek start_pos.pos_bol;
    let lines = ref [] in
    let bol = ref start_pos.pos_bol in
    let cur = ref start_pos.pos_bol in
    let b = Buffer.create 80 in
    let add_line () =
      if !bol < !cur
      then (
        let text = Buffer.contents b in
        Buffer.clear b;
        lines := { text; start_pos = !bol } :: !lines;
        bol := !cur)
    in
    let rec loop () =
      if !bol >= end_pos.pos_cnum
      then ()
      else (
        match read_char () with
        | None ->
          (* end of input *)
          add_line ()
        | Some c ->
          incr cur;
          (match c with
           | '\r' -> loop ()
           | '\n' ->
             add_line ();
             loop ()
           | _ ->
             Buffer.add_char b c;
             loop ()))
    in
    loop ();
    List.rev !lines
  ;;

  (* Attempt to get lines from the lexing buffer. *)
  let lines_around_from_lexbuf ~(start_pos : position) ~(end_pos : position) (lb : lexbuf)
    : input_line list
    =
    (* Printf.eprintf "%s lexbuf.len = %d\n%!" __FUNCTION__ lb.Lexing.lex_buffer_len; *)
    (* Converts a global position to one that is relative to the lexing buffer *)
    let rel n = n - lb.lex_abs_pos in
    if rel start_pos.pos_bol < 0
    then
      (* Do nothing if the buffer does not contain the input (because it has been
         refilled while lexing it) *)
      []
    else (
      let pos = ref 0 in
      (* relative position *)
      let seek n = pos := rel n in
      let read_char () =
        if !pos >= lb.lex_buffer_len
        then (* end of buffer *) None
        else (
          let c = Bytes.get lb.lex_buffer !pos in
          incr pos;
          Some c)
      in
      lines_around ~start_pos ~end_pos ~seek ~read_char)
  ;;

  (* Attempt to get lines from the phrase buffer *)
  let lines_around_from_phrasebuf
        ~(start_pos : position)
        ~(end_pos : position)
        (pb : Buffer.t)
    : input_line list
    =
    let pos = ref 0 in
    let seek n = pos := n in
    let read_char () =
      if !pos >= Buffer.length pb
      then None
      else (
        let c = Buffer.nth pb !pos in
        incr pos;
        Some c)
    in
    lines_around ~start_pos ~end_pos ~seek ~read_char
  ;;

  (* A [get_lines] function for [highlight_quote] that reads from the current
     input. *)
  let lines_around_from_current_input ~start_pos ~end_pos =
    match !Location.input_lexbuf, !Location.input_phrase_buffer, !Location.input_name with
    | _, Some pb, "//toplevel//" -> lines_around_from_phrasebuf pb ~start_pos ~end_pos
    | Some lb, _, _ ->
      let xs = lines_around_from_lexbuf lb ~start_pos ~end_pos in
      (* Printf.eprintf "lines_around_from_lexbuf return list len %d\n%!" (List.length xs); *)
      xs
    | None, _, _ -> []
  ;;

  let is_dummy_loc loc =
    (* Fixme: this should be just [loc.loc_ghost] and the function should be
       inlined below. However, currently, the compiler emits in some places ghost
       locations with valid ranges that should still be printed. These locations
       should be made non-ghost -- in the meantime we just check if the ranges are
       valid. *)
    loc.loc_start.pos_cnum = -1 || loc.loc_end.pos_cnum = -1
  ;;

  let is_quotable_loc loc =
    (not (is_dummy_loc loc))
    && loc.loc_start.pos_fname = !input_name
    && loc.loc_end.pos_fname = !input_name
  ;;

  let report_printer ppf loc f x =
    let highlight ppf loc =
      if is_quotable_loc loc
      then
        highlight_quote ppf ~get_lines:lines_around_from_current_input "warning" [ loc ]
    in
    Format.fprintf ppf "@[<v>%a:@ %a@]" print_loc loc highlight loc;
    Format.fprintf ppf "@[Alert zanuda-linter: @[%a@]@]@," f x;
    Format.fprintf ppf "%!"
  ;;
end :
sig
  val report_printer : formatter -> Location.t -> (formatter -> 'a -> unit) -> 'a -> unit
end)

module Report = struct
  let txt ~loc ~filename ppf msg msg_arg =
    if Sys.file_exists filename
    then (
      Location.input_name := cut_build_dir filename;
      Clflags.error_style := Some Misc.Error_style.Contextual;
      let file_contents = In_channel.with_open_text filename In_channel.input_all in
      Location.input_lexbuf := Some (Lexing.from_string file_contents);
      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
      report_printer ppf loc msg msg_arg)
    else (
      Format.fprintf ppf "@[Alert zanuda-linter: @[%a@]@]@," msg msg_arg;
      Format.fprintf ppf "%!")
  ;;

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

let has_ident ident f = not (no_ident ident f)

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

type intf_or_impl =
  | Intf
  | Impl

let with_info _kind ~source_file f =
  Compile_common.with_info
    ~native:false
    ~source_file
    ~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]
[%%if ocaml_version < (5, 0, 0)]

let pp_path = Path.print

[%%else]

let pp_path = Format_doc.compat Path.print

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

let source_of_info info = info.Compile_common.source_file

[%%else]

let source_of_info info = Unit_info.source_file info.Compile_common.target

[%%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 =	113✔
35	`Assoc	113✔
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)	113✔
43	; "location", location filename ~line ~col:1	113✔
44	; "severity", `String "INFO"
45	]
46	@
47	match code with
48	\| None -> []	71✔
49	\| Some (desc, None) -> [ "code", `Assoc [ "value", `String desc ] ]	×
50	\| Some (desc, Some url) ->	42✔
51	[ "code", `Assoc [ "value", `String desc; "url", `String url ] ])
52	in
53	fprintf ppf "%s\n%!" (Yojson.to_string j)	113✔
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	137✔
60	if String.starts_with ~prefix s
61	then Base.String.drop_prefix s (String.length prefix)	36✔
62	else s	101✔
63	;;
64
65	include (
66	struct
67	open Location
68	open Lexing
69
70	type input_line =
71	{ text : string
72	; start_pos : int
73	}
74
75	let infer_line_numbers (lines : (int option * input_line) list)
76	: (int option * input_line) list
77	=
78	let _, offset, consistent =	135✔
79	List.fold_left
80	(fun (i, offset, consistent) (lnum, _) ->
81	match lnum, offset with	237✔
82	\| None, _ -> i + 1, offset, consistent	71✔
83	\| Some n, None -> i + 1, Some (n - i), consistent	135✔
84	\| Some n, Some m -> i + 1, offset, consistent && n = m + i)	31✔
85	(0, None, true)
86	lines
87	in
88	match offset, consistent with	135✔
89	\| Some m, true -> List.mapi (fun i (_, line) -> Some (m + i), line) lines	135✔
90	\| _, _ -> lines	×
91	;;
92
93	module ISet : sig
94	type 'a bound = 'a * int
95	type 'a t
96
97	(* bounds are included *)
98	val of_intervals : ('a bound * 'a bound) list -> 'a t
99	val mem : 'a t -> pos:int -> bool
100	val find_bound_in : 'a t -> range:int * int -> 'a bound option
101	val is_start : 'a t -> pos:int -> 'a option
102	val is_end : 'a t -> pos:int -> 'a option
103	val extrema : 'a t -> ('a bound * 'a bound) option
104	end = struct
105	type 'a bound = 'a * int
106
107	(* non overlapping intervals *)
108	type 'a t = ('a bound * 'a bound) list
109
110	let of_intervals intervals =
111	let pos =	135✔
112	List.map
113	(fun ((a, x), (b, y)) -> if x > y then [] else [ (a, x), `S; (b, y), `E ])	×
114	intervals
115	\|> List.flatten	135✔
116	\|> List.sort (fun ((_, x), k) ((_, y), k') ->	135✔
117	(* Make `S come before `E so that consecutive intervals get merged
118	together in the fold below *)
119	let kn = function	135✔
120	\| `S -> 0	135✔
121	\| `E -> 1	135✔
122	in
123	compare (x, kn k) (y, kn k'))	135✔
124	in
125	let nesting, acc =	135✔
126	List.fold_left
127	(fun (nesting, acc) (a, kind) ->
128	match kind, nesting with	270✔
129	\| `S, `Outside -> `Inside (a, 0), acc	135✔
130	\| `S, `Inside (s, n) -> `Inside (s, n + 1), acc	×
131	\| `E, `Outside -> assert false
132	\| `E, `Inside (s, 0) -> `Outside, (s, a) :: acc	135✔
133	\| `E, `Inside (s, n) -> `Inside (s, n - 1), acc)	×
134	(`Outside, [])
135	pos
136	in
137	assert (nesting = `Outside);	135✔
138	List.rev acc
139	;;
140
141	let mem iset ~pos = List.exists (fun ((_, s), (_, e)) -> s <= pos && pos <= e) iset	4,820✔
142
143	let find_bound_in iset ~range:(start, end_) =
144	List.find_map	237✔
145	(fun ((a, x), (b, y)) ->
146	if start <= x && x <= end_	135✔
147	then Some (a, x)	135✔
148	else if start <= y && y <= end_	102✔
149	then Some (b, y)	31✔
150	else None)	71✔
151	iset
152	;;
153
154	let is_start iset ~pos =
155	List.find_map (fun ((a, x), _) -> if pos = x then Some a else None) iset	104✔
156	;;
157
158	let is_end iset ~pos =
159	List.find_map (fun (_, (b, y)) -> if pos = y then Some b else None) iset	104✔
160	;;
161
162	let extrema iset =
163	if iset = [] then None else Some (fst (List.hd iset), snd (List.hd (List.rev iset)))	×
164	;;
165	end
166
167	(* The number of lines already printed after input.
168
169	This is used by [highlight_terminfo] to identify the current position of the
170	input in the terminal. This would not be possible without this information,
171	since printing several warnings/errors adds text between the user input and
172	the bottom of the terminal.
173
174	We also use for {!is_first_report}, see below.
175	*)
176	let num_loc_lines = ref 0
177
178	(* We use [num_loc_lines] to determine if the report about to be
179	printed is the first or a follow-up report of the current
180	"batch" -- contiguous reports without user input in between, for
181	example for the current toplevel phrase. We use this to print
182	a blank line between messages of the same batch.
183	*)
184	let is_first_message () = !num_loc_lines = 0	×
185
186	(* This is used by the toplevel to reset [num_loc_lines] before each phrase *)
187	let reset () = num_loc_lines := 0	×
188
189	(* This is used by the toplevel *)
190	let echo_eof () =
191	print_newline ();	×
192	incr num_loc_lines	×
193	;;
194
195	(* Code printing errors and warnings must be wrapped using this function, in
196	order to update [num_loc_lines].
197
198	[print_updating_num_loc_lines ppf f arg] is equivalent to calling [f ppf
199	arg], and additionally updates [num_loc_lines]. *)
200	let print_updating_num_loc_lines ppf f arg =
201	let open Format in	×
202	let out_functions = pp_get_formatter_out_functions ppf () in
203	let out_string str start len =	×
204	let rec count i c =	×
205	if i = start + len	×
206	then c	×
207	else if String.get str i = '\n'	×
208	then count (succ i) (succ c)	×
209	else count (succ i) c	×
210	in
211	num_loc_lines := !num_loc_lines + count start 0;	×
212	out_functions.out_string str start len
213	in
214	pp_set_formatter_out_functions ppf { out_functions with out_string };
215	f ppf arg;	×
216	pp_print_flush ppf ();	×
217	pp_set_formatter_out_functions ppf out_functions	×
218	;;
219
220	(* let setup_tags () = Misc.Style.setup !Clflags.color *)
221
222	(* module Fmt = Format_doc *)
223	module Fmt = Format
224
225	let pp_two_columns ?(sep = "\|") ?max_lines ppf (lines : (string * string) list) =	×
226	let left_column_size =	31✔
227	List.fold_left (fun acc (s, _) -> Int.max acc (String.length s)) 0 lines	133✔
228	in
229	let lines_nb = List.length lines in	31✔
230	let ellipsed_first, ellipsed_last =	31✔
231	match max_lines with
232	\| Some max_lines when lines_nb > max_lines ->	31✔
233	let printed_lines = max_lines - 1 in	2✔
234	(* the ellipsis uses one line *)
235	let lines_before = (printed_lines / 2) + (printed_lines mod 2) in
236	let lines_after = printed_lines / 2 in
237	lines_before, lines_nb - lines_after - 1
238	\| _ -> -1, -1	29✔
239	in
240	Format.fprintf ppf "@[<v>";
241	List.iteri	31✔
242	(fun k (line_l, line_r) ->
243	if k = ellipsed_first then Format.fprintf ppf "...@,";	2✔
244	if ellipsed_first <= k && k <= ellipsed_last	123✔
245	then ()	16✔
246	else Format.fprintf ppf "%*s %s %s@," left_column_size line_l sep line_r)	117✔
247	lines;
248	Format.fprintf ppf "@]"	31✔
249	;;
250
251	(* [get_lines] must return the lines to highlight, given starting and ending
252	positions.
253
254	See [lines_around_from_current_input] below for an instantiation of
255	[get_lines] that reads from the current input.
256	*)
257	let highlight_quote
258	ppf
259	~(get_lines : start_pos:position -> end_pos:position -> input_line list)
260	?(max_lines = 10)	135✔
261	highlight_tag
262	locs
263	=
264	let iset =	135✔
265	ISet.of_intervals
266	@@ List.filter_map	135✔
267	(fun loc ->
268	let s, e = loc.loc_start, loc.loc_end in	135✔
269	if s.pos_cnum = -1 \|\| e.pos_cnum = -1	×
270	then None	×
271	else Some ((s, s.pos_cnum), (e, e.pos_cnum - 1)))	135✔
272	locs
273	in
274	match ISet.extrema iset with	135✔
275	\| None -> ()	×
276	\| Some ((leftmost, _), (rightmost, _)) ->	135✔
277	let lines =
278	get_lines ~start_pos:leftmost ~end_pos:rightmost
279	\|> List.map (fun ({ text; start_pos } as line) ->
280	let end_pos = start_pos + String.length text - 1 in	237✔
281	let line_nb =
282	match ISet.find_bound_in iset ~range:(start_pos, end_pos) with
283	\| None -> None	71✔
284	\| Some (p, _) -> Some p.pos_lnum	166✔
285	in
286	line_nb, line)
287	\|> infer_line_numbers	135✔
288	\|> List.map (fun (lnum, { text; start_pos }) ->	135✔
289	text, Option.fold ~some:Int.to_string ~none:"" lnum, start_pos)	237✔
290	in
291	Fmt.fprintf ppf "@[<v>";	135✔
292	(match lines with	135✔
293	\| [] \| [ ("", _, _) ] -> ()	×
294	\| [ (line, line_nb, line_start_cnum) ] ->	104✔
295	(* Single-line error *)
296	Fmt.fprintf ppf "%s \| %s@," line_nb line;
297	Fmt.fprintf ppf "%*s " (String.length line_nb) "";	104✔
298	(* Iterate up to [rightmost], which can be larger than the length of
299	the line because we may point to a location after the end of the
300	last token on the line, for instance:
301	{[
302	token
303	^
304	Did you forget ...
305	]} *)
306	for i = 0 to rightmost.pos_cnum - line_start_cnum - 1 do	104✔
307	let pos = line_start_cnum + i in	3,373✔
308	if ISet.is_start iset ~pos <> None then Fmt.fprintf ppf "@{<%s>" highlight_tag;	104✔
309	if ISet.mem iset ~pos	3,373✔
310	then Fmt.pp_print_char ppf '^'	2,376✔
311	else if i < String.length line	997✔
312	then
313	(* For alignment purposes, align using a tab for each tab in the
314	source code *)
315	if line.[i] = '\t'	997✔
316	then Fmt.pp_print_char ppf '\t'	×
317	else Fmt.pp_print_char ppf ' ';	997✔
318	if ISet.is_end iset ~pos <> None then Fmt.fprintf ppf "@}"	104✔
319	done;
320	Fmt.fprintf ppf "@}@,"	104✔
321	\| _ ->	31✔
322	(* Printf.eprintf "%s. %s %d\n%!" __FUNCTION__ __FILE__ __LINE__; *)
323	(* Multi-line error *)
324	pp_two_columns ~sep:"\|" ~max_lines ppf	31✔
325	@@ List.map	31✔
326	(fun (line, line_nb, line_start_cnum) ->
327	let line =	133✔
328	String.mapi
329	(fun i car ->
330	if ISet.mem iset ~pos:(line_start_cnum + i) then car else '.')	174✔
331	line
332	in
333	line_nb, line)	133✔
334	lines);
335	Fmt.fprintf ppf "@]"
336	;;
337
338	let lines_around
339	~(start_pos : position)
340	~(end_pos : position)
341	~(seek : int -> unit)
342	~(read_char : unit -> char option)
343	: input_line list
344	=
345	seek start_pos.pos_bol;	135✔
346	let lines = ref [] in	135✔
347	let bol = ref start_pos.pos_bol in
348	let cur = ref start_pos.pos_bol in
349	let b = Buffer.create 80 in
350	let add_line () =	135✔
351	if !bol < !cur	237✔
352	then (	237✔
353	let text = Buffer.contents b in
354	Buffer.clear b;	237✔
355	lines := { text; start_pos = !bol } :: !lines;	237✔
356	bol := !cur)
357	in
358	let rec loop () =
359	if !bol >= end_pos.pos_cnum	6,630✔
360	then ()	131✔
361	else (	6,499✔
362	match read_char () with
363	\| None ->	4✔
364	(* end of input *)
365	add_line ()
366	\| Some c ->	6,495✔
367	incr cur;
368	(match c with	6,495✔
369	\| '\r' -> loop ()	×
370	\| '\n' ->	233✔
371	add_line ();
372	loop ()	233✔
373	\| _ ->	6,262✔
374	Buffer.add_char b c;
375	loop ()))	6,262✔
376	in
377	loop ();
378	List.rev !lines	135✔
379	;;
380
381	(* Attempt to get lines from the lexing buffer. *)
382	let lines_around_from_lexbuf ~(start_pos : position) ~(end_pos : position) (lb : lexbuf)
383	: input_line list
384	=
385	(* Printf.eprintf "%s lexbuf.len = %d\n%!" __FUNCTION__ lb.Lexing.lex_buffer_len; *)
386	(* Converts a global position to one that is relative to the lexing buffer *)
387	let rel n = n - lb.lex_abs_pos in	135✔
388	if rel start_pos.pos_bol < 0	135✔
389	then
390	(* Do nothing if the buffer does not contain the input (because it has been
391	refilled while lexing it) *)
392	[]	×
393	else (	135✔
394	let pos = ref 0 in
395	(* relative position *)
396	let seek n = pos := rel n in	135✔
397	let read_char () =
398	if !pos >= lb.lex_buffer_len	6,499✔
399	then (* end of buffer *) None	4✔
400	else (	6,495✔
401	let c = Bytes.get lb.lex_buffer !pos in
402	incr pos;	6,495✔
403	Some c)	6,495✔
404	in
405	lines_around ~start_pos ~end_pos ~seek ~read_char)
406	;;
407
408	(* Attempt to get lines from the phrase buffer *)
409	let lines_around_from_phrasebuf
410	~(start_pos : position)
411	~(end_pos : position)
412	(pb : Buffer.t)
413	: input_line list
414	=
415	let pos = ref 0 in	×
416	let seek n = pos := n in	×
417	let read_char () =
418	if !pos >= Buffer.length pb	×
419	then None	×
420	else (	×
421	let c = Buffer.nth pb !pos in
422	incr pos;	×
423	Some c)	×
424	in
425	lines_around ~start_pos ~end_pos ~seek ~read_char
426	;;
427
428	(* A [get_lines] function for [highlight_quote] that reads from the current
429	input. *)
430	let lines_around_from_current_input ~start_pos ~end_pos =
431	match !Location.input_lexbuf, !Location.input_phrase_buffer, !Location.input_name with	135✔
432	\| _, Some pb, "//toplevel//" -> lines_around_from_phrasebuf pb ~start_pos ~end_pos	×
433	\| Some lb, _, _ ->	135✔
434	let xs = lines_around_from_lexbuf lb ~start_pos ~end_pos in
435	(* Printf.eprintf "lines_around_from_lexbuf return list len %d\n%!" (List.length xs); *)
436	xs	135✔
437	\| None, _, _ -> []	×
438	;;
439
440	let is_dummy_loc loc =
441	(* Fixme: this should be just [loc.loc_ghost] and the function should be
442	inlined below. However, currently, the compiler emits in some places ghost
443	locations with valid ranges that should still be printed. These locations
444	should be made non-ghost -- in the meantime we just check if the ranges are
445	valid. *)
446	loc.loc_start.pos_cnum = -1 \|\| loc.loc_end.pos_cnum = -1	×
447	;;
448
449	let is_quotable_loc loc =
450	(not (is_dummy_loc loc))	137✔
451	&& loc.loc_start.pos_fname = !input_name	135✔
452	&& loc.loc_end.pos_fname = !input_name	135✔
453	;;
454
455	let report_printer ppf loc f x =
456	let highlight ppf loc =	137✔
457	if is_quotable_loc loc	137✔
458	then
459	highlight_quote ppf ~get_lines:lines_around_from_current_input "warning" [ loc ]	135✔
460	in
461	Format.fprintf ppf "@[<v>%a:@ %a@]" print_loc loc highlight loc;
462	Format.fprintf ppf "@[Alert zanuda-linter: @[%a@]@]@," f x;	137✔
463	Format.fprintf ppf "%!"	137✔
464	;;
465	end :
466	sig
467	val report_printer : formatter -> Location.t -> (formatter -> 'a -> unit) -> 'a -> unit
468	end)
469
470	module Report = struct
471	let txt ~loc ~filename ppf msg msg_arg =
472	if Sys.file_exists filename	138✔
473	then (	137✔
474	Location.input_name := cut_build_dir filename;	137✔
475	Clflags.error_style := Some Misc.Error_style.Contextual;
476	let file_contents = In_channel.with_open_text filename In_channel.input_all in
477	Location.input_lexbuf := Some (Lexing.from_string file_contents);	137✔
478	let loc =
479	let open Location in
480	{ loc with
481	loc_start = { loc.loc_start with pos_fname = !input_name }
482	; loc_end = { loc.loc_end with pos_fname = !input_name }
483	}
484	in
485	report_printer ppf loc msg msg_arg)
486	else (	1✔
487	Format.fprintf ppf "@[Alert zanuda-linter: @[%a@]@]@," msg msg_arg;
488	Format.fprintf ppf "%!")	1✔
489	;;
490
491	let rdjsonl ~loc ~filename ~code ppf msg msg_arg =
492	let code = code, Some "https://kakadu.github.io/zanuda/" in	42✔
493	RDJsonl.pp ppf ~filename ~line:loc.Location.loc_start.pos_lnum ~code msg msg_arg
494	;;
495	end
496
497	let string_of_group : LINT.group -> string = function
498	\| LINT.Correctness -> "correctness"	5✔
499	\| Style -> "style"	20✔
500	\| Perf -> "perf"	4✔
501	\| Restriction -> "restriction"	×
502	\| Deprecated -> "deprecated"	×
503	\| Pedantic -> "pedantic"	×
504	\| Complexity -> "complexity"	×
505	\| Suspicious -> "suspicious"	3✔
506	\| Nursery -> "nursery"	1✔
507	;;
508
509	let string_of_level : LINT.level -> string = function
510	\| LINT.Allow -> "allow"	1✔
511	\| Warn -> "warn"	13✔
512	\| Deny -> "deny"	19✔
513	\| Deprecated -> "deprecated"	×
514	;;
515
516	let string_of_impl = function
517	\| LINT.Typed -> "typed"	23✔
518	\| _ -> "untyped"	10✔
519	;;
520
521	let describe_as_clippy_json
522	?(group = LINT.Correctness)	5✔
523	?(level = LINT.Deny)	18✔
524	?(impl = LINT.Typed)	23✔
525	id
526	~docs
527	: Yojson.Safe.t
528	=
529	(* List if clippy lints https://github.com/rust-lang/rust-clippy/blob/gh-pages/master/lints.json *)
530	`Assoc	33✔
531	[ "id", `String id
532	; "group", `String (string_of_group group)	33✔
533	; "level", `String (string_of_level level)	33✔
534	; "impl", `String (string_of_impl impl)	33✔
535	; "docs", `String docs
536	; ( "applicability"
537	, `Assoc
538	[ "is_multi_part_suggestion", `Bool false
539	; "applicability", `String "Unresolved"
540	] )
541	]
542	;;
543
544	exception Ident_is_found
545
546	let no_ident_iterator ident =
547	let open Tast_iterator in	73✔
548	let open Typedtree in
549	{ default_iterator with
550	expr =
551	(fun self e ->
552	let rec ident_in_list = function	1,301✔
553	\| [] -> false	156✔
554	\| (_, (id, _)) :: _ when Ident.equal id ident -> true	1✔
555	\| _ :: tl -> ident_in_list tl	208✔
556	in
557	Tast_pattern.(
558	let p1 =
559	map2 (texp_function_body __ __) ~f:(fun args rhs -> `Function (args, rhs))	157✔
560	in
561	let p2 = map1 (texp_ident __) ~f:(fun x -> `Ident x) in	525✔
562	parse	1,301✔
563	(p1 \|\|\| p2)	1,301✔
564	(* TODO: should we check other patterns? *)
565	e.exp_loc
566	e
567	~on_error:(fun _ -> default_iterator.expr self e))	619✔
568	(function
569	\| `Function (args, _rhs) when ident_in_list args -> ()	1✔
570	\| `Function (_, rhs) -> self.expr self rhs	156✔
571	\| `Ident (Pident id) when Ident.same id ident -> raise_notrace Ident_is_found	11✔
572	\| _ -> default_iterator.expr self e))	514✔
573	; case =
574	(fun (type a) self (c : a case) ->
575	match c.c_lhs.pat_desc with	74✔
576	\| Tpat_value v ->	12✔
577	(match (v :> pattern) with
578	\| p ->	12✔
579	Tast_pattern.(
580	parse
581	(tpat_id __)	12✔
582	Location.none
583	p
584	~on_error:(fun _ -> default_iterator.case self c)	12✔
585	(fun id ->
586	if Ident.equal ident id then () else default_iterator.case self c)))	×
587	\| _ -> default_iterator.case self c)	62✔
588	}
589	;;
590
591	(* Checks that identifier is not used *)
592	let no_ident ident f =
593	try	40✔
594	f (no_ident_iterator ident);	40✔
595	true	31✔
596	with
597	\| Ident_is_found -> false	9✔
598	;;
599
600	let has_ident ident f = not (no_ident ident f)	11✔
601
602	[%%if ocaml_version < (5, 0, 0)]
603
604	type intf_or_impl =
605	\| Intf
606	\| Impl
607
608	let with_info _kind ~source_file f =
609	Compile_common.with_info	135✔
610	~native:false
611	~source_file
612	~tool_name:"asdf" (* TODO: pass right tool name *)
613	~output_prefix:"asdf"
614	~dump_ext:"asdf"
615	f
616	;;
617
618	[%%else]
619
620	type intf_or_impl = Unit_info.intf_or_impl
621
622	let with_info kind ~source_file =
623	Compile_common.with_info
624	~native:false
625	~tool_name:"asdf" (* TODO: pass right tool name *)
626	~dump_ext:"asdf"
627	(Unit_info.make ~source_file kind "")
628	;;
629
630	[%%endif]
631	[%%if ocaml_version < (5, 0, 0)]
632
633	let pp_path = Path.print
634
635	[%%else]
636
637	let pp_path = Format_doc.compat Path.print
638
639	[%%endif]
640	[%%if ocaml_version < (5, 0, 0)]
641
642	let source_of_info info = info.Compile_common.source_file	133✔
643
644	[%%else]
645
646	let source_of_info info = Unit_info.source_file info.Compile_common.target
647
648	[%%endif]

Kakadu / zanuda / 41

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