mbarbin / auto-format / 136

Committed 15 May 2026 02:48PM UTC coverage: 58.738% (-27.2%) from 85.922%

Build # 136

Build Type

push

github

Committed by

mbarbin

Commit Message

Remove rm step in CI causing dune IO errors

- It is no longer clear why we needed this in the first place. It's possible in
the long run an improvement would be to avoid caching _build entirely if this is
largely superseded by relocatable+dune-cache. TBD.

Coverage Stats

121 of 206 relevant lines covered (58.74%)

2.78 hits per line

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

36.36

/src/auto_format.ml

(****************************************************************************)
(*  auto-format: Build auto-format commands for custom languages            *)
(*  SPDX-FileCopyrightText: 2023 Mathieu Barbin <mathieu.barbin@gmail.com>  *)
(*  SPDX-License-Identifier: MIT                                            *)
(****************************************************************************)

module Sexp = Sexplib0.Sexp

let find_files_in_cwd_by_extensions ~cwd ~extensions =
  Sys.readdir cwd
  |> Array.map ~f:Fpath.v
  |> Array.to_list
  |> List.filter ~f:(fun file ->
    Sys.is_regular_file (Fpath.to_string Fpath.(v cwd // file))
    && List.exists extensions ~f:(fun extension -> Fpath.has_ext extension file))
  |> List.sort ~compare:Fpath.compare
;;

let allow_changes =
  lazy
    (let var = "AUTO_FORMAT_ALLOW_CHANGES" in
     match Sys.getenv_opt var with
     | Some "true" -> true
     | None | Some "false" -> false
     | Some value ->
       Err.raise
         [ Pp.text "Unexpected value for env var."
         ; Dyn.pp (Dyn.record [ "var", var |> Dyn.string; "value", value |> Dyn.string ])
         ])
;;

module type T = sig
  type t

  val equal : t -> t -> bool
  val sexp_of_t : t -> Sexp.t
end

module type T_pp = sig
  type t

  val pp : t -> unit Pp.t
end

module Config = struct
  module type S = sig
    val language_id : string
    val extensions : string list
  end
end

module Make
    (Config : Config.S)
    (T : T)
    (T_parser : Parsing_utils.S with type t = T.t)
    (T_pp : T_pp with type t = T.t) =
struct
  module Pretty_print_result = struct
    type t =
      { pretty_printed_contents : string
      ; result : (unit, Err.t) Result.t
      }
  end

  module Parsing_result = struct
    type 'a t = 'a Parsing_utils.Parsing_result.t

    let with_dot m = if String.ends_with m ~suffix:"." then m else m ^ "."

    let or_err (t : _ t) =
      match t with
      | Ok t -> Ok t
      | Error { loc; exn } ->
        let extra =
          match exn with
          | Failure m -> with_dot m
          | Sys_error _ as exn -> with_dot (Printexc.to_string exn)
          | _ -> " syntax error."
        in
        Error (Err.create ~loc [ Pp.text extra ])
    ;;
  end

  let rec find_fix_point ~path ~num_steps ~contents =
    let open Result.Syntax in
    let* (program : T.t) =
      Parsing_utils.parse_lexbuf
        (module T_parser)
        ~path
        ~lexbuf:(Lexing.from_string contents)
      |> Parsing_result.or_err
    in
    let pretty_printed_contents = Pp.render (T_pp.pp program) in
    let ts_are_equal =
      let+ (program_2 : T.t) =
        Parsing_utils.parse_lexbuf
          (module T_parser)
          ~path
          ~lexbuf:(Lexing.from_string pretty_printed_contents)
        |> Parsing_result.or_err
      in
      Ref.set_temporarily Loc.equal_ignores_locs true ~f:(fun () ->
        T.equal program program_2)
    in
    let ts_are_equal =
      match ts_are_equal with
      | Ok false -> if Lazy.force allow_changes then Ok true else ts_are_equal
      | (Ok true | Error _) as t -> t
    in
    match ts_are_equal with
    | Ok false ->
      Ok
        { Pretty_print_result.pretty_printed_contents
        ; result = Error (Err.create [ Pp.text "AST changed during pretty-printing." ])
        }
    | Error e ->
      Ok
        { Pretty_print_result.pretty_printed_contents
        ; result =
            Error
              (Err.add_context e [ Pp.text "Pretty-printing produced invalid syntax." ])
        }
    | Ok true ->
      if String.equal pretty_printed_contents contents
      then Ok { Pretty_print_result.pretty_printed_contents; result = Ok () }
      else
        find_fix_point
          ~path
          ~num_steps:(Int.succ num_steps)
          ~contents:pretty_printed_contents
  ;;

  let pretty_print ~path ~read_contents_from_stdin =
    let contents =
      if read_contents_from_stdin
      then In_channel.input_all stdin
      else In_channel.with_open_bin (Fpath.to_string path) In_channel.input_all
    in
    find_fix_point ~path ~num_steps:0 ~contents
  ;;

  let test_cmd =
    Command.make
      ~summary:
        (Printf.sprintf
           "Check that all %s files of the current directory can be pretty-printed."
           (Config.extensions |> String.concat ~sep:", "))
      (let open Command.Std in
       let+ () = Log_cli.set_config () in
       let cwd = Sys.getcwd () in
       let files = find_files_in_cwd_by_extensions ~cwd ~extensions:Config.extensions in
       List.iter files ~f:(fun path ->
         prerr_endline ("================================: " ^ Fpath.to_string path);
         match pretty_print ~path ~read_contents_from_stdin:false with
         | Error e -> Err.prerr e ~reset_separator:true
         | Ok { pretty_printed_contents; result } ->
           Out_channel.output_string Out_channel.stderr pretty_printed_contents;
           Out_channel.flush Out_channel.stderr;
           (match result with
            | Ok () -> ()
            | Error e ->
              prerr_endline "======: errors";
              Err.prerr e ~reset_separator:true)))
  ;;

  let gen_dune_cmd =
    Command.make
      ~summary:
        (Printf.sprintf
           "Generate dune stanza for all %s files present in the cwd to be \
            pretty-printed."
           (Config.extensions |> String.concat ~sep:", "))
      (let open Command.Std in
       let+ exclude =
         Arg.named_with_default
           [ "exclude" ]
           (Param.comma_separated Param.string)
           ~default:[]
           ~docv:"FILE"
           ~doc:"Files to exclude."
       and+ call =
         Arg.pos_all
           Param.string
           ~doc:"How to access the [fmt file] command for these files."
       in
       let cwd = Sys.getcwd () in
       let exclude =
         (* Acknowledging use of polymorphic hashtbl with [string] keys. *)
         let t : (string, unit) Hashtbl.t = Hashtbl.create (List.length exclude) in
         List.iter exclude ~f:(fun s -> Hashtbl.add t s ());
         t
       in
       let files =
         find_files_in_cwd_by_extensions ~cwd ~extensions:Config.extensions
         |> List.filter ~f:(fun file -> not (Hashtbl.mem exclude (Fpath.to_string file)))
       in
       let output_ext = ".pp.output" in
       let generate_rules ~file =
         let list s = Sexp.List s
         and atom s = Sexp.Atom s in
         let atoms s = Sexp.List (List.map s ~f:atom) in
         let pp =
           list
             [ atom "rule"
             ; list
                 [ atom "with-stdout-to"
                 ; atom (Fpath.to_string file ^ output_ext)
                 ; atoms
                     ([ [ "run" ]
                      ; call
                      ; [ Printf.sprintf "%%{dep:%s}" (Fpath.to_string file) ]
                      ]
                      |> List.concat)
                 ]
             ]
         in
         let fmt =
           list
             [ atom "rule"
             ; atoms [ "alias"; "fmt" ]
             ; list
                 [ atom "action"
                 ; atoms
                     [ "diff"; Fpath.to_string file; Fpath.to_string file ^ output_ext ]
                 ]
             ]
         in
         [ pp; fmt ]
       in
       Out_channel.output_string
         Out_channel.stdout
         (Printf.sprintf
            "; dune file generated by '%s' -- do not edit.\n"
            (List.map call ~f:(function
               | "file" -> "gen-dune"
               | e -> e)
             |> String.concat ~sep:" "));
       List.iter files ~f:(fun file ->
         List.iter (generate_rules ~file) ~f:(fun sexp ->
           print_endline (Sexp.to_string_hum sexp))))
  ;;

  let file_cmd =
    Command.make
      ~summary:(Printf.sprintf "Autoformat %s files." Config.language_id)
      ~readme:(fun () ->
        let buffer = Buffer.create 256 in
        Buffer.add_substitute
          buffer
          (function
            | "LANG" -> Config.language_id
            | "EXTS" -> String.concat ~sep:", " Config.extensions
            | var ->
              Code_error.raise "Substitution not found" [ "var", var |> Dyn.string ])
          "This is a pretty-print command for ${LANG} files (extensions ${EXTS}).\n\n\
           This reads the contents of a file supplied in the command line, and \
           pretty-print it on stdout, leaving the original file unchanged.\n\n\
           If [--read-contents-from-stdin] is supplied, then the contents of the file is \
           read from stdin. In this case the filename must still be supplied, and will \
           be used for located error messages only.\n\n\
           In case of syntax errors or other issues, some contents may still be printed \
           to stdout, however the exit code will be non zero (typically [1]). Errors are \
           printed on stderr.\n\n\
           The hope for this command is for it to be compatible with editors and build \
           systems so that you can integrate autoformatting of files into your \
           workflow.\n\n\
           Because this command has been tested with a vscode extension that strips the \
           last newline, a flag has been added to add an extra blank line, shall you run \
           into this issue.";
        Buffer.contents buffer)
      (let open Command.Std in
       let+ () = Log_cli.set_config ()
       and+ path =
         Arg.pos ~pos:0 Param.file ~docv:"FILE" ~doc:"File to format." >>| Fpath.v
       and+ read_contents_from_stdin =
         Arg.flag
           [ "read-contents-from-stdin" ]
           ~doc:"Read contents from stdin rather than from the file."
       and+ add_extra_blank_line =
         Arg.flag [ "add-extra-blank-line" ] ~doc:"Add an extra blank line at the end."
       in
       (let open Result.Syntax in
        let* { Pretty_print_result.pretty_printed_contents; result } =
          pretty_print ~path ~read_contents_from_stdin
        in
        print_string pretty_printed_contents;
        if add_extra_blank_line then print_endline "";
        result)
       |> Err.ok_exn)
  ;;

  let dump_cmd =
    Command.make
      ~summary:"Dump a parsed tree on stdout."
      (let open Command.Std in
       let+ path = Arg.pos ~pos:0 Param.file ~docv:"FILE" ~doc:"File to dump." >>| Fpath.v
       and+ with_positions = Arg.flag [ "loc" ] ~doc:"Dump loc details." in
       let (program : T.t) = Parsing_utils.parse_file_exn (module T_parser) ~path in
       Ref.set_temporarily Loc.include_sexp_of_locs with_positions ~f:(fun () ->
         print_endline (Sexp.to_string_hum (program |> T.sexp_of_t))))
  ;;

  let fmt_cmd =
    Command.group
      ~summary:"Commands related to auto-formatting."
      [ "dump", dump_cmd; "file", file_cmd; "test", test_cmd; "gen-dune", gen_dune_cmd ]
  ;;
end

let fmt_cmd
      (type t)
      (module Config : Config.S)
      (module T : T with type t = t)
      (module Syntax : Parsing_utils.S with type t = t)
      (module Pp : T_pp with type t = t)
  =
  let module M = Make (Config) (T) (Syntax) (Pp) in
  M.fmt_cmd
;;

1	(****************************************************************************)
2	(* auto-format: Build auto-format commands for custom languages *)
3	(* SPDX-FileCopyrightText: 2023 Mathieu Barbin <mathieu.barbin@gmail.com> *)
4	(* SPDX-License-Identifier: MIT *)
5	(****************************************************************************)
6
7	module Sexp = Sexplib0.Sexp
8
9	let find_files_in_cwd_by_extensions ~cwd ~extensions =
10	Sys.readdir cwd	×
11	\|> Array.map ~f:Fpath.v	×
12	\|> Array.to_list	×
13	\|> List.filter ~f:(fun file ->	×
14	Sys.is_regular_file (Fpath.to_string Fpath.(v cwd // file))	×
15	&& List.exists extensions ~f:(fun extension -> Fpath.has_ext extension file))	×
16	\|> List.sort ~compare:Fpath.compare	×
17	;;
18
19	let allow_changes =
20	lazy
21	(let var = "AUTO_FORMAT_ALLOW_CHANGES" in	×
22	match Sys.getenv_opt var with
23	\| Some "true" -> true	×
24	\| None \| Some "false" -> false	×
25	\| Some value ->	×
26	Err.raise
27	[ Pp.text "Unexpected value for env var."	×
28	; Dyn.pp (Dyn.record [ "var", var \|> Dyn.string; "value", value \|> Dyn.string ])	×
29	])
30	;;
31
32	module type T = sig
33	type t
34
35	val equal : t -> t -> bool
36	val sexp_of_t : t -> Sexp.t
37	end
38
39	module type T_pp = sig
40	type t
41
42	val pp : t -> unit Pp.t
43	end
44
45	module Config = struct
46	module type S = sig
47	val language_id : string
48	val extensions : string list
49	end
50	end
51
52	module Make
53	(Config : Config.S)
54	(T : T)
55	(T_parser : Parsing_utils.S with type t = T.t)
56	(T_pp : T_pp with type t = T.t) =
57	struct
58	module Pretty_print_result = struct
59	type t =
60	{ pretty_printed_contents : string
61	; result : (unit, Err.t) Result.t
62	}
63	end
64
65	module Parsing_result = struct
66	type 'a t = 'a Parsing_utils.Parsing_result.t
67
68	let with_dot m = if String.ends_with m ~suffix:"." then m else m ^ "."	×
69
70	let or_err (t : _ t) =
71	match t with	4✔
72	\| Ok t -> Ok t	4✔
73	\| Error { loc; exn } ->	×
74	let extra =
75	match exn with
76	\| Failure m -> with_dot m	×
77	\| Sys_error _ as exn -> with_dot (Printexc.to_string exn)	×
78	\| _ -> " syntax error."	×
79	in
80	Error (Err.create ~loc [ Pp.text extra ])	×
81	;;
82	end
83
84	let rec find_fix_point ~path ~num_steps ~contents =
85	let open Result.Syntax in	2✔
86	let* (program : T.t) =
87	Parsing_utils.parse_lexbuf
88	(module T_parser)
89	~path
90	~lexbuf:(Lexing.from_string contents)	2✔
91	\|> Parsing_result.or_err	2✔
92	in
93	let pretty_printed_contents = Pp.render (T_pp.pp program) in	2✔
94	let ts_are_equal =	2✔
95	let+ (program_2 : T.t) =
96	Parsing_utils.parse_lexbuf
97	(module T_parser)
98	~path
99	~lexbuf:(Lexing.from_string pretty_printed_contents)	2✔
100	\|> Parsing_result.or_err	2✔
101	in
102	Ref.set_temporarily Loc.equal_ignores_locs true ~f:(fun () ->	2✔
103	T.equal program program_2)	2✔
104	in
105	let ts_are_equal =
106	match ts_are_equal with
107	\| Ok false -> if Lazy.force allow_changes then Ok true else ts_are_equal	×
108	\| (Ok true \| Error _) as t -> t	×
109	in
110	match ts_are_equal with
111	\| Ok false ->	×
112	Ok
113	{ Pretty_print_result.pretty_printed_contents
114	; result = Error (Err.create [ Pp.text "AST changed during pretty-printing." ])	×
115	}
116	\| Error e ->	×
117	Ok
118	{ Pretty_print_result.pretty_printed_contents
119	; result =
120	Error
121	(Err.add_context e [ Pp.text "Pretty-printing produced invalid syntax." ])	×
122	}
123	\| Ok true ->	2✔
124	if String.equal pretty_printed_contents contents
125	then Ok { Pretty_print_result.pretty_printed_contents; result = Ok () }	2✔
126	else
127	find_fix_point	×
128	~path
129	~num_steps:(Int.succ num_steps)	×
130	~contents:pretty_printed_contents
131	;;
132
133	let pretty_print ~path ~read_contents_from_stdin =
134	let contents =	2✔
135	if read_contents_from_stdin
136	then In_channel.input_all stdin	×
137	else In_channel.with_open_bin (Fpath.to_string path) In_channel.input_all	2✔
138	in
139	find_fix_point ~path ~num_steps:0 ~contents
140	;;
141
142	let test_cmd =
143	Command.make	2✔
144	~summary:
145	(Printf.sprintf	2✔
146	"Check that all %s files of the current directory can be pretty-printed."
147	(Config.extensions \|> String.concat ~sep:", "))	2✔
148	(let open Command.Std in
149	let+ () = Log_cli.set_config () in	2✔
150	let cwd = Sys.getcwd () in	×
151	let files = find_files_in_cwd_by_extensions ~cwd ~extensions:Config.extensions in	×
152	List.iter files ~f:(fun path ->
153	prerr_endline ("================================: " ^ Fpath.to_string path);	×
154	match pretty_print ~path ~read_contents_from_stdin:false with	×
155	\| Error e -> Err.prerr e ~reset_separator:true	×
156	\| Ok { pretty_printed_contents; result } ->	×
157	Out_channel.output_string Out_channel.stderr pretty_printed_contents;
158	Out_channel.flush Out_channel.stderr;	×
159	(match result with	×
160	\| Ok () -> ()	×
161	\| Error e ->	×
162	prerr_endline "======: errors";
163	Err.prerr e ~reset_separator:true)))	×
164	;;
165
166	let gen_dune_cmd =
167	Command.make	2✔
168	~summary:
169	(Printf.sprintf	2✔
170	"Generate dune stanza for all %s files present in the cwd to be \
171	pretty-printed."
172	(Config.extensions \|> String.concat ~sep:", "))	2✔
173	(let open Command.Std in
174	let+ exclude =
175	Arg.named_with_default	2✔
176	[ "exclude" ]
177	(Param.comma_separated Param.string)	2✔
178	~default:[]
179	~docv:"FILE"
180	~doc:"Files to exclude."
181	and+ call =
182	Arg.pos_all	2✔
183	Param.string
184	~doc:"How to access the [fmt file] command for these files."
185	in
186	let cwd = Sys.getcwd () in	×
187	let exclude =	×
188	(* Acknowledging use of polymorphic hashtbl with [string] keys. *)
189	let t : (string, unit) Hashtbl.t = Hashtbl.create (List.length exclude) in	×
190	List.iter exclude ~f:(fun s -> Hashtbl.add t s ());	×
191	t	×
192	in
193	let files =
194	find_files_in_cwd_by_extensions ~cwd ~extensions:Config.extensions
195	\|> List.filter ~f:(fun file -> not (Hashtbl.mem exclude (Fpath.to_string file)))	×
196	in
197	let output_ext = ".pp.output" in	×
198	let generate_rules ~file =
199	let list s = Sexp.List s	×
200	and atom s = Sexp.Atom s in	×
201	let atoms s = Sexp.List (List.map s ~f:atom) in	×
202	let pp =
203	list
204	[ atom "rule"	×
205	; list	×
206	[ atom "with-stdout-to"	×
207	; atom (Fpath.to_string file ^ output_ext)	×
208	; atoms	×
209	([ [ "run" ]
210	; call
211	; [ Printf.sprintf "%%{dep:%s}" (Fpath.to_string file) ]	×
212	]
213	\|> List.concat)	×
214	]
215	]
216	in
217	let fmt =	×
218	list
219	[ atom "rule"	×
220	; atoms [ "alias"; "fmt" ]	×
221	; list	×
222	[ atom "action"	×
223	; atoms	×
224	[ "diff"; Fpath.to_string file; Fpath.to_string file ^ output_ext ]	×
225	]
226	]
227	in
228	[ pp; fmt ]	×
229	in
230	Out_channel.output_string
231	Out_channel.stdout
232	(Printf.sprintf	×
233	"; dune file generated by '%s' -- do not edit.\n"
234	(List.map call ~f:(function
235	\| "file" -> "gen-dune"	×
236	\| e -> e)	×
237	\|> String.concat ~sep:" "));	×
238	List.iter files ~f:(fun file ->	×
239	List.iter (generate_rules ~file) ~f:(fun sexp ->	×
240	print_endline (Sexp.to_string_hum sexp))))	×
241	;;
242
243	let file_cmd =
244	Command.make	2✔
245	~summary:(Printf.sprintf "Autoformat %s files." Config.language_id)	2✔
246	~readme:(fun () ->
247	let buffer = Buffer.create 256 in	2✔
248	Buffer.add_substitute	2✔
249	buffer
250	(function
251	\| "LANG" -> Config.language_id	2✔
252	\| "EXTS" -> String.concat ~sep:", " Config.extensions	2✔
253	\| var ->	×
254	Code_error.raise "Substitution not found" [ "var", var \|> Dyn.string ])	×
255	"This is a pretty-print command for ${LANG} files (extensions ${EXTS}).\n\n\
256	This reads the contents of a file supplied in the command line, and \
257	pretty-print it on stdout, leaving the original file unchanged.\n\n\
258	If [--read-contents-from-stdin] is supplied, then the contents of the file is \
259	read from stdin. In this case the filename must still be supplied, and will \
260	be used for located error messages only.\n\n\
261	In case of syntax errors or other issues, some contents may still be printed \
262	to stdout, however the exit code will be non zero (typically [1]). Errors are \
263	printed on stderr.\n\n\
264	The hope for this command is for it to be compatible with editors and build \
265	systems so that you can integrate autoformatting of files into your \
266	workflow.\n\n\
267	Because this command has been tested with a vscode extension that strips the \
268	last newline, a flag has been added to add an extra blank line, shall you run \
269	into this issue.";
270	Buffer.contents buffer)	2✔
271	(let open Command.Std in
272	let+ () = Log_cli.set_config ()	2✔
273	and+ path =
274	Arg.pos ~pos:0 Param.file ~docv:"FILE" ~doc:"File to format." >>\| Fpath.v	2✔
275	and+ read_contents_from_stdin =
276	Arg.flag	2✔
277	[ "read-contents-from-stdin" ]
278	~doc:"Read contents from stdin rather than from the file."
279	and+ add_extra_blank_line =
280	Arg.flag [ "add-extra-blank-line" ] ~doc:"Add an extra blank line at the end."	2✔
281	in
282	(let open Result.Syntax in	2✔
283	let* { Pretty_print_result.pretty_printed_contents; result } =
284	pretty_print ~path ~read_contents_from_stdin
285	in
286	print_string pretty_printed_contents;	2✔
287	if add_extra_blank_line then print_endline "";	×
288	result)	2✔
289	\|> Err.ok_exn)
290	;;
291
292	let dump_cmd =
293	Command.make	2✔
294	~summary:"Dump a parsed tree on stdout."
295	(let open Command.Std in
296	let+ path = Arg.pos ~pos:0 Param.file ~docv:"FILE" ~doc:"File to dump." >>\| Fpath.v	2✔
297	and+ with_positions = Arg.flag [ "loc" ] ~doc:"Dump loc details." in	2✔
298	let (program : T.t) = Parsing_utils.parse_file_exn (module T_parser) ~path in	×
299	Ref.set_temporarily Loc.include_sexp_of_locs with_positions ~f:(fun () ->	×
300	print_endline (Sexp.to_string_hum (program \|> T.sexp_of_t))))	×
301	;;
302
303	let fmt_cmd =
304	Command.group	2✔
305	~summary:"Commands related to auto-formatting."
306	[ "dump", dump_cmd; "file", file_cmd; "test", test_cmd; "gen-dune", gen_dune_cmd ]
307	;;
308	end
309
310	let fmt_cmd
311	(type t)
312	(module Config : Config.S)
313	(module T : T with type t = t)
314	(module Syntax : Parsing_utils.S with type t = t)
315	(module Pp : T_pp with type t = t)
316	=
317	let module M = Make (Config) (T) (Syntax) (Pp) in	2✔
318	M.fmt_cmd
319	;;

mbarbin / auto-format / 136

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