contrib/lisp/org-mtags.el

   1 ;;; org-mtags.el --- Muse-like tags in Org-mode
   2 ;; Copyright (C) 2008-2011 Free Software Foundation, Inc.
   3 ;;
   4 ;; Author: Carsten Dominik <carsten at orgmode dot org>
   5 ;; Keywords: outlines, hypermedia, calendar, wp
   6 ;; Homepage: http://orgmode.org
   7 ;; Version: 0.01
   8 ;;
   9 ;; This file is not yet part of GNU Emacs.
  10 ;;
  11 ;; GNU Emacs is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 3, or (at your option)
  14 ;; any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  24 ;; Boston, MA 02110-1301, USA.
  25 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  26 ;;
  27 ;;; Commentary:
  28 ;;
  29 ;; This modules implements some of the formatting tags available in
  30 ;; Emacs Muse.  This is not a way if adding new functionality, but just
  31 ;; a different way to write some formatting directives.  The advantage is
  32 ;; that files written in this way can be read by Muse reasonably well,
  33 ;; and that this provides an alternative way of writing formatting
  34 ;; directives in Org, a way that some might find more pleasant to type
  35 ;; and look at that the Org's #+BEGIN..#+END notation.
  36
  37 ;; The goal of this development is to make it easier for people to
  38 ;; move between both worlds as they see fit for different tasks.
  39
  40 ;; The following muse tags will be translated during export into their
  41 ;; native Org equivalents:
  42 ;;
  43 ;;   <br>
  44 ;;        Needs to be at the end of a line.  Will be translated to "\\".
  45 ;;
  46 ;;   <example switches="-n -r">
  47 ;;        Needs to be on a line by itself, similarly the </example> tag.
  48 ;;        Will be translated into Org's #+BEGIN_EXAMPLE construct.
  49 ;;
  50 ;;   <quote>
  51 ;;        Needs to be on a line by itself, similarly the </quote> tag.
  52 ;;        Will be translated into Org's #+BEGIN_QUOTE construct.
  53 ;;
  54 ;;   <comment>
  55 ;;        Needs to be on a line by itself, similarly the </comment> tag.
  56 ;;        Will be translated into Org's #+BEGIN_COMMENT construct.
  57 ;;
  58 ;;   <verse>
  59 ;;        Needs to be on a line by itself, similarly the </verse> tag.
  60 ;;        Will be translated into Org's #+BEGIN_VERSE construct.
  61 ;;
  62 ;;   <contents>
  63 ;;        This gets translated into "[TABLE-OF-CONTENTS]".  It will not
  64 ;;        trigger the production of a table of contents - that is done
  65 ;;        in Org with the "#+OPTIONS: toc:t" setting.  But it will define
  66 ;;        the location where the TOC will be placed.
  67 ;;
  68 ;;   <literal style="STYLE">    ;; only latex, html, and docbook supported
  69 ;;        in Org.
  70 ;;        Needs to be on a line by itself, similarly the </literal> tag.
  71 ;;
  72 ;;   <src lang="LANG" switches="-n -r">
  73 ;;        Needs to be on a line by itself, similarly the </src> tag.
  74 ;;        Will be translated into Org's BEGIN_SRC construct.
  75 ;;
  76 ;;   <include file="FILE" markup="MARKUP" lang="LANG"
  77 ;;            prefix="str" prefix1="str" switches="-n -r">
  78 ;;        Needs to be on a line by itself.
  79 ;;        Will be translated into Org's #+INCLUDE construct.
  80 ;;
  81 ;; The lisp/perl/ruby/python tags can be implemented using the
  82 ;; `org-eval.el' module, which see.
  83
  84 (require 'org)
  85
  86 ;;; Customization
  87
  88 (defgroup org-mtags nil
  89   "Options concerning Muse tags in Org mode."
  90   :tag "Org Muse Tags"
  91   :group 'org)
  92
  93 (defface org-mtags    ; similar to shadow
  94   (org-compatible-face 'shadow
  95     '((((class color grayscale) (min-colors 88) (background light))
  96        (:foreground "grey50"))
  97       (((class color grayscale) (min-colors 88) (background dark))
  98        (:foreground "grey70"))
  99       (((class color) (min-colors 8) (background light))
 100        (:foreground "green"))
 101       (((class color) (min-colors 8) (background dark))
 102        (:foreground "yellow"))))
 103   "Face for Muse-like tags in Org."
 104   :group 'org-mtags
 105   :group 'org-faces)
 106
 107 (defcustom org-mtags-prefer-muse-templates t
 108   "Non-nil means prefere Muse tags for structure elements.
 109 This is relevane when expanding the templates defined in the variable
 110 `org-structure-templates'."
 111   :group 'org-mtags
 112   :type 'boolean)
 113
 114 (defconst org-mtags-supported-tags
 115   '("example" "quote" "comment" "verse" "contents" "literal" "src" "include")
 116   "The tags that are supported by org-mtags.el for conversion.
 117 In addition to this list, the <br> tag is supported as well.")
 118
 119 (defconst org-mtags-fontification-re
 120   (concat
 121    "^[ \t]*</?\\("
 122    (mapconcat 'identity org-mtags-supported-tags "\\|")
 123    "\\)\\>[^>]*>\\|<br>[ \t]*$")
 124   "Regular expression used for fontifying muse tags.")
 125
 126 (defun org-mtags-replace ()
 127   "Replace Muse-like tags with the appropriate Org constructs.
 128 The is done in the entire buffer."
 129   (interactive) ;; FIXME
 130   (let ((re (concat "^[ \t]*\\(</?\\("
 131                     (mapconcat 'identity org-mtags-supported-tags "\\|")
 132                     "\\)\\>\\)"))
 133         info tag rpl style markup lang file prefix prefix1 switches)
 134     ;; First, do the <br> tag
 135     (goto-char (point-min))
 136     (while (re-search-forward "<br>[ \t]*$" nil t)
 137       (replace-match "\\\\" t t))
 138     ;; Now, all the other tags
 139     (goto-char (point-min))
 140     (while (re-search-forward re nil t)
 141       (goto-char (match-beginning 1))
 142       (setq info (org-mtags-get-tag-and-attributes))
 143       (if (not info)
 144           (end-of-line 1)
 145         (setq tag (plist-get info :tag))
 146         (cond
 147          ((equal tag "contents")
 148           (setq rpl "[TABLE-OF-CONTENTS]")
 149           ;; FIXME: also trigger TOC in options-plist?????
 150           )
 151          ((member tag '("quote" "comment" "verse"))
 152           (if (plist-get info :closing)
 153               (setq rpl (format "#+END_%s" (upcase tag)))
 154             (setq rpl (format "#+BEGIN_%s" (upcase tag)))))
 155          ((equal tag "literal")
 156           (setq style (plist-get info :style))
 157           (and style (setq style (downcase style)))
 158           (if (plist-get info :closing)
 159               (setq rpl (cond
 160                          ((member style '("latex"))
 161                           "#+END_LaTeX")
 162                          ((member style '("html"))
 163                           "#+END_HTML")
 164                          ((member style '("docbook"))
 165                           "#+END_DOCBOOK")
 166                          ((member style '("ascii"))
 167                           "#+END_ASCII")))
 168             (setq rpl (cond
 169                        ((member style '("latex"))
 170                         "#+BEGIN_LaTeX")
 171                        ((member style '("html"))
 172                         "#+BEGIN_HTML")
 173                        ((member style '("ascii"))
 174                         "#+BEGIN_ASCII")))))
 175          ((equal tag "example")
 176           (if (plist-get info :closing)
 177               (setq rpl "#+END_EXAMPLE")
 178             (setq rpl "#+BEGIN_EXAMPLE")
 179             (when (setq switches (plist-get info :switches))
 180               (setq rpl (concat rpl " " switches)))))
 181          ((equal tag "src")
 182           (if (plist-get info :closing)
 183               (setq rpl "#+END_SRC")
 184             (setq rpl "#+BEGIN_SRC")
 185             (when (setq lang (plist-get info :lang))
 186               (setq rpl (concat rpl " " lang))
 187               (when (setq switches (plist-get info :switches))
 188                 (setq rpl (concat rpl " " switches))))))
 189          ((equal tag "include")
 190           (setq file (plist-get info :file)
 191                 markup (downcase (plist-get info :markup))
 192                 lang (plist-get info :lang)
 193                 prefix (plist-get info :prefix)
 194                 prefix1 (plist-get info :prefix1)
 195                 switches (plist-get info :switches))
 196           (setq rpl "#+INCLUDE")
 197           (setq rpl (concat rpl " " (prin1-to-string file)))
 198           (when markup
 199             (setq rpl (concat rpl " " markup))
 200             (when (and (equal markup "src") lang)
 201               (setq rpl (concat rpl " " lang))))
 202           (when prefix
 203             (setq rpl (concat rpl " :prefix " (prin1-to-string prefix))))
 204           (when prefix1
 205             (setq rpl (concat rpl " :prefix1 " (prin1-to-string prefix1))))
 206           (when switches
 207             (setq rpl (concat rpl " " switches)))))
 208         (when rpl
 209           (goto-char (plist-get info :match-beginning))
 210           (delete-region (point-at-bol) (plist-get info :match-end))
 211           (insert rpl))))))
 212
 213 (defun org-mtags-get-tag-and-attributes ()
 214   "Parse a Muse-like tag at point ant rturn the information about it.
 215 The return value is a property list which contains all the attributes
 216 with string values.  In addition, it reutnrs the following properties:
 217
 218 :tag              The tag as a string.
 219 :match-beginning  The beginning of the match, just before \"<\".
 220 :match-end        The end of the match, just after \">\".
 221 :closing          t when the tag starts with \"</\"."
 222   (when (looking-at "<\\(/\\)?\\([a-zA-Z]+\\>\\)\\([^>]*\\)>")
 223     (let ((start 0)
 224           tag rest prop attributes endp val)
 225       (setq tag (org-match-string-no-properties 2)
 226             endp (match-end 1)
 227             rest (and (match-end 3)
 228                       (org-match-string-no-properties 3))
 229             attributes (list :tag tag
 230                              :match-beginning (match-beginning 0)
 231                              :match-end (match-end 0)
 232                              :closing endp))
 233       (when rest
 234         (while (string-match "\\([a-zA-Z]+\\)=\\([^ \t\n>]+\\|\"[^>]+\"\\)"
 235                              rest start)
 236           (setq start (match-end 0)
 237                 prop (org-match-string-no-properties 1 rest)
 238                 val (org-remove-double-quotes
 239                      (org-match-string-no-properties 2 rest)))
 240           (setq attributes (plist-put attributes
 241                                       (intern (concat ":" prop)) val))))
 242       attributes)))
 243
 244 (defun org-mtags-fontify-tags (limit)
 245   "Fontify the muse-like tags."
 246   (while (re-search-forward org-mtags-fontification-re limit t)
 247     (add-text-properties (match-beginning 0) (match-end 0)
 248                          '(face org-mtags font-lock-multiline t
 249                                 font-lock-fontified t))))
 250
 251 (add-hook 'org-export-preprocess-hook 'org-mtags-replace)
 252 (add-hook 'org-font-lock-hook 'org-mtags-fontify-tags)
 253
 254 (provide 'org-mtags)
 255
 256 ;;; org-mtags.el ends here
 257