contrib/semantic-tag-folding.el

   1 ;;; semantic-tag-folding.el --- semantic decoration style to enable folding of semantic tags
   2 ;; Time-stamp: <2010-09-15 16:20:59 (lluis)>
   3
   4 ;;; Copyright (C) 2005, 2009, 2010, 2013 Suraj Acharya
   5
   6 ;; Author: Suraj Acharya <sacharya@cs.indiana.edu>
   7
   8 ;; This file is not part of GNU Emacs.
   9
  10 ;; semantic-tag-folding.el is free software; you can redistribute it
  11 ;; and/or modify it under the terms of the GNU General Public License
  12 ;; as published by the Free Software Foundation; either version 2, or
  13 ;; (at your option) any later version.:
  14
  15 ;; This software is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  23 ;; Boston, MA 02110-1301, USA.
  24
  25 ;;; Commentary:
  26 ;;;
  27 ;;; Defines a `semantic-decoration-mode' style which allows semantic
  28 ;;; tags to be expanded or collapsed in the style of folding mode and
  29 ;;; hideshow mode.  In addition to regular semantic tag, comments
  30 ;;; preceding tags can also be folded, and consecutive 'include tags
  31 ;;; are folded as a single unit.  A semantic minor mode
  32 ;;; `semantic-tag-folding-mode' is also created.  So M-x
  33 ;;; semantic-tag-folding-mode can be used to turn this mode on and
  34 ;;; off, it will also turn on `semantic-deocration-mode' if required.
  35 ;;;
  36 ;;; To use feature, add this file to your load path and put the
  37 ;;; following line in your .emacs: (require 'semantic-tag-folding)
  38 ;;;
  39 ;;; Customize `semantic-tag-folding-allow-folding-of' to choose which
  40 ;;; tags you want to be able to fold.  You can also choose which tags
  41 ;;; types are folded by default when semantic-decoration-mode is
  42 ;;; enabled.
  43 ;;;
  44 ;;; M-x semantic-tag-folding-mode to enable tag folding in a buffer,
  45 ;;; M-x global-semantic-tag-folding-mode turns on folding in all
  46 ;;; semantic enabled buffers.
  47 ;;;
  48 ;; Features:
  49 ;; 1. Indicators in the fringe to show which tags which can be
  50 ;;    expanded or hidden, clicking on the fringe symbols toggles the
  51 ;;    associated block's state
  52 ;; 2. `semantic-tag-folding-allow-folding-of' lets you customize which
  53 ;;    tags can be folded, and which of those tags are folded by
  54 ;;    default when this mode is first activated.
  55 ;; 3. semantic-tag-folding-mode which toggles this mode, without
  56 ;;    having to turn on semantic-decoration-mode
  57 ;; 4. hs-mode style commands to fold and show all tags, all child tags
  58 ;;    or only the current tag.
  59 ;;
  60 ;; TODO:
  61 ;; * semantic-tag-folding-tag and semantic-tag-folding-comment attributes should be ignored
  62 ;; when calling fold-all or show-all (or the yet to be implemented show-children functions)
  63 ;; * make tooltips behave well (turn them off when the region is
  64 ;; expanded, consistent location, no truncation, update tooltips when
  65 ;; the text changes)
  66 ;; * make the ellipsis clickable
  67 ;; * investigate occasional windows cvs Emacs crashes
  68
  69
  70
  71 (require 'semantic/decorate/mode)
  72 (eval-when-compile (require 'cl))
  73
  74 ;;; Code:
  75
  76 ;; xemacs compatibility
  77 ;; http://www.opensource.apple.com/darwinsource/10.3/emacs-56/emacs/lisp/progmodes/hideshow.el
  78 (when (or (not (fboundp 'add-to-invisibility-spec))
  79           (not (fboundp 'remove-from-invisibility-spec)))
  80   ;; `buffer-invisibility-spec' mutators snarfed from Emacs 20.3 lisp/subr.el
  81   (defun add-to-invisibility-spec (arg)
  82     (cond
  83      ((or (null buffer-invisibility-spec) (eq buffer-invisibility-spec t))
  84       (setq buffer-invisibility-spec (list arg)))
  85      (t
  86       (setq buffer-invisibility-spec
  87             (cons arg buffer-invisibility-spec)))))
  88   (defun remove-from-invisibility-spec (arg)
  89     (when buffer-invisibility-spec
  90       (setq buffer-invisibility-spec
  91             (delete arg buffer-invisibility-spec)))))
  92
  93 ;; http://list-archive.xemacs.org/xemacs-patches/200206/msg00144.html
  94 ;; `propertize' is a builtin in GNU Emacs 21.
  95 (when (not (fboundp 'propertize))
  96   (defun propertize (string &rest properties)
  97     "Return a copy of STRING with text properties added.
  98 First argument is the string to copy.
  99 Remaining arguments form a sequence of PROPERTY VALUE pairs for text
 100 properties to add to the result."
 101     (let ((str (copy-sequence string)))
 102       (add-text-properties 0 (length str)
 103                            properties
 104                            str)
 105       str)))
 106
 107 ;;;###autoload
 108 (defcustom global-semantic-tag-folding-mode nil
 109   "*If non-nil enable global use of variable `semantic-tag-folding-mode'.
 110 With this mode enabled, a new folding decoration mode is added.
 111 Clicking on a + or - in the fringe will fold that tag."
 112   :group 'semantic
 113   :group 'semantic-modes
 114   :type 'boolean
 115   :require 'semantic-util-modes
 116   :initialize 'custom-initialize-default
 117   :set (lambda (sym val)
 118          (global-semantic-tag-folding-mode (if val 1 -1))))
 119
 120 ;;;###autoload
 121 (define-minor-mode global-semantic-tag-folding-mode
 122   "Toggle global use of option `semantic-tag-folding-mode'.
 123 If ARG is positive or nil, enable, if it is negative, disable."
 124   :global t :group 'semantic :group 'semantic-modes
 125   (semantic-toggle-minor-mode-globally
 126    'semantic-tag-folding-mode (if global-semantic-tag-folding-mode 1 -1)))
 127
 128 (defcustom semantic-tag-folding-mode-hook nil
 129   "*Hook run at the end of function `semantic-tag-folding-mode'."
 130   :group 'semantic
 131   :type 'hook)
 132
 133 (defvar semantic-tag-folding-mode-map
 134   (let ((km (make-sparse-keymap)))
 135     (define-key km [left-fringe mouse-1] 'semantic-tag-folding-click)
 136     km)
 137   "Keymap for folding minor mode.")
 138
 139 (defvar semantic-tag-folding-mode nil
 140   "Non-nil if folding minor mode is enabled.
 141 Use the command `semantic-tag-folding-mode' to change this variable.")
 142
 143 (make-variable-buffer-local 'semantic-tag-folding-mode)
 144
 145 (defvar semantic-tag-folding-decoration-mode-hook-enabled t
 146   "Used to disable `semantic-tag-folding-decoration-mode-hook'.
 147 This is done when semantic-tag-folding mode turns on semantic-decoration mode.")
 148
 149
 150 (defvar semantic-tag-folding-saved-decoration-styles nil
 151 "The saved value of `semantic-decoration-styles'.")
 152 (make-variable-buffer-local 'semantic-tag-folding-saved-decoration-styles)
 153
 154 (defvar semantic-tag-folding-decoration-style
 155   '(("semantic-tag-folding" . t))
 156   "Only turn on semantic-tag-folding decorations.
 157 A value for variable `semantic-decoration-styles'.")
 158
 159 (defun semantic-tag-folding-mode-setup ()
 160   "Setup option `semantic-tag-folding-mode'.
 161 The minor mode can be turned on only if semantic feature is available
 162 and the current buffer was set up for parsing.  In addition,
 163 `semantic-tag-folding-mode' is only available when fringe images are available
 164 in Emacs 20.4."
 165   (if semantic-tag-folding-mode
 166       (if (not (and (featurep 'semantic) (semantic-active-p)
 167                     ))
 168           (progn
 169             ;; Disable minor mode if semantic stuff not available
 170             (setq semantic-tag-folding-mode nil)
 171             (error "Buffer %s cannot be folded by semantic"
 172                    (buffer-name)))
 173         ;; Enable decoration mode
 174         (add-to-invisibility-spec '(semantic-tag-fold . t))
 175         (if (featurep 'xemacs)
 176             (set (make-local-variable 'line-move-ignore-invisible) t))
 177         (setq semantic-tag-folding-saved-decoration-styles semantic-decoration-styles)
 178         (if semantic-decoration-mode
 179             ;; if decoration mode is already on, ensure that semantic-tag-folding is enabled
 180             (let ((style (assoc "semantic-tag-folding" semantic-decoration-styles)))
 181               (when (not (cdr style))
 182                 (setcdr style t)
 183                 (semantic-decoration-mode 1)))
 184           ;; else, turn on decoration mode with only semantic-tag-folding on
 185           (setq semantic-tag-folding-saved-decoration-styles semantic-decoration-styles)
 186           (setq semantic-decoration-styles semantic-tag-folding-decoration-style)
 187           (let ((semantic-tag-folding-decoration-mode-hook-enabled nil))
 188             (semantic-decoration-mode 1))))
 189     ;; Remove hooks
 190     ;; Disable the decoration.
 191     (when semantic-decoration-mode
 192       (if (eq semantic-decoration-styles semantic-tag-folding-decoration-style)
 193           ;; if no calls were made to
 194           (progn     (semantic-decoration-mode -1)
 195                      (setq  semantic-decoration-styles semantic-tag-folding-saved-decoration-styles))
 196         ;; else
 197         (setq  semantic-decoration-styles semantic-tag-folding-saved-decoration-styles)
 198         (semantic-decoration-mode 1))))
 199   semantic-tag-folding-mode)
 200
 201 (add-hook 'semantic-decoration-mode-hook 'semantic-tag-folding-decoration-mode-hook)
 202
 203 (defun semantic-tag-folding-decoration-mode-hook ()
 204   "Hook function used to manage folding icons in decoration-mode."
 205   (when semantic-tag-folding-decoration-mode-hook-enabled
 206     (cond
 207      ((and semantic-decoration-mode semantic-tag-folding-mode)
 208       ;; when turning on decoration-mode with tag folding already on,
 209       ;; use the saved value of `semantic-decoration-styles' and ensure
 210       ;; that tag folding decorations are turned on
 211       (setq semantic-decoration-styles semantic-tag-folding-saved-decoration-styles)
 212       (let ((style (assoc "semantic-tag-folding" semantic-decoration-styles)))
 213         (when (not (cdr style))
 214           (setcdr style t)
 215           (semantic-decoration-mode 1)
 216           )))
 217      ((and semantic-decoration-mode (not semantic-tag-folding-mode))
 218       ;; when turning on decorations with out tag folding, ensure that
 219       ;; tag-folding decorations are not enabled
 220       (let ((style (assoc "semantic-tag-folding" semantic-decoration-styles)))
 221         (when (cdr style)
 222           (setcdr style nil)
 223           (semantic-decoration-mode 1)
 224           )))
 225      ((and (not semantic-decoration-mode) semantic-tag-folding-mode)
 226       ;; if turning off decoration mode with semantic tag folding on,
 227       ;; turn off semantic tag foldng mode
 228       (if (eq semantic-decoration-styles semantic-tag-folding-decoration-style)
 229           ;; M-x tag-folding -> M-x decoration , turn on all the deocration mode styles
 230           (semantic-decoration-mode 1)
 231         ;; M-x tag-folding -> M-x decoration M-x decoration, only keep
 232         ;; the semantic-tag-folding-decoration-style active
 233        (semantic-tag-folding-mode 1))))))
 234
 235 ;;;###autoload
 236 (define-minor-mode semantic-tag-folding-mode
 237   "Minor mode mark semantic tags for folding.
 238 This mode will display +/- icons in the fringe.  Clicking on them
 239 will fold the current tag.
 240 With prefix argument ARG, turn on if positive, otherwise off.  The
 241 minor mode can be turned on only if semantic feature is available and
 242 the current buffer was set up for parsing.  Return non-nil if the
 243 minor mode is enabled."
 244   :lighter nil
 245   :keymap semantic-tag-folding-mode-map
 246   (setq semantic-tag-folding-mode
 247         (if arg
 248             (>
 249              (prefix-numeric-value arg)
 250              0)
 251           (not semantic-tag-folding-mode)))
 252   (semantic-tag-folding-mode-setup)
 253   (run-hooks 'semantic-tag-folding-mode-hook)
 254   (if (called-interactively-p 'any)
 255       (message "folding minor mode %sabled"
 256                (if semantic-tag-folding-mode "en" "dis")))
 257   semantic-tag-folding-mode)
 258
 259 (semantic-add-minor-mode 'semantic-tag-folding-mode "fold")
 260
 261
 262 (define-semantic-decoration-style semantic-tag-folding "Enables folding of tags.")
 263
 264 ;; this  needs  to  go  after  defining the  decoration  style,  until
 265 ;; define-semantic-decoration-style   uses  setq-default   instead  of
 266 ;; add-to-list when setting the value of semantic-decoration-styles
 267 (make-variable-buffer-local 'semantic-decoration-styles)
 268
 269
 270 (defcustom semantic-tag-folding-allow-folding-of
 271   '((type . nil) (function . nil) (variable . nil) (include . nil)
 272     (comment . nil) (package . nil))
 273   "A set of semantic classes.  Tags of these classes will be allowed to be folded and unfolded by this mode."
 274   :group 'semantic
 275   :type ;;    '(alist    :key-type  symbol   :value-type boolean :options (type function variable include package code))
 276   '(set (cons :format "%v" (const :tag "Types" type)
 277               (choice :tag "Fold by default"
 278                       (const :tag "Outer type(s) as well as inner types" all)
 279                       (const :tag "Only inner types" inner)
 280                       (const :tag "Neither" )))
 281         (cons :format "%v"
 282               (const :tag "Function/method declarations" function)
 283               (boolean :tag "Fold by default"))
 284         (cons :format "%v"
 285               (const :tag "Varible declarations" variable)
 286               (boolean :tag "Fold by default"))
 287         (cons :format "%v"
 288               (const :tag "Blocks of consecutive include/import statements" include)
 289               (boolean :tag "Fold by default"))
 290         (cons :format "%v"
 291               (const :tag "Comment blocks preceding tags" comment)
 292               (boolean :tag "Fold by default"))
 293         (cons :format "%v"
 294               (const :tag "Package declarations" package)
 295               (boolean :tag "Fold by default"))
 296         (cons :format "%v"
 297               (const :tag "Code regions" code)
 298               (boolean :tag "Fold by default"))
 299         (cons :format "%v"
 300               (const :tag "Code regions" block)
 301               (boolean :tag "Fold by default"))
 302         (repeat :tag "Other Semantic classes"
 303                 (cons :format "%v" (symbol :tag "Semantic class" code)
 304                       (boolean :tag "Fold by default")))
 305         ))
 306 (make-variable-buffer-local 'semantic-tag-folding-allow-folding-of)
 307
 308 (defcustom semantic-tag-folding-tag-higlight-time 1
 309   "The time in seconds for which a fringe highlight appears.
 310 This higlight shows extent of the tag body when a tag is
 311 expanded.  Set this to nil for no extent indication."
 312   :group 'semantic :type 'number)
 313
 314 (defcustom semantic-tag-folding-highlight-tags-shown-by-reveal-mode nil
 315   "If non-nil the extent tags unfolded by reveal mode is not highlighted."
 316   :group 'semantic
 317   :type 'boolean)
 318
 319 (defcustom semantic-tag-folding-show-tooltips nil
 320   "Display tooltips for folded tag bodies..
 321 If set to t, the body of a hidden tag is shown as a tooltip
 322   when the mouse hovers over the first line of the tag.  This is
 323   not very pretty because the tooltip sometimes appears above the
 324   cursor and not below where the tag body is, and the tootltip
 325   text is truncated at some limit so large tag bodies are often
 326   cut short."
 327   :group 'semantic :type 'boolean)
 328
 329 (defvar semantic-tag-folding-function 'semantic-tag-folding-function-default
 330   "Default folding of tags.
 331 Function which determines whether a tag should be folded by
 332 default when `semantic-tag-folding' is activated."  )
 333
 334 (defun semantic-tag-folding-set-fringe-image-style  (&optional symbol value)
 335   "Set the bitmaps for this folding \"fringe style\".
 336 This function is called when customizing
 337 `semantic-tag-folding-fringe-image-style'. SYMBOL is
 338 `semantic-tag-folding-fringe-image-style' and VALUE is the fringe
 339 style selected.
 340 Five bitmaps are needed for each style:
 341 * semantic-tag-folding-folded - the image in the fringe which
 342 indicates that there is a folded tag on this line
 343 * semantic-tag-folding-unfolded - this image indicates that the
 344 tag starting on this line can be folded
 345 * semantic-tag-folding-highlight-{top,middle,bottom} - when
 346 `semantic-tag-folding-tag-higlight-time' is non-nil these three
 347 bitmaps are used to indicate the extent of a tag when it is
 348 unfolded."
 349   (if symbol (set-default symbol value))
 350   (cond
 351    ((not (functionp 'define-fringe-bitmap)) nil)
 352    ((eq value 'plusminus)
 353
 354     (define-fringe-bitmap  'semantic-tag-folding-folded
 355       ;; a plus sign
 356       [#b00011000
 357        #b00011000
 358        #b00011000
 359        #b11111111
 360        #b11111111
 361        #b00011000
 362        #b00011000
 363        #b00011000])
 364
 365     (define-fringe-bitmap  'semantic-tag-folding-unfolded
 366       ;; a minus sign
 367       [#b11111111
 368        #b11111111])
 369
 370     (define-fringe-bitmap  'semantic-tag-folding-highlight-top
 371       ;; a minus sign
 372       [#b11111111
 373        #b11111111])
 374
 375     (define-fringe-bitmap  'semantic-tag-folding-highlight-middle
 376       ;; a vertical bar
 377       [#b00011000] nil nil '(center t))
 378
 379     (define-fringe-bitmap  'semantic-tag-folding-highlight-bottom
 380       ;; a minus sign
 381       [#b11111111
 382        #b11111111]))
 383
 384    ((eq value 'triangles)
 385
 386     (define-fringe-bitmap  'semantic-tag-folding-unfolded
 387       ;; a triangle pointing downwards
 388       [#b11111110
 389        #b01000100
 390        #b00101000
 391        #b00010000])
 392
 393     (define-fringe-bitmap  'semantic-tag-folding-folded
 394       ;; a filled triangle pointing to the right
 395       [#b100000
 396        #b110000
 397        #b111000
 398        #b111100
 399        #b111100
 400        #b111000
 401        #b110000
 402        #b100000])
 403
 404     (define-fringe-bitmap  'semantic-tag-folding-highlight-top
 405       ;; a triangle pointing downwards
 406       [#b11111110
 407        #b01000100
 408        #b00101000
 409        #b00010000])
 410
 411     (define-fringe-bitmap  'semantic-tag-folding-highlight-middle
 412       ;; a vertical bar
 413       [#b00010000] nil nil '(center t))
 414
 415     (define-fringe-bitmap  'semantic-tag-folding-highlight-bottom
 416       ;; a triangle pointing upwards
 417       [#b00010000
 418        #b00101000
 419        #b01000100
 420        #b11111110])
 421     )
 422    ))
 423
 424 (defcustom semantic-tag-folding-fringe-image-style 'triangles
 425   "Fringe image style.
 426 This variable determines the bitmaps drawn in the fringe to
 427   indicate folded or unfolded (expanded) tags."
 428   :group 'semantic
 429   :type '(choice (const triangles)
 430                  (const plusminus))
 431   :set 'semantic-tag-folding-set-fringe-image-style)
 432
 433 (defun semantic-tag-folding-allow-folding-of (class)
 434   "Is folding of tags of semantic class CLASS allowed?"
 435   (or
 436    (assq class semantic-tag-folding-allow-folding-of)
 437    (assq class (car (last semantic-tag-folding-allow-folding-of)))
 438    ))
 439
 440 (defun semantic-tag-folding-hidden-by-default (class)
 441 "Are tags of semantic class CLASS to be hidden by default?"
 442   (cdr (semantic-tag-folding-allow-folding-of class)))
 443
 444 (defun semantic-tag-folding-function-default (tag comment)
 445   "The default `semantic-tag-folding-function'.
 446 Returns non-nil if the body of TAG is to be hidden when the mode
 447 is started.  COMMENT is non-nil to indicate that the comment above
 448 TAG is what is being hidden, not the body of TAG."
 449   (if comment
 450       (semantic-tag-folding-hidden-by-default 'comment)
 451     (let* ((c (semantic-tag-class tag))
 452           (default (semantic-tag-folding-hidden-by-default c)))
 453       ;; `default' is the value to be returned, unless TAG is a type
 454       ;; and only inner types are to  be hidden
 455       (if (and default (eq c 'type) (eq default 'inner))
 456           ;; the outermost type has no parent
 457           (semantic-find-tag-parent-by-overlay tag)
 458         default))))
 459
 460 (defun semantic-tag-folding-p-default (tag)
 461   "Return non-nil if TAG is to be considered for folding.
 462 TAG has to have valid start and end locations in the
 463 buffer.  Customize variable `semantic-tag-folding-allow-folding-of' to
 464 influence the output of this function."
 465   (let ((c (semantic-tag-class tag)))
 466     (and
 467      (semantic-tag-with-position-p tag)
 468      (or (semantic-tag-folding-allow-folding-of 'comment)
 469          (semantic-tag-folding-allow-folding-of c))
 470      ;; we only want the first include from a block of includes
 471      (or (not (eq c 'include))
 472          (not (semantic-find-tag-by-overlay-prev (semantic-tag-start tag)))
 473          (not (eq (semantic-tag-class
 474                    (semantic-find-tag-by-overlay-prev (semantic-tag-start tag))) 'include)))
 475      )))
 476
 477 (defun semantic-tag-folding-highlight-default (tag)
 478   "Create decoration overlays for TAG.
 479 Also put a marker in the fringe for each thing that can be
 480 collapsed."
 481   (when (semantic-tag-buffer tag)
 482     (with-current-buffer (semantic-tag-buffer tag)
 483       (let ((point (point))
 484             (tag-start (semantic-tag-start tag))
 485             (tag-end (semantic-tag-end tag)))
 486         ;; fold the comment preceding this tag
 487         (if (semantic-tag-folding-allow-folding-of 'comment)
 488             (let ((start (progn
 489                            (goto-char tag-start)
 490                            (when (forward-comment -1)
 491                              (do ((ret (point-at-eol) (point-at-eol)))
 492                                  ( ;; until we see an empty line, or there are
 493                                   ;; no more comments, or we reach the
 494                                   ;; beginning of the buffer
 495                                   (or (re-search-backward "\n\n" (- (point) 2) t)
 496                                       (not (forward-comment -1))
 497                                       (bobp))
 498                                   ;; return
 499                                   ret)))))
 500                   (end (progn
 501                          (goto-char tag-start)
 502                          (- (point-at-bol) 1))))
 503               (semantic-tag-folding-create-folding-overlays tag start end point t)))
 504         ;; Fold the body of this tag.
 505         ;; If folding comments is enabled all tags are passed into this
 506         ;; function, so we need to check if folding is enabled for this
 507         ;; tag type
 508         (if (or (not (semantic-tag-folding-allow-folding-of 'comment)) (semantic-tag-folding-allow-folding-of (semantic-tag-class tag)))
 509             (let ((start (progn
 510                            (goto-char tag-start)
 511                            (point-at-eol)))
 512                   (end (if (eq (semantic-tag-class tag) 'include)
 513                            (progn
 514                              (let ((tag-cursor tag) (last-tag-cursor tag))
 515                                (while (eq (semantic-tag-class tag-cursor) 'include)
 516                                  (setq last-tag-cursor tag-cursor)
 517                                  (setq tag-cursor (semantic-find-tag-by-overlay-next (semantic-tag-end tag-cursor))))
 518                                (semantic-tag-end last-tag-cursor)))
 519                          tag-end)))
 520               (semantic-tag-folding-create-folding-overlays tag start end point nil)))
 521         (goto-char point)))))
 522
 523
 524 (defun semantic-tag-folding-get-attribute-overlay (tag create-if-null)
 525   "Get the overlay used to store the fold state for TAG.
 526 Create the overlay if CREATE-IF-NULL is non-nil."
 527   (let* ((pos (semantic-tag-start tag))
 528         (ov (car (remove-if-not
 529                  (lambda (ov)
 530                    (semantic-overlay-get ov 'semantic-tag-folding-attributes))
 531                  (semantic-overlays-at pos)))))
 532     (when (and create-if-null (null ov))
 533       (setq ov (semantic-make-overlay (- pos 1) (+ 1 pos)))
 534       (semantic-overlay-put ov 'semantic-tag-folding-attributes t))
 535     ov))
 536
 537 (defun semantic-tag-folding-get-folding-attribute (comment)
 538   "Return the symbol used to store the fold state.
 539 The symbol returned is for a tag (COMMENT is nil) or the comment
 540 preceding a tag (COMMENT is non-nil)"
 541   (if comment
 542       'semantic-tag-folding-comment
 543     'semantic-tag-folding-tag))
 544
 545 (defun semantic-tag-folding-get-fold-state (tag comment)
 546   "Return the fold state for TAG.
 547 If COMMENT is non-nil return the fold state for the comment preceding TAG."
 548   (let* ((attr (semantic-tag-folding-get-folding-attribute comment))
 549          (ov (semantic-tag-folding-get-attribute-overlay tag nil)))
 550     (and ov (semantic-overlay-get ov attr))))
 551
 552 (defun semantic-tag-folding-set-fold-state (tag comment state)
 553   "Set the fold state for TAG to STATE.
 554 If COMMENT is non-nil set the fold state for the comment preceding TAG."
 555   (let* ((attr (semantic-tag-folding-get-folding-attribute comment))
 556          (ov (semantic-tag-folding-get-attribute-overlay tag t)))
 557     (semantic-overlay-put ov attr state)))
 558
 559
 560 (defun semantic-tag-folding-create-folding-overlays (tag start end point comment)
 561 "Create an overlay for `semantic-tag-overlay'.
 562 Create an overlay associated TAG.  START and END are buffer
 563 positions, usually inside TAG, but can be outside for comment and
 564 include block overlays.  POINT is the saved location of point,
 565 this is used to unfold any TAGS around point by default.  COMMENT
 566 is non-nil if the fold region is a comment."
 567   (let ((fold (if (functionp semantic-tag-folding-function)
 568                   (apply semantic-tag-folding-function (list tag comment))
 569                 semantic-tag-folding-function)))
 570     (when (and start end (< start end) (> (count-lines start end) 1))
 571       (let* ((ov (semantic-decorate-tag tag start end))
 572              (start2 (if comment
 573                          (save-excursion
 574                            (goto-char start)
 575                            (backward-char)
 576                            (point-at-bol))
 577                        (semantic-tag-start tag)))
 578              (ov2 (semantic-decorate-tag tag start2 (+ start2 1)))
 579              (marker-string "+"))
 580         (semantic-overlay-put ov 'semantic-tag-folding t)
 581         (semantic-overlay-put ov 'isearch-open-invisible
 582                      'semantic-tag-folding-show-block)
 583
 584         ;; check for fold state attributes
 585         (if (functionp semantic-tag-folding-function)
 586             (let ((state (semantic-tag-folding-get-fold-state tag comment)))
 587               (if state
 588                   (setq fold (eq state 'fold)))))
 589
 590         ;; don't fold this region if point is inside it
 591         (if (and (> end point) (< start point))
 592             (setq fold nil))
 593
 594         (if (not fold)
 595             ;; just display the unfolded bitmap in the fringe
 596             (setq marker-string (propertize
 597                                  marker-string 'display
 598                                  '((left-fringe semantic-tag-folding-unfolded)
 599                                    "-")))
 600           ;; fold the body and display a + in the fringe
 601           (semantic-overlay-put ov 'invisible 'semantic-tag-fold)
 602           (setq marker-string (propertize
 603                                marker-string
 604                                'display
 605                                '((left-fringe semantic-tag-folding-folded)
 606                                  "+" ))))
 607
 608         ;; store the marker string and tag as a property of the
 609         ;; overlay so we use it to change the displayed fold state
 610         ;; later (in semantic-tag-folding-set-overlay-visibility)
 611         (semantic-overlay-put ov 'semantic-tag-folding-marker-string marker-string)
 612         (semantic-overlay-put ov 'semantic-tag-folding-tag tag)
 613         (semantic-overlay-put ov 'semantic-tag-folding-comment-overlay comment)
 614
 615         (semantic-overlay-put ov2 'before-string marker-string)
 616
 617         ;; store fold state as a function of the tag (unless the default state is being set)
 618         (unless (functionp semantic-tag-folding-function)
 619           (semantic-tag-folding-set-fold-state tag comment fold))
 620
 621         ;; tooltips
 622         (when semantic-tag-folding-show-tooltips
 623           (semantic-overlay-put ov2 'mouse-face 'highlight)
 624           (semantic-overlay-put ov2 'help-echo (buffer-substring (+ 1 start) end)))))))
 625
 626 (defun semantic-tag-folding-fold-block ()
 627   "Fold the smallest enclosing tag at point."
 628   (interactive)
 629  (semantic-tag-folding-set-overlay-visibility
 630   (semantic-tag-folding-get-overlay) t))
 631
 632 (defun semantic-tag-folding-show-block (&optional ov)
 633   "Unfold overlay OV, or the smallest enclosing tag at point."
 634   (interactive)
 635   (semantic-tag-folding-set-overlay-visibility
 636    (or ov (semantic-tag-folding-get-overlay)) nil))
 637
 638 (defun semantic-tag-folding-show-all ()
 639   "Unfold all the tags in this buffer."
 640   (interactive)
 641     (semantic-tag-folding-fold-or-show-tags
 642      (semantic-fetch-available-tags) nil))
 643
 644 (defun semantic-tag-folding-fold-all ()
 645   "Fold all the tags in this buffer."
 646   (interactive)
 647     (semantic-tag-folding-fold-or-show-tags
 648      (semantic-fetch-available-tags) t))
 649
 650 (defun semantic-tag-folding-show-children ()
 651   "Unfold all the tags in this buffer."
 652   (interactive)
 653   (semantic-tag-folding-fold-or-show-tags
 654    (cons (semantic-current-tag)
 655          (semantic-tag-components (semantic-current-tag)))
 656    nil))
 657
 658 (defun semantic-tag-folding-fold-children ()
 659   "Unfold all the tags in this buffer."
 660   (interactive)
 661   (semantic-tag-folding-fold-or-show-tags
 662    (cons (semantic-current-tag)
 663          (semantic-tag-components (semantic-current-tag)))
 664    t))
 665
 666 (defun semantic-tag-folding-fold-or-show-tags (tags fold)
 667 "Change the fold state of TAGS to FOLD."
 668   (lexical-let ((fold fold))
 669     (when semantic-decoration-mode
 670       (semantic-decorate-clear-decorations tags)
 671       (let ((semantic-tag-folding-function fold))
 672         (semantic-decorate-add-decorations tags)))))
 673
 674 (defun semantic-tag-folding-get-overlay ()
 675   "Return the innermost semantic-tag-folding-folding overlay at point."
 676   (labels ((semantic-overlay-size (ov)
 677              (- (semantic-overlay-end ov) (semantic-overlay-start ov))))
 678     (car
 679      (sort
 680       (remove-if-not (lambda (ov) (semantic-overlay-get ov 'semantic-tag-folding))
 681                      (semantic-overlays-at (point-at-eol)))
 682       (lambda (x y)
 683         (< (semantic-overlay-size x) (semantic-overlay-size y)))))))
 684
 685 (defun semantic-tag-folding-set-overlay-visibility (ov fold &optional called-by-reveal-mode)
 686   "Change the visibility of overlay OV.
 687 If FOLD is non-nil OV is hidden.  Also changes the fringe bitmap
 688 to indcate the new state.  CALLED-BY-REVEAL-MODE is t when this
 689 overlay is folded or expanded by reveal mode."
 690   (when (and (semantic-overlay-p ov)
 691              ;; if reveal mode is hiding an overlay, it should've been folded by reveal mode
 692              (or (not called-by-reveal-mode) (not fold) (semantic-overlay-get ov 'semantic-tag-reveal-mode)))
 693     (semantic-overlay-put ov 'invisible (if fold 'semantic-tag-fold))
 694     (let ((tag (semantic-overlay-get ov 'semantic-tag-folding-tag)))
 695
 696       (when tag
 697         (semantic-tag-folding-set-fold-state tag (semantic-overlay-get ov 'semantic-tag-folding-comment-overlay) (if fold 'fold 'show))
 698         (if fold
 699             (put-text-property 0 1 'display '((left-fringe semantic-tag-folding-folded) "+")
 700                                (semantic-overlay-get ov 'semantic-tag-folding-marker-string))
 701           ;; show
 702           (put-text-property 0 1 'display '((left-fringe semantic-tag-folding-unfolded) "-")
 703                              (semantic-overlay-get ov 'semantic-tag-folding-marker-string))
 704           (semantic-overlay-put ov 'semantic-tag-reveal-mode called-by-reveal-mode)
 705           (semantic-tag-folding-highlight-overlay ov))))))
 706
 707 ;; set the function to be called when regions are revealed and hidden by reveal-mode.
 708 (put  'semantic-tag-fold 'reveal-toggle-invisible 'semantic-tag-folding-set-overlay-visibility-for-reveal-mode)
 709
 710 (defun semantic-tag-folding-set-overlay-visibility-for-reveal-mode (ov fold)
 711 "Fold/unfold function called from reveal mode.
 712 OV is the overlay whose state must change, FOLD is non-nil to fold the overlay."
 713   (let ((semantic-tag-folding-tag-higlight-time
 714          (if semantic-tag-folding-highlight-tags-shown-by-reveal-mode
 715              semantic-tag-folding-tag-higlight-time
 716            nil)))
 717     (semantic-tag-folding-set-overlay-visibility ov fold t)))
 718
 719 (defun semantic-tag-folding-highlight-overlay (ov)
 720   "Temporarily draw attention to the overlay OV.
 721 This is done by drawing a vertical bar in the fringe for the
 722 lines that OV extends over for
 723 `semantic-tag-folding-tag-higlight-time' seconds."
 724   (when semantic-tag-folding-tag-higlight-time
 725     (let ((overlays nil))
 726       (labels ((make-fringe (fringe string)
 727                  (setq overlays (cons (semantic-make-overlay (point-at-bol) (+ 1(point-at-bol))) overlays) )
 728                  (semantic-overlay-put (car overlays) 'before-string
 729                               (propertize string 'display `(left-fringe ,fringe)))))
 730         (save-excursion
 731           (goto-char (semantic-overlay-start ov))
 732           (make-fringe 'semantic-tag-folding-highlight-top "+")
 733           (forward-line)
 734           (while (< (point-at-eol) (semantic-overlay-end ov))
 735             (make-fringe 'semantic-tag-folding-highlight-middle "|")
 736             (forward-line))
 737           (make-fringe 'semantic-tag-folding-highlight-bottom "+"))
 738         (sit-for semantic-tag-folding-tag-higlight-time)
 739         (mapc 'semantic-overlay-delete overlays)))))
 740
 741 (defun semantic-tag-folding-click (event)
 742   "Handle fringe click EVENT by folding/unfolding blocks."
 743     (interactive "e")
 744     (when (event-start event)
 745       (let* ((start (event-start event))
 746             (point (posn-point start))
 747             (window (posn-window start)))
 748         (select-window window)
 749         (goto-char point)
 750         (let ((bitmaps (fringe-bitmaps-at-pos point)))
 751           (if (member 'semantic-tag-folding-folded bitmaps)
 752               (semantic-tag-folding-set-overlay-visibility (semantic-tag-folding-get-overlay) nil))
 753           (if (member 'semantic-tag-folding-unfolded bitmaps)
 754               (semantic-tag-folding-set-overlay-visibility (semantic-tag-folding-get-overlay) t))))))
 755
 756 (provide 'semantic-tag-folding)
 757 ;;; semantic-tag-folding.el ends here