-
-
Notifications
You must be signed in to change notification settings - Fork 8
/
doct.el
1286 lines (1071 loc) · 48.9 KB
/
doct.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
;;; doct.el --- DOCT: Declarative Org capture templates -*- lexical-binding: t; -*-
;; Copyright (C) 2019-2023 Nicholas Vollmer
;; Author: Nicholas Vollmer <[email protected]>
;; URL: https://github.com/progfolio/doct
;; Created: December 10, 2019
;; Keywords: org, convenience
;; Package-Requires: ((emacs "25.1"))
;; Version: 3.2.0
;; 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 <https://www.gnu.org/licenses/>.
;;; Commentary:
;; This package provides an alternative syntax for declaring Org capture
;; templates. See the doct docstring for more details.
;;; Code:
(eval-when-compile (require 'subr-x))
(require 'seq)
(require 'warnings)
;;; Custom Options
(defgroup doct nil
"DOCT: Declarative Org Capture Templates."
:group 'org
:prefix "doct-")
(defcustom doct-default-entry-type 'entry
"The default template entry type.
It can be overridden by using the :type keyword in a declaration."
:type '(choice (const :tag "Regular entry" entry)
(const :tag "plain list item" item)
(const :tag "checklist item" checkitem)
(const :tag "plain text" plain))
:group 'doct)
(defcustom doct-after-conversion-functions nil
"Abnormal hook run after converting declarations to templates.
Hook functions are run with the list of templates as their only argument.
The templates have not been flattened at this point and are of the form:
\(((parent) (child)...)...)."
:group 'doct
:type 'hook)
(defvar doct--warning-types '(unbound
template-keyword
template-keyword-type
template-entry-type
template-file
option-type)
"The allowed warning types.")
(defcustom doct-warnings t
"When non-nil, doct will issue warnings.
Valid values are:
- t
warn in all cases
- nil
do not warn
Or a list containing any of the following symbols:
- `unbound'
warn when a symbol is unbound during conversion
- `template-keyword'
warn when %{KEYWORD} is not found on the declaration during conversion
- `template-keyword-type'
warn when %{KEYWORD} expansion does not return a string.
- `template-entry-type'
warn when the expanded template does not match the capture template's type
- `template-file'
warn when the :template-file's file is not found during conversion
- `option-type'
warn when additional options are not the proper type
If the list's first element is the :not keyword, the warnings are disabled.
It can be overridden on a per-declaration basis with the :warn keyword."
:group 'doct
:type `(choice (const :tag "Enable all warnings" t)
(const :tag "Disable all warnings" nil)
(set :menu-tag "Enable Some"
,@(mapcar (lambda (x) `(const ,x))
doct--warning-types))
(list :tag "Disable Some" (const :not)
(set :inline t ,@(mapcar (lambda (x) `(const ,x))
doct--warning-types)))))
;;; Variables
;;necessary for byte-compiler warnings/pre runtime
(defvar org-directory)
(defvar org-capture-plist)
(defvar org-capture-current-plist)
(defvar org-capture-templates-contexts)
(defvar org-capture-mode-hook)
(defvar org-capture-before-finalize-hook)
(defvar org-capture-prepare-finalize-hook)
(defvar org-capture-after-finalize-hook)
(defvar doct-templates nil
"If non-nil, this is used as the return value of doct.
Use this variable to return an altered list from a function run during
`doct-after-conversion-functions'
Its value is not stored between invocations to doct.")
(defvar doct--current nil
"The current declaration being processed by doct. Used for error processing.")
(defvar doct--current-plist nil
"The plist of the current declaration being processed by doct.")
(defvar doct--expansion-syntax-regexp "\\(\\\\\\)?%{\\([^z-a]*?\\)}"
"The regular expression for matching keyword in %{KEYWORD} template strings.")
(defvar doct-entry-types '(entry item checkitem table-line plain)
"The allowed template entry types.")
(defvar doct-option-keywords '(:clock-in
:clock-keep
:clock-resume
:empty-lines
:empty-lines-after
:empty-lines-before
:immediate-finish
:jump-to-captured
:kill-buffer
:no-save
:prepend
:refile-targets
:table-line-pos
:time-prompt
:tree-type
:unnarrowed)
"Keywords that define a template's additional options.")
(defvar doct-file-extension-keywords '(:datetree :function :headline :olp :regexp)
"Keywords that define the insertion location in the target file.")
(defvar doct-exclusive-target-keywords '(:clock :file :function :id :here)
"Keywords that exclusively set the target location.")
(defvar doct-hook-keywords '(:after-finalize :before-finalize :hook :prepare-finalize)
"Keywords that attach hooks for the current template.")
(defvar doct-template-keywords '(:template :template-file)
"Keywords that define the template string.")
(defvar doct-context-keywords '(:in-buffer
:in-file
:in-mode
:unless-buffer
:unless-file
:unless-mode
:function
:when
:unless)
"Keywords that define a template's contexts.")
(defvar doct-recognized-keywords `(:children
:contexts
:custom
:disabled
:doct
:doct-name
:here
:inherited-keys
:keys
:type
:warn
,@(append
;;:function is in two categories
;;only need to add once
(remq :function
doct-file-extension-keywords)
doct-exclusive-target-keywords
doct-hook-keywords
doct-template-keywords
doct-option-keywords))
"List of the keywords doct recognizes.")
;;; Errors
;;doct-error is just parent error symbol.
;;Not intended to be directly signaled.
(define-error 'doct-error "DOCT peculiar error!")
(define-error 'doct-no-keys "Declaration has no :keys value" 'doct-error)
(define-error 'doct-group-keys "Group has :keys value" 'doct-error)
(define-error 'doct-no-target "Declaration has no target" 'doct-error)
(define-error 'doct-no-template "Declaration has no template" 'doct-error)
(define-error 'doct-wrong-type-argument "Wrong type argument" 'doct-error)
;;; Utility Functions
(defun doct--wrap-list (list)
"If LIST is not a list of lists, wrap it in a list."
(if (seq-every-p #'listp list) list `(,list)))
(defun doct--get (keyword)
"Return value for KEYWORD in `doct--current-plist'."
(plist-get doct--current-plist keyword))
(defun doct--first-in (keywords &optional plist)
"Find first non-nil occurrence of one of KEYWORDS in PLIST.
If PLIST is nil, `doct--current-plist' is used.
Return (KEYWORD VAL)."
(let ((target (or plist doct--current-plist)))
(seq-some (lambda (keyword)
(when-let ((val (plist-get target keyword)))
(when (member keyword keywords)
`(,keyword ,val))))
(seq-filter #'keywordp target))))
(defun doct--plist-p (list)
"Non-null if and only if LIST is a plist of form (KEYWORD VAL...)."
(while (consp list)
(setq list (if (and (keywordp (car list))
(consp (cdr list)))
(cddr list)
'not-plist)))
(null list))
(defun doct--list-of-strings-p (object)
"Return t if OBJECT is a list of strings."
(and (listp object) (seq-every-p #'stringp object)))
(defun doct--variable-p (object)
"Return t if OBJECT is a variable symbol."
(and (symbolp object)
(not (functionp object))
(not (keywordp object))
(not (booleanp object))))
(defun doct--unbound-variable-p (object)
"Return t if OBJECT is an unbound variable."
(and (doct--variable-p object)
(not (boundp object))))
(defun doct--suppressed-warnings ()
"Return list of suppressed warnings for current declaration."
(let* ((local (plist-member doct--current-plist :warn))
(warnings (if local
(cadr local)
doct-warnings)))
(pcase warnings
('t nil)
('nil '((doct)))
(`(:not . ,_)
(mapcar (lambda (warning)
`(doct ,warning))
(cdr warnings)))
((pred listp)
(delq nil (mapcar (lambda (warning)
(unless (member warning warnings)
`(doct ,warning)))
doct--warning-types))))))
(defun doct--warn (type message &rest args)
"Issue warning of TYPE (doct TYPE) with MESSAGE and ARGS passed to `lwarn'."
(apply #'lwarn `((doct ,type) :warning ,message ,@args)))
(defun doct--warn-symbol-maybe (object value &optional prefix)
"Warn for unbound OBJECT VALUE. If non-nil, PREFIX prefixes message."
(and
(doct--unbound-variable-p value)
(doct--warn 'unbound (concat prefix "%s %s unbound during conversion "
"in the %S declaration")
object value (car doct--current))))
(defun doct--type-check (object val predicates &optional current)
"Type check OBJECT's VAL.
PREDICATES is a list of predicate functions.
If non-nil, CURRENT is the declaration where an error has occurred.
It defaults to `doct--current'.
Returns VAL."
(unless (seq-some (lambda (predicate)
(funcall predicate val))
predicates)
(signal 'doct-wrong-type-argument `(,predicates (,object ,val)
,(or current doct--current))))
(doct--warn-symbol-maybe object val)
val)
;;;###autoload
(defun doct-get (keyword &optional local)
"Return KEYWORD's value from :doct plist on `org-capture-plist'.
If LOCAL is non-nil, query `org-capture-current-plist' instead.
:doct-custom KEYWORD takes precedence over KEYWORD on the declaration.
Intended to be used at runtime."
(let* ((declaration (plist-get
(if local org-capture-current-plist org-capture-plist) :doct))
(custom (plist-get declaration :doct-custom)))
(if-let ((member (plist-member custom keyword)))
(cadr member)
(plist-get declaration keyword))))
;;;###autoload
(defun doct-flatten-lists-in (list &optional acc)
"Flatten each list in LIST. Return recursive accumulator, ACC.
For example: \\='((1) ((2) (3) (4)) (((5)))) returns: \\='((1) (2) (3) (4) (5))."
(dolist (element (nreverse (copy-tree list)) acc)
(if (seq-every-p #'listp element)
(setq acc (doct-flatten-lists-in element acc))
(push element acc))))
;;; Acessors
;;;; Children
(defun doct--child-list-p (object)
"Return t when OBJECT is a list but not a function."
(and (listp object) (not (functionp object))))
(defun doct--children ()
"Type check and return declaration's :children."
(doct--type-check :children (doct--get :children) '(doct--child-list-p)))
;;;; Keys
(defun doct--keys (&optional group)
"Type check and return declaration's :keys.
If GROUP is non-nil, make sure there is no :keys value."
(let ((keys (plist-member doct--current-plist :keys))
(inherited (plist-member doct--current-plist :inherited-keys)))
(when (and group keys)
(signal 'doct-group-keys `(,doct--current)))
(unless (or group keys inherited) (signal 'doct-no-keys `(,doct--current)))
(let ((keys (cadr (or inherited keys))))
(unless (or (stringp keys) group)
(signal 'doct-wrong-type-argument `(stringp (:keys ,keys) ,doct--current)))
keys)))
;;;; Entry Type
(defun doct--entry-type ()
"Return declaration's :type or `doct-default-entry-type'."
(let ((type (or (doct--get :type) doct-default-entry-type)))
(or (car (member type doct-entry-types))
(signal 'doct-wrong-type-argument
`(,doct-entry-types (:type ,type) ,doct--current)))))
;;;; Target
(defun doct--target-file (value)
"Convert declaration's :file VALUE and extensions to capture template syntax."
(let ((first (doct--first-in doct-file-extension-keywords))
type target)
(pcase first
((or `(:olp ,_) `(:datetree ,_))
(let ((datetree (doct--get :datetree))
(olp (doct--get :olp)))
(when datetree (push :datetree type))
(push :olp type)
(when olp
(dolist (heading (reverse
(doct--type-check :olp olp '(doct--list-of-strings-p))))
(push heading target)))))
(`(:function ,fn)
(doct--type-check :function fn '(functionp doct--variable-p null))
(push fn target)
(push :function type))
(`(,(and (or :headline :regexp) keyword) ,extension)
(doct--type-check keyword extension '(stringp))
(push extension target)
(push keyword type)))
(push :file type)
(push (doct--type-check :file value '(stringp functionp doct--variable-p)) target)
`(,(intern (mapconcat (lambda (keyword)
(substring (symbol-name keyword) 1))
(delq nil type) "+"))
,@(delq nil target))))
(defun doct--target ()
"Convert declaration's target to template target."
(pcase (doct--first-in doct-exclusive-target-keywords)
('nil
(signal 'doct-no-target `(,doct-exclusive-target-keywords nil ,doct--current)))
(`(:clock ,_) '(clock))
(`(:here ,_) '(here))
(`(:id ,id) `(id ,(doct--type-check :id id '(stringp))))
(`(:function ,fn)
(if-let ((file (doct--get :file)))
(doct--target-file file)
`(function ,(doct--type-check :function fn '(functionp doct--variable-p null)))))
(`(:file ,file) (doct--target-file file))))
;;;; Template
(defmacro doct--map-keyword-syntax (string during &rest after)
"Eval DURING for STRING substrings matching `doct--expansion-syntax-regexp'.
Retrun AFTER form."
(declare (indent 1))
(let ((s (make-symbol "string")))
`(let ((,s ,string))
(with-temp-buffer
(insert ,s)
(goto-char (point-min))
(while (re-search-forward doct--expansion-syntax-regexp nil :no-error)
(if (match-string 1)
;;replace escaped \%{KEYORD} syntax and seek to next match
;;so outer loop doesn't repeat replacement.
(progn (replace-match "" nil t nil 1)
(re-search-forward doct--expansion-syntax-regexp nil :no-error))
,during))
,@after))))
(defun doct--replace-template-strings (string)
"Replace STRING's %{KEYWORD} occurrences with their :doct-custom values."
(doct--map-keyword-syntax string
(let* ((keyword (intern (concat ":" (match-string 2))))
(val (doct-get keyword)))
(unless (or (functionp val) (stringp val) (null val))
(doct--warn 'template-keyword-type
(concat
"%%{%s} wrong type: stringp %s in the %S declaration"
"\n Substituted for empty string.")
keyword val (doct-get :doct-name))
(setq val ""))
(replace-match (if (functionp val)
(save-excursion
(save-restriction
(save-match-data (funcall val))))
(or val ""))
nil t))
(buffer-string)))
(defun doct--expansion-syntax-p (string)
"Return t for STRING containing %{KEYWORD} syntax, else nil."
(and (string-match-p doct--expansion-syntax-regexp string) t))
(defun doct--fill-template (&optional value)
"Fill declaration's template VALUE at capture time."
(let* ((pair (doct--first-in doct-template-keywords
(plist-get org-capture-plist :doct)))
(keyword (car pair))
(value (or value
(if (eq keyword :template-file)
(with-temp-buffer
(insert-file-contents
(expand-file-name (cadr pair) org-directory))
(buffer-string))
(doct-get :template))))
(template (pcase value
((pred stringp) (if (doct--expansion-syntax-p value)
(doct--replace-template-strings
value)
value))
((pred functionp) (doct--fill-template (funcall value)))
((pred doct--list-of-strings-p)
(mapconcat (lambda (element)
(if (doct--expansion-syntax-p element)
(doct--fill-template element)
element))
value "\n")))))
(doct--type-check :template template '(stringp))))
(defun doct--warn-template-entry-type-maybe (string)
"Check template STRING against entry type."
(let ((trimmed (string-trim string)))
;;default templates are used when STRING is empty
(unless (or (string-empty-p trimmed)
;;arbitrary text can be inserted with these patterns
(string-match-p (concat "^" doct--expansion-syntax-regexp)
trimmed)
(string-prefix-p "%(" trimmed)
(string-prefix-p "%[" trimmed))
(pcase (doct--entry-type)
('entry
(unless (string-match-p "\\(?:^\\*+\\)" trimmed)
(doct--warn 'template-entry-type
(concat "expanded :template %S in the %S declaration "
"is not a valid Org entry.\n"
" Are you missing the leading '*'?")
string (car doct--current))))
('table-line
(unless (string-empty-p (with-temp-buffer
(insert string)
(goto-char (point-min))
(save-match-data
(flush-lines "\\(?:[[:space:]]*|\\)"))
(buffer-string)))
(doct--warn 'template-entry-type
(concat ":template %S in the %S declaration "
"is not a valid table-line.\n"
" Are you missing the leading pipe?")
string (car doct--current)))))))
string)
(defun doct--warn-template-maybe (&optional undeclared not-string)
"If UNDECLARED or NOT-STRING are non-nil, issue appropriate warning."
(let ((name (car doct--current)))
(dolist (symbol (nreverse undeclared))
(doct--warn 'template-keyword "%%{KEYWORD} %s undeclared in the %S declaration"
symbol name))
(dolist (symbol (nreverse not-string))
(doct--warn 'template-keyword-type
"%%{KEYWORD} %s did not evaluate to a string in the %S declaration"
symbol name))))
(defun doct--validate-template (strings)
"Check STRINGS to make sure it is a proper template."
(let (undeclared
not-string
template)
(catch 'deferred
(dolist (string strings)
(when (doct--expansion-syntax-p string)
(doct--map-keyword-syntax string
(let* ((keyword (intern (concat ":" (match-string 2))))
(custom (plist-get doct--current-plist :custom))
(member (or (plist-member custom keyword)
(plist-member doct--current-plist keyword)))
(value (cadr member)))
;;If the value is a function, we can't reliably validate during
;;conversion. It may rely on runtime context.
(when (functionp value) (throw 'deferred nil))
(unless (or member
;;doct implicitly adds these
(member keyword '(:inherited-keys :doct-name)))
(push (symbol-name keyword) undeclared))
(unless (or (stringp value) (null value))
(push (symbol-name keyword) not-string))
(replace-match (format "%s" (or value "")) nil t nil)
(setq string (buffer-string)))))
(push string template))
(doct--warn-template-entry-type-maybe (string-join (nreverse template) "\n"))
(doct--warn-template-maybe undeclared not-string))))
(defun doct--template ()
"Convert declaration's :template to Org capture template."
(pcase (doct--first-in doct-template-keywords)
(`(:template-file ,file)
(doct--type-check :template-file file '(stringp doct--variable-p))
(when (stringp file)
(unless (file-exists-p (expand-file-name file org-directory))
(doct--warn 'template-file
":template-file %S not found during conversion in the %S declaration"
file (car doct--current))))
'(function doct--fill-template))
(`(:template ,template)
;;simple values: string, list of strings with no expansion syntax
(pcase template
((and (pred stringp)
(guard (not (doct--expansion-syntax-p template))))
(doct--warn-template-entry-type-maybe template))
((and (pred doct--list-of-strings-p)
(guard (not (seq-some #'doct--expansion-syntax-p template))))
(doct--warn-template-entry-type-maybe (string-join template "\n")))
(deferred
(doct--type-check :template deferred
'(functionp stringp doct--list-of-strings-p doct--variable-p))
(unless (or (functionp deferred) (doct--variable-p deferred))
(doct--validate-template
(if (doct--list-of-strings-p deferred) deferred `(,deferred))))
'(function doct--fill-template))))))
;;;; Additional Options
(defun doct--validate-option (pair)
"Type check :KEY VALUE option PAIR declaration.
Returns PAIR."
(pcase pair
;;nil values allowed for overrides. org-capture will just use defaults.
(`(,(and (or :empty-lines :empty-lines-after :empty-lines-before) option) ,value)
(doct--type-check option value '(integerp null)))
(`(:table-line-pos ,value)
(doct--type-check :table-line-pos value '(stringp null)))
(`(:tree-type ,value)
;;only a warning because `org-capture-set-target-location'
;;has a default if any symbol other than week or month is set
(unless (member value '(week month nil))
(doct--warn 'option-type (concat ":tree-type %s in the %S declaration "
"should be set to week or month.\n"
" Any other values use the default datetree type.")
value (car doct--current)))))
pair)
(defun doct--additional-options ()
"Convert declaration's additional options to Org capture syntax."
(let (options)
(dolist (keyword doct-option-keywords options)
(when-let ((pair (plist-member doct--current-plist keyword)))
(setq options (apply #'plist-put
`(,options ,@(doct--validate-option
`(,(car pair) ,(cadr pair))))))))))
(defun doct--custom-properties ()
"Return a copy of declaration's :custom plist with unrecognized keywords added."
(let ((keywords (delete-dups (seq-filter #'keywordp doct--current-plist)))
(custom (copy-tree (doct--get :custom))))
(dolist (keyword keywords (doct--type-check :custom custom '(doct--plist-p)))
(unless (member keyword doct-recognized-keywords)
(setq custom (plist-put custom keyword (doct--get keyword)))))))
;;; External Variables
;;;;Hooks
(defun doct--run-hook (keyword)
"Run declaration's KEYWORD function."
;;:org-capture-current-plist not available when :hook and :after-finalize are run.
(when-let ((fn (doct-get keyword (not (member keyword '(:hook :after-finalize))))))
(funcall fn)))
(defun doct--restore-org-capture-plist ()
"Restore `org-capture-plist' for use in `org-capture-after-finalize-hook'.
Necessary since `org-capture-after-finalize-hook' cannot access
`org-capture-current-plist'."
(setq org-capture-plist org-capture-current-plist))
;;install hook functions
(with-eval-after-load 'org-capture
(dolist (keyword doct-hook-keywords)
(let* ((name (symbol-name keyword))
(short-name (substring name 1))
(fn-name (intern (concat "doct-run-" short-name)))
(hook-name (format "org-capture-%s-hook"
(if (equal short-name "hook") "mode" short-name))))
(fset fn-name (apply-partially #'doct--run-hook keyword))
(put fn-name 'function-documentation
(concat "Run the current declaration's " name " hook."
"\nREST is ignored and the function should not take any arguments."
"\nFor information on when this hook is run see `" hook-name "'."))
(add-hook (intern hook-name) fn-name)
(when (eq fn-name 'doct-run-before-finalize)
(advice-add fn-name :after #'doct--restore-org-capture-plist)))))
(defun doct-unload-function ()
"Called when doct is unloaded. Remove hooks."
(dolist (keyword doct-hook-keywords)
(let* ((name (substring (symbol-name keyword) 1))
(fn-name (intern (concat "doct-run-" name)))
(hook (intern (format "org-capture-%s-hook"
(if (equal name "hook") "mode" name)))))
(remove-hook hook fn-name))))
;;;; Contexts
(defun doct--convert-constraint-keyword (keyword)
"Convert KEYWORD to `org-capture-templates-contexts' equivalent symbol."
(let ((name (symbol-name keyword)))
(intern (if (string-prefix-p ":unless" name)
(replace-regexp-in-string "^:unless" "not-in" name)
(replace-regexp-in-string "^:" "" name)))))
(defmacro doct--constraint-function (constraint value)
"CONSTRAINT is a context keyword. VALUE is its value in the current rule."
(let* ((name (symbol-name constraint))
(test `(string-match val
,(cond
((string-suffix-p "buffer" name) '(buffer-name))
((string-suffix-p "file" name) '(or (buffer-file-name (buffer-base-buffer)) ""))
((string-suffix-p "mode" name) '(symbol-name major-mode)))))
(fn `(seq-some (lambda (val) ,test) ',value)))
(if (string-prefix-p ":unless" name)
`(lambda () (not ,fn))
`(lambda () ,fn))))
(defmacro doct--conditional-constraint (condition value)
"Return a lambda which wraps VALUE in the appropraite CONDITION form.
CONDITION is either when or unless."
`(lambda () (,condition ,(if (functionp value) `(,value) value) t)))
(defun doct--constraint-rule-list (constraint value)
"Create a rule list for declaration's CONSTRAINT with VALUE."
;;called outside of doct--type-check to add :contexts prefix
(doct--warn-symbol-maybe constraint value ":contexts ")
`(,(cond
((eq constraint :function)
(doct--type-check :function value '(functionp doct--variable-p)))
((or (eq constraint :when) (eq constraint :unless))
(eval `(doct--conditional-constraint
,(intern (substring (symbol-name constraint) 1))
,value)))
((stringp value)
`(,(doct--convert-constraint-keyword constraint) . ,value))
((doct--list-of-strings-p value)
(macroexpand `(doct--constraint-function ,constraint ,value)))
(t (signal 'doct-wrong-type-argument
`((stringp listp) (:contexts (,constraint ,value))
,doct--current))))))
(defun doct--add-contexts ()
"Add `org-capture-template-contexts' for current declaration."
(when-let ((contexts (doct--get :contexts)))
(let ((keys (doct--keys))
definitions)
;;allow a single, or list, of context definitions
(dolist (context (doct--wrap-list contexts))
(if-let ((first (doct--first-in doct-context-keywords context)))
(let* ((constraint (car first))
(value (cadr first))
(substitute (plist-get context :keys))
(rules (doct--constraint-rule-list constraint value))
(definition (delq nil `(,keys ,substitute ,rules))))
(push definition definitions))
(signal 'doct-wrong-type-argument `(,@doct-context-keywords nil ,doct--current))))
(dolist (definition (nreverse definitions))
(add-to-list 'org-capture-templates-contexts definition)))))
;;; Conversion
(defun doct--inherit (parent child)
"Inherit PARENT's plist members unless CHILD has already declared them.
The only exceptions to this are the :keys, :children and :group properties.
CHILD's keys are prefixed with PARENT's.
The :children and :group properties are ignored."
;;remove :group description
(when (stringp (car child))
(pop child))
(dolist (keyword (seq-filter (lambda (el)
(and (keywordp el)
(not (member el '(:children :group)))))
parent))
(if (member keyword '(:inherited-keys :keys))
(plist-put child :inherited-keys (concat
(or (plist-get parent :inherited-keys)
(plist-get parent :keys))
(plist-get child :keys)))
(unless (plist-member child keyword)
(plist-put child keyword (plist-get parent keyword)))))
child)
(defun doct--compose-entry (keys name parent)
"Return a template suitable for `org-capture-templates'.
The list is of the form: (KEYS NAME type target template additional-options...).
`doct--current-plist' provides the type, target template and additional options.
If PARENT is non-nil, list is of the form (KEYS NAME)."
`(,keys ,name
,@(unless parent
`(,(doct--entry-type)
,(doct--target)
,(doct--template)
,@(doct--additional-options)))
:doct ( :doct-name ,name
,@(cdr doct--current)
,@(when-let ((custom (doct--custom-properties)))
`(:doct-custom ,custom)))))
(defun doct--convert (name &rest properties)
"Convert declaration to a template named NAME with PROPERTIES.
For a full description of the PROPERTIES plist see `doct'."
(unless (eq (plist-get properties :disabled) t)
(let ((group (eq name :group)))
;;remove :group description
(when (and group (stringp (car properties)))
(setq properties (cdr properties)))
(setq doct--current `(,name ,@properties))
(setq doct--current-plist (doct--type-check 'properties properties '(doct--plist-p)))
(let ((warning-suppress-log-types (doct--suppressed-warnings)))
(doct--type-check 'name name `(stringp (lambda (_) ,group)))
(let ((children (doct--children))
(keys (doct--keys group))
entry)
(if children
(setq children (mapcar (lambda (child)
(apply #'doct--convert
`(,(car child)
,@(doct--inherit properties
(cdr child)))))
(doct--wrap-list children)))
(doct--add-contexts)
(dolist (keyword doct-hook-keywords)
(when-let ((val (cadr (plist-member doct--current-plist keyword))))
(doct--type-check keyword val '(functionp doct--variable-p null)))))
(unless group
(when children
;;restore these because processing children overwrites them
(setq doct--current `(,name ,@properties))
(setq doct--current-plist
(doct--type-check 'properties properties '(doct--plist-p))))
(setq entry (doct--compose-entry keys name children)))
(if children
(if group
`(,@children)
`(,entry ,@children))
entry))))))
(defun doct--convert-declaration-maybe (declaration)
"Attempt to convert DECLARATION to Org capture template syntax."
(condition-case-unless-debug err
(apply #'doct--convert declaration)
(doct-error (user-error "DOCT %s" (error-message-string err)))))
;;;###autoload
(defun doct (declarations)
"Convert DECLARATIONS to `org-capture-templates'.
DECLARATIONS may be a single declaration or a list of declarations.
Each declaration is either a child, parent, or group.
A child declaration must have:
- a name
- a :keys string
- a template type
- a target
- a template
and may also have:
- hook functions defined with the hook keywords
- contexts declared via the :contexts keyword
- additional KEY VAL arguments
A parent declaration must have:
- a name
- a :keys string
- a list of :children
and may also have additional properties inherited by its children.
A group is a special kind of parent declaration.
Its children inherit its properties.
It is not added to the template selection menu.
Its name must be the :group keyword.
It may optionally have a descriptive string for the value of :group.
It must not have a :keys value.
(doct \\='((\"Work\" :keys \"w\" :file \"~/org/work.org\" :children
((:group \"Clocked\" :clock-in t :children
((\"Call\" :keys \"p\" :template \"* Phone call with %?\")
(\"Meeting\" :keys \"m\" :template \"* Meeting with %?\")))
(\"Browsing\" :keys \"b\" :template \"* Browsing %x\")))))
Returns:
((\"w\" \"Work\")
(\"wp\" \"Call\" entry
(file \"~/org/work.org\") \"* Phone call with %?\" :clock-in t)
(\"wm\" \"Meeting\" entry
(file \"~/org/work.org\") \"* Meeting with %?\" :clock-in t)
(\"wb\" \"Browsing\" entry (file \"~/org/work.org\") \"* Browsing %x\"))
Inherited Properties
====================
A child inherits its ancestors' properties.
It may optionally override an inherited property by specifying that property
directly.
For example, considering:
(doct \\='((\"Grandparent\" :keys \"g\"
:file \"example.org\"
:children (\"Parent\" :keys \"p\"
:children (\"Child\" :keys \"c\")))))
The \"Child\" template inherits its :file property from the \"Grandparent\"
declaration.
The \"Parent\" declaration could override this value:
(doct \\='((\"Grandparent\" :keys \"g\"
:file \"example.org\"
:children (\"Parent\" :keys \"p\"
:file \"overridden.org\"
:children (\"Child\" :keys \"c\")))))
And the \"Child\" would have its :file property set to \"overridden.org\".
Name & Keys
===========
Every declaration must define a name.
Unless it is a group, it must also define a :keys value.
The name is the first value in the declaration.
The :keys keyword defines the keys to access the template from the capture menu.
(doct \\='((\"example\" :keys \"e\"...)))
returns:
((\"e\" \"example\"...))
Type
====
The :type keyword defines the template's entry type and accepts the following
symbols:
- entry
An Org node with a headline.
The template becomes a child of the target entry or a top level entry.
- item
A plain list item, placed in the first plain list at the target location.
- checkitem
A checkbox item.
Same as plain list item only it uses a different default template.
- table-line
A new line in the first table at target location.
- plain
Text inserted as is.
`doct-default-entry-type' defines the entry type when the :type keyword is not
provided.
For example, with `doct-default-entry-type' set to entry (the default):
(doct \\='((\"example\"
:keys \"e\"
:type entry
:file \"\")))
and:
(doct \\='((\"example\"
:keys \"e\"
:file \"\")))
both return:
((\"e\" \"example\" entry (file \"\") nil))
Target
======
The target defines the location of the inserted template text.
The first keyword declared in the following group exclusively sets the target.
The :file keyword is not necessary for these.
- :id \"id of existing Org entry\"
File as child of this entry, or in the body of the entry
(see `org-id-get-create')
- :clock t
File to the currently clocked entry
- :here t
The position of point when `org-capture' is called
- :function (lambda () ;visit file and move point to desired location...)
This keyword is exclusive when used without the :file keyword.
It is responsible for finding the proper file and location to insert the
capture item.
If :file defines a target file, then the function is only responsible for
moving point to the desired location within that file.
(doct \\='((\"example\"
:keys \"e\"
:type entry
:clock t
;;ignored because :clock is first
:function (lambda () (ignore))
;;also ignored
:id \"1\")))
returns:
((\"e\" \"example\" entry (clock) nil))
The :file keyword defines the target file for the capture template.
(doct ... :file \"/path/to/target.org\")
It may be:
- a string:
(doct ... :file \"/path/to/target.org\")
;;empty string defaults to `org-default-notes-file'
(doct ... :file \"\")
- a function:
;;lambda
(doct ... :file (lambda () (concat (read-string \"Capture Path: \") \".org\")))
;;or a function symbol
(doct ... :file my/get-file-path)
- or a variable:
(doct ... :file my/file-path)
The following keywords refine the target file location:
- :headline \"node headline\"
File under unique heading in target file.
- :olp (\"Level 1 heading\" \"Level 2 heading\"...)
Define the full outline in the target file.
- :datetree nil|t
Requires use of the :file keyword.
If :datetree has a non-nil value, create a date tree for today's date.
If :olp is given, the date tree is added under that heading path.
Use a non-nil :time-prompt property to prompt for a different date.
Set the :tree-type property to the symbol `week` to make a week tree
instead of the default month tree.
- :regexp \"regexp describing location\"
File to entry matching regexp in target file
- :function location-finding-function
If used in addition to the :file keyword, the value should be a function
that finds the desired location in that file.
If used as an exclusive keyword (see above), the function must locate
both the target file and move point to the desired location.