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
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
|
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
open Errors
open Pp
open Util
open Names
open Term
open Vars
open Termops
open Namegen
open Environ
open Evd
open Reduction
open Reductionops
open Evarutil
open Evarsolve
open Pretype_errors
open Retyping
open Coercion
open Recordops
open Locus
open Locusops
open Find_subterm
let keyed_unification = ref (false)
let _ = Goptions.declare_bool_option {
Goptions.optsync = true; Goptions.optdepr = false;
Goptions.optname = "Unification is keyed";
Goptions.optkey = ["Keyed";"Unification"];
Goptions.optread = (fun () -> !keyed_unification);
Goptions.optwrite = (fun a -> keyed_unification:=a);
}
let debug_unification = ref (false)
let _ = Goptions.declare_bool_option {
Goptions.optsync = true; Goptions.optdepr = false;
Goptions.optname =
"Print states sent to tactic unification";
Goptions.optkey = ["Debug";"Tactic";"Unification"];
Goptions.optread = (fun () -> !debug_unification);
Goptions.optwrite = (fun a -> debug_unification:=a);
}
let occur_meta_or_undefined_evar evd c =
let rec occrec c = match kind_of_term c with
| Meta _ -> raise Occur
| Evar (ev,args) ->
(match evar_body (Evd.find evd ev) with
| Evar_defined c ->
occrec c; Array.iter occrec args
| Evar_empty -> raise Occur)
| _ -> iter_constr occrec c
in try occrec c; false with Occur | Not_found -> true
let occur_meta_evd sigma mv c =
let rec occrec c =
(* Note: evars are not instantiated by terms with metas *)
let c = whd_evar sigma (whd_meta sigma c) in
match kind_of_term c with
| Meta mv' when Int.equal mv mv' -> raise Occur
| _ -> iter_constr occrec c
in try occrec c; false with Occur -> true
(* if lname_typ is [xn,An;..;x1,A1] and l is a list of terms,
gives [x1:A1]..[xn:An]c' such that c converts to ([x1:A1]..[xn:An]c' l) *)
let abstract_scheme env evd c l lname_typ =
List.fold_left2
(fun (t,evd) (locc,a) (na,_,ta) ->
let na = match kind_of_term a with Var id -> Name id | _ -> na in
(* [occur_meta ta] test removed for support of eelim/ecase but consequences
are unclear...
if occur_meta ta then error "cannot find a type for the generalisation"
else *)
if occur_meta a then mkLambda_name env (na,ta,t), evd
else
let t', evd' = Find_subterm.subst_closed_term_occ env evd locc a t in
mkLambda_name env (na,ta,t'), evd')
(c,evd)
(List.rev l)
lname_typ
(* Precondition: resulting abstraction is expected to be of type [typ] *)
let abstract_list_all env evd typ c l =
let ctxt,_ = splay_prod_n env evd (List.length l) typ in
let l_with_all_occs = List.map (function a -> (LikeFirst,a)) l in
let p,evd = abstract_scheme env evd c l_with_all_occs ctxt in
let evd,typp =
try Typing.e_type_of env evd p
with
| UserError _ ->
error_cannot_find_well_typed_abstraction env evd p l None
| Type_errors.TypeError (env',x) ->
error_cannot_find_well_typed_abstraction env evd p l (Some (env',x)) in
evd,(p,typp)
let set_occurrences_of_last_arg args =
Some AllOccurrences :: List.tl (Array.map_to_list (fun _ -> None) args)
let abstract_list_all_with_dependencies env evd typ c l =
let evd,ev = new_evar env evd typ in
let evd,ev' = evar_absorb_arguments env evd (destEvar ev) l in
let argoccs = set_occurrences_of_last_arg (snd ev') in
let evd,b =
Evarconv.second_order_matching empty_transparent_state
env evd ev' argoccs c in
if b then
let p = nf_evar evd (existential_value evd (destEvar ev)) in
evd, p
else error_cannot_find_well_typed_abstraction env evd
(nf_evar evd c) l None
(**)
(* A refinement of [conv_pb]: the integers tells how many arguments
were applied in the context of the conversion problem; if the number
is non zero, steps of eta-expansion will be allowed
*)
let opp_status = function
| IsSuperType -> IsSubType
| IsSubType -> IsSuperType
| Conv -> Conv
let add_type_status (x,y) = ((x,TypeNotProcessed),(y,TypeNotProcessed))
let extract_instance_status = function
| CUMUL -> add_type_status (IsSubType, IsSuperType)
| CONV -> add_type_status (Conv, Conv)
let rec subst_meta_instances bl c =
match kind_of_term c with
| Meta i ->
let select (j,_,_) = Int.equal i j in
(try pi2 (List.find select bl) with Not_found -> c)
| _ -> map_constr (subst_meta_instances bl) c
(** [env] should be the context in which the metas live *)
let pose_all_metas_as_evars env evd t =
let evdref = ref evd in
let rec aux t = match kind_of_term t with
| Meta mv ->
(match Evd.meta_opt_fvalue !evdref mv with
| Some ({rebus=c},_) -> c
| None ->
let {rebus=ty;freemetas=mvs} = Evd.meta_ftype evd mv in
let ty = if Evd.Metaset.is_empty mvs then ty else aux ty in
let src = Evd.evar_source_of_meta mv !evdref in
let ev = Evarutil.e_new_evar env evdref ~src ty in
evdref := meta_assign mv (ev,(Conv,TypeNotProcessed)) !evdref;
ev)
| _ ->
map_constr aux t in
let c = aux t in
(* side-effect *)
(!evdref, c)
let solve_pattern_eqn_array (env,nb) f l c (sigma,metasubst,evarsubst) =
match kind_of_term f with
| Meta k ->
(* We enforce that the Meta does not depend on the [nb]
extra assumptions added by unification to the context *)
let env' = pop_rel_context nb env in
let sigma,c = pose_all_metas_as_evars env' sigma c in
let c = solve_pattern_eqn env l c in
let pb = (Conv,TypeNotProcessed) in
if noccur_between 1 nb c then
sigma,(k,lift (-nb) c,pb)::metasubst,evarsubst
else error_cannot_unify_local env sigma (applist (f, l),c,c)
| Evar ev ->
let env' = pop_rel_context nb env in
let sigma,c = pose_all_metas_as_evars env' sigma c in
sigma,metasubst,(env,ev,solve_pattern_eqn env l c)::evarsubst
| _ -> assert false
let push d (env,n) = (push_rel_assum d env,n+1)
(*******************************)
(* Unification à l'ordre 0 de m et n: [unify_0 env sigma cv_pb m n]
renvoie deux listes:
metasubst:(int*constr)list récolte les instances des (Meta k)
evarsubst:(constr*constr)list récolte les instances des (Const "?k")
Attention : pas d'unification entre les différences instances d'une
même meta ou evar, il peut rester des doublons *)
(* Unification order: *)
(* Left to right: unifies first argument and then the other arguments *)
(*let unify_l2r x = List.rev x
(* Right to left: unifies last argument and then the other arguments *)
let unify_r2l x = x
let sort_eqns = unify_r2l
*)
(* Option introduced and activated in Coq 8.3 *)
let global_evars_pattern_unification_flag = ref true
open Goptions
let _ =
declare_bool_option
{ optsync = true;
optdepr = false;
optname = "pattern-unification for existential variables in tactics";
optkey = ["Tactic";"Evars";"Pattern";"Unification"];
optread = (fun () -> !global_evars_pattern_unification_flag);
optwrite = (:=) global_evars_pattern_unification_flag }
let _ =
declare_bool_option
{ optsync = true;
optdepr = false;
optname = "pattern-unification for existential variables in tactics";
optkey = ["Tactic";"Pattern";"Unification"];
optread = (fun () -> !global_evars_pattern_unification_flag);
optwrite = (:=) global_evars_pattern_unification_flag }
type core_unify_flags = {
modulo_conv_on_closed_terms : Names.transparent_state option;
(* What this flag controls was activated with all constants transparent, *)
(* even for auto, since Coq V5.10 *)
use_metas_eagerly_in_conv_on_closed_terms : bool;
(* This refinement of the conversion on closed terms is activable *)
(* (and activated for apply, rewrite but not auto since Feb 2008 for 8.2) *)
use_evars_eagerly_in_conv_on_closed_terms : bool;
modulo_delta : Names.transparent_state;
(* This controls which constants are unfoldable; this is on for apply *)
(* (but not simple apply) since Feb 2008 for 8.2 *)
modulo_delta_types : Names.transparent_state;
check_applied_meta_types : bool;
(* This controls whether meta's applied to arguments have their *)
(* type unified with the type of their instance *)
use_pattern_unification : bool;
(* This says if type classes instances resolution must be used to infer *)
(* the remaining evars *)
use_meta_bound_pattern_unification : bool;
(* This solves pattern "?n x1 ... xn = t" when the xi are distinct rels *)
(* This allows for instance to unify "forall x:A, B(x)" with "A' -> B'" *)
(* This was on for all tactics, including auto, since Sep 2006 for 8.1 *)
frozen_evars : Evar.Set.t;
(* Evars of this set are considered axioms and never instantiated *)
(* Useful e.g. for autorewrite *)
restrict_conv_on_strict_subterms : bool;
(* No conversion at the root of the term; potentially useful for rewrite *)
modulo_betaiota : bool;
(* Support betaiota in the reduction *)
(* Note that zeta is always used *)
modulo_eta : bool;
(* Support eta in the reduction *)
}
type unify_flags = {
core_unify_flags : core_unify_flags;
(* Governs unification of problems of the form "t(?x) = u(?x)" in apply *)
merge_unify_flags : core_unify_flags;
(* These are the flags to be used when trying to unify *)
(* several instances of the same metavariable *)
(* Typical situation is when we give a pattern to be matched *)
(* syntactically against a subterm but we want the metas of the *)
(* pattern to be modulo convertibility *)
subterm_unify_flags : core_unify_flags;
(* Governs unification of problems of the form "?X a1..an = u" in apply, *)
(* hence in rewrite and elim *)
allow_K_in_toplevel_higher_order_unification : bool;
(* Tells in second-order abstraction over subterms which have not *)
(* been found in term are allowed (used for rewrite, elim, or *)
(* apply with a lemma whose type has the form "?X a1 ... an") *)
resolve_evars : bool
(* This says if type classes instances resolution must be used to infer *)
(* the remaining evars *)
}
(* Default flag for unifying a type against a type (e.g. apply) *)
(* We set all conversion flags (no flag should be modified anymore) *)
let default_core_unify_flags () =
let ts = Names.full_transparent_state in {
modulo_conv_on_closed_terms = Some ts;
use_metas_eagerly_in_conv_on_closed_terms = true;
use_evars_eagerly_in_conv_on_closed_terms = false;
modulo_delta = ts;
modulo_delta_types = ts;
check_applied_meta_types = true;
use_pattern_unification = true;
use_meta_bound_pattern_unification = true;
frozen_evars = Evar.Set.empty;
restrict_conv_on_strict_subterms = false;
modulo_betaiota = true;
modulo_eta = true;
}
(* Default flag for first-order or second-order unification of a type *)
(* against another type (e.g. apply) *)
(* We set all conversion flags (no flag should be modified anymore) *)
let default_unify_flags () =
let flags = default_core_unify_flags () in {
core_unify_flags = flags;
merge_unify_flags = flags;
subterm_unify_flags = { flags with modulo_delta = var_full_transparent_state };
allow_K_in_toplevel_higher_order_unification = false; (* Why not? *)
resolve_evars = false
}
let set_no_delta_core_flags flags = { flags with
modulo_conv_on_closed_terms = None;
modulo_delta = empty_transparent_state;
check_applied_meta_types = false;
use_pattern_unification = false;
use_meta_bound_pattern_unification = true;
modulo_betaiota = false
}
let set_no_delta_flags flags = {
core_unify_flags = set_no_delta_core_flags flags.core_unify_flags;
merge_unify_flags = set_no_delta_core_flags flags.merge_unify_flags;
subterm_unify_flags = set_no_delta_core_flags flags.subterm_unify_flags;
allow_K_in_toplevel_higher_order_unification =
flags.allow_K_in_toplevel_higher_order_unification;
resolve_evars = flags.resolve_evars
}
(* Default flag for the "simple apply" version of unification of a *)
(* type against a type (e.g. apply) *)
(* We set only the flags available at the time the new "apply" extended *)
(* out of "simple apply" *)
let default_no_delta_core_unify_flags () = { (default_core_unify_flags ()) with
modulo_delta = empty_transparent_state;
check_applied_meta_types = false;
use_pattern_unification = false;
use_meta_bound_pattern_unification = true;
modulo_betaiota = false;
}
let default_no_delta_unify_flags () =
let flags = default_no_delta_core_unify_flags () in {
core_unify_flags = flags;
merge_unify_flags = flags;
subterm_unify_flags = flags;
allow_K_in_toplevel_higher_order_unification = false;
resolve_evars = false
}
(* Default flags for looking for subterms in elimination tactics *)
(* Not used in practice at the current date, to the exception of *)
(* allow_K) because only closed terms are involved in *)
(* induction/destruct/case/elim and w_unify_to_subterm_list does not *)
(* call w_unify for induction/destruct/case/elim (13/6/2011) *)
let elim_core_flags sigma = { (default_core_unify_flags ()) with
modulo_betaiota = false;
frozen_evars =
fold_undefined (fun evk _ evars -> Evar.Set.add evk evars)
sigma Evar.Set.empty;
}
let elim_flags_evars sigma =
let flags = elim_core_flags sigma in {
core_unify_flags = flags;
merge_unify_flags = flags;
subterm_unify_flags = { flags with modulo_delta = empty_transparent_state };
allow_K_in_toplevel_higher_order_unification = true;
resolve_evars = false
}
let elim_flags () = elim_flags_evars Evd.empty
let elim_no_delta_core_flags () = { (elim_core_flags Evd.empty) with
modulo_delta = empty_transparent_state;
check_applied_meta_types = false;
use_pattern_unification = false;
modulo_betaiota = false;
}
let elim_no_delta_flags () =
let flags = elim_no_delta_core_flags () in {
core_unify_flags = flags;
merge_unify_flags = flags;
subterm_unify_flags = flags;
allow_K_in_toplevel_higher_order_unification = true;
resolve_evars = false
}
let use_evars_pattern_unification flags =
!global_evars_pattern_unification_flag && flags.use_pattern_unification
&& Flags.version_strictly_greater Flags.V8_2
let use_metas_pattern_unification flags nb l =
!global_evars_pattern_unification_flag && flags.use_pattern_unification
|| (Flags.version_less_or_equal Flags.V8_3 ||
flags.use_meta_bound_pattern_unification) &&
Array.for_all (fun c -> isRel c && destRel c <= nb) l
type key =
| IsKey of Closure.table_key
| IsProj of projection * constr
let expand_table_key env = function
| ConstKey cst -> constant_opt_value_in env cst
| VarKey id -> (try named_body id env with Not_found -> None)
| RelKey _ -> None
let unfold_projection env p stk =
(match try Some (lookup_projection p env) with Not_found -> None with
| Some pb ->
let s = Stack.Proj (pb.Declarations.proj_npars, pb.Declarations.proj_arg,
p, Cst_stack.empty) in
s :: stk
| None -> assert false)
let expand_key ts env sigma = function
| Some (IsKey k) -> expand_table_key env k
| Some (IsProj (p, c)) ->
let red = Stack.zip (fst (whd_betaiota_deltazeta_for_iota_state ts env sigma
Cst_stack.empty (c, unfold_projection env p [])))
in if Term.eq_constr (mkProj (p, c)) red then None else Some red
| None -> None
type unirec_flags = {
at_top: bool;
with_types: bool;
with_cs : bool;
}
let subterm_restriction opt flags =
not opt.at_top && flags.restrict_conv_on_strict_subterms
let key_of env b flags f =
if subterm_restriction b flags then None else
match kind_of_term f with
| Const (cst, u) when is_transparent env (ConstKey cst) &&
(Cpred.mem cst (snd flags.modulo_delta)
|| Environ.is_projection cst env) ->
Some (IsKey (ConstKey (cst, u)))
| Var id when is_transparent env (VarKey id) &&
Id.Pred.mem id (fst flags.modulo_delta) ->
Some (IsKey (VarKey id))
| Proj (p, c) when Projection.unfolded p
|| Cpred.mem (Projection.constant p) (snd flags.modulo_delta) ->
Some (IsProj (p, c))
| _ -> None
let translate_key = function
| ConstKey (cst,u) -> ConstKey cst
| VarKey id -> VarKey id
| RelKey n -> RelKey n
let translate_key = function
| IsKey k -> translate_key k
| IsProj (c, _) -> ConstKey (Projection.constant c)
let oracle_order env cf1 cf2 =
match cf1 with
| None ->
(match cf2 with
| None -> None
| Some k2 -> Some false)
| Some k1 ->
match cf2 with
| None -> Some true
| Some k2 ->
match k1, k2 with
| IsProj (p, _), IsKey (ConstKey (p',_))
when eq_constant (Projection.constant p) p' ->
Some (not (Projection.unfolded p))
| IsKey (ConstKey (p,_)), IsProj (p', _)
when eq_constant p (Projection.constant p') ->
Some (Projection.unfolded p')
| _ ->
Some (Conv_oracle.oracle_order (Environ.oracle env) false
(translate_key k1) (translate_key k2))
let is_rigid_head flags t =
match kind_of_term t with
| Const (cst,u) -> not (Cpred.mem cst (snd flags.modulo_delta))
| Ind (i,u) -> true
| Construct _ -> true
| Fix _ | CoFix _ -> true
| _ -> false
let force_eqs c =
Universes.Constraints.fold
(fun ((l,d,r) as c) acc ->
let c' = if d == Universes.ULub then (l,Universes.UEq,r) else c in
Universes.Constraints.add c' acc)
c Universes.Constraints.empty
let constr_cmp pb sigma flags t u =
let b, cstrs =
if pb == Reduction.CONV then Universes.eq_constr_universes t u
else Universes.leq_constr_universes t u
in
if b then
try Evd.add_universe_constraints sigma cstrs, b
with Univ.UniverseInconsistency _ -> sigma, false
| Evd.UniversesDiffer ->
if is_rigid_head flags t then
try Evd.add_universe_constraints sigma (force_eqs cstrs), b
with Univ.UniverseInconsistency _ -> sigma, false
else sigma, false
else sigma, b
let do_reduce ts (env, nb) sigma c =
Stack.zip (fst (whd_betaiota_deltazeta_for_iota_state ts env sigma Cst_stack.empty (c, Stack.empty)))
let use_full_betaiota flags =
flags.modulo_betaiota && Flags.version_strictly_greater Flags.V8_3
let isAllowedEvar flags c = match kind_of_term c with
| Evar (evk,_) -> not (Evar.Set.mem evk flags.frozen_evars)
| _ -> false
let check_compatibility env pbty flags (sigma,metasubst,evarsubst) tyM tyN =
match subst_defined_metas_evars (metasubst,[]) tyM with
| None -> sigma
| Some m ->
match subst_defined_metas_evars (metasubst,[]) tyN with
| None -> sigma
| Some n ->
if is_ground_term sigma m && is_ground_term sigma n then
let sigma, b = infer_conv ~pb:pbty ~ts:flags.modulo_delta_types env sigma m n in
if b then sigma
else error_cannot_unify env sigma (m,n)
else sigma
let rec is_neutral env ts t =
let (f, l) = decompose_appvect t in
match kind_of_term f with
| Const (c, u) ->
not (Environ.evaluable_constant c env) ||
not (is_transparent env (ConstKey c)) ||
not (Cpred.mem c (snd ts))
| Var id ->
not (Environ.evaluable_named id env) ||
not (is_transparent env (VarKey id)) ||
not (Id.Pred.mem id (fst ts))
| Rel n -> true
| Evar _ | Meta _ -> true
| Case (_, p, c, cl) -> is_neutral env ts c
| Proj (p, c) -> is_neutral env ts c
| _ -> false
let is_eta_constructor_app env ts f l1 term =
match kind_of_term f with
| Construct (((_, i as ind), j), u) when i == 0 && j == 1 ->
let mib = lookup_mind (fst ind) env in
(match mib.Declarations.mind_record with
| Some (Some (_,exp,projs)) when mib.Declarations.mind_finite <> Decl_kinds.CoFinite &&
Array.length projs == Array.length l1 - mib.Declarations.mind_nparams ->
(** Check that the other term is neutral *)
is_neutral env ts term
| _ -> false)
| _ -> false
let eta_constructor_app env f l1 term =
match kind_of_term f with
| Construct (((_, i as ind), j), u) ->
let mib = lookup_mind (fst ind) env in
(match mib.Declarations.mind_record with
| Some (Some (_, projs, _)) ->
let npars = mib.Declarations.mind_nparams in
let pars, l1' = Array.chop npars l1 in
let arg = Array.append pars [|term|] in
let l2 = Array.map (fun p -> mkApp (mkConstU (p,u), arg)) projs in
l1', l2
| _ -> assert false)
| _ -> assert false
let rec unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flags m n =
let rec unirec_rec (curenv,nb as curenvnb) pb opt ((sigma,metasubst,evarsubst) as substn) curm curn =
let cM = Evarutil.whd_head_evar sigma curm
and cN = Evarutil.whd_head_evar sigma curn in
let () =
if !debug_unification then
msg_debug (Termops.print_constr_env curenv cM ++ str" ~= " ++ Termops.print_constr_env curenv cN)
in
match (kind_of_term cM,kind_of_term cN) with
| Meta k1, Meta k2 ->
if Int.equal k1 k2 then substn else
let stM,stN = extract_instance_status pb in
let sigma =
if opt.with_types && flags.check_applied_meta_types then
let tyM = Typing.meta_type sigma k1 in
let tyN = Typing.meta_type sigma k2 in
let l, r = if k2 < k1 then tyN, tyM else tyM, tyN in
check_compatibility curenv CUMUL flags substn l r
else sigma
in
if k2 < k1 then sigma,(k1,cN,stN)::metasubst,evarsubst
else sigma,(k2,cM,stM)::metasubst,evarsubst
| Meta k, _
when not (dependent cM cN) (* helps early trying alternatives *) ->
let sigma =
if opt.with_types && flags.check_applied_meta_types then
(try
let tyM = Typing.meta_type sigma k in
let tyN = get_type_of curenv ~lax:true sigma cN in
check_compatibility curenv CUMUL flags substn tyN tyM
with RetypeError _ ->
(* Renounce, maybe metas/evars prevents typing *) sigma)
else sigma
in
(* Here we check that [cN] does not contain any local variables *)
if Int.equal nb 0 then
sigma,(k,cN,snd (extract_instance_status pb))::metasubst,evarsubst
else if noccur_between 1 nb cN then
(sigma,
(k,lift (-nb) cN,snd (extract_instance_status pb))::metasubst,
evarsubst)
else error_cannot_unify_local curenv sigma (m,n,cN)
| _, Meta k
when not (dependent cN cM) (* helps early trying alternatives *) ->
let sigma =
if opt.with_types && flags.check_applied_meta_types then
(try
let tyM = get_type_of curenv ~lax:true sigma cM in
let tyN = Typing.meta_type sigma k in
check_compatibility curenv CUMUL flags substn tyM tyN
with RetypeError _ ->
(* Renounce, maybe metas/evars prevents typing *) sigma)
else sigma
in
(* Here we check that [cM] does not contain any local variables *)
if Int.equal nb 0 then
(sigma,(k,cM,fst (extract_instance_status pb))::metasubst,evarsubst)
else if noccur_between 1 nb cM
then
(sigma,(k,lift (-nb) cM,fst (extract_instance_status pb))::metasubst,
evarsubst)
else error_cannot_unify_local curenv sigma (m,n,cM)
| Evar (evk,_ as ev), _
when not (Evar.Set.mem evk flags.frozen_evars)
&& not (occur_evar evk cN) ->
let cmvars = free_rels cM and cnvars = free_rels cN in
if Int.Set.subset cnvars cmvars then
sigma,metasubst,((curenv,ev,cN)::evarsubst)
else error_cannot_unify_local curenv sigma (m,n,cN)
| _, Evar (evk,_ as ev)
when not (Evar.Set.mem evk flags.frozen_evars)
&& not (occur_evar evk cM) ->
let cmvars = free_rels cM and cnvars = free_rels cN in
if Int.Set.subset cmvars cnvars then
sigma,metasubst,((curenv,ev,cM)::evarsubst)
else error_cannot_unify_local curenv sigma (m,n,cN)
| Sort s1, Sort s2 ->
(try
let sigma' =
if pb == CUMUL
then Evd.set_leq_sort curenv sigma s1 s2
else Evd.set_eq_sort curenv sigma s1 s2
in (sigma', metasubst, evarsubst)
with e when Errors.noncritical e ->
error_cannot_unify curenv sigma (m,n))
| Lambda (na,t1,c1), Lambda (_,t2,c2) ->
unirec_rec (push (na,t1) curenvnb) CONV {opt with at_top = true}
(unirec_rec curenvnb CONV {opt with at_top = true; with_types = false} substn t1 t2) c1 c2
| Prod (na,t1,c1), Prod (_,t2,c2) ->
unirec_rec (push (na,t1) curenvnb) pb {opt with at_top = true}
(unirec_rec curenvnb CONV {opt with at_top = true; with_types = false} substn t1 t2) c1 c2
| LetIn (_,a,_,c), _ -> unirec_rec curenvnb pb opt substn (subst1 a c) cN
| _, LetIn (_,a,_,c) -> unirec_rec curenvnb pb opt substn cM (subst1 a c)
(** Fast path for projections. *)
| Proj (p1,c1), Proj (p2,c2) when eq_constant
(Projection.constant p1) (Projection.constant p2) ->
(try unify_same_proj curenvnb cv_pb {opt with at_top = true}
substn c1 c2
with ex when precatchable_exception ex ->
unify_not_same_head curenvnb pb opt substn cM cN)
(* eta-expansion *)
| Lambda (na,t1,c1), _ when flags.modulo_eta ->
unirec_rec (push (na,t1) curenvnb) CONV {opt with at_top = true} substn
c1 (mkApp (lift 1 cN,[|mkRel 1|]))
| _, Lambda (na,t2,c2) when flags.modulo_eta ->
unirec_rec (push (na,t2) curenvnb) CONV {opt with at_top = true} substn
(mkApp (lift 1 cM,[|mkRel 1|])) c2
(* For records *)
| App (f1, l1), _ when flags.modulo_eta &&
(* This ensures cN is an evar, meta or irreducible constant/variable
and not a constructor. *)
is_eta_constructor_app curenv flags.modulo_delta f1 l1 cN ->
(try
let l1', l2' = eta_constructor_app curenv f1 l1 cN in
let opt' = {opt with at_top = true; with_cs = false} in
Array.fold_left2 (unirec_rec curenvnb CONV opt') substn l1' l2'
with ex when precatchable_exception ex ->
match kind_of_term cN with
| App(f2,l2) when isMeta f2 || isEvar f2 ->
unify_app curenvnb pb opt substn cM f1 l1 cN f2 l2
| _ -> raise ex)
| _, App (f2, l2) when flags.modulo_eta &&
is_eta_constructor_app curenv flags.modulo_delta f2 l2 cM ->
(try
let l2', l1' = eta_constructor_app curenv f2 l2 cM in
let opt' = {opt with at_top = true; with_cs = false} in
Array.fold_left2 (unirec_rec curenvnb CONV opt') substn l1' l2'
with ex when precatchable_exception ex ->
match kind_of_term cM with
| App(f1,l1) when isMeta f1 || isEvar f1 ->
unify_app curenvnb pb opt substn cM f1 l1 cN f2 l2
| _ -> raise ex)
| Case (_,p1,c1,cl1), Case (_,p2,c2,cl2) ->
(try
let opt' = {opt with at_top = true; with_types = false} in
Array.fold_left2 (unirec_rec curenvnb CONV {opt with at_top = true})
(unirec_rec curenvnb CONV opt'
(unirec_rec curenvnb CONV opt' substn p1 p2) c1 c2)
cl1 cl2
with ex when precatchable_exception ex ->
reduce curenvnb pb opt substn cM cN)
| App (f1,l1), _ when
(isMeta f1 && use_metas_pattern_unification flags nb l1
|| use_evars_pattern_unification flags && isAllowedEvar flags f1) ->
(match
is_unification_pattern curenvnb sigma f1 (Array.to_list l1) cN
with
| None ->
(match kind_of_term cN with
| App (f2,l2) -> unify_app curenvnb pb opt substn cM f1 l1 cN f2 l2
| Proj _ -> unify_app curenvnb pb opt substn cM f1 l1 cN cN [||]
| _ -> unify_not_same_head curenvnb pb opt substn cM cN)
| Some l ->
solve_pattern_eqn_array curenvnb f1 l cN substn)
| _, App (f2,l2) when
(isMeta f2 && use_metas_pattern_unification flags nb l2
|| use_evars_pattern_unification flags && isAllowedEvar flags f2) ->
(match
is_unification_pattern curenvnb sigma f2 (Array.to_list l2) cM
with
| None ->
(match kind_of_term cM with
| App (f1,l1) -> unify_app curenvnb pb opt substn cM f1 l1 cN f2 l2
| Proj _ -> unify_app curenvnb pb opt substn cM cM [||] cN f2 l2
| _ -> unify_not_same_head curenvnb pb opt substn cM cN)
| Some l ->
solve_pattern_eqn_array curenvnb f2 l cM substn)
| App (f1,l1), App (f2,l2) ->
unify_app curenvnb pb opt substn cM f1 l1 cN f2 l2
| App (f1,l1), Proj(p2,c2) ->
unify_app curenvnb pb opt substn cM f1 l1 cN cN [||]
| Proj (p1,c1), App(f2,l2) ->
unify_app curenvnb pb opt substn cM cM [||] cN f2 l2
| _ ->
unify_not_same_head curenvnb pb opt substn cM cN
and unify_app (curenv, nb as curenvnb) pb opt (sigma, metas, evars as substn) cM f1 l1 cN f2 l2 =
try
let needs_expansion p c' =
match kind_of_term c' with
| Meta _ -> true
| Evar _ -> true
| Const (c, u) -> Constant.equal c (Projection.constant p)
| _ -> false
in
let expand_proj c c' l =
match kind_of_term c with
| Proj (p, t) when not (Projection.unfolded p) && needs_expansion p c' ->
(try destApp (Retyping.expand_projection curenv sigma p t (Array.to_list l))
with RetypeError _ -> (** Unification can be called on ill-typed terms, due
to FO and eta in particular, fail gracefully in that case *)
(c, l))
| _ -> (c, l)
in
let f1, l1 = expand_proj f1 f2 l1 in
let f2, l2 = expand_proj f2 f1 l2 in
let opta = {opt with at_top = true; with_types = false} in
let optf = {opt with at_top = true; with_types = true} in
let (f1,l1,f2,l2) = adjust_app_array_size f1 l1 f2 l2 in
if Array.length l1 == 0 then error_cannot_unify (fst curenvnb) sigma (cM,cN)
else
Array.fold_left2 (unirec_rec curenvnb CONV opta)
(unirec_rec curenvnb CONV optf substn f1 f2) l1 l2
with ex when precatchable_exception ex ->
try reduce curenvnb pb {opt with with_types = false} substn cM cN
with ex when precatchable_exception ex ->
try canonical_projections curenvnb pb opt cM cN substn
with ex when precatchable_exception ex ->
expand curenvnb pb {opt with with_types = false} substn cM f1 l1 cN f2 l2
and unify_same_proj (curenv, nb as curenvnb) cv_pb opt substn c1 c2 =
let substn = unirec_rec curenvnb CONV opt substn c1 c2 in
try (* Force unification of the types to fill in parameters *)
let ty1 = get_type_of curenv ~lax:true sigma c1 in
let ty2 = get_type_of curenv ~lax:true sigma c2 in
unify_0_with_initial_metas substn true curenv cv_pb
{ flags with modulo_conv_on_closed_terms = Some full_transparent_state;
modulo_delta = full_transparent_state;
modulo_eta = true;
modulo_betaiota = true }
ty1 ty2
with RetypeError _ -> substn
and unify_not_same_head curenvnb pb opt (sigma, metas, evars as substn) cM cN =
try canonical_projections curenvnb pb opt cM cN substn
with ex when precatchable_exception ex ->
let sigma', b = constr_cmp cv_pb sigma flags cM cN in
if b then (sigma', metas, evars)
else
try reduce curenvnb pb opt substn cM cN
with ex when precatchable_exception ex ->
let (f1,l1) =
match kind_of_term cM with App (f,l) -> (f,l) | _ -> (cM,[||]) in
let (f2,l2) =
match kind_of_term cN with App (f,l) -> (f,l) | _ -> (cN,[||]) in
expand curenvnb pb opt substn cM f1 l1 cN f2 l2
and reduce curenvnb pb opt (sigma, metas, evars as substn) cM cN =
if use_full_betaiota flags && not (subterm_restriction opt flags) then
let cM' = do_reduce flags.modulo_delta curenvnb sigma cM in
if not (Term.eq_constr cM cM') then
unirec_rec curenvnb pb opt substn cM' cN
else
let cN' = do_reduce flags.modulo_delta curenvnb sigma cN in
if not (Term.eq_constr cN cN') then
unirec_rec curenvnb pb opt substn cM cN'
else error_cannot_unify (fst curenvnb) sigma (cM,cN)
else error_cannot_unify (fst curenvnb) sigma (cM,cN)
and expand (curenv,_ as curenvnb) pb opt (sigma,metasubst,evarsubst as substn) cM f1 l1 cN f2 l2 =
let res =
(* Try full conversion on meta-free terms. *)
(* Back to 1995 (later on called trivial_unify in 2002), the
heuristic was to apply conversion on meta-free (but not
evar-free!) terms in all cases (i.e. for apply but also for
auto and rewrite, even though auto and rewrite did not use
modulo conversion in the rest of the unification
algorithm). By compatibility we need to support this
separately from the main unification algorithm *)
(* The exploitation of known metas has been added in May 2007
(it is used by apply and rewrite); it might now be redundant
with the support for delta-expansion (which is used
essentially for apply)... *)
if subterm_restriction opt flags then None else
match flags.modulo_conv_on_closed_terms with
| None -> None
| Some convflags ->
let subst = ((if flags.use_metas_eagerly_in_conv_on_closed_terms then metasubst else ms), (if flags.use_evars_eagerly_in_conv_on_closed_terms then evarsubst else es)) in
match subst_defined_metas_evars subst cM with
| None -> (* some undefined Metas in cM *) None
| Some m1 ->
match subst_defined_metas_evars subst cN with
| None -> (* some undefined Metas in cN *) None
| Some n1 ->
(* No subterm restriction there, too much incompatibilities *)
let sigma, b = infer_conv ~pb ~ts:convflags curenv sigma m1 n1 in
if b then Some (sigma, metasubst, evarsubst)
else
if is_ground_term sigma m1 && is_ground_term sigma n1 then
error_cannot_unify curenv sigma (cM,cN)
else None
in
match res with
| Some substn -> substn
| None ->
let cf1 = key_of curenv opt flags f1 and cf2 = key_of curenv opt flags f2 in
match oracle_order curenv cf1 cf2 with
| None -> error_cannot_unify curenv sigma (cM,cN)
| Some true ->
(match expand_key flags.modulo_delta curenv sigma cf1 with
| Some c ->
unirec_rec curenvnb pb opt substn
(whd_betaiotazeta sigma (mkApp(c,l1))) cN
| None ->
(match expand_key flags.modulo_delta curenv sigma cf2 with
| Some c ->
unirec_rec curenvnb pb opt substn cM
(whd_betaiotazeta sigma (mkApp(c,l2)))
| None ->
error_cannot_unify curenv sigma (cM,cN)))
| Some false ->
(match expand_key flags.modulo_delta curenv sigma cf2 with
| Some c ->
unirec_rec curenvnb pb opt substn cM
(whd_betaiotazeta sigma (mkApp(c,l2)))
| None ->
(match expand_key flags.modulo_delta curenv sigma cf1 with
| Some c ->
unirec_rec curenvnb pb opt substn
(whd_betaiotazeta sigma (mkApp(c,l1))) cN
| None ->
error_cannot_unify curenv sigma (cM,cN)))
and canonical_projections (curenv, _ as curenvnb) pb opt cM cN (sigma,_,_ as substn) =
let f1 () =
if isApp cM then
let f1l1 = whd_nored_state sigma (cM,Stack.empty) in
if is_open_canonical_projection curenv sigma f1l1 then
let f2l2 = whd_nored_state sigma (cN,Stack.empty) in
solve_canonical_projection curenvnb pb opt cM f1l1 cN f2l2 substn
else error_cannot_unify (fst curenvnb) sigma (cM,cN)
else error_cannot_unify (fst curenvnb) sigma (cM,cN)
in
if not opt.with_cs ||
begin match flags.modulo_conv_on_closed_terms with
| None -> true
| Some _ -> subterm_restriction opt flags
end then
error_cannot_unify (fst curenvnb) sigma (cM,cN)
else
try f1 () with e when precatchable_exception e ->
if isApp cN then
let f2l2 = whd_nored_state sigma (cN, Stack.empty) in
if is_open_canonical_projection curenv sigma f2l2 then
let f1l1 = whd_nored_state sigma (cM, Stack.empty) in
solve_canonical_projection curenvnb pb opt cN f2l2 cM f1l1 substn
else error_cannot_unify (fst curenvnb) sigma (cM,cN)
else error_cannot_unify (fst curenvnb) sigma (cM,cN)
and solve_canonical_projection curenvnb pb opt cM f1l1 cN f2l2 (sigma,ms,es) =
let (ctx,t,c,bs,(params,params1),(us,us2),(ts,ts1),c1,(n,t2)) =
try Evarconv.check_conv_record f1l1 f2l2
with Not_found -> error_cannot_unify (fst curenvnb) sigma (cM,cN)
in
if Reductionops.Stack.compare_shape ts ts1 then
let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx in
let (evd,ks,_) =
List.fold_left
(fun (evd,ks,m) b ->
if Int.equal m n then (evd,t2::ks, m-1) else
let mv = new_meta () in
let evd' = meta_declare mv (substl ks b) evd in
(evd', mkMeta mv :: ks, m - 1))
(sigma,[],List.length bs - 1) bs
in
try
let opt' = {opt with with_types = false} in
let (substn,_,_) = Reductionops.Stack.fold2
(fun s u1 u -> unirec_rec curenvnb pb opt' s u1 (substl ks u))
(evd,ms,es) us2 us in
let (substn,_,_) = Reductionops.Stack.fold2
(fun s u1 u -> unirec_rec curenvnb pb opt' s u1 (substl ks u))
substn params1 params in
let (substn,_,_) = Reductionops.Stack.fold2 (unirec_rec curenvnb pb opt') substn ts ts1 in
let app = mkApp (c, Array.rev_of_list ks) in
(* let substn = unirec_rec curenvnb pb b false substn t cN in *)
unirec_rec curenvnb pb opt' substn c1 app
with Invalid_argument "Reductionops.Stack.fold2" ->
error_cannot_unify (fst curenvnb) sigma (cM,cN)
else error_cannot_unify (fst curenvnb) sigma (cM,cN)
in
if !debug_unification then msg_debug (str "Starting unification");
let opt = { at_top = conv_at_top; with_types = false; with_cs = true } in
let res =
if occur_meta_or_undefined_evar sigma m || occur_meta_or_undefined_evar sigma n
|| subterm_restriction opt flags then None
else
let sigma, b = match flags.modulo_conv_on_closed_terms with
| Some convflags -> infer_conv ~pb:cv_pb ~ts:convflags env sigma m n
| _ -> constr_cmp cv_pb sigma flags m n in
if b then Some sigma
else if (match flags.modulo_conv_on_closed_terms, flags.modulo_delta with
| Some (cv_id, cv_k), (dl_id, dl_k) ->
Id.Pred.subset dl_id cv_id && Cpred.subset dl_k cv_k
| None,(dl_id, dl_k) ->
Id.Pred.is_empty dl_id && Cpred.is_empty dl_k)
then error_cannot_unify env sigma (m, n) else None
in
try
let a = match res with
| Some sigma -> sigma, ms, es
| None -> unirec_rec (env,0) cv_pb opt subst m n in
if !debug_unification then msg_debug (str "Leaving unification with success");
a
with e ->
if !debug_unification then msg_debug (str "Leaving unification with failure");
raise e
let unify_0 env sigma = unify_0_with_initial_metas (sigma,[],[]) true env
let left = true
let right = false
let rec unify_with_eta keptside flags env sigma c1 c2 =
(* Question: try whd_betadeltaiota on ci if not two lambdas? *)
match kind_of_term c1, kind_of_term c2 with
| (Lambda (na,t1,c1'), Lambda (_,t2,c2')) ->
let env' = push_rel_assum (na,t1) env in
let sigma,metas,evars = unify_0 env sigma CONV flags t1 t2 in
let side,(sigma,metas',evars') =
unify_with_eta keptside flags env' sigma c1' c2'
in (side,(sigma,metas@metas',evars@evars'))
| (Lambda (na,t,c1'),_)->
let env' = push_rel_assum (na,t) env in
let side = left in (* expansion on the right: we keep the left side *)
unify_with_eta side flags env' sigma
c1' (mkApp (lift 1 c2,[|mkRel 1|]))
| (_,Lambda (na,t,c2')) ->
let env' = push_rel_assum (na,t) env in
let side = right in (* expansion on the left: we keep the right side *)
unify_with_eta side flags env' sigma
(mkApp (lift 1 c1,[|mkRel 1|])) c2'
| _ ->
(keptside,unify_0 env sigma CONV flags c1 c2)
(* We solved problems [?n =_pb u] (i.e. [u =_(opp pb) ?n]) and [?n =_pb' u'],
we now compute the problem on [u =? u'] and decide which of u or u' is kept
Rem: the upper constraint is lost in case u <= ?n <= u' (and symmetrically
in the case u' <= ?n <= u)
*)
let merge_instances env sigma flags st1 st2 c1 c2 =
match (opp_status st1, st2) with
| (Conv, Conv) ->
let side = left (* arbitrary choice, but agrees with compatibility *) in
let (side,res) = unify_with_eta side flags env sigma c1 c2 in
(side,Conv,res)
| ((IsSubType | Conv as oppst1),
(IsSubType | Conv)) ->
let res = unify_0 env sigma CUMUL flags c2 c1 in
if eq_instance_constraint oppst1 st2 then (* arbitrary choice *) (left, st1, res)
else if eq_instance_constraint st2 IsSubType then (left, st1, res)
else (right, st2, res)
| ((IsSuperType | Conv as oppst1),
(IsSuperType | Conv)) ->
let res = unify_0 env sigma CUMUL flags c1 c2 in
if eq_instance_constraint oppst1 st2 then (* arbitrary choice *) (left, st1, res)
else if eq_instance_constraint st2 IsSuperType then (left, st1, res)
else (right, st2, res)
| (IsSuperType,IsSubType) ->
(try (left, IsSubType, unify_0 env sigma CUMUL flags c2 c1)
with e when Errors.noncritical e ->
(right, IsSubType, unify_0 env sigma CUMUL flags c1 c2))
| (IsSubType,IsSuperType) ->
(try (left, IsSuperType, unify_0 env sigma CUMUL flags c1 c2)
with e when Errors.noncritical e ->
(right, IsSuperType, unify_0 env sigma CUMUL flags c2 c1))
(* Unification
*
* Procedure:
* (1) The function [unify mc wc M N] produces two lists:
* (a) a list of bindings Meta->RHS
* (b) a list of bindings EVAR->RHS
*
* The Meta->RHS bindings cannot themselves contain
* meta-vars, so they get applied eagerly to the other
* bindings. This may or may not close off all RHSs of
* the EVARs. For each EVAR whose RHS is closed off,
* we can just apply it, and go on. For each which
* is not closed off, we need to do a mimick step -
* in general, we have something like:
*
* ?X == (c e1 e2 ... ei[Meta(k)] ... en)
*
* so we need to do a mimick step, converting ?X
* into
*
* ?X -> (c ?z1 ... ?zn)
*
* of the proper types. Then, we can decompose the
* equation into
*
* ?z1 --> e1
* ...
* ?zi --> ei[Meta(k)]
* ...
* ?zn --> en
*
* and keep on going. Whenever we find that a R.H.S.
* is closed, we can, as before, apply the constraint
* directly. Whenever we find an equation of the form:
*
* ?z -> Meta(n)
*
* we can reverse the equation, put it into our metavar
* substitution, and keep going.
*
* The most efficient mimick possible is, for each
* Meta-var remaining in the term, to declare a
* new EVAR of the same type. This is supposedly
* determinable from the clausale form context -
* we look up the metavar, take its type there,
* and apply the metavar substitution to it, to
* close it off. But this might not always work,
* since other metavars might also need to be resolved. *)
let applyHead env evd n c =
let rec apprec n c cty evd =
if Int.equal n 0 then
(evd, c)
else
match kind_of_term (whd_betadeltaiota env evd cty) with
| Prod (_,c1,c2) ->
let (evd',evar) =
Evarutil.new_evar env evd ~src:(Loc.ghost,Evar_kinds.GoalEvar) c1 in
apprec (n-1) (mkApp(c,[|evar|])) (subst1 evar c2) evd'
| _ -> error "Apply_Head_Then"
in
apprec n c (Typing.type_of env evd c) evd
let is_mimick_head ts f =
match kind_of_term f with
| Const (c,u) -> not (Closure.is_transparent_constant ts c)
| Var id -> not (Closure.is_transparent_variable ts id)
| (Rel _|Construct _|Ind _) -> true
| _ -> false
let try_to_coerce env evd c cty tycon =
let j = make_judge c cty in
let (evd',j') = inh_conv_coerce_rigid_to true Loc.ghost env evd j tycon in
let evd' = Evarconv.consider_remaining_unif_problems env evd' in
let evd' = Evd.map_metas_fvalue (nf_evar evd') evd' in
(evd',j'.uj_val)
let w_coerce_to_type env evd c cty mvty =
let evd,tycon = pose_all_metas_as_evars env evd mvty in
try try_to_coerce env evd c cty tycon
with e when precatchable_exception e ->
(* inh_conv_coerce_rigid_to should have reasoned modulo reduction
but there are cases where it though it was not rigid (like in
fst (nat,nat)) and stops while it could have seen that it is rigid *)
let cty = Tacred.hnf_constr env evd cty in
try_to_coerce env evd c cty tycon
let w_coerce env evd mv c =
let cty = get_type_of env evd c in
let mvty = Typing.meta_type evd mv in
w_coerce_to_type env evd c cty mvty
let unify_to_type env sigma flags c status u =
let sigma, c = refresh_universes (Some false) env sigma c in
let t = get_type_of env sigma (nf_meta sigma c) in
let t = nf_betaiota sigma (nf_meta sigma t) in
unify_0 env sigma CUMUL flags t u
let unify_type env sigma flags mv status c =
let mvty = Typing.meta_type sigma mv in
let mvty = nf_meta sigma mvty in
unify_to_type env sigma
{flags with modulo_delta = flags.modulo_delta_types;
modulo_conv_on_closed_terms = Some flags.modulo_delta_types;
modulo_betaiota = true}
c status mvty
(* Move metas that may need coercion at the end of the list of instances *)
let order_metas metas =
let rec order latemetas = function
| [] -> List.rev latemetas
| (_,_,(_,CoerceToType) as meta)::metas ->
order (meta::latemetas) metas
| (_,_,(_,_) as meta)::metas ->
meta :: order latemetas metas
in order [] metas
(* Solve an equation ?n[x1=u1..xn=un] = t where ?n is an evar *)
let solve_simple_evar_eqn ts env evd ev rhs =
match solve_simple_eqn (Evarconv.evar_conv_x ts) env evd (None,ev,rhs) with
| UnifFailure (evd,reason) ->
error_cannot_unify env evd ~reason (mkEvar ev,rhs);
| Success evd ->
Evarconv.consider_remaining_unif_problems env evd
(* [w_merge env sigma b metas evars] merges common instances in metas
or in evars, possibly generating new unification problems; if [b]
is true, unification of types of metas is required *)
let w_merge env with_types flags (evd,metas,evars) =
let rec w_merge_rec evd metas evars eqns =
(* Process evars *)
match evars with
| (curenv,(evk,_ as ev),rhs)::evars' ->
if Evd.is_defined evd evk then
let v = Evd.existential_value evd ev in
let (evd,metas',evars'') =
unify_0 curenv evd CONV flags rhs v in
w_merge_rec evd (metas'@metas) (evars''@evars') eqns
else begin
(* This can make rhs' ill-typed if metas are *)
let rhs' = subst_meta_instances metas rhs in
match kind_of_term rhs with
| App (f,cl) when occur_meta rhs' ->
if occur_evar evk rhs' then
error_occur_check curenv evd evk rhs';
if is_mimick_head flags.modulo_delta f then
let evd' =
mimick_undefined_evar evd flags f (Array.length cl) evk in
(* let evd' = Evarconv.consider_remaining_unif_problems env evd' in *)
w_merge_rec evd' metas evars eqns
else
let evd' =
let evd', rhs'' = pose_all_metas_as_evars curenv evd rhs' in
try solve_simple_evar_eqn flags.modulo_delta_types curenv evd' ev rhs''
with Retyping.RetypeError _ ->
error_cannot_unify curenv evd' (mkEvar ev,rhs'')
in w_merge_rec evd' metas evars' eqns
| _ ->
let evd', rhs'' = pose_all_metas_as_evars curenv evd rhs' in
let evd' =
try solve_simple_evar_eqn flags.modulo_delta_types curenv evd' ev rhs''
with Retyping.RetypeError _ -> error_cannot_unify curenv evd' (mkEvar ev, rhs'')
in
w_merge_rec evd' metas evars' eqns
end
| [] ->
(* Process metas *)
match metas with
| (mv,c,(status,to_type))::metas ->
let ((evd,c),(metas'',evars'')),eqns =
if with_types && to_type != TypeProcessed then
begin match to_type with
| CoerceToType ->
(* Some coercion may have to be inserted *)
(w_coerce env evd mv c,([],[])),eqns
| _ ->
(* No coercion needed: delay the unification of types *)
((evd,c),([],[])),(mv,status,c)::eqns
end
else
((evd,c),([],[])),eqns
in
if meta_defined evd mv then
let {rebus=c'},(status',_) = meta_fvalue evd mv in
let (take_left,st,(evd,metas',evars')) =
merge_instances env evd flags status' status c' c
in
let evd' =
if take_left then evd
else meta_reassign mv (c,(st,TypeProcessed)) evd
in
w_merge_rec evd' (metas'@metas@metas'') (evars'@evars'') eqns
else
let evd' =
if occur_meta_evd evd mv c then
if isMetaOf mv (whd_betadeltaiota env evd c) then evd
else error_cannot_unify env evd (mkMeta mv,c)
else
meta_assign mv (c,(status,TypeProcessed)) evd in
w_merge_rec evd' (metas''@metas) evars'' eqns
| [] ->
(* Process type eqns *)
let rec process_eqns failures = function
| (mv,status,c)::eqns ->
(match (try Inl (unify_type env evd flags mv status c)
with e when Errors.noncritical e -> Inr e)
with
| Inr e -> process_eqns (((mv,status,c),e)::failures) eqns
| Inl (evd,metas,evars) ->
w_merge_rec evd metas evars (List.map fst failures @ eqns))
| [] ->
(match failures with
| [] -> evd
| ((mv,status,c),e)::_ -> raise e)
in process_eqns [] eqns
and mimick_undefined_evar evd flags hdc nargs sp =
let ev = Evd.find_undefined evd sp in
let sp_env = Global.env_of_context ev.evar_hyps in
let (evd', c) = applyHead sp_env evd nargs hdc in
let (evd'',mc,ec) =
unify_0 sp_env evd' CUMUL flags
(get_type_of sp_env evd' c) ev.evar_concl in
let evd''' = w_merge_rec evd'' mc ec [] in
if evd' == evd'''
then Evd.define sp c evd'''
else Evd.define sp (Evarutil.nf_evar evd''' c) evd''' in
let check_types evd =
let metas = Evd.meta_list evd in
let eqns = List.fold_left (fun acc (mv, b) ->
match b with
| Clval (n, (t, (c, TypeNotProcessed)), v) -> (mv, c, t.rebus) :: acc
| _ -> acc) [] metas
in w_merge_rec evd [] [] eqns
in
let res = (* merge constraints *)
w_merge_rec evd (order_metas metas) (List.rev evars) []
in
if with_types then check_types res
else res
let w_unify_meta_types env ?(flags=default_unify_flags ()) evd =
let metas,evd = retract_coercible_metas evd in
w_merge env true flags.merge_unify_flags (evd,metas,[])
(* [w_unify env evd M N]
performs a unification of M and N, generating a bunch of
unification constraints in the process. These constraints
are processed, one-by-one - they may either generate new
bindings, or, if there is already a binding, new unifications,
which themselves generate new constraints. This continues
until we get failure, or we run out of constraints.
[clenv_typed_unify M N clenv] expects in addition that expected
types of metavars are unifiable with the types of their instances *)
let head_app sigma m =
fst (whd_nored_state sigma (m, Stack.empty))
let check_types env flags (sigma,_,_ as subst) m n =
if isEvar_or_Meta (head_app sigma m) then
unify_0_with_initial_metas subst true env CUMUL
flags
(get_type_of env sigma n)
(get_type_of env sigma m)
else if isEvar_or_Meta (head_app sigma n) then
unify_0_with_initial_metas subst true env CUMUL
flags
(get_type_of env sigma m)
(get_type_of env sigma n)
else subst
let try_resolve_typeclasses env evd flag m n =
if flag then
Typeclasses.resolve_typeclasses ~filter:Typeclasses.no_goals ~split:false
~fail:true env evd
else evd
let w_unify_core_0 env evd with_types cv_pb flags m n =
let (mc1,evd') = retract_coercible_metas evd in
let (sigma,ms,es) = check_types env flags.core_unify_flags (evd,mc1,[]) m n in
let subst2 =
unify_0_with_initial_metas (evd',ms,es) false env cv_pb
flags.core_unify_flags m n
in
let evd = w_merge env with_types flags.merge_unify_flags subst2 in
try_resolve_typeclasses env evd flags.resolve_evars m n
let w_typed_unify env evd = w_unify_core_0 env evd true
let w_typed_unify_array env evd flags f1 l1 f2 l2 =
let f1,l1,f2,l2 = adjust_app_array_size f1 l1 f2 l2 in
let (mc1,evd') = retract_coercible_metas evd in
let fold_subst subst m n = unify_0_with_initial_metas subst true env CONV flags.core_unify_flags m n in
let subst = fold_subst (evd', [], []) f1 f2 in
let subst = Array.fold_left2 fold_subst subst l1 l2 in
let evd = w_merge env true flags.merge_unify_flags subst in
try_resolve_typeclasses env evd flags.resolve_evars
(mkApp(f1,l1)) (mkApp(f2,l2))
(* takes a substitution s, an open term op and a closed term cl
try to find a subterm of cl which matches op, if op is just a Meta
FAIL because we cannot find a binding *)
let iter_fail f a =
let n = Array.length a in
let rec ffail i =
if Int.equal i n then error "iter_fail"
else
try f a.(i)
with ex when precatchable_exception ex -> ffail (i+1)
in ffail 0
(* make_abstraction: a variant of w_unify_to_subterm which works on
contexts, with evars, and possibly with occurrences *)
let indirectly_dependent c d decls =
not (isVar c) &&
(* This test is not needed if the original term is a variable, but
it is needed otherwise, as e.g. when abstracting over "2" in
"forall H:0=2, H=H:>(0=1+1) -> 0=2." where there is now obvious
way to see that the second hypothesis depends indirectly over 2 *)
List.exists (fun (id,_,_) -> dependent_in_decl (mkVar id) d) decls
let indirect_dependency d decls =
pi1 (List.hd (List.filter (fun (id,_,_) -> dependent_in_decl (mkVar id) d) decls))
let finish_evar_resolution ?(flags=Pretyping.all_and_fail_flags) env current_sigma (pending,c) =
let sigma = Pretyping.solve_remaining_evars flags env current_sigma pending in
let sigma, subst = nf_univ_variables sigma in
sigma, subst_univs_constr subst (nf_evar sigma c)
let default_matching_core_flags sigma =
let ts = Names.full_transparent_state in {
modulo_conv_on_closed_terms = Some empty_transparent_state;
use_metas_eagerly_in_conv_on_closed_terms = false;
use_evars_eagerly_in_conv_on_closed_terms = false;
modulo_delta = empty_transparent_state;
modulo_delta_types = ts;
check_applied_meta_types = true;
use_pattern_unification = false;
use_meta_bound_pattern_unification = false;
frozen_evars =
fold_undefined (fun evk _ evars -> Evar.Set.add evk evars)
sigma Evar.Set.empty;
restrict_conv_on_strict_subterms = false;
modulo_betaiota = false;
modulo_eta = false;
}
let default_matching_merge_flags sigma =
let ts = Names.full_transparent_state in
let flags = default_matching_core_flags sigma in {
flags with
modulo_conv_on_closed_terms = Some ts;
modulo_delta = ts;
modulo_betaiota = true;
modulo_eta = true;
use_pattern_unification = true;
}
let default_matching_flags (sigma,_) =
let flags = default_matching_core_flags sigma in {
core_unify_flags = flags;
merge_unify_flags = default_matching_merge_flags sigma;
subterm_unify_flags = flags; (* does not matter *)
resolve_evars = false;
allow_K_in_toplevel_higher_order_unification = false;
}
(* This supports search of occurrences of term from a pattern *)
(* from_prefix is useful e.g. for subterms in an inductive type: we can say *)
(* "destruct t" and it finds "t u" *)
exception PatternNotFound
let make_pattern_test from_prefix_of_ind is_correct_type env sigma (pending,c) =
let flags =
if from_prefix_of_ind then
let flags = default_matching_flags pending in
{ flags with core_unify_flags = { flags.core_unify_flags with
modulo_conv_on_closed_terms = Some Names.full_transparent_state;
restrict_conv_on_strict_subterms = true } }
else default_matching_flags pending in
let n = List.length (snd (decompose_app c)) in
let matching_fun _ t =
try
let t',l2 =
if from_prefix_of_ind then
(* We check for fully applied subterms of the form "u u1 .. un" *)
(* of inductive type knowing only a prefix "u u1 .. ui" *)
let t,l = decompose_app t in
let l1,l2 =
try List.chop n l with Failure _ -> raise (NotUnifiable None) in
if not (List.for_all closed0 l2) then raise (NotUnifiable None)
else
applist (t,l1), l2
else t, [] in
let sigma = w_typed_unify env sigma Reduction.CONV flags c t' in
let ty = Retyping.get_type_of env sigma t in
if not (is_correct_type ty) then raise (NotUnifiable None);
Some(sigma, t, l2)
with
| PretypeError (_,_,CannotUnify (c1,c2,Some e)) ->
raise (NotUnifiable (Some (c1,c2,e)))
(** MS: This is pretty bad, it catches Not_found for example *)
| e when Errors.noncritical e -> raise (NotUnifiable None) in
let merge_fun c1 c2 =
match c1, c2 with
| Some (evd,c1,_) as x, Some (_,c2,_) ->
if is_conv env sigma c1 c2 then x else raise (NotUnifiable None)
| Some _, None -> c1
| None, Some _ -> c2
| None, None -> None in
{ match_fun = matching_fun; merge_fun = merge_fun;
testing_state = None; last_found = None },
(fun test -> match test.testing_state with
| None -> None
| Some (sigma,_,l) ->
let c = applist (nf_evar sigma (local_strong whd_meta sigma c),l) in
let univs, subst = nf_univ_variables sigma in
Some (sigma,subst_univs_constr subst c))
let make_eq_test env evd c =
let out cstr =
match cstr.last_found with None -> None | _ -> Some (cstr.testing_state, c)
in
(make_eq_univs_test env evd c, out)
let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl =
let id =
let t = match ty with Some t -> t | None -> get_type_of env sigma c in
let x = id_of_name_using_hdchar (Global.env()) t name in
let ids = ids_of_named_context (named_context env) in
if name == Anonymous then next_ident_away_in_goal x ids else
if mem_named_context x (named_context env) then
error ("The variable "^(Id.to_string x)^" is already declared.")
else
x
in
let likefirst = clause_with_generic_occurrences occs in
let mkvarid () = mkVar id in
let compute_dependency _ (hyp,_,_ as d) (sign,depdecls) =
match occurrences_of_hyp hyp occs with
| NoOccurrences, InHyp ->
if indirectly_dependent c d depdecls then
(* Told explicitly not to abstract over [d], but it is dependent *)
let id' = indirect_dependency d depdecls in
errorlabstrm "" (str "Cannot abstract over " ++ Nameops.pr_id id'
++ str " without also abstracting or erasing " ++ Nameops.pr_id hyp
++ str ".")
else
(push_named_context_val d sign,depdecls)
| AllOccurrences, InHyp as occ ->
let occ = if likefirst then LikeFirst else AtOccs occ in
let newdecl = replace_term_occ_decl_modulo occ test mkvarid d in
if Context.eq_named_declaration d newdecl
&& not (indirectly_dependent c d depdecls)
then
if check_occs && not (in_every_hyp occs)
then raise (PretypeError (env,sigma,NoOccurrenceFound (c,Some hyp)))
else (push_named_context_val d sign, depdecls)
else
(push_named_context_val newdecl sign, newdecl :: depdecls)
| occ ->
(* There are specific occurrences, hence not like first *)
let newdecl = replace_term_occ_decl_modulo (AtOccs occ) test mkvarid d in
(push_named_context_val newdecl sign, newdecl :: depdecls) in
try
let sign,depdecls =
fold_named_context compute_dependency env
~init:(empty_named_context_val,[]) in
let ccl = match occurrences_of_goal occs with
| NoOccurrences -> concl
| occ ->
let occ = if likefirst then LikeFirst else AtOccs occ in
replace_term_occ_modulo occ test mkvarid concl
in
let lastlhyp =
if List.is_empty depdecls then None else Some (pi1(List.last depdecls)) in
(id,sign,depdecls,lastlhyp,ccl,out test)
with
SubtermUnificationError e ->
raise (PretypeError (env,sigma,CannotUnifyOccurrences e))
(** [make_abstraction] is the main entry point to abstract over a term
or pattern at some occurrences; it returns:
- the id used for the abstraction
- the type of the abstraction
- the declarations from the context which depend on the term or pattern
- the most recent hyp before which there is no dependency in the term of pattern
- the abstracted conclusion
- an evar universe context effect to apply on the goal
- the term or pattern to abstract fully instantiated
*)
type prefix_of_inductive_support_flag = bool
type abstraction_request =
| AbstractPattern of prefix_of_inductive_support_flag * (types -> bool) * Name.t * pending_constr * clause * bool
| AbstractExact of Name.t * constr * types option * clause * bool
type abstraction_result =
Names.Id.t * named_context_val *
Context.named_declaration list * Names.Id.t option *
types * (Evd.evar_map * constr) option
let make_abstraction env evd ccl abs =
match abs with
| AbstractPattern (from_prefix,check,name,c,occs,check_occs) ->
make_abstraction_core name
(make_pattern_test from_prefix check env evd c)
env evd (snd c) None occs check_occs ccl
| AbstractExact (name,c,ty,occs,check_occs) ->
make_abstraction_core name
(make_eq_test env evd c)
env evd c ty occs check_occs ccl
let keyed_unify env evd kop =
if not !keyed_unification then fun cl -> true
else
match kop with
| None -> fun _ -> true
| Some kop ->
fun cl ->
let kc = Keys.constr_key cl in
match kc with
| None -> false
| Some kc -> Keys.equiv_keys kop kc
(* Tries to find an instance of term [cl] in term [op].
Unifies [cl] to every subterm of [op] until it finds a match.
Fails if no match is found *)
let w_unify_to_subterm env evd ?(flags=default_unify_flags ()) (op,cl) =
let bestexn = ref None in
let kop = Keys.constr_key op in
let rec matchrec cl =
let cl = strip_outer_cast cl in
(try
if closed0 cl && not (isEvar cl) && keyed_unify env evd kop cl then
(try w_typed_unify env evd CONV flags op cl,cl
with ex when Pretype_errors.unsatisfiable_exception ex ->
bestexn := Some ex; error "Unsat")
else error "Bound 1"
with ex when precatchable_exception ex ->
(match kind_of_term cl with
| App (f,args) ->
let n = Array.length args in
assert (n>0);
let c1 = mkApp (f,Array.sub args 0 (n-1)) in
let c2 = args.(n-1) in
(try
matchrec c1
with ex when precatchable_exception ex ->
matchrec c2)
| Case(_,_,c,lf) -> (* does not search in the predicate *)
(try
matchrec c
with ex when precatchable_exception ex ->
iter_fail matchrec lf)
| LetIn(_,c1,_,c2) ->
(try
matchrec c1
with ex when precatchable_exception ex ->
matchrec c2)
| Proj (p,c) -> matchrec c
| Fix(_,(_,types,terms)) ->
(try
iter_fail matchrec types
with ex when precatchable_exception ex ->
iter_fail matchrec terms)
| CoFix(_,(_,types,terms)) ->
(try
iter_fail matchrec types
with ex when precatchable_exception ex ->
iter_fail matchrec terms)
| Prod (_,t,c) ->
(try
matchrec t
with ex when precatchable_exception ex ->
matchrec c)
| Lambda (_,t,c) ->
(try
matchrec t
with ex when precatchable_exception ex ->
matchrec c)
| _ -> error "Match_subterm"))
in
try matchrec cl
with ex when precatchable_exception ex ->
match !bestexn with
| None -> raise (PretypeError (env,evd,NoOccurrenceFound (op, None)))
| Some e -> raise e
(* Tries to find all instances of term [cl] in term [op].
Unifies [cl] to every subterm of [op] and return all the matches.
Fails if no match is found *)
let w_unify_to_subterm_all env evd ?(flags=default_unify_flags ()) (op,cl) =
let return a b =
let (evd,c as a) = a () in
if List.exists (fun (evd',c') -> Term.eq_constr c c') b then b else a :: b
in
let fail str _ = error str in
let bind f g a =
let a1 = try f a
with ex
when precatchable_exception ex -> a
in try g a1
with ex
when precatchable_exception ex -> a1
in
let bind_iter f a =
let n = Array.length a in
let rec ffail i =
if Int.equal i n then fun a -> a
else bind (f a.(i)) (ffail (i+1))
in ffail 0
in
let rec matchrec cl =
let cl = strip_outer_cast cl in
(bind
(if closed0 cl
then return (fun () -> w_typed_unify env evd CONV flags op cl,cl)
else fail "Bound 1")
(match kind_of_term cl with
| App (f,args) ->
let n = Array.length args in
assert (n>0);
let c1 = mkApp (f,Array.sub args 0 (n-1)) in
let c2 = args.(n-1) in
bind (matchrec c1) (matchrec c2)
| Case(_,_,c,lf) -> (* does not search in the predicate *)
bind (matchrec c) (bind_iter matchrec lf)
| Proj (p,c) -> matchrec c
| LetIn(_,c1,_,c2) ->
bind (matchrec c1) (matchrec c2)
| Fix(_,(_,types,terms)) ->
bind (bind_iter matchrec types) (bind_iter matchrec terms)
| CoFix(_,(_,types,terms)) ->
bind (bind_iter matchrec types) (bind_iter matchrec terms)
| Prod (_,t,c) ->
bind (matchrec t) (matchrec c)
| Lambda (_,t,c) ->
bind (matchrec t) (matchrec c)
| _ -> fail "Match_subterm"))
in
let res = matchrec cl [] in
match res with
| [] ->
raise (PretypeError (env,evd,NoOccurrenceFound (op, None)))
| _ -> res
let w_unify_to_subterm_list env evd flags hdmeta oplist t =
List.fold_right
(fun op (evd,l) ->
let op = whd_meta evd op in
if isMeta op then
if flags.allow_K_in_toplevel_higher_order_unification then (evd,op::l)
else error_abstraction_over_meta env evd hdmeta (destMeta op)
else
let allow_K = flags.allow_K_in_toplevel_higher_order_unification in
let flags =
if occur_meta_or_existential op || !keyed_unification then
flags
else
(* up to Nov 2014, unification was bypassed on evar/meta-free terms;
now it is called in a minimalistic way, at least to possibly
unify pre-existing non frozen evars of the goal or of the
pattern *)
set_no_delta_flags flags in
let (evd',cl) =
try
(* This is up to delta for subterms w/o metas ... *)
w_unify_to_subterm env evd ~flags (strip_outer_cast op,t)
with PretypeError (env,_,NoOccurrenceFound _) when allow_K -> (evd,op)
in
if not allow_K &&
(* ensure we found a different instance *)
List.exists (fun op -> Term.eq_constr op cl) l
then error_non_linear_unification env evd hdmeta cl
else (evd',cl::l))
oplist
(evd,[])
let secondOrderAbstraction env evd flags typ (p, oplist) =
(* Remove delta when looking for a subterm *)
let flags = { flags with core_unify_flags = flags.subterm_unify_flags } in
let (evd',cllist) = w_unify_to_subterm_list env evd flags p oplist typ in
let typp = Typing.meta_type evd' p in
let evd',(pred,predtyp) = abstract_list_all env evd' typp typ cllist in
let evd', b = infer_conv ~pb:CUMUL env evd' predtyp typp in
if not b then
error_wrong_abstraction_type env evd'
(Evd.meta_name evd p) pred typp predtyp;
w_merge env false flags.merge_unify_flags
(evd',[p,pred,(Conv,TypeProcessed)],[])
(* let evd',metas,evars = *)
(* try unify_0 env evd' CUMUL flags predtyp typp *)
(* with NotConvertible -> *)
(* error_wrong_abstraction_type env evd *)
(* (Evd.meta_name evd p) pred typp predtyp *)
(* in *)
(* w_merge env false flags (evd',(p,pred,(Conv,TypeProcessed))::metas,evars) *)
let secondOrderDependentAbstraction env evd flags typ (p, oplist) =
let typp = Typing.meta_type evd p in
let evd, pred = abstract_list_all_with_dependencies env evd typp typ oplist in
w_merge env false flags.merge_unify_flags
(evd,[p,pred,(Conv,TypeProcessed)],[])
let secondOrderAbstractionAlgo dep =
if dep then secondOrderDependentAbstraction else secondOrderAbstraction
let w_unify2 env evd flags dep cv_pb ty1 ty2 =
let c1, oplist1 = whd_nored_stack evd ty1 in
let c2, oplist2 = whd_nored_stack evd ty2 in
match kind_of_term c1, kind_of_term c2 with
| Meta p1, _ ->
(* Find the predicate *)
secondOrderAbstractionAlgo dep env evd flags ty2 (p1,oplist1)
| _, Meta p2 ->
(* Find the predicate *)
secondOrderAbstractionAlgo dep env evd flags ty1 (p2, oplist2)
| _ -> error "w_unify2"
(* The unique unification algorithm works like this: If the pattern is
flexible, and the goal has a lambda-abstraction at the head, then
we do a first-order unification.
If the pattern is not flexible, then we do a first-order
unification, too.
If the pattern is flexible, and the goal doesn't have a
lambda-abstraction head, then we second-order unification. *)
(* We decide here if first-order or second-order unif is used for Apply *)
(* We apply a term of type (ai:Ai)C and try to solve a goal C' *)
(* The type C is in clenv.templtyp.rebus with a lot of Meta to solve *)
(* 3-4-99 [HH] New fo/so choice heuristic :
In case we have to unify (Meta(1) args) with ([x:A]t args')
we first try second-order unification and if it fails first-order.
Before, second-order was used if the type of Meta(1) and [x:A]t was
convertible and first-order otherwise. But if failed if e.g. the type of
Meta(1) had meta-variables in it. *)
let w_unify env evd cv_pb ?(flags=default_unify_flags ()) ty1 ty2 =
let hd1,l1 = decompose_appvect (whd_nored evd ty1) in
let hd2,l2 = decompose_appvect (whd_nored evd ty2) in
let is_empty1 = Array.is_empty l1 in
let is_empty2 = Array.is_empty l2 in
match kind_of_term hd1, not is_empty1, kind_of_term hd2, not is_empty2 with
(* Pattern case *)
| (Meta _, true, Lambda _, _ | Lambda _, _, Meta _, true)
when Int.equal (Array.length l1) (Array.length l2) ->
(try
w_typed_unify_array env evd flags hd1 l1 hd2 l2
with ex when precatchable_exception ex ->
try
w_unify2 env evd flags false cv_pb ty1 ty2
with PretypeError (env,_,NoOccurrenceFound _) as e -> raise e)
(* Second order case *)
| (Meta _, true, _, _ | _, _, Meta _, true) ->
(try
w_unify2 env evd flags false cv_pb ty1 ty2
with PretypeError (env,_,NoOccurrenceFound _) as e -> raise e
| ex when precatchable_exception ex ->
try
w_typed_unify_array env evd flags hd1 l1 hd2 l2
with ex' when precatchable_exception ex' ->
(* Last chance, use pattern-matching with typed
dependencies (done late for compatibility) *)
try
w_unify2 env evd flags true cv_pb ty1 ty2
with ex' when precatchable_exception ex' ->
raise ex)
(* General case: try first order *)
| _ -> w_typed_unify env evd cv_pb flags ty1 ty2
(* Profiling *)
let w_unify env evd cv_pb flags ty1 ty2 =
w_unify env evd cv_pb ~flags:flags ty1 ty2
let w_unify =
if Flags.profile then
let wunifkey = Profile.declare_profile "w_unify" in
Profile.profile6 wunifkey w_unify
else w_unify
let w_unify env evd cv_pb ?(flags=default_unify_flags ()) ty1 ty2 =
w_unify env evd cv_pb flags ty1 ty2
|