lisp/progmodes/hideshow.el

   1 ;;; hideshow.el --- minor mode cmds to selectively display blocks of code
   2
   3 ;;; Copyright (C) 1994,1995 Free Software Foundation
   4
   5 ;;; Author: Thien-Thi Nguyen <ttn@netcom.com>
   6 ;;; Version: 3.4
   7 ;;; Keywords: C C++ lisp tools editing
   8 ;;; Time-of-Day-Author-Most-Likely-to-be-Recalcitrant: early morning
   9
  10 ;;; This file is part of GNU Emacs.
  11
  12 ;;; GNU Emacs is free software; you can redistribute it and/or modify it
  13 ;;; under the terms of the GNU General Public License as published by the
  14 ;;; Free Software Foundation; either version 2 of the License, or (at your
  15 ;;; option) any later version.
  16 ;;;
  17 ;;; GNU Emacs is distributed in the hope that it will be useful, but WITHOUT
  18 ;;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  19 ;;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  20 ;;; for more details.
  21 ;;;
  22 ;;; You should have received a copy of the GNU General Public License along
  23 ;;; with this program; if not, write to the Free Software Foundation, Inc.,
  24 ;;; 675 Mass Ave, Cambridge, MA 02139, USA.
  25
  26 ;;; LCD Archive Entry:
  27 ;;; hideshow|Thien-Thi Nguyen|ttn@netcom.com|
  28 ;;; minor mode commands to selectively display blocks of code|
  29 ;;; 18-Oct-1994|3.4|~/modes/hideshow.el.Z|
  30
  31 ;;; Commentary:
  32
  33 ;;; This file provides `hs-minor-mode'.  When active, six commands:
  34 ;;;   hs-{hide,show}-{all,block}, hs-show-region and hs-minor-mode
  35 ;;; are available.  They implement block hiding and showing.  Blocks are
  36 ;;; defined in mode-specific way.  In c-mode or c++-mode, they are simply
  37 ;;; curly braces, while in lisp-ish modes they are parens.  Multi-line
  38 ;;; comments (c-mode) can also be hidden.  The command M-x hs-minor-mode
  39 ;;; toggles the minor mode or sets it (similar to outline minor mode).
  40 ;;; See documentation for each command for more info.
  41 ;;;
  42 ;;; The variable `hs-unbalance-handler-method' controls hideshow's behavior
  43 ;;; in the case of "unbalanced parentheses".  See doc for more info.
  44
  45 ;;; Suggested usage:
  46
  47 ;;; (load-library "hideshow")
  48 ;;; (defun my-hs-setup () "enables hideshow and binds some commands"
  49 ;;;   (hs-minor-mode 1)
  50 ;;;   (define-key hs-minor-mode-map "\C-ch" 'hs-hide-block)
  51 ;;;   (define-key hs-minor-mode-map "\C-cs" 'hs-show-block)
  52 ;;;   (define-key hs-minro-mode-map "\C-cH" 'hs-hide-all)
  53 ;;;   (define-key hs-minro-mode-map "\C-cS" 'hs-show-all)
  54 ;;;   (define-key hs-minor-mode-map "\C-cR" 'hs-show-region))
  55 ;;; (add-hook 'X-mode-hook 'my-hs-setup t)   ; other modes similarly
  56 ;;;
  57 ;;; where X = {emacs-lisp,c,c++,perl,...}.  See the doc for the variable
  58 ;;; `hs-special-modes-alist' if you'd like to use hideshow w/ other modes.
  59
  60 ;;; Etc:
  61
  62 ;;; Bug reports and fixes welcome (comments, too).  Thanks go to
  63 ;;;     Dean Andrews <adahome@ix.netcom.com>
  64 ;;;     Preston F. Crow <preston.f.crow@dartmouth.edu>
  65 ;;;     Gael Marziou <gael@gnlab030.grenoble.hp.com>
  66 ;;;     Keith Sheffield <sheff@edcsgw2.cr.usgs.gov>
  67 ;;;     Jan Djarv <jan.djarv@sa.erisoft.se>
  68 ;;;     Lars Lindberg <qhslali@aom.ericsson.se>
  69 ;;;     Alf-Ivar Holm <alfh@ifi.uio.no>
  70 ;;; for valuable feedback, code and bug reports.
  71
  72 ;;; Code:
  73
  74
  75 ;;;----------------------------------------------------------------------------
  76 ;;; user-configurable variables
  77
  78 (defvar hs-unbalance-handler-method 'top-level
  79   "*Symbol representing how \"unbalanced parentheses\" should be handled.
  80 This error is usually signalled by hs-show-block.  One of four values:
  81 `top-level', `next-line', `signal' or `ignore'.  Default is `top-level'.
  82
  83 - `top-level' -- Show top-level block containing the currently troublesome
  84 block.
  85 - `next-line' -- Use the fact that, for an already hidden block, its end
  86 will be on the next line.  Attempt to show this block.
  87 - `signal' -- Pass the error through, stopping execution.
  88 - `ignore' -- Ignore the error, continuing execution.
  89
  90 Values other than these four will be interpreted as `signal'.")
  91
  92 (defvar hs-special-modes-alist '((c-mode "{" "}")
  93                                  (c++-mode "{" "}"))
  94   "*Alist of the form (MODE START-RE END-RE FORWARD-SEXP-FUNC).
  95 If present, hideshow will use these values for the start and end regexps,
  96 respectively.  Since Algol-ish languages do not have single-character
  97 block delimiters, the function `forward-sexp' which is used by hideshow
  98 doesn't work.  In this case, if a similar function is provided, you can
  99 register it and have hideshow use it instead of `forward-sexp'.  To add
 100 more values, use
 101
 102 \t(pushnew '(new-mode st-re end-re function-name)
 103 \t      hs-special-modes-alist :test 'equal)
 104
 105 For example:
 106
 107 \t(pushnew '(simula-mode \"begin\" \"end\" simula-next-statement)
 108 \t      hs-special-modes-alist :test 'equal)
 109
 110 Note that the regexps should not contain leading or trailing whitespace.")
 111
 112 (defvar hs-hide-hooks nil
 113   "*Hooks called at the end of hs-hide-all and hs-hide-block.")
 114
 115 (defvar hs-show-hooks nil
 116   "*Hooks called at the end of hs-show-all, hs-show-block and hs-show-region.")
 117
 118 (defvar hs-minor-mode-prefix "\C-c"
 119   "*Prefix key to use for hideshow commands in hideshow minor mode.")
 120
 121
 122 ;;;----------------------------------------------------------------------------
 123 ;;; internal variables
 124
 125 (defvar hs-minor-mode nil
 126   "Non-nil if using hideshow mode as a minor mode of some other mode.
 127 Use the command `hs-minor-mode' to toggle this variable.")
 128
 129 (defvar hs-minor-mode-map nil
 130   "Mode map for hideshow minor mode.")
 131
 132 (defvar hs-menu-bar nil
 133   "Menu bar for hideshow minor mode (Xemacs only).")
 134
 135 (defvar hs-c-start-regexp nil
 136   "Regexp for beginning of comments.  Buffer-local.
 137 Differs from mode-specific comment regexps in that surrounding
 138 whitespace is stripped.")
 139
 140 (defvar hs-c-end-regexp nil
 141   "Regexp for end of comments.  Buffer-local.
 142 See `hs-c-start-regexp'.")
 143
 144 (defvar hs-block-start-regexp nil
 145   "Regexp for beginning of block.  Buffer-local.")
 146
 147 (defvar hs-block-end-regexp nil
 148   "Regexp for end of block.  Buffer-local.")
 149
 150 (defvar hs-forward-sexp-func 'forward-sexp
 151   "Function used to do a forward-sexp.  Should change for Algol-ish modes.
 152 For single-character block delimiters -- ie, the syntax table regexp for the
 153 character is either `(' or `)' -- `hs-forward-sexp-func' would just be
 154 `forward-sexp'.  For other modes such as simula, a more specialized function
 155 is necessary.")
 156
 157 (defvar hs-emacs-type 'fsf
 158   "Used to support both FSF Emacs and Xemacs.")
 159
 160 (eval-when-compile
 161   (if (string-match "xemacs\\|lucid" emacs-version)
 162       (progn
 163         (defvar current-menubar nil "")
 164         (defun set-buffer-menubar (arg1))
 165         (defun add-menu (arg1 arg2 arg3)))))
 166
 167
 168 ;;;----------------------------------------------------------------------------
 169 ;;; support funcs
 170
 171 ;; snarfed from outline.el, but added buffer-read-only
 172 (defun hs-flag-region (from to flag)
 173   "Hides or shows lines from FROM to TO, according to FLAG.
 174 If FLAG is \\n (newline character) then text is shown, while if FLAG
 175 is \\^M \(control-M) the text is hidden."
 176   (let ((modp (buffer-modified-p))
 177         buffer-read-only)               ; nothing is immune
 178     (unwind-protect (progn
 179                       (subst-char-in-region
 180                        from to
 181                        (if (= flag ?\n) ?\C-m ?\n)
 182                        flag t))
 183       (set-buffer-modified-p modp))))
 184
 185 (defun hs-hide-block-at-point (&optional end)
 186   "Hide block iff on block beginning, optional END means reposition at end."
 187   (if (looking-at hs-block-start-regexp)
 188       (let* ((p (point))
 189              (q (progn (funcall hs-forward-sexp-func 1) (point))))
 190         (forward-line -1) (end-of-line)
 191         (if (and (< p (point)) (> (count-lines p q) 1))
 192             (hs-flag-region p (point) ?\C-m))
 193         (goto-char (if end q p)))))
 194
 195 (defun hs-show-block-at-point (&optional end)
 196   "Show block iff on block beginning.  Optional END means reposition at end."
 197   (if (looking-at hs-block-start-regexp)
 198       (let* ((p (point))
 199              (q
 200               (condition-case error     ; probably unbalanced paren
 201                   (progn
 202                     (funcall hs-forward-sexp-func 1)
 203                     (point))
 204                 (error
 205                  (cond
 206                   ((eq hs-unbalance-handler-method 'ignore)
 207                    ;; just ignore this block
 208                    (point))
 209                   ((eq hs-unbalance-handler-method 'top-level)
 210                    ;; try to get out of rat's nest and expose the whole func
 211                    (if (/= (current-column) 0) (beginning-of-defun))
 212                    (setq p (point))
 213                    (re-search-forward (concat "^" hs-block-start-regexp)
 214                                       (point-max) t 2)
 215                    (point))
 216                   ((eq hs-unbalance-handler-method 'next-line)
 217                    ;; assumption is that user knows what s/he's doing
 218                    (beginning-of-line) (setq p (point))
 219                    (end-of-line 2) (point))
 220                   (t
 221                    ;; pass error through -- this applies to `signal', too
 222                    (signal (car error) (cdr error))))))))
 223         (hs-flag-region p q ?\n)
 224         (goto-char (if end (1+ (point)) p)))))
 225
 226 (defun hs-safety-is-job-n ()
 227   "Warns if selective-display or selective-display-ellipses is nil."
 228   (let ((str ""))
 229     (or selective-display
 230         (setq str "selective-display nil "))
 231     (or selective-display-ellipses
 232         (setq str (concat str "selective-display-ellipses nil")))
 233     (if (= (length str) 0)
 234         nil
 235       (message "warning: %s" str)
 236       (sit-for 2))))
 237
 238 (defun hs-inside-comment-p ()
 239   "Returns non-nil if point is inside a comment, otherwise nil.
 240 Actually, for multi-line-able comments, returns a list containing
 241 the buffer position of the start and the end of the comment."
 242   ;; is it single-line-only or multi-line-able?
 243   (save-excursion
 244     (let ((p (point))
 245           q)
 246       (if (string= comment-end "")      ; single line
 247           (let (found)
 248             (beginning-of-line)
 249             (setq found (re-search-forward hs-c-start-regexp p t))
 250             (and found (not (search-forward "\"" p t))))
 251         (re-search-forward hs-c-end-regexp (point-max) 1)
 252         (setq q (point))
 253         (forward-comment -1)
 254         (re-search-forward hs-c-start-regexp (point-max) 1)
 255         (if (< (- (point) (length comment-start)) p)
 256             (list (match-beginning 0) q))))))
 257
 258 (defun hs-grok-mode-type ()
 259   "Setup variables for new buffers where applicable."
 260   (if (and (boundp 'comment-start)
 261            (boundp 'comment-end))
 262       (progn
 263         (setq hs-c-start-regexp (regexp-quote comment-start))
 264         (if (string-match " +$" hs-c-start-regexp)
 265             (setq hs-c-start-regexp
 266                   (substring hs-c-start-regexp 0 (1- (match-end 0)))))
 267         (setq hs-c-end-regexp (if (string= "" comment-end) "\n"
 268                                 (regexp-quote comment-end)))
 269         (if (string-match "^ +" hs-c-end-regexp)
 270             (setq hs-c-end-regexp
 271                   (substring hs-c-end-regexp (match-end 0))))
 272         (let ((lookup (assoc major-mode hs-special-modes-alist)))
 273           (setq hs-block-start-regexp (or (nth 1 lookup) "\\s\(")
 274                 hs-block-end-regexp (or (nth 2 lookup) "\\s\)")
 275                 hs-forward-sexp-func (or (nth 3 lookup) 'forward-sexp))))))
 276
 277 (defun hs-find-block-beginning ()
 278   "Repositions point at block-start.  Return point, or nil if top-level."
 279   (let (done
 280         (here (point))
 281         (both-regexps (concat "\\(" hs-block-start-regexp "\\)\\|\\("
 282                               hs-block-end-regexp "\\)")))
 283     (while (and (not done)
 284                 (re-search-backward both-regexps (point-min) t))
 285       (if (match-beginning 1)           ; start of start-regexp
 286           (setq done (match-beginning 1))
 287         (goto-char (match-end 2))       ; end of end-regexp
 288         (funcall hs-forward-sexp-func -1)))
 289     (goto-char (or done here))
 290     done))
 291
 292 (defmacro hs-life-goes-on (&rest body)
 293   "Executes optional BODY iff variable `hs-minor-mode' is non-nil."
 294   (list 'if 'hs-minor-mode (cons 'progn body)))
 295
 296
 297 ;;;----------------------------------------------------------------------------
 298 ;;; commands
 299
 300 ;;;###autoload
 301 (defun hs-hide-all ()
 302   "Hides all top-level blocks, displaying only first and last lines.
 303 When done, point is repositioned at the beginning of the line, and
 304 hs-hide-hooks is called.  See documentation for `run-hooks'."
 305   (interactive)
 306   (hs-life-goes-on
 307    (message "hiding all blocks ...")
 308    (save-excursion
 309      (hs-flag-region (point-min) (point-max) ?\n) ; eliminate weirdness
 310      (goto-char (point-min))
 311      (let ((count 0)
 312            (top-level-re (concat "^" hs-block-start-regexp)))
 313        (while (progn
 314                 (forward-comment (buffer-size))
 315                 (re-search-forward top-level-re (point-max) t))
 316          (goto-char (match-beginning 0))
 317          (hs-hide-block-at-point t)
 318          (message "hiding ... %d" (setq count (1+ count)))))
 319      (hs-safety-is-job-n))
 320    (beginning-of-line)
 321    (message "hiding all blocks ... done")
 322    (run-hooks 'hs-hide-hooks)))
 323
 324 (defun hs-show-all ()
 325   "Shows all top-level blocks.
 326 When done, point is unchanged, and hs-show-hooks is called.  See
 327 documentation for `run-hooks'."
 328   (interactive)
 329   (hs-life-goes-on
 330    (message "showing all blocks ...")
 331    (hs-flag-region (point-min) (point-max) ?\n)
 332    (message "showing all blocks ... done")
 333    (run-hooks 'hs-show-hooks)))
 334
 335 ;;;###autoload
 336 (defun hs-hide-block (&optional end)
 337   "Selects a block and hides it.  With prefix arg, reposition at end.
 338 Block is defined as a sexp for lispish modes, mode-specific otherwise.
 339 Comments are blocks, too.  Upon completion, point is at repositioned and
 340 hs-hide-hooks is called.  See documentation for `run-hooks'."
 341   (interactive "P")
 342   (hs-life-goes-on
 343    (let ((c-reg (hs-inside-comment-p)))
 344      (if c-reg
 345          (cond ((string= comment-end "")
 346                 (message "can't hide a single-line comment"))
 347                ((< (count-lines (car c-reg) (nth 1 c-reg)) 2)
 348                 (message "not enougn comment lines to hide"))
 349                (t
 350                 (goto-char (nth 1 c-reg))
 351                 (forward-line -1)
 352                 (hs-flag-region (car c-reg) (point) ?\C-m)
 353                 (goto-char (if end (nth 1 c-reg) (car c-reg)))
 354                 (hs-safety-is-job-n)
 355                 (run-hooks 'hs-hide-hooks)))
 356        (if (or (looking-at hs-block-start-regexp)
 357                (hs-find-block-beginning))
 358            (progn
 359              (hs-hide-block-at-point end)
 360              (hs-safety-is-job-n)
 361              (run-hooks 'hs-hide-hooks)))))))
 362
 363 (defun hs-show-block (&optional end)
 364   "Selects a block and shows it.  With prefix arg, reposition at end.
 365 Upon completion, point is repositioned hs-show-hooks are called.  See
 366 documetation for `hs-hide-block' and `run-hooks'."
 367   (interactive "P")
 368   (hs-life-goes-on
 369    (let ((c-reg (hs-inside-comment-p)))
 370      (if c-reg
 371          (cond ((string= comment-end "")
 372                 (message "already looking at the entire comment"))
 373                (t
 374                 (hs-flag-region (car c-reg) (nth 1 c-reg) ?\n)
 375                 (goto-char (if end (nth 1 c-reg) (car c-reg)))))
 376        (if (or (looking-at hs-block-start-regexp)
 377                (hs-find-block-beginning))
 378            (progn
 379              (hs-show-block-at-point end)
 380              (hs-safety-is-job-n)
 381              (run-hooks 'hs-show-hooks)))))))
 382
 383 (defun hs-show-region (beg end)
 384   "Shows all lines from BEG to END, without doing any block analysis.
 385 Note: hs-show-region is intended for use when when hs-show-block signals
 386 `unbalanced parentheses' and so is an emergency measure only.  You may
 387 become very confused if you use this command indiscriminately."
 388   (interactive "r")
 389   (hs-life-goes-on
 390    (hs-flag-region beg end ?\n)
 391    (hs-safety-is-job-n)
 392    (run-hooks 'hs-show-hooks)))
 393
 394 ;;;###autoload
 395 (defun hs-minor-mode (&optional arg)
 396   "Toggle hideshow minor mode.
 397 With ARG, turn hideshow minor mode on if ARG is positive, off otherwise.
 398 When hideshow minor mode is on, the menu bar is augmented with hideshow
 399 commands and the hideshow commands are enabled.  The variables\n
 400 \tselective-display\n\tselective-display-ellipses\n
 401 are set to t.  Lastly, the hooks set in hs-minor-mode-hook are called.
 402 See documentation for `run-hooks'.\n
 403 Turning hideshow minor mode off reverts the menu bar and the
 404 variables to default values and disables the hideshow commands."
 405   (interactive "P")
 406   (setq hs-minor-mode
 407         (if (null arg)
 408             (not hs-minor-mode)
 409           (> (prefix-numeric-value arg) 0)))
 410   (if hs-minor-mode
 411       (progn
 412         (if (eq hs-emacs-type 'lucid)
 413             (progn
 414               (set-buffer-menubar (copy-sequence current-menubar))
 415               (add-menu nil (car hs-menu-bar) (cdr hs-menu-bar))))
 416         (setq selective-display t
 417               selective-display-ellipses t)
 418         (hs-grok-mode-type)
 419         (run-hooks 'hs-minor-mode-hook))
 420     (if (eq hs-emacs-type 'lucid)
 421         (set-buffer-menubar (delete hs-menu-bar current-menubar)))
 422     (kill-local-variable 'selective-display)
 423     (kill-local-variable 'selective-display-ellipses)))
 424
 425
 426 ;;;----------------------------------------------------------------------------
 427 ;;; load-time setup routines
 428
 429 ;; which emacs being used?
 430 (setq hs-emacs-type
 431       (if (string-match "xemacs\\|lucid" emacs-version)
 432           'lucid
 433         'fsf))
 434
 435 ;; keymaps and menus
 436 (if (not hs-minor-mode-map)
 437   (setq hs-minor-mode-map (make-sparse-keymap))
 438   (cond
 439    ((eq hs-emacs-type 'lucid)
 440     (setq hs-menu-bar                   ; build top down for lucid
 441           '("hideshow"
 442             ["Hide Block" hs-hide-block t]
 443             ["Show Block" hs-show-block t]
 444             ["Hide All" hs-hide-all t]
 445             ["Show All" hs-show-all t]
 446             ["Show Region" hs-show-region t])))
 447    (t                                   ; build bottom up for others
 448     (define-key hs-minor-mode-map [menu-bar hideshow]
 449       (cons "hideshow" (make-sparse-keymap "hideshow")))
 450     (define-key hs-minor-mode-map [menu-bar hideshow hs-show-region]
 451       '("Show Region" . hs-show-region))
 452     (define-key hs-minor-mode-map [menu-bar hideshow hs-show-all]
 453       '("Show All" . hs-show-all))
 454     (define-key hs-minor-mode-map [menu-bar hideshow hs-hide-all]
 455       '("Hide All" . hs-hide-all))
 456     (define-key hs-minor-mode-map [menu-bar hideshow hs-show-block]
 457       '("Show Block" . hs-show-block))
 458     (define-key hs-minor-mode-map [menu-bar hideshow hs-hide-block]
 459       '("Hide Block" . hs-hide-block)))))
 460
 461 ;; some housekeeping
 462 (or (assq 'hs-minor-mode minor-mode-map-alist)
 463     (setq minor-mode-map-alist
 464           (cons (cons 'hs-minor-mode hs-minor-mode-map)
 465                 minor-mode-map-alist)))
 466 (or (assq 'hs-minor-mode minor-mode-alist)
 467     (setq minor-mode-alist (append minor-mode-alist
 468                                    (list '(hs-minor-mode " hs")))))
 469
 470 ;; make some variables buffer-local
 471 (make-variable-buffer-local 'hs-minor-mode)
 472 (make-variable-buffer-local 'hs-c-start-regexp)
 473 (make-variable-buffer-local 'hs-c-end-regexp)
 474 (make-variable-buffer-local 'hs-block-start-regexp)
 475 (make-variable-buffer-local 'hs-block-end-regexp)
 476 (make-variable-buffer-local 'hs-forward-sexp-func)
 477 (put 'hs-minor-mode 'permanent-local t)
 478 (put 'hs-c-start-regexp 'permanent-local t)
 479 (put 'hs-c-end-regexp 'permanent-local t)
 480 (put 'hs-block-start-regexp 'permanent-local t)
 481 (put 'hs-block-end-regexp 'permanent-local t)
 482 (put 'hs-forward-sexp-func 'permanent-local t)
 483
 484
 485 ;;;----------------------------------------------------------------------------
 486 ;;; that's it
 487
 488 (provide 'hideshow)
 489
 490 ;;; hideshow.el ends here