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