Feature/dired inline preview

dired-inline-preview.el

@@ -0,0 +1,140 @@
+;;; dired-inline-preview.el --- Inline previews in dired buffer
+;; Copyright (C) 2019 Mikael Svahnberg
+;; Copyright (C) 2014-- Matúš Goljer
+
+;; 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 3 of the License, 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 this program.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;; This is heavily based on dired-subtree by Matúš Goljer,
+;; but generalises it to more different types of previews.
+
+;;; Code:
+(require 'dired-subtree)
+(require 'pdf-info)
+
+(defgroup dired-inline-preview ()
+  "Inline previews in dired buffer"
+  :group 'dired-hacks
+  :prefix "dired-inline-preview-")
+
+(defcustom dired-inline-preview-pdf-width 200
+  "width of inlined PDF preview"
+  :type 'integer
+  :group 'dired-inline-preview)
+
+(defcustom dired-inline-preview-image-height 200
+  "height of inlined image preview"
+  :type 'integer
+  :group 'dired-inline-preview)
+
+;; TODO: use image-type-file-name-regexps instead
+(defcustom dired-inline-preview-image-extensions '("PBM" "XBM" "XPM" "GIF" "JPEG" "JPG" "TIFF" "TIF" "PNG" "SVG" "PS")
+  "list of filename extensions that should be inlined as images"
+  :type 'sexp
+  :group 'dired-inline-preview)
+
+(defcustom dired-inline-preview-text-lines 10
+  "Number of lines to preview for text files"
+  :type 'integer
+  :group 'dired-inline-preview)
+(defcustom dired-inline-preview-text-extensions '("TXT" "ORG" "TEX" "CSV")
+  "list of filename extensions that should be inlined as text"
+  :type 'sexp
+  :group 'dired-inline-preview)  
+
+(defcustom dired-inline-preview-previewers '(dired-inline-preview--pdf dired-inline-preview--image dired-inline-preview--text)
+  "list of previewers to test"
+  :type 'sexp
+  :group 'dired-inline-preview)
+
+(defconst dired-inline-preview--dummy-file-details " ----------   1 X X   0 Jan 01 00:01 "
+  "Dummy file attributes to fool dired-hide-details into not swallowing the preview")
+
+;;; Helpers
+(defun dired-inline-preview--match-filename-extension (filename allowed-extensions)
+  "return t if the FILENAME extension is in the list of ALLOWED-EXTENSIONS, otherwise return nil."
+  (let* ((ext (upcase (or (file-name-extension filename) "")))
+         (search-fun (apply-partially (lambda (file-extension allowed-extension) (string= file-extension (upcase (or allowed-extension "")))) ext)))
+    (seq-find search-fun allowed-extensions nil)))
+
+(defun dired-inline-preview--maybe-insert-text (text)
+  (unless (string-match "^[[:blank:]]*$"
+                      (buffer-substring (line-beginning-position)
+                                        (line-end-position)))
+    (insert text)))
+
+(defun dired-inline-preview--fool-dired-hide-details (listing)
+  "Fool dired-hide-details by inserting a dummy file attributes list"
+  (with-temp-buffer
+    (insert listing)
+    (goto-char (point-min))
+    (dired-inline-preview--maybe-insert-text dired-inline-preview--dummy-file-details)
+    (while (= (forward-line) 0)
+      (dired-inline-preview--maybe-insert-text dired-inline-preview--dummy-file-details))
+    (buffer-string)))
+
+
+;;; Previewers:
+(defun dired-inline-preview--pdf (filename)
+  "return first page of FILENAME or nil"
+  (when (dired-inline-preview--match-filename-extension filename '("PDF"))
+    (with-temp-buffer
+      (insert ".")
+      (insert-image (create-image (pdf-info-renderpage 1 dired-inline-preview-pdf-width filename) 'imagemagick t))
+      (insert "\n")
+      (buffer-string))))
+
+(defun dired-inline-preview--image (filename)
+  "return inlined image or nil"
+  (when (dired-inline-preview--match-filename-extension filename dired-inline-preview-image-extensions)
+    (with-temp-buffer
+      (insert ".")
+      (insert-image (create-image filename 'imagemagick nil :height dired-inline-preview-image-height))
+      (insert "\n")
+      (buffer-string))))
+
+(defun dired-inline-preview--text (filename)
+  "return inlined text or nil"
+  (when (dired-inline-preview--match-filename-extension filename dired-inline-preview-text-extensions)
+    (with-temp-buffer
+      (insert-file-contents filename)
+      (goto-char (point-min))
+      (let (out)
+        (dotimes (iter dired-inline-preview-text-lines out)
+          (forward-line)))
+      (delete-region (point) (point-max))
+      (buffer-string))))
+
+
+;;; Entry points:
+(defun dired-inline-preview (filename)
+  (interactive "P")
+  (seq-some (lambda (fun) (funcall fun filename)) dired-inline-preview-previewers))
+
+(defun dired-inline-preview-insert-preview-or-subtree (orig-fun)
+  "Call the right insert function for a preview or a subtree"
+  (interactive)
+  (if (dired-subtree--dired-line-is-directory-or-link-p)
+      (apply orig-fun nil)
+    (unless (dired-subtree--is-expanded-p)
+      (let* ((filename (dired-get-filename nil))
+             (listing (dired-inline-preview filename)))
+        (if listing (dired-subtree-insert--insert filename (dired-inline-preview--fool-dired-hide-details listing)))))))
+
+(advice-add 'dired-subtree-insert :around #'dired-inline-preview-insert-preview-or-subtree)
+
+
+
+(provide 'dired-inline-preview)
+;;; dired-inline-preview.el ends here

dired-subtree.el

@@ -487,60 +487,64 @@ Return a string suitable for insertion in `dired' buffer."
   (when (and (dired-subtree--dired-line-is-directory-or-link-p)
              (not (dired-subtree--is-expanded-p)))
     (let* ((dir-name (dired-get-filename nil))
-           (listing (dired-subtree--readin (file-name-as-directory dir-name)))
-           beg end)
-      (read-only-mode -1)
-      (move-end-of-line 1)
-      ;; this is pretty ugly, I'm sure it can be done better
-      (save-excursion
-        (insert listing)
-        (setq end (+ (point) 2)))
-      (newline)
-      (setq beg (point))
-      (let ((inhibit-read-only t))
-        (remove-text-properties (1- beg) beg '(dired-filename)))
-      (let* ((ov (make-overlay beg end))
-             (parent (dired-subtree--get-ov (1- beg)))
-             (depth (or (and parent (1+ (overlay-get parent 'dired-subtree-depth)))
-                        1))
-             (face (intern (format "dired-subtree-depth-%d-face" depth))))
-        (when dired-subtree-use-backgrounds
-          (overlay-put ov 'face face))
-        ;; refactor this to some function
-        (overlay-put ov 'line-prefix
-                     (if (stringp dired-subtree-line-prefix)
-                         (if (not dired-subtree-use-backgrounds)
-                             (apply 'concat (-repeat depth dired-subtree-line-prefix))
-                           (cond
-                            ((eq nil dired-subtree-line-prefix-face)
+           (listing (dired-subtree--readin (file-name-as-directory dir-name))))
+      (dired-subtree-insert--insert dir-name listing))))
+
+(defun dired-subtree-insert--insert (filename listing)
+  "Insert LISTING under current FILENAME"
+  (let (beg end)
+    (read-only-mode -1)
+    (move-end-of-line 1)
+    ;; this is pretty ugly, I'm sure it can be done better
+    (save-excursion
+      (insert listing)
+      (setq end (+ (point) 2)))
+    (newline)
+    (setq beg (point))
+    (let ((inhibit-read-only t))
+      (remove-text-properties (1- beg) beg '(dired-filename)))
+    (let* ((ov (make-overlay beg end))
+           (parent (dired-subtree--get-ov (1- beg)))
+           (depth (or (and parent (1+ (overlay-get parent 'dired-subtree-depth)))
+                      1))
+           (face (intern (format "dired-subtree-depth-%d-face" depth))))
+      (when dired-subtree-use-backgrounds
+        (overlay-put ov 'face face))
+      ;; refactor this to some function
+      (overlay-put ov 'line-prefix
+                   (if (stringp dired-subtree-line-prefix)
+                       (if (not dired-subtree-use-backgrounds)
+                           (apply 'concat (-repeat depth dired-subtree-line-prefix))
+                         (cond
+                          ((eq nil dired-subtree-line-prefix-face)
+                           (apply 'concat
+                                  (-repeat depth dired-subtree-line-prefix)))
+                          ((eq 'subtree dired-subtree-line-prefix-face)
+                           (concat
+                            dired-subtree-line-prefix
+                            (propertize
                              (apply 'concat
-                                    (-repeat depth dired-subtree-line-prefix)))
-                            ((eq 'subtree dired-subtree-line-prefix-face)
-                             (concat
-                              dired-subtree-line-prefix
-                              (propertize
-                               (apply 'concat
-                                      (-repeat (1- depth) dired-subtree-line-prefix))
-                               'face face)))
-                            ((eq 'parents dired-subtree-line-prefix-face)
-                             (concat
-                              dired-subtree-line-prefix
-                              (apply 'concat
-                                     (--map
-                                      (propertize dired-subtree-line-prefix
-                                                  'face
-                                                  (intern (format "dired-subtree-depth-%d-face" it)))
-                                      (number-sequence 1 (1- depth))))))))
-                       (funcall dired-subtree-line-prefix depth)))
-        (overlay-put ov 'dired-subtree-name dir-name)
-        (overlay-put ov 'dired-subtree-parent parent)
-        (overlay-put ov 'dired-subtree-depth depth)
-        (overlay-put ov 'evaporate t)
-        (push ov dired-subtree-overlays))
-      (goto-char beg)
-      (dired-move-to-filename)
-      (read-only-mode 1)
-      (run-hooks 'dired-subtree-after-insert-hook))))
+                                    (-repeat (1- depth) dired-subtree-line-prefix))
+                             'face face)))
+                          ((eq 'parents dired-subtree-line-prefix-face)
+                           (concat
+                            dired-subtree-line-prefix
+                            (apply 'concat
+                                   (--map
+                                    (propertize dired-subtree-line-prefix
+                                                'face
+                                                (intern (format "dired-subtree-depth-%d-face" it)))
+                                    (number-sequence 1 (1- depth))))))))
+                     (funcall dired-subtree-line-prefix depth)))
+      (overlay-put ov 'dired-subtree-name filename)
+      (overlay-put ov 'dired-subtree-parent parent)
+      (overlay-put ov 'dired-subtree-depth depth)
+      (overlay-put ov 'evaporate t)
+      (push ov dired-subtree-overlays))
+    (goto-char beg)
+    (dired-move-to-filename)
+    (read-only-mode 1)
+    (run-hooks 'dired-subtree-after-insert-hook)))
 
 ;;;###autoload
 (defun dired-subtree-remove ()