forked from ocamllabs/ocaml
-
Notifications
You must be signed in to change notification settings - Fork 1
/
typeclass.ml
1893 lines (1762 loc) · 66.6 KB
/
typeclass.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
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
(***********************************************************************)
(* *)
(* OCaml *)
(* *)
(* Jerome Vouillon, 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 Q Public License version 1.0. *)
(* *)
(***********************************************************************)
open Parsetree
open Asttypes
open Path
open Types
open Typecore
open Typetexp
open Format
type error =
Unconsistent_constraint of (type_expr * type_expr) list
| Field_type_mismatch of string * string * (type_expr * type_expr) list
| Structure_expected of class_type
| Cannot_apply of class_type
| Apply_wrong_label of label
| Pattern_type_clash of type_expr
| Repeated_parameter
| Unbound_class_2 of Longident.t
| Unbound_class_type_2 of Longident.t
| Abbrev_type_clash of type_expr * type_expr * type_expr
| Constructor_type_mismatch of string * (type_expr * type_expr) list
| Virtual_class of bool * bool * string list * string list
| Parameter_arity_mismatch of Longident.t * int * int
| Parameter_mismatch of (type_expr * type_expr) list
| Bad_parameters of Ident.t * type_expr * type_expr
| Class_match_failure of Ctype.class_match_failure list
| Unbound_val of string
| Unbound_type_var of (formatter -> unit) * Ctype.closed_class_failure
| Make_nongen_seltype of type_expr
| Non_generalizable_class of Ident.t * Types.class_declaration
| Cannot_coerce_self of type_expr
| Non_collapsable_conjunction of
Ident.t * Types.class_declaration * (type_expr * type_expr) list
| Final_self_clash of (type_expr * type_expr) list
| Mutability_mismatch of string * mutable_flag
| No_overriding of string * string
| Duplicate of string * string
exception Error of Location.t * Env.t * error
exception Error_forward of Location.error
open Typedtree
let ctyp desc typ env loc =
{ ctyp_desc = desc; ctyp_type = typ; ctyp_loc = loc; ctyp_env = env; ctyp_attributes = [] }
(**********************)
(* Useful constants *)
(**********************)
(*
Self type have a dummy private method, thus preventing it to become
closed.
*)
let dummy_method = Btype.dummy_method
(*
Path associated to the temporary class type of a class being typed
(its constructor is not available).
*)
let unbound_class = Path.Pident (Ident.create "")
(************************************)
(* Some operations on class types *)
(************************************)
(* Fully expand the head of a class type *)
let rec scrape_class_type =
function
Cty_constr (_, _, cty) -> scrape_class_type cty
| cty -> cty
(* Generalize a class type *)
let rec generalize_class_type gen =
function
Cty_constr (_, params, cty) ->
List.iter gen params;
generalize_class_type gen cty
| Cty_signature {csig_self = sty; csig_vars = vars; csig_inher = inher} ->
gen sty;
Vars.iter (fun _ (_, _, ty) -> gen ty) vars;
List.iter (fun (_,tl) -> List.iter gen tl) inher
| Cty_arrow (_, ty, cty) ->
gen ty;
generalize_class_type gen cty
let generalize_class_type vars =
let gen = if vars then Ctype.generalize else Ctype.generalize_structure in
generalize_class_type gen
(* Return the virtual methods of a class type *)
let virtual_methods sign =
let (fields, _) =
Ctype.flatten_fields (Ctype.object_fields sign.Types.csig_self)
in
List.fold_left
(fun virt (lab, _, _) ->
if lab = dummy_method then virt else
if Concr.mem lab sign.csig_concr then virt else
lab::virt)
[] fields
(* Return the constructor type associated to a class type *)
let rec constructor_type constr cty =
match cty with
Cty_constr (_, _, cty) ->
constructor_type constr cty
| Cty_signature sign ->
constr
| Cty_arrow (l, ty, cty) ->
let eff = Ctype.instance_def (Predef.effect_io (Ctype.newty Tenil)) in
Ctype.newty (Tarrow (l, ty, eff, constructor_type constr cty, Cok))
let rec class_body cty =
match cty with
Cty_constr (_, _, cty') ->
cty (* Only class bodies can be abbreviated *)
| Cty_signature sign ->
cty
| Cty_arrow (_, ty, cty) ->
class_body cty
let extract_constraints cty =
let sign = Ctype.signature_of_class_type cty in
(Vars.fold (fun lab _ vars -> lab :: vars) sign.csig_vars [],
begin let (fields, _) =
Ctype.flatten_fields (Ctype.object_fields sign.csig_self)
in
List.fold_left
(fun meths (lab, _, _) ->
if lab = dummy_method then meths else lab::meths)
[] fields
end,
sign.csig_concr)
let rec abbreviate_class_type path params cty =
match cty with
Cty_constr (_, _, _) | Cty_signature _ ->
Cty_constr (path, params, cty)
| Cty_arrow (l, ty, cty) ->
Cty_arrow (l, ty, abbreviate_class_type path params cty)
let rec closed_class_type =
function
Cty_constr (_, params, _) ->
List.for_all Ctype.closed_schema params
| Cty_signature sign ->
Ctype.closed_schema sign.csig_self
&&
Vars.fold (fun _ (_, _, ty) cc -> Ctype.closed_schema ty && cc)
sign.csig_vars
true
| Cty_arrow (_, ty, cty) ->
Ctype.closed_schema ty
&&
closed_class_type cty
let closed_class cty =
List.for_all Ctype.closed_schema cty.cty_params
&&
closed_class_type cty.cty_type
let rec limited_generalize rv =
function
Cty_constr (path, params, cty) ->
List.iter (Ctype.limited_generalize rv) params;
limited_generalize rv cty
| Cty_signature sign ->
Ctype.limited_generalize rv sign.csig_self;
Vars.iter (fun _ (_, _, ty) -> Ctype.limited_generalize rv ty)
sign.csig_vars;
List.iter (fun (_, tl) -> List.iter (Ctype.limited_generalize rv) tl)
sign.csig_inher
| Cty_arrow (_, ty, cty) ->
Ctype.limited_generalize rv ty;
limited_generalize rv cty
(* Record a class type *)
let rc node =
Cmt_format.add_saved_type (Cmt_format.Partial_class_expr node);
Stypes.record (Stypes.Ti_class node); (* moved to genannot *)
node
(***********************************)
(* Primitives for typing classes *)
(***********************************)
(* Enter a value in the method environment only *)
let enter_met_env ?check loc lab kind ty val_env met_env par_env =
let (id, val_env) =
Env.enter_value lab {val_type = ty; val_kind = Val_unbound;
val_attributes = [];
Types.val_loc = loc} val_env
in
(id, val_env,
Env.add_value ?check id {val_type = ty; val_kind = kind;
val_attributes = [];
Types.val_loc = loc} met_env,
Env.add_value id {val_type = ty; val_kind = Val_unbound;
val_attributes = [];
Types.val_loc = loc} par_env)
(* Enter an instance variable in the environment *)
let enter_val cl_num vars inh lab mut virt ty val_env met_env par_env loc =
let instance = Ctype.instance val_env in
let (id, virt) =
try
let (id, mut', virt', ty') = Vars.find lab !vars in
if mut' <> mut then
raise (Error(loc, val_env, Mutability_mismatch(lab, mut)));
Ctype.unify val_env (instance ty) (instance ty');
(if not inh then Some id else None),
(if virt' = Concrete then virt' else virt)
with
Ctype.Unify tr ->
raise (Error(loc, val_env,
Field_type_mismatch("instance variable", lab, tr)))
| Not_found -> None, virt
in
let (id, _, _, _) as result =
match id with Some id -> (id, val_env, met_env, par_env)
| None ->
enter_met_env Location.none lab (Val_ivar (mut, cl_num))
ty val_env met_env par_env
in
vars := Vars.add lab (id, mut, virt, ty) !vars;
result
let concr_vals vars =
Vars.fold
(fun id (_, vf, _) s -> if vf = Virtual then s else Concr.add id s)
vars Concr.empty
let inheritance self_type env ovf concr_meths warn_vals loc parent =
match scrape_class_type parent with
Cty_signature cl_sig ->
(* Methods *)
begin try
Ctype.unify env self_type cl_sig.csig_self
with Ctype.Unify trace ->
match trace with
_::_::_::({desc = Tfield(n, _, _, _)}, _)::rem ->
raise(Error(loc, env, Field_type_mismatch ("method", n, rem)))
| _ ->
assert false
end;
(* Overriding *)
let over_meths = Concr.inter cl_sig.csig_concr concr_meths in
let concr_vals = concr_vals cl_sig.csig_vars in
let over_vals = Concr.inter concr_vals warn_vals in
begin match ovf with
Some Fresh ->
let cname =
match parent with
Cty_constr (p, _, _) -> Path.name p
| _ -> "inherited"
in
if not (Concr.is_empty over_meths) then
Location.prerr_warning loc
(Warnings.Method_override (cname :: Concr.elements over_meths));
if not (Concr.is_empty over_vals) then
Location.prerr_warning loc
(Warnings.Instance_variable_override
(cname :: Concr.elements over_vals));
| Some Override
when Concr.is_empty over_meths && Concr.is_empty over_vals ->
raise (Error(loc, env, No_overriding ("","")))
| _ -> ()
end;
let concr_meths = Concr.union cl_sig.csig_concr concr_meths
and warn_vals = Concr.union concr_vals warn_vals in
(cl_sig, concr_meths, warn_vals)
| _ ->
raise(Error(loc, env, Structure_expected parent))
let virtual_method val_env meths self_type lab priv sty loc =
let (_, ty') =
Ctype.filter_self_method val_env lab priv meths self_type
in
let sty = Ast_helper.Typ.force_poly sty in
let cty = transl_simple_type val_env false (Some Stype) sty in
let ty = cty.ctyp_type in
begin
try Ctype.unify val_env ty ty' with Ctype.Unify trace ->
raise(Error(loc, val_env, Field_type_mismatch ("method", lab, trace)));
end;
cty
let delayed_meth_specs = ref []
let declare_method val_env meths self_type lab priv sty loc =
let (_, ty') =
Ctype.filter_self_method val_env lab priv meths self_type
in
let unif ty =
try Ctype.unify val_env ty ty' with Ctype.Unify trace ->
raise(Error(loc, val_env, Field_type_mismatch ("method", lab, trace)))
in
let sty = Ast_helper.Typ.force_poly sty in
match sty.ptyp_desc, priv with
Ptyp_poly ([],sty'), Public ->
(* TODO: we moved the [transl_simple_type_univars] outside of the lazy,
so that we can get an immediate value. Is that correct ? Ask Jacques. *)
let returned_cty = ctyp Ttyp_any (Ctype.newty Tnil) val_env loc in
delayed_meth_specs :=
lazy (
let cty = transl_simple_type_univars val_env (Some Stype) sty' in
let ty = cty.ctyp_type in
unif ty;
returned_cty.ctyp_desc <- Ttyp_poly ([], cty);
returned_cty.ctyp_type <- ty;
) ::
!delayed_meth_specs;
returned_cty
| _ ->
let cty = transl_simple_type val_env false (Some Stype) sty in
let ty = cty.ctyp_type in
unif ty;
cty
let type_constraint val_env sty sty' loc =
let cty = transl_simple_type val_env false None sty in
let ty = cty.ctyp_type in
let cty' = transl_simple_type val_env false None sty' in
let ty' = cty'.ctyp_type in
begin
try Ctype.unify val_env ty ty' with Ctype.Unify trace ->
raise(Error(loc, val_env, Unconsistent_constraint trace));
end;
(cty, cty')
let make_method loc cl_num expr =
let open Ast_helper in
let mkid s = mkloc s loc in
Exp.fun_ ~loc:expr.pexp_loc "" None
(Pat.alias ~loc (Pat.var ~loc (mkid "self-*")) (mkid ("self-" ^ cl_num)))
expr
(*******************************)
let add_val env loc lab (mut, virt, ty) val_sig =
let virt =
try
let (mut', virt', ty') = Vars.find lab val_sig in
if virt' = Concrete then virt' else virt
with Not_found -> virt
in
Vars.add lab (mut, virt, ty) val_sig
let rec class_type_field env self_type meths
(fields, val_sig, concr_meths, inher) ctf =
let loc = ctf.pctf_loc in
let mkctf desc = { ctf_desc = desc; ctf_loc = loc; ctf_attributes = ctf.pctf_attributes } in
match ctf.pctf_desc with
Pctf_inherit sparent ->
let parent = class_type env sparent in
let inher =
match parent.cltyp_type with
Cty_constr (p, tl, _) -> (p, tl) :: inher
| _ -> inher
in
let (cl_sig, concr_meths, _) =
inheritance self_type env None concr_meths Concr.empty sparent.pcty_loc
parent.cltyp_type
in
let val_sig =
Vars.fold (add_val env sparent.pcty_loc) cl_sig.csig_vars val_sig in
(mkctf (Tctf_inherit parent) :: fields,
val_sig, concr_meths, inher)
| Pctf_val (lab, mut, virt, sty) ->
let cty = transl_simple_type env false (Some Stype) sty in
let ty = cty.ctyp_type in
(mkctf (Tctf_val (lab, mut, virt, cty)) :: fields,
add_val env ctf.pctf_loc lab (mut, virt, ty) val_sig, concr_meths, inher)
| Pctf_method (lab, priv, virt, sty) ->
let cty =
declare_method env meths self_type lab priv sty ctf.pctf_loc in
let concr_meths =
match virt with
| Concrete -> Concr.add lab concr_meths
| Virtual -> concr_meths
in
(mkctf (Tctf_method (lab, priv, virt, cty)) :: fields,
val_sig, concr_meths, inher)
| Pctf_constraint (sty, sty') ->
let (cty, cty') = type_constraint env sty sty' ctf.pctf_loc in
(mkctf (Tctf_constraint (cty, cty')) :: fields,
val_sig, concr_meths, inher)
| Pctf_attribute x ->
Typetexp.warning_attribute [x];
(mkctf (Tctf_attribute x) :: fields,
val_sig, concr_meths, inher)
| Pctf_extension ext ->
raise (Error_forward (Typetexp.error_of_extension ext))
and class_signature env {pcsig_self=sty; pcsig_fields=sign} =
let meths = ref Meths.empty in
let self_cty = transl_simple_type env false (Some Stype) sty in
let self_cty = { self_cty with
ctyp_type = Ctype.expand_head env self_cty.ctyp_type } in
let self_type = self_cty.ctyp_type in
(* Check that the binder is a correct type, and introduce a dummy
method preventing self type from being closed. *)
let dummy_obj = Ctype.newvar Stype in
Ctype.unify env (Ctype.filter_method env dummy_method Private dummy_obj)
(Ctype.newty (Ttuple []));
begin try
Ctype.unify env self_type dummy_obj
with Ctype.Unify _ ->
raise(Error(sty.ptyp_loc, env, Pattern_type_clash self_type))
end;
(* Class type fields *)
Typetexp.warning_enter_scope ();
let (rev_fields, val_sig, concr_meths, inher) =
List.fold_left (class_type_field env self_type meths)
([], Vars.empty, Concr.empty, [])
sign
in
Typetexp.warning_leave_scope ();
let cty = {csig_self = self_type;
csig_vars = val_sig;
csig_concr = concr_meths;
csig_inher = inher}
in
{ csig_self = self_cty;
csig_fields = List.rev rev_fields;
csig_type = cty;
}
and class_type env scty =
let cltyp desc typ =
{
cltyp_desc = desc;
cltyp_type = typ;
cltyp_loc = scty.pcty_loc;
cltyp_env = env;
cltyp_attributes = scty.pcty_attributes;
}
in
match scty.pcty_desc with
Pcty_constr (lid, styl) ->
let (path, decl) = Typetexp.find_class_type env scty.pcty_loc lid.txt in
if Path.same decl.clty_path unbound_class then
raise(Error(scty.pcty_loc, env, Unbound_class_type_2 lid.txt));
let (params, clty) =
Ctype.instance_class decl.clty_params decl.clty_type
in
if List.length params <> List.length styl then
raise(Error(scty.pcty_loc, env,
Parameter_arity_mismatch (lid.txt, List.length params,
List.length styl)));
let ctys = List.map2
(fun sty ty ->
let cty' =
transl_simple_type env false (Some (Btype.type_sort ty)) sty
in
let ty' = cty'.ctyp_type in
begin
try Ctype.unify env ty' ty with Ctype.Unify trace ->
raise(Error(sty.ptyp_loc, env, Parameter_mismatch trace))
end;
cty'
) styl params
in
let typ = Cty_constr (path, params, clty) in
cltyp (Tcty_constr ( path, lid , ctys)) typ
| Pcty_signature pcsig ->
let clsig = class_signature env pcsig in
let typ = Cty_signature clsig.csig_type in
cltyp (Tcty_signature clsig) typ
| Pcty_arrow (l, sty, scty) ->
let cty = transl_simple_type env false (Some Stype) sty in
let ty = cty.ctyp_type in
let clty = class_type env scty in
let typ = Cty_arrow (l, ty, clty.cltyp_type) in
cltyp (Tcty_arrow (l, cty, clty)) typ
| Pcty_extension ext ->
raise (Error_forward (Typetexp.error_of_extension ext))
let class_type env scty =
delayed_meth_specs := [];
let cty = class_type env scty in
List.iter Lazy.force (List.rev !delayed_meth_specs);
delayed_meth_specs := [];
cty
(*******************************)
let rec class_field self_loc cl_num self_type meths vars
(val_env, met_env, par_env, fields, concr_meths, warn_vals, inher,
local_meths, local_vals)
cf =
let loc = cf.pcf_loc in
let mkcf desc = { cf_desc = desc; cf_loc = loc; cf_attributes = cf.pcf_attributes } in
match cf.pcf_desc with
Pcf_inherit (ovf, sparent, super) ->
let parent = class_expr cl_num val_env par_env sparent in
let inher =
match parent.cl_type with
Cty_constr (p, tl, _) -> (p, tl) :: inher
| _ -> inher
in
let (cl_sig, concr_meths, warn_vals) =
inheritance self_type val_env (Some ovf) concr_meths warn_vals
sparent.pcl_loc parent.cl_type
in
(* Variables *)
let (val_env, met_env, par_env, inh_vars) =
Vars.fold
(fun lab info (val_env, met_env, par_env, inh_vars) ->
let mut, vr, ty = info in
let (id, val_env, met_env, par_env) =
enter_val cl_num vars true lab mut vr ty val_env met_env par_env
sparent.pcl_loc
in
(val_env, met_env, par_env, (lab, id) :: inh_vars))
cl_sig.csig_vars (val_env, met_env, par_env, [])
in
(* Inherited concrete methods *)
let inh_meths =
Concr.fold (fun lab rem -> (lab, Ident.create lab)::rem)
cl_sig.csig_concr []
in
(* Super *)
let (val_env, met_env, par_env) =
match super with
None ->
(val_env, met_env, par_env)
| Some name ->
let (id, val_env, met_env, par_env) =
enter_met_env ~check:(fun s -> Warnings.Unused_ancestor s)
sparent.pcl_loc name (Val_anc (inh_meths, cl_num)) self_type
val_env met_env par_env
in
(val_env, met_env, par_env)
in
(val_env, met_env, par_env,
lazy (mkcf (Tcf_inherit (ovf, parent, super, inh_vars, inh_meths)))
:: fields,
concr_meths, warn_vals, inher, local_meths, local_vals)
| Pcf_val (lab, mut, Cfk_virtual styp) ->
if !Clflags.principal then Ctype.begin_def ();
let cty = Typetexp.transl_simple_type val_env false (Some Stype) styp in
let ty = cty.ctyp_type in
if !Clflags.principal then begin
Ctype.end_def ();
Ctype.generalize_structure ty
end;
let (id, val_env, met_env', par_env) =
enter_val cl_num vars false lab.txt mut Virtual ty
val_env met_env par_env loc
in
(val_env, met_env', par_env,
lazy (mkcf (Tcf_val (lab, mut, id, Tcfk_virtual cty,
met_env == met_env')))
:: fields,
concr_meths, warn_vals, inher, local_meths, local_vals)
| Pcf_val (lab, mut, Cfk_concrete (ovf, sexp)) ->
if Concr.mem lab.txt local_vals then
raise(Error(loc, val_env, Duplicate ("instance variable", lab.txt)));
if Concr.mem lab.txt warn_vals then begin
if ovf = Fresh then
Location.prerr_warning lab.loc
(Warnings.Instance_variable_override[lab.txt])
end else begin
if ovf = Override then
raise(Error(loc, val_env,
No_overriding ("instance variable", lab.txt)))
end;
if !Clflags.principal then Ctype.begin_def ();
let eff = Predef.effect_io (Btype.newgenty Tenil) in
let exp =
try type_exp val_env (Expected eff) sexp with Ctype.Unify [(ty, _)] ->
raise(Error(loc, val_env, Make_nongen_seltype ty))
in
if !Clflags.principal then begin
Ctype.end_def ();
Ctype.generalize_structure exp.exp_type
end;
let (id, val_env, met_env', par_env) =
enter_val cl_num vars false lab.txt mut Concrete exp.exp_type
val_env met_env par_env loc
in
(val_env, met_env', par_env,
lazy (mkcf (Tcf_val (lab, mut, id,
Tcfk_concrete (ovf, exp), met_env == met_env')))
:: fields,
concr_meths, Concr.add lab.txt warn_vals, inher, local_meths,
Concr.add lab.txt local_vals)
| Pcf_method (lab, priv, Cfk_virtual sty) ->
let cty = virtual_method val_env meths self_type lab.txt priv sty loc in
(val_env, met_env, par_env,
lazy (mkcf(Tcf_method (lab, priv, Tcfk_virtual cty)))
::fields,
concr_meths, warn_vals, inher, local_meths, local_vals)
| Pcf_method (lab, priv, Cfk_concrete (ovf, expr)) ->
let expr =
match expr.pexp_desc with
| Pexp_poly _ -> expr
| _ -> Ast_helper.Exp.poly ~loc:expr.pexp_loc expr None
in
if Concr.mem lab.txt local_meths then
raise(Error(loc, val_env, Duplicate ("method", lab.txt)));
if Concr.mem lab.txt concr_meths then begin
if ovf = Fresh then
Location.prerr_warning loc (Warnings.Method_override [lab.txt])
end else begin
if ovf = Override then
raise(Error(loc, val_env, No_overriding("method", lab.txt)))
end;
let (_, ty) =
Ctype.filter_self_method val_env lab.txt priv meths self_type
in
begin try match expr.pexp_desc with
Pexp_poly (sbody, sty) ->
begin match sty with None -> ()
| Some sty ->
let sty = Ast_helper.Typ.force_poly sty in
let cty' =
Typetexp.transl_simple_type val_env false (Some Stype) sty
in
let ty' = cty'.ctyp_type in
Ctype.unify val_env ty' ty
end;
begin match (Ctype.repr ty).desc with
Tvar(_, Stype) ->
let ty' = Ctype.newvar Stype in
Ctype.unify val_env (Ctype.newty (Tpoly (ty', []))) ty;
Ctype.unify val_env (type_approx val_env sbody) ty'
| Tpoly (ty1, tl) ->
let _, ty1' = Ctype.instance_poly false tl ty1 in
let ty2 = type_approx val_env sbody in
Ctype.unify val_env ty2 ty1'
| _ -> assert false
end
| _ -> assert false
with Ctype.Unify trace ->
raise(Error(loc, val_env,
Field_type_mismatch ("method", lab.txt, trace)))
end;
let meth_expr = make_method self_loc cl_num expr in
(* backup variables for Pexp_override *)
let vars_local = !vars in
let field =
lazy begin
let eff = Predef.effect_io (Btype.newgenty Tenil) in
let meth_type =
Btype.newgenty (Tarrow("", self_type, eff, ty, Cok)) in
Ctype.raise_nongen_level ();
vars := vars_local;
let eff = Btype.newgenty Tenil in
let texp =
type_expect met_env (Expected eff) meth_expr meth_type
in
Ctype.end_def ();
mkcf (Tcf_method (lab, priv, Tcfk_concrete (ovf, texp)))
end in
(val_env, met_env, par_env, field::fields,
Concr.add lab.txt concr_meths, warn_vals, inher,
Concr.add lab.txt local_meths, local_vals)
| Pcf_constraint (sty, sty') ->
let (cty, cty') = type_constraint val_env sty sty' loc in
(val_env, met_env, par_env,
lazy (mkcf (Tcf_constraint (cty, cty'))) :: fields,
concr_meths, warn_vals, inher, local_meths, local_vals)
| Pcf_initializer expr ->
let expr = make_method self_loc cl_num expr in
let vars_local = !vars in
let field =
lazy begin
Ctype.raise_nongen_level ();
let eff = Ctype.instance_def (Predef.effect_io (Ctype.newty Tenil)) in
let meth_type =
Ctype.newty
(Tarrow ("", self_type, eff,
Ctype.instance_def Predef.type_unit, Cok)) in
vars := vars_local;
let eff = Btype.newgenty Tenil in
let texp =
type_expect met_env (Expected eff) expr meth_type
in
Ctype.end_def ();
mkcf (Tcf_initializer texp)
end in
(val_env, met_env, par_env, field::fields, concr_meths, warn_vals,
inher, local_meths, local_vals)
| Pcf_attribute x ->
Typetexp.warning_attribute [x];
(val_env, met_env, par_env,
lazy (mkcf (Tcf_attribute x)) :: fields,
concr_meths, warn_vals, inher, local_meths, local_vals)
| Pcf_extension ext ->
raise (Error_forward (Typetexp.error_of_extension ext))
and class_structure cl_num final val_env met_env loc
{ pcstr_self = spat; pcstr_fields = str } =
(* Environment for substructures *)
let par_env = met_env in
(* Location of self. Used for locations of self arguments *)
let self_loc = {spat.ppat_loc with Location.loc_ghost = true} in
(* Self type, with a dummy method preventing it from being closed/escaped. *)
let self_type = Ctype.newvar Stype in
Ctype.unify val_env
(Ctype.filter_method val_env dummy_method Private self_type)
(Ctype.newty (Ttuple []));
(* Private self is used for private method calls *)
let private_self = if final then Ctype.newvar Stype else self_type in
(* Self binder *)
let self_eff = Ctype.instance_def (Predef.effect_io (Ctype.newty Tenil)) in
let (pat, meths, vars, val_env, meth_env, par_env) =
type_self_pattern cl_num private_self
val_env met_env par_env (Expected self_eff) spat
in
let public_self = pat.pat_type in
(* Check that the binder has a correct type *)
let ty =
if final then Ctype.newty (Tobject (Ctype.newvar Stype, ref None))
else self_type in
begin try Ctype.unify val_env public_self ty with
Ctype.Unify _ ->
raise(Error(spat.ppat_loc, val_env, Pattern_type_clash public_self))
end;
let get_methods ty =
(fst (Ctype.flatten_fields
(Ctype.object_fields (Ctype.expand_head val_env ty)))) in
if final then begin
(* Copy known information to still empty self_type *)
List.iter
(fun (lab,kind,ty) ->
let k =
if Btype.field_kind_repr kind = Fpresent then Public else Private in
try Ctype.unify val_env ty
(Ctype.filter_method val_env lab k self_type)
with _ -> assert false)
(get_methods public_self)
end;
(* Typing of class fields *)
Typetexp.warning_enter_scope ();
let (_, _, _, fields, concr_meths, _, inher, _local_meths, _local_vals) =
List.fold_left (class_field self_loc cl_num self_type meths vars)
(val_env, meth_env, par_env, [], Concr.empty, Concr.empty, [],
Concr.empty, Concr.empty)
str
in
Typetexp.warning_leave_scope ();
Ctype.unify val_env self_type (Ctype.newvar Stype);
let sign =
{csig_self = public_self;
csig_vars = Vars.map (fun (id, mut, vr, ty) -> (mut, vr, ty)) !vars;
csig_concr = concr_meths;
csig_inher = inher} in
let methods = get_methods self_type in
let priv_meths =
List.filter (fun (_,kind,_) -> Btype.field_kind_repr kind <> Fpresent)
methods in
if final then begin
(* Unify private_self and a copy of self_type. self_type will not
be modified after this point *)
Ctype.close_object self_type;
let mets = virtual_methods {sign with csig_self = self_type} in
let vals =
Vars.fold
(fun name (mut, vr, ty) l -> if vr = Virtual then name :: l else l)
sign.csig_vars [] in
if mets <> [] || vals <> [] then
raise(Error(loc, val_env, Virtual_class(true, final, mets, vals)));
let self_methods =
List.fold_right
(fun (lab,kind,ty) rem ->
if lab = dummy_method then
(* allow public self and private self to be unified *)
match Btype.field_kind_repr kind with
Fvar r -> Btype.set_kind r Fabsent; rem
| _ -> rem
else
Ctype.newty(Tfield(lab, Btype.copy_kind kind, ty, rem)))
methods (Ctype.newty Tnil) in
begin try
Ctype.unify val_env private_self
(Ctype.newty (Tobject(self_methods, ref None)));
Ctype.unify val_env public_self self_type
with Ctype.Unify trace -> raise(Error(loc, val_env, Final_self_clash trace))
end;
end;
(* Typing of method bodies *)
if !Clflags.principal then
List.iter (fun (_,_,ty) -> Ctype.generalize_spine ty) methods;
let fields = List.map Lazy.force (List.rev fields) in
if !Clflags.principal then
List.iter (fun (_,_,ty) -> Ctype.unify val_env ty (Ctype.newvar Stype))
methods;
let meths = Meths.map (function (id, ty) -> id) !meths in
(* Check for private methods made public *)
let pub_meths' =
List.filter (fun (_,kind,_) -> Btype.field_kind_repr kind = Fpresent)
(get_methods public_self) in
let names = List.map (fun (x,_,_) -> x) in
let l1 = names priv_meths and l2 = names pub_meths' in
let added = List.filter (fun x -> List.mem x l1) l2 in
if added <> [] then
Location.prerr_warning loc (Warnings.Implicit_public_methods added);
let sign = if final then sign else
{sign with csig_self = Ctype.expand_head val_env public_self} in
{
cstr_self = pat;
cstr_fields = fields;
cstr_type = sign;
cstr_meths = meths}, sign (* redondant, since already in cstr_type *)
and class_expr cl_num val_env met_env scl =
match scl.pcl_desc with
Pcl_constr (lid, styl) ->
let (path, decl) = Typetexp.find_class val_env scl.pcl_loc lid.txt in
if Path.same decl.cty_path unbound_class then
raise(Error(scl.pcl_loc, val_env, Unbound_class_2 lid.txt));
let (params, clty) =
Ctype.instance_class decl.cty_params decl.cty_type
in
let clty' = abbreviate_class_type path params clty in
if List.length params <> List.length styl then
raise(Error(scl.pcl_loc, val_env,
Parameter_arity_mismatch (lid.txt, List.length params,
List.length styl)));
let tyl =
List.map2
(fun sty ty ->
let cty' =
transl_simple_type val_env false (Some (Btype.type_sort ty)) sty
in
let ty' = cty'.ctyp_type in
begin
try Ctype.unify val_env ty' ty with Ctype.Unify trace ->
raise(Error(sty.ptyp_loc, val_env, Parameter_mismatch trace))
end;
cty')
styl params
in
let cl =
rc {cl_desc = Tcl_ident (path, lid, tyl);
cl_loc = scl.pcl_loc;
cl_type = clty';
cl_env = val_env;
cl_attributes = scl.pcl_attributes;
}
in
let (vals, meths, concrs) = extract_constraints clty in
rc {cl_desc = Tcl_constraint (cl, None, vals, meths, concrs);
cl_loc = scl.pcl_loc;
cl_type = clty';
cl_env = val_env;
cl_attributes = []; (* attributes are kept on the inner cl node *)
}
| Pcl_structure cl_str ->
let (desc, ty) =
class_structure cl_num false val_env met_env scl.pcl_loc cl_str in
rc {cl_desc = Tcl_structure desc;
cl_loc = scl.pcl_loc;
cl_type = Cty_signature ty;
cl_env = val_env;
cl_attributes = scl.pcl_attributes;
}
| Pcl_fun (l, Some default, spat, sbody) ->
let loc = default.pexp_loc in
let open Ast_helper in
let scases = [
Exp.case
(Pat.construct ~loc
(mknoloc (Longident.(Ldot (Lident "*predef*", "Some"))))
(Some (Pat.var ~loc (mknoloc "*sth*"))))
(Exp.ident ~loc (mknoloc (Longident.Lident "*sth*")));
Exp.case
(Pat.construct ~loc
(mknoloc (Longident.(Ldot (Lident "*predef*", "None"))))
None)
default;
]
in
let smatch =
Exp.match_ ~loc (Exp.ident ~loc (mknoloc (Longident.Lident "*opt*")))
scases
in
let sfun =
Cl.fun_ ~loc:scl.pcl_loc
l None
(Pat.var ~loc (mknoloc "*opt*"))
(Cl.let_ ~loc:scl.pcl_loc Nonrecursive [Vb.mk spat smatch] sbody)
(* Note: we don't put the '#default' attribute, as it
is not detected for class-level let bindings. See #5975.*)
in
class_expr cl_num val_env met_env sfun
| Pcl_fun (l, None, spat, scl') ->
if !Clflags.principal then Ctype.begin_def ();
let eff =
Ctype.instance_def (Predef.effect_io (Ctype.newty Tenil))
in
let (pat, pv, val_env', met_env) =
Typecore.type_class_arg_pattern cl_num
val_env met_env (Expected eff) l spat
in
if !Clflags.principal then begin
Ctype.end_def ();
iter_pattern (fun {pat_type=ty} -> Ctype.generalize_structure ty) pat
end;
let pv =
List.map
begin fun (id, id_loc, id', ty) ->
let path = Pident id' in
(* do not mark the value as being used *)
let vd = Env.find_value path val_env' in
(id, id_loc,
{exp_desc =
Texp_ident(path, mknoloc (Longident.Lident (Ident.name id)), vd);
exp_loc = Location.none; exp_extra = [];
exp_type = Ctype.instance val_env' vd.val_type;
exp_attributes = []; (* check *)
exp_env = val_env'})
end
pv
in
let not_function = function
Cty_arrow _ -> false
| _ -> true
in
let cont = Ctype.newvar Stype in
let partial, _ =
Typecore.check_partial val_env (Expected eff) cont pat.pat_type
pat.pat_loc
[{c_lhs=pat;
c_guard=None;
c_rhs = (* Dummy expression *)
{exp_desc = Texp_constant (Asttypes.Const_int 1);
exp_loc = Location.none; exp_extra = [];
exp_type = Ctype.none;
exp_attributes = [];
exp_env = Env.empty }}]
in
Ctype.raise_nongen_level ();
let cl = class_expr cl_num val_env' met_env scl' in
Ctype.end_def ();
if Btype.is_optional l && not_function cl.cl_type then
Location.prerr_warning pat.pat_loc
Warnings.Unerasable_optional_argument;
rc {cl_desc = Tcl_fun (l, pat, pv, cl, partial);
cl_loc = scl.pcl_loc;
cl_type = Cty_arrow
(l, Ctype.instance_def pat.pat_type, cl.cl_type);
cl_env = val_env;
cl_attributes = scl.pcl_attributes;
}
| Pcl_apply (scl', sargs) ->
if sargs = [] then
Syntaxerr.ill_formed_ast scl.pcl_loc
"Function application with no argument.";
if !Clflags.principal then Ctype.begin_def ();