From cf327784849c843f146a301dca250553af873035 Mon Sep 17 00:00:00 2001 From: Nick Roberts Date: Thu, 28 Sep 2023 14:58:57 -0400 Subject: [PATCH] flambda-backend: Enable ocamlformat for Jane Syntax / language extensions code (#1876) * Enable and apply ocamlformat * Document the divergence in ocamlformat settings --- parsing/.ocamlformat | 21 + parsing/.ocamlformat-enable | 5 + parsing/jane_asttypes.mli | 1 - parsing/jane_syntax.ml | 1151 +++++++++++++++---------------- parsing/jane_syntax.mli | 197 +++--- parsing/jane_syntax_parsing.ml | 563 ++++++++------- parsing/jane_syntax_parsing.mli | 53 +- utils/.ocamlformat-enable | 2 + utils/language_extension.ml | 199 +++--- utils/language_extension.mli | 28 +- 10 files changed, 1110 insertions(+), 1110 deletions(-) create mode 100644 parsing/.ocamlformat create mode 100644 parsing/.ocamlformat-enable diff --git a/parsing/.ocamlformat b/parsing/.ocamlformat new file mode 100644 index 00000000000..3c4cb177b69 --- /dev/null +++ b/parsing/.ocamlformat @@ -0,0 +1,21 @@ +# Please make a pull request to change this file. +disable=true +# There is an .ocamlformat-enable file in this directory. +# Keep the remainder of this file in sync with other .ocamlformat files in this repo. +assignment-operator=begin-line +cases-exp-indent=2 +doc-comments=before +dock-collection-brackets=false +if-then-else=keyword-first +module-item-spacing=sparse +parens-tuple=multi-line-only +sequence-blank-line=compact +space-around-lists=false +space-around-variants=false +type-decl=sparse +version=0.24.1 + +# The existing comments are hand-formatted and lose a lot of readability +# if we wrap them. We should either convert the comments we care about to +# doc comments, or make this same setting change everywhere. +wrap-comments=false diff --git a/parsing/.ocamlformat-enable b/parsing/.ocamlformat-enable new file mode 100644 index 00000000000..c6a11de429d --- /dev/null +++ b/parsing/.ocamlformat-enable @@ -0,0 +1,5 @@ +jane_syntax.ml +jane_syntax.mli +jane_syntax_parsing.ml +jane_syntax_parsing.mli +jane_asttypes.mli diff --git a/parsing/jane_asttypes.mli b/parsing/jane_asttypes.mli index 4eab1a52a6f..e897903ea21 100644 --- a/parsing/jane_asttypes.mli +++ b/parsing/jane_asttypes.mli @@ -25,7 +25,6 @@ *) - open Asttypes type global_flag = diff --git a/parsing/jane_syntax.ml b/parsing/jane_syntax.ml index cdcf3e11c4b..59beaa91b61 100644 --- a/parsing/jane_syntax.ml +++ b/parsing/jane_syntax.ml @@ -9,9 +9,10 @@ open Jane_syntax_parsing *) module Language_extension = struct include Language_extension_kernel + include ( - Language_extension - : Language_extension_kernel.Language_extension_for_jane_syntax) + Language_extension : + Language_extension_kernel.Language_extension_for_jane_syntax) end (* Suppress the unused module warning so it's easy to keep around the @@ -25,11 +26,11 @@ module type Extension = sig val feature : Feature.t end -module Ast_of (AST : AST) - (Ext : Extension) : sig +module Ast_of (AST : AST) (Ext : Extension) : sig (* Wrap a bit of AST with a jane-syntax annotation *) val wrap_jane_syntax : - string list -> (* these strings describe the bit of new syntax *) + string list -> + (* these strings describe the bit of new syntax *) ?payload:payload -> AST.ast -> AST.ast @@ -58,7 +59,6 @@ module Of_ast (Ext : Extension) : sig val unwrap_jane_syntax_attributes_exn : loc:Location.t -> attributes -> unwrapped end = struct - let extension_string = Feature.extension_component Ext.feature module Desugaring_error = struct @@ -68,38 +68,34 @@ end = struct let report_error ~loc = function | Not_this_embedding name -> - Location.errorf ~loc - "Tried to desugar the embedded term %a@ \ - as belonging to the %s extension" - Embedded_name.pp_quoted_name name extension_string + Location.errorf ~loc + "Tried to desugar the embedded term %a@ as belonging to the %s \ + extension" + Embedded_name.pp_quoted_name name extension_string | Non_embedding -> - Location.errorf ~loc - "Tried to desugar a non-embedded expression@ \ - as belonging to the %s extension" - extension_string + Location.errorf ~loc + "Tried to desugar a non-embedded expression@ as belonging to the %s \ + extension" + extension_string exception Error of Location.t * error let () = - Location.register_error_of_exn - (function - | Error(loc, err) -> - Some (report_error ~loc err) - | _ -> None) + Location.register_error_of_exn (function + | Error (loc, err) -> Some (report_error ~loc err) + | _ -> None) - let raise ~loc err = - raise (Error(loc, err)) + let raise ~loc err = raise (Error (loc, err)) end let unwrap_jane_syntax_attributes attrs : (_, Desugaring_error.error) result = match find_and_remove_jane_syntax_attribute attrs with - | Some (ext_name, _loc, payload, attrs) -> begin - match Jane_syntax_parsing.Embedded_name.components ext_name with - | extension_occur :: names - when String.equal extension_occur extension_string -> - Ok (names, payload, attrs) - | _ -> Error (Not_this_embedding ext_name) - end + | Some (ext_name, _loc, payload, attrs) -> ( + match Jane_syntax_parsing.Embedded_name.components ext_name with + | extension_occur :: names + when String.equal extension_occur extension_string -> + Ok (names, payload, attrs) + | _ -> Error (Not_this_embedding ext_name)) | None -> Error Non_embedding let unwrap_jane_syntax_attributes_exn ~loc attrs = @@ -172,13 +168,17 @@ module type Payload_protocol = sig module Encode : sig val as_payload : t loc -> payload + val list_as_payload : t loc list -> payload + val option_list_as_payload : t loc option list -> payload end module Decode : sig val from_payload : loc:Location.t -> payload -> t loc + val list_from_payload : loc:Location.t -> payload -> t loc list + val option_list_from_payload : loc:Location.t -> payload -> t loc option list end @@ -186,7 +186,9 @@ end module type Stringable = sig type t + val of_string : string -> t option + val to_string : t -> string (** For error messages: a name that can be used to identify the @@ -196,26 +198,29 @@ module type Stringable = sig val indefinite_article_and_name : string * string end -module Make_payload_protocol_of_stringable (Stringable : Stringable) - : Payload_protocol with type t := Stringable.t = struct +module Make_payload_protocol_of_stringable (Stringable : Stringable) : + Payload_protocol with type t := Stringable.t = struct module Encode = struct let as_expr t_loc = let string = Stringable.to_string t_loc.txt in - Ast_helper.Exp.ident - (Location.mkloc (Longident.Lident string) t_loc.loc) + Ast_helper.Exp.ident (Location.mkloc (Longident.Lident string) t_loc.loc) let structure_item_of_expr expr = { pstr_desc = Pstr_eval (expr, []); pstr_loc = Location.none } let structure_item_of_none = - { pstr_desc = Pstr_attribute { attr_name = Location.mknoloc "none" - ; attr_payload = PStr [] - ; attr_loc = Location.none } - ; pstr_loc = Location.none } + { pstr_desc = + Pstr_attribute + { attr_name = Location.mknoloc "none"; + attr_payload = PStr []; + attr_loc = Location.none + }; + pstr_loc = Location.none + } let as_payload t_loc = let expr = as_expr t_loc in - PStr [ structure_item_of_expr expr ] + PStr [structure_item_of_expr expr] let list_as_payload t_locs = let items = @@ -225,7 +230,8 @@ module Make_payload_protocol_of_stringable (Stringable : Stringable) let option_list_as_payload t_locs = let items = - List.map (function + List.map + (function | None -> structure_item_of_none | Some t_loc -> structure_item_of_expr (as_expr t_loc)) t_locs @@ -234,28 +240,22 @@ module Make_payload_protocol_of_stringable (Stringable : Stringable) end module Desugaring_error = struct - type error = - | Unknown_payload of payload + type error = Unknown_payload of payload let report_error ~loc = function | Unknown_payload payload -> let indefinite_article, name = Stringable.indefinite_article_and_name in - Location.errorf ~loc - "Attribute payload does not name %s %s:@;%a" - indefinite_article name - (Printast.payload 0) payload + Location.errorf ~loc "Attribute payload does not name %s %s:@;%a" + indefinite_article name (Printast.payload 0) payload exception Error of Location.t * error let () = - Location.register_error_of_exn - (function - | Error(loc, err) -> - Some (report_error ~loc err) - | _ -> None) + Location.register_error_of_exn (function + | Error (loc, err) -> Some (report_error ~loc err) + | _ -> None) - let raise ~loc err = - raise (Error(loc, err)) + let raise ~loc err = raise (Error (loc, err)) end module Decode = struct @@ -265,12 +265,12 @@ module Make_payload_protocol_of_stringable (Stringable : Stringable) let from_expr = function | { pexp_desc = Pexp_ident payload_lid; _ } -> - let t = - match Stringable.of_string (Longident.last payload_lid.txt) with - | None -> raise Unexpected - | Some t -> t - in - Location.mkloc t payload_lid.loc + let t = + match Stringable.of_string (Longident.last payload_lid.txt) with + | None -> raise Unexpected + | Some t -> t + in + Location.mkloc t payload_lid.loc | _ -> raise Unexpected let expr_of_structure_item = function @@ -279,28 +279,29 @@ module Make_payload_protocol_of_stringable (Stringable : Stringable) let is_none_structure_item = function | { pstr_desc = Pstr_attribute { attr_name = { txt = "none" } } } -> - true + true | _ -> false let from_payload payload = match payload with - | PStr [ item ] -> from_expr (expr_of_structure_item item) + | PStr [item] -> from_expr (expr_of_structure_item item) | _ -> raise Unexpected let list_from_payload payload = match payload with | PStr items -> - List.map (fun item -> from_expr (expr_of_structure_item item)) items + List.map (fun item -> from_expr (expr_of_structure_item item)) items | _ -> raise Unexpected let option_list_from_payload payload = match payload with | PStr items -> - List.map (fun item -> - if is_none_structure_item item - then None - else Some (from_expr (expr_of_structure_item item))) - items + List.map + (fun item -> + if is_none_structure_item item + then None + else Some (from_expr (expr_of_structure_item item))) + items | _ -> raise Unexpected end @@ -358,12 +359,13 @@ module Layout_annotation : sig include module type of Decode val bound_vars_from_vars_and_payload : - loc:Location.t -> string Location.loc list -> payload -> + loc:Location.t -> + string Location.loc list -> + payload -> (string Location.loc * layout_annotation option) list end end = struct - module Protocol = - Make_payload_protocol_of_stringable (Stringable_const_layout) + module Protocol = Make_payload_protocol_of_stringable (Stringable_const_layout) (*******************************************************) (* Conversions with a payload *) @@ -379,38 +381,35 @@ end = struct let report_error ~loc = function | Wrong_number_of_layouts (n, layouts) -> - Location.errorf ~loc - "Wrong number of layouts in an layout attribute;@;\ - expecting %i but got this list:@;%a" - n - (Format.pp_print_list - (Format.pp_print_option - ~none:(fun ppf () -> Format.fprintf ppf "None") - Layouts_pprint.layout_annotation)) - layouts + Location.errorf ~loc + "Wrong number of layouts in an layout attribute;@;\ + expecting %i but got this list:@;\ + %a" + n + (Format.pp_print_list + (Format.pp_print_option + ~none:(fun ppf () -> Format.fprintf ppf "None") + Layouts_pprint.layout_annotation)) + layouts exception Error of Location.t * error let () = - Location.register_error_of_exn - (function - | Error(loc, err) -> - Some (report_error ~loc err) - | _ -> None) + Location.register_error_of_exn (function + | Error (loc, err) -> Some (report_error ~loc err) + | _ -> None) - let raise ~loc err = - raise (Error(loc, err)) + let raise ~loc err = raise (Error (loc, err)) end let bound_vars_from_vars_and_payload ~loc var_names payload = let layouts = option_list_from_payload ~loc payload in - try - List.combine var_names layouts + try List.combine var_names layouts with (* seems silly to check the length in advance when [combine] does *) - Invalid_argument _ -> + | Invalid_argument _ -> Desugaring_error.raise ~loc - (Wrong_number_of_layouts(List.length var_names, layouts)) + (Wrong_number_of_layouts (List.length var_names, layouts)) end end @@ -421,21 +420,21 @@ module Mode_annotation = struct | Once include Make_payload_protocol_of_stringable (struct - type nonrec t = t + type nonrec t = t - let indefinite_article_and_name = "a", "mode" + let indefinite_article_and_name = "a", "mode" - let to_string = function - | Local -> "local" - | Unique -> "unique" - | Once -> "once" + let to_string = function + | Local -> "local" + | Unique -> "unique" + | Once -> "once" - let of_string = function - | "local" -> Some Local - | "unique" -> Some Unique - | "once" -> Some Once - | _ -> None - end) + let of_string = function + | "local" -> Some Local + | "unique" -> Some Unique + | "once" -> Some Once + | _ -> None + end) end (** List and array comprehensions *) @@ -446,31 +445,33 @@ module Comprehensions = struct module Ast_of = Ast_of (Expression) (Ext) module Of_ast = Of_ast (Ext) - include Ext type iterator = - | Range of { start : expression - ; stop : expression - ; direction : direction_flag } + | Range of + { start : expression; + stop : expression; + direction : direction_flag + } | In of expression type clause_binding = - { pattern : pattern - ; iterator : iterator - ; attributes : attribute list } + { pattern : pattern; + iterator : iterator; + attributes : attribute list + } type clause = | For of clause_binding list | When of expression type comprehension = - { body : expression - ; clauses : clause list + { body : expression; + clauses : clause list } type expression = - | Cexp_list_comprehension of comprehension + | Cexp_list_comprehension of comprehension | Cexp_array_comprehension of mutable_flag * comprehension (* The desugared-to-OCaml version of comprehensions is described by the @@ -501,28 +502,25 @@ module Comprehensions = struct let expr_of_iterator = function | Range { start; stop; direction } -> - Ast_of.wrap_jane_syntax - [ "for" - ; "range" - ; match direction with - | Upto -> "upto" - | Downto -> "downto" ] - (Ast_helper.Exp.tuple [start; stop]) - | In seq -> - Ast_of.wrap_jane_syntax ["for"; "in"] seq + Ast_of.wrap_jane_syntax + [ "for"; + "range"; + (match direction with Upto -> "upto" | Downto -> "downto") ] + (Ast_helper.Exp.tuple [start; stop]) + | In seq -> Ast_of.wrap_jane_syntax ["for"; "in"] seq let expr_of_clause_binding { pattern; iterator; attributes } = Ast_helper.Vb.mk ~attrs:attributes pattern (expr_of_iterator iterator) - let expr_of_clause clause rest = match clause with + let expr_of_clause clause rest = + match clause with | For iterators -> - Ast_of.wrap_jane_syntax - ["for"] - (Ast_helper.Exp.let_ - Nonrecursive (List.map expr_of_clause_binding iterators) - rest) + Ast_of.wrap_jane_syntax ["for"] + (Ast_helper.Exp.let_ Nonrecursive + (List.map expr_of_clause_binding iterators) + rest) | When cond -> - Ast_of.wrap_jane_syntax ["when"] (Ast_helper.Exp.sequence cond rest) + Ast_of.wrap_jane_syntax ["when"] (Ast_helper.Exp.sequence cond rest) let expr_of_comprehension ~type_ { body; clauses } = (* We elect to wrap the body in a new AST node (here, [Pexp_lazy]) @@ -532,27 +530,24 @@ module Comprehensions = struct part of its contract is threading through the user-written attributes on the outermost node. *) - Ast_of.wrap_jane_syntax - type_ + Ast_of.wrap_jane_syntax type_ (Ast_helper.Exp.lazy_ - (List.fold_right - expr_of_clause - clauses - (Ast_of.wrap_jane_syntax ["body"] body))) + (List.fold_right expr_of_clause clauses + (Ast_of.wrap_jane_syntax ["body"] body))) let expr_of ~loc cexpr = (* See Note [Wrapping with make_entire_jane_syntax] *) Expression.make_entire_jane_syntax ~loc feature (fun () -> - match cexpr with - | Cexp_list_comprehension comp -> + match cexpr with + | Cexp_list_comprehension comp -> expr_of_comprehension ~type_:["list"] comp - | Cexp_array_comprehension (amut, comp) -> + | Cexp_array_comprehension (amut, comp) -> expr_of_comprehension - ~type_:[ "array" - ; match amut with - | Mutable -> "mutable" - | Immutable -> "immutable" - ] + ~type_: + [ "array"; + (match amut with + | Mutable -> "mutable" + | Immutable -> "immutable") ] comp) (** Then, we define how to go from the OCaml AST to the nice AST; this is @@ -567,35 +562,33 @@ module Comprehensions = struct let report_error ~loc = function | Has_payload payload -> - Location.errorf ~loc - "Comprehensions attribute has an unexpected payload:@;%a" - (Printast.payload 0) payload + Location.errorf ~loc + "Comprehensions attribute has an unexpected payload:@;%a" + (Printast.payload 0) payload | Bad_comprehension_embedding subparts -> - Location.errorf ~loc - "Unknown, unexpected, or malformed@ comprehension embedded term %a" - Embedded_name.pp_quoted_name - (Embedded_name.of_feature feature subparts) + Location.errorf ~loc + "Unknown, unexpected, or malformed@ comprehension embedded term %a" + Embedded_name.pp_quoted_name + (Embedded_name.of_feature feature subparts) | No_clauses -> - Location.errorf ~loc - "Tried to desugar a comprehension with no clauses" + Location.errorf ~loc "Tried to desugar a comprehension with no clauses" exception Error of Location.t * error let () = - Location.register_error_of_exn - (function - | Error(loc, err) -> Some (report_error ~loc err) - | _ -> None) + Location.register_error_of_exn (function + | Error (loc, err) -> Some (report_error ~loc err) + | _ -> None) - let raise expr err = raise (Error(expr.pexp_loc, err)) + let raise expr err = raise (Error (expr.pexp_loc, err)) end (* Returns the expression node with the outermost Jane Syntax-related attribute removed. *) let expand_comprehension_extension_expr expr = let names, payload, attributes = - Of_ast.unwrap_jane_syntax_attributes_exn - ~loc:expr.pexp_loc expr.pexp_attributes + Of_ast.unwrap_jane_syntax_attributes_exn ~loc:expr.pexp_loc + expr.pexp_attributes in match payload with | PStr [] -> names, { expr with pexp_attributes = attributes } @@ -603,44 +596,36 @@ module Comprehensions = struct let iterator_of_expr expr = match expand_comprehension_extension_expr expr with - | ["for"; "range"; "upto"], - { pexp_desc = Pexp_tuple [start; stop]; _ } -> - Range { start; stop; direction = Upto } - | ["for"; "range"; "downto"], - { pexp_desc = Pexp_tuple [start; stop]; _ } -> - Range { start; stop; direction = Downto } - | ["for"; "in"], seq -> - In seq - | bad, _ -> - Desugaring_error.raise expr (Bad_comprehension_embedding bad) + | ["for"; "range"; "upto"], { pexp_desc = Pexp_tuple [start; stop]; _ } -> + Range { start; stop; direction = Upto } + | ["for"; "range"; "downto"], { pexp_desc = Pexp_tuple [start; stop]; _ } -> + Range { start; stop; direction = Downto } + | ["for"; "in"], seq -> In seq + | bad, _ -> Desugaring_error.raise expr (Bad_comprehension_embedding bad) let clause_binding_of_vb { pvb_pat; pvb_expr; pvb_attributes; pvb_loc = _ } = - { pattern = pvb_pat - ; iterator = iterator_of_expr pvb_expr - ; attributes = pvb_attributes } + { pattern = pvb_pat; + iterator = iterator_of_expr pvb_expr; + attributes = pvb_attributes + } let add_clause clause comp = { comp with clauses = clause :: comp.clauses } let comprehension_of_expr = let rec raw_comprehension_of_expr expr = match expand_comprehension_extension_expr expr with - | ["for"], { pexp_desc = Pexp_let(Nonrecursive, iterators, rest); _ } -> - add_clause - (For (List.map clause_binding_of_vb iterators)) - (raw_comprehension_of_expr rest) - | ["when"], { pexp_desc = Pexp_sequence(cond, rest); _ } -> - add_clause - (When cond) - (raw_comprehension_of_expr rest) - | ["body"], body -> - { body; clauses = [] } - | bad, _ -> - Desugaring_error.raise expr (Bad_comprehension_embedding bad) + | ["for"], { pexp_desc = Pexp_let (Nonrecursive, iterators, rest); _ } -> + add_clause + (For (List.map clause_binding_of_vb iterators)) + (raw_comprehension_of_expr rest) + | ["when"], { pexp_desc = Pexp_sequence (cond, rest); _ } -> + add_clause (When cond) (raw_comprehension_of_expr rest) + | ["body"], body -> { body; clauses = [] } + | bad, _ -> Desugaring_error.raise expr (Bad_comprehension_embedding bad) in fun expr -> match raw_comprehension_of_expr expr with - | { body = _; clauses = [] } -> - Desugaring_error.raise expr No_clauses + | { body = _; clauses = [] } -> Desugaring_error.raise expr No_clauses | comp -> comp (* Returns remaining unconsumed attributes on outermost expression *) @@ -649,27 +634,24 @@ module Comprehensions = struct let comp = match name, wrapper.pexp_desc with | ["list"], Pexp_lazy comp -> - Cexp_list_comprehension (comprehension_of_expr comp) + Cexp_list_comprehension (comprehension_of_expr comp) | ["array"; "mutable"], Pexp_lazy comp -> - Cexp_array_comprehension (Mutable, comprehension_of_expr comp) + Cexp_array_comprehension (Mutable, comprehension_of_expr comp) | ["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 (); - Cexp_array_comprehension (Immutable, comprehension_of_expr comp) - | bad, _ -> - Desugaring_error.raise expr (Bad_comprehension_embedding bad) + (* assert_extension_enabled: + See Note [Check for immutable extension in comprehensions code] *) + 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) in comp, wrapper.pexp_attributes end (** Immutable arrays *) module Immutable_arrays = struct - type nonrec expression = - | Iaexp_immutable_array of expression list + type nonrec expression = Iaexp_immutable_array of expression list - type nonrec pattern = - | Iapat_immutable_array of pattern list + type nonrec pattern = Iapat_immutable_array of pattern list let feature : Feature.t = Language_extension Immutable_arrays @@ -677,10 +659,11 @@ module Immutable_arrays = struct | Iaexp_immutable_array elts -> (* See Note [Wrapping with make_entire_jane_syntax] *) Expression.make_entire_jane_syntax ~loc feature (fun () -> - Ast_helper.Exp.array elts) + Ast_helper.Exp.array elts) (* Returns remaining unconsumed attributes *) - let of_expr expr = match expr.pexp_desc with + let of_expr expr = + match expr.pexp_desc with | Pexp_array elts -> Iaexp_immutable_array elts, expr.pexp_attributes | _ -> failwith "Malformed immutable array expression" @@ -688,10 +671,11 @@ module Immutable_arrays = struct | Iapat_immutable_array elts -> (* See Note [Wrapping with make_entire_jane_syntax] *) Pattern.make_entire_jane_syntax ~loc feature (fun () -> - Ast_helper.Pat.array elts) + Ast_helper.Pat.array elts) (* Returns remaining unconsumed attributes *) - let of_pat pat = match pat.ppat_desc with + let of_pat pat = + match pat.ppat_desc with | Ppat_array elts -> Iapat_immutable_array elts, pat.ppat_attributes | _ -> failwith "Malformed immutable array pattern" end @@ -714,8 +698,8 @@ module N_ary_functions = struct | Pparam_newtype of string loc * layout_annotation option type function_param = - { pparam_desc : function_param_desc - ; pparam_loc : Location.t + { pparam_desc : function_param_desc; + pparam_loc : Location.t } type mode_annotation = Mode_annotation.t = @@ -728,8 +712,8 @@ module N_ary_functions = struct | Pcoerce of core_type option * core_type type function_constraint = - { mode_annotations: mode_annotation loc list; - type_constraint: type_constraint; + { mode_annotations : mode_annotation loc list; + type_constraint : type_constraint } type expression = @@ -769,43 +753,44 @@ module N_ary_functions = struct let to_suffix_and_payload = function | Top_level -> [], None - | Fun_then Cases -> [ "cases" ], None - | Fun_then Constraint_then_cases -> [ "constraint"; "cases" ], None + | Fun_then Cases -> ["cases"], None + | Fun_then Constraint_then_cases -> ["constraint"; "cases"], None | Mode_constraint mode_annotation -> - let payload = - Mode_annotation.Encode.list_as_payload mode_annotation - in - [ "mode_constraint" ], Some payload + let payload = Mode_annotation.Encode.list_as_payload mode_annotation in + ["mode_constraint"], Some payload | Layout_annotation layout_annotation -> - let payload = Layout_annotation.Encode.as_payload layout_annotation in - [ "layout_annotation" ], Some payload + let payload = Layout_annotation.Encode.as_payload layout_annotation in + ["layout_annotation"], Some payload let of_suffix suffix = match suffix with | [] -> No_payload Top_level - | [ "cases" ] -> No_payload (Fun_then Cases) - | [ "constraint"; "cases" ] -> No_payload (Fun_then Constraint_then_cases) - | [ "mode_constraint" ] -> - Payload (fun payload ~loc -> - let mode_annotations = - Mode_annotation.Decode.list_from_payload payload ~loc - in - List.iter (fun mode_annotation -> + | ["cases"] -> No_payload (Fun_then Cases) + | ["constraint"; "cases"] -> No_payload (Fun_then Constraint_then_cases) + | ["mode_constraint"] -> + Payload + (fun payload ~loc -> + let mode_annotations = + Mode_annotation.Decode.list_from_payload payload ~loc + in + List.iter + (fun mode_annotation -> assert_extension_enabled ~loc (match (mode_annotation.txt : mode_annotation) with - | Local -> Local - | Unique | Once -> Unique) + | Local -> Local + | Unique | Once -> Unique) ()) - mode_annotations; - Mode_constraint mode_annotations) - | [ "layout_annotation" ] -> - Payload (fun payload ~loc -> - assert_extension_enabled ~loc Layouts - (Stable : Language_extension.maturity); - let layout_annotation = - Layout_annotation.Decode.from_payload payload ~loc - in - Layout_annotation layout_annotation) + mode_annotations; + Mode_constraint mode_annotations) + | ["layout_annotation"] -> + Payload + (fun payload ~loc -> + assert_extension_enabled ~loc Layouts + (Stable : Language_extension.maturity); + let layout_annotation = + Layout_annotation.Decode.from_payload payload ~loc + in + Layout_annotation layout_annotation) | _ -> Unknown_suffix let format ppf t = @@ -824,39 +809,38 @@ module N_ary_functions = struct let report_error ~loc = function | Has_payload payload -> - Location.errorf ~loc - "Syntactic arity attribute has an unexpected payload:@;%a" - (Printast.payload 0) payload + Location.errorf ~loc + "Syntactic arity attribute has an unexpected payload:@;%a" + (Printast.payload 0) payload | Expected_constraint_or_coerce -> - Location.errorf ~loc - "Expected a Pexp_constraint or Pexp_coerce node at this position." + Location.errorf ~loc + "Expected a Pexp_constraint or Pexp_coerce node at this position." | Expected_function_cases attribute -> - Location.errorf ~loc - "Expected a Pexp_function node in this position, as the enclosing \ - Pexp_fun is annotated with %a." - Attribute_node.format attribute + Location.errorf ~loc + "Expected a Pexp_function node in this position, as the enclosing \ + Pexp_fun is annotated with %a." + Attribute_node.format attribute | Expected_fun_or_newtype attribute -> - Location.errorf ~loc - "Only Pexp_fun or Pexp_newtype may carry the attribute %a." - Attribute_node.format attribute + Location.errorf ~loc + "Only Pexp_fun or Pexp_newtype may carry the attribute %a." + Attribute_node.format attribute | Expected_newtype_with_layout_annotation annotation -> - Location.errorf ~loc - "Only Pexp_newtype may carry the attribute %a." - Attribute_node.format (Attribute_node.Layout_annotation annotation) + Location.errorf ~loc "Only Pexp_newtype may carry the attribute %a." + Attribute_node.format (Attribute_node.Layout_annotation annotation) | Parameterless_function -> - Location.errorf ~loc - "The expression is a Jane Syntax encoding of a function with no \ - parameters, which is an invalid expression." + Location.errorf ~loc + "The expression is a Jane Syntax encoding of a function with no \ + parameters, which is an invalid expression." exception Error of Location.t * error let () = - Location.register_error_of_exn - (function - | Error(loc, err) -> Some (report_error ~loc err) - | _ -> None) + Location.register_error_of_exn (function + | Error (loc, err) -> Some (report_error ~loc err) + | _ -> None) let raise_with_loc loc err = raise (Error (loc, err)) + let raise expr err = raise (Error (expr.pexp_loc, err)) end @@ -920,15 +904,15 @@ module N_ary_functions = struct match Of_ast.unwrap_jane_syntax_attributes expr.pexp_attributes with | Error (Not_this_embedding _ | Non_embedding) -> None | Ok (suffix, payload, attributes) -> - let attribute_node = - match Attribute_node.of_suffix suffix, payload with - | No_payload t, PStr [] -> Some t - | Payload f, payload -> Some (f payload ~loc:expr.pexp_loc) - | No_payload _, payload -> - Desugaring_error.raise expr (Has_payload payload) - | Unknown_suffix, _ -> None - in - Option.map (fun x -> x, attributes) attribute_node + let attribute_node = + match Attribute_node.of_suffix suffix, payload with + | No_payload t, PStr [] -> Some t + | Payload f, payload -> Some (f payload ~loc:expr.pexp_loc) + | No_payload _, payload -> + Desugaring_error.raise expr (Has_payload payload) + | Unknown_suffix, _ -> None + in + Option.map (fun x -> x, attributes) attribute_node let require_function_cases expr ~arity_attribute = match expr.pexp_desc with @@ -943,11 +927,11 @@ module N_ary_functions = struct let check_constraint expr = match expr.pexp_desc with | Pexp_constraint (e, ty) -> - let mode_annotations = constraint_modes expr in - Some ({ mode_annotations; type_constraint = Pconstraint ty }, e) + let mode_annotations = constraint_modes expr in + Some ({ mode_annotations; type_constraint = Pconstraint ty }, e) | Pexp_coerce (e, ty1, ty2) -> - let mode_annotations = constraint_modes expr in - Some ({ mode_annotations; type_constraint = Pcoerce (ty1, ty2) }, e) + let mode_annotations = constraint_modes expr in + Some ({ mode_annotations; type_constraint = Pcoerce (ty1, ty2) }, e) | _ -> None let require_constraint expr = @@ -958,39 +942,39 @@ module N_ary_functions = struct let check_param pexp_desc (pexp_loc : Location.t) ~layout = match pexp_desc, layout with | Pexp_fun (lbl, def, pat, body), None -> - let pparam_loc : Location.t = - { loc_ghost = true; - loc_start = pexp_loc.loc_start; - loc_end = pat.ppat_loc.loc_end; - } - in - let pparam_desc = Pparam_val (lbl, def, pat) in - Some ({ pparam_desc; pparam_loc }, body) + let pparam_loc : Location.t = + { loc_ghost = true; + loc_start = pexp_loc.loc_start; + loc_end = pat.ppat_loc.loc_end + } + in + let pparam_desc = Pparam_val (lbl, def, pat) in + Some ({ pparam_desc; pparam_loc }, body) | Pexp_newtype (newtype, body), layout -> - (* This imperfectly estimates where a newtype parameter ends: it uses - the end of the type name rather than the closing paren. The closing - paren location is not tracked anywhere in the parsetree. We don't - think merlin is affected. - *) - let pparam_loc : Location.t = - { loc_ghost = true; - loc_start = pexp_loc.loc_start; - loc_end = newtype.loc.loc_end; - } - in - let pparam_desc = Pparam_newtype (newtype, layout) in - Some ({ pparam_desc; pparam_loc }, body) + (* This imperfectly estimates where a newtype parameter ends: it uses + the end of the type name rather than the closing paren. The closing + paren location is not tracked anywhere in the parsetree. We don't + think merlin is affected. + *) + let pparam_loc : Location.t = + { loc_ghost = true; + loc_start = pexp_loc.loc_start; + loc_end = newtype.loc.loc_end + } + in + let pparam_desc = Pparam_newtype (newtype, layout) in + Some ({ pparam_desc; pparam_loc }, body) | _, None -> None | _, Some layout -> - Desugaring_error.raise_with_loc pexp_loc - (Expected_newtype_with_layout_annotation layout) + Desugaring_error.raise_with_loc pexp_loc + (Expected_newtype_with_layout_annotation layout) let require_param pexp_desc pexp_loc ~arity_attribute ~layout = match check_param pexp_desc pexp_loc ~layout with | Some x -> x | None -> - Desugaring_error.raise_with_loc pexp_loc - (Expected_fun_or_newtype arity_attribute) + Desugaring_error.raise_with_loc pexp_loc + (Expected_fun_or_newtype arity_attribute) (* Should only be called on [Pexp_fun] and [Pexp_newtype]. *) let extract_fun_params = @@ -998,8 +982,7 @@ module N_ary_functions = struct type continue_or_stop = | Continue of Parsetree.expression | Stop of function_constraint option * function_body - end - in + end in (* Returns: the next parameter, together with whether there are possibly more parameters available ("Continue") or whether all parameters have been consumed ("Stop"). @@ -1012,52 +995,47 @@ module N_ary_functions = struct call to [extract_next_fun_param] in the event that it sees a [Layout_annotation] attribute. *) - let rec extract_next_fun_param expr ~layout - : (function_param * attributes) option * continue_or_stop - = + let rec extract_next_fun_param expr ~layout : + (function_param * attributes) option * continue_or_stop = match expand_n_ary_expr expr with - | None -> begin - match check_param expr.pexp_desc expr.pexp_loc ~layout with - | Some (param, body) -> - Some (param, expr.pexp_attributes), Continue body - | None -> - None, Stop (None, Pfunction_body expr) - end + | None -> ( + match check_param expr.pexp_desc expr.pexp_loc ~layout with + | Some (param, body) -> + Some (param, expr.pexp_attributes), Continue body + | None -> None, Stop (None, Pfunction_body expr)) | Some (Top_level, _) -> None, Stop (None, Pfunction_body expr) | Some (Layout_annotation next_layout, unconsumed_attributes) -> - extract_next_fun_param - { expr with pexp_attributes = unconsumed_attributes } - ~layout:(Some next_layout) + extract_next_fun_param + { expr with pexp_attributes = unconsumed_attributes } + ~layout:(Some next_layout) | Some (Mode_constraint _, _unconsumed_attributes) -> - (* We need not pass through any unconsumed attributes, as - [Mode_constraint _] isn't the outermost Jane Syntax node: - [extract_fun_params] took in [Pexp_fun] or [Pexp_newtype]. - *) - let function_constraint, body = require_constraint expr in - None, Stop (Some function_constraint, Pfunction_body body) - | Some (Fun_then after_fun as arity_attribute, unconsumed_attributes) -> - let param, body = - require_param expr.pexp_desc expr.pexp_loc ~arity_attribute ~layout - in - let continue_or_stop = - match after_fun with - | Cases -> - let cases = require_function_cases body ~arity_attribute in - let function_body = - Pfunction_cases - (cases, body.pexp_loc, body.pexp_attributes) - in - Stop (None, function_body) - | Constraint_then_cases -> - let function_constraint, body = require_constraint body in - let cases = require_function_cases body ~arity_attribute in - let function_body = - Pfunction_cases - (cases, body.pexp_loc, body.pexp_attributes) - in - Stop (Some function_constraint, function_body) - in - Some (param, unconsumed_attributes), continue_or_stop + (* We need not pass through any unconsumed attributes, as + [Mode_constraint _] isn't the outermost Jane Syntax node: + [extract_fun_params] took in [Pexp_fun] or [Pexp_newtype]. + *) + let function_constraint, body = require_constraint expr in + None, Stop (Some function_constraint, Pfunction_body body) + | Some ((Fun_then after_fun as arity_attribute), unconsumed_attributes) -> + let param, body = + require_param expr.pexp_desc expr.pexp_loc ~arity_attribute ~layout + in + let continue_or_stop = + match after_fun with + | Cases -> + let cases = require_function_cases body ~arity_attribute in + let function_body = + Pfunction_cases (cases, body.pexp_loc, body.pexp_attributes) + in + Stop (None, function_body) + | Constraint_then_cases -> + let function_constraint, body = require_constraint body in + let cases = require_function_cases body ~arity_attribute in + let function_body = + Pfunction_cases (cases, body.pexp_loc, body.pexp_attributes) + in + Stop (Some function_constraint, function_body) + in + Some (param, unconsumed_attributes), continue_or_stop in let rec loop expr ~rev_params = let next_param, continue_or_stop = @@ -1071,15 +1049,13 @@ module N_ary_functions = struct match continue_or_stop with | Continue body -> loop body ~rev_params | Stop (function_constraint, body) -> - let params = List.rev rev_params in - params, function_constraint, body + let params = List.rev rev_params in + params, function_constraint, body in fun expr -> - begin match expr.pexp_desc with - | Pexp_newtype _ | Pexp_fun _ -> () - | _ -> - Misc.fatal_error "called on something that isn't a newtype or fun" - end; + (match expr.pexp_desc with + | Pexp_newtype _ | Pexp_fun _ -> () + | _ -> Misc.fatal_error "called on something that isn't a newtype or fun"); let unconsumed_attributes = match extract_next_fun_param expr ~layout:None with | Some (_, attributes), _ -> attributes @@ -1103,8 +1079,8 @@ module N_ary_functions = struct let rec remove_top_level_attributes expr = match expand_n_ary_expr expr with | Some (Top_level, unconsumed_attributes) -> - remove_top_level_attributes - { expr with pexp_attributes = unconsumed_attributes } + remove_top_level_attributes + { expr with pexp_attributes = unconsumed_attributes } | _ -> expr in fun expr -> @@ -1112,20 +1088,19 @@ module N_ary_functions = struct match expr.pexp_desc with | Pexp_fun _ | Pexp_newtype _ -> Some (extract_fun_params expr) | Pexp_function cases -> + let n_ary = + function_without_additional_params cases None expr.pexp_loc + in + Some (n_ary, expr.pexp_attributes) + | _ -> ( + match check_constraint expr with + | Some (constraint_, { pexp_desc = Pexp_function cases }) -> let n_ary = - function_without_additional_params cases None expr.pexp_loc + function_without_additional_params cases (Some constraint_) + expr.pexp_loc in Some (n_ary, expr.pexp_attributes) - | _ -> begin - match check_constraint expr with - | Some (constraint_, { pexp_desc = Pexp_function cases }) -> - let n_ary = - function_without_additional_params cases (Some constraint_) - expr.pexp_loc - in - Some (n_ary, expr.pexp_attributes) - | _ -> None - end + | _ -> None) let n_ary_function_expr ext x = let suffix, payload = Attribute_node.to_suffix_and_payload ext in @@ -1139,15 +1114,14 @@ module N_ary_functions = struct in match pparam_desc with | Pparam_val (label, default, pat) -> - (Ast_helper.Exp.fun_ label default pat body ~loc - [@alert "-prefer_jane_syntax"]) - | Pparam_newtype (newtype, layout) -> - match layout with - | None -> Ast_helper.Exp.newtype newtype body ~loc - | Some layout -> - n_ary_function_expr - (Layout_annotation layout) - (Ast_helper.Exp.newtype newtype body ~loc) + Ast_helper.Exp.fun_ label default pat body ~loc + [@alert "-prefer_jane_syntax"] + | Pparam_newtype (newtype, layout) -> ( + match layout with + | None -> Ast_helper.Exp.newtype newtype body ~loc + | Some layout -> + n_ary_function_expr (Layout_annotation layout) + (Ast_helper.Exp.newtype newtype body ~loc)) in match after_fun_attribute with | None -> fun_ @@ -1156,17 +1130,17 @@ module N_ary_functions = struct fun ~loc (params, constraint_, function_body) -> (* See Note [Wrapping with make_entire_jane_syntax] *) Expression.make_entire_jane_syntax ~loc feature (fun () -> - let body = - match function_body with - | Pfunction_body body -> body - | Pfunction_cases (cases, loc, attrs) -> - (Ast_helper.Exp.function_ cases ~loc ~attrs - [@alert "-prefer_jane_syntax"]) - in - let possibly_constrained_body = - match constraint_ with - | None -> body - | Some { mode_annotations; type_constraint } -> + let body = + match function_body with + | Pfunction_body body -> body + | Pfunction_cases (cases, loc, attrs) -> + Ast_helper.Exp.function_ cases ~loc ~attrs + [@alert "-prefer_jane_syntax"] + in + let possibly_constrained_body = + match constraint_ with + | None -> body + | Some { mode_annotations; type_constraint } -> ( let constrained_body = (* We can't call [Location.ghostify] here, as we need this file to build with the upstream compiler; see Note [Buildable with @@ -1178,14 +1152,13 @@ module N_ary_functions = struct in match mode_annotations with | _ :: _ as mode_annotations -> - n_ary_function_expr - (Mode_constraint mode_annotations) - constrained_body - | [] -> constrained_body - in - match params with - | [] -> possibly_constrained_body - | params -> + n_ary_function_expr (Mode_constraint mode_annotations) + constrained_body + | [] -> constrained_body) + in + match params with + | [] -> possibly_constrained_body + | params -> let init_params, last_param = Misc.split_last params in let after_fun_attribute : Attribute_node.after_fun option = match constraint_, function_body with @@ -1203,31 +1176,31 @@ end (** [include functor] *) module Include_functor = struct - type signature_item = - | Ifsig_include_functor of include_description + type signature_item = Ifsig_include_functor of include_description - type structure_item = - | Ifstr_include_functor of include_declaration + type structure_item = Ifstr_include_functor of include_declaration let feature : Feature.t = Language_extension Include_functor let sig_item_of ~loc = function | Ifsig_include_functor incl -> - (* See Note [Wrapping with make_entire_jane_syntax] *) - Signature_item.make_entire_jane_syntax ~loc feature (fun () -> + (* See Note [Wrapping with make_entire_jane_syntax] *) + Signature_item.make_entire_jane_syntax ~loc feature (fun () -> Ast_helper.Sig.include_ incl) - let of_sig_item sigi = match sigi.psig_desc with + let of_sig_item sigi = + match sigi.psig_desc with | Psig_include incl -> Ifsig_include_functor incl | _ -> failwith "Malformed [include functor] in signature" let str_item_of ~loc = function | Ifstr_include_functor incl -> - (* See Note [Wrapping with make_entire_jane_syntax] *) - Structure_item.make_entire_jane_syntax ~loc feature (fun () -> + (* See Note [Wrapping with make_entire_jane_syntax] *) + Structure_item.make_entire_jane_syntax ~loc feature (fun () -> Ast_helper.Str.include_ incl) - let of_str_item stri = match stri.pstr_desc with + let of_str_item stri = + match stri.pstr_desc with | Pstr_include incl -> Ifstr_include_functor incl | _ -> failwith "Malformed [include functor] in structure" end @@ -1235,7 +1208,9 @@ end (** Module strengthening *) module Strengthen = struct type nonrec module_type = - { mty : Parsetree.module_type; mod_id : Longident.t Location.loc } + { mty : Parsetree.module_type; + mod_id : Longident.t Location.loc + } let feature : Feature.t = Language_extension Module_strengthening @@ -1246,13 +1221,15 @@ module Strengthen = struct let mty_of ~loc { mty; mod_id } = (* See Note [Wrapping with make_entire_jane_syntax] *) Module_type.make_entire_jane_syntax ~loc feature (fun () -> - Ast_helper.Mty.functor_ (Named (Location.mknoloc None, mty)) - (Ast_helper.Mty.alias mod_id)) + Ast_helper.Mty.functor_ + (Named (Location.mknoloc None, mty)) + (Ast_helper.Mty.alias mod_id)) (* Returns remaining unconsumed attributes *) - let of_mty mty = match mty.pmty_desc with - | Pmty_functor(Named(_, mty), {pmty_desc = Pmty_alias mod_id}) -> - { mty; mod_id }, mty.pmty_attributes + let of_mty mty = + match mty.pmty_desc with + | Pmty_functor (Named (_, mty), { pmty_desc = Pmty_alias mod_id }) -> + { mty; mod_id }, mty.pmty_attributes | _ -> failwith "Malformed strengthened module type" end @@ -1263,7 +1240,6 @@ module Layouts = struct end include Ext - module Of_ast = Of_ast (Ext) type constant = @@ -1274,22 +1250,28 @@ module Layouts = struct | Lexp_constant of constant | Lexp_newtype of string loc * layout_annotation * expression - type nonrec pattern = - | Lpat_constant of constant + type nonrec pattern = Lpat_constant of constant type nonrec core_type = - | Ltyp_var of { name : string option - ; layout : layout_annotation } - | Ltyp_poly of { bound_vars : (string loc * layout_annotation option) list - ; inner_type : core_type } - | Ltyp_alias of { aliased_type : core_type - ; name : string option - ; layout : layout_annotation } + | Ltyp_var of + { name : string option; + layout : layout_annotation + } + | Ltyp_poly of + { bound_vars : (string loc * layout_annotation option) list; + inner_type : core_type + } + | Ltyp_alias of + { aliased_type : core_type; + name : string option; + layout : layout_annotation + } type nonrec extension_constructor = - | Lext_decl of (string Location.loc * layout_annotation option) list * - constructor_arguments * - Parsetree.core_type option + | Lext_decl of + (string Location.loc * layout_annotation option) list + * constructor_arguments + * Parsetree.core_type option (*******************************************************) (* Pretty-printing *) @@ -1315,40 +1297,35 @@ module Layouts = struct [Buildable with upstream] in jane_syntax.mli for details. *) let report_error ~loc = function | Unexpected_wrapped_type _typ -> - Location.errorf ~loc - "Layout attribute on wrong core type" + Location.errorf ~loc "Layout attribute on wrong core type" | Unexpected_wrapped_ext _ext -> - Location.errorf ~loc - "Layout attribute on wrong extension constructor" + Location.errorf ~loc "Layout attribute on wrong extension constructor" | Unexpected_attribute names -> Location.errorf ~loc "Layout extension does not understand these attribute names:@;[%a]" (Format.pp_print_list ~pp_sep:(fun ppf () -> Format.fprintf ppf ";@ ") - Format.pp_print_text) names + Format.pp_print_text) + names | No_integer_suffix -> Location.errorf ~loc "All unboxed integers require a suffix to determine their size." | Unexpected_constant _c -> - Location.errorf ~loc - "Unexpected unboxed constant" + Location.errorf ~loc "Unexpected unboxed constant" | Unexpected_wrapped_expr expr -> - Location.errorf ~loc - "Layout attribute on wrong expression:@;%a" + Location.errorf ~loc "Layout attribute on wrong expression:@;%a" (Printast.expression 0) expr | Unexpected_wrapped_pat _pat -> - Location.errorf ~loc - "Layout attribute on wrong pattern" + Location.errorf ~loc "Layout attribute on wrong pattern" exception Error of Location.t * error let () = - Location.register_error_of_exn - (function - | Error(loc, err) -> Some (report_error ~loc err) - | _ -> None) + Location.register_error_of_exn (function + | Error (loc, err) -> Some (report_error ~loc err) + | _ -> None) - let raise ~loc err = raise (Error(loc, err)) + let raise ~loc err = raise (Error (loc, err)) end module Encode = Layout_annotation.Encode @@ -1364,8 +1341,7 @@ module Layouts = struct let of_constant ~loc = function | Pconst_float (x, suffix) -> Float (x, suffix) | Pconst_integer (x, Some suffix) -> Integer (x, suffix) - | Pconst_integer (_, None) -> - Desugaring_error.raise ~loc No_integer_suffix + | Pconst_integer (_, None) -> Desugaring_error.raise ~loc No_integer_suffix | const -> Desugaring_error.raise ~loc (Unexpected_constant const) (*******************************************************) @@ -1374,17 +1350,16 @@ module Layouts = struct let expr_of ~loc expr = let module Ast_of = Ast_of (Expression) (Ext) in (* See Note [Wrapping with make_entire_jane_syntax] *) - Expression.make_entire_jane_syntax ~loc feature begin fun () -> - match expr with - | Lexp_constant c -> - let constant = constant_of c in - Ast_of.wrap_jane_syntax ["unboxed"] @@ - Ast_helper.Exp.constant constant - | Lexp_newtype (name, layout, inner_expr) -> - let payload = Encode.as_payload layout in - Ast_of.wrap_jane_syntax ["newtype"] ~payload @@ - Ast_helper.Exp.newtype name inner_expr - end + Expression.make_entire_jane_syntax ~loc feature (fun () -> + match expr with + | Lexp_constant c -> + let constant = constant_of c in + Ast_of.wrap_jane_syntax ["unboxed"] + @@ Ast_helper.Exp.constant constant + | Lexp_newtype (name, layout, inner_expr) -> + let payload = Encode.as_payload layout in + Ast_of.wrap_jane_syntax ["newtype"] ~payload + @@ Ast_helper.Exp.newtype name inner_expr) (*******************************************************) (* Desugaring expressions *) @@ -1394,19 +1369,18 @@ module Layouts = struct let names, payload, attributes = Of_ast.unwrap_jane_syntax_attributes_exn ~loc expr.pexp_attributes in - let lexpr = match names with - | [ "unboxed" ] -> - begin match expr.pexp_desc with + let lexpr = + match names with + | ["unboxed"] -> ( + match expr.pexp_desc with | Pexp_constant const -> Lexp_constant (of_constant ~loc const) - | _ -> Desugaring_error.raise ~loc (Unexpected_wrapped_expr expr) - end - | [ "newtype" ] -> + | _ -> Desugaring_error.raise ~loc (Unexpected_wrapped_expr expr)) + | ["newtype"] -> ( let layout = Decode.from_payload ~loc payload in - begin match expr.pexp_desc with + match expr.pexp_desc with | Pexp_newtype (name, inner_expr) -> Lexp_newtype (name, layout, inner_expr) - | _ -> Desugaring_error.raise ~loc (Unexpected_wrapped_expr expr) - end + | _ -> Desugaring_error.raise ~loc (Unexpected_wrapped_expr expr)) | _ -> Desugaring_error.raise ~loc (Unexpected_attribute names) in lexpr, attributes @@ -1415,19 +1389,19 @@ module Layouts = struct (* Encoding patterns *) let pat_of ~loc t = - Pattern.make_entire_jane_syntax ~loc feature begin fun () -> - match t with - | Lpat_constant c -> - let constant = constant_of c in - Ast_helper.Pat.constant constant - end + Pattern.make_entire_jane_syntax ~loc feature (fun () -> + match t with + | Lpat_constant c -> + let constant = constant_of c in + Ast_helper.Pat.constant constant) (*******************************************************) (* Desugaring patterns *) let of_pat pat = let loc = pat.ppat_loc in - let lpat = match pat.ppat_desc with + let lpat = + match pat.ppat_desc with | Ppat_constant const -> Lpat_constant (of_constant ~loc const) | _ -> Desugaring_error.raise ~loc (Unexpected_wrapped_pat pat) in @@ -1442,35 +1416,33 @@ module Layouts = struct let exception No_wrap_necessary of Parsetree.core_type in try (* See Note [Wrapping with make_entire_jane_syntax] *) - Core_type.make_entire_jane_syntax ~loc feature begin fun () -> - match typ with - | Ltyp_var { name; layout } -> - let payload = Encode.as_payload layout in - Type_of.wrap_jane_syntax ["var"] ~payload @@ - begin match name with - | None -> Ast_helper.Typ.any ~loc () - | Some name -> Ast_helper.Typ.var ~loc name - end - | Ltyp_poly { bound_vars; inner_type } -> - let var_names, layouts = List.split bound_vars in - (* Pass the loc because we don't want a ghost location here *) - let tpoly = Ast_helper.Typ.poly ~loc var_names inner_type in - if List.for_all Option.is_none layouts - then raise (No_wrap_necessary tpoly) - else - let payload = Encode.option_list_as_payload layouts in - Type_of.wrap_jane_syntax ["poly"] ~payload tpoly - - | Ltyp_alias { aliased_type; name; layout } -> - let payload = Encode.as_payload layout in - let has_name, inner_typ = match name with - | None -> "anon", aliased_type - | Some name -> "named", Ast_helper.Typ.alias aliased_type name - in - Type_of.wrap_jane_syntax ["alias"; has_name] ~payload inner_typ - end - with - No_wrap_necessary result_type -> result_type + Core_type.make_entire_jane_syntax ~loc feature (fun () -> + match typ with + | Ltyp_var { name; layout } -> ( + let payload = Encode.as_payload layout in + Type_of.wrap_jane_syntax ["var"] ~payload + @@ + match name with + | None -> Ast_helper.Typ.any ~loc () + | Some name -> Ast_helper.Typ.var ~loc name) + | Ltyp_poly { bound_vars; inner_type } -> + let var_names, layouts = List.split bound_vars in + (* Pass the loc because we don't want a ghost location here *) + let tpoly = Ast_helper.Typ.poly ~loc var_names inner_type in + if List.for_all Option.is_none layouts + then raise (No_wrap_necessary tpoly) + else + let payload = Encode.option_list_as_payload layouts in + Type_of.wrap_jane_syntax ["poly"] ~payload tpoly + | Ltyp_alias { aliased_type; name; layout } -> + let payload = Encode.as_payload layout in + let has_name, inner_typ = + match name with + | None -> "anon", aliased_type + | Some name -> "named", Ast_helper.Typ.alias aliased_type name + in + Type_of.wrap_jane_syntax ["alias"; has_name] ~payload inner_typ) + with No_wrap_necessary result_type -> result_type (*******************************************************) (* Desugaring types *) @@ -1480,46 +1452,36 @@ module Layouts = struct let names, payload, attributes = Of_ast.unwrap_jane_syntax_attributes_exn ~loc typ.ptyp_attributes in - let lty = match names with - | [ "var" ] -> + let lty = + match names with + | ["var"] -> ( let layout = Decode.from_payload ~loc payload in - begin match typ.ptyp_desc with - | Ptyp_any -> - Ltyp_var { name = None; layout } - | Ptyp_var name -> - Ltyp_var { name = Some name; layout } - | _ -> Desugaring_error.raise ~loc (Unexpected_wrapped_type typ) - end - - | [ "poly" ] -> - begin match typ.ptyp_desc with + match typ.ptyp_desc with + | Ptyp_any -> Ltyp_var { name = None; layout } + | Ptyp_var name -> Ltyp_var { name = Some name; layout } + | _ -> Desugaring_error.raise ~loc (Unexpected_wrapped_type typ)) + | ["poly"] -> ( + match typ.ptyp_desc with | Ptyp_poly (var_names, inner_type) -> let bound_vars = Decode.bound_vars_from_vars_and_payload ~loc var_names payload in Ltyp_poly { bound_vars; inner_type } - | _ -> Desugaring_error.raise ~loc (Unexpected_wrapped_type typ) - end - - | [ "alias"; "anon" ] -> + | _ -> Desugaring_error.raise ~loc (Unexpected_wrapped_type typ)) + | ["alias"; "anon"] -> let layout = Decode.from_payload ~loc payload in - Ltyp_alias { aliased_type = { typ with ptyp_attributes = attributes } - ; name = None - ; layout } - - | [ "alias"; "named" ] -> + Ltyp_alias + { aliased_type = { typ with ptyp_attributes = attributes }; + name = None; + layout + } + | ["alias"; "named"] -> ( let layout = Decode.from_payload ~loc payload in - begin match typ.ptyp_desc with + match typ.ptyp_desc with | Ptyp_alias (inner_typ, name) -> - Ltyp_alias { aliased_type = inner_typ - ; name = Some name - ; layout } - - | _ -> Desugaring_error.raise ~loc (Unexpected_wrapped_type typ) - end - - | _ -> - Desugaring_error.raise ~loc (Unexpected_attribute names) + Ltyp_alias { aliased_type = inner_typ; name = Some name; layout } + | _ -> Desugaring_error.raise ~loc (Unexpected_wrapped_type typ)) + | _ -> Desugaring_error.raise ~loc (Unexpected_attribute names) in lty, attributes @@ -1534,24 +1496,21 @@ module Layouts = struct let exception No_wrap_necessary of Parsetree.extension_constructor in try (* See Note [Wrapping with make_entire_jane_syntax] *) - Extension_constructor.make_entire_jane_syntax ~loc feature - begin fun () -> - match ext with - | Lext_decl (bound_vars, args, res) -> - let vars, layouts = List.split bound_vars in - let ext_ctor = - (* Pass ~loc here, because the constructor declaration is - not a ghost *) - Ast_helper.Te.decl ~loc ~vars ~args ?info ?docs ?res name - in - if List.for_all Option.is_none layouts - then raise (No_wrap_necessary ext_ctor) - else - let payload = Encode.option_list_as_payload layouts in - Ext_ctor_of.wrap_jane_syntax ["ext"] ~payload ext_ctor - end - with - No_wrap_necessary ext_ctor -> ext_ctor + Extension_constructor.make_entire_jane_syntax ~loc feature (fun () -> + match ext with + | Lext_decl (bound_vars, args, res) -> + let vars, layouts = List.split bound_vars in + let ext_ctor = + (* Pass ~loc here, because the constructor declaration is + not a ghost *) + Ast_helper.Te.decl ~loc ~vars ~args ?info ?docs ?res name + in + if List.for_all Option.is_none layouts + then raise (No_wrap_necessary ext_ctor) + else + let payload = Encode.option_list_as_payload layouts in + Ext_ctor_of.wrap_jane_syntax ["ext"] ~payload ext_ctor) + with No_wrap_necessary ext_ctor -> ext_ctor (*******************************************************) (* Desugaring extension constructor *) @@ -1561,19 +1520,17 @@ module Layouts = struct let names, payload, attributes = Of_ast.unwrap_jane_syntax_attributes_exn ~loc ext.pext_attributes in - let lext = match names with - | [ "ext" ] -> - begin match ext.pext_kind with + let lext = + match names with + | ["ext"] -> ( + match ext.pext_kind with | Pext_decl (var_names, args, res) -> let bound_vars = Decode.bound_vars_from_vars_and_payload ~loc var_names payload in Lext_decl (bound_vars, args, res) - | _ -> Desugaring_error.raise ~loc (Unexpected_wrapped_ext ext) - end - - | _ -> - Desugaring_error.raise ~loc (Unexpected_attribute names) + | _ -> Desugaring_error.raise ~loc (Unexpected_wrapped_ext ext)) + | _ -> Desugaring_error.raise ~loc (Unexpected_attribute names) in lext, attributes @@ -1582,8 +1539,8 @@ module Layouts = struct module Ctor_decl_of = Ast_of (Constructor_declaration) (Ext) - let constructor_declaration_of ~loc ~attrs ~info ~vars_layouts ~args - ~res name = + let constructor_declaration_of ~loc ~attrs ~info ~vars_layouts ~args ~res name + = let vars, layouts = List.split vars_layouts in let ctor_decl = Ast_helper.Type.constructor ~loc ~info ~vars ~args ?res name @@ -1593,17 +1550,15 @@ module Layouts = struct then ctor_decl else let payload = Encode.option_list_as_payload layouts in - Constructor_declaration.make_entire_jane_syntax ~loc feature - begin fun () -> - Ctor_decl_of.wrap_jane_syntax ["vars"] ~payload ctor_decl - end + Constructor_declaration.make_entire_jane_syntax ~loc feature (fun () -> + Ctor_decl_of.wrap_jane_syntax ["vars"] ~payload ctor_decl) in (* Performance hack: save an allocation if [attrs] is empty. *) match attrs with | [] -> ctor_decl | _ :: _ as attrs -> - (* See Note [Outer attributes at end] *) - { ctor_decl with pcd_attributes = ctor_decl.pcd_attributes @ attrs } + (* See Note [Outer attributes at end] *) + { ctor_decl with pcd_attributes = ctor_decl.pcd_attributes @ attrs } let of_constructor_declaration_internal (feat : Feature.t) ctor_decl = match feat with @@ -1612,10 +1567,11 @@ module Layouts = struct let names, payload, attributes = Of_ast.unwrap_jane_syntax_attributes_exn ~loc ctor_decl.pcd_attributes in - let vars_layouts = match names with - | [ "vars" ] -> - Decode.bound_vars_from_vars_and_payload - ~loc ctor_decl.pcd_vars payload + let vars_layouts = + match names with + | ["vars"] -> + Decode.bound_vars_from_vars_and_payload ~loc ctor_decl.pcd_vars + payload | _ -> Desugaring_error.raise ~loc (Unexpected_attribute names) in Some (vars_layouts, attributes) @@ -1623,7 +1579,7 @@ module Layouts = struct let of_constructor_declaration = Constructor_declaration.make_of_ast - ~of_ast_internal:of_constructor_declaration_internal + ~of_ast_internal:of_constructor_declaration_internal end (******************************************************************************) @@ -1631,16 +1587,17 @@ end module type AST = sig type t + type ast val of_ast : ast -> t option end module Core_type = struct - type t = - | Jtyp_layout of Layouts.core_type + type t = Jtyp_layout of Layouts.core_type - let of_ast_internal (feat : Feature.t) typ = match feat with + let of_ast_internal (feat : Feature.t) typ = + match feat with | Language_extension Layouts -> let typ, attrs = Layouts.of_type typ in Some (Jtyp_layout typ, attrs) @@ -1649,23 +1606,19 @@ module Core_type = struct let of_ast = Core_type.make_of_ast ~of_ast_internal let core_type_of ~loc ~attrs t = - let core_type = - match t with - | Jtyp_layout x -> Layouts.type_of ~loc x - in + let core_type = match t with Jtyp_layout x -> Layouts.type_of ~loc x in (* Performance hack: save an allocation if [attrs] is empty. *) match attrs with | [] -> core_type | _ :: _ as attrs -> - (* See Note [Outer attributes at end] *) - { core_type with ptyp_attributes = core_type.ptyp_attributes @ attrs } + (* See Note [Outer attributes at end] *) + { core_type with ptyp_attributes = core_type.ptyp_attributes @ attrs } end module Constructor_argument = struct type t = | - let of_ast_internal (feat : Feature.t) _carg = match feat with - | _ -> None + let of_ast_internal (feat : Feature.t) _carg = match feat with _ -> None let of_ast = Constructor_argument.make_of_ast ~of_ast_internal end @@ -1675,9 +1628,10 @@ module Expression = struct | Jexp_comprehension of Comprehensions.expression | Jexp_immutable_array of Immutable_arrays.expression | Jexp_layout of Layouts.expression - | Jexp_n_ary_function of N_ary_functions.expression + | Jexp_n_ary_function of N_ary_functions.expression - let of_ast_internal (feat : Feature.t) expr = match feat with + let of_ast_internal (feat : Feature.t) expr = + match feat with | Language_extension Comprehensions -> let expr, attrs = Comprehensions.comprehension_expr_of_expr expr in Some (Jexp_comprehension expr, attrs) @@ -1687,11 +1641,10 @@ module Expression = struct | Language_extension Layouts -> let expr, attrs = Layouts.of_expr expr in Some (Jexp_layout expr, attrs) - | Builtin -> begin - match N_ary_functions.of_expr expr with - | Some (expr, attrs) -> Some (Jexp_n_ary_function expr, attrs) - | None -> None - end + | Builtin -> ( + match N_ary_functions.of_expr expr with + | Some (expr, attrs) -> Some (Jexp_n_ary_function expr, attrs) + | None -> None) | _ -> None let of_ast = Expression.make_of_ast ~of_ast_internal @@ -1699,17 +1652,17 @@ module Expression = struct let expr_of ~loc ~attrs t = let expr = match t with - | Jexp_comprehension x -> Comprehensions.expr_of ~loc x + | Jexp_comprehension x -> Comprehensions.expr_of ~loc x | Jexp_immutable_array x -> Immutable_arrays.expr_of ~loc x - | Jexp_layout x -> Layouts.expr_of ~loc x - | Jexp_n_ary_function x -> N_ary_functions.expr_of ~loc x + | Jexp_layout x -> Layouts.expr_of ~loc x + | Jexp_n_ary_function x -> N_ary_functions.expr_of ~loc x in (* Performance hack: save an allocation if [attrs] is empty. *) match attrs with | [] -> expr | _ :: _ as attrs -> - (* See Note [Outer attributes at end] *) - { expr with pexp_attributes = expr.pexp_attributes @ attrs } + (* See Note [Outer attributes at end] *) + { expr with pexp_attributes = expr.pexp_attributes @ attrs } end module Pattern = struct @@ -1717,7 +1670,8 @@ module Pattern = struct | Jpat_immutable_array of Immutable_arrays.pattern | Jpat_layout of Layouts.pattern - let of_ast_internal (feat : Feature.t) pat = match feat with + let of_ast_internal (feat : Feature.t) pat = + match feat with | Language_extension Immutable_arrays -> let expr, attrs = Immutable_arrays.of_pat pat in Some (Jpat_immutable_array expr, attrs) @@ -1738,15 +1692,15 @@ module Pattern = struct match attrs with | [] -> pat | _ :: _ as attrs -> - (* See Note [Outer attributes at end] *) - { pat with ppat_attributes = pat.ppat_attributes @ attrs } + (* See Note [Outer attributes at end] *) + { pat with ppat_attributes = pat.ppat_attributes @ attrs } end module Module_type = struct - type t = - | Jmty_strengthen of Strengthen.module_type + type t = Jmty_strengthen of Strengthen.module_type - let of_ast_internal (feat : Feature.t) mty = match feat with + let of_ast_internal (feat : Feature.t) mty = + match feat with | Language_extension Module_strengthening -> let mty, attrs = Strengthen.of_mty mty in Some (Jmty_strengthen mty, attrs) @@ -1755,21 +1709,17 @@ module Module_type = struct let of_ast = Module_type.make_of_ast ~of_ast_internal let mty_of ~loc ~attrs t = - let mty = - match t with - | Jmty_strengthen x -> Strengthen.mty_of ~loc x - in + let mty = match t with Jmty_strengthen x -> Strengthen.mty_of ~loc x in (* Performance hack: save an allocation if [attrs] is empty. *) match attrs with | [] -> mty | _ :: _ as attrs -> - (* See Note [Outer attributes at end] *) - { mty with pmty_attributes = mty.pmty_attributes @ attrs } + (* See Note [Outer attributes at end] *) + { mty with pmty_attributes = mty.pmty_attributes @ attrs } end module Signature_item = struct - type t = - | Jsig_include_functor of Include_functor.signature_item + type t = Jsig_include_functor of Include_functor.signature_item let of_ast_internal (feat : Feature.t) sigi = match feat with @@ -1781,8 +1731,7 @@ module Signature_item = struct end module Structure_item = struct - type t = - | Jstr_include_functor of Include_functor.structure_item + type t = Jstr_include_functor of Include_functor.structure_item let of_ast_internal (feat : Feature.t) stri = match feat with @@ -1794,10 +1743,10 @@ module Structure_item = struct end module Extension_constructor = struct - type t = - | Jext_layout of Layouts.extension_constructor + type t = Jext_layout of Layouts.extension_constructor - let of_ast_internal (feat : Feature.t) ext = match feat with + let of_ast_internal (feat : Feature.t) ext = + match feat with | Language_extension Layouts -> let ext, attrs = Layouts.of_extension_constructor ext in Some (Jext_layout ext, attrs) @@ -1809,12 +1758,12 @@ module Extension_constructor = struct let ext_ctor = match t with | Jext_layout lext -> - Layouts.extension_constructor_of ~loc ~name ?info ?docs lext + Layouts.extension_constructor_of ~loc ~name ?info ?docs lext in (* Performance hack: save an allocation if [attrs] is empty. *) match attrs with | [] -> ext_ctor | _ :: _ as attrs -> - (* See Note [Outer attributes at end] *) - { ext_ctor with pext_attributes = ext_ctor.pext_attributes @ attrs } + (* See Note [Outer attributes at end] *) + { ext_ctor with pext_attributes = ext_ctor.pext_attributes @ attrs } end diff --git a/parsing/jane_syntax.mli b/parsing/jane_syntax.mli index e7a014e5517..21a72c7174d 100644 --- a/parsing/jane_syntax.mli +++ b/parsing/jane_syntax.mli @@ -44,38 +44,40 @@ (** The ASTs for list and array comprehensions *) module Comprehensions : sig type iterator = - | Range of { start : Parsetree.expression - ; stop : Parsetree.expression - ; direction : Asttypes.direction_flag } - (** "= START to STOP" (direction = Upto) + | Range of + { start : Parsetree.expression; + stop : Parsetree.expression; + direction : Asttypes.direction_flag + } + (** "= START to STOP" (direction = Upto) "= START downto STOP" (direction = Downto) *) - | In of Parsetree.expression - (** "in EXPR" *) + | In of Parsetree.expression (** "in EXPR" *) (* In [Typedtree], the [pattern] moves into the [iterator]. *) + + (** [@...] PAT (in/=) ... *) type clause_binding = - { pattern : Parsetree.pattern - ; iterator : iterator - ; attributes : Parsetree.attribute list } - (** [@...] PAT (in/=) ... *) + { pattern : Parsetree.pattern; + iterator : iterator; + attributes : Parsetree.attribute list + } type clause = | For of clause_binding list - (** "for PAT (in/=) ... and PAT (in/=) ... and ..."; must be nonempty *) - | When of Parsetree.expression - (** "when EXPR" *) + (** "for PAT (in/=) ... and PAT (in/=) ... and ..."; must be nonempty *) + | When of Parsetree.expression (** "when EXPR" *) type comprehension = - { body : Parsetree.expression - (** The body/generator of the comprehension *) - ; clauses : clause list - (** The clauses of the comprehension; must be nonempty *) } + { body : Parsetree.expression; + (** The body/generator of the comprehension *) + clauses : clause list + (** The clauses of the comprehension; must be nonempty *) + } type expression = - | Cexp_list_comprehension of comprehension - (** [BODY ...CLAUSES...] *) + | Cexp_list_comprehension of comprehension (** [BODY ...CLAUSES...] *) | Cexp_array_comprehension of Asttypes.mutable_flag * comprehension - (** [|BODY ...CLAUSES...|] (flag = Mutable) + (** [|BODY ...CLAUSES...|] (flag = Mutable) [:BODY ...CLAUSES...:] (flag = Immutable) (only allowed with [-extension immutable_arrays]) *) @@ -88,18 +90,17 @@ end module Immutable_arrays : sig type expression = | Iaexp_immutable_array of Parsetree.expression list - (** [: E1; ...; En :] *) + (** [: E1; ...; En :] *) type pattern = - | Iapat_immutable_array of Parsetree.pattern list - (** [: P1; ...; Pn :] **) + | Iapat_immutable_array of Parsetree.pattern list (** [: P1; ...; Pn :] **) val expr_of : loc:Location.t -> expression -> Parsetree.expression + val pat_of : loc:Location.t -> pattern -> Parsetree.pattern end module N_ary_functions : sig - (** These types use the [P] prefix to match how they are represented in the upstream compiler *) @@ -107,7 +108,7 @@ module N_ary_functions : sig type function_body = | Pfunction_body of Parsetree.expression | Pfunction_cases of Parsetree.case list * Location.t * Parsetree.attributes - (** In [Pfunction_cases (_, loc, attrs)], the location extends from the + (** In [Pfunction_cases (_, loc, attrs)], the location extends from the start of the [function] keyword to the end of the last case. The compiler will only use typechecking-related attributes from [attrs], e.g. enabling or disabling a warning. @@ -116,7 +117,7 @@ module N_ary_functions : sig type function_param_desc = | Pparam_val of Asttypes.arg_label * Parsetree.expression option * Parsetree.pattern - (** [Pparam_val (lbl, exp0, P)] represents the parameter: + (** [Pparam_val (lbl, exp0, P)] represents the parameter: - [P] when [lbl] is {{!Asttypes.arg_label.Nolabel}[Nolabel]} and [exp0] is [None] @@ -135,7 +136,7 @@ module N_ary_functions : sig *) | Pparam_newtype of string Asttypes.loc * Jane_asttypes.layout_annotation option - (** [Pparam_newtype (x, layout)] represents the parameter [(type x)]. + (** [Pparam_newtype (x, layout)] represents the parameter [(type x)]. [x] carries the location of the identifier, whereas [pparam_loc] is the location of the [(type x)] as a whole. @@ -156,8 +157,8 @@ module N_ary_functions : sig *) type function_param = - { pparam_desc : function_param_desc - ; pparam_loc : Location.t + { pparam_desc : function_param_desc; + pparam_loc : Location.t } type type_constraint = @@ -174,8 +175,8 @@ module N_ary_functions : sig | Once type function_constraint = - { mode_annotations: mode_annotation Location.loc list; - type_constraint: type_constraint; + { mode_annotations : mode_annotation Location.loc list; + type_constraint : type_constraint } (** [([P1; ...; Pn], C, body)] represents any construct @@ -202,20 +203,21 @@ end these into the existing [P{sig,str}_include] constructors (similar to what we did with [T{sig,str}_include], but without depending on typechecking). *) module Include_functor : sig - type signature_item = - | Ifsig_include_functor of Parsetree.include_description + type signature_item = Ifsig_include_functor of Parsetree.include_description - type structure_item = - | Ifstr_include_functor of Parsetree.include_declaration + type structure_item = Ifstr_include_functor of Parsetree.include_declaration val sig_item_of : loc:Location.t -> signature_item -> Parsetree.signature_item + val str_item_of : loc:Location.t -> structure_item -> Parsetree.structure_item end (** The ASTs for module type strengthening. *) module Strengthen : sig type module_type = - { mty : Parsetree.module_type; mod_id : Longident.t Location.loc } + { mty : Parsetree.module_type; + mod_id : Longident.t Location.loc + } val mty_of : loc:Location.t -> module_type -> Parsetree.module_type end @@ -230,13 +232,12 @@ module Layouts : sig (* examples: [ #2.0 ] or [ #42L ] *) (* This is represented as an attribute wrapping a [Pexp_constant] node. *) | Lexp_constant of constant - (* [fun (type a : immediate) -> ...] *) (* This is represented as an attribute wrapping a [Pexp_newtype] node. *) | Lexp_newtype of - string Location.loc * - Jane_asttypes.layout_annotation * - Parsetree.expression + string Location.loc + * Jane_asttypes.layout_annotation + * Parsetree.expression type nonrec pattern = (* examples: [ #2.0 ] or [ #42L ] *) @@ -247,9 +248,10 @@ module Layouts : sig (* ['a : immediate] or [_ : float64] *) (* This is represented by an attribute wrapping either a [Ptyp_any] or a [Ptyp_var] node. *) - | Ltyp_var of { name : string option - ; layout : Jane_asttypes.layout_annotation } - + | Ltyp_var of + { name : string option; + layout : Jane_asttypes.layout_annotation + } (* [('a : immediate) 'b 'c ('d : value). 'a -> 'b -> 'c -> 'd] *) (* This is represented by an attribute wrapping a [Ptyp_poly] node. *) (* This is used instead of [Ptyp_poly] only where there is at least one @@ -257,17 +259,20 @@ module Layouts : sig annotations at all, [Ptyp_poly] is used instead. This saves space in the parsed representation and guarantees that we don't accidentally try to require the layouts extension. *) - | Ltyp_poly of { bound_vars : (string Location.loc * - Jane_asttypes.layout_annotation option) list - ; inner_type : Parsetree.core_type } - + | Ltyp_poly of + { bound_vars : + (string Location.loc * Jane_asttypes.layout_annotation option) list; + inner_type : Parsetree.core_type + } (* [ty as ('a : immediate)] *) (* This is represented by an attribute wrapping either a [Ptyp_alias] node or, in the [ty as (_ : layout)] case, the annotated type itself, with no intervening [type_desc]. *) - | Ltyp_alias of { aliased_type : Parsetree.core_type - ; name : string option - ; layout : Jane_asttypes.layout_annotation } + | Ltyp_alias of + { aliased_type : Parsetree.core_type; + name : string option; + layout : Jane_asttypes.layout_annotation + } type nonrec extension_constructor = (* [ 'a ('b : immediate) ('c : float64). 'a * 'b * 'c -> exception ] *) @@ -275,13 +280,12 @@ module Layouts : sig (* Like [Ltyp_poly], this is used only when there is at least one layout annotation. Otherwise, we will have a [Pext_decl]. *) | Lext_decl of - (string Location.loc * Jane_asttypes.layout_annotation option) list * - Parsetree.constructor_arguments * - Parsetree.core_type option + (string Location.loc * Jane_asttypes.layout_annotation option) list + * Parsetree.constructor_arguments + * Parsetree.core_type option module Pprint : sig - val const_layout : - Format.formatter -> Jane_asttypes.const_layout -> unit + val const_layout : Format.formatter -> Jane_asttypes.const_layout -> unit val layout_annotation : Format.formatter -> Jane_asttypes.layout_annotation -> unit @@ -304,11 +308,15 @@ module Layouts : sig (** See also [Ast_helper.Type.constructor], which is a direct inspiration for the interface here. It's meant to be able to be a drop-in replacement. *) val constructor_declaration_of : - loc:Location.t -> attrs:Parsetree.attributes -> info:Docstrings.info -> - vars_layouts:(string Location.loc * - Jane_asttypes.layout_annotation option) list -> - args:Parsetree.constructor_arguments -> res:Parsetree.core_type option -> - string Location.loc -> Parsetree.constructor_declaration + loc:Location.t -> + attrs:Parsetree.attributes -> + info:Docstrings.info -> + vars_layouts: + (string Location.loc * Jane_asttypes.layout_annotation option) list -> + args:Parsetree.constructor_arguments -> + res:Parsetree.core_type option -> + string Location.loc -> + Parsetree.constructor_declaration (** Extract the layouts from a [constructor_declaration]; returns leftover attributes along with the annotated variables. Unlike other pieces @@ -316,8 +324,9 @@ module Layouts : sig the remaining pieces of the original [constructor_declaration]. *) val of_constructor_declaration : Parsetree.constructor_declaration -> - ((string Location.loc * Jane_asttypes.layout_annotation option) list * - Parsetree.attributes) option + ((string Location.loc * Jane_asttypes.layout_annotation option) list + * Parsetree.attributes) + option end (******************************************) @@ -398,12 +407,12 @@ end (** Novel syntax in types *) module Core_type : sig - type t = - | Jtyp_layout of Layouts.core_type + type t = Jtyp_layout of Layouts.core_type - include AST - with type t := t * Parsetree.attributes - and type ast := Parsetree.core_type + include + AST + with type t := t * Parsetree.attributes + and type ast := Parsetree.core_type val core_type_of : loc:Location.t -> attrs:Parsetree.attributes -> t -> Parsetree.core_type @@ -414,9 +423,10 @@ end module Constructor_argument : sig type t = | - include AST - with type t := t * Parsetree.attributes - and type ast := Parsetree.core_type + include + AST + with type t := t * Parsetree.attributes + and type ast := Parsetree.core_type end (** Novel syntax in expressions *) @@ -427,9 +437,10 @@ module Expression : sig | Jexp_layout of Layouts.expression | Jexp_n_ary_function of N_ary_functions.expression - include AST - with type t := t * Parsetree.attributes - and type ast := Parsetree.expression + include + AST + with type t := t * Parsetree.attributes + and type ast := Parsetree.expression val expr_of : loc:Location.t -> attrs:Parsetree.attributes -> t -> Parsetree.expression @@ -441,9 +452,10 @@ module Pattern : sig | Jpat_immutable_array of Immutable_arrays.pattern | Jpat_layout of Layouts.pattern - include AST - with type t := t * Parsetree.attributes - and type ast := Parsetree.pattern + include + AST + with type t := t * Parsetree.attributes + and type ast := Parsetree.pattern val pat_of : loc:Location.t -> attrs:Parsetree.attributes -> t -> Parsetree.pattern @@ -451,12 +463,12 @@ end (** Novel syntax in module types *) module Module_type : sig - type t = - | Jmty_strengthen of Strengthen.module_type + type t = Jmty_strengthen of Strengthen.module_type - include AST - with type t := t * Parsetree.attributes - and type ast := Parsetree.module_type + include + AST + with type t := t * Parsetree.attributes + and type ast := Parsetree.module_type val mty_of : loc:Location.t -> attrs:Parsetree.attributes -> t -> Parsetree.module_type @@ -464,30 +476,33 @@ end (** Novel syntax in signature items *) module Signature_item : sig - type t = - | Jsig_include_functor of Include_functor.signature_item + type t = Jsig_include_functor of Include_functor.signature_item include AST with type t := t and type ast := Parsetree.signature_item end (** Novel syntax in structure items *) module Structure_item : sig - type t = - | Jstr_include_functor of Include_functor.structure_item + type t = Jstr_include_functor of Include_functor.structure_item include AST with type t := t and type ast := Parsetree.structure_item end (** Novel syntax in extension constructors *) module Extension_constructor : sig - type t = - | Jext_layout of Layouts.extension_constructor + type t = Jext_layout of Layouts.extension_constructor - include AST with type t := t * Parsetree.attributes - and type ast := Parsetree.extension_constructor + include + AST + with type t := t * Parsetree.attributes + and type ast := Parsetree.extension_constructor val extension_constructor_of : - loc:Location.t -> name:string Location.loc -> attrs:Parsetree.attributes -> - ?info:Docstrings.info -> ?docs:Docstrings.docs -> t -> + loc:Location.t -> + name:string Location.loc -> + attrs:Parsetree.attributes -> + ?info:Docstrings.info -> + ?docs:Docstrings.docs -> + t -> Parsetree.extension_constructor end diff --git a/parsing/jane_syntax_parsing.ml b/parsing/jane_syntax_parsing.ml index c439e65212a..a2af5cc0e9e 100644 --- a/parsing/jane_syntax_parsing.ml +++ b/parsing/jane_syntax_parsing.ml @@ -85,9 +85,10 @@ open Parsetree *) module Language_extension = struct include Language_extension_kernel + include ( - Language_extension - : Language_extension_kernel.Language_extension_for_jane_syntax) + Language_extension : + Language_extension_kernel.Language_extension_for_jane_syntax) end (******************************************************************************) @@ -109,8 +110,9 @@ module Feature : sig val is_erasable : t -> bool end = struct - type t = Language_extension : _ Language_extension.t -> t - | Builtin + type t = + | Language_extension : _ Language_extension.t -> t + | Builtin type error = | Disabled_extension : _ Language_extension.t -> error @@ -120,25 +122,23 @@ end = struct let describe_uppercase = function | Language_extension ext -> - "The extension \"" ^ Language_extension.to_string ext ^ "\"" - | Builtin -> - "Built-in syntax" + "The extension \"" ^ Language_extension.to_string ext ^ "\"" + | Builtin -> "Built-in syntax" let extension_component = function | Language_extension ext -> Language_extension.to_string ext | Builtin -> builtin_component let of_component str = - if String.equal str builtin_component then - Ok Builtin + if String.equal str builtin_component + then Ok Builtin else match Language_extension.of_string str with | Some (Pack ext) -> - if Language_extension.is_enabled ext - then Ok (Language_extension ext) - else Error (Disabled_extension ext) - | None -> - Error (Unknown_extension str) + if Language_extension.is_enabled ext + then Ok (Language_extension ext) + else Error (Disabled_extension ext) + | None -> Error (Unknown_extension str) let is_erasable = function | Language_extension ext -> Language_extension.is_erasable ext @@ -168,10 +168,7 @@ module Embedding_syntax = struct | Attribute -> "attributes" let pp ppf (t, name) = - let sigil = match t with - | Extension_node -> "%" - | Attribute -> "@" - in + let sigil = match t with Extension_node -> "%" | Attribute -> "@" in Format.fprintf ppf "[%s%s]" sigil name end @@ -187,9 +184,8 @@ module Misnamed_embedding_error = struct | No_erasability -> "Missing erasability and feature components" | No_feature -> "Missing a feature component" | Unknown_erasability str -> - Printf.sprintf - "Unrecognized component where erasability was expected: `%s'" - str + Printf.sprintf + "Unrecognized component where erasability was expected: `%s'" str end (** The component of an attribute or extension name that identifies whether or @@ -231,7 +227,6 @@ end nodes or attributes for modular syntax; see the .mli file for more details. *) module Embedded_name : sig - (** A nonempty list of name components, without the first two components. (That is, without the leading root component that identifies it as part of the modular syntax mechanism, and without the next component that @@ -239,8 +234,8 @@ module Embedded_name : sig type components = ( :: ) of string * string list type t = - { erasability : Erasability.t - ; components : components + { erasability : Erasability.t; + components : components } (** See the mli. *) @@ -294,8 +289,8 @@ end = struct type components = ( :: ) of string * string list type t = - { erasability : Erasability.t - ; components : components + { erasability : Erasability.t; + components : components } let of_feature feature trailing_components = @@ -308,23 +303,20 @@ end = struct let components t = t.components let to_string { erasability; components = feat :: subparts } = - String.concat - separator_str + String.concat separator_str (root :: Erasability.to_string erasability :: feat :: subparts) let of_string str : (t, Misnamed_embedding_error.t) result option = match String.split_on_char separator str with - | root' :: parts when String.equal root root' -> begin - match parts with - | [] -> Some (Error No_erasability) - | [_] -> Some (Error No_feature) - | erasability :: feat :: subparts -> begin - match Erasability.of_string erasability with - | Ok erasability -> - Some (Ok { erasability; components = feat :: subparts }) - | Error () -> Some (Error (Unknown_erasability erasability)) - end - end + | root' :: parts when String.equal root root' -> ( + match parts with + | [] -> Some (Error No_erasability) + | [_] -> Some (Error No_feature) + | erasability :: feat :: subparts -> ( + match Erasability.of_string erasability with + | Ok erasability -> + Some (Ok { erasability; components = feat :: subparts }) + | Error () -> Some (Error (Unknown_erasability erasability)))) | _ :: _ | [] -> None let pp_quoted_name ppf t = Format.fprintf ppf "\"%s\"" (to_string t) @@ -338,13 +330,13 @@ module Error = struct (** An error triggered when desugaring a language extension from an OCaml AST; should always be fatal *) type error = - | Introduction_has_payload of - Embedding_syntax.t * Embedded_name.t * payload + | Introduction_has_payload of Embedding_syntax.t * Embedded_name.t * payload | Unknown_extension of Embedding_syntax.t * Erasability.t * string | Disabled_extension : - { ext : _ Language_extension.t - ; maturity : Language_extension.maturity option - } -> error + { ext : _ Language_extension.t; + maturity : Language_extension.maturity option + } + -> error | Wrong_syntactic_category of Feature.t * string | Misnamed_embedding of Misnamed_embedding_error.t * string * Embedding_syntax.t @@ -357,81 +349,65 @@ end open Error -let assert_extension_enabled - (type a) ~loc (ext : a Language_extension.t) (setting : a) - = - if not (Language_extension.is_at_least ext setting) then +let assert_extension_enabled (type a) ~loc (ext : a Language_extension.t) + (setting : a) = + if not (Language_extension.is_at_least ext setting) + then let maturity : Language_extension.maturity option = match ext with | Layouts -> Some (setting : Language_extension.maturity) | _ -> None in - raise (Error(loc, Disabled_extension { ext; maturity })) -;; + raise (Error (loc, Disabled_extension { ext; maturity })) let report_error ~loc = function | Introduction_has_payload (what, name, _payload) -> - Location.errorf - ~loc - "@[Modular syntax %s are not allowed to have a payload,@ \ - but %a does@]" - (Embedding_syntax.name_plural what) - Embedded_name.pp_quoted_name name + Location.errorf ~loc + "@[Modular syntax %s are not allowed to have a payload,@ but %a does@]" + (Embedding_syntax.name_plural what) + Embedded_name.pp_quoted_name name | Unknown_extension (what, erasability, name) -> - let embedded_name = { Embedded_name.erasability; components = [name] } in - Location.errorf - ~loc - "@[Unknown extension \"%s\" referenced via@ %a %s@]" - name - Embedded_name.pp_a_term (what, embedded_name) - (Embedding_syntax.name what) - | Disabled_extension { ext; maturity } -> begin - (* CR layouts: The [maturity] special case is a bit ad-hoc, but the - layouts error message would be much worse without it. It also - would be nice to mention the language construct in the error message. - *) - match maturity with - | None -> - Location.errorf - ~loc - "The extension \"%s\" is disabled and cannot be used" - (Language_extension.to_string ext) - | Some maturity -> - Location.errorf - ~loc - "This construct requires the %s version of the extension \"%s\", \ - which is disabled and cannot be used" - (Language_extension.maturity_to_string maturity) - (Language_extension.to_string ext) - end - | Wrong_syntactic_category(feat, cat) -> - Location.errorf - ~loc - "%s cannot appear in %s" - (Feature.describe_uppercase feat) - cat + let embedded_name = { Embedded_name.erasability; components = [name] } in + Location.errorf ~loc "@[Unknown extension \"%s\" referenced via@ %a %s@]" + name Embedded_name.pp_a_term (what, embedded_name) + (Embedding_syntax.name what) + | Disabled_extension { ext; maturity } -> ( + (* CR layouts: The [maturity] special case is a bit ad-hoc, but the + layouts error message would be much worse without it. It also + would be nice to mention the language construct in the error message. + *) + match maturity with + | None -> + Location.errorf ~loc "The extension \"%s\" is disabled and cannot be used" + (Language_extension.to_string ext) + | Some maturity -> + Location.errorf ~loc + "This construct requires the %s version of the extension \"%s\", which \ + is disabled and cannot be used" + (Language_extension.maturity_to_string maturity) + (Language_extension.to_string ext)) + | Wrong_syntactic_category (feat, cat) -> + Location.errorf ~loc "%s cannot appear in %s" + (Feature.describe_uppercase feat) + cat | Misnamed_embedding (err, name, what) -> - Location.errorf - ~loc - "Cannot have %s named %a: %s" - (Embedding_syntax.name_indefinite what) - Embedding_syntax.pp (what, name) - (Misnamed_embedding_error.to_string err) - | Bad_introduction(what, ({ components = ext :: _; _ } as name)) -> - Location.errorf - ~loc - "@[The extension \"%s\" was referenced improperly; it started with@ \ - %a %s,@ not %a one@]" - ext - Embedded_name.pp_a_term (what, name) - (Embedding_syntax.name what) - Embedded_name.pp_a_term (what, { name with components = [ext] }) + Location.errorf ~loc "Cannot have %s named %a: %s" + (Embedding_syntax.name_indefinite what) + Embedding_syntax.pp (what, name) + (Misnamed_embedding_error.to_string err) + | Bad_introduction (what, ({ components = ext :: _; _ } as name)) -> + Location.errorf ~loc + "@[The extension \"%s\" was referenced improperly; it started with@ %a \ + %s,@ not %a one@]" + ext Embedded_name.pp_a_term (what, name) + (Embedding_syntax.name what) + Embedded_name.pp_a_term + (what, { name with components = [ext] }) let () = - Location.register_error_of_exn - (function - | Error(loc, err) -> Some (report_error ~loc err) - | _ -> None) + Location.register_error_of_exn (function + | Error (loc, err) -> Some (report_error ~loc err) + | _ -> None) (******************************************************************************) (** Generically find and create the OCaml AST syntax used to encode one of our @@ -465,8 +441,7 @@ module type AST_internal = sig val embedding_syntax : Embedding_syntax.t - val make_jane_syntax : - Embedded_name.t -> ?payload:payload -> ast -> ast + val make_jane_syntax : Embedded_name.t -> ?payload:payload -> ast -> ast (** Given an AST node, check if it's a representation of a term from one of our novel syntactic features; if it is, split it back up into its name, @@ -486,7 +461,8 @@ let parse_embedding_exn ~loc ~name ~embedding_syntax = let raise_error err = raise (Error (loc, err)) in match Embedded_name.of_string name with | Some (Ok name) -> Some name - | Some (Error err) -> raise_error (Misnamed_embedding (err, name, embedding_syntax)) + | Some (Error err) -> + raise_error (Misnamed_embedding (err, name, embedding_syntax)) | None -> None let find_and_remove_jane_syntax_attribute = @@ -494,113 +470,98 @@ let find_and_remove_jane_syntax_attribute = let rec loop ~rev_prefix ~suffix = match rev_prefix with | [] -> None - | attr :: rev_prefix -> - let { attr_name = { txt = name; loc = attr_loc }; attr_payload } = - attr - in - begin - match - parse_embedding_exn ~loc:attr_loc ~name ~embedding_syntax:Attribute - with - | None -> loop ~rev_prefix ~suffix:(attr :: suffix) - | Some name -> - let unconsumed_attributes = List.rev_append rev_prefix suffix in - Some (name, attr_loc, attr_payload, unconsumed_attributes) - end + | attr :: rev_prefix -> ( + let { attr_name = { txt = name; loc = attr_loc }; attr_payload } = attr in + match + parse_embedding_exn ~loc:attr_loc ~name ~embedding_syntax:Attribute + with + | None -> loop ~rev_prefix ~suffix:(attr :: suffix) + | Some name -> + let unconsumed_attributes = List.rev_append rev_prefix suffix in + Some (name, attr_loc, attr_payload, unconsumed_attributes)) in fun attributes -> loop ~rev_prefix:(List.rev attributes) ~suffix:[] -;; let make_jane_syntax_attribute name payload = { attr_name = - { txt = Embedded_name.to_string name - ; loc = !Ast_helper.default_loc - } - ; attr_loc = !Ast_helper.default_loc - ; attr_payload = payload + { txt = Embedded_name.to_string name; loc = !Ast_helper.default_loc }; + attr_loc = !Ast_helper.default_loc; + attr_payload = payload } (** For a syntactic category, produce translations into and out of our novel syntax, using parsetree attributes as the encoding. *) -module Make_with_attribute - (AST_syntactic_category : sig - include AST_syntactic_category +module Make_with_attribute (AST_syntactic_category : sig + include AST_syntactic_category - val attributes : ast -> attributes - val with_attributes : ast -> attributes -> ast - end) : AST_internal with type ast = AST_syntactic_category.ast -= struct - include AST_syntactic_category + val attributes : ast -> attributes - let embedding_syntax = Embedding_syntax.Attribute + val with_attributes : ast -> attributes -> ast +end) : AST_internal with type ast = AST_syntactic_category.ast = struct + include AST_syntactic_category - let make_jane_syntax name ?(payload = PStr []) ast = - let attr = make_jane_syntax_attribute name payload in - (* See Note [Outer attributes at end] in jane_syntax.ml *) - with_attributes ast (attributes ast @ [ attr ]) + let embedding_syntax = Embedding_syntax.Attribute - let match_jane_syntax ast = - match find_and_remove_jane_syntax_attribute (attributes ast) with - | None -> None - | Some (name, loc, payload, attrs) -> - Some (name, loc, payload, with_attributes ast attrs) + let make_jane_syntax name ?(payload = PStr []) ast = + let attr = make_jane_syntax_attribute name payload in + (* See Note [Outer attributes at end] in jane_syntax.ml *) + with_attributes ast (attributes ast @ [attr]) + + let match_jane_syntax ast = + match find_and_remove_jane_syntax_attribute (attributes ast) with + | None -> None + | Some (name, loc, payload, attrs) -> + Some (name, loc, payload, with_attributes ast attrs) end (** For a syntactic category, produce translations into and out of our novel syntax, using extension nodes as the encoding. *) -module Make_with_extension_node - (AST_syntactic_category : sig - include AST_syntactic_category +module Make_with_extension_node (AST_syntactic_category : sig + include AST_syntactic_category - (** How to construct an extension node for this AST (something of the + (** How to construct an extension node for this AST (something of the shape [[%name]]). Should just be [Ast_helper.CAT.extension] for the appropriate syntactic category [CAT]. (This means that [?loc] should default to [!Ast_helper.default_loc.].) *) - val make_extension_node : - ?loc:Location.t -> ?attrs:attributes -> extension -> ast + val make_extension_node : + ?loc:Location.t -> ?attrs:attributes -> extension -> ast - (** Given an extension node (as created by [make_extension_node]) with an + (** Given an extension node (as created by [make_extension_node]) with an appropriately-formed name and a body, combine them into the special syntactic form we use for novel syntactic features in this syntactic category. Partial inverse of [match_extension_use]. *) - val make_extension_use : extension_node:ast -> ast -> ast + val make_extension_use : extension_node:ast -> ast -> ast - (** Given an AST node, check if it's of the special syntactic form + (** Given an AST node, check if it's of the special syntactic form indicating that this is one of our novel syntactic features (as created by [make_extension_node]), split it back up into the extension node and the possible body. Doesn't do any checking about the name/format of the extension or the possible body terms (for which see [AST.match_extension]). Partial inverse of [make_extension_use]. *) - val match_extension_use : ast -> (extension * ast) option - end) : AST_internal with type ast = AST_syntactic_category.ast = - struct - include AST_syntactic_category - - let embedding_syntax = Embedding_syntax.Extension_node - - let make_jane_syntax name ?(payload = PStr []) ast = - make_extension_use - ast - ~extension_node: - (make_extension_node - ({ txt = Embedded_name.to_string name - ; loc = !Ast_helper.default_loc }, - payload)) - - let match_jane_syntax ast = - match match_extension_use ast with + val match_extension_use : ast -> (extension * ast) option +end) : AST_internal with type ast = AST_syntactic_category.ast = struct + include AST_syntactic_category + + let embedding_syntax = Embedding_syntax.Extension_node + + let make_jane_syntax name ?(payload = PStr []) ast = + make_extension_use ast + ~extension_node: + (make_extension_node + ( { txt = Embedded_name.to_string name; + loc = !Ast_helper.default_loc + }, + payload )) + + let match_jane_syntax ast = + match match_extension_use ast with + | None -> None + | Some (({ txt = name; loc = ext_loc }, ext_payload), body) -> ( + match parse_embedding_exn ~loc:ext_loc ~name ~embedding_syntax with | None -> None - | Some (({txt = name; loc = ext_loc}, ext_payload), body) -> - match - parse_embedding_exn - ~loc:ext_loc - ~name - ~embedding_syntax - with - | None -> None - | Some name -> Some (name, ext_loc, ext_payload, body) + | Some name -> Some (name, ext_loc, ext_payload, body)) end (********************************************************) @@ -623,17 +584,19 @@ module Type_AST_syntactic_category = struct (* Missing [plural] *) let location typ = typ.ptyp_loc + let with_location typ l = { typ with ptyp_loc = l } let attributes typ = typ.ptyp_attributes + let with_attributes typ ptyp_attributes = { typ with ptyp_attributes } end (** Types; embedded with attributes. *) module Core_type0 = Make_with_attribute (struct - include Type_AST_syntactic_category + include Type_AST_syntactic_category - let plural = "types" + let plural = "types" end) (** Constructor arguments; the same as types, but used in fewer places *) @@ -648,10 +611,13 @@ module Expression0 = Make_with_attribute (struct type ast = expression let plural = "expressions" + let location expr = expr.pexp_loc + let with_location expr l = { expr with pexp_loc = l } let attributes expr = expr.pexp_attributes + let with_attributes expr pexp_attributes = { expr with pexp_attributes } end) @@ -660,35 +626,44 @@ module Pattern0 = Make_with_attribute (struct type ast = pattern let plural = "patterns" + let location pat = pat.ppat_loc + let with_location pat l = { pat with ppat_loc = l } let attributes pat = pat.ppat_attributes + let with_attributes pat ppat_attributes = { pat with ppat_attributes } end) (** Module types; embedded using an attribute on the module type. *) module Module_type0 = Make_with_attribute (struct - type ast = module_type + type ast = module_type + + let plural = "module types" + + let location mty = mty.pmty_loc - let plural = "module types" - let location mty = mty.pmty_loc - let with_location mty l = { mty with pmty_loc = l } + let with_location mty l = { mty with pmty_loc = l } - let attributes mty = mty.pmty_attributes - let with_attributes mty pmty_attributes = { mty with pmty_attributes } + let attributes mty = mty.pmty_attributes + + let with_attributes mty pmty_attributes = { mty with pmty_attributes } end) (** Extension constructors; embedded using an attribute. *) module Extension_constructor0 = Make_with_attribute (struct - type ast = extension_constructor + type ast = extension_constructor + + let plural = "extension constructors" + + let location ext = ext.pext_loc + + let with_location ext l = { ext with pext_loc = l } - let plural = "extension constructors" - let location ext = ext.pext_loc - let with_location ext l = { ext with pext_loc = l } + let attributes ext = ext.pext_attributes - let attributes ext = ext.pext_attributes - let with_attributes ext pext_attributes = { ext with pext_attributes } + let with_attributes ext pext_attributes = { ext with pext_attributes } end) (** Signature items; embedded as @@ -696,34 +671,36 @@ end) attributes or we'd use them instead. *) module Signature_item0 = Make_with_extension_node (struct - type ast = signature_item - - let plural = "signature items" - - let location sigi = sigi.psig_loc - let with_location sigi l = { sigi with psig_loc = l } - - let make_extension_node = Ast_helper.Sig.extension - - let make_extension_use ~extension_node sigi = - Ast_helper.Sig.include_ - { pincl_mod = Ast_helper.Mty.signature [extension_node; sigi] - ; pincl_loc = !Ast_helper.default_loc - ; pincl_attributes = [] } - - let match_extension_use sigi = - match sigi.psig_desc with - | Psig_include - { pincl_mod = - { pmty_desc = - Pmty_signature - [ { psig_desc = Psig_extension (ext, []); _ } - ; sigi ] - ; _} - ; _} - -> - Some (ext, sigi) - | _ -> None + type ast = signature_item + + let plural = "signature items" + + let location sigi = sigi.psig_loc + + let with_location sigi l = { sigi with psig_loc = l } + + let make_extension_node = Ast_helper.Sig.extension + + let make_extension_use ~extension_node sigi = + Ast_helper.Sig.include_ + { pincl_mod = Ast_helper.Mty.signature [extension_node; sigi]; + pincl_loc = !Ast_helper.default_loc; + pincl_attributes = [] + } + + let match_extension_use sigi = + match sigi.psig_desc with + | Psig_include + { pincl_mod = + { pmty_desc = + Pmty_signature + [{ psig_desc = Psig_extension (ext, []); _ }; sigi]; + _ + }; + _ + } -> + Some (ext, sigi) + | _ -> None end) (** Structure items; embedded as @@ -731,46 +708,50 @@ end) have attributes or we'd use them instead. *) module Structure_item0 = Make_with_extension_node (struct - type ast = structure_item - - let plural = "structure items" - - let location stri = stri.pstr_loc - let with_location stri l = { stri with pstr_loc = l } - - let make_extension_node = Ast_helper.Str.extension - - let make_extension_use ~extension_node stri = - Ast_helper.Str.include_ - { pincl_mod = Ast_helper.Mod.structure [extension_node; stri] - ; pincl_loc = !Ast_helper.default_loc - ; pincl_attributes = [] } - - let match_extension_use stri = - match stri.pstr_desc with - | Pstr_include - { pincl_mod = - { pmod_desc = - Pmod_structure - [ { pstr_desc = Pstr_extension (ext, []); _ } - ; stri ] - ; _} - ; _} - -> - Some (ext, stri) - | _ -> None -end) + type ast = structure_item + + let plural = "structure items" + + let location stri = stri.pstr_loc + + let with_location stri l = { stri with pstr_loc = l } + let make_extension_node = Ast_helper.Str.extension + + let make_extension_use ~extension_node stri = + Ast_helper.Str.include_ + { pincl_mod = Ast_helper.Mod.structure [extension_node; stri]; + pincl_loc = !Ast_helper.default_loc; + pincl_attributes = [] + } + + let match_extension_use stri = + match stri.pstr_desc with + | Pstr_include + { pincl_mod = + { pmod_desc = + Pmod_structure + [{ pstr_desc = Pstr_extension (ext, []); _ }; stri]; + _ + }; + _ + } -> + Some (ext, stri) + | _ -> None +end) (** Constructor declarations; embedded with attributes. *) -module Constructor_declaration0 = Make_with_attribute(struct +module Constructor_declaration0 = Make_with_attribute (struct type ast = Parsetree.constructor_declaration let plural = "constructor declarations" + let location pcd = pcd.pcd_loc + let with_location pcd loc = { pcd with pcd_loc = loc } let attributes pcd = pcd.pcd_attributes + let with_attributes pcd pcd_attributes = { pcd with pcd_attributes } end) @@ -782,10 +763,12 @@ module type AST = sig val make_jane_syntax : Feature.t -> string list -> ?payload:payload -> ast -> ast + val make_entire_jane_syntax : loc:Location.t -> Feature.t -> (unit -> ast) -> ast + val make_of_ast : - of_ast_internal:(Feature.t -> ast -> 'a option) -> (ast -> 'a option) + of_ast_internal:(Feature.t -> ast -> 'a option) -> ast -> 'a option end (* See Note [Hiding internal details] *) @@ -795,8 +778,7 @@ module Make_ast (AST : AST_internal) : AST with type ast = AST.ast = struct let make_jane_syntax feature trailing_components ?payload ast = AST.make_jane_syntax (Embedded_name.of_feature feature trailing_components) - ?payload - ast + ?payload ast let make_entire_jane_syntax ~loc feature ast = AST.with_location @@ -804,7 +786,7 @@ module Make_ast (AST : AST_internal) : AST with type ast = AST.ast = struct [jane_syntax_parsing.ml] to build with the upstream compiler; see Note [Buildable with upstream] in jane_syntax.mli for details. *) (Ast_helper.with_default_loc { loc with loc_ghost = true } (fun () -> - make_jane_syntax feature [] (ast ()))) + make_jane_syntax feature [] (ast ()))) loc (** Generically lift our custom ASTs for our novel syntax from OCaml ASTs. *) @@ -813,29 +795,32 @@ module Make_ast (AST : AST_internal) : AST with type ast = AST.ast = struct let loc = AST.location ast in let raise_error loc err = raise (Error (loc, err)) in match AST.match_jane_syntax ast with - | Some ({ erasability; components = [name] } as embedded_name, syntax_loc, payload, ast) -> begin - begin match payload with - | PStr [] -> () - | _ -> raise_error syntax_loc - (Introduction_has_payload - (AST.embedding_syntax, embedded_name, payload)) - end; - match Feature.of_component name with - | Ok feat -> begin - match of_ast_internal feat ast with - | Some ext_ast -> Some ext_ast - | None -> - raise_error loc (Wrong_syntactic_category(feat, AST.plural)) - end - | Error err -> raise_error loc begin match err with + | Some + ( ({ erasability; components = [name] } as embedded_name), + syntax_loc, + payload, + ast ) -> ( + (match payload with + | PStr [] -> () + | _ -> + raise_error syntax_loc + (Introduction_has_payload + (AST.embedding_syntax, embedded_name, payload))); + match Feature.of_component name with + | Ok feat -> ( + match of_ast_internal feat ast with + | Some ext_ast -> Some ext_ast + | None -> + raise_error loc (Wrong_syntactic_category (feat, AST.plural))) + | Error err -> + raise_error loc + (match err with | Disabled_extension ext -> - Disabled_extension { ext; maturity = None } + Disabled_extension { ext; maturity = None } | Unknown_extension name -> - Unknown_extension (AST.embedding_syntax, erasability, name) - end - end - | Some ({ components = _ :: _ :: _; _ } as name, _, _, _) -> - raise_error loc (Bad_introduction(AST.embedding_syntax, name)) + Unknown_extension (AST.embedding_syntax, erasability, name))) + | Some (({ components = _ :: _ :: _; _ } as name), _, _, _) -> + raise_error loc (Bad_introduction (AST.embedding_syntax, name)) | None -> None in of_ast @@ -847,12 +832,12 @@ let make_jane_syntax_attribute feature trailing_components payload = payload (* See Note [Hiding internal details] *) -module Expression = Make_ast(Expression0) -module Pattern = Make_ast(Pattern0) -module Module_type = Make_ast(Module_type0) -module Signature_item = Make_ast(Signature_item0) -module Structure_item = Make_ast(Structure_item0) -module Core_type = Make_ast(Core_type0) -module Constructor_argument = Make_ast(Constructor_argument0) -module Extension_constructor = Make_ast(Extension_constructor0) -module Constructor_declaration = Make_ast(Constructor_declaration0) +module Expression = Make_ast (Expression0) +module Pattern = Make_ast (Pattern0) +module Module_type = Make_ast (Module_type0) +module Signature_item = Make_ast (Signature_item0) +module Structure_item = Make_ast (Structure_item0) +module Core_type = Make_ast (Core_type0) +module Constructor_argument = Make_ast (Constructor_argument0) +module Extension_constructor = Make_ast (Extension_constructor0) +module Constructor_declaration = Make_ast (Constructor_declaration0) diff --git a/parsing/jane_syntax_parsing.mli b/parsing/jane_syntax_parsing.mli index 43f73ffed0b..b67ba98864c 100644 --- a/parsing/jane_syntax_parsing.mli +++ b/parsing/jane_syntax_parsing.mli @@ -110,7 +110,6 @@ end also why we don't expose any functions for rendering or parsing these names; that's all handled internally. *) module Embedded_name : sig - (** A nonempty list of name components, without the first two components. (That is, without the leading root component that identifies it as part of the modular syntax mechanism, and without the next component that @@ -150,12 +149,8 @@ module type AST = sig given name (in the [Feature.t]) and body (the [ast]). Any locations in the generated AST will be set to [!Ast_helper.default_loc], which should be [ghost]. *) - val make_jane_syntax - : Feature.t - -> string list - -> ?payload:Parsetree.payload - -> ast - -> ast + val make_jane_syntax : + Feature.t -> string list -> ?payload:Parsetree.payload -> ast -> ast (** As [make_jane_syntax], but specifically for the AST node corresponding to the entire piece of novel syntax (e.g., for a list comprehension, the @@ -163,11 +158,8 @@ module type AST = sig sets [Ast_helper.default_loc] locally to the [ghost] version of the provided location, which is why the [ast] is generated from a function call; it is during this call that the location is so set. *) - val make_entire_jane_syntax - : loc:Location.t - -> Feature.t - -> (unit -> ast) - -> ast + val make_entire_jane_syntax : + loc:Location.t -> Feature.t -> (unit -> ast) -> ast (** Build an [of_ast] function. The return value of this function should be used to implement [of_ast] in modules satisfying the signature @@ -178,9 +170,9 @@ module type AST = sig It raises an error if it finds a term from a disabled extension or if the embedding is malformed. *) - val make_of_ast - : of_ast_internal:(Feature.t -> ast -> 'a option) - (** A function to convert [Parsetree]'s AST to our novel extended one. The + val make_of_ast : + of_ast_internal:(Feature.t -> ast -> 'a option) + (** A function to convert [Parsetree]'s AST to our novel extended one. The choice of feature and the piece of syntax will both be extracted from the embedding by the first argument. @@ -189,30 +181,24 @@ module type AST = sig example: There are no pattern comprehensions, so when building the extended pattern AST, this function will return [None] if it spots an embedding that claims to be from [Language_extension Comprehensions].) - *) - -> (ast -> 'a option) + *) -> + ast -> + 'a option end -module Expression : - AST with type ast = Parsetree.expression +module Expression : AST with type ast = Parsetree.expression -module Pattern : - AST with type ast = Parsetree.pattern +module Pattern : AST with type ast = Parsetree.pattern -module Module_type : - AST with type ast = Parsetree.module_type +module Module_type : AST with type ast = Parsetree.module_type -module Signature_item : - AST with type ast = Parsetree.signature_item +module Signature_item : AST with type ast = Parsetree.signature_item -module Structure_item : - AST with type ast = Parsetree.structure_item +module Structure_item : AST with type ast = Parsetree.structure_item -module Core_type : - AST with type ast = Parsetree.core_type +module Core_type : AST with type ast = Parsetree.core_type -module Constructor_argument : - AST with type ast = Parsetree.core_type +module Constructor_argument : AST with type ast = Parsetree.core_type module Extension_constructor : AST with type ast = Parsetree.extension_constructor @@ -239,6 +225,7 @@ val assert_extension_enabled : approach for now, but we could revisit this decision if we use it more often. *) + (** Extracts the last attribute (in list order) that was inserted by the Jane Syntax framework, and returns the rest of the attributes in the same relative order as was input, along with the location of the removed @@ -250,8 +237,8 @@ val assert_extension_enabled : *) val find_and_remove_jane_syntax_attribute : Parsetree.attributes -> - (Embedded_name.t * Location.t * - Parsetree.payload * Parsetree.attributes) option + (Embedded_name.t * Location.t * Parsetree.payload * Parsetree.attributes) + option (** Creates an attribute used for encoding syntax from the given [Feature.t] *) val make_jane_syntax_attribute : diff --git a/utils/.ocamlformat-enable b/utils/.ocamlformat-enable index dc0bce1feed..330a26761ec 100644 --- a/utils/.ocamlformat-enable +++ b/utils/.ocamlformat-enable @@ -2,3 +2,5 @@ compilation_unit.ml compilation_unit.mli import_info.ml import_info.mli +language_extension.ml +language_extension.mli diff --git a/utils/language_extension.ml b/utils/language_extension.ml index b657ccdcc5c..cdab91ce9c1 100644 --- a/utils/language_extension.ml +++ b/utils/language_extension.ml @@ -3,37 +3,47 @@ include Language_extension_kernel (* 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 module Unit = struct type t = unit + let compare = Unit.compare + let max _ _ = () + let max_value = () + let all = [()] + let to_command_line_suffix () = "" end module Maturity = struct - type t = maturity = Stable | Beta | Alpha + type t = maturity = + | Stable + | Beta + | Alpha let compare t1 t2 = - let rank = function - | Stable -> 1 - | Beta -> 2 - | Alpha -> 3 - in + 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 all = [Stable; Beta; Alpha] let to_command_line_suffix = function | Stable -> "" @@ -54,24 +64,28 @@ let get_level_ops : type a. a t -> (module Extension_level with type t = a) = | SIMD -> (module Unit) type extn_pair = Exist_pair.t = Pair : 'a t * 'a -> extn_pair + type exist = Exist.t = Pack : _ t -> exist (**********************************) (* string conversions *) -let to_command_line_string : type a. a t -> a -> string = fun extn level -> +let to_command_line_string : type a. a t -> a -> string = + fun extn level -> let (module Ops) = get_level_ops extn in to_string extn ^ Ops.to_command_line_suffix level -let pair_of_string_exn extn_name = match pair_of_string extn_name with +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)) + raise (Arg.Bad (Printf.sprintf "Extension %s is not known" extn_name)) (************************************) (* equality *) -let equal_t (type a b) (a : a t) (b : b t) : (a, b) Misc.eq option = match a, b with +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 | Unique, Unique -> Some Refl @@ -81,8 +95,11 @@ let equal_t (type a b) (a : a t) (b : b t) : (a, b) Misc.eq option = match a, b | Module_strengthening, Module_strengthening -> Some Refl | Layouts, Layouts -> Some Refl | SIMD, SIMD -> Some Refl - | (Comprehensions | Local | Unique | Include_functor | Polymorphic_parameters | - Immutable_arrays | Module_strengthening | Layouts | SIMD), _ -> None + | ( ( Comprehensions | Local | Unique | Include_functor + | Polymorphic_parameters | Immutable_arrays | Module_strengthening + | Layouts | SIMD ), + _ ) -> + None let equal a b = Option.is_some (equal_t a b) @@ -91,7 +108,9 @@ let equal a b = Option.is_some (equal_t a b) module Universe : sig val is_allowed : 'a t -> bool + val check : 'a t -> unit + val check_maximal : unit -> unit type t = @@ -108,11 +127,7 @@ end = struct | Any let compare t1 t2 = - let rank = function - | No_extensions -> 1 - | Only_erasable -> 2 - | Any -> 3 - in + let rank = function No_extensions -> 1 | Only_erasable -> 2 | Any -> 3 in compare (rank t1) (rank t2) let universe = ref Any @@ -120,65 +135,65 @@ end = struct let compiler_options = function | No_extensions -> "flag -disable-all-extensions" | Only_erasable -> "flag -only-erasable-extensions" - | Any -> "default options" + | Any -> "default options" - let is_allowed ext = match !universe with + let is_allowed ext = + match !universe with | No_extensions -> false | Only_erasable -> is_erasable ext - | Any -> true + | Any -> true (* are _all_ extensions allowed? *) - let all_allowed () = match !universe with - | Any -> true - | No_extensions | Only_erasable -> false + 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 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) - () + 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) - () + 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; + 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: +(* Mutable state. Invariants: (1) [!extensions] contains at most one copy of each extension. - (2) Every member of [!extensions] satisfies [Universe.is_allowed]. - (For instance, [!universe = No_extensions] implies - [!extensions = []]). *) + (2) Every member of [!extensions] satisfies [Universe.is_allowed]. (For + instance, [!universe = No_extensions] implies [!extensions = []]). *) let default_extensions : extn_pair list = - [ Pair (Local, ()) - ; Pair (Include_functor, ()) - ; Pair (Polymorphic_parameters, ()) - ; Pair (Immutable_arrays, ()) - ] + [ Pair (Local, ()); + Pair (Include_functor, ()); + Pair (Polymorphic_parameters, ()); + Pair (Immutable_arrays, ()) ] + let extensions : extn_pair list ref = ref default_extensions let set_worker (type a) (extn : a t) = function @@ -188,21 +203,23 @@ let set_worker (type a) (extn : a t) = function 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 + | (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 (Pair (extn', _) : extn_pair) -> not (equal extn extn')) - !extensions + extensions + := List.filter + (fun (Pair (extn', _) : extn_pair) -> not (equal extn extn')) + !extensions + +let set extn ~enabled = set_worker extn (if enabled then Some () else None) -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 (* This is similar to [Misc.protect_refs], but we don't have values to set @@ -215,21 +232,25 @@ let with_temporary_extensions f = [only_erasable_extensions], and [disallow_extensions] inside [f], but it's not clear that it's worth the hassle *) let with_set_worker extn value f = - with_temporary_extensions (fun () -> set_worker extn value; f ()) + with_temporary_extensions (fun () -> + set_worker extn value; + f ()) 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 +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_of_string_exn extn_name = + match pair_of_string_exn extn_name with Pair (extn, _) -> disable extn -let disable_all () = - extensions := [] +let disable_all () = extensions := [] let unconditionally_enable_maximal_without_checks () = let maximal_pair (Pack extn) = @@ -246,8 +267,11 @@ let enable_maximal () = let restrict_to_erasable_extensions () = let changed = Universe.set Only_erasable in if changed - then extensions := - List.filter (fun (Pair (extn, _)) -> Universe.is_allowed extn) !extensions + then + extensions + := List.filter + (fun (Pair (extn, _)) -> Universe.is_allowed extn) + !extensions let disallow_extensions () = ignore (Universe.set No_extensions : bool); @@ -259,27 +283,27 @@ let disallow_extensions () = let is_at_least (type a) (extn : a t) (value : a) = let rec check : extn_pair list -> bool = function | [] -> false - | (Pair (e, v) :: es) -> + | 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 + | 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 + | Pair (e, _) :: _ when equal e extn -> true + | _ :: es -> check es in check !extensions let get_command_line_string_if_enabled extn = let rec find = function | [] -> None - | (Pair (e, v) :: _) when equal e extn -> Some (to_command_line_string e v) - | (_ :: es) -> find es + | Pair (e, v) :: _ when equal e extn -> Some (to_command_line_string e v) + | _ :: es -> find es in find !extensions @@ -293,14 +317,11 @@ module Exist = struct let (module Ops) = get_level_ops extn in List.map (to_command_line_string extn) Ops.all - let to_string : t -> string = function - | Pack extn -> to_string extn + let to_string : t -> string = function Pack extn -> to_string extn - let is_enabled : t -> bool = function - | Pack extn -> is_enabled extn + let is_enabled : t -> bool = function Pack extn -> is_enabled extn - let is_erasable : t -> bool = function - | Pack extn -> is_erasable extn + let is_erasable : t -> bool = function Pack extn -> is_erasable extn end (********************************************) @@ -309,23 +330,25 @@ end module For_pprintast = struct type printer_exporter = { print_with_maximal_extensions : - 'a. (Format.formatter -> 'a -> unit) -> (Format.formatter -> 'a -> unit) + 'a. (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a -> unit } let can_still_define_printers = ref true let make_printer_exporter () = - if !can_still_define_printers then begin + if !can_still_define_printers + then ( can_still_define_printers := false; - { print_with_maximal_extensions = fun pp fmt item -> - with_temporary_extensions (fun () -> - (* It's safe to call this here without validating that the - extensions are enabled, because the [Pprintast] printers should - always print Jane syntax. *) - unconditionally_enable_maximal_without_checks (); - pp fmt item) - } - end else + { print_with_maximal_extensions = + (fun pp fmt item -> + with_temporary_extensions (fun () -> + (* It's safe to call this here without validating that the + extensions are enabled, because the [Pprintast] printers + should always print Jane syntax. *) + unconditionally_enable_maximal_without_checks (); + pp fmt item)) + }) + else Misc.fatal_error "Only Pprintast may use [Language_extension.For_pprintast]" end diff --git a/utils/language_extension.mli b/utils/language_extension.mli index bd7669c0338..02b23ceb404 100644 --- a/utils/language_extension.mli +++ b/utils/language_extension.mli @@ -3,7 +3,10 @@ *) (** A setting for extensions that track multiple maturity levels *) -type maturity = Language_extension_kernel.maturity = Stable | Beta | Alpha +type maturity = Language_extension_kernel.maturity = + | Stable + | Beta + | Alpha (** 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 @@ -21,13 +24,16 @@ type 'a t = 'a Language_extension_kernel.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 = Language_extension_kernel.Exist.t = - | Pack : 'a extn -> t + type 'a extn = 'a t + (* this is removed from the sig by the [with] below; ocamldoc doesn't like + [:=] in sigs *) + + type t = Language_extension_kernel.Exist.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 @@ -35,7 +41,8 @@ module Exist : sig val to_command_line_strings : t -> string list val all : t list -end with type 'a extn := 'a t +end +with type 'a extn := 'a t (** Equality on language extensions *) val equal : 'a t -> 'b t -> bool @@ -54,7 +61,9 @@ val is_erasable : 'a t -> bool (** Print and parse language extensions; parsing is case-insensitive *) val to_string : 'a t -> string + val to_command_line_string : 'a t -> 'a -> string + val of_string : string -> Exist.t option val maturity_to_string : maturity -> string @@ -66,11 +75,14 @@ val get_command_line_string_if_enabled : 'a t -> string 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 : 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) @@ -86,7 +98,9 @@ val is_at_least : 'a t -> 'a -> bool be rolled back when the function finishes, but this behavior may change; nest multiple [with_*] functions instead. *) 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 @@ -121,7 +135,7 @@ module For_pprintast : sig trying to print syntax from disabled extensions. *) type printer_exporter = { print_with_maximal_extensions : - 'a. (Format.formatter -> 'a -> unit) -> (Format.formatter -> 'a -> unit) + 'a. (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a -> unit } (** Raises if called more than once ever. *)