org-prettify-source-block.el

;;; org-prettify-source-block.el --- 

;; Copyright (C)  2018 Not me

;; Author: 
;; Created: ew (2018-04-18):
;; Version: 0.1

;; This program 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 2, or (at
;; your option) any later version.

;; This program 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; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Commentary:

;; 
;; 
;; 

(defgroup org-prettify-source-block nil
  "Prettify org-mode source block markers."
  :group 'org-mode
  :prefix "org-prettify-source-block"
  :version "0.1")

(defvar opsb-block-alist `(("#+begin_src" . ?╦) ;; ➤ 🖝 ➟ ➤ ✎ ✎
                           ("#+end_src"   . ?╩) ;; □
                           ("#+header:" . ,opsb-ob-header-symbol)
                           ("#+begin_comment" . ?✎)
                           ("#+end_comment" . ?✎)
                           ("#+begin_notes" . ?➤)
                           ("#+end_notes" . ?➤)
                           ("#+begin_quote" . ?»)
                           ("#+end_quote" . ?«)))

(defvar-local opsb-org-at-src-begin -1
  "Variable that holds whether last position was a ")

(defvar opsb-ob-header-symbol ?☰
  "Symbol used for babel headers")

(defun opsb-org-prettify-src--update ()
  (let ((case-fold-search t)
        (re "^[ \t]*#\\+begin_src[ \t]+[^ \f\t\n\r\v]+[ \t]*")
        found)
    (save-excursion
      (goto-char (point-min))
      (while (re-search-forward re nil t)
        (goto-char (match-end 0))
        (let ((args (org-trim
                     (buffer-substring-no-properties (point)
                                                     (line-end-position)))))
          (when (org-string-nw-p args)
            (let ((new-cell (cons args opsb-ob-header-symbol)))
              (cl-pushnew new-cell prettify-symbols-alist :test #'equal)
              (cl-pushnew new-cell found :test #'equal)))))

      (setq prettify-symbols-alist
            (cl-set-difference prettify-symbols-alist
                               (cl-set-difference
                                (cl-remove-if-not
                                 (lambda (elm)
                                   (eq (cdr elm) opsb-ob-header-symbol))
                                 prettify-symbols-alist)
                                found :test #'equal)))

      ;; Clean up old font-lock-keywords.
      (font-lock-remove-keywords nil prettify-symbols--keywords)
      (setq prettify-symbols--keywords (prettify-symbols--make-keywords))
      (font-lock-add-keywords nil prettify-symbols--keywords)
      (while (re-search-forward re nil t)
        (font-lock-flush (line-beginning-position) (line-end-position))))))

(defun opsb-org-prettify-src ()
  "Hide src options via `prettify-symbols-mode'.
    `prettify-symbols-mode' is used because it has
    uncollapsing. It may not be efficient."
  (let* ((case-fold-search t)
         (at-src-block
          (save-excursion
            (beginning-of-line)
            (looking-at "^[ \t]*#\\+begin_src[ \t]+[^ \f\t\n\r\v]+[ \t]*"))))
    ;; Test if we moved out of a block.
    (when (or (and opsb-org-at-src-begin
                   (not at-src-block))
              ;; File was just opened.
              (eq opsb-org-at-src-begin -1))
      (opsb-org-prettify-src--update))
    (setq opsb-org-at-src-begin at-src-block)))

(defsubst opsb-append-upcase (the-list)
    "Duplicate THE-LIST with upcased cars."
  (cl-reduce 'append
             (mapcar (lambda (x) (list x (cons (upcase (car x)) (cdr x))))
                     the-list)))

(defun opsb-append-org-prettify-symbols ()
  (setq prettify-symbols-alist
          (cl-union prettify-symbols-alist
                    (opsb-append-upcase opsb-block-alist))))

  (defun opsb-delete-org-prettify-symbols ()
    (setq prettify-symbols-alist
          (cl-set-difference prettify-symbols-alist
                             (opsb-append-upcase opsb-block-alist))))

(define-minor-mode org-prettify-source-block-mode
  "Toggle prettification of org source blocks."
  :lighter ""
  (if org-prettify-source-block-mode
      (progn
        (turn-on-prettify-symbols-mode)
        (add-hook 'post-command-hook 'opsb-org-prettify-src t t)
        (opsb-append-org-prettify-symbols))
    (remove-hook 'post-command-hook 'opsb-org-prettify-src t)
    (opsb-delete-org-prettify-symbols)
    ))

(provide 'org-prettify-source-block)
;;; org-prettify-source-block.el ends here