path: root/emacs.d/elisp/muse/muse-context.el

;;; muse-context.el --- publish entries in ConTeXt or PDF format

;; Copyright (C) 2007, 2008, 2009, 2010  Free Software Foundation, Inc.

;; Author: Jean Magnan de Bornier (jean@bornier.net)
;; Created: 16-Apr-2007

;; Emacs Muse is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published
;; by the Free Software Foundation; either version 3, or (at your
;; option) any later version.

;; This file when loaded allows you to publish .muse files as ConTeXt
;; files or as pdf files, using respectively the "context" and
;; "context-pdf" styles. It is far from being perfect, so any feedback
;; will be welcome and any mistake hopefully fixed.

;;; Author:

;; Jean Magnan de Bornier, who based this file on muse-latex.el and
;; made the context, context-pdf, context-slides, and
;; context-slides-pdf Muse publishing styles.

;; 16 Avril 2007

;;; Code:

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Muse ConTeXt Publishing
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(require 'muse-publish)

(defgroup muse-context nil
  "Rules for marking up a Muse file as a ConTeXt article."
  :group 'muse-publish)

(defcustom muse-context-extension ".tex"
  "Default file extension for publishing ConTeXt files."
  :type 'string
  :group 'muse-context)

(defcustom muse-context-pdf-extension ".pdf"
  "Default file extension for publishing ConTeXt files to PDF."
  :type 'string
  :group 'muse-context)

(defcustom muse-context-pdf-program "texexec --pdf"
  "The program that is called to generate PDF content from ConTeXt content."
  :type 'string
  :group 'muse-context)

(defcustom muse-context-pdf-cruft '(".pgf" ".tmp" ".tui" ".tuo" ".toc"  ".log")
  "Extensions of files to remove after generating PDF output successfully."
  :type 'string
  :group 'muse-context)

(defcustom muse-context-header
  "\\setupinteraction [state=start]
\\usemodule[tikz]
\\usemodule[bib]\n
<lisp>(muse-context-setup-bibliography)</lisp>
 \\setuppublications[]\n
\\setuppublicationlist[]\n\\setupcite[]\n
\\starttext
\\startalignment[center]
  \\blank[2*big]
    {\\tfd <lisp>(muse-publishing-directive \"title\")</lisp>}
  \\blank[3*medium]
    {\\tfa <lisp>(muse-publishing-directive \"author\")</lisp>}
  \\blank[2*medium]
    {\\tfa <lisp>(muse-publishing-directive \"date\")</lisp>}
  \\blank[3*medium]
\\stopalignment

<lisp>(and muse-publish-generate-contents
           (not muse-context-permit-contents-tag)
           \"\\\\placecontent\n\\\\page[yes]\")</lisp>\n\n"
  "Header used for publishing ConTeXt files.  This may be text or a filename."
  :type 'string
  :group 'muse-context)

(defcustom muse-context-footer "<lisp>(muse-context-bibliography)</lisp>
\\stoptext\n"
  "Footer used for publishing ConTeXt files.  This may be text or a filename."
  :type 'string
  :group 'muse-context)

(defcustom muse-context-markup-regexps
  `(;; numeric ranges
    (10000 "\\([0-9]+\\)-\\([0-9]+\\)" 0 "\\1--\\2")

    ;; be careful of closing quote pairs
    (10100 "\"'" 0 "\"\\\\-'"))
  "List of markup regexps for identifying regions in a Muse page.
For more on the structure of this list, see `muse-publish-markup-regexps'."
  :type '(repeat (choice
                  (list :tag "Markup rule"
                        integer
                        (choice regexp symbol)
                        integer
                        (choice string function symbol))
                  function))
  :group 'muse-context)

(defcustom muse-context-markup-functions
  '((table . muse-context-markup-table))
  "An alist of style types to custom functions for that kind of text.
For more on the structure of this list, see
`muse-publish-markup-functions'."
  :type '(alist :key-type symbol :value-type function)
  :group 'muse-context)

(defcustom muse-context-markup-strings
  '((image-with-desc . "\\placefigure[][]{%3%}{\\externalfigure[%1%.%2%]}")
    (image           . "\\placefigure[][]{}{\\externalfigure[%s.%s]}")
    (image-link      . "\\useURL[aa][%s][][%1%] \\from[aa]")
    (anchor-ref      . "\\goto{%2%}{}[%1%]")
    (url             . "\\useURL[aa][%s][][%s] \\from[aa]")
    (url-and-desc    . "\\useURL[bb][%s][][%s]\\from[bb]\\footnote{%1%}")
    (link            . "\\goto{%2%}[program(%1%)]\\footnote{%1%}")
    (link-and-anchor . "\\useexternaldocument[%4%][%4%][] \\at{%3%, page}{}[%4%::%2%]\\footnote{%1%}")
    (email-addr      . "\\useURL[mail][mailto:%s][][%s]\\from[mail]")
    (anchor          . "\\reference[%s] ")
    (emdash          . "---")
    (comment-begin   . "\\doifmode{comment}{")
    (comment-end     . "}")
    (rule            . "\\blank[medium]\\hrule\\blank[medium]")
    (no-break-space  . "~")
    (enddots         . "\\ldots ")
    (dots            . "\\dots ")
    (part            . "\\part{")
    (part-end        . "}")
    (chapter         . "\\chapter{")
    (chapter-end     . "}")
    (section         . "\\section{")
    (section-end     . "}")
    (subsection      . "\\subsection{")
    (subsection-end  . "}")
    (subsubsection   . "\\subsubsection{")
    (subsubsection-end . "}")
    (section-other   . "\\subsubsubject{")
    (section-other-end . "}")
    (footnote        . "\\footnote{")
    (footnote-end    . "}")
    (footnotetext    . "\\footnotetext[%d]{")
    (begin-underline . "\\underbar{")
    (end-underline   . "}")
    (begin-literal   . "\\type{")
    (end-literal     . "}")
    (begin-emph      . "{\\em ")
    (end-emph        . "}")
    (begin-more-emph . "{\\bf ")
    (end-more-emph   . "}")
    (begin-most-emph . "{\\bf {\\em ")
    (end-most-emph   . "}}")
    (begin-example   . "\\starttyping")
    (end-example     . "\\stoptyping")
    (begin-center    . "\\startalignment[center]\n")
    (end-center      . "\n\\stopalignment")
    (begin-quote     . "\\startquotation\n")
    (end-quote       . "\n\\stopquotation")
    (begin-cite     . "\\cite[authoryear][")
    (begin-cite-author . "\\cite[author][")
    (begin-cite-year . "\\cite[year][")
    (end-cite        . "]")
    (begin-uli       . "\\startitemize\n")
    (end-uli         . "\n\\stopitemize")
    (begin-uli-item  . "\\item ")
    (begin-oli       . "\\startitemize[n]\n")
    (end-oli         . "\n\\stopitemize")
    (begin-oli-item  . "\\item ")
    (begin-dl        . "\\startitemize\n")
    (end-dl          . "\n\\stopitemize")
    (begin-ddt       . "\\head ")
    (end-ddt         . "\n")
    (begin-verse     . "\\blank[big]")
    (end-verse-line  . "\\par")
    (verse-space     . "\\fixedspaces ~~")
    (end-verse       . "\\blank[big]"))
  "Strings used for marking up text.
These cover the most basic kinds of markup, the handling of which
differs little between the various styles."
  :type '(alist :key-type symbol :value-type string)
  :group 'muse-context)

(defcustom muse-context-slides-header
  "\\usemodule[<lisp>(if (string-equal (muse-publishing-directive \"module\") nil) \"pre-01\" (muse-publishing-directive \"module\"))</lisp>]
\\usemodule[tikz]
\\usemodule[newmat]
\\setupinteraction [state=start]
\\starttext
\\TitlePage { <lisp>(muse-publishing-directive \"title\")</lisp>
\\blank[3*medium]
\\tfa <lisp>(muse-publishing-directive \"author\")</lisp>
 \\blank[2*medium]
  \\tfa <lisp>(muse-publishing-directive \"date\")</lisp>}"
  "Header for publishing a presentation (slides) using ConTeXt.
Any of the predefined modules, which are available in the
tex/context/base directory, can be used by writing a \"module\"
directive at the top of the muse file; if no such directive is
provided, module pre-01 is used.  Alternatively, you can use your
own style (\"mystyle\", in this example) by replacing
\"\\usemodule[]\" with \"\\input mystyle\".

This may be text or a filename."
  :type 'string
  :group 'muse-context)

(defcustom muse-context-slides-markup-strings
   '((section      . "\\Topic {")
     (subsection   . "\\page \n{\\bf ")
     (subsubsection . "{\\em "))
  "Strings used for marking up text in ConTeXt slides."
  :type '(alist :key-type symbol :value-type string)
  :group 'muse-context)

(defcustom muse-context-markup-specials-document
  '((?\\ . "\\textbackslash{}")
    (?\_ . "\\textunderscore{}")
    (?\< . "\\switchtobodyfont[small]")
    (?\> . "\\switchtobodyfont[big]")
    (?^  . "\\^")
    (?\~ . "\\~")
    (?\@ . "\\@")
    (?\$ . "\\$")
    (?\% . "\\%")
    (?\{ . "\\{")
    (?\} . "\\}")
    (?\& . "\\&")
    (?\# . "\\#"))
  "A table of characters which must be represented specially.
These are applied to the entire document, sans already-escaped
regions."
  :type '(alist :key-type character :value-type string)
  :group 'muse-context)

(defcustom muse-context-markup-specials-example
  '()
  "A table of characters which must be represented specially.
These are applied to <example> regions.

With the default interpretation of <example> regions, no specials
need to be escaped."
  :type '(alist :key-type character :value-type string)
  :group 'muse-context)

(defcustom muse-context-markup-specials-literal
  '()
  "A table of characters which must be represented specially.
This applies to =monospaced text= and <code> regions."
  :type '(alist :key-type character :value-type string)
  :group 'muse-context)

(defcustom muse-context-markup-specials-url
  '((?\\ . "\\textbackslash")
    (?\_ . "\\_")
    (?\< . "\\<")
    (?\> . "\\>")
    (?\$ . "\\$")
    (?\% . "\\%")
    (?\{ . "\\{")
    (?\} . "\\}")
    (?\& . "\\&")
    (?\# . "\\#"))
  "A table of characters which must be represented specially.
These are applied to URLs."
  :type '(alist :key-type character :value-type string)
  :group 'muse-context)

(defcustom muse-context-markup-specials-image
  '((?\\ . "\\textbackslash")       ; cannot find suitable replacement
    (?\< . "\\<")
    (?\> . "\\>")
    (?\$ . "\\$")
    (?\% . "\\%")
    (?\{ . "\\{")
    (?\} . "\\}")
    (?\& . "\\&")
    (?\# . "\\#")                     ; cannot find suitable replacement
    )
  "A table of characters which must be represented specially.
These are applied to image filenames."
  :type '(alist :key-type character :value-type string)
  :group 'muse-context)

(defun muse-context-decide-specials (context)
  "Determine the specials to escape, depending on the CONTEXT argument."
  (cond ((memq context '(underline emphasis document url-desc verbatim
                                   footnote))
         muse-context-markup-specials-document)
        ((eq context 'image)
         muse-context-markup-specials-image)
        ((memq context '(email url))
         muse-context-markup-specials-url)
        ((eq context 'literal)
         muse-context-markup-specials-literal)
        ((eq context 'example)
         muse-context-markup-specials-example)
        (t (error "Invalid context argument '%s' in muse-context" context))))

(defun muse-context-markup-table ()
  (let* ((table-info (muse-publish-table-fields (match-beginning 0)
                                                (match-end 0)))
         (row-len (car table-info))
         (field-list (cdr table-info)))
    (when table-info
      (muse-insert-markup "\\starttable[|"
                          (mapconcat 'symbol-name (make-vector row-len 'l)
                                     "|") "|]\n \\HL\n \\VL ")
      (dolist (fields field-list)
        (let ((type (car fields)))
          (setq fields (cdr fields))
          (when (= type 3)
            (muse-insert-markup ""))
          (insert (car fields))
          (setq fields (cdr fields))
          (dolist (field fields)
            (muse-insert-markup " \\VL ")
            (insert field))
          (muse-insert-markup "\\VL\\NR\n \\HL\n \\VL ")
          (when (= type 2)
            (muse-insert-markup " "))))
      (muse-insert-markup "\\stoptable\n")
      (while (search-backward "VL \\stoptable" nil t)
        (replace-match "stoptable" nil t)))))

(defun muse-context-fixup-dquotes ()
  "Fixup double quotes."
  (goto-char (point-min))
  (let ((open t))
    (while (search-forward "\"" nil t)
      (unless (get-text-property (match-beginning 0) 'read-only)
        (when (or (bobp)
                  (eq (char-before) ?\n))
          (setq open t))
        (if open
            (progn
              (replace-match "``")
              (setq open nil))
          (replace-match "''")
          (setq open t))))))

(defcustom muse-context-permit-contents-tag nil
  "If nil, ignore <contents> tags.  Otherwise, insert table of contents.

Most of the time, it is best to have a table of contents on the
first page, with a new page immediately following.  To make this
work with documents published in both HTML and ConTeXt, we need to
ignore the <contents> tag.

If you don't agree with this, then set this option to non-nil,
and it will do what you expect."
  :type 'boolean
  :group 'muse-context)

(defun muse-context-fixup-citations ()
  "Replace semicolons in multi-head citations with colons."
  (goto-char (point-min))
  (while (re-search-forward "\\\\cite.?\\[" nil t)
    (let ((start (point))
          (end (re-search-forward "]")))
      (save-restriction
        (narrow-to-region start end)
        (goto-char (point-min))
        (while (re-search-forward ";" nil t)
          (replace-match ","))))))

(defun muse-context-munge-buffer ()
  (muse-context-fixup-dquotes)
  (muse-context-fixup-citations)
  (when (and muse-context-permit-contents-tag
             muse-publish-generate-contents)
    (goto-char (car muse-publish-generate-contents))
    (muse-insert-markup "\\placecontent")))

(defun muse-context-bibliography ()
  (save-excursion
    (goto-char (point-min))
    (if (re-search-forward "\\\\cite.?\\[" nil t)
        "\\completepublications[criterium=all]"
      "")))

(defun muse-context-setup-bibliography ()
  (save-excursion
    (goto-char (point-min))
    (if (re-search-forward "\\\\cite.?\\[" nil t)
        (concat
         "\\usemodule[bibltx]\n\\setupbibtex [database="
         (muse-publishing-directive "bibsource") "]")
      "")))

(defun muse-context-pdf-browse-file (file)
  (shell-command (concat "open " file)))

(defun muse-context-pdf-generate (file output-path final-target)
  (apply
   #'muse-publish-transform-output
   file output-path final-target "PDF"
   (function
    (lambda (file output-path)
      (let* ((fnd (file-name-directory output-path))
             (command (format "%s \"%s\""
                              muse-context-pdf-program
                              (file-relative-name file fnd)))
             (times 0)
             (default-directory fnd)
             result)
        ;; XEmacs can sometimes return a non-number result.  We'll err
        ;; on the side of caution by continuing to attempt to generate
        ;; the PDF if this happens and treat the final result as
        ;; successful.
        (while (and (< times 2)
                    (or (not (numberp result))
                        (not (eq result 0))
                        ;; table of contents takes 2 passes
;;                         (file-readable-p
;;                          (muse-replace-regexp-in-string
;;                           "\\.tex\\'" ".toc" file t t))
                        ))
          (setq result (shell-command command)
                times (1+ times)))
        (if (or (not (numberp result))
                (eq result 0))
            t
          nil))))
   muse-context-pdf-cruft))

(muse-define-style "context"
                   :suffix    'muse-context-extension
                   :regexps   'muse-context-markup-regexps
                   :functions 'muse-context-markup-functions
                   :strings   'muse-context-markup-strings
                   :specials  'muse-context-decide-specials
                   :after     'muse-context-munge-buffer
                   :header    'muse-context-header
                   :footer    'muse-context-footer
                   :browser   'find-file)

(muse-derive-style "context-pdf" "context"
                   :final   'muse-context-pdf-generate
                   :browser 'muse-context-pdf-browse-file
                   :link-suffix 'muse-context-pdf-extension
                   :osuffix 'muse-context-pdf-extension)

(muse-derive-style "context-slides" "context"
                   :header  'muse-context-slides-header
                   :strings 'muse-context-slides-markup-strings)

(muse-derive-style "context-slides-pdf" "context-pdf"
                   :header  'muse-context-slides-header
                   :strings 'muse-context-slides-markup-strings)

(provide 'muse-context)

;;; muse-context.el ends here