code.delx.au - gnu-emacs/blob - lisp/progmodes/hideshow.el

   1 ;;; hideshow.el --- minor mode cmds to selectively display blocks of code
   2
   3 ;; Copyright (C) 1994,1995,1996,1997 Free Software Foundation
   4
   5 ;; Author: Thien-Thi Nguyen <ttn@netcom.com>
   6 ;; Maintainer: Dan Nicolaescu <done@ece.arizona.edu>
   7 ;; Version: 4.0
   8 ;; Keywords: C C++ java lisp tools editing comments blocks hiding outlines
   9 ;; Time-of-Day-Author-Most-Likely-to-be-Recalcitrant: early morning
  10
  11 ;; This file is part of GNU Emacs.
  12
  13 ;; GNU Emacs is free software; you can redistribute it and/or modify
  14 ;; it under the terms of the GNU General Public License as published by
  15 ;; the Free Software Foundation; either version 2, or (at your option)
  16 ;; any later version.
  17
  18 ;; GNU Emacs is distributed in the hope that it will be useful,
  19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21 ;; GNU General Public License for more details.
  22
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  25 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  26 ;; Boston, MA 02111-1307, USA.
  27
  28 ;; LCD Archive Entry:
  29 ;; hideshow|Thien-Thi Nguyen|ttn@netcom.com|
  30 ;; minor mode commands to selectively display blocks of code|
  31 ;; 18-Oct-1994|3.4|~/modes/hideshow.el.Z|
  32
  33 ;;; Commentary:
  34
  35 ;; This file provides `hs-minor-mode'.  When active, six commands:
  36 ;;   hs-{hide,show}-{all,block}, hs-show-region and hs-minor-mode
  37 ;; are available.  They implement block hiding and showing.  Blocks are
  38 ;; defined in mode-specific way.  In c-mode or c++-mode, they are simply
  39 ;; curly braces, while in lisp-ish modes they are parens.  Multi-line
  40 ;; comments (c-mode) can also be hidden.  The command M-x hs-minor-mode
  41 ;; toggles the minor mode or sets it (similar to outline minor mode).
  42 ;; See documentation for each command for more info.
  43 ;;
  44 ;; The variable `hs-unbalance-handler-method' controls hideshow's behavior
  45 ;; in the case of "unbalanced parentheses".  See doc for more info.
  46
  47 ;; Suggested usage:
  48
  49 ;; (load-library "hideshow")
  50 ;; (add-hook 'X-mode-hook 'hs-minor-mode)   ; other modes similarly
  51 ;;
  52 ;; where X = {emacs-lisp,c,c++,perl,...}.  See the doc for the variable
  53 ;; `hs-special-modes-alist' if you'd like to use hideshow w/ other modes.
  54
  55 ;; Etc:
  56
  57 ;; Bug reports and fixes welcome (comments, too).  Thanks go to
  58 ;;      Dean Andrews <adahome@ix.netcom.com>
  59 ;;      Preston F. Crow <preston.f.crow@dartmouth.edu>
  60 ;;      Gael Marziou <gael@gnlab030.grenoble.hp.com>
  61 ;;      Keith Sheffield <sheff@edcsgw2.cr.usgs.gov>
  62 ;;      Jan Djarv <jan.djarv@sa.erisoft.se>
  63 ;;      Lars Lindberg <qhslali@aom.ericsson.se>
  64 ;;      Alf-Ivar Holm <alfh@ifi.uio.no>
  65 ;; for valuable feedback, code and bug reports.
  66
  67 ;;; Code:
  68
  69
  70 ;;;----------------------------------------------------------------------------
  71 ;;; user-configurable variables
  72
  73 (defgroup hideshow nil
  74   "Minor mode for hiding and showing program and comment blocks."
  75   :prefix "hs-"
  76   :group 'languages)
  77
  78 ;;;#autoload
  79 (defcustom hs-hide-comments-when-hiding-all t
  80   "Hide the comments too when you do an `hs-hide-all'."
  81   :type 'boolean
  82   :group 'hideshow)
  83
  84 ;;;#autoload
  85 (defcustom hs-show-hidden-short-form t
  86   "Leave only the first line visible in a hidden block.
  87 If t only the first line is visible when a block is in the hidden state,
  88 else both the first line and the last line are showed. Also if t and
  89 `hs-adjust-block-beginning' is set, it is used also.
  90
  91 An example of how this works: (in c-mode)
  92 original:
  93
  94 /* My function main
  95    some more stuff about main
  96 */
  97 int
  98 main(void)
  99 {
 100   int x=0;
 101   return 0;
 102 }
 103
 104
 105 hidden and hs-show-hidden-short-form is nil
 106 /* My function main...
 107 */
 108 int
 109 main(void)
 110 {...
 111 }
 112
 113 hidden and hs-show-hidden-short-form is t
 114 /* My function main...
 115 int
 116 main(void)...
 117
 118 For latest you have to be on the line containing the ellipsis when
 119 you do `hs-show-block'."
 120   :type 'boolean
 121   :group 'hideshow)
 122
 123 (defcustom hs-minor-mode-hook 'hs-hide-initial-comment-block
 124   "Hook called when `hs-minor-mode' is installed.
 125 A good value for this would be `hs-hide-initial-comment-block' to
 126 hide all the comments at the beginning of the file."
 127   :type 'integer
 128   :group 'hideshow)
 129
 130 (defcustom hs-isearch-open 'block
 131 "What kind of hidden blocks to open when doing `isearch'.
 132 It can have the following values:
 133     `block'     open only  blocks
 134     `comment'   open only comments
 135     t           open all of them
 136     nil         don't open any.
 137 This only has effect iff `search-invisible' is set to `open'."
 138   :type '(choice (const :tag "open only  blocks" block)
 139                  (const :tag "open only comments" comment)
 140                  (const :tag "open both blocks and comments" t)
 141                  (const :tag "don't open any of them" nil))
 142   :group 'hideshow)
 143
 144 (defvar hs-unbalance-handler-method 'top-level
 145   "*Symbol representing how \"unbalanced parentheses\" should be handled.
 146 This error is usually signaled by `hs-show-block'.  One of four values:
 147 `top-level', `next-line', `signal' or `ignore'.  Default is `top-level'.
 148
 149 - `top-level' -- Show top-level block containing the currently troublesome
 150                  block.
 151 - `next-line' -- Use the fact that, for an already hidden block, its end
 152                  will be on the next line.  Attempt to show this block.
 153 - `signal' -- Pass the error through, stopping execution.
 154 - `ignore' -- Ignore the error, continuing execution.
 155
 156 Values other than these four will be interpreted as `signal'.")
 157
 158 ;;;#autoload
 159 (defvar hs-special-modes-alist
 160   '((c-mode "{" "}" nil nil hs-c-like-adjust-block-beginning)
 161     (c++-mode "{" "}" "/[*/]" nil hs-c-like-adjust-block-beginning)
 162     (java-mode   "\\(\\(\\([ \t]*\\(\\(public\\|private\\|protected\\|abstract\\|static\\|\\final\\)[ \t\n]+\\)+\\(synchronized[ \t\n]*\\)?[a-zA-Z0-9_:]+[ \t\n]*\\(\\[[ \t\n]*\\][ \t\n]*\\)?\\([a-zA-Z0-9_:]+[ \t\n]*\\)([^)]*)\\([ \n\t]+throws[ \t\n][^{]+\\)?\\)\\|\\([ \t]*static[^{]*\\)\\)[ \t\n]*{\\)"  "}"  "/[*/]" java-hs-forward-sexp hs-c-like-adjust-block-beginning))
 163 ; I tested the java regexp using the following:
 164 ;(defvar hsj-public)
 165 ;(defvar hsj-syncronised)
 166 ;(defvar hsj-type)
 167 ;(defvar hsj-fname)
 168 ;(defvar hsj-par)
 169 ;(defvar hsj-throws)
 170 ;(defvar hsj-static)
 171
 172 ;(setq hsj-public "[ \t]*\\(\\(public\\|private\\|protected\\|abstract\\|static\\|\\final\\)[ \t\n]+\\)+")
 173 ;(setq hsj-syncronised "\\(synchronized[ \t\n]*\\)?")
 174 ;(setq hsj-type "[a-zA-Z0-9_:]+[ \t\n]*\\(\\[[ \t\n]*\\][ \t\n]*\\)?")
 175 ;(setq hsj-fname "\\([a-zA-Z0-9_:]+[ \t\n]*\\)")
 176 ;(setq hsj-par "([^)]*)")
 177 ;(setq hsj-throws "\\([ \n\t]+throws[ \t\n][^{]+\\)?")
 178
 179 ;(setq hsj-static "[ \t]*static[^{]*")
 180
 181
 182 ;(setq hs-block-start-regexp (concat
 183 ;                            "\\("
 184 ;                                "\\("
 185 ;                                     "\\("
 186 ;                                        hsj-public
 187 ;                                        hsj-syncronised
 188 ;                                        hsj-type
 189 ;                                        hsj-fname
 190 ;                                        hsj-par
 191 ;                                        hsj-throws
 192 ;                                     "\\)"
 193 ;                                     "\\|"
 194 ;                                     "\\("
 195 ;                                        hsj-static
 196 ;                                     "\\)"
 197 ;                                "\\)"
 198 ;                                   "[ \t\n]*{"
 199 ;                             "\\)"
 200 ;                                   ))
 201
 202   "*Alist for initializing the hideshow variables for different modes.
 203 It has the form
 204 (MODE START-RE END-RE COMMENT-START-RE FORWARD-SEXP-FUNC ADJUST-BEG-FUNC).
 205 If present, hideshow will use these values for the start and end regexps,
 206 respectively.  Since Algol-ish languages do not have single-character
 207 block delimiters, the function `forward-sexp' which is used by hideshow
 208 doesn't work.  In this case, if a similar function is provided, you can
 209 register it and have hideshow use it instead of `forward-sexp'.  To add
 210 more values, use
 211
 212 \t(pushnew '(new-mode st-re end-re function-name)
 213 \t      hs-special-modes-alist :test 'equal)
 214
 215 For example:
 216
 217 \t(pushnew '(simula-mode \"begin\" \"end\" \"!\" simula-next-statement)
 218 \t      hs-special-modes-alist :test 'equal)
 219
 220 See the documentation for `hs-adjust-block-beginning' to see what
 221 is the use of ADJUST-BEG-FUNC.
 222
 223 If any of those is left nil, hideshow will try to guess some values, see
 224 `hs-grok-mode-type' for this.
 225
 226 Note that the regexps should not contain leading or trailing whitespace.")
 227
 228 (defvar hs-hide-hook nil
 229   "*Hooks called at the end of `hs-hide-all' and `hs-hide-block'.")
 230
 231 (defvar hs-show-hook nil
 232   "*Hooks called at the end of commands to show text.
 233 These commands include `hs-show-all', `hs-show-block' and `hs-show-region'.")
 234
 235 (defvar hs-minor-mode-prefix "\C-c"
 236   "*Prefix key to use for hideshow commands in hideshow minor mode.")
 237
 238 ;;;----------------------------------------------------------------------------
 239 ;;; internal variables
 240
 241 (defvar hs-minor-mode nil
 242   "Non-nil if using hideshow mode as a minor mode of some other mode.
 243 Use the command `hs-minor-mode' to toggle this variable.")
 244
 245 (defvar hs-minor-mode-map nil
 246   "Mode map for hideshow minor mode.")
 247
 248 ;(defvar hs-menu-bar nil
 249 ;  "Menu bar for hideshow minor mode (Xemacs only).")
 250
 251 (defvar hs-c-start-regexp nil
 252   "Regexp for beginning of comments.
 253 Differs from mode-specific comment regexps in that
 254 surrounding whitespace is stripped.")
 255
 256 (defvar hs-block-start-regexp nil
 257   "Regexp for beginning of block.")
 258
 259 (defvar hs-block-end-regexp nil
 260   "Regexp for end of block.")
 261
 262 (defvar hs-forward-sexp-func 'forward-sexp
 263   "Function used to do a forward-sexp.
 264 Should change for Algol-ish modes.  For single-character block
 265 delimiters -- ie, the syntax table regexp for the character is
 266 either `(' or `)' -- `hs-forward-sexp-func' would just be `forward-sexp'.
 267 For other modes such as simula, a more specialized function
 268 is necessary.")
 269
 270 (defvar hs-adjust-block-beginning nil
 271   "Function used to tweak the block beginning.
 272 It has effect only if `hs-show-hidden-short-form' is t. The block it
 273 is hidden from the point returned by this function, as opposed to
 274 hiding it from the point returned when searching
 275 `hs-block-start-regexp'.  In c-like modes, if we wish to also hide the
 276 curly braces (if you think they occupy too much space on the screen),
 277 this function should return the starting point (at the end of line) of
 278 the hidden region.
 279
 280 It is called with a single argument ARG which is the the position in
 281 buffer after the block beginning.
 282
 283 It should return the position from where we should start hiding.
 284
 285 It should not move the point.
 286
 287 See `hs-c-like-adjust-block-beginning' for an example of using this.")
 288
 289 ;(defvar hs-emacs-type 'fsf
 290 ;  "Used to support both Emacs and Xemacs.")
 291
 292 ;(eval-when-compile
 293 ;  (if (string-match "xemacs\\|lucid" emacs-version)
 294 ;      (progn
 295 ;       (defvar current-menubar nil "")
 296 ;       (defun set-buffer-menubar (arg1))
 297 ;       (defun add-menu (arg1 arg2 arg3)))))
 298
 299 ;;;----------------------------------------------------------------------------
 300 ;;; support funcs
 301
 302 ;; snarfed from outline.el;
 303 (defun hs-flag-region (from to flag)
 304   "Hides or shows lines from FROM to TO, according to FLAG.  If FLAG
 305 is nil then text is shown, while if FLAG is non-nil the text is
 306 hidden. Actualy flag is realy either `comment' or `block' depending on
 307 what kind of block it is suppose to hide."
 308     (save-excursion
 309       (goto-char from)
 310       (end-of-line)
 311       (hs-discard-overlays (point) to 'invisible 'hs)
 312       (if flag
 313           (let ((overlay (make-overlay (point) to)))
 314             ;; Make overlay hidden and intangible.
 315             (overlay-put overlay 'invisible 'hs)
 316             (overlay-put overlay 'hs t)
 317             (when (or (eq hs-isearch-open t) (eq hs-isearch-open flag))
 318                 (overlay-put overlay 'isearch-open-invisible
 319                              'hs-isearch-open-invisible))
 320             (overlay-put overlay 'intangible t)))))
 321
 322 ;; This is set as an `isearch-open-invisible' property to hidden
 323 ;; overlays.
 324 (defun hs-isearch-open-invisible (ov)
 325   (save-excursion
 326     (goto-char (overlay-start ov))
 327     (hs-show-block)))
 328
 329 ;; Remove from the region BEG ... END all overlays
 330 ;; with a PROP property equal to VALUE.
 331 ;; Overlays with a PROP property different from VALUE are not touched.
 332 (defun hs-discard-overlays (beg end prop value)
 333   (if (< end beg)
 334       (setq beg (prog1 end (setq end beg))))
 335   (save-excursion
 336     (goto-char beg)
 337     (let ((overlays (overlays-in beg end))
 338           o)
 339       (while overlays
 340         (setq o (car overlays))
 341         (if (eq (overlay-get o prop) value)
 342             (delete-overlay o))
 343           (setq overlays (cdr overlays))))))
 344
 345 (defun hs-hide-block-at-point (&optional end comment-reg)
 346   "Hide block iff on block beginning, optional END means reposition at end.
 347 COMMENT-REG is a list of the form (BEGIN . END) and specifies the limits
 348 of the comment, or nil if the block is not a comment."
 349   (if comment-reg
 350       (progn
 351         ;; goto the end of line at the end of the comment
 352         (goto-char (nth 1 comment-reg))
 353         (unless hs-show-hidden-short-form (forward-line -1))
 354         (end-of-line)
 355         (hs-flag-region (car comment-reg)  (point) 'comment)
 356         (goto-char (if end (nth 1 comment-reg) (car comment-reg))))
 357       (if (looking-at hs-block-start-regexp)
 358           (let* ((p ;; p is the point at the end of the block beginning
 359                   (if (and  hs-show-hidden-short-form
 360                             hs-adjust-block-beginning)
 361                       ;; we need to adjust the block beginning
 362                       (funcall hs-adjust-block-beginning (match-end 0))
 363                     (match-end 0)))
 364                  ;; q is the point at the end of the block
 365                  (q (progn (funcall hs-forward-sexp-func 1) (point))))
 366             ;; position the point so we can call `hs-flag-region'
 367             (unless hs-show-hidden-short-form (forward-line -1))
 368             (end-of-line)
 369             (if (and (< p (point)) (> (count-lines p q)
 370                                       (if hs-show-hidden-short-form 1 2)))
 371                 (hs-flag-region p (point) 'block))
 372             (goto-char (if end q p))))))
 373
 374 (defun hs-show-block-at-point (&optional end comment-reg)
 375   "Show block iff on block beginning.  Optional END means reposition at end.
 376 COMMENT-REG is a list of the forme (BEGIN . END) and specifies the limits
 377 of the comment. It should be nil when hiding a block."
 378   (if comment-reg
 379       (when (car comment-reg)
 380         (hs-flag-region (car comment-reg) (nth 1 comment-reg) nil)
 381         (goto-char (if end (nth 1 comment-reg) (car comment-reg))))
 382     (if (looking-at hs-block-start-regexp)
 383         (let* ((p (point))
 384                (q
 385                 (condition-case error   ; probably unbalanced paren
 386                     (progn
 387                       (funcall hs-forward-sexp-func 1)
 388                       (point))
 389                   (error
 390                    (cond
 391                     ((eq hs-unbalance-handler-method 'ignore)
 392                      ;; just ignore this block
 393                      (point))
 394                     ((eq hs-unbalance-handler-method 'top-level)
 395                      ;; try to get out of rat's nest and expose the whole func
 396                      (if (/= (current-column) 0) (beginning-of-defun))
 397                      (setq p (point))
 398                      (re-search-forward (concat "^" hs-block-start-regexp)
 399                                         (point-max) t 2)
 400                      (point))
 401                     ((eq hs-unbalance-handler-method 'next-line)
 402                      ;; assumption is that user knows what s/he's doing
 403                      (beginning-of-line) (setq p (point))
 404                      (end-of-line 2) (point))
 405                     (t
 406                      ;; pass error through -- this applies to `signal', too
 407                      (signal (car error) (cdr error))))))))
 408           (hs-flag-region p q nil)
 409           (goto-char (if end (1+ (point)) p))))))
 410
 411 (defun hs-safety-is-job-n ()
 412   "Warn `buffer-invisibility-spec' does not contain hs."
 413     (if (or buffer-invisibility-spec (assq 'hs buffer-invisibility-spec) )
 414         nil
 415       (message "Warning: `buffer-invisibility-spec' does not contain hs!!")
 416       (sit-for 2)))
 417
 418 (defun hs-hide-initial-comment-block ()
 419   (interactive)
 420   "Hides the first block of comments in a file.
 421 The best usage is in `hs-minor-mode-hook', it hides all the comments at the
 422 file beginning, so if you have huge RCS logs you won't see them!"
 423       (let ((p (point))
 424             c-reg)
 425         (goto-char (point-min))
 426         (skip-chars-forward " \t\n^L")
 427         (setq c-reg (hs-inside-comment-p))
 428         ;; see if we have enough comment lines to hide
 429         (if (and c-reg (> (count-lines (car c-reg) (nth 1 c-reg))
 430                           (if hs-show-hidden-short-form 1 2)))
 431             (hs-hide-block)
 432           (goto-char p))))
 433
 434 (defun hs-inside-comment-p ()
 435   "Returns non-nil if point is inside a comment, otherwise nil.
 436 Actually, returns a list containing the buffer position of the start
 437 and the end of the comment. A comment block can be hided only if on its
 438 starting line there are only white spaces preceding the actual comment
 439 beginning, if we are inside of a comment but this condition is not
 440 we return a list having a nil as its car and the end of comment position
 441 as cdr."
 442   (save-excursion
 443     ;; the idea is to look backwards for a comment start regexp, do a
 444     ;; forward comment, and see if we are inside, then extend extend
 445     ;; forward and backward as long as we have comments
 446     (let ((q (point)))
 447       (when (or (looking-at hs-c-start-regexp)
 448               (re-search-backward hs-c-start-regexp (point-min) t))
 449         (forward-comment (- (buffer-size)))
 450         (skip-chars-forward " \t\n\f")
 451         (let ((p (point))
 452               (not-hidable nil))
 453           (beginning-of-line)
 454           (unless (looking-at (concat "[ \t]*" hs-c-start-regexp))
 455             ;; we are in this situation: (example)
 456             ;; (defun bar ()
 457             ;;      (foo)
 458             ;;                ) ; comment
 459             ;;                 ^
 460             ;;   the point was here before doing (beginning-of-line)
 461             ;; here we should advance till the next comment which
 462             ;; eventually has only white spaces preceding it on the same
 463             ;; line
 464             (goto-char p)
 465             (forward-comment 1)
 466             (skip-chars-forward " \t\n\f")
 467             (setq p (point))
 468             (while (and (< (point) q)
 469                         (> (point) p)
 470                         (not (looking-at hs-c-start-regexp)))
 471               (setq p (point))  ;; use this to avoid an infinit cycle.
 472               (forward-comment 1)
 473               (skip-chars-forward " \t\n\f"))
 474             (if (or (not (looking-at hs-c-start-regexp))
 475                     (> (point) q))
 476                 ;; we cannot hide this comment block
 477                 (setq not-hidable t)))
 478           ;; goto the end of the comment
 479           (forward-comment (buffer-size))
 480           (skip-chars-backward " \t\n\f")
 481           (end-of-line)
 482           (if (>= (point) q)
 483               (list (if not-hidable nil p) (point))))))))
 484
 485 (defun hs-grok-mode-type ()
 486   "Setup variables for new buffers where applicable."
 487   (when (and (boundp 'comment-start)
 488              (boundp 'comment-end))
 489     (let ((lookup (assoc major-mode hs-special-modes-alist)))
 490       (setq hs-block-start-regexp (or (nth 1 lookup) "\\s\(")
 491             hs-block-end-regexp (or (nth 2 lookup) "\\s\)")
 492             hs-c-start-regexp (or (nth 3 lookup)
 493                                   (let ((c-start-regexp
 494                                          (regexp-quote comment-start)))
 495                                     (if (string-match " +$" c-start-regexp)
 496                                          (substring c-start-regexp 0 (1- (match-end 0)))
 497                                       c-start-regexp)))
 498             hs-forward-sexp-func (or (nth 4 lookup) 'forward-sexp)
 499             hs-adjust-block-beginning (nth 5 lookup)))))
 500
 501 (defun hs-find-block-beginning ()
 502   "Repositions point at block-start.
 503 Return point, or nil if top-level."
 504   (let (done
 505         (try-again t)
 506         (here (point))
 507         (both-regexps (concat "\\(" hs-block-start-regexp "\\)\\|\\("
 508                               hs-block-end-regexp "\\)"))
 509         (buf-size (buffer-size)))
 510     (beginning-of-line)
 511     ;; A block beginning can span on multiple lines, if the point
 512     ;; is on one of those lines, trying a regexp search from
 513     ;; that point would fail to find the block beginning, so we look
 514     ;; backwards for the block beginning, or a block end.
 515     (while try-again
 516       (setq try-again nil)
 517       (if (and (re-search-backward both-regexps (point-min) t)
 518                (match-beginning 1)) ; found a block beginning
 519           (if (save-match-data (hs-inside-comment-p))
 520               ;;but it was inside a comment, so we have to look for
 521               ;;it again
 522               (setq try-again t)
 523             ;; that's what we were looking for
 524             (setq done (match-beginning 0)))
 525         ;; we found a block end, or we reached the beginning of the
 526         ;; buffer look to see if we were on a block beginning when we
 527         ;; started
 528         (if (and
 529              (re-search-forward hs-block-start-regexp (point-max) t)
 530              (or
 531               (and (>= here (match-beginning 0)) (< here (match-end 0)))
 532               (and hs-show-hidden-short-form hs-adjust-block-beginning
 533                    (save-match-data
 534                      (= 1 (count-lines
 535                            (funcall hs-adjust-block-beginning
 536                                     (match-end 0)) here))))))
 537               (setq done (match-beginning 0)))))
 538     (goto-char here)
 539     (while (and (not done)
 540                 ;; This had problems because the regexp can match something
 541                 ;; inside of a comment!
 542                 ;; Since inside a comment we can have incomplete sexps
 543                 ;; this would have signaled an error.
 544                 (or (forward-comment (- buf-size)) t); `or' is a hack to
 545                                                          ; make it return t
 546                 (re-search-backward both-regexps (point-min) t))
 547       (if (match-beginning 1)           ; start of start-regexp
 548           (setq done (match-beginning 0))
 549         (goto-char (match-end 0))       ; end of end-regexp
 550         (funcall hs-forward-sexp-func -1)))
 551     (goto-char (or done here))
 552     done))
 553
 554 (defmacro hs-life-goes-on (&rest body)
 555   "Executes optional BODY iff variable `hs-minor-mode' is non-nil."
 556   (list 'if 'hs-minor-mode (cons 'progn body)))
 557
 558 (defun hs-already-hidden-p ()
 559   "Return non-nil if point is in an already-hidden block, otherwise nil."
 560   (save-excursion
 561     (let ((c-reg (hs-inside-comment-p)))
 562       (if (and c-reg (nth 0 c-reg))
 563           ;; point is inside a comment, and that comment is hidable
 564           (goto-char (nth 0 c-reg))
 565         (if (and (not c-reg) (hs-find-block-beginning)
 566                  (looking-at hs-block-start-regexp))
 567             ;; point is inside a block
 568             (goto-char (match-end 0)))))
 569     (end-of-line)
 570     (let ((overlays (overlays-at (point)))
 571           (found nil))
 572       (while (and (not found) (overlayp (car overlays)))
 573            (setq found (overlay-get (car overlays) 'hs)
 574                  overlays (cdr overlays)))
 575       found)))
 576
 577 (defun java-hs-forward-sexp (arg)
 578   "Function used by `hs-minor-mode' for `forward-sexp' in Java mode."
 579   (if (< arg 0)
 580       (backward-sexp 1)
 581     (if (looking-at hs-block-start-regexp)
 582         (progn
 583           (goto-char (match-end 0))
 584           (forward-char -1)
 585           (forward-sexp 1))
 586       (forward-sexp 1))))
 587
 588 (defun hs-c-like-adjust-block-beginning (arg)
 589   "Function to be assigned to `hs-adjust-block-beginning' for C like modes.
 590 Arg is a position in buffer just after {. This goes back to the end of
 591 the function header. The purpose is to save some space on the screen
 592 when displaying hidden blocks."
 593   (save-excursion
 594     (goto-char arg)
 595     (forward-char -1)
 596     (forward-comment (- (buffer-size)))
 597     (point)))
 598
 599 ;;;----------------------------------------------------------------------------
 600 ;;; commands
 601
 602 ;;;###autoload
 603 (defun hs-hide-all ()
 604   "Hides all top-level blocks, displaying only first and last lines.
 605 It moves point to the beginning of the line, and it runs the normal hook
 606 `hs-hide-hook'.  See documentation for `run-hooks'.
 607 If `hs-hide-comments-when-hiding-all' is t also hides the comments."
 608   (interactive)
 609   (hs-life-goes-on
 610    (message "Hiding all blocks ...")
 611    (save-excursion
 612      (hs-flag-region (point-min) (point-max) nil) ; eliminate weirdness
 613      (goto-char (point-min))
 614      (if hs-hide-comments-when-hiding-all
 615          (let (c-reg
 616                (count 0)
 617                (block-and-comment-re  ;; this should match
 618                 (concat "\\(^"        ;; the block beginning and comment start
 619                         hs-block-start-regexp
 620                         "\\)\\|\\(" hs-c-start-regexp "\\)")))
 621            (while (re-search-forward block-and-comment-re (point-max) t)
 622              (if (match-beginning 1) ;; we have found a block beginning
 623                  (progn
 624                    (goto-char (match-beginning 1))
 625                    (hs-hide-block-at-point t)
 626                    (message "Hiding ... %d" (setq count (1+ count))))
 627                ;;found a comment
 628                (setq c-reg (hs-inside-comment-p))
 629                (if (and c-reg (car c-reg))
 630                    (if (> (count-lines (car c-reg) (nth 1 c-reg))
 631                           (if hs-show-hidden-short-form 1 2))
 632                        (progn
 633                          (hs-hide-block-at-point t c-reg)
 634                          (message "Hiding ... %d" (setq count (1+ count))))
 635                      (goto-char (nth 1 c-reg)))))))
 636        (let ((count 0)
 637              (top-level-re (concat "^" hs-block-start-regexp))
 638              (buf-size (buffer-size)))
 639          (while
 640              (progn
 641                (forward-comment buf-size)
 642                (re-search-forward top-level-re (point-max) t))
 643            (goto-char (match-beginning 0))
 644            (hs-hide-block-at-point t)
 645            (message "Hiding ... %d" (setq count (1+ count))))))
 646    (hs-safety-is-job-n))
 647    (beginning-of-line)
 648    (message "Hiding all blocks ... done")
 649    (run-hooks 'hs-hide-hook)))
 650
 651 (defun hs-show-all ()
 652   "Shows all top-level blocks.
 653 This does not change point; it runs the normal hook `hs-show-hook'.
 654 See documentation for `run-hooks'."
 655   (interactive)
 656   (hs-life-goes-on
 657    (message "Showing all blocks ...")
 658    (hs-flag-region (point-min) (point-max) nil)
 659    (message "Showing all blocks ... done")
 660    (run-hooks 'hs-show-hook)))
 661
 662 (defun hs-hide-block (&optional end)
 663   "Selects a block and hides it.
 664 With prefix arg, reposition at end. Block is defined as a sexp for
 665 lispish modes, mode-specific otherwise. Comments are blocks, too.
 666 Upon completion, point is at repositioned and the normal hook
 667 `hs-hide-hook' is run.  See documentation for `run-hooks'."
 668   (interactive "P")
 669   (hs-life-goes-on
 670    (let ((c-reg (hs-inside-comment-p)))
 671      (cond
 672       ((and c-reg (or (null (nth 0 c-reg))
 673                       (<= (count-lines (car c-reg) (nth 1 c-reg))
 674                           (if hs-show-hidden-short-form 1 2))))
 675            (message "Not enough comment lines to hide!"))
 676       ((or c-reg (looking-at hs-block-start-regexp)
 677                (hs-find-block-beginning))
 678        (hs-hide-block-at-point end c-reg)
 679        (hs-safety-is-job-n)
 680        (run-hooks 'hs-hide-hook))))))
 681
 682 (defun hs-show-block (&optional end)
 683   "Selects a block and shows it.
 684 With prefix arg, reposition at end. Upon completion, point is
 685 repositioned and the normal hook `hs-show-hook' is run.
 686 See documentation for `hs-hide-block' and `run-hooks'."
 687   (interactive "P")
 688   (hs-life-goes-on
 689    (let ((c-reg (hs-inside-comment-p)))
 690      (if (or c-reg
 691              (looking-at hs-block-start-regexp)
 692              (hs-find-block-beginning))
 693            (progn
 694              (hs-show-block-at-point end c-reg)
 695              (hs-safety-is-job-n)
 696              (run-hooks 'hs-show-hook))))))
 697
 698 (defun hs-show-region (beg end)
 699   "Shows all lines from BEG to END, without doing any block analysis.
 700 Note:`hs-show-region' is intended for use when `hs-show-block' signals
 701 `unbalanced parentheses' and so is an emergency measure only.  You may
 702 become very confused if you use this command indiscriminately."
 703   (interactive "r")
 704   (hs-life-goes-on
 705    (hs-flag-region beg end nil)
 706    (hs-safety-is-job-n)
 707    (run-hooks 'hs-show-hook)))
 708
 709 ;;;###autoload
 710 (defun hs-mouse-toggle-hiding (e)
 711   "Toggles hiding/showing of a block.
 712 Should be bound to a mouse key."
 713   (interactive "@e")
 714   (mouse-set-point e)
 715   (if (hs-already-hidden-p)
 716       (hs-show-block)
 717     (hs-hide-block)))
 718
 719 ;;;###autoload
 720 (defun hs-minor-mode (&optional arg)
 721   "Toggle hideshow minor mode.
 722 With ARG, turn hideshow minor mode on if ARG is positive, off otherwise.
 723 When hideshow minor mode is on, the menu bar is augmented with hideshow
 724 commands and the hideshow commands are enabled.
 725 The value '(hs . t) is added to `buffer-invisibility-spec'.
 726 Last, the normal hook `hs-minor-mode-hook' is run; see the doc
 727 for `run-hooks'.
 728
 729 The main commands are: `hs-hide-all', `hs-show-all', `hs-hide-block'
 730 and `hs-show-block'.
 731 Also see the documentation for the variable `hs-show-hidden-short-form'.
 732
 733 Turning hideshow minor mode off reverts the menu bar and the
 734 variables to default values and disables the hideshow commands.
 735
 736 Key bindings:
 737 \\{hs-minor-mode-map}"
 738
 739   (interactive "P")
 740   (setq hs-minor-mode
 741         (if (null arg)
 742             (not hs-minor-mode)
 743           (> (prefix-numeric-value arg) 0)))
 744   (if hs-minor-mode
 745       (progn
 746 ;       (if (eq hs-emacs-type 'lucid)
 747 ;           (progn
 748 ;             (set-buffer-menubar (copy-sequence current-menubar))
 749 ;             (add-menu nil (car hs-menu-bar) (cdr hs-menu-bar))))
 750         (make-variable-buffer-local 'line-move-ignore-invisible)
 751         (setq  line-move-ignore-invisible t)
 752         (add-to-invisibility-spec '(hs . t)) ;;hs invisible
 753         (hs-grok-mode-type)
 754         (run-hooks 'hs-minor-mode-hook))
 755 ;    (if (eq hs-emacs-type 'lucid)
 756 ;       (set-buffer-menubar (delete hs-menu-bar current-menubar)))
 757     (remove-from-invisibility-spec '(hs . t))))
 758
 759
 760 ;;;----------------------------------------------------------------------------
 761 ;;; load-time setup routines
 762
 763 ;; which emacs being used?
 764 ;(setq hs-emacs-type
 765 ;      (if (string-match "xemacs\\|lucid" emacs-version)
 766 ;         'lucid
 767 ;       'fsf))
 768
 769 ;; keymaps and menus
 770 (if hs-minor-mode-map
 771     nil
 772   (setq hs-minor-mode-map (make-sparse-keymap))
 773   ;; I beleive there is nothing bound on this keys
 774   (define-key hs-minor-mode-map "\C-ch" 'hs-hide-block)
 775   (define-key hs-minor-mode-map "\C-cs" 'hs-show-block)
 776   (define-key hs-minor-mode-map "\C-cH" 'hs-hide-all)
 777   (define-key hs-minor-mode-map "\C-cS" 'hs-show-all)
 778   (define-key hs-minor-mode-map "\C-cR" 'hs-show-region)
 779
 780   (define-key hs-minor-mode-map [S-mouse-2] 'hs-mouse-toggle-hiding)
 781
 782   ;; should we use easymenu here?
 783   (define-key hs-minor-mode-map [menu-bar Hide/Show]
 784     (cons "Hide/Show" (make-sparse-keymap "Hide/Show")))
 785   (define-key hs-minor-mode-map [menu-bar Hide/Show  hs-show-region]
 786     '("Show Region" . hs-show-region))
 787   (define-key hs-minor-mode-map [menu-bar Hide/Show hs-show-all]
 788     '("Show All" . hs-show-all))
 789   (define-key hs-minor-mode-map [menu-bar Hide/Show hs-hide-all]
 790     '("Hide All" . hs-hide-all))
 791   (define-key hs-minor-mode-map [menu-bar Hide/Show hs-show-block]
 792     '("Show Block" . hs-show-block))
 793   (define-key hs-minor-mode-map [menu-bar Hide/Show hs-hide-block]
 794     '("Hide Block" . hs-hide-block)))
 795
 796 ;; some housekeeping
 797 (or (assq 'hs-minor-mode minor-mode-map-alist)
 798     (setq minor-mode-map-alist
 799           (cons (cons 'hs-minor-mode hs-minor-mode-map)
 800                 minor-mode-map-alist)))
 801 (or (assq 'hs-minor-mode minor-mode-alist)
 802     (setq minor-mode-alist (append minor-mode-alist
 803                                    (list '(hs-minor-mode " hs")))))
 804
 805 ;; make some variables buffer-local
 806 (make-variable-buffer-local 'hs-minor-mode)
 807 (make-variable-buffer-local 'hs-c-start-regexp)
 808 (make-variable-buffer-local 'hs-block-start-regexp)
 809 (make-variable-buffer-local 'hs-block-end-regexp)
 810 (make-variable-buffer-local 'hs-forward-sexp-func)
 811 (make-variable-buffer-local 'hs-adjust-block-beginning)
 812 (put 'hs-minor-mode 'permanent-local t)
 813 (put 'hs-c-start-regexp 'permanent-local t)
 814 (put 'hs-block-start-regexp 'permanent-local t)
 815 (put 'hs-block-end-regexp 'permanent-local t)
 816 (put 'hs-forward-sexp-func 'permanent-local t)
 817 (put 'hs-adjust-block-beginning 'permanent-local t)
 818
 819
 820 ;;;----------------------------------------------------------------------------
 821 ;;; that's it
 822
 823 (provide 'hideshow)
 824
 825 ;;; hideshow.el ends here