toplevel: a discrepancy in extension constructors printing
fixes #9148 genprintval.tree_of_extension was missing instantiation of constructor argument types. the Ctype.apply code is factorized out from a number of other places.master
parent
9f804a25d2
commit
8f87147c9d
4
Changes
4
Changes
|
@ -385,6 +385,10 @@ Working version
|
||||||
- #9421, #9427: fix printing of (::) in ocamldoc
|
- #9421, #9427: fix printing of (::) in ocamldoc
|
||||||
(Florian Angeletti, report by Yawar Amin, review by Damien Doligez)
|
(Florian Angeletti, report by Yawar Amin, review by Damien Doligez)
|
||||||
|
|
||||||
|
- #9440: for a type extension constructor with parameterised arguments,
|
||||||
|
REPL displayed <poly> for each as opposed to the concrete values used.
|
||||||
|
(Christian Quinn, review by Gabriel Scherer)
|
||||||
|
|
||||||
- #9469: Better backtraces for lazy values
|
- #9469: Better backtraces for lazy values
|
||||||
(Leo White, review by Nicolás Ojeda Bär)
|
(Leo White, review by Nicolás Ojeda Bär)
|
||||||
|
|
||||||
|
|
|
@ -0,0 +1,60 @@
|
||||||
|
(* TEST
|
||||||
|
* expect
|
||||||
|
*)
|
||||||
|
|
||||||
|
(* Test a success case *)
|
||||||
|
type 'a t = T of 'a
|
||||||
|
;;
|
||||||
|
T 123
|
||||||
|
[%%expect {|
|
||||||
|
type 'a t = T of 'a
|
||||||
|
- : int t = T 123
|
||||||
|
|}]
|
||||||
|
|
||||||
|
(* no <poly> after fix *)
|
||||||
|
type _ t = ..
|
||||||
|
type 'a t += T of 'a
|
||||||
|
;;
|
||||||
|
T 123
|
||||||
|
[%%expect {|
|
||||||
|
type _ t = ..
|
||||||
|
type 'a t += T of 'a
|
||||||
|
- : int t = T 123
|
||||||
|
|}]
|
||||||
|
|
||||||
|
|
||||||
|
(* GADT with fixed arg type *)
|
||||||
|
type _ t += T: char -> int t
|
||||||
|
;;
|
||||||
|
T 'x'
|
||||||
|
[%%expect {|
|
||||||
|
type _ t += T : char -> int t
|
||||||
|
- : int t = T 'x'
|
||||||
|
|}]
|
||||||
|
|
||||||
|
|
||||||
|
(* GADT with poly arg type.... and the expected T <poly> *)
|
||||||
|
type _ t += T: 'a -> int t
|
||||||
|
;;
|
||||||
|
T 'x'
|
||||||
|
[%%expect {|
|
||||||
|
type _ t += T : 'a -> int t
|
||||||
|
- : int t = T <poly>
|
||||||
|
|}]
|
||||||
|
|
||||||
|
(* the rest are expected without <poly> *)
|
||||||
|
type _ t += T: 'a * bool -> 'a t
|
||||||
|
;;
|
||||||
|
T ('x',true)
|
||||||
|
[%%expect {|
|
||||||
|
type _ t += T : 'a * bool -> 'a t
|
||||||
|
- : char t = T ('x', true)
|
||||||
|
|}]
|
||||||
|
|
||||||
|
type _ t += T: 'a -> ('a * bool) t
|
||||||
|
;;
|
||||||
|
T 'x'
|
||||||
|
[%%expect {|
|
||||||
|
type _ t += T : 'a -> ('a * bool) t
|
||||||
|
- : (char * bool) t = T 'x'
|
||||||
|
|}]
|
|
@ -384,8 +384,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
|
||||||
Oval_stuff "<abstr>"
|
Oval_stuff "<abstr>"
|
||||||
| {type_kind = Type_abstract; type_manifest = Some body} ->
|
| {type_kind = Type_abstract; type_manifest = Some body} ->
|
||||||
tree_of_val depth obj
|
tree_of_val depth obj
|
||||||
(try Ctype.apply env decl.type_params body ty_list with
|
(instantiate_type env decl.type_params ty_list body)
|
||||||
Ctype.Cannot_apply -> abstract_type)
|
|
||||||
| {type_kind = Type_variant constr_list; type_unboxed} ->
|
| {type_kind = Type_variant constr_list; type_unboxed} ->
|
||||||
let unbx = type_unboxed.unboxed in
|
let unbx = type_unboxed.unboxed in
|
||||||
let tag =
|
let tag =
|
||||||
|
@ -408,12 +407,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
|
||||||
match cd_args with
|
match cd_args with
|
||||||
| Cstr_tuple l ->
|
| Cstr_tuple l ->
|
||||||
let ty_args =
|
let ty_args =
|
||||||
List.map
|
instantiate_types env type_params ty_list l in
|
||||||
(function ty ->
|
|
||||||
try Ctype.apply env type_params ty ty_list with
|
|
||||||
Ctype.Cannot_apply -> abstract_type)
|
|
||||||
l
|
|
||||||
in
|
|
||||||
tree_of_constr_with_args (tree_of_constr env path)
|
tree_of_constr_with_args (tree_of_constr env path)
|
||||||
(Ident.name cd_id) false 0 depth obj
|
(Ident.name cd_id) false 0 depth obj
|
||||||
ty_args unbx
|
ty_args unbx
|
||||||
|
@ -444,7 +438,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
|
||||||
lbl_list pos obj unbx
|
lbl_list pos obj unbx
|
||||||
end
|
end
|
||||||
| {type_kind = Type_open} ->
|
| {type_kind = Type_open} ->
|
||||||
tree_of_extension path depth obj
|
tree_of_extension path ty_list depth obj
|
||||||
with
|
with
|
||||||
Not_found -> (* raised by Env.find_type *)
|
Not_found -> (* raised by Env.find_type *)
|
||||||
Oval_stuff "<abstr>"
|
Oval_stuff "<abstr>"
|
||||||
|
@ -494,12 +488,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
|
||||||
let rec tree_of_fields pos = function
|
let rec tree_of_fields pos = function
|
||||||
| [] -> []
|
| [] -> []
|
||||||
| {ld_id; ld_type} :: remainder ->
|
| {ld_id; ld_type} :: remainder ->
|
||||||
let ty_arg =
|
let ty_arg = instantiate_type env type_params ty_list ld_type in
|
||||||
try
|
|
||||||
Ctype.apply env type_params ld_type
|
|
||||||
ty_list
|
|
||||||
with
|
|
||||||
Ctype.Cannot_apply -> abstract_type in
|
|
||||||
let name = Ident.name ld_id in
|
let name = Ident.name ld_id in
|
||||||
(* PR#5722: print full module path only
|
(* PR#5722: print full module path only
|
||||||
for first record field *)
|
for first record field *)
|
||||||
|
@ -544,7 +533,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
|
||||||
in
|
in
|
||||||
Oval_constr (lid, args)
|
Oval_constr (lid, args)
|
||||||
|
|
||||||
and tree_of_extension type_path depth bucket =
|
and tree_of_extension type_path ty_list depth bucket =
|
||||||
let slot =
|
let slot =
|
||||||
if O.tag bucket <> 0 then bucket
|
if O.tag bucket <> 0 then bucket
|
||||||
else O.field bucket 0
|
else O.field bucket 0
|
||||||
|
@ -571,10 +560,17 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
|
||||||
identifier contained in the exception bucket *)
|
identifier contained in the exception bucket *)
|
||||||
if not (EVP.same_value slot (EVP.eval_address addr))
|
if not (EVP.same_value slot (EVP.eval_address addr))
|
||||||
then raise Not_found;
|
then raise Not_found;
|
||||||
|
let type_params =
|
||||||
|
match (Ctype.repr cstr.cstr_res).desc with
|
||||||
|
Tconstr (_,params,_) ->
|
||||||
|
params
|
||||||
|
| _ -> assert false
|
||||||
|
in
|
||||||
|
let args = instantiate_types env type_params ty_list cstr.cstr_args in
|
||||||
tree_of_constr_with_args
|
tree_of_constr_with_args
|
||||||
(fun x -> Oide_ident x) name (cstr.cstr_inlined <> None)
|
(fun x -> Oide_ident x) name (cstr.cstr_inlined <> None)
|
||||||
1 depth bucket
|
1 depth bucket
|
||||||
cstr.cstr_args false
|
args false
|
||||||
with Not_found | EVP.Error ->
|
with Not_found | EVP.Error ->
|
||||||
match check_depth depth bucket ty with
|
match check_depth depth bucket ty with
|
||||||
Some x -> x
|
Some x -> x
|
||||||
|
@ -583,6 +579,13 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
|
||||||
| None ->
|
| None ->
|
||||||
Oval_stuff "<extension>"
|
Oval_stuff "<extension>"
|
||||||
|
|
||||||
|
and instantiate_type env type_params ty_list ty =
|
||||||
|
try Ctype.apply env type_params ty ty_list
|
||||||
|
with Ctype.Cannot_apply -> abstract_type
|
||||||
|
|
||||||
|
and instantiate_types env type_params ty_list args =
|
||||||
|
List.map (instantiate_type env type_params ty_list) args
|
||||||
|
|
||||||
and find_printer depth env ty =
|
and find_printer depth env ty =
|
||||||
let rec find = function
|
let rec find = function
|
||||||
| [] -> raise Not_found
|
| [] -> raise Not_found
|
||||||
|
|
Loading…
Reference in New Issue