path: root/.doom.d/custom-packages/screenshot.el

;;; screenshot.el --- Swiftly grab images of your code -*- lexical-binding: t -*-

;; Copyright (C) 2020 TEC

;; Author: TEC <http://github/tecosaur>
;; Maintainer: TEC <tec@tecosaur.com>
;; Homepage: https://github.com/tecosaur/screenshot
;; Version: 0.1.0
;; Keywords: convenience, screenshot
;; Package-Requires: ((emacs "27") (transient "0.2.0") (posframe "0.8.3"))

;; This file is not part of GNU Emacs.

;;; License:

;; 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, 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.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;; Convenience package for creating images of the current region or buffer.
;; Requires `imagemagick' for some visual post-processing, and `xclip' for
;; copying images to the clipboard.

;;; Code:

(require 'transient)
(require 'posframe)

(defgroup screenshot ()
  "Customise group for Screenshot."
  :group 'convenience)

(defvar screenshot--buffer nil
  "The buffer last used to create a screenshot.")

(defcustom screenshot-buffer-creation-hook nil
  "Hook run after creating a buffer for screenshots.
Run after hardcoded setup, but before the screenshot is captured."
  :type 'hook
  :group 'screenshot)

(defvar screenshot--region-beginning nil
  "Start of the region forming the screenshot.")
(defvar screenshot--region-end nil
  "End of the region forming the screenshot.")

(defvar screenshot--tmp-file nil
  "An intermediate target file for the screenshot.")

(defvar screenshot--first-line-number nil
  "The first line contained in the screenshot.")

(defvar screenshot--total-lines nil
  "The total number of lines contained in the screenshot.")

;;; Generated variables

;;; Screenshot parameters

(eval-when-compile
  (defmacro screenshot--define-infix (key name description type default
                                          &rest reader)
    "Define infix with KEY, NAME, DESCRIPTION, TYPE, DEFAULT and READER as arguments."
    `(progn
       (defcustom ,(intern (concat "screenshot-" name)) ,default
         ,description
         :type ,type
         :group 'screenshot)
       (transient-define-infix ,(intern (concat "screenshot--set-" name)) ()
         "Set `screenshot--theme' from a popup buffer."
         :class 'transient-lisp-variable
         :variable ',(intern (concat "screenshot-" name))
         :key ,key
         :description ,description
         :argument ,(concat "--" name)
         :reader (lambda (&rest _) ,@reader))))

  (screenshot--define-infix
   "-l" "line-numbers-p" "Show line numbers"
   'boolean nil
   (not screenshot-line-numbers-p))

  (screenshot--define-infix
   "-L" "relative-line-numbers-p" "Relative line numbers within the screenshot"
   'boolean nil
   (not screenshot-relative-line-numbers-p))

  (screenshot--define-infix
   "-t" "text-only-p" "Use a text-only version of the buffer"
   'boolean nil
   (not screenshot-text-only-p))

  (screenshot--define-infix
   "-T" "truncate-lines-p" "Truncate lines beyond the screenshot width"
   'boolean nil
   (not screenshot-truncate-lines-p))

  (declare-function counsel-fonts "ext:counsel-fonts")

  (declare-function ivy-read "ext:ivy-read")

  (screenshot--define-infix
   "-ff" "font-family" "Font family to use"
   'string (let ((font (face-attribute 'default :font)))
             (if (eq font 'unspecified) "monospace"
               (symbol-name (font-get font :family))))
   (if (fboundp #'counsel-fonts)
       (ivy-read "Font: " (delete-dups (font-family-list))
                 :preselect screenshot-font-family
                 :require-match t
                 :history 'counsel-fonts-history
                 :caller 'counsel-fonts)
     (completing-read "Font: " (delete-dups (font-family-list)))))

  (screenshot--define-infix
   "-fs" "font-size" "Font size (pt)"
   'number 14
   (read-number "Font size in pt: " screenshot-font-size))

;;;; Frame

  (screenshot--define-infix
   "-b" "border-width" "Border width in pixels"
   'integer 20
   (read-number "Border width in px: " screenshot-border-width))

  (screenshot--define-infix
   "-r" "radius" "Rounded corner radius"
   'integer 10
   (read-number "Border radius in px: " screenshot-radius))

  (screenshot--define-infix
   "-w" "min-width" "Minimum width, in columns"
   'integer 40
   (read-number "Minimum width (columns): " screenshot-min-width))

  (screenshot--define-infix
   "-W" "max-width" "Maximum width, in columns"
   'integer 120
   (read-number "Maximum width (columns): " screenshot-max-width))

;;;; Shadow

  (screenshot--define-infix
   "-s" "shadow-radius" "Radius of the shadow in pixels"
   'integer 12
   (read-number "Shadow width in px: " screenshot-shadow-radius))

  (screenshot--define-infix
   "-i" "shadow-intensity" "Intensity of the shadow"
   'integer 80
   (read-number "Shadow intensity: " screenshot-shadow-intensity))

  (screenshot--define-infix
   "-c" "shadow-color" "Color of the shadow"
   'color "#333"
   (read-string "Shadow color: " screenshot-shadow-color))

  (screenshot--define-infix
   "-x" "shadow-offset-horizontal" "Shadow horizontal offset"
   'integer -8
   (read-number "Shadow horizontal offset in px: " screenshot-shadow-offset-horizontal))

  (screenshot--define-infix
   "-y" "shadow-offset-vertical" "Shadow vertical offset"
   'integer 5
   (read-number "Shadow vertical offset in px: " screenshot-shadow-offset-vertical)))

;;; Main function

;;;###autoload
(defun screenshot (beg end &optional upload-text)
  "Take a screenshot of the current region or buffer.

Region included in screenshot is the active selection, interactively,
or given by BEG and END.  Buffer is used if region spans 0-1 characters.

When a universal argument is given, UPLOAD-TEXT is non-nil.
Then the text of the region/buffer is uploaded, and the URL is copied to clipboard."
  (interactive (if (region-active-p)
                   (list (region-beginning) (region-end) (when current-prefix-arg t))
                 (list (point-min) (point-max) (when current-prefix-arg t))))

  (if upload-text
      (screenshot-text-upload beg end)
    (deactivate-mark)
    (screenshot--set-screenshot-region beg end)
    (setq screenshot--tmp-file
          (make-temp-file "screenshot-" nil ".png"))
    (call-interactively #'screenshot-transient)))

(defvar screenshot-text-upload-function #'screenshot-ixio-upload
  "Function to use to upload text.

Must take a start and end position for the current buffer, and
return a URL.")

(defun screenshot-text-upload (beg end)
  "Upload the region from BEG to END, and copy the upload URL to the clipboard."
  (message "Uploading text...")
  (let ((url
         (funcall screenshot-text-upload-function beg end)))
    (gui-select-text url)
    (message "Screenshot uploaded, link copied to clipboard (%s)" url)))

(defun screenshot-ixio-upload (beg end)
  "Upload the region from BEG to END to ix.io, and return the URL."
  (let ((output (generate-new-buffer "ixio")) url)
    (shell-command-on-region beg end
                             (format "curl -F 'ext:1=%s' -F 'f:1=<-' ix.io 2>/dev/null"
                                     (file-name-extension (or (buffer-file-name) " .txt")))
                             output)
    (setq url (string-trim-right (with-current-buffer output (buffer-string))))
    (kill-buffer output)
    url))

;;; Screenshot capturing

(defun screenshot--set-screenshot-region (beg end)
  "Use the region from BEG to END to determine the relevant region to capture.
Also records useful information like the total number of lines contained,
and the line number of the first line of the region."
  (when (or (= beg end) (= (1+ beg) end))
    (setq beg (point-min)
          end (point-max)))
  (save-excursion
    (goto-char beg)
    (when (string-match-p "\\`\\s-*$" (thing-at-point 'line))
      (forward-line 1)
      (setq beg (line-beginning-position)))
    (back-to-indentation)
    (when (= beg (point))
      (setq beg (line-beginning-position)))
    (goto-char end)
    (when (string-match-p "\\`\\s-*$" (thing-at-point 'line))
      (forward-line -1)
      (setq end (line-end-position))))
  (setq screenshot--region-beginning beg
        screenshot--region-end end
        screenshot--first-line-number (line-number-at-pos beg)
        screenshot--total-lines (- (line-number-at-pos end) (line-number-at-pos beg) -1)))

(defun screenshot--setup-buffer ()
  "Modify the current buffer to make it appropriate for screenshotting."
  (setq-local face-remapping-alist '((line-number-current-line line-number)
                                     (show-paren-match nil)
                                     (region nil))
              line-spacing 0.1)
  (when (bound-and-true-p hl-line-mode) (hl-line-mode -1))
  (when (bound-and-true-p solaire-mode) (solaire-mode -1))
  (run-hooks 'screenshot-buffer-creation-hook))

(defvar screenshot--text-only-buffer
  (with-current-buffer (generate-new-buffer " *screenshot")
    (screenshot--setup-buffer)
    (when prettify-symbols-mode
      (prettify-symbols-mode -1))
    (current-buffer))
  "A text-only buffer for use in creating screenshots.")

(defun screenshot--format-text-only-buffer (beg end)
  "Insert text from BEG to END in the current buffer, into the screenshot text-only buffer."
  ;; include indentation if `beg' is where indentation starts
  (let ((s (string-trim-right (buffer-substring beg end))))
    (with-current-buffer (setq screenshot--buffer screenshot--text-only-buffer)
      (buffer-face-set :family screenshot-font-family
                       :height (* 10 screenshot-font-size))
      (erase-buffer)
      (insert s)
      (indent-rigidly (point-min) (point-max)
                      (- (indent-rigidly--current-indentation
                          (point-min) (point-max))))
      (current-buffer))))

(defun screenshot--narrowed-clone-buffer (beg end)
  "Create a clone of the current buffer, narrowed to the region from BEG to END.
This buffer then then set up to be used for a screenshot."
  (with-current-buffer (clone-indirect-buffer " *screenshot-clone" nil t)
    (narrow-to-region beg end)
    (screenshot--setup-buffer)
    (buffer-face-set :family screenshot-font-family
                     :height (* 10 screenshot-font-size))
    (current-buffer)))

;;; Screenshot processing

(defun screenshot--process ()
  "Perform the screenshot process.

Create a buffer for the screenshot, use `x-export-frames' to create the image,
and process it."
  (setq screenshot--buffer
        (if screenshot-text-only-p
            (screenshot--format-text-only-buffer screenshot--region-beginning screenshot--region-end)
          (screenshot--narrowed-clone-buffer screenshot--region-beginning screenshot--region-end)))

  (let ((frame (posframe-show
                screenshot--buffer
                :position (point-min)
                :internal-border-width screenshot-border-width
                :min-width screenshot-min-width
                :width screenshot-max-width
                :min-height screenshot--total-lines
                :lines-truncate screenshot-truncate-lines-p
                :poshandler #'posframe-poshandler-point-bottom-left-corner
                :hidehandler #'posframe-hide)))
    (with-current-buffer screenshot--buffer
      (setq-local display-line-numbers screenshot-line-numbers-p)
      (when screenshot-text-only-p
        (setq-local display-line-numbers-offset
                    (if screenshot-relative-line-numbers-p
                        0 (1- screenshot--first-line-number))))
      (font-lock-ensure (point-min) (point-max))
      (redraw-frame frame)
      (with-temp-file screenshot--tmp-file
        (insert (x-export-frames frame 'png))))
    (posframe-hide screenshot--buffer))
  (unless screenshot-text-only-p
    (kill-buffer screenshot--buffer))
  (screenshot--post-process screenshot--tmp-file))

(defcustom screenshot-post-process-hook
  (when (executable-find "pngquant")
    (list (defun screenshot--compress-file (file)
            (call-process "pngquant" nil nil nil "-f" "-o" file file))))
  "Functions to be called on the output file after processing.
Must take a single argument, the file name, and operate in-place."
  :type 'function
  :group 'screenshot)

(defun screenshot--post-process (file)
  "Apply any image post-processing to FILE."
  (when (or (> screenshot-radius 0)
            (> screenshot-shadow-radius 0))
    (let ((result
           (shell-command-to-string
            (format "convert '%1$s' \\( +clone -alpha extract \\
\\( -size %2$dx%2$d xc:black -draw 'fill white circle %2$d,%2$d %2$d,0' -write mpr:arc +delete \\) \\
\\( mpr:arc \\) -gravity northwest -composite \\
\\( mpr:arc -flip \\) -gravity southwest -composite \\
\\( mpr:arc -flop \\) -gravity northeast -composite \\
\\( mpr:arc -rotate 180 \\) -gravity southeast -composite \\) \\
-alpha off -compose CopyOpacity -composite -compose over \\
\\( +clone -background '%3$s' -shadow %4$dx%5$d+%6$d+%7$d \\) \\
+swap -background none -layers merge '%1$s'"
                    file
                    screenshot-radius
                    screenshot-shadow-color
                    screenshot-shadow-intensity
                    screenshot-shadow-radius
                    screenshot-shadow-offset-horizontal
                    screenshot-shadow-offset-vertical))))
      (unless (string= result "")
        (error "Could not apply imagemagick commands to image:\n%s" result))))
  (run-hook-with-args 'screenshot-post-process-hook file))

;;; Screenshot actions

(eval-when-compile
  (defmacro screenshot--def-action (name &rest body)
    "Define action NAME to be performed from the transient interface.
BODY is executed after `screenshot-process' is called."
    `(defun ,(intern (concat "screenshot-" name)) (&optional _args)
       "Screenshot action to be performed from the transient interface."
       (interactive
        (list (transient-args 'screenshot-transient)))
       (screenshot--process)
       ,@body))

  (screenshot--def-action
   "save"
   (rename-file
    screenshot--tmp-file
    (concat (file-name-sans-extension
             (or (buffer-file-name)
                 (expand-file-name "screenshot")))
            ".png")
    t)
   (message "Screenshot saved"))

  (screenshot--def-action
   "save-as"
   (rename-file
    screenshot--tmp-file
    (read-file-name "Save as: " (file-name-directory (or (buffer-file-name) default-directory)))
    1)
   (message "Screenshot saved"))

  (screenshot--def-action
   "copy"
   (call-process "xclip" nil nil nil
                 "-selection" "clipboard"
                 "-target" "image/png"
                 "-in" screenshot--tmp-file)
   (delete-file screenshot--tmp-file)
   (message "Screenshot copied"))

  (defcustom screenshot-upload-fn nil
    "Function or string which provides a method to upload a file.
If a function, it must take a filename and returns a URL to it.
If a string, it is formatted with the file name, and run as a shell command.

Note: you have to define this yourself, there is no default."
    :type '(choice function string)
    :group 'screenshot)

  (screenshot--def-action
   "upload"
   (if (not screenshot-upload-fn)
       (error "No upload function defined")
     (message "Uploading...")
     (let ((url
            (pcase screenshot-upload-fn
              ((pred functionp) (funcall screenshot-upload-fn screenshot--tmp-file))
              ((pred stringp) (string-trim-right (shell-command-to-string (format screenshot-upload-fn screenshot--tmp-file))))
              (_ (error "Upload function is not a function or string!")))))
       (gui-select-text url)
       (message "Screenshot uploaded, link copied to clipboard (%s)" url)))
   (delete-file screenshot--tmp-file)))

;;; Screenshot transient

(transient-define-prefix screenshot-transient ()
  ["Code"
   (screenshot--set-line-numbers-p)
   (screenshot--set-relative-line-numbers-p)
   (screenshot--set-text-only-p)
   (screenshot--set-truncate-lines-p)
   (screenshot--set-font-family)
   (screenshot--set-font-size)]
  ["Frame"
   (screenshot--set-border-width)
   (screenshot--set-radius)
   (screenshot--set-min-width)
   (screenshot--set-max-width)]
  ["Shadow"
   (screenshot--set-shadow-radius)
   (screenshot--set-shadow-intensity)
   (screenshot--set-shadow-color)
   (screenshot--set-shadow-offset-horizontal)
   (screenshot--set-shadow-offset-vertical)]
  ["Action"
   ("s" "Save" screenshot-save)
   ("S" "Save as" screenshot-save-as)
   ("c" "Copy" screenshot-copy)
   ("u" "Upload" screenshot-upload)])

(provide 'screenshot)
;;; screenshot.el ends here