-
Notifications
You must be signed in to change notification settings - Fork 1
/
emit.el
226 lines (185 loc) · 8.63 KB
/
emit.el
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
;;; emit.el --- Tools for configuration -*- lexical-binding: t; -*-
;; Copyright (C) 2016-2023 Ivan Malison
;; Author: Ivan Malison <[email protected]>
;; Keywords: init utility general library macro
;; URL: https://github.com/IvanMalison/emit
;; Version: 0.0.0
;; Package-Requires: ((dash "2.10.0") (emacs "24") (cl-lib "0.5"))
;; 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 package provides functions that are generally useful for
;; configuring Emacs.
;;; Code:
(require 'dash)
(require 'cl-lib)
;; named-builder
(eval-and-compile
(defvar emit-named-builder-suffix "-fn"))
(defmacro emit-named-build (name builder &rest args)
"Alias NAME to the function produced by applying BUILDER to ARGS."
`(defalias (quote ,name) (,builder ,@args)))
(put 'emit-named-build 'lisp-indent-function 1)
(defmacro emit-build-named-builder (name builder-name)
"Create a macro NAME that invokes BUILDER-NAME with `emit-named-build'."
`(progn
(defmacro ,name (function-name &rest args)
(cons 'emit-named-build
(cons function-name
(cons (quote ,builder-name) args))))
(put (quote ,builder-name) 'lisp-indent-function 1)))
(defmacro emit-named-builder (name)
"Create a naming builder NAME from NAME with `emit-named-builder-suffix'."
`(emit-build-named-builder
,name ,(intern (concat (symbol-name name) emit-named-builder-suffix))))
;; compose
;; This implementation of compose may seem quite complicated, but it
;; has the advantage that it works with macros it performs quite well
;; because it results in only one additional stack frame.
(defun emit-help-function-arglist (fn)
(let ((result (help-function-arglist fn)))
(if (eq result t) '(&rest args) result)))
(defmacro emit-compose-fn (&rest funcs)
"Build a new lambda function that is the composition of FUNCS."
(let* ((last-function (car (last funcs)))
(arguments (emit-help-function-arglist last-function))
(call-arguments (remq '&optional arguments)))
;; When we have an &rest arguments there is no point in taking any
;; of the arguments by name, so we simply pass them all as an
;; argument list. See the comment below to understand how this
;; impacts the evaluation of the last function.
(when (memq '&rest arguments)
(setq arguments '(&rest args))
(setq call-arguments '(args)))
`(emit-compose-argspec ,arguments ,call-arguments ,@funcs)))
(defmacro emit-compose-argspec (arguments call-arguments &rest funcs)
"Build a lambda with CALL-ARGUMENTS passed as ARGUMENTS that composes FUNCS."
(let* ((interactive-form (when (and funcs (listp funcs))
(interactive-form (car (last funcs)))))
(function-names (mapcar 'symbol-name funcs))
(functions-string
(mapconcat (apply-partially 'format "`%s'") function-names ", ")))
`(lambda ,arguments
,(format "The composition of %s." functions-string)
,@(when interactive-form (list interactive-form))
(emit-compose-helper ,funcs ,call-arguments))))
(defmacro emit-compose-helper (funcs arguments)
(if (equal (length funcs) 1)
(let ((last-function (car funcs)))
;; This hideous clause is here because it is the only way to
;; handle functions that take &rest args.
(when (memq '&rest (emit-help-function-arglist last-function))
(setq last-function (apply-partially 'apply last-function)))
`(,last-function ,@arguments))
`(,(car funcs)
(emit-compose-helper ,(cdr funcs) ,arguments))))
(emit-named-builder emit-compose)
(put 'emit-compose 'lisp-indent-function 'defun)
;; prefix-selector
(defun emit-interpret-prefix-as-number (prefix)
(cond
((numberp prefix) prefix)
((and (-non-nil prefix) (listp prefix))
(truncate (log (car prefix) 4)))
(0)))
(defmacro emit-prefix-selector-fn (&rest functions)
"Build a lambda to dispatch to FUNCTIONS based on the prefix argument."
(let* ((selector-number 0)
(conditions
(cl-loop for fn in functions
collect `(,selector-number (quote ,fn))
do (cl-incf selector-number))))
`(lambda (arg)
,(format "Call one of %s depending the prefix argument.\nCall `%s' by default."
(mapconcat (lambda (fn-or-symbol)
(cond
((symbolp fn-or-symbol)
(format "`%s'" (symbol-name fn-or-symbol)))
((format "%s" fn-or-symbol))))
functions ", ") (car functions))
(interactive "P")
(setq arg (emit-interpret-prefix-as-number arg))
(let ((selection (pcase arg ,@conditions (_ (quote ,(car functions))))))
(setq current-prefix-arg nil)
(call-interactively selection)))))
(emit-named-builder emit-prefix-selector)
(put 'emit-prefix-selector 'lisp-indent-function 'defun)
;; let-around
(defmacro emit-let-around-fn (orig-func &rest forms)
"Build a lambda that will call ORIG-FUNC with the bindings in FORMS set."
(let* ((orig-interactive-form (interactive-form orig-func))
(docstring-form (format "Call `%s' with bindings: %s." orig-func forms))
(additional-forms (list docstring-form)))
`(lambda (&rest args)
,@additional-forms
,@(when orig-interactive-form (list orig-interactive-form))
(let ,forms
(apply (quote ,orig-func) args)))))
(emit-named-builder emit-let-around)
;; Minor mode utilities
(defmacro emit-variable-set-mode (set-mode-name variable value)
"Define a minor mode to set a global variable's value when enabled.
SET-MODE-NAME is the name of the mode.
VARIABLE is the global variable to be toggled.
VALUE is the value to be set when the mode is activated."
(let ((original-value
(make-symbol (concat (symbol-name set-mode-name) "-original-"
(symbol-name variable))))
(mode-value
(make-symbol (concat (symbol-name set-mode-name) "-value")))
(mode-enable
(make-symbol (concat (symbol-name set-mode-name) "-enable")))
(mode-disable
(make-symbol (concat (symbol-name set-mode-name) "-disable"))))
`(progn
(defvar ,original-value nil
,(concat "Storage for the original value of `" (symbol-name variable)
"' before `" (symbol-name set-mode-name) "' was activated."))
(defvar ,mode-value ,value
,(concat "The value to set `" (symbol-name variable)
"' to when `" (symbol-name set-mode-name) "' is active."))
(defun ,mode-enable ()
(unless ,original-value
(setq ,original-value ,variable))
(setq ,variable ,mode-value))
(defun ,mode-disable ()
(if (eq ,variable ,mode-value)
(setq ,variable ,original-value)
(message "Unexpected value for %s when disabling %s " ',variable ',set-mode-name))
(setq ,original-value nil))
(define-minor-mode ,set-mode-name
,(concat "A minor mode to toggle the value of `" (symbol-name variable) "'.")
:lighter (concat " " (symbol-name set-mode-name))
:global t
:init-value nil
(if ,set-mode-name
(,mode-enable)
(,mode-disable))))))
(defmacro emit-make-mode-dependent (dependent-mode trigger-mode)
"Make DEPENDENT-MODE activate or deactivate based on the state of TRIGGER-MODE."
(let ((sync-fn-name
(intern (concat "emit-sync-" (symbol-name dependent-mode) "-with-"
(symbol-name trigger-mode)))))
`(progn
(defun ,sync-fn-name ()
(if ,trigger-mode
(unless ,dependent-mode
(,dependent-mode 1))
(when ,dependent-mode
(,dependent-mode -1))))
;; Add the synchronization function to TRIGGER-MODE's hook.
(add-hook
(quote
,(intern (concat (symbol-name trigger-mode) "-hook"))) ',sync-fn-name)
;; Call the synchronization function once to align the modes right away.
(,sync-fn-name))))
(provide 'emit)
;;; emit.el ends here