forked from ocaml/ocaml
-
Notifications
You must be signed in to change notification settings - Fork 0
/
typetexp.ml
813 lines (769 loc) · 29.6 KB
/
typetexp.ml
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 1996 Institut National de Recherche en Informatique et *)
(* en Automatique. *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
(* typetexp.ml,v 1.34.4.9 2002/01/07 08:39:16 garrigue Exp *)
(* Typechecking of type expressions for the core language *)
open Asttypes
open Misc
open Parsetree
open Typedtree
open Types
open Ctype
exception Already_bound
type error =
Unbound_type_variable of string
| Undefined_type_constructor of Path.t
| Type_arity_mismatch of Longident.t * int * int
| Bound_type_variable of string
| Recursive_type
| Unbound_row_variable of Longident.t
| Type_mismatch of Ctype.Unification_trace.t
| Alias_type_mismatch of Ctype.Unification_trace.t
| Present_has_conjunction of string
| Present_has_no_type of string
| Constructor_mismatch of type_expr * type_expr
| Not_a_variant of type_expr
| Variant_tags of string * string
| Invalid_variable_name of string
| Cannot_quantify of string * type_expr
| Multiple_constraints_on_type of Longident.t
| Method_mismatch of string * type_expr * type_expr
| Opened_object of Path.t option
| Not_an_object of type_expr
exception Error of Location.t * Env.t * error
exception Error_forward of Location.error
(** Map indexed by type variable names. *)
module TyVarMap = Misc.Stdlib.String.Map
type variable_context = int * type_expr TyVarMap.t
(* Support for first-class modules. *)
let transl_modtype_longident = ref (fun _ -> assert false)
let transl_modtype = ref (fun _ -> assert false)
let create_package_mty fake loc env (p, l) =
let l =
List.sort
(fun (s1, _t1) (s2, _t2) ->
if s1.txt = s2.txt then
raise (Error (loc, env, Multiple_constraints_on_type s1.txt));
compare s1.txt s2.txt)
l
in
l,
List.fold_left
(fun mty (s, t) ->
let d = {ptype_name = mkloc (Longident.last s.txt) s.loc;
ptype_params = [];
ptype_cstrs = [];
ptype_kind = Ptype_abstract;
ptype_private = Asttypes.Public;
ptype_manifest = if fake then None else Some t;
ptype_attributes = [];
ptype_loc = loc} in
Ast_helper.Mty.mk ~loc
(Pmty_with (mty, [ Pwith_type ({ txt = s.txt; loc }, d) ]))
)
(Ast_helper.Mty.mk ~loc (Pmty_ident p))
l
(* Translation of type expressions *)
let type_variables = ref (TyVarMap.empty : type_expr TyVarMap.t)
let univars = ref ([] : (string * type_expr) list)
let pre_univars = ref ([] : type_expr list)
let used_variables = ref (TyVarMap.empty : (type_expr * Location.t) TyVarMap.t)
let reset_type_variables () =
reset_global_level ();
Ctype.reset_reified_var_counter ();
type_variables := TyVarMap.empty
let narrow () =
(increase_global_level (), !type_variables)
let widen (gl, tv) =
restore_global_level gl;
type_variables := tv
let strict_ident c = (c = '_' || c >= 'a' && c <= 'z' || c >= 'A' && c <= 'Z')
let validate_name = function
None -> None
| Some name as s ->
if name <> "" && strict_ident name.[0] then s else None
let new_global_var ?name () =
new_global_var ?name:(validate_name name) ()
let newvar ?name () =
newvar ?name:(validate_name name) ()
let type_variable loc name =
try
TyVarMap.find name !type_variables
with Not_found ->
raise(Error(loc, Env.empty, Unbound_type_variable ("'" ^ name)))
let valid_tyvar_name name =
name <> "" && name.[0] <> '_'
let transl_type_param env styp =
let loc = styp.ptyp_loc in
match styp.ptyp_desc with
Ptyp_any ->
let ty = new_global_var ~name:"_" () in
{ ctyp_desc = Ttyp_any; ctyp_type = ty; ctyp_env = env;
ctyp_loc = loc; ctyp_attributes = styp.ptyp_attributes; }
| Ptyp_var name ->
let ty =
try
if not (valid_tyvar_name name) then
raise (Error (loc, Env.empty, Invalid_variable_name ("'" ^ name)));
ignore (TyVarMap.find name !type_variables);
raise Already_bound
with Not_found ->
let v = new_global_var ~name () in
type_variables := TyVarMap.add name v !type_variables;
v
in
{ ctyp_desc = Ttyp_var name; ctyp_type = ty; ctyp_env = env;
ctyp_loc = loc; ctyp_attributes = styp.ptyp_attributes; }
| _ -> assert false
let transl_type_param env styp =
(* Currently useless, since type parameters cannot hold attributes
(but this could easily be lifted in the future). *)
Builtin_attributes.warning_scope styp.ptyp_attributes
(fun () -> transl_type_param env styp)
let new_pre_univar ?name () =
let v = newvar ?name () in pre_univars := v :: !pre_univars; v
type policy = Fixed | Extensible | Univars
let rec transl_type env policy styp =
Builtin_attributes.warning_scope styp.ptyp_attributes
(fun () -> transl_type_aux env policy styp)
and transl_type_aux env policy styp =
let loc = styp.ptyp_loc in
let ctyp ctyp_desc ctyp_type =
{ ctyp_desc; ctyp_type; ctyp_env = env;
ctyp_loc = loc; ctyp_attributes = styp.ptyp_attributes }
in
match styp.ptyp_desc with
Ptyp_any ->
let ty =
if policy = Univars then new_pre_univar () else
if policy = Fixed then
raise (Error (styp.ptyp_loc, env, Unbound_type_variable "_"))
else newvar ()
in
ctyp Ttyp_any ty
| Ptyp_var name ->
let ty =
if not (valid_tyvar_name name) then
raise (Error (styp.ptyp_loc, env, Invalid_variable_name ("'" ^ name)));
begin try
instance (List.assoc name !univars)
with Not_found -> try
instance (fst (TyVarMap.find name !used_variables))
with Not_found ->
let v =
if policy = Univars then new_pre_univar ~name () else newvar ~name ()
in
used_variables := TyVarMap.add name (v, styp.ptyp_loc) !used_variables;
v
end
in
ctyp (Ttyp_var name) ty
| Ptyp_arrow(l, st1, st2) ->
let cty1 = transl_type env policy st1 in
let cty2 = transl_type env policy st2 in
let ty1 = cty1.ctyp_type in
let ty1 =
if Btype.is_optional l
then newty (Tconstr(Predef.path_option,[ty1], ref Mnil))
else ty1 in
let ty = newty (Tarrow(l, ty1, cty2.ctyp_type, Cok)) in
ctyp (Ttyp_arrow (l, cty1, cty2)) ty
| Ptyp_tuple stl ->
assert (List.length stl >= 2);
let ctys = List.map (transl_type env policy) stl in
let ty = newty (Ttuple (List.map (fun ctyp -> ctyp.ctyp_type) ctys)) in
ctyp (Ttyp_tuple ctys) ty
| Ptyp_constr(lid, stl) ->
let (path, decl) = Env.lookup_type ~loc:lid.loc lid.txt env in
let stl =
match stl with
| [ {ptyp_desc=Ptyp_any} as t ] when decl.type_arity > 1 ->
List.map (fun _ -> t) decl.type_params
| _ -> stl
in
if List.length stl <> decl.type_arity then
raise(Error(styp.ptyp_loc, env,
Type_arity_mismatch(lid.txt, decl.type_arity,
List.length stl)));
let args = List.map (transl_type env policy) stl in
let params = instance_list decl.type_params in
let unify_param =
match decl.type_manifest with
None -> unify_var
| Some ty ->
if (repr ty).level = Btype.generic_level then unify_var else unify
in
List.iter2
(fun (sty, cty) ty' ->
try unify_param env ty' cty.ctyp_type with Unify trace ->
let trace = Unification_trace.swap trace in
raise (Error(sty.ptyp_loc, env, Type_mismatch trace))
)
(List.combine stl args) params;
let constr =
newconstr path (List.map (fun ctyp -> ctyp.ctyp_type) args) in
begin try
Ctype.enforce_constraints env constr
with Unify trace ->
raise (Error(styp.ptyp_loc, env, Type_mismatch trace))
end;
ctyp (Ttyp_constr (path, lid, args)) constr
| Ptyp_object (fields, o) ->
let ty, fields = transl_fields env policy o fields in
ctyp (Ttyp_object (fields, o)) (newobj ty)
| Ptyp_class(lid, stl) ->
let (path, decl, _is_variant) =
try
let path, decl = Env.find_type_by_name lid.txt env in
let rec check decl =
match decl.type_manifest with
None -> raise Not_found
| Some ty ->
match (repr ty).desc with
Tvariant row when Btype.static_row row -> ()
| Tconstr (path, _, _) ->
check (Env.find_type path env)
| _ -> raise Not_found
in check decl;
Location.deprecated styp.ptyp_loc
"old syntax for polymorphic variant type";
ignore(Env.lookup_type ~loc:lid.loc lid.txt env);
(path, decl,true)
with Not_found -> try
let lid2 =
match lid.txt with
Longident.Lident s -> Longident.Lident ("#" ^ s)
| Longident.Ldot(r, s) -> Longident.Ldot (r, "#" ^ s)
| Longident.Lapply(_, _) -> fatal_error "Typetexp.transl_type"
in
let path, decl = Env.find_type_by_name lid2 env in
ignore(Env.lookup_cltype ~loc:lid.loc lid.txt env);
(path, decl, false)
with Not_found ->
ignore (Env.lookup_cltype ~loc:lid.loc lid.txt env); assert false
in
if List.length stl <> decl.type_arity then
raise(Error(styp.ptyp_loc, env,
Type_arity_mismatch(lid.txt, decl.type_arity,
List.length stl)));
let args = List.map (transl_type env policy) stl in
let params = instance_list decl.type_params in
List.iter2
(fun (sty, cty) ty' ->
try unify_var env ty' cty.ctyp_type with Unify trace ->
let trace = Unification_trace.swap trace in
raise (Error(sty.ptyp_loc, env, Type_mismatch trace))
)
(List.combine stl args) params;
let ty_args = List.map (fun ctyp -> ctyp.ctyp_type) args in
let ty =
try Ctype.expand_head env (newconstr path ty_args)
with Unify trace ->
raise (Error(styp.ptyp_loc, env, Type_mismatch trace))
in
let ty = match ty.desc with
Tvariant row ->
let row = Btype.row_repr row in
let fields =
List.map
(fun (l,f) -> l,
match Btype.row_field_repr f with
| Rpresent (Some ty) ->
Reither(false, [ty], false, ref None)
| Rpresent None ->
Reither (true, [], false, ref None)
| _ -> f)
row.row_fields
in
let row = { row_closed = true; row_fields = fields;
row_bound = (); row_name = Some (path, ty_args);
row_fixed = None; row_more = newvar () } in
let static = Btype.static_row row in
let row =
if static then { row with row_more = newty Tnil }
else if policy <> Univars then row
else { row with row_more = new_pre_univar () }
in
newty (Tvariant row)
| Tobject (fi, _) ->
let _, tv = flatten_fields fi in
if policy = Univars then pre_univars := tv :: !pre_univars;
ty
| _ ->
assert false
in
ctyp (Ttyp_class (path, lid, args)) ty
| Ptyp_alias(st, alias) ->
let cty =
try
let t =
try List.assoc alias !univars
with Not_found ->
instance (fst(TyVarMap.find alias !used_variables))
in
let ty = transl_type env policy st in
begin try unify_var env t ty.ctyp_type with Unify trace ->
let trace = Unification_trace.swap trace in
raise(Error(styp.ptyp_loc, env, Alias_type_mismatch trace))
end;
ty
with Not_found ->
if !Clflags.principal then begin_def ();
let t = newvar () in
used_variables :=
TyVarMap.add alias (t, styp.ptyp_loc) !used_variables;
let ty = transl_type env policy st in
begin try unify_var env t ty.ctyp_type with Unify trace ->
let trace = Unification_trace.swap trace in
raise(Error(styp.ptyp_loc, env, Alias_type_mismatch trace))
end;
if !Clflags.principal then begin
end_def ();
generalize_structure t;
end;
let t = instance t in
let px = Btype.proxy t in
begin match px.desc with
| Tvar None -> Btype.set_type_desc px (Tvar (Some alias))
| Tunivar None -> Btype.set_type_desc px (Tunivar (Some alias))
| _ -> ()
end;
{ ty with ctyp_type = t }
in
ctyp (Ttyp_alias (cty, alias)) cty.ctyp_type
| Ptyp_variant(fields, closed, present) ->
let name = ref None in
let mkfield l f =
newty (Tvariant {row_fields=[l,f]; row_more=newvar();
row_bound=(); row_closed=true;
row_fixed=None; row_name=None}) in
let hfields = Hashtbl.create 17 in
let add_typed_field loc l f =
let h = Btype.hash_variant l in
try
let (l',f') = Hashtbl.find hfields h in
(* Check for tag conflicts *)
if l <> l' then raise(Error(styp.ptyp_loc, env, Variant_tags(l, l')));
let ty = mkfield l f and ty' = mkfield l f' in
if equal env false [ty] [ty'] then () else
try unify env ty ty'
with Unify _trace ->
raise(Error(loc, env, Constructor_mismatch (ty,ty')))
with Not_found ->
Hashtbl.add hfields h (l,f)
in
let add_field field =
let rf_loc = field.prf_loc in
let rf_attributes = field.prf_attributes in
let rf_desc = match field.prf_desc with
| Rtag (l, c, stl) ->
name := None;
let tl =
Builtin_attributes.warning_scope rf_attributes
(fun () -> List.map (transl_type env policy) stl)
in
let f = match present with
Some present when not (List.mem l.txt present) ->
let ty_tl = List.map (fun cty -> cty.ctyp_type) tl in
Reither(c, ty_tl, false, ref None)
| _ ->
if List.length stl > 1 || c && stl <> [] then
raise(Error(styp.ptyp_loc, env,
Present_has_conjunction l.txt));
match tl with [] -> Rpresent None
| st :: _ ->
Rpresent (Some st.ctyp_type)
in
add_typed_field styp.ptyp_loc l.txt f;
Ttag (l,c,tl)
| Rinherit sty ->
let cty = transl_type env policy sty in
let ty = cty.ctyp_type in
let nm =
match repr cty.ctyp_type with
{desc=Tconstr(p, tl, _)} -> Some(p, tl)
| _ -> None
in
begin try
(* Set name if there are no fields yet *)
Hashtbl.iter (fun _ _ -> raise Exit) hfields;
name := nm
with Exit ->
(* Unset it otherwise *)
name := None
end;
let fl = match expand_head env cty.ctyp_type, nm with
{desc=Tvariant row}, _ when Btype.static_row row ->
let row = Btype.row_repr row in
row.row_fields
| {desc=Tvar _}, Some(p, _) ->
raise(Error(sty.ptyp_loc, env, Undefined_type_constructor p))
| _ ->
raise(Error(sty.ptyp_loc, env, Not_a_variant ty))
in
List.iter
(fun (l, f) ->
let f = match present with
Some present when not (List.mem l present) ->
begin match f with
Rpresent(Some ty) ->
Reither(false, [ty], false, ref None)
| Rpresent None ->
Reither(true, [], false, ref None)
| _ ->
assert false
end
| _ -> f
in
add_typed_field sty.ptyp_loc l f)
fl;
Tinherit cty
in
{ rf_desc; rf_loc; rf_attributes; }
in
let tfields = List.map add_field fields in
let fields = Hashtbl.fold (fun _ p l -> p :: l) hfields [] in
begin match present with None -> ()
| Some present ->
List.iter
(fun l -> if not (List.mem_assoc l fields) then
raise(Error(styp.ptyp_loc, env, Present_has_no_type l)))
present
end;
let row =
{ row_fields = List.rev fields; row_more = newvar ();
row_bound = (); row_closed = (closed = Closed);
row_fixed = None; row_name = !name } in
let static = Btype.static_row row in
let row =
if static then { row with row_more = newty Tnil }
else if policy <> Univars then row
else { row with row_more = new_pre_univar () }
in
let ty = newty (Tvariant row) in
ctyp (Ttyp_variant (tfields, closed, present)) ty
| Ptyp_poly(vars, st) ->
let vars = List.map (fun v -> v.txt) vars in
begin_def();
let new_univars = List.map (fun name -> name, newvar ~name ()) vars in
let old_univars = !univars in
univars := new_univars @ !univars;
let cty = transl_type env policy st in
let ty = cty.ctyp_type in
univars := old_univars;
end_def();
generalize ty;
let ty_list =
List.fold_left
(fun tyl (name, ty1) ->
let v = Btype.proxy ty1 in
if deep_occur v ty then begin
match v.desc with
Tvar name when v.level = Btype.generic_level ->
v.desc <- Tunivar name;
v :: tyl
| _ ->
raise (Error (styp.ptyp_loc, env, Cannot_quantify (name, v)))
end else tyl)
[] new_univars
in
let ty' = Btype.newgenty (Tpoly(ty, List.rev ty_list)) in
unify_var env (newvar()) ty';
ctyp (Ttyp_poly (vars, cty)) ty'
| Ptyp_package (p, l) ->
let l, mty = create_package_mty true styp.ptyp_loc env (p, l) in
let z = narrow () in
let mty = !transl_modtype env mty in
widen z;
let ptys = List.map (fun (s, pty) ->
s, transl_type env policy pty
) l in
let path = !transl_modtype_longident styp.ptyp_loc env p.txt in
let ty = newty (Tpackage (path,
List.map (fun (s, _pty) -> s.txt) l,
List.map (fun (_,cty) -> cty.ctyp_type) ptys))
in
ctyp (Ttyp_package {
pack_path = path;
pack_type = mty.mty_type;
pack_fields = ptys;
pack_txt = p;
}) ty
| Ptyp_extension ext ->
raise (Error_forward (Builtin_attributes.error_of_extension ext))
and transl_poly_type env policy t =
transl_type env policy (Ast_helper.Typ.force_poly t)
and transl_fields env policy o fields =
let hfields = Hashtbl.create 17 in
let add_typed_field loc l ty =
try
let ty' = Hashtbl.find hfields l in
if equal env false [ty] [ty'] then () else
try unify env ty ty'
with Unify _trace ->
raise(Error(loc, env, Method_mismatch (l, ty, ty')))
with Not_found ->
Hashtbl.add hfields l ty in
let add_field {pof_desc; pof_loc; pof_attributes;} =
let of_loc = pof_loc in
let of_attributes = pof_attributes in
let of_desc = match pof_desc with
| Otag (s, ty1) -> begin
let ty1 =
Builtin_attributes.warning_scope of_attributes
(fun () -> transl_poly_type env policy ty1)
in
let field = OTtag (s, ty1) in
add_typed_field ty1.ctyp_loc s.txt ty1.ctyp_type;
field
end
| Oinherit sty -> begin
let cty = transl_type env policy sty in
let nm =
match repr cty.ctyp_type with
{desc=Tconstr(p, _, _)} -> Some p
| _ -> None in
let t = expand_head env cty.ctyp_type in
match t, nm with
{desc=Tobject ({desc=(Tfield _ | Tnil) as tf}, _)}, _ -> begin
if opened_object t then
raise (Error (sty.ptyp_loc, env, Opened_object nm));
let rec iter_add = function
| Tfield (s, _k, ty1, ty2) -> begin
add_typed_field sty.ptyp_loc s ty1;
iter_add ty2.desc
end
| Tnil -> ()
| _ -> assert false in
iter_add tf;
OTinherit cty
end
| {desc=Tvar _}, Some p ->
raise (Error (sty.ptyp_loc, env, Undefined_type_constructor p))
| _ -> raise (Error (sty.ptyp_loc, env, Not_an_object t))
end in
{ of_desc; of_loc; of_attributes; }
in
let object_fields = List.map add_field fields in
let fields = Hashtbl.fold (fun s ty l -> (s, ty) :: l) hfields [] in
let ty_init =
match o, policy with
| Closed, _ -> newty Tnil
| Open, Univars -> new_pre_univar ()
| Open, _ -> newvar () in
let ty = List.fold_left (fun ty (s, ty') ->
newty (Tfield (s, Fpresent, ty', ty))) ty_init fields in
ty, object_fields
(* Make the rows "fixed" in this type, to make universal check easier *)
let rec make_fixed_univars ty =
let ty = repr ty in
if ty.level >= Btype.lowest_level then begin
Btype.mark_type_node ty;
match ty.desc with
| Tvariant row ->
let row = Btype.row_repr row in
let more = Btype.row_more row in
if Btype.is_Tunivar more then
ty.desc <- Tvariant
{row with row_fixed=Some(Univar more);
row_fields = List.map
(fun (s,f as p) -> match Btype.row_field_repr f with
Reither (c, tl, _m, r) -> s, Reither (c, tl, true, r)
| _ -> p)
row.row_fields};
Btype.iter_row make_fixed_univars row
| _ ->
Btype.iter_type_expr make_fixed_univars ty
end
let make_fixed_univars ty =
make_fixed_univars ty;
Btype.unmark_type ty
let create_package_mty = create_package_mty false
let globalize_used_variables env fixed =
let r = ref [] in
TyVarMap.iter
(fun name (ty, loc) ->
let v = new_global_var () in
let snap = Btype.snapshot () in
if try unify env v ty; true with _ -> Btype.backtrack snap; false
then try
r := (loc, v, TyVarMap.find name !type_variables) :: !r
with Not_found ->
if fixed && Btype.is_Tvar (repr ty) then
raise(Error(loc, env, Unbound_type_variable ("'"^name)));
let v2 = new_global_var () in
r := (loc, v, v2) :: !r;
type_variables := TyVarMap.add name v2 !type_variables)
!used_variables;
used_variables := TyVarMap.empty;
fun () ->
List.iter
(function (loc, t1, t2) ->
try unify env t1 t2 with Unify trace ->
raise (Error(loc, env, Type_mismatch trace)))
!r
let transl_simple_type env fixed styp =
univars := []; used_variables := TyVarMap.empty;
let typ = transl_type env (if fixed then Fixed else Extensible) styp in
globalize_used_variables env fixed ();
make_fixed_univars typ.ctyp_type;
typ
let transl_simple_type_univars env styp =
univars := []; used_variables := TyVarMap.empty; pre_univars := [];
begin_def ();
let typ = transl_type env Univars styp in
(* Only keep already global variables in used_variables *)
let new_variables = !used_variables in
used_variables := TyVarMap.empty;
TyVarMap.iter
(fun name p ->
if TyVarMap.mem name !type_variables then
used_variables := TyVarMap.add name p !used_variables)
new_variables;
globalize_used_variables env false ();
end_def ();
generalize typ.ctyp_type;
let univs =
List.fold_left
(fun acc v ->
let v = repr v in
match v.desc with
Tvar name when v.level = Btype.generic_level ->
v.desc <- Tunivar name; v :: acc
| _ -> acc)
[] !pre_univars
in
make_fixed_univars typ.ctyp_type;
{ typ with ctyp_type =
instance (Btype.newgenty (Tpoly (typ.ctyp_type, univs))) }
let transl_simple_type_delayed env styp =
univars := []; used_variables := TyVarMap.empty;
let typ = transl_type env Extensible styp in
make_fixed_univars typ.ctyp_type;
(typ, globalize_used_variables env false)
let transl_type_scheme env styp =
reset_type_variables();
begin_def();
let typ = transl_simple_type env false styp in
end_def();
generalize typ.ctyp_type;
typ
(* Error report *)
open Format
open Printtyp
let report_error env ppf = function
| Unbound_type_variable name ->
let add_name name _ l = if name = "_" then l else ("'" ^ name) :: l in
let names = TyVarMap.fold add_name !type_variables [] in
fprintf ppf "The type variable %s is unbound in this type declaration.@ %a"
name
did_you_mean (fun () -> Misc.spellcheck names name )
| Undefined_type_constructor p ->
fprintf ppf "The type constructor@ %a@ is not yet completely defined"
path p
| Type_arity_mismatch(lid, expected, provided) ->
fprintf ppf
"@[The type constructor %a@ expects %i argument(s),@ \
but is here applied to %i argument(s)@]"
longident lid expected provided
| Bound_type_variable name ->
fprintf ppf "Already bound type parameter %a" Pprintast.tyvar name
| Recursive_type ->
fprintf ppf "This type is recursive"
| Unbound_row_variable lid ->
(* we don't use "spellcheck" here: this error is not raised
anywhere so it's unclear how it should be handled *)
fprintf ppf "Unbound row variable in #%a" longident lid
| Type_mismatch trace ->
Printtyp.report_unification_error ppf Env.empty trace
(function ppf ->
fprintf ppf "This type")
(function ppf ->
fprintf ppf "should be an instance of type")
| Alias_type_mismatch trace ->
Printtyp.report_unification_error ppf Env.empty trace
(function ppf ->
fprintf ppf "This alias is bound to type")
(function ppf ->
fprintf ppf "but is used as an instance of type")
| Present_has_conjunction l ->
fprintf ppf "The present constructor %s has a conjunctive type" l
| Present_has_no_type l ->
fprintf ppf
"@[<v>@[The constructor %s is missing from the upper bound@ \
(between '<'@ and '>')@ of this polymorphic variant@ \
but is present in@ its lower bound (after '>').@]@,\
@[Hint: Either add `%s in the upper bound,@ \
or remove it@ from the lower bound.@]@]"
l l
| Constructor_mismatch (ty, ty') ->
wrap_printing_env ~error:true env (fun () ->
Printtyp.reset_and_mark_loops_list [ty; ty'];
fprintf ppf "@[<hov>%s %a@ %s@ %a@]"
"This variant type contains a constructor"
!Oprint.out_type (tree_of_typexp false ty)
"which should be"
!Oprint.out_type (tree_of_typexp false ty'))
| Not_a_variant ty ->
fprintf ppf
"@[The type %a@ does not expand to a polymorphic variant type@]"
Printtyp.type_expr ty;
begin match ty.desc with
| Tvar (Some s) ->
(* PR#7012: help the user that wrote 'Foo instead of `Foo *)
Misc.did_you_mean ppf (fun () -> ["`" ^ s])
| _ -> ()
end
| Variant_tags (lab1, lab2) ->
fprintf ppf
"@[Variant tags `%s@ and `%s have the same hash value.@ %s@]"
lab1 lab2 "Change one of them."
| Invalid_variable_name name ->
fprintf ppf "The type variable name %s is not allowed in programs" name
| Cannot_quantify (name, v) ->
fprintf ppf
"@[<hov>The universal type variable %a cannot be generalized:@ "
Pprintast.tyvar name;
if Btype.is_Tvar v then
fprintf ppf "it escapes its scope"
else if Btype.is_Tunivar v then
fprintf ppf "it is already bound to another variable"
else
fprintf ppf "it is bound to@ %a" Printtyp.type_expr v;
fprintf ppf ".@]";
| Multiple_constraints_on_type s ->
fprintf ppf "Multiple constraints for type %a" longident s
| Method_mismatch (l, ty, ty') ->
wrap_printing_env ~error:true env (fun () ->
fprintf ppf "@[<hov>Method '%s' has type %a,@ which should be %a@]"
l Printtyp.type_expr ty Printtyp.type_expr ty')
| Opened_object nm ->
fprintf ppf
"Illegal open object type%a"
(fun ppf -> function
Some p -> fprintf ppf "@ %a" path p
| None -> fprintf ppf "") nm
| Not_an_object ty ->
fprintf ppf "@[The type %a@ is not an object type@]"
Printtyp.type_expr ty
let () =
Location.register_error_of_exn
(function
| Error (loc, env, err) ->
Some (Location.error_of_printer ~loc (report_error env) err)
| Error_forward err ->
Some err
| _ ->
None
)