Skip to content
This repository
tree: 97325e2bd6
Fetching contributors…

Octocat-spinner-32-eaf2f5

Cannot retrieve contributors at this time

file 1901 lines (1779 sloc) 78.492 kb
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 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900
(*
Copyright © 2011, 2012 MLstate

This file is part of Opa.

Opa is free software: you can redistribute it and/or modify it under the
terms of the GNU Affero General Public License, version 3, as published by
the Free Software Foundation.

Opa is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
more details.

You should have received a copy of the GNU Affero General Public License
along with Opa. If not, see <http://www.gnu.org/licenses/>.
*)
module Format = Base.Format
module List = Base.List
module String = Base.String
module Q = QmlAst
module Package = ObjectFiles.Package

module WClass = struct

  let all =
    WarningClass.create
      ~public:true
      ~name:"slicer"
      ~doc:"All the warnings of the slicer"
      ~err:true
      ~enable:true
      ()

  let sliced_expr =
    WarningClass.create
      ~parent:all
      ~public:true
      ~name:"sliced_expr"
      ~doc:"Warns when a declaration with a @sliced_expr is not defined on both sides"
      ~err:true
      ~enable:true
      ()

  module Server = struct
    (* can only be checked at link time *)
    (** when a server directive has no purpose, TODO *)
    let useless =
      WarningClass.create
        ~parent:all
        ~public:true
        ~name:"server.useless"
        ~doc:"Warns when a declaration with a server directive is never called from the client (i.e. remove it)"
        ~err:false
        ~enable:true
        ()

    (** when a server directive is ignored *)
    let meaningless =
      WarningClass.create
        ~parent:all
        ~public:true
        ~name:"server.meaningless"
        ~doc:"Warns when a declaration with a server directive is using a protected (or server_private) value"
        ~err:false
        ~enable:true
        ()

    (** when a server directive is generating first order call back to the client *)
    let misleading =
      WarningClass.create
        ~parent:all
        ~public:true
        ~name:"server.misleading"
        ~doc:"Warns when a declaration with a server directive is calling the client called"
        ~err:false
        ~enable:true
        ()
  end

  module Protected = struct
    (** when a protected directive is generating first order call back to the client *)
    let misleading =
      WarningClass.create
        ~parent:all
        ~public:true
        ~name:"protected.misleading"
        ~doc:"Warns when a declaration with a protected directive is calling the client called"
        ~err:false
        ~enable:true
        ()

    (** when a exposed directive is generating first order call back to the client *)
    let implicit_access =
      WarningClass.create
        ~parent:all
        ~public:true
        ~name:"protected.implicit.expose"
        ~doc:"Warns when a xhtml event is giving access to a protected value by being implicitly exposed but completly server side (safe in most cases)"
        ~err:false
        ~enable:true
        ()
  end

  module Exposed = struct
    (** when an exposed directive is not exposing a protected value *)
    let meaningless =
      WarningClass.create
        ~parent:all
        ~public:true
        ~name:"exposed.meaningless"
        ~doc:"Warns when a declaration is asked to be exposed but it is not using any protected value"
        ~err:false
        ~enable:true
        ()
    (** when an exposed directive is adding an entry point uselessly TODO *)
    let useless =
      WarningClass.create
        ~parent:all
        ~public:true
        ~name:"exposed.useless"
        ~doc:"Warns when a declaration with an exposed directive is never called from client"
        ~err:false
        ~enable:true
        ()
    (** when a exposed directive is generating first order call back to the client *)
    let misleading =
      WarningClass.create
        ~parent:all
        ~public:true
        ~name:"exposed.misleading"
        ~doc:"Warns when a declaration with an exposed directive is calling the client"
        ~err:false
        ~enable:true
        ()
  end

  let as_ignored l = List.iter (fun wclass -> WarningClass.set_warn wclass false;
                                              WarningClass.set_warn_error wclass false) l
  let as_warning l = List.iter (fun wclass -> WarningClass.set_warn wclass true;
                                              WarningClass.set_warn_error wclass false) l
  let as_error li lw all = List.iter (fun wclass ->
    if not(List.mem wclass li) && not(List.mem wclass lw) then (
      WarningClass.set_warn wclass true;
      WarningClass.set_warn_error wclass true
    )
  ) all

  (* first list => ignored
second list => warning
otherwise error *)
  let all_swclass = [ Server.meaningless ; Server.useless ; Server.misleading ;
                      Exposed.meaningless; Exposed.useless ; Exposed.misleading ;
                      (*TODO*) (* TODO *) Protected.misleading ; Protected.implicit_access]
  let security_levels_warnings = [
    "low", (
      all_swclass,
      []
    );
    "warnall", (
      [],
      all_swclass
    );
    "normal", (
      [Exposed.misleading; Server.misleading; Protected.implicit_access; Server.misleading],
      [Protected.misleading]
    );
    "high", (
      [Exposed.misleading],
      [Server.misleading;Protected.implicit_access]
    );
    "higher", (
      [],
      [Exposed.misleading;Protected.implicit_access]
    );
    "pedantic", (
      [],
      []
    )
  ]

  let select_security_level level =
    let ignored, warn = List.assoc level security_levels_warnings
    in
    as_ignored ignored;
    as_warning warn;
    as_error ignored warn all_swclass

  let security_levels = List.map fst security_levels_warnings

  let warning_set = WarningClass.Set.create_from_list ([
    all;
    sliced_expr;
  ] @ all_swclass)

end

let warning_set = WClass.warning_set

module Options = struct

  module Arg = Base.Arg

  module Type = struct
    type options = {
      check_level : string;
    }
  end

  include Type

  let default_options = {
    check_level = "normal"
  }
  let _ = WClass.select_security_level default_options.check_level

  let r = ref default_options

  let list =
  [
    "--slicer-check",
    Arg.Symbol (WClass.security_levels, (fun level ->
      r := { check_level = level };
      WClass.select_security_level level;
    )),
    Format.sprintf " Level of security of the slicing checks (%a) [%s]"
      (Format.pp_list "@ " Format.pp_print_string) WClass.security_levels
      default_options.check_level
    ;
  ]

end


type splitted_code = {
  code : QmlAst.code ;
  published : Pass_ExplicitInstantiation.published_map;
  original_renaming : QmlRenamingMap.t;
  renaming : QmlRenamingMap.t ;
}

type side_annotation =
  | Client (* client side *)
  | Server (* server side *)
  | Both (* side independent *)
type user_wish =
  | Prefer
  | Force
type user_annotation = { side : side_annotation; wish : user_wish }
type client_code_kind =
  [ `expression
  | `insert_server_value (* SHOULD NOT BE USED FOR FUNCTIONAL TYPES, it is useless *)
  | `alias ]
type server_code_kind =
  [ `expression
  | `alias ]

(**
A weakened form of type [privacy], exported to the rest of the compiler
*)
type publication = [ `Published of [`sync | `async | `funaction ]
                   | `Private ]

type privacy =
  | Published of bool (* the bool indicate that the publish was implicit *)
  | Private
  | Visible

let variant_of_async async =
  if async then `async else `sync

type 'a value =
  | Local of 'a
  | External of Package.t

type information = (* TODO: explicit the invariants *)
    { (* fields that aren't computed *)
      privacy : privacy;
      implemented_both : bool;
      user_annotation : user_annotation option;
      ident : Ident.t;
      async : bool;
      mutable expr : Q.expr value; (* this field is muted only at the very end
* to avoid marshalling the expression *)

      (* computed by initialize_env *)
      mutable calls_server_bypass : BslKey.t option;
      mutable calls_client_bypass : BslKey.t option;
      mutable has_sliced_expr : bool;
      mutable lambda_lifted : Ident.t list;

      (* computed by propagate_server_private *)
      mutable calls_private : information value option; (* this field is independent of the @publish annotation *)

      (* TODO handle instantaneous deps *)

      (* computed by the kind of effect analysis *)
      mutable does_side_effects : bool;

      (* these fields are computed by choose sides *)
      mutable needs_the_server : bool;
      mutable needs_the_client : bool;
      (*mutable need_serialization : bool; (* not equivalent to calls_the_client || calls_the_server
* because you need serialization mechanisms
* for @insert_server_value, but there is no call
* (at least if there is no function) *)*)
      mutable on_the_server : server_code_kind option option; (* TODO: use a right default value? options because this is unset at the beginning *)
      mutable on_the_client : client_code_kind option option; (* same thing *)
      mutable publish_on_the_client : bool; (* need a @comet_publish *)
      mutable publish_on_the_server : bool; (* need an @ajax_publish *)

      (* these fields are computed by the renaming are used to be able
* to do the same alpha conversion of identifiers across different
* compilation units *)
      mutable server_ident : [ `ident of Ident.t
                             | `tsc of (QmlAst.ty, unit) QmlGenericScheme.tsc option
                             | `ident_tsc of Ident.t * (QmlAst.ty, unit) QmlGenericScheme.tsc option
                             | `undefined ];
      (* if the declaration is defined on the server,
* gives the renamed identifier
* if not, it gives the typescheme to put on the @ajax_call *)
      mutable client_ident : [ `ident of Ident.t
                             | `tsc of (QmlAst.ty, unit) QmlGenericScheme.tsc option
                             | `ident_tsc of Ident.t * (QmlAst.ty, unit) QmlGenericScheme.tsc option
                             | `undefined ];
    }

let pp_option pp_a f = function
  | None -> Format.pp_print_string f "None"
  | Some a -> Format.fprintf f "Some %a" pp_a a
let pp_server_ident f = function
  | `ident i -> Format.fprintf f "`ident %s" (Ident.to_string i)
  | `tsc tsc_opt -> Format.fprintf f "`tsc %a" (pp_option QmlPrint.pp_base#tsc) tsc_opt
  | `ident_tsc (i, tsc_opt) ->
      Format.fprintf f "`ident_tsc (%s, %a)" (Ident.to_string i) (pp_option
        QmlPrint.pp_base#tsc) tsc_opt
  | `undefined -> Format.pp_print_string f "undefined"
let pp_kind f = function
  | `expression -> Format.pp_print_string f "`expression"
  | `insert_server_value -> Format.pp_print_string f "`insert_server_value"
  | `alias -> Format.pp_print_string f "`alias"
let pp_value pp_a f = function
  | Local a -> Format.fprintf f "Local %a" pp_a a
  | External p -> Format.fprintf f "External %a" Package.pp p
let pp_info_ident f {ident; _} = Format.pp_print_string f (Ident.to_string ident)
let pp_privacy f = function
  | Published _ -> Format.pp_print_string f "Published"
  | Private -> Format.pp_print_string f "Private"
  | Visible -> Format.pp_print_string f "Visible"
let pp_info f {ident; server_ident; client_ident;
               publish_on_the_server; publish_on_the_client;
               on_the_server; on_the_client;
               calls_private; privacy;
               calls_server_bypass; calls_client_bypass; _} =
  Format.fprintf f "@[<v>{@[<v2>@ ident: %s@ server_ident: %a@ client_ident: %a\
@ publish_on_the_server: %B@ publish_on_the_client: %B\
@ on_the_server: %a@ on_the_client: %a\
@ calls_private: %a@ privacy: %a\
@ calls_server_bypass: %a@ calls_client_bypass: %a@]@ }@]"
    (Ident.to_string ident) pp_server_ident server_ident pp_server_ident client_ident
    publish_on_the_server publish_on_the_client
    (pp_option (pp_option pp_kind)) on_the_server (pp_option (pp_option pp_kind)) on_the_client
    (pp_option (pp_value pp_info_ident)) calls_private pp_privacy privacy
    (pp_option BslKey.pp) calls_server_bypass (pp_option BslKey.pp) calls_client_bypass

module Information =
struct
  type t = information
  let compare info1 info2 = Ident.compare info1.ident info2.ident
  let equal info1 info2 = Ident.equal info1.ident info2.ident
  let hash info = Ident.hash info.ident
end
module G = struct
  include Graph.Imperative.Digraph.ConcreteBidirectional(Information)
  let exists_succ f graph node =
    Return.set_checkpoint
      (fun label ->
         iter_succ (fun node -> if f node then Return.return label true) graph node;
         false
      )
  let find_succ f graph node =
    Return.set_checkpoint
      (fun label ->
         iter_succ (fun node -> if f node then Return.return label node) graph node;
         raise Not_found
      )
end

type environment =
    { informations : information IdentTable.t;
      call_graph : G.t;
      client_bsl_lang : BslLanguage.t;
      server_bsl_lang : BslLanguage.t; (* could have a debug mode where both sides are ml *)
      bymap : BslLib.BSL.ByPassMap.t;
      gamma : QmlTypes.gamma;
      annotmap : Q.annotmap;
    }

let get_bypass_side env bslkey =
  match BslLib.BSL.ByPassMap.find_opt env.bymap bslkey with
  | None ->
      (* shouldn't have undefined bypass at that point *)
      OManager.i_error "@[missing bypass @{<bright>%a@}@] in bypasses @[%a@]"
        BslKey.pp bslkey
        BslLib.BSL.ByPassMap.pp env.bymap
  | Some bypass ->
      let langs = BslLib.BSL.ByPass.langs bypass in
      let impl_client = List.mem env.client_bsl_lang langs in
      let impl_server = List.mem env.server_bsl_lang langs in
      match impl_server,impl_client with
      | true,true -> `both
      | false,true -> `client
      | true,false -> `server
      | _ -> assert false (* could happen in we use a c only bypass *)


(* TODO: annotation of db default values as full server
* annotation of dbgen generated code as server private *)
(* TODO: pas de passe collect annotations *)
(* TODO: handle recursive annotations full_server -> pas besoin de serialization + at least on the server but not only? *)
(* TODO: annotation @assert_both etc? *)
(* TODO: never insert_server_value of any datatype containing functions? *)

let empty_env ~client_bsl_lang ~server_bsl_lang bymap typer_env =
  { informations = IdentTable.create 100;
    call_graph = G.create ();
    client_bsl_lang ;
    server_bsl_lang ;
    bymap = bymap;
    gamma = typer_env.QmlTypes.gamma;
    annotmap = typer_env.QmlTypes.annotmap;
  }

(* same as rewriteAsyncLambda presumably *)
type ignored_directive = [
| Q.type_directive
| Q.lambda_lifting_directive
| Q.slicer_directive
]
let async_lambda e =
  QmlAstWalk.Expr.traverse_exists
    (fun tra -> function
     | Q.Coerce _
     | Q.Directive (_, #ignored_directive, _, _) ->
         tra e
     | Q.Lambda _ -> true
     | _ -> false
    ) e

let rec slicer_annots_of_expr visibility both_implem side_annot async annotmap expr =
  match expr with
  | Q.Directive (label, `async, [e], _) when async_lambda e ->
      async := true;
      let tsc_gen = QmlAnnotMap.find_tsc_opt_label label !annotmap in
      annotmap := QmlAnnotMap.add_tsc_opt_label (Q.Label.expr e) tsc_gen !annotmap;
      slicer_annots_of_expr visibility both_implem side_annot async annotmap e
  | Q.Coerce (label, e, ty) ->
      let e' = slicer_annots_of_expr visibility both_implem side_annot async annotmap e in
      (*if e == e' then expr else*) Q.Coerce (label, e', ty)
  | Q.Directive (label, (#Q.type_directive as d), [e], ty) ->
      let e' = slicer_annots_of_expr visibility both_implem side_annot async annotmap e in
      (*if e == e' then expr else*) Q.Directive (label, d, [e'], ty)
  | Q.Directive (label, (`visibility_annotation _ | `side_annotation _ as v), [e], _) ->
    begin match v, !visibility, !side_annot with
       | `visibility_annotation v, None, _ ->
           visibility := Some (
             match v with
             | `public (`sync | `async as sync) ->
                 (async := match sync with `async -> true | `sync -> !async);
                 Published false
             | `private_ -> Private
             | `public `funaction -> Published true (* `sync*)
                 (* problem: since fun actions are lambda lifting with two groups
* of lambda, the funaction is onclick="f(env)(arg)"
* and the remote call f(env) does not return void
* it should be solved by putting fun action lifting after typing
* and by putting a partial apply directly
* when this is done, `funaction should become `async as is done
* in the commented code below
*)
           )
       | `side_annotation v, _, None ->
           side_annot := Some (
             match v with
             | `client -> {side=Client;wish=Force}
             | `server -> {side=Server;wish=Force}
             | `both -> {side=Both;wish=Force}
             | `both_implem -> both_implem := true; {side=Both;wish=Force}
             | `prefer_client -> {side=Client;wish=Prefer}
             | `prefer_server -> {side=Server;wish=Prefer}
             | `prefer_both -> {side=Both;wish=Prefer}
           )
       | `visibility_annotation _, Some _, _ ->
         let context = QmlError.Context.expr expr in
           QmlError.serror context "You have conflicting security annotations (protected,exposed) on the same declaration."
       | `side_annotation _, _, Some _ ->
           let context = QmlError.Context.expr expr in
           QmlError.serror context "You have conflicting side annotations (server,client) on the same declaration."
    end;
    let tsc_gen = QmlAnnotMap.find_tsc_opt_label label !annotmap in
    annotmap := QmlAnnotMap.add_tsc_opt_label (Q.Label.expr e) tsc_gen !annotmap;
    slicer_annots_of_expr visibility both_implem side_annot async annotmap e
  | _ -> expr

let default_information ~env ~annotmap (ident,expr) =
  let visibility = ref None in
  let both_implem = ref false in
  let side_annot = ref None in
  let async = ref false in
  let expr = slicer_annots_of_expr visibility both_implem side_annot async annotmap expr in
  if !async then (
    (* we can't have asynchronous calls to functions that return something else than void
* note that {} / ... is not good either because f(x:{} / ...) = x cannot
* be called asynchronous
* So we are NOT checking that the return type is unifiable with void,
* we want exactly void
* Another way to do that would be to force the typer to unify void and the return type
* but for that, the directive would need to be still in the ast when typing *)
    let ty = QmlAnnotMap.find_ty (Q.QAnnot.expr expr) !annotmap in
    let fail () =
      let context = QmlError.Context.expr expr in
      QmlError.serror context
        "@[@@async_publish can be put only on functions whose return type is {}@]@\n\
@[<2>Hint:@\nit has type %a@]@."
        QmlPrint.pp#ty ty
    in
    (match QmlTypesUtils.Inspect.get_arrow_through_alias_and_private env.gamma ty with
     | None -> fail ()
     | Some (_params, ty) ->
         if not (QmlTypesUtils.Inspect.is_type_void env.gamma ty) then fail ());
  );
  { calls_private = None;
    lambda_lifted = [];
    calls_server_bypass = None;
    calls_client_bypass = None;
    privacy = Option.default Visible !visibility;
    implemented_both = !both_implem;
    user_annotation = !side_annot;
    async = !async;
    has_sliced_expr = false;
    expr = Local expr;
    on_the_server = None;
    on_the_client = None;
    publish_on_the_server = false;
    publish_on_the_client = false;
    needs_the_client = false;
    needs_the_server = false;
    ident = ident;
    does_side_effects = false;
    server_ident = `undefined;
    client_ident = `undefined;
  }, expr

let get_expr = function
  | {expr = Local expr; _} -> expr
  | {expr = External _; _} -> assert false
let is_external = function
  | {expr = External _; _} -> true
  | {expr = Local _; _} -> false

let pp_pos_a f label = FilePos.pp_pos f (Annot.pos label)
let pp_pos f info =
  match info.expr with
  | Local expr -> pp_pos_a f (Q.Label.expr expr)
  | External package -> Package.pp_full f package

let update_call_graph env info =
  let infos = env.informations in
  let call_graph = env.call_graph in
  match info.expr with
  | External _ -> ()
  | Local expr ->
      QmlAstWalk.Expr.iter_context_down
        (fun context -> function
         | Q.Ident (_, i) -> (
             try
               let info_i = IdentTable.find infos i in
               G.add_edge call_graph info info_i
             with Not_found -> ()
           );
             context

         | Q.Bypass (_, key) -> (
             match get_bypass_side env key with
             | `server -> info.calls_server_bypass <- Some key
             | `client -> info.calls_client_bypass <- Some key
             | `both -> ()
           );
             context

         | Q.Directive (label, `sliced_expr, _, _) ->
             if context then
               OManager.serror "@[<v>%a@]@\n@[<2> You have a nested @@sliced_expr.@]"
                 pp_pos_a label;
             info.has_sliced_expr <- true;
             true

         | Q.Directive (label, (`side_annotation _ | `visibility_annotation _), _, _) ->
             let error_context = QmlError.Context.label label in
             QmlError.serror error_context "@[This is an invalid slicer annotation: they can only appear on toplevel bindings (or inside toplevel modules) or on function bindings.@]";
             context

         | Q.Directive (_, `lifted_lambda (_,hierarchy), _, _) ->
             assert (info.lambda_lifted = []);
             (* if the code is lifted, you have only one function per toplevel
declaration (so at most one @lifted_lambda) *)
             info.lambda_lifted <- hierarchy;
             context

         | _ ->
             context
        )
        false
        expr

let initialize_env ~env code =
  let annotmap = ref env.annotmap in
  let call_graph = env.call_graph in
  let initialize_bindings iel =
    List.map
      (fun ((i,_) as bnd) ->
         let info, e = default_information ~env ~annotmap bnd in
         IdentTable.add env.informations i info;
         G.add_vertex call_graph info;
         (i, e)
      ) iel in
  let code =
    List.map
      (function
       | Q.NewVal (label,iel) ->
           Q.NewVal (label,initialize_bindings iel)
       | Q.NewValRec (label,iel) ->
           Q.NewValRec (label,initialize_bindings iel)
       | Q.NewType _ -> assert false
       | Q.Database _ -> assert false
       | Q.NewDbValue _ -> assert false)
      code in
  IdentTable.iter (fun _ info -> update_call_graph env info) env.informations;
  {env with annotmap = !annotmap}, code

module G_for_server_private =
struct
  include G
  let iter_succ f graph node =
    iter_succ (fun node -> match node.privacy with Published _ -> () | _ -> f node) graph node
  let exists_succ f graph node =
    exists_succ (fun node -> match node.privacy with Published _ -> false | _ -> f node) graph node
  let find_succ f graph node =
    find_succ (fun node -> match node.privacy with Published _ -> false | _ -> f node) graph node
  let find_opt_succ f graph node =
    try Some (find_succ f graph node) with Not_found -> None
end
module SCC_for_server_private = GraphUtils.Components.Make(G_for_server_private)

let propagate_server_private env =
  let graph = env.call_graph in
  let groups = SCC_for_server_private.scc ~size:200 graph in
  List.iter
    (fun group ->
       let info_opt =
         List.find_map
           (fun info ->
              if info.calls_server_bypass <> None || info.privacy = Private
              then Some info
              else
                G_for_server_private.find_opt_succ
                  (fun node -> node.calls_private <> None) graph info)
           group in
       match info_opt with
       | Some info -> List.iter (fun node -> node.calls_private <- Some (Local info)) group
       | None -> ()
    ) groups


module S_eff =
struct
  type t = QmlEffects.SlicerEffect.env
  let pass = "qmlSimpleSlicerEffect"
  let pp f _ = Format.pp_print_string f "<dummy>"
end

module R_eff =
struct
  include ObjectFiles.Make(S_eff)
  let load () =
    fold
      (fun (eff1,typ1) (eff2,typ2) ->
         (IdentMap.safe_merge eff1 eff2, IdentMap.safe_merge typ1 typ2))
      (IdentMap.empty,IdentMap.empty)
  let save (load_eff,load_typ) (final_eff,final_typ) =
    let diff_env = (IdentMap.diff final_eff load_eff, IdentMap.diff final_typ load_typ) in
    save diff_env
end

let analyse_side_effects env code =
  let bypass_typer =
    let typer = BslLib.BSL.ByPassMap.bypass_typer env.bymap in
    fun s -> Option.get (typer s) in
  let initial_env = R_eff.load () in
  let (effect_env,_) as final_env = QmlEffects.SlicerEffect.infer_code ~initial_env bypass_typer code in
  R_eff.save initial_env final_env;
  IdentTable.iter
    (fun ident info ->
       info.does_side_effects <- QmlEffects.SlicerEffect.flatten_effect (IdentMap.find ident effect_env)
    ) env.informations

module SCC = GraphUtils.Components.Make(G)

let get_arity_opt gamma annotmap e =
  let ty = QmlAnnotMap.find_ty (Q.QAnnot.expr e) annotmap in
  match QmlTypesUtils.Inspect.get_arrow_through_alias_and_private gamma ty with
  | Some (params, _) -> Some (List.length params)
  | None -> None

let get_arity_of_functional_type gamma annotmap e =
  Option.get (get_arity_opt gamma annotmap e)

let has_functional_type gamma annotmap e =
  match get_arity_opt gamma annotmap e with
  | None -> false
  | Some _ -> true


let rec find_private_path acc info =
  let acc = info :: acc in
  match info.privacy with
  | Private -> List.rev acc, `annot
  | Published _ | Visible ->
      match info.calls_server_bypass with
      | Some key -> List.tl (List.rev acc), `key key
      | None ->
          match info.calls_private with
          | None -> assert false
          | Some (Local info) -> find_private_path acc info
          | Some (External package) -> List.rev acc, `package package

let find_private_path info = find_private_path [] info


let pp_private_path pp_pos f info =
  let l,end_ = find_private_path info in
  let pp_info f info =
    Format.fprintf f "'%s' at @[<v>%a@]"
      (Ident.original_name info.ident)
      pp_pos info in
  let pp_end f = function
    | `key key -> Format.fprintf f "%%%%%a%%%% which is a server bypass" BslKey.pp key
    | `package package -> Format.fprintf f "from package %a" Package.pp_full package
    | `annot -> Format.fprintf f "which is annotated as 'protected'" in
  if l = [] then
    Format.fprintf f "@[<v>%a@]"
      pp_end end_
  else
    Format.fprintf f "@[<v>%a@ %a@]"
      (Format.pp_list "@ " pp_info) l
      pp_end end_

(* FIXME: with the smarter analysis for side effects, this function doesn't work anymore:
* @server b = 1
* @client a = (-> b)() would probably not do an insert_server_value when it should
* this function contains some bugs anyway *)
let direct_dep_on_the_server env node =
  let informations = env.informations in
  let rec aux tra bnds = function
    | Q.Lambda _ -> true
    | Q.Ident (_, i) as expr -> (
        (* we don't have to care about recursive deps
* (cases when on_the_server or on_the_client can be None)
* because in recursion we only have lambdas, which never do side effects *)
        try
          match IdentTable.find informations i with
          | { on_the_server = Some (Some _); on_the_client = Some None; _} ->
              (* avoiding to put an insert_server_value on cases such as @server f() = ...; @both g = f
* this is hackish and this should be done better by computing dependencies while doing
* side effect analysis *)
              has_functional_type env.gamma env.annotmap expr
          | _ -> true
        with
        | Not_found -> true
      )
    | e -> tra bnds e in
  not (QmlAstWalk.Expr.traverse_forall_context_down aux IdentSet.empty (get_expr node))

type faulty = Private_path | No

let warn_tagged_but_use node ~wclass ~tagged ~use (faulty:faulty) consequence=
  OManager.warning ~wclass
    "@[<v>%a@]@\n@[<2> '%s' is tagged as '%s' but it uses '%s' values%a%s@]"
    pp_pos node
    (Ident.original_name node.ident)
    tagged
    use
    (fun b node -> match faulty with
    | No -> Format.fprintf b "%s" ". "
    | Private_path -> Format.fprintf b ":@\n%a@\n" (pp_private_path pp_pos) node
    )
    node
    consequence

let may_warn_tagged_but_use ~emit node ~wclass ~tagged ~use faulty consequence =
  if emit then (
    warn_tagged_but_use node ~wclass ~tagged ~use faulty consequence;
    false
  ) else false

let check_privacy ~emit_error:_ ~emit node =
  let may_warn ~wclass ~tagged ~use faulty consequence =
    ignore(may_warn_tagged_but_use ~emit node ~wclass ~tagged ~use faulty consequence)
  in
  match node.privacy with
  | Published implicit ->
    (* an explicit exposed value is giving access to nothing protected *)
    let c1 = node.calls_private = None && not(implicit) in
    if c1 then may_warn ~wclass:WClass.Exposed.meaningless
      ~tagged:"exposed" ~use:"only non protected" No
      "The directive will be ignored"
    ;
    (* an implict exposed value is giving access to a protected value *)
    let c2 = node.calls_private <> None && implicit in
    if c2 then may_warn ~wclass:WClass.Protected.implicit_access
      ~tagged:"implicit exposed" ~use:"protected" Private_path
      "The access to these value is guaranteed to be safe, but they can be accessed."
    ;
    let c3 = node.needs_the_client && not(implicit) in
    if c3 then may_warn ~wclass:WClass.Exposed.misleading
      ~tagged:"exposed" ~use:"client" No
      "This is can be inefficient and may be a security threat."
    ;
    c1 && c2 && c3
  | Visible -> true
  | Private ->
    let c1 = node.needs_the_client in
    if c1 then may_warn ~wclass:WClass.Protected.misleading
      ~tagged:"protected" ~use:"client" No
      "This is probably a security threat."
    ;
    c1

let check_side ~emit_error ~emit node =
  let side_str = function
    | Server -> "server"
    | Both -> "both"
    | Client -> "client"
  in
  let c1 = if node.calls_private <> None then (
    match node.user_annotation with
    | Some {wish=Force; side=Server} when not(node.does_side_effects)->
      may_warn_tagged_but_use ~emit node ~wclass:WClass.Server.meaningless
        ~tagged:"server" ~use:"protected" Private_path
        "The directive will be ignored.";
    | Some {wish=Force; side=(Client|Both) as side} ->
      let c1 = side=Both && (match node.privacy with Published _ -> true | _ -> false) in
      if not(c1) && (emit || emit_error) then (
      OManager.serror "@[<v>%a@]@\n@[<4> '%s' is tagged as '%s' but it uses 'protected' values:@\n%a@]"
        pp_pos node
        (Ident.original_name node.ident)
        (side_str side)
        (pp_private_path pp_pos) node;
        c1
      ) else c1
    | _ -> true
  ) else true
  in
  let c2 = if node.needs_the_client then (
    match node.user_annotation with
    | Some {wish=Force; side=Server} ->
      may_warn_tagged_but_use ~emit node ~wclass:WClass.Server.misleading
        ~tagged:"server" ~use:"client" No
        "This can be inefficient.";
    | _ -> true
  ) else true
  in
  let c3 = if node.has_sliced_expr then (
    match node.user_annotation with
    | Some {wish=Force; side=(Client|Server) as side} ->
      may_warn_tagged_but_use ~emit node ~wclass:WClass.sliced_expr
        ~tagged:(side_str side) ~use:"sliced_expr" No
        "This is unusual."
    | _ -> true
  ) else true
  in c1 && c2 && c3

let check_node ?(emit_error=false) ~emit node =
  let c1 = check_privacy ~emit_error ~emit node in
  let c2 = check_side ~emit_error ~emit node in
  c1 && c2

let look_at_user_annotation env pp_pos node annot =
  let rec aux node annot =
    ignore( check_node ~emit_error:false ~emit:false node);
    match annot with
    | Some {wish=Force; side=Client} ->
        node.on_the_server <- Some None;
        node.on_the_client <- Some (Some `expression);
        node.publish_on_the_server <- false;
        node.publish_on_the_client <- true
    | Some {wish=Force; side=Server} ->
      (match node.calls_client_bypass with
        | Some key ->
             OManager.serror "@[<v>%a@]@\n@[<2> '%s' is tagged as @@server but it contains a client bypass (%%%%%a%%%%).@]"
             pp_pos node
               (Ident.original_name node.ident)
               BslKey.pp key
        | None -> ());
        node.on_the_server <- Some (Some `expression);
        node.on_the_client <- Some None;
        node.publish_on_the_server <- node.calls_private = None || (match node.privacy with Published _-> true | _-> false);
        node.publish_on_the_client <- false
    | Some {wish=Force; side=Both} ->
        let fake_server, fake_client =
          if node.calls_private <> None then (
            (
            match node.privacy with
            | Published _ -> ()
            | _ ->
                OManager.serror "@[<v>%a@]@\n@[<4> '%s' is tagged as 'both' but it uses a 'protected' values:@\n%a@]"
                  pp_pos node
                  (Ident.original_name node.ident)
                  (pp_private_path pp_pos) node
            );
            if node.implemented_both then
              OManager.serror "@[<v>%a@]@\n@[<4> '%s' is tagged as 'both_implem' but it uses 'protected' values:@\n%a@]"
                pp_pos node
                (Ident.original_name node.ident)
                (pp_private_path pp_pos) node;
            false, true
          ) else
            match node.calls_client_bypass with
            | Some key ->
                if node.implemented_both then (
                  OManager.serror "@[<v>%a@]@\n@[<4> '%s' is tagged as 'both_implem' but it uses the client bypass %s@]"
                    pp_pos node
                    (Ident.original_name node.ident)
                    (BslKey.to_string key)
                );
                true, false
            | None ->
                false, false in
        let on_the_server =
          if fake_server then
            let functional_type = has_functional_type env.gamma env.annotmap (get_expr node) in
            if not functional_type then
              OManager.serror "@[<v>%a@]@\n@[<2> '%s' is tagged as 'both' but it contains a client bypass (%%%%%a%%%%) and it is not a function.@]"
                pp_pos node
                (Ident.original_name node.ident)
                BslKey.pp (Option.get node.calls_client_bypass);
            `alias
          else
            `expression in
        let on_the_client =
          let functional_type = has_functional_type env.gamma env.annotmap (get_expr node) in
          if fake_client then
            if functional_type then
              `alias
            else
              `insert_server_value
          else if node.implemented_both then
            `expression
          else if node.does_side_effects then
            `insert_server_value
          else
            (* not sure exactly what should happen when you have instantaneous deps, should possibly be a slicing error *)
            if direct_dep_on_the_server env node then
              if functional_type then
                `alias
              else
                `insert_server_value
            else
              `expression in
        if node.has_sliced_expr then (
          (match on_the_client with
           | `expression -> ()
           | `alias | `insert_server_value ->
               OManager.warning ~wclass:WClass.sliced_expr "@[<v>%a@]@\n@[<2> '%s' contains a 'sliced_expr' but the client code will not be executed.@]"
                 pp_pos node
                 (Ident.original_name node.ident)
          );
          (match on_the_server with
           | `expression -> ()
           | `alias ->
               OManager.warning ~wclass:WClass.sliced_expr "@[<v>%a@]@\n@[<2> '%s' contains a 'sliced_expr' but the server code will not be executed.@]"
                 pp_pos node
                 (Ident.original_name node.ident))
        );
        node.on_the_server <- Some (Some on_the_server);
        node.on_the_client <- Some (Some on_the_client);
        node.publish_on_the_server <- on_the_client = `alias;
        node.publish_on_the_client <- on_the_server = `alias
    | Some {wish=Prefer; side=Client} ->
        (* same check as for @client to be sure that we have no error and no warning *)
        if node.calls_private <> None || node.has_sliced_expr then
          aux node None
        else
          aux node (Some {wish=Force; side=Client})
    | Some {wish=Prefer; side=Server} ->
        (* same check as for @server *)
        if node.calls_client_bypass <> None || node.has_sliced_expr then
          aux node None
        else
          aux node (Some {wish=Force; side=Server})
    | Some {wish=Prefer; side=Both} ->
        (* not exactly the same check as for @both
* the check must be stronger not to generate errors, but if the slicer
* isn't forced to, it won't generated stupid code like @both would
* (with `alias) *)
        if node.calls_private <> None || node.calls_client_bypass <> None then
          aux node None
        else
          (* FIXME: we can have warnings anyway with @sliced_expr and @insert_server_value because the check above is not enough *)
          aux node (Some {wish=Force; side=Both})
    | None ->
        (*
if node.calls_private <> None then ( (* should have a different value for functions and not functions maybe ?
* @publish max_int = ... should be insert_server_valued, but not @publish f() = ... *)
aux node (Some {wish=Force; side=Server})
) else if node.calls_client_bypass <> None then (
aux node (Some {wish=Force; side=Client})
) else if node.has_sliced_expr then (
aux node (Some {wish=Force; side=Both})
) else (
(* optimization: if a function needs functionalities present on one side only
* then put the function only on this side. This way you switch side sooner, and you factorize
* remote calls. This cannot increase the number of remote calls, and in the cases where it is not decreased
* the side of the code decreases *)
match node.needs_the_client, node.needs_the_server with
| true, false ->
aux node (Some {wish=Force; side=Client})
| false, true ->
aux node (Some {wish=Force; side=Server})
| _ ->
aux node (Some {wish=Force; side=Both})
)*)
        if node.calls_private = None then(*|| node.privacy = Published then*)
          aux node (Some {wish=Force; side=Both})
        else
          aux node (Some {wish=Force; side=Server}) in
  aux node annot

(* to preserve the behaviour that we had before the early lambda lifting
* by default, a function is sliced as if all local functions had not been lifted
* IF it is not annotated
* If it is annotated, it is treated as if the user had lambda lifted the code by hand *)
let node_is_annotated info =
  match info.privacy with
  | Visible -> (
      (* no @publish nor @server_private *)
      match info.user_annotation with
      | None -> (* no @client, @server, @both *) false
      | _ -> true
    )
  | _ -> true

let enclosing_info_if_not_toplevel_and_not_annotated env info =
  if info.lambda_lifted = [] || node_is_annotated info then None
  else (
    let orig =
      try
        (* a local function is sliced as the its innermost
* enclosing function that is annotated
* (or the toplevel one by default) *)
        List.find
          (fun ident ->
             let info = IdentTable.find env.informations ident in
             node_is_annotated info
          ) info.lambda_lifted
      with Not_found -> List.last info.lambda_lifted in
    let orig_info = IdentTable.find env.informations orig in
    Some orig_info
  )

let inline_informations_lambda_lifted env =
  IdentTable.iter
    (fun _ info ->
       match info.expr with
       | External _ -> ()
       | Local _ ->
           match enclosing_info_if_not_toplevel_and_not_annotated env info with
           | None -> ()
           | Some orig_info ->
               (* merging @sliced_expr, @call_*_bypass
* because these are the only properties that would
* be different if the the lifted functions were inlined
* I think (they depend on the field expr) *)
               orig_info.has_sliced_expr <- orig_info.has_sliced_expr || info.has_sliced_expr;
               orig_info.calls_client_bypass <- (
                 match orig_info.calls_client_bypass with
                 | None -> info.calls_client_bypass
                 | Some _ as v -> v
               );
               orig_info.calls_server_bypass <- (
                 match orig_info.calls_server_bypass with
                 | None -> info.calls_server_bypass
                 | Some _ as v -> v
               );
               (* we add a dependency from the original to the lifted one
* because if the local function is not used, then there is no dependency
* (and the outer function will be put on both sides, so will the inner function
* and if it is server private, resolveRemoteCalls will break)
* example of such a problem if you remove this:
* @server_private x = 1
* g() =
* f() = x
* @fail
*)
               G.add_edge env.call_graph orig_info info
    ) env.informations

let choose_sides env =
  let graph = env.call_graph in
  let groups = SCC.scc ~size:1000 graph in
  List.iter
    (fun group ->
       if List.exists is_external group then
         assert (match group with [_] -> true | _ -> false)
       else (
       (* first step: looking at who needs (transitively) the server or the client *)
         List.iter
           (fun node ->
              (* this value doesn't take into account all the recursive calls *)
              node.needs_the_server <- node.calls_server_bypass <> None || node.privacy = Private || G.exists_succ
                (fun node ->
                   node.needs_the_server ||
                     (match node.on_the_client, node.on_the_server with
                      | Some None, Some (Some b) ->
                          assert (b = `expression); (* if not on the client, must be on the server *)
                          true
                      | _ -> false)) graph node;
              node.needs_the_client <- node.calls_client_bypass <> None || G.exists_succ
                (fun node ->
                   node.needs_the_client ||
                     (match node.on_the_client, node.on_the_server with
                      | Some Some a, Some None ->
                          assert (a = `expression);
                          true
                      | _ -> false)) graph node;
           ) group;
         if List.exists (fun node -> node.needs_the_server) group then
           List.iter (fun node -> node.needs_the_server <- true) group;
         if List.exists (fun node -> node.needs_the_client) group then
           List.iter (fun node -> node.needs_the_client <- true) group;
         (* FIXME the value of needs_the_* is not correct when you have recursive bindings
* with some but not all bindings annotated *)
         (* we should first look at annotated declarations, then compute this set
* and then take of unannotated declaration *)

         (* second step (completely independent): complain if a sliced_expr calls someone private *)
         List.iter
           (fun node ->
              if node.calls_private <> None && node.has_sliced_expr then
                OManager.serror "@[<v>%a@]@\n@[<4> This declaration contains a @@sliced_expr but it uses server private values:@\n%a@]"
                  pp_pos node
                  (pp_private_path pp_pos) node
           ) group;

         (* third step: dispatch according the annotation *)
         List.iter (fun node ->
                      match enclosing_info_if_not_toplevel_and_not_annotated env node with
                      | Some _ -> (* this is treated below *) ()
                      | None -> look_at_user_annotation env pp_pos node node.user_annotation
                   ) group
       )
    ) groups;

  List.iter
    (fun group ->
       List.iter
         (fun node ->
            match enclosing_info_if_not_toplevel_and_not_annotated env node with
            | Some node_i ->
                (* never publish those for now at least, because it adds type
* variables in unwanted places like the runtime of the serialization *)
                let relax = function
                  | None -> assert false
                  | Some (Some `expression)
                  | Some None as v -> v
                  | Some (Some `alias)
                  | Some (Some `insert_server_value) ->
                      (* avoids many useless insert_server_values
* should be solved cleanly when we have an actual slicing strategy for
* local functions *)
                      Some None in
                node.on_the_server <- relax (node_i.on_the_server :> client_code_kind option option);
                node.on_the_client <- relax node_i.on_the_client;
            | None -> ()
         ) group
    ) groups


(*------------------------------------*)
(*--------- ast utilities ------------*)
(*------------------------------------*)

(**
Make a directive

@param dir The directive constructor
*)
let make_dir ?annotmap_old ~inner dir annotmap e =
  let annotmap_old = Option.default annotmap annotmap_old in
  let full = QmlAnnotMap.find (Q.QAnnot.expr e) annotmap_old in
  let typ = QmlAnnotMap.find_ty (Q.QAnnot.expr e) annotmap_old in
  let a = Annot.next () in
  let annotmap = QmlAnnotMap.add a full annotmap in
  let label = Annot.make_label a (Q.Pos.expr e) in
  annotmap, Q.Directive (label, dir, (if inner then [e] else []), (if inner then [] else [typ]))

let directive_call = function
  | `comet_call -> fun a e -> make_dir `comet_call ~inner:true a e
  | `ajax_call b -> fun a e -> make_dir (`ajax_call b) ~inner:true a e

let directive_publish ident dir annotmap expr =
  let ty = QmlAnnotMap.find_ty (Q.QAnnot.expr expr) annotmap in
  let pos = Q.Pos.expr expr in
  let annotmap, expr = QmlAstCons.TypedExpr.ident ~pos annotmap ident ty in
  match dir with
  | `comet_publish ->
      make_dir `comet_publish ~inner:true annotmap expr
  | `ajax_publish b ->
      make_dir (`ajax_publish b) ~inner:true annotmap expr

(* builds (fun x1 x2 ... -> @comet_call(client_name)(x1,x2,...))
the type of client_name is refreshed so that ei can propagate type vars
to the remote call but not to the original implementation
*)
let eta_expand comet_call_or_ajax_call ~gamma ~expr_for_annot ~annotmap_old ~annotmap ~tsc client_name =
  let arity = get_arity_of_functional_type gamma annotmap_old expr_for_annot in
  (*let tsc = QmlTypes.process_scheme gamma tsc in*)
  let annotmap, for_annot = QmlAstCons.TypedExpr.shallow_copy_new ~annotmap_old annotmap expr_for_annot in
  let e = Q.Ident (Q.Label.expr for_annot, client_name) in
  let annot = Q.QAnnot.expr e in
  let ty =
    match tsc with
    | None ->
        (* if the type is not polymorphic, we do not care about using the same typevars
* because ei will not propagate anything in the first place *)
        QmlAnnotMap.find_ty annot annotmap
    | Some tsc ->
        let _quant, ty, () = QmlGenericScheme.export_unsafe tsc in
        ty in
  (*let ty = QmlAnnotMap.find_ty annot annotmap in
let ty = QmlTypes.type_of_type gamma ty in*)
  let annotmap = QmlAnnotMap.add_ty annot ty annotmap in
  let annotmap = QmlAnnotMap.remove_tsc annot annotmap in
  let annotmap, e = directive_call comet_call_or_ajax_call annotmap e in
  let annot = Q.QAnnot.expr e in
  (* don't forget to put the typescheme for ei *)
  let annotmap = QmlAnnotMap.add_ty annot ty annotmap in
  let annotmap = QmlAnnotMap.add_tsc_inst_opt annot tsc annotmap in
  let idents = List.init arity
    (fun i ->
       let (ty, _) = QmlTypes.type_of_type gamma (QmlAstCons.Type.typevar (Q.TypeVar.next ())) in
       let ident = Ident.refresh ~map:(fun name -> name ^ "_eta_" ^ string_of_int i) client_name in
       ident,ty
    ) in
  let annotmap,exprs =
    List.fold_left_map
      (fun annotmap (ident,ty) ->
         QmlAstCons.TypedExpr.ident annotmap ident ty) annotmap idents in
  let annotmap, e = QmlAstCons.TypedExpr.apply gamma annotmap e exprs in
  let annotmap, e = QmlAstCons.TypedExpr.lambda annotmap idents e in
  (* don't forget to put the typescheme for ei *)
  let annot = Q.QAnnot.expr e in
  let annotmap = QmlAnnotMap.add_ty annot ty annotmap in
  let annotmap = QmlAnnotMap.add_tsc_opt annot tsc annotmap in
  annotmap, e

(* renaming all the variables in addition to inserting directives everywhere
* this renaming can't be easily done with QmlAlphaConv and renaming isn't really
* hard to do on already renamed code, so we do it by hand *)
let insert_directives_expr
    ~infos
    ~(side:[`server | `client])
    ~rename
    ~rename_other
    ~tsc
    ~annotmap e =
  let rec aux tra annotmap e = (* need to go down, because we need to know if we are under a @fun_action *)
    match e with
    (* inserting remote calls *)
    | Q.Ident (label, j) -> (
        try
          let new_j = IdentMap.find j rename in
          let tsc_inst_opt = try IdentMap.find j tsc with Not_found -> None in
          let annotmap = QmlAnnotMap.add_tsc_inst_opt_label label tsc_inst_opt annotmap in
          annotmap, Q.Ident (label, new_j)
        with
        | Not_found ->
            try
              let new_j = IdentMap.find j rename_other in
              let e = Q.Ident (label, new_j) in
              let annotmap = QmlAnnotMap.remove_tsc_inst_label label annotmap in
              (* we are on the client and calling the server *)
              let call =
                match side with
                | `server -> `comet_call
                | `client ->
                    let info = IdentTable.find infos j in
                    let sync = variant_of_async info.async in
                    `ajax_call sync in
              let annotmap, e = directive_call call annotmap e in
              assert (IdentMap.mem j tsc);
              let tsc_inst_opt = IdentMap.find j tsc in
              let annotmap = QmlAnnotMap.add_tsc_inst_opt (Q.QAnnot.expr e) tsc_inst_opt annotmap in
              annotmap, e
            with Not_found ->
              annotmap, e
      )

    | Q.Directive (_, `sliced_expr, [client;server], []) -> (
        match side with
        | `client -> aux tra annotmap client
        | `server -> aux tra annotmap server
      )

    (* when we meet a `fun_action directive, the function identifier is always the one of the client *)
    | Q.Directive (label, (`fun_action None as a), [e'], b) -> (
        match side with
        | `client -> tra annotmap e (* nothing special, we are already on the client *)
        | `server ->
            let annotmap, e' =
              match e' with
              | Q.Apply (label_apply, Q.Ident (label_ident, i), el) ->
                  let annotmap, el = List.fold_left_map (aux tra) annotmap el in
                  let i = IdentMap.find i rename_other in
                  annotmap, Q.Apply (label_apply, Q.Ident (label_ident, i), el)

              | _ ->
                  (*
these expressions are created by lambda lifting and must have these forms
*)
                  assert false
            in

            let e = Q.Directive (label, a, [e'], b) in
            annotmap, e
      )

    | Q.Directive (_, `fun_action _, _, _) -> assert false

    (* nothing to do *)
    | _ -> tra annotmap e
  in

  QmlAstWalk.Expr.traverse_foldmap aux annotmap e

let is_present side info =
  let on_the_ =
    match side with
    | `server -> (info.on_the_server :> client_code_kind option option)
    | `client -> info.on_the_client in
  match on_the_ with
  | None -> assert false
  | Some None -> false
  | Some (Some _) -> true

let is_a_lambda info =
  let rec aux = function
      (* this check should be kept consistent with the one in qmlUncurry presumably *)
    | Q.Coerce (_, e, _)
    | Q.Directive (_, #Q.type_directive, [e], _) -> aux e
    | Q.Lambda _ -> true
    | _ -> false in
  match info.expr with
  | External _ -> false (* do not generate stubs for functions from other packages! *)
  | Local e -> aux e

(* if a lambda is not present on our side, we pretend that is it
* just to be able to name the stub a(x) = @comet_call(a)(x)
* this way, when we have:
* @client f(x,y) = ... @typeof(x) ...
* g = f
* then, g will be an alias in both code which is necessary
* or else the two codes have the same set of functions
* but not the same set of closures (and you end up serializing non exiting functions)
*)
let name_stub side info =
  is_a_lambda info && (
    match side with
    | `client -> info.publish_on_the_server
    | `server -> info.publish_on_the_client
  )

let split_code ~gamma:_ ~annotmap_old env code =
  let _chrono_insert = Chrono.make () in
  let _chrono_copy = Chrono.make () in
  let _chrono = Chrono.make () in

  let update_map_with_tsc ~side i info map =
    let expr =
      match info.expr with
      | Local e -> e
      | External _ -> assert false in
    let tsc_opt = Option.map QmlTypes.Scheme.refresh (QmlAnnotMap.find_tsc_opt (Q.QAnnot.expr expr) env.annotmap) in
    (match side with
     | `client -> (
         match info.client_ident with
         | `undefined -> info.client_ident <- `tsc tsc_opt
         | `ident ident -> info.client_ident <- `ident_tsc (ident, tsc_opt)
         | `tsc _ | `ident_tsc _ -> assert false
       )
     | `server -> (
         match info.server_ident with
         | `undefined -> info.server_ident <- `tsc tsc_opt
         | `ident ident -> info.server_ident <- `ident_tsc (ident, tsc_opt)
         | `tsc _ | `ident_tsc _ -> assert false
       ));
    IdentMap.safe_add i tsc_opt map in
  let renaming_server, tsc_server =
    IdentTable.fold
      (fun i info (map,tsc_map) ->
         (* we check if we have a server ident before checking that [if_present `server info]
* because we may be in the case where [name_stub_server is true] *)
         match info.server_ident with
         | `undefined ->
             if is_present `server info || name_stub `server info then (
               let ident = Ident.refresh i in
               info.server_ident <- `ident ident;
               let tsc_map =
                 if info.publish_on_the_client then update_map_with_tsc ~side:`server i info tsc_map
                 else tsc_map in
               (IdentMap.safe_add i ident map, tsc_map)
             ) else
               (map, update_map_with_tsc ~side:`server i info tsc_map)
         | `tsc tsc_opt ->
             (map, IdentMap.safe_add i tsc_opt tsc_map)
         | `ident ident ->
             (IdentMap.safe_add i ident map, tsc_map)
         | `ident_tsc (ident, tsc_opt) ->
             (IdentMap.safe_add i ident map, IdentMap.safe_add i tsc_opt tsc_map)
      ) env.informations (IdentMap.empty, IdentMap.empty) in
  let renaming_client, tsc_client =
    IdentTable.fold
      (fun i info (map,tsc_map) ->
         match info.client_ident with
         | `undefined ->
             if is_present `client info || name_stub `client info then (
               let ident = Ident.refresh i in
               info.client_ident <- `ident ident;
               let tsc_map =
                 if info.publish_on_the_server then update_map_with_tsc ~side:`client i info tsc_map
                 else tsc_map in
               (IdentMap.safe_add i ident map, tsc_map)
             ) else
               (map, update_map_with_tsc ~side:`client i info tsc_map)
         | `tsc tsc_opt ->
             (map, IdentMap.safe_add i tsc_opt tsc_map)
         | `ident ident ->
             (IdentMap.safe_add i ident map, tsc_map)
         | `ident_tsc (ident, tsc_opt) ->
             (IdentMap.safe_add i ident map, IdentMap.safe_add i tsc_opt tsc_map)
      ) env.informations (IdentMap.empty,IdentMap.empty) in
  let rename_server i = IdentMap.find i renaming_server in
  let rename_client i = IdentMap.find i renaming_client in
  let alpha_conv_server = QmlAlphaConv.create_from_maps ~map:renaming_server ~revmap:IdentMap.empty in
  let renaming_map_server = QmlRenamingMap.from_map renaming_server in
  let renaming_map_client = QmlRenamingMap.from_map renaming_client in
  let find_server_name name = IdentMap.find_opt name renaming_server in
  let find_client_name name = IdentMap.find_opt name renaming_client in

  let insert_server annotmap e =
    insert_directives_expr
      ~infos:env.informations
      ~side:`server
      ~rename:renaming_server ~rename_other:renaming_client
      ~tsc:tsc_server
      ~annotmap e in
  let insert_client annotmap e =
    insert_directives_expr
      ~infos:env.informations
      ~side:`client
      ~rename:renaming_client ~rename_other:renaming_server
      ~tsc:tsc_client
      ~annotmap e in

  let annotmap,rev_code_client,rev_code_server,publish_rev_code_client,publish_rev_code_server,client_published,server_published =
    List.fold_left
      (fun (annotmap,rev_code_client,rev_code_server,publish_rev_code_client,publish_rev_code_server,client_publish,server_publish) code_elt ->
         match code_elt with
         | Q.NewVal (label,iel)
         | Q.NewValRec (label,iel) ->
             let rebuild =
               match code_elt with
               | Q.NewVal _ -> (fun x -> Q.NewVal (label, x))
               | Q.NewValRec _ -> (fun x -> Q.NewValRec (label, x))
               | _ -> assert false in
             let annotmap,more_server =
               List.fold_left_filter_map
                 (fun annotmap (i,e) ->
                    match IdentTable.find env.informations i with
                    | {on_the_server=Some (Some `expression); _} ->
                        #<If:SLICER_TIME> _chrono_copy.Chrono.start () #<End>;
                        let annotmap, e = QmlAstCons.TypedExpr.copy_new ~annotmap_old annotmap e in
                        #<If:SLICER_TIME> _chrono_copy.Chrono.stop () #<End>;
                        #<If:SLICER_TIME> _chrono_insert.Chrono.start () #<End>;
                        let annotmap, e = insert_server annotmap e in
                        #<If:SLICER_TIME> _chrono_insert.Chrono.stop () #<End>;
                        annotmap, Some (rename_server i, e)
                    | {on_the_server=Some (Some `alias | None); _} -> (
                        try
                          let server_name = rename_server i in
                          let client_name = rename_client i in
                          (* need to take the tsc last, because sometimes find will fail (on dbgen inserted idents)
* but in this cas, rename_server or rename_client would have failed earlier
* (because these idents are server private anyway) *)
                          assert (IdentMap.mem i tsc_server);
                          let tsc = IdentMap.find i tsc_server in
                          let annotmap, e =
                            eta_expand `comet_call ~gamma:env.gamma ~expr_for_annot:e ~annotmap_old ~annotmap ~tsc client_name in
                          annotmap, Some (server_name, e)
                        with Not_found ->
                          annotmap, None
                      )
                    | {on_the_server=None; _} -> assert false)
                 annotmap iel in
             let annotmap,more_client =
               List.fold_left_filter_map
                 (fun annotmap (i,e) ->
                    match IdentTable.find env.informations i with
                    | {on_the_client=Some (Some `expression); _} ->
                        #<If:SLICER_TIME> _chrono_copy.Chrono.start () #<End>;
                        let annotmap, e = QmlAstCons.TypedExpr.copy_new ~annotmap_old annotmap e in
                        #<If:SLICER_TIME> _chrono_copy.Chrono.stop () #<End>;
                        #<If:SLICER_TIME> _chrono_insert.Chrono.start () #<End>;
                        let annotmap, e = insert_client annotmap e in
                        #<If:SLICER_TIME> _chrono_insert.Chrono.stop () #<End>;
                        annotmap, Some (rename_client i,e)
                    | {on_the_client=Some (Some `insert_server_value); _} ->
                        let annotmap, e = make_dir ~annotmap_old ~inner:false (`insert_server_value (rename_server i)) annotmap e in
                        annotmap, Some (rename_client i,e)
                    | {on_the_client=Some (Some `alias | None); _} -> (
                        try
                          let client_name = rename_client i in
                          let server_name = rename_server i in
                          assert (IdentMap.mem i tsc_client);
                          let tsc = IdentMap.find i tsc_client in
                          let info = IdentTable.find env.informations i in
                          let sync = variant_of_async info.async in
                          let annotmap, e =
                            eta_expand (`ajax_call sync) ~gamma:env.gamma ~expr_for_annot:e ~annotmap_old ~annotmap ~tsc server_name in
                          annotmap, Some (client_name, e)
                        with Not_found ->
                          annotmap, None
                      )
                    | {on_the_client=None; _} -> assert false)
                 annotmap iel in
             let rev_code_server = if more_server = [] then rev_code_server else rebuild more_server :: rev_code_server in
             let rev_code_client = if more_client = [] then rev_code_client else rebuild more_client :: rev_code_client in
             (* FIXME: enough duplication! *)
             let annotmap, publish_rev_code_client, client_publish =
               List.fold_left
                 (fun ((annotmap, rev_code_client, client_publish) as acc) (i,_e) ->
                    let info = IdentTable.find env.informations i in
                    if info.publish_on_the_client then
                      let new_i = rename_client i in
                      let e = snd (List.find (fun (j,_) -> Ident.equal new_i j) more_client) in
                      let client_publish = IdentMap.add new_i None client_publish in
                      let annotmap, e = directive_publish new_i `comet_publish annotmap e in
                      let label = Annot.nolabel "QmlSimpleSlicer.rev_code_client" in
                      (annotmap, Q.NewVal (label, [Ident.refresh ~map:(fun s -> "skel_"^s) new_i, e]) :: rev_code_client, client_publish)
                    else acc
                 ) (annotmap, publish_rev_code_client, client_publish) iel in
             let annotmap, publish_rev_code_server, server_publish =
               List.fold_left
                 (fun ((annotmap, rev_code_server, server_publish) as acc) (i,_e) ->
                    let info = IdentTable.find env.informations i in
                    if info.publish_on_the_server then
                      let new_i = rename_server i in
                      let e = snd (List.find (fun (j,_) -> Ident.equal new_i j) more_server) in
                      let server_publish = IdentMap.add new_i None server_publish in
                      let sync = variant_of_async info.async in
                      let annotmap, e = directive_publish new_i (`ajax_publish sync) annotmap e in
                      let label = Annot.nolabel "QmlSimpleSlicer.rev_code_server" in
                      (annotmap, Q.NewVal (label, [Ident.refresh ~map:(fun s -> "skel_"^s) new_i, e]) :: rev_code_server, server_publish)
                    else acc
                 ) (annotmap, publish_rev_code_server, server_publish) iel in
             (annotmap,rev_code_client,rev_code_server,publish_rev_code_client,publish_rev_code_server,client_publish,server_publish)
         | _ -> assert false)
      (QmlAnnotMap.empty,[],[],[],[],IdentMap.empty,IdentMap.empty) code in
  #<If:SLICER_TIME> _chrono.Chrono.start () #<End>;
  let client = {
    code = List.rev (publish_rev_code_client @ rev_code_client);
    published = client_published;
    original_renaming = renaming_map_client;
    renaming = renaming_map_client;
  } in
  let server = {
    code = List.rev (publish_rev_code_server @ rev_code_server);
    published = server_published;
    original_renaming = renaming_map_server;
    renaming = renaming_map_server;
  } in
  let res =
    client,
    server,
    find_client_name,
    find_server_name,
    alpha_conv_server,
    annotmap in
  #<If:SLICER_TIME>
    let conv = _chrono.Chrono.read () in
    let copy = _chrono_copy.Chrono.read () in
    let insert = _chrono_insert.Chrono.read () in
    Printf.printf " copy:%fs\n insert:%fs\n conv:%fs\n" copy insert conv
  #<End>;
  res

let update_gamma ~rename_server ~rename_client gamma =
  QmlTypes.Env.Ident.fold
    (fun ident tsc new_gamma ->
       let new_gamma =
         match rename_server ident with
         | None -> new_gamma
         | Some server_ident -> QmlTypes.Env.Ident.add server_ident tsc new_gamma in
       let new_gamma =
         match rename_client ident with
         | None -> new_gamma
         | Some client_ident -> QmlTypes.Env.Ident.add client_ident tsc new_gamma in
       QmlTypes.Env.Ident.remove ident new_gamma) gamma gamma

let update_typer_env ~alpha_conv_server ~rename_server ~rename_client ~typer_env ~annotmap =
  let _chrono = Chrono.make () in
  (* updating ident -> tsc map with renamed (and duplicated) identifiers *)
  let gamma = typer_env.QmlTypes.gamma in
  #<If:SLICER_TIME> _chrono.Chrono.start () #<End>;
  let gamma = update_gamma ~rename_server ~rename_client gamma in
  (* updating the db schema with renamed Expression and new annots *)
  #<If:SLICER_TIME> Printf.printf " gamma: %fs\n%!" (_chrono.Chrono.read ()); _chrono.Chrono.restart () #<End>;
  let schema = typer_env.QmlTypes.schema in
  let _ = alpha_conv_server in
  (* FIXME: won't work if dbgen goes after slicing, but in the meantime this is very slow
let annotmap,schema = QmlDbGen.Schema.foldmap_expr
(fun annotmap e ->
let annotmap,e = QmlAstCons.TypedExpr.copy_new ~annotmap_old:typer_env.QmlTypes.annotmap annotmap e in
let e_renamed = QmlAlphaConv.expr alpha_conv_server e in
annotmap, e_renamed
) annotmap schema in*)
  #<If:SLICER_TIME> Printf.printf " schema: %fs\n%!" (_chrono.Chrono.read ()); _chrono.Chrono.restart () #<End>;
  {typer_env with
     QmlTypes.gamma = gamma;
     QmlTypes.annotmap = annotmap;
     QmlTypes.schema = schema}

let pp_constraint_ f c =
  Format.pp_print_string f (
    match c with
    | `expression -> "Expression"
    | `alias -> "Eta expansion"
    | `insert_server_value -> "Insert_server_value"
  )
let show_annotations env =
  let client, server_visible, server_not_visible =
    IdentTable.fold
      (fun i info (client, server_visible, server_not_visible) ->
         let client =
           match info.on_the_client with
           | Some (Some v) -> IdentMap.add i v client
           | _ -> client in
         let server_visible, server_not_visible =
           match info.on_the_server with
           | None -> assert false
           | Some None -> server_visible, server_not_visible
           | Some (Some v) ->
               if info.publish_on_the_server then
                 IdentSet.add i server_visible, server_not_visible
               else
                 server_visible, IdentMap.add i v server_not_visible in
         (client, server_visible, server_not_visible)
      ) env.informations (IdentMap.empty,IdentSet.empty,IdentMap.empty) in
  let pn = ObjectFiles.get_current_package_name () in
  let show_set set =
    let elts = IdentSet.elements set in
    let names = List.filter_map
      (fun a ->
         match Ident.safe_get_package_name a with
         | Some pn2 when pn2 = pn -> Some (Ident.original_name a)
         | _ -> None
      )
      elts in
    let sorted_names = List.sort compare names in
    List.iter (Format.printf " %s\n") sorted_names in
  let show_map p map =
    let l = IdentMap.to_list map in
    let l = List.filter_map
      (fun (a,b) ->
         match Ident.safe_get_package_name a with
         | Some pn2 when pn2 = pn -> Some (Ident.original_name a,b)
         | _ -> None
      )
      l in
    let l = List.sort compare l in
    List.iter (fun (a,b) -> Format.printf " %s->%a\n" a p b) l in
  Format.printf "Server private:\n"; show_map pp_constraint_ server_not_visible;
  Format.printf "Server public:\n"; show_set server_visible;
  Format.printf "Client:\n"; show_map pp_constraint_ client;
  Format.printf "%!"

let whole_check env code =
  let check_binding (i,_) =
     let node = IdentTable.find env.informations i in
     let _ = check_node ~emit:true node in
     ()
  in
  QmlAstWalk.Code.iter_binding check_binding code

let dump_annotations env code =
  match ObjectFiles.compilation_mode () with
  | `init -> ()
  | `compilation | `linking | `prelude ->
  let filename =
    Filename.concat (ObjectFiles.get_compilation_directory_or_current_dir ()) "slicer.dump" in
  let channel = open_out filename in
  let f = Format.formatter_of_out_channel channel in
  QmlAstWalk.Code.iter_binding (fun (i,_) ->
    let info = IdentTable.find env.informations i in
    let both = match info with
      | {on_the_server = Some (Some `expression); on_the_client = Some (Some `expression); _} -> true
      | _ -> false
    in
    let fprintf form = Format.fprintf f form in
    (* if boring (i.e. both) we print nothing *)
    (if both then () else
      fprintf "@[<v>%a@]@\n@[<2> %s is %s@]@\n"
      pp_pos info
      (Ident.original_name i)
      (match info with
       | {on_the_server = None; _}
       | {on_the_client = None; _}
       | {on_the_server = Some None; on_the_client = Some None; _} -> assert false
       | {on_the_server = Some None; on_the_client = Some (Some k); _} ->
           (match k with
            | `expression -> "client only"
            | `insert_server_value | `alias -> assert false)
       | {on_the_server = Some (Some k); on_the_client = Some None; _} ->
           (match k with
            | `expression -> "server only"
            | `alias -> assert false)
       | {on_the_server = Some (Some s); on_the_client = Some (Some c); _} ->
           match s, c with
           | `alias, (`alias | `insert_server_value) -> assert false
           | `alias, `expression -> "server(alias) and client"
           | `expression, `expression -> "server and client"
           | `expression, `alias -> "server and client(alias)"
           | `expression, `insert_server_value -> "server and client(insert_server_value)")
      (* TODO: reimplement the printing of the distant calls *)
      (*
name , location , ...
[name , side , ...]
[name , server_api]
[name , client_api]
[name , remote_call , ...]
[name , private_call, ...]
*)
    );
    let (|>) a f = f a in
    let side_of info = match Option.get(info.on_the_server),Option.get(info.on_the_client) with
      | Some `expression, Some `expression -> "both"
      | _ , Some `expression -> "client"
      | Some `expression, None -> "server"
      | _ -> "unknown"
    in
    let name i =
      Printf.sprintf "%s[%s]"
        (Ident.original_name i)
        (Ident.get_package_name i)
    in
    let side = side_of info in
    let remote_call =
      G.succ env.call_graph info
      |> List.filter (fun (i:information) ->
        let side_of_i = side_of i in side_of_i <> side && side_of_i <> "both"
        )
      |> List.map (fun i->name i.ident)
    in
    if side<>"both" || remote_call <> [] then (
      let get_bypass o = match o with
        | None -> []
        | Some bp -> [Format.sprintf "%a" BslKey.pp bp]
      in
      let get_private = match info.calls_private with
        | Some (Local infobis) when not(Ident.equal infobis.ident info.ident)-> [name infobis.ident]
        | Some (External _) -> ["EXTERNAL"]
        | _ -> []
      in
      let private_call = get_private
                       @ (get_bypass info.calls_client_bypass)
                       @ (get_bypass info.calls_server_bypass)
      in
      let name = name info.ident in
      fprintf "%s , location , %a\n" name pp_pos info;
      if side<>"both" then fprintf "%s , side , %s\n" name side;
      if info.publish_on_the_server then fprintf "%s , server_api\n" name;
      if info.publish_on_the_client then fprintf "%s , client_api\n" name;
      if remote_call <> [] then
      fprintf "%s , remote_call , %a\n" name (Format.pp_list " " Format.pp_print_string) remote_call;
      if private_call <> [] then
      fprintf "%s , private_call, %a\n" name (Format.pp_list " " Format.pp_print_string) private_call;
      ()
      )
  ) code;
  Format.pp_print_flush f ();
  close_out channel

module S =
struct
  type t = information list
  let pass = "pass_Slicing"
  let pp f l =
    Format.fprintf f "@[<v>%a@]" (Format.pp_list "@ " pp_info) l
end

module R =
struct
  include ObjectFiles.Make(S)
  let save env =
    let current_package = ObjectFiles.get_current_package () in
    let externalize_info info =
      info.expr <- External current_package;
      match info.calls_private with
      | None -> ()
      | Some (Local _) -> info.calls_private <- Some (External current_package)
      | Some (External _) -> assert false in
    let t = IdentTable.fold
      (fun _ident info acc ->
         match info.expr with
         | External _ -> acc
         | Local _ -> externalize_info info; info :: acc)
      env.informations [] in
    save t
  let refresh_opt _side _info package = function
    | None -> None
    | Some tsc ->
        let tsc2 = QmlRefresh.refresh_typevars_from_tsc package tsc in
        (*Format.printf "@[<2>REFRESH SLICER %s %s: %a -> %a@]@." _side (Ident.to_string _info.ident) QmlPrint.pp_base#tsc tsc QmlPrint.pp_base#tsc tsc2;*)
        Some tsc2
  let load env =
    let informations = env.informations in
    let call_graph = env.call_graph in
    iter_with_name
      (fun package infos ->
         List.iter
           (fun info ->
              (* BEWARE: do not modify this info, or else you screw the value memoized in objectFiles *)
              (* damned, cannot simply copy a record *)
              let info = {info with ident = info.ident} in
              (match info.server_ident with
               | `ident _ -> ()
               | `undefined -> assert false
               | `tsc tsc_opt -> info.server_ident <- `tsc (refresh_opt "SERVER" info package tsc_opt)
               | `ident_tsc (ident, tsc_opt) -> info.server_ident <- `ident_tsc (ident, refresh_opt "SERVER" info package tsc_opt));
              (match info.client_ident with
               | `ident _ -> ()
               | `undefined -> assert false
               | `tsc tsc_opt -> info.client_ident <- `tsc (refresh_opt "CLIENT" info package tsc_opt)
               | `ident_tsc (ident, tsc_opt) -> info.client_ident <- `ident_tsc (ident, refresh_opt "CLIENT" info package tsc_opt));
              IdentTable.add informations info.ident info;
              G.add_vertex call_graph info;
           ) infos
      )
end

let process_code ~test_mode ~dump ~typer_env ~stdlib_gamma
    ~client_bsl_lang ~server_bsl_lang ~bymap
    ~code =
  let env = empty_env ~client_bsl_lang ~server_bsl_lang bymap typer_env in
  let _chrono = Chrono.make () in
  #<If:SLICER_TIME> _chrono.Chrono.start () #<End>;
  R.load env;
  #<If:SLICER_TIME> Printf.printf "load_env: %fs\n%!" (_chrono.Chrono.read ()); _chrono.Chrono.restart () #<End>;
  let env, code = initialize_env ~env code in
  #<If:SLICER_TIME> Printf.printf "initialize_env: %fs\n%!" (_chrono.Chrono.read ()); _chrono.Chrono.restart () #<End>;
  inline_informations_lambda_lifted env;
  #<If:SLICER_TIME> Printf.printf "inline_informations_lambda_lifted: %fs\n%!" (_chrono.Chrono.read ()); _chrono.Chrono.restart () #<End>;
  propagate_server_private env;
  #<If:SLICER_TIME> Printf.printf "propagate_server_private: %fs\n%!" (_chrono.Chrono.read ()); _chrono.Chrono.restart () #<End>;
  analyse_side_effects env code;
  #<If:SLICER_TIME> Printf.printf "analyse_side_effects: %fs\n%!" (_chrono.Chrono.read ()); _chrono.Chrono.restart () #<End>;
  choose_sides env;
  #<If:SLICER_TIME> Printf.printf "choose_sides: %fs\n%!" (_chrono.Chrono.read ()); _chrono.Chrono.restart () #<End>;
  whole_check env code;
  if dump then (
    dump_annotations env code
  );
  if test_mode then (
    OManager.flush_errors (); (* not to dump the annotations when an error happened, for compatibility with the previous version of the slicer *)
    show_annotations env;
    exit 0
  );
  let client,
      server,
      rename_client,
      rename_server,
      alpha_conv_server,
      annotmap =
    split_code ~gamma:env.gamma ~annotmap_old:env.annotmap env code in
  #<If:SLICER_TIME> Printf.printf "split_code: %fs\n%!" (_chrono.Chrono.read ()); _chrono.Chrono.restart () #<End>;
  R.save env;
  let typer_env = update_typer_env ~alpha_conv_server ~rename_server ~rename_client ~typer_env ~annotmap in
  let stdlib_gamma = update_gamma ~rename_server ~rename_client stdlib_gamma in
  #<If:SLICER_TIME> Printf.printf "update_typer_env: %fs\n%!" (_chrono.Chrono.read ()); _chrono.Chrono.restart () #<End>;
  stdlib_gamma, typer_env,client,server
Something went wrong with that request. Please try again.