[muse-el.git] / lisp / muse-backlink.el

;;; muse-backlink.el --- backlinks for Muse

;; Copyright (C) 2005, 2006, 2007, 2008, 2009  Free Software Foundation, Inc.

;; Author: Jim Ottaway <j.ottaway@lse.ac.uk>
;; Keywords:

;; This file is part of Emacs Muse.  It is not part of GNU Emacs.

;; Emacs Muse 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.

;; Emacs Muse 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 Emacs Muse; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;;; Commentary:

;; Hierarchical backlink insertion into new muse pages.
;;
;; To add:
;;
;; (require 'muse-backlink)
;; (muse-backlink-install)
;;
;; To control what gets backlinked, modify
;; `muse-backlink-exclude-backlink-regexp' and
;; `muse-backlink-exclude-backlink-parent-regexp'.
;;
;; To stop backlinking temporarily:
;; (setq muse-backlink-create-backlinks nil)
;;
;; To remove the backlink functionality completely:
;;
;; (muse-backlink-remove)

;;; Contributors:

;;; Code:

(require 'muse)
(require 'muse-project)

(eval-when-compile (require 'muse-mode))

(eval-and-compile
  (if (< emacs-major-version 22)
      (progn
        ;; Swiped from Emacs 22.0.50.4
        (defvar muse-backlink-split-string-default-separators "[ \f\t\n\r\v]+"
        "The default value of separators for `split-string'.

A regexp matching strings of whitespace.  May be locale-dependent
\(as yet unimplemented).  Should not match non-breaking spaces.

Warning: binding this to a different value and using it as default is
likely to have undesired semantics.")

        (defun muse-backlink-split-string (string &optional separators omit-nulls)
        "Split STRING into substrings bounded by matches for SEPARATORS.

The beginning and end of STRING, and each match for SEPARATORS, are
splitting points.  The substrings matching SEPARATORS are removed, and
the substrings between the splitting points are collected as a list,
which is returned.

If SEPARATORS is non-nil, it should be a regular expression matching text
which separates, but is not part of, the substrings.  If nil it defaults to
`split-string-default-separators', normally \"[ \\f\\t\\n\\r\\v]+\", and
OMIT-NULLS is forced to t.

If OMIT-NULLS is t, zero-length substrings are omitted from the list \(so
that for the default value of SEPARATORS leading and trailing whitespace
are effectively trimmed).  If nil, all zero-length substrings are retained,
which correctly parses CSV format, for example.

Note that the effect of `(split-string STRING)' is the same as
`(split-string STRING split-string-default-separators t)').  In the rare
case that you wish to retain zero-length substrings when splitting on
whitespace, use `(split-string STRING split-string-default-separators)'.

Modifies the match data; use `save-match-data' if necessary."
        (let ((keep-nulls (not (if separators omit-nulls t)))
              (rexp (or separators muse-backlink-split-string-default-separators))
              (start 0)
              notfirst
              (list nil))
          (while (and (string-match rexp string
                                    (if (and notfirst
                                             (= start (match-beginning 0))
                                             (< start (length string)))
                                        (1+ start) start))
                      (< start (length string)))
            (setq notfirst t)
            (if (or keep-nulls (< start (match-beginning 0)))
                (setq list
                      (cons (substring string start (match-beginning 0))
                            list)))
            (setq start (match-end 0)))
          (if (or keep-nulls (< start (length string)))
              (setq list
                    (cons (substring string start)
                          list)))
          (nreverse list))))
    (defalias 'muse-backlink-split-string 'split-string)))

(defgroup muse-backlink nil
  "Hierarchical backlinking for Muse."
  :group 'muse)

(defcustom muse-backlink-create-backlinks t
  "When non-nil, create hierarchical backlinks in new Muse pages.
For control over which pages will receive backlinks, see
`muse-backlink-exclude-backlink-parent-regexp' and
`muse-backlink-exclude-backlink-regexp'."
  :type 'boolean
  :group 'muse-backlink)

(defcustom muse-backlink-avoid-bad-links t
  "When non-nil, avoid bad links when backlinking."
  :type 'boolean
  :group 'muse-backlink)

;; The default for exclusion stops backlinks from being added to and
;; from planner day pages.
(defcustom muse-backlink-exclude-backlink-parent-regexp
  "^[0-9][0-9][0-9][0-9]\\.[0-9][0-9]\\.[0-9][0-9]$"
  "Regular expression matching pages whose children should not have backlinks."
  :type 'regexp
  :group 'muse-backlink)

(defcustom muse-backlink-exclude-backlink-regexp
  "^[0-9][0-9][0-9][0-9]\\.[0-9][0-9]\\.[0-9][0-9]$"
  "Regular expression matching pages that should not have backlinks."
  :type 'regexp
  :group 'muse-backlink)

(defcustom muse-backlink-separator "/"
  "String that separates backlinks.
Should be something that will not appear as a substring in an explicit
link that has no description."
  :type 'string
  :group 'muse-backlink)

(defcustom muse-backlink-before-string "backlinks: "
  "String to come before the backlink list."
  :type 'string
  :group 'muse-backlink)

(defcustom muse-backlink-after-string ""
  "String to come after the backlink list."
  :type 'string
  :group 'muse-backlink)

(defcustom muse-backlink-separator "/"
  "String that separates backlinks.
Should be something that will not appear as a substring in an explicit
link that has no description."
  :type 'string
  :group 'muse-backlink)

(defcustom muse-backlink-regexp
  (concat "^"
          (regexp-quote muse-backlink-before-string)
          "\\("
          (regexp-quote muse-backlink-separator)
          ".+\\)"
          (regexp-quote muse-backlink-after-string))
  ;; Really, I want something like this, but I can't make it work:
  ;;   (concat "^\\("
  ;;           (regexp-quote muse-backlink-separator)
  ;;           "\\(?:"
  ;;           muse-explicit-link-regexp
  ;;           "\\)\\)+")
  "Regular expression to match backlinks in a buffer.
Match 1 is the list of backlinks without `muse-backlink-before-string'
and `muse-backlink-after-string'."
  :type 'regexp
  :group 'muse-backlink)

(defun muse-backlink-goto-insertion-point ()
  "Find the right place to add backlinks."
  (goto-char (point-min))
  (when (looking-at "\\(?:^#.+[ \t]*\n\\)+")
    (goto-char (match-end 0))))

(defun muse-backlink-get-current ()
  "Return a list of backlinks in the current buffer."
  (save-excursion
    (goto-char (point-min))
    (when (re-search-forward muse-backlink-regexp nil t)
      (muse-backlink-split-string
       (match-string 1)
       (regexp-quote muse-backlink-separator) t))))

(defun muse-backlink-format-link-list (links)
  "Format the list of LINKS as backlinks."
  (concat muse-backlink-separator
          (mapconcat #'identity links muse-backlink-separator)))

(defun muse-backlink-insert-links (links)
  "Insert backlinks to LINKS into the current page.
LINKS is a list of links ordered by ancestry, with the parent as the
last element."
  (muse-backlink-goto-insertion-point)
  (insert muse-backlink-before-string
          (muse-backlink-format-link-list links)
          muse-backlink-after-string
          ;; Could have this in the after string, but they might get
          ;; deleted.
          "\n\n"))

(defun muse-backlink-unsaved-page-p (page project)
  "Return non-nil if PAGE is in PROJECT but has not been saved."
  (member
   page
   (mapcar
    #'(lambda (b)
        (with-current-buffer b
          (and (derived-mode-p 'muse-mode)
               (equal muse-current-project project)
               (not (muse-project-page-file
                     (muse-page-name)
                     muse-current-project))
               (muse-page-name))))
    (buffer-list))))

(defvar muse-backlink-links nil
  "Internal variable.
The links to insert in the forthcomingly visited muse page.")

(defvar muse-backlink-pending nil
  "Internal variable.")

(defvar muse-backlink-parent-buffer nil
  "Internal variable.
The parent buffer of the forthcomingly visited muse page.")


;;; Attach hook to the derived mode hook, to avoid problems such as
;;; planner-prepare-file thinking that the buffer needs no template.
(defun muse-backlink-get-mode-hook ()
  (derived-mode-hook-name major-mode))

(defun muse-backlink-insert-hook-func ()
  "Insert backlinks into the current buffer and clean up."
  (when (and muse-backlink-links
             muse-backlink-pending
             (string= (car muse-backlink-links) (muse-page-name)))
    (muse-backlink-insert-links (cdr muse-backlink-links))
    (when muse-backlink-avoid-bad-links
      (save-buffer)
      (when muse-backlink-parent-buffer
        (with-current-buffer muse-backlink-parent-buffer
          (font-lock-fontify-buffer))))
    (setq muse-backlink-links nil
          muse-backlink-parent-buffer nil
          muse-backlink-pending nil)
    (remove-hook (muse-backlink-get-mode-hook) #'muse-backlink-insert-hook-func)))

(defun muse-backlink-handle-link (link)
  "When appropriate, arrange for backlinks on visiting LINK."
  (when (and muse-backlink-create-backlinks
             (not muse-backlink-pending)
             (memq this-command
                   '(muse-follow-name-at-point muse-follow-name-at-mouse))
             (not muse-publishing-p)
             (not (and (boundp 'muse-colors-fontifying-p)
                       muse-colors-fontifying-p)))
    (require 'muse-mode)
    (setq
     muse-backlink-links
     (save-match-data
       (let* ((orig-link (or link (match-string 1)))
              (link (if (string-match "#" orig-link)
                        (substring orig-link 0 (match-beginning 0))
                      orig-link)))
         (unless
             (or (not muse-current-project)
                 (string-match muse-url-regexp orig-link)
                 (string-match muse-image-regexp orig-link)
                 (and (boundp 'muse-wiki-interwiki-regexp)
                      (string-match muse-wiki-interwiki-regexp
                                    orig-link))
                 ;; Don't add a backlink if the page already
                 ;; exists, whether it has been saved or not.
                 (or (muse-project-page-file link muse-current-project)
                     (muse-backlink-unsaved-page-p link muse-current-project))
                 (string-match muse-backlink-exclude-backlink-parent-regexp
                               (muse-page-name))
                 (string-match muse-backlink-exclude-backlink-regexp link))
           ;; todo: Hmm. This will only work if the child page is the
           ;; same mode as the parent page.
           (add-hook (muse-backlink-get-mode-hook) #'muse-backlink-insert-hook-func)
           (setq muse-backlink-pending t)
           (when muse-backlink-avoid-bad-links
             (setq muse-backlink-parent-buffer (current-buffer))
             (unless (muse-project-page-file
                      (muse-page-name) muse-current-project)
               ;; It must be modified...
               (save-buffer)))
           (cons link
                 (append (muse-backlink-get-current)
                         (list (muse-make-link (muse-page-name))))))))))
  ;; Make sure we always return nil
  nil)

(defun muse-backlink-install ()
  "Add backlinking functionality to muse-mode."
  (add-to-list 'muse-explicit-link-functions #'muse-backlink-handle-link))

(defun muse-backlink-remove ()
  "Remove backlinking functionality from muse-mode."
  (setq muse-explicit-link-functions
        (delq #'muse-backlink-handle-link muse-explicit-link-functions)))

(provide 'muse-backlink)
;;; muse-backlink.el ends here