src/TeXmacs/progs/utils/plugins/plugin-eval.scm

   1
   2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   3 ;;
   4 ;; MODULE      : plugin-eval.scm
   5 ;; DESCRIPTION : Evaluation via plugins
   6 ;; COPYRIGHT   : (C) 1999-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 (utils plugins plugin-eval)
  15   (:use (utils library tree)
  16         (utils library cursor)))
  17
  18 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  19 ;; evaluation + simplification of document fragments
  20 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  21
  22 (tm-define (plugin-output-std-simplify name t)
  23   (cond ((or (func? t 'document 0) (func? 'concat 0)) "")
  24         ((or (func? t 'document 1) (func? t 'concat 1))
  25          (plugin-output-simplify name (cadr t)))
  26         ((and (or (func? t 'document) (func? t 'concat))
  27               (in? (cadr t) '("" " " "  ")))
  28          (plugin-output-simplify name (cons (car t) (cddr t))))
  29         ((and (or (func? t 'document) (func? t 'concat))
  30               (in? (cAr t) '("" " " "  ")))
  31          (plugin-output-simplify name (cDr t)))
  32         ((match? t '(with "mode" "math" :%1))
  33          `(math ,(plugin-output-simplify name (cAr t))))
  34         ((func? t 'with)
  35          (rcons (cDr t) (plugin-output-simplify name (cAr t))))
  36         (else t)))
  37
  38 (tm-define (plugin-output-simplify name t)
  39   (plugin-output-std-simplify name t))
  40
  41 (tm-define (plugin-preprocess name ses t opts)
  42   ;;(display* "Preprocess " t "\n")
  43   (if (null? opts) t
  44       (begin
  45         (if (and (== (car opts) :math-input)
  46                  (plugin-supports-math-input-ref name))
  47             (set! t (plugin-math-input (list 'tuple name t)))))
  48         (plugin-preprocess name ses t (cdr opts))))
  49
  50 (tm-define (plugin-postprocess name ses r opts)
  51   ;;(display* "Postprocess " r "\n")
  52   (if (null? opts) r
  53       (begin
  54         (if (== (car opts) :simplify-output)
  55             (set! r (plugin-output-simplify name r)))
  56         (plugin-postprocess name ses r (cdr opts)))))
  57
  58 (tm-define (plugin-eval name ses t . opts)
  59   (with u (plugin-preprocess name ses t opts)
  60     ;;(display* "u= " u "\n")
  61     (with r (tree->stree (connection-eval name ses u))
  62       ;;(display* "r= " r "\n")
  63       (plugin-postprocess name ses r (cons :simplify-output opts)))))
  64
  65 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  66 ;; New connection management
  67 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  68
  69 (define plugin-pending (make-ahash-table))
  70 (define plugin-started (make-ahash-table))
  71 (define plugin-prompts (make-ahash-table))
  72 (define plugin-author  (make-ahash-table))
  73
  74 (define (pending-set lan ses l)
  75   (ahash-set! plugin-pending (list lan ses) l))
  76
  77 (tm-define (pending-ref lan ses)
  78   (or (ahash-ref plugin-pending (list lan ses)) '()))
  79
  80 (define (plugin-status lan ses)
  81   (if (!= lan "scheme")
  82       (connection-status lan ses)
  83       2))
  84
  85 (define (plugin-set-author lan ses)
  86   (with l (pending-ref lan ses)
  87     (when (nnull? l)
  88       (ahash-set! plugin-author (list lan ses) (fifth (caar l))))))
  89
  90 (define (plugin-start lan ses)
  91   (when (!= lan "scheme")
  92     (plugin-set-author lan ses)
  93     (connection-start lan ses)))
  94
  95 (tm-define (plugin-write lan ses t)
  96   (ahash-set! plugin-started (list lan ses) (texmacs-time))
  97   (if (!= lan "scheme")
  98       (begin
  99         (plugin-set-author lan ses)
 100         (connection-write lan ses t))
 101       (delayed
 102         (connection-notify-status lan ses 3)
 103         (with r (scheme-eval t)
 104           (if (not (func? r 'document))
 105               (set! r (tree 'document r)))
 106           (connection-notify lan ses "output" r))
 107         (connection-notify-status lan ses 2))))
 108
 109 (define (plugin-do lan ses)
 110   (with l (pending-ref lan ses)
 111     (when (nnull? l)
 112       (with status (plugin-status lan ses)
 113         (cond ((and (> (length (car l)) 2) (== (second (car l)) :start))
 114                (if (== status 0)
 115                    (plugin-start lan ses)
 116                    (plugin-next lan ses)))
 117               ((== status 0)
 118                (with author 0
 119                  (when (!= lan "scheme")
 120                    (set! author (new-author))
 121                    (start-slave author))
 122                  (with p (silent-encode :start noop '())
 123                    (set! p (cons (rcons (car p) author) (cdr p)))
 124                    (pending-set lan ses (cons p l))
 125                    (plugin-do lan ses))))
 126               (#t
 127                ((first (caar l)) lan ses)))))))
 128
 129 (tm-define (plugin-next lan ses)
 130   (with l (pending-ref lan ses)
 131     (when (nnull? l)
 132       ((third (caar l)) lan ses)
 133       (pending-set lan ses (cdr l))
 134       (plugin-do lan ses))))
 135
 136 (define (plugin-cancel lan ses dead?)
 137   (with l (pending-ref lan ses)
 138     (when (nnull? l)
 139       ((fourth (caar l)) lan ses dead?)
 140       (pending-set lan ses (cdr l))
 141       (plugin-cancel lan ses dead?))))
 142
 143 (tm-define (plugin-prompt lan ses)
 144   (with p (ahash-ref plugin-prompts (list lan ses))
 145     (if p (tree-copy p) (string-append (upcase-first lan) "] "))))
 146
 147 (tm-define (plugin-timing lan ses)
 148   (with t (ahash-ref plugin-started (list lan ses))
 149     (if t (- (texmacs-time) t) 0)))
 150
 151 (tm-define (plugin-feed lan ses do notify next cancel args)
 152   (with l (pending-ref lan ses)
 153     (with author 0
 154       (when (!= lan "scheme")
 155         (set! author (new-author))
 156         (start-slave author))
 157       (with cb (list do notify next cancel author)
 158         (pending-set lan ses (rcons l (cons cb args)))
 159         (if (null? l) (plugin-do lan ses))))))
 160
 161 (tm-define (plugin-interrupt)
 162   (let* ((lan (get-env "prog-language"))
 163          (ses (get-env "prog-session")))
 164     (if (== (connection-status lan ses) 3)
 165         (connection-interrupt lan ses))
 166     (plugin-cancel lan ses #f)))
 167
 168 (tm-define (plugin-stop)
 169   (let* ((lan (get-env "prog-language"))
 170          (ses (get-env "prog-session")))
 171     (if (!= (connection-status lan ses) 0)
 172         (connection-stop lan ses))))
 173
 174 (define-public-macro (with-author a . body)
 175   `(if (not ,a)
 176        (begin ,@body)
 177        (with old (get-author)
 178          (set-author ,a)
 179          (with r (begin ,@body)
 180            (commit-changes)
 181            (set-author old)
 182            r))))
 183
 184 (tm-define (connection-notify lan ses ch t)
 185   ;;(display* "Notify " lan ", " ses ", " ch ", " t "\n")
 186   (with-author (ahash-ref plugin-author (list lan ses))
 187     (with l (pending-ref lan ses)
 188       (when (nnull? l)
 189         (if (== ch "prompt")
 190             (ahash-set! plugin-prompts (list lan ses) (tree-copy t)))
 191         ((second (caar l)) lan ses ch t)))))
 192
 193 (tm-define (connection-notify-status lan ses st)
 194   ;;(display* "Notify status " lan ", " ses ", " st "\n")
 195   (with-author (ahash-ref plugin-author (list lan ses))
 196     (when (== st 0)
 197       (ahash-remove! plugin-started (list lan ses))
 198       (ahash-remove! plugin-prompts (list lan ses))
 199       (plugin-cancel lan ses #t))
 200     (when (== st 2)
 201       (plugin-next lan ses))))
 202
 203 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 204 ;; Silent evaluation
 205 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 206
 207 (define (silent-encode in return opts)
 208   (list (list silent-do silent-notify silent-next silent-cancel)
 209         (if (tm? in) (tm->stree in) in)
 210         (tree 'document)
 211         (tree 'document)
 212         return
 213         opts))
 214
 215 (define (silent-decode l)
 216   (list (second l)
 217         (third l)
 218         (fourth l)
 219         (fifth l)
 220         (sixth l)))
 221
 222 (define (silent-do lan ses)
 223   (with l (pending-ref lan ses)
 224     (with (in out err return opts) (silent-decode (car l))
 225       ;;(display* "Silent do " lan ", " ses ", " in "\n")
 226       (if (tree-empty? in)
 227           (plugin-next lan ses)
 228           (plugin-write lan ses in)))))
 229
 230 (define (silent-next lan ses)
 231   ;;(display* "Silent next " lan ", " ses "\n")
 232   (with l (pending-ref lan ses)
 233     (with (in out err return opts) (silent-decode (car l))
 234       (return (cons (tm->stree out) (tm->stree err))))))
 235
 236 (define (var-tree-children t)
 237   (with r (tree-children t)
 238     (if (and (nnull? r) (tree-empty? (cAr r))) (cDr r) r)))
 239
 240 (define (silent-output t u)
 241   (when (and (tm-func? t 'document) (tm-func? u 'document))
 242     (tree-insert! t (tree-arity t) (var-tree-children u))))
 243
 244 (define (silent-notify lan ses ch t)
 245   ;;(display* "Silent notify " lan ", " ses ", " ch ", " t "\n")
 246   (with l (pending-ref lan ses)
 247     (with (in out err return opts) (silent-decode (car l))
 248       (cond ((== ch "output")
 249              (silent-output out t))
 250             ((== ch "error")
 251              (silent-output err t))))))
 252
 253 (define (silent-cancel lan ses dead?)
 254   ;;(display* "Silent cancel " lan ", " ses ", " dead? "\n")
 255   (with l (pending-ref lan ses)
 256     (with (in out err return opts) (silent-decode (car l))
 257       (return (if dead? :dead :interrupted)))))
 258
 259 (tm-define (silent-feed lan ses in return opts)
 260   (set! in (plugin-preprocess lan ses in opts))
 261   (with ret (lambda (x)
 262               (return (if (npair? x) x
 263                           (cons (plugin-postprocess lan ses (car x) opts)
 264                                 (plugin-postprocess lan ses (cdr x) opts)))))
 265     (with x (silent-encode in ret opts)
 266       (apply plugin-feed `(,lan ,ses ,@(car x) ,(cdr x))))))
 267
 268 (tm-define (silent-feed* lan ses in return opts)
 269   (with ret (lambda (x)
 270               (return (cond ((== x :dead) '(script-dead))
 271                             ((== x :interrupted) '(script-interrupted))
 272                             ((!= (tm-arity (cdr x)) 0)
 273                              `(with "color" "red" ,(cdr x)))
 274                             (else (car x)))))
 275     (silent-feed lan ses in ret opts)))