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