plugins/buffer-replace/progs/buffer-replace.scm

   1
   2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; arch-tag: 78866f97-a87b-42c1-91d1-33142c08439f
   3 ;;
   4 ;; MODULE      : buffer-replace.scm
   5 ;; DESCRIPTION : Walking and changing the buffer
   6 ;; COPYRIGHT   : (C) 2004  David Allouche
   7 ;;
   8 ;;   This program is free software; you can redistribute it and/or modify
   9 ;;   it under the terms of the GNU General Public License as published by
  10 ;;   the Free Software Foundation; either version 2 of the License, or
  11 ;;   (at your option) any later version.
  12 ;;
  13 ;;   You should have received a copy of the GNU General Public License
  14 ;;   along with this program; if not, write to the Free Software
  15 ;;   Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  16 ;;
  17 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  18
  19 (texmacs-module (buffer-replace)
  20   (:use (utils library tree)))
  21
  22 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  23 ;; Walking and changing the buffer
  24 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  25 ;;
  26 ;; (pred? p t) -> bool
  27 ;;   p: a path in the buffer tree
  28 ;;   t: the buffer subtree (path->tree) for that path
  29 ;;   returns: should transf be called, with saved position.
  30 ;;   Must not modify the buffer.
  31 ;;
  32 ;; (transf p t) -> unspecified
  33 ;;  p, t: same as for "pred?"
  34 ;;  Modify the buffer. Before calling this function, the current tree iteration
  35 ;;  position is saved as an editor position. The updated position, which may
  36 ;;  have been altered by editor actions in @transf, will be used for subsequent
  37 ;;  iterations.
  38 ;;
  39 ;; NOTE: robustness against buffer changes in @transf requires a tail recursive
  40 ;; implementation.
  41
  42 (define (protect-position p thunk cont)
  43   ;; Save @p as an editor position, execute @thunk, get the updated value of
  44   ;; @p, deleted the position, and apply the updated value to @cont.
  45   (let ((pos (position-new)))
  46     (position-set pos p)
  47     (thunk)
  48     (let ((p (position-get pos)))
  49       (position-delete pos)
  50       (cont p))))
  51
  52 (tm-define buffer-replace
  53   (case-lambda
  54     ((order pred? transf)
  55      (cond ((eqv? :pre order)
  56             (buffer-replace-preorder pred? transf))
  57            ((eqv? :post order)
  58             (buffer-replace-postorder pred? transf))
  59            (else
  60             (error "Bad order keyword:" order))))
  61     ((order p pred? transf)
  62      (cond ((eqv? :pre order)
  63             (buffer-replace-preorder-from p pred? transf))
  64            ((eqv? :post order)
  65             (buffer-replace-postorder-from p pred? transf))
  66            (else
  67             (error "Bad order keyword:" order))))))
  68
  69 (tm-define (buffer-replace-preorder pred? transf)
  70   ;; Preorder traversal, do not recurse in matching subtrees.
  71   (buffer-replace-preorder-from '() pred? transf))
  72
  73 (tm-define (buffer-replace-preorder-from p pred? transf)
  74   (let ((t (path->tree p)))
  75     (cond ((pred? p t)
  76            (protect-position
  77             (rcons p 0) (cut transf p t)
  78             (lambda (pos)
  79               (buffer-replace-preorder/right (cDr pos) pred? transf))))
  80           ((and (tree-compound? t)
  81                 (< 0 (tree-arity t)))
  82            (buffer-replace-preorder-from (rcons p 0) pred? transf))
  83           (else (buffer-replace-preorder/right p pred? transf)))))
  84
  85 (define (buffer-replace-preorder/right p pred? transf)
  86   (let ascend ((ip (reverse p)))
  87     (if (pair? ip)
  88         (let* ((i (1+ (car ip)))
  89                (ipp (cdr ip))
  90                (t (path->tree (reverse ipp))))
  91           ;; by construction, t is a compound tree
  92           (if (< i (tree-arity t))
  93               (buffer-replace-preorder-from
  94                (reverse (cons i ipp)) pred? transf)
  95               (ascend ipp))))))
  96
  97 (tm-define (buffer-replace-postorder pred? transf)
  98   ;; Postorder traversal, all subtrees are walked.
  99   (buffer-replace-postorder-from '() pred? transf))
 100
 101 (tm-define (buffer-replace-postorder-from p pred? transf)
 102   (let ((t (path->tree p)))
 103     (if (and (tree-compound? t)
 104              (< 0 (tree-arity t)))
 105         (buffer-replace-postorder-from (rcons p 0) pred? transf)
 106         (buffer-replace-postorder/right p pred? transf))))
 107
 108 (define (buffer-replace-postorder/right p pred? transf)
 109   (let ascend ((ip (reverse p)))
 110     (if (pair? ip)
 111         (let* ((i (1+ (car ip)))
 112                (ipp (cdr ip))
 113                (t (path->tree (reverse ipp))))
 114           ;; by construction, t is a compound tree
 115           (cond ((< i (tree-arity t))
 116                  (buffer-replace-postorder-from
 117                   (reverse (cons i ipp)) pred? transf))
 118                 ((pred? (reverse ipp) t)
 119                  (protect-position
 120                   (reverse (cons 0 ipp)) (cut transf (reverse ipp) t)
 121                   (lambda (pos) (ascend (cdr (reverse pos))))))
 122                 (else (ascend ipp)))))))