/bdw/emacs/nxhtml/util/foldit.el

;;; foldit.el --- Helpers for folding
;;
;; Author: Lennart Borgman (lennart O borgman A gmail O com)
;; Created: 2009-08-10 Mon
;; Version:
;; Last-Updated:
;; URL:
;; Keywords:
;; Compatibility:
;;
;; Features that might be required by this library:
;;
;;   None
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Commentary:
;;
;; Defines `foldit-mode' which puts visual clues on hidden regions.
;; Does not do any folding itself but works with `outline-minor-mode'
;; and `hs-minor-mode'.
;;
;; Fix-me: reveal-mode does not work with this and I have no idea why
;; ...
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Change log:
;;
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 3, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth
;; Floor, Boston, MA 02110-1301, USA.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Code:

;; Fix-me: start-tag-beg/start-tag-end are workarounds for smaller
;; bugs in hs-minor-mode and outline-minor-mode. Maybe try to fix
;; them... - but there are a whole bunch of other invisibilty related
;; bugs that ought to be fixed first since otherwise it is impossible
;; to know where point goes after hiding/unhiding.

(eval-when-compile (require 'cl))
(eval-when-compile (require 'hideshow))
(eval-when-compile (require 'mumamo nil t))
(eval-when-compile (require 'outline))

(defsubst foldit-overlay-priority ()
  (1+ (or (and (boundp 'mlinks-link-overlay-priority)
               mlinks-link-overlay-priority)
          100)))

;;;###autoload
(defgroup foldit nil
  "Customization group for foldit folding helpers."
  :group 'nxhtml)

(defvar foldit-temp-at-point-ovl nil)
(make-variable-buffer-local 'foldit-temp-at-point-ovl)

;;;###autoload
(define-minor-mode foldit-mode
  "Minor mode providing visual aids for folding.
Shows some hints about what you have hidden and how to reveal it.

Supports `hs-minor-mode', `outline-minor-mode' and major modes
derived from `outline-mode'."
  :lighter nil
  (if foldit-mode
      (progn
        ;; Outline
        (add-hook 'outline-view-change-hook 'foldit-outline-change nil t)
        ;; Add our overlays
        (when (or (and (boundp 'outline-minor-mode) outline-minor-mode)
                  ;; Fix-me: mumamo
                  (derived-mode-p 'outline-mode)) (foldit-outline-change))
        ;; hs
        (unless (local-variable-p 'hs-set-up-overlay)
          (set (make-local-variable 'hs-set-up-overlay) 'foldit-hs-set-up-overlay))
        ;; Add our overlays
        (when (or (and (boundp 'hs-minor-mode) hs-minor-mode))
          (save-restriction
            (widen)
            (let (ovl)
              (dolist (ovl (overlays-in (point-min) (point-max)))
                (when (eq (overlay-get ovl 'invisible) 'hs)
                  (funcall hs-set-up-overlay ovl)))))))
    ;; Outline
    (remove-hook 'outline-view-change-hook 'foldit-outline-change t)
    ;; hs
    (when (and (local-variable-p 'hs-set-up-overlay)
               (eq hs-set-up-overlay 'foldit-hs-set-up-overlay))
      (kill-local-variable 'hs-set-up-overlay))
    ;; Remove our overlays
    (save-restriction
      (widen)
      (let (ovl prop)
        (dolist (ovl (overlays-in (point-min) (point-max)))
          (when (setq prop (overlay-get ovl 'foldit))
            (case prop
              ;;('display (overlay-put ovl 'display nil))
              ('foldit (delete-overlay ovl))
              (t (delete-overlay ovl))
              )))))))

(defcustom foldit-avoid '(org-mode)
  "List of major modes to avoid."
  :group 'foldit)

;;;###autoload
(define-globalized-minor-mode foldit-global-mode foldit-mode
  (lambda () (foldit-mode 1))
  :group 'foldit)

(defun foldit-hidden-line-str (hidden-lines type)
  "String to display for hidden lines.
HIDDEN-LINES are the number of lines and TYPE is a string
indicating how they were hidden."
  (propertize (format " ...(%d %slines)" hidden-lines type)
              'face 'shadow))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Outline

(defvar foldit-outline-keymap
  (let ((map (make-sparse-keymap)))
    (define-key map "\r" 'foldit-outline-show-entry)
    (define-key map [down-mouse-1] 'foldit-outline-show-entry)
    (define-key map [S-tab]   'mlinks-backward-link)
    (define-key map [tab]     'mlinks-forward-link)
    (define-key map "\t"      'mlinks-forward-link)
    map))

(defun foldit-outline-change ()
  "Check outline overlays.
Run this in `outline-view-change-hook'."
  ;; We get the variables FROM and TO here from `outline-flag-region'
  ;; so let us use them. But O is hidden...
  (let* (from
         to
         num-lines
         ovl
         (tag ""))
    (cond
     ((and (boundp 'start)
           start
           (boundp 'end)
           end)
      (setq from start)
      (setq to   end))
     (t
      (setq from (point-min))
      (setq to   (point-max))))
    (dolist (ovl (overlays-in from to))
      (when (eq (overlay-get ovl 'invisible) 'outline)
        (setq num-lines (count-lines (overlay-start ovl) (overlay-end ovl)))
        (overlay-put ovl 'display (concat
                                   (propertize "+" 'face 'mode-line)
                                   ""
                                   tag (foldit-hidden-line-str num-lines "")))
        (overlay-put ovl 'foldit 'display) ;; Should be a list...
        (overlay-put ovl 'keymap foldit-outline-keymap)
        (overlay-put ovl 'face 'lazy-highlight)
        (overlay-put ovl 'mouse-face 'highlight)
        (overlay-put ovl 'help-echo "Press RET to show hidden part")
        (overlay-put ovl 'mlinks-link t)
        (overlay-put ovl 'priority (foldit-overlay-priority))
        (mumamo-with-buffer-prepared-for-jit-lock
         (let* ((start-tag-beg (overlay-start ovl))
                (start-tag-end start-tag-beg))
           (put-text-property start-tag-beg (+ start-tag-beg 1)
                              'foldit-tag-end (copy-marker start-tag-end))))
        ))))

(defvar foldit-outline-hide-again-keymap
  (let ((map (make-sparse-keymap)))
    (define-key map "\r" 'foldit-outline-hide-again)
    (define-key map [down-mouse-1] 'foldit-outline-hide-again)
    (define-key map [S-tab]   'mlinks-backward-link)
    (define-key map [tab]     'mlinks-forward-link)
    (define-key map "\t"      'mlinks-forward-link)
    map))

(defun foldit-outline-show-entry ()
  "Show hidden entry."
  (interactive)
  (let ((tag-end (get-text-property (point) 'foldit-tag-end)))
    (show-entry)
    (mumamo-with-buffer-prepared-for-jit-lock
     (set-text-properties (point) (+ (point) 2) 'foldit-tag-end))
    (when tag-end (goto-char tag-end))
    (foldit-add-temp-at-point-overlay "-"
                                      foldit-outline-hide-again-keymap
                                      "Press RET to hide again")))

(defun foldit-outline-hide-again ()
  "Hide entry again."
  (interactive)
  (when (overlayp foldit-temp-at-point-ovl)
    (delete-overlay foldit-temp-at-point-ovl))
  (hide-entry))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Hide/Show

(defvar foldit-hs-start-tag-end-func 'foldit-hs-default-start-tag-end)
(make-variable-buffer-local 'foldit-hs-start-tag-end-func)
(put 'foldit-hs-start-tag-end-func 'permanent-local t)

(defun foldit-hs-default-start-tag-end (beg)
  "Find end of hide/show tag beginning at BEG."
  (min (+ beg 65)
       (save-excursion
         (goto-char beg)
         (line-end-position))))

(defvar foldit-hs-keymap
  (let ((map (make-sparse-keymap)))
    (define-key map "\r" 'foldit-hs-show-block)
    (define-key map [down-mouse-1] 'foldit-hs-show-block)
    (define-key map [S-tab]   'mlinks-backward-link)
    (define-key map [tab]     'mlinks-forward-link)
    (define-key map "\t"      'mlinks-forward-link)
    map))

(defvar foldit-hs-hide-again-keymap
  (let ((map (make-sparse-keymap)))
    (define-key map "\r" 'foldit-hs-hide-again)
    (define-key map [down-mouse-1] 'foldit-hs-hide-again)
    (define-key map [S-tab]   'mlinks-backward-link)
    (define-key map [tab]     'mlinks-forward-link)
    (define-key map "\t"      'mlinks-forward-link)
    map))

(defun foldit-hs-set-up-overlay (ovl)
  "Set up overlay OVL for hide/show."
  (let* ((num-lines (count-lines (overlay-start ovl) (overlay-end ovl)))
         (here (point))
         (start-tag-beg (overlay-start ovl))
         (start-tag-end (funcall foldit-hs-start-tag-end-func start-tag-beg))
         (tag (buffer-substring start-tag-beg start-tag-end)))
    (goto-char here)
    ;;(overlay-put ovl 'isearch-open-invisible t)
    (overlay-put ovl 'display (concat
                               (propertize "+" 'face 'mode-line)
                               " "
                               tag (foldit-hidden-line-str num-lines "h")))
    (overlay-put ovl 'foldit 'display)
    (overlay-put ovl 'keymap foldit-hs-keymap)
    (overlay-put ovl 'face 'next-error)
    (overlay-put ovl 'face 'lazy-highlight)
    (overlay-put ovl 'mouse-face 'highlight)
    (overlay-put ovl 'help-echo "Press RET to show hidden part")
    (overlay-put ovl 'mlinks-link t)
    (overlay-put ovl 'priority (foldit-overlay-priority))
    (mumamo-with-buffer-prepared-for-jit-lock
     (put-text-property start-tag-beg (+ start-tag-beg 1)
                        'foldit-tag-end (copy-marker start-tag-end)))))

(defun foldit-hs-show-block ()
  "Show hidden block."
  (interactive)
  (let ((tag-end (get-text-property (point) 'foldit-tag-end)))
    (hs-show-block)
    (mumamo-with-buffer-prepared-for-jit-lock
     (set-text-properties (point) (+ (point) 2) 'foldit-tag-end))
    (when tag-end (goto-char tag-end))
    (foldit-add-temp-at-point-overlay "-"
                                      foldit-hs-hide-again-keymap
                                    "Press RET to hide again")))

(defun foldit-hs-hide-again ()
  "Hide hide/show block again."
  (interactive)
  (when (overlayp foldit-temp-at-point-ovl)
    (delete-overlay foldit-temp-at-point-ovl))
  (hs-hide-block))


;;; Fix-me: break out this
;; >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
(defun foldit-add-temp-at-point-overlay (marker keymap msg)
  "Add a temporary overlay with a marker MARKER and a keymap KEYMAP.
The overlay is also given the help echo MSG.

This overlay is removed as soon as point moves from current point."
  (let ((ovl (make-overlay (point) (1+ (point))))
        (real (buffer-substring (point) (1+ (point)))))
    (overlay-put ovl 'isearch-open-invisible t)
    (overlay-put ovl 'display (concat
                               (propertize marker 'face 'mode-line)
                               " "
                               msg
                               real))
    (overlay-put ovl 'foldit 'foldit)
    (overlay-put ovl 'keymap keymap)
    (overlay-put ovl 'face 'lazy-highlight)
    (overlay-put ovl 'mouse-face 'highlight)
    (overlay-put ovl 'help-echo msg)
    (overlay-put ovl 'mlinks-link t)
    (overlay-put ovl 'priority (foldit-overlay-priority))
    (setq foldit-temp-at-point-ovl ovl)
    (add-hook 'post-command-hook
              'foldit-remove-temp-at-point-overlay
              nil t)))

(defun foldit-remove-temp-at-point-overlay ()
  "Remove overlay made by `foldit-add-temp-at-point-overlay'."
  (condition-case err
      (unless (and foldit-temp-at-point-ovl
                   (overlay-buffer foldit-temp-at-point-ovl)
                   (= (overlay-start foldit-temp-at-point-ovl)
                      (point)))
        (delete-overlay foldit-temp-at-point-ovl)
        (setq foldit-temp-at-point-ovl nil)
        (remove-hook 'post-command-hook 'foldit-remove-temp-at-point-overlay t)
        )
    (error (message "foldit-remove-temp-at-point-overlay: %s"
                    (propertize (error-message-string err))))))
;; <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<



;; (defun put-before-on-invis ()
;;   (let* (o
;;          (io (catch 'io
;;                (dolist (o (overlays-at (1+ (point))))
;;                  (when (overlay-get o 'invisible)
;;                    (throw 'io o)))))
;;          (str (propertize "IOSTRING"
;;                           'face 'secondary-selection
;;                           )))
;;     (overlay-put io 'before-string str)
;;     ;;(overlay-put io 'display "display")
;;     (overlay-put io 'display nil)
;;     ;;(overlay-put io 'after-string "AFTER")
;;     ))

(provide 'foldit)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; foldit.el ends here