Improve: improve errors returned to the user.

Explicitly discriminate errors between
- invalid source (together with the reason why)
- and ocamlformat bugs (detail with -g/--debug)

Additionnally,
- ocamlformat does not stop at the first error and process all input.
- add a -quiet flag
- remove -warn-error flag
- [@@@ocamlformat.disable] is only interpreted at toplevel

src/Ast.ml

@@ -388,7 +388,7 @@ end = struct
   let fail ctx ast exc =
     let bt = Caml.Printexc.get_backtrace () in
     dump Format.err_formatter ctx ast ;
-    Format.eprintf "%s" bt ;
+    Format.eprintf "%s%!" bt ;
     raise exc
 
   (** Predicates to check the claimed sub-term relation. *)

src/Cmts.ml

@@ -334,7 +334,7 @@ let add_cmts t ?prev ?next tbl loc cmts =
             Option.value_map next ~default:"no next"
               ~f:(string_between cmt_loc)
           in
-          Format.eprintf "add %s %a: %a \"%s\" %s \"%s\"@\n"
+          Format.eprintf "add %s %a: %a \"%s\" %s \"%s\"@\n%!"
             ( if phys_equal tbl t.cmts_before then "before"
             else if phys_equal tbl t.cmts_after then "after"
             else "within" )
@@ -375,7 +375,7 @@ let rec place t loc_tree ?prev_loc locs cmts =
     | None ->
         if Conf.debug then
           List.iter (CmtSet.to_list cmts) ~f:(fun (txt, _) ->
-              Format.eprintf "lost: %s@\n" txt )
+              Format.eprintf "lost: %s@\n%!" txt )
 
 (** Remove comments that duplicate docstrings (or other comments). *)
 let dedup_cmts map_ast ast comments =
@@ -419,12 +419,12 @@ let init map_ast loc_of_ast source conf asts comments_n_docstrings =
   let comments = dedup_cmts map_ast asts comments_n_docstrings in
   if Conf.debug then
     List.iter comments ~f:(fun (txt, loc) ->
-        Format.eprintf "%a %s %s@\n" Location.fmt loc txt
+        Format.eprintf "%a %s %s@\n%!" Location.fmt loc txt
           (if Source.ends_line source loc then "eol" else "") ) ;
   if not (List.is_empty comments) then (
     let loc_tree = Loc_tree.of_ast map_ast asts in
     if Conf.debug then
-      Format.eprintf "@\n%a@\n@\n" (Fn.flip Loc_tree.dump) loc_tree ;
+      Format.eprintf "@\n%a@\n@\n%!" (Fn.flip Loc_tree.dump) loc_tree ;
     let locs = loc_of_ast asts in
     let cmts = CmtSet.of_list comments in
     place t loc_tree locs cmts ) ;
@@ -453,7 +453,7 @@ let relocate t ~src ~before ~after =
                 f src_data dst_data ) ) )
   in
   if Conf.debug then
-    Format.eprintf "relocate %a to %a and %a@\n" Location.fmt src
+    Format.eprintf "relocate %a to %a and %a@\n%!" Location.fmt src
       Location.fmt before Location.fmt after ;
   update_multi t.cmts_before src before ~f:(fun src_cmts dst_cmts ->
       List.append src_cmts dst_cmts ) ;
@@ -556,25 +556,23 @@ let fmt t ?pro ?epi ?eol ?adj loc k =
 let fmt_list t ?pro ?epi ?eol locs init =
   List.fold locs ~init ~f:(fun k loc -> fmt t ?pro ?epi ?eol loc @@ k)
 
-(** check if any comments have not been formatted *)
-let final_check t =
-  if not (Hashtbl.is_empty t.cmts_before && Hashtbl.is_empty t.cmts_after)
-  then
-    let f before_after ~key:ast_loc ~data init =
-      List.fold data ~init ~f:(fun z (cmt_txt, cmt_loc) ->
-          let open Sexp in
-          ( before_after
-          , List
-              [ List [Atom "ast_loc"; Location.sexp_of_t ast_loc]
-              ; List [Atom "cmt_loc"; Location.sexp_of_t cmt_loc]
-              ; List [Atom "cmt_txt"; Atom cmt_txt] ] )
-          :: z )
-    in
-    internal_error "formatting lost comments"
-      (Hashtbl.fold t.cmts_before ~f:(f "before")
-         ~init:
-           (Hashtbl.fold t.cmts_after ~f:(f "after")
-              ~init:(Hashtbl.fold t.cmts_within ~f:(f "within") ~init:[])))
+(** returns comments that have not been formatted *)
+let remaining_comments t =
+  let get t before_after =
+    Hashtbl.to_alist t
+    |> List.concat_map ~f:(fun (ast_loc, cmts) ->
+           List.map cmts ~f:(fun (cmt_txt, cmt_loc) ->
+               ( before_after
+               , let open Sexp in
+                 List
+                   [ List [Atom "ast_loc"; Location.sexp_of_t ast_loc]
+                   ; List [Atom "cmt_loc"; Location.sexp_of_t cmt_loc]
+                   ; List [Atom "cmt_txt"; Atom cmt_txt] ] ) ) )
+  in
+  List.concat
+    [ get t.cmts_before "before"
+    ; get t.cmts_within "within"
+    ; get t.cmts_after "after" ]
 
 let diff x y =
   let norm z =

src/Cmts.mli

@@ -108,9 +108,8 @@ val fmt_list :
   -> Fmt.t
 (** [fmt_list locs] formats as per [fmt] for each loc in [locs]. *)
 
-val final_check : t -> unit
-(** Check that all comments passed to the initialization function have been
-    formatted. *)
+val remaining_comments : t -> (string * Sexp.t) list
+(** Returns comments that have not been formatted yet. *)
 
 val doc_is_dup : t -> string Asttypes.loc -> bool
 (** [doc_is_dup docstring] holds if [docstring] has been passed to

src/Conf.ml

@@ -183,6 +183,11 @@ let inplace =
   let default = false in
   mk ~default Arg.(value & flag & info ["i"; "inplace"] ~doc)
 
+let quiet =
+  let doc = "Quiet" in
+  let default = false in
+  mk ~default Arg.(value & flag & info ["q"; "quiet"] ~doc)
+
 let inputs =
   let docv = "SRC" in
   let doc =
@@ -292,15 +297,6 @@ let no_version_check =
   let default = false in
   mk ~default Arg.(value & flag & info ["no-version-check"] ~doc)
 
-let no_warn_error =
-  let doc =
-    "Do no treat warnings detected by the parser as errors. These warnings \
-     almost always indicate an unrecoverable situation, so expect an \
-     unhandled exception."
-  in
-  let default = false in
-  mk ~default Arg.(value & flag & info ["no-warn-error"] ~doc)
-
 let wrap_comments =
   let doc =
     "Wrap comments and docstrings. Comments and docstrings are divided \
@@ -338,7 +334,8 @@ type t =
   ; parens_tuple: [`Always | `Multi_line_only]
   ; if_then_else: [`Compact | `Keyword_first]
   ; break_infix: [`Wrap | `Fit_or_vertical]
-  ; ocp_indent_compat: bool }
+  ; ocp_indent_compat: bool
+  ; quiet: bool }
 
 let update conf name value =
   match name with
@@ -462,7 +459,8 @@ let conf name =
     ; parens_tuple= !parens_tuple
     ; if_then_else= !if_then_else
     ; break_infix= !break_infix
-    ; ocp_indent_compat= !ocp_indent_compat }
+    ; ocp_indent_compat= !ocp_indent_compat
+    ; quiet= !quiet }
     (Filename.dirname (to_absolute name))
 
 type 'a input = {kind: 'a; name: string; file: string; conf: t}
@@ -493,5 +491,3 @@ let action =
     | _ -> impossible "checked by validate"
 
 and debug = !debug
-
-and warn_error = not !no_warn_error

src/Conf.mli

@@ -28,7 +28,8 @@ type t = private
   ; parens_tuple: [`Always | `Multi_line_only]
   ; if_then_else: [`Compact | `Keyword_first]
   ; break_infix: [`Wrap | `Fit_or_vertical]
-  ; ocp_indent_compat: bool  (** Try to indent like ocp-indent *) }
+  ; ocp_indent_compat: bool  (** Try to indent like ocp-indent *)
+  ; quiet: bool }
 
 type 'a input = {kind: 'a; name: string; file: string; conf: t}
 
@@ -43,6 +44,3 @@ val action : action
 
 val debug : bool
 (** Generate debugging output if true. *)
-
-val warn_error : bool
-(** Treat warnings detected by the parser as errors. *)

src/Fmt_ast.ml

@@ -21,8 +21,6 @@ open Fmt
 
 type c = {conf: Conf.t; source: Source.t; cmts: Cmts.t}
 
-exception Formatting_disabled
-
 (* Debug: catch and report failures at nearest enclosing Ast.t *)
 
 let protect =
@@ -32,7 +30,7 @@ let protect =
       if !first then (
         let bt = Caml.Printexc.get_backtrace () in
         Format.pp_print_flush fs () ;
-        Caml.Format.eprintf "@\nFAIL@\n%a@\n%s@." Ast.dump ast bt ;
+        Caml.Format.eprintf "@\nFAIL@\n%a@\n%s@.%!" Ast.dump ast bt ;
         first := false ) ;
       raise exc
 
@@ -2665,8 +2663,6 @@ and fmt_signature_item c {ast= si} =
   @@
   let ctx = Sig si in
   match si.psig_desc with
-  | Psig_attribute ({txt= "ocamlformat.disable"; _}, _) ->
-      raise Formatting_disabled
   | Psig_attribute atr ->
       let doc, atrs = doc_atrs [atr] in
       fmt_docstring c ~epi:(fmt "") doc $ fmt_attributes c ~key:"@@@" atrs
@@ -3253,8 +3249,6 @@ and fmt_structure_item c ~sep ~last:last_item ?ext ?(use_file= false)
   wrap_k fmt_cmts_before fmt_cmts_after
   @@
   match si.pstr_desc with
-  | Pstr_attribute ({txt= "ocamlformat.disable"; _}, _) ->
-      raise Formatting_disabled
   | Pstr_attribute atr ->
       let doc, atrs = doc_atrs [atr] in
       fmt_docstring c ~epi:(fmt "") doc $ fmt_attributes c ~key:"@@@" atrs

src/Fmt_ast.mli

@@ -16,10 +16,6 @@ module Format = Format_
 open Migrate_ast
 open Parsetree
 
-(** Raise this exception to Indicate that formatting has been disabled for
-    the current file *)
-exception Formatting_disabled
-
 val fmt_signature : Source.t -> Cmts.t -> Conf.t -> signature -> Fmt.t
 (** Format a signature. *)
 

src/Normalize.ml

@@ -159,3 +159,43 @@ let equal_impl ast1 ast2 = Poly.equal (impl ast1) (impl ast2)
 let equal_intf ast1 ast2 = Poly.equal (intf ast1) (intf ast2)
 
 let equal_use_file ast1 ast2 = Poly.equal (use_file ast1) (use_file ast2)
+
+exception Formatting_disabled
+
+let iter =
+  let structure_item _ (si: structure_item) =
+    match si.pstr_desc with
+    | Pstr_attribute ({txt= "ocamlformat.disable"; _}, _) ->
+        raise Formatting_disabled
+    | _ -> ()
+  in
+  let signature_item _ (si: signature_item) =
+    match si.psig_desc with
+    | Psig_attribute ({txt= "ocamlformat.disable"; _}, _) ->
+        raise Formatting_disabled
+    | _ -> ()
+  in
+  {Ast_iterator.default_iterator with structure_item; signature_item}
+
+let disabled_impl impl =
+  match impl with
+  | [] -> true
+  | _ ->
+    try iter.structure iter impl ; false with Formatting_disabled -> true
+
+let disabled_intf intf =
+  match intf with
+  | [] -> true
+  | _ ->
+    try iter.signature iter intf ; false with Formatting_disabled -> true
+
+let disabled_use_file l =
+  match l with
+  | [] -> true
+  | l ->
+    try
+      List.iter l ~f:(function
+        | Ptop_dir _ -> ()
+        | Ptop_def l -> iter.structure iter l ) ;
+      false
+    with Formatting_disabled -> true

src/Normalize.mli

@@ -34,3 +34,9 @@ val equal_use_file : toplevel_phrase list -> toplevel_phrase list -> bool
 
 val mapper : Ast_mapper.mapper
 (** Ast_mapper for normalization transformations. *)
+
+val disabled_impl : structure -> bool
+
+val disabled_intf : signature -> bool
+
+val disabled_use_file : toplevel_phrase list -> bool

src/Reason.ml

@@ -20,13 +20,13 @@ type 'a reason_data =
     [input_channel]. It is expected to have the given [magic_number] and is
     assumed to be the output of `refmt --print=binary_reason` where `refmt`
     has been compiled with the same version of `ocaml` as `ocamlformat`. *)
-let input ast_magic ~input_name ic =
-  Location.input_name := input_name ;
+let input ast_magic ic =
   let (magic, _, (ast: 'a), comments, _, _) : 'a reason_data =
     Caml.Marshal.from_channel ic
   in
   if String.equal magic ast_magic then
-    (ast, List.map comments ~f:(fun (txt, _, loc) -> (txt, loc)))
+    let comments = List.map comments ~f:(fun (txt, _, loc) -> (txt, loc)) in
+    {Translation_unit.ast; comments}
   else user_error "input not a serialized translation unit" []
 
 let input_impl = input Config.ast_impl_magic_number
@@ -115,10 +115,12 @@ let mapper cmts =
   in
   {Normalize.mapper with attributes; pat; expr; structure; signature}
 
-let norm_impl (ast, cmts) = map_structure (mapper cmts) ast
+let norm_impl {Translation_unit.ast; comments} =
+  map_structure (mapper comments) ast
 
-let norm_intf (ast, cmts) = map_signature (mapper cmts) ast
+let norm_intf {Translation_unit.ast; comments} =
+  map_signature (mapper comments) ast
 
-let equal_impl x y = Poly.equal (norm_impl x) (norm_impl y)
+let equal_impl x y = Normalize.equal_impl (norm_impl x) (norm_impl y)
 
-let equal_intf x y = Poly.equal (norm_intf x) (norm_intf y)
+let equal_intf x y = Normalize.equal_intf (norm_intf x) (norm_intf y)

src/Reason.mli

@@ -13,37 +13,26 @@
 
 open Migrate_ast
 open Parsetree
+open Translation_unit
 
-val input_impl :
-     input_name:string
-  -> In_channel.t
-  -> structure * (string * Location.t) list
+val input_impl : In_channel.t -> structure with_comments
 (** Reads a serialized structure from an input channel. It is assumed to be
     the output of `refmt --print=binary_reason` where `refmt` has been
     compiled with the same version of `ocaml` as `ocamlformat`. *)
 
-val input_intf :
-     input_name:string
-  -> In_channel.t
-  -> signature * (string * Location.t) list
+val input_intf : In_channel.t -> signature with_comments
 (** Reads a serialized signature from an input channel. It is assumed to be
     the output of `refmt --print=binary_reason` where `refmt` has been
     compiled with the same version of `ocaml` as `ocamlformat`. *)
 
-val norm_impl : structure * (string * Location.t) list -> structure
+val norm_impl : structure with_comments -> structure
 (** Normalize a structure. *)
 
-val norm_intf : signature * (string * Location.t) list -> signature
+val norm_intf : signature with_comments -> signature
 (** Normalize a signature. *)
 
-val equal_impl :
-     structure * (string * Location.t) list
-  -> structure * (string * Location.t) list
-  -> bool
+val equal_impl : structure with_comments -> structure with_comments -> bool
 (** Compare structures for equality up to normalization. *)
 
-val equal_intf :
-     signature * (string * Location.t) list
-  -> signature * (string * Location.t) list
-  -> bool
+val equal_intf : signature with_comments -> signature with_comments -> bool
 (** Compare signatures for equality up to normalization. *)

src/Source.ml

@@ -65,7 +65,7 @@ let char_literal t (l: Location.t) =
   in
   match toks with
   | [(Parser.CHAR _, loc)] -> Literal_lexer.char (lexbuf_from_loc t loc)
-  | _ -> user_error "location does not contain a string literal" []
+  | _ -> user_error "location does not contain a char literal" []
 
 let begins_line t (l: Location.t) =
   let rec begins_line_ cnum =