/usr/lib/ocaml/compiler-libs/typing/parmatch.ml is in ocaml-compiler-libs 3.12.1-2ubuntu2.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
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 | (***********************************************************************)
(* *)
(* Objective Caml *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 1996 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed *)
(* under the terms of the Q Public License version 1.0. *)
(* *)
(***********************************************************************)
(* $Id: parmatch.ml 9547 2010-01-22 12:48:24Z doligez $ *)
(* Detection of partial matches and unused match cases. *)
open Misc
open Asttypes
open Types
open Typedtree
(*************************************)
(* Utilities for building patterns *)
(*************************************)
let make_pat desc ty tenv =
{pat_desc = desc; pat_loc = Location.none;
pat_type = ty ; pat_env = tenv }
let omega = make_pat Tpat_any Ctype.none Env.empty
let extra_pat =
make_pat (Tpat_var (Ident.create "+")) Ctype.none Env.empty
let rec omegas i =
if i <= 0 then [] else omega :: omegas (i-1)
let omega_list l = List.map (fun _ -> omega) l
let zero = make_pat (Tpat_constant (Const_int 0)) Ctype.none Env.empty
(***********************)
(* Compatibility check *)
(***********************)
(* p and q compatible means, there exists V that matches both *)
let is_absent tag row = Btype.row_field tag !row = Rabsent
let is_absent_pat p = match p.pat_desc with
| Tpat_variant (tag, _, row) -> is_absent tag row
| _ -> false
let sort_fields args =
Sort.list
(fun (lbl1,_) (lbl2,_) -> lbl1.lbl_pos <= lbl2.lbl_pos)
args
let records_args l1 l2 =
let l1 = sort_fields l1
and l2 = sort_fields l2 in
let rec combine r1 r2 l1 l2 = match l1,l2 with
| [],[] -> r1,r2
| [],(_,p2)::rem2 -> combine (omega::r1) (p2::r2) [] rem2
| (_,p1)::rem1,[] -> combine (p1::r1) (omega::r2) rem1 []
| (lbl1,p1)::rem1, (lbl2,p2)::rem2 ->
if lbl1.lbl_pos < lbl2.lbl_pos then
combine (p1::r1) (omega::r2) rem1 l2
else if lbl1.lbl_pos > lbl2.lbl_pos then
combine (omega::r1) (p2::r2) l1 rem2
else (* same label on both sides *)
combine (p1::r1) (p2::r2) rem1 rem2 in
combine [] [] l1 l2
let rec compat p q =
match p.pat_desc,q.pat_desc with
| Tpat_alias (p,_),_ -> compat p q
| _,Tpat_alias (q,_) -> compat p q
| (Tpat_any|Tpat_var _),_ -> true
| _,(Tpat_any|Tpat_var _) -> true
| Tpat_or (p1,p2,_),_ -> compat p1 q || compat p2 q
| _,Tpat_or (q1,q2,_) -> compat p q1 || compat p q2
| Tpat_constant c1, Tpat_constant c2 -> c1=c2
| Tpat_tuple ps, Tpat_tuple qs -> compats ps qs
| Tpat_lazy p, Tpat_lazy q -> compat p q
| Tpat_construct (c1,ps1), Tpat_construct (c2,ps2) ->
c1.cstr_tag = c2.cstr_tag && compats ps1 ps2
| Tpat_variant(l1,Some p1, r1), Tpat_variant(l2,Some p2,_) ->
l1=l2 && compat p1 p2
| Tpat_variant (l1,None,r1), Tpat_variant(l2,None,_) ->
l1 = l2
| Tpat_variant (_, None, _), Tpat_variant (_,Some _, _) -> false
| Tpat_variant (_, Some _, _), Tpat_variant (_, None, _) -> false
| Tpat_record l1,Tpat_record l2 ->
let ps,qs = records_args l1 l2 in
compats ps qs
| Tpat_array ps, Tpat_array qs ->
List.length ps = List.length qs &&
compats ps qs
| _,_ ->
assert false
and compats ps qs = match ps,qs with
| [], [] -> true
| p::ps, q::qs -> compat p q && compats ps qs
| _,_ -> assert false
(****************************************)
(* Utilities for retrieving constructor *)
(* and record label names *)
(****************************************)
exception Empty (* Empty pattern *)
(* May need a clean copy, cf. PR#4745 *)
let clean_copy ty =
if ty.level = Btype.generic_level then ty
else Subst.type_expr Subst.identity ty
let get_type_path ty tenv =
let ty = Ctype.repr (Ctype.expand_head tenv (clean_copy ty)) in
match ty.desc with
| Tconstr (path,_,_) -> path
| _ -> fatal_error "Parmatch.get_type_path"
let rec get_type_descr ty tenv =
match (Ctype.repr ty).desc with
| Tconstr (path,_,_) -> Env.find_type path tenv
| _ -> fatal_error "Parmatch.get_type_descr"
let rec get_constr tag ty tenv =
match get_type_descr ty tenv with
| {type_kind=Type_variant constr_list} ->
Datarepr.find_constr_by_tag tag constr_list
| {type_manifest = Some _} ->
get_constr tag (Ctype.expand_head_once tenv (clean_copy ty)) tenv
| _ -> fatal_error "Parmatch.get_constr"
let find_label lbl lbls =
try
let name,_,_ = List.nth lbls lbl.lbl_pos in
name
with Failure "nth" -> "*Unkown label*"
let rec get_record_labels ty tenv =
match get_type_descr ty tenv with
| {type_kind = Type_record(lbls, rep)} -> lbls
| {type_manifest = Some _} ->
get_record_labels (Ctype.expand_head_once tenv (clean_copy ty)) tenv
| _ -> fatal_error "Parmatch.get_record_labels"
(*************************************)
(* Values as patterns pretty printer *)
(*************************************)
open Format
;;
let get_constr_name tag ty tenv = match tag with
| Cstr_exception path -> Path.name path
| _ ->
try
let name,_ = get_constr tag ty tenv in name
with
| Datarepr.Constr_not_found -> "*Unknown constructor*"
let is_cons tag v = match get_constr_name tag v.pat_type v.pat_env with
| "::" -> true
| _ -> false
let rec pretty_val ppf v = match v.pat_desc with
| Tpat_any -> fprintf ppf "_"
| Tpat_var x -> Ident.print ppf x
| Tpat_constant (Const_int i) -> fprintf ppf "%d" i
| Tpat_constant (Const_char c) -> fprintf ppf "%C" c
| Tpat_constant (Const_string s) -> fprintf ppf "%S" s
| Tpat_constant (Const_float f) -> fprintf ppf "%s" f
| Tpat_constant (Const_int32 i) -> fprintf ppf "%ldl" i
| Tpat_constant (Const_int64 i) -> fprintf ppf "%LdL" i
| Tpat_constant (Const_nativeint i) -> fprintf ppf "%ndn" i
| Tpat_tuple vs ->
fprintf ppf "@[(%a)@]" (pretty_vals ",") vs
| Tpat_construct ({cstr_tag=tag},[]) ->
let name = get_constr_name tag v.pat_type v.pat_env in
fprintf ppf "%s" name
| Tpat_construct ({cstr_tag=tag},[w]) ->
let name = get_constr_name tag v.pat_type v.pat_env in
fprintf ppf "@[<2>%s@ %a@]" name pretty_arg w
| Tpat_construct ({cstr_tag=tag},vs) ->
let name = get_constr_name tag v.pat_type v.pat_env in
begin match (name, vs) with
("::", [v1;v2]) ->
fprintf ppf "@[%a::@,%a@]" pretty_car v1 pretty_cdr v2
| _ ->
fprintf ppf "@[<2>%s@ @[(%a)@]@]" name (pretty_vals ",") vs
end
| Tpat_variant (l, None, _) ->
fprintf ppf "`%s" l
| Tpat_variant (l, Some w, _) ->
fprintf ppf "@[<2>`%s@ %a@]" l pretty_arg w
| Tpat_record lvs ->
fprintf ppf "@[{%a}@]"
(pretty_lvals (get_record_labels v.pat_type v.pat_env))
(List.filter
(function
| (_,{pat_desc=Tpat_any}) -> false (* do not show lbl=_ *)
| _ -> true) lvs)
| Tpat_array vs ->
fprintf ppf "@[[| %a |]@]" (pretty_vals " ;") vs
| Tpat_lazy v ->
fprintf ppf "@[<2>lazy@ %a@]" pretty_arg v
| Tpat_alias (v,x) ->
fprintf ppf "@[(%a@ as %a)@]" pretty_val v Ident.print x
| Tpat_or (v,w,_) ->
fprintf ppf "@[(%a|@,%a)@]" pretty_or v pretty_or w
and pretty_car ppf v = match v.pat_desc with
| Tpat_construct ({cstr_tag=tag}, [_ ; _])
when is_cons tag v ->
fprintf ppf "(%a)" pretty_val v
| _ -> pretty_val ppf v
and pretty_cdr ppf v = match v.pat_desc with
| Tpat_construct ({cstr_tag=tag}, [v1 ; v2])
when is_cons tag v ->
fprintf ppf "%a::@,%a" pretty_car v1 pretty_cdr v2
| _ -> pretty_val ppf v
and pretty_arg ppf v = match v.pat_desc with
| Tpat_construct (_,_::_) -> fprintf ppf "(%a)" pretty_val v
| _ -> pretty_val ppf v
and pretty_or ppf v = match v.pat_desc with
| Tpat_or (v,w,_) ->
fprintf ppf "%a|@,%a" pretty_or v pretty_or w
| _ -> pretty_val ppf v
and pretty_vals sep ppf = function
| [] -> ()
| [v] -> pretty_val ppf v
| v::vs ->
fprintf ppf "%a%s@ %a" pretty_val v sep (pretty_vals sep) vs
and pretty_lvals lbls ppf = function
| [] -> ()
| [lbl,v] ->
let name = find_label lbl lbls in
fprintf ppf "%s=%a" name pretty_val v
| (lbl,v)::rest ->
let name = find_label lbl lbls in
fprintf ppf "%s=%a;@ %a" name pretty_val v (pretty_lvals lbls) rest
let top_pretty ppf v =
fprintf ppf "@[%a@]@?" pretty_val v
let prerr_pat v =
top_pretty str_formatter v ;
prerr_string (flush_str_formatter ())
(****************************)
(* Utilities for matching *)
(****************************)
(* Check top matching *)
let simple_match p1 p2 =
match p1.pat_desc, p2.pat_desc with
| Tpat_construct(c1, _), Tpat_construct(c2, _) ->
c1.cstr_tag = c2.cstr_tag
| Tpat_variant(l1, _, _), Tpat_variant(l2, _, _) ->
l1 = l2
| Tpat_constant(Const_float s1), Tpat_constant(Const_float s2) ->
float_of_string s1 = float_of_string s2
| Tpat_constant(c1), Tpat_constant(c2) -> c1 = c2
| Tpat_tuple _, Tpat_tuple _ -> true
| Tpat_lazy _, Tpat_lazy _ -> true
| Tpat_record _ , Tpat_record _ -> true
| Tpat_array p1s, Tpat_array p2s -> List.length p1s = List.length p2s
| _, (Tpat_any | Tpat_var(_)) -> true
| _, _ -> false
(* extract record fields as a whole *)
let record_arg p = match p.pat_desc with
| Tpat_any -> []
| Tpat_record args -> args
| _ -> fatal_error "Parmatch.as_record"
(* Raise Not_found when pos is not present in arg *)
let get_field pos arg =
let _,p = List.find (fun (lbl,_) -> pos = lbl.lbl_pos) arg in
p
let extract_fields omegas arg =
List.map
(fun (lbl,_) ->
try
get_field lbl.lbl_pos arg
with Not_found -> omega)
omegas
let sort_record p = match p.pat_desc with
| Tpat_record args ->
make_pat
(Tpat_record (sort_fields args))
p.pat_type p.pat_env
| _ -> p
let all_record_args lbls = match lbls with
| ({lbl_all=lbl_all},_)::_ ->
let t =
Array.map
(fun lbl -> lbl,omega) lbl_all in
List.iter
(fun ((lbl,_) as x) -> t.(lbl.lbl_pos) <- x)
lbls ;
Array.to_list t
| _ -> fatal_error "Parmatch.all_record_args"
(* Build argument list when p2 >= p1, where p1 is a simple pattern *)
let rec simple_match_args p1 p2 = match p2.pat_desc with
| Tpat_alias (p2,_) -> simple_match_args p1 p2
| Tpat_construct(cstr, args) -> args
| Tpat_variant(lab, Some arg, _) -> [arg]
| Tpat_tuple(args) -> args
| Tpat_record(args) -> extract_fields (record_arg p1) args
| Tpat_array(args) -> args
| Tpat_lazy arg -> [arg]
| (Tpat_any | Tpat_var(_)) ->
begin match p1.pat_desc with
Tpat_construct(_, args) -> omega_list args
| Tpat_variant(_, Some _, _) -> [omega]
| Tpat_tuple(args) -> omega_list args
| Tpat_record(args) -> omega_list args
| Tpat_array(args) -> omega_list args
| Tpat_lazy _ -> [omega]
| _ -> []
end
| _ -> []
(*
Normalize a pattern ->
all arguments are omega (simple pattern) and no more variables
*)
let rec normalize_pat q = match q.pat_desc with
| Tpat_any | Tpat_constant _ -> q
| Tpat_var _ -> make_pat Tpat_any q.pat_type q.pat_env
| Tpat_alias (p,_) -> normalize_pat p
| Tpat_tuple (args) ->
make_pat (Tpat_tuple (omega_list args)) q.pat_type q.pat_env
| Tpat_construct (c,args) ->
make_pat (Tpat_construct (c,omega_list args)) q.pat_type q.pat_env
| Tpat_variant (l, arg, row) ->
make_pat (Tpat_variant (l, may_map (fun _ -> omega) arg, row))
q.pat_type q.pat_env
| Tpat_array (args) ->
make_pat (Tpat_array (omega_list args)) q.pat_type q.pat_env
| Tpat_record (largs) ->
make_pat (Tpat_record (List.map (fun (lbl,_) -> lbl,omega) largs))
q.pat_type q.pat_env
| Tpat_lazy _ ->
make_pat (Tpat_lazy omega) q.pat_type q.pat_env
| Tpat_or _ -> fatal_error "Parmatch.normalize_pat"
(*
Build normalized (cf. supra) discriminating pattern,
in the non-data type case
*)
let discr_pat q pss =
let rec acc_pat acc pss = match pss with
({pat_desc = Tpat_alias (p,_)}::ps)::pss ->
acc_pat acc ((p::ps)::pss)
| ({pat_desc = Tpat_or (p1,p2,_)}::ps)::pss ->
acc_pat acc ((p1::ps)::(p2::ps)::pss)
| ({pat_desc = (Tpat_any | Tpat_var _)}::_)::pss ->
acc_pat acc pss
| (({pat_desc = Tpat_tuple _} as p)::_)::_ -> normalize_pat p
| (({pat_desc = Tpat_lazy _} as p)::_)::_ -> normalize_pat p
| (({pat_desc = Tpat_record largs} as p)::_)::pss ->
let new_omegas =
List.fold_left
(fun r (lbl,_) ->
try
let _ = get_field lbl.lbl_pos r in
r
with Not_found ->
(lbl,omega)::r)
(record_arg acc)
largs in
acc_pat
(make_pat (Tpat_record new_omegas) p.pat_type p.pat_env)
pss
| _ -> acc in
match normalize_pat q with
| {pat_desc= (Tpat_any | Tpat_record _)} as q ->
sort_record (acc_pat q pss)
| q -> q
(*
In case a matching value is found, set actual arguments
of the matching pattern.
*)
let rec read_args xs r = match xs,r with
| [],_ -> [],r
| _::xs, arg::rest ->
let args,rest = read_args xs rest in
arg::args,rest
| _,_ ->
fatal_error "Parmatch.read_args"
let do_set_args erase_mutable q r = match q with
| {pat_desc = Tpat_tuple omegas} ->
let args,rest = read_args omegas r in
make_pat (Tpat_tuple args) q.pat_type q.pat_env::rest
| {pat_desc = Tpat_record omegas} ->
let args,rest = read_args omegas r in
make_pat
(Tpat_record
(List.map2 (fun (lbl,_) arg ->
if
erase_mutable &&
(match lbl.lbl_mut with
| Mutable -> true | Immutable -> false)
then
lbl, omega
else
lbl,arg)
omegas args))
q.pat_type q.pat_env::
rest
| {pat_desc = Tpat_construct (c,omegas)} ->
let args,rest = read_args omegas r in
make_pat
(Tpat_construct (c,args)) q.pat_type q.pat_env::
rest
| {pat_desc = Tpat_variant (l, omega, row)} ->
let arg, rest =
match omega, r with
Some _, a::r -> Some a, r
| None, r -> None, r
| _ -> assert false
in
make_pat
(Tpat_variant (l, arg, row)) q.pat_type q.pat_env::
rest
| {pat_desc = Tpat_lazy omega} ->
begin match r with
arg::rest ->
make_pat (Tpat_lazy arg) q.pat_type q.pat_env::rest
| _ -> fatal_error "Parmatch.do_set_args (lazy)"
end
| {pat_desc = Tpat_array omegas} ->
let args,rest = read_args omegas r in
make_pat
(Tpat_array args) q.pat_type q.pat_env::
rest
| {pat_desc=Tpat_constant _|Tpat_any} ->
q::r (* case any is used in matching.ml *)
| _ -> fatal_error "Parmatch.set_args"
let set_args q r = do_set_args false q r
and set_args_erase_mutable q r = do_set_args true q r
(* filter pss acording to pattern q *)
let filter_one q pss =
let rec filter_rec = function
({pat_desc = Tpat_alias(p,_)}::ps)::pss ->
filter_rec ((p::ps)::pss)
| ({pat_desc = Tpat_or(p1,p2,_)}::ps)::pss ->
filter_rec ((p1::ps)::(p2::ps)::pss)
| (p::ps)::pss ->
if simple_match q p
then (simple_match_args q p @ ps) :: filter_rec pss
else filter_rec pss
| _ -> [] in
filter_rec pss
(*
Filter pss in the ``extra case''. This applies :
- According to an extra constructor (datatype case, non-complete signature).
- Acordinng to anything (all-variables case).
*)
let filter_extra pss =
let rec filter_rec = function
({pat_desc = Tpat_alias(p,_)}::ps)::pss ->
filter_rec ((p::ps)::pss)
| ({pat_desc = Tpat_or(p1,p2,_)}::ps)::pss ->
filter_rec ((p1::ps)::(p2::ps)::pss)
| ({pat_desc = (Tpat_any | Tpat_var(_))} :: qs) :: pss ->
qs :: filter_rec pss
| _::pss -> filter_rec pss
| [] -> [] in
filter_rec pss
(*
Pattern p0 is the discriminating pattern,
returns [(q0,pss0) ; ... ; (qn,pssn)]
where the qi's are simple patterns and the pssi's are
matched matrices.
NOTES
* (qi,[]) is impossible.
* In the case when matching is useless (all-variable case),
returns []
*)
let filter_all pat0 pss =
let rec insert q qs env =
match env with
[] ->
let q0 = normalize_pat q in
[q0, [simple_match_args q0 q @ qs]]
| ((q0,pss) as c)::env ->
if simple_match q0 q
then (q0, ((simple_match_args q0 q @ qs) :: pss)) :: env
else c :: insert q qs env in
let rec filter_rec env = function
({pat_desc = Tpat_alias(p,_)}::ps)::pss ->
filter_rec env ((p::ps)::pss)
| ({pat_desc = Tpat_or(p1,p2,_)}::ps)::pss ->
filter_rec env ((p1::ps)::(p2::ps)::pss)
| ({pat_desc = (Tpat_any | Tpat_var(_))}::_)::pss ->
filter_rec env pss
| (p::ps)::pss ->
filter_rec (insert p ps env) pss
| _ -> env
and filter_omega env = function
({pat_desc = Tpat_alias(p,_)}::ps)::pss ->
filter_omega env ((p::ps)::pss)
| ({pat_desc = Tpat_or(p1,p2,_)}::ps)::pss ->
filter_omega env ((p1::ps)::(p2::ps)::pss)
| ({pat_desc = (Tpat_any | Tpat_var(_))}::ps)::pss ->
filter_omega
(List.map (fun (q,qss) -> (q,(simple_match_args q omega @ ps) :: qss)) env)
pss
| _::pss -> filter_omega env pss
| [] -> env in
filter_omega
(filter_rec
(match pat0.pat_desc with
(Tpat_record(_) | Tpat_tuple(_) | Tpat_lazy(_)) -> [pat0,[]]
| _ -> [])
pss)
pss
(* Variant related functions *)
let rec set_last a = function
[] -> []
| [_] -> [a]
| x::l -> x :: set_last a l
(* mark constructor lines for failure when they are incomplete *)
let rec mark_partial = function
({pat_desc = Tpat_alias(p,_)}::ps)::pss ->
mark_partial ((p::ps)::pss)
| ({pat_desc = Tpat_or(p1,p2,_)}::ps)::pss ->
mark_partial ((p1::ps)::(p2::ps)::pss)
| ({pat_desc = (Tpat_any | Tpat_var(_))} :: _ as ps) :: pss ->
ps :: mark_partial pss
| ps::pss ->
(set_last zero ps) :: mark_partial pss
| [] -> []
let close_variant env row =
let row = Btype.row_repr row in
let nm =
List.fold_left
(fun nm (tag,f) ->
match Btype.row_field_repr f with
| Reither(_, _, false, e) ->
(* m=false means that this tag is not explicitly matched *)
Btype.set_row_field e Rabsent;
None
| Rabsent | Reither (_, _, true, _) | Rpresent _ -> nm)
row.row_name row.row_fields in
if not row.row_closed || nm != row.row_name then begin
(* this unification cannot fail *)
Ctype.unify env row.row_more
(Btype.newgenty
(Tvariant {row with row_fields = []; row_more = Btype.newgenvar();
row_closed = true; row_name = nm}))
end
let row_of_pat pat =
match Ctype.expand_head pat.pat_env pat.pat_type with
{desc = Tvariant row} -> Btype.row_repr row
| _ -> assert false
(*
Check whether the first column of env makes up a complete signature or
not.
*)
let full_match closing env = match env with
| ({pat_desc = Tpat_construct ({cstr_tag=Cstr_exception _},_)},_)::_ ->
false
| ({pat_desc = Tpat_construct(c,_)},_) :: _ ->
List.length env = c.cstr_consts + c.cstr_nonconsts
| ({pat_desc = Tpat_variant _} as p,_) :: _ ->
let fields =
List.map
(function ({pat_desc = Tpat_variant (tag, _, _)}, _) -> tag
| _ -> assert false)
env
in
let row = row_of_pat p in
if closing && not row.row_fixed then
(* closing=true, we are considering the variant as closed *)
List.for_all
(fun (tag,f) ->
match Btype.row_field_repr f with
Rabsent | Reither(_, _, false, _) -> true
| Reither (_, _, true, _)
(* m=true, do not discard matched tags, rather warn *)
| Rpresent _ -> List.mem tag fields)
row.row_fields
else
row.row_closed &&
List.for_all
(fun (tag,f) ->
Btype.row_field_repr f = Rabsent || List.mem tag fields)
row.row_fields
| ({pat_desc = Tpat_constant(Const_char _)},_) :: _ ->
List.length env = 256
| ({pat_desc = Tpat_constant(_)},_) :: _ -> false
| ({pat_desc = Tpat_tuple(_)},_) :: _ -> true
| ({pat_desc = Tpat_record(_)},_) :: _ -> true
| ({pat_desc = Tpat_array(_)},_) :: _ -> false
| ({pat_desc = Tpat_lazy(_)},_) :: _ -> true
| _ -> fatal_error "Parmatch.full_match"
let extendable_match env = match env with
| ({pat_desc = Tpat_construct({cstr_tag=(Cstr_constant _|Cstr_block _)},_)} as p,_) :: _ ->
let path = get_type_path p.pat_type p.pat_env in
not
(Path.same path Predef.path_bool ||
Path.same path Predef.path_list ||
Path.same path Predef.path_option)
| _ -> false
let should_extend ext env = match ext with
| None -> false
| Some ext -> match env with
| ({pat_desc =
Tpat_construct({cstr_tag=(Cstr_constant _|Cstr_block _)},_)} as p,_)
:: _ ->
let path = get_type_path p.pat_type p.pat_env in
Path.same path ext
| _ -> false
(* complement constructor tags *)
let complete_tags nconsts nconstrs tags =
let seen_const = Array.create nconsts false
and seen_constr = Array.create nconstrs false in
List.iter
(function
| Cstr_constant i -> seen_const.(i) <- true
| Cstr_block i -> seen_constr.(i) <- true
| _ -> assert false)
tags ;
let r = ref [] in
for i = 0 to nconsts-1 do
if not seen_const.(i) then
r := Cstr_constant i :: !r
done ;
for i = 0 to nconstrs-1 do
if not seen_constr.(i) then
r := Cstr_block i :: !r
done ;
!r
(* build a pattern from a constructor list *)
let pat_of_constr ex_pat cstr =
{ex_pat with pat_desc = Tpat_construct (cstr,omegas cstr.cstr_arity)}
let rec pat_of_constrs ex_pat = function
| [] -> raise Empty
| [cstr] -> pat_of_constr ex_pat cstr
| cstr::rem ->
{ex_pat with
pat_desc=
Tpat_or
(pat_of_constr ex_pat cstr,
pat_of_constrs ex_pat rem, None)}
(* Sends back a pattern that complements constructor tags all_tag *)
let complete_constrs p all_tags = match p.pat_desc with
| Tpat_construct (c,_) ->
begin try
let not_tags = complete_tags c.cstr_consts c.cstr_nonconsts all_tags in
List.map
(fun tag ->
let _,targs = get_constr tag p.pat_type p.pat_env in
{c with
cstr_tag = tag ;
cstr_args = targs ;
cstr_arity = List.length targs})
not_tags
with
| Datarepr.Constr_not_found ->
fatal_error "Parmatch.complete_constr: constr_not_found"
end
| _ -> fatal_error "Parmatch.complete_constr"
(* Auxiliary for build_other *)
let build_other_constant proj make first next p env =
let all = List.map (fun (p, _) -> proj p.pat_desc) env in
let rec try_const i =
if List.mem i all
then try_const (next i)
else make_pat (make i) p.pat_type p.pat_env
in try_const first
(*
Builds a pattern that is incompatible with all patterns in
in the first column of env
*)
let build_other ext env = match env with
| ({pat_desc = Tpat_construct ({cstr_tag=Cstr_exception _} as c,_)},_)
::_ ->
make_pat
(Tpat_construct
({c with
cstr_tag=(Cstr_exception
(Path.Pident (Ident.create "*exception*")))},
[]))
Ctype.none Env.empty
| ({pat_desc = Tpat_construct (_,_)} as p,_) :: _ ->
begin match ext with
| Some ext when Path.same ext (get_type_path p.pat_type p.pat_env) ->
extra_pat
| _ ->
let get_tag = function
| {pat_desc = Tpat_construct (c,_)} -> c.cstr_tag
| _ -> fatal_error "Parmatch.get_tag" in
let all_tags = List.map (fun (p,_) -> get_tag p) env in
pat_of_constrs p (complete_constrs p all_tags)
end
| ({pat_desc = Tpat_variant (_,_,r)} as p,_) :: _ ->
let tags =
List.map
(function ({pat_desc = Tpat_variant (tag, _, _)}, _) -> tag
| _ -> assert false)
env
in
let row = row_of_pat p in
let make_other_pat tag const =
let arg = if const then None else Some omega in
make_pat (Tpat_variant(tag, arg, r)) p.pat_type p.pat_env in
begin match
List.fold_left
(fun others (tag,f) ->
if List.mem tag tags then others else
match Btype.row_field_repr f with
Rabsent (* | Reither _ *) -> others
(* This one is called after erasing pattern info *)
| Reither (c, _, _, _) -> make_other_pat tag c :: others
| Rpresent arg -> make_other_pat tag (arg = None) :: others)
[] row.row_fields
with
[] ->
make_other_pat "AnyExtraTag" true
| pat::other_pats ->
List.fold_left
(fun p_res pat ->
make_pat (Tpat_or (pat, p_res, None)) p.pat_type p.pat_env)
pat other_pats
end
| ({pat_desc = Tpat_constant(Const_char _)} as p,_) :: _ ->
let all_chars =
List.map
(fun (p,_) -> match p.pat_desc with
| Tpat_constant (Const_char c) -> c
| _ -> assert false)
env in
let rec find_other i imax =
if i > imax then raise Not_found
else
let ci = Char.chr i in
if List.mem ci all_chars then
find_other (i+1) imax
else
make_pat (Tpat_constant (Const_char ci)) p.pat_type p.pat_env in
let rec try_chars = function
| [] -> omega
| (c1,c2) :: rest ->
try
find_other (Char.code c1) (Char.code c2)
with
| Not_found -> try_chars rest in
try_chars
[ 'a', 'z' ; 'A', 'Z' ; '0', '9' ;
' ', '~' ; Char.chr 0 , Char.chr 255]
| ({pat_desc=(Tpat_constant (Const_int _))} as p,_) :: _ ->
build_other_constant
(function Tpat_constant(Const_int i) -> i | _ -> assert false)
(function i -> Tpat_constant(Const_int i))
0 succ p env
| ({pat_desc=(Tpat_constant (Const_int32 _))} as p,_) :: _ ->
build_other_constant
(function Tpat_constant(Const_int32 i) -> i | _ -> assert false)
(function i -> Tpat_constant(Const_int32 i))
0l Int32.succ p env
| ({pat_desc=(Tpat_constant (Const_int64 _))} as p,_) :: _ ->
build_other_constant
(function Tpat_constant(Const_int64 i) -> i | _ -> assert false)
(function i -> Tpat_constant(Const_int64 i))
0L Int64.succ p env
| ({pat_desc=(Tpat_constant (Const_nativeint _))} as p,_) :: _ ->
build_other_constant
(function Tpat_constant(Const_nativeint i) -> i | _ -> assert false)
(function i -> Tpat_constant(Const_nativeint i))
0n Nativeint.succ p env
| ({pat_desc=(Tpat_constant (Const_string _))} as p,_) :: _ ->
build_other_constant
(function Tpat_constant(Const_string s) -> String.length s
| _ -> assert false)
(function i -> Tpat_constant(Const_string(String.make i '*')))
0 succ p env
| ({pat_desc=(Tpat_constant (Const_float _))} as p,_) :: _ ->
build_other_constant
(function Tpat_constant(Const_float f) -> float_of_string f
| _ -> assert false)
(function f -> Tpat_constant(Const_float (string_of_float f)))
0.0 (fun f -> f +. 1.0) p env
| ({pat_desc = Tpat_array args} as p,_)::_ ->
let all_lengths =
List.map
(fun (p,_) -> match p.pat_desc with
| Tpat_array args -> List.length args
| _ -> assert false)
env in
let rec try_arrays l =
if List.mem l all_lengths then try_arrays (l+1)
else
make_pat
(Tpat_array (omegas l))
p.pat_type p.pat_env in
try_arrays 0
| [] -> omega
| _ -> omega
(*
Core function :
Is the last row of pattern matrix pss + qs satisfiable ?
That is :
Does there exists at least one value vector, es such that :
1- for all ps in pss ps # es (ps and es are not compatible)
2- qs <= es (es matches qs)
*)
let rec has_instance p = match p.pat_desc with
| Tpat_variant (l,_,r) when is_absent l r -> false
| Tpat_any | Tpat_var _ | Tpat_constant _ | Tpat_variant (_,None,_) -> true
| Tpat_alias (p,_) | Tpat_variant (_,Some p,_) -> has_instance p
| Tpat_or (p1,p2,_) -> has_instance p1 || has_instance p2
| Tpat_construct (_,ps) | Tpat_tuple ps | Tpat_array ps -> has_instances ps
| Tpat_record lps -> has_instances (List.map snd lps)
| Tpat_lazy p -> has_instance p
and has_instances = function
| [] -> true
| q::rem -> has_instance q && has_instances rem
let rec satisfiable pss qs = match pss with
| [] -> has_instances qs
| _ ->
match qs with
| [] -> false
| {pat_desc = Tpat_or(q1,q2,_)}::qs ->
satisfiable pss (q1::qs) || satisfiable pss (q2::qs)
| {pat_desc = Tpat_alias(q,_)}::qs ->
satisfiable pss (q::qs)
| {pat_desc = (Tpat_any | Tpat_var(_))}::qs ->
let q0 = discr_pat omega pss in
begin match filter_all q0 pss with
(* first column of pss is made of variables only *)
| [] -> satisfiable (filter_extra pss) qs
| constrs ->
if full_match false constrs then
List.exists
(fun (p,pss) ->
not (is_absent_pat p) &&
satisfiable pss (simple_match_args p omega @ qs))
constrs
else
satisfiable (filter_extra pss) qs
end
| {pat_desc=Tpat_variant (l,_,r)}::_ when is_absent l r -> false
| q::qs ->
let q0 = discr_pat q pss in
satisfiable (filter_one q0 pss) (simple_match_args q0 q @ qs)
(*
Now another satisfiable function that additionally
supplies an example of a matching value.
This function should be called for exhaustiveness check only.
*)
type 'a result =
| Rnone (* No matching value *)
| Rsome of 'a (* This matching value *)
let rec try_many f = function
| [] -> Rnone
| x::rest ->
begin match f x with
| Rnone -> try_many f rest
| r -> r
end
let rec exhaust ext pss n = match pss with
| [] -> Rsome (omegas n)
| []::_ -> Rnone
| pss ->
let q0 = discr_pat omega pss in
begin match filter_all q0 pss with
(* first column of pss is made of variables only *)
| [] ->
begin match exhaust ext (filter_extra pss) (n-1) with
| Rsome r -> Rsome (q0::r)
| r -> r
end
| constrs ->
let try_non_omega (p,pss) =
if is_absent_pat p then
Rnone
else
match
exhaust
ext pss (List.length (simple_match_args p omega) + n - 1)
with
| Rsome r -> Rsome (set_args p r)
| r -> r in
if
full_match false constrs && not (should_extend ext constrs)
then
try_many try_non_omega constrs
else
(*
D = filter_extra pss is the default matrix
as it is included in pss, one can avoid
recursive calls on specialized matrices,
Essentially :
* D exhaustive => pss exhaustive
* D non-exhaustive => we have a non-filtered value
*)
let r = exhaust ext (filter_extra pss) (n-1) in
match r with
| Rnone -> Rnone
| Rsome r ->
try
Rsome (build_other ext constrs::r)
with
(* cannot occur, since constructors don't make a full signature *)
| Empty -> fatal_error "Parmatch.exhaust"
end
(*
Another exhaustiveness check, enforcing variant typing.
Note that it does not check exact exhaustiveness, but whether a
matching could be made exhaustive by closing all variant types.
When this is true of all other columns, the current column is left
open (even if it means that the whole matching is not exhaustive as
a result).
When this is false for the matrix minus the current column, and the
current column is composed of variant tags, we close the variant
(even if it doesn't help in making the matching exhaustive).
*)
let rec pressure_variants tdefs = function
| [] -> false
| []::_ -> true
| pss ->
let q0 = discr_pat omega pss in
begin match filter_all q0 pss with
[] -> pressure_variants tdefs (filter_extra pss)
| constrs ->
let rec try_non_omega = function
(p,pss) :: rem ->
let ok = pressure_variants tdefs pss in
try_non_omega rem && ok
| [] -> true
in
if full_match (tdefs=None) constrs then
try_non_omega constrs
else if tdefs = None then
pressure_variants None (filter_extra pss)
else
let full = full_match true constrs in
let ok =
if full then try_non_omega constrs
else try_non_omega (filter_all q0 (mark_partial pss))
in
begin match constrs, tdefs with
({pat_desc=Tpat_variant _} as p,_):: _, Some env ->
let row = row_of_pat p in
if row.row_fixed
|| pressure_variants None (filter_extra pss) then ()
else close_variant env row
| _ -> ()
end;
ok
end
(* Yet another satisfiable fonction *)
(*
This time every_satisfiable pss qs checks the
utility of every expansion of qs.
Expansion means expansion of or-patterns inside qs
*)
type answer =
| Used (* Useful pattern *)
| Unused (* Useless pattern *)
| Upartial of Typedtree.pattern list (* Neither, with list of useless pattern *)
let pretty_pat p =
top_pretty Format.str_formatter p ;
prerr_string (Format.flush_str_formatter ())
type matrix = pattern list list
let pretty_line ps =
List.iter
(fun p ->
top_pretty Format.str_formatter p ;
prerr_string " <" ;
prerr_string (Format.flush_str_formatter ()) ;
prerr_string ">")
ps
let pretty_matrix pss =
prerr_endline "begin matrix" ;
List.iter
(fun ps ->
pretty_line ps ;
prerr_endline "")
pss ;
prerr_endline "end matrix"
(* this row type enable column processing inside the matrix
- left -> elements not to be processed,
- right -> elements to be processed
*)
type 'a row = {no_ors : 'a list ; ors : 'a list ; active : 'a list}
let pretty_row {ors=ors ; no_ors=no_ors; active=active} =
pretty_line ors ; prerr_string " *" ;
pretty_line no_ors ; prerr_string " *" ;
pretty_line active
let pretty_rows rs =
prerr_endline "begin matrix" ;
List.iter
(fun r ->
pretty_row r ;
prerr_endline "")
rs ;
prerr_endline "end matrix"
(* Initial build *)
let make_row ps = {ors=[] ; no_ors=[]; active=ps}
let make_rows pss = List.map make_row pss
(* Useful to detect and expand or pats inside as pats *)
let rec unalias p = match p.pat_desc with
| Tpat_alias (p,_) -> unalias p
| _ -> p
let is_var p = match (unalias p).pat_desc with
| Tpat_any|Tpat_var _ -> true
| _ -> false
let is_var_column rs =
List.for_all
(fun r -> match r.active with
| p::_ -> is_var p
| [] -> assert false)
rs
(* Standard or-args for left-to-right matching *)
let rec or_args p = match p.pat_desc with
| Tpat_or (p1,p2,_) -> p1,p2
| Tpat_alias (p,_) -> or_args p
| _ -> assert false
(* Just remove current column *)
let remove r = match r.active with
| _::rem -> {r with active=rem}
| [] -> assert false
let remove_column rs = List.map remove rs
(* Current column has been processed *)
let push_no_or r = match r.active with
| p::rem -> { r with no_ors = p::r.no_ors ; active=rem}
| [] -> assert false
let push_or r = match r.active with
| p::rem -> { r with ors = p::r.ors ; active=rem}
| [] -> assert false
let push_or_column rs = List.map push_or rs
and push_no_or_column rs = List.map push_no_or rs
(* Those are adaptations of the previous homonymous functions that
work on the current column, instead of the first column
*)
let discr_pat q rs =
discr_pat q (List.map (fun r -> r.active) rs)
let filter_one q rs =
let rec filter_rec rs = match rs with
| [] -> []
| r::rem ->
match r.active with
| [] -> assert false
| {pat_desc = Tpat_alias(p,_)}::ps ->
filter_rec ({r with active = p::ps}::rem)
| {pat_desc = Tpat_or(p1,p2,_)}::ps ->
filter_rec
({r with active = p1::ps}::
{r with active = p2::ps}::
rem)
| p::ps ->
if simple_match q p then
{r with active=simple_match_args q p @ ps} :: filter_rec rem
else
filter_rec rem in
filter_rec rs
(* Back to normal matrices *)
let make_vector r = r.no_ors
let make_matrix rs = List.map make_vector rs
(* Standard union on answers *)
let union_res r1 r2 = match r1, r2 with
| (Unused,_)
| (_, Unused) -> Unused
| Used,_ -> r2
| _, Used -> r1
| Upartial u1, Upartial u2 -> Upartial (u1@u2)
(* propose or pats for expansion *)
let extract_elements qs =
let rec do_rec seen = function
| [] -> []
| q::rem ->
{no_ors= List.rev_append seen rem @ qs.no_ors ;
ors=[] ;
active = [q]}::
do_rec (q::seen) rem in
do_rec [] qs.ors
(* idem for matrices *)
let transpose rs = match rs with
| [] -> assert false
| r::rem ->
let i = List.map (fun x -> [x]) r in
List.fold_left
(List.map2 (fun r x -> x::r))
i rem
let extract_columns pss qs = match pss with
| [] -> List.map (fun _ -> []) qs.ors
| _ ->
let rows = List.map extract_elements pss in
transpose rows
(* Core function
The idea is to first look for or patterns (recursive case), then
check or-patterns argument usefulness (terminal case)
*)
let rec every_satisfiables pss qs = match qs.active with
| [] ->
(* qs is now partitionned, check usefulness *)
begin match qs.ors with
| [] -> (* no or-patterns *)
if satisfiable (make_matrix pss) (make_vector qs) then
Used
else
Unused
| _ -> (* n or-patterns -> 2n expansions *)
List.fold_right2
(fun pss qs r -> match r with
| Unused -> Unused
| _ ->
match qs.active with
| [q] ->
let q1,q2 = or_args q in
let r_loc = every_both pss qs q1 q2 in
union_res r r_loc
| _ -> assert false)
(extract_columns pss qs) (extract_elements qs)
Used
end
| q::rem ->
let uq = unalias q in
begin match uq.pat_desc with
| Tpat_any | Tpat_var _ ->
if is_var_column pss then
(* forget about ``all-variable'' columns now *)
every_satisfiables (remove_column pss) (remove qs)
else
(* otherwise this is direct food for satisfiable *)
every_satisfiables (push_no_or_column pss) (push_no_or qs)
| Tpat_or (q1,q2,_) ->
if
q1.pat_loc.Location.loc_ghost &&
q2.pat_loc.Location.loc_ghost
then
(* syntactically generated or-pats should not be expanded *)
every_satisfiables (push_no_or_column pss) (push_no_or qs)
else
(* this is a real or-pattern *)
every_satisfiables (push_or_column pss) (push_or qs)
| Tpat_variant (l,_,r) when is_absent l r -> (* Ah Jacques... *)
Unused
| _ ->
(* standard case, filter matrix *)
let q0 = discr_pat q pss in
every_satisfiables
(filter_one q0 pss)
{qs with active=simple_match_args q0 q @ rem}
end
(*
This function ``every_both'' performs the usefulness check
of or-pat q1|q2.
The trick is to call every_satisfied twice with
current active columns restricted to q1 and q2,
That way,
- others orpats in qs.ors will not get expanded.
- all matching work performed on qs.no_ors is not performed again.
*)
and every_both pss qs q1 q2 =
let qs1 = {qs with active=[q1]}
and qs2 = {qs with active=[q2]} in
let r1 = every_satisfiables pss qs1
and r2 = every_satisfiables (if compat q1 q2 then qs1::pss else pss) qs2 in
match r1 with
| Unused ->
begin match r2 with
| Unused -> Unused
| Used -> Upartial [q1]
| Upartial u2 -> Upartial (q1::u2)
end
| Used ->
begin match r2 with
| Unused -> Upartial [q2]
| _ -> r2
end
| Upartial u1 ->
begin match r2 with
| Unused -> Upartial (u1@[q2])
| Used -> r1
| Upartial u2 -> Upartial (u1 @ u2)
end
(* le_pat p q means, forall V, V matches q implies V matches p *)
let rec le_pat p q =
match (p.pat_desc, q.pat_desc) with
| (Tpat_var _|Tpat_any),_ -> true
| Tpat_alias(p,_), _ -> le_pat p q
| _, Tpat_alias(q,_) -> le_pat p q
| Tpat_constant(c1), Tpat_constant(c2) -> c1 = c2
| Tpat_construct(c1,ps), Tpat_construct(c2,qs) ->
c1.cstr_tag = c2.cstr_tag && le_pats ps qs
| Tpat_variant(l1,Some p1,_), Tpat_variant(l2,Some p2,_) ->
(l1 = l2 && le_pat p1 p2)
| Tpat_variant(l1,None,r1), Tpat_variant(l2,None,_) ->
l1 = l2
| Tpat_variant(_,_,_), Tpat_variant(_,_,_) -> false
| Tpat_tuple(ps), Tpat_tuple(qs) -> le_pats ps qs
| Tpat_lazy p, Tpat_lazy q -> le_pat p q
| Tpat_record l1, Tpat_record l2 ->
let ps,qs = records_args l1 l2 in
le_pats ps qs
| Tpat_array(ps), Tpat_array(qs) ->
List.length ps = List.length qs && le_pats ps qs
(* In all other cases, enumeration is performed *)
| _,_ -> not (satisfiable [[p]] [q])
and le_pats ps qs =
match ps,qs with
p::ps, q::qs -> le_pat p q && le_pats ps qs
| _, _ -> true
let get_mins le ps =
let rec select_rec r = function
[] -> r
| p::ps ->
if List.exists (fun p0 -> le p0 p) ps
then select_rec r ps
else select_rec (p::r) ps in
select_rec [] (select_rec [] ps)
(*
lub p q is a pattern that matches all values matched by p and q
may raise Empty, when p and q and not compatible
*)
let rec lub p q = match p.pat_desc,q.pat_desc with
| Tpat_alias (p,_),_ -> lub p q
| _,Tpat_alias (q,_) -> lub p q
| (Tpat_any|Tpat_var _),_ -> q
| _,(Tpat_any|Tpat_var _) -> p
| Tpat_or (p1,p2,_),_ -> orlub p1 p2 q
| _,Tpat_or (q1,q2,_) -> orlub q1 q2 p (* Thanks god, lub is commutative *)
| Tpat_constant c1, Tpat_constant c2 when c1=c2 -> p
| Tpat_tuple ps, Tpat_tuple qs ->
let rs = lubs ps qs in
make_pat (Tpat_tuple rs) p.pat_type p.pat_env
| Tpat_lazy p, Tpat_lazy q ->
let r = lub p q in
make_pat (Tpat_lazy r) p.pat_type p.pat_env
| Tpat_construct (c1,ps1), Tpat_construct (c2,ps2)
when c1.cstr_tag = c2.cstr_tag ->
let rs = lubs ps1 ps2 in
make_pat (Tpat_construct (c1,rs)) p.pat_type p.pat_env
| Tpat_variant(l1,Some p1,row), Tpat_variant(l2,Some p2,_)
when l1=l2 ->
let r=lub p1 p2 in
make_pat (Tpat_variant (l1,Some r,row)) p.pat_type p.pat_env
| Tpat_variant (l1,None,row), Tpat_variant(l2,None,_)
when l1 = l2 -> p
| Tpat_record l1,Tpat_record l2 ->
let rs = record_lubs l1 l2 in
make_pat (Tpat_record rs) p.pat_type p.pat_env
| Tpat_array ps, Tpat_array qs
when List.length ps = List.length qs ->
let rs = lubs ps qs in
make_pat (Tpat_array rs) p.pat_type p.pat_env
| _,_ ->
raise Empty
and orlub p1 p2 q =
try
let r1 = lub p1 q in
try
{q with pat_desc=(Tpat_or (r1,lub p2 q,None))}
with
| Empty -> r1
with
| Empty -> lub p2 q
and record_lubs l1 l2 =
let l1 = sort_fields l1 and l2 = sort_fields l2 in
let rec lub_rec l1 l2 = match l1,l2 with
| [],_ -> l2
| _,[] -> l1
| (lbl1,p1)::rem1, (lbl2,p2)::rem2 ->
if lbl1.lbl_pos < lbl2.lbl_pos then
(lbl1,p1)::lub_rec rem1 l2
else if lbl2.lbl_pos < lbl1.lbl_pos then
(lbl2,p2)::lub_rec l1 rem2
else
(lbl1,lub p1 p2)::lub_rec rem1 rem2 in
lub_rec l1 l2
and lubs ps qs = match ps,qs with
| p::ps, q::qs -> lub p q :: lubs ps qs
| _,_ -> []
(******************************)
(* Exported variant closing *)
(******************************)
(* Apply pressure to variants *)
let pressure_variants tdefs patl =
let pss = List.map (fun p -> [p;omega]) patl in
ignore (pressure_variants (Some tdefs) pss)
(*****************************)
(* Utilities for diagnostics *)
(*****************************)
(*
Build up a working pattern matrix by forgetting
about guarded patterns
*)
let has_guard act = match act.exp_desc with
| Texp_when(_, _) -> true
| _ -> false
let rec initial_matrix = function
[] -> []
| (pat, act) :: rem ->
if has_guard act
then
initial_matrix rem
else
[pat] :: initial_matrix rem
(******************************************)
(* Look for a row that matches some value *)
(******************************************)
(*
Useful for seeing if the example of
non-matched value can indeed be matched
(by a guarded clause)
*)
exception NoGuard
let rec initial_all no_guard = function
| [] ->
if no_guard then
raise NoGuard
else
[]
| (pat, act) :: rem ->
([pat], pat.pat_loc) :: initial_all (no_guard && not (has_guard act)) rem
let rec do_filter_var = function
| (_::ps,loc)::rem -> (ps,loc)::do_filter_var rem
| _ -> []
let do_filter_one q pss =
let rec filter_rec = function
| ({pat_desc = Tpat_alias(p,_)}::ps,loc)::pss ->
filter_rec ((p::ps,loc)::pss)
| ({pat_desc = Tpat_or(p1,p2,_)}::ps,loc)::pss ->
filter_rec ((p1::ps,loc)::(p2::ps,loc)::pss)
| (p::ps,loc)::pss ->
if simple_match q p
then (simple_match_args q p @ ps, loc) :: filter_rec pss
else filter_rec pss
| _ -> [] in
filter_rec pss
let rec do_match pss qs = match qs with
| [] ->
begin match pss with
| ([],loc)::_ -> Some loc
| _ -> None
end
| q::qs -> match q with
| {pat_desc = Tpat_or (q1,q2,_)} ->
begin match do_match pss (q1::qs) with
| None -> do_match pss (q2::qs)
| r -> r
end
| {pat_desc = Tpat_any} ->
do_match (do_filter_var pss) qs
| _ ->
let q0 = normalize_pat q in
do_match (do_filter_one q0 pss) (simple_match_args q0 q @ qs)
let check_partial_all v casel =
try
let pss = initial_all true casel in
do_match pss [v]
with
| NoGuard -> None
(************************)
(* Exhaustiveness check *)
(************************)
let do_check_partial loc casel pss = match pss with
| [] ->
(*
This can occur
- For empty matches generated by ocamlp4 (no warning)
- when all patterns have guards (then, casel <> [])
(specific warning)
Then match MUST be considered non-exhaustive,
otherwise compilation of PM is broken.
*)
begin match casel with
| [] -> ()
| _ -> Location.prerr_warning loc Warnings.All_clauses_guarded
end ;
Partial
| ps::_ ->
begin match exhaust None pss (List.length ps) with
| Rnone -> Total
| Rsome [v] ->
let errmsg =
try
let buf = Buffer.create 16 in
let fmt = formatter_of_buffer buf in
top_pretty fmt v;
begin match check_partial_all v casel with
| None -> ()
| Some _ ->
(* This is 'Some loc', where loc is the location of
a possibly matching clause.
Forget about loc, because printing two locations
is a pain in the top-level *)
Buffer.add_string buf
"\n(However, some guarded clause may match this value.)"
end ;
Buffer.contents buf
with _ ->
"" in
Location.prerr_warning loc (Warnings.Partial_match errmsg) ;
Partial
| _ ->
fatal_error "Parmatch.check_partial"
end
(*****************)
(* Fragile check *)
(*****************)
(* Collect all data types in a pattern *)
let rec add_path path = function
| [] -> [path]
| x::rem as paths ->
if Path.same path x then paths
else x::add_path path rem
let extendable_path path =
not
(Path.same path Predef.path_bool ||
Path.same path Predef.path_list ||
Path.same path Predef.path_option)
let rec collect_paths_from_pat r p = match p.pat_desc with
| Tpat_construct({cstr_tag=(Cstr_constant _|Cstr_block _)},ps) ->
let path = get_type_path p.pat_type p.pat_env in
List.fold_left
collect_paths_from_pat
(if extendable_path path then add_path path r else r)
ps
| Tpat_any|Tpat_var _|Tpat_constant _| Tpat_variant (_,None,_) -> r
| Tpat_tuple ps | Tpat_array ps
| Tpat_construct ({cstr_tag=Cstr_exception _}, ps)->
List.fold_left collect_paths_from_pat r ps
| Tpat_record lps ->
List.fold_left
(fun r (_,p) -> collect_paths_from_pat r p)
r lps
| Tpat_variant (_, Some p, _) | Tpat_alias (p,_) -> collect_paths_from_pat r p
| Tpat_or (p1,p2,_) ->
collect_paths_from_pat (collect_paths_from_pat r p1) p2
| Tpat_lazy p ->
collect_paths_from_pat r p
(*
Actual fragile check
1. Collect data types in the patterns of the match.
2. One exhautivity check per datatype, considering that
the type is extended.
*)
let do_check_fragile loc casel pss =
let exts =
List.fold_left
(fun r (p,_) -> collect_paths_from_pat r p)
[] casel in
match exts with
| [] -> ()
| _ -> match pss with
| [] -> ()
| ps::_ ->
List.iter
(fun ext ->
match exhaust (Some ext) pss (List.length ps) with
| Rnone ->
Location.prerr_warning
loc
(Warnings.Fragile_match (Path.name ext))
| Rsome _ -> ())
exts
(********************************)
(* Exported exhustiveness check *)
(********************************)
(*
Fragile check is performed when required and
on exhaustive matches only.
*)
let check_partial loc casel =
if Warnings.is_active (Warnings.Partial_match "") then begin
let pss = initial_matrix casel in
let pss = get_mins le_pats pss in
let total = do_check_partial loc casel pss in
if
total = Total && Warnings.is_active (Warnings.Fragile_match "")
then begin
do_check_fragile loc casel pss
end ;
total
end else
Partial
(********************************)
(* Exported unused clause check *)
(********************************)
let check_unused tdefs casel =
if Warnings.is_active Warnings.Unused_match then
let rec do_rec pref = function
| [] -> ()
| (q,act)::rem ->
let qs = [q] in
begin try
let pss =
get_mins le_pats (List.filter (compats qs) pref) in
let r = every_satisfiables (make_rows pss) (make_row qs) in
match r with
| Unused ->
Location.prerr_warning
q.pat_loc Warnings.Unused_match
| Upartial ps ->
List.iter
(fun p ->
Location.prerr_warning
p.pat_loc Warnings.Unused_pat)
ps
| Used -> ()
with e -> assert false
end ;
if has_guard act then
do_rec pref rem
else
do_rec ([q]::pref) rem in
do_rec [] casel
(*********************************)
(* Exported irrefutability tests *)
(*********************************)
let irrefutable pat = le_pat pat omega
(* An inactive pattern is a pattern whose matching needs only
trivial computations (tag/equality tests).
Patterns containing (lazy _) subpatterns are active. *)
let rec inactive pat = match pat with
| Tpat_lazy _ ->
false
| Tpat_any | Tpat_var _ | Tpat_constant _ | Tpat_variant (_, None, _) ->
true
| Tpat_tuple ps | Tpat_construct (_, ps) | Tpat_array ps ->
List.for_all (fun p -> inactive p.pat_desc) ps
| Tpat_alias (p,_) | Tpat_variant (_, Some p, _) ->
inactive p.pat_desc
| Tpat_record ldps ->
List.exists (fun (_, p) -> inactive p.pat_desc) ldps
| Tpat_or (p,q,_) ->
inactive p.pat_desc && inactive q.pat_desc
(* A `fluid' pattern is both irrefutable and inactive *)
let fluid pat = irrefutable pat && inactive pat.pat_desc
|