lisp/muse-wiki.el

   1 ;;; muse-wiki.el --- wiki features for Muse
   2
   3 ;; Copyright (C) 2005, 2006 Free Software Foundation, Inc.
   4
   5 ;; Author: Yann Hodique <Yann.Hodique@lifl.fr>
   6 ;; Keywords:
   7
   8 ;; This file is part of Emacs Muse.  It is not part of GNU Emacs.
   9
  10 ;; Emacs Muse is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published
  12 ;; by the Free Software Foundation; either version 2, or (at your
  13 ;; option) any later version.
  14
  15 ;; Emacs Muse is distributed in the hope that it will be useful, but
  16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  18 ;; General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with Emacs Muse; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  23 ;; Boston, MA 02110-1301, USA.
  24
  25 ;;; Commentary:
  26
  27 ;;; Contributors:
  28
  29 ;; Per B. Sederberg (per AT med DOT upenn DOT edu) made it so that all
  30 ;; files in a Muse project can become implicit links.
  31
  32 ;;; Code:
  33
  34 (require 'muse-regexps)
  35 (require 'muse-mode)
  36
  37 (eval-when-compile
  38   (require 'muse-colors))
  39
  40 (defgroup muse-wiki nil
  41   "Options controlling the behavior of Emacs Muse Wiki features."
  42   :group 'muse-mode)
  43
  44 (defcustom muse-wiki-use-wikiword t
  45   "Whether to use color and publish bare WikiNames."
  46   :type 'boolean
  47   :group 'muse-wiki)
  48
  49 (defcustom muse-wiki-allow-nonexistent-wikiword nil
  50   "Whether to color bare WikiNames that don't have an existing file."
  51   :type 'boolean
  52   :group 'muse-wiki)
  53
  54 (defcustom muse-wiki-match-all-project-files nil
  55   "Whether to extend WikiName functionality to also match
  56 existing filenames, regardless of whether they are named in
  57 WikiWord format.
  58
  59 If non-nil, Muse will color and publish implicit links to any
  60 file in your project."
  61   :type 'boolean
  62   :group 'muse-wiki)
  63
  64 (defcustom muse-wiki-ignore-implicit-links-to-current-page nil
  65   "Whether to ignore implicit links to the current page.
  66
  67 If non-nil, Muse will not recognize implicit links to the current
  68 page, both when formatting and publishing."
  69   :type 'boolean
  70   :group 'muse-wiki)
  71
  72 (defvar muse-wiki-updating-wikiword-p nil
  73   "Prevent recursive calls to `muse-wiki-update-local-wikiword-regexp'.")
  74
  75 (eval-when-compile
  76   (defvar muse-wiki-wikiword-regexp))
  77
  78 (defun muse-wiki-update-local-wikiword-regexp ()
  79   "Update a local copy of `muse-wiki-wikiword-regexp' to include
  80 all the files in the project."
  81   ;; see if the user wants to append project files
  82   (when (and muse-wiki-use-wikiword
  83              muse-wiki-match-all-project-files
  84              (not muse-wiki-updating-wikiword-p))
  85     (let ((muse-wiki-updating-wikiword-p t))
  86       ;; make the regexp local
  87       (set (make-local-variable 'muse-wiki-wikiword-regexp)
  88            (concat "\\(\\<\\(?:"
  89                    ;; append the files from the project
  90                    (mapconcat 'car
  91                               (muse-project-file-alist (muse-project))
  92                               "\\|")
  93                    "\\)\\>\\|\\(?:"
  94                    (default-value 'muse-wiki-wikiword-regexp)
  95                    "\\)\\)"))
  96       ;; update coloring setup
  97       (when (featurep 'muse-colors)
  98         (muse-configure-highlighting
  99          'muse-colors-markup muse-colors-markup)))))
 100
 101 (add-hook 'muse-update-values-hook
 102           'muse-wiki-update-local-wikiword-regexp)
 103 (add-hook 'muse-project-file-alist-hook
 104           'muse-wiki-update-local-wikiword-regexp)
 105
 106 (defun muse-wiki-update-wikiword-regexp (sym val)
 107   "Update everything related to `muse-wiki-wikiword-regexp'."
 108   (set sym val)
 109   (muse-wiki-update-local-wikiword-regexp)
 110   (when (featurep 'muse-colors)
 111     (muse-configure-highlighting 'muse-colors-markup muse-colors-markup)))
 112
 113 (defcustom muse-wiki-wikiword-regexp
 114   (concat "\\<\\(\\(?:[" muse-regexp-upper
 115           "]+[" muse-regexp-lower "]+\\)\\(?:["
 116           muse-regexp-upper "]+[" muse-regexp-lower "]+\\)+\\)")
 117   "Regexp used to match WikiWords."
 118   :type 'regexp
 119   :group 'muse-wiki
 120   :set 'muse-wiki-update-wikiword-regexp)
 121
 122 (defcustom muse-wiki-ignore-bare-project-names nil
 123   "Determine whether project names without a page specifer are links.
 124 If non-nil, project names without a page specifier will not be
 125 considered links.
 126 When nil, project names without a specifier are highlighted and
 127 they link to the default page of the project that they name."
 128   :type 'boolean
 129   :group 'muse-wiki)
 130
 131 (defvar muse-wiki-interwiki-regexp ""
 132   "Regexp that matches all interwiki links.
 133 This is automatically generated by setting `muse-wiki-interwiki-alist'.
 134 It can also be set by calling `muse-wiki-update-interwiki-regexp'.")
 135
 136 (defcustom muse-wiki-interwiki-delimiter "#\\|::"
 137   "Delimiter regexp used for InterWiki links.
 138 If you use groups, use only shy groups."
 139   :type 'regexp
 140   :group 'muse-wiki)
 141
 142 (defcustom muse-wiki-interwiki-replacement ": "
 143   "Regexp used for replacing `muse-wiki-interwiki-delimiter' in
 144 InterWiki link descriptions.
 145
 146 If you want this replacement to happen, you must add
 147 `muse-wiki-publish-pretty-interwiki' to
 148 `muse-publish-desc-transforms'."
 149   :type 'regexp
 150   :group 'muse-wiki)
 151
 152 (eval-when-compile
 153   (defvar muse-wiki-interwiki-alist))
 154
 155 (defun muse-wiki-project-files-with-spaces (&optional project)
 156   "Return a list of files in PROJECT that have spaces."
 157   (setq project (muse-project project))
 158   (let ((flist nil))
 159     (save-match-data
 160       (mapcar (function (lambda (file)
 161                           (when (string-match " " (car file))
 162                             (setq flist (cons (car file) flist)))))
 163               (muse-project-file-alist project)))
 164     flist))
 165
 166 (defun muse-wiki-update-interwiki-regexp ()
 167   "Update the value of `muse-wiki-interwiki-regexp' based on
 168 `muse-wiki-interwiki-alist' and `muse-project-alist'."
 169   (setq muse-wiki-interwiki-regexp
 170         (concat "\\<\\(" (mapconcat 'car muse-project-alist "\\|")
 171                 (when muse-wiki-interwiki-alist
 172                   (concat "\\|" (mapconcat 'car muse-wiki-interwiki-alist
 173                                            "\\|")))
 174                 "\\)\\(?:\\(?:" muse-wiki-interwiki-delimiter
 175                 "\\)\\("
 176                 (when muse-wiki-match-all-project-files
 177                   ;; append the files from the project
 178                   (concat
 179                    (mapconcat
 180                     (function
 181                      (lambda (proj)
 182                        (mapconcat 'identity
 183                                   (muse-wiki-project-files-with-spaces
 184                                    (car proj))
 185                                   "\\|")))
 186                     muse-project-alist "")
 187                    "\\|"))
 188                 "\\sw+\\)\\)?\\>"))
 189   (when (featurep 'muse-colors)
 190     (muse-configure-highlighting 'muse-colors-markup muse-colors-markup)))
 191
 192 (defcustom muse-wiki-interwiki-alist
 193   '(("EmacsWiki" . "http://www.emacswiki.org/cgi-bin/wiki/"))
 194   "A table of WikiNames that refer to external entities.
 195 The format of this table is an alist, or series of cons cells.
 196 Each cons cell must be of the form:
 197
 198   (WIKINAME . STRING-OR-FUNCTION)
 199
 200 The second part of the cons cell may either be a STRING, which in most
 201 cases should be a URL, or a FUNCTION.  If a function, it will be
 202 called with one argument: the tag applied to the Interwiki name, or
 203 nil if no tag was used.  If the cdr was a STRING and a tag is used,
 204 the tag is simply appended.
 205
 206 Here are some examples:
 207
 208   (\"JohnWiki\" . \"http://alice.dynodns.net/wiki?\")
 209
 210 Referring to [[JohnWiki::EmacsModules]] then really means:
 211
 212   http://alice.dynodns.net/wiki?EmacsModules
 213
 214 If a function is used for the replacement text, you can get creative
 215 depending on what the tag is.  Tags may contain any alphabetic
 216 character, any number, % or _.  If you need other special characters,
 217 use % to specify the hex code, as in %2E.  All browsers should support
 218 this."
 219   :type '(repeat (cons (string :tag "WikiName")
 220                        (choice (string :tag "URL") function)))
 221   :set (function
 222         (lambda (sym value)
 223           (set sym value)
 224           (muse-wiki-update-interwiki-regexp)))
 225   :group 'muse-wiki)
 226
 227 (add-hook 'muse-update-values-hook
 228           'muse-wiki-update-interwiki-regexp)
 229
 230 (defun muse-wiki-choose-style-by-link-suffix (given-suffix style)
 231   "If the given STYLE has a link-suffix that equals GIVEN-SUFFIX,
 232 return non-nil."
 233   (let ((link-suffix (muse-style-element :link-suffix style)))
 234     (and (stringp link-suffix)
 235          (string= given-suffix link-suffix))))
 236
 237 (defun muse-wiki-resolve-project-page-1 (page local-styles remote-styles)
 238   "Pick the best match for PAGE given potential local and remote styles.
 239 See `muse-wiki-resolve-project-page' for more information."
 240   (let ((link-suffix (muse-style-element :link-suffix))
 241         remote-style local-style prefix)
 242     (if (not (stringp link-suffix))
 243         (progn
 244           (setq remote-style (car remote-styles)
 245                 local-style (car local-styles)))
 246       (setq remote-style (muse-project-choose-style
 247                           link-suffix
 248                           #'muse-wiki-choose-style-by-link-suffix
 249                           remote-styles)
 250             local-style (muse-project-choose-style
 251                          link-suffix
 252                          #'muse-wiki-choose-style-by-link-suffix
 253                          local-styles)))
 254     (setq prefix (muse-style-element :base-url remote-style))
 255     (muse-publish-link-file
 256      (if prefix
 257          (concat prefix page)
 258        (file-relative-name (expand-file-name
 259                             page
 260                             (muse-style-element :path remote-style))
 261                            (expand-file-name
 262                             (muse-style-element :path local-style))))
 263      nil remote-style)))
 264
 265 (defun muse-wiki-resolve-project-page (&optional project page)
 266   "Return the published path from the current page to PAGE of PROJECT.
 267 If PAGE is not specified, use the value of :default in PROJECT.
 268 If PROJECT is not specified, default to first project of
 269 `muse-projects-alist'.
 270
 271 Note that PAGE can have several output directories.  If this is
 272 the case, we will use the first one that matches our current
 273 style and has the same link suffix, ignoring the others.  If no
 274 style has the same link suffix as the current publishing style,
 275 use the first style we find."
 276   (setq project (or (and project
 277                          (muse-project project))
 278                     (car muse-project-alist))
 279         page (or page (muse-get-keyword :default
 280                                         (cadr project))))
 281   (let* ((page-path (muse-project-page-file page project))
 282          (remote-styles (when page-path (muse-project-applicable-styles
 283                                          page-path (cddr project))))
 284          (local-styles (muse-project-applicable-styles
 285                         (muse-current-file)
 286                         (cddr (muse-project-of-file)))))
 287     (cond ((and remote-styles local-styles muse-publishing-p)
 288            (muse-wiki-resolve-project-page-1 page local-styles remote-styles))
 289           ((not muse-publishing-p)
 290            (if page-path
 291                page-path
 292              (when muse-wiki-allow-nonexistent-wikiword
 293                ;; make a path to a nonexistent file in project
 294                (setq page-path (expand-file-name
 295                                 page (car (cadr project))))
 296                (if (and muse-file-extension
 297                         (not (string= muse-file-extension "")))
 298                    (concat page-path "." muse-file-extension)
 299                  page-path)))))))
 300
 301 (defun muse-wiki-handle-interwiki (&optional string)
 302   "If STRING or point has an interwiki link, resolve it and
 303 return the first match.
 304 Match 1 is set to the link.
 305 Match 2 is set to the description."
 306   (when (if string (string-match muse-wiki-interwiki-regexp string)
 307           (looking-at muse-wiki-interwiki-regexp))
 308     (let* ((project (match-string 1 string))
 309            (subst (cdr (assoc project muse-wiki-interwiki-alist)))
 310            (word (if string
 311                      (and (match-beginning 2)
 312                           (substring string (match-beginning 2)))
 313                    (match-string 2 string))))
 314       (if subst
 315           (if (functionp subst)
 316               (funcall subst word)
 317             (concat subst word))
 318         (and (assoc project muse-project-alist)
 319              (or word (not muse-wiki-ignore-bare-project-names))
 320              (muse-wiki-resolve-project-page project word))))))
 321
 322 (defun muse-wiki-handle-wikiword (&optional string)
 323   "If STRING or point has a WikiWord, return it.
 324 Match 1 is set to the WikiWord."
 325   (when (and muse-wiki-use-wikiword
 326              (if string
 327                  (string-match muse-wiki-wikiword-regexp string)
 328                (looking-at muse-wiki-wikiword-regexp))
 329              (cond
 330               (muse-wiki-allow-nonexistent-wikiword
 331                t)
 332               ((and muse-wiki-ignore-implicit-links-to-current-page
 333                     (string= (match-string 1 string) (muse-page-name)))
 334                nil)
 335               ((and (muse-project-of-file)
 336                     (muse-project-page-file
 337                      (match-string 1 string) muse-current-project t))
 338                t)
 339               ((file-exists-p (match-string 1 string))
 340                t)
 341               (t nil)))
 342     (match-string 1 string)))
 343
 344 ;; Prettifications
 345
 346 (defcustom muse-wiki-publish-small-title-words
 347   '("the" "and" "at" "on" "of" "for" "in" "an" "a")
 348   "Strings that should be downcased in a page title.
 349 This is used by `muse-wiki-publish-pretty-title', which must be
 350 called manually."
 351   :type '(repeat string)
 352   :group 'muse-wiki)
 353
 354 (defcustom muse-wiki-hide-nop-tag t
 355   "If non-nil, hide <nop> tags when coloring a Muse buffer."
 356   :type 'boolean
 357   :group 'muse-wiki)
 358
 359 (defun muse-wiki-publish-pretty-title (&optional title explicit)
 360   "Return a pretty version of the given TITLE.
 361 If EXPLICIT is non-nil, TITLE will be returned unmodified."
 362   (unless title (setq title (or (muse-publishing-directive "title") "")))
 363   (if (or explicit
 364           (save-match-data (string-match muse-url-regexp title)))
 365       title
 366     (save-match-data
 367       (let ((case-fold-search nil))
 368         (while (string-match (concat "\\([" muse-regexp-lower
 369                                      "]\\)\\([" muse-regexp-upper
 370                                      "0-9]\\)")
 371                              title)
 372           (setq title (replace-match "\\1 \\2" t nil title)))
 373         (let* ((words (split-string title))
 374                (w (cdr words)))
 375           (while w
 376             (if (member (downcase (car w))
 377                         muse-wiki-publish-small-title-words)
 378                 (setcar w (downcase (car w))))
 379             (setq w (cdr w)))
 380           (mapconcat 'identity words " "))))))
 381
 382 (defun muse-wiki-publish-pretty-interwiki (desc &optional explicit)
 383   "Replace instances of `muse-wiki-interwiki-delimiter' with
 384 `muse-wiki-interwiki-replacement'."
 385   (if (or explicit
 386           (save-match-data (string-match muse-url-regexp desc)))
 387       desc
 388     (muse-replace-regexp-in-string muse-wiki-interwiki-delimiter
 389                                    muse-wiki-interwiki-replacement
 390                                    desc)))
 391
 392 ;; Coloring setup
 393
 394 (eval-after-load "muse-colors"
 395   '(progn
 396      (defun muse-wiki-colors-nop-tag (beg end)
 397        (when muse-wiki-hide-nop-tag
 398          (add-text-properties beg (+ beg 5)
 399                               '(invisible muse intangible t))))
 400      (defun muse-colors-wikiword-separate ()
 401        (add-text-properties (match-beginning 0) (match-end 0)
 402                             '(invisible muse intangible t)))
 403
 404      (add-to-list 'muse-colors-tags
 405                   '("nop" nil nil muse-wiki-colors-nop-tag)
 406                   t)
 407
 408      (add-to-list 'muse-colors-markup
 409                   '(muse-wiki-interwiki-regexp t muse-colors-implicit-link)
 410                   t)
 411      (add-to-list 'muse-colors-markup
 412                   '(muse-wiki-wikiword-regexp t muse-colors-implicit-link)
 413                   t)
 414      (add-to-list 'muse-colors-markup
 415                   '("''''" ?\' muse-colors-wikiword-separate)
 416                   nil)
 417
 418      (muse-configure-highlighting 'muse-colors-markup muse-colors-markup)))
 419
 420 ;; Publishing setup
 421
 422 (eval-after-load "muse-publish"
 423   '(progn
 424      (add-to-list 'muse-publish-markup-regexps
 425                   '(3100 muse-wiki-interwiki-regexp 0 link)
 426                   t)
 427      (add-to-list 'muse-publish-markup-regexps
 428                   '(3200 muse-wiki-wikiword-regexp 0 link)
 429                   t)
 430      (add-to-list 'muse-publish-markup-regexps
 431                   '(3300 "''''" 0 "")
 432                   t)
 433
 434      (custom-add-option 'muse-publish-desc-transforms
 435                         'muse-wiki-publish-pretty-interwiki)
 436      (custom-add-option 'muse-publish-desc-transforms
 437                         'muse-wiki-publish-pretty-title)))
 438
 439 ;; Insinuate link handling
 440
 441 (custom-add-option 'muse-implicit-link-functions
 442                    'muse-wiki-handle-interwiki)
 443 (custom-add-option 'muse-implicit-link-functions
 444                    'muse-wiki-handle-wikiword)
 445
 446 (custom-add-option 'muse-explicit-link-functions
 447                    'muse-wiki-handle-interwiki)
 448
 449 (add-to-list 'muse-implicit-link-functions
 450              'muse-wiki-handle-interwiki t)
 451 (add-to-list 'muse-implicit-link-functions
 452              'muse-wiki-handle-wikiword t)
 453
 454 (add-to-list 'muse-explicit-link-functions
 455              'muse-wiki-handle-interwiki t)
 456
 457 ;; Obsolete functions
 458
 459 (defun muse-wiki-update-custom-values ()
 460   (muse-display-warning
 461    (concat "Please remove `muse-wiki-update-custom-values' from"
 462            " `muse-mode-hook'.  Its use is now deprecated.")))
 463
 464 (provide 'muse-wiki)
 465 ;;; muse-wiki.el ends here