flambda-backend: Syntactic support for instance names as identifiers (#1873)

Author: lukemaurer

driver/compile_common.ml

@@ -90,7 +90,7 @@ let emit_signature info alerts tsg =
       else begin
         let cmi_arg_for =
           match !Clflags.as_argument_for with
-          | Some arg_type -> Some (Global_module.Name.create arg_type [])
+          | Some arg_type -> Some (Global_module.Name.create_no_args arg_type)
           | None -> None
         in
         Normal { cmi_impl = info.module_name; cmi_arg_for }

parsing/ast_iterator.ml

@@ -56,6 +56,7 @@ type iterator = {
   module_declaration: iterator -> module_declaration -> unit;
   module_substitution: iterator -> module_substitution -> unit;
   module_expr: iterator -> module_expr -> unit;
+  module_expr_jane_syntax: iterator -> Jane_syntax.Module_expr.t -> unit;
   module_type: iterator -> module_type -> unit;
   module_type_declaration: iterator -> module_type_declaration -> unit;
   module_type_jane_syntax: iterator -> Jane_syntax.Module_type.t -> unit;
@@ -403,9 +404,27 @@ end
 module M = struct
   (* Value expressions for the module language *)
 
-  let iter sub {pmod_loc = loc; pmod_desc = desc; pmod_attributes = attrs} =
+  module I = Jane_syntax.Instances
+
+  let iter_instance _sub : I.instance -> _ = function
+    | _ ->
+        (* CR lmaurer: Implement this. Might want to change the [instance] type to have
+           Ids with locations in them rather than just raw strings. *)
+        ()
+
+  let iter_instance_expr sub : I.module_expr -> _ = function
+    | Imod_instance i -> iter_instance sub i
+
+  let iter_ext sub : Jane_syntax.Module_expr.t -> _ = function
+    | Emod_instance i -> iter_instance_expr sub i
+
+  let iter sub
+        ({pmod_loc = loc; pmod_desc = desc; pmod_attributes = attrs} as expr) =
     sub.location sub loc;
     sub.attributes sub attrs;
+    match Jane_syntax.Module_expr.of_ast expr with
+    | Some ext -> sub.module_expr_jane_syntax sub ext
+    | None ->
     match desc with
     | Pmod_ident x -> iter_loc sub x
     | Pmod_structure str -> sub.structure sub str
@@ -760,6 +779,7 @@ let default_iterator =
     structure_item = M.iter_structure_item;
     structure_item_jane_syntax = M.iter_structure_item_jst;
     module_expr = M.iter;
+    module_expr_jane_syntax = M.iter_ext;
     signature = (fun this l -> List.iter (this.signature_item this) l);
     signature_item = MT.iter_signature_item;
     signature_item_jane_syntax = MT.iter_signature_item_jst;

parsing/ast_iterator.mli

@@ -59,6 +59,7 @@ type iterator = {
   module_declaration: iterator -> module_declaration -> unit;
   module_substitution: iterator -> module_substitution -> unit;
   module_expr: iterator -> module_expr -> unit;
+  module_expr_jane_syntax: iterator -> Jane_syntax.Module_expr.t -> unit;
   module_type: iterator -> module_type -> unit;
   module_type_declaration: iterator -> module_type_declaration -> unit;
   module_type_jane_syntax: iterator -> Jane_syntax.Module_type.t -> unit;

parsing/ast_mapper.ml

@@ -94,6 +94,8 @@ type mapper = {
     Jane_syntax.Extension_constructor.t -> Jane_syntax.Extension_constructor.t;
   module_type_jane_syntax: mapper
     -> Jane_syntax.Module_type.t -> Jane_syntax.Module_type.t;
+  module_expr_jane_syntax: mapper
+    -> Jane_syntax.Module_expr.t -> Jane_syntax.Module_expr.t;
   pat_jane_syntax: mapper -> Jane_syntax.Pattern.t -> Jane_syntax.Pattern.t;
   signature_item_jane_syntax: mapper ->
     Jane_syntax.Signature_item.t -> Jane_syntax.Signature_item.t;
@@ -479,12 +481,33 @@ end
 
 
 module M = struct
+  module I = Jane_syntax.Instances
+
   (* Value expressions for the module language *)
+  let map_instance _sub : I.instance -> I.instance = function
+    | i ->
+      (* CR lmaurer: Implement this. Might want to change the [instance] type to have
+        Ids with locations in them rather than just raw strings. *)
+      i
+
+  let map_instance_expr sub : I.module_expr -> I.module_expr = function
+    | Imod_instance i -> Imod_instance (map_instance sub i)
+
+  let map_ext sub : Jane_syntax.Module_expr.t -> Jane_syntax.Module_expr.t =
+    function
+    | Emod_instance i -> Emod_instance (map_instance_expr sub i)
 
-  let map sub {pmod_loc = loc; pmod_desc = desc; pmod_attributes = attrs} =
+  let map sub
+        ({pmod_loc = loc; pmod_desc = desc; pmod_attributes = attrs} as mexpr) =
     let open Mod in
     let loc = sub.location sub loc in
     let attrs = sub.attributes sub attrs in
+    match Jane_syntax.Module_expr.of_ast mexpr with
+    | Some ext -> begin
+        match sub.module_expr_jane_syntax sub ext with
+        | Emod_instance i -> Jane_syntax.Instances.module_expr_of ~loc i
+      end
+    | None ->
     match desc with
     | Pmod_ident x -> ident ~loc ~attrs (map_loc sub x)
     | Pmod_structure str -> structure ~loc ~attrs (sub.structure sub str)
@@ -887,6 +910,7 @@ let default_mapper =
     structure = (fun this l -> List.map (this.structure_item this) l);
     structure_item = M.map_structure_item;
     module_expr = M.map;
+    module_expr_jane_syntax = M.map_ext;
     signature = (fun this l -> List.map (this.signature_item this) l);
     signature_item = MT.map_signature_item;
     module_type = MT.map;

parsing/ast_mapper.mli

@@ -129,6 +129,8 @@ type mapper = {
     Jane_syntax.Extension_constructor.t -> Jane_syntax.Extension_constructor.t;
   module_type_jane_syntax: mapper ->
     Jane_syntax.Module_type.t -> Jane_syntax.Module_type.t;
+  module_expr_jane_syntax: mapper ->
+    Jane_syntax.Module_expr.t -> Jane_syntax.Module_expr.t;
   pat_jane_syntax: mapper -> Jane_syntax.Pattern.t -> Jane_syntax.Pattern.t;
   signature_item_jane_syntax: mapper ->
     Jane_syntax.Signature_item.t -> Jane_syntax.Signature_item.t;

parsing/jane_syntax.ml

@@ -1261,6 +1261,74 @@ module Layouts = struct
     | _ -> failwith "Malformed [kind_abbrev] in structure"
 end
 
+module Instances = struct
+  type instance =
+    { head : string;
+      args : (string * instance) list
+    }
+
+  type module_expr = Imod_instance of instance
+
+  let feature : Feature.t = Language_extension Instances
+
+  let module_expr_of_string ~loc str =
+    Ast_helper.Mod.ident ~loc { txt = Lident str; loc }
+
+  let rec module_expr_of_instance ~loc { head; args } =
+    let head = module_expr_of_string ~loc head in
+    match args with
+    | [] -> head
+    | _ ->
+      let args =
+        List.concat_map
+          (fun (param, value) ->
+            let param = module_expr_of_string ~loc param in
+            let value = module_expr_of_instance ~loc value in
+            [param; value])
+          args
+      in
+      List.fold_left (Ast_helper.Mod.apply ~loc) head args
+
+  let module_expr_of ~loc = function
+    | Imod_instance instance ->
+      Module_expr.make_entire_jane_syntax ~loc feature (fun () ->
+          module_expr_of_instance ~loc instance)
+
+  let head_of_ident (lid : Longident.t Location.loc) =
+    match lid with
+    | { txt = Lident s; loc = _ } -> s
+    | _ -> failwith "Malformed instance identifier"
+
+  let gather_args mexpr =
+    let rec loop mexpr rev_acc =
+      match mexpr.pmod_desc with
+      | Pmod_apply (f, v) -> (
+        match f.pmod_desc with
+        | Pmod_apply (f, n) -> loop f ((n, v) :: rev_acc)
+        | _ -> failwith "Malformed instance identifier")
+      | head -> head, List.rev rev_acc
+    in
+    loop mexpr []
+
+  let string_of_module_expr mexpr =
+    match mexpr.pmod_desc with
+    | Pmod_ident i -> head_of_ident i
+    | _ -> failwith "Malformed instance identifier"
+
+  let rec instance_of_module_expr mexpr =
+    match gather_args mexpr with
+    | Pmod_ident i, args ->
+      let head = head_of_ident i in
+      let args = List.map instances_of_arg_pair args in
+      { head; args }
+    | _ -> failwith "Malformed instance identifier"
+
+  and instances_of_arg_pair (n, v) =
+    string_of_module_expr n, instance_of_module_expr v
+
+  let of_module_expr mexpr = Imod_instance (instance_of_module_expr mexpr)
+end
+
 (******************************************************************************)
 (** The interface to our novel syntax, which we export *)
 
@@ -1391,6 +1459,18 @@ module Module_type = struct
       { mty with pmty_attributes = mty.pmty_attributes @ attrs }
 end
 
+module Module_expr = struct
+  type t = Emod_instance of Instances.module_expr
+
+  let of_ast_internal (feat : Feature.t) sigi =
+    match feat with
+    | Language_extension Instances ->
+      Some (Emod_instance (Instances.of_module_expr sigi))
+    | _ -> None
+
+  let of_ast = Module_expr.make_of_ast ~of_ast_internal
+end
+
 module Signature_item = struct
   type t = Jsig_layout of Layouts.signature_item
 

parsing/jane_syntax.mli

@@ -276,6 +276,19 @@ module Layouts : sig
     (Jkind.annotation * Parsetree.attributes) option
 end
 
+module Instances : sig
+  (** The name of an instance module. Gets converted to [Global.Name.t] in the
+      flambda-backend compiler. *)
+  type instance =
+    { head : string;
+      args : (string * instance) list
+    }
+
+  type module_expr = Imod_instance of instance
+
+  val module_expr_of : loc:Location.t -> module_expr -> Parsetree.module_expr
+end
+
 (******************************************)
 (* General facility, which we export *)
 
@@ -452,3 +465,10 @@ module Extension_constructor : sig
     t ->
     Parsetree.extension_constructor
 end
+
+(** Novel syntax in module expressions *)
+module Module_expr : sig
+  type t = Emod_instance of Instances.module_expr
+
+  include AST with type t := t and type ast := Parsetree.module_expr
+end

parsing/jane_syntax_parsing.ml

@@ -633,6 +633,21 @@ module Module_type0 = Make_with_attribute (struct
   let with_attributes mty pmty_attributes = { mty with pmty_attributes }
 end)
 
+(** Module expressions; embedded using an attribute on the module expression. *)
+module Module_expr0 = Make_with_attribute (struct
+  type ast = module_expr
+
+  let plural = "module expressions"
+
+  let location mexpr = mexpr.pmod_loc
+
+  let with_location mexpr l = { mexpr with pmod_loc = l }
+
+  let attributes mexpr = mexpr.pmod_attributes
+
+  let with_attributes mexpr pmod_attributes = { mexpr with pmod_attributes }
+end)
+
 (** Extension constructors; embedded using an attribute. *)
 module Extension_constructor0 = Make_with_attribute (struct
   type ast = extension_constructor
@@ -849,6 +864,7 @@ let make_jane_syntax_attribute feature trailing_components payload =
 module Expression = Make_ast (Expression0)
 module Pattern = Make_ast (Pattern0)
 module Module_type = Make_ast (Module_type0)
+module Module_expr = Make_ast (Module_expr0)
 module Signature_item = Make_ast (Signature_item0)
 module Structure_item = Make_ast (Structure_item0)
 module Core_type = Make_ast (Core_type0)

parsing/jane_syntax_parsing.mli

@@ -202,6 +202,8 @@ module Pattern : AST with type ast = Parsetree.pattern
 
 module Module_type : AST with type ast = Parsetree.module_type
 
+module Module_expr : AST with type ast = Parsetree.module_expr
+
 module Signature_item : AST with type ast = Parsetree.signature_item
 
 module Structure_item : AST with type ast = Parsetree.structure_item

parsing/pprintast.ml

@@ -1643,7 +1643,9 @@ and module_expr ctxt f x =
   if x.pmod_attributes <> [] then
     pp f "((%a)%a)" (module_expr ctxt) {x with pmod_attributes=[]}
       (attributes ctxt) x.pmod_attributes
-  else match x.pmod_desc with
+  else match Jane_syntax.Module_expr.of_ast x with
+    | Some ext -> extension_module_expr ctxt f ext
+    | None -> match x.pmod_desc with
     | Pmod_structure (s) ->
         pp f "@[<hv2>struct@;@[<0>%a@]@;<1 -2>end@]"
           (list (structure_item ctxt) ~sep:"@\n") s;
@@ -2342,6 +2344,23 @@ and labeled_tuple_expr ctxt f ~unboxed x =
   pp f "@[<hov2>%s(%a)@]" (if unboxed then "#" else "")
     (list (tuple_component ctxt) ~sep:",@;") x
 
+and extension_module_expr ctxt f (x : Jane_syntax.Module_expr.t) =
+  match x with
+  | Emod_instance i -> instance_module_expr ctxt f i
+
+and instance_module_expr ctxt f (x : Jane_syntax.Instances.module_expr) =
+  match x with
+  | Imod_instance i -> instance ctxt f i
+
+and instance ctxt f (x : Jane_syntax.Instances.instance) =
+  match x with
+  | { head; args = [] } -> pp f "%s" head
+  | { head; args } ->
+    pp f "@[<2>%s %a@]" head (list (instance_arg ctxt)) args
+
+and instance_arg ctxt f (param, value) =
+  pp f "@[<1>(%s)@;(%a)@]" param (instance ctxt) value
+
 (******************************************************************************)
 (* All exported functions must be defined or redefined below here and wrapped in
    [export_printer] in order to ensure they are invariant with respecto which

testsuite/tests/language-extensions/pprintast_unconditional.ml

@@ -81,6 +81,11 @@ module Example = struct
       kind_abbrev_ data = value mod sync many \
     end"
 
+  let instance_name =
+    parse module_expr "\
+      Base(Name1)(Value1)(Name2)(Value2(Name2_1)(Value2_1)) \
+        [@jane.non_erasable.instances]"
+
   let longident        = parse longident "No.Longidents.Require.extensions"
   let expression       = parse expression "[x for x = 1 to 10]"
   let pattern          = parse pattern "[:_:]"
@@ -231,6 +236,7 @@ end = struct
   let string_of_structure = test_string_of "string_of_structure" string_of_structure Example.structure
   let modal_kind_struct = test "modal_kind_struct" module_expr Example.modal_kind_struct
   let modal_kind_sig = test "modal_kind_sig" module_type Example.modal_kind_sig
+  let instance_name = test "instance_name" module_expr Example.instance_name
 
   let tyvar_of_name =
     test_string_of "tyvar_of_name" tyvar_of_name Example.tyvar_of_name

testsuite/tests/language-extensions/pprintast_unconditional.reference

@@ -122,6 +122,10 @@ modal_kind_sig:
     kind_abbrev_ data = value mod sync many
   end
 
+instance_name:
+  ((((((Base)(Name1))(Value1))(Name2))(((Value2)(Name2_1))(Value2_1)))
+  [@jane.non_erasable.instances ])
+
 tyvar_of_name: 'no_tyvars_require_extensions
 
 tyvar: 'no_tyvars_require_extensions
@@ -256,6 +260,10 @@ modal_kind_sig:
     kind_abbrev_ data = value mod sync many
   end
 
+instance_name:
+  ((((((Base)(Name1))(Value1))(Name2))(((Value2)(Name2_1))(Value2_1)))
+  [@jane.non_erasable.instances ])
+
 tyvar_of_name: 'no_tyvars_require_extensions
 
 tyvar: 'no_tyvars_require_extensions

testsuite/tests/templates/basic/bad_instance_repeated_arg_name.ml

@@ -0,0 +1,2 @@
+module Monoid_utils_of_list_monoid =
+  Monoid_utils(Monoid)(List_monoid)(Monoid)(List_monoid) [@jane.non_erasable.instances]

testsuite/tests/templates/basic/bad_instance_repeated_arg_name.reference

@@ -0,0 +1,4 @@
+File "bad_instance_repeated_arg_name.ml", line 2, characters 2-56:
+2 |   Monoid_utils(Monoid)(List_monoid)(Monoid)(List_monoid) [@jane.non_erasable.instances]
+      ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This instance has multiple arguments with the name "Monoid".