lisp/muse-registry.el

   1 ;;; muse-registry.el --- registry for Muse and Planner
   2
   3 ;; Copyright (C) 2005, 2006 Free Software Foundation, Inc.
   4 ;; Time-stamp: <2006-01-23 18:21:18 guerry>
   5 ;;
   6 ;; Author: Bastien Guerry <bzg@altern.org>
   7 ;; Version: $Id: muse-registry.el,v 0.1 2006/01/23 17:21:21 guerry Exp $
   8 ;; Keywords: planner muse registry
   9
  10 ;; This file is part of Emacs Muse.  It is not part of GNU Emacs.
  11
  12 ;; Emacs Muse is free software; you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published
  14 ;; by the Free Software Foundation; either version 2, or (at your
  15 ;; option) any later version.
  16
  17 ;; Emacs Muse is distributed in the hope that it will be useful, but
  18 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  20 ;; General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with Emacs Muse; see the file COPYING.  If not, write to the
  24 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  25 ;; Boston, MA 02110-1301, USA.
  26
  27 ;;; Commentary:
  28
  29 ;; This module provides a way to keep track of all the URLs in your
  30 ;; projects, and to list them depending on the current buffer.  The
  31 ;; URLs are defined in `muse-url-protocols' - it does NOT include
  32 ;; wikiwords (for now).
  33 ;;
  34 ;; If a URL has been created by `planner-create-task-from-buffer',
  35 ;; going to that buffer and calling `muse-registry-show' will show you
  36 ;; where planner put the URL.
  37 ;;
  38 ;; Say for example that you created a task from an e-mail.  Go to that
  39 ;; e-mail and call `muse-registry-show': it will open a new buffer
  40 ;; displaying the files (in a muse links format) where a link to this
  41 ;; e-mail has been added.
  42
  43 ;;; Getting Started:
  44
  45 ;; Put this in your init file:
  46 ;;
  47 ;; (require 'muse-registry)
  48 ;; (muse-registry-initialize)
  49 ;;
  50 ;; You MUST put it after your planner config have been loaded.
  51 ;;
  52 ;; If you want the registry to be updated each time you save a Muse
  53 ;; file, add this:
  54 ;;
  55 ;; (muse-registry-insinuate)
  56 ;;
  57 ;; If you don't want to update the registry each time a file is
  58 ;; written, you can do it manually with `muse-registry-update': it
  59 ;; will update the registry for saved muse/planner buffers only.
  60 ;;
  61 ;; There's no default `define-key' for `muse-registry-show' because
  62 ;; it's not bounded to one particular mode.  You can bound it to
  63 ;; whatever you want.
  64
  65 ;;; Todo:
  66
  67 ;; 1) Better windows manipulations
  68 ;; 2) Wiki links support
  69
  70 ;;; Problems:
  71
  72 ;; If you're using this with Planner, the default value of
  73 ;; `planner-bibtex-separator' must be changed from ":" to something
  74 ;; else.
  75 ;;
  76 ;; (setq planner-bibtex-separator "#")
  77 ;;
  78 ;; "#" as a separator enables you to perform fuzzy-matching on bibtex
  79 ;; URLs as well.
  80
  81 ;;; History:
  82
  83 ;; 2005.11.22 - new release.
  84 ;; 2005.11.18 - first release.
  85
  86 ;;; Contributors:
  87
  88 ;;; Code:
  89
  90 ;;;_* Prerequisites
  91
  92 (require 'muse)
  93 (require 'muse-mode)
  94 (require 'muse-project)
  95
  96 ;;;_* Options
  97
  98 (defgroup muse-registry nil
  99   "A registry for muse and planner."
 100   :prefix "muse-registry-"
 101   :group 'muse)
 102
 103 ;; You can setq this var to what do you like.
 104 (defcustom muse-registry-file
 105   (concat (getenv "HOME") "/.muse-registry.el")
 106   "The registry file."
 107   :type 'string
 108   :group 'muse-registry)
 109
 110 (defcustom muse-registry-min-keyword-size 3
 111   "Minimum size for keywords."
 112   :type 'integer
 113   :group 'muse-registry)
 114
 115 (defcustom muse-registry-max-keyword-size 10
 116   "Maximum size for keywords."
 117   :type 'integer
 118   :group 'muse-registry)
 119
 120 (defcustom muse-registry-max-number-of-keywords 3
 121   "Maximum number of keywords."
 122   :type 'integer
 123   :group 'muse-registry)
 124
 125 (defcustom muse-registry-ignore-keywords
 126   '("E-Mail" "from" "www")
 127   "A list of ignored keywords."
 128   :type 'list
 129   :group 'muse-registry)
 130
 131 (defcustom muse-registry-show-level 0
 132   "Level for `muse-registry-show'.
 133 0 means that this function shows only exact matches.
 134 1 means that this function also shows descriptive matches.
 135 2 (or more) means that this function also shows fuzzy matches."
 136   :type 'boolean
 137   :group 'muse-registry)
 138
 139 ;;;_* Other variables and constants
 140
 141 (defvar muse-registry-alist nil
 142   "An alist containing the muse registry.")
 143
 144 (defconst muse-registry-url-regexp
 145   (concat "\\(" (mapconcat 'car muse-url-protocols "\\|") "\\)"
 146           "[^][" muse-regexp-blank "\"'()^`{}\n]*[^][" muse-regexp-blank
 147           "\"'()^`{}.,;\n]+")
 148   "A regexp that matches muse URL links.")
 149
 150 (defconst muse-registry-link-regexp
 151   (concat "\\[\\[\\(" muse-registry-url-regexp
 152           "\\)\\]\\[\\([^][\n]+\\)\\]\\]")
 153   "A regexp that matches muse explicit links.")
 154
 155 (defconst muse-registry-url-or-link-regexp
 156   (concat "\\(" muse-registry-url-regexp "\\)\\|"
 157           muse-registry-link-regexp)
 158   "A regexp that matches both muse URL and explicit links.
 159 The link is returned by `match-string' 3 or 1.
 160 The protocol is returned bu `match-string' 4 or 2.
 161 The description is returned by `match-string' 5")
 162
 163 ;;;_* Core code
 164
 165 ;;;###autoload
 166 (defun muse-registry-initialize (&optional from-scratch)
 167   "Set `muse-registry-alist' from `muse-registry-file'.
 168 If `muse-registry-file' doesn't exist, create it.
 169 If FROM-SCRATCH is non-nil, make the registry from scratch."
 170   (interactive "P")
 171   (if (or (not (file-exists-p muse-registry-file))
 172           from-scratch)
 173       (muse-registry-make-new-registry)
 174     (muse-registry-read-registry))
 175   (message "Muse registry initialized"))
 176
 177 (defun muse-registry-update nil
 178   "Update the registry from the current buffer."
 179   (interactive)
 180   (let* ((from-file (buffer-file-name))
 181          (new-entries
 182           (muse-registry-new-entries from-file)))
 183     (muse-registry-update-registry from-file new-entries))
 184   (with-temp-buffer
 185     (insert-file-contents muse-registry-file)
 186     (eval-buffer)))
 187
 188 (defun muse-registry-insinuate nil
 189   "Call `muse-registry-update' after saving in muse/planner modes.
 190 Use with caution.  This could slow down things a bit."
 191   (interactive)
 192   (when (boundp 'planner-mode-hook)
 193     (add-hook 'planner-mode-hook
 194               (lambda nil
 195                 (add-hook 'after-save-hook 'muse-registry-update t t))))
 196   (add-hook 'muse-mode-hook
 197             (lambda nil
 198               (add-hook 'after-save-hook 'muse-registry-update t t))))
 199
 200 (defun muse-registry-show (&optional level)
 201   "Show entries at LEVEL.
 202 See `muse-registry-show-level' for details."
 203   (interactive "p")
 204   (let ((annot (and (boundp 'planner-annotation-functions)
 205                     (run-hook-with-args-until-success
 206                      'planner-annotation-functions)))
 207         (level (or level muse-registry-show-level)))
 208     (if (not annot)
 209         (message "Annotation is not supported for this buffer")
 210       (let ((entries (muse-registry-get-entries annot level)))
 211         (if (not entries)
 212             (message
 213              (format "No match (level %d) for \"%s\"" level
 214                      (progn (string-match
 215                              muse-registry-url-or-link-regexp annot)
 216                             (match-string 5 annot))))
 217           (delete-other-windows)
 218           (switch-to-buffer-other-window
 219            (set-buffer (get-buffer-create "*Muse registry*")))
 220           (erase-buffer)
 221           (dolist (elem entries)
 222             (dolist (entry elem)
 223               (insert entry))
 224             (when elem (insert "\n")))
 225           (muse-mode))))))
 226
 227 (defun muse-registry-create nil
 228   "Create `muse-registry-file'."
 229   (let ((items muse-registry-alist)
 230         item)
 231     (with-temp-buffer
 232       (find-file muse-registry-file)
 233       (erase-buffer)
 234       (insert
 235        (with-output-to-string
 236          (princ ";; -*- emacs-lisp -*-\n")
 237          (princ ";; Muse registry\n;; What are you doing here?\n\n")
 238          (princ "(setq muse-registry-alist\n'(\n")
 239          (while items
 240            (when (setq item (pop items))
 241              (prin1 item)
 242              (princ "\n")))
 243          (princ "))\n")))
 244       (save-buffer)
 245       (kill-buffer (current-buffer))))
 246   (message "Muse registry created"))
 247
 248 (defun muse-registry-entry-output (entry)
 249   "Make an output string for ENTRY."
 250   (concat " - [[pos://" (car entry)
 251           "#" (nth 1 entry) "]["
 252           (muse-registry-get-project-name (car entry))
 253           ": " (file-name-nondirectory (car entry))
 254           "]] - [[" (nth 2 entry) "][" (nth 3 entry) "]]\n"))
 255
 256 (defun muse-registry-get-project-name (file)
 257   "Get project name for FILE."
 258   (let ((file1 (directory-file-name
 259                 (file-name-directory file))))
 260     (muse-replace-regexp-in-string "/?[^/]+/" "" file1 t t)))
 261
 262 (defun muse-registry-read-registry nil
 263   "Set `muse-registry-alist' from `muse-registry-file'."
 264   (with-temp-buffer
 265     (find-file muse-registry-file)
 266     (eval-buffer)
 267     (kill-buffer (current-buffer))))
 268
 269 (defun muse-registry-update-registry (from-file new-entries)
 270   "Update the registry FROM-FILE with NEW-ENTRIES."
 271   (with-temp-buffer
 272     (find-file muse-registry-file)
 273     (goto-char (point-min))
 274     (while (re-search-forward
 275             (concat "^(\"" from-file) nil t)
 276       (delete-region (muse-line-beginning-position)
 277                      (muse-line-end-position)))
 278     (goto-char (point-min))
 279     (re-search-forward "^(\"" nil t)
 280     (goto-char (match-beginning 0))
 281     (dolist (elem new-entries)
 282       (insert (with-output-to-string (prin1 elem)) "\n"))
 283     (save-buffer)
 284     (kill-buffer (current-buffer)))
 285     (message (format "Muse registry updated for URLs in %s"
 286                      (file-name-nondirectory
 287                       (buffer-file-name)))))
 288
 289 (defun muse-registry-make-new-registry nil
 290   "Make a new `muse-registry-alist' from scratch."
 291   (setq muse-registry-alist nil)
 292   (let ((muse-directories (mapcar 'caadr muse-project-alist))
 293         muse-directory)
 294     (while muse-directories
 295       (when (setq muse-directory (pop muse-directories))
 296         (mapcar (lambda (file)
 297                   (unless (or (file-directory-p file)
 298                               (let ((case-fold-search nil))
 299                                 (string-match muse-project-ignore-regexp
 300                                               file)))
 301                     (dolist (elem (muse-registry-new-entries file))
 302                       (add-to-list 'muse-registry-alist elem))))
 303                 (directory-files muse-directory t)))))
 304   (muse-registry-create))
 305
 306 (defun muse-registry-new-entries (file)
 307   "List links in FILE that will be put in the registry."
 308   (let (result)
 309     (with-temp-buffer
 310       (insert-file-contents file)
 311       (goto-char (point-min))
 312       (while (re-search-forward muse-registry-url-or-link-regexp nil t)
 313         (let* ((point (number-to-string (match-beginning 0)))
 314                (link (or (match-string-no-properties 3)
 315                          (match-string-no-properties 1)))
 316                (desc (or (match-string-no-properties 5)
 317                          (progn (string-match
 318                                  muse-registry-url-regexp link)
 319                                 (substring
 320                                  link (length (match-string 1 link))))))
 321                (keywords (muse-registry-get-keywords desc))
 322                (ln-keyword (muse-registry-get-link-keywords link)))
 323           (add-to-list 'result
 324                        (list file point link desc keywords ln-keyword)))))
 325     result))
 326
 327 (defun muse-registry-get-entries (annot level)
 328   "Show the relevant entries in the registry.
 329 ANNOT is the annotation for the current buffer.
 330 LEVEL is set interactively or  set to `muse-registry-show-level'."
 331   (when (string-match muse-registry-url-or-link-regexp annot)
 332     (let* ((link (or (match-string 3 annot)
 333                      (match-string 1 annot)))
 334            (desc (or (match-string 5 annot) ""))
 335            exact-match descriptive fuzzy)
 336       (dolist (entry muse-registry-alist)
 337         (let* ((output (muse-registry-entry-output entry))
 338                (keyword (nth 4 entry))
 339                (ln-keyword (nth 5 entry)))
 340           ;; exact matching
 341           (when (equal (nth 2 entry) link)
 342             (add-to-list 'exact-match output))
 343           ;; descriptive matching
 344           (when (and (> level 0) (equal (nth 3 entry) desc))
 345             (unless (member output exact-match)
 346               (add-to-list 'descriptive output)))
 347           ;; fuzzy matching
 348           (when (and (> level 1)
 349                      (or (string-match ln-keyword link)
 350                          (string-match keyword desc)))
 351             ;; use (muse-registry-get-keywords)?
 352             (unless (or (member output exact-match)
 353                         (member output descriptive))
 354               (add-to-list 'fuzzy output)))))
 355       (when exact-match
 356         (add-to-list 'exact-match
 357                      (concat "* Exact match(es):\n\n")))
 358       (when descriptive
 359         (add-to-list 'descriptive
 360                      (concat "* Description match(es):\n\n")))
 361       (when fuzzy
 362         (add-to-list 'fuzzy
 363                      (concat "* Fuzzy match(es):\n\n")))
 364       (cond (fuzzy (list exact-match descriptive fuzzy))
 365             (descriptive (list exact-match descriptive))
 366             (exact-match (list exact-match))
 367             (t nil)))))
 368
 369 (defun muse-registry-get-link-keywords (link)
 370   "Make a list of keywords for LINK."
 371   (setq link (car (split-string link "#" t))))
 372
 373 (defun muse-registry-get-keywords (desc)
 374   "Make a list of keywords for DESC."
 375   (let ((kw (split-string desc "[ ./]+" t)))
 376     (mapcar (lambda (wd) (setq kw (delete wd kw)))
 377             muse-registry-ignore-keywords)
 378     (setq kw
 379           (mapcar (lambda (a)
 380                     (when (>= (length a) muse-registry-min-keyword-size)
 381                       (substring
 382                        a 0 (if (> (length a) muse-registry-max-keyword-size)
 383                                muse-registry-max-keyword-size (length a)))))
 384                   kw))
 385     (setq kw (delq nil kw))
 386     (setq kw (nthcdr (- (length kw)
 387                         muse-registry-max-number-of-keywords) kw))
 388     (mapconcat (lambda (e) e) kw ".*")))
 389
 390 (provide 'muse-registry)
 391
 392 ;;; muse-registry.el ends here
 393 ;;
 394 ;; Local Variables:
 395 ;; indent-tabs-mode: t
 396 ;; tab-width: 8
 397 ;; End: