1 2;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 3;; 4;; MODULE : session-edit.scm 5;; DESCRIPTION : editing routines for sessions 6;; COPYRIGHT : (C) 2001--2009 Joris van der Hoeven 7;; 8;; This software falls under the GNU general public license version 3 or later. 9;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE 10;; in the root directory or <http://www.gnu.org/licenses/gpl-3.0.html>. 11;; 12;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 13 14(texmacs-module (dynamic session-edit) 15 (:use (utils library tree) 16 (utils library cursor) 17 (utils plugins plugin-cmd) 18 (dynamic session-drd) 19 (dynamic fold-edit))) 20 21;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 22;; Style package rules for sessions 23;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 24 25(tm-define (style-category p) 26 (:require (in? p (list "framed-session" "ring-session"))) 27 :session-theme) 28 29(tm-define (style-category-precedes? x y) 30 (:require (and (== x :session-theme) 31 (in? y (map symbol->string (plugin-list))))) 32 #t) 33 34;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 35;; Switches 36;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 37 38(define session-math-input (make-ahash-table)) 39 40(define (session-key) 41 (let* ((lan (get-env "prog-language")) 42 (ses (get-env "prog-session"))) 43 (cons lan ses))) 44 45(tm-define (session-math-input?) 46 (ahash-ref session-math-input (session-key))) 47 48(tm-define (toggle-session-math-input) 49 (:synopsis "Toggle mathematical input in sessions.") 50 (:check-mark "v" session-math-input?) 51 (ahash-set! session-math-input (session-key) (not (session-math-input?))) 52 (with-innermost t field-context? 53 (field-update-math t))) 54 55(define session-multiline-input (make-ahash-table)) 56 57(tm-define (session-multiline-input?) 58 (ahash-ref session-multiline-input (session-key))) 59 60(tm-define (set-session-multiline-input lan ses set?) 61 (ahash-set! session-multiline-input (cons lan ses) set?)) 62 63(tm-define (toggle-session-multiline-input) 64 (:synopsis "Toggle multi-line input in sessions.") 65 (:check-mark "v" session-multiline-input?) 66 (ahash-set! session-multiline-input (session-key) 67 (not (session-multiline-input?)))) 68 69(define session-output-timings (make-ahash-table)) 70 71(tm-define (session-output-timings?) 72 (ahash-ref session-output-timings (session-key))) 73 74(tm-define (toggle-session-output-timings) 75 (:synopsis "Toggle output of evaluation timings.") 76 (:check-mark "v" session-output-timings?) 77 (ahash-set! session-output-timings (session-key) 78 (not (session-output-timings?)))) 79 80;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 81;; Specific switches for Scheme sessions 82;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 83 84(define session-scheme-trees #t) 85 86(tm-define (session-scheme-trees?) 87 session-scheme-trees) 88 89(tm-define (toggle-session-scheme-trees) 90 (:synopsis "Toggle pretty tree output in scheme sessions.") 91 (:check-mark "v" session-scheme-trees?) 92 (set! session-scheme-trees (not session-scheme-trees))) 93 94(define session-scheme-math #f) 95 96(tm-define (session-scheme-math?) 97 session-scheme-math) 98 99(tm-define (toggle-session-scheme-math) 100 (:synopsis "Toggle pretty math output in scheme sessions.") 101 (:check-mark "v" session-scheme-math?) 102 (set! session-scheme-math (not session-scheme-math))) 103 104;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 105;; Scheme sessions 106;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 107 108(define (replace-newline s) 109 (with l (string-tokenize-by-char s #\newline) 110 (if (<= (length l) 1) s 111 (tm->tree `(document ,@l))))) 112 113(define (var-object->string t) 114 (with s (object->string t) 115 (if (== s "#<unspecified>") "" (replace-newline (string->tmstring s))))) 116 117(define (eval-string-with-catch s) 118 (catch #t 119 (lambda () (eval (string->object s))) 120 (lambda (key msg . err-msg) 121 (let* ((msg (car err-msg)) 122 (args (cadr err-msg)) 123 (err-msg 124 (if (list? args) (eval (apply format #f msg args)) msg))) 125 (stree->tree `(errput ,err-msg)))))) 126 127(define (error-tree? t) 128 (and (tree? t) (tree-is? t 'errput))) 129 130(tm-define (scheme-eval t) 131 (let* ((s (texmacs->code t "iso-8859-1")) 132 (r (eval-string-with-catch s))) 133 (cond ((and (tree? r) (error-tree? r) (session-scheme-trees?)) 134 (tree-copy r)) 135 ((and (tree? r) (session-scheme-trees?)) 136 (tree 'text (tree-copy r))) 137 ((session-scheme-math?) 138 (with m (cas->stree r) 139 (if (tm? m) (tree 'math (tm->tree m)) (var-object->string r)))) 140 (else (var-object->string r))))) 141 142;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 143;; Low-level evaluation management 144;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 145 146(define (session-encode in out next opts) 147 (list (list session-do session-notify session-next session-cancel) 148 (if (tm? in) (tm->stree in) in) 149 (tree->tree-pointer out) 150 (tree->tree-pointer next) 151 opts)) 152 153(define (session-decode l) 154 (list (second l) 155 (tree-pointer->tree (third l)) 156 (tree-pointer->tree (fourth l)) 157 (fifth l))) 158 159(define (session-detach l) 160 (tree-pointer-detach (third l)) 161 (tree-pointer-detach (fourth l))) 162 163(define (session-coherent? out next) 164 (and (field-or-output-context? (tree-ref out :up)) 165 (field-context? next))) 166 167(define (session-do lan ses) 168 (with l (pending-ref lan ses) 169 (with (in out next opts) (session-decode (car l)) 170 ;;(display* "Session do " lan ", " ses ", " in "\n") 171 (if (or (and (tree-empty? in) (!= lan "r")) 172 (not (session-coherent? out next))) 173 (plugin-next lan ses) 174 (begin 175 (plugin-write lan ses in) 176 (tree-set out :up 0 (plugin-prompt lan ses))))))) 177 178(define (session-next lan ses) 179 ;;(display* "Session next " lan ", " ses "\n") 180 (with l (pending-ref lan ses) 181 (with (in out next opts) (session-decode (car l)) 182 (when (and (session-coherent? out next) 183 (tm-func? out 'document) 184 (tm-func? (tree-ref out :last) 'script-busy)) 185 (let* ((dt (plugin-timing lan ses)) 186 (ts (if (< dt 1000) 187 (string-append (number->string dt) " msec") 188 (string-append (number->string (/ dt 1000.0)) " sec")))) 189 (if (and (in? :timings opts) (>= dt 1)) 190 (tree-set (tree-ref out :last) `(timing ,ts)) 191 (tree-remove! out (- (tree-arity out) 1) 1)))) 192 (when (and (session-coherent? out next) 193 (tree-empty? out)) 194 (field-remove-output (tree-ref out :up))) 195 (session-detach (car l))))) 196 197(define (var-tree-children t) 198 (with r (tree-children t) 199 (if (and (nnull? r) (tree-empty? (cAr r))) (cDr r) r))) 200 201(define (session-output t u) 202 (when (tm-func? t 'document) 203 (with i (tree-arity t) 204 (if (and (> i 0) (tm-func? (tree-ref t (- i 1)) 'script-busy)) 205 (set! i (- i 1))) 206 (if (and (> i 0) (tm-func? (tree-ref t (- i 1)) 'errput)) 207 (set! i (- i 1))) 208 (if (tm-func? u 'document) 209 (tree-insert! t i (var-tree-children u)))))) 210 211(define (session-errput t u) 212 (when (tm-func? t 'document) 213 (with i (tree-arity t) 214 (if (and (> i 0) (tm-func? (tree-ref t (- i 1)) 'script-busy)) 215 (set! i (- i 1))) 216 (if (and (> i 0) (tm-func? (tree-ref t (- i 1)) 'errput)) 217 (set! i (- i 1)) 218 (tree-insert! t i '((errput (document))))) 219 (session-output (tree-ref t i 0) u)))) 220 221(define (session-notify lan ses ch t) 222 ;;(display* "Session notify " lan ", " ses ", " ch ", " t "\n") 223 (with l (pending-ref lan ses) 224 (with (in out next opts) (session-decode (car l)) 225 (when (session-coherent? out next) 226 (cond ((== ch "output") 227 (session-output out t)) 228 ((== ch "error") 229 (session-errput out t)) 230 ((== ch "prompt") 231 (if (and (== (length l) 1) (tree-empty? (tree-ref next 1))) 232 (tree-set! next 0 (tree-copy t)))) 233 ((and (== ch "input") (null? (cdr l))) 234 (tree-set! next 1 t))))))) 235 236(define (session-cancel lan ses dead?) 237 ;;(display* "Session cancel " lan ", " ses ", " dead? "\n") 238 (with l (pending-ref lan ses) 239 (with (in out next opts) (session-decode (car l)) 240 (when (and (session-coherent? out next) 241 (tm-func? out 'document) 242 (tm-func? (tree-ref out :last) 'script-busy)) 243 (tree-assign (tree-ref out :last) 244 (if dead? '(script-dead) '(script-interrupted)))) 245 (session-detach (car l))))) 246 247(tm-define (session-feed lan ses in out next opts) 248 (set! in (plugin-preprocess lan ses in opts)) 249 (tree-assign! out '(document (script-busy))) 250 (with x (session-encode in out next opts) 251 (apply plugin-feed `(,lan ,ses ,@(car x) ,(cdr x))))) 252 253;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 254;; Session contexts 255;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 256 257(tm-define (session-document-context? t) 258 (and (tm-func? t 'document) 259 (tm-func? (tree-ref t :up) 'session))) 260 261(tm-define (subsession-document-context? t) 262 (or (and (tm-func? t 'document) 263 (tm-func? (tree-ref t :up) 'session)) 264 (and (tm-func? t 'document) 265 (tm-func? (tree-ref t :up) 'unfolded-subsession) 266 (== (tree-index t) 1)))) 267 268(tm-define field-tags 269 '(input unfolded-io folded-io input-math unfolded-io-math folded-io-math)) 270 271(tm-define (field-context? t) 272 (and (tm? t) 273 (tree-in? t field-tags) 274 (tm-func? (tree-ref t :up) 'document))) 275 276(tm-define (field-or-output-context? t) 277 (and (tm? t) 278 (tree-in? t (cons 'output field-tags)) 279 (tm-func? (tree-ref t :up) 'document))) 280 281(tm-define (field-folded-context? t) 282 (and (tree-in? t '(folded-io folded-io-math)) 283 (tm-func? (tree-ref t :up) 'document))) 284 285(tm-define (field-unfolded-context? t) 286 (and (tree-in? t '(unfolded-io unfolded-io-math)) 287 (tm-func? (tree-ref t :up) 'document))) 288 289(tm-define (field-prog-context? t) 290 (and (tree-in? t '(input folded-io unfolded-io)) 291 (tm-func? (tree-ref t :up) 'document))) 292 293(tm-define (field-math-context? t) 294 (and (tree-in? t '(input-math folded-io-math unfolded-io-math)) 295 (tm-func? (tree-ref t :up) 'document))) 296 297(tm-define (field-input-context? t) 298 (and (field-context? t) 299 (== (tree-down-index t) 1))) 300 301;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 302;; Style parameters 303;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 304 305(define (field-parameters kind) 306 (let* ((var (string-append (get-env "prog-language") "-" kind)) 307 (gen (string-append "generic-" kind))) 308 (search-parameters (if (style-has? var) var gen)))) 309 310(tm-define (standard-parameters l) 311 (:require (== l "session")) 312 (field-parameters "session")) 313 314(tm-define (standard-parameters l) 315 (:require (== l "input")) 316 (field-parameters "input")) 317 318(tm-define (standard-parameters l) 319 (:require (== l "output")) 320 (field-parameters "output")) 321 322(tm-define (standard-parameters l) 323 (:require (== l "errput")) 324 (field-parameters "errput")) 325 326(tm-define (standard-parameters l) 327 (:require (== l "textput")) 328 (field-parameters "textput")) 329 330;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 331;; Subroutines 332;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 333 334(tm-define (session-ready? . err-flag?) 335 (with lan (get-env "prog-language") 336 (or (== lan "scheme") 337 (connection-defined? lan) 338 (begin 339 (if err-flag? 340 (set-message `(concat "undefined plugin: " (verbatim ,lan)) "")) 341 #f)))) 342 343(tm-define (session-status) 344 (let* ((lan (get-env "prog-language")) 345 (ses (get-env "prog-session"))) 346 (cond ((== lan "scheme") 2) 347 ((not (connection-defined? lan)) 0) 348 (else (connection-status lan ses))))) 349 350(tm-define (session-busy-message msg) 351 (let* ((lan (get-env "prog-language")) 352 (ses (get-env "prog-session"))) 353 (with l (pending-ref lan ses) 354 (for-each 355 (lambda (x) 356 (with (in out next opts) (session-decode x) 357 (when (and (tm-func? out 'document) 358 (tm-func? (tree-ref out :last) 'script-busy)) 359 (tree-assign (tree-ref out :last) `(script-busy ,msg))))) 360 l)))) 361 362(tm-define (session-alive?) 363 (> (session-status) 1)) 364 365(tm-define (session-supports-completions?) 366 (and (session-alive?) 367 (plugin-supports-completions? (get-env "prog-language")))) 368 369(tm-define (session-supports-input-done?) 370 (and (session-alive?) 371 (plugin-supports-input-done? (get-env "prog-language")))) 372 373(define (field-next* t forward?) 374 (and-with u (tree-ref t (if forward? :next :previous)) 375 (cond ((field-context? u) u) 376 ((tree-in? u '(folded-subsession unfolded-subsession)) #f) 377 (else (field-next u forward?))))) 378 379(define (field-next t forward?) 380 (and-with u (tree-ref t (if forward? :next :previous)) 381 (if (field-context? u) u (field-next u forward?)))) 382 383(define (field-extreme t last?) 384 (with u (tree-ref t :up (if last? :last :first)) 385 (if (field-context? u) u 386 (field-next u (not last?))))) 387 388(define (field-insert-output t) 389 (cond ((tm-func? t 'input) 390 (tree-insert! t 2 (list '(document))) 391 (tree-assign-node! t 'unfolded-io)) 392 ((tm-func? t 'input-math) 393 (tree-insert! t 2 (list '(document))) 394 (tree-assign-node! t 'unfolded-io-math)))) 395 396(define (field-remove-output t) 397 (cond ((or (tm-func? t 'folded-io) (tm-func? t 'unfolded-io)) 398 (tree-assign-node! t 'input) 399 (tree-remove! t 2 1)) 400 ((or (tm-func? t 'folded-io-math) (tm-func? t 'unfolded-io-math)) 401 (tree-assign-node! t 'input-math) 402 (tree-remove! t 2 1)) 403 ((tm-func? t 'output) 404 (with p (tree-ref t :up) 405 (when (tree-is? p 'document) 406 (tree-remove! p (tree-index t) 1)))))) 407 408(define (field-update-math t) 409 (if (session-math-input?) 410 (when (field-prog-context? t) 411 (if (tm-func? t 'input) 412 (tree-assign-node! t 'input-math) 413 (begin 414 (tree-assign-node! t 'folded-io-math) 415 (tree-assign (tree-ref t 1) '(document ""))))) 416 (when (field-math-context? t) 417 (if (tm-func? t 'input-math) 418 (tree-assign-node! t 'input) 419 (begin 420 (tree-assign-node! t 'folded-io) 421 (tree-assign (tree-ref t 1) '(document ""))))))) 422 423(define (field-create t p forward?) 424 (let* ((d (tree-ref t :up)) 425 (i (+ (tree-index t) (if forward? 1 0))) 426 (l (if (session-math-input?) 'input-math 'input)) 427 (b `(,l ,p (document "")))) 428 (tree-insert d i (list b)) 429 (tree-ref d i))) 430 431(define (session-forall-sub fun t) 432 (for (u (tree-children t)) 433 (when (field-context? u) 434 (fun u)) 435 (when (and (tm-func? u 'unfolded-subsession) 436 (tm-func? (tree-ref u 1) 'document)) 437 (session-forall-sub fun (tree-ref u 1))))) 438 439(define (session-forall fun) 440 (with-innermost t subsession-document-context? 441 (session-forall-sub fun t))) 442 443;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 444;; Processing input 445;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 446 447(tm-define (make-session lan ses) 448 (let* ((ban `(output (document ""))) 449 (l (if (session-math-input?) 'input-math 'input)) 450 (p (plugin-prompt lan ses)) 451 (in `(,l (document ,p) (document ""))) 452 (s `(session ,lan ,ses (document ,ban ,in)))) 453 (insert-go-to s '(2 1 1 0 0)) 454 (with-innermost t field-input-context? 455 (with u (tree-ref t :previous 0) 456 (if (url-exists? (url-unix "$TEXMACS_STYLE_PATH" 457 (string-append lan ".ts"))) 458 (add-style-package lan)) 459 (session-feed lan ses :start u t '()))))) 460 461(define (input-options t) 462 (with opts '() 463 (when (session-output-timings?) (set! opts (cons :timings opts))) 464 (when (field-math-context? t) (set! opts (cons :math-input opts))) 465 opts)) 466 467(define (field-process-input t) 468 (when (session-ready? #t) 469 (field-insert-output t) 470 (cond ((tm-func? t 'folded-io) 471 (tree-assign-node! t 'unfolded-io)) 472 ((tm-func? t 'folded-io-math) 473 (tree-assign-node! t 'unfolded-io-math))) 474 (let* ((lan (get-env "prog-language")) 475 (ses (get-env "prog-session")) 476 (p (plugin-prompt lan ses)) 477 (in (tree->stree (tree-ref t 1))) 478 (out (tree-ref t 2)) 479 (opts (input-options t))) 480 (with u (or (field-next* t #t) (field-create t p #t)) 481 (session-feed lan ses in out u opts) 482 (tree-go-to u 1 :end))))) 483 484(define (kbd-enter-sub t done?) 485 (if (in? done? (list #f "#f")) 486 (insert-return) 487 (delayed 488 (:idle 1) 489 (session-evaluate)))) 490 491(tm-define (kbd-enter t shift?) 492 (:require (field-input-context? t)) 493 (cond ((xor (session-multiline-input?) shift?) 494 (insert-return)) 495 ((session-supports-input-done?) 496 (let* ((lan (get-env "prog-language")) 497 (ses (get-env "prog-session")) 498 (opts (input-options t)) 499 (st (tree->stree (tree-ref t 1))) 500 (pre (plugin-preprocess lan ses st opts)) 501 (in (plugin-serialize lan pre)) 502 (rew (if (string-ends? in "\n") (string-drop-right in 1) in)) 503 (cmd (string-append "(input-done? " (string-quote rew) ")")) 504 (ret (lambda (done?) (kbd-enter-sub t done?)))) 505 (plugin-command lan ses cmd ret '()))) 506 (else (session-evaluate)))) 507 508(tm-define (session-evaluate) 509 (with-innermost t field-input-context? 510 (field-process-input t))) 511 512(tm-define (session-evaluate-all) 513 (session-forall 514 (lambda (t) 515 (when (not (tree-empty? (tree-ref t 1))) 516 (field-process-input t))))) 517 518(tm-define (session-evaluate-above) 519 (with-innermost me field-input-context? 520 (session-forall 521 (lambda (t) 522 (when (not (tree-empty? (tree-ref t 1))) 523 (when (path-inf? (tree->path t) (tree->path me)) 524 (field-process-input t))))))) 525 526(tm-define (session-evaluate-below) 527 (with-innermost me field-input-context? 528 (session-forall 529 (lambda (t) 530 (when (not (tree-empty? (tree-ref t 1))) 531 (when (path-inf-eq? (tree->path me) (tree->path t)) 532 (field-process-input t))))))) 533 534;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 535;; Keyboard editing 536;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 537 538(tm-define (kbd-horizontal t forwards?) 539 (:require (field-context? t)) 540 (with move (if forwards? go-right go-left) 541 (go-to-remain-inside move field-context? 1))) 542 543(tm-define (kbd-extremal t forwards?) 544 (:require (field-context? t)) 545 (with move (if forwards? go-end-line go-start-line) 546 (go-to-remain-inside move field-context? 1))) 547 548(define (field-go-to-previous) 549 (with-innermost t field-context? 550 (with u (tree-ref t :previous) 551 (if (and u (field-context? u)) 552 (tree-go-to u 1 :end) 553 (go-to-previous-tag-same-argument field-tags))))) 554 555(define (field-go-to-next) 556 (with-innermost t field-context? 557 (with u (tree-ref t :next) 558 (if (and u (field-context? u)) 559 (tree-go-to u 1 :start) 560 (go-to-next-tag-same-argument field-tags)) 561 (go-end-line)))) 562 563(define (field-go-up) 564 (with p (cursor-path) 565 (go-to-remain-inside go-up field-context? 1) 566 (when (== (cursor-path) p) 567 (field-go-to-previous)))) 568 569(define (field-go-down) 570 (with p (cursor-path) 571 (go-to-remain-inside go-down field-context? 1) 572 (when (== (cursor-path) p) 573 (field-go-to-next)))) 574 575(tm-define (kbd-vertical t downwards?) 576 (:require (field-context? t)) 577 (if downwards? (field-go-down) (field-go-up))) 578 579(tm-define (kbd-incremental t downwards?) 580 (:require (field-context? t)) 581 (for (n 0 5) 582 (if downwards? (field-go-to-next) (field-go-to-previous)))) 583 584(tm-define (kbd-remove t forwards?) 585 (:require (field-input-context? t)) 586 (cond ((and (tree-cursor-at? t 1 :start) (not forwards?)) (noop)) 587 ((and (tree-cursor-at? t 1 :end) forwards?) (noop)) 588 (else (remove-text forwards?)))) 589 590(tm-define (kbd-remove t forwards?) 591 (:require (and (field-input-context? t) (selection-active-any?))) 592 (clipboard-cut "nowhere") 593 (clipboard-clear "nowhere")) 594 595(tm-define (kbd-variant t forwards?) 596 (:require (and (field-context? t) (session-supports-completions?))) 597 (let* ((lan (get-env "prog-language")) 598 (ses (get-env "prog-session")) 599 (cmd (session-complete-command t)) 600 (ret (lambda (x) (when x (custom-complete (tm->tree x)))))) 601 (when (!= cmd "") 602 (plugin-command lan ses cmd ret '())))) 603 604;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 605;; Structured keyboard movements 606;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 607 608(tm-define (document-context? t) 609 (:require (and (tree-is? t 'document) 610 (field-input-context? (tree-ref t :up)))) 611 #f) 612 613(tm-define (traverse-horizontal t forwards?) 614 (:require (field-input-context? t)) 615 (with move (if forwards? go-to-next-word go-to-previous-word) 616 (go-to-remain-inside move field-context? 1))) 617 618(tm-define (traverse-vertical t downwards?) 619 (:require (field-input-context? t)) 620 (if downwards? (field-go-down) (field-go-up))) 621 622(tm-define (traverse-extremal t forwards?) 623 (:require (field-input-context? t)) 624 (with move (if forwards? field-go-down field-go-up) 625 (go-to-repeat move))) 626 627(tm-define (traverse-incremental t downwards?) 628 (:require (field-input-context? t)) 629 (if downwards? (field-go-down) (field-go-up))) 630 631(tm-define (structured-horizontal t forwards?) 632 (:require (field-input-context? t)) 633 (noop)) 634 635(tm-define (structured-vertical t downwards?) 636 (:require (field-input-context? t)) 637 (with move (if downwards? field-go-down field-go-up) 638 (go-to-remain-inside move 'session))) 639 640;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 641;; Fold and unfold 642;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 643 644(tm-define (alternate-toggle t) 645 (:require (field-unfolded-context? t)) 646 (with i (tree-down-index t) 647 (variant-set t (ahash-ref alternate-table (tree-label t))) 648 (if (== i 2) (tree-go-to t 1 :end)))) 649 650(tm-define (alternate-toggle t) 651 (:require (field-folded-context? t)) 652 (variant-set t (ahash-ref alternate-table (tree-label t)))) 653 654(tm-define (field-fold t) 655 (when (field-unfolded-context? t) 656 (alternate-toggle t))) 657 658(tm-define (field-unfold t) 659 (when (field-folded-context? t) 660 (alternate-toggle t))) 661 662;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 663;; Field management 664;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 665 666(tm-define (field-insert t* forwards?) 667 (and-with t (tree-search-upwards t* field-input-context?) 668 (let* ((lan (get-env "prog-language")) 669 (ses (get-env "prog-session")) 670 (p (plugin-prompt lan ses)) 671 (t (field-create t p forwards?))) 672 (tree-go-to t 1 :end)))) 673 674(tm-define (field-insert-text t* forward?) 675 (and-with t (tree-search-upwards t* field-input-context?) 676 (let* ((d (tree-ref t :up)) 677 (i (+ (tree-index t) (if forward? 1 0))) 678 (b `(textput (document "")))) 679 (tree-insert d i (list b)) 680 (tree-go-to d i 0 :start)))) 681 682(tm-define (field-remove-banner t*) 683 (and-with t (tree-search-upwards t* session-document-context?) 684 (when (tm-func? (tree-ref t 0) 'output) 685 (tree-remove! t 0 1)))) 686 687(tm-define (field-remove-extreme t* last?) 688 (and-with t (tree-search-upwards t* field-input-context?) 689 (with u (field-extreme t last?) 690 (with v (field-next t (not last?)) 691 (if (and (== u t) v) 692 (tree-go-to v 1 :end)) 693 (if (or (!= u t) v) 694 (tree-remove (tree-ref u :up) (tree-index u) 1)))))) 695 696(tm-define (field-remove t* forwards?) 697 (and-with t (tree-search-upwards t* field-input-context?) 698 (if forwards? 699 (with u (field-next t #t) 700 (if u (begin 701 (tree-remove (tree-ref t :up) (tree-index t) 1) 702 (tree-go-to u 1 :start)) 703 (field-remove-extreme t #t))) 704 (with u (field-next* t #f) 705 (if u (tree-remove (tree-ref u :up) (tree-index u) 1) 706 (field-remove-banner t)))))) 707 708(tm-define (structured-insert-horizontal t forwards?) 709 (:require (field-input-context? t)) 710 (if forwards? (field-insert-fold t))) 711 712(tm-define (structured-insert-vertical t downwards?) 713 (:require (field-input-context? t)) 714 (field-insert t downwards?)) 715 716(tm-define (structured-remove-horizontal t forwards?) 717 (:require (field-input-context? t)) 718 (field-remove t forwards?)) 719 720(tm-define (structured-remove-vertical t forwards?) 721 (:require (field-input-context? t)) 722 (field-remove t forwards?)) 723 724;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 725;; Session management 726;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 727 728(tm-define (session-clear-all) 729 (session-forall field-remove-output)) 730 731(tm-define (session-fold-all) 732 (session-forall field-fold)) 733 734(tm-define (session-unfold-all) 735 (session-forall field-unfold)) 736 737(tm-define (field-insert-fold t*) 738 (and-with t (tree-search-upwards t* field-input-context?) 739 (tree-set! t `(unfolded-subsession (document "") (document ,t))) 740 (tree-go-to t 0 :end))) 741 742(tm-define (session-split) 743 (with-innermost t session-document-context? 744 (let* ((u (tree-ref t :up)) ;; session 745 (v (tree-ref u :up)) ;; document 746 (i (+ (tree-down-index t) 1)) 747 (j (tree-index u)) 748 (lan (tree-ref u 0)) 749 (ses (tree-ref u 1))) 750 (when (< i (tree-arity t)) 751 (tree-remove! u 0 2) 752 (tree-split! u 0 i) 753 (tree-split! v j 1) 754 (tree-insert (tree-ref v j) 0 `(,lan ,ses)) 755 (tree-insert (tree-ref v (+ j 1)) 0 `(,lan ,ses)) 756 (tree-insert v (+ j 1) '((document ""))) 757 (tree-go-to v (+ j 1) :end))))) 758