Syntactic support for instance names as identifiers

ocaml/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_exn arg_type [])
           | None -> None
         in
         Normal { cmi_impl = info.module_name; cmi_arg_for }

ocaml/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,24 @@ 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
+    | _ -> () (* Currently treating these as atomic? *)
+
+  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 +776,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;

ocaml/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;

ocaml/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,30 @@ 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 -> i (* Currently treating these as atomic? *)
+
+  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 +907,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;

ocaml/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;

ocaml/parsing/jane_syntax.ml

@@ -1261,6 +1261,66 @@ module Layouts = struct
     | _ -> failwith "Malformed [kind_abbrev] in structure"
 end
 
+module Instances = struct
+  type instance =
+    { head : string;
+      args : (instance * instance) list
+    }
+
+  type module_expr = Imod_instance of instance
+
+  let feature : Feature.t = Language_extension Instances
+
+  let rec module_expr_of_instance ~loc { head; args } =
+    let head = Ast_helper.Mod.ident ~loc { txt = Lident head; loc } in
+    match args with
+    | [] -> head
+    | _ ->
+      let args =
+        List.concat_map
+          (fun (param, value) ->
+            let param = module_expr_of_instance ~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 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) =
+    instance_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 +1451,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
 

ocaml/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 : (instance * 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

ocaml/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)

ocaml/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

ocaml/parsing/pprintast.ml

@@ -1637,7 +1637,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;
@@ -2336,6 +2338,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>(%a)@;(%a)@]" (instance ctxt) 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

ocaml/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]

ocaml/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".

ocaml/testsuite/tests/templates/basic/test.ml

@@ -2,6 +2,7 @@
  readonly_files = "\
    bad_arg_impl.ml bad_arg_impl.reference \
    bad_arg_intf.mli bad_arg_intf.reference \
+   bad_instance_repeated_arg_name.ml bad_instance_repeated_arg_name.reference \
    bad_param_param.mli bad_param_param.reference \
    bad_ref_direct.ml bad_ref_direct.reference \
    bad_ref_indirect.reference \
@@ -128,6 +129,15 @@
 
        reference = "monoid_utils_as_program.reference";
        check-program-output;
+     }{
+       flags = "-parameter Semigroup";
+       module = "bad_instance_repeated_arg_name.ml";
+       compiler_output = "bad_instance_repeated_arg_name.output";
+       ocamlc_byte_exit_status = "2";
+       ocamlc.byte;
+
+       compiler_reference = "bad_instance_repeated_arg_name.reference";
+       check-ocamlc.byte-output;
      }
    }
  }{
@@ -247,6 +257,15 @@
 
        reference = "monoid_utils_as_program.reference";
        check-program-output;
+     }{
+       flags = "-parameter Semigroup";
+       module = "bad_instance_repeated_arg_name.ml";
+       compiler_output = "bad_instance_repeated_arg_name.output";
+       ocamlopt_byte_exit_status = "2";
+       ocamlopt.byte;
+
+       compiler_reference = "bad_instance_repeated_arg_name.reference";
+       check-ocamlopt.byte-output;
      }
    }
  }

ocaml/testsuite/tests/tool-toplevel/pr6468.compilers.reference

@@ -9,17 +9,17 @@ val g : unit -> int = <fun>
 Exception: Not_found.
 Raised at Stdlib__Map.Make.find in file "map.ml", line 146, characters 10-25
 Called from Env.find_type_data in file "ocaml/typing/env.ml", line 1275, characters 8-48
-Re-raised at Ident.find_same in file "ocaml/typing/ident.ml", line 309, characters 6-21
+Re-raised at Ident.find_same in file "ocaml/typing/ident.ml", line 307, characters 6-21
 Called from Env.IdTbl.find_same_without_locks in file "ocaml/typing/env.ml", line 428, characters 10-40
 Re-raised at Stdlib__Map.Make.find in file "map.ml", line 146, characters 10-25
 Called from Env.find_type_data in file "ocaml/typing/env.ml", line 1275, characters 8-48
-Re-raised at Ident.find_same in file "ocaml/typing/ident.ml", line 309, characters 6-21
+Re-raised at Ident.find_same in file "ocaml/typing/ident.ml", line 307, characters 6-21
 Called from Env.IdTbl.find_same_without_locks in file "ocaml/typing/env.ml", line 428, characters 10-40
 Re-raised at Stdlib__Map.Make.find in file "map.ml", line 146, characters 10-25
 Called from Env.find_type_data in file "ocaml/typing/env.ml", line 1275, characters 8-48
-Re-raised at Ident.find_same in file "ocaml/typing/ident.ml", line 309, characters 6-21
+Re-raised at Ident.find_same in file "ocaml/typing/ident.ml", line 307, characters 6-21
 Called from Env.IdTbl.find_same_without_locks in file "ocaml/typing/env.ml", line 428, characters 10-40
-Re-raised at Ident.find_same in file "ocaml/typing/ident.ml", line 309, characters 6-21
+Re-raised at Ident.find_same in file "ocaml/typing/ident.ml", line 307, characters 6-21
 Called from Translmod.toplevel_name in file "ocaml/lambda/translmod.ml", line 1599, characters 6-40
 Re-raised at Stdlib__Hashtbl.find in file "hashtbl.ml", line 547, characters 13-28
 Called from Simplif.simplify_lets.simplif in file "ocaml/lambda/simplif.ml", line 571, characters 8-28