Improve the API of language extensions to better support upstream compatibility (and also tooling) (#13)

This doesn't change much inside the compiler, but is important for writing
e.g. refactoring tools that aren't part of the compiler.

Author: antalsz

driver/compenv.ml

@@ -489,9 +489,9 @@ let read_one_param ppf position name v =
   | "dump-into-file" -> Clflags.dump_into_file := true
   | "dump-dir" -> Clflags.dump_dir := Some v
 
-  | "extension" -> Clflags.Extension.enable v
+  | "extension" -> Clflags.Extension.(enable (of_string_exn v))
   | "disable-all-extensions" ->
-    if check_bool ppf name v then Clflags.Extension.disable_all ()
+    if check_bool ppf name v then Clflags.Extension.disallow_extensions ()
 
   | _ ->
     if !warnings_for_discarded_params &&

driver/main_args.ml

@@ -731,15 +731,37 @@ let mk_extension f =
     Clflags.Extension.(List.map to_string all)
   in
   "-extension", Arg.Symbol (available_extensions, f),
-  "<extension>  Enable the extension (may be specified more than once)"
+  "  Enable the specified extension (may be specified more than once)"
+;;
+
+let mk_no_extension f =
+  let available_extensions =
+    Clflags.Extension.(List.map to_string all)
+  in
+  "-no-extension", Arg.Symbol (available_extensions, f),
+  "  Disable the specified extension (may be specified more than once)"
 ;;
 
 let mk_disable_all_extensions f =
   "-disable-all-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."
+  "  Disable all extensions, wherever they have been specified; this\n\
+  \    flag overrides prior uses of the -extension flag, disables any\n\
+  \    extensions that are enabled by default, and causes future uses of\n\
+  \    the -extension flag to raise an error."
+;;
+
+let mk_only_erasable_extensions f =
+  let erasable_extensions =
+    let open Clflags.Extension in
+    all |> List.filter is_erasable |> List.map to_string |> String.concat ", "
+  in
+"-only-erasable-extensions", Arg.Unit f,
+  "  Disable all extensions that cannot be \"erased\" to attributes,\n\
+  \    wherever they have been specified; this flag overrides prior\n\
+  \    contradictory uses of the -extension flag, raises an error on\n\
+  \    future such uses, and disables any such extensions that are\n\
+  \    enabled by default.\n\
+  \    (Erasable extensions: " ^ erasable_extensions ^ ")"
 ;;
 
 let mk_dump_dir f =
@@ -958,7 +980,9 @@ module type Common_options = sig
   val _app_funct : unit -> unit
   val _no_app_funct : unit -> unit
   val _disable_all_extensions : unit -> unit
+  val _only_erasable_extensions : unit -> unit
   val _extension : string -> unit
+  val _no_extension : string -> unit
   val _noassert : unit -> unit
   val _nolabels : unit -> unit
   val _nostdlib : unit -> unit
@@ -1220,10 +1244,12 @@ struct
     mk_config_var F._config_var;
     mk_custom F._custom;
     mk_disable_all_extensions F._disable_all_extensions;
+    mk_only_erasable_extensions F._only_erasable_extensions;
     mk_dllib F._dllib;
     mk_dllpath F._dllpath;
     mk_dtypes F._annot;
     mk_extension F._extension;
+    mk_no_extension F._no_extension;
     mk_for_pack_byt F._for_pack;
     mk_g_byt F._g;
     mk_stop_after ~native:false F._stop_after;
@@ -1332,7 +1358,9 @@ struct
     mk_app_funct F._app_funct;
     mk_no_app_funct F._no_app_funct;
     mk_disable_all_extensions F._disable_all_extensions;
+    mk_only_erasable_extensions F._only_erasable_extensions;
     mk_extension F._extension;
+    mk_no_extension F._no_extension;
     mk_noassert F._noassert;
     mk_noinit F._noinit;
     mk_nolabels F._nolabels;
@@ -1410,7 +1438,9 @@ struct
     mk_config_var F._config_var;
     mk_dtypes F._annot;
     mk_disable_all_extensions F._disable_all_extensions;
+    mk_only_erasable_extensions F._only_erasable_extensions;
     mk_extension F._extension;
+    mk_no_extension F._no_extension;
     mk_for_pack_opt F._for_pack;
     mk_g_opt F._g;
     mk_function_sections F._function_sections;
@@ -1579,7 +1609,9 @@ module Make_opttop_options (F : Opttop_options) = struct
     mk_app_funct F._app_funct;
     mk_no_app_funct F._no_app_funct;
     mk_disable_all_extensions F._disable_all_extensions;
+    mk_only_erasable_extensions F._only_erasable_extensions;
     mk_extension F._extension;
+    mk_no_extension F._no_extension;
     mk_no_float_const_prop F._no_float_const_prop;
     mk_noassert F._noassert;
     mk_noinit F._noinit;
@@ -1673,7 +1705,9 @@ struct
     mk_app_funct F._app_funct;
     mk_no_app_funct F._no_app_funct;
     mk_disable_all_extensions F._disable_all_extensions;
+    mk_only_erasable_extensions F._only_erasable_extensions;
     mk_extension F._extension;
+    mk_no_extension F._no_extension;
     mk_noassert F._noassert;
     mk_nolabels F._nolabels;
     mk_nostdlib F._nostdlib;
@@ -1768,8 +1802,10 @@ module Default = struct
     let _no_strict_formats = clear strict_formats
     let _no_strict_sequence = clear strict_sequence
     let _no_unboxed_types = clear unboxed_types
-    let _disable_all_extensions = Extension.disable_all
-    let _extension s = Extension.enable s
+    let _disable_all_extensions = Extension.disallow_extensions
+    let _only_erasable_extensions = Extension.restrict_to_erasable_extensions
+    let _extension s = Extension.(enable (of_string_exn s))
+    let _no_extension s = Extension.(disable (of_string_exn s))
     let _noassert = set noassert
     let _nolabels = set classic
     let _nostdlib = set no_std_include

driver/main_args.mli

@@ -26,7 +26,9 @@ module type Common_options = sig
   val _app_funct : unit -> unit
   val _no_app_funct : unit -> unit
   val _disable_all_extensions : unit -> unit
+  val _only_erasable_extensions : unit -> unit
   val _extension : string -> unit
+  val _no_extension : string -> unit
   val _noassert : unit -> unit
   val _nolabels : unit -> unit
   val _nostdlib : unit -> unit

manual/src/cmds/unified-options.etex

@@ -851,5 +851,26 @@ hyphen (-).}
 \item["-help" or "--help"]
 Display a short usage summary and exit.
 
+\item[(JST) "-extension" \var{language-extension}]
+Enable the specified \var{language-extension}.  Can be specified more than once,
+either with the same or a different language extension; is idempotent.
+
+\item[(JST) "-no-extension" \var{language-extension}]
+Disable the specified \var{language-extension}.  Can be specified more than once,
+either with the same or a different language extension; is idempotent.
+
+\item[(JST) "-only-erasable-extensions"]
+Restricts the "-extension" option to work only with so-called ``erasable''
+extensions: ones that can be rewritten into attributes while still preserving
+the program's runtime input/output behavior.  Turns off currently-enabled
+non-erasable extensions when specified.  After this flag, specifying a
+non-erasable extension (even to disable it) will fail with an error.  This flag
+cannot be reversed, but it can be strengthened (by "-disable-all-extensions").
+
+\item[(JST) "-disable-all-extensions"]
+Disallow all language extensions moving forward, and turn off currently-enabled
+ones.  This makes "-extension" raise errors moving forwards.  This flag cannot
+be reversed.
+
 \end{options}
 %

testsuite/tests/ast-invariants/test.ml

@@ -85,5 +85,5 @@ let rec walk dir =
     (Sys.readdir dir)
 
 let () =
-  List.iter Clflags.Extension.enable_t Clflags.Extension.all;
+  List.iter Clflags.Extension.enable Clflags.Extension.all;
   walk root

testsuite/tests/comprehensions/syntax.ml

@@ -1,7 +1,7 @@
 (* TEST
    include ocamlcommon *)
 
-let () = Clflags.Extension.enable "comprehensions_experimental";;
+let () = Clflags.Extension.enable Comprehensions;;
 
 let printf = Printf.printf;;
 

testsuite/tests/language-extensions/language_extensions.ml

@@ -0,0 +1,189 @@
+(* TEST
+   include ocamlcommon
+   flags = "-I ${ocamlsrcdir}/parsing"
+   reference = "${test_source_directory}/reference.txt"
+*)
+
+(* Change these two variables to change which extension is being tested *)
+let extension            = Clflags.Extension.Comprehensions
+let extension_expression = "[x for x = 1 to 10]"
+
+let extension_name = Clflags.Extension.to_string extension
+let extension_parsed_expression =
+  Parse.expression (Lexing.from_string extension_expression)
+  (* Currently, parsing always succeeds and we only fail during typechecking *)
+
+let report ~name ~text =
+  Printf.printf "# %s [%s %s]:\n%s\n\n"
+    name
+    extension_name
+    (if Clflags.Extension.is_enabled extension then "enabled" else "disabled")
+    text
+
+let typecheck_with_extension ?(full_name = false) name =
+  let success =
+    match Typecore.type_expression Env.empty extension_parsed_expression with
+    | _ -> true
+    | exception (Extensions_parsing.Error.Error _) -> false
+  in
+  report
+    ~name:(if full_name
+           then name
+           else "\"" ^ extension_name ^ "\" extension " ^ name)
+    ~text:(if success
+           then "Successfully typechecked \"" ^ extension_expression ^ "\""
+           else "<extension error>")
+;;
+
+let should_succeed name what f =
+  report ~name ~text:(match f () with
+    | () ->
+        "Succeeded at " ^ what
+    | exception Arg.Bad msg ->
+        "FAILED at " ^ what ^ ", with the following error\n:" ^ msg)
+;;
+
+let should_fail name f =
+  report ~name ~text:(match f () with
+    | () -> "<succeeded INCORRECTLY>"
+    | exception Arg.Bad msg -> "Failed as expected: " ^ msg)
+;;
+
+let try_disallowing_extensions name =
+  should_succeed
+    name
+    "disallowing all extensions"
+    Clflags.Extension.disallow_extensions
+;;
+
+type goal = Fail | Succeed
+
+let when_disallowed goal f_str f =
+  let can_or_can't = match goal with
+    | Fail    -> "can't"
+    | Succeed -> "can"
+  in
+  let f_code = "[" ^ f_str ^ "]" in
+  let name =
+    can_or_can't ^ " call " ^ f_code ^ " when extensions are disallowed"
+  in
+  let action () = f extension in
+  match goal with
+  | Fail    -> should_fail    name                                   action
+  | Succeed -> should_succeed name ("redundantly calling " ^ f_code) action
+;;
+
+let lift_with with_fn extension = with_fn extension Fun.id;;
+
+(* Test the ground state *)
+
+typecheck_with_extension "in its default state";
+
+(* Disable all extensions for testing *)
+
+List.iter Clflags.Extension.disable Clflags.Extension.all;
+typecheck_with_extension ~full_name:true "no extensions enabled";
+
+(* Test globally toggling a language extension *)
+
+Clflags.Extension.enable extension;
+typecheck_with_extension "enabled";
+
+Clflags.Extension.enable extension;
+typecheck_with_extension "still enabled";
+
+Clflags.Extension.disable extension;
+typecheck_with_extension "disabled";
+
+Clflags.Extension.disable extension;
+typecheck_with_extension "still disabled";
+
+Clflags.Extension.set extension ~enabled:true;
+typecheck_with_extension "enabled via [set]";
+
+Clflags.Extension.enable extension;
+typecheck_with_extension "still enabled, via [set] and [enable]";
+
+Clflags.Extension.set extension ~enabled:false;
+typecheck_with_extension "disabled via [set]";
+
+Clflags.Extension.disable extension;
+typecheck_with_extension "still disabled, via [set] and [disable]";
+
+(* Test locally toggling a language extension *)
+
+(* Globally disable the language extension (idempotent, given the prior tests,
+   but it's more robust to do this explicitly) *)
+Clflags.Extension.disable extension;
+
+Clflags.Extension.with_enabled extension (fun () ->
+  typecheck_with_extension "enabled locally and disabled globally");
+
+Clflags.Extension.with_disabled extension (fun () ->
+  typecheck_with_extension "disabled locally and globally");
+
+Clflags.Extension.with_set extension ~enabled:true (fun () ->
+  typecheck_with_extension
+    "enabled locally via [with_set] and disabled globally");
+
+Clflags.Extension.with_set extension ~enabled:false (fun () ->
+  typecheck_with_extension "disabled locally via [with_set] and also globally");
+
+(* Globally enable the language extension *)
+Clflags.Extension.enable extension;
+
+Clflags.Extension.with_disabled extension (fun () ->
+  typecheck_with_extension "disabled locally and enabled globally");
+
+Clflags.Extension.with_enabled extension (fun () ->
+  typecheck_with_extension "enabled locally and globally");
+
+Clflags.Extension.with_set extension ~enabled:false (fun () ->
+  typecheck_with_extension
+    "disabled locally via [with_set] and enabled globally");
+
+Clflags.Extension.with_set extension ~enabled:true (fun () ->
+  typecheck_with_extension "disabled locally via [with_set] and also globally");
+
+(* Test disallowing extensions *)
+
+try_disallowing_extensions
+  "can disallow extensions while extensions are enabled";
+
+try_disallowing_extensions
+  "can disallow extensions while extensions are already disallowed";
+
+(* Test that disallowing extensions prevents other functions from working *)
+
+when_disallowed Fail "set ~enabled:true"
+  (Clflags.Extension.set ~enabled:true);
+
+when_disallowed Succeed "set ~enabled:false"
+  (Clflags.Extension.set ~enabled:false);
+
+when_disallowed Fail "enable"
+  Clflags.Extension.enable;
+
+when_disallowed Succeed "disable"
+  Clflags.Extension.disable;
+
+when_disallowed Fail "with_set ~enabled:true"
+  (Clflags.Extension.with_set ~enabled:true |> lift_with);
+
+when_disallowed Succeed "with_set ~enabled:false"
+  (Clflags.Extension.with_set ~enabled:false |> lift_with);
+
+when_disallowed Fail "with_enabled"
+  (Clflags.Extension.with_enabled |> lift_with);
+
+when_disallowed Succeed "with_disabled"
+  (Clflags.Extension.with_disabled |> lift_with);
+
+(* Test explicitly (rather than just via [report]) that [is_enabled] returns
+   [false] now that we've disallowed all extensions *)
+report
+  ~name:"[is_enabled] returns [false] when extensions are disallowed"
+  ~text:("\"" ^ extension_name ^ "\" is " ^
+         if Clflags.Extension.is_enabled extension
+         then "INCORRECTLY enabled"
+         else "correctly disabled")