lisp/muse-registry.el

   1 ;;; muse-registry.el --- URL registry for Muse
   2
   3 ;; Copyright (C) 2005  Bastien Guerry
   4 ;; Time-stamp: <2005-11-24 23:09:53 guerry>
   5 ;;
   6 ;; Author: bzg@altern.org
   7 ;; Version: $Id: muse-registry.el,v 0.3 2005/11/24 23:10:10 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 ;; 2000.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 '(repeat string)
 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           "[^][[:space:]\"'()^`{}]*[^][[:space:]\"'()^`{}.,;\n]+")
 142   "A regexp that matches muse URL links.")
 143
 144 (defconst muse-registry-link-regexp
 145   (concat "\\[\\[\\(" muse-registry-url-regexp
 146           "\\)\\]\\[\\([^][]+\\)\\]\\]")
 147   "A regexp that matches muse explicit links.")
 148
 149 (defconst muse-registry-url-or-link-regexp
 150   (concat "\\(" muse-registry-url-regexp "\\)\\|"
 151           muse-registry-link-regexp)
 152   "A regexp that matches both muse URL and explicit links.
 153 The link is returned by `match-string' 3 or 1.
 154 The protocol is returned bu `match-string' 4 or 2.
 155 The description is returned by `match-string' 5")
 156
 157 ;;;_* Core code
 158
 159 ;;;###autoload
 160 (defun muse-registry-initialize (&optional from-scratch)
 161   "Set `muse-registry-alist' from `muse-registry-file'.
 162 If `muse-registry-file' doesn't exist, create it.
 163 If FROM-SCRATCH is non-nil, make the registry from scratch."
 164   (interactive "P")
 165   (if (or (not (file-exists-p muse-registry-file))
 166           from-scratch)
 167       (muse-registry-make-new-registry)
 168     (muse-registry-read-registry))
 169   (message "Muse registry initialized"))
 170
 171 (defun muse-registry-update nil
 172   "Update the registry from the current buffer."
 173   (interactive)
 174   (let* ((from-file (buffer-file-name))
 175          (new-entries
 176           (muse-registry-new-entries from-file)))
 177     (muse-registry-update-registry from-file new-entries))
 178   (with-temp-buffer
 179     (find-file muse-registry-file)
 180     (eval-buffer)
 181     (kill-buffer (current-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           (mapc (lambda (elem)
 217                   (mapc (lambda (entry) (insert entry)) elem)
 218                   (when elem (insert "\n"))) entries)
 219           (muse-mode))))))
 220
 221 (defun muse-registry-create nil
 222   "Create `muse-registry-file'."
 223   (let ((items muse-registry-alist)
 224         item)
 225     (with-temp-buffer
 226       (find-file muse-registry-file)
 227       (erase-buffer)
 228       (insert
 229        (with-output-to-string
 230          (princ ";; -*- emacs-lisp -*-\n")
 231          (princ ";; Muse registry\n;; What are you doing here?\n\n")
 232          (princ "(setq muse-registry-alist\n'(\n")
 233          (while items
 234            (when (setq item (pop items))
 235              (prin1 item)
 236              (princ "\n")))
 237          (princ "))\n")))
 238       (save-buffer)
 239       (kill-buffer (current-buffer))))
 240   (message "Muse registry created"))
 241
 242 (defun muse-registry-entry-output (entry)
 243   "Make an output string for ENTRY."
 244   (concat " - [[pos://" (car entry)
 245           "#" (nth 1 entry) "]["
 246           (muse-registry-get-project-name (car entry))
 247           ": " (file-name-nondirectory (car entry))
 248           "]] - [[" (nth 2 entry) "][" (nth 3 entry) "]]\n"))
 249
 250 (defun muse-registry-get-project-name (file)
 251   "Get project name for FILE."
 252   (let ((file1 (directory-file-name
 253                 (file-name-directory file))))
 254     (replace-regexp-in-string "/?[^/]+/" "" file1)))
 255
 256 (defun muse-registry-read-registry nil
 257   "Set `muse-registry-alist' from `muse-registry-file'."
 258   (with-temp-buffer
 259     (find-file muse-registry-file)
 260     (eval-buffer)
 261     (kill-buffer (current-buffer))))
 262
 263 (defun muse-registry-update-registry (from-file new-entries)
 264   "Update the registry FROM-FILE with NEW-ENTRIES."
 265   (with-temp-buffer
 266     (find-file muse-registry-file)
 267     (goto-char (point-min))
 268     (while (re-search-forward
 269             (concat "^(\"" from-file) nil t)
 270       (delete-region (muse-line-beginning-position)
 271                      (muse-line-end-position)))
 272     (goto-char (point-min))
 273     (re-search-forward "^(\"" nil t)
 274     (goto-char (match-beginning 0))
 275     (mapc (lambda (elem)
 276             (insert
 277              (with-output-to-string (prin1 elem)) "\n"))
 278           new-entries)
 279     (save-buffer)
 280     (kill-buffer (current-buffer)))
 281     (message (format "Muse registry updated for URLs in %s"
 282                      (file-name-nondirectory
 283                       (buffer-file-name)))))
 284
 285 (defun muse-registry-make-new-registry nil
 286   "Make a new `muse-registry-alist' from scratch."
 287   (setq muse-registry-alist nil)
 288   (let ((muse-directories (mapcar 'caadr muse-project-alist))
 289         muse-directory)
 290     (while muse-directories
 291       (when (setq muse-directory (pop muse-directories))
 292         (mapcar (lambda (file)
 293                   (unless (or (string-match "d" (nth 9 file))
 294                               (string-match muse-project-ignore-regexp
 295                                             (car file)))
 296                     (mapc (lambda (elem)
 297                             (add-to-list 'muse-registry-alist elem))
 298                           (muse-registry-new-entries (car file)))))
 299                 (directory-files-and-attributes muse-directory t)))))
 300   (muse-registry-create))
 301
 302 (defun muse-registry-new-entries (file)
 303   "List links in FILE that will be put in the registry."
 304   (let (result)
 305     (with-temp-buffer
 306       (insert-file-contents file)
 307       (goto-char (point-min))
 308       (while (re-search-forward muse-registry-url-or-link-regexp nil t)
 309         (let* ((point (number-to-string (match-beginning 0)))
 310                (link (or (match-string-no-properties 3)
 311                          (match-string-no-properties 1)))
 312                (desc (or (match-string-no-properties 5)
 313                          (progn (string-match
 314                                  muse-registry-url-regexp link)
 315                                 (substring
 316                                  link (length (match-string 1 link))))))
 317                (keywords (muse-registry-get-keywords desc))
 318                (ln-keyword (muse-registry-get-link-keywords link)))
 319           (add-to-list 'result
 320                        (list file point link desc keywords ln-keyword)))))
 321     result))
 322
 323 (defun muse-registry-get-entries (annot level)
 324   "Show the relevant entries in the registry.
 325 ANNOT is the annotation for the current buffer.
 326 LEVEL is set interactively or  set to `muse-registry-show-level'."
 327   (when (string-match muse-registry-url-or-link-regexp annot)
 328     (let* ((link (or (match-string 3 annot)
 329                      (match-string 1 annot)))
 330            (desc (or (match-string 5 annot) ""))
 331            exact-match descriptive fuzzy)
 332       (dolist (entry muse-registry-alist)
 333         (let* ((output (muse-registry-entry-output entry))
 334                (keyword (nth 4 entry))
 335                (ln-keyword (nth 5 entry)))
 336           ;; exact matching
 337           (when (equal (nth 2 entry) link)
 338             (add-to-list 'exact-match output))
 339           ;; descriptive matching
 340           (when (and (> level 0) (equal (nth 3 entry) desc))
 341             (unless (member output exact-match)
 342               (add-to-list 'descriptive output)))
 343           ;; fuzzy matching
 344           (when (and (> level 1)
 345                      (or (string-match ln-keyword link)
 346                          (string-match keyword desc)))
 347             ;; use (muse-registry-get-keywords)?
 348             (unless (or (member output exact-match)
 349                         (member output descriptive))
 350               (add-to-list 'fuzzy output)))))
 351       (when exact-match
 352         (add-to-list 'exact-match
 353                      (concat "* Exact match(es):\n\n")))
 354       (when descriptive
 355         (add-to-list 'descriptive
 356                      (concat "* Description match(es):\n\n")))
 357       (when fuzzy
 358         (add-to-list 'fuzzy
 359                      (concat "* Fuzzy match(es):\n\n")))
 360       (cond (fuzzy (list exact-match descriptive fuzzy))
 361             (descriptive (list exact-match descriptive))
 362             (exact-match (list exact-match))
 363             (t nil)))))
 364
 365 (defun muse-registry-get-link-keywords (link)
 366   "Make a list of keywords for LINK."
 367   (setq link (car (split-string link "#" t))))
 368
 369 (defun muse-registry-get-keywords (desc)
 370   "Make a list of keywords for DESC."
 371   (let ((kw (split-string desc "[ ./]+" t)))
 372     (mapcar (lambda (wd) (setq kw (delete wd kw)))
 373             muse-registry-ignore-keywords)
 374     (setq kw
 375           (mapcar (lambda (a)
 376                     (when (>= (length a) muse-registry-min-keyword-size)
 377                       (substring
 378                        a 0 (if (> (length a) muse-registry-max-keyword-size)
 379                                muse-registry-max-keyword-size (length a)))))
 380                   kw))
 381     (setq kw (delq nil kw))
 382     (setq kw (nthcdr (- (length kw)
 383                         muse-registry-max-number-of-keywords) kw))
 384     (mapconcat (lambda (e) e) kw ".*")))
 385
 386 (provide 'muse-registry)
 387
 388 ;;; muse-registry.el ends here
 389 ;;
 390 ;; Local Variables:
 391 ;; indent-tabs-mode: nil
 392 ;; End: