nxhtml/util/mumamo-regions.el

   1 ;;; mumamo-regions.el --- user defined regions with mumamo
   2 ;;
   3 ;; Author: Lennart Borgman (lennart O borgman A gmail O com)
   4 ;; Created: 2009-05-31 Sun
   5 ;; Version: 0.5
   6 ;; Last-Updated: 2009-06-01 Mon
   7 ;; URL:
   8 ;; Keywords:
   9 ;; Compatibility:
  10 ;;
  11 ;; Features that might be required by this library:
  12 ;;
  13 ;;   None
  14 ;;
  15 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  16 ;;
  17 ;;; Commentary:
  18 ;;
  19 ;; Add temporary mumamo chunks (called mumamo regions).  This are
  20 ;; added interactively from a highlighted region.
  21 ;;
  22 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  23 ;;
  24 ;;; Change log:
  25 ;;
  26 ;;
  27 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  28 ;;
  29 ;; This program is free software; you can redistribute it and/or
  30 ;; modify it under the terms of the GNU General Public License as
  31 ;; published by the Free Software Foundation; either version 3, or
  32 ;; (at your option) any later version.
  33 ;;
  34 ;; This program is distributed in the hope that it will be useful,
  35 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  36 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  37 ;; General Public License for more details.
  38 ;;
  39 ;; You should have received a copy of the GNU General Public License
  40 ;; along with this program; see the file COPYING.  If not, write to
  41 ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth
  42 ;; Floor, Boston, MA 02110-1301, USA.
  43 ;;
  44 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  45 ;;
  46 ;;; Code:
  47
  48 (eval-when-compile (require 'cl))
  49 (eval-when-compile (require 'mumamo))
  50 (eval-when-compile (require 'ourcomments-widgets))
  51 (require 'ps-print) ;; For ps-print-ensure-fontified
  52
  53 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  54 ;;; Internal side functions etc
  55
  56 (defvar mumamo-regions nil
  57   "List of active mumamo regions.  Internal use only.
  58 The entries in this list should be like this
  59
  60     \(OVL-DEF OVL-CHUNK)
  61
  62 where OVL-DEF is an overlay containing the definitions, ie `major-mode'.
  63 OVL-CHUNK is the definitions set up temporarily for mumamo chunks.
  64
  65 The fontification functions in mumamo looks in this list, but the
  66 chunk dividing functions defined by
  67 `define-mumamo-multi-major-mode' does not.  The effect is that
  68 the normal chunks exists regardless of what is in this list, but
  69 fontification etc is overridden by what this list says.")
  70 (make-variable-buffer-local 'mumamo-regions)
  71 (put 'mumamo-regions 'permanent-local t)
  72
  73 (defun mumamo-add-region-1 (major start end buffer)
  74   "Add a mumamo region with major mode MAJOR from START to END.
  75 Return the region.  The returned value can be used in
  76 `mumamo-clear-region'.
  77
  78 START and END should be markers in the buffer BUFFER.  They may
  79 also be nil in which case they extend the region to the buffer
  80 boundaries."
  81   (unless mumamo-multi-major-mode
  82     (mumamo-temporary-multi-major))
  83   (or (not start)
  84       (markerp start)
  85       (eq (marker-buffer start) buffer)
  86       (error "Bad arg start: %s" start))
  87   (or (not end)
  88       (markerp end)
  89       (eq (marker-buffer end) buffer)
  90       (error "Bad arg end: %s" end))
  91   (let ((ovl (make-overlay start end)))
  92     (overlay-put ovl 'mumamo-region 'defined)
  93     (overlay-put ovl 'face 'mumamo-region)
  94     (overlay-put ovl 'priority 2)
  95     (mumamo-region-set-major ovl major)
  96     (setq mumamo-regions (cons (list ovl nil) mumamo-regions))
  97     (mumamo-mark-for-refontification (overlay-start ovl) (overlay-end ovl))
  98     (message "Added mumamo region from %d to %d" (+ 0 start) (+ 0 end))
  99     ovl))
 100
 101 (defun mumamo-clear-region-1 (region-entry)
 102   "Clear mumamo region REGION-ENTRY.
 103 The entry must have been returned from `mumamo-add-region-1'."
 104   (let ((buffer (overlay-buffer (car region-entry)))
 105         (entry  (cdr region-entry)))
 106     (when (buffer-live-p buffer)
 107       (with-current-buffer buffer
 108         (let ((ovl1 (car region-entry))
 109               (ovl2 (cadr region-entry)))
 110           (delete-overlay ovl1)
 111           (when ovl2
 112             (mumamo-mark-for-refontification (overlay-start ovl2) (overlay-end ovl2))
 113             (delete-overlay ovl2))
 114           (setq mumamo-regions (delete region-entry mumamo-regions)))))))
 115
 116 (defvar mumamo-region-priority 0)
 117 (make-variable-buffer-local 'mumamo-region-priority)
 118 (put 'mumamo-region-priority 'permanent-local t)
 119
 120 (defun mumamo-get-region-from-1 (point)
 121   "Return mumamo region values for POINT.
 122 The return value is either mumamo chunk or a cons with
 123 information about where regions starts to hide normal chunks.
 124 Such a cons has the format \(BELOW . OVER) where each of them is
 125 a position or nil."
 126   (when mumamo-regions
 127     (save-restriction
 128       (widen)
 129       (let* ((start nil)
 130              (end   nil)
 131              (major nil)
 132              hit-reg
 133              ret-val)
 134         (catch 'found-major
 135           (dolist (reg mumamo-regions)
 136             (assert (eq (overlay-get (car reg) 'mumamo-region) 'defined) t)
 137             (assert (or (not (cadr reg)) (overlayp (cadr reg))))
 138             (let* ((this-ovl (car reg))
 139                    (this-start (overlay-start this-ovl))
 140                    (this-end   (overlay-end this-ovl)))
 141                (when  (<= this-end point)
 142                  (setq start this-end))
 143                (when  (< point this-start)
 144                  (setq end this-start))
 145                (when (and (<= this-start point)
 146                           (< point this-end))
 147                  (setq major (overlay-get this-ovl 'mumamo-major-mode))
 148                  (setq start (max this-start (or start this-start)))
 149                  (setq end   (min this-end   (or end this-end)))
 150                  (setq hit-reg reg)
 151                  (throw 'found-major nil)))))
 152         (if major
 153             (progn
 154               (setq ret-val (nth 1 hit-reg))
 155               (when ret-val (assert (eq (overlay-get ret-val 'mumamo-region) 'used) t))
 156               (if ret-val
 157                   (move-overlay ret-val start end)
 158                 (setq ret-val (make-overlay start end nil t nil)) ;; fix-me
 159                 (setcar (cdr hit-reg) ret-val)
 160                 (overlay-put ret-val 'mumamo-region 'used)
 161                 (overlay-put ret-val 'priority ;; above normal chunks + chunks on chunks
 162                              (setq mumamo-region-priority (1+ mumamo-region-priority)))
 163                 ;;(overlay-put ret-val 'face '(:background "chocolate")) ;; temporary
 164                 (overlay-put ret-val 'mumamo-major-mode
 165                              (overlay-get (car hit-reg) 'mumamo-major-mode))))
 166           (setq ret-val (cons start end)))
 167         ;;(message "mumamo-get-region-from-1, point=%s ret-val=%s" point ret-val)
 168         ret-val))))
 169
 170 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 171 ;;; User side functions
 172
 173 (defun mumamo-temporary-multi-major ()
 174   "Turn on a temporary multi major mode from buffers current mode.
 175 Define one if no one exists.  It will have no chunk dividing
 176 routines.  It is meant mainly to be used with mumamo regions when
 177 there is no mumamo multi major mode in the buffer and the user
 178 wants to add a mumamo region \(which requires a multi major mode
 179 to work)."
 180   (when mumamo-multi-major-mode
 181     (error "Mumamo is already active in buffer"))
 182   (let* ((temp-mode-name (concat "mumamo-1-"
 183                                  (symbol-name major-mode)))
 184          (temp-mode-sym (intern-soft temp-mode-name)))
 185     (unless (and temp-mode-sym
 186                  (fboundp temp-mode-sym))
 187       (setq temp-mode-sym (intern temp-mode-name))
 188       (eval
 189        `(define-mumamo-multi-major-mode ,temp-mode-sym
 190           "Temporary multi major mode."
 191           ("Temporary" ,major-mode nil))))
 192     (put temp-mode-sym 'mumamo-temporary major-mode)
 193     (funcall temp-mode-sym)))
 194
 195 (defface mumamo-region
 196   '((t (:background "white")))
 197   "Face for mumamo-region regions."
 198   :group 'mumamo)
 199
 200 ;;;###autoload
 201 (defun mumamo-add-region ()
 202   "Add a mumamo region from selection.
 203 Mumamo regions are like another layer of chunks above the normal chunks.
 204 They does not affect the normal chunks, but they overrides them.
 205
 206 To create a mumamo region first select a visible region and then
 207 call this function.
 208
 209 If the buffer is not in a multi major mode a temporary multi
 210 major mode will be created applied to the buffer first.
 211 To get out of this and get back to a single major mode just use
 212
 213   M-x normal-mode"
 214   (interactive)
 215   (if (not mark-active)
 216       (message (propertize "Please select a visible region first" 'face 'secondary-selection))
 217     (let ((beg (region-beginning))
 218           (end (region-end))
 219           (maj (mumamo-region-read-major)))
 220       (mumamo-add-region-1 maj (copy-marker beg) (copy-marker end) (current-buffer))
 221       (setq deactivate-mark t))))
 222
 223 ;;;###autoload
 224 (defun mumamo-add-region-from-string ()
 225   "Add a mumamo region from string at point.
 226 Works as `mumamo-add-region' but for string or comment at point.
 227
 228 Buffer must be fontified."
 229   (interactive)
 230   ;; assure font locked.
 231   (require 'ps-print)
 232   (ps-print-ensure-fontified (point-min) (point-max))
 233   (let ((the-face (get-text-property (point) 'face)))
 234     (if (not (memq the-face
 235                    '(font-lock-doc-face
 236                      font-lock-string-face
 237                      font-lock-comment-face)))
 238         (message "No string or comment at point")
 239       (let ((beg (previous-single-property-change (point) 'face))
 240             (end (next-single-property-change (point) 'face))
 241             (maj (mumamo-region-read-major)))
 242         (setq beg (or (when beg (1+ beg))
 243                       (point-min)))
 244         (setq end (or (when end (1- end))
 245                       (point-max)))
 246         (mumamo-add-region-1 maj (copy-marker beg) (copy-marker end) (current-buffer))))))
 247 ;; (dolist (o (overlays-in (point-min) (point-max))) (delete-overlay o))
 248 (defun mumamo-clear-all-regions ()
 249   "Clear all mumamo regions in buffer.
 250 For information about mumamo regions see `mumamo-add-region'."
 251   (interactive)
 252   (unless mumamo-multi-major-mode
 253     (error "There can be no mumamo regions to clear unless in multi major modes"))
 254   (while mumamo-regions
 255     (mumamo-clear-region-1 (car mumamo-regions))
 256     (setq mumamo-regions (cdr mumamo-regions)))
 257   (let ((old (get mumamo-multi-major-mode 'mumamo-temporary)))
 258     (when old (funcall old)))
 259   (message "Cleared all mumamo regions"))
 260
 261 (defun mumamo-region-read-major ()
 262   "Prompt user for major mode.
 263 Accept only single major mode, not mumamo multi major modes."
 264   (let ((major (read-command "Major mode: ")))
 265     (unless (major-modep major) (error "Not a major mode: %s" major))
 266     (when (mumamo-multi-major-modep major) (error "Multi major modes not allowed: %s" major))
 267     (when (let ((major-mode major))
 268             (derived-mode-p 'nxml-mode))
 269       (error "%s is based on nxml-mode and can't be used here" major))
 270     major))
 271
 272 (defun mumamo-region-at (point)
 273   "Return mumamo region at POINT."
 274    (let ((ovls (overlays-at (point))))
 275      (catch 'overlay
 276        (dolist (o ovls)
 277          (when (overlay-get o 'mumamo-region)
 278            (throw 'overlay o)))
 279        nil)))
 280
 281 (defun mumamo-region-set-major (ovl major)
 282   "Change major mode for mumamo region at point.
 283 For information about mumamo regions see `mumamo-add-region'.
 284
 285 If run non-interactively then OVL should be a mumamo region and
 286 MAJOR the major mode to set for that region."
 287   (interactive
 288    (list (or (mumamo-region-at (point))
 289              (error "There is no mumamo region at point"))
 290          (mumamo-region-read-major)))
 291   (overlay-put ovl 'mumamo-major-mode `(,major))
 292   (overlay-put ovl 'help-echo (format "Mumamo region, major mode `%s'" major)))
 293
 294 (defun mumamo-clear-region (ovl)
 295   "Clear the mumamo region at point.
 296 For information about mumamo regions see `mumamo-add-region'.
 297
 298 If run non-interactively then OVL should be the mumamo region to
 299 clear."
 300   (interactive
 301    (list (or (mumamo-region-at (point))
 302              (error "There is no mumamo region at point"))))
 303   (let ((region-entry (rassoc (list ovl) mumamo-regions)))
 304     (unless region-entry
 305       (error "No mumamo region found at point"))
 306     (mumamo-clear-region-1 region-entry)))
 307
 308
 309 (provide 'mumamo-regions)
 310 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 311 ;;; mumamo-regions.el ends here