emacs/nxhtml/util/foldit.el

   1 ;;; foldit.el --- Helpers for folding
   2 ;;
   3 ;; Author: Lennart Borgman (lennart O borgman A gmail O com)
   4 ;; Created: 2009-08-10 Mon
   5 ;; Version:
   6 ;; Last-Updated:
   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 ;; Defines `foldit-mode' which puts visual clues on hidden regions.
  20 ;; Does not do any folding itself but works with `outline-minor-mode'
  21 ;; and `hs-minor-mode'.
  22 ;;
  23 ;; Fix-me: reveal-mode does not work with this and I have no idea why
  24 ;; ...
  25 ;;
  26 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  27 ;;
  28 ;;; Change log:
  29 ;;
  30 ;;
  31 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  32 ;;
  33 ;; This program is free software; you can redistribute it and/or
  34 ;; modify it under the terms of the GNU General Public License as
  35 ;; published by the Free Software Foundation; either version 3, or
  36 ;; (at your option) any later version.
  37 ;;
  38 ;; This program is distributed in the hope that it will be useful,
  39 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  40 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  41 ;; General Public License for more details.
  42 ;;
  43 ;; You should have received a copy of the GNU General Public License
  44 ;; along with this program; see the file COPYING.  If not, write to
  45 ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth
  46 ;; Floor, Boston, MA 02110-1301, USA.
  47 ;;
  48 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  49 ;;
  50 ;;; Code:
  51
  52 ;; Fix-me: start-tag-beg/start-tag-end are workarounds for smaller
  53 ;; bugs in hs-minor-mode and outline-minor-mode. Maybe try to fix
  54 ;; them... - but there are a whole bunch of other invisibilty related
  55 ;; bugs that ought to be fixed first since otherwise it is impossible
  56 ;; to know where point goes after hiding/unhiding.
  57
  58 (eval-when-compile (require 'cl))
  59 (eval-when-compile (require 'hideshow))
  60 (eval-when-compile (require 'mumamo nil t))
  61 (eval-when-compile (require 'outline))
  62
  63 (defsubst foldit-overlay-priority ()
  64   (1+ (or (and (boundp 'mlinks-link-overlay-priority)
  65                mlinks-link-overlay-priority)
  66           100)))
  67
  68 ;;;###autoload
  69 (defgroup foldit nil
  70   "Customization group for foldit folding helpers."
  71   :group 'nxhtml)
  72
  73 (defvar foldit-temp-at-point-ovl nil)
  74 (make-variable-buffer-local 'foldit-temp-at-point-ovl)
  75
  76 ;;;###autoload
  77 (define-minor-mode foldit-mode
  78   "Minor mode providing visual aids for folding.
  79 Shows some hints about what you have hidden and how to reveal it.
  80
  81 Supports `hs-minor-mode', `outline-minor-mode' and major modes
  82 derived from `outline-mode'."
  83   :lighter nil
  84   (if foldit-mode
  85       (progn
  86         ;; Outline
  87         (add-hook 'outline-view-change-hook 'foldit-outline-change nil t)
  88         ;; Add our overlays
  89         (when (or (and (boundp 'outline-minor-mode) outline-minor-mode)
  90                   ;; Fix-me: mumamo
  91                   (derived-mode-p 'outline-mode)) (foldit-outline-change))
  92         ;; hs
  93         (unless (local-variable-p 'hs-set-up-overlay)
  94           (set (make-local-variable 'hs-set-up-overlay) 'foldit-hs-set-up-overlay))
  95         ;; Add our overlays
  96         (when (or (and (boundp 'hs-minor-mode) hs-minor-mode))
  97           (save-restriction
  98             (widen)
  99             (let (ovl)
 100               (dolist (ovl (overlays-in (point-min) (point-max)))
 101                 (when (eq (overlay-get ovl 'invisible) 'hs)
 102                   (funcall hs-set-up-overlay ovl)))))))
 103     ;; Outline
 104     (remove-hook 'outline-view-change-hook 'foldit-outline-change t)
 105     ;; hs
 106     (when (and (local-variable-p 'hs-set-up-overlay)
 107                (eq hs-set-up-overlay 'foldit-hs-set-up-overlay))
 108       (kill-local-variable 'hs-set-up-overlay))
 109     ;; Remove our overlays
 110     (save-restriction
 111       (widen)
 112       (let (ovl prop)
 113         (dolist (ovl (overlays-in (point-min) (point-max)))
 114           (when (setq prop (overlay-get ovl 'foldit))
 115             (case prop
 116               ;;('display (overlay-put ovl 'display nil))
 117               ('foldit (delete-overlay ovl))
 118               (t (delete-overlay ovl))
 119               )))))))
 120
 121 (defcustom foldit-avoid '(org-mode)
 122   "List of major modes to avoid."
 123   :group 'foldit)
 124
 125 ;;;###autoload
 126 (define-globalized-minor-mode foldit-global-mode foldit-mode
 127   (lambda () (foldit-mode 1))
 128   :group 'foldit)
 129
 130 (defun foldit-hidden-line-str (hidden-lines type)
 131   "String to display for hidden lines.
 132 HIDDEN-LINES are the number of lines and TYPE is a string
 133 indicating how they were hidden."
 134   (propertize (format " ...(%d %slines)" hidden-lines type)
 135               'face 'shadow))
 136
 137 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 138 ;;; Outline
 139
 140 (defvar foldit-outline-keymap
 141   (let ((map (make-sparse-keymap)))
 142     (define-key map "\r" 'foldit-outline-show-entry)
 143     (define-key map [down-mouse-1] 'foldit-outline-show-entry)
 144     (define-key map [S-tab]   'mlinks-backward-link)
 145     (define-key map [tab]     'mlinks-forward-link)
 146     (define-key map "\t"      'mlinks-forward-link)
 147     map))
 148
 149 (defun foldit-outline-change ()
 150   "Check outline overlays.
 151 Run this in `outline-view-change-hook'."
 152   ;; We get the variables FROM and TO here from `outline-flag-region'
 153   ;; so let us use them. But O is hidden...
 154   (let* (from
 155          to
 156          num-lines
 157          ovl
 158          (tag ""))
 159     (cond
 160      ((and (boundp 'start)
 161            start
 162            (boundp 'end)
 163            end)
 164       (setq from start)
 165       (setq to   end))
 166      (t
 167       (setq from (point-min))
 168       (setq to   (point-max))))
 169     (dolist (ovl (overlays-in from to))
 170       (when (eq (overlay-get ovl 'invisible) 'outline)
 171         (setq num-lines (count-lines (overlay-start ovl) (overlay-end ovl)))
 172         (overlay-put ovl 'display (concat
 173                                    (propertize "+" 'face 'mode-line)
 174                                    ""
 175                                    tag (foldit-hidden-line-str num-lines "")))
 176         (overlay-put ovl 'foldit 'display) ;; Should be a list...
 177         (overlay-put ovl 'keymap foldit-outline-keymap)
 178         (overlay-put ovl 'face 'lazy-highlight)
 179         (overlay-put ovl 'mouse-face 'highlight)
 180         (overlay-put ovl 'help-echo "Press RET to show hidden part")
 181         (overlay-put ovl 'mlinks-link t)
 182         (overlay-put ovl 'priority (foldit-overlay-priority))
 183         (mumamo-with-buffer-prepared-for-jit-lock
 184          (let* ((start-tag-beg (overlay-start ovl))
 185                 (start-tag-end start-tag-beg))
 186            (put-text-property start-tag-beg (+ start-tag-beg 1)
 187                               'foldit-tag-end (copy-marker start-tag-end))))
 188         ))))
 189
 190 (defvar foldit-outline-hide-again-keymap
 191   (let ((map (make-sparse-keymap)))
 192     (define-key map "\r" 'foldit-outline-hide-again)
 193     (define-key map [down-mouse-1] 'foldit-outline-hide-again)
 194     (define-key map [S-tab]   'mlinks-backward-link)
 195     (define-key map [tab]     'mlinks-forward-link)
 196     (define-key map "\t"      'mlinks-forward-link)
 197     map))
 198
 199 (defun foldit-outline-show-entry ()
 200   "Show hidden entry."
 201   (interactive)
 202   (let ((tag-end (get-text-property (point) 'foldit-tag-end)))
 203     (show-entry)
 204     (mumamo-with-buffer-prepared-for-jit-lock
 205      (set-text-properties (point) (+ (point) 2) 'foldit-tag-end))
 206     (when tag-end (goto-char tag-end))
 207     (foldit-add-temp-at-point-overlay "-"
 208                                       foldit-outline-hide-again-keymap
 209                                       "Press RET to hide again")))
 210
 211 (defun foldit-outline-hide-again ()
 212   "Hide entry again."
 213   (interactive)
 214   (when (overlayp foldit-temp-at-point-ovl)
 215     (delete-overlay foldit-temp-at-point-ovl))
 216   (hide-entry))
 217
 218
 219 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 220 ;;; Hide/Show
 221
 222 (defvar foldit-hs-start-tag-end-func 'foldit-hs-default-start-tag-end)
 223 (make-variable-buffer-local 'foldit-hs-start-tag-end-func)
 224 (put 'foldit-hs-start-tag-end-func 'permanent-local t)
 225
 226 (defun foldit-hs-default-start-tag-end (beg)
 227   "Find end of hide/show tag beginning at BEG."
 228   (min (+ beg 65)
 229        (save-excursion
 230          (goto-char beg)
 231          (line-end-position))))
 232
 233 (defvar foldit-hs-keymap
 234   (let ((map (make-sparse-keymap)))
 235     (define-key map "\r" 'foldit-hs-show-block)
 236     (define-key map [down-mouse-1] 'foldit-hs-show-block)
 237     (define-key map [S-tab]   'mlinks-backward-link)
 238     (define-key map [tab]     'mlinks-forward-link)
 239     (define-key map "\t"      'mlinks-forward-link)
 240     map))
 241
 242 (defvar foldit-hs-hide-again-keymap
 243   (let ((map (make-sparse-keymap)))
 244     (define-key map "\r" 'foldit-hs-hide-again)
 245     (define-key map [down-mouse-1] 'foldit-hs-hide-again)
 246     (define-key map [S-tab]   'mlinks-backward-link)
 247     (define-key map [tab]     'mlinks-forward-link)
 248     (define-key map "\t"      'mlinks-forward-link)
 249     map))
 250
 251 (defun foldit-hs-set-up-overlay (ovl)
 252   "Set up overlay OVL for hide/show."
 253   (let* ((num-lines (count-lines (overlay-start ovl) (overlay-end ovl)))
 254          (here (point))
 255          (start-tag-beg (overlay-start ovl))
 256          (start-tag-end (funcall foldit-hs-start-tag-end-func start-tag-beg))
 257          (tag (buffer-substring start-tag-beg start-tag-end)))
 258     (goto-char here)
 259     ;;(overlay-put ovl 'isearch-open-invisible t)
 260     (overlay-put ovl 'display (concat
 261                                (propertize "+" 'face 'mode-line)
 262                                " "
 263                                tag (foldit-hidden-line-str num-lines "h")))
 264     (overlay-put ovl 'foldit 'display)
 265     (overlay-put ovl 'keymap foldit-hs-keymap)
 266     (overlay-put ovl 'face 'next-error)
 267     (overlay-put ovl 'face 'lazy-highlight)
 268     (overlay-put ovl 'mouse-face 'highlight)
 269     (overlay-put ovl 'help-echo "Press RET to show hidden part")
 270     (overlay-put ovl 'mlinks-link t)
 271     (overlay-put ovl 'priority (foldit-overlay-priority))
 272     (mumamo-with-buffer-prepared-for-jit-lock
 273      (put-text-property start-tag-beg (+ start-tag-beg 1)
 274                         'foldit-tag-end (copy-marker start-tag-end)))))
 275
 276 (defun foldit-hs-show-block ()
 277   "Show hidden block."
 278   (interactive)
 279   (let ((tag-end (get-text-property (point) 'foldit-tag-end)))
 280     (hs-show-block)
 281     (mumamo-with-buffer-prepared-for-jit-lock
 282      (set-text-properties (point) (+ (point) 2) 'foldit-tag-end))
 283     (when tag-end (goto-char tag-end))
 284     (foldit-add-temp-at-point-overlay "-"
 285                                       foldit-hs-hide-again-keymap
 286                                     "Press RET to hide again")))
 287
 288 (defun foldit-hs-hide-again ()
 289   "Hide hide/show block again."
 290   (interactive)
 291   (when (overlayp foldit-temp-at-point-ovl)
 292     (delete-overlay foldit-temp-at-point-ovl))
 293   (hs-hide-block))
 294
 295
 296 ;;; Fix-me: break out this
 297 ;; >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
 298 (defun foldit-add-temp-at-point-overlay (marker keymap msg)
 299   "Add a temporary overlay with a marker MARKER and a keymap KEYMAP.
 300 The overlay is also given the help echo MSG.
 301
 302 This overlay is removed as soon as point moves from current point."
 303   (let ((ovl (make-overlay (point) (1+ (point))))
 304         (real (buffer-substring (point) (1+ (point)))))
 305     (overlay-put ovl 'isearch-open-invisible t)
 306     (overlay-put ovl 'display (concat
 307                                (propertize marker 'face 'mode-line)
 308                                " "
 309                                msg
 310                                real))
 311     (overlay-put ovl 'foldit 'foldit)
 312     (overlay-put ovl 'keymap keymap)
 313     (overlay-put ovl 'face 'lazy-highlight)
 314     (overlay-put ovl 'mouse-face 'highlight)
 315     (overlay-put ovl 'help-echo msg)
 316     (overlay-put ovl 'mlinks-link t)
 317     (overlay-put ovl 'priority (foldit-overlay-priority))
 318     (setq foldit-temp-at-point-ovl ovl)
 319     (add-hook 'post-command-hook
 320               'foldit-remove-temp-at-point-overlay
 321               nil t)))
 322
 323 (defun foldit-remove-temp-at-point-overlay ()
 324   "Remove overlay made by `foldit-add-temp-at-point-overlay'."
 325   (condition-case err
 326       (unless (and foldit-temp-at-point-ovl
 327                    (overlay-buffer foldit-temp-at-point-ovl)
 328                    (= (overlay-start foldit-temp-at-point-ovl)
 329                       (point)))
 330         (delete-overlay foldit-temp-at-point-ovl)
 331         (setq foldit-temp-at-point-ovl nil)
 332         (remove-hook 'post-command-hook 'foldit-remove-temp-at-point-overlay t)
 333         )
 334     (error (message "foldit-remove-temp-at-point-overlay: %s"
 335                     (propertize (error-message-string err))))))
 336 ;; <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
 337
 338
 339
 340 ;; (defun put-before-on-invis ()
 341 ;;   (let* (o
 342 ;;          (io (catch 'io
 343 ;;                (dolist (o (overlays-at (1+ (point))))
 344 ;;                  (when (overlay-get o 'invisible)
 345 ;;                    (throw 'io o)))))
 346 ;;          (str (propertize "IOSTRING"
 347 ;;                           'face 'secondary-selection
 348 ;;                           )))
 349 ;;     (overlay-put io 'before-string str)
 350 ;;     ;;(overlay-put io 'display "display")
 351 ;;     (overlay-put io 'display nil)
 352 ;;     ;;(overlay-put io 'after-string "AFTER")
 353 ;;     ))
 354
 355 (provide 'foldit)
 356 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 357 ;;; foldit.el ends here