Fix wrong calls to Env.normalize_path on non-module paths (#2131)

Changes

@@ -683,6 +683,9 @@ Working version
   (Alain Frisch, review by Armaël Guéneau and Gabriel Scherer,
   report by Hugo Heuzard)
 
+- GPR#2131: fix wrong calls to Env.normalize_path on non-module paths
+  (Alain Frisch, review by Jacques Garrigue)
+
 
 OCaml 4.07.1 (4 October 2018)
 -----------------------------

bytecomp/translprim.ml

@@ -91,7 +91,7 @@ let used_primitives = Hashtbl.create 7
 let add_used_primitive loc env path =
   match path with
     Some (Path.Pdot _ as path) ->
-      let path = Env.normalize_path (Some loc) env path in
+      let path = Env.normalize_path_prefix (Some loc) env path in
       let unit = Path.head path in
       if Ident.global unit && not (Hashtbl.mem used_primitives path)
       then Hashtbl.add used_primitives path loc

testsuite/tests/typing-modules/normalize_path.ml

@@ -0,0 +1,17 @@
+(* TEST
+   * expect
+*)
+
+module X = struct
+
+  module B = List
+
+  exception B of {x:int}
+end
+
+let _ = X.B {x=2}
+;;
+[%%expect{|
+module X : sig module B = List exception B of { x : int; } end
+- : exn = X.B {x = 2}
+|}]

testsuite/tests/typing-modules/ocamltests

@@ -4,6 +4,7 @@ firstclass.ml
 generative.ml
 nondep.ml
 nondep_private_abbrev.ml
+normalize_path.ml
 pr5911.ml
 pr6394.ml
 pr7207.ml

typing/ctype.ml

@@ -756,7 +756,7 @@ let rec normalize_package_path env p =
       match p with
         Path.Pdot (p1, s) ->
           (* For module aliases *)
-          let p1' = Env.normalize_path None env p1 in
+          let p1' = Env.normalize_module_path None env p1 in
           if Path.same p1 p1' then p else
           normalize_package_path env (Path.Pdot (p1', s))
       | _ -> p
@@ -1511,7 +1511,7 @@ let expand_abbrev_gen kind find_type_expansion env ty =
           match find_type_expansion path env with
           | exception Not_found ->
             (* another way to expand is to normalize the path itself *)
-            let path' = Env.normalize_path None env path in
+            let path' = Env.normalize_type_path None env path in
             if Path.same path path' then raise Cannot_expand
             else newty2 level (Tconstr (path', args, abbrev))
           | (params, body, lv) ->

typing/env.ml

@@ -1106,18 +1106,25 @@ let add_required_global id =
   && not (List.exists (Ident.same id) !required_globals)
   then required_globals := id :: !required_globals
 
-let rec normalize_path lax env path =
-  let path =
-    match path with
-      Pdot(p, s) ->
-        Pdot(normalize_path lax env p, s)
-    | Papply(p1, p2) ->
-        Papply(normalize_path lax env p1, normalize_path true env p2)
-    | _ -> path
-  in
+let rec normalize_module_path lax env = function
+  | Pident id as path when lax && Ident.persistent id ->
+      path (* fast path (avoids lookup) *)
+  | Pdot (p, s) as path ->
+      let p' = normalize_module_path lax env p in
+      if p == p' then expand_module_path lax env path
+      else expand_module_path lax env (Pdot(p', s))
+  | Papply (p1, p2) as path ->
+      let p1' = normalize_module_path lax env p1 in
+      let p2' = normalize_module_path true env p2 in
+      if p1 == p1' && p2 == p2' then expand_module_path lax env path
+      else expand_module_path lax env (Papply(p1', p2'))
+  | Pident _ as path ->
+      expand_module_path lax env path
+
+and expand_module_path lax env path =
   try match find_module ~alias:true path env with
     {md_type=Mty_alias path1} ->
-      let path' = normalize_path lax env path1 in
+      let path' = normalize_module_path lax env path1 in
       if lax || !Clflags.transparent_modules then path' else
       let id = Path.head path in
       if Ident.global id && not (Ident.same id (Path.head path'))
@@ -1128,22 +1135,50 @@ let rec normalize_path lax env path =
   || (match path with Pident id -> not (Ident.persistent id) | _ -> true) ->
       path
 
-let normalize_path oloc env path =
-  try normalize_path (oloc = None) env path
+let normalize_module_path oloc env path =
+  try normalize_module_path (oloc = None) env path
   with Not_found ->
     match oloc with None -> assert false
     | Some loc ->
-        raise (Error(Missing_module(loc, path, normalize_path true env path)))
+        raise (Error(Missing_module(loc, path,
+                                    normalize_module_path true env path)))
 
 let normalize_path_prefix oloc env path =
   match path with
     Pdot(p, s) ->
-      Pdot(normalize_path oloc env p, s)
+      let p2 = normalize_module_path oloc env p in
+      if p == p2 then path else Pdot(p2, s)
   | Pident _ ->
       path
   | Papply _ ->
       assert false
 
+let is_uident s =
+  match s.[0] with
+  | 'A'..'Z' -> true
+  | _ -> false
+
+let normalize_type_path oloc env path =
+  (* Inlined version of Path.is_constructor_typath:
+     constructor type paths (i.e. path pointing to an inline
+     record argument of a constructpr) are built as a regular
+     type path followed by a capitalized constructor name. *)
+  match path with
+  | Pident _ ->
+      path
+  | Pdot(p, s) ->
+      let p2 =
+        if is_uident s && not (is_uident (Path.last p)) then
+          (* Cstr M.t.C *)
+          normalize_path_prefix oloc env p
+        else
+          (* Regular M.t, Ext M.C *)
+          normalize_module_path oloc env p
+      in
+      if p == p2 then path else Pdot (p2, s)
+  | Papply _ ->
+      assert false
+
 let find_module path env =
   find_module ~alias:false path env
 

typing/env.mli

@@ -87,13 +87,21 @@ val find_constructor_address: Path.t -> t -> address
 
 val add_functor_arg: Ident.t -> t -> t
 val is_functor_arg: Path.t -> t -> bool
-val normalize_path: Location.t option -> t -> Path.t -> Path.t
-(* Normalize the path to a concrete value or module.
+
+val normalize_module_path: Location.t option -> t -> Path.t -> Path.t
+(* Normalize the path to a concrete module.
    If the option is None, allow returning dangling paths.
    Otherwise raise a Missing_module error, and may add forgotten
    head as required global. *)
+
+val normalize_type_path: Location.t option -> t -> Path.t -> Path.t
+(* Normalize the prefix part of the type path *)
+
 val normalize_path_prefix: Location.t option -> t -> Path.t -> Path.t
-(* Only normalize the prefix part of the path *)
+(* Normalize the prefix part of other kinds of paths
+   (value/modtype/etc) *)
+
+
 val reset_required_globals: unit -> unit
 val get_required_globals: unit -> Ident.t list
 val add_required_global: Ident.t -> unit

typing/includemod.ml

@@ -264,14 +264,16 @@ and try_modtypes ~loc env ~mark cxt subst mty1 mty2 =
       if Env.is_functor_arg p2 env then
         raise (Error[cxt, env, Invalid_module_alias p2]);
       if not (Path.same p1 p2) then begin
-        let p1 = Env.normalize_path None env p1
-        and p2 = Env.normalize_path None env (Subst.module_path subst p2) in
+        let p1 = Env.normalize_module_path None env p1
+        and p2 = Env.normalize_module_path None env
+            (Subst.module_path subst p2)
+        in
         if not (Path.same p1 p2) then raise Dont_match
       end;
       Tcoerce_none
   | (Mty_alias p1, _) -> begin
       let p1 = try
-        Env.normalize_path (Some Location.none) env p1
+        Env.normalize_module_path (Some Location.none) env p1
       with Env.Error (Env.Missing_module (_, _, path)) ->
         raise (Error[cxt, env, Unbound_module_path path])
       in

typing/path.ml

@@ -19,7 +19,8 @@ type t =
   | Papply of t * t
 
 let rec same p1 p2 =
-  match (p1, p2) with
+  p1 == p2
+  || match (p1, p2) with
     (Pident id1, Pident id2) -> Ident.same id1 id2
   | (Pdot(p1, s1), Pdot(p2, s2)) -> s1 = s2 && same p1 p2
   | (Papply(fun1, arg1), Papply(fun2, arg2)) ->
@@ -27,7 +28,8 @@ let rec same p1 p2 =
   | (_, _) -> false
 
 let rec compare p1 p2 =
-  match (p1, p2) with
+  if p1 == p2 then 0
+  else match (p1, p2) with
     (Pident id1, Pident id2) -> Ident.compare id1 id2
   | (Pdot(p1, s1), Pdot(p2, s2)) ->
       let h = compare p1 p2 in

typing/printtyp.ml

@@ -566,7 +566,7 @@ let rec normalize_type_path ?(cache=false) env p =
         (p, Nth (index params ty))
   with
     Not_found ->
-      (Env.normalize_path None env p, Id)
+      (Env.normalize_type_path None env p, Id)
 
 let penalty s =
   if s <> "" && s.[0] = '_' then

typing/typecore.ml

@@ -680,7 +680,7 @@ let rec expand_path env p =
       | _ -> assert false
       end
   | _ ->
-      let p' = Env.normalize_path None env p in
+      let p' = Env.normalize_type_path None env p in
       if Path.same p p' then p else expand_path env p'
 
 let compare_type_path env tpath1 tpath2 =

typing/typemod.ml

@@ -1723,7 +1723,7 @@ and type_module_aux ~alias sttn funct_body anchor env smod =
           (Env.add_required_global (Path.head path); md)
         else match (Env.find_module path env).md_type with
         | Mty_alias p1 when not alias ->
-            let p1 = Env.normalize_path (Some smod.pmod_loc) env p1 in
+            let p1 = Env.normalize_module_path (Some smod.pmod_loc) env p1 in
             let mty = Includemod.expand_module_alias env [] p1 in
             { md with
               mod_desc =