;;; ob-reladraw.el --- Babel Functions for reladraw diagrams  -*- lexical-binding: t; -*-

;; Author: Pavel Popov
;; Keywords: literate programming, diagrams
;; URL: https://github.com/reladraw/reladraw
;;
;; This file is NOT part of GNU Emacs.

;; GNU Emacs 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 of the License, or
;; (at your option) any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.

;;; Commentary:

;; Org-Babel support for reladraw, a diagram language where you say
;; where things go.  A block renders to the SVG named by :file:
;;
;;   #+begin_src reladraw :file assets/arch.svg :exports results
;;   node app "Web app"
;;   node db "Database" right of app
;;   edge app -> db
;;   #+end_src
;;
;; Header arguments:
;;   :file     the SVG to write (required)
;;   :theme    render in this theme, whatever the source says
;;   :cmdline  extra arguments for the reladraw command

;;; Code:
(require 'ob)

(defgroup ob-reladraw nil
  "Org-Babel support for reladraw diagrams."
  :group 'org-babel)

(defcustom org-babel-reladraw-command "reladraw"
  "The reladraw command."
  :type 'string)

(defvar org-babel-default-header-args:reladraw
  '((:results . "file") (:exports . "results"))
  "Default arguments for reladraw source blocks.")

(defconst reladraw-keywords
  '("node" "edge" "style" "diagram" "default")
  "Words that start a reladraw statement.")

(defconst reladraw-placement-words
  '("of" "with" "between" "and" "below" "above" "left" "right" "level"
    "top" "bottom" "inside" "around" "from" "to")
  "Words that state where a reladraw node goes.")

(defvar reladraw-mode-syntax-table
  (let ((table (make-syntax-table)))
    (modify-syntax-entry ?/ ". 12" table)
    (modify-syntax-entry ?\n ">" table)
    (modify-syntax-entry ?\" "\"" table)
    (modify-syntax-entry ?- "_" table)
    (modify-syntax-entry ?_ "_" table)
    (modify-syntax-entry ?. "_" table)
    table)
  "Syntax table for `reladraw-mode': `//' comments, double-quoted text.")

(defvar reladraw-font-lock-keywords
  `((,(concat "^" (regexp-opt reladraw-keywords 'words)) . 'font-lock-keyword-face)
    (,(regexp-opt reladraw-placement-words 'words) . 'font-lock-builtin-face)
    ("\\_<\\([a-z][a-z0-9_-]*\\):" 1 'font-lock-variable-name-face)
    ("<?->\\|<->\\|--" . 'font-lock-operator-face)
    ("#[0-9a-fA-F]\\{3,8\\}\\_>" . 'font-lock-constant-face))
  "Highlighting for `reladraw-mode'.")

;;;###autoload
(define-derived-mode reladraw-mode prog-mode "Reladraw"
  "Major mode for editing reladraw diagram sources."
  :syntax-table reladraw-mode-syntax-table
  (setq-local comment-start "// ")
  (setq-local comment-start-skip "//+\\s-*")
  (setq-local font-lock-defaults '(reladraw-font-lock-keywords)))

;;;###autoload
(add-to-list 'auto-mode-alist '("\\.reladraw\\'" . reladraw-mode))

(with-eval-after-load 'org-src
  (add-to-list 'org-src-lang-modes '("reladraw" . reladraw)))

;; Org keeps a buffer per language for native fontification and enters
;; the mode only once, so drop it to let a reloaded mode take effect.
(when-let* ((buffer (get-buffer " *org-src-fontification:reladraw-mode*")))
  (kill-buffer buffer))

(defun org-babel-reladraw--args (in-file out-file params)
  "Return reladraw arguments rendering IN-FILE to OUT-FILE under PARAMS."
  (let ((theme (cdr (assq :theme params)))
        (cmdline (cdr (assq :cmdline params))))
    (append (list (org-babel-process-file-name in-file t)
                  "-o" (org-babel-process-file-name out-file t))
            (when theme (list "--theme" (format "%s" theme)))
            (when cmdline (split-string-and-unquote cmdline)))))

(defun org-babel-execute:reladraw (body params)
  "Render reladraw BODY into the SVG named by the :file header in PARAMS."
  (let ((out-file (cdr (assq :file params))))
    (unless out-file
      (user-error "Reladraw blocks need a :file header argument"))
    (unless (string-equal (downcase (or (file-name-extension out-file) "")) "svg")
      (user-error ":file is the SVG to render into, e.g. %s; the diagram goes in the block body"
                  (concat (file-name-sans-extension out-file) ".svg")))
    (let ((in-file (org-babel-temp-file "reladraw-" ".reladraw")))
      (with-temp-file in-file (insert body))
      (make-directory (file-name-directory (expand-file-name out-file)) t)
      (with-temp-buffer
        (let ((status (apply #'process-file org-babel-reladraw-command nil t nil
                             (org-babel-reladraw--args in-file out-file params))))
          ;; reladraw's message names the offending statement, so show it as is.
          (unless (eq status 0)
            (error "Reladraw failed: %s" (string-trim (buffer-string))))))
      nil)))

(defun org-babel-prep-session:reladraw (_session _params)
  "Reladraw has no sessions."
  (error "Reladraw does not support sessions"))

(provide 'ob-reladraw)

;;; ob-reladraw.el ends here