Fix wrong calls to Env.normalize_path on non-module paths (#2131)
parent
f6837be875
commit
4c130cae87
3
Changes
3
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)
|
||||
-----------------------------
|
||||
|
|
BIN
boot/ocamlc
BIN
boot/ocamlc
Binary file not shown.
BIN
boot/ocamllex
BIN
boot/ocamllex
Binary file not shown.
|
@ -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
|
||||
|
|
|
@ -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}
|
||||
|}]
|
|
@ -4,6 +4,7 @@ firstclass.ml
|
|||
generative.ml
|
||||
nondep.ml
|
||||
nondep_private_abbrev.ml
|
||||
normalize_path.ml
|
||||
pr5911.ml
|
||||
pr6394.ml
|
||||
pr7207.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) ->
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 =
|
||||
|
|
|
@ -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 =
|
||||
|
|
Loading…
Reference in New Issue