Compiler: control warnings - WIP

Author: hhugo

compiler/bin-js_of_ocaml/compile.ml

@@ -226,10 +226,11 @@ let run
   let check_debug (one : Parse_bytecode.one) =
     if Option.is_some source_map && Parse_bytecode.Debug.is_empty one.debug
     then
-      warn
-        "Warning: '--source-map' is enabled but the bytecode program was compiled with \
-         no debugging information.\n\
-         Warning: Consider passing '-g' option to ocamlc.\n\
+      Warning.warn
+        `Missing_debug_event
+        "'--source-map' is enabled but the bytecode program was compiled with no \
+         debugging information.\n\
+         Consider passing '-g' option to ocamlc.\n\
          %!"
   in
   let pseudo_fs_instr prim debug cmis =

compiler/bin-js_of_ocaml/js_of_ocaml.ml

@@ -23,7 +23,7 @@ open Js_of_ocaml_compiler
 
 let () =
   Sys.catch_break true;
-  let argv = Jsoo_cmdline.normalize_argv ~warn:(warn "%s") Sys.argv in
+  let argv = Sys.argv in
   let argv =
     let like_arg x = String.length x > 0 && Char.equal x.[0] '-' in
     let like_command x =
@@ -59,11 +59,8 @@ let () =
            ])
     with
     | Ok (`Ok () | `Help | `Version) ->
-        if !warnings > 0 && !werror
-        then (
-          Format.eprintf "%s: all warnings being treated as errors@." Sys.argv.(0);
-          exit 1)
-        else exit 0
+        Warning.process_warnings ();
+        exit 0
     | Error `Term -> exit 1
     | Error `Parse -> exit Cmdliner.Cmd.Exit.cli_error
     | Error `Exn -> ()

compiler/bin-jsoo_minify/jsoo_minify.ml

@@ -92,12 +92,7 @@ let main =
   Cmdliner.Cmd.v Cmd_arg.info t
 
 let (_ : int) =
-  try
-    Cmdliner.Cmd.eval
-      ~catch:false
-      ~argv:(Jsoo_cmdline.normalize_argv ~warn:(warn "%s") Sys.argv)
-      main
-  with
+  try Cmdliner.Cmd.eval ~catch:false ~argv:Sys.argv main with
   | (Match_failure _ | Assert_failure _ | Not_found) as exc ->
       let backtrace = Printexc.get_backtrace () in
       Format.eprintf

compiler/bin-wasm_of_ocaml/compile.ml

@@ -414,9 +414,10 @@ let run
       && Parse_bytecode.Debug.is_empty one.debug
       && not (Code.is_empty one.code)
     then
-      warn
-        "Warning: '--source-map' is enabled but the bytecode program was compiled with \
-         no debugging information.\n\
+      Warning.warn
+        `Missing_debug_event
+        "'--source-map' is enabled but the bytecode program was compiled with no \
+         debugging information.\n\
          Warning: Consider passing '-g' option to ocamlc.\n\
          %!"
   in

compiler/bin-wasm_of_ocaml/gen/gen.ml

@@ -17,7 +17,7 @@ let check_js_file fname =
   let freenames = StringSet.diff freenames Reserved.provided in
   if not (StringSet.is_empty freenames)
   then (
-    Format.eprintf "warning: free variables in %S@." fname;
+    Format.eprintf "Warning: free variables in %S@." fname;
     Format.eprintf "vars: %s@." (String.concat ~sep:", " (StringSet.elements freenames));
     exit 2);
   ()

compiler/bin-wasm_of_ocaml/wasm_of_ocaml.ml

@@ -21,7 +21,7 @@ open Js_of_ocaml_compiler
 
 let () =
   Sys.catch_break true;
-  let argv = Jsoo_cmdline.normalize_argv ~warn:(warn "%s") Sys.argv in
+  let argv = Sys.argv in
   let argv =
     let like_arg x = String.length x > 0 && Char.equal x.[0] '-' in
     let like_command x =
@@ -57,11 +57,8 @@ let () =
            ])
     with
     | Ok (`Ok () | `Help | `Version) ->
-        if !warnings > 0 && !werror
-        then (
-          Format.eprintf "%s: all warnings being treated as errors@." Sys.argv.(0);
-          exit 1)
-        else exit 0
+        Warning.process_warnings ();
+        exit 0
     | Error `Term -> exit 1
     | Error `Parse -> exit Cmdliner.Cmd.Exit.cli_error
     | Error `Exn -> ()

compiler/bin-wasm_of_ocaml/wasmoo_link_wasm.ml

@@ -20,12 +20,7 @@
 open Js_of_ocaml_compiler.Stdlib
 
 let (_ : int) =
-  try
-    Cmdliner.Cmd.eval
-      ~catch:false
-      ~argv:(Jsoo_cmdline.normalize_argv ~warn:(warn "%s") Sys.argv)
-      Link_wasm.command
-  with
+  try Cmdliner.Cmd.eval ~catch:false ~argv:Sys.argv Link_wasm.command with
   | (Match_failure _ | Assert_failure _ | Not_found) as exc ->
       let backtrace = Printexc.get_backtrace () in
       Format.eprintf

compiler/lib-cmdline/arg.ml

@@ -31,6 +31,7 @@ type t =
   ; optim : string list on_off
   ; quiet : bool
   ; werror : bool
+  ; warnings : (bool * Warning.t) list
   ; custom_header : string option
   }
 
@@ -61,6 +62,35 @@ let disable =
      in
      Term.(const List.flatten $ arg))
 
+let parse_warning s =
+  let err s = `Msg (Printf.sprintf "Unknown warning %s" s) in
+  if String.is_empty s
+  then Error (err s)
+  else
+    match Warning.parse s with
+    | Some n -> Ok (true, n)
+    | None -> (
+        match String.drop_prefix ~prefix:"no-" s with
+        | Some n -> (
+            match Warning.parse n with
+            | Some n -> Ok (false, n)
+            | None -> Error (err n))
+        | None -> Error (err s))
+
+let print_warning fmt (b, w) =
+  Format.fprintf
+    fmt
+    "%s%s"
+    (match b with
+    | true -> ""
+    | false -> "")
+    (Warning.name w)
+
+let warnings : (bool * Warning.t) list Term.t =
+  let doc = "Enable or disable the warnings specified by the argument [$(docv)]." in
+  let c : 'a Arg.conv = Arg.conv ~docv:"" (parse_warning, print_warning) in
+  Arg.(value & opt_all c [] & info [ "w" ] ~docv:"WARN" ~doc)
+
 let pretty =
   let doc = "Pretty print the output." in
   Arg.(value & flag & info [ "pretty" ] ~doc)
@@ -91,7 +121,19 @@ let custom_header =
 let t =
   lazy
     Term.(
-      const (fun debug enable disable pretty debuginfo noinline quiet werror c_header ->
+      const
+        (fun
+          debug
+          enable
+          disable
+          pretty
+          debuginfo
+          noinline
+          quiet
+          (warnings : (bool * Warning.t) list)
+          werror
+          c_header
+        ->
           let enable = if pretty then "pretty" :: enable else enable in
           let enable = if debuginfo then "debuginfo" :: enable else enable in
           let disable = if noinline then "inline" :: disable else disable in
@@ -104,6 +146,7 @@ let t =
           let disable = disable_if_pretty "share" disable in
           { debug = { enable = debug; disable = [] }
           ; optim = { enable; disable }
+          ; warnings
           ; quiet
           ; werror
           ; custom_header = c_header
@@ -115,6 +158,7 @@ let t =
       $ debuginfo
       $ noinline
       $ is_quiet
+      $ warnings
       $ is_werror
       $ custom_header)
 
@@ -125,5 +169,8 @@ let on_off on off t =
 let eval t =
   Config.Flag.(on_off enable disable t.optim);
   Debug.(on_off enable disable t.debug);
-  quiet := t.quiet;
-  werror := t.werror
+  List.iter t.warnings ~f:(function
+    | true, w -> Warning.enable w
+    | false, w -> Warning.disable w);
+  Warning.quiet := t.quiet;
+  Warning.werror := t.werror

compiler/lib-cmdline/arg.mli

@@ -27,6 +27,7 @@ type t =
   ; optim : string list on_off
   ; quiet : bool
   ; werror : bool
+  ; warnings : (bool * Js_of_ocaml_compiler.Warning.t) list
   ; custom_header : string option
   }
 

compiler/lib-cmdline/jsoo_cmdline.ml

@@ -17,33 +17,4 @@
  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  *)
 
-open Js_of_ocaml_compiler.Stdlib
 module Arg = Arg
-
-let normalize_argv ?(warn = fun _ -> ()) a =
-  let bad = ref [] in
-  let a =
-    Array.map
-      ~f:(fun s ->
-        let size = String.length s in
-        if size <= 2
-        then s
-        else if
-          Char.equal s.[0] '-'
-          && (not (Char.equal s.[1] '-'))
-          && not (Char.equal s.[2] '=')
-        then (
-          bad := s :: !bad;
-          (* long option with one dash lets double the dash *)
-          "-" ^ s)
-        else s)
-      a
-  in
-  if not (List.is_empty !bad)
-  then
-    warn
-      (Format.sprintf
-         "[Warning] long options with a single '-' are now deprecated. Please use '--' \
-          for the following options: %s@."
-         (String.concat ~sep:", " !bad));
-  a

compiler/lib-wasm/generate.ml

@@ -1397,7 +1397,6 @@ module Generate (Target : Target_sig.S) = struct
       ~live_vars
       ~in_cps (*
     ~should_export
-    ~warn_on_unhandled_effect
 *)
       ~deadcode_sentinal
       ~global_flow_info

compiler/lib-wasm/link.ml

@@ -409,12 +409,15 @@ let output_js js =
 
 let report_missing_primitives missing =
   if not (List.is_empty missing)
-  then (
-    warn "There are some missing Wasm primitives@.";
-    warn "Dummy implementations (raising an exception) ";
-    warn "will be provided.@.";
-    warn "Missing primitives:@.";
-    List.iter ~f:(fun nm -> warn "  %s@." nm) missing)
+  then
+    Warning.warn
+      `Missing_primitive
+      "There are some missing Wasm primitives\n\
+       Dummy implementations (raising an exception) will be provided.\n\
+       Missing primitives:\n\
+       %a"
+      (Format.pp_print_list Format.pp_print_string)
+      missing
 
 let build_runtime_arguments
     ~link_spec

compiler/lib/builtins.ml

@@ -40,7 +40,9 @@ let register ~name ~content ~fragments =
   let name = "+" ^ name in
   let t = { File.name; content; fragments } in
   if String.Hashtbl.mem tbl name
-  then warn "The builtin runtime file %S was registered multiple time" name;
+  then
+    failwith
+      (Printf.sprintf "The builtin runtime file %S was registered multiple time" name);
   String.Hashtbl.add tbl name t;
   t
 

compiler/lib/config.ml

@@ -89,8 +89,6 @@ module Flag = struct
 
   let improved_stacktrace = o ~name:"with-js-error" ~default:false
 
-  let warn_unused = o ~name:"warn-unused" ~default:false
-
   let inline_callgen = o ~name:"callgen" ~default:false
 
   let safe_string = o ~name:"safestring" ~default:true
@@ -130,7 +128,7 @@ module Param = struct
     let set : string -> unit =
      fun v ->
       try state := convert v
-      with _ -> warn "Warning: malformed option %s=%s. IGNORE@." name v
+      with _ -> Warning.warn `Malformed_params "malformed option %s=%s. IGNORE@." name v
     in
     params := (name, (set, desc)) :: !params;
     fun () -> !state

compiler/lib/config.mli

@@ -60,8 +60,6 @@ module Flag : sig
 
   val improved_stacktrace : unit -> bool
 
-  val warn_unused : unit -> bool
-
   val inline_callgen : unit -> bool
 
   val safe_string : unit -> bool

compiler/lib/debug.ml

@@ -57,7 +57,7 @@ let find ?(even_if_quiet = false) s =
   in
   fun () ->
     if String.equal s "times" then take_snapshot ();
-    (even_if_quiet || not !quiet) && !state
+    (even_if_quiet || not !Warning.quiet) && !state
 
 let enable s =
   match List.string_assoc s !debugs with