src/TeXmacs/progs/kernel/texmacs/tm-dialogue.scm

   1
   2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   3 ;;
   4 ;; MODULE      : tm-dialogue.scm
   5 ;; DESCRIPTION : Interactive dialogues between Scheme and C++
   6 ;; COPYRIGHT   : (C) 1999  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 (kernel texmacs tm-dialogue)
  15   (:use (kernel texmacs tm-define)))
  16
  17 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  18 ;; Dialogues
  19 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  20
  21 (with-module texmacs-user ;; switch modules for old versions of Guile
  22   (define-public dialogue-break #f)
  23   (define-public dialogue-return #f)
  24   (define-public dialogue-error #f))
  25
  26 (define-public (dialogue-report-errors)
  27   (if dialogue-error
  28       (with error dialogue-error
  29         (set! dialogue-error #f)
  30         (apply throw error))))
  31
  32 (define-public-macro (dialogue . body)
  33   (cond
  34     (dialogue-break
  35      `(begin ,@body))
  36     (dialogue-return
  37      `(begin
  38         (exec-delayed (lambda () (dialogue ,@body)))
  39         (dialogue-return (noop))))
  40     (else
  41      `(begin
  42         (with-cc cont
  43           (set! dialogue-break cont)
  44           (catch #t
  45                  (lambda () ,@body)
  46                  (lambda err (set! dialogue-error err)))
  47           (set! dialogue-break #f))
  48         (if dialogue-return (dialogue-return (noop)))
  49         (dialogue-report-errors)))))
  50
  51 (define-public ((dialogue-machine local-continue) result)
  52   (with-cc cont
  53     (set! dialogue-return cont)
  54     (local-continue result))
  55   (set! dialogue-return #f)
  56   (dialogue-report-errors))
  57
  58 (define-public-macro (dialogue-user local-continue . body)
  59   `(with local-break dialogue-break
  60      (set! dialogue-break #f)
  61      (with r (with-cc ,local-continue
  62                ,@body
  63                (local-break (noop)))
  64        (set! dialogue-break local-break)
  65        r)))
  66
  67 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  68 ;; Simple questions
  69 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  70
  71 (define-public (dialogue-ask prompt)
  72   (if dialogue-break
  73       (dialogue-user local-continue
  74         (tm-interactive (dialogue-machine local-continue)
  75                         (if (string? prompt)
  76                             (list (build-interactive-arg prompt))
  77                             (list prompt))))
  78       (texmacs-error "dialogue-ask" "Not in dialogue")))
  79
  80 (define (yes)
  81   (with lan (get-output-language)
  82     (cond ((== lan "french") "oui")
  83           ((in? lan '("dutch" "german")) "ja")
  84           ((in? lan '("italian" "spanish")) "si")
  85           (else "yes"))))
  86
  87 (define (no)
  88   (with lan (get-output-language)
  89     (cond ((== lan "french") "non")
  90           ((== lan "dutch") "nee")
  91           ((== lan "german") "nein")
  92           (else "no"))))
  93
  94 (define-public (dialogue-confirm? prompt default)
  95   (if default
  96       (yes? (dialogue-ask (list prompt "question" (yes) (no))))
  97       (yes? (dialogue-ask (list prompt "question" (no) (yes))))))
  98
  99 (define-public (dialogue-url prompt type)
 100   (if dialogue-break
 101       (dialogue-user local-continue
 102         (delayed
 103           (choose-file (dialogue-machine local-continue) prompt type)))
 104       (texmacs-error "dialogue-ask" "Not in dialogue")))
 105
 106 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 107 ;; Delayed execution of commands
 108 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 109
 110 (define-public (delayed-sub body)
 111   (cond ((or (npair? body) (nlist? (car body)) (not (keyword? (caar body))))
 112          `(lambda () ,@body #t))
 113         ((== (caar body) :pause)
 114          `(let* ((start (texmacs-time))
 115                  (proc ,(delayed-sub (cdr body))))
 116             (lambda ()
 117               (with left (- (+ start ,(cadar body)) (texmacs-time))
 118                 (if (> left 0) left
 119                     (begin
 120                       (set! start (texmacs-time))
 121                       (proc)))))))
 122         ((== (caar body) :every)
 123          `(let* ((time (+ (texmacs-time) ,(cadar body)))
 124                  (proc ,(delayed-sub (cdr body))))
 125             (lambda ()
 126               (with left (- time (texmacs-time))
 127                 (if (> left 0) left
 128                     (begin
 129                       (set! time (+ (texmacs-time) ,(cadar body)))
 130                       (proc)))))))
 131         ((== (caar body) :idle)
 132          `(with proc ,(delayed-sub (cdr body))
 133             (lambda ()
 134               (with left (- ,(cadar body) (idle-time))
 135                 (if (> left 0) left
 136                     (proc))))))
 137         ((== (caar body) :refresh)
 138          (with sym (gensym)
 139            `(let* ((,sym #f)
 140                    (proc ,(delayed-sub (cdr body))))
 141               (lambda ()
 142                 (if (!= ,sym (change-time)) 0
 143                     (with left (- ,(cadar body) (idle-time))
 144                       (if (> left 0) left
 145                           (begin
 146                             (set! ,sym (change-time))
 147                             (proc)))))))))
 148         ((== (caar body) :require)
 149          `(with proc ,(delayed-sub (cdr body))
 150             (lambda ()
 151               (if (not ,(cadar body)) 0
 152                   (proc)))))
 153         ((== (caar body) :while)
 154          `(with proc ,(delayed-sub (cdr body))
 155             (lambda ()
 156               (if (not ,(cadar body)) #t
 157                   (begin (proc) 0)))))
 158         ((== (caar body) :clean)
 159          `(with proc ,(delayed-sub (cdr body))
 160             (lambda ()
 161               (with left (proc)
 162                 (if (!= left #t) left
 163                     (begin ,(cadar body) #t))))))
 164         ((== (caar body) :permanent)
 165          `(with proc ,(delayed-sub (cdr body))
 166             (lambda ()
 167               (with left (proc)
 168                 (if (!= left #t) left
 169                     (with next ,(cadar body)
 170                       (if (!= next #t) #t
 171                           0)))))))
 172         ((== (caar body) :do)
 173          `(with proc ,(delayed-sub (cdr body))
 174             (lambda ()
 175               ,(cadar body)
 176               (proc))))
 177         (else (delayed-sub (cdr body)))))
 178
 179 (define-public-macro (delayed . body)
 180   (if dialogue-break
 181       `(dialogue-user local-continue
 182          (exec-delayed
 183           (with proc ,(delayed-sub body)
 184             (lambda ()
 185               (with r (proc)
 186                 (if r ((dialogue-machine local-continue) (noop)))
 187                 r)))))
 188       `(exec-delayed-pause ,(delayed-sub body))))
 189
 190 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 191 ;; Messages and feedback on the status bar
 192 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 193
 194 (define-public message-serial 0)
 195
 196 (define-public (set-message-notify)
 197   (set! message-serial (+ message-serial 1)))
 198
 199 (define-public (recall-message-after len)
 200   (with current message-serial
 201     (delayed
 202       (:idle len)
 203       (when (== message-serial current)
 204         (recall-message)))))
 205
 206 (define-public (set-temporary-message left right len)
 207   (set-message-temp left right #t)
 208   (recall-message-after len))
 209
 210 (define-public (texmacs-banner)
 211   (with tmv (string-append "GNU TeXmacs " (texmacs-version))
 212     (delayed
 213      (set-message "Welcome to GNU TeXmacs" tmv)
 214      (delayed
 215      (:pause 5000)
 216      (set-message "GNU TeXmacs falls under the GNU general public license" tmv)
 217      (delayed
 218      (:pause 2500)
 219      (set-message "GNU TeXmacs comes without any form of legal warranty" tmv)
 220      (delayed
 221      (:pause 2500)
 222      (set-message
 223       "More information about GNU TeXmacs can be found in the Help->About menu"
 224       tmv)
 225      (delayed
 226      (:pause 2500)
 227      (set-message "" ""))))))))
 228
 229 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 230 ;; Interactive commands
 231 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 232
 233 (define interactive-arg-table (make-ahash-table))
 234
 235 (define (list-but l1 l2)
 236   (cond ((null? l1) l1)
 237         ((in? (car l1) l2) (list-but (cdr l1) l2))
 238         (else (cons (car l1) (list-but (cdr l1) l2)))))
 239
 240 (define (as-stree x)
 241   (cond ((tree? x) (tree->stree x))
 242         ((== x #f) "false")
 243         ((== x #t) "true")
 244         (else x)))
 245
 246 (define-public (procedure-symbol-name fun)
 247   (cond ((symbol? fun) fun)
 248         ((string? fun) (string->symbol fun))
 249         ((and (procedure? fun) (procedure-name fun)) => identity)
 250         (else #f)))
 251
 252 (define-public (procedure-string-name fun)
 253   (and-with name (procedure-symbol-name fun)
 254     (symbol->string name)))
 255
 256 (define-public (learn-interactive fun assoc-t)
 257   "Learn interactive values for @fun"
 258   (set! assoc-t (map (lambda (x) (cons (car x) (as-stree (cdr x)))) assoc-t))
 259   (set! fun (procedure-symbol-name fun))
 260   (when (symbol? fun)
 261     (let* ((l1 (or (ahash-ref interactive-arg-table fun) '()))
 262            (l2 (cons assoc-t (list-but l1 (list assoc-t)))))
 263       (ahash-set! interactive-arg-table fun l2))))
 264
 265 (define-public (learned-interactive fun)
 266   "Return learned list of interactive values for @fun"
 267   (set! fun (procedure-symbol-name fun))
 268   (or (ahash-ref interactive-arg-table fun) '()))
 269
 270 (define (learned-interactive-arg fun nr)
 271   (let* ((l (learned-interactive fun))
 272          (arg (number->string nr))
 273          (extract (lambda (assoc-l) (assoc-ref assoc-l arg))))
 274     (map extract l)))
 275
 276 (define (compute-interactive-arg-text fun which)
 277   (with arg (property fun (list :argument which))
 278     (cond ((npair? arg) (upcase-first (symbol->string which)))
 279           ((and (string? (car arg)) (null? (cdr arg))) (car arg))
 280           ((string? (cadr arg)) (cadr arg))
 281           (else (upcase-first (symbol->string which))))))
 282
 283 (define (compute-interactive-arg-type fun which)
 284   (with arg (property fun (list :argument which))
 285     (cond ((or (npair? arg) (npair? (cdr arg))) "string")
 286           ((string? (car arg)) (car arg))
 287           ((symbol? (car arg)) (symbol->string (car arg)))
 288           (else "string"))))
 289
 290 (define (compute-interactive-arg-proposals fun which)
 291   (let* ((default (property fun (list :default which)))
 292          (proposals (property fun (list :proposals which)))
 293          (learned '()))
 294     (cond ((procedure? default) (list (default)))
 295           ((procedure? proposals) (proposals))
 296           (else '()))))
 297
 298 (define (compute-interactive-arg fun which)
 299   (cons (compute-interactive-arg-text fun which)
 300         (cons (compute-interactive-arg-type fun which)
 301               (compute-interactive-arg-proposals fun which))))
 302
 303 (define (compute-interactive-args-try-hard fun)
 304   (with src (procedure-source fun)
 305     (if (and (pair? src) (== (car src) 'lambda)
 306              (pair? (cdr src)) (list? (cadr src)))
 307         (map upcase-first (map symbol->string (cadr src)))
 308         '())))
 309
 310 (tm-define (compute-interactive-args fun)
 311   (with args (property fun :arguments)
 312     (if (not args)
 313         (compute-interactive-args-try-hard fun)
 314         (map (lambda (which) (compute-interactive-arg fun which)) args))))
 315
 316 (define (build-interactive-arg s)
 317   (cond ((string-ends? s ":") s)
 318         ((string-ends? s "?") s)
 319         (else (string-append s ":"))))
 320
 321 (tm-define (build-interactive-args fun l nr learned?)
 322   (cond ((null? l) l)
 323         ((string? (car l))
 324          (build-interactive-args
 325           fun (cons (list (car l) "string") (cdr l)) nr learned?))
 326         (else
 327          (let* ((name (build-interactive-arg (caar l)))
 328                 (type (cadar l))
 329                 (pl (cddar l))
 330                 (ql pl)
 331                 ;;(ql (if (null? pl) '("") pl))
 332                 (ll (if learned? (learned-interactive-arg fun nr) '()))
 333                 (rl (append ql (list-but ll ql)))
 334                 (props (if (<= (length ql) 1) rl ql)))
 335            (cons (cons name (cons type props))
 336                  (build-interactive-args fun (cdr l) (+ nr 1) learned?))))))
 337
 338 (tm-define (interactive fun . args)
 339   (:synopsis "Call @fun with interactively specified arguments @args")
 340   (:interactive #t)
 341   (lazy-define-force fun)
 342   (if (null? args) (set! args (compute-interactive-args fun)))
 343   (with fun-args (build-interactive-args fun args 0 #t)
 344     (if dialogue-break
 345         (dialogue-user local-continue
 346           (tm-interactive
 347            (lambda args*
 348              (with r* (apply fun args*)
 349                ((dialogue-machine local-continue) r*)
 350                r*))
 351            fun-args))
 352         (tm-interactive fun fun-args))))
 353
 354 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 355 ;; Store learned arguments from one session to another
 356 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 357
 358 (define (save-learned)
 359   (with l (ahash-table->list interactive-arg-table)
 360     (save-object "$TEXMACS_HOME_PATH/system/interactive.scm" l)))
 361
 362 (define (ahash-set-2! t x)
 363   (with (key . l) x
 364     (with (form arg) key
 365       (with a (or (ahash-ref t form) '())
 366         (set! a (assoc-set! a arg l))
 367         (ahash-set! t form a)))))
 368
 369 (define (rearrange-old x)
 370   (with (form . l) x
 371     (let* ((len (apply min (map length l)))
 372            (truncl (map (cut sublist <> 0 len) l))
 373            (sl (sort truncl (lambda (l1 l2) (< (car l1) (car l2)))))
 374            (nl (map (lambda (x) (cons (number->string (car x)) (cdr x))) sl))
 375            (build (lambda args (map cons (map car nl) args)))
 376            (r (apply map (cons build (map cdr nl)))))
 377       (cons form r))))
 378
 379 (define (decode-old l)
 380   (let* ((t (make-ahash-table))
 381          (setter (cut ahash-set-2! t <>)))
 382     (for-each setter l)
 383     (let* ((r (ahash-table->list t))
 384            (m (map rearrange-old r)))
 385       (list->ahash-table m))))
 386
 387 (define (retrieve-learned)
 388   (if (url-exists? "$TEXMACS_HOME_PATH/system/interactive.scm")
 389       (let* ((l (load-object "$TEXMACS_HOME_PATH/system/interactive.scm"))
 390              (old? (and (pair? l) (pair? (car l)) (list-2? (caar l))))
 391              (decode (if old? decode-old list->ahash-table)))
 392         (set! interactive-arg-table (decode l)))))
 393
 394 (on-entry (retrieve-learned))
 395 (on-exit (save-learned))