org-link-beautify.el

   1 ;;; org-link-beautify.el --- Beautify Org Links -*- lexical-binding: t; -*-
   2
   3 ;;; Time-stamp: <2020-08-28 17:22:45 stardiviner>
   4
   5 ;; Authors: stardiviner <numbchild@gmail.com>
   6 ;; Package-Requires: ((emacs "27.1") (all-the-icons "4.0.0"))
   7 ;; Package-Version: 1.0
   8 ;; Keywords: hypermedia
   9 ;; homepage: https://github.com/stardiviner/org-link-beautify
  10
  11 ;; org-link-beautify is free software; you can redistribute it and/or modify it
  12 ;; under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 3, or (at your option)
  14 ;; any later version.
  15 ;;
  16 ;; org-link-beautify is distributed in the hope that it will be useful, but WITHOUT
  17 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
  18 ;; or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public
  19 ;; License for more details.
  20 ;;
  21 ;;
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
  24
  25 ;;; Commentary:
  26
  27 ;; Usage:
  28 ;;
  29 ;; (org-link-beautify-mode 1)
  30
  31 ;;; Code:
  32 \f
  33 (require 'ol)
  34 (require 'org-element)
  35 (require 'all-the-icons)
  36
  37 (defgroup org-link-beautify nil
  38   "Customize group of org-link-beautify-mode."
  39   :prefix "org-link-beautify-"
  40   :group 'org)
  41
  42 (defcustom org-link-beautify-exclude-modes '(org-agenda-mode)
  43   "A list of excluded major modes which wouldn't enable `org-link-beautify'."
  44   :type 'list
  45   :safe #'listp
  46   :group 'org-link-beautify)
  47
  48 (defcustom org-link-beautify-thumbnail-dir "~/.cache/thumbnails/"
  49   "The directory of generated thumbnails."
  50   :type 'string
  51   :safe #'stringp
  52   :group 'org-link-beautify)
  53
  54 (defcustom org-link-beautify-thumbnail-size 512
  55   "The video thumbnail image size."
  56   :type 'number
  57   :safe #'numberp
  58   :group 'org-link-beautify)
  59
  60 (defcustom org-link-beautify-video-types-list '("avi" "rmvb" "ogg" "ogv" "mp4" "mkv" "webm" "flv")
  61   "A list of video file types be supported with thumbnails."
  62   :type 'list
  63   :safe #'listp
  64   :group 'org-link-beautify)
  65
  66 (defun org-link-beautify--get-element (position)
  67   "Return the org element of link at the `POSITION'."
  68   (save-excursion (goto-char position) (org-element-context)))
  69
  70 (defun org-link-beautify--get-link-description-fast (position)
  71   "Get the link description at `POSITION' (fuzzy but faster version)."
  72   (save-excursion
  73     (goto-char position)
  74     (and (org-in-regexp org-link-bracket-re) (match-string 2))))
  75
  76 (defun org-link-beautify--warning (path)
  77   "Use `org-warning' face if link PATH does not exist."
  78   (if (and (not (file-remote-p path))
  79            (file-exists-p (expand-file-name path)))
  80       'org-link 'org-warning))
  81
  82 (defun org-link-beautify (start end path bracket-p)
  83   "Display icon for the link type based on PATH from START to END."
  84   ;; (message
  85   ;;  (format "start: %s, end: %s, path: %s, bracket-p: %s" start end path bracket-p))
  86   (unless (memq major-mode org-link-beautify-exclude-modes)
  87     ;; detect whether link is normal, jump other links in special places.
  88     (when (eq (car (org-link-beautify--get-element start)) 'link)
  89       (save-match-data
  90         (let* ((link-element (org-link-beautify--get-element start))
  91                ;; (link-element-debug (message link-element))
  92                (raw-link (org-element-property :raw-link link-element))
  93                ;; (raw-link-debug (message raw-link))
  94                (type (org-element-property :type link-element))
  95                (extension (or (file-name-extension (org-link-unescape path)) "txt"))
  96                ;; (ext-debug (message extension))
  97                (description (or (and (org-element-property :contents-begin link-element) ; in raw link case, it's nil
  98                                      (buffer-substring-no-properties
  99                                       (org-element-property :contents-begin link-element)
 100                                       (org-element-property :contents-end link-element)))
 101                                 ;; when description not exist, use raw link for raw link case.
 102                                 raw-link))
 103                ;; (desc-debug (message description))
 104                (icon (pcase type
 105                        ("file"
 106                         (cond
 107                          ((file-remote-p path) ; remote file
 108                           (all-the-icons-faicon "server" :face 'org-warning))
 109                          ((not (file-exists-p (expand-file-name path))) ; not exist file
 110                           (all-the-icons-faicon "exclamation-triangle" :face 'org-warning))
 111                          ((file-directory-p path) ; directory
 112                           (all-the-icons-icon-for-dir
 113                            "path"
 114                            :face (org-link-beautify--warning path)
 115                            :v-adjust 0))
 116                          (t (all-the-icons-icon-for-file ; file
 117                              (format ".%s" extension)
 118                              :face (org-link-beautify--warning path)
 119                              :v-adjust 0))))
 120                        ("file+sys" (all-the-icons-faicon "link"))
 121                        ("file+emacs" (all-the-icons-icon-for-mode 'emacs-lisp-mode))
 122                        ("http" (all-the-icons-icon-for-url (concat "http:" path) :v-adjust -0.05))
 123                        ("https" (all-the-icons-icon-for-url (concat "https:" path) :v-adjust -0.05))
 124                        ("ftp" (all-the-icons-faicon "link"))
 125                        ("custom-id" (all-the-icons-faicon "hashtag"))
 126                        ("coderef" (all-the-icons-faicon "code"))
 127                        ("id" (all-the-icons-fileicon ""))
 128                        ("attachment" (all-the-icons-faicon "puzzle-piece"))
 129                        ("elisp" (all-the-icons-icon-for-mode 'emacs-lisp-mode :v-adjust -0.05))
 130                        ("shell" (all-the-icons-icon-for-mode 'shell-mode))
 131                        ("eww" (all-the-icons-icon-for-mode 'eww-mode))
 132                        ("mu4e" (all-the-icons-faicon "envelope-o" :v-adjust -0.05))
 133                        ("git" (all-the-icons-octicon "git-branch"))
 134                        ("orgit" (all-the-icons-octicon "git-branch"))
 135                        ("orgit-rev" (all-the-icons-octicon "git-commit"))
 136                        ("orgit-log" (all-the-icons-icon-for-mode 'magit-log-mode))
 137                        ("pdfview" (all-the-icons-icon-for-file ".pdf"))
 138                        ("grep" (all-the-icons-icon-for-mode 'grep-mode))
 139                        ("occur" (all-the-icons-icon-for-mode 'occur-mode))
 140                        ("man" (all-the-icons-icon-for-mode 'Man-mode))
 141                        ("info" (all-the-icons-icon-for-mode 'Info-mode))
 142                        ("help" (all-the-icons-icon-for-mode 'Info-mode))
 143                        ("rss" (all-the-icons-material "rss_feed"))
 144                        ("elfeed" (all-the-icons-material "rss_feed"))
 145                        ("telnet" (all-the-icons-faicon "compress"))
 146                        ("wikipedia" (all-the-icons-faicon "wikipedia-w"))
 147                        ("mailto" (all-the-icons-material "email" :v-adjust -0.05))
 148                        ("doi" (all-the-icons-fileicon "isabelle"))
 149                        ("eaf" (all-the-icons-faicon "linux" :v-adjust -0.05)))))
 150           (when bracket-p (ignore))
 151           (cond
 152            ;; video thumbnails
 153            ((and (equal type "file") (member extension org-link-beautify-video-types-list))
 154             (let* ((video (expand-file-name (org-link-unescape path)))
 155                    (thumbnails-dir (file-name-directory
 156                                     (or org-link-beautify-thumbnail-dir "~/.cache/thumbnails/")))
 157                    (thumbnail-size (or org-link-beautify-thumbnail-size 512))
 158
 159                    (thumbnail (expand-file-name (format "%s%s.jpg" thumbnails-dir (file-name-base video)))))
 160               ;; (message (format "ffmpegthumbnailer -f -i %s -s %s -o %s"
 161               ;;                  (shell-quote-argument video) thumbnail-size (shell-quote-argument thumbnail)))
 162               (shell-command
 163                (format "ffmpegthumbnailer -f -i %s -s %s -o %s"
 164                        (shell-quote-argument video) thumbnail-size (shell-quote-argument thumbnail)))
 165               ;; (message "start: %s, end: %s" start end)
 166               ;; (message "%s" thumbnail)
 167               (put-text-property
 168                start end
 169                'display (create-image thumbnail nil nil :ascent 'center :max-height thumbnail-size))))
 170            ;; general icons
 171            (t (put-text-property
 172                start end
 173                'display
 174                (propertize
 175                 (concat
 176                  (propertize "[" 'face '(:inherit nil :underline nil :foreground "orange"))
 177                  (propertize description 'face '(:underline t :foreground "dark cyan"))
 178                  (propertize "]" 'face '(:inherit nil :underline nil :foreground "orange"))
 179                  (propertize "(" 'face '(:inherit nil :underline nil :foreground "orange"))
 180                  (propertize icon 'face '(:inherit nil :underline nil :foreground "gray"))
 181                  (propertize ")" 'face '(:inherit nil :underline nil :foreground "orange"))))))))))))
 182
 183 (defun org-link-beautify-toggle-overlays ()
 184   "Toggle the display of `org-link-beautify'."
 185   (let ((point (point-min))
 186         (bmp (buffer-modified-p)))
 187     (while (setq point (next-single-property-change point 'display))
 188             (when (and (get-text-property point 'display)
 189                              (eq (get-text-property point 'face) 'org-link))
 190               (remove-text-properties
 191                point (setq point (next-single-property-change point 'display))
 192                '(display t))))
 193     (set-buffer-modified-p bmp))
 194   (org-restart-font-lock))
 195
 196 ;;;###autoload
 197 (defun org-link-beautify-enable ()
 198   "Enable `org-link-beautify'."
 199   (dolist (link-type (mapcar #'car org-link-parameters))
 200     (org-link-set-parameters link-type :activate-func #'org-link-beautify))
 201   (org-link-beautify-toggle-overlays))
 202
 203 ;;;###autoload
 204 (defun org-link-beautify-disable ()
 205   "Disable `org-link-beautify'."
 206   (dolist (link-type (mapcar #'car org-link-parameters))
 207     (org-link-set-parameters link-type :activate-func t))
 208   (org-link-beautify-toggle-overlays))
 209
 210 ;;;###autoload
 211 (define-minor-mode org-link-beautify-mode
 212   "A minor mode that beautify Org links with colors and icons."
 213   :init-value nil
 214   :lighter nil
 215   :group 'org-link-beautify
 216   :global t
 217   (if org-link-beautify-mode
 218       (org-link-beautify-enable)
 219     (org-link-beautify-disable)))
 220
 221 \f
 222
 223 (provide 'org-link-beautify)
 224
 225 ;;; org-link-beautify.el ends here