flambda-backend: Refactor -extension and -standard flags (#398)

* Refactor extension handling in Clflags

Move all extension handling function into a separate module

* Compiler flag -standard disables all extensions

Regardless of the position of -standard flag relative to -extension flags,
-standard disables extensions that were enabled before or after it.

* Fix testsuite

* Add extension and standard to OCAMLPARAM

* Rename flag -standard to -no-extensions

* Rename standard to no-extensions in OCAMLPARAM

* Improve help text for -no-extensions

* Print available extensions in help text for -extension

Author: gretay-js

driver/compenv.ml

@@ -469,6 +469,10 @@ let read_one_param ppf position name v =
       | Some pass -> set_save_ir_after pass true
     end
 
+  | "extension" -> Clflags.Extension.enable v
+  | "no-extensions" ->
+    if check_bool ppf "no-extensions" v then Clflags.Extension.disable_all ()
+
   | _ ->
     if !warnings_for_discarded_params &&
        not (List.mem name !can_discard) then begin

driver/main_args.ml

@@ -716,11 +716,19 @@ let mk_dump_into_file f =
 ;;
 
 let mk_extension f =
-  "-extension", Arg.String f, "<extension> Enable the extension"
+  let available_extensions =
+    Clflags.Extension.(List.map to_string all)
+  in
+  "-extension", Arg.Symbol (available_extensions, f),
+  "<extension>  Enable the extension (may be specified more than once)"
 ;;
 
-let mk_standard f =
-  "-standard", Arg.Unit f, " Disable all default extensions"
+let mk_no_extensions f =
+  "-no-extensions", Arg.Unit f,
+  " Disable all extensions, wherever they are specified; this flag\n\
+  \    overrides the -extension flag (whether specified before or after this\n\
+  \    flag), disables any extensions that are enabled by default, and\n\
+  \    ignores any extensions requested in OCAMLPARAM."
 ;;
 
 let mk_dparsetree f =
@@ -1031,7 +1039,7 @@ module type Compiler_options = sig
   val _match_context_rows : int -> unit
   val _dtimings : unit -> unit
   val _dprofile : unit -> unit
-  val _standard : unit -> unit
+  val _no_extensions : unit -> unit
   val _dump_into_file : unit -> unit
 
   val _args: string -> string array
@@ -1283,7 +1291,7 @@ struct
     mk_dcamlprimc F._dcamlprimc;
     mk_dtimings F._dtimings;
     mk_dprofile F._dprofile;
-    mk_standard F._standard;
+    mk_no_extensions F._no_extensions;
     mk_dump_into_file F._dump_into_file;
     mk_extension F._extension;
 
@@ -1510,7 +1518,7 @@ struct
     mk_dstartup F._dstartup;
     mk_dtimings F._dtimings;
     mk_dprofile F._dprofile;
-    mk_standard F._standard;
+    mk_no_extensions F._no_extensions;
     mk_dump_into_file F._dump_into_file;
     mk_dump_pass F._dump_pass;
     mk_extension F._extension;
@@ -1769,7 +1777,7 @@ module Default = struct
     let _unsafe = set unsafe
     let _warn_error s = Warnings.parse_options true s
     let _warn_help = Warnings.help_warnings
-    let _extension s = add_extension s
+    let _extension s = Extension.enable s
   end
 
   module Native = struct
@@ -1884,7 +1892,7 @@ module Default = struct
     let _config_var = Misc.show_config_variable_and_exit
     let _dprofile () = profile_columns := Profile.all_columns
     let _dtimings () = profile_columns := [`Time]
-    let _standard = set_standard
+    let _no_extensions = Extension.disable_all
     let _dump_into_file = set dump_into_file
     let _for_pack s = for_package := (Some s)
     let _g = set debug

driver/main_args.mli

@@ -119,7 +119,7 @@ module type Compiler_options = sig
   val _match_context_rows : int -> unit
   val _dtimings : unit -> unit
   val _dprofile : unit -> unit
-  val _standard : unit -> unit
+  val _no_extensions : unit -> unit
   val _dump_into_file : unit -> unit
 
   val _args: string -> string array

testsuite/tests/comprehensions/comprehensions.ml

@@ -1,5 +1,5 @@
 (* TEST
-  flags = "-extension Comprehensions"
+  flags = "-extension comprehensions"
    * expect
 *)
 (*Type checking tests.*)

typing/typecore.ml

@@ -127,7 +127,7 @@ type error =
   | Probe_name_format of string
   | Probe_name_undefined of string
   | Probe_is_enabled_format
-  | Extension_not_enabled of Clflags.extension
+  | Extension_not_enabled of Clflags.Extension.t
   | Literal_overflow of string
   | Unknown_literal of string * char
   | Illegal_letrec_pat
@@ -3776,12 +3776,12 @@ and type_expect_
   | Pexp_extension (({ txt = ("extension.list_comprehension"
                             | "extension.arr_comprehension"); _ },
                     _ ) as extension)  ->
-    if Clflags.is_extension_enabled Clflags.Comprehensions then
+    if Clflags.Extension.(is_enabled Comprehensions) then
       let ext_expr = Extensions.extension_expr_of_payload ~loc extension in
       type_extension ~loc ~env ~ty_expected ~sexp ext_expr
     else
       raise
-        (Error (loc, env, Extension_not_enabled(Clflags.Comprehensions)))
+        (Error (loc, env, Extension_not_enabled(Clflags.Extension.Comprehensions)))
   | Pexp_extension ext ->
     raise (Error_forward (Builtin_attributes.error_of_extension ext))
 
@@ -5739,8 +5739,8 @@ let report_error ~loc env = function
       Location.errorf ~loc
         "%%probe_is_enabled points must specify a single probe name as a \
          string literal"
-  | Extension_not_enabled(ext) ->
-    let name = Clflags.string_of_extension ext in
+  | Extension_not_enabled ext ->
+    let name = Clflags.Extension.to_string ext in
     Location.errorf ~loc
         "Extension %s must be enabled to use this feature." name
   | Literal_overflow ty ->

typing/typecore.mli

@@ -185,7 +185,7 @@ type error =
   | Probe_name_undefined of string
   (* CR-soon mshinwell: Use an inlined record *)
   | Probe_is_enabled_format
-  | Extension_not_enabled of Clflags.extension
+  | Extension_not_enabled of Clflags.Extension.t
   | Literal_overflow of string
   | Unknown_literal of string * char
   | Illegal_letrec_pat

utils/clflags.ml

@@ -375,23 +375,31 @@ let set_dumped_pass s enabled =
     dumped_passes_list := dumped_passes
   end
 
-type extension = Comprehensions
+module Extension = struct
+  type t = Comprehensions
 
-let extensions = ref ([] : extension list) (* -extensions *)
-let set_standard () = extensions := []
+  let all = [ Comprehensions ]
 
-let string_of_extension = function
-| Comprehensions -> "comprehensions"
+  let extensions = ref ([] : t list)   (* -extension *)
+  let equal Comprehensions Comprehensions = true
 
-let extension_of_string = function
-| "comprehensions" -> Comprehensions
-| extn ->  raise (Arg.Bad(Printf.sprintf "Extension %s is not known" extn))
+  let disable_all_extensions = ref false             (* -no-extensions *)
+  let disable_all () = disable_all_extensions := true
 
-let add_extension extn =
-  let extension = extension_of_string (String.lowercase_ascii extn) in
-  extensions := extension::!extensions
+  let to_string = function
+    | Comprehensions -> "comprehensions"
+
+  let of_string = function
+    | "comprehensions" -> Comprehensions
+    | extn -> raise (Arg.Bad(Printf.sprintf "Extension %s is not known" extn))
 
-let is_extension_enabled ext = List.mem ext !extensions
+  let enable extn =
+    let t = of_string (String.lowercase_ascii extn) in
+    if not (List.exists (equal t) !extensions) then
+      extensions := t :: !extensions
+
+  let is_enabled ext = not !disable_all_extensions && List.mem ext !extensions
+end
 
 let dump_into_file = ref false (* -dump-into-file *)
 

utils/clflags.mli

@@ -201,12 +201,14 @@ val set_dumped_pass : string -> bool -> unit
 
 val dump_into_file : bool ref
 
-type extension = Comprehensions
-val extensions : extension list ref
-val set_standard : unit -> unit
-val add_extension: string -> unit
-val is_extension_enabled: extension -> bool
-val string_of_extension: extension -> string
+module Extension : sig
+  type t = Comprehensions
+  val enable : string -> unit
+  val is_enabled : t -> bool
+  val to_string : t -> string
+  val all : t list
+  val disable_all : unit -> unit
+end
 
 (* Support for flags that can also be set from an environment variable *)
 type 'a env_reader = {