-
Notifications
You must be signed in to change notification settings - Fork 125
/
w_CoreTypes.ml
1113 lines (949 loc) · 54 KB
/
w_CoreTypes.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
(*
Copyright © 2011 MLstate
This file is part of OPA.
OPA is free software: you can redistribute it and/or modify it under the
terms of the GNU Affero General Public License, version 3, as published by
the Free Software Foundation.
OPA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
more details.
You should have received a copy of the GNU Affero General Public License
along with OPA. If not, see <http://www.gnu.org/licenses/>.
*)
(*
@author François Pessaux
*)
(* ************************************************************************** *)
(** {b Descr}: This module implements the typechecker's type algebra and its
manipulation. This module is especially big, but since it is the only one
to have access to the internal representation of types, we must put inside
any function that requires this internal representation.
This is a design choice, to avoid exporting hence giving to much visibility
on the types internal structure, since this structure contains strong
invariants (mostly sharing and canonical representation not being equal to
structural representation) that must really not be broken.
So, this module is split into several sections, each being dedicated to a
particular kind of operation on the types. *)
(* ************************************************************************** *)
(* ************************************************************************** *)
(** {b Descr}: Returns the current binding level for generalization, i.e. the
level of variables than can be generalized if they are of a level strictly
greater than the current binding level.
{b Visibility} Exported outside this module, BUT must never be assigned
manually. This value is visible in READ-ONLY mode. The 4 only functions
allowed to modify this value are [begin_definition], [end_definition]
[reset_toplevel_binding_level_on_error] and
[restore_binding_level_from_backup]. *)
(* ************************************************************************** *)
let current_binding_level = ref 0
(* ************************************************************************** *)
(** {b Descr}: Binding level at which type variables introduced by type
annotations are created. In effect since the scope of such variables is
either the whole toplevel let-definition or the whole module field, we must
prevent them from being generalized when leaving definitions where they
appear because some coming type constraint can still instantiate them after
the local let-definition or field module.
Do to so, before typechecking a toplevel let-definition, we artificially
increase the current binding level of 1, remind it as the level for
variables introduced by annotation, then we go on with regular
let-definition typechecking. We do idem before typechecking each field of
a module.
And at the end of the toplevel let-definition or the module field, before
generalization, we decrease the current binding level since we increased
it before.
Then, at this level, variables created by annotation finally become
generalizable.
So, this ensure that these variables can be generalized only once returned
at toplevel or once exited of the module field, not before, not "too soon".
{b Visibility}: Not exported outside this module. BUT must never be
assigned manually. This value is visible in READ-ONLY mode. The 3 only
functions allowed to modify this value are
[new_annotations_generalizable_level],
[release_annotations_generalizable_level] and
[reset_toplevel_binding_level_on_error] *)
(* ************************************************************************** *)
let current_annotations_generalizable_level = ref 0
(* ************************************************************************** *)
(** {b Descr}: Value of binding level indicating that variables having this
level are generalized (polymorphic). This is a bit hacky to arbitrarily
decide of this value, but we need a level greater than any level that can
be obtained during type inference. Of course, theoretically it is possible
to nest let-definition until having a binding level equal to this value,
but... it would require tons of nested definitions and there is really an
insignificant chance a developer does this ! So, we assume living with this
assumption ^^
{b Visibility}: Exported outside this module. *)
(* ************************************************************************** *)
let generic_binding_level = 100000000
(* ************************************************************************** *)
(** {b Descr}: Must be called AFTER every potentially generalizable
definition. It decreases the binding level to prevent generalization of
higher binding level type variables.
{b Visibility}: Exported outside this module. *)
(* ************************************************************************** *)
let begin_definition () = incr current_binding_level
(* ************************************************************************** *)
(** {b Descr}: Must be called AFTER every potentially generalizable
definition. It decreases the binding level to prevent generalization of
higher binding level type variables.
{b Visibility}: Exported outside this module. *)
(* ************************************************************************** *)
let end_definition () = decr current_binding_level
(* ************************************************************************** *)
(** {b Descr}: Reset the current binding level to 0, i.e. as when the
typechecker is at toplevel, in no let-definition.
This function must only be called in case of typechecking error in order to
allow future toplevel sentences to be typechecked.
In effect, opatop allows to continue accepting code even if the previous
phrase was ill-typed. In case the wrong type left the typechecker in the
middle of definitions or type constraints, it is possible to have the
current binding level not lowered back to 0 because the exception that
pinpointed the error prevented from executing correctly the [end_definition]
calls corresponding to the executed [begin_definition] calls.
Then, to reset the typechecker, this function must be called in case of
error. This will prevent next phrases to be (wrongly) typechecked starting
with a binding level greater that 0.
We could even say that this function can always be called when
[Typer_w.type_of_expr] is launched, but this should not be necessary since
if there is no bug around, the binding level should always goes back at the
end of typechecking a toplevel phrase, i.e. at the end of
[Typer_w.type_of_expr]. Always calling the present function at the beginning
of [Typer_w.type_of_expr] would mask bugs of coupling [begin_definition] and
[end_definition] calls in the typechecker.
{b Visibility}: Exported outside this module. *)
(* ************************************************************************** *)
let reset_toplevel_binding_level_on_error () =
current_binding_level := 0 ;
current_annotations_generalizable_level := 0
(* ************************************************************************** *)
(** {b Descr}: Argggg! Very hairy function that sets the current binding level
to a certain value. In a ideal world, we should not need this. But in fact,
during QML type -> [simple_type] conversion, the case of abstract QML types
[QmlAst.TypeAbstract] raised an exception to delay the creation of the
[simple_type]. The problem is that raising this exception can interrupt the
conversion in the middle of nowhere, especially after having started the
definition of of type in the environment. This operation involves scheme
creations and may temporarily change the current binding level. If the
search is killed by the exception before completion, then the binding level
will remain modified, breaking the balance between [begin_definition] and
[end_definition] calls.
To circumvent this issue, [W_TypingEnv.rec_import_qml_type] makes a backup
of the current binding level before processing the case of a named type
and restores it in case of exception [W_TypingEnv.Importing_Qml_Abstract]
(this exception meaning that a QML type "abstract" was encountered).
{b Visibility}: Exported outside this module. *)
(* ************************************************************************** *)
let restore_binding_level_from_backup backup =
current_binding_level := backup
(* ************************************************************************** *)
(** {b Descr}: Record the new binding level strictly above which type variables
introduced by explicit type annotations will be generalizable. The effect
is to artificially increase the current binding level and reminding this
level. From this point, type variables created by annotations will have this
reminded level.
This function must only be called in the case of toplevel let-definitions
or modules.
In the first case, it is called before typechecking the bindings of the
let-definition and [release_annotations_generalizable_level] is called just
after typechecking the bindings of the let-definition.
In the second case, it is called before typechecking *each* field of the
module and [release_annotations_generalizable_level] is called just
after typechecking *this* field of the module.
Hence, except variables introduced by explicit annotations, no other
variables can be created with this recorded level.
Until we descend back to a binding level strictly lower to this recorded
level, variables created with this recorded level won't be generalizable.
And, especially, to descend back to a binding level where these variables
become generalizable, we call [release_annotations_generalizable_level]
whose job is to lower the binding level we artificially increased here.
So [release_annotations_generalizable_level] must be called if we were
called and in this case, just before generalizing the type of a toplevel
let-definition or of a module field (via forallization in this last case).
{b Visibility}: Exported outside this module. *)
(* ************************************************************************** *)
let new_annotations_generalizable_level () =
begin_definition () ;
current_annotations_generalizable_level := !current_binding_level
(* ************************************************************************** *)
(** {b Descr}: Revert back to the previously known level strictly above which
type variables introduced by explicit type annotations must be created.
The effect is to decrease the current binding level originally increased by
[new_annotations_generalizable_level] and to record it as the new level
for variables introduced by annotations.
Because we always balance [begin_definition] and [end_definition], by
calling the present function, once we decreased the level we increased by
[new_annotations_generalizable_level], by construction the current binding
level re-becomes equal to the previous annotations generalizable level.
Note: read also documentation of [new_annotations_generalizable_level].
{b Visibility}: Exported outside this module. *)
(* ************************************************************************** *)
let release_annotations_generalizable_level () =
end_definition () ;
current_annotations_generalizable_level := !current_binding_level
(* {b Visibility}: Exported outside this module. *)
let __row_variable () =
{ W_Algebra.rv_level = !current_binding_level ;
W_Algebra.rv_value = W_Algebra.Row_unknown ;
W_Algebra.rv_public_identity = QmlTypeVars.RowVar.next () ;
W_Algebra.rv_mark = W_Algebra.VM_not_seen
}
(* {b Visibility}: Exported outside this module. *)
let __row_variable_with_public_identity qml_var =
{ W_Algebra.rv_level = !current_binding_level ;
W_Algebra.rv_value = W_Algebra.Row_unknown ;
W_Algebra.rv_public_identity = qml_var ;
W_Algebra.rv_mark = W_Algebra.VM_not_seen
}
(* ************************************************************************** *)
(** {b Descr}: Creates a row variable whose QML counterpart is known. This
function must be used when the variable to create comes from the context of
an explicit type annotation (i.e. a constraining type expression). In
effect, such variables introduced by annotations can only be generalized at
toplevel and not when getting outside the let-body where they were created.
To achieve this, such variables get a binding level equal to 0, and the
[W_SchemeGenAndInst.generalize] function makes a special case when it
encounters a variable of level 0 and the current binding level is 0: it
generalize it.
This is to achive the same scoping policy of type variables than OCaml does,
and make so type variables inserted by type annotations have a scope being
the whole current toplevel definition.
{b Visibility}: Exported outside this module. *)
(* ************************************************************************** *)
let __annotation_row_variable_with_public_identity qml_var =
{ W_Algebra.rv_level = !current_annotations_generalizable_level ;
W_Algebra.rv_value = W_Algebra.Row_unknown ;
W_Algebra.rv_public_identity = qml_var ;
W_Algebra.rv_mark = W_Algebra.VM_not_seen
}
(* {b Visibility}: Exported outside this module. *)
let __generic_row_variable () =
{ W_Algebra.rv_level = generic_binding_level ;
W_Algebra.rv_value = W_Algebra.Row_unknown ;
W_Algebra.rv_public_identity = QmlTypeVars.RowVar.next () ;
W_Algebra.rv_mark = W_Algebra.VM_not_seen
}
(* {b Visibility}: Exported outside this module. *)
let __generic_row_variable_with_public_identity qml_var =
{ W_Algebra.rv_level = generic_binding_level ;
W_Algebra.rv_value = W_Algebra.Row_unknown ;
W_Algebra. rv_public_identity = qml_var ;
W_Algebra.rv_mark = W_Algebra.VM_not_seen
}
(* {b Visibility}: Exported outside this module. *)
let row_ending_variable () = W_Algebra.Var_row (__row_variable ())
(* {b Visibility}: Exported outside this module. *)
let __column_variable () =
{ W_Algebra.cv_level = !current_binding_level ;
W_Algebra.cv_value = W_Algebra.Col_unknown ;
W_Algebra.cv_public_identity = QmlTypeVars.ColVar.next () ;
W_Algebra.cv_mark = W_Algebra.VM_not_seen
}
(* {b Visibility}: Exported outside this module. *)
let __column_variable_with_public_identity qml_var =
{ W_Algebra.cv_level = !current_binding_level ;
W_Algebra.cv_value = W_Algebra.Col_unknown ;
W_Algebra.cv_public_identity = qml_var ;
W_Algebra.cv_mark = W_Algebra.VM_not_seen
}
(* ************************************************************************** *)
(** {b Descr}: Creates a column variable whose QML counterpart is known. This
function must be used when the variable to create comes from the context of
an explicit type annotation (i.e. a constraining type expression). In
effect, such variables introduced by annotations can only be generalized at
toplevel and not when getting outside the let-body where they were created.
To achieve this, such variables get a binding level equal to 0, and the
[W_SchemeGenAndInst.generalize] function makes a special case when it
encounters a variable of level 0 and the current binding level is 0: it
generalize it.
This is to achive the same scoping policy of type variables than OCaml does,
and make so type variables inserted by type annotations have a scope being
the whole current toplevel definition.
{b Visibility}: Exported outside this module. *)
(* ************************************************************************** *)
let __annotation_column_variable_with_public_identity qml_var =
{ W_Algebra.cv_level = !current_annotations_generalizable_level ;
W_Algebra.cv_value = W_Algebra.Col_unknown ;
W_Algebra.cv_public_identity = qml_var ;
W_Algebra.cv_mark = W_Algebra.VM_not_seen
}
(* {b Visibility}: Exported outside this module. *)
let __generic_column_variable () =
{ W_Algebra.cv_level = generic_binding_level ;
W_Algebra.cv_value = W_Algebra.Col_unknown ;
W_Algebra.cv_public_identity = QmlTypeVars.ColVar.next () ;
W_Algebra.cv_mark = W_Algebra.VM_not_seen
}
(* {b Visibility}: Exported outside this module. *)
let __generic_column_variable_with_public_identity qml_var =
{ W_Algebra.cv_level = generic_binding_level ;
W_Algebra.cv_value = W_Algebra.Col_unknown ;
W_Algebra.cv_public_identity = qml_var ;
W_Algebra.cv_mark = W_Algebra.VM_not_seen
}
(* {b Visibility}: Exported outside this module. *)
let column_ending_variable () =
W_Algebra.Var_column (__column_variable ())
let foo_counter = ref 0 ;;
(* {b Visibility}: Exported outside this module. *)
let type_variable () =
incr foo_counter ; (* FOR DEBUG PURPOSE ONLY. *)
{ W_Algebra.sty_desc =
W_Algebra.SType_var {
W_Algebra.tv_level = !current_binding_level ;
W_Algebra.tv_qml = (QmlTypeVars.TypeVar.next ()) ;
W_Algebra.tv_debug_count = !foo_counter (* FOR DEBUG PURPOSE ONLY. *)} ;
W_Algebra.sty_link = None ;
W_Algebra.sty_mark = W_Algebra.TM_not_seen }
(* {b Visibility}: Exported outside this module. *)
let __type_variable_with_public_identity qml_var =
incr foo_counter ; (* FOR DEBUG PURPOSE ONLY. *)
{ W_Algebra.sty_desc =
W_Algebra.SType_var {
W_Algebra.tv_level = !current_binding_level ;
W_Algebra.tv_qml = qml_var ;
W_Algebra.tv_debug_count = !foo_counter (* FOR DEBUG PURPOSE ONLY. *)} ;
W_Algebra.sty_link = None ;
W_Algebra.sty_mark = W_Algebra.TM_not_seen }
(* ************************************************************************** *)
(** {b Descr}: Creates a type variable whose QML counterpart is known. This
function must be used when the variable to create comes from the context of
an explicit type annotation (i.e. a constraining type expression). In
effect, such variables introduced by annotations can only be generalized at
toplevel and not when getting outside the let-body where they were created.
To achieve this, such variables get a binding level equal to 0, and the
[W_SchemeGenAndInst.generalize] function makes a special case when it
encounters a variable of level 0 and the current binding level is 0: it
generalize it.
This is to achive the same scoping policy of type variables than OCaml does,
and make so type variables inserted by type annotations have a scope being
the whole current toplevel definition.
{b Visibility}: Exported outside this module. *)
(* ************************************************************************** *)
let __annotation_type_variable_with_public_identity qml_var =
incr foo_counter ; (* FOR DEBUG PURPOSE ONLY. *)
{ W_Algebra.sty_desc =
W_Algebra.SType_var {
(* This variable will be generalizable only when the current binding
level will be > to this level and this level is the binding level
recorded before *)
W_Algebra.tv_level = !current_annotations_generalizable_level ;
W_Algebra.tv_qml = qml_var ;
W_Algebra.tv_debug_count = !foo_counter (* FOR DEBUG PURPOSE ONLY. *)} ;
W_Algebra.sty_link = None ;
W_Algebra.sty_mark = W_Algebra.TM_not_seen }
(* ************************************************************************** *)
(** {b Descr}: Creates a type variable already generalized. This function is
only used by [unify_simple_type] during unification to handle types
forall and must **absolutely neither** be used somewhere else **nor
exported** !
{b Visibility}: Exported outside this module. *)
(* ************************************************************************** *)
let __generic_type_variable () =
incr foo_counter ; (* FOR DEBUG PURPOSE ONLY. *)
{ W_Algebra.sty_desc =
W_Algebra.SType_var {
W_Algebra.tv_level = generic_binding_level ;
W_Algebra.tv_qml = QmlTypeVars.TypeVar.next () ;
W_Algebra.tv_debug_count = !foo_counter (* FOR DEBUG PURPOSE ONLY. *)} ;
W_Algebra.sty_link = None ;
W_Algebra.sty_mark = W_Algebra.TM_not_seen }
(* {b Visibility}: Not exported outside this module. *)
let __generic_type_variable_with_public_identity qml_var =
incr foo_counter ; (* FOR DEBUG PURPOSE ONLY. *)
{ W_Algebra.sty_desc =
W_Algebra.SType_var {
W_Algebra.tv_level = generic_binding_level ;
W_Algebra.tv_qml = qml_var ;
W_Algebra.tv_debug_count = !foo_counter (* FOR DEBUG PURPOSE ONLY. *)} ;
W_Algebra.sty_link = None ;
W_Algebra.sty_mark = W_Algebra.TM_not_seen }
let type_named ty_name ty_abb_height ty_args manifest =
{ W_Algebra.sty_desc =
W_Algebra.SType_named {
W_Algebra.nst_name = ty_name ;
W_Algebra.nst_abbrev_height = ty_abb_height ;
W_Algebra.nst_args = ty_args ;
W_Algebra.nst_unwinded = manifest } ;
W_Algebra.sty_link = None ;
W_Algebra.sty_mark = W_Algebra.TM_not_seen }
let type_int () =
type_named (QmlAst.TypeIdent.of_string Opacapi.Types.int) 0 [] None
let type_bool () =
type_named (QmlAst.TypeIdent.of_string Opacapi.Types.bool) 0 [] None
let type_float () =
type_named (QmlAst.TypeIdent.of_string Opacapi.Types.float) 0 [] None
let type_string () =
type_named (QmlAst.TypeIdent.of_string Opacapi.Types.string) 0 [] None
(* ************************************************************************** *)
(** {b Descr}: Creates a type of function whose arguments have types [tys_args]
and return type is [ty_res].
{b Visibility}: Exported outside this module. *)
(* ************************************************************************** *)
let type_arrow tys_args ty_res =
{ W_Algebra.sty_desc = W_Algebra.SType_arrow (tys_args, ty_res) ;
W_Algebra.sty_link = None ;
W_Algebra.sty_mark = W_Algebra.TM_not_seen }
(* ************************************************************************** *)
(** {b Descr}: Creates a type of record with no row-variable, and plugged in
an opened column. This represents the type of a simple record expression,
**not of a record pattern** !
{b Visibility}: Exported outside this module. *)
(* ************************************************************************** *)
let type_closed_record fields_tys =
let closed_row =
{ W_Algebra.rt_value = (fields_tys, W_Algebra.Closed_row) } in
let opened_column =
{ W_Algebra.ct_value = ([closed_row], (column_ending_variable ())) } in
{ W_Algebra.sty_desc = W_Algebra.SType_sum_of_records opened_column ;
W_Algebra.sty_link = None ;
W_Algebra.sty_mark = W_Algebra.TM_not_seen }
(** Closed record in closed column. *)
let type_module_record fields_tys =
let closed_row =
{ W_Algebra.rt_value = (fields_tys, W_Algebra.Closed_row) } in
let closed_column =
{ W_Algebra.ct_value = ([closed_row], W_Algebra.Closed_column) } in
{ W_Algebra.sty_desc = W_Algebra.SType_sum_of_records closed_column ;
W_Algebra.sty_link = None ;
W_Algebra.sty_mark = W_Algebra.TM_not_seen }
(* ************************************************************************** *)
(** {b Descr}: Creates a type of record with a row-variable, and plugged in
a closed column. This represents the type of an expression (**not a record
expression**) in which a dot access can be done, or the type of an opened
(i.e. ended explicitly by "...") record pattern.
{b Visibility}: Exported outside this module. *)
(* ************************************************************************** *)
let type_opened_record fields_tys =
let opened_row =
{ W_Algebra.rt_value = (fields_tys, (row_ending_variable ())) } in
let closed_column =
{ W_Algebra.ct_value = ([opened_row], W_Algebra.Closed_column) } in
{ W_Algebra.sty_desc = W_Algebra.SType_sum_of_records closed_column ;
W_Algebra.sty_link = None ;
W_Algebra.sty_mark = W_Algebra.TM_not_seen }
(* ************************************************************************** *)
(** {b Descr}: Creates a type record with or without row variable, depending on
the [row_is_opened] parameter, plugged into an opened column. This is used
to create the type of a record *pattern*. The row is opened if the pattern
ends by an elipsis (...), otherwise it is closed.
{b Visibility}: Exported outside this module. *)
(* ************************************************************************** *)
let type_of_record_pattern ~row_is_opened fields_tys =
let row =
if row_is_opened then
{ W_Algebra.rt_value = (fields_tys, (row_ending_variable ())) }
else { W_Algebra.rt_value = (fields_tys, W_Algebra.Closed_row) } in
let opened_column =
{ W_Algebra.ct_value = ([row], (column_ending_variable ())) } in
{ W_Algebra.sty_desc = W_Algebra.SType_sum_of_records opened_column ;
W_Algebra.sty_link = None ;
W_Algebra.sty_mark = W_Algebra.TM_not_seen }
(* ************************************************************************** *)
(** {b Descr}: From a field name and its type, which are expected to come from
a record extension expression and be the field to update with its new type,
this function synthesizes 2 types:
- the minimal record type expected for the expression to extend
- the type to use as result of the whole result after extension.
These 2 types share the same ending row variable to ensure that fields
"other" than the updated one are shared between the 2 types.
This allows to give to the extension primitive of the field "label" a
type like:
{ label : 'a ; rho } -> 'b -> { label : 'b ; rho }
This is more visible on f(x) = { x with lbl = 5 }
where we expect the application of [f] on a record having extra fields [A]
and [B] to return a record extension with these 2 fields present.
f({ lbl = ""; A; 5 = 5 }) must have type { lbl = int; A; 5 = 5 }
This means that the row variable shared between the argument's type of [f]
and its result type propagate the fields "other than" [lbl] in the result
of the function.
So, the type returned as minimal expected type will have to be unified
during inferrence with the actual type inferred for the expression to extend
in order to ensure propagation of constraints in the result type via this
shared row variable.
Because we want to avoid creation of type with both row and column
variables, we make the choice that the result record type is plugged in
a *closed* column.
The column of the minimal type is closed since we need it to be
instantiated only by 1 unique row, the one having at least the stated field
(the field to update by the extension).
{b Visibility}: Exported outside this module. *)
(* ************************************************************************** *)
let record_extention_min_expected_ty_and_result_ty field field_ty =
(* Create the row variable that will be shared between the minimal type to
expected for the expression to extend and the type of the result after
extension. Sharing this variable will ensure propagation of "other"
fields between the 2 types. *)
let shared_row_ending_var = row_ending_variable () in
(* Minimal row expected has just the field with no special type constraint
(i.e. with a variable) and any remaining row (i.e. a row variable, the one
we will share with the row of the result). *)
let min_expected_row =
{ W_Algebra.rt_value =
([(field, (type_variable ()))], shared_row_ending_var) } in
let extension_result_row =
{ W_Algebra.rt_value = ([(field, field_ty)], shared_row_ending_var) } in
(* The column hosting the row of the minimal record type we expect for the
expression to extend. This column is closed since we expect only 1 row to
instantiate it, i.e. we expect it to be unified with the unique row
representing a record. *)
let min_expected_column =
{ W_Algebra.ct_value = ([min_expected_row], W_Algebra.Closed_column) } in
let extension_result_column =
{ W_Algebra.ct_value =
([extension_result_row], W_Algebra.Closed_column) } in
let min_expected_record_ty = {
W_Algebra.sty_desc = W_Algebra.SType_sum_of_records min_expected_column ;
W_Algebra.sty_link = None ;
W_Algebra.sty_mark = W_Algebra.TM_not_seen } in
let extension_result_record_ty = {
W_Algebra.sty_desc =
W_Algebra.SType_sum_of_records extension_result_column ;
W_Algebra.sty_link = None ;
W_Algebra.sty_mark = W_Algebra.TM_not_seen } in
(min_expected_record_ty, extension_result_record_ty)
(* ************************************************************************** *)
(* **** Tracing and performing changes induced by unification in place **** *)
(* **** stuff **** *)
(* ************************************************************************** *)
(* ************************************************************************** *)
(** {b Descr}: Represents the various operations that unification may apply on
types to change their structure. This information will be recorded in a
stack to be able to revert the changes if needed.
Changes need to be reverted in 2 cases:
- Unification error in the inference: we want to display types in the
error message as they were before unification and not once they are
partially instantiated and hacked by the unification. This is more clean
for the user.
- Unification failure between 2 rows when unifying 2 column types. In
effect, in this case unification must by tried in cross. This is similar
to what happens during unification of 2 rows, the only thing is that
for 2 rows we just have to compare the 2 head constructors to know if we
must unify in cross or not. In the case of column, "comparing the 2 head"
constructors means "see if the 2 head rows unify". Hence, to see if they
unify... we must unify them, performing the side effects. And if they
finally don't unify, we must restore these 2 rows in there state before
we tried to unify them in order to be clean when trying to do the column
unification in cross.
ATTENTION:
When restoring the types from information stored in changes,
[simple_type]s recorded in the change must **never** be "repr-ed". In
effect, they represent the physical structures modified by the changes, so
reverting these changes must be done on these physical structures, not on
the canonical representation of them ! Especially, we want to rewind the
modifications that changed the canonical representation of these type !
So again, **never** "repr" them during restoration !
{b Visibility}: Not exported outside this module. *)
(* ************************************************************************** *)
type unification_change =
| UC_ty_level of (W_Algebra.type_variable * int) (** The level of the type
variable was of the recorded integer value before the
change occurred during the unification. In other words,
the recorded integer is the backup of the level of the
type variable before the unification modified it. *)
| UC_row_level of (W_Algebra.row_variable * int)
| UC_column_level of (W_Algebra.column_variable * int)
| UC_ty_link of (W_Algebra.simple_type * W_Algebra.simple_type option) (** The
recorded first [simple_type] had the recorded
[simple_type option] as [sty_link] field before the change
occurred during the unification. In other words, the
recorded [simple_type option] is the backup of the
type's [sty_link] field before the unification modified
it. *)
| UC_row_link of (W_Algebra.row_type *
((string * W_Algebra.simple_type) list *
W_Algebra.row_type_ending)) (** Same thing than
[UC_ty_link] but for rows. *)
| UC_column_link of (W_Algebra.column_type *
(W_Algebra.row_type list *
W_Algebra.column_type_ending)) (** Same thing than
[UC_ty_link] but for columns. *)
| UC_row_var_link of
(W_Algebra.row_variable * W_Algebra.row_variable_value) (** Same thing
than [UC_ty_link] but for row variables. *)
| UC_column_var_link of
(W_Algebra.column_variable * W_Algebra.column_variable_value) (** Same
thing than [UC_ty_link] but for column variables. *)
(* ************************************************************************** *)
(** {b Descr}: Basic cell of linked-list of unification changes. Such cells
are linked to represent a list (trace) of changes, each change being
plugged into a record type in order to get a physical equality test.
{b Visibility}: Not exported outside this module. *)
(* ************************************************************************** *)
type unification_changes_trace_item =
| UCT_no_change
| UCT_change of (unification_change * unification_changes_checkpoint)
(* ************************************************************************** *)
(** {b Descr}: Represents a checkpoint in a linked list of changes, i.e. a
"location" in the linked list of changes that can be identified by physical
equality. The need of physical equality is the reason for having here a
record. We need physical equality to be able to compare changes and
determine that while rewinding them, we reached the point where to stop
rewinding.
{b Visibility}: Exported as abstract outside this module. *)
(* ************************************************************************** *)
and unification_changes_checkpoint = {
uct_item : unification_changes_trace_item
}
(* ************************************************************************** *)
(** {b Descr}: Global, but really private, head of the current linked-list of
changes performed by unification at some point. This head gets updated as
long as unification is performed and according to reset and rewind requests.
The only guys allowed to manipulate it are:
[reset_unification_changes_trace], [get_current_changes_checkpoint],
[rewind_unification_changes], [change_..._level] and [change_..._link].
{b Visibility}: Not exported outside this module. *)
(* ************************************************************************** *)
let __performed_unification_changes = ref { uct_item = UCT_no_change }
(* ************************************************************************** *)
(** {b Descr}: Resets the list of changes performed by unification, i.e. clear
the linked-list, i.e. forget all the changes in the current trace.
{b Visibility}: Exported outside this module. *)
(* ************************************************************************** *)
let reset_unification_changes_trace () =
(* Initialize the head of the linked-list of changes with a fresh record
containing "no change". *)
__performed_unification_changes := { uct_item = UCT_no_change }
(* ************************************************************************** *)
(** {b Descr}: Returns the current state of the linked-list of changes done by
the unification, in order to get a "mark" of what is already changed, to be
able later to rewind changes until getting back into this state.
{b Visibility}: Exported outside this module. *)
(* ************************************************************************** *)
let get_current_changes_checkpoint () = !__performed_unification_changes
let rewind_unification_changes ~performed_after =
let rec iter_on_history head =
if head == performed_after then (
(* Finished: we arrived at the change that marks the point were rewind
must stop. *)
__performed_unification_changes := performed_after
)
else (
(* Not yet arrived at the change marked as the first one not to undo. *)
match head.uct_item with
| UCT_no_change -> assert false
| UCT_change (ch, next) -> (
match ch with
| UC_ty_level (var, lev) -> var.W_Algebra.tv_level <- lev
| UC_row_level (row_var, lev) -> row_var.W_Algebra.rv_level <- lev
| UC_column_level (col_var, lev) -> col_var.W_Algebra.cv_level <- lev
| UC_ty_link (ty, link_val) -> ty.W_Algebra.sty_link <- link_val
| UC_row_link (row_type, link_val) ->
row_type.W_Algebra.rt_value <- link_val
| UC_column_link (col_type, link_val) ->
col_type.W_Algebra.ct_value <- link_val
| UC_row_var_link (var, link_val) ->
var.W_Algebra.rv_value <- link_val ;
| UC_column_var_link (var, link_val) ->
var.W_Algebra.cv_value <- link_val) ;
(* Continue going back into the past. *)
iter_on_history next
) in
iter_on_history !__performed_unification_changes
(* ************************************************************************** *)
(** {b Descr}: Changes the binding level of a type variable. **Only** used by
the unification routine [W_Unify.__unify_simple_type] and
[W_Unify.lowerize_level_in_simple_type].
{b Visibility}: Exported outside this module. *)
(* ************************************************************************** *)
let change_ty_var_level var level =
(* Create a "change" representing a [tv_level] modification, backing-up the
type variable's level before its modification. *)
let ch = UC_ty_level (var, var.W_Algebra.tv_level) in
(* Add the change in head of the linked list of changes. *)
__performed_unification_changes :=
{ uct_item = UCT_change (ch, !__performed_unification_changes) } ;
(* Now really change the type's level. *)
var.W_Algebra.tv_level <- level
(* ************************************************************************** *)
(** {b Descr}: Changes the binding level of a row variable. **Only** used by the
unification routines [W_Unify.__unify_row_type] and
[W_Unify.lowerize_level_in_row].
{b Visibility}: Exported outside this module. *)
(* ************************************************************************** *)
let change_row_var_level row_var level =
(* Create a "change" representing a [rv_level] modification, backing-up the
row variable's level before its modification. *)
let ch = UC_row_level (row_var, row_var.W_Algebra.rv_level) in
(* Add the change in head of the linked list of changes. *)
__performed_unification_changes :=
{ uct_item = UCT_change (ch, !__performed_unification_changes) } ;
(* Now really change the row variable's level. *)
row_var.W_Algebra.rv_level <- level
(* ************************************************************************** *)
(** {b Descr}: Changes the binding level of a column variable. **Only** used
by the unification routines [W_Unify.__unify_column_type] and
[W_Unify.lowerize_level_in_column].
{b Visibility}: Exported outside this module. *)
(* ************************************************************************** *)
let change_column_var_level col_var level =
(* Create a "change" representing a [cv_level] modification, backing-up the
column variable's level before its modification. *)
let ch = UC_column_level (col_var, col_var.W_Algebra.cv_level) in
(* Add the change in head of the linked list of changes. *)
__performed_unification_changes :=
{ uct_item = UCT_change (ch, !__performed_unification_changes) } ;
(* Now really change the column variable's level. *)
col_var.W_Algebra.cv_level <- level
(* ************************************************************************** *)
(** {b Descr}: Changes the link toward what a type is in fact equal to.
**Only** used by the unification routine [W_Unify.__unify_simple_type] and
the "repr" routine [simple_type_repr].
{b Visibility}: Exported outside this module. *)
(* ************************************************************************** *)
let change_ty_link ~receiver ~link_val =
(* Create a "change" representing a [sty_link] modification, backing-up the
type's link before its modification. *)
let ch = UC_ty_link (receiver, receiver.W_Algebra.sty_link) in
(* Add the change in head of the linked list of changes. *)
__performed_unification_changes :=
{ uct_item = UCT_change (ch, !__performed_unification_changes) } ;
(* Now really change the type's link. *)
receiver.W_Algebra.sty_link <- link_val
(* ************************************************************************** *)
(*
val change_row_link:
receiver: W_Algebra.row_type ->
link_val:
((string * W_Algebra.simple_type) list * W_Algebra.row_type_ending) ->
unit
*)
(** {b Descr}: Changes the link toward what a row type is in fact equal to.
**Only** used by the "repr" routine [row_type_repr].
{b Visibility}: Not exported outside this module. *)
(* ************************************************************************** *)
let change_row_link ~receiver ~link_val =
(* Create a "change" representing a [rt_link] modification, backing-up the
row type's link before its modification. *)
let ch = UC_row_link (receiver, receiver.W_Algebra.rt_value) in
(* Add the change in head of the linked list of changes. *)
__performed_unification_changes :=
{ uct_item = UCT_change (ch, !__performed_unification_changes) } ;
(* Now really change the row type's link. *)
receiver.W_Algebra.rt_value <- link_val
(* ************************************************************************** *)
(*
val change_column_link:
receiver: W_Algebra.column_type ->
link_val: (W_Algebra.row_type list * W_Algebra.column_type_ending) ->
unit
*)
(** {b Descr}: Changes the link toward what a column type is in fact equal to.
**Only** used by the "repr" routine [column_type_repr].
{b Visibility}: Not exported outside this module. *)
(* ************************************************************************** *)
let change_column_link ~receiver ~link_val =
(* Create a "change" representing a [ct_link] modification, backing-up the
column type's link before its modification. *)
let ch = UC_column_link (receiver, receiver.W_Algebra.ct_value) in
(* Add the change in head of the linked list of changes. *)
__performed_unification_changes :=
{ uct_item = UCT_change (ch, !__performed_unification_changes) } ;
(* Now really change the column type's link. *)
receiver.W_Algebra.ct_value <- link_val
let change_row_var_link ~receiver ~link_val =
(* Create a "change" representing a [rv_value] modification, backing-up the
row variable's link before its modification. *)
let ch = UC_row_var_link (receiver, receiver.W_Algebra.rv_value) in
(* Add the change in head of the linked list of changes. *)
__performed_unification_changes :=
{ uct_item = UCT_change (ch, !__performed_unification_changes) } ;
(* Now really change the row type's link. *)
receiver.W_Algebra.rv_value <- link_val
let change_column_var_link ~receiver ~link_val =
(* Create a "change" representing a [cv_value] modification, backing-up the
column variable's link before its modification. *)
let ch = UC_column_var_link (receiver, receiver.W_Algebra.cv_value) in
(* Add the change in head of the linked list of changes. *)
__performed_unification_changes :=
{ uct_item = UCT_change (ch, !__performed_unification_changes) } ;
(* Now really change the row type's link. *)
receiver.W_Algebra.cv_value <- link_val
(* *************************************************** *)
(* **** Canonical representation of types stuff. **** *)
(* *************************************************** *)
(* ************************************************************************** *)
(** {b Descr}: Computes the canonical representation of a simple (i.e. ML-like)
type.
Before a type's structure can be structurally examined, this function must
be called to ensure that the type representation is the one of its canonical
form.
This function performs the union-find and path-compression to incrementally
follow instantiated types (variables or cycles) appearing in a type.
Instantiated variables as well as type cycles are "uncompressed" only at
the present level, i.e. at one level each time.
If we need one day to known more about the type instantiating a variable,
this will "uncompressed" later, just when we will really need it.
{b Visibility}: Exported outside this module. *)
(* ************************************************************************** *)
let rec simple_type_repr ty =
match ty with
| { W_Algebra.sty_link = Some eq_to_ty } ->
(* The type is "already known to be equal to another type". So, we
recursively ask for the canonical representation of this "another
type", and compress the instantiation path by telling in the
type's structure that we now it is equal to the canonical
representation of this "another" type. And then, we return this
"another type" since the type is equal to it. Hence, the original type
"disappears" from our result type. *)
let eq_to_ty' = simple_type_repr eq_to_ty in
change_ty_link ~receiver: ty ~link_val: (Some eq_to_ty') ;
eq_to_ty'
| otherwise ->
(* The type is not a an alias, it is something with a "hard" constructor.
Hence, we already have its "effective" toplevel structure. We don't
descent inside the structure, this will be done later if someone need
to know more about the sub-terms of type this type contains. *)
otherwise
(* ************************************************************************** *)
(** {b Descr}: Computes the canonical representation of a row type. The idea is
the same than for simple types. This is just a bit more tricky because rows
have a mutable "value field" and can contain row variables that, them, have
a mutable "row variable value" field. Hence path compression is performed
at the 2 levels. We compress row-variables when they are instantiated.
And we also compress rows when their "row ending" is instantiated. With this
last compression, we can see the canonical representation of a row in one
shot, instead of having each time to take its fields part and dig in its
"row ending" part to see if there is some more known fields to add to the
former part.
{b Visibility}: Exported outside this module. *)
(* ************************************************************************** *)
let rec row_type_repr row =
let (row_fields, row_ending) = row.W_Algebra.rt_value in
match row_ending with
| W_Algebra.Closed_row
| W_Algebra.Var_row { W_Algebra.rv_value = W_Algebra.Row_unknown } ->
row
| W_Algebra.Var_row { W_Algebra.rv_value = W_Algebra.Row_known row' } ->
(
let row'_repr = row_type_repr row' in
let (row'_fields, row'_ending) = row'_repr.W_Algebra.rt_value in
(* We assume lists are already individually sorted. *)
let all_fields =
Sort.merge (fun (f1, _) (f2, _) -> f1 < f2) row_fields row'_fields in
change_row_link ~receiver: row ~link_val: (all_fields, row'_ending) ;
row
)
(* ************************************************************************** *)
(** {b Descr}: Computes the canonical representation of a column type. Works
the same way than [row_type_repr] does.
{b Visibility}: Exported outside this module. *)
(* ************************************************************************** *)
let rec column_type_repr column =
let (col_rows, col_ending) = column.W_Algebra.ct_value in
match col_ending with
| W_Algebra.Closed_column
| W_Algebra.Var_column { W_Algebra.cv_value = W_Algebra.Col_unknown } ->
column
| W_Algebra.Var_column { W_Algebra.cv_value = W_Algebra.Col_known col' } ->
(
let col'_repr = column_type_repr col' in
let (col'_rows, col'_ending) = col'_repr.W_Algebra.ct_value in
(* We don't sort the rows representing the records of the sum. So,
we simply catenate all of them. *)
let all_rows = col_rows @ col'_rows in
change_column_link
~receiver: column ~link_val: (all_rows, col'_ending) ;
column
)