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         (dynamic session-drd)
  18         (dynamic scripts-edit)
  19         (dynamic fold-edit)))
  20
  21 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  22 ;; Switches
  23 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  24
  25 (tm-define (toggle-session-math-input)
  26   (:synopsis "Toggle mathematical input in sessions.")
  27   (:check-mark "v" session-math-input?)
  28   (session-use-math-input (not (session-math-input?)))
  29   (with-innermost t io-context?
  30     (io-update-math t)))
  31
  32 (define session-multiline-input #f)
  33
  34 (tm-define (session-multiline-input?)
  35   session-multiline-input)
  36
  37 (tm-define (toggle-session-multiline-input)
  38   (:synopsis "Toggle multi-line input in sessions.")
  39   (:check-mark "v" session-multiline-input?)
  40   (set! session-multiline-input (not session-multiline-input)))
  41
  42 (define session-scheme-trees #t)
  43
  44 (tm-define (session-scheme-trees?)
  45   session-scheme-trees)
  46
  47 (tm-define (toggle-session-scheme-trees)
  48   (:synopsis "Toggle pretty tree output in scheme sessions.")
  49   (:check-mark "v" session-scheme-trees?)
  50   (set! session-scheme-trees (not session-scheme-trees)))
  51
  52 (define session-scheme-math #f)
  53
  54 (tm-define (session-scheme-math?)
  55   session-scheme-math)
  56
  57 (tm-define (toggle-session-scheme-math)
  58   (:synopsis "Toggle pretty tree output in scheme sessions.")
  59   (:check-mark "v" session-scheme-math?)
  60   (set! session-scheme-math (not session-scheme-math)))
  61
  62 (define session-output-timings #f)
  63
  64 (tm-define (session-output-timings?)
  65   session-output-timings)
  66
  67 (tm-define (toggle-session-output-timings)
  68   (:synopsis "Toggle output of evaluation timings.")
  69   (:check-mark "v" session-output-timings?)
  70   (set! session-output-timings (not session-output-timings)))
  71
  72 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  73 ;; Session contexts
  74 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  75
  76 (tm-define (session-document-context? t)
  77   (and (tm-func? t 'document)
  78        (tm-func? (tree-ref t :up) 'session)))
  79
  80 (tm-define (subsession-document-context? t)
  81   (or (and (tm-func? t 'document)
  82            (tm-func? (tree-ref t :up) 'session))
  83       (and (tm-func? t 'document)
  84            (tm-func? (tree-ref t :up) 'unfolded)
  85            (== (tree-index t) 1))))
  86
  87 (tm-define io-tags '(unfolded-io folded-io unfolded-io-math folded-io-math))
  88
  89 (tm-define (io-context? t)
  90   (and (tree-in? t io-tags)
  91        (tm-func? (tree-ref t :up) 'document)))
  92
  93 (tm-define (io-folded-context? t)
  94   (and (tree-in? t '(folded-io folded-io-math))
  95        (tm-func? (tree-ref t :up) 'document)))
  96
  97 (tm-define (io-unfolded-context? t)
  98   (and (tree-in? t '(unfolded-io unfolded-io-math))
  99        (tm-func? (tree-ref t :up) 'document)))
 100
 101 (tm-define (io-prog-context? t)
 102   (and (tree-in? t '(folded-io unfolded-io))
 103        (tm-func? (tree-ref t :up) 'document)))
 104
 105 (tm-define (io-math-context? t)
 106   (and (tree-in? t '(folded-io-math unfolded-io-math))
 107        (tm-func? (tree-ref t :up) 'document)))
 108
 109 (tm-define (input-context? t)
 110   (and (io-context? t)
 111        (== (tree-down-index t) 1)))
 112
 113 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 114 ;; Subroutines
 115 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 116
 117 (define (io-next t forward?)
 118   (and-with u (tree-ref t (if forward? :next :previous))
 119     (if (io-context? u) u (io-next u forward?))))
 120
 121 (define (io-extreme t last?)
 122   (with u (tree-ref t :up (if last? :last :first))
 123     (if (io-context? u) u
 124         (io-next u (not last?)))))
 125
 126 (define (io-update-math t)
 127   (if (session-math-input?)
 128       (when (io-prog-context? t)
 129         (tree-assign-node! t 'folded-io-math)
 130         (tree-assign (tree-ref t 1) '(document "")))
 131       (when (io-math-context? t)
 132         (tree-assign-node! t 'folded-io)
 133         (tree-assign (tree-ref t 1) '(document "")))))
 134
 135 (define (io-create t p forward?)
 136   (let* ((d (tree-ref t :up))
 137          (i (+ (tree-index t) (if forward? 1 0)))
 138          (l (if (session-math-input?) 'folded-io-math 'folded-io))
 139          (b `(,l ,p (document "") (document))))
 140     (tree-insert d i (list b))
 141     (tree-ref d i)))
 142
 143 (define (session-forall-sub fun t)
 144   (for (u (tree-children t))
 145     (when (io-context? u)
 146       (fun u))
 147     (when (and (tm-func? u 'unfolded)
 148                (tm-func? (tree-ref u 1) 'document))
 149       (session-forall-sub fun (tree-ref u 1)))))
 150
 151 (define (session-forall fun)
 152   (with-innermost t subsession-document-context?
 153     (session-forall-sub fun t)))
 154
 155 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 156 ;; Processing input
 157 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 158
 159 (tm-define (make-session lan ses)
 160   (let* ((ban `(output (document "")))
 161          (l (if (session-math-input?) 'folded-io-math 'folded-io))
 162          (p (connection-prompt lan ses))
 163          (in `(,l (document ,p) (document "") (document)))
 164          (s `(session ,lan ,ses (document ,ban ,in))))
 165     (insert-go-to s '(2 1 1 0 0))
 166     (with-innermost t input-context?
 167       (with u (tree-ref t :previous 0)
 168         (if (url-exists? (url "$TEXMACS_STYLE_PATH" (string-append lan ".ts")))
 169             (init-add-package lan))
 170         (session-feed lan ses :start u t '())))))
 171
 172 (define (io-process-input t)
 173   (if (tm-func? t 'folded-io)
 174       (tree-assign-node! t 'unfolded-io))
 175   (if (tm-func? t 'folded-io-math)
 176       (tree-assign-node! t 'unfolded-io-math))
 177   (let* ((lan (get-env "prog-language"))
 178          (ses (get-env "prog-session"))
 179          (p (connection-prompt lan ses))
 180          (in (tree->stree (tree-ref t 1)))
 181          (out (tree-ref t 2))
 182          (opts '()))
 183     (when (session-output-timings?) (set! opts (cons :timings opts)))
 184     (when (io-math-context? t) (set! opts (cons :math-input opts)))
 185     (with u (or (io-next t #t) (io-create t p #t))
 186       (session-feed lan ses in out u opts)
 187       (tree-go-to u 1 :end))))
 188
 189 (tm-define (kbd-return)
 190   (:context input-context?)
 191   (if (session-multiline-input?)
 192       (insert-return)
 193       (session-evaluate)))
 194
 195 (tm-define (kbd-shift-return)
 196   (:context input-context?)
 197   (if (session-multiline-input?)
 198       (session-evaluate)
 199       (insert-return)))
 200
 201 (tm-define (session-evaluate)
 202   (with-innermost t input-context?
 203     (io-process-input t)))
 204
 205 (tm-define (session-evaluate-all)
 206   (session-forall
 207     (lambda (t)
 208       (when (not (tree-empty? (tree-ref t 1)))
 209         (io-process-input t)))))
 210
 211 (tm-define (session-evaluate-above)
 212   (with-innermost me input-context?
 213     (session-forall
 214       (lambda (t)
 215         (when (not (tree-empty? (tree-ref t 1)))
 216           (when (path-inf? (tree->path t) (tree->path me))
 217             (io-process-input t)))))))
 218
 219 (tm-define (session-evaluate-below)
 220   (with-innermost me input-context?
 221     (session-forall
 222       (lambda (t)
 223         (when (not (tree-empty? (tree-ref t 1)))
 224           (when (path-inf-eq? (tree->path me) (tree->path t))
 225             (io-process-input t)))))))
 226
 227 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 228 ;; Keyboard editing
 229 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 230
 231 (tm-define (kbd-left)
 232   (:context io-context?)
 233   (go-to-remain-inside go-left io-context? 1))
 234
 235 (tm-define (kbd-right)
 236   (:context io-context?)
 237   (go-to-remain-inside go-right io-context? 1))
 238
 239 (define (io-go-up)
 240   (with p (cursor-path)
 241     (go-to-remain-inside go-up io-context? 1)
 242     (when (== (cursor-path) p)
 243       (go-to-previous-tag-same-argument io-tags))))
 244
 245 (define (io-go-down)
 246   (with p (cursor-path)
 247     (go-to-remain-inside go-down io-context? 1)
 248     (when (== (cursor-path) p)
 249       (go-to-next-tag-same-argument io-tags))))
 250
 251 (tm-define (kbd-up)
 252   (:context io-context?)
 253   (io-go-up))
 254
 255 (tm-define (kbd-down)
 256   (:context io-context?)
 257   (io-go-down))
 258
 259 (tm-define (kbd-page-up)
 260   (:context input-context?)
 261   (for (n 0 5)
 262     (go-to-next-inside go-to-previous-node io-context? 1)))
 263
 264 (tm-define (kbd-page-down)
 265   (:context input-context?)
 266   (for (n 0 5)
 267     (go-to-next-inside go-to-next-node io-context? 1)))
 268
 269 (tm-define (kbd-remove forward?)
 270   (:context input-context?)
 271   (with-innermost t input-context?
 272     (cond ((and (tree-cursor-at? t 1 :start) (not forward?)) (noop))
 273           ((and (tree-cursor-at? t 1 :end) forward?) (noop))
 274           (else (remove-text forward?)))))
 275
 276 (tm-define (kbd-tab)
 277   (:context input-context?)
 278   (:require (plugin-supports-completions? (get-env "prog-language")))
 279   (with-innermost t input-context?
 280     (session-complete-try? t)))
 281
 282 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 283 ;; Structured keyboard movements
 284 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 285
 286 (define (io-input-simple-context? t)
 287   (and (nleaf? t)
 288        (simple-context? (tree-down t))
 289        (input-context? t)))
 290
 291 (tm-define (document-context? t)
 292   (:case document)
 293   (:require (input-context? (tree-ref t :up)))
 294   #f)
 295
 296 (tm-define (traverse-left)
 297   (:context input-context?)
 298   (go-to-remain-inside go-to-previous-word io-context? 1))
 299
 300 (tm-define (traverse-right)
 301   (:context input-context?)
 302   (go-to-remain-inside go-to-next-word io-context? 1))
 303
 304 (tm-define (traverse-up)
 305   (:context input-context?)
 306   (io-go-up))
 307
 308 (tm-define (traverse-down)
 309   (:context input-context?)
 310   (io-go-down))
 311
 312 (tm-define (traverse-previous)
 313   (:context input-context?)
 314   (io-go-up))
 315
 316 (tm-define (traverse-next)
 317   (:context input-context?)
 318   (io-go-down))
 319
 320 (tm-define (structured-left)
 321   (:context io-input-simple-context?)
 322   (noop))
 323
 324 (tm-define (structured-right)
 325   (:context io-input-simple-context?)
 326   (noop))
 327
 328 (tm-define (structured-up)
 329   (:context io-input-simple-context?)
 330   (go-to-remain-inside io-go-up 'session))
 331
 332 (tm-define (structured-down)
 333   (:context io-input-simple-context?)
 334   (go-to-remain-inside io-go-down 'session))
 335
 336 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 337 ;; Fold and unfold
 338 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 339
 340 (tm-define (fold)
 341   (:context io-unfolded-context?)
 342   (with-innermost t io-unfolded-context?
 343     (toggle-toggle t)
 344     (tree-go-to t 1 :end)))
 345
 346 (tm-define (unfold)
 347   (:context io-folded-context?)
 348   (with-innermost t io-folded-context?
 349     (toggle-toggle t)
 350     (tree-go-to t 1 :end)))
 351
 352 (tm-define (io-fold t)
 353   (when (io-unfolded-context? t)
 354     (toggle-toggle t)))
 355
 356 (tm-define (io-unfold t)
 357   (when (io-folded-context? t)
 358     (toggle-toggle t)))
 359
 360 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 361 ;; Field management
 362 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 363
 364 (tm-define (io-insert forwards?)
 365   (with-innermost t input-context?
 366     (let* ((lan (get-env "prog-language"))
 367            (ses (get-env "prog-session"))
 368            (p (connection-prompt lan ses)))
 369       (tree-go-to (io-create t p forwards?) 1 :end))))
 370
 371 (tm-define (io-insert-text forward?)
 372   (with-innermost t input-context?
 373     (let* ((d (tree-ref t :up))
 374            (i (+ (tree-index t) (if forward? 1 0)))
 375            (b `(textput (document ""))))
 376       (tree-insert d i (list b))
 377       (tree-go-to d i 0 :start))))
 378
 379 (tm-define (io-remove-banner)
 380   (with-innermost t session-document-context?
 381     (when (tm-func? (tree-ref t 0) 'output)
 382       (tree-remove! t 0 1))))
 383
 384 (tm-define (io-remove-extreme last?)
 385   (with-innermost t input-context?
 386     (with u (io-extreme t last?)
 387       (with v (io-next t (not last?))
 388         (if (and (== u t) v)
 389             (tree-go-to v 1 :end))
 390         (if (or (!= u t) v)
 391             (tree-remove (tree-ref u :up) (tree-index u) 1))))))
 392
 393 (tm-define (io-remove forwards?)
 394   (with-innermost t input-context?
 395     (if forwards?
 396         (with u (io-next t #t)
 397           (if u (begin
 398                   (tree-remove (tree-ref t :up) (tree-index t) 1)
 399                   (tree-go-to u 1 :start))
 400               (io-remove-extreme #t)))
 401         (with u (io-next t #f)
 402           (if u (tree-remove (tree-ref u :up) (tree-index u) 1)
 403               (io-remove-banner))))))
 404
 405 (tm-define (structured-insert forwards?)
 406   (:context input-context?)
 407   (if forwards? (io-insert-fold)))
 408
 409 (tm-define (structured-insert-up)
 410   (:context input-context?)
 411   (io-insert #f))
 412
 413 (tm-define (structured-insert-down)
 414   (:context input-context?)
 415   (io-insert #t))
 416
 417 (tm-define (structured-remove forwards?)
 418   (:context input-context?)
 419   (io-remove forwards?))
 420
 421 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 422 ;; Session management
 423 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 424
 425 (tm-define (session-clear-all)
 426   (session-forall (lambda (t) (tree-set! t 2 '(document)))))
 427
 428 (tm-define (session-fold-all)
 429   (session-forall io-fold))
 430
 431 (tm-define (session-unfold-all)
 432   (session-forall io-unfold))
 433
 434 (tm-define (io-insert-fold)
 435   (with-innermost t input-context?
 436     (tree-set! t `(unfolded (document "") (document ,t)))
 437     (tree-go-to t 0 :end)))
 438
 439 (tm-define (session-split)
 440   (:context session-document-context?)
 441   (with-innermost t session-document-context?
 442     (let* ((u (tree-ref t :up)) ;; session
 443            (v (tree-ref u :up)) ;; document
 444            (i (+ (tree-down-index t) 1))
 445            (j (tree-index u))
 446            (lan (tree-ref u 0))
 447            (ses (tree-ref u 1)))
 448       (when (< i (tree-arity t))
 449         (tree-remove! u 0 2)
 450         (tree-split! u 0 i)
 451         (tree-split! v j 1)
 452         (tree-insert (tree-ref v j) 0 `(,lan ,ses))
 453         (tree-insert (tree-ref v (+ j 1)) 0 `(,lan ,ses))
 454         (tree-insert v (+ j 1) '((document "")))
 455         (tree-go-to v (+ j 1) :end)))))