contrib/lisp/org-mtags.el

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