Better control over jsoo warnings

compiler/bin-js_of_ocaml/cmd_arg.ml

@@ -80,6 +80,26 @@ type t =
   ; effects : Config.effects_backend
   }
 
+let set_param =
+  let doc = "Set compiler options." in
+  let all = List.map (Config.Param.all ()) ~f:(fun (x, _, _) -> x, x) in
+  let pair = Arg.(pair ~sep:'=' (enum all) string) in
+  let parser s =
+    match Arg.conv_parser pair s with
+    | Ok (k, v) -> (
+        match
+          List.find ~f:(fun (k', _, _) -> String.equal k k') (Config.Param.all ())
+        with
+        | _, _, valid -> (
+            match valid v with
+            | Ok () -> Ok (k, v)
+            | Error msg -> Error (`Msg ("Unexpected VALUE after [=], " ^ msg))))
+    | Error _ as e -> e
+  in
+  let printer = Arg.conv_printer pair in
+  let c = Arg.conv (parser, printer) in
+  Arg.(value & opt_all (list c) [] & info [ "set" ] ~docv:"PARAM=VALUE" ~doc)
+
 let wrap_with_fun_conv =
   let conv s =
     if String.equal s ""
@@ -180,14 +200,6 @@ let options =
     in
     Arg.(value & opt wrap_with_fun_conv `Iife & info [ "wrap-with-fun" ] ~doc)
   in
-  let set_param =
-    let doc = "Set compiler options." in
-    let all = List.map (Config.Param.all ()) ~f:(fun (x, _) -> x, x) in
-    Arg.(
-      value
-      & opt_all (list (pair ~sep:'=' (enum all) string)) []
-      & info [ "set" ] ~docv:"PARAM=VALUE" ~doc)
-  in
   let set_env =
     let doc = "Set environment variable statically." in
     Arg.(
@@ -502,14 +514,6 @@ let options_runtime_only =
     in
     Arg.(value & opt wrap_with_fun_conv `Iife & info [ "wrap-with-fun" ] ~doc)
   in
-  let set_param =
-    let doc = "Set compiler options." in
-    let all = List.map (Config.Param.all ()) ~f:(fun (x, _) -> x, x) in
-    Arg.(
-      value
-      & opt_all (list (pair ~sep:'=' (enum all) string)) []
-      & info [ "set" ] ~docv:"PARAM=VALUE" ~doc)
-  in
   let set_env =
     let doc = "Set environment variable statically." in
     Arg.(

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/cmd_arg.ml

@@ -66,6 +66,26 @@ type t =
   ; shape_files : string list
   }
 
+let set_param =
+  let doc = "Set compiler options." in
+  let all = List.map (Config.Param.all ()) ~f:(fun (x, _, _) -> x, x) in
+  let pair = Arg.(pair ~sep:'=' (enum all) string) in
+  let parser s =
+    match Arg.conv_parser pair s with
+    | Ok (k, v) -> (
+        match
+          List.find ~f:(fun (k', _, _) -> String.equal k k') (Config.Param.all ())
+        with
+        | _, _, valid -> (
+            match valid v with
+            | Ok () -> Ok (k, v)
+            | Error msg -> Error (`Msg ("Unexpected VALUE after [=], " ^ msg))))
+    | Error _ as e -> e
+  in
+  let printer = Arg.conv_printer pair in
+  let c = Arg.conv (parser, printer) in
+  Arg.(value & opt_all (list c) [] & info [ "set" ] ~docv:"PARAM=VALUE" ~doc)
+
 let options () =
   let runtime_files =
     let doc = "Link JavaScript and WebAssembly files [$(docv)]. " in
@@ -110,14 +130,6 @@ let options () =
     let doc = "root dir for source map." in
     Arg.(value & opt (some string) None & info [ "source-map-root" ] ~doc)
   in
-  let set_param =
-    let doc = "Set compiler options." in
-    let all = List.map (Config.Param.all ()) ~f:(fun (x, _) -> x, x) in
-    Arg.(
-      value
-      & opt_all (list (pair ~sep:'=' (enum all) string)) []
-      & info [ "set" ] ~docv:"PARAM=VALUE" ~doc)
-  in
   let include_dirs =
     let doc = "Add [$(docv)] to the list of include directories." in
     Arg.(value & opt_all string [] & info [ "I" ] ~docv:"DIR" ~doc)
@@ -232,14 +244,6 @@ let options_runtime_only () =
     let doc = "Add [$(docv)] to the list of include directories." in
     Arg.(value & opt_all string [] & info [ "I" ] ~docv:"DIR" ~doc)
   in
-  let set_param =
-    let doc = "Set compiler options." in
-    let all = List.map (Config.Param.all ()) ~f:(fun (x, _) -> x, x) in
-    Arg.(
-      value
-      & opt_all (list (pair ~sep:'=' (enum all) string)) []
-      & info [ "set" ] ~docv:"PARAM=VALUE" ~doc)
-  in
   let effects =
     let doc =
       "Select an implementation of effect handlers. [$(docv)] should be one of $(b,jspi) \

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