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

   1
   2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   3 ;;
   4 ;; MODULE      : tm-convert.scm
   5 ;; DESCRIPTION : Declaration of data formats and converters
   6 ;; COPYRIGHT   : (C) 2003  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-convert)
  15   (:use (kernel texmacs tm-define) (kernel texmacs tm-modes)))
  16
  17 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  18 ;; Lazy formats
  19 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  20
  21 (define lazy-format-todo '())
  22
  23 (define-public-macro (lazy-format module . ignored)
  24   (set! lazy-format-todo (cons module lazy-format-todo))
  25   `(delayed (:idle 2000) (import-from ,module)))
  26
  27 (define (lazy-format-force)
  28   (if (nnull? lazy-format-todo)
  29       (eval (cons 'import-from lazy-format-todo)))
  30   (set! lazy-format-todo '()))
  31
  32 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  33 ;; Adding new converters
  34 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  35
  36 (define converter-forward (make-ahash-table))
  37 (define converter-backward (make-ahash-table))
  38 (define converter-function (make-ahash-table))
  39 (define converter-options (make-ahash-table))
  40 (define converter-option-for (make-ahash-table))
  41 (define converter-distance (make-ahash-table))
  42 (define converter-path (make-ahash-table))
  43
  44 (define (converter-set-penalty from to penalty)
  45   (if (not (ahash-ref converter-forward from))
  46       (ahash-set! converter-forward from (make-ahash-table)))
  47   (ahash-set! (ahash-ref converter-forward from) to penalty)
  48   (if (not (ahash-ref converter-backward to))
  49       (ahash-set! converter-backward to (make-ahash-table)))
  50   (ahash-set! (ahash-ref converter-backward to) from penalty))
  51
  52 (define (converter-remove from to)
  53   (converter-set-penalty from to #f)
  54   (ahash-remove! (ahash-ref converter-forward from) to)
  55   (ahash-remove! (ahash-ref converter-backward to) from))
  56
  57 (define (converter-change-option from to option val)
  58   (with key (list from to)
  59     (if (not (ahash-ref converter-options key))
  60         (ahash-set! converter-options key '()))
  61     (ahash-set! converter-options key
  62                 (assoc-set! (ahash-ref converter-options key) option val))))
  63
  64 (define (converter-set-option option val)
  65   (with key (ahash-ref converter-option-for option)
  66     (if key (converter-change-option (car key) (cadr key) option val))))
  67
  68 (define (converter-define-option from to option val)
  69   (with key (list from to)
  70     (ahash-set! converter-option-for option key)
  71     (converter-change-option from to option key)
  72     (define-preferences
  73       (option val converter-set-option))))
  74
  75 (define-public (converter-cmd from to cmd)
  76   "Helper routine for converter macro"
  77   (cond ((func? cmd :penalty 1)
  78          (converter-set-penalty from to (second cmd)))
  79         ((func? cmd :require 1)
  80          (if (not ((second cmd))) (converter-remove from to)))
  81         ((func? cmd :option 2)
  82          (converter-define-option from to (second cmd) (third cmd)))
  83         ((func? cmd :function 1)
  84          (ahash-set! converter-function (list from to)
  85                      (lambda (x opts) ((second cmd) x))))
  86         ((func? cmd :function-with-options 1)
  87          (ahash-set! converter-function (list from to) (second cmd)))
  88         ((func? cmd :shell)
  89          (if (not (url-exists-in-path? (second cmd)))
  90              (converter-remove from to))
  91          (ahash-set! converter-function (list from to)
  92                      (lambda (what opts)
  93                        (converter-shell (cdr cmd) what to opts))))))
  94
  95 (define-public (converter-sub cmd)
  96   "Helper routine for converter macro"
  97   (cond ((and (list? cmd) (= (length cmd) 2)
  98               (in? (car cmd) '(:function :function-with-options)))
  99          (list (car cmd) (list 'unquote (cadr cmd))))
 100         ((and (list? cmd) (= (length cmd) 2)
 101               (in? (car cmd) '(:require)))
 102          (list (car cmd) (list 'unquote `(lambda () ,(cadr cmd)))))
 103         (else cmd)))
 104
 105 (define-public-macro (converter from* to* . options)
 106   "Declare a converter between @from@ and @to* according to @options"
 107   (let* ((from (if (string? from*) from* (symbol->string from*)))
 108          (to (if (string? to*) to* (symbol->string to*))))
 109     (set! converter-distance (make-ahash-table))
 110     (set! converter-path (make-ahash-table))
 111     (converter-set-penalty from to 1.0)
 112     `(for-each (lambda (x) (converter-cmd ,from ,to x))
 113                ,(list 'quasiquote (map converter-sub options)))))
 114
 115 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 116 ;; Special converters
 117 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 118
 119 (define (converter-shell-cmd l from to)
 120   (if (null? l) ""
 121       (with x (car l)
 122         (string-append (cond ((== x 'from) (url-concretize from))
 123                              ((== x 'to) (url-concretize to))
 124                              (else x))
 125                        " "
 126                        (converter-shell-cmd (cdr l) from to)))))
 127
 128 (define (converter-shell l from to-format opts)
 129   ;;(display* "converter-shell " l ", " from ", " to-format ", " opts "\n")
 130   (let* ((last? (assoc-ref opts 'last?))
 131          (dest (assoc-ref opts 'dest))
 132          (dsuf (format-default-suffix to-format))
 133          (suf (if (and dsuf (!= dsuf "")) (string-append "." dsuf) ""))
 134          (to (if (and last? dest) dest (url-glue (url-temp) suf)))
 135          (cmd (converter-shell-cmd l from to)))
 136     ;;(display* "shell: " cmd "\n")
 137     (system cmd)
 138     to))
 139
 140 (define-public (converter-save s opts)
 141   "Helper routine for define-format macro"
 142   (let* ((last? (assoc-ref opts 'last?))
 143          (dest (assoc-ref opts 'dest))
 144          (to (if (and last? dest) dest (url-temp))))
 145     (string-save s to)
 146     to))
 147
 148 (define-public (converter-load u opts)
 149   "Helper routine for define-format macro"
 150   (string-load u))
 151
 152 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 153 ;; Finding converters from and to a format
 154 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 155
 156 (define (converters-sub l h p)
 157   (cond ((null? l) (map car (ahash-table->list h)))
 158         ((ahash-ref h (car l)) (converters-sub (cdr l) h p))
 159         (else (let* ((hn (ahash-ref p (car l)))
 160                      (next (if hn (map car (ahash-table->list hn)) '())))
 161                 (ahash-set! h (car l) #t)
 162                 (converters-sub (append next (cdr l)) h p)))))
 163
 164 (define-public (converters-from . from)
 165   (lazy-format-force)
 166   (converters-sub from (make-ahash-table) converter-forward))
 167
 168 (define-public (converters-to . to)
 169   (lazy-format-force)
 170   (converters-sub to (make-ahash-table) converter-backward))
 171
 172 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 173 ;; Finding the shortest path
 174 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 175
 176 (define (converter-insert from to penalty path)
 177   (if (ahash-ref converter-distance (list from to)) #f
 178       (begin
 179         (ahash-set! converter-distance (list from to) penalty)
 180         (ahash-set! converter-path (list from to) path)
 181         #t)))
 182
 183 (define (converter-walk from l*)
 184   ;;(display* "convert-walk " from ", " l* "\n")
 185   (if (nnull? l*)
 186       (let* ((l (list-sort l* (lambda (x y) (< (cadr x) (cadr y)))))
 187              (aux (caar l))
 188              (d (cadar l))
 189              (path (caddar l)))
 190         (if (converter-insert from aux d (reverse path))
 191             (let* ((hn (ahash-ref converter-forward aux))
 192                    (next (if hn (ahash-table->list hn) '()))
 193                    (r (map (lambda (x) (list (car x)
 194                                              (+ d (cdr x))
 195                                              (cons (car x) path)))
 196                            next)))
 197               (converter-walk from (append (cdr l) r)))
 198             (converter-walk from (cdr l))))))
 199
 200 (define-public (converter-search from to)
 201   (lazy-format-force)
 202   (converter-walk from (list (list from 0.0 (list from))))
 203   (ahash-ref converter-path (list from to)))
 204
 205 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 206 ;; Actual conversion
 207 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 208
 209 (define (convert-via what from path options)
 210   ;;(display* "convert-via " what ", " from ", " path ", " options "\n")
 211   (if (null? path) what
 212       (with fun (ahash-ref converter-function (list from (car path)))
 213         (if fun
 214             (let* ((last? (null? (cdr path)))
 215                    (opts1 (acons 'last? last? options))
 216                    (opts2 (ahash-ref converter-options (list from (car path))))
 217                    (what* (fun what (append opts1 (or opts2 '()))))
 218                    (result (convert-via what* (car path) (cdr path) options)))
 219               (if (and (not last?) (string-ends? (car path) "-file"))
 220                   (system-remove what*))
 221               result)
 222             #f))))
 223
 224 (define-public (convert what from to . options)
 225   ;;(display* "convert " what ", " from ", " to ", " options "\n")
 226   (lazy-format-force)
 227   (with path (converter-search from to)
 228     (if path
 229         (convert-via what from (cdr path) options)
 230         #f)))
 231
 232 (define-public (convert-to-file what from to dest . options)
 233   (apply convert (cons* what from to (acons 'dest dest options))))
 234
 235 (define-public (image->postscript name)
 236   (let* ((suffix (locase-all (url-suffix name)))
 237          (fm (string-append (format-from-suffix suffix) "-file"))
 238          (s (convert name fm "postscript-document")))
 239     (if (string? s) s "")))
 240
 241 (define-public (texmacs->generic doc fm)
 242   (with r (convert doc "texmacs-tree" fm)
 243     (if r r "Error: bad format or data")))
 244
 245 (define-public (generic->texmacs s fm)
 246   (with r (convert s fm "texmacs-tree")
 247     (if r r (stree->tree '(error "bad format or data")))))
 248
 249 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 250 ;; Setting up conversion menus
 251 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 252
 253 (define (format<=? fm1 fm2)
 254   (string<=? (ahash-ref format-name fm1) (ahash-ref format-name fm2)))
 255
 256 (define (converters-from-special fm suf tm?)
 257   (let* ((l1 (converters-from fm))
 258          (l2 (list-filter l1 (lambda (s) (string-ends? s suf))))
 259          (l3 (map (lambda (s) (string-drop-right s (string-length suf))) l2))
 260          (l4 (if tm? l3 (list-filter l3 (lambda (s) (!= s "texmacs"))))))
 261     (list-sort l4 format<=?)))
 262
 263 (define (converters-to-special fm suf tm?)
 264   (let* ((l1 (converters-to fm))
 265          (l2 (list-filter l1 (lambda (s) (string-ends? s suf))))
 266          (l3 (map (lambda (s) (string-drop-right s (string-length suf))) l2))
 267          (l4 (if tm? l3 (list-filter l3 (lambda (s) (!= s "texmacs"))))))
 268     (list-sort l4 format<=?)))
 269
 270 (define (converter-build-menu item-builder l)
 271   (define (menu-item fm)
 272     (item-builder fm (ahash-ref format-name fm)))
 273   (map menu-item l))
 274
 275 (define-public (converter-from-menu fm special tm? item-builder)
 276   (with l (converters-from-special fm special tm?)
 277     (converter-build-menu item-builder l)))
 278
 279 (define-public (converter-to-menu fm special tm? item-builder)
 280   (with l (converters-to-special fm special tm?)
 281     (converter-build-menu item-builder l)))
 282
 283 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 284 ;; Other useful subroutines
 285 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 286
 287 (define-public (tmfile? doc)
 288   (and (tmfile-extract doc 'TeXmacs) (tmfile-extract doc 'body)))
 289
 290 (define-public (tmfile-extract doc what)
 291   (if (not (func? doc 'document)) #f
 292       (with val (assoc-ref (cdr doc) what)
 293         (if val (car val) val))))
 294
 295 (define (default-init var)
 296   ;; FIXME: should use C++ code
 297   (cond ((== var "mode") "text")
 298         ((== var "language") "english")
 299         (else "")))
 300
 301 (define-public (tmfile-init doc var)
 302   (with init (tmfile-extract doc 'initial)
 303     (if (not init) (default-init var)
 304         (with item (list-find (cdr init) (lambda (x) (== (cadr x) var)))
 305           (if item (caddr item) (default-init var))))))
 306
 307 (define-public-macro (with-aux u . prg)
 308   `(let* ((u ,u)
 309           (t (texmacs-load-tree u "texmacs"))
 310           (name (get-name-buffer)))
 311      (set-aux-buffer "* Aux *" u t)
 312      (with r (begin ,@prg)
 313        (switch-to-buffer name)
 314        r)))
 315
 316 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 317 ;; Adding new formats
 318 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 319
 320 (define format-name (make-ahash-table))
 321 (define format-suffixes (make-ahash-table))
 322 (define format-mime (make-ahash-table))
 323 (define format-recognize (make-ahash-table))
 324 (define format-must-recognize (make-ahash-table))
 325
 326 (define-public (format-cmd name cmd)
 327   "Helper routine for define-format"
 328   (cond ((func? cmd :name 1)
 329          (ahash-set! format-name name (second cmd)))
 330         ((func? cmd :suffix)
 331          (ahash-set! format-suffixes name (cdr cmd))
 332          (for-each (lambda (s) (ahash-set! format-mime s name)) (cdr cmd)))
 333         ((func? cmd :recognize 1)
 334          (ahash-set! format-recognize name (second cmd)))
 335         ((func? cmd :must-recognize 1)
 336          (ahash-set! format-recognize name (second cmd))
 337          (ahash-set! format-must-recognize name #t))))
 338
 339 (define-public (format-sub cmd)
 340   "Helper routine for define-format"
 341   (if (and (list? cmd) (= (length cmd) 2)
 342            (in? (car cmd) '(:recognize :must-recognize)))
 343       (list (car cmd) (list 'unquote (cadr cmd)))
 344       cmd))
 345
 346 (define-public-macro (define-format name* . options)
 347   "Declare data format @name* according to @options"
 348   (let* ((name (if (string? name*) name* (symbol->string name*)))
 349          (name-document (string-append name "-document"))
 350          (name-file (string-append name "-file")))
 351     `(begin
 352        (converter ,name-document ,name-file
 353          (:function-with-options converter-save))
 354        (converter ,name-file ,name-document
 355          (:function-with-options converter-load))
 356        (for-each (lambda (x) (format-cmd ,name x))
 357                  ,(list 'quasiquote (map format-sub options))))))
 358
 359 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 360 ;; Useful routines for format recognition
 361 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 362
 363 (define-public (format-skip-spaces s pos)
 364   (cond ((>= pos (string-length s)) pos)
 365         ((char-whitespace? (string-ref s pos))
 366          (format-skip-spaces s (+ pos 1)))
 367         (else pos)))
 368
 369 (define-public (format-skip-line s pos)
 370   (cond ((>= pos (string-length s)) pos)
 371         ((in? (string-ref s pos) '(#\newline #\cr)) (+ pos 1))
 372         (else (format-skip-line s (+ pos 1)))))
 373
 374 (define-public (format-test? s pos what)
 375   (with end (+ pos (string-length what))
 376     (and (>= (string-length s) end)
 377          (== (string-downcase (substring s pos end)) what))))
 378
 379 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 380 ;; Getting suffix information
 381 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 382
 383 (define (format-get-suffixes-sub fm)
 384   (with l (ahash-ref format-suffixes fm)
 385     (if l l '())))
 386
 387 (define (format-image-suffixes)
 388   (with l (converters-to-special "postscript-file" "-file" #f)
 389     (apply append (map format-get-suffixes-sub l))))
 390
 391 (define (format-get-suffixes fm)
 392   (cond ((and (== fm "image") (os-win32?))
 393          '("ps" "eps" "bmp" "gif" "ico" "tga" "pcx" "wbmp" "wmf" "jpg"
 394            "jpeg" "png" "tif" "jbig" "ras" "pnm" "jp2" "jpc" "pgx"
 395            "cut" "iff" "lbm" "jng" "koa" "mng" "pbm" "pcd" "pcx"
 396            "pgm" "ppm" "psd" "tga" "tiff" "xbm" "xpm"))
 397         ((== fm "image") (format-image-suffixes))
 398         ((== fm "sound")
 399          '("au" "cdr" "cvs" "dat" "gsm" "ogg" "snd" "voc" "wav"))
 400         ((== fm "animation") '("gif"))
 401         (else (format-get-suffixes-sub fm))))
 402
 403 (define-public (format-get-suffixes* fm)
 404   (lazy-format-force)
 405   (cons 'tuple (format-get-suffixes fm)))
 406
 407 (define-public (format-default-suffix fm)
 408   (lazy-format-force)
 409   (with l (ahash-ref format-suffixes fm)
 410     (cond ((== fm "image") "png")
 411           ((or (not l) (null? l))
 412            (if (string-ends? fm "-file")
 413                (format-default-suffix (string-drop-right fm 5))
 414                ""))
 415           (else (car l)))))
 416
 417 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 418 ;; Automatic determination of the format
 419 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 420
 421 (define-public (format? fm)
 422   (lazy-format-force)
 423   (not (not (ahash-ref format-name fm))))
 424
 425 (define-public (format-recognizes? doc fm)
 426   (lazy-format-force)
 427   (with pred? (ahash-ref format-recognize fm)
 428     (and pred? (pred? doc))))
 429
 430 (define-public (format-from-suffix suffix)
 431   (lazy-format-force)
 432   (with fm (ahash-ref format-mime (locase-all suffix))
 433     (if fm fm "generic")))
 434
 435 (define-public (format-determine body suffix)
 436   (lazy-format-force)
 437   (with p (list-find (ahash-table->list format-recognize)
 438                      (lambda (p) ((cdr p) body)))
 439     (if p (car p)
 440         (with fm (ahash-ref format-mime (locase-all suffix))
 441           (cond ((not fm) "verbatim")
 442                 ((ahash-ref format-must-recognize fm) "verbatim")
 443                 (else fm))))))