Merge pull request ocaml#792 from sliquister/generalize-destr-subst2

Fixing the limitations on destructive substitutions

Author: lpw25

Changes

@@ -12,6 +12,11 @@ Working version
   in class expressions and class type expressions.
   (Alain Frisch, reviews by Thomas Refis and Jacques Garrigue)
 
+- GPR#792: fix limitations of destructive substitutions, by
+  allowing "S with type t := type-expr",
+  "S with type M.t := type-expr", "S with module M.N := path"
+  (Valentin Gatien-Baron, review by Jacques Garrigue and Leo White)
+
 - GPR#1142: Mark assertions nonexpansive, so that 'assert false'
   can be used as a placeholder for a polymorphic function.
   (Stephen Dolan)

manual/manual/refman/exten.etex

@@ -844,22 +844,23 @@ it to represent sets internally in a different way.
 \ikwd{type\@\texttt{type}}
 \label{s:signature-substitution}
 
-(Introduced in OCaml 3.12)
+(Introduced in OCaml 3.12, generalized in 4.06)
 
 \begin{syntax}
 mod-constraint:
           ...
         | 'type' [type-params] typeconstr-name ':=' typexpr
-        | 'module' module-name ':=' extended-module-path
+        | 'module' module-path ':=' extended-module-path
 \end{syntax}
 
-``Destructive'' substitution (@'with' ... ':=' ...@) behaves essentially like
+A ``destructive'' substitution (@'with' ... ':=' ...@) behaves essentially like
 normal signature constraints (@'with' ... '=' ...@), but it additionally removes
-the redefined type or module from the signature. There are a number of
-restrictions: one can only remove types and modules at the outermost
-level (not inside submodules), and in the case of @'with type'@ the
-definition must be another type constructor with the same type
-parameters.
+the redefined type or module from the signature.
+
+Prior to OCaml 4.06, there were a number of restrictions: one could only remove
+types and modules at the outermost level (not inside submodules), and in the
+case of @'with type'@ the definition had to be another type constructor with the
+same type parameters.
 
 A natural application of destructive substitution is merging two
 signatures sharing a type name.

ocamldoc/odoc_name.ml

@@ -219,8 +219,4 @@ let to_path n =
 
 let from_longident = Odoc_misc.string_of_longident
 
-module Set = Set.Make (struct
-  type z = t
-  type t = z
-  let compare = String.compare
-end)
+module Map = Map.Make(String)

ocamldoc/odoc_name.mli

@@ -70,5 +70,4 @@ val to_path : t -> Path.t
 (** Get a name from a [Longident.t].*)
 val from_longident : Longident.t -> t
 
-(** Set of Name.t *)
-module Set : Set.S with type elt = t
+module Map : Map.S with type key = t

ocamldoc/odoc_sig.ml

@@ -422,17 +422,57 @@ module Analyser =
           let comments = Record.(doc typedtree) pos_end l in
           Odoc_type.Cstr_record (List.map (record comments) l)
 
+    (* Given a constraint "with type M.N.t := foo", this function adds "M" ->
+       "with type N.t := foo" to acc, ie it build the constraint to put on the
+       first element of the path being modified.
+       When filter_out_erased_items_from_signature finds "M", it applies the
+       constraint on its module type. *)
+    let constraint_for_subitem =
+      let split_longident p =
+        match Longident.flatten p with
+        | [] -> assert false
+        | hd :: tl -> hd, Longident.unflatten tl
+      in
+      fun acc s rebuild_constraint ->
+        match split_longident s.txt with
+        | hd, None -> Name.Map.add hd `Removed acc
+        | hd, Some p ->
+           let constraint_ = rebuild_constraint { s with txt = p } in
+           match Name.Map.find hd acc with
+           | exception Not_found ->
+              Name.Map.add hd (`Constrained [constraint_]) acc
+           | `Constrained old ->
+              Name.Map.add hd (`Constrained (constraint_ :: old)) acc
+           | `Removed -> acc
+
     let erased_names_of_constraints constraints acc =
       List.fold_right (fun constraint_ acc ->
         match constraint_ with
         | Parsetree.Pwith_type _ | Parsetree.Pwith_module _ -> acc
-        | Parsetree.Pwith_typesubst {Parsetree.ptype_name=s}
-        | Parsetree.Pwith_modsubst (s, _) ->
-          Name.Set.add s.txt acc)
+        | Parsetree.Pwith_typesubst (s, typedecl) ->
+           constraint_for_subitem acc s (fun s -> Parsetree.Pwith_typesubst (s, typedecl))
+        | Parsetree.Pwith_modsubst (s, modpath) ->
+           constraint_for_subitem acc s (fun s -> Parsetree.Pwith_modsubst (s, modpath)))
         constraints acc
 
+    let is_erased ident map =
+      match Name.Map.find ident map with
+      | exception Not_found -> false
+      | `Removed -> true
+      | `Constrained _ -> false
+
+    let apply_constraint module_type constraints  =
+      match module_type.Parsetree.pmty_desc with
+      | Parsetree.Pmty_alias _ -> module_type
+      | _ ->
+         { Parsetree.
+           pmty_desc = Parsetree.Pmty_with (module_type, List.rev constraints);
+           pmty_loc = module_type.Parsetree.pmty_loc;
+           pmty_attributes = []
+         }
+
     let filter_out_erased_items_from_signature erased signature =
-      if Name.Set.is_empty erased then signature
+      if Name.Map.is_empty erased then signature
       else List.fold_right (fun sig_item acc ->
         let take_item psig_desc = { sig_item with Parsetree.psig_desc } :: acc in
         match sig_item.Parsetree.psig_desc with
@@ -446,14 +486,24 @@ module Analyser =
         | Parsetree.Psig_class _
         | Parsetree.Psig_class_type _ as tp -> take_item tp
         | Parsetree.Psig_type (rf, types) ->
-          (match List.filter (fun td -> not (Name.Set.mem td.Parsetree.ptype_name.txt erased)) types with
+          (match List.filter (fun td -> not (is_erased td.Parsetree.ptype_name.txt erased)) types with
           | [] -> acc
           | types -> take_item (Parsetree.Psig_type (rf, types)))
-        | Parsetree.Psig_module {Parsetree.pmd_name=name}
+        | Parsetree.Psig_module ({Parsetree.pmd_name=name;
+                                  pmd_type=module_type} as r) as m ->
+           begin match Name.Map.find name.txt erased with
+           | exception Not_found -> take_item m
+           | `Removed -> acc
+           | `Constrained constraints ->
+              take_item
+                (Parsetree.Psig_module
+                   { r with Parsetree.pmd_type =
+                       apply_constraint module_type constraints })
+           end
         | Parsetree.Psig_modtype {Parsetree.pmtd_name=name} as m ->
-          if Name.Set.mem name.txt erased then acc else take_item m
+          if is_erased name.txt erased then acc else take_item m
         | Parsetree.Psig_recmodule mods ->
-          (match List.filter (fun pmd -> not (Name.Set.mem pmd.Parsetree.pmd_name.txt erased)) mods with
+          (match List.filter (fun pmd -> not (is_erased pmd.Parsetree.pmd_name.txt erased)) mods with
           | [] -> acc
           | mods -> take_item (Parsetree.Psig_recmodule mods)))
         signature []
@@ -1336,7 +1386,7 @@ module Analyser =
 
     (** Return a module_type_kind from a Parsetree.module_type and a Types.module_type *)
     and analyse_module_type_kind
-      ?(erased = Name.Set.empty) env current_module_name module_type sig_module_type =
+      ?(erased = Name.Map.empty) env current_module_name module_type sig_module_type =
       match module_type.Parsetree.pmty_desc with
         Parsetree.Pmty_ident longident ->
           let name =
@@ -1432,7 +1482,7 @@ module Analyser =
 
     (** analyse of a Parsetree.module_type and a Types.module_type.*)
     and analyse_module_kind
-        ?(erased = Name.Set.empty) env current_module_name module_type sig_module_type =
+        ?(erased = Name.Map.empty) env current_module_name module_type sig_module_type =
       match module_type.Parsetree.pmty_desc with
       | Parsetree.Pmty_ident _longident ->
           let k = analyse_module_type_kind env current_module_name module_type sig_module_type in
@@ -1502,7 +1552,7 @@ module Analyser =
                raise (Failure "Parsetree.Pmty_functor _ but not Types.Mty_functor _")
           )
       | Parsetree.Pmty_with (module_type2, constraints) ->
-          (*of module_type * (Longident.t * with_constraint) list*)
+          (* of module_type * (Longident.t * with_constraint) list*)
           (
            let loc_start = Loc.end_ module_type2.Parsetree.pmty_loc in
            let loc_end = Loc.end_ module_type.Parsetree.pmty_loc in

ocamldoc/odoc_sig.mli

@@ -180,7 +180,9 @@ module Analyser :
 
       (** Return a module_type_kind from a Parsetree.module_type and a Types.module_type *)
       val analyse_module_type_kind :
-          ?erased:Odoc_name.Set.t -> Odoc_env.env -> Odoc_name.t ->
+          ?erased:[ `Constrained of Parsetree.with_constraint list
+                  | `Removed ] Odoc_name.Map.t
+          -> Odoc_env.env -> Odoc_name.t ->
             Parsetree.module_type -> Types.module_type ->
               Odoc_module.module_type_kind
 

parsing/ast_iterator.ml

@@ -232,7 +232,8 @@ module MT = struct
         iter_loc sub lid; sub.type_declaration sub d
     | Pwith_module (lid, lid2) ->
         iter_loc sub lid; iter_loc sub lid2
-    | Pwith_typesubst d -> sub.type_declaration sub d
+    | Pwith_typesubst (lid, d) ->
+        iter_loc sub lid; sub.type_declaration sub d
     | Pwith_modsubst (s, lid) ->
         iter_loc sub s; iter_loc sub lid
 

parsing/ast_mapper.ml

@@ -246,7 +246,8 @@ module MT = struct
         Pwith_type (map_loc sub lid, sub.type_declaration sub d)
     | Pwith_module (lid, lid2) ->
         Pwith_module (map_loc sub lid, map_loc sub lid2)
-    | Pwith_typesubst d -> Pwith_typesubst (sub.type_declaration sub d)
+    | Pwith_typesubst (lid, d) ->
+        Pwith_typesubst (map_loc sub lid, sub.type_declaration sub d)
     | Pwith_modsubst (s, lid) ->
         Pwith_modsubst (map_loc sub s, map_loc sub lid)
 

parsing/depend.ml

@@ -307,7 +307,7 @@ and add_modtype bv mty =
         (function
           | Pwith_type (_, td) -> add_type_declaration bv td
           | Pwith_module (_, lid) -> addmodule bv lid
-          | Pwith_typesubst td -> add_type_declaration bv td
+          | Pwith_typesubst (_, td) -> add_type_declaration bv td
           | Pwith_modsubst (_, lid) -> addmodule bv lid
         )
         cstrl

parsing/longident.ml

@@ -37,8 +37,13 @@ let rec split_at_dots s pos =
   with Not_found ->
     [String.sub s pos (String.length s - pos)]
 
+let unflatten l =
+  match l with
+  | [] -> None
+  | hd :: tl -> Some (List.fold_left (fun p s -> Ldot(p, s)) (Lident hd) tl)
+
 let parse s =
-  match split_at_dots s 0 with
-    [] -> Lident ""  (* should not happen, but don't put assert false
-                        so as not to crash the toplevel (see Genprintval) *)
-  | hd :: tl -> List.fold_left (fun p s -> Ldot(p, s)) (Lident hd) tl
+  match unflatten (split_at_dots s 0) with
+  | None -> Lident ""  (* should not happen, but don't put assert false
+                          so as not to crash the toplevel (see Genprintval) *)
+  | Some v -> v

parsing/longident.mli

@@ -21,5 +21,6 @@ type t =
   | Lapply of t * t
 
 val flatten: t -> string list
+val unflatten: string list -> t option
 val last: t -> string
 val parse: string -> t

parsing/parser.mly

@@ -2135,15 +2135,16 @@ with_constraint:
               ~loc:(symbol_rloc()))) }
     /* used label_longident instead of type_longident to disallow
        functor applications in type path */
-  | TYPE type_parameters label COLONEQUAL core_type_no_attr
+  | TYPE type_parameters label_longident COLONEQUAL core_type_no_attr
       { Pwith_typesubst
-          (Type.mk (mkrhs $3 3)
+         (mkrhs $3 3,
+           (Type.mk (mkrhs (Longident.last $3) 3)
              ~params:$2
              ~manifest:$5
-             ~loc:(symbol_rloc())) }
+             ~loc:(symbol_rloc()))) }
   | MODULE mod_longident EQUAL mod_ext_longident
       { Pwith_module (mkrhs $2 2, mkrhs $4 4) }
-  | MODULE UIDENT COLONEQUAL mod_ext_longident
+  | MODULE mod_longident COLONEQUAL mod_ext_longident
       { Pwith_modsubst (mkrhs $2 2, mkrhs $4 4) }
 ;
 with_type_binder:

parsing/parsetree.mli

@@ -767,10 +767,10 @@ and with_constraint =
            the name of the type_declaration. *)
   | Pwith_module of Longident.t loc * Longident.t loc
         (* with module X.Y = Z *)
-  | Pwith_typesubst of type_declaration
-        (* with type t := ... *)
-  | Pwith_modsubst of string loc * Longident.t loc
-        (* with module X := Z *)
+  | Pwith_typesubst of Longident.t loc * type_declaration
+        (* with type X.t := ..., same format as [Pwith_type] *)
+  | Pwith_modsubst of Longident.t loc * Longident.t loc
+        (* with module X.Y := Z *)
 
 (* Value expressions for the module language *)
 

parsing/pprintast.ml

@@ -952,14 +952,14 @@ and module_type ctxt f x =
                 ls longident_loc li (type_declaration ctxt) td
           | Pwith_module (li, li2) ->
               pp f "module %a =@ %a" longident_loc li longident_loc li2;
-          | Pwith_typesubst ({ptype_params=ls;_} as td) ->
+          | Pwith_typesubst (li, ({ptype_params=ls;_} as td)) ->
               let ls = List.map fst ls in
-              pp f "type@ %a %s :=@ %a"
+              pp f "type@ %a %a :=@ %a"
                 (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")")
-                ls td.ptype_name.txt
+                ls longident_loc li
                 (type_declaration ctxt) td
-          | Pwith_modsubst (s, li2) ->
-              pp f "module %s :=@ %a" s.txt longident_loc li2 in
+          | Pwith_modsubst (li, li2) ->
+             pp f "module %a :=@ %a" longident_loc li longident_loc li2 in
         (match l with
          | [] -> pp f "@[<hov2>%a@]" (module_type ctxt) mt
          | _ -> pp f "@[<hov2>(%a@ with@ %a)@]"

parsing/printast.ml

@@ -722,17 +722,17 @@ and with_constraint i ppf x =
   | Pwith_type (lid, td) ->
       line i ppf "Pwith_type %a\n" fmt_longident_loc lid;
       type_declaration (i+1) ppf td;
-  | Pwith_typesubst (td) ->
-      line i ppf "Pwith_typesubst\n";
+  | Pwith_typesubst (lid, td) ->
+      line i ppf "Pwith_typesubst %a\n" fmt_longident_loc lid;
       type_declaration (i+1) ppf td;
   | Pwith_module (lid1, lid2) ->
       line i ppf "Pwith_module %a = %a\n"
         fmt_longident_loc lid1
         fmt_longident_loc lid2;
-  | Pwith_modsubst (s, li) ->
+  | Pwith_modsubst (lid1, lid2) ->
       line i ppf "Pwith_modsubst %a = %a\n"
-        fmt_string_loc s
-        fmt_longident_loc li;
+        fmt_longident_loc lid1
+        fmt_longident_loc lid2;
 
 and module_expr i ppf x =
   line i ppf "module_expr %a\n" fmt_location x.pmod_loc;

testsuite/tests/parsing/attributes.ml.reference

@@ -125,7 +125,7 @@
                     []
                   Pmod_ident "M" (attributes.ml[26,254+27]..[26,254+28])
               [
-                Pwith_typesubst
+                Pwith_typesubst "t" (attributes.ml[26,254+53]..[26,254+54])
                   type_declaration "t" (attributes.ml[26,254+53]..[26,254+54]) (attributes.ml[26,254+48]..[26,254+61])
                     ptype_params =
                       []

testsuite/tests/typing-sigsubst/Makefile

@@ -14,5 +14,5 @@
 #**************************************************************************
 
 BASEDIR=../..
-include $(BASEDIR)/makefiles/Makefile.toplevel
+include $(BASEDIR)/makefiles/Makefile.expect
 include $(BASEDIR)/makefiles/Makefile.common