From 6bd3184b2f10313021b93cb9e7e8d45c32e0916b Mon Sep 17 00:00:00 2001 From: Roger Gonzalez Date: Sat, 18 Mar 2023 16:44:35 -0300 Subject: Changed fish_variables --- .config/doom/custom-packages/deferred.el | 971 +++++++++++++++++++++++++++++ .config/doom/custom-packages/ox-slack.el | 366 +++++++++++ .config/doom/custom-packages/screenshot.el | 460 ++++++++++++++ 3 files changed, 1797 insertions(+) create mode 100644 .config/doom/custom-packages/deferred.el create mode 100644 .config/doom/custom-packages/ox-slack.el create mode 100644 .config/doom/custom-packages/screenshot.el (limited to '.config/doom/custom-packages') diff --git a/.config/doom/custom-packages/deferred.el b/.config/doom/custom-packages/deferred.el new file mode 100644 index 00000000..041c90b0 --- /dev/null +++ b/.config/doom/custom-packages/deferred.el @@ -0,0 +1,971 @@ +;;; deferred.el --- Simple asynchronous functions for emacs lisp -*- lexical-binding: t; -*- + +;; Copyright (C) 2010-2016 SAKURAI Masashi + +;; Author: SAKURAI Masashi +;; Version: 0.5.1 +;; Keywords: deferred, async +;; Package-Requires: ((emacs "24.4")) +;; URL: https://github.com/kiwanami/emacs-deferred + +;; 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 . + +;;; Commentary: + +;; 'deferred.el' is a simple library for asynchronous tasks. +;; [https://github.com/kiwanami/emacs-deferred] + +;; The API is almost the same as JSDeferred written by cho45. See the +;; JSDeferred and Mochikit.Async web sites for further documentations. +;; [https://github.com/cho45/jsdeferred] +;; [http://mochikit.com/doc/html/MochiKit/Async.html] + +;; A good introduction document (JavaScript) +;; [http://cho45.stfuawsc.com/jsdeferred/doc/intro.en.html] + +;;; Samples: + +;; ** HTTP Access + +;; (require 'url) +;; (deferred:$ +;; (deferred:url-retrieve "http://www.gnu.org") +;; (deferred:nextc it +;; (lambda (buf) +;; (insert (with-current-buffer buf (buffer-string))) +;; (kill-buffer buf)))) + +;; ** Invoking command tasks + +;; (deferred:$ +;; (deferred:process "wget" "-O" "a.jpg" "http://www.gnu.org/software/emacs/tour/images/splash.png") +;; (deferred:nextc it +;; (lambda (x) (deferred:process "convert" "a.jpg" "-resize" "100x100" "jpg:b.jpg"))) +;; (deferred:nextc it +;; (lambda (x) +;; (insert-image (create-image (expand-file-name "b.jpg") 'jpeg nil))))) + +;; See the readme for further API documentation. + +;; ** Applications + +;; *Inertial scrolling for Emacs +;; [https://github.com/kiwanami/emacs-inertial-scroll] + +;; This program makes simple multi-thread function, using +;; deferred.el. + +(require 'cl-lib) +(require 'subr-x) + +(declare-function pp-display-expression 'pp) + +(defvar deferred:version nil "deferred.el version") +(setq deferred:version "0.5.0") + +;;; Code: + +(defmacro deferred:aand (test &rest rest) + "[internal] Anaphoric AND." + (declare (debug ("test" form &rest form))) + `(let ((it ,test)) + (if it ,(if rest `(deferred:aand ,@rest) 'it)))) + +(defmacro deferred:$ (&rest elements) + "Anaphoric function chain macro for deferred chains." + (declare (debug (&rest form))) + `(let (it) + ,@(cl-loop for i in elements + collect + `(setq it ,i)) + it)) + +(defmacro deferred:lambda (args &rest body) + "Anaphoric lambda macro for self recursion." + (declare (debug ("args" form &rest form))) + (let ((argsyms (cl-loop repeat (length args) collect (cl-gensym)))) + `(lambda (,@argsyms) + (let (self) + (setq self (lambda( ,@args ) ,@body)) + (funcall self ,@argsyms))))) + +(cl-defmacro deferred:try (d &key catch finally) + "Try-catch-finally macro. This macro simulates the +try-catch-finally block asynchronously. CATCH and FINALLY can be +nil. Because of asynchrony, this macro does not ensure that the +task FINALLY should be called." + (let ((chain + (if catch `((deferred:error it ,catch))))) + (when finally + (setq chain (append chain `((deferred:watch it ,finally))))) + `(deferred:$ ,d ,@chain))) + +(defun deferred:setTimeout (f msec) + "[internal] Timer function that emulates the `setTimeout' function in JS." + (run-at-time (/ msec 1000.0) nil f)) + +(defun deferred:cancelTimeout (id) + "[internal] Timer cancellation function that emulates the `cancelTimeout' function in JS." + (cancel-timer id)) + +(defun deferred:run-with-idle-timer (sec f) + "[internal] Wrapper function for run-with-idle-timer." + (run-with-idle-timer sec nil f)) + +(defun deferred:call-lambda (f &optional arg) + "[internal] Call a function with one or zero argument safely. +The lambda function can define with zero and one argument." + (condition-case err + (funcall f arg) + ('wrong-number-of-arguments + (display-warning 'deferred "\ +Callback that takes no argument may be specified. +Passing callback with no argument is deprecated. +Callback must take one argument. +Or, this error is coming from somewhere inside of the callback: %S" err) + (condition-case nil + (funcall f) + ('wrong-number-of-arguments + (signal 'wrong-number-of-arguments (cdr err))))))) ; return the first error + +;; debug + +(eval-and-compile + (defvar deferred:debug nil "Debug output switch.")) +(defvar deferred:debug-count 0 "[internal] Debug output counter.") + +(defmacro deferred:message (&rest args) + "[internal] Debug log function." + (when deferred:debug + `(progn + (with-current-buffer (get-buffer-create "*deferred:debug*") + (save-excursion + (goto-char (point-max)) + (insert (format "%5i %s\n" deferred:debug-count (format ,@args))))) + (cl-incf deferred:debug-count)))) + +(defun deferred:message-mark () + "[internal] Debug log function." + (interactive) + (deferred:message "==================== mark ==== %s" + (format-time-string "%H:%M:%S" (current-time)))) + +(defun deferred:pp (d) + (require 'pp) + (deferred:$ + (deferred:nextc d + (lambda (x) + (pp-display-expression x "*deferred:pp*"))) + (deferred:error it + (lambda (e) + (pp-display-expression e "*deferred:pp*"))) + (deferred:nextc it + (lambda (_x) (pop-to-buffer "*deferred:pp*"))))) + +(defvar deferred:debug-on-signal nil +"If non nil, the value `debug-on-signal' is substituted this +value in the `condition-case' form in deferred +implementations. Then, Emacs debugger can catch an error occurred +in the asynchronous tasks.") + +(defmacro deferred:condition-case (var protected-form &rest handlers) + "[internal] Custom condition-case. See the comment for +`deferred:debug-on-signal'." + (declare (debug condition-case) + (indent 2)) + `(let ((debug-on-signal + (or debug-on-signal deferred:debug-on-signal))) + (condition-case ,var + ,protected-form + ,@handlers))) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Back end functions of deferred tasks + +(defvar deferred:tick-time 0.001 + "Waiting time between asynchronous tasks (second). +The shorter waiting time increases the load of Emacs. The end +user can tune this parameter. However, applications should not +modify it because the applications run on various environments.") + +(defvar deferred:queue nil + "[internal] The execution queue of deferred objects. +See the functions `deferred:post-task' and `deferred:worker'.") + +(defmacro deferred:pack (a b c) + `(cons ,a (cons ,b ,c))) + +(defun deferred:schedule-worker () + "[internal] Schedule consuming a deferred task in the execution queue." + (run-at-time deferred:tick-time nil 'deferred:worker)) + +(defun deferred:post-task (d which &optional arg) + "[internal] Add a deferred object to the execution queue +`deferred:queue' and schedule to execute. +D is a deferred object. WHICH is a symbol, `ok' or `ng'. ARG is +an argument value for execution of the deferred task." + (push (deferred:pack d which arg) deferred:queue) + (deferred:message "QUEUE-POST [%s]: %s" + (length deferred:queue) (deferred:pack d which arg)) + (deferred:schedule-worker) + d) + +(defun deferred:clear-queue () + "Clear the execution queue. For test and debugging." + (interactive) + (deferred:message "QUEUE-CLEAR [%s -> 0]" (length deferred:queue)) + (setq deferred:queue nil)) + +(defun deferred:worker () + "[internal] Consume a deferred task. +Mainly this function is called by timer asynchronously." + (when deferred:queue + (let* ((pack (car (last deferred:queue))) + (d (car pack)) + (which (cadr pack)) + (arg (cddr pack)) value) + (setq deferred:queue (nbutlast deferred:queue)) + (condition-case err + (setq value (deferred:exec-task d which arg)) + (error + (deferred:message "ERROR : %s" err) + (message "deferred error : %s" err))) + value))) + +(defun deferred:flush-queue! () + "Call all deferred tasks synchronously. For test and debugging." + (let (value) + (while deferred:queue + (setq value (deferred:worker))) + value)) + +(defun deferred:sync! (d) + "Wait for the given deferred task. For test and debugging. +Error is raised if it is not processed within deferred chain D." + (progn + (let ((last-value 'deferred:undefined*) + uncaught-error) + (deferred:try + (deferred:nextc d + (lambda (x) (setq last-value x))) + :catch + (lambda (err) (setq uncaught-error err))) + (while (and (eq 'deferred:undefined* last-value) + (not uncaught-error)) + (sit-for 0.05) + (sleep-for 0.05)) + (when uncaught-error + (deferred:resignal uncaught-error)) + last-value))) + + + +;; Struct: deferred +;; +;; callback : a callback function (default `deferred:default-callback') +;; errorback : an errorback function (default `deferred:default-errorback') +;; cancel : a canceling function (default `deferred:default-cancel') +;; next : a next chained deferred object (default nil) +;; status : if 'ok or 'ng, this deferred has a result (error) value. (default nil) +;; value : saved value (default nil) +;; +(cl-defstruct deferred + (callback 'deferred:default-callback) + (errorback 'deferred:default-errorback) + (cancel 'deferred:default-cancel) + next status value) + +(defun deferred:default-callback (i) + "[internal] Default callback function." + (identity i)) + +(defun deferred:default-errorback (err) + "[internal] Default errorback function." + (deferred:resignal err)) + +(defun deferred:resignal (err) + "[internal] Safely resignal ERR as an Emacs condition. + +If ERR is a cons (ERROR-SYMBOL . DATA) where ERROR-SYMBOL has an +`error-conditions' property, it is re-signaled unchanged. If ERR +is a string, it is signaled as a generic error using `error'. +Otherwise, ERR is formatted into a string as if by `print' before +raising with `error'." + (cond ((and (listp err) + (symbolp (car err)) + (get (car err) 'error-conditions)) + (signal (car err) (cdr err))) + ((stringp err) + (error "%s" err)) + (t + (error "%S" err)))) + +(defun deferred:default-cancel (d) + "[internal] Default canceling function." + (deferred:message "CANCEL : %s" d) + (setf (deferred-callback d) 'deferred:default-callback) + (setf (deferred-errorback d) 'deferred:default-errorback) + (setf (deferred-next d) nil) + d) + +(defvar deferred:onerror nil + "Default error handler. This value is nil or a function that + have one argument for the error message.") + +(defun deferred:exec-task (d which &optional arg) + "[internal] Executing deferred task. If the deferred object has +next deferred task or the return value is a deferred object, this +function adds the task to the execution queue. +D is a deferred object. WHICH is a symbol, `ok' or `ng'. ARG is +an argument value for execution of the deferred task." + (deferred:message "EXEC : %s / %s / %s" d which arg) + (when (null d) (error "deferred:exec-task was given a nil.")) + (let ((callback (if (eq which 'ok) + (deferred-callback d) + (deferred-errorback d))) + (next-deferred (deferred-next d))) + (cond + (callback + (deferred:condition-case err + (let ((value (deferred:call-lambda callback arg))) + (cond + ((deferred-p value) + (deferred:message "WAIT NEST : %s" value) + (if next-deferred + (deferred:set-next value next-deferred) + value)) + (t + (if next-deferred + (deferred:post-task next-deferred 'ok value) + (setf (deferred-status d) 'ok) + (setf (deferred-value d) value) + value)))) + (error + (cond + (next-deferred + (deferred:post-task next-deferred 'ng err)) + (deferred:onerror + (deferred:call-lambda deferred:onerror err)) + (t + (deferred:message "ERROR : %S" err) + (message "deferred error : %S" err) + (setf (deferred-status d) 'ng) + (setf (deferred-value d) err) + err))))) + (t ; <= (null callback) + (cond + (next-deferred + (deferred:exec-task next-deferred which arg)) + ((eq which 'ok) arg) + (t ; (eq which 'ng) + (deferred:resignal arg))))))) + +(defun deferred:set-next (prev next) + "[internal] Connect deferred objects." + (setf (deferred-next prev) next) + (cond + ((eq 'ok (deferred-status prev)) + (setf (deferred-status prev) nil) + (let ((ret (deferred:exec-task + next 'ok (deferred-value prev)))) + (if (deferred-p ret) ret + next))) + ((eq 'ng (deferred-status prev)) + (setf (deferred-status prev) nil) + (let ((ret (deferred:exec-task next 'ng (deferred-value prev)))) + (if (deferred-p ret) ret + next))) + (t + next))) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Basic functions for deferred objects + +(defun deferred:new (&optional callback) + "Create a deferred object." + (if callback + (make-deferred :callback callback) + (make-deferred))) + +(defun deferred:callback (d &optional arg) + "Start deferred chain with a callback message." + (deferred:exec-task d 'ok arg)) + +(defun deferred:errorback (d &optional arg) + "Start deferred chain with an errorback message." + (deferred:exec-task d 'ng arg)) + +(defun deferred:callback-post (d &optional arg) + "Add the deferred object to the execution queue." + (deferred:post-task d 'ok arg)) + +(defun deferred:errorback-post (d &optional arg) + "Add the deferred object to the execution queue." + (deferred:post-task d 'ng arg)) + +(defun deferred:cancel (d) + "Cancel all callbacks and deferred chain in the deferred object." + (deferred:message "CANCEL : %s" d) + (funcall (deferred-cancel d) d) + d) + +(defun deferred:status (d) + "Return a current status of the deferred object. The returned value means following: +`ok': the callback was called and waiting for next deferred. +`ng': the errorback was called and waiting for next deferred. + nil: The neither callback nor errorback was not called." + (deferred-status d)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Basic utility functions + +(defun deferred:succeed (&optional arg) + "Create a synchronous deferred object." + (let ((d (deferred:new))) + (deferred:exec-task d 'ok arg) + d)) + +(defun deferred:fail (&optional arg) + "Create a synchronous deferred object." + (let ((d (deferred:new))) + (deferred:exec-task d 'ng arg) + d)) + +(defun deferred:next (&optional callback arg) + "Create a deferred object and schedule executing. This function +is a short cut of following code: + (deferred:callback-post (deferred:new callback))." + (let ((d (if callback + (make-deferred :callback callback) + (make-deferred)))) + (deferred:callback-post d arg) + d)) + +(defun deferred:nextc (d callback) + "Create a deferred object with OK callback and connect it to the given deferred object." + (let ((nd (make-deferred :callback callback))) + (deferred:set-next d nd))) + +(defun deferred:error (d callback) + "Create a deferred object with errorback and connect it to the given deferred object." + (let ((nd (make-deferred :errorback callback))) + (deferred:set-next d nd))) + +(defun deferred:watch (d callback) + "Create a deferred object with watch task and connect it to the given deferred object. +The watch task CALLBACK can not affect deferred chains with +return values. This function is used in following purposes, +simulation of try-finally block in asynchronous tasks, progress +monitoring of tasks." + (let* ((callback callback) + (normal (lambda (x) (ignore-errors (deferred:call-lambda callback x)) x)) + (err (lambda (e) + (ignore-errors (deferred:call-lambda callback e)) + (deferred:resignal e)))) + (let ((nd (make-deferred :callback normal :errorback err))) + (deferred:set-next d nd)))) + +(defun deferred:wait (msec) + "Return a deferred object scheduled at MSEC millisecond later." + (let ((d (deferred:new)) (start-time (float-time)) timer) + (deferred:message "WAIT : %s" msec) + (setq timer (deferred:setTimeout + (lambda () + (deferred:exec-task d 'ok + (* 1000.0 (- (float-time) start-time))) + nil) msec)) + (setf (deferred-cancel d) + (lambda (x) + (deferred:cancelTimeout timer) + (deferred:default-cancel x))) + d)) + +(defun deferred:wait-idle (msec) + "Return a deferred object which will run when Emacs has been +idle for MSEC millisecond." + (let ((d (deferred:new)) (start-time (float-time)) timer) + (deferred:message "WAIT-IDLE : %s" msec) + (setq timer + (deferred:run-with-idle-timer + (/ msec 1000.0) + (lambda () + (deferred:exec-task d 'ok + (* 1000.0 (- (float-time) start-time))) + nil))) + (setf (deferred-cancel d) + (lambda (x) + (deferred:cancelTimeout timer) + (deferred:default-cancel x))) + d)) + +(defun deferred:call (f &rest args) + "Call the given function asynchronously." + (deferred:next + (lambda (_x) + (apply f args)))) + +(defun deferred:apply (f &optional args) + "Call the given function asynchronously." + (deferred:next + (lambda (_x) + (apply f args)))) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Utility functions + +(defun deferred:empty-p (times-or-seq) + "[internal] Return non-nil if TIMES-OR-SEQ is the number zero or nil." + (or (and (numberp times-or-seq) (<= times-or-seq 0)) + (and (sequencep times-or-seq) (= (length times-or-seq) 0)))) + +(defun deferred:loop (times-or-seq func) + "Return a iteration deferred object." + (deferred:message "LOOP : %s" times-or-seq) + (if (deferred:empty-p times-or-seq) (deferred:next) + (let* (items (rd + (cond + ((numberp times-or-seq) + (cl-loop for i from 0 below times-or-seq + with ld = (deferred:next) + do + (push ld items) + (setq ld + (let ((i i)) + (deferred:nextc ld + (lambda (_x) (deferred:call-lambda func i))))) + finally return ld)) + ((sequencep times-or-seq) + (cl-loop for i in (append times-or-seq nil) ; seq->list + with ld = (deferred:next) + do + (push ld items) + (setq ld + (let ((i i)) + (deferred:nextc ld + (lambda (_x) (deferred:call-lambda func i))))) + finally return ld))))) + (setf (deferred-cancel rd) + (lambda (x) (deferred:default-cancel x) + (cl-loop for i in items + do (deferred:cancel i)))) + rd))) + +(defun deferred:trans-multi-args (args self-func list-func main-func) + "[internal] Check the argument values and dispatch to methods." + (cond + ((and (= 1 (length args)) (consp (car args)) (not (functionp (car args)))) + (let ((lst (car args))) + (cond + ((or (null lst) (null (car lst))) + (deferred:next)) + ((deferred:aand lst (car it) (or (functionp it) (deferred-p it))) + ;; a list of deferred objects + (funcall list-func lst)) + ((deferred:aand lst (consp it)) + ;; an alist of deferred objects + (funcall main-func lst)) + (t (error "Wrong argument type. %s" args))))) + (t (funcall self-func args)))) + +(defun deferred:parallel-array-to-alist (lst) + "[internal] Translation array to alist." + (cl-loop for d in lst + for i from 0 below (length lst) + collect (cons i d))) + +(defun deferred:parallel-alist-to-array (alst) + "[internal] Translation alist to array." + (cl-loop for pair in + (sort alst (lambda (x y) + (< (car x) (car y)))) + collect (cdr pair))) + +(defun deferred:parallel-func-to-deferred (alst) + "[internal] Normalization for parallel and earlier arguments." + (cl-loop for pair in alst + for d = (cdr pair) + collect + (progn + (unless (deferred-p d) + (setf (cdr pair) (deferred:next d))) + pair))) + +(defun deferred:parallel-main (alst) + "[internal] Deferred alist implementation for `deferred:parallel'. " + (deferred:message "PARALLEL" ) + (let ((nd (deferred:new)) + (len (length alst)) + values) + (cl-loop for pair in + (deferred:parallel-func-to-deferred alst) + with cd ; current child deferred + do + (let ((name (car pair))) + (setq cd + (deferred:nextc (cdr pair) + (lambda (x) + (push (cons name x) values) + (deferred:message "PARALLEL VALUE [%s/%s] %s" + (length values) len (cons name x)) + (when (= len (length values)) + (deferred:message "PARALLEL COLLECTED") + (deferred:post-task nd 'ok (nreverse values))) + nil))) + (deferred:error cd + (lambda (e) + (push (cons name e) values) + (deferred:message "PARALLEL ERROR [%s/%s] %s" + (length values) len (cons name e)) + (when (= (length values) len) + (deferred:message "PARALLEL COLLECTED") + (deferred:post-task nd 'ok (nreverse values))) + nil)))) + nd)) + +(defun deferred:parallel-list (lst) + "[internal] Deferred list implementation for `deferred:parallel'. " + (deferred:message "PARALLEL" ) + (let* ((pd (deferred:parallel-main (deferred:parallel-array-to-alist lst))) + (rd (deferred:nextc pd 'deferred:parallel-alist-to-array))) + (setf (deferred-cancel rd) + (lambda (x) (deferred:default-cancel x) + (deferred:cancel pd))) + rd)) + +(defun deferred:parallel (&rest args) + "Return a deferred object that calls given deferred objects or +functions in parallel and wait for all callbacks. The following +deferred task will be called with an array of the return +values. ARGS can be a list or an alist of deferred objects or +functions." + (deferred:message "PARALLEL : %s" args) + (deferred:trans-multi-args args + 'deferred:parallel 'deferred:parallel-list 'deferred:parallel-main)) + +(defun deferred:earlier-main (alst) + "[internal] Deferred alist implementation for `deferred:earlier'. " + (deferred:message "EARLIER" ) + (let ((nd (deferred:new)) + (len (length alst)) + value results) + (cl-loop for pair in + (deferred:parallel-func-to-deferred alst) + with cd ; current child deferred + do + (let ((name (car pair))) + (setq cd + (deferred:nextc (cdr pair) + (lambda (x) + (push (cons name x) results) + (cond + ((null value) + (setq value (cons name x)) + (deferred:message "EARLIER VALUE %s" (cons name value)) + (deferred:post-task nd 'ok value)) + (t + (deferred:message "EARLIER MISS [%s/%s] %s" (length results) len (cons name value)) + (when (eql (length results) len) + (deferred:message "EARLIER COLLECTED")))) + nil))) + (deferred:error cd + (lambda (e) + (push (cons name e) results) + (deferred:message "EARLIER ERROR [%s/%s] %s" (length results) len (cons name e)) + (when (and (eql (length results) len) (null value)) + (deferred:message "EARLIER FAILED") + (deferred:post-task nd 'ok nil)) + nil)))) + nd)) + +(defun deferred:earlier-list (lst) + "[internal] Deferred list implementation for `deferred:earlier'. " + (deferred:message "EARLIER" ) + (let* ((pd (deferred:earlier-main (deferred:parallel-array-to-alist lst))) + (rd (deferred:nextc pd (lambda (x) (cdr x))))) + (setf (deferred-cancel rd) + (lambda (x) (deferred:default-cancel x) + (deferred:cancel pd))) + rd)) + + +(defun deferred:earlier (&rest args) + "Return a deferred object that calls given deferred objects or +functions in parallel and wait for the first callback. The +following deferred task will be called with the first return +value. ARGS can be a list or an alist of deferred objects or +functions." + (deferred:message "EARLIER : %s" args) + (deferred:trans-multi-args args + 'deferred:earlier 'deferred:earlier-list 'deferred:earlier-main)) + +(defmacro deferred:timeout (timeout-msec timeout-form d) + "Time out macro on a deferred task D. If the deferred task D +does not complete within TIMEOUT-MSEC, this macro cancels the +deferred task and return the TIMEOUT-FORM." + `(deferred:earlier + (deferred:nextc (deferred:wait ,timeout-msec) + (lambda (x) ,timeout-form)) + ,d)) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Application functions + +(defvar deferred:uid 0 "[internal] Sequence number for some utilities. See the function `deferred:uid'.") + +(defun deferred:uid () + "[internal] Generate a sequence number." + (cl-incf deferred:uid)) + +(defun deferred:buffer-string (strformat buf) + "[internal] Return a string in the buffer with the given format." + (format strformat + (with-current-buffer buf (buffer-string)))) + +(defun deferred:process (command &rest args) + "A deferred wrapper of `start-process'. Return a deferred +object. The process name and buffer name of the argument of the +`start-process' are generated by this function automatically. +The next deferred object receives stdout and stderr string from +the command process." + (deferred:process-gen 'start-process command args)) + +(defun deferred:process-shell (command &rest args) + "A deferred wrapper of `start-process-shell-command'. Return a deferred +object. The process name and buffer name of the argument of the +`start-process-shell-command' are generated by this function automatically. +The next deferred object receives stdout and stderr string from +the command process." + (deferred:process-gen 'start-process-shell-command command args)) + +(defun deferred:process-buffer (command &rest args) + "A deferred wrapper of `start-process'. Return a deferred +object. The process name and buffer name of the argument of the +`start-process' are generated by this function automatically. +The next deferred object receives stdout and stderr buffer from +the command process." + (deferred:process-buffer-gen 'start-process command args)) + +(defun deferred:process-shell-buffer (command &rest args) + "A deferred wrapper of `start-process-shell-command'. Return a deferred +object. The process name and buffer name of the argument of the +`start-process-shell-command' are generated by this function automatically. +The next deferred object receives stdout and stderr buffer from +the command process." + (deferred:process-buffer-gen 'start-process-shell-command command args)) + +(defun deferred:process-gen (f command args) + "[internal]" + (let ((pd (deferred:process-buffer-gen f command args)) d) + (setq d (deferred:nextc pd + (lambda (buf) + (prog1 + (with-current-buffer buf (buffer-string)) + (kill-buffer buf))))) + (setf (deferred-cancel d) + (lambda (_x) + (deferred:default-cancel d) + (deferred:default-cancel pd))) + d)) + +(defun deferred:process-buffer-gen (f command args) + "[internal]" + (let ((d (deferred:next)) (uid (deferred:uid))) + (let ((proc-name (format "*deferred:*%s*:%s" command uid)) + (buf-name (format " *deferred:*%s*:%s" command uid)) + (pwd default-directory) + (env process-environment) + (con-type process-connection-type) + (nd (deferred:new)) proc-buf proc) + (deferred:nextc d + (lambda (_x) + (setq proc-buf (get-buffer-create buf-name)) + (condition-case err + (let ((default-directory pwd) + (process-environment env) + (process-connection-type con-type)) + (setq proc + (if (null (car args)) + (apply f proc-name buf-name command nil) + (apply f proc-name buf-name command args))) + (set-process-sentinel + proc + (lambda (proc event) + (unless (process-live-p proc) + (if (zerop (process-exit-status proc)) + (deferred:post-task nd 'ok proc-buf) + (let ((msg (format "Deferred process exited abnormally:\n command: %s\n exit status: %s %s\n event: %s\n buffer contents: %S" + command + (process-status proc) + (process-exit-status proc) + (string-trim-right event) + (if (buffer-live-p proc-buf) + (with-current-buffer proc-buf + (buffer-string)) + "(unavailable)")))) + (kill-buffer proc-buf) + (deferred:post-task nd 'ng msg)))))) + (setf (deferred-cancel nd) + (lambda (x) (deferred:default-cancel x) + (when proc + (kill-process proc) + (kill-buffer proc-buf))))) + (error (deferred:post-task nd 'ng err))) + nil)) + nd))) + +(defmacro deferred:processc (d command &rest args) + "Process chain of `deferred:process'." + `(deferred:nextc ,d + (lambda (,(cl-gensym)) (deferred:process ,command ,@args)))) + +(defmacro deferred:process-bufferc (d command &rest args) + "Process chain of `deferred:process-buffer'." + `(deferred:nextc ,d + (lambda (,(cl-gensym)) (deferred:process-buffer ,command ,@args)))) + +(defmacro deferred:process-shellc (d command &rest args) + "Process chain of `deferred:process'." + `(deferred:nextc ,d + (lambda (,(cl-gensym)) (deferred:process-shell ,command ,@args)))) + +(defmacro deferred:process-shell-bufferc (d command &rest args) + "Process chain of `deferred:process-buffer'." + `(deferred:nextc ,d + (lambda (,(cl-gensym)) (deferred:process-shell-buffer ,command ,@args)))) + +;; Special variables defined in url-vars.el. +(defvar url-request-data) +(defvar url-request-method) +(defvar url-request-extra-headers) + +(declare-function url-http-symbol-value-in-buffer "url-http" + (symbol buffer &optional unbound-value)) + +(declare-function deferred:url-param-serialize "request" (params)) + +(declare-function deferred:url-escape "request" (val)) + +(eval-after-load "url" + ;; for url package + ;; TODO: proxy, charaset + ;; List of gloabl variables to preserve and restore before url-retrieve call + '(let ((url-global-variables '(url-request-data + url-request-method + url-request-extra-headers))) + + (defun deferred:url-retrieve (url &optional cbargs silent inhibit-cookies) + "A wrapper function for url-retrieve. The next deferred +object receives the buffer object that URL will load +into. Values of dynamically bound 'url-request-data', 'url-request-method' and +'url-request-extra-headers' are passed to url-retrieve call." + (let ((nd (deferred:new)) + buf + (local-values (mapcar (lambda (symbol) (symbol-value symbol)) url-global-variables))) + (deferred:next + (lambda (_x) + (cl-progv url-global-variables local-values + (condition-case err + (setq buf + (url-retrieve + url (lambda (_xx) (deferred:post-task nd 'ok buf)) + cbargs silent inhibit-cookies)) + (error (deferred:post-task nd 'ng err))) + nil))) + (setf (deferred-cancel nd) + (lambda (_x) + (when (buffer-live-p buf) + (kill-buffer buf)))) + nd)) + + (defun deferred:url-delete-header (buf) + (with-current-buffer buf + (let ((pos (url-http-symbol-value-in-buffer + 'url-http-end-of-headers buf))) + (when pos + (delete-region (point-min) (1+ pos))))) + buf) + + (defun deferred:url-delete-buffer (buf) + (when (and buf (buffer-live-p buf)) + (kill-buffer buf)) + nil) + + (defun deferred:url-get (url &optional params &rest args) + "Perform a HTTP GET method with `url-retrieve'. PARAMS is +a parameter list of (key . value) or key. ARGS will be appended +to deferred:url-retrieve args list. The next deferred +object receives the buffer object that URL will load into." + (when params + (setq url + (concat url "?" (deferred:url-param-serialize params)))) + (let ((d (deferred:$ + (apply 'deferred:url-retrieve url args) + (deferred:nextc it 'deferred:url-delete-header)))) + (deferred:set-next + d (deferred:new 'deferred:url-delete-buffer)) + d)) + + (defun deferred:url-post (url &optional params &rest args) + "Perform a HTTP POST method with `url-retrieve'. PARAMS is +a parameter list of (key . value) or key. ARGS will be appended +to deferred:url-retrieve args list. The next deferred +object receives the buffer object that URL will load into." + (let ((url-request-method "POST") + (url-request-extra-headers + (append url-request-extra-headers + '(("Content-Type" . "application/x-www-form-urlencoded")))) + (url-request-data (deferred:url-param-serialize params))) + (let ((d (deferred:$ + (apply 'deferred:url-retrieve url args) + (deferred:nextc it 'deferred:url-delete-header)))) + (deferred:set-next + d (deferred:new 'deferred:url-delete-buffer)) + d))) + + (defun deferred:url-escape (val) + "[internal] Return a new string that is VAL URI-encoded." + (unless (stringp val) + (setq val (format "%s" val))) + (url-hexify-string + (encode-coding-string val 'utf-8))) + + (defun deferred:url-param-serialize (params) + "[internal] Serialize a list of (key . value) cons cells +into a query string." + (when params + (mapconcat + 'identity + (cl-loop for p in params + collect + (cond + ((consp p) + (concat + (deferred:url-escape (car p)) "=" + (deferred:url-escape (cdr p)))) + (t + (deferred:url-escape p)))) + "&"))) + )) + + +(provide 'deferred) +;;; deferred.el ends here diff --git a/.config/doom/custom-packages/ox-slack.el b/.config/doom/custom-packages/ox-slack.el new file mode 100644 index 00000000..7f930277 --- /dev/null +++ b/.config/doom/custom-packages/ox-slack.el @@ -0,0 +1,366 @@ +;;; ox-slack.el --- Slack Exporter for org-mode -*- lexical-binding: t; -*- + + +;; Copyright (C) 2018 Matt Price + +;; Author: Matt Price +;; Keywords: org, slack, outlines +;; Package-Version: 0.1.1 +;; Package-Requires: ((emacs "24") (org "9.1.4") (ox-gfm "1.0")) +;; URL: https://github.com/titaniumbones/ox-slack + +;; This file is not part of GNU Emacs. + +;; 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 . + +;;; Commentary: + +;; This library implements a Slack backend for the Org +;; exporter, based on the `md' and `gfm' back-ends. + +;;; Code: + +(require 'ox-gfm) + +(org-export-define-derived-backend 'slack 'gfm + ;; for now, I just have this commented out + ;; might be better to create a defcustom to + ;; decide whether to add this to the export dispatcher + ;; :menu-entry + ;; '(?s "Export to Slack syntax" + ;; ((?s "To temporary buffer" + ;; (lambda (a s v b) (org-slack-export-as-slack a s v))) + ;; (?S "To file" (lambda (a s v b) (org-slack-export-to-slack a s v))) + ;; (?o "To file and open" + ;; (lambda (a s v b) + ;; (if a (org-slack-export-to-slack t s v) + ;; (org-open-file (org-slack-export-to-slack nil s v))))))) + :translate-alist + '( + (bold . org-slack-bold) + (code . org-slack-code) + (headline . org-slack-headline) + (inner-template . org-slack-inner-template) + (italic . org-slack-italic) + (link . org-slack-link) + (plain-text . org-slack-plain-text) + (src-block . org-slack-src-block) + (strike-through . org-slack-strike-through) + (timestamp . org-slack-timestamp))) + +;; timestamp +(defun org-slack-timestamp (timestamp contents info) + "Transcode TIMESTAMP element into Slack format. +CONTENTS is the timestamp contents. INFO is a plist used as a +ocmmunications channel." + (org-html-plain-text (org-timestamp-translate timestamp) info)) + +;; headline +(defun org-slack-headline (headline contents info) + "Transcode HEADLINE element into Markdown format. +CONTENTS is the headline contents. INFO is a plist used as +a communication channel." + (unless (org-element-property :footnote-section-p headline) + (let* ((level (org-export-get-relative-level headline info)) + (title (org-export-data (org-element-property :title headline) info)) + (todo (and (plist-get info :with-todo-keywords) + (let ((todo (org-element-property :todo-keyword + headline))) + (and todo (concat (org-export-data todo info) " "))))) + (tags (and (plist-get info :with-tags) + (let ((tag-list (org-export-get-tags headline info))) + (and tag-list + (concat " " (org-make-tag-string tag-list)))))) + (priority + (and (plist-get info :with-priority) + (let ((char (org-element-property :priority headline))) + (and char (format "[#%c] " char))))) + ;; Headline text without tags. + (heading (concat todo priority title))) + (format "*%s*\n\n%s" title contents) + ))) + +;; link +(defun org-slack-link (link contents info) + "Transcode LINK object into Markdown format. + CONTENTS is the link's description. INFO is a plist used as + a communication channel." + (let ((link-org-files-as-md + (lambda (raw-path) + ;; Treat links to `file.org' as links to `file.md'. + (if (string= ".org" (downcase (file-name-extension raw-path "."))) + (concat (file-name-sans-extension raw-path) ".md") + raw-path))) + (type (org-element-property :type link))) + (cond + ;; Link type is handled by a special function. + ((org-export-custom-protocol-maybe link contents 'md)) + ((member type '("custom-id" "id" "fuzzy")) + (let ((destination (if (string= type "fuzzy") + (org-export-resolve-fuzzy-link link info) + (org-export-resolve-id-link link info)))) + (pcase (org-element-type destination) + (`plain-text ; External file. + (let ((path (funcall link-org-files-as-md destination))) + (if (not contents) (format "%s>" path) + (format "[%s](%s)" contents path)))) + (`headline + (format + ;; "[%s](#%s)" + "[%s]" + ;; Description. + (cond ((org-string-nw-p contents)) + ((org-export-numbered-headline-p destination info) + (mapconcat #'number-to-string + (org-export-get-headline-number destination info) + ".")) + (t (org-export-data (org-element-property :title destination) + info))) + ;; Reference. + ;; (or (org-element-property :CUSTOM_ID destination) + ;; (org-export-get-reference destination info)) + )) + (_ + (let ((description + (or (org-string-nw-p contents) + (let ((number (org-export-get-ordinal destination info))) + (cond + ((not number) nil) + ((atom number) (number-to-string number)) + (t (mapconcat #'number-to-string number "."))))))) + (when description + (format "[%s]" + description + ;; (org-export-get-reference destination info) + ))))))) + ((org-export-inline-image-p link org-html-inline-image-rules) + (let ((path (let ((raw-path (org-element-property :path link))) + (cond ((not (equal "file" type)) (concat type ":" raw-path)) + ((not (file-name-absolute-p raw-path)) raw-path) + (t (expand-file-name raw-path))))) + (caption (org-export-data + (org-export-get-caption + (org-export-get-parent-element link)) info))) + (format "![img](%s)" + (if (not (org-string-nw-p caption)) path + (format "%s \"%s\"" path caption))))) + ((string= type "coderef") + (let ((ref (org-element-property :path link))) + (format (org-export-get-coderef-format ref contents) + (org-export-resolve-coderef ref info)))) + ((equal type "radio") contents) + (t (let* ((raw-path (org-element-property :path link)) + (path + (cond + ((member type '("http" "https" "ftp" "mailto")) + (concat type ":" raw-path)) + ((string= type "file") + (org-export-file-uri (funcall link-org-files-as-md raw-path))) + (t raw-path)))) + (if (not contents) (format "%s" path) + (format "[%s](%s)" contents path))))))) + +(defun org-slack-verbatim (_verbatim contents _info) + "Transcode VERBATIM from Org to Slack. + CONTENTS is the text with bold markup. INFO is a plist holding + contextual information." + (format "`%s`" contents)) + +(defun org-slack-code (code _contents info) + "Return a CODE object from Org to SLACK. + CONTENTS is nil. INFO is a plist holding contextual + information." + (format "`%s`" + (org-element-property :value code))) + + ;;;; Italic + +(defun org-slack-italic (_italic contents _info) + "Transcode italic from Org to SLACK. + CONTENTS is the text with italic markup. INFO is a plist holding + contextual information." + (format "_%s_" contents)) + + ;;; Bold +(defun org-slack-bold (_bold contents _info) + "Transcode bold from Org to SLACK. + CONTENTS is the text with bold markup. INFO is a plist holding + contextual information." + (format "*%s*" contents)) + + +;;;; Strike-through +(defun org-slack-strike-through (_strike-through contents _info) + "Transcode STRIKE-THROUGH from Org to SLACK. + CONTENTS is text with strike-through markup. INFO is a plist + holding contextual information." + (format "~%s~" contents)) + + +(defun org-slack-inline-src-block (inline-src-block _contents info) + "Transcode an INLINE-SRC-BLOCK element from Org to SLACK. + CONTENTS holds the contents of the item. INFO is a plist holding + contextual information." + (format "`%s`" + (org-element-property :value inline-src-block))) + +;;;; Src Block +(defun org-slack-src-block (src-block contents info) + "Transcode SRC-BLOCK element into Github Flavored Markdown format. + CONTENTS is nil. INFO is a plist used as a communication + channel." + (let* ((lang (org-element-property :language src-block)) + (code (org-export-format-code-default src-block info)) + (prefix (concat "```" "\n")) + (suffix "```")) + (concat prefix code suffix))) + +;;;; Quote Block +(defun org-slack-quote-block (_quote-block contents info) + "Transcode a QUOTE-BLOCK element from Org to SLACK. + CONTENTS holds the contents of the block. INFO is a plist + holding contextual information." + (org-slack--indent-string contents (plist-get info :slack-quote-margin))) + + +(defun org-slack-inner-template (contents info) + "Return body of document after converting it to Markdown syntax. + CONTENTS is the transcoded contents string. INFO is a plist + holding export options." + ;; Make sure CONTENTS is separated from table of contents and + ;; footnotes with at least a blank line. + (concat + ;; Table of contents. + ;; (let ((depth (plist-get info :with-toc))) + ;; (when depth + ;; (concat (org-md--build-toc info (and (wholenump depth) depth)) "\n"))) + ;; Document contents. + contents + "\n" + ;; Footnotes section. + (org-md--footnote-section info))) + +;;;; Plain text +(defun org-slack-plain-text (text info) + "Transcode a TEXT string into Markdown format. + TEXT is the string to transcode. INFO is a plist holding + contextual information." + ;; (when (plist-get info :with-smart-quotes) + ;; (setq text (org-export-activate-smart-quotes text :html info))) + ;; The below series of replacements in `text' is order sensitive. + ;; Protect `, *, _, and \ + ;; (setq text (replace-regexp-in-string "[`*_\\]" "\\\\\\&" text)) + ;; Protect ambiguous #. This will protect # at the beginning of + ;; a line, but not at the beginning of a paragraph. See + ;; `org-md-paragraph'. + (setq text (replace-regexp-in-string "\n#" "\n\\\\#" text)) + ;; Protect ambiguous ! + (setq text (replace-regexp-in-string "\\(!\\)\\[" "\\\\!" text nil nil 1)) + ;; ;; Handle special strings, if required. + ;; (when (plist-get info :with-special-strings) + ;; (setq text (org-html-convert-special-strings text))) + ;; Handle break preservation, if required. + (when (plist-get info :preserve-breaks) + (setq text (replace-regexp-in-string "[ \t]*\n" " \n" text))) + ;; Return value. + text) + +;;; End-user functions + +;;;###autoload +(defun org-slack-export-as-slack + (&optional async subtreep visible-only body-only ext-plist) + "Export current buffer to a text buffer. + + If narrowing is active in the current buffer, only export its + narrowed part. + + If a region is active, export that region. + + A non-nil optional argument ASYNC means the process should happen + asynchronously. The resulting buffer should be accessible + through the `org-export-stack' interface. + + When optional argument SUBTREEP is non-nil, export the sub-tree + at point, extracting information from the headline properties + first. + + When optional argument VISIBLE-ONLY is non-nil, don't export + contents of hidden elements. + + When optional argument BODY-ONLY is non-nil, strip title and + table of contents from output. + + EXT-PLIST, when provided, is a property list with external + parameters overriding Org default settings, but still inferior to + file-local settings. + + Export is done in a buffer named \"*Org SLACK Export*\", which + will be displayed when `org-export-show-temporary-export-buffer' + is non-nil." + (interactive) + (org-export-to-buffer 'slack "*Org SLACK Export*" + async subtreep visible-only body-only ext-plist (lambda () (text-mode)))) + +;;;###autoload +(defun org-slack-export-to-slack + (&optional async subtreep visible-only body-only ext-plist) + "Export current buffer to a text file. + + If narrowing is active in the current buffer, only export its + narrowed part. + + If a region is active, export that region. + + A non-nil optional argument ASYNC means the process should happen + asynchronously. The resulting file should be accessible through + the `org-export-stack' interface. + + When optional argument SUBTREEP is non-nil, export the sub-tree + at point, extracting information from the headline properties + first. + + When optional argument VISIBLE-ONLY is non-nil, don't export + contents of hidden elements. + + When optional argument BODY-ONLY is non-nil, strip title and + table of contents from output. + + EXT-PLIST, when provided, is a property list with external + parameters overriding Org default settings, but still inferior to + file-local settings. + + Return output file's name." + (interactive) + (let ((file (org-export-output-file-name ".txt" subtreep))) + (org-export-to-file 'slack file + async subtreep visible-only body-only ext-plist))) + +;;;###autoload +(defun org-slack-export-to-clipboard-as-slack () + "Export region to slack, and copy to the kill ring for pasting into other programs." + (interactive) + (let* ((org-export-with-toc nil) + (org-export-with-smart-quotes nil)) + (kill-new (org-export-as 'slack) )) + ) + +;; (org-export-register-backend 'slack) +(provide 'ox-slack) + +;; Local variables: +;; coding: utf-8 +;; End: + +;;; ox-slack.el ends here diff --git a/.config/doom/custom-packages/screenshot.el b/.config/doom/custom-packages/screenshot.el new file mode 100644 index 00000000..f16f0247 --- /dev/null +++ b/.config/doom/custom-packages/screenshot.el @@ -0,0 +1,460 @@ +;;; screenshot.el --- Swiftly grab images of your code -*- lexical-binding: t -*- + +;; Copyright (C) 2020 TEC + +;; Author: TEC +;; Maintainer: TEC +;; 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 . + +;;; 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 -- cgit v1.2.3