lisp/org-exp-blocks.el

   1 ;;; org-exp-blocks.el --- pre-process blocks when exporting org files
   2
   3 ;; Copyright (C) 2009
   4 ;;   Free Software Foundation, Inc.
   5
   6 ;; Author: Eric Schulte
   7
   8 ;; This file is part of GNU Emacs.
   9 ;;
  10 ;; GNU Emacs 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 3 of the License, or
  13 ;; (at your option) any later version.
  14
  15 ;; GNU Emacs 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 GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 ;;; Commentary:
  24 ;;
  25 ;; This is a utility for pre-processing blocks in org files before
  26 ;; export using the `org-export-preprocess-hook'.  It can be used for
  27 ;; exporting new types of blocks from org-mode files and also for
  28 ;; changing the default export behavior of existing org-mode blocks.
  29 ;; The `org-export-blocks' and `org-export-interblocks' variables can
  30 ;; be used to control how blocks and the spaces between blocks
  31 ;; respectively are processed upon export.
  32 ;;
  33 ;; The type of a block is defined as the string following =#+begin_=,
  34 ;; so for example the following block would be of type ditaa.  Note
  35 ;; that both upper or lower case are allowed in =#+BEGIN_= and
  36 ;; =#+END_=.
  37 ;;
  38 ;; #+begin_ditaa blue.png -r -S
  39 ;; +---------+
  40 ;; | cBLU    |
  41 ;; |         |
  42 ;; |    +----+
  43 ;; |    |cPNK|
  44 ;; |    |    |
  45 ;; +----+----+
  46 ;; #+end_ditaa
  47 ;;
  48 ;;; Currently Implemented Block Types
  49 ;;
  50 ;; ditaa :: Convert ascii pictures to actual images using ditaa
  51 ;;          http://ditaa.sourceforge.net/.  To use this set
  52 ;;          `org-ditaa-jar-path' to the path to ditaa.jar on your
  53 ;;          system (should be set automatically in most cases) .
  54 ;;
  55 ;; dot :: Convert graphs defined using the dot graphing language to
  56 ;;        images using the dot utility.  For information on dot see
  57 ;;        http://www.graphviz.org/
  58 ;;
  59 ;; comment :: Wrap comments with titles and author information, in
  60 ;;            their own divs with author-specific ids allowing for css
  61 ;;            coloring of comments based on the author.
  62 ;;
  63 ;; R :: Implements Sweave type exporting, evaluates blocks of R code,
  64 ;;      and also replaces \R{} chunks in the file with their result
  65 ;;      when passed to R.  This require the `R' command which is
  66 ;;      provided by ESS (Emacs Speaks Statistics).
  67 ;;
  68 ;;; Adding new blocks
  69 ;;
  70 ;; When adding a new block type first define a formatting function
  71 ;; along the same lines as `org-export-blocks-format-dot' and then use
  72 ;; `org-export-blocks-add-block' to add your block type to
  73 ;; `org-export-blocks'.
  74
  75 (require 'org)
  76
  77 (defvar comint-last-input-end)
  78 (defvar comint-prompt-regexp)
  79 (defvar comint-last-input-end)
  80 (defvar htmlp)
  81 (defvar latexp)
  82 (defvar docbookp)
  83 (defvar asciip)
  84
  85 (declare-function comint-send-input "comint" (&optional no-newline artificial))
  86 (declare-function R "ess" nil)
  87
  88 (defun org-export-blocks-set (var value)
  89   "Set the value of `org-export-blocks' and install fontification."
  90   (set var value)
  91   (mapc (lambda (spec)
  92           (if (nth 2 spec)
  93               (setq org-protecting-blocks
  94                     (delete (symbol-name (car spec))
  95                             org-protecting-blocks))
  96             (add-to-list 'org-protecting-blocks
  97                          (symbol-name (car spec)))))
  98         value))
  99
 100 (defcustom org-export-blocks
 101   '((comment org-export-blocks-format-comment t)
 102     (ditaa org-export-blocks-format-ditaa nil)
 103     (dot org-export-blocks-format-dot nil)
 104     (r org-export-blocks-format-R nil)
 105     (R org-export-blocks-format-R nil))
 106   "Use this a-list to associate block types with block exporting
 107 functions.  The type of a block is determined by the text
 108 immediately following the '#+BEGIN_' portion of the block header.
 109 Each block export function should accept three argumets..."
 110   :group 'org-export-general
 111   :type '(repeat
 112           (list
 113            (symbol :tag "Block name")
 114            (function :tag "Block formatter")
 115            (boolean :tag "Fontify content as Org syntax")))
 116   :set 'org-export-blocks-set)
 117
 118 (defun org-export-blocks-add-block (block-spec)
 119   "Add a new block type to `org-export-blocks'.  BLOCK-SPEC
 120 should be a three element list the first element of which should
 121 indicate the name of the block, the second element should be the
 122 formatting function called by `org-export-blocks-preprocess' and
 123 the third element a flag indicating whether these types of blocks
 124 should be fontified in org-mode buffers (see
 125 `org-protecting-blocks').  For example the BLOCK-SPEC for ditaa
 126 blocks is as follows...
 127
 128   (ditaa org-export-blocks-format-ditaa nil)"
 129   (unless (member block-spec org-export-blocks)
 130     (setq org-export-blocks (cons block-spec org-export-blocks))
 131     (org-export-blocks-set 'org-export-blocks org-export-blocks)))
 132
 133 (defcustom org-export-interblocks
 134   '((r org-export-interblocks-format-R)
 135     (R org-export-interblocks-format-R))
 136   "Use this a-list to associate block types with block exporting
 137 functions.  The type of a block is determined by the text
 138 immediately following the '#+BEGIN_' portion of the block header.
 139 Each block export function should accept three argumets..."
 140   :group 'org-export-general
 141   :type 'alist)
 142
 143 (defcustom org-export-blocks-witheld
 144   '(hidden)
 145   "List of block types (see `org-export-blocks') which should not
 146 be exported."
 147   :group 'org-export-general
 148   :type 'list)
 149
 150 (defvar org-export-blocks-postblock-hooks nil "")
 151
 152 (defun org-export-blocks-html-quote (body &optional open close)
 153   "Protext BODY from org html export.  The optional OPEN and
 154 CLOSE tags will be inserted around BODY."
 155   (concat
 156    "\n#+BEGIN_HTML\n"
 157    (or open "")
 158    body (if (string-match "\n$" body) "" "\n")
 159    (or close "")
 160    "#+END_HTML\n"))
 161
 162 (defun org-export-blocks-latex-quote (body &optional open close)
 163   "Protext BODY from org latex export.  The optional OPEN and
 164 CLOSE tags will be inserted around BODY."
 165   (concat
 166    "\n#+BEGIN_LaTeX\n"
 167    (or open "")
 168    body (if (string-match "\n$" body) "" "\n")
 169    (or close "")
 170    "#+END_LaTeX\n"))
 171
 172 (defun org-export-blocks-preprocess ()
 173   "Export all blocks acording to the `org-export-blocks' block
 174 exportation alist.  Does not export block types specified in
 175 specified in BLOCKS which default to the value of
 176 `org-export-blocks-witheld'."
 177   (interactive)
 178   (save-window-excursion
 179     (let ((count 0)
 180           (blocks org-export-blocks-witheld)
 181           (case-fold-search t)
 182           (types '())
 183           indentation type func start end)
 184       (flet ((interblock (start end type)
 185                          (save-match-data
 186                            (when (setf func (cadr (assoc type org-export-interblocks)))
 187                              (funcall func start end)))))
 188         (goto-char (point-min))
 189         (setf start (point))
 190         (while (re-search-forward
 191                 "^\\([ \t]*\\)#\\+begin_\\(\\S-+\\)[ \t]*\\(.*\\)?[\r\n]\\([^\000]*?\\)[\r\n][ \t]*#\\+end_\\S-+.*" nil t)
 192           (save-match-data (setq indentation (length (match-string 1))))
 193           (save-match-data (setf type (intern (match-string 2))))
 194           (unless (memq type types) (setf types (cons type types)))
 195           (setf end (save-match-data (match-beginning 0)))
 196           (interblock start end type)
 197           (if (setf func (cadr (assoc type org-export-blocks)))
 198               (progn
 199                 (replace-match (save-match-data
 200                                  (if (memq type blocks)
 201                                      ""
 202                                    (apply func (save-match-data (org-remove-indentation (match-string 4)))
 203                                           (split-string (match-string 3) " ")))) t t)
 204                 ;; indent the replaced match
 205                 (indent-region (match-beginning 0) (match-end 0) indentation)
 206                 ))
 207           (setf start (save-match-data (match-end 0))))
 208         (mapcar (lambda (type)
 209                   (interblock start (point-max) type))
 210                 types)))))
 211
 212 (add-hook 'org-export-preprocess-hook 'org-export-blocks-preprocess)
 213
 214 ;;================================================================================
 215 ;; type specific functions
 216
 217 ;;--------------------------------------------------------------------------------
 218 ;; ditaa: create images from ASCII art using the ditaa utility
 219 (defvar org-ditaa-jar-path (expand-file-name
 220                             "ditaa.jar"
 221                             (file-name-as-directory
 222                              (expand-file-name
 223                               "scripts"
 224                               (file-name-as-directory
 225                                (expand-file-name
 226                                 "../contrib"
 227                                 (file-name-directory (or load-file-name buffer-file-name)))))))
 228   "Path to the ditaa jar executable")
 229
 230 (defun org-export-blocks-format-ditaa (body &rest headers)
 231   "Pass block BODY to the ditaa utility creating an image.
 232 Specify the path at which the image should be saved as the first
 233 element of headers, any additional elements of headers will be
 234 passed to the ditaa utility as command line arguments."
 235   (message "ditaa-formatting...")
 236   (let ((out-file (if headers (car headers)))
 237         (args (if (cdr headers) (mapconcat 'identity (cdr headers) " ")))
 238         (data-file (make-temp-file "org-ditaa")))
 239     (unless (file-exists-p org-ditaa-jar-path)
 240       (error (format "Could not find ditaa.jar at %s" org-ditaa-jar-path)))
 241     (setq body (if (string-match "^\\([^:\\|:[^ ]\\)" body)
 242                    body
 243                  (mapconcat (lambda (x) (substring x (if (> (length x) 1) 2 1)))
 244                             (org-split-string body "\n")
 245                             "\n")))
 246     (cond
 247      ((or htmlp latexp docbookp)
 248       (with-temp-file data-file (insert body))
 249       (message (concat "java -jar " org-ditaa-jar-path " " args " " data-file " " out-file))
 250       (shell-command (concat "java -jar " org-ditaa-jar-path " " args " " data-file " " out-file))
 251       (format "\n[[file:%s]]\n" out-file))
 252      (t (concat
 253          "\n#+BEGIN_EXAMPLE\n"
 254          body (if (string-match "\n$" body) "" "\n")
 255          "#+END_EXAMPLE\n")))))
 256
 257 ;;--------------------------------------------------------------------------------
 258 ;; dot: create graphs using the dot graphing language
 259 ;;      (require the dot executable to be in your path)
 260 (defun org-export-blocks-format-dot (body &rest headers)
 261   "Pass block BODY to the dot graphing utility creating an image.
 262 Specify the path at which the image should be saved as the first
 263 element of headers, any additional elements of headers will be
 264 passed to the dot utility as command line arguments.  Don't
 265 forget to specify the output type for the dot command, so if you
 266 are exporting to a file with a name like 'image.png' you should
 267 include a '-Tpng' argument, and your block should look like the
 268 following.
 269
 270 #+begin_dot models.png -Tpng
 271 digraph data_relationships {
 272   \"data_requirement\" [shape=Mrecord, label=\"{DataRequirement|description\lformat\l}\"]
 273   \"data_product\" [shape=Mrecord, label=\"{DataProduct|name\lversion\lpoc\lformat\l}\"]
 274   \"data_requirement\" -> \"data_product\"
 275 }
 276 #+end_dot"
 277   (message "dot-formatting...")
 278   (let ((out-file (if headers (car headers)))
 279         (args (if (cdr headers) (mapconcat 'identity (cdr headers) " ")))
 280         (data-file (make-temp-file "org-ditaa")))
 281     (cond
 282      ((or htmlp latexp docbookp)
 283       (with-temp-file data-file (insert body))
 284       (message (concat "dot " data-file " " args " -o " out-file))
 285       (shell-command (concat "dot " data-file " " args " -o " out-file))
 286       (format "\n[[file:%s]]\n" out-file))
 287      (t (concat
 288          "\n#+BEGIN_EXAMPLE\n"
 289          body (if (string-match "\n$" body) "" "\n")
 290          "#+END_EXAMPLE\n")))))
 291
 292 ;;--------------------------------------------------------------------------------
 293 ;; comment: export comments in author-specific css-stylable divs
 294 (defun org-export-blocks-format-comment (body &rest headers)
 295   "Format comment BODY by OWNER and return it formatted for export.
 296 Currently, this only does something for HTML export, for all
 297 other backends, it converts the comment into an EXAMPLE segment."
 298   (let ((owner (if headers (car headers)))
 299         (title (if (cdr headers) (mapconcat 'identity (cdr headers) " "))))
 300     (cond
 301      (htmlp ;; We are exporting to HTML
 302       (concat "#+BEGIN_HTML\n"
 303               "<div class=\"org-comment\""
 304               (if owner (format " id=\"org-comment-%s\" " owner))
 305               ">\n"
 306               (if owner (concat "<b>" owner "</b> ") "")
 307               (if (and title (> (length title) 0)) (concat " -- " title "</br>\n") "</br>\n")
 308               "<p>\n"
 309               "#+END_HTML\n"
 310               body
 311               "#+BEGIN_HTML\n"
 312               "</p>\n"
 313               "</div>\n"
 314               "#+END_HTML\n"))
 315      (t ;; This is not HTML, so just make it an example.
 316       (concat "#+BEGIN_EXAMPLE\n"
 317               (if title (concat "Title:" title "\n") "")
 318               (if owner (concat "By:" owner "\n") "")
 319               body
 320               (if (string-match "\n\\'" body) "" "\n")
 321               "#+END_EXAMPLE\n")))))
 322
 323 ;;--------------------------------------------------------------------------------
 324 ;; R: Sweave-type functionality
 325 (defvar interblock-R-buffer nil
 326   "Holds the buffer for the current R process")
 327
 328 (defvar count) ; dynamicaly scoped from `org-export-blocks-preprocess'?
 329 (defun org-export-blocks-format-R (body &rest headers)
 330   "Process R blocks and replace \R{} forms outside the blocks
 331 with their values as determined by R."
 332   (interactive)
 333   (message "R processing...")
 334   (let ((image-path (or (and (car headers)
 335                              (string-match "\\(.?\\)\.\\(EPS\\|eps\\)" (car headers))
 336                              (match-string 1 (car headers)))
 337                         (and (> (length (car headers)) 0)
 338                              (car headers))
 339                         ;; create the default filename
 340                         (format "Rplot-%03d" count)))
 341         (plot (string-match "plot" body))
 342         R-proc)
 343     (setf count (+ count 1))
 344     (interblock-initiate-R-buffer)
 345     (setf R-proc (get-buffer-process interblock-R-buffer))
 346     ;; send strings to the ESS process using `comint-send-string'
 347     (setf body (mapconcat (lambda (line)
 348                             (interblock-R-input-command line) (concat "> " line))
 349                           (butlast (split-string body "[\r\n]"))
 350                           "\n"))
 351     ;; if there is a plot command, then create the images
 352     (when plot
 353       (interblock-R-input-command (format "dev.copy2eps(file=\"%s.eps\")" image-path)))
 354     (concat (cond
 355              (htmlp (org-export-blocks-html-quote body
 356                                                   (format "<div id=\"R-%d\">\n<pre>\n" count)
 357                                                   "</pre>\n</div>\n"))
 358              (latexp (org-export-blocks-latex-quote body
 359                                                     "\\begin{Schunk}\n\\begin{Sinput}\n"
 360                                                     "\\end{Sinput}\n\\end{Schunk}\n"))
 361              (t (insert ;; default export
 362                  "#+begin_R " (mapconcat 'identity headers " ") "\n"
 363                  body (if (string-match "\n$" body) "" "\n")
 364                  "#+end_R\n")))
 365             (if plot
 366                 (format "[[file:%s.eps]]\n" image-path)
 367               ""))))
 368
 369 (defun org-export-interblocks-format-R (start end)
 370   "This is run over parts of the org-file which are between R
 371 blocks.  It's main use is to expand the \R{stuff} chunks for
 372 export."
 373   (save-excursion
 374     (goto-char start)
 375     (interblock-initiate-R-buffer)
 376     (let (code replacement)
 377       (while (and (< (point) end) (re-search-forward "\\\\R{\\(.*\\)}" end t))
 378         (save-match-data (setf code (match-string 1)))
 379         (setf replacement (interblock-R-command-to-string code))
 380         (setf replacement (cond
 381                            (htmlp replacement)
 382                            (latexp replacement)
 383                            (t replacement)))
 384         (setf end (+ end (- (length replacement) (length code))))
 385         (replace-match replacement t t)))))
 386
 387 (defun interblock-initiate-R-buffer ()
 388   "If there is not a current R process then create one."
 389   (unless (and (buffer-live-p interblock-R-buffer) (get-buffer interblock-R-buffer))
 390     (save-excursion
 391       (R)
 392       (setf interblock-R-buffer (current-buffer))
 393       (interblock-R-wait-for-output)
 394       (interblock-R-input-command ""))))
 395
 396 (defun interblock-R-command-to-string (command)
 397   "Send a command to R, and return the results as a string."
 398   (interblock-R-input-command command)
 399   (interblock-R-last-output))
 400
 401 (defun interblock-R-input-command (command)
 402   "Pass COMMAND to the R process running in `interblock-R-buffer'."
 403   (save-excursion
 404     (save-match-data
 405       (set-buffer interblock-R-buffer)
 406       (goto-char (process-mark (get-buffer-process (current-buffer))))
 407       (insert command)
 408       (comint-send-input)
 409       (interblock-R-wait-for-output))))
 410
 411 (defun interblock-R-wait-for-output ()
 412   "Wait until output arrives"
 413   (save-excursion
 414     (save-match-data
 415       (set-buffer interblock-R-buffer)
 416       (while (progn
 417                (goto-char comint-last-input-end)
 418                (not (re-search-forward comint-prompt-regexp nil t)))
 419         (accept-process-output (get-buffer-process (current-buffer)))))))
 420
 421 (defun interblock-R-last-output ()
 422   "Return the last R output as a string"
 423   (save-excursion
 424     (save-match-data
 425       (set-buffer interblock-R-buffer)
 426       (goto-char (process-mark (get-buffer-process (current-buffer))))
 427       (forward-line 0)
 428       (let ((raw (buffer-substring comint-last-input-end (- (point) 1))))
 429         (if (string-match "\n" raw)
 430             raw
 431           (and (string-match "\\[[[:digit:]+]\\] *\\(.*\\)$" raw)
 432                (message raw)
 433                (message (match-string 1 raw))
 434                (match-string 1 raw)))))))
 435
 436 (provide 'org-exp-blocks)
 437
 438 ;;; org-exp-blocks.el ends here