flambda-backend: Provide an AST-like view of modular extension extension node names (#1362)

antalsz · web-flow · commit 9d3b5a1e9e36 · 2023-05-15T09:49:07.000-04:00
That is: if you have `[%extension.comprehensions.for.in]`, this will be
represented in OCaml as
`Extensions_parsing.Extension_node_name.("comprehensions" :: ["for"; "in"])`;
we're guaranteed to have it be nonempty, we can pass it around as a unit, and
most importantly we can change the representation in a single place (e.g., to
`[%jst.comprehensions.for.in]`, or to `[%extension'comprehensions'for'in]`,
etc.).

Some minor error changes come along as well, either around spacing (due to
printing changes) or the locations in errors that the user will never see.
diff --git a/parsing/extensions.ml b/parsing/extensions.ml
@@ -151,26 +151,27 @@ module Comprehensions = struct
 
   module Desugaring_error = struct
     type error =
-      | Non_comprehension_extension_point of string list
+      | Non_comprehension_extension_point of Extension_node_name.t
       | Non_extension
       | Bad_comprehension_extension_point of string list
       | No_clauses
 
     let report_error ~loc = function
-      | Non_comprehension_extension_point name ->
+      | Non_comprehension_extension_point ext_name ->
           Location.errorf ~loc
-            "Tried to desugar the non-comprehension extension point \
-             \"extension.%s\" as part of a comprehension expression"
-            (String.concat "." name)
+            "Tried to desugar the non-comprehension extension point %a@ \
+             as part of a comprehension expression"
+            Extension_node_name.pp_quoted_name ext_name
       | Non_extension ->
           Location.errorf ~loc
-            "Tried to desugar a non-extension expression as part of a \
-             comprehension expression"
-      | Bad_comprehension_extension_point name ->
+            "Tried to desugar a non-extension expression@ \
+             as part of a comprehension expression"
+      | Bad_comprehension_extension_point subparts ->
           Location.errorf ~loc
-            "Unknown, unexpected, or malformed comprehension extension point \
-             \"extension.comprehension.%s\""
-            (String.concat "." name)
+            "Unknown, unexpected, or malformed@ \
+             comprehension extension point %a"
+            Extension_node_name.pp_quoted_name
+            Extension_node_name.(extension_string :: subparts)
       | No_clauses ->
           Location.errorf ~loc
             "Tried to desugar a comprehension with no clauses"
@@ -191,8 +192,8 @@ module Comprehensions = struct
     | Some (comprehensions :: names, expr)
       when String.equal comprehensions extension_string ->
         names, expr
-    | Some (name, _) ->
-        Desugaring_error.raise expr (Non_comprehension_extension_point name)
+    | Some (ext_name, _) ->
+        Desugaring_error.raise expr (Non_comprehension_extension_point ext_name)
     | None ->
         Desugaring_error.raise expr Non_extension
 
diff --git a/parsing/extensions_parsing.ml b/parsing/extensions_parsing.ml
@@ -41,19 +41,100 @@
 
 open Parsetree
 
+(******************************************************************************)
+(** Collect all the extension-node-name-building machinery in one place so that
+    it can be changed all at once. *)
+
+(** An AST-style representation of the names used when generating extension
+    nodes for modular extensions; see the .mli file for more details. *)
+module Extension_node_name : sig
+  (** A nonempty list of name components, without the leading root [extension.];
+      see the .mli file for more details. *)
+  type t = ( :: ) of string * string list
+
+  (** Convert a modular extension extension node's name to the string form used
+      in the OCaml AST; not exposed. *)
+  val to_string : t -> string
+
+  (** Parse an OCaml extension node's name:
+        - [Some (Ok _)] if it's a legal modular extension name;
+        - [Some (Error ())] if it's the bare [extension]; and
+        - [None] if it doesn't start with the leading [extension].
+      Not exposed. *)
+  val of_string : string -> (t, unit) result option
+
+  (** Print out a modular extension extension node name, in quotes; for use in
+      error messages. *)
+  val pp_quoted_name : Format.formatter -> t -> unit
+
+  (** Print out an empty extension node with a modular extension name,
+      accompanied by an indefinite article; for use in error messages.  Not
+      exposed. *)
+  val pp_a_node : Format.formatter -> t -> unit
+
+  (** Print out the illegal empty quasi-modular extension extension node with no
+      name beyond [extension]; for use in error messages.  Not exposed. *)
+  val pp_bad_empty_node : Format.formatter -> unit -> unit
+end = struct
+  (** The three parameters that control how we encode modular extension
+      extension node names.  When updating these, update comments that refer to
+      them! *)
+  module Config = struct
+    (** The separator between name components *)
+    let separator = '.'
+
+    (** The leading namespace that identifies this extension point as reserved
+        for a modular extension *)
+    let root = "extension"
+
+    (** For printing purposes, the appropriate indefinite article for [root] *)
+    let article = "an"
+  end
+
+  include Config
+  let separator_str = String.make 1 separator
+
+  type t = ( :: ) of string * string list
+
+  let to_string (ext :: subparts) =
+    String.concat separator_str (root :: ext :: subparts)
+
+  let of_string str = match String.split_on_char separator str with
+    | root' :: parts when String.equal root root' -> begin
+        match parts with
+        | ext :: subparts -> Some (Ok (ext :: subparts))
+        | []              -> Some (Error ())
+      end
+    | _ :: _ | [] -> None
+
+  let pp_quoted_name ppf t = Format.fprintf ppf "\"%s\"" (to_string t)
+
+  let pp_extension_node ppf id = Format.fprintf ppf "[%%%s]" id
+
+  let pp_a_node ppf t =
+    Format.fprintf ppf "%s %a" article pp_extension_node (to_string t)
+
+  let pp_bad_empty_node ppf () = pp_extension_node ppf root
+end
+
 (******************************************************************************)
 module Error = struct
+  (** Someone used [[%extension.EXTNAME]] wrong *)
   type malformed_extension =
     | Has_payload of payload
 
+  (** An error triggered when desugaring a language extension from an OCaml
+      AST; should always be fatal *)
   type error =
-    | Malformed_extension of string list * malformed_extension
+    | Malformed_extension of Extension_node_name.t * malformed_extension
     | Unknown_extension of string
     | Disabled_extension of Language_extension.t
     | Wrong_syntactic_category of Language_extension.t * string
     | Unnamed_extension
-    | Bad_introduction of string * string list
+    | Bad_introduction of Extension_node_name.t
 
+  (** The exception type thrown when desugaring a language extension from an
+      OCaml AST *)
   exception Error of Location.t * error
 end
 
@@ -65,23 +146,21 @@ let assert_extension_enabled ~loc ext =
 ;;
 
 let report_error ~loc = function
-  | Malformed_extension(name, malformed) -> begin
-      let name = String.concat "." ("extension" :: name) in
+  | Malformed_extension(ext_name, malformed) -> begin
       match malformed with
       | Has_payload _payload ->
           Location.errorf
             ~loc
             "@[Modular extension nodes are not allowed to have a payload,@ \
-             but \"%s\" does@]"
-          name
+             but %a does@]"
+          Extension_node_name.pp_quoted_name ext_name
     end
   | Unknown_extension name ->
       Location.errorf
         ~loc
-        "@[Unknown extension \"%s\" referenced via an@ [%%extension.%s] \
-         extension node@]"
-        name
+        "@[Unknown extension \"%s\" referenced via@ %a extension node@]"
         name
+        Extension_node_name.pp_a_node Extension_node_name.[name]
   | Disabled_extension ext ->
       Location.errorf
         ~loc
@@ -96,15 +175,16 @@ let report_error ~loc = function
   | Unnamed_extension ->
       Location.errorf
         ~loc
-        "Cannot have an extension node named [%%extension]"
-  | Bad_introduction(name, subnames) ->
+        "Cannot have an extension node named %a"
+        Extension_node_name.pp_bad_empty_node ()
+  | Bad_introduction(ext :: _ as ext_name) ->
       Location.errorf
         ~loc
-        "@[The extension \"%s\" was referenced improperly; it started with an@ \
-         [%%extension.%s] extension node,@ not an [%%extension.%s] one@]"
-        name
-        (String.concat "." (name :: subnames))
-        name
+        "@[The extension \"%s\" was referenced improperly; it started with@ %a \
+         extension node,@ not %a one@]"
+        ext
+        Extension_node_name.pp_a_node ext_name
+        Extension_node_name.pp_a_node Extension_node_name.[ext]
 
 let () =
   Location.register_error_of_exn
@@ -177,19 +257,19 @@ module type AST = sig
   val wrap_desc :
     ?loc:Location.t -> attrs:Parsetree.attributes -> ast_desc -> ast
 
-  val make_extension : string list -> ast -> ast_desc
+  val make_extension : Extension_node_name.t -> ast -> ast_desc
 
   val make_entire_extension :
     loc:Location.t -> string -> (unit -> ast) -> ast_desc
 
-  val match_extension : ast -> (string list * ast) option
+  val match_extension : ast -> (Extension_node_name.t * ast) option
 end
 
 (* Some extensions written before this file existed are handled in their own
    way; this function filters them out. *)
-let uniformly_handled_extension names =
-  match names with
-  | [("local"|"global"|"nonlocal"|"escape"|"include_functor"|"curry")] -> false
+let uniformly_handled_extension name =
+  match name with
+  | "local"|"global"|"nonlocal"|"escape"|"include_functor"|"curry" -> false
   | _ -> true
 
 (** Given the [AST_parameters] for a syntactic category, produce the
@@ -201,12 +281,12 @@ module Make_AST (AST_parameters : AST_parameters) :
   struct
     include AST_parameters
 
-    let make_extension names =
+    let make_extension ext_name =
       make_extension_use
         ~extension_node:
           (make_extension_node
-             ({ txt = String.concat "." ("extension" :: names);
-                loc = !Ast_helper.default_loc },
+             ({ txt = Extension_node_name.to_string ext_name
+              ; loc = !Ast_helper.default_loc },
               PStr []))
 
     let make_entire_extension ~loc name ast =
@@ -225,16 +305,19 @@ module Make_AST (AST_parameters : AST_parameters) :
       match match_extension_use ast with
       | Some (({txt = ext_name; loc = ext_loc}, ext_payload), body) ->
         begin
-          match String.split_on_char '.' ext_name with
-          | "extension" :: names when uniformly_handled_extension names -> begin
+          let raise_error err = raise (Error(ext_loc, err)) in
+          match Extension_node_name.of_string ext_name with
+          | Some (Ok (ext :: _ as ext_name))
+            when uniformly_handled_extension ext -> begin
               let raise_malformed err =
-                raise (Error(ext_loc, Malformed_extension(names, err)))
+                raise_error (Malformed_extension(ext_name, err))
               in
               match ext_payload with
-              | PStr [] -> Some (names, body)
+              | PStr [] -> Some (ext_name, body)
               | _ -> raise_malformed (Has_payload ext_payload)
             end
-          | _ -> None
+          | Some (Error ()) -> raise_error Unnamed_extension
+          | Some (Ok (_ :: _)) | None -> None
         end
       | None -> None
 end
@@ -341,8 +424,6 @@ end = struct
           end
         | None -> raise_error (Unknown_extension name)
       end
-    | Some ([], _) ->
-        raise_error Unnamed_extension
-    | Some (name :: subnames, _) ->
-        raise_error (Bad_introduction(name, subnames))
+    | Some (_ :: _ :: _ as ext_name, _) ->
+        raise_error (Bad_introduction(ext_name))
 end
diff --git a/parsing/extensions_parsing.mli b/parsing/extensions_parsing.mli
@@ -80,26 +80,22 @@
     detect that you've violated its well-formedness constraints and fail to
     parse the resulting AST. *)
 
-(** Errors around the extension representation.  These should mostly just be
-    fatal, but they're needed for one test case
-    (tests/ast-invariants/test.ml). *)
-module Error : sig
-  (** Someone used [[%extension.EXTNAME]] wrong *)
-  type malformed_extension =
-    | Has_payload of Parsetree.payload
-
-  (** An error triggered when desugaring a language extension from an OCaml AST *)
-  type error =
-    | Malformed_extension of string list * malformed_extension
-    | Unknown_extension of string
-    | Disabled_extension of Language_extension.t
-    | Wrong_syntactic_category of Language_extension.t * string
-    | Unnamed_extension
-    | Bad_introduction of string * string list
-
-  (** The main exception type thrown when desugaring a language extension from an
-      OCaml AST; we also use the occasional [Misc.fatal_errorf]. *)
-  exception Error of Location.t * error
+(** An AST-style representation of the names used when generating extension
+    nodes for modular extensions.  We use this to abstract over the details of
+    how they're encoded, so we have some flexibility in changing them (although
+    comments may refer to the specific encoding choices).  This is also why we
+    don't expose any functions for rendering or parsing these names; that's all
+    handled internally. *)
+module Extension_node_name : sig
+  (** A modular extension's extension node's name broken down into its
+      components: the extension name plus any subparts.  This is a nonempty list
+      corresponding to the dot-separated components of the name, less
+      [extension.]. *)
+  type t = ( :: ) of string * string list
+
+  (** Print out a modular extension extension node name, in quotes; for use in
+      error messages. *)
+  val pp_quoted_name : Format.formatter -> t -> unit
 end
 
 (** The type of modules that lift and lower language extension terms from and
@@ -131,7 +127,7 @@ module type AST = sig
       [extension.].  Any locations in the generated AST will be set to
       [!Ast_helper.default_loc], which should be [ghost].  Partial inverse of
       [match_extension]. *)
-  val make_extension  : string list -> ast -> ast_desc
+  val make_extension  : Extension_node_name.t -> ast -> ast_desc
 
   (** As [make_extension], but specifically for the AST node corresponding to
       the entire piece of extension syntax (e.g., for a list comprehension, the
@@ -143,12 +139,12 @@ module type AST = sig
     loc:Location.t -> string -> (unit -> ast) -> ast_desc
 
   (** Given an AST node, check if it's a language extension term; if it is,
-      split it back up into its name (the [string list]) and the body (the
-      [ast]); the resulting name is split on dots and the leading [extension]
-      component is dropped.  If the language extension term is malformed in any
-      way, raises an error; if the input isn't a language extension term,
-      returns [None].  Partial inverse of [make_extension]. *)
-  val match_extension : ast -> (string list * ast) option
+      split it back up into its name and the body; the resulting name is split
+      on dots and the leading [extension] component is dropped.  If the language
+      extension term is malformed in any way, raises an error; if the input
+      isn't a language extension term, returns [None].  Partial inverse of
+      [make_extension]. *)
+  val match_extension : ast -> (Extension_node_name.t * ast) option
 end
 
 (** One [AST] module per syntactic category we currently care about; we're
@@ -214,3 +210,16 @@ end
     requires two extensions to be enabled at once (e.g., immutable array
     comprehensions such as [[:x for x = 1 to 10:]]). *)
 val assert_extension_enabled : loc:Location.t -> Language_extension.t -> unit
+
+(** Errors around the extension representation.  These should mostly just be
+    fatal, but they're needed for one test case
+    (language-extensions/language_extensions.ml). *)
+module Error : sig
+  (** An error triggered when desugaring a language extension from an OCaml
+      AST; left abstract because it should always be fatal *)
+  type error
+
+  (** The exception type thrown when desugaring a language extension from an
+      OCaml AST *)
+  exception Error of Location.t * error
+end
diff --git a/testsuite/tests/jst-modular-extensions/user_error3.compilers.reference b/testsuite/tests/jst-modular-extensions/user_error3.compilers.reference
@@ -1,5 +1,5 @@
 File "user_error3.ml", line 21, characters 25-69:
 21 | let _unknown_extension = [%extension.this_extension_doesn't_exist] ();;
                               ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: Unknown extension "this_extension_doesn't_exist" referenced via an
-       [%extension.this_extension_doesn't_exist] extension node
+Error: Unknown extension "this_extension_doesn't_exist" referenced via
+       an [%extension.this_extension_doesn't_exist] extension node
diff --git a/testsuite/tests/jst-modular-extensions/user_error5.compilers.reference b/testsuite/tests/jst-modular-extensions/user_error5.compilers.reference
@@ -1,4 +1,4 @@
-File "user_error5.ml", line 21, characters 25-40:
+File "user_error5.ml", line 21, characters 27-36:
 21 | let _unnamed_extension = [%extension] ();;
-                              ^^^^^^^^^^^^^^^
+                                ^^^^^^^^^
 Error: Cannot have an extension node named [%extension]
diff --git a/testsuite/tests/jst-modular-extensions/user_error6.compilers.reference b/testsuite/tests/jst-modular-extensions/user_error6.compilers.reference
@@ -1,6 +1,6 @@
 File "user_error6.ml", line 21, characters 24-56:
 21 | let _bad_introduction = [%extension.something.nested] ();;
                              ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: The extension "something" was referenced improperly; it started with an
-       [%extension.something.nested] extension node,
+Error: The extension "something" was referenced improperly; it started with
+       an [%extension.something.nested] extension node,
        not an [%extension.something] one
