Files
@ af490fef2ca9
Branch filter:
Location: workgroups2/src/workgroups2.el
af490fef2ca9
174.6 KiB
text/x-elisp
More informative messages + some checks
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 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 3811 3812 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 3874 3875 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 3899 3900 3901 3902 3903 3904 3905 3906 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 3920 3921 3922 3923 3924 3925 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 3951 3952 3953 3954 3955 3956 3957 3958 3959 3960 3961 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 3984 3985 3986 3987 3988 3989 3990 3991 3992 3993 3994 3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 4005 4006 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 4017 4018 4019 4020 4021 4022 4023 4024 4025 4026 4027 4028 4029 4030 4031 4032 4033 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 4097 4098 4099 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 4114 4115 4116 4117 4118 4119 4120 4121 4122 4123 4124 4125 4126 4127 4128 4129 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 4143 4144 4145 4146 4147 4148 4149 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 4160 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 4173 4174 4175 4176 4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 4189 4190 4191 4192 4193 4194 4195 4196 4197 4198 4199 4200 4201 4202 4203 4204 4205 4206 4207 4208 4209 4210 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 4230 4231 4232 4233 4234 4235 4236 4237 4238 4239 4240 4241 4242 4243 4244 4245 4246 4247 4248 4249 4250 4251 4252 4253 4254 4255 4256 4257 4258 4259 4260 4261 4262 4263 4264 4265 4266 4267 4268 4269 4270 4271 4272 4273 4274 4275 4276 4277 4278 4279 4280 4281 4282 4283 4284 4285 4286 4287 4288 4289 4290 4291 4292 4293 4294 4295 4296 4297 4298 4299 4300 4301 4302 4303 4304 4305 4306 4307 4308 4309 4310 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 4323 4324 4325 4326 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 4351 4352 4353 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 4364 4365 4366 4367 4368 4369 4370 4371 4372 4373 4374 4375 4376 4377 4378 4379 4380 4381 4382 4383 4384 4385 4386 4387 4388 4389 4390 4391 4392 4393 4394 4395 4396 4397 4398 4399 4400 4401 4402 4403 4404 4405 4406 4407 4408 4409 4410 4411 4412 4413 4414 4415 4416 4417 4418 4419 4420 4421 4422 4423 4424 4425 4426 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 4445 4446 4447 4448 4449 4450 4451 4452 4453 4454 4455 4456 4457 4458 4459 4460 4461 4462 4463 4464 4465 4466 4467 4468 4469 4470 4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 4486 4487 4488 4489 4490 4491 4492 4493 4494 4495 4496 4497 4498 4499 4500 4501 4502 4503 4504 4505 4506 4507 4508 4509 4510 4511 4512 4513 4514 4515 4516 4517 4518 4519 4520 4521 4522 4523 4524 4525 4526 4527 4528 4529 4530 4531 4532 4533 4534 4535 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 4546 4547 4548 4549 4550 4551 4552 4553 4554 4555 4556 4557 4558 4559 4560 4561 4562 4563 4564 4565 4566 4567 4568 4569 4570 4571 4572 4573 4574 4575 4576 4577 4578 4579 4580 4581 4582 4583 4584 4585 4586 4587 4588 4589 4590 4591 4592 4593 4594 4595 4596 4597 4598 4599 4600 4601 | ;;; workgroups2.el --- New workspaces for Emacs
;;; -*- coding: utf-8; lexical-binding: t -*-
;;
;; Copyright (C) 2013-2014 Sergey Pashinin
;; Copyright (C) 2010-2011 tlh
;;
;; Author: Sergey Pashinin <sergey at pashinin dot com>
;; Keywords: session management window-configuration persistence
;; Homepage: https://github.com/pashinin/workgroups2
;; Version: 1.2.0
;; Package-Requires: ((cl-lib "0.4") (dash "2.8.0") (anaphora "1.0.0") (f "0.17"))
;;
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2 of the License, or (at
;; your option) any later version.
;;
;; This program 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
;; General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
;; USA
;;
;;; Commentary:
;;
;; Workgroups2 is an Emacs session manager. It is based on the
;; experimental branch of the original "workgroups" extension.
;;
;; If you find a bug - please post it here:
;; https://github.com/pashinin/workgroups2/issues
;;
;;
;; Install
;; ----------------------
;; See the README.md file at: https://github.com/pashinin/workgroups2
;; Add the lines below to your .emacs configuration.
;;
;; (require 'workgroups2)
;;
;; <settings here>
;;
;; (workgroups-mode 1) ; put this one at the bottom of .emacs
;;
;;
;; Configure
;; ----------------------
;; ;; Change prefix key (before activating WG)
;; (setq wg-prefix-key (kbd "C-c z"))
;;
;; ;; Change workgroups session file
;; (setq wg-session-file "~/.emacs.d/.emacs_workgroups"
;;
;; ;; Set your own keyboard shortcuts to reload/save/switch WG:
;; (global-set-key (kbd "<pause>") 'wg-reload-session)
;; (global-set-key (kbd "C-S-<pause>") 'wg-save-session)
;; (global-set-key (kbd "s-z") 'wg-switch-to-workgroup)
;; (global-set-key (kbd "s-/") 'wg-switch-to-previous-workgroup)
;;
;;
;; Use
;; ----------------------
;; Most commands start with prefix `wg-prefix-key'.
;; You can change it before activating workgroups.
;; By default prefix is: "C-c z"
;;
;; <prefix> <key>
;;
;; <prefix> c - create workgroup
;; <prefix> A - rename workgroup
;; <prefix> k - kill workgroup
;; <prefix> v - switch to workgroup
;; <prefix> C-s - save session
;; <prefix> C-f - load session
;;
;;
;; Help
;; ----------------------
;; Type "<prefix> ?" for more help
;;
;; See also: https://github.com/pashinin/workgroups2/wiki
;;
;;; Code:
(require 'cl-lib)
(require 'f)
(require 'dash)
(require 'ring)
(require 'anaphora)
(defconst wg-version "1.2.0" "Current version of Workgroups.")
(defgroup workgroups nil
"Workgroups for Emacs -- Emacs session manager"
:group 'convenience)
(defcustom wg-session-file "~/.emacs_workgroups"
"Default filename to be used to save workgroups."
:type 'file
:group 'workgroups)
(defvaralias 'wg-default-session-file 'wg-session-file)
(defcustom wg-prefix-key (kbd "C-c z")
"Workgroups' prefix key.
Setting this variable requires that `workgroups-mode' be turned
off and then on again to take effect."
:type 'string
:group 'workgroups)
(defvar workgroups-mode-map nil "Workgroups Mode's keymap.")
(defvar wg-incorrectly-restored-bufs nil
"FIXME: docstring this.")
;; TODO: check it on switching WG
(defvar wg-record-incorrectly-restored-bufs nil
"FIXME: docstring this.")
(defvar wg-log-level 1
"Use later.
0 means no messages at all (for tests)")
(defcustom wg-emacs-exit-save-behavior 'save
"Determines save behavior on Emacs exit.
`ask' Ask the user whether to save if there are unsaved changes
`save' Call `wg-save-session' when there are unsaved changes
Anything else Exit Emacs without saving changes"
:type 'symbol
:group 'workgroups)
(defcustom wg-workgroups-mode-exit-save-behavior 'save
"Determines save behavior on `workgroups-mode' exit.
`ask' Ask the user whether to saveif there are unsaved changes
`save' Call `wg-save-session' when there are unsaved changes
Anything else Exit `workgroups-mode' without saving changes"
:type 'symbol
:group 'workgroups)
(defcustom wg-session-load-on-start (not (daemonp))
"Load a session file on Workgroups start.
Don't do it with Emacs --daemon option."
:type 'boolean
:group 'workgroups)
(defvaralias 'wg-use-default-session-file 'wg-session-load-on-start)
(defcustom workgroups-mode nil
"Non-nil if Workgroups mode is enabled."
:set 'custom-set-minor-mode
:initialize 'custom-initialize-default
:group 'workgroups
:type 'boolean)
(defcustom wg-first-wg-name "First workgroup"
"Title of the first workgroup created."
:type 'string
:group 'workgroups)
(defcustom wg-modeline-string " wg"
"Appears in modeline."
:type 'string
:group 'workgroups)
(defcustom wg-mode-line-display-on (not (featurep 'powerline))
"Toggles Workgroups' mode-line display."
:type 'boolean
:group 'workgroups
:set (lambda (sym val)
(custom-set-default sym val)
(force-mode-line-update)))
(defcustom wg-mode-line-use-faces nil
"Non-nil means use faces in the mode-line display.
It can be tricky to choose faces that are visible in both active
and inactive mode-lines, so this feature defaults to off."
:type 'boolean
:group 'workgroups)
(defcustom wg-mode-line-decor-left-brace "("
"String displayed at the left of the mode-line display."
:type 'string
:group 'workgroups)
(defcustom wg-mode-line-decor-right-brace ")"
"String displayed at the right of the mode-line display."
:type 'string
:group 'workgroups)
(defcustom wg-mode-line-decor-divider ":"
"String displayed between elements of the mode-line display."
:type 'string
:group 'workgroups)
(defcustom wg-mode-line-decor-window-dedicated
#("#" 0 1 (help-echo "This window is dedicated to its buffer."))
"Indicates that the window is dedicated to its buffer."
:type 'string
:group 'workgroups)
(defcustom wg-mode-line-decor-window-undedicated
#("-" 0 1 (help-echo "This window is not dedicated to its buffer."))
"Indicates that the window is not dedicated to its buffer."
:type 'string
:group 'workgroups)
(defcustom wg-mode-line-decor-session-modified
#("*" 0 1 (help-echo "The session is modified"))
"Indicates that the session is modified."
:type 'string
:group 'workgroups)
(defcustom wg-mode-line-decor-session-unmodified
#("-" 0 1 (help-echo "The session is unmodified"))
"Indicates that the session is unmodified."
:type 'string
:group 'workgroups)
(defcustom wg-mode-line-decor-workgroup-modified
#("*" 0 1 (help-echo "The current workgroup is modified"))
"Indicates that the current workgroup is modified."
:type 'string
:group 'workgroups)
(defcustom wg-mode-line-decor-workgroup-unmodified
#("-" 0 1 (help-echo "The current workgroup is unmodified"))
"Indicates that the current workgroup is unmodified."
:type 'string
:group 'workgroups)
(defcustom wg-load-last-workgroup t
"Load last active (not first) workgroup from all your workgroups if it exists."
:group 'workgroups
:type 'boolean)
(defcustom wg-control-frames t
"Save/restore frames."
:group 'workgroups
:type 'boolean)
(defcustom workgroups-mode-hook nil
"Hook run when `workgroups-mode' is turned on."
:type 'hook
:group 'workgroups)
(defcustom workgroups-mode-exit-hook nil
"Hook run when `workgroups-mode' is turned off."
:type 'hook
:group 'workgroups)
(defcustom wg-before-switch-to-workgroup-hook nil
"Hook run by `wg-switch-to-workgroup'."
:type 'hook
:group 'workgroups)
(defcustom wg-after-switch-to-workgroup-hook nil
"Hook run by `wg-switch-to-workgroup'."
:type 'hook
:group 'workgroups)
(define-obsolete-variable-alias 'wg-switch-to-workgroup-hook 'wg-after-switch-to-workgroup-hook)
(defcustom wg-pre-window-configuration-change-hook nil
"Hook run before any function that triggers `window-configuration-change-hook'."
:type 'hook
:group 'workgroups)
(defcustom wg-open-this-wg nil
"Try to open this workgroup on start.
If nil - nothing happens."
:type 'string
:group 'workgroups)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; FIXME:
;;
;; Only set `wg-workgroup-base-wconfig' on `wg-save-session-as' or
;; `delete-frame' and only with the most recently changed working-wconfig.
;; Then, since it's not overwritten on every call to
;; `wg-workgroup-working-wconfig', its restoration can be retried after manually
;; recreating buffers that couldn't be restored. So it takes over the
;; 'incorrect restoration' portion of the base wconfig's duty. All that leaves
;; to base wconfigs is that they're a saved wconfig the user felt was important.
;; So why not allow more of of them? A workgroup could stash an unlimited
;; number of wconfigs.
;;
;; TODO:
;;
;; * Write new commands for restoring stashed wconfigs
;;
;; * Add this message on improper restoration of `base-wconfig':
;;
;; "Unable to restore 'buf1', 'buf2'... Hit C-whatever to retry after
;; manually recreating these buffers."
;;
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; TODO: possibly add `buffer-file-coding-system', `text-scale-mode-amount'
(defcustom wg-buffer-local-variables-alist
`((major-mode nil wg-deserialize-buffer-major-mode)
(mark-ring wg-serialize-buffer-mark-ring wg-deserialize-buffer-mark-ring)
(left-fringe-width nil nil)
(right-fringe-width nil nil)
(fringes-outside-margins nil nil)
(left-margin-width nil nil)
(right-margin-width nil nil)
(vertical-scroll-bar nil nil))
"Alist mapping buffer-local variable symbols to serdes functions.
The `car' of each entry should be a buffer-local variable symbol.
The `cadr' of the entry should be either nil or a function of no
arguments. If nil, the variable's value is used as-is, and
should have a readable printed representation. If a function,
`funcall'ing it should yield a serialization of the value of the
variable.
The `caddr' of the entry should be either nil or a function of
one argument. If nil, the serialized value from above is
assigned to the variable as-is. It a function, `funcall'ing it
on the serialized value from above should do whatever is
necessary to properly restore the original value of the variable.
For example, in the case of `major-mode' it should funcall the
value (a major-mode function symbol) rather than just assigning
it to `major-mode'."
:type 'alist
:group 'workgroups)
(defcustom wg-nowg-string "No workgroups"
"Display this string if there are no workgroups and
`wg-display-nowg' is t."
:type 'string
:group 'workgroups)
(defcustom wg-display-nowg nil
"Display something if there are no workgroups."
:type 'boolean
:group 'workgroups)
(defcustom wg-restore-remote-buffers t
"Restore buffers that get \"t\" with `file-remote-p'."
:type 'boolean
:group 'workgroups)
(defcustom wg-restore-frame-position t
"Non-nil means restore frame position on workgroup restore."
:type 'boolean
:group 'workgroups)
(defcustom wg-restore-scroll-bars t
"Non-nil means restore scroll-bar settings on workgroup restore."
:type 'boolean
:group 'workgroups)
(defcustom wg-restore-fringes t
"Non-nil means restore fringe settings on workgroup restore."
:type 'boolean
:group 'workgroups)
(defcustom wg-restore-margins t
"Non-nil means restore margin settings on workgroup restore."
:type 'boolean
:group 'workgroups)
(defcustom wg-restore-point t
"Non-nil means restore `point' on workgroup restore.
This is included mainly so point restoration can be suspended
during `wg-morph' -- you probably want this non-nil."
:type 'boolean
:group 'workgroups)
(defcustom wg-restore-point-max t
"Controls point restoration when point is at `point-max'.
If `point' is at `point-max' when a wconfig is created, put
`point' back at `point-max' when the wconfig is restored, even if
`point-max' has increased in the meantime. This is useful in,
say, irc buffers where `point-max' is constantly increasing."
:type 'boolean
:group 'workgroups)
(defcustom wg-restore-mark t
"Non-nil means restore mark data on workgroup restore."
:type 'boolean
:group 'workgroups)
(defcustom wg-restore-window-dedicated-p t
"Non-nil means restore `window-dedicated-p' on workgroup restore."
:type 'boolean
:group 'workgroups)
(defcustom wg-remember-frame-for-each-wg nil
"When switching workgroups - restore frame parameters for each workgroup.
When nil - save/restore frame parameters to/from the first workgroup."
:type 'boolean
:group 'workgroups)
(defcustom wg-wconfig-undo-list-max 20
"Number of past window configs to retain for undo."
:type 'integer
:group 'workgroups)
(defcustom wg-wconfig-kill-ring-max 20
"Maximum length of the `wg-wconfig-kill-ring'."
:type 'integer
:group 'workgroups)
(defvar wg-wconfig-kill-ring nil
"Ring of killed or kill-ring-saved wconfigs.")
(defvar wg-buffer-uid nil
"Symbol for the current buffer's wg-buf's uid.
Every Workgroups buffer object (wg-buf) has a uid. When
Workgroups creates or encounters an Emacs buffer object
corresponding to a wg-buf, it tags it with the wg-buf's uid to
unambiguously pair the two.")
(make-variable-buffer-local 'wg-buffer-uid)
(defcustom wg-flag-modified t
"Show \"modified\" flags in modeline."
:type 'boolean
:group 'workgroups
:set (lambda (sym val)
(custom-set-default sym val)
(force-mode-line-update)))
(defvar wg-window-configuration-changed nil
"Flag set by `window-configuration-change-hook'.")
(defvar wg-already-updated-working-wconfig nil
"Flag set by `wg-update-working-wconfig-hook'.")
(defvar wg-undoify-window-configuration-change t
"Should windows undo info be updated or not.
When you change window configuration.")
(defvar wg-current-workgroup nil "Bound to the current workgroup.")
(defvar wg-window-min-width 2
"Bound to `window-min-width' when restoring wtrees.")
(defvar wg-window-min-height 1
"Bound to `window-min-height' when restoring wtrees.")
(defvar wg-window-min-pad 2
"Added to `wg-window-min-foo' to produce the actual minimum window size.")
(defvar wg-actual-min-width (+ wg-window-min-width wg-window-min-pad)
"Actual minimum window width when creating windows.")
(defvar wg-actual-min-height (+ wg-window-min-height wg-window-min-pad)
"Actual minimum window height when creating windows.")
(defvar wg-min-edges `(0 0 ,wg-actual-min-width ,wg-actual-min-height)
"Smallest allowable edge list of windows created by Workgroups.")
(defvar wg-null-edges '(0 0 0 0) "Null edge list.")
(defvar wg-window-tree-selected-window nil
"Used during wconfig restoration to hold the selected window.")
(defvar wg-buffer-workgroup nil
"A workgroup in which this buffer most recently appeared.
Buffer-local.")
(make-variable-buffer-local 'wg-buffer-workgroup)
(defcustom wg-default-buffer "*scratch*"
"Show this in case everything else fails.
When a buffer can't be restored, when creating a blank wg."
:type 'string
:group 'workgroups)
;;
;; Crazy stuff...
;;
(defcustom wg-associate-blacklist (list "*helm mini*" "*Messages*" "*scratch*"
"*helm action*")
"Do not autoassociate these buffers."
:type 'list
:group 'workgroups)
(defconst wg-buffer-list-original (symbol-function 'buffer-list))
(fset 'wg-buffer-list-emacs wg-buffer-list-original)
(defun buffer-list (&optional frame)
"Redefinition of `buffer-list'.
Pass FRAME to it.
Remove file and dired buffers that are not associated with workgroup."
(let ((res (wg-buffer-list-emacs frame))
(wg-buf-uids (wg-workgroup-associated-buf-uids)))
(--remove (and (or (buffer-file-name it)
(eq (buffer-local-value 'major-mode it) 'dired-mode))
;;(not (member b wg-buffers))
(not (member (wg-buffer-uid-or-add it) wg-buf-uids)))
res)))
(defconst wg-buffer-list-function (symbol-function 'buffer-list))
(fset 'buffer-list wg-buffer-list-original)
;; locate-dominating-file
(defcustom wg-mess-with-buffer-list nil
"Redefine `buffer-list' to show buffers for each workgroup.
Crazy stuff that allows to reduce amount of code, gives new
features but is fucking unstable, so disabled by default"
:type 'boolean
:group 'workgroups
:set (lambda (sym val)
(custom-set-default sym val)
(if (and workgroups-mode val)
(fset 'buffer-list wg-buffer-list-function)
(fset 'buffer-list wg-buffer-list-original))))
(fset 'buffer-list wg-buffer-list-original)
(defcustom wg-use-faces t
"Non-nil means use faces in various messages."
:type 'boolean
:group 'workgroups)
(defcustom wg-list-display-decor-left-brace "( "
"String displayed to the left of the list display."
:type 'string
:group 'workgroups)
(defcustom wg-list-display-decor-right-brace " )"
"String displayed to the right of the list display."
:type 'string
:group 'workgroups)
(defcustom wg-list-display-decor-divider " | "
"String displayed between elements of the list display."
:type 'string
:group 'workgroups)
(defcustom wg-list-display-decor-current-left "-<{ "
"String displayed to the left of the current element of the list display."
:type 'string
:group 'workgroups)
(defcustom wg-list-display-decor-current-right " }>-"
"String displayed to the right of the current element of the list display."
:type 'string
:group 'workgroups)
(defcustom wg-list-display-decor-previous-left "< "
"String displayed to the left of the previous element of the list display."
:type 'string
:group 'workgroups)
(defcustom wg-list-display-decor-previous-right " >"
"String displayed to the right of the previous element of the list display."
:type 'string
:group 'workgroups)
(defvar wg-face-abbrevs nil
"Assoc list mapping face abbreviations to face names.")
(defmacro wg-defface (face key spec doc &rest args)
"`defface' wrapper adding a lookup key used by `wg-fontify'."
(declare (indent 2))
`(progn
(cl-pushnew (cons ,key ',face) wg-face-abbrevs :test #'equal)
(defface ,face ,spec ,doc ,@args)))
(wg-defface wg-current-workgroup-face :cur
'((t :inherit font-lock-constant-face :bold nil))
"Face used for current elements in list displays."
:group 'workgroups)
(wg-defface wg-previous-workgroup-face :prev
'((t :inherit font-lock-keyword-face :bold nil))
"Face used for the name of the previous workgroup in the list display."
:group 'workgroups)
(wg-defface wg-other-workgroup-face :other
'((t :inherit font-lock-string-face :bold nil))
"Face used for the names of other workgroups in the list display."
:group 'workgroups)
(wg-defface wg-command-face :cmd
'((t :inherit font-lock-function-name-face :bold nil))
"Face used for command/operation strings."
:group 'workgroups)
(wg-defface wg-divider-face :div
'((t :inherit font-lock-builtin-face :bold nil))
"Face used for dividers."
:group 'workgroups)
(wg-defface wg-brace-face :brace
'((t :inherit font-lock-builtin-face :bold nil))
"Face used for left and right braces."
:group 'workgroups)
(wg-defface wg-message-face :msg
'((t :inherit font-lock-string-face :bold nil))
"Face used for messages."
:group 'workgroups)
(wg-defface wg-mode-line-face :mode
'((t :inherit font-lock-doc-face :bold nil))
"Face used for workgroup position and name in the mode-line display."
:group 'workgroups)
(wg-defface wg-filename-face :file
'((t :inherit font-lock-keyword-face :bold nil))
"Face used for filenames."
:group 'workgroups)
;;; fancy displays
(defun wg-element-display (elt elt-string &optional current-elt-p previous-elt-p)
"Return display string for ELT."
(cond ((and current-elt-p (funcall current-elt-p elt))
(wg-fontify (:cur (concat wg-list-display-decor-current-left
elt-string
wg-list-display-decor-current-right))))
((and previous-elt-p (funcall previous-elt-p elt))
(wg-fontify (:prev (concat wg-list-display-decor-previous-left
elt-string
wg-list-display-decor-previous-right))))
(t (wg-fontify (:other elt-string)))))
(defun wg-workgroup-display (workgroup index)
"Return display string for WORKGROUP at INDEX."
(if (not workgroup) wg-nowg-string
(wg-element-display
workgroup
(format "%d: %s" index (wg-workgroup-name workgroup))
'wg-current-workgroup-p
'wg-previous-workgroup-p)))
(defun wg-buffer-display (buffer index)
"Return display string for BUFFER. INDEX is ignored."
(if (not buffer) "No buffers"
(wg-element-display
(wg-get-buffer buffer)
(format "%s" (wg-buffer-name buffer))
'wg-current-buffer-p)))
(defun wg-message (format-string &rest args)
"Call `message' with FORMAT-STRING and ARGS."
(if (> wg-log-level 0) (apply #'message format-string args)))
(defmacro wg-fontified-message (&rest format)
"`wg-fontify' FORMAT and call `wg-message' on it."
(declare (indent defun))
`(wg-message (wg-fontify ,@format)))
(defun wg-add-face (facekey string)
"Return a copy of STRING fontified according to FACEKEY.
FACEKEY must be a key in `wg-face-abbrevs'."
(let ((face (wg-aget wg-face-abbrevs facekey))
(string (copy-sequence string)))
(unless face (error "No face with key %s" facekey))
(if (not wg-use-faces) string
(put-text-property 0 (length string) 'face face string)
string)))
(defmacro wg-fontify (&rest specs)
"A small fontification DSL.
The results of all SPECS are `concat'd together.
If a spec is a cons with a keyword car, apply `wg-add-face' to it.
Other conses get evaluated, and should produce a strings.
If a spec is a string it is used unmodified.
Anything else is formatted with %s to produce a string."
(declare (indent defun))
`(concat
,@(wg-docar (spec specs)
(cond ((and (consp spec)
(keywordp (car spec)))
`(wg-add-face ,@spec))
;;((listp spec) (cdr (eval spec)))
;;((listp spec)
;; ;;(prin1-to-string (nth 1 (eval spec)))
;; )
((consp spec) spec)
((stringp spec) spec)
(t `(format "%s" ,spec))))))
(defmacro wg-with-gensyms (syms &rest body)
"Bind all symbols in SYMS to `gensym's, and eval BODY."
(declare (indent 1))
`(let (,@(mapcar (lambda (sym) `(,sym (cl-gensym))) syms)) ,@body))
(defmacro wg-dbind (args expr &rest body)
"Bind the variables in ARGS to the result of EXPR and execute BODY.
Abbreviation of `destructuring-bind'."
(declare (indent 2))
`(cl-destructuring-bind ,args ,expr ,@body))
(defun wg-partition (list &optional n step)
"Take LIST, return a list of N length sublists, offset by STEP.
N defaults to 2, and STEP defaults to N.
Iterative to prevent stack overflow."
(let* ((n (or n 2)) (step (or step n)) acc)
(while list
(push (-take n list) acc)
(setq list (nthcdr step list)))
(nreverse acc)))
(defmacro wg-when-boundp (symbols &rest body)
"When all SYMBOLS are bound, `eval' BODY."
(declare (indent 1))
`(when (and ,@(mapcar (lambda (sym) `(boundp ',sym)) symbols))
,@body))
(defmacro wg-docar (spec &rest body)
"do-style wrapper for `mapcar'.
\(fn (VAR LIST) BODY...)"
(declare (indent 1))
`(mapcar (lambda (,(car spec)) ,@body) ,(cadr spec)))
(defmacro wg-dohash (spec &rest body)
"do-style wrapper for `maphash'.
\(fn (KEY VALUE TABLE [RESULT]) BODY...)"
(declare (indent 1))
(wg-dbind (key val table &optional result) spec
`(progn (maphash (lambda (,key ,val) ,@body) ,table) ,result)))
(defmacro wg-doconcat (spec &rest body)
"do-style wrapper for `mapconcat'.
\(fn (VAR SEQ [SEPARATOR]) BODY...)"
(declare (indent 1))
(wg-dbind (elt seq &optional sep) spec
`(mapconcat (lambda (,elt) ,@body) ,seq (or ,sep ""))))
(defmacro wg-asetf (&rest places-and-values)
"Anaphoric `setf'."
`(progn ,@(mapcar (lambda (pv) `(let ((it ,(car pv))) (setf ,@pv)))
(wg-partition places-and-values 2))))
(defmacro wg-destructuring-dolist (spec &rest body)
"Loop over a list.
Evaluate BODY, destructuring LIST into SPEC, then evaluate RESULT
to get a return value, defaulting to nil. The only hitch is that
spec must end in dotted style, collecting the rest of the list
into a var, like so: (a (b c) . rest)
\(fn (SPEC LIST [RESULT]) BODY...)"
(declare (indent 1))
(wg-dbind (loopspec list &optional result) spec
(let ((rest (cdr (last loopspec))))
(wg-with-gensyms (list-sym)
`(let ((,list-sym ,list))
(while ,list-sym
(wg-dbind ,loopspec ,list-sym
,@body
(setq ,list-sym ,rest)))
,result)))))
;;; numbers
(defun wg-step-to (n m step)
"Increment or decrement N toward M by STEP.
Return M when the difference between N and M is less than STEP."
(cond ((= n m) n)
((< n m) (min (+ n step) m))
((> n m) (max (- n step) m))))
(defun wg-within (num lo hi &optional hi-inclusive)
"Return t when NUM is within bounds LO and HI.
HI-INCLUSIVE non-nil means the HI bound is inclusive."
(and (>= num lo) (if hi-inclusive (<= num hi) (< num hi))))
(defun wg-int-to-b36-one-digit (i)
"Return a character in 0..9 or A..Z from I, and integer 0<=I<32.
Cribbed from `org-id-int-to-b36-one-digit'."
(cond ((not (wg-within i 0 36))
(error "%s out of range" i))
((< i 10) (+ ?0 i))
((< i 36) (+ ?A i -10))))
(defun wg-b36-to-int-one-digit (i)
"Turn a character 0..9, A..Z, a..z into a number 0..61.
The input I may be a character, or a single-letter string.
Cribbed from `org-id-b36-to-int-one-digit'."
(and (stringp i) (setq i (string-to-char i)))
(cond ((and (>= i ?0) (<= i ?9)) (- i ?0))
((and (>= i ?A) (<= i ?Z)) (+ (- i ?A) 10))
(t (error "Invalid b36 character"))))
(defun wg-int-to-b36 (i &optional length)
"Return a base 36 string from I."
(let ((base 36) b36)
(cl-labels ((add-digit () (push (wg-int-to-b36-one-digit (mod i base)) b36)
(setq i (/ i base))))
(add-digit)
(while (> i 0) (add-digit))
(setq b36 (cl-map 'string 'identity b36))
(if (not length) b36
(concat (make-string (max 0 (- length (length b36))) ?0) b36)))))
(defun wg-b36-to-int (str)
"Convert STR, a base-36 string, into the corresponding integer.
Cribbed from `org-id-b36-to-int'."
(let ((result 0))
(mapc (lambda (i)
(setq result (+ (* result 36)
(wg-b36-to-int-one-digit i))))
str)
result))
;;; lists
(defmacro wg-removef-p (item seq-place &rest keys)
"If ITEM is a `member*' of SEQ-PLACE, remove it from SEQ-PLACE and return t.
Otherwise return nil. KEYS can be any keywords accepted by `remove*'."
`(> (length ,seq-place)
(length (setf ,seq-place (cl-remove ,item ,seq-place ,@keys)))))
(defmacro wg-pushnew-p (item seq-place &rest keys)
"If ITEM is not a `member' of SEQ-PLACE, push it to SEQ-PLACE and return t.
Otherwise return nil. KEYS can be any keyword args accepted by `pushnew'."
`(< (length ,seq-place)
(length (cl-pushnew ,item ,seq-place ,@keys))))
(defun wg-range (start end)
"Return a list of integers from START up to but not including END."
(let (accum)
(dotimes (i (- end start) (nreverse accum))
(push (+ start i) accum))))
(defun wg-insert-before (elt list index)
"Insert ELT into LIST before INDEX."
(if (zerop index) (cons elt list)
(-insert-at index elt list)))
(defun wg-move-elt (elt list index &rest keys)
"Move ELT before INDEX in LIST.
KEYS is passed to `remove*'."
(wg-insert-before elt (apply 'cl-remove elt list keys) index))
(defun wg-cyclic-nth (list n)
"Return the Nth element of LIST, modded by the length of list."
(nth (mod n (length list)) list))
(defun wg-cyclic-offset-elt (elt list n)
"Cyclically offset ELT's position in LIST by N."
(-when-let (pos (cl-position elt list))
(wg-move-elt elt list (mod (+ n pos) (length list)))))
(defun wg-cyclic-nth-from-elt (elt list n &rest keys)
"Return the elt in LIST N places cyclically from ELT.
If ELT is not present is LIST, return nil.
KEYS is passed to `position'."
(-when-let (pos (apply 'cl-position elt list keys))
(wg-cyclic-nth list (+ pos n))))
(defun wg-util-swap (elt1 elt2 list)
"Return a copy of LIST with ELT1 and ELT2 swapped.
Return nil when ELT1 and ELT2 aren't both present."
(-when-let* ((p1 (cl-position elt1 list))
(p2 (cl-position elt2 list)))
(wg-move-elt elt1 (wg-move-elt elt2 list p1) p2)))
(defun wg-dups-p (list &rest keys)
"Return non-nil when LIST contains duplicate elements.
Keywords supported: :test :key
\(fn LIST [KEYWORD VALUE]...)"
(let ((test (or (plist-get keys :test) 'eq))
(key (or (plist-get keys :key) 'identity)))
(cl-loop for (elt . rest) on list
for elt = (funcall key elt)
when (cl-find elt rest :test test :key key) return elt)))
(defun wg-string-list-union (&optional list1 list2)
"Return the `union' of LIST1 and LIST2, using `string=' as the test.
This only exists to get rid of duplicate lambdas in a few reductions."
(cl-union list1 list2 :test 'string=))
;;; alists
(defun wg-aget (alist key &optional default)
"Return the value of KEY in ALIST. Uses `assq'.
If PARAM is not found, return DEFAULT which defaults to nil."
(aif (assq key alist) (cdr it) default))
(defun wg-aput (alist key value)
"Return a new alist from ALIST with KEY's value set to VALUE."
(let* ((found nil)
(new (wg-docar (kvp alist)
(if (not (eq key (car kvp))) kvp
(setq found (cons key value))))))
(if found new (cons (cons key value) new))))
(defun wg-aremove (alist key)
"`remove' KEY's key-value-pair from ALIST."
(remove (assoc key alist) alist))
;;; symbols and strings
(defun wg-toggle (symbol)
"Toggle SYMBOL's truthiness."
(set symbol (not (symbol-value symbol))))
(defun wg-get-buffer (buffer-or-name)
"Return BUFFER-OR-NAME's buffer, or error."
(or (get-buffer buffer-or-name)
(error "%S does not identify a buffer" buffer-or-name)))
(defun wg-buffer-name (buffer-or-name)
"Return BUFFER-OR-NAME's `buffer-name', or error."
(buffer-name (wg-get-buffer buffer-or-name)))
(defun wg-buffer-major-mode (buffer-or-name)
"Return BUFFER's major-mode."
(with-current-buffer buffer-or-name major-mode))
(defun wg-current-buffer-p (buffer-or-name)
"Return t if BUFFER-OR-NAME is the current buffer, nil otherwise."
(eq (wg-get-buffer buffer-or-name) (current-buffer)))
(defun wg-symcat (&rest symbols-and-strings)
"Return a new interned symbol by concatenating SYMBOLS-AND-STRINGS."
(intern (mapconcat (lambda (obj) (if (symbolp obj) (symbol-name obj) obj))
symbols-and-strings "")))
(defmacro wg-defstruct (prefix name-form &rest slot-defs)
"`defstruct' wrapper that namespace-prefixes all generated functions.
Note: this doesn't yet work with :conc-name, and possibly other
options."
(declare (indent 2))
(let* ((name (if (consp name-form) (car name-form) name-form))
(prefixed-name (wg-symcat prefix "-" name)))
(cl-labels ((rebind (opstr)
(let ((oldfnsym (wg-symcat opstr "-" prefix "-" name)))
`((fset ',(wg-symcat prefix "-" opstr "-" name)
(symbol-function ',oldfnsym))
(fmakunbound ',oldfnsym)))))
;; `eval-and-compile' gets rid of byte-comp warnings ("function `foo' not
;; known to be defined"). We can accomplish this with `declare-function'
;; too, but it annoyingly requires inclusion of the function's arglist,
;; which gets ugly.
`(eval-and-compile
(cl-defstruct ,(if (symbolp name-form) prefixed-name
`(,prefixed-name ,@(cdr name-form)))
,@slot-defs)
,@(rebind "make")
,@(rebind "copy")
',prefixed-name))))
(wg-defstruct wg session
(uid (wg-generate-uid))
(name)
(modified)
(parameters)
(file-name)
(version wg-version)
(workgroup-list)
(buf-list))
(wg-defstruct wg workgroup
(uid (wg-generate-uid))
(name)
(modified)
(parameters)
(base-wconfig)
(selected-frame-wconfig)
(saved-wconfigs)
(strong-buf-uids)
(weak-buf-uids))
(wg-defstruct wg workgroup-state
(undo-pointer)
(undo-list))
(wg-defstruct wg wconfig
(uid (wg-generate-uid))
(name)
(parameters)
(left)
(top)
(width)
(height)
(vertical-scroll-bars)
(scroll-bar-width)
(wtree))
(wg-defstruct wg wtree
(uid)
(dir)
(edges)
(wlist))
(wg-defstruct wg win
(uid)
(parameters)
(edges)
(point)
(start)
(hscroll)
(dedicated)
(selected)
(minibuffer-scroll)
(buf-uid))
(wg-defstruct wg buf
(uid (wg-generate-uid))
(name)
(file-name)
(point)
(mark)
(local-vars)
(special-data)
;; This may be used later:
(gc))
(defmacro wg-with-slots (obj slot-bindings &rest body)
"Bind OBJ's slot values to symbols in BINDS, then eval BODY.
The car of each element of SLOT-BINDINGS is the bound symbol, and
the cadr as the accessor function."
(declare (indent 2))
(wg-with-gensyms (objsym)
`(let* ((,objsym ,obj)
,@(wg-docar (slot slot-bindings)
`(,(car slot) (,(cadr slot) ,objsym))))
,@body)))
(defun wg-add-or-remove-hooks (remove &rest pairs)
"Add FUNCTION to or remove it from HOOK, depending on REMOVE."
(dolist (pair (wg-partition pairs 2))
(funcall (if remove 'remove-hook 'add-hook)
(car pair) (cadr pair))))
(defmacro wg-set-parameter (place parameter value)
"Set PARAMETER to VALUE at PLACE.
This needs to be a macro to allow specification of a setf'able place."
(wg-with-gensyms (p v)
`(let ((,p ,parameter) (,v ,value))
(wg-pickelable-or-error ,p)
(wg-pickelable-or-error ,v)
(setf ,place (wg-aput ,place ,p ,v))
,v)))
(defun wg-time-to-b36 ()
"Convert `current-time' into a b36 string."
(apply 'concat (wg-docar (time (current-time))
(wg-int-to-b36 time 4))))
(defun wg-b36-to-time (b36)
"Parse the time in B36 string from UID."
(cl-loop for i from 0 to 8 by 4
collect (wg-b36-to-int (cl-subseq b36 i (+ i 4)))))
(defalias 'wg-uid-to-time 'wg-b36-to-time)
(defun wg-generate-uid (&optional prefix)
"Return a new uid, optionally prefixed by PREFIX."
(concat prefix (wg-time-to-b36) "-" (wg-int-to-b36 string-chars-consed)))
(defun wg-uid-to-seconds (uid)
"Return the `float-time' parsed from UID with `wg-uid-to-time'."
(float-time (wg-uid-to-time uid)))
(defun wg-get-value (arg)
"Get a value of ARG if it exists."
(if (boundp `,arg) arg))
(defmacro wg-support (mode pkg params)
"Macro to create (de)serialization functions for a buffer.
You need to save/restore a specific MODE which is loaded from a
package PKG. In PARAMS you give local variables to save and a
deserialization function."
(declare (indent 2))
`(let ((mode-str (symbol-name ,mode))
(args ,params))
(eval `(defun ,(intern (format "wg-deserialize-%s-buffer" mode-str)) (buffer)
"DeSerialization function created with `wg-support'.
Gets saved variables and runs code to restore a BUFFER."
(when (require ',,pkg nil 'noerror)
(wg-dbind (this-function variables) (wg-buf-special-data buffer)
(let ((default-directory (car variables))
(df (cdr (assoc 'deserialize ',,params)))
(user-vars (cadr variables)))
(if df
(funcall df buffer user-vars)
(get-buffer-create wg-default-buffer))
)))))
(eval `(defun ,(intern (format "wg-serialize-%s-buffer" mode-str)) (buffer)
"Serialization function created with `wg-support'.
Saves some variables to restore a BUFFER later."
(when (get-buffer buffer)
(with-current-buffer buffer
(when (eq major-mode ',,mode)
(let ((sf (cdr (assoc 'serialize ',,params)))
(save (cdr (assoc 'save ',,params))))
(list ',(intern (format "wg-deserialize-%s-buffer" mode-str))
(list default-directory
(if sf
(funcall sf buffer)
(if save (mapcar 'wg-get-value save)))
))))))))
;; Maybe change a docstring for functions
;;(put (intern (format "wg-serialize-%s-buffer" (symbol-name mode)))
;; 'function-documentation
;; (format "A function created by `wg-support'."))
;; Add function to `wg-special-buffer-serdes-functions' variable
(eval `(add-to-list 'wg-special-buffer-serdes-functions
',(intern (format "wg-serialize-%s-buffer" mode-str)) t))
))
(defconst wg-font-lock-keywords
'(("(\\(wg-support\\|wg-support\\)[ \t]*"
(1 font-lock-keyword-face)
;;(2 font-lock-keyword-face)
)))
(font-lock-add-keywords 'emacs-lisp-mode wg-font-lock-keywords)
(defvar wg-current-session nil "Current session object.")
(defun wg-current-session (&optional noerror)
"Return `wg-current-session' or error unless NOERROR."
(or wg-current-session
(if workgroups-mode
(unless noerror (error "No session is defined"))
(unless noerror
(error "Activate workgroups with (workgroups-mode 1)")))))
;; locate-dominating-file
(defun wg-get-first-existing-dir (&optional dir)
"Test if DIR exists and return it.
If not - try to go to the parent dir and do the same."
(let* ((d (or dir default-directory)))
(if (file-directory-p d) d
(let* ((cur d) (parent (file-name-directory (directory-file-name cur))))
(while (and (> (length cur) (length parent))
(not (file-directory-p parent)))
(message "Test %s" parent)
(setq cur parent)
(setq parent (file-name-directory (directory-file-name cur))))
parent))))
(defvar wg-pickel-identifier '~pickel!~
"Symbol identifying a stream as a pickel.")
(defvar wg-pickel-pickelable-types
'(integer
float
symbol
string
cons
vector
hash-table
buffer
marker
;;window-configuration
;;frame
;;window
;;process
)
"Types pickel can serialize.")
(defvar wg-pickel-object-serializers
'((integer . identity)
(float . identity)
(string . identity)
(symbol . wg-pickel-symbol-serializer)
(cons . wg-pickel-cons-serializer)
(vector . wg-pickel-vector-serializer)
(hash-table . wg-pickel-hash-table-serializer)
(buffer . wg-pickel-buffer-serializer)
(marker . wg-pickel-marker-serializer)
;;(window-configuration . wg-pickel-window-configuration-serializer)
)
"Alist mapping types to object serialization functions.")
(defvar wg-pickel-object-deserializers
'((s . wg-pickel-deserialize-uninterned-symbol)
(c . wg-pickel-deserialize-cons)
(v . wg-pickel-deserialize-vector)
(h . wg-pickel-deserialize-hash-table)
(b . wg-pickel-deserialize-buffer)
(m . wg-pickel-deserialize-marker)
;;(f . wg-pickel-deserialize-frame)
)
"Alist mapping type keys to object deserialization functions.")
(defvar wg-pickel-link-serializers
'((cons . wg-pickel-cons-link-serializer)
(vector . wg-pickel-vector-link-serializer)
(hash-table . wg-pickel-hash-table-link-serializer))
"Alist mapping types to link serialization functions.")
(defvar wg-pickel-link-deserializers
`((c . wg-pickel-cons-link-deserializer)
(v . wg-pickel-vector-link-deserializer)
(h . wg-pickel-hash-table-link-deserializer))
"Alist mapping type keys to link deserialization functions.")
;;; errors and predicates
(put 'wg-pickel-unpickelable-type-error
'error-conditions
'(error wg-pickel-errors wg-pickel-unpickelable-type-error))
(put 'wg-pickel-unpickelable-type-error
'error-message
"Attemp to pickel unpickelable type")
(defun wg-pickelable-or-error (obj)
"Error when OBJ isn't pickelable."
(unless (memq (type-of obj) wg-pickel-pickelable-types)
(signal 'wg-pickel-unpickelable-type-error
(format "Can't pickel objects of type: %S" (type-of obj))))
(cl-typecase obj
(cons
(wg-pickelable-or-error (car obj))
(wg-pickelable-or-error (cdr obj)))
(vector
(cl-map nil 'wg-pickelable-or-error obj))
(hash-table
(wg-dohash (key value obj)
(wg-pickelable-or-error key)
(wg-pickelable-or-error value)))))
(defun wg-pickelable-p (obj)
(condition-case err
(progn (wg-pickelable-or-error obj) t)
(wg-pickel-unpickelable-type-error nil)))
(defun wg-pickel-p (obj)
"Return t when OBJ is a pickel, nil otherwise."
(and (consp obj) (eq (car obj) wg-pickel-identifier)))
;; accessor functions
(defun wg-pickel-object-serializer (obj)
"Return the object serializer for the `type-of' OBJ."
(or (wg-aget wg-pickel-object-serializers (type-of obj))
(error "Invalid type: %S" (type-of obj))))
(defun wg-pickel-link-serializer (obj)
"Return the link serializer for the `type-of' OBJ."
(wg-aget wg-pickel-link-serializers (type-of obj)))
(defun wg-pickel-object-deserializer (key)
"Return the object deserializer for type key KEY, or error."
(or (wg-aget wg-pickel-object-deserializers key)
(error "Invalid object deserializer key: %S" key)))
(defun wg-pickel-link-deserializer (key)
"Return the link deserializer for type key KEY, or error."
(or (wg-aget wg-pickel-link-deserializers key)
(error "Invalid link deserializer key: %S" key)))
;;; bindings
(defun wg-pickel-make-bindings-table (obj)
"Return a table binding unique subobjects of OBJ to ids."
(let ((binds (make-hash-table :test 'eq))
(id -1))
(cl-labels
((inner (obj)
(unless (gethash obj binds)
(puthash obj (cl-incf id) binds)
(cl-case (type-of obj)
(cons
(inner (car obj))
(inner (cdr obj)))
(vector
(dotimes (idx (length obj))
(inner (aref obj idx))))
(hash-table
(wg-dohash (key val obj)
(inner key)
(inner val)))))))
(inner obj)
binds)))
;;; Objects
(defun wg-pickel-symbol-serializer (symbol)
"Return SYMBOL's serialization."
(cond ((eq symbol t) t)
((eq symbol nil) nil)
((intern-soft symbol) symbol)
(t (list 's (symbol-name symbol)))))
(defun wg-pickel-deserialize-uninterned-symbol (name)
"Return a new uninterned symbol from NAME."
(make-symbol name))
;; buffer
(defun wg-pickel-buffer-serializer (buffer)
"Return BUFFER's UID in workgroups buffer list."
(list 'b (wg-add-buffer-to-buf-list buffer)))
(defun wg-pickel-deserialize-buffer (uid)
"Return a restored buffer from it's UID."
(wg-restore-buffer (wg-find-buf-by-uid uid)))
;; marker
(defun wg-pickel-marker-serializer (marker)
"Return MARKER's data."
(list 'm (list (marker-position marker)
(wg-add-buffer-to-buf-list (marker-buffer marker)))))
(defun wg-pickel-deserialize-marker (data)
"Return marker from it's DATA."
(let ((m (make-marker)))
(set-marker m (car data) (wg-pickel-deserialize-buffer (car (cdr data))))))
;; cons - http://www.gnu.org/software/emacs/manual/html_node/eintr/cons.html
(defun wg-pickel-cons-serializer (cons)
"Return CONS's serialization."
(list 'c))
(defun wg-pickel-deserialize-cons ()
"Return a new cons cell initialized to nil."
(cons nil nil))
(defun wg-pickel-cons-link-serializer (cons binds)
"Return the serialization of CONS's links in BINDS."
(list 'c
(gethash cons binds)
(gethash (car cons) binds)
(gethash (cdr cons) binds)))
(defun wg-pickel-cons-link-deserializer (cons-id car-id cdr-id binds)
"Relink a cons cell with its car and cdr in BINDS."
(let ((cons (gethash cons-id binds)))
(setcar cons (gethash car-id binds))
(setcdr cons (gethash cdr-id binds))))
;; vector - http://www.gnu.org/software/emacs/manual/html_node/elisp/Vector-Functions.html
;; (wg-unpickel (wg-pickel (make-vector 9 'Z)))
;;
(defun wg-pickel-vector-serializer (vector)
"Return VECTOR's serialization."
(list 'v (length vector)))
(defun wg-pickel-deserialize-vector (length)
"Return a new vector of length LENGTH."
(make-vector length nil))
(defun wg-pickel-vector-link-serializer (vector binds)
"Return the serialization of VECTOR's links in BINDS."
(let (result)
(dotimes (i (length vector) result)
(setq result
(nconc (list 'v
(gethash vector binds)
i
(gethash (aref vector i) binds))
result)))))
(defun wg-pickel-vector-link-deserializer (vector-id index value-id binds)
"Relink a vector with its elements in BINDS."
(aset (gethash vector-id binds) index (gethash value-id binds)))
;; hash table - http://www.gnu.org/software/emacs/manual/html_node/elisp/Hash-Tables.html
(defun wg-pickel-hash-table-serializer (table)
"Return HASH-TABLE's serialization."
(list 'h
(hash-table-test table)
(hash-table-size table)
(hash-table-rehash-size table)
(hash-table-rehash-threshold table)
(hash-table-weakness table)))
(defun wg-pickel-deserialize-hash-table (test size rsize rthresh weakness)
"Return a new hash-table with the specified properties."
(make-hash-table :test test :size size :rehash-size rsize
:rehash-threshold rthresh :weakness weakness))
(defun wg-pickel-hash-table-link-serializer (table binds)
"Return the serialization of TABLE's links in BINDS."
(let (result)
(wg-dohash (key value table result)
(setq result
(nconc (list 'h
(gethash key binds)
(gethash value binds)
(gethash table binds))
result)))))
(defun wg-pickel-hash-table-link-deserializer (key-id value-id table-id binds)
"Relink a hash-table with its keys and values in BINDS."
(puthash (gethash key-id binds)
(gethash value-id binds)
(gethash table-id binds)))
;; TODO
(defun wg-pickel-window-configuration-serializer (wc)
"Return Window configuration WC's serialization."
(list 'wc 1))
(defun wg-pickel-serialize-objects (binds)
"Return a list of serializations of the objects in BINDS."
(let (result)
(wg-dohash (obj id binds result)
(setq result
(nconc (list id (funcall (wg-pickel-object-serializer obj) obj))
result)))))
(defun wg-pickel-deserialize-objects (serial-objects)
"Return a hash-table of objects deserialized from SERIAL-OBJECTS."
(let ((binds (make-hash-table)))
(wg-destructuring-dolist ((id obj . rest) serial-objects binds)
(puthash id
(if (atom obj) obj
(wg-dbind (key . data) obj
(apply (wg-pickel-object-deserializer key) data)))
binds))))
(defun wg-pickel-serialize-links (binds)
"Return a list of serializations of the links between objects in BINDS."
(let (result)
(wg-dohash (obj id binds result)
(awhen (wg-pickel-link-serializer obj)
(setq result (nconc (funcall it obj binds) result))))))
(defun wg-pickel-deserialize-links (serial-links binds)
"Return BINDS after relinking all its objects according to SERIAL-LINKS."
(wg-destructuring-dolist ((key arg1 arg2 arg3 . rest) serial-links binds)
(funcall (wg-pickel-link-deserializer key) arg1 arg2 arg3 binds)))
(defun wg-pickel (obj)
"Return the serialization of OBJ."
(wg-pickelable-or-error obj)
(let ((binds (wg-pickel-make-bindings-table obj)))
(list wg-pickel-identifier
(wg-pickel-serialize-objects binds)
(wg-pickel-serialize-links binds)
(gethash obj binds))))
(defun wg-pickel-to-string (obj)
"Serialize OBJ to a string and return the string."
(format "%S" (wg-pickel obj)))
(defun wg-unpickel (pickel)
"Return the deserialization of PICKEL."
(unless (wg-pickel-p pickel)
(error "Attempt to unpickel a non-pickel."))
(wg-dbind (id serial-objects serial-links result) pickel
(gethash
result
(wg-pickel-deserialize-links
serial-links
(wg-pickel-deserialize-objects serial-objects)))))
;; `wg-pre-window-configuration-change-hook' implementation advice
(cl-macrolet ((define-p-w-c-c-h-advice
(fn)
`(defadvice ,fn (before wg-pre-window-configuration-change-hook)
"Call `wg-update-working-wconfig-hook' before this
function to save up-to-date undo information before the
window-configuration changes."
(run-hooks 'wg-pre-window-configuration-change-hook))))
(define-p-w-c-c-h-advice split-window)
(define-p-w-c-c-h-advice enlarge-window)
(define-p-w-c-c-h-advice delete-window)
(define-p-w-c-c-h-advice delete-other-windows)
(define-p-w-c-c-h-advice delete-windows-on)
(define-p-w-c-c-h-advice switch-to-buffer)
(define-p-w-c-c-h-advice set-window-buffer))
(defadvice save-buffers-kill-emacs (around wg-freeze-wconfig)
"`save-buffers-kill-emacs' calls `list-processes' when active
processes exist, screwing up the window config right before
Workgroups saves it. This advice freezes `wg-current-wconfig' in
its correct state, prior to any window-config changes caused by
`s-b-k-e'."
(wg-with-current-wconfig nil (wg-frame-to-wconfig)
ad-do-it))
(defadvice select-frame (before wg-update-current-workgroup-working-wconfig)
"Update `selected-frame's current workgroup's working-wconfig.
Before selecting a new frame."
(wg-update-current-workgroup-working-wconfig))
(defun wg-enable-all-advice ()
"Enable and activate all of Workgroups' advice."
;; switch-to-buffer
(ad-enable-advice 'switch-to-buffer 'after 'wg-auto-associate-buffer)
(ad-enable-advice 'switch-to-buffer 'before 'wg-pre-window-configuration-change-hook)
(ad-activate 'switch-to-buffer)
;; set-window-buffer
(ad-enable-advice 'set-window-buffer 'after 'wg-auto-associate-buffer)
(ad-enable-advice 'set-window-buffer 'before 'wg-pre-window-configuration-change-hook)
(ad-activate 'set-window-buffer)
;; split-window
(ad-enable-advice 'split-window 'before 'wg-pre-window-configuration-change-hook)
(ad-activate 'split-window)
;; enlarge-window
(ad-enable-advice 'enlarge-window 'before 'wg-pre-window-configuration-change-hook)
(ad-activate 'enlarge-window)
;; delete-window
(ad-enable-advice 'delete-window 'before 'wg-pre-window-configuration-change-hook)
(ad-activate 'delete-window)
;; delete-other-windows
(ad-enable-advice 'delete-other-windows 'before 'wg-pre-window-configuration-change-hook)
(ad-activate 'delete-other-windows)
;; delete-windows-on
(ad-enable-advice 'delete-windows-on 'before 'wg-pre-window-configuration-change-hook)
(ad-activate 'delete-windows-on)
;; save-buffers-kill-emacs
(ad-enable-advice 'save-buffers-kill-emacs 'around 'wg-freeze-wconfig)
(ad-activate 'save-buffers-kill-emacs)
;; select-frame
;;(ad-enable-advice 'select-frame 'before
;; 'wg-update-current-workgroup-working-wconfig)
;;(ad-activate 'select-frame)
)
;; disable all advice
;; (wg-disable-all-advice)
(defun wg-disable-all-advice ()
"Disable and deactivate all of Workgroups' advice."
;; switch-to-buffer
(ad-disable-advice 'switch-to-buffer 'after 'wg-auto-associate-buffer)
(ad-disable-advice 'switch-to-buffer 'before 'wg-pre-window-configuration-change-hook)
(ad-deactivate 'switch-to-buffer)
;; set-window-buffer
(ad-disable-advice 'set-window-buffer 'after 'wg-auto-associate-buffer)
(ad-disable-advice 'set-window-buffer 'before 'wg-pre-window-configuration-change-hook)
(ad-deactivate 'set-window-buffer)
;; split-window
(ad-disable-advice 'split-window 'before 'wg-pre-window-configuration-change-hook)
(ad-deactivate 'split-window)
;; enlarge-window
(ad-disable-advice 'enlarge-window 'before 'wg-pre-window-configuration-change-hook)
(ad-deactivate 'enlarge-window)
;; delete-window
(ad-disable-advice 'delete-window 'before 'wg-pre-window-configuration-change-hook)
(ad-deactivate 'delete-window)
;; delete-other-windows
(ad-disable-advice 'delete-other-windows 'before 'wg-pre-window-configuration-change-hook)
(ad-deactivate 'delete-other-windows)
;; delete-windows-on
(ad-disable-advice 'delete-windows-on 'before 'wg-pre-window-configuration-change-hook)
(ad-deactivate 'delete-windows-on)
;; save-buffers-kill-emacs
(ad-disable-advice 'save-buffers-kill-emacs 'around 'wg-freeze-wconfig)
(ad-deactivate 'save-buffers-kill-emacs)
;; select-frame
;;(ad-disable-advice 'select-frame 'before
;; 'wg-update-current-workgroup-working-wconfig)
;;(ad-deactivate 'select-frame)
)
;; buffer auto-association advice
(defcustom wg-buffer-auto-association-on t
"Non-nil means buffer auto-association is on.
-nil means it's off. See `wg-buffer-auto-association'."
:type 'boolean
:group 'workgroups)
(defcustom wg-buffer-auto-association 'weak
"Specifies the behavior for auto-associating buffers with workgroups.
When a buffer is made visible in a window it can be automatically
associated with the current workgroup in the window's frame.
This setting determines whether and how that happens.
Allowable values:
`weak' - weakly associate the buffer with the workgroup
`strong' - strongly associate the buffer with the workgroup
A function (a function-symbol or a lambda) - `funcall' the function to
determine whether and how to associate the buffer with the
workgroup. The function should accept two arguments -- the
buffer and the workgroup -- and should return one of the
allowable values for this variable.
`nil' or any other value - don't associate the buffer with the
workgroup.
Becomes workgroup-local when set with `wg-set-workgroup-parameter'.
Becomes session-local when set with `wg-set-session-parameter'."
:type 'sexp
:group 'workgroups)
(defcustom wg-dissociate-buffer-on-kill-buffer t
"Non-nil means dissociate buffers killed with `kill-buffer'."
:type 'boolean
:group 'workgroups)
(defun wg-auto-associate-buffer-helper (workgroup buffer assoc)
"Associate BUFFER with WORKGROUP based on ASSOC.
See `wg-buffer-auto-association' for allowable values of ASSOC."
(cond ((memq assoc '(weak strong))
(wg-workgroup-associate-bufobj workgroup buffer (eq assoc 'weak)))
((functionp assoc)
(wg-auto-associate-buffer-helper
workgroup buffer (funcall assoc workgroup buffer)))
(t nil)))
(defun wg-auto-associate-buffer (buffer &optional frame)
"Conditionally associate BUFFER with the current workgroup in FRAME.
Frame defaults to `selected-frame'. See `wg-buffer-auto-association'."
(when wg-buffer-auto-association-on
(-when-let* ((wg (wg-current-workgroup t frame))
(b (get-buffer buffer)))
(unless (or (wg-workgroup-bufobj-association-type wg buffer)
(member wg wg-deactivation-list)
(member (buffer-name b) wg-associate-blacklist)
(not (or (buffer-file-name b)
(eq (buffer-local-value 'major-mode b) 'dired-mode))))
(wg-auto-associate-buffer-helper
wg buffer (wg-local-value 'wg-buffer-auto-association wg))))))
(defadvice switch-to-buffer (after wg-auto-associate-buffer)
"Automatically associate the buffer with the current workgroup."
(wg-auto-associate-buffer ad-return-value))
(defadvice set-window-buffer (after wg-auto-associate-buffer)
"Automatically associate the buffer with the current workgroup."
(wg-auto-associate-buffer
(ad-get-arg 1)
(window-frame (or (ad-get-arg 0) (selected-window)))))
(defun wg-mode-line-string ()
"Return the string to be displayed in the mode-line."
(let ((wg (wg-current-workgroup t))
(wg-use-faces wg-mode-line-use-faces))
(cond (wg (wg-fontify " "
(:brace wg-mode-line-decor-left-brace)
(:mode (wg-workgroup-name wg))
(if wg-flag-modified
(concat
(wg-add-face :div wg-mode-line-decor-divider)
;;(if (window-dedicated-p)
;; wg-mode-line-decor-window-dedicated
;; wg-mode-line-decor-window-undedicated)
;;(wg-add-face :div wg-mode-line-decor-divider)
(if (wg-session-modified (wg-current-session))
wg-mode-line-decor-session-modified
wg-mode-line-decor-session-unmodified)
(if (wg-workgroup-modified wg)
wg-mode-line-decor-workgroup-modified
wg-mode-line-decor-workgroup-unmodified)))
(:brace wg-mode-line-decor-right-brace)))
(t (if wg-display-nowg
(wg-fontify " "
(:brace wg-mode-line-decor-left-brace)
(:mode wg-nowg-string)
(:brace wg-mode-line-decor-right-brace))
"")))))
(defun wg-change-modeline ()
"Add Workgroups' mode-line format to `mode-line-format'."
(unless (assq 'wg-mode-line-display-on mode-line-format)
(let ((format '(wg-mode-line-display-on (:eval (wg-mode-line-string))))
(pos (or (cl-position 'mode-line-position mode-line-format) 10)))
(set-default 'mode-line-format (-insert-at (1+ pos) format mode-line-format))
(force-mode-line-update))))
(defun wg-remove-mode-line-display ()
"Remove Workgroups' mode-line format from `mode-line-format'."
(awhen (assq 'wg-mode-line-display-on mode-line-format)
(set-default 'mode-line-format (remove it mode-line-format))
(force-mode-line-update)))
(defun wg-add-workgroups-mode-minor-mode-entries ()
"Add Workgroups' minor-mode entries.
Adds entries to `minor-mode-list', `minor-mode-alist' and
`minor-mode-map-alist'."
(cl-pushnew 'workgroups-mode minor-mode-list)
(cl-pushnew '(workgroups-mode wg-modeline-string) minor-mode-alist :test 'equal)
(setq minor-mode-map-alist
(cons (cons 'workgroups-mode (wg-make-workgroups-mode-map))
(delete (assoc 'workgroups-mode minor-mode-map-alist)
minor-mode-map-alist))))
(defun wg-fill-keymap (keymap &rest binds)
"Return KEYMAP after defining in it all keybindings in BINDS."
(while binds
(define-key keymap (car binds) (cadr binds))
(setq binds (cddr binds)))
keymap)
(defvar wg-prefixed-map
(wg-fill-keymap
(make-sparse-keymap)
;; workgroups
(kbd "C-c") 'wg-create-workgroup
(kbd "c") 'wg-create-workgroup
(kbd "C") 'wg-clone-workgroup
(kbd "A") 'wg-rename-workgroup
(kbd "C-'") 'wg-switch-to-workgroup
(kbd "'") 'wg-switch-to-workgroup
(kbd "C-v") 'wg-switch-to-workgroup
(kbd "v") 'wg-switch-to-workgroup
;; session
(kbd "C-s") 'wg-save-session
(kbd "C-w") 'wg-save-session-as
(kbd "C-f") 'wg-open-session
;; killing and yanking
(kbd "C-k") 'wg-kill-workgroup
(kbd "k") 'wg-kill-workgroup
(kbd "M-W") 'wg-kill-ring-save-base-wconfig
(kbd "M-w") 'wg-kill-ring-save-working-wconfig
(kbd "C-y") 'wg-yank-wconfig
(kbd "y") 'wg-yank-wconfig
(kbd "M-k") 'wg-kill-workgroup-and-buffers
(kbd "K") 'wg-delete-other-workgroups
;; workgroup switching
(kbd "C-j") 'wg-switch-to-workgroup-at-index
(kbd "j") 'wg-switch-to-workgroup-at-index
(kbd "0") 'wg-switch-to-workgroup-at-index-0
(kbd "1") 'wg-switch-to-workgroup-at-index-1
(kbd "2") 'wg-switch-to-workgroup-at-index-2
(kbd "3") 'wg-switch-to-workgroup-at-index-3
(kbd "4") 'wg-switch-to-workgroup-at-index-4
(kbd "5") 'wg-switch-to-workgroup-at-index-5
(kbd "6") 'wg-switch-to-workgroup-at-index-6
(kbd "7") 'wg-switch-to-workgroup-at-index-7
(kbd "8") 'wg-switch-to-workgroup-at-index-8
(kbd "9") 'wg-switch-to-workgroup-at-index-9
(kbd "C-p") 'wg-switch-to-workgroup-left
(kbd "p") 'wg-switch-to-workgroup-left
(kbd "C-n") 'wg-switch-to-workgroup-right
(kbd "n") 'wg-switch-to-workgroup-right
(kbd "C-a") 'wg-switch-to-previous-workgroup
(kbd "a") 'wg-switch-to-previous-workgroup
;; updating and reverting
;; wconfig undo/redo
(kbd "C-r") 'wg-revert-workgroup
(kbd "r") 'wg-revert-workgroup
(kbd "C-S-r") 'wg-revert-all-workgroups
(kbd "R") 'wg-revert-all-workgroups
(kbd "<left>") 'wg-undo-wconfig-change
(kbd "<right>") 'wg-redo-wconfig-change
(kbd "[") 'wg-undo-wconfig-change
(kbd "]") 'wg-redo-wconfig-change
(kbd "{") 'wg-undo-once-all-workgroups
(kbd "}") 'wg-redo-once-all-workgroups
;; wconfig save/restore
(kbd "C-d C-s") 'wg-save-wconfig
(kbd "C-d C-'") 'wg-restore-saved-wconfig
(kbd "C-d C-k") 'wg-kill-saved-wconfig
;; workgroup movement
(kbd "C-x") 'wg-swap-workgroups
(kbd "C-,") 'wg-offset-workgroup-left
(kbd "C-.") 'wg-offset-workgroup-right
;; window moving and frame reversal
(kbd "|") 'wg-reverse-frame-horizontally
(kbd "\\") 'wg-reverse-frame-vertically
(kbd "/") 'wg-reverse-frame-horizontally-and-vertically
;; toggling
(kbd "C-t C-m") 'wg-toggle-mode-line-display
(kbd "C-t C-d") 'wg-toggle-window-dedicated-p
;; misc
(kbd "!") 'wg-reset
(kbd "?") 'wg-help
)
"The keymap that sits on `wg-prefix-key'.")
(defun wg-make-workgroups-mode-map ()
"Return Workgroups' minor-mode-map.
This map includes `wg-prefixed-map' on `wg-prefix-key', as well
as Workgroups' command remappings."
(let ((map (make-sparse-keymap)))
(define-key map wg-prefix-key
wg-prefixed-map)
(when (and (fboundp 'winner-undo)
(fboundp 'winner-redo))
(define-key map [remap winner-undo] 'wg-undo-wconfig-change)
(define-key map [remap winner-redo] 'wg-redo-wconfig-change))
(setq workgroups-mode-map map)))
(defun wg-min-size (dir)
"Return the minimum window size in split direction DIR."
(if dir wg-window-min-height wg-window-min-width))
(defun wg-actual-min-size (dir)
"Return the actual minimum window size in split direction DIR."
(if dir wg-actual-min-height wg-actual-min-width))
(defmacro wg-with-edges (w spec &rest body)
"Bind W's edge list to SPEC and eval BODY."
(declare (indent 2))
`(wg-dbind ,spec (wg-w-edges ,w) ,@body))
(defmacro wg-with-bounds (wtree dir spec &rest body)
"Bind SPEC to W's bounds in DIR, and eval BODY.
\"bounds\" are a direction-independent way of dealing with edge lists."
(declare (indent 3))
(wg-with-gensyms (dir-sym l1 t1 r1 b1)
(wg-dbind (ls1 hs1 lb1 hb1) spec
`(wg-with-edges ,wtree (,l1 ,t1 ,r1 ,b1)
(cond (,dir (let ((,ls1 ,l1) (,hs1 ,r1) (,lb1 ,t1) (,hb1 ,b1))
,@body))
(t (let ((,ls1 ,t1) (,hs1 ,b1) (,lb1 ,l1) (,hb1 ,r1))
,@body)))))))
(defun wg-set-bounds (w dir ls hs lb hb)
"Set W's edges in DIR with bounds LS HS LB and HB."
(wg-set-edges w (if dir (list ls lb hs hb) (list lb ls hb hs))))
(defun wg-step-edges (edges1 edges2 hstep vstep)
"Return W1's edges stepped once toward W2's by HSTEP and VSTEP."
(wg-dbind (l1 t1 r1 b1) edges1
(wg-dbind (l2 t2 r2 b2) edges2
(let ((left (wg-step-to l1 l2 hstep))
(top (wg-step-to t1 t2 vstep)))
(list left top
(+ left (wg-step-to (- r1 l1) (- r2 l2) hstep))
(+ top (wg-step-to (- b1 t1) (- b2 t2) vstep)))))))
(defun wg-w-edge-operation (w edges op)
"Return a copy of W with its edges mapped against EDGES through OP."
(wg-set-edges w (cl-mapcar op (wg-w-edges w) edges)))
(defun wg-first-win (w)
"Return the first actual window in W."
(if (wg-win-p w) w
(wg-first-win (car (wg-wtree-wlist w)))))
(defun wg-last-win (w)
"Return the last actual window in W."
(if (wg-win-p w) w
(wg-last-win (-last-item (wg-wtree-wlist w)))))
(defun wg-minify-win (w)
"Set W's edges to the smallest allowable."
(let* ((edges (wg-w-edges w))
(left (car edges))
(top (cadr edges)))
(wg-set-edges w (list left top
(+ left wg-actual-min-width)
(+ top wg-actual-min-height)))))
(defun wg-minified-copy-of-last-win (w)
"Minify a copy of the last actual window in W."
(wg-minify-win (wg-copy-win (wg-last-win w))))
(defun wg-w-size (w &optional height)
"Return the width or height of W, calculated from its edge list."
(wg-with-edges w (l1 t1 r1 b1)
(if height (- b1 t1) (- r1 l1))))
(defun wg-adjust-w-size (w width-fn height-fn &optional new-left new-top)
"Adjust W's width and height with WIDTH-FN and HEIGHT-FN."
(wg-with-edges w (left top right bottom)
(let ((left (or new-left left)) (top (or new-top top)))
(wg-set-edges (wg-copy-w w)
(list left
top
(+ left (funcall width-fn (- right left)))
(+ top (funcall height-fn (- bottom top))))))))
(defun wg-scale-w-size (w width-scale height-scale)
"Scale W's size by WIDTH-SCALE and HEIGHT-SCALE."
(cl-labels
((wscale (width) (truncate (* width width-scale)))
(hscale (height) (truncate (* height height-scale))))
(wg-adjust-w-size w #'wscale #'hscale)))
(defun wg-restore-window (win)
"Restore WIN in `selected-window'."
(let ((selwin (selected-window))
(buf (wg-find-buf-by-uid (wg-win-buf-uid win))))
(if (not buf)
(wg-restore-default-buffer)
(when (wg-restore-buffer buf t)
;; Restore various positions in WINDOW from their values in WIN
;; (wg-restore-window-positions win selwin)
(let ((window (or selwin (selected-window))))
(wg-with-slots win
((win-point wg-win-point)
(win-start wg-win-start)
(win-hscroll wg-win-hscroll))
(set-window-start window win-start t)
(set-window-hscroll window win-hscroll)
(set-window-point
window
(cond ((not wg-restore-point) win-start)
((eq win-point :max) (point-max))
(t win-point)))
(when (>= win-start (point-max)) (recenter))))
(when wg-restore-window-dedicated-p
(set-window-dedicated-p selwin (wg-win-dedicated win)))))
(ignore-errors
(set-window-prev-buffers
selwin (wg-unpickel (wg-win-parameter win 'prev-buffers)))
(set-window-next-buffers
selwin (wg-unpickel (wg-win-parameter win 'next-buffers)))
)))
(defun wg-window-point (ewin)
"Return `point' or :max. See `wg-restore-point-max'.
EWIN should be an Emacs window object."
(let ((p (window-point ewin)))
(if (and wg-restore-point-max (= p (point-max))) :max p)))
(defun wg-win-parameter (win parameter &optional default)
"Return WIN's value for PARAMETER.
If PARAMETER is not found, return DEFAULT which defaults to nil.
SESSION nil defaults to the current session."
(wg-aget (wg-win-parameters win) parameter default))
(defun wg-set-win-parameter (win parameter value)
"Set WIN's value of PARAMETER to VALUE.
SESSION nil means use the current session.
Return value."
(wg-set-parameter (wg-win-parameters win) parameter value)
value)
;; (wg-win-parameters (wg-window-to-win (selected-window)))
(defun wg-remove-win-parameter (win parameter)
"Remove parameter PARAMETER from WIN's parameters."
(wg-asetf (wg-win-parameters win) (wg-aremove it parameter)))
(defun wg-window-to-win (&optional window)
"Return the serialization (a wg-win) of Emacs window WINDOW."
(let ((window (or window (selected-window)))
(selected (eq window (selected-window)))
win)
(with-selected-window window
(setq win
(wg-make-win
:edges (window-edges window)
:point (wg-window-point window)
:start (window-start window)
:hscroll (window-hscroll window)
:selected selected
:minibuffer-scroll (eq window minibuffer-scroll-window)
:dedicated (window-dedicated-p window)
:buf-uid (wg-buffer-uid-or-add (window-buffer window))))
(unless (version< emacs-version "24")
;; To solve: https://github.com/pashinin/workgroups2/issues/51
;; shouldn't ignore here
(ignore-errors
(wg-set-win-parameter
win 'next-buffers (wg-pickel (remove nil (cl-subseq (window-next-buffers window) 0 4))))
(wg-set-win-parameter
win 'prev-buffers (wg-pickel (remove nil (cl-subseq (window-prev-buffers window) 0 4)))))))
win))
(defun wg-toggle-window-dedicated-p ()
"Toggle `window-dedicated-p' in `selected-window'."
(interactive)
(set-window-dedicated-p nil (not (window-dedicated-p)))
(force-mode-line-update t)
(wg-fontified-message
(:cmd "Window:")
(:cur (concat (unless (window-dedicated-p) " not") " dedicated"))))
(defun wg-w-edges (w)
"Return W's edge list."
(cl-etypecase w
(wg-win (wg-win-edges w))
(wg-wtree (wg-wtree-edges w))))
(defun wg-copy-w (w)
"Return a copy of W. W should be a wg-win or a wg-wtree."
(cl-etypecase w
(wg-win (wg-copy-win w))
(wg-wtree (wg-copy-wtree w))))
(defun wg-set-edges (w edges)
"Set W's EDGES list, and return W."
(cl-etypecase w
(wg-win (setf (wg-win-edges w) edges))
(wg-wtree (setf (wg-wtree-edges w) edges)))
w)
(defun wg-equal-wtrees (w1 w2)
"Return t when W1 and W2 have equal structure."
(cond ((and (wg-win-p w1) (wg-win-p w2))
(equal (wg-w-edges w1) (wg-w-edges w2)))
((and (wg-wtree-p w1) (wg-wtree-p w2))
(and (eq (wg-wtree-dir w1) (wg-wtree-dir w2))
(equal (wg-wtree-edges w1) (wg-wtree-edges w2))
(cl-every #'wg-equal-wtrees
(wg-wtree-wlist w1)
(wg-wtree-wlist w2))))))
(defun wg-normalize-wtree (wtree)
"Clean up and return a new wtree from WTREE.
Recalculate the edge lists of all subwins, and remove subwins
outside of WTREE's bounds. If there's only one element in the
new wlist, return it instead of a new wtree."
(if (wg-win-p wtree) wtree
(wg-with-slots wtree ((dir wg-wtree-dir)
(wlist wg-wtree-wlist))
(wg-with-bounds wtree dir (ls1 hs1 lb1 hb1)
(let* ((min-size (wg-min-size dir))
(max (- hb1 1 min-size))
(lastw (-last-item wlist)))
(cl-labels
((mapwl
(wl)
(wg-dbind (sw . rest) wl
(cons (wg-normalize-wtree
(wg-set-bounds
sw dir ls1 hs1 lb1
(setq lb1 (if (eq sw lastw) hb1
(let ((hb2 (+ lb1 (wg-w-size sw dir))))
(if (>= hb2 max) hb1 hb2))))))
(when (< lb1 max) (mapwl rest))))))
(let ((new (mapwl wlist)))
(if (not (cdr new)) (car new)
(setf (wg-wtree-wlist wtree) new)
wtree))))))))
(defun wg-scale-wtree (wtree wscale hscale)
"Return a copy of WTREE with its dimensions scaled by WSCALE and HSCALE.
All WTREE's subwins are scaled as well."
(let ((scaled (wg-scale-w-size wtree wscale hscale)))
(if (wg-win-p wtree) scaled
(wg-asetf (wg-wtree-wlist scaled)
(wg-docar (sw it) (wg-scale-wtree sw wscale hscale)))
scaled)))
(defun wg-resize-frame-scale-wtree (wconfig)
"Set FRAME's size to WCONFIG's, returning a possibly scaled wtree.
If the frame size was set correctly, return WCONFIG's wtree
unchanged. If it wasn't, return a copy of WCONFIG's wtree scaled
with `wg-scale-wconfigs-wtree' to fit the frame as it exists."
(let ((frame (selected-frame)))
(wg-with-slots wconfig ((wcwidth wg-wconfig-width)
(wcheight wg-wconfig-height))
(when window-system (set-frame-size frame wcwidth wcheight))
(let ((fwidth (frame-parameter frame 'width))
(fheight (frame-parameter frame 'height)))
(if (and (= wcwidth fwidth) (= wcheight fheight))
(wg-wconfig-wtree wconfig)
(wg-scale-wconfigs-wtree wconfig fwidth fheight))))))
(defun wg-wtree-buf-uids (wtree)
"Return a new list of the buf uids of all wins in WTREE."
(if (not wtree)
(error "WTREE is nil in `wg-wtree-buf-uids'!"))
(wg-flatten-wtree wtree 'wg-win-buf-uid))
(defun wg-wtree-unique-buf-uids (wtree)
"Return a list of the unique buf uids of all wins in WTREE."
(cl-remove-duplicates (wg-wtree-buf-uids wtree) :test 'string=))
(defun wg-reset-window-tree ()
"Delete all but one window in `selected-frame', and reset
various parameters of that window in preparation for restoring
a wtree."
(delete-other-windows)
(set-window-dedicated-p nil nil))
(defun wg-restore-window-tree-helper (w)
"Recursion helper for `wg-restore-window-tree' W."
(if (wg-wtree-p w)
(cl-loop with dir = (wg-wtree-dir w)
for (win . rest) on (wg-wtree-wlist w)
do (when rest (split-window nil (wg-w-size win dir) (not dir)))
do (wg-restore-window-tree-helper win))
(wg-restore-window w)
(when (wg-win-selected w)
(setq wg-window-tree-selected-window (selected-window)))
(when (wg-win-minibuffer-scroll w)
(setq minibuffer-scroll-window (selected-window)))
(other-window 1)))
(defun wg-restore-window-tree (wtree)
"Restore WTREE in `selected-frame'."
(let ((window-min-width wg-window-min-width)
(window-min-height wg-window-min-height)
(wg-window-tree-selected-window nil))
(wg-reset-window-tree)
(wg-restore-window-tree-helper wtree)
(awhen wg-window-tree-selected-window (select-window it))))
(defun wg-window-tree-to-wtree (&optional window-tree)
"Return the serialization (a wg-wtree) of Emacs window tree WINDOW-TREE."
(wg-barf-on-active-minibuffer)
(unless window-tree
(setq window-tree (window-tree)))
(cl-labels
((inner (w) (if (windowp w) (wg-window-to-win w)
(wg-dbind (dir edges . wins) w
(wg-make-wtree
:dir dir
:edges edges
:wlist (mapcar #'inner wins))))))
(let ((w (car window-tree)))
(when (and (windowp w) (window-minibuffer-p w))
(error "Workgroups can't operate on minibuffer-only frames."))
(inner w))))
(defun wg-flatten-wtree (wtree &optional key)
"Return a new list by flattening WTREE.
KEY non returns returns a list of WTREE's wins.
KEY non-nil returns a list of the results of calling KEY on each win."
(cl-labels
((inner (w) (if (wg-win-p w) (list (if key (funcall key w) w))
(cl-mapcan #'inner (wg-wtree-wlist w)))))
(inner wtree)))
(defun wg-reverse-wlist (w &optional dir)
"Reverse W's wlist and those of all its sub-wtrees in direction DIR.
If DIR is nil, reverse WTREE horizontally.
If DIR is 'both, reverse WTREE both horizontally and vertically.
Otherwise, reverse WTREE vertically."
(cl-labels
((inner (w) (if (wg-win-p w) w
(wg-with-slots w ((d1 wg-wtree-dir))
(wg-make-wtree
:dir d1
:edges (wg-wtree-edges w)
:wlist (let ((wl2 (mapcar #'inner (wg-wtree-wlist w))))
(if (or (eq dir 'both) (eq dir d1))
(nreverse wl2)
wl2)))))))
(wg-normalize-wtree (inner w))))
(defun wg-wtree-move-window (wtree offset)
"Offset `selected-window' OFFSET places in WTREE."
(cl-labels
((inner (w) (if (wg-win-p w) w
(wg-with-slots w ((wlist wg-wtree-wlist))
(wg-make-wtree
:dir (wg-wtree-dir w)
:edges (wg-wtree-edges w)
:wlist (aif (cl-find t wlist :key 'wg-win-selected)
(wg-cyclic-offset-elt it wlist offset)
(mapcar #'inner wlist)))))))
(wg-normalize-wtree (inner wtree))))
(defun wg-frame-to-wconfig (&optional frame)
"Return the serialization (a wg-wconfig) of Emacs frame FRAME.
FRAME nil defaults to `selected-frame'."
(let* ((frame (or frame (selected-frame)))
(fullscrn (frame-parameter frame 'fullscreen)))
(wg-make-wconfig
:left (frame-parameter frame 'left)
:top (frame-parameter frame 'top)
:width (frame-parameter frame 'width)
:height (frame-parameter frame 'height)
:parameters `((fullscreen . ,fullscrn))
:vertical-scroll-bars (frame-parameter frame 'vertical-scroll-bars)
:scroll-bar-width (frame-parameter frame 'scroll-bar-width)
:wtree (wg-window-tree-to-wtree (window-tree frame))
)))
(defun wg-current-wconfig ()
"Return the current wconfig.
If `wg-current-wconfig' is non-nil, return it. Otherwise return
`wg-frame-to-wconfig'."
(or (frame-parameter nil 'wg-current-wconfig)
(wg-frame-to-wconfig)))
(defmacro wg-with-current-wconfig (frame wconfig &rest body)
"Eval BODY with WCONFIG current in FRAME.
FRAME nil defaults to `selected-frame'."
(declare (indent 2))
(wg-with-gensyms (frame-sym old-value)
`(let* ((,frame-sym (or ,frame (selected-frame)))
(,old-value (frame-parameter ,frame-sym 'wg-current-wconfig)))
(unwind-protect
(progn
(set-frame-parameter ,frame-sym 'wg-current-wconfig ,wconfig)
,@body)
(when (frame-live-p ,frame-sym)
(set-frame-parameter ,frame-sym 'wg-current-wconfig ,old-value))))))
(defun wg-make-blank-wconfig (&optional buffer)
"Return a new blank wconfig.
BUFFER or `wg-default-buffer' is visible in the only window."
(save-window-excursion
(delete-other-windows)
(switch-to-buffer (or buffer wg-default-buffer))
(wg-frame-to-wconfig)))
(defun wg-wconfig-move-window (wconfig offset)
"Offset `selected-window' OFFSET places in WCONFIG."
(wg-asetf (wg-wconfig-wtree wconfig) (wg-wtree-move-window it offset))
wconfig)
;;; base wconfig updating
(defun wg-update-working-wconfig-on-delete-frame (frame)
"Update FRAME's current workgroup's working-wconfig before
FRAME is deleted, so we don't lose its state."
(wg-flag-session-modified)
(with-selected-frame frame
(wg-update-current-workgroup-working-wconfig)))
(defun wg-update-working-wconfig-on-make-frame (frame)
"Update FRAME's current workgroup's working-wconfig before
FRAME is deleted, so we don't lose its state."
(if (> (length (frame-list)) 1)
(wg-flag-session-modified))
;;(with-selected-frame frame
;; (wg-update-current-workgroup-working-wconfig))
)
(defun wg-wconfig-buf-uids (wconfig)
"Return WCONFIG's wtree's `wg-wtree-buf-uids'."
(if (not (wg-wconfig-wtree wconfig))
(error "WTREE is nil in `wg-wconfig-buf-uids'!"))
(wg-wtree-unique-buf-uids (wg-wconfig-wtree wconfig)))
(defun wg-wconfig-restore-frame-position (wconfig &optional frame)
"Use WCONFIG to restore FRAME's position.
If frame is nil then `selected-frame'."
(-when-let* ((left (wg-wconfig-left wconfig))
(top (wg-wconfig-top wconfig)))
;; Check that arguments are integers
;; Problem: https://github.com/pashinin/workgroups2/issues/15
(if (and (integerp left)
(integerp top))
(set-frame-position frame left top))))
(defun wg-wconfig-restore-scroll-bars (wconfig)
"Restore `selected-frame's scroll-bar settings from WCONFIG."
(set-frame-parameter
nil 'vertical-scroll-bars (wg-wconfig-vertical-scroll-bars wconfig))
(set-frame-parameter
nil 'scroll-bar-width (wg-wconfig-scroll-bar-width wconfig)))
;;(defun wg-wconfig-restore-fullscreen (wconfig)
;; "Restore `selected-frame's fullscreen settings from WCONFIG."
;; (set-frame-parameter
;; nil 'fullscreen (wg-wconfig-parameters wconfig))
;; )
(defun wg-scale-wconfigs-wtree (wconfig new-width new-height)
"Scale WCONFIG's wtree with NEW-WIDTH and NEW-HEIGHT.
Return a copy WCONFIG's wtree scaled with `wg-scale-wtree' by the
ratio or NEW-WIDTH to WCONFIG's width, and NEW-HEIGHT to
WCONFIG's height."
(wg-normalize-wtree
(wg-scale-wtree
(wg-wconfig-wtree wconfig)
(/ (float new-width) (wg-wconfig-width wconfig))
(/ (float new-height) (wg-wconfig-height wconfig)))))
(defun wg-scale-wconfig-to-frame (wconfig)
"Scale WCONFIG buffers to fit current frame size.
Return a scaled copy of WCONFIG."
(interactive)
(wg-scale-wconfigs-wtree wconfig
(frame-parameter nil 'width)
(frame-parameter nil 'height)))
(defun wg-frame-resize-and-position (wconfig &optional frame)
"Apply WCONFIG's size and position to a FRAME."
(interactive)
(unless frame (setq frame (selected-frame)))
(let* ((params (wg-wconfig-parameters wconfig))
fullscreen)
(set-frame-parameter frame 'fullscreen (if (assoc 'fullscreen params)
(cdr (assoc 'fullscreen params))
nil))
(when (and wg-restore-frame-position
(not (frame-parameter frame 'fullscreen)))
(wg-wconfig-restore-frame-position wconfig frame))
))
(defun wg-restore-frame-size-position (wconfig &optional fs)
"Smart-restore of frame size and position.
Depending on `wg-remember-frame-for-each-wg' frame parameters may
be restored for each workgroup.
If `wg-remember-frame-for-each-wg' is nil (by default) then
current frame parameters are saved/restored to/from first
workgroup. And frame parameters for all other workgroups are just
ignored.
"
(interactive)
(let* ((params (wg-wconfig-parameters wconfig))
fullscreen)
;; Frame maximized / fullscreen / none
(unless wg-remember-frame-for-each-wg
(setq params (wg-wconfig-parameters (wg-workgroup-working-wconfig (wg-first-workgroup)))))
(setq fullscreen (if (assoc 'fullscreen params)
(cdr (assoc 'fullscreen params))
nil))
(when (and fs
fullscreen
(or wg-remember-frame-for-each-wg
(null (wg-current-workgroup t))))
(set-frame-parameter nil 'fullscreen fullscreen)
;; I had bugs restoring maximized frame:
;; Frame could be maximized but buffers are not scaled to fit it.
;;
;; Maybe because of `set-frame-parameter' takes some time to finish and is async.
;; So I tried this and it helped
(sleep-for 0 100))
;; Position
(when (and wg-restore-frame-position
wg-remember-frame-for-each-wg
(not (frame-parameter nil 'fullscreen)))
(wg-wconfig-restore-frame-position wconfig))
))
(defun wg-restore-frames ()
"Try to recreate opened frames, take info from session's 'frame-list parameter."
(interactive)
(delete-other-frames)
(awhen (wg-current-session t)
(let ((fl (wg-session-parameter 'frame-list nil it))
(frame (selected-frame)))
(mapc (lambda (wconfig)
(with-selected-frame (make-frame)
;;(wg-frame-resize-and-position wconfig)
;;(wg-restore-frame-size-position wconfig)
;;(wg-wconfig-restore-frame-position wconfig)
(wg-restore-wconfig wconfig)
)) fl)
(select-frame-set-input-focus frame))))
;; FIXME: throw a specific error if the restoration was unsuccessful
(defun wg-restore-wconfig (wconfig &optional frame)
"Restore a workgroup configuration WCONFIG in a FRAME.
Runs each time you're switching workgroups."
(unless frame (setq frame (selected-frame)))
(let ((wg-record-incorrectly-restored-bufs t)
(wg-incorrectly-restored-bufs nil)
(params (wg-wconfig-parameters wconfig))
fullscreen)
(wg-barf-on-active-minibuffer)
(when wg-restore-scroll-bars
(wg-wconfig-restore-scroll-bars wconfig))
(when (null (wg-current-workgroup t))
(set-frame-parameter frame 'fullscreen (if (assoc 'fullscreen params)
(cdr (assoc 'fullscreen params))
nil)))
;; Restore frame position
(when (and wg-restore-frame-position
(not (frame-parameter nil 'fullscreen))
(null (wg-current-workgroup t)))
(wg-wconfig-restore-frame-position wconfig frame))
;; Restore buffers
(wg-restore-window-tree (wg-scale-wconfig-to-frame wconfig))
(when wg-incorrectly-restored-bufs
(message "Unable to restore these buffers: %S\
If you want, restore them manually and try again."
(mapcar 'wg-buf-name wg-incorrectly-restored-bufs)))))
;;; saved wconfig commands
(defun wg-save-wconfig ()
"Save the current wconfig to the current workgroup's saved wconfigs."
(interactive)
(let* ((workgroup (wg-current-workgroup))
(name (wg-read-saved-wconfig-name workgroup))
(wconfig (wg-current-wconfig)))
(setf (wg-wconfig-name wconfig) name)
(wg-workgroup-save-wconfig workgroup wconfig)
(wg-fontified-message
(:cmd "Saved: ")
(:cur name))))
(defun wg-restore-saved-wconfig ()
"Restore one of the current workgroup's saved wconfigs in `selected-frame'."
(interactive)
(let ((workgroup (wg-current-workgroup)))
(wg-restore-wconfig-undoably
(wg-workgroup-get-saved-wconfig
workgroup
(ido-completing-read "Saved wconfig: "
(mapcar 'wg-wconfig-name (wg-workgroup-saved-wconfigs workgroup))
nil t)))))
(defun wg-kill-saved-wconfig ()
"Kill one of the current workgroup's saved wconfigs.
Also add it to the wconfig kill-ring."
(interactive)
(let* ((workgroup (wg-current-workgroup))
(wconfig (wg-read-saved-wconfig workgroup)))
(wg-workgroup-kill-saved-wconfig workgroup wconfig)
(wg-add-to-wconfig-kill-ring wconfig)
(wg-fontified-message
(:cmd "Deleted: ")
(:cur (wg-wconfig-name wconfig)))))
(defun wg-reverse-wconfig (wconfig &optional dir)
"Reverse WCONFIG's wtree's wlist in direction DIR."
(wg-asetf (wg-wconfig-wtree wconfig) (wg-reverse-wlist it dir))
wconfig)
;; specialbufs
(defcustom wg-special-buffer-serdes-functions
'(wg-serialize-comint-buffer
)
"Functions providing serialization/deserialization for complex buffers.
Use `wg-support' macro and this variable will be filled
automatically.
An entry should be either a function symbol or a lambda, and should
accept a single Emacs buffer object as an argument.
When a buffer is to be serialized, it is passed to each of these
functions in turn until one returns non-nil, or the list ends. A
return value of nil indicates that the function can't handle
buffers of that type. A non-nil return value indicates that it
can. The first non-nil return value becomes the buffer's special
serialization data. The return value should be a cons, with a
deserialization function (a function symbol or a lambda) as the car,
and any other serialization data as the cdr.
When it comes time to deserialize the buffer, the deserialization
function (the car of the cons mentioned above) is passed the
wg-buf object, from which it should restore the buffer. The
special serialization data itself can be accessed
with (cdr (wg-buf-special-data <wg-buf>)). The deserialization
function must return the restored Emacs buffer object.
See the definitions of the functions in this list for examples of
how to write your own."
:type 'alist
:group 'workgroups)
;; Dired
(wg-support 'dired-mode 'dired
`((deserialize . ,(lambda (buffer vars)
(when (or wg-restore-remote-buffers
(not (file-remote-p default-directory)))
(let ((d (wg-get-first-existing-dir)))
(if (file-directory-p d) (dired d))))))))
;; `Info-mode' C-h i
(wg-support 'Info-mode 'info
`((save . (Info-current-file Info-current-node))
(deserialize . ,(lambda (buffer vars)
;;(with-current-buffer
;; (get-buffer-create (wg-buf-name buffer))
(aif vars
(if (fboundp 'Info-find-node)
(apply #'Info-find-node it))
(info)
(get-buffer (wg-buf-name buffer)))))))
;; `help-mode'
;; Bug: https://github.com/pashinin/workgroups2/issues/29
;; bug in wg-get-value
(wg-support 'help-mode 'help-mode
`((save . (help-xref-stack-item help-xref-stack help-xref-forward-stack))
(deserialize . ,(lambda (buffer vars)
(wg-dbind (item stack forward-stack) vars
(condition-case err
(apply (car item) (cdr item))
(error (message "%s" err)))
(awhen (get-buffer "*Help*")
(set-buffer it)
(wg-when-boundp (help-xref-stack help-xref-forward-stack)
(setq help-xref-stack stack
help-xref-forward-stack forward-stack))))))))
;; ielm
(wg-support 'inferior-emacs-lisp-mode 'ielm
`((deserialize . ,(lambda (buffer vars)
(ielm) (get-buffer "*ielm*")))))
;; Magit status
(wg-support 'magit-status-mode 'magit
`((deserialize . ,(lambda (buffer vars)
(if (file-directory-p default-directory)
(magit-status default-directory)
(let ((d (wg-get-first-existing-dir)))
(if (file-directory-p d) (dired d))))))))
;; Shell
(wg-support 'shell-mode 'shell
`((deserialize . ,(lambda (buffer vars)
(shell (wg-buf-name buffer))))))
;; org-agenda buffer
(defun wg-get-org-agenda-view-commands ()
"Return commands to restore the state of Agenda buffer.
Can be restored using \"(eval commands)\"."
(interactive)
(when (boundp 'org-agenda-buffer-name)
(if (get-buffer org-agenda-buffer-name)
(with-current-buffer org-agenda-buffer-name
(let* ((p (or (and (looking-at "\\'") (1- (point))) (point)))
(series-redo-cmd (get-text-property p 'org-series-redo-cmd)))
(if series-redo-cmd
(get-text-property p 'org-series-redo-cmd)
(get-text-property p 'org-redo-cmd)))))))
(defun wg-run-agenda-cmd (f)
"Run commands F in Agenda buffer.
You can get these commands using `wg-get-org-agenda-view-commands'."
(when (and (boundp 'org-agenda-buffer-name)
(fboundp 'org-current-line)
(fboundp 'org-goto-line))
(if (get-buffer org-agenda-buffer-name)
(save-window-excursion
(with-current-buffer org-agenda-buffer-name
(let* ((line (org-current-line)))
(if f (eval f))
(org-goto-line line)))))))
(wg-support 'org-agenda-mode 'org-agenda
'((serialize . (lambda (buffer)
(wg-get-org-agenda-view-commands)))
(deserialize . (lambda (buffer vars)
(org-agenda-list)
(awhen (get-buffer org-agenda-buffer-name)
(with-current-buffer it
(wg-run-agenda-cmd vars))
it)))))
;; eshell
(wg-support 'eshell-mode 'esh-mode
'((deserialize . (lambda (buffer vars)
(prog1 (eshell t)
(rename-buffer (wg-buf-name buffer) t))))))
;; term-mode
;;
;; This should work for `ansi-term's, too, as there doesn't seem to
;; be any difference between the two except how the name of the
;; buffer is generated.
;;
(wg-support 'term-mode 'term
`((serialize . ,(lambda (buffer)
(if (get-buffer-process buffer)
(-last-item (process-command (get-buffer-process buffer)))
"/bin/bash")))
(deserialize . ,(lambda (buffer vars)
(cl-labels ((term-window-width () 80)
(window-height () 24))
(prog1 (term vars)
(rename-buffer (wg-buf-name buffer) t)))))))
;; `inferior-python-mode'
(wg-support 'inferior-python-mode 'python
`((save . (python-shell-interpreter python-shell-interpreter-args))
(deserialize . ,(lambda (buffer vars)
(wg-dbind (pythoncmd pythonargs) vars
(run-python (concat pythoncmd " " pythonargs))
(awhen (get-buffer (process-buffer
(python-shell-get-or-create-process)))
(with-current-buffer it (goto-char (point-max)))
it))))))
;; Sage shell ;;
(wg-support 'inferior-sage-mode 'sage-mode
`((deserialize . ,(lambda (buffer vars)
(save-window-excursion
(if (boundp' sage-command)
(run-sage t sage-command t)))
(if (boundp 'sage-buffer)
(awhen sage-buffer
(set-buffer it)
(switch-to-buffer sage-buffer)
(goto-char (point-max))))))))
;; `inferior-ess-mode' M-x R
(wg-support 'inferior-ess-mode 'ess-inf
`((save . (inferior-ess-program))
(deserialize . ,(lambda (buffer vars)
(wg-dbind (cmd) vars
(let ((ess-ask-about-transfile nil)
(ess-ask-for-ess-directory nil)
(ess-history-file nil))
(R)
(get-buffer (wg-buf-name buffer))))))))
;; `inferior-octave-mode'
(wg-support 'inferior-octave-mode 'octave
`((deserialize . ,(lambda (buffer vars)
(prog1 (run-octave)
(rename-buffer (wg-buf-name buffer) t))))))
;; `prolog-inferior-mode'
(wg-support 'prolog-inferior-mode 'prolog
`((deserialize . ,(lambda (buffer vars)
(save-window-excursion
(run-prolog nil))
(switch-to-buffer "*prolog*")
(goto-char (point-max))))))
;; `ensime-inf-mode'
(wg-support 'ensime-inf-mode 'ensime
`((deserialize . ,(lambda (buffer vars)
(save-window-excursion
(ensime-inf-switch))
(when (boundp 'ensime-inf-buffer-name)
(switch-to-buffer ensime-inf-buffer-name)
(goto-char (point-max)))))))
;; compilation-mode
;;
;; I think it's not a good idea to compile a program just to switch
;; workgroups. So just restoring a buffer name.
(wg-support 'compilation-mode 'compile
`((serialize . ,(lambda (buffer)
(if (boundp' compilation-arguments) compilation-arguments)))
(deserialize . ,(lambda (buffer vars)
(save-window-excursion
(get-buffer-create (wg-buf-name buffer)))
(with-current-buffer (wg-buf-name buffer)
(when (boundp' compilation-arguments)
(make-local-variable 'compilation-arguments)
(setq compilation-arguments vars)))
(switch-to-buffer (wg-buf-name buffer))
(goto-char (point-max))))))
;; grep-mode
;; see grep.el - `compilation-start' - it is just a compilation buffer
;; local variables:
;; `compilation-arguments' == (cmd mode nil nil)
(wg-support 'grep-mode 'grep
`((serialize . ,(lambda (buffer)
(if (boundp' compilation-arguments) compilation-arguments)))
(deserialize . ,(lambda (buffer vars)
(compilation-start (car vars) (nth 1 vars))
(switch-to-buffer "*grep*")))))
;; `speedbar-mode' (has bugs)
;; only from sr-speedbar.el
;;(wg-support 'speedbar-mode 'sr-speedbar
;; `((deserialize . ,(lambda (buffer vars)
;; ;;(with-current-buffer (get-buffer-create "*SPEEDBAR*")
;; (with-no-warnings
;; (setq speedbar-buffer (get-buffer-create "*SPEEDBAR*"))
;; (setq speedbar-frame (selected-frame)
;; dframe-attached-frame (selected-frame)
;; speedbar-select-frame-method 'attached
;; speedbar-verbosity-level 0
;; speedbar-last-selected-file nil)
;; (set-buffer speedbar-buffer)
;; (speedbar-mode)
;; (speedbar-reconfigure-keymaps)
;; (speedbar-update-contents)
;; (speedbar-set-timer 1)
;; (aif (get-buffer-window "*SPEEDBAR*")
;; (set-window-dedicated-p it t))
;; (get-buffer-create "*SPEEDBAR*"))))))
(defun wg-deserialize-slime-buffer (buf)
"Deserialize `slime' buffer BUF."
(when (require 'slime nil 'noerror)
(wg-dbind (this-function args) (wg-buf-special-data buf)
(let ((default-directory (car args))
(arguments (nth 1 args)))
(when (and (fboundp 'slime-start*)
(fboundp 'slime-process))
(save-window-excursion
(slime-start* arguments))
(switch-to-buffer (process-buffer (slime-process)))
(current-buffer))))))
;; `comint-mode' (general mode for all shells)
;;
;; It may have different shells. So we need to determine which shell is
;; now in `comint-mode' and how to restore it.
;;
;; Just executing `comint-exec' may be not enough because we can miss
;; some hooks or any other stuff that is executed when you run a
;; specific shell.
(defun wg-serialize-comint-buffer (buffer)
"Serialize comint BUFFER."
(with-current-buffer buffer
(if (fboundp 'comint-mode)
(when (eq major-mode 'comint-mode)
;; `slime-inferior-lisp-args' var is used when in `slime'
(when (and (boundp 'slime-inferior-lisp-args)
slime-inferior-lisp-args)
(list 'wg-deserialize-slime-buffer
(list default-directory slime-inferior-lisp-args)
))))))
;; inf-mongo
;; https://github.com/tobiassvn/inf-mongo
;; `mongo-command' - command used to start inferior mongo
(wg-support 'inf-mongo-mode 'inf-mongo
`((serialize . ,(lambda (buffer)
(if (boundp 'inf-mongo-command) inf-mongo-command)))
(deserialize . ,(lambda (buffer vars)
(save-window-excursion
(when (fboundp 'inf-mongo)
(inf-mongo vars)))
(when (get-buffer "*mongo*")
(switch-to-buffer "*mongo*")
(goto-char (point-max)))))))
(defun wg-temporarily-rename-buffer-if-exists (buffer)
"Rename BUFFER if it exists."
(when (get-buffer buffer)
(with-current-buffer buffer
(rename-buffer "*wg--temp-buffer*" t))))
;; SML shell
;; Functions to serialize deserialize inferior sml buffer
;; `inf-sml-program' is the program run as inferior sml, is the
;; `inf-sml-args' are the extra parameters passed, `inf-sml-host'
;; is the host on which sml was running when serialized
(wg-support 'inferior-sml-mode 'sml-mode
`((serialize . ,(lambda (buffer)
(list (if (boundp 'sml-program-name) sml-program-name)
(if (boundp 'sml-default-arg) sml-default-arg)
(if (boundp 'sml-host-name) sml-host-name))))
(deserialize . ,(lambda (buffer vars)
(wg-dbind (program args host) vars
(save-window-excursion
;; If a inf-sml buffer already exists rename it temporarily
;; otherwise `run-sml' will simply switch to the existing
;; buffer, however we want to create a separate buffer with
;; the serialized name
(let* ((inf-sml-buffer-name (concat "*"
(file-name-nondirectory program)
"*"))
(existing-sml-buf (wg-temporarily-rename-buffer-if-exists
inf-sml-buffer-name)))
(with-current-buffer (run-sml program args host)
;; Rename the buffer
(rename-buffer (wg-buf-name buffer) t)
;; Now we can re-rename the previously renamed buffer
(when existing-sml-buf
(with-current-buffer existing-sml-buf
(rename-buffer inf-sml-buffer-name t))))))
(switch-to-buffer (wg-buf-name buffer))
(goto-char (point-max)))))))
;; Geiser repls
;; http://www.nongnu.org/geiser/
(wg-support 'geiser-repl-mode 'geiser
`((save . (geiser-impl--implementation))
(deserialize . ,(lambda (buffer vars)
(when (fboundp 'run-geiser)
(wg-dbind (impl) vars
(run-geiser impl)
(goto-char (point-max))))
(switch-to-buffer (wg-buf-name buffer))))))
;; w3m-mode
(wg-support 'w3m-mode 'w3m
`((save . (w3m-current-url))
(deserialize . ,(lambda (buffer vars)
(wg-dbind (url) vars
(w3m-goto-url url))))))
;; notmuch
(wg-support 'notmuch-hello-mode 'notmuch
`((deserialize . ,(lambda (buffer vars)
(notmuch)
(get-buffer (wg-buf-name buffer))))))
;; Wanderlust modes:
;; WL - folders
;;(defun wg-deserialize-wl-folders-buffer (buf)
;; ""
;; (if (fboundp 'wl)
;; (wg-dbind (this-function) (wg-buf-special-data buf)
;; ;;(when (not (eq major-mode 'wl-folder-mode))
;; (wl)
;; (goto-char (point-max))
;; (current-buffer)
;; )))
;;
;;(defun wg-serialize-wl-folders-buffer (buffer)
;; ""
;; (if (fboundp 'wl)
;; (with-current-buffer buffer
;; (when (eq major-mode 'wl-folder-mode)
;; (list 'wg-deserialize-wl-folders-buffer
;; )))))
;; WL - summary mode (list of mails)
;;(defun wg-deserialize-wl-summary-buffer (buf)
;; ""
;; (interactive)
;; (if (fboundp 'wl)
;; (wg-dbind (this-function param-list) (wg-buf-special-data buf)
;; (when (not (eq major-mode 'wl-summary-mode))
;; (let ((fld-name (car param-list)))
;; ;;(switch-to-buffer "*scratch*")
;; ;;(wl)
;; ;;(wl-folder-jump-folder fld-name)
;; ;;(message fld-name)
;; ;;(goto-char (point-max))
;; ;;(insert fld-name)
;; (current-buffer)
;; )))))
;;
;;(defun wg-serialize-wl-summary-buffer (buffer)
;; ""
;; (if (fboundp 'wl)
;; (with-current-buffer buffer
;; (when (eq major-mode 'wl-summary-mode)
;; (list 'wg-deserialize-wl-summary-buffer
;; (wg-take-until-unreadable (list wl-summary-buffer-folder-name))
;; )))))
;;
;;
;;;; mime-view-mode
;;
;;(defun wg-deserialize-mime-view-buffer (buf)
;; ""
;; (wg-dbind (this-function) (wg-buf-special-data buf)
;; (when (not (eq major-mode 'mime-view-mode))
;; ;;(wl-summary-enter-handler 3570) ; only in wl-summary-mode
;; ;;(wl-summary-enter-handler) ; only in wl-summary-mode
;; (current-buffer)
;; )))
;;
;;(defun wg-serialize-mime-view-buffer (buffer)
;; ""
;; (with-current-buffer buffer
;; (when (eq major-mode 'mime-view-mode)
;; (list 'wg-deserialize-mime-view-buffer
;; ))))
;; emms-playlist-mode
;;
;; Help me on this one:
;; 1. How to start emms without any user interaction?
;;
;;(defun wg-deserialize-emms-buffer (buf)
;; "Deserialize emms-playlist buffer BUF."
;; (when (require 'emms-setup nil 'noerror)
;; (require 'emms-player-mplayer)
;; (emms-standard)
;; (emms-default-players)
;; (if (fboundp 'emms-playlist-mode)
;; (wg-dbind (this-function args) (wg-buf-special-data buf)
;; (let ((default-directory (car args)))
;; (save-window-excursion
;; ;;(emms)
;; (if (or (null emms-playlist-buffer)
;; (not (buffer-live-p emms-playlist-buffer)))
;; ;;(call-interactively 'emms-add-file)
;; (emms-source-directory "/usr/data/disk_3/Music/SORT/")
;; ))
;; ;; (emms)
;; ;;(with-current-buffer emms-playlist-buffer-name
;; ;;(emms-source-playlist-directory-tree "/usr/data/disk_3/Music/SORT/")
;; ;;(emms-source-directory "/usr/data/disk_3/Music/SORT")
;; ;;(switch-to-buffer emms-playlist-buffer-name)
;; (emms-playlist-mode-go)
;; (current-buffer)
;; )))))
;;
;;(defun wg-serialize-emms-buffer (buffer)
;; "Serialize emms BUFFER."
;; (with-current-buffer buffer
;; (if (fboundp 'emms-playlist-mode)
;; (when (eq major-mode 'emms-playlist-mode)
;; (list 'wg-deserialize-emms-buffer
;; (wg-take-until-unreadable (list default-directory))
;; )))))
;;; buffer-local variable serdes
(defun wg-serialize-buffer-mark-ring ()
"Return a new list of the positions of the marks in `mark-ring'."
(mapcar 'marker-position mark-ring))
(defun wg-deserialize-buffer-mark-ring (positions)
"Set `mark-ring' to a new list of markers created from POSITIONS."
(setq mark-ring
(mapcar (lambda (pos) (set-marker (make-marker) pos))
positions)))
(defun wg-deserialize-buffer-major-mode (major-mode-symbol)
"Conditionally retore MAJOR-MODE-SYMBOL in `current-buffer'."
(and (fboundp major-mode-symbol)
(not (eq major-mode-symbol major-mode))
(funcall major-mode-symbol)))
(defun wg-deserialize-buffer-local-variables (buf)
"Restore BUF's buffer local variables in `current-buffer'."
(cl-loop for ((var . val) . rest) on (wg-buf-local-vars buf)
do (awhen (assq var wg-buffer-local-variables-alist)
(wg-dbind (var ser des) it
(if des (funcall des val)
(set var val))))))
(defmacro wg-workgroup-list ()
"Setf'able `wg-current-session' modified slot accessor."
`(wg-session-workgroup-list (wg-current-session)))
(defmacro wg-buf-list ()
"Setf'able `wg-current-session' buf-list slot accessor."
`(wg-session-buf-list (wg-current-session)))
(defun wg-restore-default-buffer (&optional switch)
"Return `wg-default-buffer' and maybe SWITCH to it."
(if switch
(switch-to-buffer wg-default-buffer t)
(get-buffer-create wg-default-buffer)))
(defun wg-restore-existing-buffer (buf &optional switch)
"Return existing buffer from BUF and maybe SWITCH to it."
(-when-let (b (wg-find-buf-in-buffer-list buf (wg-buffer-list-emacs)))
(if switch (switch-to-buffer b t))
(with-current-buffer b
(wg-set-buffer-uid-or-error (wg-buf-uid buf))
b)))
(defun wg-restore-file-buffer (buf &optional switch)
"Restore BUF by finding its file and maybe SWITCH to it.
Return the created buffer.
If BUF's file doesn't exist, call `wg-restore-default-buffer'"
;;(-when-let ((file-name (wg-buf-file-name buf)))
(let ((file-name (wg-buf-file-name buf)))
(when (and file-name
(or wg-restore-remote-buffers
(not (file-remote-p file-name))))
(cond ((file-exists-p file-name)
;; jit ignore errors
;;(ignore-errors
(condition-case err
(let ((b (find-file-noselect file-name nil nil nil)))
(with-current-buffer b
(rename-buffer (wg-buf-name buf) t)
(wg-set-buffer-uid-or-error (wg-buf-uid buf))
(when wg-restore-mark
(set-mark (wg-buf-mark buf))
(deactivate-mark))
(wg-deserialize-buffer-local-variables buf)
)
(if switch (switch-to-buffer b))
b)
(error
(message "Error while restoring a file %s:\n %s" file-name (error-message-string err))
nil)))
(t
;; try directory
(if (file-directory-p (file-name-directory file-name))
(dired (file-name-directory file-name))
(progn
(message "Attempt to restore nonexistent file: %S" file-name)
nil))
)))))
(defun wg-restore-special-buffer (buf &optional switch)
"Restore a buffer BUF with DESERIALIZER-FN and maybe SWITCH to it."
(-when-let*
((special-data (wg-buf-special-data buf))
(buffer (save-window-excursion
(condition-case err
(funcall (car special-data) buf)
(error (message "Error deserializing %S: %S" (wg-buf-name buf) err)
nil)))))
(if switch (switch-to-buffer buffer t))
(with-current-buffer buffer
(wg-set-buffer-uid-or-error (wg-buf-uid buf)))
buffer))
(defun wg-restore-buffer (buf &optional switch)
"Restore BUF, return it and maybe SWITCH to it."
(when buf
(fset 'buffer-list wg-buffer-list-original)
(prog1
(or (wg-restore-existing-buffer buf switch)
(wg-restore-special-buffer buf switch) ;; non existent dired problem
(wg-restore-file-buffer buf switch)
(progn (wg-restore-default-buffer switch) nil))
(if wg-mess-with-buffer-list
(fset 'buffer-list wg-buffer-list-function)))))
;;; buffer object utils
(defun wg-buffer-uid (buffer-or-name)
"Return BUFFER-OR-NAME's buffer-local value of `wg-buffer-uid'."
(buffer-local-value 'wg-buffer-uid (wg-get-buffer buffer-or-name)))
(defun wg-bufobj-uid (bufobj)
"Return BUFOBJ's uid."
(cl-etypecase bufobj
(buffer (wg-buffer-uid bufobj))
(wg-buf (wg-buf-uid bufobj))
(string (wg-bufobj-uid (wg-get-buffer bufobj)))))
(defun wg-bufobj-name (bufobj)
"Return BUFOBJ's buffer name."
(cl-etypecase bufobj
(buffer (buffer-name bufobj))
(wg-buf (wg-buf-name bufobj))
(string (wg-buffer-name bufobj))))
(defun wg-bufobj-file-name (bufobj)
"Return BUFOBJ's filename."
(cl-etypecase bufobj
(buffer (buffer-file-name bufobj))
(wg-buf (wg-buf-file-name bufobj))
(string (wg-bufobj-file-name (wg-get-buffer bufobj)))))
(defun wg-buf-major-mode (buf)
"Return BUF's `major-mode'.
It's stored in BUF's local-vars list, since it's a local variable."
(wg-aget (wg-buf-local-vars buf) 'major-mode))
(defun wg-buffer-major-mode (bufobj)
"Return BUFOBJ's `major-mode'.
It works with Emacs buffer, Workgroups buffer object and a simple string."
(cl-etypecase bufobj
(buffer (wg-buffer-major-mode bufobj))
(wg-buf (wg-buf-major-mode bufobj))
(string (wg-buffer-major-mode bufobj))))
;; `wg-equal-bufobjs' and `wg-find-bufobj' may need to be made a lot smarter
(defun wg-equal-bufobjs (bufobj1 bufobj2)
"Return t if BUFOBJ1 is \"equal\" to BUFOBJ2."
(let ((fname1 (wg-bufobj-file-name bufobj1))
(fname2 (wg-bufobj-file-name bufobj2)))
(cond ((and fname1 fname2) (string= fname1 fname2))
((or fname1 fname2) nil)
((string= (wg-bufobj-name bufobj1) (wg-bufobj-name bufobj2)) t))))
(defun wg-find-bufobj (bufobj bufobj-list)
"Find BUFOBJ in BUFOBJ-LIST, testing with `wg-equal-bufobjs'."
(cl-find bufobj bufobj-list :test 'wg-equal-bufobjs))
(defun wg-find-bufobj-by-uid (uid bufobj-list)
"Find the bufobj in BUFOBJ-LIST with uid UID."
(cl-find uid bufobj-list :test 'string= :key 'wg-bufobj-uid))
(defun wg-find-buffer-in-buf-list (buffer-or-name buf-list)
"Find BUFFER-OR-NAME in BUF-LIST."
(aif (wg-buffer-uid buffer-or-name)
(wg-find-bufobj-by-uid it buf-list)
(wg-find-bufobj buffer-or-name buf-list)))
(defun wg-find-buf-in-buffer-list (buf buffer-list)
"Find BUF in BUFFER-LIST."
(or (wg-find-bufobj-by-uid (wg-buf-uid buf) buffer-list)
(wg-find-bufobj buf buffer-list)))
(defun wg-find-buf-by-uid (uid)
"Find a buf in `wg-buf-list' by UID."
(when uid
(wg-find-bufobj-by-uid uid (wg-buf-list))))
(defun wg-set-buffer-uid-or-error (uid &optional buffer)
"Change UID value of a BUFFER's local var `wg-buffer-uid'.
If BUFFER already has a buffer local value of `wg-buffer-uid',
and it's not equal to UID, error."
(if wg-buffer-uid
;;(if (string= wg-buffer-uid uid) uid
;; (error "uids don't match %S and %S" uid wg-buffer-uid))
(setq wg-buffer-uid uid)))
(defun wg-buffer-special-data (buffer)
"Return BUFFER's auxiliary serialization, or nil."
(cl-some (lambda (fn) (funcall fn buffer)) wg-special-buffer-serdes-functions))
(defun wg-serialize-buffer-local-variables ()
"Return an alist of buffer-local variable symbols and their values.
See `wg-buffer-local-variables-alist' for details."
(wg-docar (entry wg-buffer-local-variables-alist)
(wg-dbind (var ser des) entry
(when (local-variable-p var)
(cons var (if ser (funcall ser) (symbol-value var)))))))
(defun wg-buffer-to-buf (buffer)
"Return the serialization (a wg-buf) of Emacs buffer BUFFER."
(with-current-buffer buffer
(wg-make-buf
:name (buffer-name)
:file-name (buffer-file-name)
:point (point)
:mark (mark)
:local-vars (wg-serialize-buffer-local-variables)
:special-data (wg-buffer-special-data buffer))))
(defun wg-add-buffer-to-buf-list (buffer)
"Make a buf from BUFFER, and add it to `wg-buf-list' if necessary.
If there isn't already a buf corresponding to BUFFER in
`wg-buf-list', make one and add it. Return BUFFER's uid
in either case."
(when buffer
(with-current-buffer buffer
(setq wg-buffer-uid
(aif (wg-find-buffer-in-buf-list buffer (wg-buf-list))
(wg-buf-uid it)
(let ((buf (wg-buffer-to-buf buffer)))
(push buf (wg-buf-list))
(wg-buf-uid buf)))))))
(defun wg-buffer-uid-or-add (buffer)
"Return BUFFER's uid.
If there isn't already a buf corresponding to BUFFER in
`wg-buf-list', make one and add it."
(or (wg-buffer-uid buffer) (wg-add-buffer-to-buf-list buffer)))
(defun wg-bufobj-uid-or-add (bufobj)
"If BUFOBJ is a wg-buf, return its uid.
If BUFOBJ is a buffer or a buffer name, see `wg-buffer-uid-or-add'."
(cl-etypecase bufobj
(wg-buf (wg-buf-uid bufobj)) ;; possibly also add to `wg-buf-list'
(buffer (wg-buffer-uid-or-add bufobj))
(string (wg-bufobj-uid-or-add (wg-get-buffer bufobj)))))
(defun wg-reset-buffer (buffer)
"Return BUFFER.
Currently only sets BUFFER's `wg-buffer-uid' to nil."
(with-current-buffer buffer (setq wg-buffer-uid nil)))
(defun wg-update-buffer-in-buf-list (&optional buffer)
"Update BUFFER's corresponding buf in `wg-buf-list'.
BUFFER nil defaults to `current-buffer'."
(let ((buffer (or buffer (current-buffer))))
(-when-let* ((uid (wg-buffer-uid buffer))
(old-buf (wg-find-buf-by-uid uid))
(new-buf (wg-buffer-to-buf buffer)))
(setf (wg-buf-uid new-buf) (wg-buf-uid old-buf))
(wg-asetf (wg-buf-list) (cons new-buf (remove old-buf it))))))
(defvar wg-just-exited-minibuffer nil
"Flag set by `minibuffer-exit-hook'.
To exempt from undoification those window-configuration changes
caused by exiting the minibuffer. This is ugly, but necessary.
It may seem like we could just null out
`wg-undoify-window-configuration-change' in
`minibuffer-exit-hook', but that also prevents undoification of
window configuration changes triggered by commands called with
`execute-extended-command' -- i.e. it's just too coarse.")
(defcustom wg-no-confirm-on-destructive-operation nil
"Do not request confirmation before various destructive operations."
:type 'boolean
:group 'workgroups)
(defcustom wg-minibuffer-message-timeout 0.75
"Bound to `minibuffer-message-timeout' when messaging while the
minibuffer is active."
:type 'float
:group 'workgroups)
(defun wg-read-object (prompt test warning &optional initial-contents keymap
read hist default-value inherit-input-method)
"PROMPT for an object that satisfies TEST. WARNING if necessary.
INITIAL-CONTENTS KEYMAP READ HIST DEFAULT-VALUE
INHERIT-INPUT-METHOD are `read-from-minibuffer's args."
(cl-labels ((read () (read-from-minibuffer
prompt initial-contents keymap read hist
default-value inherit-input-method)))
(let ((obj (read)))
(when (and (equal obj "") default-value) (setq obj default-value))
(while (not (funcall test obj))
(message warning)
(sit-for wg-minibuffer-message-timeout)
(setq obj (read)))
obj)))
(defun wg-read-new-workgroup-name (&optional prompt)
"Read a non-empty name string from the minibuffer.
Print PROMPT"
(let ((default (wg-new-default-workgroup-name)))
(wg-read-object
(or prompt (format "Name (default: %S): " default))
(lambda (new) (and (stringp new)
(not (equal new ""))
(wg-unique-workgroup-name-p new)))
"Please enter a unique, non-empty name"
nil nil nil nil default)))
(defun wg-read-workgroup-index ()
"Prompt for the index of a workgroup."
(let ((max (1- (length (wg-workgroup-list-or-error)))))
(wg-read-object
(format "%s\n\nEnter [0-%d]: " (wg-workgroup-list-display) max)
(lambda (obj) (and (integerp obj) (wg-within obj 0 max t)))
(format "Please enter an integer [%d-%d]" 0 max)
nil nil t)))
(defun wg-minibuffer-inactive-p ()
"Return t when `minibuffer-depth' is zero, nil otherwise."
(zerop (minibuffer-depth)))
(defun wg-barf-on-active-minibuffer ()
"Throw an error when the minibuffer is active."
(when (not (wg-minibuffer-inactive-p))
(error "Exit minibuffer to use workgroups functions!")))
(defvar wg-deactivation-list nil
"A stack of workgroups that are currently being switched away from.
Used to avoid associating the old workgroup's buffers with the
new workgroup during a switch.")
(defun wg-flag-session-modified (&optional session)
"Set SESSION's modified flag."
(when (and wg-flag-modified
(or session (wg-current-session t)))
(setf (wg-session-modified (or session (wg-current-session t))) t)))
(defun wg-flag-workgroup-modified (&optional workgroup)
"Set WORKGROUP's and the current session's modified flags."
(unless workgroup
(setq workgroup (wg-get-workgroup nil t)))
(when (and wg-flag-modified workgroup)
(setf (wg-workgroup-modified workgroup) t)
(wg-flag-session-modified)))
(defun wg-current-workgroup (&optional noerror frame)
"Return current workgroup in frame.
Error unless NOERROR, in FRAME if specified."
(or wg-current-workgroup
(aif (frame-parameter frame 'wg-current-workgroup-uid)
(wg-find-workgroup-by :uid it noerror)
(unless noerror (error "No current workgroup in this frame")))))
(defun wg-previous-workgroup (&optional noerror frame)
"Return the previous workgroup in FRAME, or error unless NOERROR."
(aif (frame-parameter frame 'wg-previous-workgroup-uid)
(wg-find-workgroup-by :uid it noerror)
(unless noerror (error "No previous workgroup in this frame"))))
(defun wg-set-current-workgroup (workgroup &optional frame)
"Set the current workgroup to WORKGROUP in FRAME.
WORKGROUP should be a workgroup or nil."
(set-frame-parameter frame 'wg-current-workgroup-uid
(when workgroup (wg-workgroup-uid workgroup))))
(defun wg-set-previous-workgroup (workgroup &optional frame)
"Set the previous workgroup to WORKGROUP in FRAME.
WORKGROUP should be a workgroup or nil."
(set-frame-parameter frame 'wg-previous-workgroup-uid
(when workgroup (wg-workgroup-uid workgroup))))
(defun wg-current-workgroup-p (workgroup &optional frame)
"Return t when WORKGROUP is the current workgroup, nil otherwise."
(awhen (wg-current-workgroup t frame)
(eq workgroup it)))
(defun wg-previous-workgroup-p (workgroup &optional frame)
"Return t when WORKGROUP is the previous workgroup, nil otherwise."
(awhen (wg-previous-workgroup t frame)
(eq workgroup it)))
(defun wg-get-workgroup (obj &optional noerror)
"Return a workgroup from OBJ.
If OBJ is a workgroup, return it.
If OBJ is a string, return the workgroup named OBJ, or error unless NOERROR.
If OBJ is nil, return the current workgroup, or error unless NOERROR."
(cond ((wg-workgroup-p obj) obj)
((stringp obj) (wg-find-workgroup-by :name obj noerror))
((null obj) (wg-current-workgroup noerror))
(t (error "Can't get workgroup from type:: %S" (type-of obj)))))
;;; workgroup parameters
;;
;; Quick test:
;; (wg-workgroup-parameters (wg-current-workgroup))
;; (wg-set-workgroup-parameter (wg-current-workgroup) 'test1 t)
;; (wg-workgroup-parameter (wg-current-workgroup) 'test1)
(defun wg-workgroup-parameter (workgroup parameter &optional default)
"Return WORKGROUP's value for PARAMETER.
If PARAMETER is not found, return DEFAULT which defaults to nil.
WORKGROUP should be accepted by `wg-get-workgroup'."
(wg-aget (wg-workgroup-parameters (wg-get-workgroup workgroup))
parameter default))
(defun wg-set-workgroup-parameter (parameter value &optional workgroup)
"Set PARAMETER to VALUE in a WORKGROUP.
WORKGROUP should be a value accepted by `wg-get-workgroup'.
Return VALUE."
(-when-let (workgroup (wg-get-workgroup (or workgroup (wg-current-workgroup t)) t))
(wg-set-parameter (wg-workgroup-parameters workgroup) parameter value)
(wg-flag-workgroup-modified workgroup)
value))
(defun wg-remove-workgroup-parameter (parameter &optional workgroup)
"Remove PARAMETER from WORKGROUP's parameters."
(-when-let (workgroup (wg-get-workgroup workgroup t))
(wg-flag-workgroup-modified workgroup)
(wg-asetf (wg-workgroup-parameters workgroup) (wg-aremove it parameter))))
(defun wg-workgroup-local-value (variable &optional workgroup)
"Return the value of VARIABLE in WORKGROUP.
WORKGROUP nil defaults to the current workgroup. If there is no
current workgroup, or if VARIABLE does not have a workgroup-local
binding in WORKGROUP, resolve VARIABLE with `wg-session-local-value'."
(let ((workgroup (wg-get-workgroup workgroup t)))
(if (not workgroup) (wg-session-local-value variable)
(let* ((undefined (cl-gensym))
(value (wg-workgroup-parameter workgroup variable undefined)))
(if (not (eq value undefined)) value
(wg-session-local-value variable))))))
(defalias 'wg-local-value 'wg-workgroup-local-value)
(defun wg-workgroup-saved-wconfig-names (workgroup)
"Return a new list of the names of all WORKGROUP's saved wconfigs."
(mapcar 'wg-wconfig-name (wg-workgroup-saved-wconfigs workgroup)))
(defun wg-workgroup-get-saved-wconfig (wconfig-or-name &optional workgroup)
"Return the wconfig by WCONFIG-OR-NAME from WORKGROUP's saved wconfigs.
WCONFIG-OR-NAME must be either a string or a wconfig. If
WCONFIG-OR-NAME is a string and there is no saved wconfig with
that name, return nil. If WCONFIG-OR-NAME is a wconfig, and it
is a member of WORKGROUP's saved wconfigs, return is as given.
Otherwise return nil."
(let ((wconfigs (wg-workgroup-saved-wconfigs (or workgroup (wg-current-workgroup)))))
(cl-etypecase wconfig-or-name
(wg-wconfig (car (memq wconfig-or-name wconfigs)))
(string (cl-find wconfig-or-name wconfigs
:key 'wg-wconfig-name
:test 'string=)))))
(defun wg-workgroup-save-wconfig (wconfig &optional workgroup)
"Add WCONFIG to WORKGROUP's saved wconfigs.
WCONFIG must have a name. If there's already a wconfig with the
same name in WORKGROUP's saved wconfigs, replace it."
(let ((name (wg-wconfig-name wconfig)))
(unless name (error "Attempt to save a nameless wconfig"))
(setf (wg-workgroup-modified workgroup) t)
(wg-asetf (wg-workgroup-saved-wconfigs workgroup)
(cons wconfig (cl-remove name it
:key 'wg-wconfig-name
:test 'string=)))))
(defun wg-workgroup-kill-saved-wconfig (workgroup wconfig-or-name)
"Delete WCONFIG-OR-NAME from WORKGROUP's saved wconfigs.
WCONFIG-OR-NAME is resolved with `wg-workgroup-get-saved-wconfig'."
(-when-let (wconfig (wg-workgroup-get-saved-wconfig
workgroup wconfig-or-name))
(wg-asetf (wg-workgroup-saved-wconfigs workgroup) (remq wconfig it)
(wg-workgroup-modified workgroup) t)))
(defun wg-workgroup-base-wconfig-buf-uids (workgroup)
"Return a new list of all unique buf uids in WORKGROUP's working wconfig."
(wg-wconfig-buf-uids (wg-workgroup-base-wconfig workgroup)))
(defun wg-workgroup-saved-wconfigs-buf-uids (workgroup)
"Return a new list of all unique buf uids in WORKGROUP's base wconfig."
(cl-reduce 'wg-string-list-union
(wg-workgroup-saved-wconfigs workgroup)
:key 'wg-wconfig-buf-uids))
(defun wg-workgroup-all-wconfig-buf-uids (workgroup)
"Return a new list of all unique buf uids in WORKGROUP's wconfigs."
(cl-union (wg-workgroup-base-wconfig-buf-uids workgroup)
(wg-workgroup-saved-wconfigs-buf-uids workgroup)
:test 'string=))
(defun wg-workgroup-all-buf-uids (workgroup)
"Return a new list of all unique buf uids in WORKGROUP."
(cl-reduce 'wg-string-list-union
(list (wg-workgroup-base-wconfig-buf-uids workgroup)
(wg-workgroup-saved-wconfigs-buf-uids workgroup))))
(defun wg-restore-workgroup (workgroup)
"Restore WORKGROUP in `selected-frame'."
(let (wg-flag-modified)
(wg-restore-wconfig-undoably (wg-workgroup-working-wconfig workgroup) t)))
(defun wg-workgroup-list-or-error (&optional noerror)
"Return the value of `wg-current-session's :workgroup-list slot.
Or scream unless NOERROR."
(aif (wg-current-session noerror)
(or (wg-session-workgroup-list it)
(unless noerror (error "No workgroups are defined.")))
(unless noerror (error "Current session is nil. No workgroups are defined"))))
(defun wg-find-workgroup-by (slotkey value &optional noerror)
"Return the workgroup on which ACCESSOR returns VALUE or error."
(let ((accessor (cl-ecase slotkey
(:name 'wg-workgroup-name)
(:uid 'wg-workgroup-uid))))
(or (cl-find value (wg-workgroup-list-or-error noerror) :test 'equal :key accessor)
(unless noerror
(error "There are no workgroups with a %S of %S"
accessor value)))))
(defun wg-cyclic-nth-from-workgroup (workgroup &optional n)
"Return the workgroup N places from WORKGROUP in `wg-workgroup-list'."
(wg-cyclic-nth-from-elt workgroup (wg-workgroup-list-or-error) (or n 1)))
(defun wg-workgroup-names (&optional noerror)
"Return a list of workgroup names or scream unless NOERROR."
(mapcar 'wg-workgroup-name (wg-workgroup-list-or-error noerror)))
(defun wg-read-workgroup-name (&optional require-match)
"Read a workgroup name from `wg-workgroup-names'.
REQUIRE-MATCH to match."
(ido-completing-read "Workgroup: " (wg-workgroup-names) nil require-match nil nil
(awhen (wg-current-workgroup t) (wg-workgroup-name it))))
(defun wg-new-default-workgroup-name ()
"Return a new, unique, default workgroup name."
(let ((names (wg-workgroup-names t)) (index -1) result)
(while (not result)
(let ((new-name (format "wg%s" (cl-incf index))))
(unless (member new-name names)
(setq result new-name))))
result))
(defun wg-unique-workgroup-name-p (new-name)
"Return t if NEW-NAME is unique in `wg-workgroup-list', nil otherwise."
(cl-every (lambda (existing-name) (not (equal new-name existing-name)))
(wg-workgroup-names t)))
(defun wg-read-saved-wconfig-name (workgroup &optional prompt require-match)
"Read the name of a saved wconfig, completing on the names of
WORKGROUP's saved wconfigs."
(ido-completing-read (or prompt "Saved wconfig name: ")
(wg-workgroup-saved-wconfig-names workgroup)
nil require-match))
(defun wg-read-saved-wconfig (workgroup)
"Read the name of and return one of WORKGROUP's saved wconfigs."
(wg-workgroup-get-saved-wconfig
workgroup (wg-read-saved-wconfig-name workgroup nil t)))
;;; workgroup-list reorganization commands
(defun wg-swap-workgroups ()
"Swap the previous and current workgroups."
(interactive)
(wg-swap-workgroups-in-workgroup-list
(wg-current-workgroup) (wg-previous-workgroup))
(wg-fontified-message
(:cmd "Swapped: ")
(wg-workgroup-list-display)))
(defun wg-offset-workgroup-left (&optional workgroup n)
"Offset WORKGROUP leftward in `wg-workgroup-list' cyclically."
(interactive (list nil current-prefix-arg))
(wg-cyclic-offset-workgroup (wg-get-workgroup workgroup) (or n -1))
(wg-fontified-message
(:cmd "Offset left: ")
(wg-workgroup-list-display)))
(defun wg-offset-workgroup-right (&optional workgroup n)
"Offset WORKGROUP rightward in `wg-workgroup-list' cyclically."
(interactive (list nil current-prefix-arg))
(wg-cyclic-offset-workgroup (wg-get-workgroup workgroup) (or n 1))
(wg-fontified-message
(:cmd "Offset right: ")
(wg-workgroup-list-display)))
;;; undo/redo commands
(defun wg-undo-wconfig-change (&optional workgroup)
"Undo a change to the current workgroup's window-configuration."
(interactive)
(let* ((workgroup (wg-get-workgroup workgroup))
(undid? (wg-workgroup-offset-position-in-undo-list workgroup 1)))
(wg-fontified-message
(:cmd "Undo")
(:cur (if undid? "" " No more undo info")))))
(defun wg-redo-wconfig-change (&optional workgroup)
"Redo a change to the current workgroup's window-configuration."
(interactive)
(let* ((workgroup (wg-get-workgroup workgroup))
(redid? (wg-workgroup-offset-position-in-undo-list workgroup -1)))
(wg-fontified-message
(:cmd "Redo")
(:cur (if redid? "" " No more redo info")))))
(defun wg-undo-once-all-workgroups ()
"Do what the name says. Useful for instance when you
accidentally call `wg-revert-all-workgroups' and want to return
all workgroups to their un-reverted state."
(interactive)
(mapc 'wg-undo-wconfig-change (wg-workgroup-list-or-error))
(wg-message "Undid once on all workgroups."))
(defun wg-redo-once-all-workgroups ()
"Do what the name says. Probably useless. Included for
symetry with `wg-undo-once-all-workgroups'."
(interactive)
(mapc 'wg-redo-wconfig-change (wg-workgroup-list-or-error))
(wg-message "Redid once on all workgroups."))
;;; window-tree commands
;;
;; TODO: These are half-hearted. Clean them up; allow specification of the
;; window-tree depth at which to operate; add complex window creation commands;
;; and add window splitting, deletion and locking commands.
(defun wg-reverse-frame-horizontally (&optional workgroup)
"Reverse the order of all horizontally split wtrees."
(interactive)
(wg-restore-wconfig-undoably
(wg-reverse-wconfig
(wg-workgroup-working-wconfig
(wg-get-workgroup workgroup)))))
(defun wg-reverse-frame-vertically (&optional workgroup)
"Reverse the order of all vertically split wtrees."
(interactive)
(wg-restore-wconfig-undoably
(wg-reverse-wconfig
(wg-workgroup-working-wconfig
(wg-get-workgroup workgroup))
t)))
(defun wg-reverse-frame-horizontally-and-vertically (&optional workgroup)
"Reverse the order of all wtrees."
(interactive)
(wg-restore-wconfig-undoably
(wg-reverse-wconfig
(wg-workgroup-working-wconfig
(wg-get-workgroup workgroup))
'both)))
(defun wg-rename-workgroup (newname &optional workgroup)
"Set NEWNAME to WORKGROUP's name."
(interactive (list (wg-read-new-workgroup-name "New name: ") nil))
(-when-let (workgroup (wg-get-workgroup workgroup))
(let* ((oldname (wg-workgroup-name workgroup)))
(setf (wg-workgroup-name workgroup) newname)
(wg-flag-workgroup-modified workgroup)
(wg-fontified-message
(:cmd "Renamed: ")
(:cur oldname)
(:msg " to ")
(:cur (wg-workgroup-name workgroup))))))
(defun wg-reset (&optional force)
"Reset Workgroups.
Resets all frame parameters, buffer-local vars, the current
Workgroups session object, etc."
(interactive "P")
(unless (or force wg-no-confirm-on-destructive-operation
(y-or-n-p "Really reset Workgroups? "))
(error "Canceled"))
(wg-reset-internal)
(wg-fontified-message (:cmd "Reset: ") (:msg "Workgroups")))
(defun wg-query-and-save-if-modified ()
"Query for save when `wg-modified-p'."
(or (not (wg-modified-p))
(when (y-or-n-p "Save modified workgroups? ")
(wg-save-session))))
(defun wg-create-workgroup (name &optional blank)
"Create and add a workgroup named NAME.
Optional argument BLANK non-nil (set interactively with a prefix
arg) means use a blank, one window window-config. Otherwise use
the current window-configuration. Keep in mind that even though
the current window-config may be used, other parameters of the
current workgroup are not copied to the created workgroup. For
that, use `wg-clone-workgroup'."
(interactive (list (wg-read-new-workgroup-name) current-prefix-arg))
(wg-switch-to-workgroup (wg-make-and-add-workgroup name blank))
(wg-fontified-message
(:cmd "Created: ") (:cur name) " " (wg-workgroup-list-display)))
(defun wg-clone-workgroup (workgroup name)
"Create and add a clone of WORKGROUP named NAME.
Keep in mind that only WORKGROUP's top level alist structure is
copied, so destructive operations on the keys or values of
WORKGROUP will be reflected in the clone, and vice-versa. Be
safe -- don't mutate them."
(interactive (list nil (wg-read-new-workgroup-name)))
(let* ((workgroup (wg-get-workgroup workgroup))
(clone (wg-copy-workgroup workgroup)))
(setf (wg-workgroup-name clone) name
(wg-workgroup-uid clone) (wg-generate-uid))
(when (wg-check-and-add-workgroup clone)
(wg-flag-workgroup-modified clone))
(wg-set-workgroup-working-wconfig
clone (wg-workgroup-working-wconfig workgroup))
(wg-switch-to-workgroup clone)
(wg-fontified-message
(:cmd "Cloned: ")
(:cur (wg-workgroup-name workgroup))
(:msg " to ")
(:cur name) " "
(wg-workgroup-list-display))))
(defun wg-switch-to-workgroup (workgroup &optional noerror)
"Switch to WORKGROUP.
NOERROR means fail silently."
(interactive (list (wg-read-workgroup-name)))
(fset 'buffer-list wg-buffer-list-original)
(let ((workgroup (wg-get-workgroup-create workgroup))
(current (wg-current-workgroup t)))
(when (and (eq workgroup current) (not noerror))
(error "Already on: %s" (wg-workgroup-name current)))
(when current (push current wg-deactivation-list))
(unwind-protect
(progn
;; Before switch
(run-hooks 'wg-before-switch-to-workgroup-hook)
;; Save info about some hard-to-work-with libraries
(let (wg-flag-modified)
(wg-set-workgroup-parameter 'ecb (and (boundp 'ecb-minor-mode)
ecb-minor-mode)))
;;(wg-set-workgroup-parameter (wg-current-workgroup t) 'ecb-win-config (ecb-current-window-configuration))
;; (type-of (ecb-current-window-configuration))
;; (type-of (car (ecb-current-window-configuration)))
;; (type-of (car (nthcdr 3 (ecb-current-window-configuration))))
;; (wg-pickelable-or-error (ecb-current-window-configuration))
;;(ecb-current-window-configuration)
;;)
;; Before switching - turn off ECB
;; https://github.com/pashinin/workgroups2/issues/34
(if (and (boundp 'ecb-minor-mode)
(boundp 'ecb-frame)
(fboundp 'ecb-deactivate)
ecb-minor-mode
(equal ecb-frame (selected-frame)))
(let ((ecb-split-edit-window-after-start 'before-deactivation))
(ecb-deactivate)))
;; Switch
(wg-restore-workgroup workgroup)
(wg-set-previous-workgroup current)
(wg-set-current-workgroup workgroup)
;; After switch
;; Save "last-workgroup" to the session params
(let (wg-flag-modified)
(awhen (wg-current-workgroup t)
(wg-set-session-parameter 'last-workgroup (wg-workgroup-name it)))
(awhen (wg-previous-workgroup t)
(wg-set-session-parameter 'prev-workgroup (wg-workgroup-name it))))
;; If a workgroup had ECB - turn it on
(if (and (boundp 'ecb-minor-mode)
(not ecb-minor-mode)
(fboundp 'ecb-activate)
(wg-workgroup-parameter (wg-current-workgroup t) 'ecb nil))
(let ((ecb-split-edit-window-after-start 'before-deactivation))
(ecb-activate)))
;;(ecb-last-window-config-before-deactivation
;; (wg-workgroup-parameter (wg-current-workgroup t) 'ecb-win-config nil)))
;; `sr-speedbar'
;; if *SPEEDBAR* buffer is visible - set some variables
(let* ((buffers (mapcar 'window-buffer (window-list)))
(buffer-names (mapcar 'buffer-name buffers)))
(when (and (featurep 'sr-speedbar)
(member sr-speedbar-buffer-name buffer-names))
(setq sr-speedbar-window (get-buffer-window sr-speedbar-buffer-name))))
;; Finally
(if wg-mess-with-buffer-list
(fset 'buffer-list wg-buffer-list-function))
(wg-fontified-message (:cmd "Switched: ") (wg-workgroup-name (wg-current-workgroup t)))
(run-hooks 'wg-after-switch-to-workgroup-hook))
(when current (pop wg-deactivation-list)))))
(defun wg-switch-to-workgroup-at-index (index)
"Switch to the workgroup at INDEX in `wg-workgroup-list'."
(interactive (list (or current-prefix-arg (wg-read-workgroup-index))))
(let ((wl (wg-workgroup-list-or-error)))
(wg-switch-to-workgroup
(or (nth index wl) (error "There are only %d workgroups" (length wl))))))
(cl-macrolet
((define-range-of-switch-to-workgroup-at-index (num)
`(progn
,@(wg-docar (i (wg-range 0 num))
`(defun ,(intern (format "wg-switch-to-workgroup-at-index-%d" i)) ()
,(format "Switch to the workgroup at index %d." i)
(interactive)
(wg-switch-to-workgroup-at-index ,i))))))
(define-range-of-switch-to-workgroup-at-index 10))
(defun wg-switch-to-cyclic-nth-from-workgroup (workgroup n)
"Switch N workgroups cyclically from WORKGROUP in `wg-workgroup-list.'"
(let ((workgroup-list (wg-workgroup-list-or-error))
(workgroup (wg-get-workgroup workgroup t)))
(wg-switch-to-workgroup
(cond ((not workgroup) (car workgroup-list))
((= 1 (length workgroup-list)) (error "There's only one workgroup"))
(t (wg-cyclic-nth-from-workgroup workgroup n))))))
(defun wg-switch-to-workgroup-left (&optional workgroup n)
"Switch to WORKGROUP that is (- N) places away from WORKGROUP in `wg-workgroup-list'.
Use `current-prefix-arg' for N if non-nil. Otherwise N defaults to 1."
(interactive (list nil current-prefix-arg))
(wg-switch-to-cyclic-nth-from-workgroup workgroup (- (or n 1))))
(defun wg-switch-to-workgroup-right (&optional workgroup n)
"Switch to the workgroup N places from WORKGROUP in `wg-workgroup-list'.
Use `current-prefix-arg' for N if non-nil. Otherwise N defaults to 1."
(interactive (list nil current-prefix-arg))
(wg-switch-to-cyclic-nth-from-workgroup workgroup (or n 1)))
(defun wg-switch-to-previous-workgroup ()
"Switch to the previous workgroup."
(interactive)
(wg-switch-to-workgroup (wg-previous-workgroup)))
(defun wg-wconfig-kill-ring ()
"Return `wg-wconfig-kill-ring', creating it first if necessary."
(or wg-wconfig-kill-ring
(setq wg-wconfig-kill-ring (make-ring wg-wconfig-kill-ring-max))))
(defun wg-add-to-wconfig-kill-ring (wconfig)
"Add WCONFIG to `wg-wconfig-kill-ring'."
(ring-insert (wg-wconfig-kill-ring) wconfig))
(defun wg-kill-workgroup (&optional workgroup)
"Kill WORKGROUP, saving its working-wconfig to the kill ring."
(interactive)
(let* ((workgroup (wg-get-workgroup workgroup))
(to (or (wg-previous-workgroup t)
(wg-cyclic-nth-from-workgroup workgroup))))
(wg-add-to-wconfig-kill-ring (wg-workgroup-working-wconfig workgroup))
(wg-delete-workgroup workgroup)
(if (eq workgroup to) (wg-restore-wconfig (wg-make-blank-wconfig))
(wg-switch-to-workgroup to))
(wg-fontified-message
(:cmd "Killed: ")
(:cur (wg-workgroup-name workgroup)) " "
(wg-workgroup-list-display))))
(defun wg-kill-ring-save-base-wconfig (&optional workgroup)
"Save WORKGROUP's base wconfig to the kill ring."
(interactive)
(let ((workgroup (wg-get-workgroup workgroup)))
(wg-add-to-wconfig-kill-ring (wg-workgroup-base-wconfig workgroup))
(wg-fontified-message
(:cmd "Saved: ") (:cur (wg-workgroup-name workgroup))
(:cur "'s ") (:msg "base wconfig to the kill ring"))))
(defun wg-kill-ring-save-working-wconfig (&optional workgroup)
"Save WORKGROUP's working-wconfig to `wg-wconfig-kill-ring'."
(interactive)
(let ((workgroup (wg-get-workgroup workgroup)))
(wg-add-to-wconfig-kill-ring (wg-workgroup-working-wconfig workgroup))
(wg-fontified-message
(:cmd "Saved: ") (:cur (wg-workgroup-name workgroup))
(:cur "'s ") (:msg "working-wconfig to the kill ring"))))
(defun wg-yank-wconfig ()
"Restore a wconfig from `wg-wconfig-kill-ring'.
Successive yanks restore wconfigs sequentially from the kill
ring, starting at the front."
(interactive)
(when (zerop (ring-length (wg-wconfig-kill-ring)))
(error "The kill-ring is empty"))
(let ((pos (if (not (eq real-last-command 'wg-yank-wconfig)) 0
(1+ (or (get 'wg-yank-wconfig :position) 0)))))
(put 'wg-yank-wconfig :position pos)
(wg-restore-wconfig-undoably (ring-ref (wg-wconfig-kill-ring) pos))
(wg-fontified-message
(:cmd "Yanked: ")
(:msg (format "%S" pos)) " "
(wg-workgroup-list-display))))
(defun wg-kill-workgroup-and-buffers (&optional workgroup)
"Kill WORKGROUP and the buffers in its working-wconfig."
(interactive)
(let* ((workgroup (wg-get-workgroup workgroup))
(bufs (save-window-excursion
(wg-restore-workgroup workgroup)
(mapcar #'window-buffer (window-list)))))
(wg-kill-workgroup workgroup)
(mapc #'kill-buffer bufs)
(wg-fontified-message
(:cmd "Killed: ")
(:cur (wg-workgroup-name workgroup))
(:msg " and its buffers ") "\n"
(wg-workgroup-list-display))))
(defun wg-delete-other-workgroups (&optional workgroup)
"Delete all workgroups but WORKGROUP."
(interactive)
(let ((workgroup (wg-get-workgroup workgroup)))
(unless (or wg-no-confirm-on-destructive-operation
(y-or-n-p "Really delete all other workgroups? "))
(error "Cancelled"))
(dolist (w (wg-workgroup-list-or-error))
(unless (eq w workgroup)
(wg-delete-workgroup w)))
(unless (wg-current-workgroup-p workgroup)
(wg-switch-to-workgroup workgroup))
(wg-fontified-message
(:cmd "Deleted: ")
(:msg "All workgroups but ")
(:cur (wg-workgroup-name workgroup)))))
(defun wg-revert-workgroup (&optional workgroup)
"Restore WORKGROUP's window configuration to its state at the last save."
(interactive)
(let* ((workgroup (wg-get-workgroup workgroup))
(base-wconfig (wg-workgroup-base-wconfig workgroup)))
(if (wg-current-workgroup-p workgroup)
(wg-restore-wconfig-undoably base-wconfig)
(wg-add-wconfig-to-undo-list workgroup base-wconfig))
(wg-fontified-message
(:cmd "Reverted: ")
(:cur (wg-workgroup-name workgroup)))))
(defun wg-revert-all-workgroups ()
"Revert all workgroups to their base wconfigs.
Only workgroups' working-wconfigs in `selected-frame' are
reverted."
(interactive)
(mapc #'wg-revert-workgroup (wg-workgroup-list-or-error))
(wg-fontified-message
(:cmd "Reverted: ")
(:msg "All")))
(defun wg-workgroup-state-table (&optional frame)
"Return FRAME's workgroup table, creating it first if necessary."
(or (frame-parameter frame 'wg-workgroup-state-table)
(let ((wtree (make-hash-table :test 'equal)))
(set-frame-parameter frame 'wg-workgroup-state-table wtree)
wtree)))
(defun wg-get-workgroup-state (workgroup &optional frame)
"Return WORKGROUP's state table in a FRAME."
(let ((uid (wg-workgroup-uid workgroup))
(state-table (wg-workgroup-state-table frame)))
(or (gethash uid state-table)
(let ((wgs (wg-make-workgroup-state
:undo-pointer 0
:undo-list
(list (or (wg-workgroup-selected-frame-wconfig workgroup)
(wg-workgroup-base-wconfig workgroup))))))
(puthash uid wgs state-table)
wgs))))
(defmacro wg-with-undo (workgroup spec &rest body)
"Bind WORKGROUP's undo state to SPEC and eval BODY."
(declare (indent 2))
(wg-dbind (state undo-pointer undo-list) spec
`(let* ((,state (wg-get-workgroup-state ,workgroup))
(,undo-pointer (wg-workgroup-state-undo-pointer ,state))
(,undo-list (wg-workgroup-state-undo-list ,state)))
,@body)))
(defun wg-flag-just-exited-minibuffer ()
"Added to `minibuffer-exit-hook'."
(setq wg-just-exited-minibuffer t))
(defun wg-flag-window-configuration-changed ()
"Set `wg-window-configuration-changed' to t.
But only if not the minibuffer was just exited. Added to
`window-configuration-change-hook'."
(if wg-just-exited-minibuffer
(setq wg-just-exited-minibuffer nil)
(progn
(wg-flag-workgroup-modified)
(setq wg-window-configuration-changed t))))
(defun wg-unflag-undoify-window-configuration-change ()
"Set `wg-undoify-window-configuration-change' to nil, exempting
from undoification any window-configuration changes caused by the
current command."
(setq wg-undoify-window-configuration-change nil))
(defun wg-set-workgroup-working-wconfig (workgroup wconfig)
"Set the working-wconfig of WORKGROUP to WCONFIG."
(wg-flag-workgroup-modified workgroup)
(setf (wg-workgroup-selected-frame-wconfig workgroup) wconfig)
(wg-with-undo workgroup (state undo-pointer undo-list)
(setcar (nthcdr undo-pointer undo-list) wconfig)))
(defun wg-add-wconfig-to-undo-list (workgroup wconfig)
"Add WCONFIG to WORKGROUP's undo list, truncating its future if necessary."
(wg-with-undo workgroup (state undo-pointer undo-list)
(let ((undo-list (cons nil (nthcdr undo-pointer undo-list))))
(awhen (nthcdr wg-wconfig-undo-list-max undo-list) (setcdr it nil))
(setf (wg-workgroup-state-undo-list state) undo-list))
(setf (wg-workgroup-state-undo-pointer state) 0))
(wg-set-workgroup-working-wconfig workgroup wconfig))
(defun wg-workgroup-working-wconfig (workgroup &optional noupdate)
"Return WORKGROUP's working-wconfig.
If WORKGROUP is the current workgroup in `selected-frame', and
NOUPDATE is nil, set its working wconfig in `selected-frame' to
`wg-current-wconfig' and return the updated wconfig. Otherwise
return WORKGROUP's current undo state."
(if (and (not noupdate) (wg-current-workgroup-p workgroup))
(wg-set-workgroup-working-wconfig workgroup (wg-current-wconfig))
(wg-with-undo workgroup (state undo-pointer undo-list)
(nth undo-pointer undo-list))))
(defun wg-update-current-workgroup-working-wconfig ()
"Update `selected-frame's current workgroup's working-wconfig with `wg-current-wconfig'."
(awhen (wg-current-workgroup t)
(wg-set-workgroup-working-wconfig it (wg-current-wconfig))))
(defun wg-restore-wconfig-undoably (wconfig &optional noundo)
"Restore WCONFIG in `selected-frame', saving undo information.
Skip undo when NOUNDO."
(when noundo (wg-unflag-undoify-window-configuration-change))
(wg-update-current-workgroup-working-wconfig)
(wg-restore-wconfig wconfig))
(defun wg-workgroup-offset-position-in-undo-list (workgroup increment)
"Increment WORKGROUP's undo-pointer by INCREMENT.
Also restore the wconfig at the incremented undo-pointer if
WORKGROUP is current."
(wg-with-undo workgroup (state undo-pointer undo-list)
(let ((new-pointer (+ undo-pointer increment)))
(when (wg-within new-pointer 0 (length undo-list))
(when (wg-current-workgroup-p workgroup)
(wg-restore-wconfig-undoably (nth new-pointer undo-list) t))
(setf (wg-workgroup-state-undo-pointer state) new-pointer)))))
(defun wg-undoify-window-configuration-change ()
"Conditionally `wg-add-wconfig-to-undo-list'.
Added to `post-command-hook'."
(when (and wg-window-configuration-changed ;; When the window config has changed,
wg-undoify-window-configuration-change ;; and undoification is still on for the current command
(wg-minibuffer-inactive-p)) ;; and the change didn't occur while the minibuffer is active,
(-when-let (workgroup (wg-current-workgroup t)) ;; and there's a current workgroup,
;; add the current wconfig to that workgroup's undo list:
(wg-add-wconfig-to-undo-list workgroup (wg-current-wconfig))))
;; Reset all flags no matter what:
(setq wg-window-configuration-changed nil
wg-undoify-window-configuration-change t
wg-already-updated-working-wconfig nil))
(defun wg-update-working-wconfig-hook ()
"Used in before advice on all functions that trigger `window-configuration-change-hook'.
To save up to date undo info before the change."
(when (and (not wg-already-updated-working-wconfig)
(wg-minibuffer-inactive-p))
(wg-update-current-workgroup-working-wconfig)
(setq wg-already-updated-working-wconfig t)))
(defun wg-workgroup-gc-buf-uids (workgroup)
"Remove buf uids from WORKGROUP that have no referent in `wg-buf-list'."
(wg-asetf (wg-workgroup-strong-buf-uids workgroup)
(cl-remove-if-not 'wg-find-buf-by-uid it)
(wg-workgroup-weak-buf-uids workgroup)
(cl-remove-if-not 'wg-find-buf-by-uid it)))
(defun wg-display-internal (elt-fn list)
"Return display string built by calling ELT-FN on each element of LIST."
(let ((div (wg-add-face :div wg-list-display-decor-divider))
(wwidth (window-width (minibuffer-window)))
(i -1)
(str))
(setq str
(wg-fontify
(:brace wg-list-display-decor-left-brace)
(if (not list) (funcall elt-fn nil nil)
(wg-doconcat (elt list div) (funcall elt-fn elt (cl-incf i))))
(:brace wg-list-display-decor-right-brace)))
;; (subseq str 0 wwidth)
))
(defun wg-workgroup-list-display (&optional workgroup-list)
"Return the WORKGROUP-LIST display string.
The string contains the names of all workgroups in `wg-workgroup-list',
decorated with faces, dividers and strings identifying the
current and previous workgroups."
(if (wg-current-session t)
(wg-display-internal 'wg-workgroup-display
(or workgroup-list (wg-workgroup-list)))))
(defun wg-create-first-wg ()
"Create a first workgroup if needed."
(when (and workgroups-mode
wg-session-load-on-start
(= (length (wg-workgroup-list)) 0))
(wg-create-workgroup wg-first-wg-name)
(wg-mark-everything-unmodified)))
(defun wg-pickel-workgroup-parameters (workgroup)
"Return a copy of WORKGROUP after pickeling its parameters.
If WORKGROUP's parameters are non-nil, otherwise return
WORKGROUP."
(if (not (wg-workgroup-parameters workgroup)) workgroup
(let ((copy (wg-copy-workgroup workgroup)))
(wg-asetf (wg-workgroup-parameters copy) (wg-pickel it))
copy)))
(defun wg-unpickel-workgroup-parameters (workgroup)
"If WORKGROUP's parameters are non-nil, return a copy of
WORKGROUP after unpickeling its parameters. Otherwise return
WORKGROUP."
(if (not (wg-workgroup-parameters workgroup)) workgroup
(let ((copy (wg-copy-workgroup workgroup)))
(wg-asetf (wg-workgroup-parameters copy) (wg-unpickel it))
copy)))
(defun wg-delete-workgroup (workgroup)
"Remove WORKGROUP from `wg-workgroup-list'.
Also delete all references to it by `wg-workgroup-state-table',
`wg-current-workgroup' and `wg-previous-workgroup'."
(dolist (frame (frame-list))
(remhash (wg-workgroup-uid workgroup) (wg-workgroup-state-table frame))
(when (wg-current-workgroup-p workgroup frame)
(wg-set-current-workgroup nil frame))
(when (wg-previous-workgroup-p workgroup frame)
(wg-set-previous-workgroup nil frame)))
(setf (wg-workgroup-list) (remove workgroup (wg-workgroup-list-or-error)))
(wg-flag-session-modified)
workgroup)
(defun wg-add-workgroup (workgroup &optional index)
"Add WORKGROUP to `wg-workgroup-list' at INDEX or the end.
If a workgroup with the same name exists, overwrite it."
(awhen (wg-find-workgroup-by :name (wg-workgroup-name workgroup) t)
(unless index (setq index (cl-position it (wg-workgroup-list-or-error))))
(wg-delete-workgroup it))
(wg-asetf (wg-workgroup-list)
(wg-insert-before workgroup it (or index (length it))))
(wg-flag-session-modified)
workgroup)
(defun wg-check-and-add-workgroup (workgroup)
"Add WORKGROUP to `wg-workgroup-list'.
Ask to overwrite if a workgroup with the same name exists."
(let ((name (wg-workgroup-name workgroup))
(uid (wg-workgroup-uid workgroup)))
(when (wg-find-workgroup-by :uid uid t)
(error "A workgroup with uid %S already exists" uid))
(when (wg-find-workgroup-by :name name t)
(unless (or wg-no-confirm-on-destructive-operation
(y-or-n-p (format "%S exists. Overwrite? " name)))
(error "Cancelled"))))
(wg-add-workgroup workgroup))
(defun wg-make-and-add-workgroup (name &optional blank)
"Create a workgroup named NAME with current `window-tree'.
If BLANK - then just scratch buffer.
Add it with `wg-check-and-add-workgroup'."
(wg-check-and-add-workgroup
(wg-make-workgroup
:name name
:base-wconfig (if blank (wg-make-blank-wconfig)
(wg-current-wconfig)))))
(defun wg-get-workgroup-create (workgroup)
"Return the workgroup specified by WORKGROUP, creating a new one if needed.
If `wg-get-workgroup' on WORKGROUP returns a workgroup, return it.
Otherwise, if WORKGROUP is a string, create a new workgroup with
that name and return it. Otherwise error."
(or (wg-get-workgroup workgroup t)
(if (stringp workgroup)
(wg-make-and-add-workgroup workgroup)
(wg-get-workgroup workgroup)))) ; Call this again for its error message
(defun wg-cyclic-offset-workgroup (workgroup n)
"Offset WORKGROUP's position in `wg-workgroup-list' by N."
(let ((workgroup-list (wg-workgroup-list-or-error)))
(unless (member workgroup workgroup-list)
(error "Workgroup isn't present in `wg-workgroup-list'."))
(setf (wg-workgroup-list) (wg-cyclic-offset-elt workgroup workgroup-list n)
(wg-session-modified (wg-current-session)) t)))
(defun wg-swap-workgroups-in-workgroup-list (workgroup1 workgroup2)
"Swap the positions of WORKGROUP1 and WORKGROUP2 in `wg-workgroup-list'."
(let ((workgroup-list (wg-workgroup-list-or-error)))
(when (eq workgroup1 workgroup2)
(error "Can't swap a workgroup with itself"))
(unless (and (memq workgroup1 workgroup-list)
(memq workgroup2 workgroup-list))
(error "Both workgroups aren't present in `wg-workgroup-list'."))
(setf (wg-workgroup-list) (wg-util-swap workgroup1 workgroup2 workgroup-list)
(wg-session-modified (wg-current-session)) t)))
(defun wg-session-uids-consistent-p ()
"Return t if there are no duplicate bufs or buf uids in the wrong places.
nil otherwise."
(and (not (wg-dups-p (wg-buf-list) :key 'wg-buf-uid :test 'string=))
(not (wg-dups-p (wg-workgroup-list) :key 'wg-workgroup-uid :test 'string=))))
(defun wg-open-session (filename)
"Load a session visiting FILENAME, creating one if none already exists."
(interactive "FFind session file: ")
(cond ((file-exists-p filename)
;; TODO: handle errors when reading object
(let ((session (read (f-read-text filename))))
(unless (wg-session-p session)
(error "%S is not a Workgroups session file." filename))
(setf (wg-session-file-name session) filename)
(wg-reset-internal (wg-unpickel-session-parameters session)))
(if wg-control-frames (wg-restore-frames))
(awhen (wg-workgroup-list)
(if (and wg-open-this-wg
(member wg-open-this-wg (wg-workgroup-names)))
(wg-switch-to-workgroup wg-open-this-wg)
(if (and wg-load-last-workgroup
(member (wg-session-parameter 'last-workgroup) (wg-workgroup-names)))
(wg-switch-to-workgroup (wg-session-parameter 'last-workgroup))
(wg-switch-to-workgroup (car it))))
(awhen (wg-session-parameter 'prev-workgroup)
(when (and (member it (wg-workgroup-names))
(wg-get-workgroup it t))
(wg-set-previous-workgroup (wg-get-workgroup it t)))))
(wg-fontified-message (:cmd "Loaded: ") (:file filename))
(wg-mark-everything-unmodified))
(t
(wg-query-and-save-if-modified)
(wg-reset-internal (wg-make-session :file-name filename))
(wg-fontified-message (:cmd "(New Workgroups session file)")))))
(defalias 'wg-find-session-file 'wg-open-session)
(defun wg-write-sexp-to-file (sexp file)
"Write the printable representation of SEXP to FILE."
(with-temp-buffer
(let ((print-level nil) (print-length nil))
(insert (format "%S" sexp)))
(write-file file)))
;; FIXME: Duplicate buf names probably shouldn't be allowed. An unrelated error
;; causes two *scratch* buffers to be present, triggering the "uids don't match"
;; error. Write something to remove bufs with duplicate names.
(defun wg-perform-session-maintenance ()
"Perform various maintenance operations on the current Workgroups session."
(wg-update-current-workgroup-working-wconfig)
;; Update every workgroup's base wconfig with `wg-workgroup-update-base-wconfig'
(dolist (workgroup (wg-workgroup-list))
(awhen (wg-workgroup-selected-frame-wconfig workgroup)
(setf (wg-workgroup-base-wconfig workgroup) it
(wg-workgroup-selected-frame-wconfig workgroup) nil)))
;; Garbage collection
;; https://github.com/pashinin/workgroups2/issues/48
;;(let ((all-buf-uids (wg-all-buf-uids)))
;; (wg-asetf (wg-buf-list)
;; (cl-remove-if-not (lambda (uid) (member uid all-buf-uids)) it
;; :key 'wg-buf-uid)))
(mapc 'wg-workgroup-gc-buf-uids (wg-workgroup-list)) ; Remove buf uids that have no referent in `wg-buf-list'
(mapc 'wg-update-buffer-in-buf-list (wg-buffer-list-emacs)))
(defun wg-save-session-as (filename &optional confirm)
"Write the current session into file FILENAME.
This makes the session visit that file, and marks it as not modified.
If optional second arg CONFIRM is non-nil, this function asks for
confirmation before overwriting an existing file. Interactively,
confirmation is required unless you supply a prefix argument."
(interactive (list (read-file-name "Save session as: ")
(not current-prefix-arg)))
(when (and confirm (file-exists-p filename))
(unless (y-or-n-p (format "File `%s' exists; overwrite? " filename))
(error "Cancelled")))
(unless (file-writable-p filename)
(error "File %s can't be written to" filename))
(wg-perform-session-maintenance)
(setf (wg-session-file-name (wg-current-session)) filename)
(setf (wg-session-version (wg-current-session)) wg-version)
;; Save opened frames as a session parameter "frame-list".
;; Exclude `selected-frame' and daemon one (if any).
;; http://stackoverflow.com/questions/21151992/why-emacs-as-daemon-gives-1-more-frame-than-is-opened
(if wg-control-frames
(let ((fl (frame-list)))
;; TODO: remove using dash
(mapc (lambda (frame)
(if (string-equal "initial_terminal" (terminal-name frame))
(delete frame fl))) fl)
(setq fl (delete (selected-frame) fl))
(let (wg-flag-modified)
(wg-set-session-parameter 'frame-list (mapcar 'wg-frame-to-wconfig fl)))))
(wg-write-sexp-to-file (wg-pickel-all-session-parameters) filename)
(wg-fontified-message (:cmd "Wrote: ") (:file filename))
(wg-mark-everything-unmodified))
(defalias 'wg-write-session-file 'wg-save-session-as)
(defun wg-get-session-file ()
"Return the filename in which to save the session."
(or (aif (wg-current-session t) (wg-session-file-name it))
wg-session-file))
;;(read-file-name (format "Save session as [%s]: " wg-session-file))
(defun wg-save-session (&optional force)
"Save the current Workgroups session if it's been modified.
When FORCE - save session regardless of whether it's been modified."
(interactive "P")
;;(if (and (not (wg-modified-p)) (not force))
;; (wg-message "(The session is unmodified)")
(wg-save-session-as (wg-get-session-file)))
(defun wg-reset-internal (&optional session)
"Reset Workgroups, setting `wg-current-session' to SESSION.
Resets all frame parameters, buffer-local vars, current session
object, etc. SESSION nil defaults to a new, blank session."
(mapc 'wg-reset-frame (frame-list))
(mapc 'wg-reset-buffer (wg-buffer-list-emacs))
(setq wg-wconfig-kill-ring nil)
(setq wg-current-session (or session (wg-make-session))))
(defun wg-all-buf-uids (&optional session buffer-list)
"Return the union of all SESSION buf-uids and BUFFER-LIST uids."
(cl-union (cl-reduce 'wg-string-list-union ; (wg-session-all-buf-uids session)
(wg-session-workgroup-list (or session (wg-current-session)))
:key 'wg-workgroup-all-buf-uids)
;; (wg-buffer-list-all-uids buffer-list)
(delq nil (mapcar 'wg-buffer-uid (or buffer-list (wg-buffer-list-emacs))))
:test 'string=))
(defun wg-modified-p ()
"Return t when the current session or any of its workgroups are modified."
(aif (wg-current-session t)
(or (wg-session-modified it)
(cl-some 'wg-workgroup-modified (wg-workgroup-list)))))
(defun wg-mark-everything-unmodified ()
"Mark the session and all workgroups as unmodified."
(let (wg-undoify-window-configuration-change) ; to skip WG's `post-command-hook' that marks "modified" again
(-when-let (session (wg-current-session t))
(setf (wg-session-modified session) nil))
(dolist (workgroup (wg-workgroup-list))
(setf (wg-workgroup-modified workgroup) nil))))
(defun wg-session-parameter (parameter &optional default session)
"Return session's value for PARAMETER.
If PARAMETER is not found, return DEFAULT which defaults to nil.
SESSION nil defaults to the current session."
(wg-aget (wg-session-parameters (or session (wg-current-session)))
parameter default))
(defun wg-set-session-parameter (parameter value &optional session)
"Set PARAMETER to VALUE in SESSION.
SESSION nil means use the current session. Return value."
(-when-let (session (or session (wg-current-session t)))
(wg-set-parameter (wg-session-parameters session) parameter value)
(wg-flag-session-modified session)
value))
(defun wg-remove-session-parameter (parameter &optional session)
"Remove parameter PARAMETER from SESSION's parameters."
(let ((session (or session (wg-current-session))))
(wg-asetf (wg-session-parameters session) (wg-aremove it parameter))
(wg-flag-session-modified session)))
(defun wg-session-local-value (variable &optional session)
"Return the value of VARIABLE in SESSION.
SESSION nil defaults to the current session. If VARIABLE does
not have a session-local binding in SESSION, the value is
resolved by Emacs."
(let* ((undefined (cl-gensym))
(value (wg-session-parameter variable undefined session)))
(if (not (eq value undefined)) value
(symbol-value variable))))
(defun wg-reset-frame (frame)
"Reset Workgroups' `frame-parameters' in FRAME to nil."
(set-frame-parameter frame 'wg-workgroup-state-table nil)
(set-frame-parameter frame 'wg-current-workgroup-uid nil)
(set-frame-parameter frame 'wg-previous-workgroup-uid nil))
(defun wg-save-session-on-exit (behavior)
"Perform session-saving operations based on BEHAVIOR."
(cl-case behavior
(ask (wg-query-and-save-if-modified))
(save (wg-save-session))))
(defun wg-reload-session ()
"Reload current workgroups session."
(interactive)
(let* ((file (wg-get-session-file))
(exists (file-exists-p file)))
(condition-case err
(wg-open-session file)
(progn
(wg-create-first-wg)
(message "Error loading session-file: %s" err))))
;; TODO: print what exactly happened
(wg-create-first-wg))
(defun wg-save-session-on-emacs-exit ()
"Call `wg-save-session-on-exit' with `wg-emacs-exit-save-behavior'.
Added to `kill-emacs-query-functions'."
(wg-save-session-on-exit wg-emacs-exit-save-behavior) t)
(defun wg-save-session-on-workgroups-mode-exit ()
"Call `wg-save-session-on-exit' with `wg-workgroups-mode-exit-save-behavior'.
Called when `workgroups-mode' is turned off."
(wg-save-session-on-exit wg-workgroups-mode-exit-save-behavior) t)
(defun wg-pickel-all-session-parameters (&optional session)
"Return a copy of SESSION after pickeling its parameters.
And the parameters of all its workgroups."
(let ((copy (wg-copy-session (or session (wg-current-session)))))
(when (wg-session-parameters copy)
(wg-asetf (wg-session-parameters copy) (wg-pickel it)))
(wg-asetf (wg-session-workgroup-list copy)
(cl-mapcar 'wg-pickel-workgroup-parameters it))
copy))
(defun wg-unpickel-session-parameters (session)
"Return a copy of SESSION after unpickeling its parameters.
And the parameters of all its workgroups."
(let ((copy (wg-copy-session session)))
(when (wg-session-parameters copy)
(wg-asetf (wg-session-parameters copy) (wg-unpickel it)))
(wg-asetf (wg-session-workgroup-list copy)
(cl-mapcar 'wg-unpickel-workgroup-parameters it))
copy))
(defvar wg-buffer-workgroup nil
"Associating each buffer with the workgroup.
In which it most recently appeared.")
(make-variable-buffer-local 'wg-buffer-workgroup)
(defun wg-workgroup-associated-buf-uids (&optional workgroup)
"Return a new list containing all of WORKGROUP's associated buf uids."
(awhen (or workgroup (wg-current-workgroup t))
(append (wg-workgroup-strong-buf-uids it)
(wg-workgroup-weak-buf-uids it))))
(defun wg-workgroup-associated-bufs (workgroup)
"Return a new list containing all of WORKGROUP's associated bufs."
(delete nil (mapcar 'wg-find-buf-by-uid
(wg-workgroup-associated-buf-uids workgroup))))
(defun wg-workgroup-associated-buffers (workgroup)
"Return a new list containing all of WORKGROUP's associated buffer objects."
(delete nil (mapcar 'wg-restore-buffer
(wg-workgroup-associated-bufs workgroup))))
(defun wg-workgroup-strongly-associate-bufobj (workgroup bufobj)
"Strongly associate BUFOBJ with WORKGROUP."
(let* ((uid (wg-bufobj-uid-or-add bufobj))
(remp (wg-removef-p uid (wg-workgroup-weak-buf-uids workgroup)
:test 'string=))
(addp (wg-pushnew-p uid (wg-workgroup-strong-buf-uids workgroup)
:test 'string=)))
(when (or remp addp)
(wg-flag-workgroup-modified workgroup)
bufobj)))
(defun wg-workgroup-weakly-associate-bufobj (workgroup bufobj)
"Weakly associate BUFOBJ with WORKGROUP."
(let* ((uid (wg-bufobj-uid-or-add bufobj))
(remp (wg-removef-p uid (wg-workgroup-strong-buf-uids workgroup)
:test 'string=))
(addp (wg-pushnew-p uid (wg-workgroup-weak-buf-uids workgroup)
:test 'string=)))
(when (or remp addp)
(wg-flag-workgroup-modified workgroup)
bufobj)))
(defun wg-workgroup-associate-bufobj (workgroup bufobj &optional weak)
"Associate BUFOBJ with WORKGROUP.
WEAK non-nil means weakly associate it. Otherwise strongly associate it."
(if weak (wg-workgroup-weakly-associate-bufobj workgroup bufobj)
(wg-workgroup-strongly-associate-bufobj workgroup bufobj)))
(defun wg-workgroup-dissociate-bufobj (workgroup bufobj)
"Dissociate BUFOBJ from WORKGROUP."
(let* ((uid (wg-bufobj-uid-or-add bufobj))
(rem1p (wg-removef-p uid (wg-workgroup-strong-buf-uids workgroup)
:test 'string=))
(rem2p (wg-removef-p uid (wg-workgroup-weak-buf-uids workgroup)
:test 'string=)))
(when (or rem1p rem2p)
(wg-flag-workgroup-modified workgroup)
bufobj)))
(defun wg-workgroup-dissociate-weakly-associated-buffers (workgroup)
"Dissociate from WORKGROUP all weakly associated buffers."
(when (wg-workgroup-weak-buf-uids workgroup)
(wg-flag-workgroup-modified workgroup)
(setf (wg-workgroup-weak-buf-uids workgroup) nil)))
(defun wg-workgroup-dissociate-strongly-associated-buffers (workgroup)
"Dissociate from WORKGROUP all strongly associated buffers."
(when (wg-workgroup-strong-buf-uids workgroup)
(wg-flag-workgroup-modified workgroup)
(setf (wg-workgroup-strong-buf-uids workgroup) nil)))
(defun wg-workgroup-dissociate-all-buffers (workgroup)
"Dissociate from WORKGROUP all its associated buffers."
(wg-workgroup-dissociate-weakly-associated-buffers workgroup)
(wg-workgroup-dissociate-strongly-associated-buffers workgroup))
(defun wg-auto-dissociate-buffer-hook ()
"`kill-buffer-hook' that automatically dissociates buffers from workgroups."
(when wg-dissociate-buffer-on-kill-buffer
(awhen (wg-current-workgroup t)
(wg-workgroup-dissociate-bufobj it (current-buffer)))))
(defun wg-associate-buffer-with-workgroup (&optional workgroup buffer weak)
"Associate BUFFER with WORKGROUP.
WEAK non-nil means weakly associate BUFFER."
(interactive (list nil nil current-prefix-arg))
(let* ((workgroup (wg-get-workgroup workgroup))
(buffer (or buffer (current-buffer)))
(bname (buffer-name buffer))
(wgname (wg-workgroup-name workgroup)))
(if (wg-workgroup-associate-bufobj workgroup buffer weak)
(wg-message "%s-associated %S with %s"
(if weak "Weakly" "Strongly") bname wgname)
(wg-message "%S is already associated with %s" bname wgname))))
(defun wg-associate-visible-buffers-with-workgroup (&optional workgroup weak)
"Associate all buffers visible in `selected-frame' with WORKGROUP.
WEAK non-nil means weakly associate them. Otherwise strongly
associate them."
(interactive (list nil current-prefix-arg))
(let ((workgroup (wg-get-workgroup workgroup))
(buffers (mapcar 'window-buffer (window-list))))
(dolist (buffer buffers)
(wg-workgroup-associate-bufobj workgroup buffer weak))
(wg-fontified-message
(:cmd (format "%s associated: " (if weak "Weakly" "Strongly")))
(wg-display-internal 'wg-buffer-display buffers))))
(defun wg-dissociate-buffer-from-workgroup (&optional workgroup buffer)
"Dissociate BUFFER from WORKGROUP."
(interactive (list nil nil))
(let ((workgroup (wg-get-workgroup workgroup))
(buffer (or buffer (current-buffer))))
(wg-message
(if (wg-workgroup-dissociate-bufobj workgroup buffer)
"Dissociated %S from %s" "%S isn't associated with %s")
(wg-buffer-name buffer)
(wg-workgroup-name workgroup))))
(defun wg-associate-buffers (workgroup window-or-emacs-window-tree)
"Associate the buffers visible in window elements of
WINDOW-OR-EMACS-WINDOW-TREE with the given WORKGROUP.
WINDOW-OR-EMACS-WINDOW-TREE must be either a window or a tree of
the form produced by `(car (window-tree))'."
(if (windowp window-or-emacs-window-tree)
(with-current-buffer (window-buffer window-or-emacs-window-tree)
(setq wg-buffer-workgroup workgroup))
(dolist (w (cddr window-or-emacs-window-tree))
(when w (wg-associate-buffers workgroup w)))))
(defun wg-workgroup-bufobj-association-type (workgroup bufobj)
"Return BUFOBJ's association-type in WORKGROUP, or nil if unassociated."
(let ((uid (wg-bufobj-uid-or-add bufobj)))
(or (and (member uid (wg-workgroup-strong-buf-uids workgroup)) 'strong)
(and (member uid (wg-workgroup-weak-buf-uids workgroup)) 'weak))))
(defun wg-associate-frame-buffers ()
"Associate visible buffers with the current workgroup.
Unless it is currently being deactivated."
(awhen (wg-current-workgroup :noerror)
(unless (member it wg-deactivation-list)
(wg-associate-buffers it (car (window-tree))))))
(defun wg-add-or-remove-workgroups-hooks (remove)
"Add or remove all of Workgroups' hooks, depending on REMOVE."
(wg-add-or-remove-hooks
remove
'kill-emacs-query-functions 'wg-save-session-on-emacs-exit
'delete-frame-hook 'wg-update-working-wconfig-on-delete-frame
'after-make-frame-functions 'wg-update-working-wconfig-on-make-frame
'wg-pre-window-configuration-change-hook 'wg-update-working-wconfig-hook
'window-configuration-change-hook 'wg-flag-window-configuration-changed
'post-command-hook 'wg-undoify-window-configuration-change
'minibuffer-exit-hook 'wg-flag-just-exited-minibuffer
'kill-buffer-hook 'wg-update-buffer-in-buf-list
'kill-buffer-hook 'wg-auto-dissociate-buffer-hook
;;'window-configuration-change-hook 'wg-associate-frame-buffers
))
;;;###autoload
(defun workgroups-mode (&optional arg)
"Turn `workgroups-mode' on and off.
ARG is nil - toggle
ARG >= 1 - turn on
ARG == 0 - turn off
ARG is anything else, turn on `workgroups-mode'."
(interactive (list current-prefix-arg))
(setq workgroups-mode
(cond ((not arg) (not workgroups-mode))
((integerp arg) (if (> arg 0) t nil))
(t)))
(cond
(workgroups-mode
(if (boundp 'desktop-restore-frames)
(setq desktop-restore-frames nil))
(wg-reset-internal) ; creates a new `wg-current-session'
(wg-add-workgroups-mode-minor-mode-entries)
(wg-enable-all-advice)
(wg-add-or-remove-workgroups-hooks nil)
(wg-change-modeline)
;; some sr-speedbar hooks can harm
(when (featurep 'sr-speedbar)
(ad-disable-advice 'delete-other-windows 'around 'sr-speedbar-delete-other-window-advice)
(ad-disable-advice 'delete-window 'before 'sr-speedbar-delete-window-advice))
;; Load session
(when (and wg-session-load-on-start
(file-exists-p wg-session-file))
(condition-case err
(wg-open-session wg-session-file)
(error (message "Error finding `wg-session-file': %s" err))))
(run-hooks 'workgroups-mode-hook))
(t
(wg-save-session-on-workgroups-mode-exit)
(wg-disable-all-advice)
(wg-add-or-remove-workgroups-hooks t)
(wg-remove-mode-line-display)
(run-hooks 'workgroups-mode-exit-hook)))
(wg-fontified-message
(:cmd "Workgroups Mode: ") (:msg (if workgroups-mode "on" "off")))
(wg-create-first-wg)
workgroups-mode)
;;;###autoload
(defun wg-help ()
"Just call `apropos-command' on \"^wg-\".
There used to be a bunch of help-buffer construction stuff here,
including a `wg-help' variable that basically duplicated every
command's docstring; But why, when there's `apropos-command'?"
(interactive)
(apropos-command "^wg-"))
;; Remove after some time
(defalias 'wg-switch-to-buffer 'switch-to-buffer)
(provide 'workgroups2)
;;; workgroups2.el ends here
|