Kakadu / zanuda / 21

Committed 17 Sep 2025 05:25PM UTC coverage: 85.476% (-0.4%) from 85.847%

Build # 21

Build Type

Pull #72

github

Committed by

Kakadu

Commit Message

Set ocamlformat=0.27.0 as a dependency. No code promote yet

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

Pull Request Pull Request #72: OCaml53 support

Run Details

241 of 298 new or added lines in 18 files covered. (80.87%)

7 existing lines in 4 files now uncovered.

2207 of 2582 relevant lines covered (85.48%)

511.36 hits per line

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

78.14

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

  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 ~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]

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 =	110✔
35	`Assoc	110✔
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)	110✔
43	; "location", location filename ~line ~col:1	110✔
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) ->	42✔
51	[ "code", `Assoc [ "value", `String desc; "url", `String url ] ])
52	in
53	fprintf ppf "%s\n%!" (Yojson.to_string j)	110✔
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	136✔
60	if String.starts_with ~prefix s
61	then Base.String.drop_prefix s (String.length prefix)	36✔
62	else s	100✔
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 =	134✔
79	List.fold_left
80	(fun (i, offset, consistent) (lnum, _) ->
81	match lnum, offset with	236✔
82	\| None, _ -> i + 1, offset, consistent	71✔
83	\| Some n, None -> i + 1, Some (n - i), consistent	134✔
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	134✔
89	\| Some m, true -> List.mapi (fun i (_, line) -> Some (m + i), line) lines	134✔
NEW 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 =	134✔
112	List.map
NEW 113	(fun ((a, x), (b, y)) -> if x > y then [] else [ (a, x), `S; (b, y), `E ])	×
114	intervals
115	\|> List.flatten	134✔
116	\|> List.sort (fun ((_, x), k) ((_, y), k') ->	134✔
117	(* Make `S come before `E so that consecutive intervals get merged
118	together in the fold below *)
119	let kn = function	134✔
120	\| `S -> 0	134✔
121	\| `E -> 1	134✔
122	in
123	compare (x, kn k) (y, kn k'))	134✔
124	in
125	let nesting, acc =	134✔
126	List.fold_left
127	(fun (nesting, acc) (a, kind) ->
128	match kind, nesting with	268✔
129	\| `S, `Outside -> `Inside (a, 0), acc	134✔
NEW 130	\| `S, `Inside (s, n) -> `Inside (s, n + 1), acc	×
131	\| `E, `Outside -> assert false
132	\| `E, `Inside (s, 0) -> `Outside, (s, a) :: acc	134✔
NEW 133	\| `E, `Inside (s, n) -> `Inside (s, n - 1), acc)	×
134	(`Outside, [])
135	pos
136	in
137	assert (nesting = `Outside);	134✔
138	List.rev acc
139	;;
140
141	let mem iset ~pos = List.exists (fun ((_, s), (_, e)) -> s <= pos && pos <= e) iset	4,792✔
142
143	let find_bound_in iset ~range:(start, end_) =
144	List.find_map	236✔
145	(fun ((a, x), (b, y)) ->
146	if start <= x && x <= end_	134✔
147	then Some (a, x)	134✔
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	103✔
156	;;
157
158	let is_end iset ~pos =
159	List.find_map (fun (_, (b, y)) -> if pos = y then Some b else None) iset	103✔
160	;;
161
162	let extrema iset =
NEW 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	*)
NEW 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 *)
NEW 187	let reset () = num_loc_lines := 0	×
188
189	(* This is used by the toplevel *)
190	let echo_eof () =
NEW 191	print_newline ();	×
NEW 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 =
NEW 201	let open Format in	×
202	let out_functions = pp_get_formatter_out_functions ppf () in
NEW 203	let out_string str start len =	×
NEW 204	let rec count i c =	×
NEW 205	if i = start + len	×
NEW 206	then c	×
NEW 207	else if String.get str i = '\n'	×
NEW 208	then count (succ i) (succ c)	×
NEW 209	else count (succ i) c	×
210	in
NEW 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 };
NEW 215	f ppf arg;	×
NEW 216	pp_print_flush ppf ();	×
NEW 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
NEW 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)	134✔
261	highlight_tag
262	locs
263	=
264	let iset =	134✔
265	ISet.of_intervals
266	@@ List.filter_map	134✔
267	(fun loc ->
268	let s, e = loc.loc_start, loc.loc_end in	134✔
NEW 269	if s.pos_cnum = -1 \|\| e.pos_cnum = -1	×
NEW 270	then None	×
271	else Some ((s, s.pos_cnum), (e, e.pos_cnum - 1)))	134✔
272	locs
273	in
274	match ISet.extrema iset with	134✔
NEW 275	\| None -> ()	×
276	\| Some ((leftmost, _), (rightmost, _)) ->	134✔
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	236✔
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	165✔
285	in
286	line_nb, line)
287	\|> infer_line_numbers	134✔
288	\|> List.map (fun (lnum, { text; start_pos }) ->	134✔
289	text, Option.fold ~some:Int.to_string ~none:"" lnum, start_pos)	236✔
290	in
291	Fmt.fprintf ppf "@[<v>";	134✔
292	(match lines with	134✔
NEW 293	\| [] \| [ ("", _, _) ] -> ()	×
294	\| [ (line, line_nb, line_start_cnum) ] ->	103✔
295	(* Single-line error *)
296	Fmt.fprintf ppf "%s \| %s@," line_nb line;
297	Fmt.fprintf ppf "%*s " (String.length line_nb) "";	103✔
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	103✔
307	let pos = line_start_cnum + i in	3,317✔
308	if ISet.is_start iset ~pos <> None then Fmt.fprintf ppf "@{<%s>" highlight_tag;	103✔
309	if ISet.mem iset ~pos	3,317✔
310	then Fmt.pp_print_char ppf '^'	2,348✔
311	else if i < String.length line	969✔
312	then
313	(* For alignment purposes, align using a tab for each tab in the
314	source code *)
315	if line.[i] = '\t'	969✔
NEW 316	then Fmt.pp_print_char ppf '\t'	×
317	else Fmt.pp_print_char ppf ' ';	969✔
318	if ISet.is_end iset ~pos <> None then Fmt.fprintf ppf "@}"	103✔
319	done;
320	Fmt.fprintf ppf "@}@,"	103✔
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;	134✔
346	let lines = ref [] in	134✔
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 () =	134✔
351	if !bol < !cur	236✔
352	then (	236✔
353	let text = Buffer.contents b in
354	Buffer.clear b;	236✔
355	lines := { text; start_pos = !bol } :: !lines;	236✔
356	bol := !cur)
357	in
358	let rec loop () =
359	if !bol >= end_pos.pos_cnum	6,554✔
360	then ()	130✔
361	else (	6,424✔
362	match read_char () with
363	\| None ->	4✔
364	(* end of input *)
365	add_line ()
366	\| Some c ->	6,420✔
367	incr cur;
368	(match c with	6,420✔
NEW 369	\| '\r' -> loop ()	×
370	\| '\n' ->	232✔
371	add_line ();
372	loop ()	232✔
373	\| _ ->	6,188✔
374	Buffer.add_char b c;
375	loop ()))	6,188✔
376	in
377	loop ();
378	List.rev !lines	134✔
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	134✔
388	if rel start_pos.pos_bol < 0	134✔
389	then
390	(* Do nothing if the buffer does not contain the input (because it has been
391	refilled while lexing it) *)
NEW 392	[]	×
393	else (	134✔
394	let pos = ref 0 in
395	(* relative position *)
396	let seek n = pos := rel n in	134✔
397	let read_char () =
398	if !pos >= lb.lex_buffer_len	6,424✔
399	then (* end of buffer *) None	4✔
400	else (	6,420✔
401	let c = Bytes.get lb.lex_buffer !pos in
402	incr pos;	6,420✔
403	Some c)	6,420✔
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	=
NEW 415	let pos = ref 0 in	×
NEW 416	let seek n = pos := n in	×
417	let read_char () =
NEW 418	if !pos >= Buffer.length pb	×
NEW 419	then None	×
NEW 420	else (	×
421	let c = Buffer.nth pb !pos in
NEW 422	incr pos;	×
NEW 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	134✔
NEW 432	\| _, Some pb, "//toplevel//" -> lines_around_from_phrasebuf pb ~start_pos ~end_pos	×
433	\| Some lb, _, _ ->	134✔
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	134✔
NEW 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. *)
NEW 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))	136✔
451	&& loc.loc_start.pos_fname = !input_name	134✔
452	&& loc.loc_end.pos_fname = !input_name	134✔
453	;;
454
455	let report_printer ppf loc f x =
456	let highlight ppf loc =	136✔
457	if is_quotable_loc loc	136✔
458	then
459	highlight_quote ppf ~get_lines:lines_around_from_current_input "warning" [ loc ]	134✔
460	in
461	Format.fprintf ppf "@[<v>%a:@ %a@]" print_loc loc highlight loc;
462	Format.fprintf ppf "@[Alert zanuda-linter: @[%a@]@]@," f x;	136✔
463	Format.fprintf ppf "%!"	136✔
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	Location.input_name := cut_build_dir filename;	136✔
473	Clflags.error_style := Some Misc.Error_style.Contextual;
474	let file_contents = In_channel.with_open_text filename In_channel.input_all in
475	Location.input_lexbuf := Some (Lexing.from_string file_contents);	136✔
476	let loc =
477	let open Location in
478	{ loc with
479	loc_start = { loc.loc_start with pos_fname = !input_name }
480	; loc_end = { loc.loc_end with pos_fname = !input_name }
481	}
482	in
483	report_printer ppf loc msg msg_arg
484	;;
485
486	let rdjsonl ~loc ~filename ~code ppf msg msg_arg =
487	let code = code, Some "https://kakadu.github.io/zanuda/" in	42✔
488	RDJsonl.pp ppf ~filename ~line:loc.Location.loc_start.pos_lnum ~code msg msg_arg
489	;;
490	end
491
492	let string_of_group : LINT.group -> string = function
493	\| LINT.Correctness -> "correctness"	5✔
494	\| Style -> "style"	20✔
495	\| Perf -> "perf"	4✔
496	\| Restriction -> "restriction"	×
497	\| Deprecated -> "deprecated"	×
498	\| Pedantic -> "pedantic"	×
499	\| Complexity -> "complexity"	×
500	\| Suspicious -> "suspicious"	3✔
501	\| Nursery -> "nursery"	1✔
502	;;
503
504	let string_of_level : LINT.level -> string = function
505	\| LINT.Allow -> "allow"	1✔
506	\| Warn -> "warn"	13✔
507	\| Deny -> "deny"	19✔
508	\| Deprecated -> "deprecated"	×
509	;;
510
511	let string_of_impl = function
512	\| LINT.Typed -> "typed"	23✔
513	\| _ -> "untyped"	10✔
514	;;
515
516	let describe_as_clippy_json
517	?(group = LINT.Correctness)	5✔
518	?(level = LINT.Deny)	18✔
519	?(impl = LINT.Typed)	23✔
520	id
521	~docs
522	: Yojson.Safe.t
523	=
524	(* List if clippy lints https://github.com/rust-lang/rust-clippy/blob/gh-pages/master/lints.json *)
525	`Assoc	33✔
526	[ "id", `String id
527	; "group", `String (string_of_group group)	33✔
528	; "level", `String (string_of_level level)	33✔
529	; "impl", `String (string_of_impl impl)	33✔
530	; "docs", `String docs
531	; ( "applicability"
532	, `Assoc
533	[ "is_multi_part_suggestion", `Bool false
534	; "applicability", `String "Unresolved"
535	] )
536	]
537	;;
538
539	exception Ident_is_found
540
541	let no_ident_iterator ident =
542	let open Tast_iterator in	70✔
543	let open Typedtree in
544	{ default_iterator with
545	expr =
546	(fun self e ->
547	let rec ident_in_list = function	1,269✔
548	\| [] -> false	149✔
549	\| (_, (id, _)) :: _ when Ident.equal id ident -> true	1✔
550	\| _ :: tl -> ident_in_list tl	200✔
551	in
552	Tast_pattern.(
553	let p1 =
554	map2 (texp_function_body __ __) ~f:(fun args rhs -> `Function (args, rhs))	150✔
555	in
556	let p2 = map1 (texp_ident __) ~f:(fun x -> `Ident x) in	510✔
557	parse	1,269✔
558	(p1 \|\|\| p2)	1,269✔
559	(* TODO: should we check other patterns? *)
560	e.exp_loc
561	e
562	~on_error:(fun _ -> default_iterator.expr self e))	609✔
563	(function
564	\| `Function (args, _rhs) when ident_in_list args -> ()	1✔
565	\| `Function (_, rhs) -> self.expr self rhs	149✔
566	\| `Ident (Pident id) when Ident.same id ident -> raise_notrace Ident_is_found	11✔
567	\| _ -> default_iterator.expr self e))	499✔
568	; case =
569	(fun (type a) self (c : a case) ->
570	match c.c_lhs.pat_desc with	72✔
571	\| Tpat_value v ->	11✔
572	(match (v :> pattern) with
573	\| p ->	11✔
574	Tast_pattern.(
575	parse
576	(tpat_id __)	11✔
577	Location.none
578	p
579	~on_error:(fun _ -> default_iterator.case self c)	11✔
580	(fun id ->
NEW 581	if Ident.equal ident id then () else default_iterator.case self c)))	×
582	\| _ -> default_iterator.case self c)	61✔
583	}
584	;;
585
586	(* Checks that identifier is not used *)
587	let no_ident ident f =
588	try	39✔
589	f (no_ident_iterator ident);	39✔
590	true	30✔
591	with
592	\| Ident_is_found -> false	9✔
593	;;
594
595	[%%if ocaml_version < (5, 0, 0)]
596
597	type intf_or_impl =
598	\| Intf
599	\| Impl
600
601	let with_info _kind ~source_file f =
602	Compile_common.with_info	129✔
603	~native:false
604	~source_file
605	~tool_name:"asdf" (* TODO: pass right tool name *)
606	~output_prefix:"asdf"
607	~dump_ext:"asdf"
608	f
609	;;
610
611	[%%else]
612
613	type intf_or_impl = Unit_info.intf_or_impl
614
615	let with_info kind ~source_file =
616	Compile_common.with_info
617	~native:false
618	~tool_name:"asdf" (* TODO: pass right tool name *)
619	~dump_ext:"asdf"
620	(Unit_info.make ~source_file kind "")
621	;;
622
623	[%%endif]
624	[%%if ocaml_version < (5, 0, 0)]
625
626	let pp_path = Path.print
627
628	[%%else]
629
630	let pp_path = Format_doc.compat Path.print
631
632	[%%endif]

Kakadu / zanuda / 21

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