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
|
;;; nrepl.scm -- notcurses-based repl
(set! (*s7* 'history-enabled) #f)
(provide 'nrepl.scm)
(define libc-let (if (defined? '*nlibc*) ; nrepl.c has the parts of *libc* we need under the name *nlibc*
*nlibc*
(begin
(require libc.scm)
*libc*)))
(unless (defined? '*notcurses*) ; nrepl.c has notcurses_s7.c (thus *notcurses*) built-in
(load "notcurses_s7.so" (inlet 'init_func 'notcurses_s7_init)))
(unless (defined? 'notcurses_getc) (define (notcurses_getc a b c d) (notcurses_get a b d)))
(define (drop-into-repl call e)
((*nrepl* 'run) "break>" (object->string call) e))
(define (display-debug-info cint) #f) ; replaced later
(define (remove-watcher var) #f)
(define (nrepl-lookup symbol) (((*nrepl* 'top-level-let) 'run-let) symbol))
(define (debug.scm-init)
(set! (debug-repl)
drop-into-repl)
(set! (debug-port)
(open-output-function display-debug-info))
(set! (hook-functions ((funclet trace-in) '*debug-unwatch-hook*))
(list (lambda (h)
(remove-watcher (h 'var))))))
(define old-debug (*s7* 'debug))
(set! (*s7* 'debug) 0)
(define startup-symbols (copy (symbol-table)))
;(autoload 'lint "lint.scm")
(require lint.scm)
(define with-lint (defined? '*lint*)) ; maybe require should return #f if no luck? (or a list since it takes any number of args), or an error??
(autoload 'pretty-print "write.scm")
(autoload 'pp "write.scm")
(autoload '*libc* "libc.scm")
(autoload '*libm* "libm.scm")
(autoload '*libgsl* "libgsl.scm")
(autoload 'trace "debug.scm")
(autoload 'untrace "debug.scm")
(autoload 'break "debug.scm")
(autoload 'unbreak "debug.scm")
(autoload 'watch "debug.scm")
(autoload 'unwatch "debug.scm")
(autoload 'ow! "stuff.scm")
(autoload 'show-profile "profile.scm")
(autoload 'profile-port "profile.scm")
(when (file-exists? ".nrepl") ; local (scheme) initialization file for nrepl
(load ".nrepl"))
;(define dbstr "")
(unless (defined? '*nrepl*)
(define *nrepl*
(let* ((nc #f)
(nc-cols 0)
(nc-rows 0)
(status-rows 3)
(status-cells (vector (nccell_make) (nccell_make) (nccell_make) (nccell_make) (nccell_make) (nccell_make)))
(statp #f)
(statp-row 0)
(recursor #f)
(top-level-let
(sublet (rootlet) ; environment in which evaluation takes place
:history #f ; set below
:ncp-let #f
:display-status #f
:status-text ""
:run-let #f
:s7-version (lambda () (*s7* 'version))
:exit (let ((+documentation+ "(exit) stops notcurses and then calls #_exit"))
(let-temporarily (((*s7* 'debug) 0))
(lambda ()
(notcurses_stop (*nrepl* 'nc))
(#_exit))))
:time (macro (expr)
`(let ((start (*s7* 'cpu-time)))
,expr
(- (*s7* 'cpu-time) start)))
:with-profile (macro body
`(let-temporarily (((*s7* 'profile) 1)
((profile-port) (open-output-string)))
,@body
(show-profile)
(clear-profile)
(get-output-string (profile-port))))
;; the profiler has to be on when the to-be-profiled functions are loaded
:apropos
(let ((levenshtein
(lambda (s1 s2)
(let ((L1 (length s1))
(L2 (length s2)))
(cond ((zero? L1) L2)
((zero? L2) L1)
(else (let ((distance (make-vector (list (+ L2 1) (+ L1 1)) 0)))
(do ((i 0 (+ i 1)))
((> i L1))
(set! (distance 0 i) i))
(do ((i 0 (+ i 1)))
((> i L2))
(set! (distance i 0) i))
(do ((i 1 (+ i 1)))
((> i L2))
(do ((j 1 (+ j 1)))
((> j L1))
(let ((c1 (+ (distance i (- j 1)) 1))
(c2 (+ (distance (- i 1) j) 1))
(c3 (if (char=? (s2 (- i 1)) (s1 (- j 1)))
(distance (- i 1) (- j 1))
(+ (distance (- i 1) (- j 1)) 1))))
(set! (distance i j) (min c1 c2 c3)))))
(distance L2 L1)))))))
(make-full-let-iterator ; walk the entire let chain
(lambda* (lt (stop (rootlet)))
(if (eq? stop lt)
(make-iterator lt)
(letrec ((iterloop
(let ((iter (make-iterator lt))
(+iterator+ #t))
(lambda ()
(let ((result (iter)))
(if (and (eof-object? result)
(iterator-at-end? iter)
(not (eq? stop (iterator-sequence iter))))
(begin
(set! iter (make-iterator (outlet (iterator-sequence iter))))
(iterloop))
result))))))
(make-iterator iterloop))))))
(lambda* (name (e (sublet (*nrepl* 'top-level-let) *notcurses*)))
(let ((ap-name (if (string? name) name
(if (symbol? name)
(symbol->string name)
(error 'wrong-type-arg "apropos argument 1 should be a string or a symbol"))))
(ap-env (if (let? e) e
(error 'wrong-type-arg "apropos argument 2 should be an environment"))))
(let ((strs ())
(min2 (floor (log (length ap-name) 2))))
(for-each
(lambda (binding)
(if (pair? binding)
(let ((symbol-name (symbol->string (car binding))))
(if (string-position ap-name symbol-name)
(set! strs (cons (cons binding 0) strs))
(let ((distance (levenshtein ap-name symbol-name)))
(if (< distance min2)
(set! strs (cons (cons binding distance) strs))))))))
(make-full-let-iterator ap-env))
(if (not (pair? strs))
'no-match
(let ((data "")
(name-len (length name)))
(for-each (lambda (b)
(set! data (string-append data
(if (> (length data) 0) (string #\newline) "")
(if (procedure? (cdar b))
(let ((doc (documentation (cdar b)))) ; returns "" if no doc
(if (positive? (length doc))
doc
(object->string (caar b))))
(object->string (caar b))))))
(sort! strs (lambda (a b)
(or (< (cdr a) (cdr b))
(and (= (cdr a) (cdr b))
(< (abs (- (length (symbol->string (caar a))) name-len))
(abs (- (length (symbol->string (caar b))) name-len))))))))
data))))))
)))
;; to call notcurses functions in the repl, use *nrepl* or ncp-let:
;; (notcurses_refresh (ncp-let 'nc))
;; to call run within run:
;; ((*nrepl* 'run) "new-prompt>" "header info")
;; -------- completion --------
(define (symbol-completion text)
(let ((text-len (length text))
(match #f))
(call-with-exit
(lambda (return)
(for-each
(lambda (lst)
(for-each
(lambda (par)
(let* ((sym (symbol->string par))
(sym-len (length sym)))
(when (and (>= sym-len text-len)
(string=? text (substring sym 0 text-len)))
(if match
;; more than one match, save the longest text that all syms match
(do ((min-len (min (string-length match) sym-len))
(i text-len (+ i 1)))
((or (= i min-len)
(not (char=? (match i) (sym i))))
(if (= min-len text-len)
(return text)
(set! match (substring match 0 i)))))
(set! match sym)))))
lst))
(list startup-symbols (map car top-level-let))) ; (using startup-symbols to avoid all the lint junk), any others?
match))))
(define (filename-completion text)
(and (> (length text) 0)
(with-let (sublet libc-let :text text)
(let ((g (glob.make)))
(glob (string-append text "*")
(logior (if (and (defined? 'GLOB_TILDE)
(char=? (text 0) #\~))
GLOB_TILDE
0)
GLOB_MARK)
g)
(let ((files (map (lambda (f) ; get rid of emacs' *~ files
(if (and (> (length f) 1)
(char=? #\~ (f (- (length f) 1))))
(values)
f))
(glob.gl_pathv g))))
(globfree g)
(and (not (null? files))
(null? (cdr files))
(car files)))))))
;; -------- status area --------
(define (display-status-area)
(ncplane_cursor_move_yx statp 0 0)
(ncplane_box statp
(status-cells 0) (status-cells 1) (status-cells 2)
(status-cells 3) (status-cells 4) (status-cells 5)
2 (- nc-cols 1) 0)
(ncplane_move_yx statp statp-row 0)
(notcurses_render nc))
(define (statp-set-bg-color r g b)
;; (statp-bg-set-color 0.85 0.85 0.85): light gray background
(let ((c1 (nccell_make)))
(let ((color (logior (ash (floor (* r 256)) 16)
(ash (floor (* g 256)) 8)
(floor (* b 256)))))
(set! (nccell_gcluster c1) (char->integer #\space))
(set! (nccell_channels c1) (logior (ash NC_BGDEFAULT_MASK 32) NC_BGDEFAULT_MASK color)))
(set! (nccell_stylemask c1) 0)
(ncplane_set_base_cell statp c1)
(notcurses_render nc)
c1))
(define (clear-status)
(ncplane_putstr_yx statp 1 1 (make-string (- nc-cols 2) #\space)))
(define (display-status str)
(clear-status)
(ncplane_putstr_yx statp 1 2 (substring str 0 (min (length str) (- nc-cols 3))))
(notcurses_render nc))
(set! (top-level-let 'display-status) display-status)
(define (first-line text)
(let ((pos (char-position #\newline text)))
(if (not pos)
text
(substring text 0 pos))))
;; -------- red text --------
(define (red c)
(let ((c1 (nccell_make)))
(set! (nccell_gcluster c1) (char->integer c))
(set! (nccell_channels c1) (logior (ash NC_BGDEFAULT_MASK 32) #xff000000000000))
(set! (nccell_stylemask c1) 0)
c1))
(define (normal c)
(let ((c1 (nccell_make)))
(set! (nccell_gcluster c1) (char->integer c))
(set! (nccell_channels c1) 0)
(set! (nccell_stylemask c1) 0)
c1))
(define red-error (let ((v (make-vector 5)))
(set! (v 0) (red #\e))
(set! (v 1) (red #\r))
(set! (v 2) (v 1))
(set! (v 3) (red #\o))
(set! (v 4) (v 1))
v))
(define red-paren (red #\())
(define normal-paren (normal #\())
;; -------- run --------
(define* (run (prompt ">") header (envir (*nrepl* 'top-level-let)))
(let ((ncp-col 0) ; top-left in ncp
(ncp-row 0)
(ncp-cols (max 100 nc-cols))
(ncp-rows (max 100 nc-rows))
(ncp-max-row 0)
(ncp #f)
(col 0) ; ncplane-relative row/column
(row 0)
(header-row 0)
(prev-pars #f)
(keymap (make-hash-table 512))
(old-history (top-level-let 'history)) ; see below, old restored upon exit from this ncplane
(hc #f)
(hc-cells #f)
(header-cols 0)
(header-strings #f)
(watch-row 0)
(watch-rows 3)
(watch-col 0)
(watch-cols 0)
(watchers (make-hash-table 8 eq?))
(wc #f)
(wc-cells #f))
(define (move-cursor y x) ; this was (format *stderr* "~C[~D;~DH" #\escape y x) in repl.scm
(notcurses_refresh nc) ; needed in 1.7.1, not in 1.6.11
(notcurses_cursor_enable nc
(max header-row (+ y ncp-row))
(if (and wc (= y (+ watch-row 1)))
(min (- watch-col 1) (+ x ncp-col))
(+ x ncp-col))))
(set! (top-level-let :run-let) (curlet))
(when header
(set! hc-cells (vector (nccell_make) (nccell_make) (nccell_make) (nccell_make) (nccell_make) (nccell_make)))
(let ((newline-pos (char-position #\newline header)))
(if newline-pos
(let loop ((str (substring header (+ newline-pos 1)))
(newlines (list (+ newline-pos 1) 0)))
(let ((pos (char-position #\newline str)))
(if pos
(loop (substring str (+ pos 1))
(cons (+ (car newlines) pos 1) newlines))
(let ((npos (reverse newlines))
(nlen (length newlines)))
(set! hc (ncplane_new nc (+ 3 nlen) ncp-cols 0 0 (c-pointer 0)))
(ncplane_cursor_move_yx hc 0 0)
(nccells_double_box hc 0 0 (hc-cells 0) (hc-cells 1) (hc-cells 2) (hc-cells 3) (hc-cells 4) (hc-cells 5))
(ncplane_box hc (hc-cells 0) (hc-cells 1) (hc-cells 2) (hc-cells 3) (hc-cells 4) (hc-cells 5) (+ 1 nlen) (- nc-cols 1) 0)
(set! header-strings (make-vector nlen))
(do ((i 0 (+ i 1))
(hrow 1 (+ hrow 1))
(posl npos (cdr posl)))
((= hrow nlen)
(ncplane_putstr_yx hc hrow 1 (make-string (- nc-cols 5) #\space))
(set! (header-strings i) (substring header (car posl)))
(ncplane_putstr_yx hc hrow 2 (substring (header-strings i) 0 (min (length (header-strings i)) (- nc-cols 3))))
(set! header-row (+ 3 nlen))
(set! row header-row))
(ncplane_putstr_yx hc hrow 1 (make-string (- nc-cols 5) #\space))
(set! (header-strings i) (substring header (car posl) (cadr posl)))
(ncplane_putstr_yx hc hrow 2 (substring (header-strings i) 0 (min (length (header-strings i)) (- nc-cols 3)))))))))
(begin
(set! hc (ncplane_new nc 3 ncp-cols 0 0 (c-pointer 0)))
(ncplane_cursor_move_yx hc 0 0)
(nccells_double_box hc 0 0 (hc-cells 0) (hc-cells 1) (hc-cells 2) (hc-cells 3) (hc-cells 4) (hc-cells 5))
(ncplane_box hc (hc-cells 0) (hc-cells 1) (hc-cells 2) (hc-cells 3) (hc-cells 4) (hc-cells 5) 2 (- nc-cols 1) 0)
(ncplane_putstr_yx hc 1 1 (make-string (- nc-cols 5) #\space))
(set! header-strings (vector header))
(ncplane_putstr_yx hc 1 2 (substring (header-strings 0) 0 (min (length header) (- nc-cols 3))))
(set! header-row 3)
(set! row header-row))))
(set! header-cols nc-cols))
(set! ncp (ncplane_new nc ncp-rows ncp-cols 0 0 (c-pointer 0)))
(let ((eols (make-int-vector ncp-rows 0))
(bols (make-int-vector ncp-rows 0)))
(ncplane_move_below ncp statp) ; statp always displayed with ncplanes sliding underneath conceptually
;; opaque plane
(let ((c1 (nccell_make)))
(set! (nccell_gcluster c1) (char->integer #\space))
(set! (nccell_channels c1) 0)
(set! (nccell_stylemask c1) 0)
(ncplane_set_base_cell ncp c1)
(unless header
(set! header-row 1) ; avoid first row -- output is messed up by notcurses
(set! row 1)
(set! header-cols nc-cols))
(notcurses_render nc))
(let ((last-name ""))
(set! (hook-functions *load-hook*)
(cons (lambda (h)
(unless (string=? (h 'name) last-name)
(set! last-name (h 'name))
(display-status (format #f "loading ~S" (h 'name)))))
(hook-functions *load-hook*)))
(set! (hook-functions *autoload-hook*)
(cons (lambda (h)
(set! last-name (h 'file))
(display-status (format #f "autoloading ~S from ~S" (h 'name) (h 'file))))
(hook-functions *autoload-hook*))))
;; -------- scrolling and resizing --------
;;
;; row and col are ncp-relative, its ncp-row|col are the location of its top left corner (0,0)
;; in the terminal window. ncp-rows|cols are its size. nc-rows|cols is the terminal size.
;; ncp-col = -5 means ncp is shifted left (to display the rightward portion),
;; ncp-col = 5 means ncp is shifted right (moving its top-left corner to (5,0) in the terminal
;; (using (row,col) throughout). This won't happen in normal editing, but the user
;; can easily move ncp: (ncplane_move_yx (ncp-let 'ncp) 5 0).
;; Here the assumption is we want val to be visible and the current row is already visible.
;; The currently visible portion of ncp is from ((max 0 -ncp-row), (max 0 -ncp-col)) to (bottom right)
;; ((nc-rows - ncp-row), (nc-cols - ncp-col)) (assuming we're not completely off screen).
(define (set-ncp-row val)
(when prev-pars
(set! prev-pars #f)
(notcurses_refresh nc))
(set! ncp-row val))
(define (set-ncp-col val)
(when prev-pars
(set! prev-pars #f)
(notcurses_refresh nc))
(set! ncp-col val))
(define (resize-watcher)
(when wc
(let ((old-watch-cols watch-cols)
(old-watch-rows watch-rows))
(set! watch-rows (+ (hash-table-entries watchers) 2))
(set! watch-col (floor (* 0.618 nc-cols)))
(set! watch-cols (- nc-cols watch-col))
(ncplane_resize wc 0 0
(min old-watch-rows watch-rows)
(min old-watch-cols watch-cols)
0 0
watch-rows watch-cols)
(ncplane_move_yx wc header-row watch-col)
(ncplane_cursor_move_yx wc 0 0)
(ncplane_box wc (wc-cells 0) (wc-cells 1) (wc-cells 2) (wc-cells 3) (wc-cells 4) (wc-cells 5) (- watch-rows 1) (- watch-cols 1) 0)
(for-each (lambda (key-row&str)
(ncplane_putstr_yx wc (cadr key-row&str) 1 (make-string (- watch-cols 2) #\space))
(ncplane_putstr_yx wc (cadr key-row&str) 2 (cddr key-row&str)))
watchers))))
(define (nc-resize new-rows new-cols)
(let ((old-nc-cols nc-cols))
(set! nc-cols new-cols)
(set! nc-rows new-rows)
;; resize status area
(set! statp-row (- nc-rows status-rows))
(ncplane_putstr_yx statp 1 (- old-nc-cols 1) " ")
(ncplane_resize statp 0 0 status-rows (min old-nc-cols nc-cols) 0 0 status-rows nc-cols)
;; resize header
(when hc
(ncplane_resize hc 0 0 header-row (min old-nc-cols nc-cols) 0 0 header-row nc-cols)
(ncplane_cursor_move_yx hc 0 0)
(ncplane_box hc (hc-cells 0) (hc-cells 1) (hc-cells 2) (hc-cells 3) (hc-cells 4) (hc-cells 5) (+ (length header-strings) 1) (- nc-cols 1) 0)
(do ((i 0 (+ i 1))
(hrow 1 (+ hrow 1)))
((= i (length header-strings)))
(ncplane_putstr_yx hc hrow (- old-nc-cols 1) " "))
(set! header-cols nc-cols)
;; redisplay the header from the original strings
(do ((i 0 (+ i 1))
(hrow 1 (+ hrow 1)))
((= i (length header-strings)))
(ncplane_putstr_yx hc hrow 1 (make-string (- nc-cols 5) #\space))
(ncplane_putstr_yx hc hrow 2 (substring (header-strings i) 0 (min (length (header-strings i)) (- nc-cols 3))))))
(resize-watcher)
;; resize current pane (ncp)
(when (or (< ncp-rows nc-rows)
(< ncp-cols nc-cols))
(ncplane_resize ncp 0 0 ncp-rows ncp-cols 0 0 (max ncp-rows nc-rows) (max ncp-cols nc-cols))
(when (> nc-rows ncp-rows)
(set! bols (copy bols (make-int-vector nc-rows)))
(set! eols (copy eols (make-int-vector nc-rows)))
(set! ncp-rows nc-rows))
(set! ncp-cols (max ncp-cols nc-cols)))))
(define (visible? r c)
(and (< r (- statp-row ncp-row))
(>= r (- header-row ncp-row))
(< c (- nc-cols ncp-col))
(>= c (- ncp-col))))
(define (set-row val)
(set! row (max header-row val))
(when (>= row ncp-rows)
(ncplane_resize ncp 0 0 ncp-rows ncp-cols 0 0 (+ row 40) ncp-cols)
(set! ncp-rows (+ row 40))
(set! bols (copy bols (make-int-vector ncp-rows)))
(set! eols (copy eols (make-int-vector ncp-rows))))
(cond ((>= row (- statp-row ncp-row)) ; current row is outside (below) the terminal window
(set-ncp-row (min 0 (- statp-row row 2)))
(ncplane_move_yx ncp ncp-row ncp-col)
(move-cursor row col))
((< row (- header-row ncp-row)) ; current row is outside (above) the terminal window
(set-ncp-row (- header-row row))
(ncplane_move_yx ncp ncp-row ncp-col))))
(define (set-col val)
(set! col val)
(when (>= col ncp-cols)
(ncplane_resize ncp 0 0 ncp-rows ncp-cols 0 0 ncp-rows (+ col 10))
(set! ncp-cols (+ col 10)))
(cond ((>= col (- nc-cols ncp-col)) ; current column is outside (to the right of) the terminal window
(set-ncp-col (min 0 (- nc-cols col 2)))
(ncplane_move_yx ncp ncp-row ncp-col))
((< col (- ncp-col)) ; current column is outside (to the left of) the terminal window, ncp-col < 0 means the ncp plane is shifted left
(set-ncp-col (- col))
(ncplane_move_yx ncp ncp-row ncp-col))
((and (= col (bols row)) ; special case: we're stuck against the prompt, but want move it into view
(< ncp-col 0))
(set-ncp-col 0)
(ncplane_move_yx ncp ncp-row ncp-col))))
(define (increment-row incr)
(set! row (+ row incr))
;; (display-status (format #f "increment -> ~D~%" row))
(when (>= row ncp-rows)
(ncplane_resize ncp 0 0 ncp-rows ncp-cols 0 0 (+ row 40) ncp-cols)
(set! ncp-rows (+ row 40))
(set! bols (copy bols (make-int-vector ncp-rows)))
(set! eols (copy eols (make-int-vector ncp-rows))))
(when (>= row (- statp-row ncp-row))
(set-ncp-row (min 0 (- statp-row row 1))) ; this moves to bottom, (- row) to top??
(ncplane_move_yx ncp ncp-row ncp-col)
(move-cursor row col)))
(define (increment-col incr)
(set! col (+ col incr))
(when (>= col ncp-cols)
(ncplane_resize ncp 0 0 ncp-rows ncp-cols 0 0 ncp-rows (+ col 10))
(set! ncp-cols (+ col 10)))
(when (>= col (+ ncp-col nc-cols))
(set-ncp-col (min 0 (- nc-cols col 2)))
(ncplane_move_yx ncp ncp-row ncp-col)))
(define (decrement-row incr)
(set! row (max header-row (- row incr)))
(when (<= row (- header-row ncp-row)) ; current row is outside (above) the terminal window
(set-ncp-row (- header-row row))
(ncplane_move_yx ncp ncp-row ncp-col)))
(define (decrement-col incr)
(set! col (- col incr))
(when (<= col (- ncp-col)) ; current column is outside (to the left of) the terminal window
(set-ncp-col (- col))
(ncplane_move_yx ncp ncp-row ncp-col)))
(define (nc-multiline-display str) ; increment-row below will make space if needed
(let ((len (length str)))
(if (not (char-position #\newline str))
(begin
(nc-display row 0 str)
(set! (eols row) len))
(do ((start 0)
(i 0 (+ i 1)))
((= i len)
(nc-display row 0 (substring str start len))
(set! (eols row) (- len start)))
(if (char=? #\newline (str i))
(begin
(nc-display row 0 (substring str start i))
(set! (eols row) (- i start))
(increment-row 1)
(set! ncp-max-row (max ncp-max-row row))
(set! start (+ i 1))))))))
;; -------- lint (redirect output) --------
;;
;; we load lint above, at which time it sets its *output-port* to *stderr* (the global built-in port), but
;; when called in the repl, we have over-ridden *stderr* to place that output in the notcurses display,
;; so we need to redirect lint's output by hand.
(when with-lint
(set! lint ; force top-level change
(let ((old-lint lint))
(lambda* (file (outp :unset) (report-input :unset))
(if (and (eq? outp :unset)
(eq? report-input :unset))
(nc-multiline-display
(call-with-output-string
(lambda (p)
(old-lint file p))))
(old-lint file outp report-input))))))
;; -------- top-level-let --------
(set! (top-level-let 'history)
(lambda (filename)
(call-with-output-file filename
(lambda (p)
(let ((timestamp (with-let (sublet libc-let)
(let ((timestr (make-string 128)))
(strftime timestr 128 "%a %d-%b-%Y %H:%M:%S %Z"
(localtime
(time.make (time (c-pointer 0 'time_t*)))))
timestr))))
(format p ";;; nrepl: ~A~%~%" timestamp))
(do ((i 0 (+ i 1)))
((= i ncp-max-row))
(if (> (bols i) 0)
(format p "~A ~A~%" (ncplane_contents ncp i 0 1 (bols i)) (ncplane_contents ncp i (bols i) 1 (eols i)))
(format p "~A~%" (ncplane_contents ncp i 0 1 (eols i)))))))))
;; --------display --------
(define (clear-line row)
(ncplane_putstr_yx ncp row (bols row) (make-string (max 80 (- (eols row) (bols row))) #\space)))
(define (nc-display r c str)
(let ((len (length str)))
(when (>= (+ c len) ncp-cols)
(ncplane_resize ncp 0 0 ncp-rows ncp-cols 0 0 ncp-rows (+ c len 10))
(set! ncp-cols (+ c len 10)))
(ncplane_putstr_yx ncp r c str)
(if (= c 0) (set! (bols r) 0))))
(define (reprompt y)
(ncplane_cursor_move_yx ncp y 0)
;(clear-line y)
(ncplane_putstr_yx ncp y 0 prompt)
(notcurses_render nc)
(let ((prompt-len (+ (length prompt) 1)))
(when (zero? (bols row)) ; might be in pre-existing section where we're just re-establishing an existing prompt
(set! (bols row) prompt-len)
(set! (eols row) prompt-len))
(set! col prompt-len)
(set-row y)
(notcurses_refresh nc)
(move-cursor y prompt-len)))
(define (display-error ncp row info)
(do ((i 0 (+ i 1)))
((= i 5))
(ncplane_putc_yx ncp row i (red-error i)))
(notcurses_render nc) ; else cursor jumps back!
(ncplane_putstr_yx ncp row 5 ": ")
(set! (eols row) 7)
(if (and (pair? info)
(string? (car info)))
(let ((err (apply format #f info)))
(nc-display row 7 err)
(set! (eols row) (+ (length err) 7)))
(if (not (null? info))
(let ((err (object->string info)))
(nc-display row 1 err)
(set! (eols row) (+ (length err) 7)))))
row)
;; -------- watchers --------
(define local-debug-info
(let ((str ""))
(lambda (int)
(if (= int (char->integer #\newline))
(begin ; watch
(display-status str)
(if (string-position "set! to " str) ; it's a watcher
(let* ((pos (char-position #\space str))
(var (string->symbol (substring str 0 pos)))
(var-data (watchers var))
(var-row (and (pair? var-data) (car var-data)))
(var-str (format #f "~A: ~A" var (substring str (+ pos 9)))))
(unless wc
(set! wc-cells (vector (nccell_make) (nccell_make) (nccell_make) (nccell_make) (nccell_make) (nccell_make)))
(set! watch-row header-row)
(set! watch-col (floor (* 0.618 nc-cols))) ; ah the good old days
(set! watch-cols (- nc-cols watch-col))
(set! wc (ncplane_new nc watch-rows watch-cols watch-row watch-col (c-pointer 0)))
(nccells_double_box wc 0 0 (wc-cells 0) (wc-cells 1) (wc-cells 2) (wc-cells 3) (wc-cells 4) (wc-cells 5))
(ncplane_box wc (wc-cells 0) (wc-cells 1) (wc-cells 2) (wc-cells 3) (wc-cells 4) (wc-cells 5) (- watch-rows 1) (- watch-cols 1) 0)
(let ((c1 (nccell_make)))
(set! (nccell_gcluster c1) (char->integer #\space))
(set! (nccell_channels c1) 0) ; opaque apparently
(set! (nccell_stylemask c1) 0)
(ncplane_set_base_cell wc c1)
(notcurses_render nc)))
(if var-row
(set-cdr! var-data var-str)
(begin
(set! var-row (+ 1 (hash-table-entries watchers)))
(set! var-data (cons var-row var-str))
(hash-table-set! watchers var var-data)
(resize-watcher)))
(ncplane_putstr_yx wc var-row 1 (make-string (- watch-cols 2) #\space))
(ncplane_putstr_yx wc var-row 2 (cdr var-data))
(notcurses_render nc))
(begin ; trace etc
;(nc-display row 0 str) ; this is break in debug.scm reporting the result " -> 1" but we have already done that
(set! (eols row) (length str))
(increment-row 1)))
(set! str ""))
(set! str (append str (string (integer->char int))))))))
(define (local-remove-watcher var)
(hash-table-set! watchers var #f)
(if (and wc (zero? (hash-table-entries watchers)))
(begin
(ncplane_destroy wc)
(set! wc #f))
(let ((r 1))
(resize-watcher)
(for-each (lambda (var&row)
(hash-table-set! watchers (car var&row) (cons r (cddr var&row)))
(ncplane_putstr_yx wc r 1 (make-string (max 0 (- nc-cols watch-col 3)) #\space))
(ncplane_putstr_yx wc r 2 (cddr var&row))
(set! r (+ r 1)))
watchers)
;(ncplane_putstr_yx wc r 2 (make-string (max 0 (max 0 (- nc-cols watch-col 3)) #\space)))
)))
;; -------- match close paren --------
(define (match-close-paren ncp row col indenting)
;; if row/col is just after #|), get start of current expr, scan until row/col
;; return either matching row/col or #f if none
(call-with-exit
(lambda (return)
(do ((r row (- r 1)))
((> (bols r) 0)
(do ((cur-row r (+ cur-row 1))
(oparens ()))
((> cur-row row)
;; ((top-level-let 'display-status) (format #f "~S ~S ~S" row cur-row oparens))
(and (pair? oparens)
oparens))
(let* ((cur-line (ncplane_contents ncp cur-row (bols cur-row) 1 (- (eols cur-row) (bols cur-row))))
(len (if (and (= cur-row row)
(not indenting))
(min (- col (bols row) 1) (length cur-line))
(length cur-line))))
(do ((i 0 (+ i 1)))
((>= i len))
(case (cur-line i)
((#\()
(set! oparens (cons (list cur-row (+ i (bols cur-row)) 0 #f) oparens)))
((#\))
(when (pair? oparens)
(set! oparens (cdr oparens))
(when (and indenting
(pair? oparens))
(let ((top (cddar oparens)))
(set-car! top (+ (car top) 1))))))
((#\;)
(set! i (+ len 1)))
((#\")
(do ((found-close-quote #f))
(found-close-quote) ; need to look possibly across several rows
(do ((k (+ i 1) (+ k 1)))
((or (>= k len)
(and (char=? (cur-line k) #\")
(not (char=? (cur-line (- k 1)) #\\))))
;; ((top-level-let 'display-status) (format #f "~S ~S ~S ~S" cur-row row k len))
(if (>= k len) ; no close quotes by eol
(if (= cur-row row)
(return #f)
(begin
(set! cur-row (+ cur-row 1))
(set! i 0)
(set! cur-line (ncplane_contents ncp cur-row (bols cur-row) 1 (- (eols cur-row) (bols cur-row))))
(set! len (if (and (= cur-row row)
(not indenting))
(min (- col (bols row) 1) (length cur-line))
(length cur-line)))))
(begin
(set! found-close-quote #t)
(set! i k)))))))
((#\#)
(when (and (< i (- len 1))
(char=? (cur-line (+ i 1)) #\|))
(do ((found-close-comment #f))
(found-close-comment)
(do ((k (+ i 1) (+ k 1)))
((or (>= k (- len 1))
(and (char=? (cur-line k) #\|)
(char=? (cur-line (+ k 1)) #\#)))
(if (>= k len)
(if (= cur-row row)
(return #f)
(begin
(set! cur-row (+ cur-row 1))
(set! i -1)
(set! cur-line (ncplane_contents ncp cur-row (bols cur-row) 1 (- (eols cur-row) (bols cur-row))))
(set! len (if (and (= cur-row row)
(not indenting))
(min (- col (bols row) 1) (length cur-line))
(length cur-line)))))
(begin
(set! found-close-comment #t)
(set! i (+ k 1)))))))))
((#\space #\newline #\tab #\return))
(else
(when (and indenting
(pair? oparens))
(let ((top (cdddar oparens))
(c (+ i (bols cur-row))))
(if (pair? (car top))
(set-car! (cdar top) c)
(set! (car top) (list c c)))))))))))))))
;; -------- indentation --------
(define indent
(let ((white-space (string #\newline #\space #\return #\tab #\linefeed)))
(lambda (ncp row col)
(if (not (zero? (bols row)))
col
(let ((pars (match-close-paren ncp (- row 1) (eols (- row 1)) #t)))
(if (not pars)
(set! (eols row) 0)
(let ((unmatched-par (car pars)))
;; -> (row col-of-( visits #f-or-(name-start name-end)
;; row/col args = cursor pos
(let ((open-row (car unmatched-par))
(open-col (cadr unmatched-par))
(visits (caddr unmatched-par)) ; how many complete lists follow this (
(name-bounds (cadddr unmatched-par)) ; bounds of non-white-space after (
(trailer (ncplane_contents ncp row 0 1 (eols row)))
(slice 0))
(let ((tlen (length trailer)))
(when (positive? tlen)
(do ((i 0 (+ i 1)))
((or (= i tlen)
(not (char-whitespace? (trailer i))))
(set! slice i)
(set! trailer (substring trailer i))))))
(if (not (pair? name-bounds))
(let ((incr 2))
(let ((uname (and (pair? (cdr pars))
(let* ((upar (cadr pars))
(uopen-row (car upar))
(uname-bounds (cadddr upar))
(uname+args (ncplane_contents ncp
uopen-row (car uname-bounds)
1 (+ (- (cadr uname-bounds) (car uname-bounds)) 1)))
(uwpos (char-position white-space uname+args)))
(if (integer? uwpos)
(substring uname+args 0 uwpos)
uname+args)))))
(if (member uname '("do" "let" "let*" "letrec" "letrec*" "let-temporarily") string=?)
(set! incr 1)))
;; nothing after the ( on its row, might be moving back, so we need to erase the current line
(clear-line row)
(nc-display row 0 (format #f "~NC~A" (+ open-col incr) #\space trailer))
(set! (eols row) (+ open-col incr (length trailer)))
(min (+ open-col incr (- col slice)) (eols row))) ; keep cursor in its relative-to-trailer position if possible
(let* ((name+args (ncplane_contents ncp open-row (car name-bounds) 1 (+ (- (cadr name-bounds) (car name-bounds)) 1)))
(wpos (char-position white-space name+args))
(name (if (integer? wpos)
(substring name+args 0 wpos)
name+args))
(increment
(cond ((member name '("cond" "when" "unless" "lambda" "lambda*" "begin" "case" "with-let"
"let" "let*" "letrec" "letrec*" "let-temporarily"
"call-with-exit" "call/cc" "call-with-current-continuation"
"define" "define*" "define-macro" "catch" "sublet")
string=?)
2)
((string=? name "do")
(if (= visits 1) 4 2))
((member name '("call-with-input-string" "call-with-input-file") string=?)
(if (= open-row (- row 1)) 4 2))
(else (+ (length name) 2)))))
;; might be moving back, so we need to erase the current line
(clear-line row)
(nc-display row 0 (format #f "~NC~A" (+ increment open-col) #\space trailer))
(set! (eols row) (+ open-col increment (length trailer)))
(max 0 (min (+ open-col increment (- col slice)) (eols row))))
;; keep cursor in its relative-to-trailer position if possible, but squeeze slice (space) if not enough room
)))))))))
;;-------- tab --------
(define (tab c)
(if (< col (eols row))
(set-col (indent ncp row col))
(let ((start (bols row))
(end (eols row)))
(if (= end start)
(begin
(nc-display row end " ")
(set! (eols row) (+ end 4))
(increment-col 4))
(let ((cur-line (ncplane_contents ncp row (bols row) 1 (- (eols row) (bols row)))))
(if (not (let loop ((i 0) (len (length cur-line)))
(and (< i len)
(or (not (char-whitespace? (cur-line i)))
(loop (+ i 1) len)))))
(set-col (indent ncp row col))
(let ((loc (do ((i (- (length cur-line) 1) (- i 1)))
((or (< i 0)
(char-whitespace? (cur-line i))
(memv (cur-line i) '(#\( #\' #\" #\))))
i))))
(if (= (+ loc 1) (eols row))
(set-col (indent ncp row col))
(let ((completion (if (< loc 0) ; match whole cur-line
(symbol-completion cur-line)
((if (char=? (cur-line loc) #\") filename-completion symbol-completion)
(substring cur-line (+ loc 1))))))
(if (not completion)
(set-col (min (indent ncp row col) (eols row)))
(unless (string=? completion cur-line)
(when (>= loc 0)
(set! completion (string-append (substring cur-line 0 (+ loc 1)) completion))
(if (char=? (cur-line loc) #\")
(set! completion (string-append completion "\""))))
(nc-display row (bols row) completion)
(set-col (+ (bols row) (length completion)))
(set! (eols row) col))))))))))))
;; -------- run ---------
(reprompt header-row)
(catch #t
(lambda ()
(let ((ni (ncinput_make))
(mouse-col #f)
(mouse-row #f)
(repl-done #f)
(selection "")
(previously-selected #f)
(just-selected #f)
(control-key (ash 1 33))
(meta-key (ash 1 34))) ; notcurses get returns 32 bits
(set! (top-level-let 'ncp-let) (curlet))
(set! display-debug-info local-debug-info)
(set! remove-watcher local-remove-watcher)
;; -------- enter --------
(define enter ; either eval/print or insert newline
(let ()
(define stdin-wrapper (open-input-function ; current-input-port for scheme input in repl
(lambda (choice)
(case choice
((read char-ready? peek-char) "?")
((read-char) (integer->char (notcurses_getc nc (c-pointer 0) (c-pointer 0) ni)))
((read-line)
(let loop ((str ""))
(let ((c (notcurses_getc nc (c-pointer 0) (c-pointer 0) ni)))
(if (or (= c (char->integer #\newline))
(> c 255))
str
(loop (append str (string (integer->char c))))))))))))
;; -------- evaluation ---------
(define (badexpr h) ; *missing-close-paren-hook* function for Enter command
(let ((ow (owlet)))
(if (and (ow 'error-file)
(not (equal? (ow 'error-file) "nrepl.scm")))
(error 'syntax-error "missing close paren in ~S" (ow 'error-file))
(set! (h 'result) 'string-read-error))))
(define (shell? h) ; *unbound-variable-hook* function, also for Enter
;; examine cur-line -- only call system if the unbound variable matches the first non-whitespace chars
;; of cur-line, and command -v name returns 0 (indicating the shell thinks it is an executable command)
(let ((cur-line (ncplane_contents ncp (- row 1) (bols (- row 1)) 1 col)))
;; at this point (eols row) has not been set, so use col?
(do ((i 0 (+ i 1)))
((or (= i (length cur-line))
(not (char-whitespace? (cur-line i))))
(let ((var-name (symbol->string (h 'variable))))
(when (and (>= (- (length cur-line) i) (length var-name)) ; var-name might be unrelated to cur-line
(string=? var-name (substring cur-line i (+ i (length var-name))))
(zero? (system (string-append "command -v " var-name " >/dev/null"))))
(set! (h 'result)
(and (procedure? ((rootlet) 'system))
(((rootlet) 'system) cur-line #t)))))))))
(define new-eval
(let ((+documentation+ "this is the repl's eval replacement; its default is to use the repl's top-level-let.")
(+signature+ '(values #t let?)))
(lambda (form . rest) ; use lambda (not lambda*) so we can handle forms like :key
(let ((e (if (pair? rest)
(car rest)
(*nrepl* 'top-level-let))))
(let-temporarily (((hook-functions *unbound-variable-hook*) (list shell?)) ; so pwd et al will work
((*s7* 'history-enabled) #t))
(eval form e))))))
(define (current-expression ncp row)
(if (> (bols row) 0)
(ncplane_contents ncp row (bols row) 1 (- (eols row) (bols row)))
(do ((i (- row 1) (- i 1)))
((not (zero? (bols i)))
(let ((expr (ncplane_contents ncp i (bols i) 1 (- (eols i) (bols i)))))
(do ((nrow (+ i 1) (+ nrow 1)))
((> nrow row)
expr)
(set! expr (append expr "\n" ; need newline to terminate comments
(ncplane_contents ncp nrow (bols nrow) 1 (- (eols nrow) (bols nrow)))))))))))
(lambda (c)
(let ((cur-line (current-expression ncp row)))
(increment-row 1)
(set! ncp-max-row (max ncp-max-row row))
(if (> (eols row) 0)
(clear-line row))
(call-with-exit
(lambda (return)
(do ((len (length cur-line))
(i 0 (+ i 1))) ; check for just whitespace
((or (= i len)
(not (char-whitespace? (cur-line i))))
(when (= i len)
(set! (eols row) col)
(return))))
(catch #t
(lambda ()
(catch 'string-read-error ; this matches (throw #t 5) -- is this correct? *missing-close-paren-hook* returns 'string-read-error
(lambda ()
(let-temporarily (((hook-functions *missing-close-paren-hook*) (list badexpr))
((hook-functions *read-error-hook*) ())) ; lint sets this and messes up our error reporting
;; catch and report reader errors as well as eval troubles
(let-temporarily ((*stderr* (open-output-string)) ; capture *stderr* output
(*stdout* (open-output-string))
((current-output-port) (open-output-string))
((current-error-port) (open-output-string))
((*s7* 'undefined-constant-warnings) #t)) ; ??? what about case*?
(let ((form (with-input-from-string cur-line #_read))
(val #f))
(let-temporarily (((current-input-port) stdin-wrapper) ; for scheme side input (read-char etc)
((hook-functions *ncp-move-hook*) ; scheme code calls ncplane_move_yx??
(list (lambda (h)
(when (eq? (h 'plane) ncp)
(set! ncp-row (h 'y))
(set! ncp-col (h 'x)))))))
;(set-sigint-handler) ; catch C-C to interrupt computation -- this no longer works in notcurses
(let ((str (with-output-to-string ; for scheme side output
(lambda ()
(set! val (list (new-eval form envir))))))) ; list, not lambda -- confuses trace!
;(unset-sigint-handler nc) ; catch C-C to exit cleanly
(for-each
(lambda (s)
(when (> (length s) 0)
(set-col 0)
(nc-multiline-display s)
(increment-row 1)))
(list str
(get-output-string *stderr*)
(get-output-string *stdout*)
(get-output-string (current-error-port))
(get-output-string (current-output-port))))))
(set! val (if (or (null? val) ; try to trap (values) -> #<unspecified>
(and (unspecified? (car val))
(null? (cdr val))))
#<unspecified>
(if (pair? (cdr val)) ; val is a list, it must have caught multiple values if cdr is a pair
(cons 'values val)
(car val))))
(nc-multiline-display (object->string val))))))
(lambda (type info)
;(unset-sigint-handler nc)
(if (eq? type 'string-read-error)
(begin
;; missing close paren, newline already added, spaces here are not optional!
(nc-display row 0 (make-string col #\space))
(set! (eols row) col)
(return))
(apply throw type info))))) ; re-raise error
(lambda (type info)
;(unset-sigint-handler nc)
(if (and (eq? type 'read-error) ; maybe we hit <enter> in a block comment
(equal? info '("unexpected end of input while reading #|")))
(begin
(nc-display row 0 (make-string col #\space))
(set! (eols row) col)
(return)))
(display-error ncp row info)))
(increment-row 1)
(set! ncp-max-row (max ncp-max-row row))
(reprompt row)))))))
;; -------- keymap --------
(define (normal-char c)
(let ((trailing (and (> (eols row) col)
(ncplane_contents ncp row col 1 (- (eols row) col -1)))))
(nc-display row col (string (integer->char c)))
(if (and trailing (> (length trailing) 0))
(nc-display row (+ col 1) trailing)))
(if (or (char=? (integer->char c) #\space)
(= col (bols row))) ; maybe (memv (integer->char c) '(#\space #\())
(notcurses_refresh nc))
(increment-col 1) ; might be midline
(set! (eols row) (+ (eols row) 1))) ; in any case we've added a character
(do ((i 0 (+ i 1)))
((= i 256))
(set! (keymap i) normal-char))
(define (prepend-to-selection new-text)
(unless (zero? (length new-text))
(set! selection (if previously-selected (append new-text selection)
new-text))
(set! just-selected #t)))
(define (append-to-selection new-text)
(unless (zero? (length new-text))
(set! selection (if previously-selected (append selection new-text)
new-text))
(set! just-selected #t)))
(define (char-separator? c)
(char-position c " ()`',\"#"))
(define (word-back-x) ;; some of these are courtesy of Elijah Stone
(let loop ((col (max (bols row) (- col 1))))
(if (= col (bols row))
col
(if (char-separator? (ncplane_contents ncp row col 1 1))
(loop (- col 1))
(let loop ((col col))
(if (or (= col (bols row))
(char-separator? (ncplane_contents ncp row (- col 1) 1 1)))
col
(loop (- col 1))))))))
(define (word-forward-x)
(let loop ((col (min (eols row) (+ col 1))))
(if (= col (eols row))
col
(if (char-separator? (ncplane_contents ncp row col 1 1))
(loop (+ col 1))
(let loop ((col col))
(if (or (= col (eols row))
(char-separator? (ncplane_contents ncp row col 1 1)))
col
(loop (+ col 1))))))))
(set! (keymap (+ meta-key (char->integer #\B)))
(set! (keymap (+ meta-key (char->integer #\b)))
(lambda (c)
(set! col (word-back-x)))))
(set! (keymap (+ meta-key (char->integer #\C)))
(set! (keymap (+ meta-key (char->integer #\c)))
(lambda (c)
(do ((len (- (eols row) col))
(cur-line (ncplane_contents ncp row col 1 (- (eols row) col)))
(i 0 (+ i 1)))
((or (= i len)
(char-alphabetic? (cur-line i)))
(when (< i len)
(set! (cur-line i) (char-upcase (cur-line i)))
(nc-display row col cur-line)
(notcurses_refresh nc)
(do ((k (+ i 1) (+ k 1)))
((or (>= k len)
(not (or (char-alphabetic? (cur-line k))
(char-numeric? (cur-line k)))))
(set! col (min (eols row) (+ col k)))))))))))
(set! (keymap (+ meta-key (char->integer #\D)))
(set! (keymap (+ meta-key (char->integer #\d)))
(lambda (c)
(let ((newcol (word-forward-x)))
(append-to-selection (ncplane_contents ncp row col 1 (- newcol col)))
(nc-display row col (ncplane_contents ncp row newcol 1 (- (eols row) newcol)))
(nc-display row (- (eols row) (- newcol col)) (make-string (- newcol col) #\space))
(set! (eols row) (- (eols row) (- newcol col)))))))
(set! (keymap (+ meta-key (char->integer #\F)))
(set! (keymap (+ meta-key (char->integer #\f)))
(lambda (c)
(set! col (word-forward-x)))))
(set! (keymap (+ meta-key (char->integer #\L)))
(set! (keymap (+ meta-key (char->integer #\l)))
(lambda (c)
(do ((len (- (eols row) col))
(cur-line (ncplane_contents ncp row col 1 (- (eols row) col)))
(i 0 (+ i 1)))
((or (= i len)
(char-alphabetic? (cur-line i)))
(when (< i len)
(do ((k i (+ k 1)))
((or (= k len)
(not (char-alphabetic? (cur-line k))))
(nc-display row col cur-line)
(notcurses_refresh nc)
(set! col (+ col k)))
(set! (cur-line k) (char-downcase (cur-line k))))))))))
(set! (keymap (+ meta-key (char->integer #\U)))
(set! (keymap (+ meta-key (char->integer #\u)))
(lambda (c)
(do ((len (- (eols row) col))
(cur-line (ncplane_contents ncp row col 1 (- (eols row) col)))
(i 0 (+ i 1)))
((or (= i len)
(char-alphabetic? (cur-line i)))
(when (< i len)
(do ((k i (+ k 1)))
((or (= k len)
(not (char-alphabetic? (cur-line k))))
(nc-display row col cur-line)
(notcurses_refresh nc)
(set! col (+ col k)))
(set! (cur-line k) (char-upcase (cur-line k))))))))))
(set! (keymap (+ meta-key (char->integer #\<)))
(lambda (c)
(set-row 0)
(set-col (bols 0))))
(set! (keymap (+ meta-key (char->integer #\>)))
(lambda (c)
(set-row ncp-max-row)
(set-col (bols ncp-max-row))))
(set! (keymap (char->integer #\tab)) tab)
(set! (keymap (+ control-key (char->integer #\A)))
(lambda (c)
(unless (>= ncp-col 0)
(set-ncp-col 0)
(ncplane_move_yx ncp ncp-row ncp-col))
(set-col (bols row))))
(set! (keymap (+ control-key (char->integer #\B)))
(lambda (c)
(if (and (= col (bols row))
(> row 0))
(let ((old-row row))
(decrement-row 1)
(if (< row old-row)
(set-col (eols row))))
(set-col (max (bols row) (- col 1))))))
(set! (keymap (+ control-key (char->integer #\C)))
(lambda (c)
(set! repl-done #t)))
(set! (keymap (+ control-key (char->integer #\D)))
(lambda (c)
(when (and (< col (eols row)) ; should this delete the newline?
(> (eols row) (bols row)))
(let ((trailing (ncplane_contents ncp row (+ col 1) 1 (- (eols row) col -1))))
(nc-display row col trailing)
(nc-display row (+ col (length trailing)) " "))
(set! (eols row) (- (eols row) 1)))))
(set! (keymap (+ control-key (char->integer #\E)))
(lambda (c)
(set-col (eols row))))
(set! (keymap (+ control-key (char->integer #\F)))
(lambda (c)
(if (and (= col (eols row))
(< row ncp-max-row))
(begin
(increment-row 1)
(set! ncp-max-row (max ncp-max-row row))
(set-col (bols row)))
(set-col (min (eols row) (+ col 1))))))
(set! (keymap (+ control-key (char->integer #\G))) ; get a prompt
(lambda (c)
(increment-row 1)
(set-ncp-col 0)
(ncplane_move_yx ncp ncp-row ncp-col)
(reprompt row)))
(set! (keymap (+ control-key (char->integer #\K)))
(lambda (c)
(append-to-selection (ncplane_contents ncp row col 1 (- (eols row) col)))
(nc-display row col (make-string (- (eols row) col) #\space))
(set! (eols row) col)))
(set! (keymap (+ control-key (char->integer #\L))) ; not the same as emacs's C-l (moves current row to top)
(lambda (c)
(unless (= row (- ncp-row))
(set-ncp-row (- row))
(ncplane_move_yx ncp ncp-row ncp-col))))
(set! (keymap (+ control-key (char->integer #\N)))
(lambda (c)
(when (< row ncp-max-row)
(increment-row 1)
(set-col (min (max col (bols row)) (eols row))))))
(set! (keymap (+ control-key (char->integer #\O)))
(lambda (c)
(let ((trailer (ncplane_contents ncp row col 1 (- (eols row) col)))
(old-row row))
(when (> ncp-max-row row)
(when (>= (+ ncp-max-row 1) ncp-rows)
(ncplane_resize ncp 0 0 ncp-rows ncp-cols 0 0 (+ ncp-rows 40) ncp-cols)
(set! ncp-rows (+ ncp-rows 40))
(set! bols (copy bols (make-int-vector ncp-rows)))
(set! eols (copy eols (make-int-vector ncp-rows))))
(do ((i (+ ncp-max-row 1) (- i 1)))
((= i (+ row 1))
(set! ncp-max-row (+ ncp-max-row 1)))
(let ((contents (ncplane_contents ncp (- i 1) 0 1 (eols (- i 1)))))
(clear-line i)
(nc-display i 0 contents)) ; should this be indented?
(set! (eols i) (eols (- i 1)))
(set! (bols i) (bols (- i 1)))))
(nc-display row col (make-string (- (eols row) col) #\space))
(set! (eols row) col)
(increment-row 1)
(set! ncp-max-row (max ncp-max-row row))
(clear-line row)
(nc-display row 0 trailer)
(set! (bols row) 0)
(set! (eols row) (length trailer))
(set-row old-row))))
(set! (keymap (+ control-key (char->integer #\P)))
(lambda (c)
(set-row (- row 1))
(set-col (min (max col (bols row)) (eols row)))))
(set! (keymap (+ control-key (char->integer #\Q)))
(lambda (c)
(set! repl-done #t)
(set! (top-level-let 'history) old-history))) ; fix up the ncp pointer I think
(set! (keymap (+ control-key (char->integer #\T)))
(lambda (c)
(when (> col (bols row))
(let ((cur (if (>= col (eols row))
(- col 1)
col))
(cur-line (ncplane_contents ncp row 0 1 (eols row))))
(let ((tmp-c (cur-line (- cur 1))))
(set! (cur-line (- cur 1)) (cur-line cur))
(set! (cur-line cur) tmp-c))
(nc-display row (bols row) (substring cur-line (bols row))) ; if c=0 nc-display sets (bols row) to 0
(if (< cur (eols row))
(set-col (+ cur 1)))))))
(set! (keymap (+ control-key (char->integer #\U)))
(lambda (c)
(prepend-to-selection (ncplane_contents ncp row (bols row) 1 (- col (bols row))))
(nc-display row (bols row) (ncplane_contents ncp row col 1 (- (eols row) col)))
(nc-display row (- (eols row) (- col (bols row))) (make-string (- col (bols row)) #\space))
(set! (eols row) (- (eols row) (- col (bols row))))
(set! col (bols row))))
(set! (keymap (+ control-key (char->integer #\W)))
(lambda (c)
(let ((newcol (word-back-x)))
(prepend-to-selection (ncplane_contents ncp row newcol 1 (- col newcol)))
(nc-display row newcol (ncplane_contents ncp row col 1 (- (eols row) col)))
(nc-display row (- (eols row) (- col newcol)) (make-string (- col newcol) #\space))
(set! (eols row) (- (eols row) (- col newcol)))
(set! col newcol))))
(set! (keymap (+ control-key (char->integer #\Y)))
(lambda (c)
(when (string? selection)
(let ((trailing (and (> (eols row) col)
(ncplane_contents ncp row col 1 (- (eols row) col -1)))))
(nc-display row col selection)
(if (char=? #\space (selection (- (length selection) 1)))
(notcurses_refresh nc))
(if (and trailing
(> (length trailing) 0))
(nc-display row (+ col (length selection)) trailing)))
(set! (eols row) (+ (eols row) (length selection)))
(set-col (+ col (length selection))))))
(set! (keymap NCKEY_LEFT) ; arrow keys
(lambda (c)
(set-col (max (bols row) (- col 1)))))
(set! (keymap NCKEY_RIGHT)
(lambda (c)
(set-col (min (eols row) (+ col 1)))))
(set! (keymap NCKEY_UP)
(lambda (c)
(set-row (- row 1))
(set-col (min (max col (bols row)) (eols row)))))
(set! (keymap NCKEY_DOWN)
(lambda (c)
(when (< row ncp-max-row)
(increment-row 1)
(set-col (min (max col (bols row)) (eols row))))))
(set! (keymap NCKEY_HOME)
(lambda (c)
(set-row 0)
(set-col (bols 0))))
(set! (keymap NCKEY_END)
(lambda (c)
(set-row ncp-max-row)
(set-col (bols ncp-max-row))))
(set! (keymap NCKEY_PGUP)
(lambda (c)
(set-row (max 0 (- row (- nc-rows status-rows))))))
(set! (keymap NCKEY_PGDOWN)
(lambda (c)
(set-row (max 0 (min ncp-max-row (+ row (- nc-rows status-rows)))))))
(set! (keymap NCKEY_RESIZE) ; terminal window resized (not a key event)
(lambda (c)
(apply nc-resize (ncplane_dim_yx (notcurses_stdplane nc)))))
(set! (keymap NCKEY_BACKSPACE) ; backspace
(lambda (c)
(when (> col (bols row))
(let ((trailing (and (> (eols row) col)
(ncplane_contents ncp row col 1 (- (eols row) col -1)))))
(if trailing
(begin
(nc-display row (- col 1) trailing)
(nc-display row (+ col (- (length trailing) 1)) " "))
(nc-display row (- col 1) " "))
(set! (eols row) (- (eols row) 1))
(decrement-col 1)))))
;; check this: if we backspaced past ncp-col, scroll-left
(set! (keymap NCKEY_BUTTON1) ; mouse click, doesn't work in rxvt apparently, right button = button2? click scroll??
(lambda (c)
;; ncinput gives row|col in current view, so we need to map that to the ncplane row|col
;(display-status (format #f "nc-rows: ~S, ncp-row: ~S, input: ~S" nc-rows ncp-row (ncinput_y ni)))
(if (= (ncinput_evtype ni) NCTYPE_RELEASE)
(begin
(when (and (number? mouse-col)
(not (= col mouse-col)))
(set! selection (ncplane_contents ncp mouse-row (min col mouse-col) 1 (abs (- col mouse-col)))))
(set! mouse-col #f))
(begin
(set-row (min ncp-max-row (- (ncinput_y ni) ncp-row)))
(set-col (max (min (eols row) (ncinput_x ni)) (bols row)))
(unless mouse-col
(set! mouse-col col)
(set! mouse-row row))))))
(set! (keymap NCKEY_ENTER) enter)
;; -------- read/eval/print loop --------
(define (recover-previous-layout)
(set! display-debug-info local-debug-info)
(set! recursor #f)
(notcurses_render nc)
(move-cursor row col)
;; perhaps a resize happened while we were away
(when (and hc
(not (= header-cols nc-cols)))
(ncplane_resize hc 0 0 header-row (min old-nc-cols nc-cols) 0 0 header-row nc-cols)
(ncplane_cursor_move_yx hc 0 0)
(ncplane_box hc (hc-cells 0) (hc-cells 1) (hc-cells 2) (hc-cells 3) (hc-cells 4) (hc-cells 5) (- header-row 1) (- nc-cols 1) 0)
(do ((i 1 (+ i 1)))
((= i (- header-row 1)))
(ncplane_putstr_yx hc i (- old-nc-cols 1) " "))
(set! header-cols nc-cols))
(when (or (< ncp-rows nc-rows)
(< ncp-cols nc-cols))
(ncplane_resize ncp 0 0 ncp-rows ncp-cols 0 0 (max ncp-rows nc-rows) (max ncp-cols nc-cols))
(when (> nc-rows ncp-rows)
(set! bols (copy bols (make-int-vector nc-rows)))
(set! eols (copy eols (make-int-vector nc-rows)))
(set! ncp-rows nc-rows))
(set! ncp-cols (max ncp-cols nc-cols))))
(let repl-loop ()
(display-status-area)
(if repl-done
(begin
(ncplane_destroy ncp) ; does this free ncp?
(if hc (ncplane_destroy hc)) ; free cells?
(if wc (ncplane_destroy wc))
(set! ncp #f) ; unnecessary?
(set! hc #f) ; old header if nested??
(set! wc #f)
(set! recursor #t))
(begin
(when recursor
(recover-previous-layout))
(set! previously-selected just-selected)
(set! just-selected #f)
(let* ((c (notcurses_getc nc (c-pointer 0) (c-pointer 0) ni))
(c (if (= c (char->integer #\escape))
(logior meta-key (notcurses_getc nc (c-pointer 0) (c-pointer 0) ni))
c))
(func (hash-table-ref keymap (logior c (if (ncinput_ctrl ni) control-key 0)
(if (ncinput_alt ni) meta-key 0)))))
(if (procedure? func)
(catch #t
(lambda ()
(func c))
(lambda (type info) ; this is usually an internal (nrepl) error, or sometimes a read error
(display-error ncp row info)
(increment-row 1)
(reprompt row)))
;(display-status (format #f "unhandled ~D" c))
))
(notcurses_render nc)
;; if cursor is after ), look for matching open, highlight if found
(when (and (pair? prev-pars)
(visible? (car prev-pars) (cadr prev-pars)))
(ncplane_putc_yx ncp (car prev-pars) (cadr prev-pars) normal-paren)
(notcurses_render nc)
(set! prev-pars #f))
;; if we have "(name" and name is a function/macro, and it has either
;; a signature or documentation, post it in the status area
(let ((name (ncplane_contents ncp row (bols row) 1 (- col (bols row)))))
(do ((i (- (length name) 1) (- i 1)))
((or (< i 0)
(char-whitespace? (name i))
(memv (name i) '(#\( #\) #\# #\; #\" #\' #\`)))
(when (and (>= i 0)
(char=? (name i) #\())
(set! name (substring name 1))
(when (positive? (length name))
(let ((value (symbol->value (string->symbol name) top-level-let)))
(when (or (procedure? value)
(macro? value)) ; syntax here is just noise -- everyone knows about "if"!
(let ((sig (signature value))
(args (let ((source (procedure-source value)))
(and (pair? source)
(pair? (cdr source))
(cadr source))))
(doc (documentation value)))
(let ((str (format #f "~A~A~A"
(if (pair? sig)
(format #f "sig: ~S" sig)
"")
(if args
(format #f "~Aargs: ~S" (if sig ", " "") args)
"")
(if (and (string? doc)
(> (length doc) 0))
(format #f "~Adoc: ~S" (if (or args sig) ", " "") doc)
""))))
(set! (top-level-let 'status-text) str)
(display-status (first-line str)))))))))))
;; show matching open paren, if it's a complete expression, ask lint about it
(unless (or (<= col (+ (bols row) 1)) ; got to be room for #\(
(not (string=? ")" (ncplane_contents ncp row (- col 1) 1 1)))
(and (>= col (+ (bols row) 3))
(string=? (ncplane_contents ncp row (- col 3) 1 3) "#\\)")))
(let ((pars (match-close-paren ncp row col #f)))
(when (and (pair? pars)
(visible? (caar pars) (cadar pars)))
(ncplane_putc_yx ncp (caar pars) (cadar pars) red-paren)
(set! prev-pars (car pars))
(notcurses_render nc)
(when (and with-lint (= row (caar pars)))
(let ((expr (ncplane_contents ncp row (cadar pars) 1 (- col (cadar pars)))))
(catch #t
(lambda ()
(let ((result (call-with-output-string
(lambda (op)
(call-with-input-string expr
(lambda (ip)
(let-temporarily ((*report-laconically* #t)
(*report-combinable-lets* #f)
(*report-boolean-functions-misbehaving* #f)
(*report-quasiquote-rewrites* #f))
(lint ip op #f))))))))
(unless (string=? result expr)
(set! (top-level-let 'status-text) result)
(display-status (first-line result)))))
(lambda (type info)
#f)))))))
(move-cursor row col)
(repl-loop))))))
(lambda (type info)
(display-error ncp row info)
(notcurses_stop nc)
(apply format *stderr* info)
(format *stderr* "~%line ~A: ~A~%" ((owlet) 'error-line) ((owlet) 'error-code))
(#_exit)
)
)))) ; run
(define (stop)
(notcurses_stop nc)
(#_exit))
;; -------- emacs --------
(define (emacs-repl)
;; also this does not resend the entire expression after editing
;; and does not notice in-place edits
;; can <cr> get entire expr?
(with-let (sublet libc-let)
(let ((buf (c-pointer->string (calloc 512 1) 512)))
(format *stderr* "> ")
(do ((b (fgets buf 512 stdin) (fgets buf 512 stdin)))
((zero? (length b))
(#_exit))
(let ((len (strlen buf)))
(when (positive? len)
(do ((i 0 (+ i 1)))
((or (not (char-whitespace? (buf i)))
(= i len))
(when (< i len)
(let ((str (substring buf 0 (- (strlen buf) 1))))
(catch #t
(lambda ()
(do ()
((= (string-length str) 0))
(catch 'string-read-error
(lambda ()
(format *stderr* "~S~%> " (eval-string str (*nrepl* 'top-level-let)))
(set! str ""))
(lambda (type info)
(fgets buf 512 stdin)
(set! str (string-append str " " (substring buf 0 (- (strlen buf) 1))))))))
(lambda (type info)
(set! str "")
(apply format *stderr* info)
(format *stderr* "~%> ")))))))))))))
(define (start)
(if (with-let libc-let
(or (zero? (isatty (fileno stdin))) ; not a terminal -- input from pipe probably
(string=? (getenv "TERM") "dumb"))) ; no vt100 codes -- emacs subjob for example
(emacs-repl)
(begin
(let ((noptions (notcurses_options_make)))
(set! (notcurses_options_flags noptions) NCOPTION_SUPPRESS_BANNERS)
(set! nc (notcurses_core_init noptions)))
(notcurses_cursor_enable nc 0 2)
(unless (string-position "rxvt" ((libc-let 'getenv) "TERM"))
(notcurses_mice_enable nc NCMICE_ALL_EVENTS)) ; 0 if ok, -1 if failure
(let ((size (ncplane_dim_yx (notcurses_stdplane nc))))
(set! nc-cols (cadr size))
(set! nc-rows (car size))
(set! statp-row (- nc-rows status-rows)))
(set! statp (ncplane_new nc nc-rows nc-cols 0 0 (c-pointer 0)))
(nccells_double_box statp 0 0 (status-cells 0) (status-cells 1) (status-cells 2) (status-cells 3) (status-cells 4) (status-cells 5))
(ncplane_putstr_yx statp 1 1 (make-string (- nc-cols 5) #\space))
(when (string-position "rxvt" (getenv "TERM"))
(ncplane_putstr_yx statp 1 2 (substring "rxvt doesn't support the mouse" 0 (min 30 (- nc-cols 3))))
(notcurses_render nc)))))
(curlet)))
(with-let *nrepl*
(start)
(run)
(stop)))
;; selection (both ways):
;; (currently works by dragging mouse and using C-y, but text is not highlighted)
;; xclip to access the clipboard?? (system "xclip -o")=current contents, (system "echo ... | xclip")=set contents
;; so if mouse(2)=get from xclip if it exists etc, or maybe add example function, or can we do this in nrepl.c?
;; right button is nckey_button2, scroll=nckey_button3 (lxterminal -- not rxvt)
;; C_<space>+move cursor -- need highlighting too
;;
;; some terminals have "zoom" -- can we tell this has happened? apparently not
;; (ncplane_dim_yx (notcurses_stdplane (*nrepl* 'nc))) doesn't change, but cursor movement is confused and status area gets lost
;; add signatures and help for notcurses
;; C-s|r? [need positions as adding chars, backspace=remove and backup etc, display current search string in status]
;; start at row/col, get contents, go to current match else increment, save row/col of match
;; begin_hook for stepper: at each call, drop back into the debugger with curlet -- how to keep our place? (step=continue+break -- ambiguous)
;; colorize, perhaps make a vector for each color indexed by char; for colorized name, for each char get cell from vector (or make it if needed)
(set! (*s7* 'debug) old-debug)
*nrepl*
|