diff --git a/parsing/ast_mapper.ml b/parsing/ast_mapper.ml index 0125b76a89d..d24b8298387 100644 --- a/parsing/ast_mapper.ml +++ b/parsing/ast_mapper.ml @@ -149,7 +149,7 @@ module T = struct match Jane_syntax.Core_type.of_ast typ with | Some (jtyp, attrs) -> begin let attrs = sub.attributes sub attrs in - Jane_syntax_parsing.AST.wrap_desc Core_type ~loc ~attrs @@ + Jane_syntax_parsing.Core_type.wrap_desc ~loc ~attrs @@ match sub.typ_jane_syntax sub jtyp with | _ -> . end @@ -302,7 +302,7 @@ module MT = struct match Jane_syntax.Module_type.of_ast mty with | Some (jmty, attrs) -> begin let attrs = sub.attributes sub attrs in - Jane_syntax_parsing.AST.wrap_desc Module_type ~loc ~attrs @@ + Jane_syntax_parsing.Module_type.wrap_desc ~loc ~attrs @@ match sub.module_type_jane_syntax sub jmty with | Jmty_strengthen smty -> Jane_syntax.Strengthen.mty_of ~loc smty end @@ -354,7 +354,7 @@ module MT = struct let loc = sub.location sub loc in match Jane_syntax.Signature_item.of_ast sigi with | Some jsigi -> begin - Jane_syntax_parsing.AST.wrap_desc Signature_item ~loc ~attrs:[] @@ + Jane_syntax_parsing.Signature_item.wrap_desc ~loc ~attrs:[] @@ match sub.signature_item_jane_syntax sub jsigi with | Jsig_include_functor incl -> Jane_syntax.Include_functor.sig_item_of ~loc incl @@ -434,7 +434,7 @@ module M = struct let loc = sub.location sub loc in match Jane_syntax.Structure_item.of_ast stri with | Some jstri -> begin - Jane_syntax_parsing.AST.wrap_desc Structure_item ~loc ~attrs:[] @@ + Jane_syntax_parsing.Structure_item.wrap_desc ~loc ~attrs:[] @@ match sub.structure_item_jane_syntax sub jstri with | Jstr_include_functor incl -> Jane_syntax.Include_functor.str_item_of ~loc incl @@ -512,7 +512,7 @@ module E = struct match Jane_syntax.Expression.of_ast exp with | Some (jexp, attrs) -> begin let attrs = sub.attributes sub attrs in - Jane_syntax_parsing.AST.wrap_desc Expression ~loc ~attrs @@ + Jane_syntax_parsing.Expression.wrap_desc ~loc ~attrs @@ match sub.expr_jane_syntax sub jexp with | Jexp_comprehension c -> Jane_syntax.Comprehensions.expr_of ~loc c | Jexp_immutable_array i -> Jane_syntax.Immutable_arrays.expr_of ~loc i @@ -623,7 +623,7 @@ module P = struct match Jane_syntax.Pattern.of_ast pat with | Some (jpat, attrs) -> begin let attrs = sub.attributes sub attrs in - Jane_syntax_parsing.AST.wrap_desc Pattern ~loc ~attrs @@ + Jane_syntax_parsing.Pattern.wrap_desc ~loc ~attrs @@ match sub.pat_jane_syntax sub jpat with | Jpat_immutable_array i -> Jane_syntax.Immutable_arrays.pat_of ~loc i end diff --git a/parsing/jane_syntax.ml b/parsing/jane_syntax.ml index 42cdacd18d5..eab237c6257 100644 --- a/parsing/jane_syntax.ml +++ b/parsing/jane_syntax.ml @@ -95,8 +95,8 @@ module Comprehensions = struct *) let comprehension_expr names x = - AST.wrap_desc Expression ~attrs:[] ~loc:x.pexp_loc @@ - AST.make_jane_syntax Expression feature names x + Expression.wrap_desc ~attrs:[] ~loc:x.pexp_loc @@ + Expression.make_jane_syntax feature names x (** First, we define how to go from the nice AST to the OCaml AST; this is the [expr_of_...] family of expressions, culminating in @@ -145,7 +145,7 @@ module Comprehensions = struct let expr_of ~loc cexpr = (* See Note [Wrapping with make_entire_jane_syntax] *) - AST.make_entire_jane_syntax Expression ~loc feature (fun () -> + Expression.make_entire_jane_syntax ~loc feature (fun () -> match cexpr with | Cexp_list_comprehension comp -> expr_of_comprehension ~type_:["list"] comp @@ -289,7 +289,7 @@ module Immutable_arrays = struct let expr_of ~loc = function | Iaexp_immutable_array elts -> (* See Note [Wrapping with make_entire_jane_syntax] *) - AST.make_entire_jane_syntax Expression ~loc feature (fun () -> + Expression.make_entire_jane_syntax ~loc feature (fun () -> Ast_helper.Exp.array elts) (* Returns remaining unconsumed attributes *) @@ -300,7 +300,7 @@ module Immutable_arrays = struct let pat_of ~loc = function | Iapat_immutable_array elts -> (* See Note [Wrapping with make_entire_jane_syntax] *) - AST.make_entire_jane_syntax Pattern ~loc feature (fun () -> + Pattern.make_entire_jane_syntax ~loc feature (fun () -> Ast_helper.Pat.array elts) (* Returns remaining unconsumed attributes *) @@ -322,7 +322,7 @@ module Include_functor = struct let sig_item_of ~loc = function | Ifsig_include_functor incl -> (* See Note [Wrapping with make_entire_jane_syntax] *) - AST.make_entire_jane_syntax Signature_item ~loc feature (fun () -> + Signature_item.make_entire_jane_syntax ~loc feature (fun () -> Ast_helper.Sig.include_ incl) let of_sig_item sigi = match sigi.psig_desc with @@ -332,7 +332,7 @@ module Include_functor = struct let str_item_of ~loc = function | Ifstr_include_functor incl -> (* See Note [Wrapping with make_entire_jane_syntax] *) - AST.make_entire_jane_syntax Structure_item ~loc feature (fun () -> + Structure_item.make_entire_jane_syntax ~loc feature (fun () -> Ast_helper.Str.include_ incl) let of_str_item stri = match stri.pstr_desc with @@ -353,7 +353,7 @@ module Strengthen = struct let mty_of ~loc { mty; mod_id } = (* See Note [Wrapping with make_entire_jane_syntax] *) - AST.make_entire_jane_syntax Module_type ~loc feature (fun () -> + Module_type.make_entire_jane_syntax ~loc feature (fun () -> Ast_helper.Mty.functor_ (Named (Location.mknoloc None, mty)) (Ast_helper.Mty.alias mod_id)) @@ -380,7 +380,7 @@ module Core_type = struct let of_ast_internal (feat : Feature.t) _typ = match feat with | _ -> None - let of_ast = AST.make_of_ast Core_type ~of_ast_internal + let of_ast = Core_type.make_of_ast ~of_ast_internal end module Constructor_argument = struct @@ -389,7 +389,7 @@ module Constructor_argument = struct let of_ast_internal (feat : Feature.t) _carg = match feat with | _ -> None - let of_ast = AST.make_of_ast Constructor_argument ~of_ast_internal + let of_ast = Constructor_argument.make_of_ast ~of_ast_internal end module Expression = struct @@ -406,7 +406,7 @@ module Expression = struct Some (Jexp_immutable_array expr, attrs) | _ -> None - let of_ast = AST.make_of_ast Expression ~of_ast_internal + let of_ast = Expression.make_of_ast ~of_ast_internal end module Pattern = struct @@ -419,7 +419,7 @@ module Pattern = struct Some (Jpat_immutable_array expr, attrs) | _ -> None - let of_ast = AST.make_of_ast Pattern ~of_ast_internal + let of_ast = Pattern.make_of_ast ~of_ast_internal end module Module_type = struct @@ -432,7 +432,7 @@ module Module_type = struct Some (Jmty_strengthen mty, attrs) | _ -> None - let of_ast = AST.make_of_ast Module_type ~of_ast_internal + let of_ast = Module_type.make_of_ast ~of_ast_internal end module Signature_item = struct @@ -445,7 +445,7 @@ module Signature_item = struct Some (Jsig_include_functor (Include_functor.of_sig_item sigi)) | _ -> None - let of_ast = AST.make_of_ast Signature_item ~of_ast_internal + let of_ast = Signature_item.make_of_ast ~of_ast_internal end module Structure_item = struct @@ -458,5 +458,5 @@ module Structure_item = struct Some (Jstr_include_functor (Include_functor.of_str_item stri)) | _ -> None - let of_ast = AST.make_of_ast Structure_item ~of_ast_internal + let of_ast = Structure_item.make_of_ast ~of_ast_internal end diff --git a/parsing/jane_syntax_parsing.ml b/parsing/jane_syntax_parsing.ml index db17ffb0791..3535a42df87 100644 --- a/parsing/jane_syntax_parsing.ml +++ b/parsing/jane_syntax_parsing.ml @@ -464,7 +464,7 @@ module type AST_syntactic_category = sig ?loc:Location.t -> attrs:attributes -> ast_desc -> ast end -module type AST = sig +module type AST_internal = sig include AST_syntactic_category val embedding_syntax : Embedding_syntax.t @@ -543,9 +543,9 @@ module Make_with_attribute val attributes : ast -> attributes val with_attributes : ast -> attributes -> ast end) : - AST with type ast = AST_syntactic_category.ast - and type ast_desc = - AST_syntactic_category.ast_desc With_attributes.t + AST_internal with type ast = AST_syntactic_category.ast + and type ast_desc = + AST_syntactic_category.ast_desc With_attributes.t = struct include AST_syntactic_category @@ -606,8 +606,8 @@ module Make_with_extension_node [AST.match_extension]). Partial inverse of [make_extension_use]. *) val match_extension_use : ast -> (extension * ast) option end) : - AST with type ast = AST_syntactic_category.ast - and type ast_desc = AST_syntactic_category.ast_desc = + AST_internal with type ast = AST_syntactic_category.ast + and type ast_desc = AST_syntactic_category.ast_desc = struct include AST_syntactic_category @@ -655,21 +655,21 @@ module Type_AST_syntactic_category = struct end (** Types; embedded as [[[%jane.FEATNAME] * BODY]]. *) -module Core_type = Make_with_attribute (struct +module Core_type0 = Make_with_attribute (struct include Type_AST_syntactic_category let plural = "types" end) (** Constructor arguments; the same as types, but used in fewer places *) -module Constructor_argument = Make_with_attribute (struct +module Constructor_argument0 = Make_with_attribute (struct include Type_AST_syntactic_category let plural = "constructor arguments" end) (** Expressions; embedded using an attribute on the expression. *) -module Expression = Make_with_attribute (struct +module Expression0 = Make_with_attribute (struct type ast = expression type ast_desc = expression_desc @@ -685,7 +685,7 @@ module Expression = Make_with_attribute (struct end) (** Patterns; embedded using an attribute on the pattern. *) -module Pattern = Make_with_attribute (struct +module Pattern0 = Make_with_attribute (struct type ast = pattern type ast_desc = pattern_desc @@ -701,7 +701,7 @@ module Pattern = Make_with_attribute (struct end) (** Module types; embedded using an attribute on the module type. *) -module Module_type = Make_with_attribute (struct +module Module_type0 = Make_with_attribute (struct type ast = module_type type ast_desc = module_type_desc @@ -720,7 +720,7 @@ end) [include sig [%%extension.EXTNAME];; BODY end]. Signature items don't have attributes or we'd use them instead. *) -module Signature_item = Make_with_extension_node (struct +module Signature_item0 = Make_with_extension_node (struct type ast = signature_item type ast_desc = signature_item_desc @@ -763,7 +763,7 @@ end) [include struct [%%extension.EXTNAME];; BODY end]. Structure items don't have attributes or we'd use them instead. *) -module Structure_item = Make_with_extension_node (struct +module Structure_item0 = Make_with_extension_node (struct type ast = structure_item type ast_desc = structure_item_desc @@ -803,51 +803,37 @@ module Structure_item = Make_with_extension_node (struct end) (******************************************************************************) +(* Main exports *) -module AST = struct - type (_, _) t = - | Expression : (expression, expression_desc With_attributes.t) t - | Pattern : (pattern, pattern_desc With_attributes.t) t - | Module_type : (module_type, module_type_desc With_attributes.t) t - | Signature_item : (signature_item, signature_item_desc) t - | Structure_item : (structure_item, structure_item_desc) t - | Core_type : (core_type, core_type_desc With_attributes.t) t - | Constructor_argument : (core_type, core_type_desc With_attributes.t) t - - let to_module (type ast ast_desc) (t : (ast, ast_desc) t) : - (module AST with type ast = ast and type ast_desc = ast_desc) = - match t with - | Expression -> (module Expression) - | Pattern -> (module Pattern) - | Module_type -> (module Module_type) - | Signature_item -> (module Signature_item) - | Structure_item -> (module Structure_item) - | Core_type -> (module Core_type) - | Constructor_argument -> (module Constructor_argument) - - let wrap_desc (type ast ast_desc) (t : (ast, ast_desc) t) = - let (module AST) = to_module t in - AST.wrap_desc - - let make_jane_syntax - (type ast ast_desc) - (t : (ast, ast_desc) t) - feature - trailing_components - ast - = - let (module AST) = to_module t in +module type AST = sig + type ast + type ast_desc + + val wrap_desc : + ?loc:Location.t -> attrs:Parsetree.attributes -> ast_desc -> ast + val make_jane_syntax : Feature.t -> string list -> ast -> ast_desc + val make_entire_jane_syntax : + loc:Location.t -> Feature.t -> (unit -> ast) -> ast_desc + val make_of_ast : + of_ast_internal:(Feature.t -> ast -> 'a option) -> (ast -> 'a option) +end + +module Make_ast (AST : AST_internal) : AST with type ast = AST.ast + and type ast_desc = AST.ast_desc + = struct + include AST + + let make_jane_syntax feature trailing_components ast = AST.make_jane_syntax (Embedded_name.of_feature feature trailing_components) ast - let make_entire_jane_syntax t ~loc feature ast = - make_jane_syntax t feature [] + let make_entire_jane_syntax ~loc feature ast = + make_jane_syntax feature [] (Ast_helper.with_default_loc (Location.ghostify loc) ast) (** Generically lift our custom ASTs for our novel syntax from OCaml ASTs. *) - let make_of_ast (type ast ast_desc) (t : (ast, ast_desc) t) ~of_ast_internal = - let (module AST) = to_module t in + let make_of_ast ~of_ast_internal = let of_ast ast = let loc = AST.location ast in let raise_error err = raise (Error (loc, err)) in @@ -873,3 +859,11 @@ module AST = struct in of_ast end + +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) diff --git a/parsing/jane_syntax_parsing.mli b/parsing/jane_syntax_parsing.mli index 7d6c284215d..1b933af7c19 100644 --- a/parsing/jane_syntax_parsing.mli +++ b/parsing/jane_syntax_parsing.mli @@ -148,53 +148,39 @@ module With_attributes : sig } end -(** Values that lift and lower terms from our novel syntactic - features from and to an OCaml AST type ([ast]) *) -module AST : sig - (** One [AST] value per syntactic category we currently care about; we're - adding these lazily as we need them. When you add another one, make - sure also to add special handling in [Ast_iterator] and [Ast_mapper]. - - ['ast]: The AST type (e.g., [Parsetree.expression]) - ['ast_desc]: The "AST description" type, without the location and - attributes (e.g., [Parsetree.expression_desc]) - *) - type ('ast, 'ast_desc) t = - | Expression : - (Parsetree.expression, Parsetree.expression_desc With_attributes.t) t - | Pattern : (Parsetree.pattern, Parsetree.pattern_desc With_attributes.t) t - | Module_type : - (Parsetree.module_type, Parsetree.module_type_desc With_attributes.t) t - | Signature_item : - (Parsetree.signature_item, Parsetree.signature_item_desc) t - | Structure_item : - (Parsetree.structure_item, Parsetree.structure_item_desc) t - | Core_type : - (Parsetree.core_type, Parsetree.core_type_desc With_attributes.t) t - | Constructor_argument : - (Parsetree.core_type, Parsetree.core_type_desc With_attributes.t) t +(** Each syntactic category that contains novel syntactic features has a + corresponding module of this module type. We're adding these lazily as we + need them. When you add another one, make sure also to add special handling + in [Ast_iterator] and [Ast_mapper]. + +*) +module type AST = sig + (** The AST type (e.g., [Parsetree.expression]) *) + type ast + + (** The "AST description" type, without the location and + attributes (e.g., [Parsetree.expression_desc]) *) + type ast_desc (** Turn an [ast_desc] into an [ast] by adding the appropriate metadata. When creating [ast] nodes afresh to embed our novel syntax, the location should be omitted; in this case, it will default to [!Ast_helper.default_loc], which should be [ghost]. *) val wrap_desc - : ('ast, 'ast_desc) t - -> ?loc:Location.t + : ?loc:Location.t -> attrs:Parsetree.attributes - -> 'ast_desc - -> 'ast + -> ast_desc + -> ast (** Embed a term from one of our novel syntactic features in the AST using the given name (the [Embedded_name.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 - : ('ast, 'ast_desc) t - -> Feature.t + : Feature.t -> string list - -> 'ast - -> 'ast_desc + -> ast + -> ast_desc (** 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 @@ -203,11 +189,10 @@ module AST : sig 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 - : ('ast, 'ast_desc) t - -> loc:Location.t + : loc:Location.t -> Feature.t - -> (unit -> 'ast) - -> 'ast_desc + -> (unit -> ast) + -> ast_desc (** Build an [of_ast] function. The return value of this function should be used to implement [of_ast] in modules satisfying the signature @@ -218,13 +203,8 @@ module 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 : - ('ast, _) t - (** Which syntactic category is this for? E.g., [module AST = Expression]. - ['ast] is the type of novel syntactic terms for this syntactic category, - across all syntax features. E.g., [Jane_syntax.Expression.t] - *) - -> of_ast_internal:(Feature.t -> 'ast -> 'a option) + 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. @@ -235,9 +215,37 @@ module AST : sig 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 + and type ast_desc = Parsetree.expression_desc With_attributes.t + +module Pattern : + AST with type ast = Parsetree.pattern + and type ast_desc = Parsetree.pattern_desc With_attributes.t + +module Module_type : + AST with type ast = Parsetree.module_type + and type ast_desc = Parsetree.module_type_desc With_attributes.t + +module Signature_item : + AST with type ast = Parsetree.signature_item + and type ast_desc = Parsetree.signature_item_desc + +module Structure_item : + AST with type ast = Parsetree.structure_item + and type ast_desc = Parsetree.structure_item_desc + +module Core_type : + AST with type ast = Parsetree.core_type + and type ast_desc = Parsetree.core_type_desc With_attributes.t + +module Constructor_argument : + AST with type ast = Parsetree.core_type + and type ast_desc = Parsetree.core_type_desc With_attributes.t + (** Require that an extension is enabled for at least the provided level, or else throw an exception (of an abstract type) at the provided location saying otherwise. This is intended to be used in [jane_syntax.ml] when a