lisp/muse-registry.el

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