From 0b53d91262fc26e70d34fe355e027619b7d8ae0e Mon Sep 17 00:00:00 2001 From: Richard Eisenberg Date: Thu, 8 Jun 2023 04:47:12 -0400 Subject: [PATCH] New extensions API, supporting maturity levels (#1454) * New extensions API, supporting for maturity levels * Fix ocamldoc failure * Nick's suggestions, plus some cleaning up * Refactor [fail] in the style of [Base.failwithf] --------- Co-authored-by: Nick Roberts --- ocaml/.depend | 9 +- ocaml/boot/menhir/parser.ml | 18 +- ocaml/driver/compenv.ml | 2 +- ocaml/driver/main_args.ml | 15 +- ocaml/driver/makedepend.ml | 2 +- ocaml/parsing/builtin_attributes.ml | 5 +- ocaml/parsing/jane_syntax.ml | 2 +- ocaml/parsing/jane_syntax_parsing.ml | 22 +- ocaml/parsing/jane_syntax_parsing.mli | 17 +- ocaml/parsing/parser.mly | 18 +- ocaml/testsuite/tests/ast-invariants/test.ml | 2 +- .../testsuite/tests/comprehensions/syntax.ml | 2 +- .../language_extensions.ml | 68 +-- .../tests/language-extensions/reference.txt | 12 +- .../tests/lib-array/iarray_syntax.ml | 2 +- .../tests/typing-local/print_syntax.ml | 2 +- ocaml/typing/typecore.ml | 2 +- ocaml/typing/typecore.mli | 2 +- ocaml/typing/typetexp.ml | 2 +- ocaml/typing/typetexp.mli | 2 +- ocaml/utils/language_extension.ml | 415 ++++++++++++------ ocaml/utils/language_extension.mli | 83 ++-- ocaml/utils/misc.ml | 6 + ocaml/utils/misc.mli | 5 + 24 files changed, 460 insertions(+), 255 deletions(-) diff --git a/ocaml/.depend b/ocaml/.depend index c3f9f393a64..109dfb1b98b 100644 --- a/ocaml/.depend +++ b/ocaml/.depend @@ -128,8 +128,10 @@ utils/int_replace_polymorphic_compare.cmx : \ utils/int_replace_polymorphic_compare.cmi utils/int_replace_polymorphic_compare.cmi : utils/language_extension.cmo : \ + utils/misc.cmi \ utils/language_extension.cmi utils/language_extension.cmx : \ + utils/misc.cmx \ utils/language_extension.cmi utils/language_extension.cmi : utils/lazy_backtrack.cmo : \ @@ -534,6 +536,7 @@ parsing/parser.cmo : \ parsing/parsetree.cmi \ parsing/longident.cmi \ parsing/location.cmi \ + parsing/jane_syntax_parsing.cmi \ parsing/jane_syntax.cmi \ parsing/docstrings.cmi \ utils/clflags.cmi \ @@ -547,6 +550,7 @@ parsing/parser.cmx : \ parsing/parsetree.cmi \ parsing/longident.cmx \ parsing/location.cmx \ + parsing/jane_syntax_parsing.cmx \ parsing/jane_syntax.cmx \ parsing/docstrings.cmx \ utils/clflags.cmx \ @@ -2030,6 +2034,7 @@ typing/typetexp.cmo : \ parsing/location.cmi \ typing/layouts.cmi \ utils/language_extension.cmi \ + parsing/jane_syntax.cmi \ typing/errortrace.cmi \ typing/env.cmi \ typing/ctype.cmi \ @@ -2053,6 +2058,7 @@ typing/typetexp.cmx : \ parsing/location.cmx \ typing/layouts.cmx \ utils/language_extension.cmx \ + parsing/jane_syntax.cmx \ typing/errortrace.cmx \ typing/env.cmx \ typing/ctype.cmx \ @@ -6803,6 +6809,7 @@ toplevel/topcommon.cmi : \ typing/outcometree.cmi \ parsing/longident.cmi \ parsing/location.cmi \ + typing/layouts.cmi \ typing/ident.cmi \ toplevel/genprintval.cmi \ typing/env.cmi \ @@ -7078,7 +7085,6 @@ toplevel/native/topeval.cmo : \ parsing/location.cmi \ utils/load_path.cmi \ utils/linkage_name.cmi \ - typing/layouts.cmi \ lambda/lambda.cmi \ typing/includemod.cmi \ typing/ident.cmi \ @@ -7112,7 +7118,6 @@ toplevel/native/topeval.cmx : \ parsing/location.cmx \ utils/load_path.cmx \ utils/linkage_name.cmx \ - typing/layouts.cmx \ lambda/lambda.cmx \ typing/includemod.cmx \ typing/ident.cmx \ diff --git a/ocaml/boot/menhir/parser.ml b/ocaml/boot/menhir/parser.ml index d778c67842b..4e7d617bc3f 100644 --- a/ocaml/boot/menhir/parser.ml +++ b/ocaml/boot/menhir/parser.ml @@ -995,7 +995,13 @@ let check_layout loc id = (* Unboxed literals *) -let unboxed_literals_extension : Language_extension.t = Layouts Alpha +(* CR layouts v2: The [unboxed_*] functions will both be improved and lose + their explicit assert once we have real unboxed literals in Jane syntax; they + may also get re-inlined at that point *) +let unboxed_literals_extension = Language_extension.Layouts +let assert_unboxed_literals ~loc = + Language_extension.( + Jane_syntax_parsing.assert_extension_enabled ~loc Layouts Alpha) type sign = Positive | Negative @@ -1004,15 +1010,10 @@ let with_sign sign num = | Positive -> num | Negative -> "-" ^ num -(* CR layouts ASZ: The [unboxed_*] functions will both be improved and lose - their explicit assert once we have real unboxed literals in Jane syntax; they - may also get re-inlined at that point *) - let unboxed_int sloc int_loc sign (n, m) = match m with | Some _ -> - Jane_syntax_parsing.assert_extension_enabled - ~loc:(make_loc sloc) unboxed_literals_extension; + assert_unboxed_literals ~loc:(make_loc sloc); Pconst_integer (with_sign sign n, m) | None -> if Language_extension.is_enabled unboxed_literals_extension then @@ -1021,8 +1022,7 @@ let unboxed_int sloc int_loc sign (n, m) = not_expecting sloc "line number directive" let unboxed_float sloc sign (f, m) = - Jane_syntax_parsing.assert_extension_enabled - ~loc:(make_loc sloc) unboxed_literals_extension; + assert_unboxed_literals ~loc:(make_loc sloc); Pconst_float (with_sign sign f, m) (* Jane syntax *) diff --git a/ocaml/driver/compenv.ml b/ocaml/driver/compenv.ml index 4eb8fe0a9e1..c63aedda76c 100644 --- a/ocaml/driver/compenv.ml +++ b/ocaml/driver/compenv.ml @@ -490,7 +490,7 @@ let read_one_param ppf position name v = | "dump-into-file" -> Clflags.dump_into_file := true | "dump-dir" -> Clflags.dump_dir := Some v - | "extension" -> Language_extension.(enable (of_string_exn v)) + | "extension" -> Language_extension.enable_of_string_exn v | "disable-all-extensions" -> if check_bool ppf name v then Language_extension.disallow_extensions () diff --git a/ocaml/driver/main_args.ml b/ocaml/driver/main_args.ml index b1b6d5a942d..09143ea4678 100644 --- a/ocaml/driver/main_args.ml +++ b/ocaml/driver/main_args.ml @@ -732,7 +732,7 @@ let mk_dump_into_file f = let mk_extension f = let available_extensions = - Language_extension.(List.map to_string all) + Language_extension.Exist.(List.concat_map to_command_line_strings all) in "-extension", Arg.Symbol (available_extensions, f), " Enable the specified extension (may be specified more than once)" @@ -740,7 +740,7 @@ let mk_extension f = let mk_no_extension f = let available_extensions = - Language_extension.(List.map to_string all) + Language_extension.Exist.(List.concat_map to_command_line_strings all) in "-no-extension", Arg.Symbol (available_extensions, f), " Disable the specified extension (may be specified more than once)" @@ -756,8 +756,11 @@ let mk_disable_all_extensions f = let mk_only_erasable_extensions f = let erasable_extensions = - let open Language_extension in - all |> List.filter is_erasable |> List.map to_string |> String.concat ", " + let open Language_extension.Exist in + all |> + List.filter is_erasable |> + List.concat_map to_command_line_strings |> + String.concat ", " in "-only-erasable-extensions", Arg.Unit f, " Disable all extensions that cannot be \"erased\" to attributes,\n\ @@ -1818,8 +1821,8 @@ module Default = struct let _disable_all_extensions = Language_extension.disallow_extensions let _only_erasable_extensions = Language_extension.restrict_to_erasable_extensions - let _extension s = Language_extension.(enable (of_string_exn s)) - let _no_extension s = Language_extension.(disable (of_string_exn s)) + let _extension s = Language_extension.(enable_of_string_exn s) + let _no_extension s = Language_extension.(disable_of_string_exn s) let _noassert = set noassert let _nolabels = set classic let _nostdlib = set no_std_include diff --git a/ocaml/driver/makedepend.ml b/ocaml/driver/makedepend.ml index 303a3f2ea2e..0a715f6aed4 100644 --- a/ocaml/driver/makedepend.ml +++ b/ocaml/driver/makedepend.ml @@ -662,7 +662,7 @@ let run_main argv = let program = Filename.basename Sys.argv.(0) in Compenv.parse_arguments (ref argv) (add_dep_arg (fun f -> Src (f, None))) program; - List.iter Language_extension.enable Language_extension.max_compatible; + Language_extension.enable_maximal (); process_dep_args (List.rev !dep_args_rev); Compenv.readenv ppf Before_link; if !sort_files then sort_files_by_dependencies !files diff --git a/ocaml/parsing/builtin_attributes.ml b/ocaml/parsing/builtin_attributes.ml index 04c48ee64e9..35f1bcc4c9d 100644 --- a/ocaml/parsing/builtin_attributes.ml +++ b/ocaml/parsing/builtin_attributes.ml @@ -478,10 +478,9 @@ let layout ~legacy_immediate attrs = | Value -> check true | Immediate | Immediate64 -> check (legacy_immediate - || Language_extension.( is_enabled (Layouts Beta) - || is_enabled (Layouts Alpha))) + || Language_extension.(is_at_least Layouts Beta)) | Any | Void -> - check (Language_extension.is_enabled (Layouts Alpha)) + check Language_extension.(is_at_least Layouts Alpha) (* The "ocaml.boxed (default)" and "ocaml.unboxed (default)" attributes cannot be input by the user, they are added by the diff --git a/ocaml/parsing/jane_syntax.ml b/ocaml/parsing/jane_syntax.ml index 236ab4ce9b8..42cdacd18d5 100644 --- a/ocaml/parsing/jane_syntax.ml +++ b/ocaml/parsing/jane_syntax.ml @@ -268,7 +268,7 @@ module Comprehensions = struct | ["array"; "immutable"], Pexp_lazy comp -> (* assert_extension_enabled: See Note [Check for immutable extension in comprehensions code] *) - assert_extension_enabled ~loc:expr.pexp_loc Immutable_arrays; + assert_extension_enabled ~loc:expr.pexp_loc Immutable_arrays (); Cexp_array_comprehension (Immutable, comprehension_of_expr comp) | bad, _ -> Desugaring_error.raise expr (Bad_comprehension_embedding bad) diff --git a/ocaml/parsing/jane_syntax_parsing.ml b/ocaml/parsing/jane_syntax_parsing.ml index 79ca732278d..079be792db9 100644 --- a/ocaml/parsing/jane_syntax_parsing.ml +++ b/ocaml/parsing/jane_syntax_parsing.ml @@ -83,11 +83,11 @@ open Parsetree module Feature : sig type t = - | Language_extension of Language_extension.t + | Language_extension : _ Language_extension.t -> t | Builtin type error = - | Disabled_extension of Language_extension.t + | Disabled_extension : _ Language_extension.t -> error | Unknown_extension of string val describe_uppercase : t -> string @@ -98,11 +98,11 @@ module Feature : sig val is_erasable : t -> bool end = struct - type t = Language_extension of Language_extension.t + type t = Language_extension : _ Language_extension.t -> t | Builtin type error = - | Disabled_extension of Language_extension.t + | Disabled_extension : _ Language_extension.t -> error | Unknown_extension of string let builtin_component = "_builtin" @@ -122,10 +122,10 @@ end = struct Ok Builtin else match Language_extension.of_string str with - | Some ext when Language_extension.is_enabled ext -> - Ok (Language_extension ext) - | Some ext -> - Error (Disabled_extension ext) + | Some (Pack ext) -> + if Language_extension.is_enabled ext + then Ok (Language_extension ext) + else Error (Disabled_extension ext) | None -> Error (Unknown_extension str) @@ -334,7 +334,7 @@ module Error = struct | Malformed_embedding of Embedding_syntax.t * Embedded_name.t * malformed_embedding | Unknown_extension of Embedding_syntax.t * Erasability.t * string - | Disabled_extension of Language_extension.t + | Disabled_extension : _ Language_extension.t -> error | Wrong_syntactic_category of Feature.t * string | Misnamed_embedding of Misnamed_embedding_error.t * string * Embedding_syntax.t @@ -347,8 +347,8 @@ end open Error -let assert_extension_enabled ~loc ext = - if not (Language_extension.is_enabled ext) then +let assert_extension_enabled ~loc ext setting = + if not (Language_extension.is_at_least ext setting) then raise (Error(loc, Disabled_extension ext)) ;; diff --git a/ocaml/parsing/jane_syntax_parsing.mli b/ocaml/parsing/jane_syntax_parsing.mli index 5ca82ff25a5..7d6c284215d 100644 --- a/ocaml/parsing/jane_syntax_parsing.mli +++ b/ocaml/parsing/jane_syntax_parsing.mli @@ -94,7 +94,7 @@ built-in features. *) module Feature : sig type t = - | Language_extension of Language_extension.t + | Language_extension : _ Language_extension.t -> t | Builtin (** The component of an attribute or extension name that identifies the @@ -238,13 +238,14 @@ module AST : sig -> ('ast -> 'a option) end -(** Require that an extension is enabled, or else throw an exception (of an - abstract type) at the provided location saying otherwise. This is intended - to be used in [jane_syntax.ml] when a certain piece of syntax requires two - extensions to be enabled at once (e.g., immutable array comprehensions such - as [[:x for x = 1 to 10:]], which require both [Comprehensions] and - [Immutable_arrays]). *) -val assert_extension_enabled : loc:Location.t -> Language_extension.t -> unit +(** Require that an extension is enabled for at least the provided level, or + else throw an exception (of an abstract type) at the provided location + saying otherwise. This is intended to be used in [jane_syntax.ml] when a + certain piece of syntax requires two extensions to be enabled at once (e.g., + immutable array comprehensions such as [[:x for x = 1 to 10:]], which + require both [Comprehensions] and [Immutable_arrays]). *) +val assert_extension_enabled : + loc:Location.t -> 'a Language_extension.t -> 'a -> unit (* CR-someday nroberts: An earlier version of this revealed less of its implementation in its name: it was called [match_jane_syntax], and diff --git a/ocaml/parsing/parser.mly b/ocaml/parsing/parser.mly index f9ccfbe9fa7..f3c44dba16b 100644 --- a/ocaml/parsing/parser.mly +++ b/ocaml/parsing/parser.mly @@ -782,7 +782,13 @@ let check_layout loc id = (* Unboxed literals *) -let unboxed_literals_extension : Language_extension.t = Layouts Alpha +(* CR layouts v2: The [unboxed_*] functions will both be improved and lose + their explicit assert once we have real unboxed literals in Jane syntax; they + may also get re-inlined at that point *) +let unboxed_literals_extension = Language_extension.Layouts +let assert_unboxed_literals ~loc = + Language_extension.( + Jane_syntax_parsing.assert_extension_enabled ~loc Layouts Alpha) type sign = Positive | Negative @@ -791,15 +797,10 @@ let with_sign sign num = | Positive -> num | Negative -> "-" ^ num -(* CR layouts ASZ: The [unboxed_*] functions will both be improved and lose - their explicit assert once we have real unboxed literals in Jane syntax; they - may also get re-inlined at that point *) - let unboxed_int sloc int_loc sign (n, m) = match m with | Some _ -> - Jane_syntax_parsing.assert_extension_enabled - ~loc:(make_loc sloc) unboxed_literals_extension; + assert_unboxed_literals ~loc:(make_loc sloc); Pconst_integer (with_sign sign n, m) | None -> if Language_extension.is_enabled unboxed_literals_extension then @@ -808,8 +809,7 @@ let unboxed_int sloc int_loc sign (n, m) = not_expecting sloc "line number directive" let unboxed_float sloc sign (f, m) = - Jane_syntax_parsing.assert_extension_enabled - ~loc:(make_loc sloc) unboxed_literals_extension; + assert_unboxed_literals ~loc:(make_loc sloc); Pconst_float (with_sign sign f, m) (* Jane syntax *) diff --git a/ocaml/testsuite/tests/ast-invariants/test.ml b/ocaml/testsuite/tests/ast-invariants/test.ml index f4c06b9f55b..ab0cd7f7363 100644 --- a/ocaml/testsuite/tests/ast-invariants/test.ml +++ b/ocaml/testsuite/tests/ast-invariants/test.ml @@ -85,5 +85,5 @@ let rec walk dir = (Sys.readdir dir) let () = - List.iter Language_extension.enable Language_extension.max_compatible; + Language_extension.enable_maximal (); walk root diff --git a/ocaml/testsuite/tests/comprehensions/syntax.ml b/ocaml/testsuite/tests/comprehensions/syntax.ml index 1ddbc1a213f..6dca7d0a7c2 100644 --- a/ocaml/testsuite/tests/comprehensions/syntax.ml +++ b/ocaml/testsuite/tests/comprehensions/syntax.ml @@ -1,7 +1,7 @@ (* TEST include ocamlcommon *) -let () = Language_extension.enable Comprehensions;; +let () = Language_extension.enable Comprehensions ();; let printf = Printf.printf;; diff --git a/ocaml/testsuite/tests/language-extensions/language_extensions.ml b/ocaml/testsuite/tests/language-extensions/language_extensions.ml index c3cc941615b..8b69a9ded4b 100644 --- a/ocaml/testsuite/tests/language-extensions/language_extensions.ml +++ b/ocaml/testsuite/tests/language-extensions/language_extensions.ml @@ -64,23 +64,6 @@ let with_goal goal ~name ~what test = match goal with | Fail -> should_fail name test | Succeed -> should_succeed name what test -let with_two_layouts goal first second ~enabled = - let verb ending = - "enabl" ^ ending ^ (if enabled then "" else " and disabl" ^ ending) - in - let comparison, plural = - if first = second then "the same", "" else "two different", "s" - in - let description ending = - verb ending ^ " " ^ comparison ^ " layouts extension" ^ plural - in - Language_extension.with_enabled (Layouts first) (fun () -> - with_goal goal - ~name:(description "e") - ~what:(description "ing") - (fun () -> - Language_extension.with_set (Layouts second) ~enabled (fun () -> ()))) - let when_disallowed goal f_str f = let can_or_can't = match goal with | Fail -> "can't" @@ -101,15 +84,15 @@ typecheck_with_extension "in its default state"; (* Disable all extensions for testing *) -List.iter Language_extension.disable Language_extension.all; +Language_extension.disable_all (); typecheck_with_extension ~full_name:true "no extensions enabled"; (* Test globally toggling a language extension *) -Language_extension.enable extension; +Language_extension.enable extension (); typecheck_with_extension "enabled"; -Language_extension.enable extension; +Language_extension.enable extension (); typecheck_with_extension "still enabled"; Language_extension.disable extension; @@ -121,7 +104,7 @@ typecheck_with_extension "still disabled"; Language_extension.set extension ~enabled:true; typecheck_with_extension "enabled via [set]"; -Language_extension.enable extension; +Language_extension.enable extension (); typecheck_with_extension "still enabled, via [set] and [enable]"; Language_extension.set extension ~enabled:false; @@ -136,7 +119,7 @@ typecheck_with_extension "still disabled, via [set] and [disable]"; but it's more robust to do this explicitly) *) Language_extension.disable extension; -Language_extension.with_enabled extension (fun () -> +Language_extension.with_enabled extension () (fun () -> typecheck_with_extension "enabled locally and disabled globally"); Language_extension.with_disabled extension (fun () -> @@ -150,12 +133,12 @@ Language_extension.with_set extension ~enabled:false (fun () -> typecheck_with_extension "disabled locally via [with_set] and also globally"); (* Globally enable the language extension *) -Language_extension.enable extension; +Language_extension.enable extension (); Language_extension.with_disabled extension (fun () -> typecheck_with_extension "disabled locally and enabled globally"); -Language_extension.with_enabled extension (fun () -> +Language_extension.with_enabled extension () (fun () -> typecheck_with_extension "enabled locally and globally"); Language_extension.with_set extension ~enabled:false (fun () -> @@ -165,13 +148,32 @@ Language_extension.with_set extension ~enabled:false (fun () -> Language_extension.with_set extension ~enabled:true (fun () -> typecheck_with_extension "disabled locally via [with_set] and also globally"); -(* Test that we only allow you to pass one distinct layouts extension flag*) - -with_two_layouts Succeed Alpha Alpha ~enabled:false; - -with_two_layouts Fail Alpha Beta ~enabled:false; - -with_two_layouts Fail Alpha Beta ~enabled:true; +(* Test behavior of layouts extensions *) +Language_extension.(enable Layouts Beta);; +Language_extension.(enable Layouts Alpha);; +report ~name:"Enable two layouts" + ~text:(if Language_extension.is_at_least Layouts Alpha + && Language_extension.is_at_least Layouts Beta + && Language_extension.is_at_least Layouts Stable + then "Succeeded" + else "Failed");; + +Language_extension.disable Layouts;; +report ~name:"Disable layouts" + ~text:(if Language_extension.is_at_least Layouts Alpha + || Language_extension.is_at_least Layouts Beta + || Language_extension.is_at_least Layouts Stable + then "Failed" + else "Succeeded");; + +Language_extension.(enable Layouts Alpha);; +Language_extension.(enable Layouts Beta);; +report ~name:"Enable two layouts, in reverse order" + ~text:(if Language_extension.is_at_least Layouts Alpha + && Language_extension.is_at_least Layouts Beta + && Language_extension.is_at_least Layouts Stable + then "Succeeded" + else "Failed");; (* Test disallowing extensions *) @@ -190,7 +192,7 @@ when_disallowed Succeed "set ~enabled:false" (Language_extension.set ~enabled:false); when_disallowed Fail "enable" - Language_extension.enable; + (fun x -> Language_extension.enable x ()); when_disallowed Succeed "disable" Language_extension.disable; @@ -202,7 +204,7 @@ when_disallowed Succeed "with_set ~enabled:false" (Language_extension.with_set ~enabled:false |> lift_with); when_disallowed Fail "with_enabled" - (Language_extension.with_enabled |> lift_with); + ((fun x -> Language_extension.with_enabled x ()) |> lift_with); when_disallowed Succeed "with_disabled" (Language_extension.with_disabled |> lift_with); diff --git a/ocaml/testsuite/tests/language-extensions/reference.txt b/ocaml/testsuite/tests/language-extensions/reference.txt index 2f40c613081..0b0298c3696 100644 --- a/ocaml/testsuite/tests/language-extensions/reference.txt +++ b/ocaml/testsuite/tests/language-extensions/reference.txt @@ -52,14 +52,14 @@ Successfully typechecked "[x for x = 1 to 10]" # "comprehensions" extension disabled locally via [with_set] and also globally [comprehensions enabled]: Successfully typechecked "[x for x = 1 to 10]" -# enable and disable the same layouts extension [comprehensions enabled]: -Succeeded at enabling and disabling the same layouts extension +# Enable two layouts [comprehensions enabled]: +Succeeded -# enable and disable two different layouts extensions [comprehensions enabled]: -Failed as expected: Cannot disable extension layouts_beta because extension layouts_alpha is enabled. Please enable or disable at most one of the layouts extensions. +# Disable layouts [comprehensions enabled]: +Succeeded -# enable two different layouts extensions [comprehensions enabled]: -Failed as expected: Invalid extensions: Please enable at most one of 'layouts', 'layouts_beta', and 'layouts_alpha'. +# Enable two layouts, in reverse order [comprehensions enabled]: +Succeeded # can disallow extensions while extensions are enabled [comprehensions disabled]: Succeeded at disallowing all extensions diff --git a/ocaml/testsuite/tests/lib-array/iarray_syntax.ml b/ocaml/testsuite/tests/lib-array/iarray_syntax.ml index aa8cf84ceaf..7c66988c1f2 100644 --- a/ocaml/testsuite/tests/lib-array/iarray_syntax.ml +++ b/ocaml/testsuite/tests/lib-array/iarray_syntax.ml @@ -3,7 +3,7 @@ let printf = Printf.printf;; -let () = Language_extension.enable Immutable_arrays;; +let () = Language_extension.enable Immutable_arrays ();; let test_printing parsed = let expr = Parse.expression (Lexing.from_string parsed) in diff --git a/ocaml/testsuite/tests/typing-local/print_syntax.ml b/ocaml/testsuite/tests/typing-local/print_syntax.ml index 112d7a711f4..888c837a494 100644 --- a/ocaml/testsuite/tests/typing-local/print_syntax.ml +++ b/ocaml/testsuite/tests/typing-local/print_syntax.ml @@ -6,7 +6,7 @@ let () = let fname = "example_syntax.ml" in - Language_extension.enable Local; + Language_extension.enable Local (); let ic = open_in fname in let lexbuf = Lexing.from_channel ic in Location.init lexbuf fname; diff --git a/ocaml/typing/typecore.ml b/ocaml/typing/typecore.ml index 41a36251b6c..cd3bc1bf2e5 100644 --- a/ocaml/typing/typecore.ml +++ b/ocaml/typing/typecore.ml @@ -166,7 +166,7 @@ type error = | Probe_name_format of string | Probe_name_undefined of string | Probe_is_enabled_format - | Extension_not_enabled of Language_extension.t + | Extension_not_enabled : _ Language_extension.t -> error | Literal_overflow of string | Unknown_literal of string * char | Illegal_letrec_pat diff --git a/ocaml/typing/typecore.mli b/ocaml/typing/typecore.mli index 26105952cc7..b775b784521 100644 --- a/ocaml/typing/typecore.mli +++ b/ocaml/typing/typecore.mli @@ -243,7 +243,7 @@ type error = | Probe_name_undefined of string (* CR-soon mshinwell: Use an inlined record *) | Probe_is_enabled_format - | Extension_not_enabled of Language_extension.t + | Extension_not_enabled : _ Language_extension.t -> error | Literal_overflow of string | Unknown_literal of string * char | Illegal_letrec_pat diff --git a/ocaml/typing/typetexp.ml b/ocaml/typing/typetexp.ml index 9b062cebebc..bc802549bde 100644 --- a/ocaml/typing/typetexp.ml +++ b/ocaml/typing/typetexp.ml @@ -54,7 +54,7 @@ type error = | Method_mismatch of string * type_expr * type_expr | Opened_object of Path.t option | Not_an_object of type_expr - | Unsupported_extension of Language_extension.t + | Unsupported_extension : _ Language_extension.t -> error | Polymorphic_optional_param | Non_value of {vloc : value_loc; typ : type_expr; err : Layout.Violation.t} diff --git a/ocaml/typing/typetexp.mli b/ocaml/typing/typetexp.mli index df9415af7b9..07dc1187630 100644 --- a/ocaml/typing/typetexp.mli +++ b/ocaml/typing/typetexp.mli @@ -95,7 +95,7 @@ type error = | Method_mismatch of string * type_expr * type_expr | Opened_object of Path.t option | Not_an_object of type_expr - | Unsupported_extension of Language_extension.t + | Unsupported_extension : _ Language_extension.t -> error | Polymorphic_optional_param | Non_value of {vloc : value_loc; typ : type_expr; err : Layout.Violation.t} diff --git a/ocaml/utils/language_extension.ml b/ocaml/utils/language_extension.ml index 7f5153b394b..427b185b2ec 100644 --- a/ocaml/utils/language_extension.ml +++ b/ocaml/utils/language_extension.ml @@ -1,73 +1,136 @@ -type maturity = Stable | Beta | Alpha +(* operations we want on every extension level *) +module type Extension_level = sig + type t + val compare : t -> t -> int + val max : t -> t -> t + val max_value : t + val all : t list + val to_command_line_suffix : t -> string +end -let equal_maturity (a : maturity) (b : maturity) = (a = b) +module Unit = struct + type t = unit + let compare = Unit.compare + let max _ _ = () + let max_value = () + let all = [()] + let to_command_line_suffix () = "" +end -type t = - | Comprehensions - | Local - | Include_functor - | Polymorphic_parameters - | Immutable_arrays - | Module_strengthening - | Layouts of maturity - -let equal (a : t) (b : t) = (a = b) - -let all = - [ Comprehensions - ; Local - ; Include_functor - ; Polymorphic_parameters - ; Immutable_arrays - ; Module_strengthening - ; Layouts Alpha - ; Layouts Beta - ; Layouts Stable - ] +module Maturity = struct + type t = Stable | Beta | Alpha -let max_compatible = - [ Comprehensions - ; Local - ; Include_functor - ; Polymorphic_parameters - ; Immutable_arrays - ; Module_strengthening - ; Layouts Alpha - ] + let compare t1 t2 = + let rank = function + | Stable -> 1 + | Beta -> 2 + | Alpha -> 3 + in + compare (rank t1) (rank t2) + + let max t1 t2 = if compare t1 t2 >= 0 then t1 else t2 + let max_value = Alpha + + let all = [ Stable; Beta; Alpha ] + + let to_command_line_suffix = function + | Stable -> "" + | Beta -> "_beta" + | Alpha -> "_alpha" +end + +type maturity = Maturity.t = Stable | Beta | Alpha + +(* Remember to update [all] when changing this type. *) +type _ t = + | Comprehensions : unit t + | Local : unit t + | Include_functor : unit t + | Polymorphic_parameters : unit t + | Immutable_arrays : unit t + | Module_strengthening : unit t + | Layouts : Maturity.t t + +type exist = + Pack : _ t -> exist -let default_extensions = - [ Local - ; Include_functor - ; Polymorphic_parameters +let all : exist list = + [ Pack Comprehensions + ; Pack Local + ; Pack Include_functor + ; Pack Polymorphic_parameters + ; Pack Immutable_arrays + ; Pack Module_strengthening + ; Pack Layouts ] -let to_string = function +type extn_pair = + | Pair : 'a t * 'a -> extn_pair + +let get_level_ops : type a. a t -> (module Extension_level with type t = a) = + function + | Comprehensions -> (module Unit) + | Local -> (module Unit) + | Include_functor -> (module Unit) + | Polymorphic_parameters -> (module Unit) + | Immutable_arrays -> (module Unit) + | Module_strengthening -> (module Unit) + | Layouts -> (module Maturity) + +(**********************************) +(* string conversions *) + +let to_string : type a. a t -> string = function | Comprehensions -> "comprehensions" | Local -> "local" | Include_functor -> "include_functor" | Polymorphic_parameters -> "polymorphic_parameters" | Immutable_arrays -> "immutable_arrays" | Module_strengthening -> "module_strengthening" - | Layouts Alpha -> "layouts_alpha" - | Layouts Beta -> "layouts_beta" - | Layouts Stable -> "layouts" - -let of_string extn = match String.lowercase_ascii extn with - | "comprehensions" -> Some Comprehensions - | "local" -> Some Local - | "include_functor" -> Some Include_functor - | "polymorphic_parameters" -> Some Polymorphic_parameters - | "immutable_arrays" -> Some Immutable_arrays - | "strengthening" -> Some Module_strengthening - | "layouts_alpha" -> Some (Layouts Alpha) - | "layouts_beta" -> Some (Layouts Beta) - | "layouts" -> Some (Layouts Stable) + | Layouts -> "layouts" + +(* converts full extension names, like "layouts_alpha" to a pair of + an extension and its setting *) +let pair_of_string extn_name : extn_pair option = + match String.lowercase_ascii extn_name with + | "comprehensions" -> Some (Pair (Comprehensions, ())) + | "local" -> Some (Pair (Local, ())) + | "include_functor" -> Some (Pair (Include_functor, ())) + | "polymorphic_parameters" -> Some (Pair (Polymorphic_parameters, ())) + | "immutable_arrays" -> Some (Pair (Immutable_arrays, ())) + | "strengthening" -> Some (Pair (Module_strengthening, ())) + | "layouts" -> Some (Pair (Layouts, (Stable : Maturity.t))) + | "layouts_beta" -> Some (Pair (Layouts, (Beta : Maturity.t))) + | "layouts_alpha" -> Some (Pair (Layouts, (Alpha : Maturity.t))) | _ -> None -let of_string_exn extn = - match of_string extn with - | Some extn -> extn - | None -> raise (Arg.Bad(Printf.sprintf "Extension %s is not known" extn)) +let pair_of_string_exn extn_name = match pair_of_string extn_name with + | Some pair -> pair + | None -> + raise (Arg.Bad(Printf.sprintf "Extension %s is not known" extn_name)) + +let of_string extn_name = + let pack (Pair (extn, _) : extn_pair) = Pack extn in + Option.map pack (pair_of_string extn_name) + +(************************************) +(* equality *) + +let equal_t (type a b) (a : a t) (b : b t) : (a, b) Misc.eq option = match a, b with + | Comprehensions, Comprehensions -> Some Refl + | Local, Local -> Some Refl + | Include_functor, Include_functor -> Some Refl + | Polymorphic_parameters, Polymorphic_parameters -> Some Refl + | Immutable_arrays, Immutable_arrays -> Some Refl + | Module_strengthening, Module_strengthening -> Some Refl + | Layouts, Layouts -> Some Refl + | (Comprehensions | Local | Include_functor | Polymorphic_parameters | + Immutable_arrays | Module_strengthening | Layouts), _ -> None + +let equal a b = Option.is_some (equal_t a b) + +(*****************************) +(* extension universes *) (* We'll do this in a more principled way later. *) (* CR layouts: Note that layouts is only "mostly" erasable, because of annoying @@ -77,11 +140,9 @@ let of_string_exn extn = But we've decided to punt on this issue in the short term. *) -let is_erasable = function +let is_erasable : type a. a t -> bool = function | Local - | Layouts Alpha - | Layouts Beta - | Layouts Stable -> + | Layouts -> true | Comprehensions | Include_functor @@ -90,114 +151,208 @@ let is_erasable = function | Module_strengthening -> false -module Universe = struct +module Universe : sig + val is_allowed : 'a t -> bool + val check : 'a t -> unit + val check_maximal : unit -> unit + + type t = + | No_extensions + | Only_erasable + | Any + + val set : t -> bool +end = struct (** Which extensions can be enabled? *) type t = | No_extensions | Only_erasable | Any + let compare t1 t2 = + let rank = function + | No_extensions -> 1 + | Only_erasable -> 2 + | Any -> 3 + in + compare (rank t1) (rank t2) + + let universe = ref Any + let compiler_options = function | No_extensions -> "flag -disable-all-extensions" | Only_erasable -> "flag -only-erasable-extensions" | Any -> "default options" - let is_allowed t ext = match t with + let is_allowed ext = match !universe with | No_extensions -> false | Only_erasable -> is_erasable ext | Any -> true + + (* are _all_ extensions allowed? *) + let all_allowed () = match !universe with + | Any -> true + | No_extensions | Only_erasable -> false + + (* The terminating [()] argument helps protect against ignored arguments. See + the documentation for [Base.failwithf]. *) + let fail fmt = + Format.ksprintf (fun str () -> raise (Arg.Bad str)) fmt + + let check extn = + if not (is_allowed extn) + then fail "Cannot enable extension %s: incompatible with %s" + (to_string extn) + (compiler_options !universe) + () + + let check_maximal () = + if not (all_allowed ()) + then fail "Cannot enable all extensions: incompatible with %s" + (compiler_options !universe) + () + + (* returns whether or not a change was actually made *) + let set new_universe = + let cmp = compare new_universe !universe in + if cmp > 0 + then fail "Cannot specify %s: incompatible with %s" + (compiler_options new_universe) + (compiler_options !universe) + (); + universe := new_universe; + cmp <> 0 end +(*****************************************) +(* enabling / disabling *) + (* Mutable state. Invariants: (1) [!extensions] contains at most one copy of each extension. - (2) Every member of [!extensions] satisfies [Universe.is_allowed !universe]. + (2) Every member of [!extensions] satisfies [Universe.is_allowed]. (For instance, [!universe = No_extensions] implies [!extensions = []]). *) -let extensions = ref default_extensions (* -extension *) -let universe = ref Universe.Any (* -only-erasable-extensions, - -disable-all-extensions *) - -type compatibility = Compatible | Duplicate | Incompatible of string -let check_conflicts t1 = - let layouts_err = - "Invalid extensions: Please enable at most one of 'layouts', \ - 'layouts_beta', and 'layouts_alpha'." - in - let c = List.find_map (fun t2 -> - if equal t1 t2 then Some Duplicate else - match t1, t2 with - | Layouts _, Layouts _ -> Some (Incompatible layouts_err) - | _, _ -> None) - !extensions - in - Option.value c ~default:Compatible +let default_extensions : extn_pair list = + [ Pair (Local, ()) + ; Pair (Include_functor, ()) + ; Pair (Polymorphic_parameters, ()) + ] +let extensions : extn_pair list ref = ref default_extensions -let set extn ~enabled = - if enabled then begin - if not (Universe.is_allowed !universe extn) then - raise (Arg.Bad(Printf.sprintf - "Cannot %s extension %s: incompatible with %s" - (if enabled then "enable" else "disable") - (to_string extn) - (Universe.compiler_options !universe))); - match check_conflicts extn with - | Duplicate -> () - | Compatible -> extensions := extn :: !extensions - | Incompatible err -> raise (Arg.Bad err) - end else +let set_worker (type a) (extn : a t) = function + | Some value -> + Universe.check extn; + let (module Ops) = get_level_ops extn in + let rec update_extensions already_seen : extn_pair list -> extn_pair list = + function + | [] -> Pair (extn, value) :: already_seen + | ((Pair (extn', v) as e) :: es) -> + match equal_t extn extn' with + | None -> update_extensions (e :: already_seen) es + | Some Refl -> + Pair (extn, Ops.max v value) :: List.rev_append already_seen es + in + extensions := update_extensions [] !extensions + | None -> extensions := - List.filter (fun extn' -> - match extn, extn' with - | Layouts m1, Layouts m2 when not (equal_maturity m1 m2) -> - raise (Arg.Bad(Printf.sprintf - "Cannot disable extension %s because extension %s is enabled. \ - Please enable or disable at most one of the layouts extensions." - (to_string extn) (to_string extn'))) - | _, _ -> - not (equal extn extn')) + List.filter (fun (Pair (extn', _) : extn_pair) -> not (equal extn extn')) !extensions -let enable = set ~enabled:true -let disable = set ~enabled:false - -let is_enabled extn = List.mem extn !extensions +let set extn ~enabled = + set_worker extn (if enabled then Some () else None) +let enable extn value = set_worker extn (Some value) +let disable extn = set_worker extn None (* It might make sense to ban [set], [enable], [disable], [only_erasable_extensions], and [disallow_extensions] inside [f], but it's not clear that it's worth the hassle *) -let with_set extn ~enabled f = +let with_set_worker extn value f = (* This is similar to [Misc.protect_refs], but we don't have values to set - [extensions] and [universe] to. *) + [extensions] to. *) let current_extensions = !extensions in - let current_universe = !universe in Fun.protect - ~finally:(fun () -> - extensions := current_extensions; - universe := current_universe) + ~finally:(fun () -> extensions := current_extensions) (fun () -> - set extn ~enabled; + set_worker extn value; f ()) -let with_enabled = with_set ~enabled:true -let with_disabled = with_set ~enabled:false +let with_set extn ~enabled = + with_set_worker extn (if enabled then Some () else None) +let with_enabled extn value = with_set_worker extn (Some value) +let with_disabled extn = with_set_worker extn None + +let enable_of_string_exn extn_name = match pair_of_string_exn extn_name with + | Pair (extn, setting) -> enable extn setting + +let disable_of_string_exn extn_name = match pair_of_string_exn extn_name with + | Pair (extn, _) -> disable extn + +let disable_all () = + extensions := [] + +let enable_maximal () = + Universe.check_maximal (); + let maximal_pair (Pack extn) = + let (module Ops) = get_level_ops extn in + Pair (extn, Ops.max_value) + in + extensions := List.map maximal_pair all let restrict_to_erasable_extensions () = - match !universe with - | Any -> - extensions := List.filter is_erasable !extensions; - universe := Universe.Only_erasable - | Only_erasable -> - () (* Idempotent *) - | No_extensions -> - raise (Arg.Bad(Printf.sprintf - "Cannot specify %s: incompatible with %s" - (Universe.compiler_options Only_erasable) - (Universe.compiler_options No_extensions))) + let changed = Universe.set Only_erasable in + if changed + then extensions := + List.filter (fun (Pair (extn, _)) -> Universe.is_allowed extn) !extensions let disallow_extensions () = - (* The strictest option, so no internal checks needed *) - extensions := []; - universe := Universe.No_extensions + ignore (Universe.set No_extensions : bool); + disable_all () + +(********************************************) +(* checking an extension *) + +let is_at_least (type a) (extn : a t) (value : a) = + let rec check : extn_pair list -> bool = function + | [] -> false + | (Pair (e, v) :: es) -> + let (module Ops) = get_level_ops e in + match equal_t e extn with + | Some Refl -> Ops.compare v value >= 0 + | None -> check es + in + check !extensions + +let is_enabled extn = + let rec check : extn_pair list -> bool = function + | [] -> false + | (Pair (e, _) :: _) when equal e extn -> true + | (_ :: es) -> check es + in + check !extensions + + +module Exist = struct + type 'a extn = 'a t + type t = exist = + | Pack : 'a extn -> t + + let to_command_line_strings (Pack extn) = + let (module Ops) = get_level_ops extn in + List.map + (fun level -> to_string extn ^ Ops.to_command_line_suffix level) + Ops.all + + let to_string : t -> string = function + | Pack extn -> to_string extn + + let is_enabled : t -> bool = function + | Pack extn -> is_enabled extn + + let is_erasable : t -> bool = function + | Pack extn -> is_erasable extn + + let all = all +end diff --git a/ocaml/utils/language_extension.mli b/ocaml/utils/language_extension.mli index f48e47985e6..367e0d09dbe 100644 --- a/ocaml/utils/language_extension.mli +++ b/ocaml/utils/language_extension.mli @@ -1,53 +1,82 @@ (** Language extensions provided by ocaml-jst *) +(** A setting for extensions that track multiple maturity levels *) type maturity = Stable | Beta | Alpha -(** The type of language extensions *) -type t = - | Comprehensions - | Local - | Include_functor - | Polymorphic_parameters - | Immutable_arrays - | Module_strengthening - | Layouts of maturity +(** The type of language extensions. An ['a t] is an extension that can either + be off or be set to have any value in ['a], so a [unit t] can be either on + or off, while a [maturity t] can have different maturity settings. *) +type _ t = + | Comprehensions : unit t + | Local : unit t + | Include_functor : unit t + | Polymorphic_parameters : unit t + | Immutable_arrays : unit t + | Module_strengthening : unit t + | Layouts : maturity t + +(** Existentially packed language extension *) +module Exist : sig + type 'a extn = 'a t (* this is removed from the sig by the [with] below; + ocamldoc doesn't like [:=] in sigs *) + type t = + | Pack : 'a extn -> t + + val to_string : t -> string + val is_enabled : t -> bool + val is_erasable : t -> bool + + (** Returns a list of all strings, like ["layouts_beta"], that + correspond to this extension. *) + val to_command_line_strings : t -> string list + + val all : t list +end with type 'a extn := 'a t (** Equality on language extensions *) -val equal : t -> t -> bool +val equal : 'a t -> 'b t -> bool -(** A list of all possible language extensions *) -val all : t list +(** Disable all extensions *) +val disable_all : unit -> unit -(** A maximal list of compatible language extensions (of the layouts extensions, - "layouts_alpha" is selected). *) -val max_compatible : t list +(** Maximally enable all extensions (that is, set to [Alpha] for [maturity] + extensions. *) +val enable_maximal : unit -> unit (** Check if a language extension is "erasable", i.e. whether it can be harmlessly translated to attributes and compiled with the upstream compiler. *) -val is_erasable : t -> bool +val is_erasable : 'a t -> bool (** Print and parse language extensions; parsing is case-insensitive *) -val to_string : t -> string -val of_string : string -> t option -val of_string_exn : string -> t +val to_string : 'a t -> string +val of_string : string -> Exist.t option + +(** Enable and disable according to command-line strings; these raise + an exception if the input string is invalid. *) +val enable_of_string_exn : string -> unit +val disable_of_string_exn : string -> unit (** Enable and disable language extensions; these operations are idempotent *) -val set : t -> enabled:bool -> unit -val enable : t -> unit -val disable : t -> unit +val set : unit t -> enabled:bool -> unit +val enable : 'a t -> 'a -> unit +val disable : 'a t -> unit + +(** Check if a language extension is currently enabled (at any maturity level) +*) +val is_enabled : 'a t -> bool -(** Check if a language extension is currently enabled *) -val is_enabled : t -> bool +(** Check if a language extension is enabled at least at the given level *) +val is_at_least : 'a t -> 'a -> bool (** Tooling support: Temporarily enable and disable language extensions; these operations are idempotent. Calls to [set], [enable], [disable], and [disallow_extensions] inside the body of the function argument will also be rolled back when the function finishes, but this behavior may change; nest multiple [with_*] functions instead. *) -val with_set : t -> enabled:bool -> (unit -> unit) -> unit -val with_enabled : t -> (unit -> unit) -> unit -val with_disabled : t -> (unit -> unit) -> unit +val with_set : unit t -> enabled:bool -> (unit -> unit) -> unit +val with_enabled : 'a t -> 'a -> (unit -> unit) -> unit +val with_disabled : 'a t -> (unit -> unit) -> unit (** Permanently restrict the allowable extensions to those that are "erasable", i.e. those that can be harmlessly translated to attributes and diff --git a/ocaml/utils/misc.ml b/ocaml/utils/misc.ml index 5ca4d768b66..825d45df14a 100644 --- a/ocaml/utils/misc.ml +++ b/ocaml/utils/misc.ml @@ -1275,3 +1275,9 @@ module Magic_number = struct | Error err -> Error (Unexpected_error err) | Ok () -> Ok info end + +(*********************************************) +(* Fancy types *) + +type (_, _) eq = Refl : ('a, 'a) eq + diff --git a/ocaml/utils/misc.mli b/ocaml/utils/misc.mli index a93cc39f5d3..5eb6bd7995a 100644 --- a/ocaml/utils/misc.mli +++ b/ocaml/utils/misc.mli @@ -707,3 +707,8 @@ module Magic_number : sig val all_kinds : kind list end + +(** Propositional equality *) +type (_, _) eq = Refl : ('a, 'a) eq + +