forked from alhassy/org-special-block-extras
-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathorg-special-block-extras.el
2200 lines (1857 loc) · 96.9 KB
/
org-special-block-extras.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
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
;;; org-special-block-extras.el --- 30 new custom blocks & 34 link types for Org-mode -*- lexical-binding: t; -*-
;; Copyright (c) 2021 Musa Al-hassy
;; Author: Musa Al-hassy <[email protected]>
;; Version: 4.1.1
;; Package-Requires: ((s "1.13.1") (dash "2.18.1") (emacs "27.1") (org "9.1") (lf "1.0") (dad-joke "1.4") (seq "2.0") (lolcat "0"))
;; Keywords: org, blocks, colors, convenience
;; URL: https://alhassy.github.io/org-special-block-extras
;; 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 <https://www.gnu.org/licenses/>.
;;; Commentary:
;; This library provides common desirable features using the Org interface for
;; blocks and links:
;;
;; 0. A unified interface, the ‘defblock’ macro, for making new block and link types.
;;
;; 1. Colours: Regions of text and inline text can be coloured using 19 colours;
;; easily extendable; below is an example.
;;
;; #+begin_red org
;; /This/
;; *text*
;; _is_
;; red!
;; #+end_red
;;
;; 2. Multiple columns: Regions of text are exported into multiple side-by-side
;; columns
;;
;; 3. Remarks: First-class visible editor comments
;;
;; 4. Details: Regions of text can be folded away in HTML
;;
;; 5. Badges: SVG badges have the pleasant syntax
;; badge:key|value|colour|url|logo; only the first two are necessary.
;;
;; 6. Tooltips: Full access to Lisp documentation as tooltips, or any other
;; documentation-backend, including user-defined entries; e.g., doc:thread-first
;; retrives the documentation for thread-first and attachs it as a tooltip to
;; the text in the HTML export and as a glossary entry in the LaTeX export
;;
;; 7. Various other blocks: Solution, org-demo, spoiler (“fill in the blanks”).
;;
;; This file has been tangled from a literate, org-mode, file; and so contains
;; further examples demonstrating the special blocks it introduces.
;;
;; Full documentation can be found at
;; https://alhassy.github.io/org-special-block-extras
;;; Code:
;; String and list manipulation libraries
;; https://github.com/magnars/dash.el
;; https://github.com/magnars/s.el
(require 's) ;; “The long lost Emacs string manipulation library”
(require 'dash) ;; “A modern list library for Emacs”
(require 'subr-x) ;; Extra Lisp functions; e.g., ‘when-let’.
(require 'cl-lib) ;; New Common Lisp library; ‘cl-???’ forms.
(require 'cus-edit) ;; To get the custom-* faces
(require 'org)
(require 'ox-latex)
(require 'ox-html)
(require 'seq)
(require 'lf)
(defconst org-special-block-extras-version (package-get-version))
(defun org-special-block-extras-version ()
"Print the current version of the package in the minibuffer."
(interactive)
(message org-special-block-extras-version))
(defcustom org-special-block-add-html-extra t
"Whether to let `org-special-block-extras' to add content to the `ox-html' head tag.
The `org-special-block-extras' mode adds a lot of extra HTML/JS code that
1. [Bloat] may not be needed by everyone using this package,
2. [Security Threat] loads stuff from foreign websites.
Since the extra stuff is for beautiful tooltips or styles,
for ease of use, the default behaviour is to use such
“untrusted data from untrusted websites”.
To avoid such behaviour, set this variable to `nil'.")
;;;###autoload
(define-minor-mode org-special-block-extras-mode
"Provide 30 new custom blocks & 34 link types for Org-mode.
All relevant Lisp functions are prefixed ‘org-’; e.g., `org-docs-insert'.
This minor mode uses “untrusted data from untrusted websites” when exporting
to HTML, this is done for beautiful tooltips or styles.
Disable this behaviour by setting `org-special-block-add-html-extra' to `nil'.
"
:lighter " OSPE"
(if org-special-block-extras-mode
(progn
;; https://orgmode.org/manual/Advanced-Export-Configuration.html
(add-hook 'org-export-before-parsing-hook 'org--support-special-blocks-with-args)
(setq org-export-allow-bind-keywords t)
(defvar org--ospe-kbd-html-setup nil
"Has the necessary keyboard styling HTML beeen added?")
(unless org--ospe-kbd-html-setup
(setq org--ospe-kbd-html-setup t))
(when org-special-block-add-html-extra
(setq org-html-head-extra
(concat org-html-head-extra
"
<style>
/* From: https://endlessparentheses.com/public/css/endless.css */
/* See also: https://meta.superuser.com/questions/4788/css-for-the-new-kbd-style */
kbd
{
-moz-border-radius: 6px;
-moz-box-shadow: 0 1px 0 rgba(0,0,0,0.2),0 0 0 2px #fff inset;
-webkit-border-radius: 6px;
-webkit-box-shadow: 0 1px 0 rgba(0,0,0,0.2),0 0 0 2px #fff inset;
background-color: #f7f7f7;
border: 1px solid #ccc;
border-radius: 6px;
box-shadow: 0 1px 0 rgba(0,0,0,0.2),0 0 0 2px #fff inset;
color: #333;
display: inline-block;
font-family: 'Droid Sans Mono', monospace;
font-size: 80%;
font-weight: normal;
line-height: inherit;
margin: 0 .1em;
padding: .08em .4em;
text-shadow: 0 1px 0 #fff;
word-spacing: -4px;
box-shadow: 2px 2px 2px #222; /* MA: An extra I've added. */
}
</style>")))
;; Ensure user's documentation libraries have loaded
(unless org--docs-from-libraries
(org-docs-load-libraries))
(defvar org--tooltip-html-setup nil
"Has the necessary HTML beeen added?")
(unless org--tooltip-html-setup
(setq org--tooltip-html-setup t))
(when org-special-block-add-html-extra
(setq org-html-head-extra
(concat org-html-head-extra
"
<link rel=\"stylesheet\" type=\"text/css\" href=\"https://alhassy.github.io/org-special-block-extras/tooltipster/dist/css/tooltipster.bundle.min.css\"/>
<link rel=\"stylesheet\" type=\"text/css\" href=\"https://alhassy.github.io/org-special-block-extras/tooltipster/dist/css/plugins/tooltipster/sideTip/themes/tooltipster-sideTip-punk.min.css\" />
<script type=\"text/javascript\">
if (typeof jQuery == 'undefined') {
document.write(unescape('%3Cscript src=\"https://code.jquery.com/jquery-1.10.0.min.js\"%3E%3C/script%3E'));
}
</script>
<script type=\"text/javascript\" src=\"https://alhassy.github.io/org-special-block-extras/tooltipster/dist/js/tooltipster.bundle.min.js\"></script>
<script>
$(document).ready(function() {
$('.tooltip').tooltipster({
theme: 'tooltipster-punk',
contentAsHTML: true,
animation: 'grow',
delay: [100,500],
// trigger: 'click'
trigger: 'custom',
triggerOpen: {
mouseenter: true
},
triggerClose: {
originClick: true,
scroll: true
}
});
});
</script>
<style>
abbr {color: red;}
.tooltip { border-bottom: 1px dotted #000;
color:red;
text-decoration: none;}
</style>
")))
(defvar org--docs-empty! (list nil t)
"An indicator of when glossary entries should be erased.
We erase the glossary not on the first export, but on the second export.
The first export collects all citations, which are used in the second export.")
(setcdr (last org--docs-empty!) org--docs-empty!) ;; It's an infinite cyclic list.
;; Actual used glossary entries depends on the buffer; so clean up after each export
(advice-add #'org-export-dispatch
:after (lambda (&rest _)
(when (pop org--docs-empty!)
(setq org--docs-actually-used nil ;; The 𝒳 of each “doc:𝒳” that appears in the current buffer.
org--docs nil)))) ;; The “#+begin_documentation ⋯ :label 𝒳” of the current buffer.
) ;; Must be on a new line; I'm using noweb-refs
(remove-hook 'org-export-before-parsing-hook 'org--support-special-blocks-with-args)
)) ;; Must be on a new line; I'm using noweb-refs
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; We define a parent keymap that org-deflink keymaps inherit from.
;; We also define a few useful functions that we then bind to this parent map.
(defvar org-special-block-extras-mode-map (make-keymap)
"A keymap of actions, on link types, that is inherited by all `org-deflink' link keymaps.
To learn about keymap inheritance, run: C-h i m elisp RETURN m Inheritance and Keymaps RETURN.
This keymap has the following bindings setup:
(define-key org-special-block-extras-mode-map (kbd \"C-n\") #'org-this-link-next)
(define-key org-special-block-extras-mode-map (kbd \"C-p\") #'org-this-link-previous)
(define-key org-special-block-extras-mode-map (kbd \"C-h\") #'org-this-link-show-docs)
The use of `C-n' and `C-p' may be a nuisance to some users, since they override `forward-line'
and `previous-line' when the cursor is on an org-link type. As such, place something like the following
in your initialisation file.
;; Use C-c C-f to move to the next link of the same link-type as the one under the cursor
(define-key org-special-block-extras-mode-map (kbd \"C-c C-f\") #'org-this-link-next)
Alternatively, if you don't find much value in these basic bindings, you can remove them all:
;; Disable basic org-special-block-extras link keybindings
(setcdr org-special-block-extras-mode-map nil)
;; Or, remove a single binding
(define-key org-special-block-extras-mode-map (kbd \"C-n\") nil)")
(defvar org-special-block-extras-mode-map--link-keymap-docs nil
"An alist referencing key bindings for Org links; used in `org-this-link-show-docs'.")
(defun org-link-at-point ()
"Get the Org link type at point, with suffix colon."
(interactive)
(let ((working-line (line-number-at-pos)))
(save-excursion
;; Account for cursour being on anywhere on the links “name:key”.
(backward-word 2)
(unless (= working-line (line-number-at-pos))
(goto-line working-line))
(let* ((here-to-eol (buffer-substring-no-properties (point) (point-at-eol)))
;; E.g., “kbd:”, the name part of an Org link
(link-name (cl-second (s-match "\\([^ ]+:\\).+" here-to-eol))))
link-name))))
(defun org-this-link-next ()
"Go to the next Org link that is similar to the link at point."
(interactive)
(re-search-forward (org-link-at-point) nil t))
(defun org-this-link-previous ()
"Go to the previous Org link that is similar to the link at point."
(interactive)
(re-search-backward (org-link-at-point) nil t))
(defun org-this-link-show-docs ()
"Show documentation for the Org link at point in a read-only buffer.
Press ‘q’ to kill the resulting buffer and window."
(interactive)
(let* ((link (s-chop-suffix ":" (org-link-at-point)))
(msg (ignore-errors
(concat
(documentation (intern (format "org-link/%s" link)))
"\nKEY BINDINGS:\n"
"\nUnless indicated below otherwise..."
"\n\tC-h: Shows this helpful message buffer"
"\n\tC-n/C-p on the link to jump to next/previous links of this type;"
"\n\tC-c C-x C-n/p for moving between arbitrary link types.\n\n"
(pp-to-string
(cdr (assoc link org-special-block-extras-mode-map--link-keymap-docs))))))
;; i.e., insist on displaying in a dedicated buffer
(max-mini-window-height 0))
(display-message-or-buffer msg)
(switch-to-buffer-other-window "*Message*")
(rename-buffer (format "Help: Org Link “%s”" link))
(read-only-mode)
(local-set-key "q" #'kill-buffer-and-window)
(message "Read-only; “q” to kill buffer and window.")))
(define-key org-special-block-extras-mode-map (kbd "C-n") #'org-this-link-next)
(define-key org-special-block-extras-mode-map (kbd "C-p") #'org-this-link-previous)
(define-key org-special-block-extras-mode-map (kbd "C-h") #'org-this-link-show-docs)
(cl-defmacro org-deflink
(name &optional docstring display &rest body)
"Make a new Org-link NAME that exports using form BODY.
Since Org links are essentially string-valued functions,
a function ‘org-link/NAME’ is created.
DOCSTRING is optional; it is visible with
(documentation 'org-link/NAME)
BODY is a string-valued expression, that may make use of the names
o-label, o-description, o-backend. The final one refers to the export
backend, such as 'html or 'latex. The first two are obtained from uses:
[[name:o-label][o-description]]
In particular, the use case “name:o-label” means that o-description is nil.
---------------------------------------------------------------------------
Example use:
;; In a Lisp buffer, press “C-x C-e” to load this definition
(org-deflink shout (upcase (or o-description o-label)))
;; In an Org-buffer, press “C-c C-e h o” to see how this exports
<shout: hello world!>
;; Or using the bracket format
[[shout:][hello world!]]
[[shout: hello world!]]
;; or using the plain format
shout:hello_world
Here is a more complex, involved, example that makes use of
‘:let’ for local declarations. For instance, “define:hello”
renders as the word “hello” with a tooltip defining the word; the
definition is obtained from the command line tool ‘wn’.
(org-deflink define
\"Define the given word using WordNet, along with synonyms and coordinate terms.\"
[:let (definition (shell-command-to-string (format \"wn %s -over -synsn -coorn\" o-label)))
:help-echo definition]
(--> definition
(s-replace-regexp \"\\\\\\\"\" \"''\" it) ;; The presence of ‘\\\"’ in tooltips breaks things, so omit them.
(s-replace-regexp \"\\n\" \"<br>\" it)
(format \"<abbr class=\\\"tooltip\\\" title=\\\"%s\\\">%s</abbr>\" it o-label)))
For HTML tooltips, see `org-ospe-html-export-preserving-whitespace'.
More generally, org-special-block-extra's “doc” link type
supports, in order of precedence: User definitions, Emacs Lisp
documentation of functions & variables, and definitions of
English words. For example, “doc:existential_angst” for an entry
‘existential_angst’ whose associated documentation-glossary is
user-defined in a ‘#+documentation’ Org-block, or
“doc:thread-first” for the Emacs Lisp documentation of the
function `thread-first', or “doc:user-mail-address” for the Emacs
Lisp documentation of the variable `user-mail-address', or
“doc:hello” for the definition of the English word ‘hello’.
DISPLAY is a vector consisting of key-value pairs that affects how the link
is displayed in Emacs Org buffers. The keys are as follows.
+ :help-echo is a string-valued expression of the tooltip that should accompany
the new link in Org buffers. It has access to o-format being one of ‘plain’,
‘angle’, ‘bracket’ which indicates the format of the link, as shown above.
It also has access to o-label and o-description.
By default, the tooltip is the link name followed by the documentation
of the link, and, finally, the HTML export of the link.
That way, upon hover, users can visually see the link contents,
know what/how the link exports, and actually see the HTML export.
That is to say, for the ‘shout’ example aboce, the default display is essentially:
[:help-echo (org-link/shout o-label o-description 'html)]
You may want to add the following to your Emacs init file:
;; Nearly instantaneous display of tooltips.
(setq tooltip-delay 0)
;; Give user 30 seconds before tooltip automatically disappears.
(setq tooltip-hide-delay 300)
+ :face specifies how should these links be displayed within Emacs.
It is a list-valued expression.
As usual, it may make use of O-LABEL (but O-DESCRIPTION has value nil).
Example:
:face '(:underline \"green\")
See https://www.gnu.org/software/emacs/manual/html_node/elisp/Face-Attributes.html
+ [:display 'full] if you do not want bracket links to be
folded away in Org buffers; i.e., “[[X][Y]]” does not render as just “Y”.
+ :follow is a form that is executed when you click on such links; e.g., to open
another buffer, browser, or other action. It makes use of (an implicit argument) ‘o-label’.
Be aware that ‘o-label’ is a string that may contain spaces; e.g., when the action is to open
a URL in a browser.
If you are in need of providing similar, related, actions on a single link
then your :follow can condition on the current prefix argument via ‘o-prefix’
(which is essentially `current-prefix-arg').
For instance, a user presses “C-u RET” on your link to do one thing
but “C-u 72 RET” to do another action.
+ :keymap is an alternating list of keys and actions to be
performed when those keys are pressed while point is on the link.
For example:
[:keymap (C-h (message-box \"hola\"))]
By default, C-n and C-p are for moving to next and previous occruances of the same link type.
+ :let is a list of alternating variable symbol name and value, which are then used to form
a concrete `let*' clause. This is useful for introducing local variables for use in the DISPLAY
as well as in the CONTENTS. Such local declarations may make use of O-LABEL and O-DESCRIPTION, as usual."
(cl-destructuring-bind (docstring display body)
(lf-extract-optionals-from-rest docstring #'stringp
display #'vectorp
body)
(setq display (seq--into-list display))
(let ((org-link/NAME (intern (format "org-link/%s" name)))
(navigation "Press “C-h” to see possible actions on this link type.")
(lets (cl-loop for (variable value)
on (cl-getf display :let)
by #'cddr
collect (list variable value))))
`(progn
;; Declare the underlying function and documentation
(cl-defun ,org-link/NAME ;; function name
(o-label o-description o-backend) ;; function args
;; new function documentation
,docstring
;; function body
(let* ,lets ,@body))
;; Construct the Org-link
(org-link-set-parameters
,(format "%s" name)
:export (quote ,org-link/NAME)
;; How should these links be displayed?
;; (We augment the namespace with the missing o-description that local variables may be using.)
:face (lambda (o-label) (let (o-description) (let* ,lets ,(cl-getf display :face))))
;; When you click on such links, what should happen?
;; (We augment the namespace with the missing o-description that local variables may be using.)
:follow (lambda (o-label o-prefix) (let (o-description) (let* ,lets ,(cl-getf display :follow))))
;; These links should *never* be folded in descriptive display;
;; i.e., “[[example:lable][description]]” will always appear verbatim
;; and not hide the first pair […].
:display (cl-the symbol ,(cl-getf display :display)) ;; e.g.,: 'full
;; Any special keybindings when cursour is on this link type?
;; On ‘NAME:’ links, C-n/p to go to the next/previous such links.
:keymap (let ((o-keymap (copy-keymap org-mouse-map))
(pattern (format "%s:" (quote ,name))))
;; If this Org-link has additional key bindings, then save
;; them in an alist for reference in `org-this-link-show-docs'.
(when (quote ,(cl-getf display :keymap))
(push (cons (format "%s" (quote ,name)) (quote ,(cl-getf display :keymap)))
org-special-block-extras-mode-map--link-keymap-docs))
;; Let's inherit some possibly useful key bindings.
(set-keymap-parent o-keymap org-special-block-extras-mode-map)
;; Populate the keymap
(cl-loop for (key action) on (quote ,(cl-getf display :keymap))
by #'cddr
do (define-key o-keymap (kbd (format "%s" key))
`(lambda () (interactive) ,action)))
;; Return the keymap
o-keymap)
;; The tooltip alongside a link
:help-echo (lambda (window object position)
(save-excursion
(goto-char position)
(-let* (((&plist :path :format :contents-begin :contents-end)
(cadr (org-element-context)))
(org-format format)
(o-label path)
(o-description
(when (equal format 'bracket)
(copy-region-as-kill contents-begin contents-end)
(substring-no-properties (car kill-ring)))))
(or (let* ,lets ,(cl-getf display :help-echo))
(format "%s:%s\n\n%s\nHTML Export:\n\n%s"
(quote ,name)
(or o-description o-label)
,(concat (or docstring "") "\n\n" navigation "\n")
(,org-link/NAME o-label o-description 'html)))))))
;; Return value is the name of the underlying function.
;; We do this to be consistent with `defun'.
(quote ,org-link/NAME)))))
(org-deflink melpa
"Produce a Melpa badge for a given pacakge O-LABEL, which links to the Melpa page.
We try to get the package's version from a constant “⟨O-LABEL⟩-version” if it exists."
[:face '(:box "purple" :foreground "purple")]
(format (concat "<a href=\"https://melpa.org/#/%s\">"
"<img alt=\"MELPA\" src=\"https://img.shields.io/badge/%s-%s-green?logo=Gnu-Emacs\"></img>"
"</a>")
o-label
(s-replace "_" "__" (s-replace "-" "--" o-label)) ;; shields.io conventions
(or (ignore-errors (eval (intern (concat o-label "-version")))) "Melpa")))
(defvar org--supported-blocks nil
"Which special blocks, defined with DEFBLOCK, are supported.")
(cl-defmacro org-defblock
(name kwds &optional link-display docstring &rest body)
"Declare a new special block, and link, in the style of DEFUN.
A full featured example is at the end of this documentation string.
This is an anaphoric macro that provides export support for
special blocks *and* links named NAME. Just as an Org-mode
src-block consumes as main argument the language for the src
block, our special blocks too consume a MAIN-ARG; it may be a
symbol or a cons-list consisting of a symbolic name (with which
to refer to the main argument in the definition of the block)
followed by a default value, then, optionally, any information
for a one-time setup of the associated link type.
The main arg may be a sequence of symbols separated by spaces,
and a few punctuation with the exception of comma ‘,’ since it is
a special Lisp operator. In doubt, enclose the main arg in
quotes.
Then, just as Org-mode src blocks consume key-value pairs, our
special blocks consume a number of KWDS, which is a list of the
form (key₀ value₀ … keyₙ valueₙ).
After that is an optional DOCSTRING, a familar feature of DEFUN.
The docstring is displayed as part of the tooltip for the
produced link type.
Finally, the BODY is a (sequence of) Lisp forms ---no progn
needed--- that may refer to the names BACKEND and CONTENTS which
refer to the current export backend and the contents of the
special block ---or the description clause of a link.
CONTENTS refers to an Org-mode parsed string; i.e., Org-markup is
acknowledged.
In, hopefully, rare circumstances, one may refer to RAW-CONTENTS
to look at the fully unparsed contents.
Finally, this macro exposes two functions:
+ ORG-EXPORT: Wrap the argument in an export block for the current backend.
+ ORG-PARSE: This should ONLY be called within an ORG-EXPORT call,
to escape text to Org, and out of the export block.
⇄ We use “@@html:⋯:@@” when altering CONTENTS, but otherwise use raw HTML *around* CONTENTS.
⇄ For example: (format \"<div>%s</div>\" (s-replace \"#+columnbreak:\" \"@@html:<hr>@@\" contents))
----------------------------------------------------------------------
The relationship between links and special blocks:
[ [type:label][description]]
≈
#+begin_type label
description
#+end_type
----------------------------------------------------------------------
Example declaration, with all possible features shown:
;; We can use variable values when defining new blocks
(setq angry-red '(:foreground \"red\" :weight bold))
(org-defblock remark
(editor \"Editor Remark\" :face angry-red) (color \"red\" signoff \"\")
\"Top level (HTML & LaTeX) editorial remarks; in Emacs they're angry red.\"
(format (if (equal backend 'html)
\"<strong style=\\\"color: %s;\\\">⟦%s: %s%s⟧</strong>\"
\"{\\color{%s}\\bfseries %s: %s%s}\")
color editor contents signoff))
;; I don't want to change the definition, but I'd like to have
;; the following as personalised defaults for the “remark” block.
;; OR, I'd like to set this for links, which do not have argument options.
(defblock-header-args remark :main-arg \"Jasim Jameson\" :signoff \"( Aim for success! )\")
Three example uses:
;; ⟨0⟩ As a special blocks with arguments given.
#+begin_remark Bobbert Barakallah :signoff \"Thank-you for pointing this out!\" :color green
I was trying to explain that ${\large (n × (n + 1) \over 2}$ is always an integer.
#+end_remark
;; ⟨1⟩ As a terse link, using default values for the args.
;; Notice that Org-mode formatting is recoqgnised even in links.
[ [remark:Jasim Jameson][Why are you taking about “$\mathsf{even}$” here?]]
;; ⟨2⟩ So terse that no editor name is provided.
[ [remark:][Please improve your transition sentences.]]
;; ⟨★⟩ Unlike 0, examples 1 and 2 will have the default SIGNOFF
;; catenated as well as the default red color."
;; ⇨ The special block support
;;
(add-to-list 'org--supported-blocks name) ;; global var
;; TODO: Relocate
(defvar org--block--link-display nil
"Association list of block name symbols to link display vectors.")
;; Identify which of the optional features is present...
(cl-destructuring-bind (link-display docstring body)
(lf-extract-optionals-from-rest link-display #'vectorp
docstring #'stringp
body)
`(progn
(when ,(not (null link-display)) (push (cons (quote ,name) ,link-display) org--block--link-display))
(list
,(org--create-defmethod-of-defblock name docstring (plist-get kwds :backend) kwds body)
;; ⇨ The link type support
(eval (backquote (org-deflink ,name
,(vconcat `[:help-echo (format "%s:%s\n\n%s" (quote ,name) o-label ,docstring)] (or link-display (cdr (assoc name org--block--link-display))))
;; s-replace-all `((,(format "@@%s:" backend) . "") ("#+end_export" . "") (,(format "#+begin_export %s" backend) . ""))
(s-replace-regexp "@@" ""
(,(intern (format "org-block/%s" name)) o-backend (or o-description o-label) o-label :o-link? t)))))))))
;; WHERE ...
(cl-defmethod org--create-defmethod-of-defblock ((name symbol) docstring backend-type (kwds list) (body list))
"Helper method to produce an associated Lisp function for org-defblock.
+ NAME: The name of the block type.
+ DOCSTRING, string|null: Documentation of block.
+ KWDS: Keyword-value pairs
+ BODY: Code to be executed"
(cl-assert (or (stringp docstring) (null docstring)))
(cl-assert (or (symbolp backend-type) (null backend-type)))
(let ((main-arg-name (or (cl-first kwds) 'main-arg))
(main-arg-value (cl-second kwds))
(kwds (cddr kwds)))
;; Unless we've already set the docs for the generic function, don't re-declare it.
`(if ,(null body)
(cl-defgeneric ,(intern (format "org-block/%s" name)) (backend raw-contents &rest _)
,docstring)
(cl-defmethod ,(intern (format "org-block/%s" name))
((backend ,(if backend-type `(eql ,backend-type) t))
(raw-contents string)
&optional
,main-arg-name
&rest _
&key (o-link? nil) ,@(--reject (keywordp (car it)) (-partition 2 kwds))
&allow-other-keys)
,docstring
;; Use default for main argument
(when (and ',main-arg-name (s-blank-p ,main-arg-name))
(--if-let (plist-get (cdr (assoc ',name org--header-args)) :main-arg)
(setq ,main-arg-name it)
(setq ,main-arg-name ,main-arg-value)))
(cl-letf (((symbol-function 'org-export)
(lambda (x) "Wrap the given X in an export block for the current backend."
(if o-link? x (format "#+begin_export %s \n%s\n#+end_export" backend x))))
((symbol-function 'org-parse)
(lambda (x) "This should ONLY be called within an ORG-EXPORT call."
(if o-link? x (format "\n#+end_export\n%s\n#+begin_export %s\n" x backend)))))
;; Use any headers for this block type, if no local value is passed
,@(cl-loop for k in (mapcar #'car (-partition 2 kwds))
collect `(--when-let (plist-get (cdr (assoc ',name org--header-args))
,(intern (format ":%s" k)))
(when (s-blank-p ,k)
(setq ,k it))))
(org-export
(let ((contents (org-parse raw-contents))) ,@body)))))))
(defun org--pp-list (xs)
"Given XS as (x₁ x₂ … xₙ), yield the string “x₁ x₂ … xₙ”, no parens.
When n = 0, yield the empty string “”."
(s-chop-suffix ")" (s-chop-prefix "(" (format "%s" (or xs "")))))
(defvar org--current-backend nil
"A message-passing channel updated by
org--support-special-blocks-with-args
and used by DEFBLOCK.")
(defun org--support-special-blocks-with-args (backend)
"Remove all headlines in the current buffer.
BACKEND is the export back-end being used, as a symbol."
(setq org--current-backend backend)
(let (blk-start ;; The point at which the user's block begins.
header-start ;; The point at which the user's block header & args begin.
kwdargs ;; The actual key-value arguments for the header.
main-arg ;; The first (non-keyed) value to the block.
blk-column ;; The column at which the user's block begins.
body-start ;; The starting line of the user's block.
blk-contents ;; The actual body string.
;; ⟨blk-start/column⟩#+begin_⟨header-start⟩blk main-arg :key₀ val ₀ … :keyₙ valₙ ;; ⟵ ⟨kwdargs⟩
;; ⟨body-start⟩ body
;; #+end_blk
)
(cl-loop for blk in org--supported-blocks
do (goto-char (point-min))
(while (ignore-errors (re-search-forward (format "^\s*\\#\\+begin_%s" blk)))
;; MA: HACK: Instead of a space, it should be any non-whitespace, optionally;
;; otherwise it may accidentlly rewrite blocks with one being a prefix of the other!
(setq header-start (point))
;; Save indentation
(re-search-backward (format "\\#\\+begin_%s" blk))
(setq blk-start (point))
(setq blk-column (current-column))
;; actually process body
(goto-char header-start)
(setq body-start (1+ (line-end-position)))
(thread-last
(buffer-substring-no-properties header-start (line-end-position))
(format "(%s)")
read
(--split-with (not (keywordp it)))
(setq kwdargs))
(setq main-arg (org--pp-list (car kwdargs)))
(setq kwdargs (cadr kwdargs))
(forward-line -1)
(re-search-forward (format "^\s*\\#\\+end_%s" blk))
(setq blk-contents (buffer-substring-no-properties body-start (line-beginning-position)))
(kill-region blk-start (point))
(insert (eval `(,(intern (format "org-block/%s" blk))
(quote ,backend)
,blk-contents
,main-arg
,@(--map (list 'quote it) kwdargs))))
;; See: https://github.com/alhassy/org-special-block-extras/issues/8
;; (indent-region blk-start (point) blk-column) ;; Actually, this may be needed...
;; (indent-line-to blk-column) ;; #+end...
;; (goto-char blk-start) (indent-line-to blk-column) ;; #+begin...
;; the --map is so that arguments may be passed
;; as "this" or just ‘this’ (raw symbols)
))))
(defvar org--header-args nil
"Alist (name plist) where “:main-arg” is a special plist key.
It serves a similar role to that of Org's src ‘header-args’.
See doc of SET-BLOCK-HEADER-ARGS for more information.")
(defmacro org-set-block-header-args (blk &rest kvs)
"Set default valuts for special block arguments.
This is similar to, and inspired by, Org-src block header-args.
Example src use:
#+PROPERTY: header-args:Language :key value
Example block use:
(set-block-header-args Block :main-arg mainvalue :key value)
A full, working, example can be seen by “C-h o RET defblock”.
"
`(add-to-list 'org--header-args (list (quote ,blk) ,@kvs)))
;; This is our 𝒳, “remark”.
;; As a link, it should be shown angry-red;
;; it takes two arguments: “color” and “signoff”
;; with default values being "red" and "".
(org-defblock rremark
(editor "Editor Remark" color "red" signoff "")
[:face '(:foreground "red" :weight bold)]
; :please-preserve-new-lines
"Top level (HTML & LaTeX) editorial remarks; in Emacs they're angry red."
(format (if (equal backend 'html)
"<strong style=\"color: %s;\">⟦%s: %s%s⟧</strong>"
"{\\color{%s}\\bfseries %s: %s%s}")
color editor contents signoff))
;; I don't want to change the definition, but I'd like to have
;; the following as personalised defaults for the “remark” block.
;; OR, I'd like to set this for links, which do not have argument options.
(org-set-block-header-args rremark :main-arg "Jasim Jameson" :signoff "( Aim for success! )")
(cl-defmacro org--blockcall (blk &optional main-arg &rest keyword-args-then-contents)
"An anaologue to `funcall` but for blocks.
Usage: (blockcall blk-name main-arg even-many:key-values raw-contents)
One should rarely use this directly; instead use
o-thread-blockcall.
"
`(concat "#+end_export\n" (,(intern (format "org-block/%s" blk))
backend ;; defblock internal
; (format "\n#+begin_export html\n\n%s\n#+end_export\n" ,(car (last keyword-args-then-contents))) ;; contents
,@(last keyword-args-then-contents) ;; contents
,main-arg
,@(-drop-last 1 keyword-args-then-contents)) "\n#+begin_export"))
(defmacro org-thread-blockcall (body &rest forms)
"Thread text through a number of blocks.
BODY is likely to be ‘raw-contents’, possibly with user manipulations.
Each FORMS is of the shape “(block-name main-argument
:key-value-pairs)”
(thread-blockcall x) = x
(thread-blockcall x (f a)) = (blockcall f a x)
(thread-blockcall x f₁ f₂) ≈ (f₂ (f₁ x))
The third is a ‘≈’, and not ‘=’, because the RHS contains
‘blockcall’s as well as massages the export matter
between conseqeuctive blockcalls.
A full example:
(org-defblock nesting (name nil)
\"Show text in a box, within details, which contains a box.\"
(org-thread-blockcall raw-contents
(box name)
(details (upcase name) :title-color \"green\")
(box (format \"⇨ %s ⇦\" name) :background-color \"blue\")
))
"
(if (not forms) body
`(-let [result (org--blockcall ,@(car forms) ,body)]
,@(cl-loop for b in (cdr forms)
collect `(setq result (org--blockcall ,@b
(concat
"#+begin_export\n"
result
"\n#+end_export"
)))) result)))
(org-defblock solution
(title "Solution" reprimand "Did you actually try? Maybe see the ‘hints’ above!"
really "Solution, for real")
"Show the answers to a problem, but with a reprimand in case no attempt was made."
(org-thread-blockcall raw-contents
(details really :title-color "red")
(box reprimand :background-color "blue")
(details title)))
(org-defblock org-demo (nil nil source "Source" result "Result"
source-color "cyan" result-color "cyan"
style "parallel"
sep (if (equal backend 'html) "@@html:<p><br>@@" "\n\n\n\n")
)
"Output the CONTENTS of the block as both parsed Org and unparsed.
Label the source text by SOURCE and the result text by RESULT
finally, the source-result fragments can be shown in a STYLE
that is either “parallel” (default) or “sequential”.
SEP is the separator; e.g., a rule ‘<hr>'.
"
(-let [text (concat
;; Source
(thread-last raw-contents
(format (if (equal backend 'html)
"<div ><pre class=\"src src-org\">%s</pre></div>"
"\n\\begin{verbatim}\n%s\n\\end{verbatim}"))
org-export
(org--blockcall box source :background-color source-color)
org-export)
;; Separator
sep
;; Result
(thread-last raw-contents
(org--blockcall box result :background-color result-color)
org-export))]
(if (equal style "parallel")
(org--blockcall parallel "2" :bar nil text)
(concat "#+end_export\n" text "\n#+begin_export"))))
(org-defblock stutter (reps 2)
"Output the CONTENTS of the block REPS many times"
(-let [num (if (numberp reps) reps (string-to-number reps))]
(s-repeat num contents)))
(org-defblock rename (list "")
"Perform the given LIST of substitutions on the text.
The LIST is a comma separated list of ‘to’ separated symbols.
In a link, no quotes are needed."
(s-replace-all
(--map (cons (car it) (cadr it))
(--map (s-split " to " (s-trim it))
(s-split "," list)))
contents))
(org-defblock spoiler (color "grey" left "((" right "))")
"Hide text enclosed in double parens ((like this)) as if it were spoilers.
LEFT and RIGHT may be other kinds of delimiters.
The main argument, COLOR, indicates which color to use.
For LaTeX, this becomes “fill in the blanks”, with the answers
in the footnotes."
(if (equal backend 'latex)
(s-replace-regexp
(concat (regexp-quote left) "\\(.*?\\)" (regexp-quote right))
"@@latex:\\\\fbox{\\\\phantom{\\1}}\\\\footnote{\\1}@@"
contents)
(-let [id (gensym)]
(concat
;; In HTML, a ‘style’ can be, technically, almost anywhere...
(format
"<style> #%s {color: %s; background-color:%s;}
#%s:hover {color: black; background-color:white;} </style>
" id color color id)
(s-replace-regexp
(concat (regexp-quote left) "\\(.*?\\)" (regexp-quote right))
(format "@@html:<span id=\"%s\"> \\1 </span>@@" id)
contents)))))
(defun org--list-to-math (lst)
"Get a result LST from ORG-LIST-TO-LISP and render it as a proof tree."
(cond
((symbolp lst) "")
((symbolp (car lst)) (org--list-to-math (cadr lst)))
(t
(-let* (((conclusion₀ children) lst)
((name named?) (s-split " :: " conclusion₀))
(conclusion (or named? conclusion₀)))
(if (not children)
(if named? (format "\\frac{}{%s}[%s]" conclusion name) conclusion)
(format "\\frac{\\displaystyle %s}{%s}%s"
(s-join " \\qquad "
(mapcar #'org--list-to-math children))
conclusion
(if named? (format "[\\text{%s}]" name) "")))))))
(org-defblock tree (main-arg)
"Write a proof tree using Org-lists.
To get
premises₀ … premisesₙ
────────────────────────────[ reason ]
conclusion
You type
#+begin_tree
+ reason :: conclusion
- premises₀
- premises₁
⋮
- premisesₙ
#+end_tree
Where each premisesᵢ may, recursively, also have named reasons
and (indented) child premises of its own.
If there are multiple trees, they are shown one after the other.
The text in this block should be considered LaTeX;
as such, Org markup is not recognised.
A proof tree, derivation, is then just a deeply nested
itemisation. For instance, assuming P = Q(X), X = Y, Q(Y) = R,
the following proves P = R.
#+begin_tree
+ Trans :: P = R
- P = Q(X)
+ ✓
- Trans :: Q(X) = R
+ Trans :: Q(X) = Q(Y)
- Refl :: Q(X) = Q(X)
+ ✓
- Leibniz :: Q(X) = Q(Y)
+ X = Y
- ✓
+ Sym :: Q(Y) = R
- R = Q(Y)
- ✓
#+end_tree"
(s-join "" (--map (format "\\[%s\\]"
(org--list-to-math it))
(cdr (with-temp-buffer
(insert raw-contents)
(goto-char (point-min))
(org-list-to-lisp))))))
(defun osbe--block-fontifications ()
"Yields a cons list of block type and language pairs.
The intent is that the block types are fontified using the given language name."
(--map (cons (symbol-name it) "org") (-cons* 'tiny 'center 'quote org--supported-blocks)))
(defvar osbe--original-match-string (symbol-function 'match-string))