src/TeXmacs/progs/dynamic/session-edit.scm

   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 ;; Switches
  23 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  24
  25 (define session-math-input #f)
  26
  27 (tm-define (session-math-input?)
  28   session-math-input)
  29
  30 (tm-define (toggle-session-math-input)
  31   (:synopsis "Toggle mathematical input in sessions.")
  32   (:check-mark "v" session-math-input?)
  33   (set! session-math-input (not session-math-input))
  34   (with-innermost t field-context?
  35     (field-update-math t)))
  36
  37 (define session-multiline-input #f)
  38
  39 (tm-define (session-multiline-input?)
  40   session-multiline-input)
  41
  42 (tm-define (toggle-session-multiline-input)
  43   (:synopsis "Toggle multi-line input in sessions.")
  44   (:check-mark "v" session-multiline-input?)
  45   (set! session-multiline-input (not session-multiline-input)))
  46
  47 (define session-scheme-trees #t)
  48
  49 (tm-define (session-scheme-trees?)
  50   session-scheme-trees)
  51
  52 (tm-define (toggle-session-scheme-trees)
  53   (:synopsis "Toggle pretty tree output in scheme sessions.")
  54   (:check-mark "v" session-scheme-trees?)
  55   (set! session-scheme-trees (not session-scheme-trees)))
  56
  57 (define session-scheme-math #f)
  58
  59 (tm-define (session-scheme-math?)
  60   session-scheme-math)
  61
  62 (tm-define (toggle-session-scheme-math)
  63   (:synopsis "Toggle pretty math output in scheme sessions.")
  64   (:check-mark "v" session-scheme-math?)
  65   (set! session-scheme-math (not session-scheme-math)))
  66
  67 (define session-output-timings #f)
  68
  69 (tm-define (session-output-timings?)
  70   session-output-timings)
  71
  72 (tm-define (toggle-session-output-timings)
  73   (:synopsis "Toggle output of evaluation timings.")
  74   (:check-mark "v" session-output-timings?)
  75   (set! session-output-timings (not session-output-timings)))
  76
  77 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  78 ;; Scheme sessions
  79 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  80
  81 (define (replace-newline s)
  82   (with l (string-tokenize-by-char s #\newline)
  83     (if (<= (length l) 1) s
  84         (tm->tree `(document ,@l)))))
  85
  86 (define (var-object->string t)
  87   (with s (object->string t)
  88     (if (== s "#<unspecified>") "" (replace-newline (string-encode s)))))
  89
  90 (define (eval-string-with-catch s)
  91   (catch #t
  92          (lambda () (eval (string->object s)))
  93          (lambda (key msg . args)
  94            key)))
  95
  96 (tm-define (scheme-eval t)
  97   (let* ((s (texmacs->verbatim (tm->tree t)))
  98          (r (eval-string-with-catch s)))
  99     (cond ((and (tree? r) (session-scheme-trees?)) (tree-copy r))
 100           ((session-scheme-math?)
 101            (with m (cas->stree r)
 102              (if (tm? m) (tree 'math (tm->tree m)) (var-object->string r))))
 103           (else (var-object->string r)))))
 104
 105 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 106 ;; Low-level evaluation management
 107 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 108
 109 (define (session-encode in out next opts)
 110   (list (list session-do session-notify session-next session-cancel)
 111         (if (tm? in) (tm->stree in) in)
 112         (tree->tree-pointer out)
 113         (tree->tree-pointer next)
 114         opts))
 115
 116 (define (session-decode l)
 117   (list (second l)
 118         (tree-pointer->tree (third l))
 119         (tree-pointer->tree (fourth l))
 120         (fifth l)))
 121
 122 (define (session-detach l)
 123   (tree-pointer-detach (third l))
 124   (tree-pointer-detach (fourth l)))
 125
 126 (define (session-coherent? out next)
 127   (and (field-or-output-context? (tree-ref out :up))
 128        (field-context? next)))
 129
 130 (define (session-do lan ses)
 131   (with l (pending-ref lan ses)
 132     (with (in out next opts) (session-decode (car l))
 133       ;;(display* "Session do " lan ", " ses ", " in "\n")
 134       (if (or (tree-empty? in) (not (session-coherent? out next)))
 135           (plugin-next lan ses)
 136           (begin
 137             (plugin-write lan ses in)
 138             (tree-set out :up 0 (plugin-prompt lan ses)))))))
 139
 140 (define (session-next lan ses)
 141   ;;(display* "Session next " lan ", " ses "\n")
 142   (with l (pending-ref lan ses)
 143     (with (in out next opts) (session-decode (car l))
 144       (when (and (session-coherent? out next)
 145                  (tm-func? out 'document)
 146                  (tm-func? (tree-ref out :last) 'script-busy))
 147         (let* ((dt (plugin-timing lan ses))
 148                (ts (if (< dt 1000)
 149                        (string-append (number->string dt) " msec")
 150                        (string-append (number->string (/ dt 1000.0)) " sec"))))
 151           (if (and (in? :timings opts) (>= dt 1))
 152               (tree-set (tree-ref out :last) `(timing ,ts))
 153               (tree-remove! out (- (tree-arity out) 1) 1))))
 154       (when (and (session-coherent? out next)
 155                  (tree-empty? out))
 156         (field-remove-output (tree-ref out :up)))
 157       (session-detach (car l)))))
 158
 159 (define (var-tree-children t)
 160   (with r (tree-children t)
 161     (if (and (nnull? r) (tree-empty? (cAr r))) (cDr r) r)))
 162
 163 (define (session-output t u)
 164   (when (tm-func? t 'document)
 165     (with i (tree-arity t)
 166       (if (and (> i 0) (tm-func? (tree-ref t (- i 1)) 'script-busy))
 167           (set! i (- i 1)))
 168       (if (and (> i 0) (tm-func? (tree-ref t (- i 1)) 'errput))
 169           (set! i (- i 1)))
 170       (if (tm-func? u 'document)
 171           (tree-insert! t i (var-tree-children u))))))
 172
 173 (define (session-errput t u)
 174   (when (tm-func? t 'document)
 175     (with i (tree-arity t)
 176       (if (and (> i 0) (tm-func? (tree-ref t (- i 1)) 'script-busy))
 177           (set! i (- i 1)))
 178       (if (and (> i 0) (tm-func? (tree-ref t (- i 1)) 'errput))
 179           (set! i (- i 1))
 180           (tree-insert! t i '((errput (document)))))
 181       (session-output (tree-ref t i 0) u))))
 182
 183 (define (session-notify lan ses ch t)
 184   ;;(display* "Session notify " lan ", " ses ", " ch ", " t "\n")
 185   (with l (pending-ref lan ses)
 186     (with (in out next opts) (session-decode (car l))
 187       (when (session-coherent? out next)
 188         (cond ((== ch "output")
 189                (session-output out t))
 190               ((== ch "error")
 191                (session-errput out t))
 192               ((== ch "prompt")
 193                (if (and (== (length l) 1) (tree-empty? (tree-ref next 1)))
 194                    (tree-set! next 0 (tree-copy t))))
 195               ((and (== ch "input") (null? (cdr l)))
 196                (tree-set! next 1 t)))))))
 197
 198 (define (session-cancel lan ses dead?)
 199   ;;(display* "Session cancel " lan ", " ses ", " dead? "\n")
 200   (with l (pending-ref lan ses)
 201     (with (in out next opts) (session-decode (car l))
 202       (when (and (session-coherent? out next)
 203                  (tm-func? out 'document)
 204                  (tm-func? (tree-ref out :last) 'script-busy))
 205         (tree-assign (tree-ref out :last)
 206                      (if dead? '(script-dead) '(script-interrupted))))
 207       (session-detach (car l)))))
 208
 209 (tm-define (session-feed lan ses in out next opts)
 210   (set! in (plugin-preprocess lan ses in opts))
 211   (tree-assign! out '(document (script-busy)))
 212   (with x (session-encode in out next opts)
 213     (apply plugin-feed `(,lan ,ses ,@(car x) ,(cdr x)))))
 214
 215 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 216 ;; Session contexts
 217 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 218
 219 (tm-define (session-document-context? t)
 220   (and (tm-func? t 'document)
 221        (tm-func? (tree-ref t :up) 'session)))
 222
 223 (tm-define (subsession-document-context? t)
 224   (or (and (tm-func? t 'document)
 225            (tm-func? (tree-ref t :up) 'session))
 226       (and (tm-func? t 'document)
 227            (tm-func? (tree-ref t :up) 'unfolded)
 228            (== (tree-index t) 1))))
 229
 230 (tm-define field-tags
 231   '(input unfolded-io folded-io input-math unfolded-io-math folded-io-math))
 232
 233 (tm-define (field-context? t)
 234   (and (tm? t)
 235        (tree-in? t field-tags)
 236        (tm-func? (tree-ref t :up) 'document)))
 237
 238 (tm-define (field-or-output-context? t)
 239   (and (tm? t)
 240        (tree-in? t (cons 'output field-tags))
 241        (tm-func? (tree-ref t :up) 'document)))
 242
 243 (tm-define (field-folded-context? t)
 244   (and (tree-in? t '(folded-io folded-io-math))
 245        (tm-func? (tree-ref t :up) 'document)))
 246
 247 (tm-define (field-unfolded-context? t)
 248   (and (tree-in? t '(unfolded-io unfolded-io-math))
 249        (tm-func? (tree-ref t :up) 'document)))
 250
 251 (tm-define (field-prog-context? t)
 252   (and (tree-in? t '(input folded-io unfolded-io))
 253        (tm-func? (tree-ref t :up) 'document)))
 254
 255 (tm-define (field-math-context? t)
 256   (and (tree-in? t '(input-math folded-io-math unfolded-io-math))
 257        (tm-func? (tree-ref t :up) 'document)))
 258
 259 (tm-define (field-input-context? t)
 260   (and (field-context? t)
 261        (== (tree-down-index t) 1)))
 262
 263 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 264 ;; Subroutines
 265 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 266
 267 (tm-define (session-defined? . err-flag?)
 268   (with lan (get-env "prog-language")
 269     (or (== lan "scheme")
 270         (connection-defined? lan)
 271         (begin
 272           (if err-flag?
 273               (set-message (string-append "plugin '" lan "' not defined") ""))
 274           #f))))
 275
 276 (tm-define (session-status)
 277   (let* ((lan (get-env "prog-language"))
 278          (ses (get-env "prog-session")))
 279     (cond ((== lan "scheme") 2)
 280           ((not (connection-defined? lan)) 0)
 281           (else (connection-status lan ses)))))
 282
 283 (tm-define (session-alive?)
 284   (> (session-status) 1))
 285
 286 (tm-define (session-supports-completions?)
 287   (and (session-alive?)
 288        (plugin-supports-completions? (get-env "prog-language"))))
 289
 290 (define (field-next t forward?)
 291   (and-with u (tree-ref t (if forward? :next :previous))
 292     (if (field-context? u) u (field-next u forward?))))
 293
 294 (define (field-extreme t last?)
 295   (with u (tree-ref t :up (if last? :last :first))
 296     (if (field-context? u) u
 297         (field-next u (not last?)))))
 298
 299 (define (field-insert-output t)
 300   (cond ((tm-func? t 'input)
 301          (tree-insert! t 2 (list '(document)))
 302          (tree-assign-node! t 'unfolded-io))
 303         ((tm-func? t 'input-math)
 304          (tree-insert! t 2 (list '(document)))
 305          (tree-assign-node! t 'unfolded-io-math))))
 306
 307 (define (field-remove-output t)
 308   (cond ((or (tm-func? t 'folded-io) (tm-func? t 'unfolded-io))
 309          (tree-assign-node! t 'input)
 310          (tree-remove! t 2 1))
 311         ((or (tm-func? t 'folded-io-math) (tm-func? t 'unfolded-io-math))
 312          (tree-assign-node! t 'input-math)
 313          (tree-remove! t 2 1))
 314         ((tm-func? t 'output)
 315          (with p (tree-ref t :up)
 316            (when (tree-is? p 'document)
 317              (tree-remove! p (tree-index t) 1))))))
 318
 319 (define (field-update-math t)
 320   (if (session-math-input?)
 321       (when (field-prog-context? t)
 322         (tree-assign-node! t 'folded-io-math)
 323         (tree-assign (tree-ref t 1) '(document "")))
 324       (when (field-math-context? t)
 325         (tree-assign-node! t 'folded-io)
 326         (tree-assign (tree-ref t 1) '(document "")))))
 327
 328 (define (field-create t p forward?)
 329   (let* ((d (tree-ref t :up))
 330          (i (+ (tree-index t) (if forward? 1 0)))
 331          (l (if (session-math-input?) 'input-math 'input))
 332          (b `(,l ,p (document ""))))
 333     (tree-insert d i (list b))
 334     (tree-ref d i)))
 335
 336 (define (session-forall-sub fun t)
 337   (for (u (tree-children t))
 338     (when (field-context? u)
 339       (fun u))
 340     (when (and (tm-func? u 'unfolded)
 341                (tm-func? (tree-ref u 1) 'document))
 342       (session-forall-sub fun (tree-ref u 1)))))
 343
 344 (define (session-forall fun)
 345   (with-innermost t subsession-document-context?
 346     (session-forall-sub fun t)))
 347
 348 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 349 ;; Processing input
 350 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 351
 352 (tm-define (make-session lan ses)
 353   (let* ((ban `(output (document "")))
 354          (l (if (session-math-input?) 'input-math 'input))
 355          (p (plugin-prompt lan ses))
 356          (in `(,l (document ,p) (document "")))
 357          (s `(session ,lan ,ses (document ,ban ,in))))
 358     (insert-go-to s '(2 1 1 0 0))
 359     (with-innermost t field-input-context?
 360       (with u (tree-ref t :previous 0)
 361         (if (url-exists? (url "$TEXMACS_STYLE_PATH" (string-append lan ".ts")))
 362             (init-add-package lan))
 363         (session-feed lan ses :start u t '())))))
 364
 365 (define (field-process-input t)
 366   (when (session-defined? #t)
 367     (field-insert-output t)
 368     (cond ((tm-func? t 'folded-io)
 369            (tree-assign-node! t 'unfolded-io))
 370           ((tm-func? t 'folded-io-math)
 371            (tree-assign-node! t 'unfolded-io-math)))
 372     (let* ((lan (get-env "prog-language"))
 373            (ses (get-env "prog-session"))
 374            (p (plugin-prompt lan ses))
 375            (in (tree->stree (tree-ref t 1)))
 376            (out (tree-ref t 2))
 377            (opts '()))
 378       (when (session-output-timings?) (set! opts (cons :timings opts)))
 379       (when (field-math-context? t) (set! opts (cons :math-input opts)))
 380       (with u (or (field-next t #t) (field-create t p #t))
 381         (session-feed lan ses in out u opts)
 382         (tree-go-to u 1 :end)))))
 383
 384 (tm-define (kbd-return)
 385   (:context field-input-context?)
 386   (if (session-multiline-input?)
 387       (insert-return)
 388       (session-evaluate)))
 389
 390 (tm-define (kbd-shift-return)
 391   (:context field-input-context?)
 392   (if (session-multiline-input?)
 393       (session-evaluate)
 394       (insert-return)))
 395
 396 (tm-define (session-evaluate)
 397   (with-innermost t field-input-context?
 398     (field-process-input t)))
 399
 400 (tm-define (session-evaluate-all)
 401   (session-forall
 402     (lambda (t)
 403       (when (not (tree-empty? (tree-ref t 1)))
 404         (field-process-input t)))))
 405
 406 (tm-define (session-evaluate-above)
 407   (with-innermost me field-input-context?
 408     (session-forall
 409       (lambda (t)
 410         (when (not (tree-empty? (tree-ref t 1)))
 411           (when (path-inf? (tree->path t) (tree->path me))
 412             (field-process-input t)))))))
 413
 414 (tm-define (session-evaluate-below)
 415   (with-innermost me field-input-context?
 416     (session-forall
 417       (lambda (t)
 418         (when (not (tree-empty? (tree-ref t 1)))
 419           (when (path-inf-eq? (tree->path me) (tree->path t))
 420             (field-process-input t)))))))
 421
 422 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 423 ;; Keyboard editing
 424 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 425
 426 (tm-define (kbd-left)
 427   (:context field-context?)
 428   (go-to-remain-inside go-left field-context? 1))
 429
 430 (tm-define (kbd-right)
 431   (:context field-context?)
 432   (go-to-remain-inside go-right field-context? 1))
 433
 434 (define (field-go-to-previous)
 435   (with-innermost t field-context?
 436     (with u (tree-ref t :previous)
 437       (if (and u (field-context? u))
 438           (tree-go-to u 1 :end)
 439           (go-to-previous-tag-same-argument field-tags)))))
 440
 441 (define (field-go-to-next)
 442   (with-innermost t field-context?
 443     (with u (tree-ref t :next)
 444       (if (and u (field-context? u))
 445           (tree-go-to u 1 :start)
 446           (go-to-next-tag-same-argument field-tags))
 447       (go-end-line))))
 448
 449 (define (field-go-up)
 450   (with p (cursor-path)
 451     (go-to-remain-inside go-up field-context? 1)
 452     (when (== (cursor-path) p)
 453       (field-go-to-previous))))
 454
 455 (define (field-go-down)
 456   (with p (cursor-path)
 457     (go-to-remain-inside go-down field-context? 1)
 458     (when (== (cursor-path) p)
 459       (field-go-to-next))))
 460
 461 (tm-define (kbd-up)
 462   (:context field-context?)
 463   (field-go-up))
 464
 465 (tm-define (kbd-down)
 466   (:context field-context?)
 467   (field-go-down))
 468
 469 (tm-define (kbd-page-up)
 470   (:context field-input-context?)
 471   (for (n 0 5)
 472     (field-go-to-previous)))
 473
 474 (tm-define (kbd-page-down)
 475   (:context field-input-context?)
 476   (for (n 0 5)
 477     (field-go-to-next)))
 478
 479 (tm-define (kbd-remove forward?)
 480   (:context field-input-context?)
 481   (with-innermost t field-input-context?
 482     (cond ((and (tree-cursor-at? t 1 :start) (not forward?)) (noop))
 483           ((and (tree-cursor-at? t 1 :end) forward?) (noop))
 484           (else (remove-text forward?)))))
 485
 486 (tm-define (kbd-tab)
 487   (:context field-input-context?)
 488   (:require (session-supports-completions?))
 489   (with-innermost t field-input-context?
 490     (let* ((lan (get-env "prog-language"))
 491            (ses (get-env "prog-session"))
 492            (cmd (session-complete-command t))
 493            (ret (lambda (x) (when x (custom-complete (tm->tree x))))))
 494       (when (!= cmd "")
 495         (plugin-command lan ses cmd ret '())))))
 496
 497 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 498 ;; Structured keyboard movements
 499 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 500
 501 (define (field-input-simple-context? t)
 502   (and (nleaf? t)
 503        (simple-context? (tree-down t))
 504        (field-input-context? t)))
 505
 506 (tm-define (document-context? t)
 507   (:case document)
 508   (:require (field-input-context? (tree-ref t :up)))
 509   #f)
 510
 511 (tm-define (traverse-left)
 512   (:context field-input-context?)
 513   (go-to-remain-inside go-to-previous-word field-context? 1))
 514
 515 (tm-define (traverse-right)
 516   (:context field-input-context?)
 517   (go-to-remain-inside go-to-next-word field-context? 1))
 518
 519 (tm-define (traverse-up)
 520   (:context field-input-context?)
 521   (field-go-up))
 522
 523 (tm-define (traverse-down)
 524   (:context field-input-context?)
 525   (field-go-down))
 526
 527 (tm-define (traverse-previous)
 528   (:context field-input-context?)
 529   (field-go-up))
 530
 531 (tm-define (traverse-next)
 532   (:context field-input-context?)
 533   (field-go-down))
 534
 535 (tm-define (structured-left)
 536   (:context field-input-simple-context?)
 537   (noop))
 538
 539 (tm-define (structured-right)
 540   (:context field-input-simple-context?)
 541   (noop))
 542
 543 (tm-define (structured-up)
 544   (:context field-input-simple-context?)
 545   (go-to-remain-inside field-go-up 'session))
 546
 547 (tm-define (structured-down)
 548   (:context field-input-simple-context?)
 549   (go-to-remain-inside field-go-down 'session))
 550
 551 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 552 ;; Fold and unfold
 553 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 554
 555 (tm-define (fold)
 556   (:context field-unfolded-context?)
 557   (with-innermost t field-unfolded-context?
 558     (toggle-toggle t)
 559     (tree-go-to t 1 :end)))
 560
 561 (tm-define (unfold)
 562   (:context field-folded-context?)
 563   (with-innermost t field-folded-context?
 564     (toggle-toggle t)
 565     (tree-go-to t 1 :end)))
 566
 567 (tm-define (field-fold t)
 568   (when (field-unfolded-context? t)
 569     (toggle-toggle t)))
 570
 571 (tm-define (field-unfold t)
 572   (when (field-folded-context? t)
 573     (toggle-toggle t)))
 574
 575 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 576 ;; Field management
 577 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 578
 579 (tm-define (field-insert forwards?)
 580   (with-innermost t field-input-context?
 581     (let* ((lan (get-env "prog-language"))
 582            (ses (get-env "prog-session"))
 583            (p (plugin-prompt lan ses))
 584            (t (field-create t p forwards?)))
 585       (tree-go-to t 1 :end))))
 586
 587 (tm-define (field-insert-text forward?)
 588   (with-innermost t field-input-context?
 589     (let* ((d (tree-ref t :up))
 590            (i (+ (tree-index t) (if forward? 1 0)))
 591            (b `(textput (document ""))))
 592       (tree-insert d i (list b))
 593       (tree-go-to d i 0 :start))))
 594
 595 (tm-define (field-remove-banner)
 596   (with-innermost t session-document-context?
 597     (when (tm-func? (tree-ref t 0) 'output)
 598       (tree-remove! t 0 1))))
 599
 600 (tm-define (field-remove-extreme last?)
 601   (with-innermost t field-input-context?
 602     (with u (field-extreme t last?)
 603       (with v (field-next t (not last?))
 604         (if (and (== u t) v)
 605             (tree-go-to v 1 :end))
 606         (if (or (!= u t) v)
 607             (tree-remove (tree-ref u :up) (tree-index u) 1))))))
 608
 609 (tm-define (field-remove forwards?)
 610   (with-innermost t field-input-context?
 611     (if forwards?
 612         (with u (field-next t #t)
 613           (if u (begin
 614                   (tree-remove (tree-ref t :up) (tree-index t) 1)
 615                   (tree-go-to u 1 :start))
 616               (field-remove-extreme #t)))
 617         (with u (field-next t #f)
 618           (if u (tree-remove (tree-ref u :up) (tree-index u) 1)
 619               (field-remove-banner))))))
 620
 621 (tm-define (structured-insert forwards?)
 622   (:context field-input-context?)
 623   (if forwards? (field-insert-fold)))
 624
 625 (tm-define (structured-insert-up)
 626   (:context field-input-context?)
 627   (field-insert #f))
 628
 629 (tm-define (structured-insert-down)
 630   (:context field-input-context?)
 631   (field-insert #t))
 632
 633 (tm-define (structured-remove forwards?)
 634   (:context field-input-context?)
 635   (field-remove forwards?))
 636
 637 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 638 ;; Session management
 639 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 640
 641 (tm-define (session-clear-all)
 642   (session-forall field-remove-output))
 643
 644 (tm-define (session-fold-all)
 645   (session-forall field-fold))
 646
 647 (tm-define (session-unfold-all)
 648   (session-forall field-unfold))
 649
 650 (tm-define (field-insert-fold)
 651   (with-innermost t field-input-context?
 652     (tree-set! t `(unfolded (document "") (document ,t)))
 653     (tree-go-to t 0 :end)))
 654
 655 (tm-define (session-split)
 656   (:context session-document-context?)
 657   (with-innermost t session-document-context?
 658     (let* ((u (tree-ref t :up)) ;; session
 659            (v (tree-ref u :up)) ;; document
 660            (i (+ (tree-down-index t) 1))
 661            (j (tree-index u))
 662            (lan (tree-ref u 0))
 663            (ses (tree-ref u 1)))
 664       (when (< i (tree-arity t))
 665         (tree-remove! u 0 2)
 666         (tree-split! u 0 i)
 667         (tree-split! v j 1)
 668         (tree-insert (tree-ref v j) 0 `(,lan ,ses))
 669         (tree-insert (tree-ref v (+ j 1)) 0 `(,lan ,ses))
 670         (tree-insert v (+ j 1) '((document "")))
 671         (tree-go-to v (+ j 1) :end)))))