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
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
|
;;; srecode/insert.el --- Insert srecode templates to an output stream.
;; Copyright (C) 2005, 2007-2015 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; This file is part of GNU Emacs.
;; GNU Emacs 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.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;
;; Define and implements specific inserter objects.
;;
;; Manage the insertion process for a template.
;;
(eval-when-compile
(require 'cl)) ;; for `lexical-let'
(require 'srecode/compile)
(require 'srecode/find)
(require 'srecode/dictionary)
(require 'srecode/args)
(require 'srecode/filters)
(defvar srecode-template-inserter-point)
(declare-function srecode-overlaid-activate "srecode/fields")
(declare-function srecode-template-inserted-region "srecode/fields")
;;; Code:
(defcustom srecode-insert-ask-variable-method 'ask
"Determine how to ask for a dictionary value when inserting a template.
Only the ASK style inserter will query the user for a value.
Dictionary value references that ask begin with the ? character.
Possible values are:
'ask - Prompt in the minibuffer as the value is inserted.
'field - Use the dictionary macro name as the inserted value,
and place a field there. Matched fields change together.
NOTE: The field feature does not yet work with XEmacs."
:group 'srecode
:type '(choice (const :tag "Ask" ask)
(const :tag "Field" field)))
(defvar srecode-insert-with-fields-in-progress nil
"Non-nil means that we are actively inserting a template with fields.")
;;; INSERTION COMMANDS
;;
;; User level commands for inserting stuff.
(defvar srecode-insertion-start-context nil
"The context that was at point at the beginning of the template insertion.")
(defun srecode-insert-again ()
"Insert the previously inserted template (by name) again."
(interactive)
(let ((prev (car srecode-read-template-name-history)))
(if prev
(srecode-insert prev)
(call-interactively 'srecode-insert))))
;;;###autoload
(defun srecode-insert (template-name &rest dict-entries)
"Insert the template TEMPLATE-NAME into the current buffer at point.
DICT-ENTRIES are additional dictionary values to add."
(interactive (list (srecode-read-template-name "Template Name: ")))
(if (not (srecode-table))
(error "No template table found for mode %s" major-mode))
(let ((newdict (srecode-create-dictionary))
(temp (srecode-template-get-table (srecode-table) template-name))
(srecode-insertion-start-context (srecode-calculate-context))
)
(if (not temp)
(error "No Template named %s" template-name))
(while dict-entries
(srecode-dictionary-set-value newdict
(car dict-entries)
(car (cdr dict-entries)))
(setq dict-entries (cdr (cdr dict-entries))))
(srecode-insert-fcn temp newdict)
;; Don't put code here. We need to return the end-mark
;; for this insertion step.
))
(defun srecode-insert-fcn (template dictionary &optional stream skipresolver)
"Insert TEMPLATE using DICTIONARY into STREAM.
Optional SKIPRESOLVER means to avoid refreshing the tag list,
or resolving any template arguments. It is assumed the caller
has set everything up already."
;; Perform the insertion.
(let ((standard-output (or stream (current-buffer)))
(end-mark nil))
;; Merge any template entries into the input dictionary.
(when (slot-boundp template 'dictionary)
(srecode-dictionary-merge dictionary (oref template dictionary)))
(unless skipresolver
;; Make sure the semantic tags are up to date.
(semantic-fetch-tags)
;; Resolve the arguments
(srecode-resolve-arguments template dictionary))
;; Insert
(if (bufferp standard-output)
;; If there is a buffer, turn off various hooks. This will cause
;; the mod hooks to be buffered up during the insert, but
;; prevent tools like font-lock from fontifying mid-template.
;; Especially important during insertion of complex comments that
;; cause the new font-lock to comment-color stuff after the inserted
;; comment.
;;
;; I'm not sure about the motion hooks. It seems like a good
;; idea though.
;;
;; Borrowed these concepts out of font-lock.
;;
;; I tried `combine-after-change-calls', but it did not have
;; the effect I wanted.
(let ((start (point)))
(let ((inhibit-point-motion-hooks t)
(inhibit-modification-hooks t)
)
(srecode--insert-into-buffer template dictionary)
)
;; Now call those after change functions.
(run-hook-with-args 'after-change-functions
start (point) 0)
)
(srecode-insert-method template dictionary))
;; Handle specialization of the POINT inserter.
(when (and (bufferp standard-output)
(slot-boundp 'srecode-template-inserter-point 'point)
)
(set-buffer standard-output)
(setq end-mark (point-marker))
(goto-char (oref srecode-template-inserter-point point)))
(oset-default 'srecode-template-inserter-point point eieio-unbound)
;; Return the end-mark.
(or end-mark (point)))
)
(defun srecode--insert-into-buffer (template dictionary)
"Insert a TEMPLATE with DICTIONARY into a buffer.
Do not call this function yourself. Instead use:
`srecode-insert' - Inserts by name.
`srecode-insert-fcn' - Insert with objects.
This function handles the case from one of the above functions when
the template is inserted into a buffer. It looks
at `srecode-insert-ask-variable-method' to decide if unbound dictionary
entries ask questions or insert editable fields.
Buffer based features related to change hooks is handled one level up."
;; This line prevents the field archive from being let bound
;; while the field insert tool is loaded via autoloads during
;; the insert.
(when (eq srecode-insert-ask-variable-method 'field)
(require 'srecode/fields))
(let ((srecode-field-archive nil) ; Prevent field leaks during insert
(start (point)) ; Beginning of the region.
)
;; This sub-let scopes the 'in-progress' piece so we know
;; when to setup the end-template.
(let ((srecode-insert-with-fields-in-progress
(if (eq srecode-insert-ask-variable-method 'field) t nil))
)
(srecode-insert-method template dictionary)
)
;; If we are not in-progress, and we insert fields, then
;; create the end-template with fields editable area.
(when (and (not srecode-insert-with-fields-in-progress)
(eq srecode-insert-ask-variable-method 'field) ; Only if user asked
srecode-field-archive ; Only if there were fields created
)
(let ((reg
;; Create the field-driven editable area.
(srecode-template-inserted-region
"TEMPLATE" :start start :end (point))))
(srecode-overlaid-activate reg))
)
;; We return with 'point being the end of the template insertion
;; area. Return value is not important.
))
(declare-function data-debug-new-buffer "data-debug")
(declare-function data-debug-insert-stuff-list "data-debug")
(declare-function data-debug-insert-thing dictionary "data-debug")
(defun srecode-insert-show-error-report (dictionary format &rest args)
"Display an error report based on DICTIONARY, FORMAT and ARGS.
This is intended to diagnose problems with failed template
insertions."
(with-current-buffer (data-debug-new-buffer "*SRECODE INSERTION ERROR*")
(erase-buffer)
;; Insert the stack of templates that are currently being
;; inserted.
(insert (propertize "Template Stack" 'face '(:weight bold))
(propertize " (most recent at bottom)" 'face '(:slant italic))
":\n")
(data-debug-insert-stuff-list
(reverse (oref srecode-template active)) "> ")
;; Show the current dictionary.
(insert (propertize "Dictionary" 'face '(:weight bold)) "\n")
(data-debug-insert-thing dictionary "" "> ")
;; Show the error message.
(insert (propertize "Error" 'face '(:weight bold)) "\n")
(insert (apply #'format format args))
(pop-to-buffer (current-buffer))))
(defun srecode-insert-report-error (dictionary format &rest args)
;; TODO only display something when inside an interactive call?
(srecode-insert-show-error-report dictionary format args)
(apply #'error format args))
;;; TEMPLATE ARGUMENTS
;;
;; Some templates have arguments. Each argument is associated with
;; a function that can resolve the inputs needed.
(defun srecode-resolve-arguments (temp dict)
"Resolve all the arguments needed by the template TEMP.
Apply anything learned to the dictionary DICT."
(srecode-resolve-argument-list (oref temp args) dict temp))
(defun srecode-resolve-argument-list (args dict &optional temp)
"Resolve arguments in the argument list ARGS.
ARGS is a list of symbols, such as :blank, or :file.
Apply values to DICT.
Optional argument TEMP is the template that is getting its arguments resolved."
(let ((fcn nil))
(while args
(setq fcn (intern-soft (concat "srecode-semantic-handle-"
(symbol-name (car args)))))
(if (not fcn)
(error "Error resolving template argument %S" (car args)))
(if temp
(condition-case nil
;; Allow some to accept a 2nd argument optionally.
;; They throw an error if not available, so try again.
(funcall fcn dict temp)
(wrong-number-of-arguments (funcall fcn dict)))
(funcall fcn dict))
(setq args (cdr args)))
))
;;; INSERTION STACK & METHOD
;;
;; Code managing the top-level insert method and the current
;; insertion stack.
;;
(defmethod srecode-push ((st srecode-template))
"Push the srecoder template ST onto the active stack."
(oset st active (cons st (oref st active))))
(defmethod srecode-pop :STATIC ((st srecode-template))
"Pop the srecoder template ST onto the active stack.
ST can be a class, or an object."
(oset st active (cdr (oref st active))))
(defmethod srecode-peek :STATIC ((st srecode-template))
"Fetch the topmost active template record. ST can be a class."
(car (oref st active)))
(defmethod srecode-insert-method ((st srecode-template) dictionary)
"Insert the srecoder template ST."
;; Merge any template entries into the input dictionary.
;; This may happen twice since some templates arguments need
;; these dictionary values earlier, but these values always
;; need merging for template inserting in other templates.
(when (slot-boundp st 'dictionary)
(srecode-dictionary-merge dictionary (oref st dictionary)))
;; Do an insertion.
(unwind-protect
(let ((c (oref st code)))
(srecode-push st)
(srecode-insert-code-stream c dictionary))
;; Popping the stack is protected.
(srecode-pop st)))
(defun srecode-insert-code-stream (code dictionary)
"Insert the CODE from a template into `standard-output'.
Use DICTIONARY to resolve any macros."
(while code
(cond ((stringp (car code))
(princ (car code)))
(t
(srecode-insert-method (car code) dictionary)))
(setq code (cdr code))))
;;; INSERTERS
;;
;; Specific srecode inserters.
;; The base class is from srecode-compile.
;;
;; Each inserter handles various macro codes from the template.
;; The `code' slot specifies a character used to identify which
;; inserter is to be created.
;;
(defclass srecode-template-inserter-newline (srecode-template-inserter)
((key :initform "\n"
:allocation :class
:documentation
"The character code used to identify inserters of this style.")
(hard :initform nil
:initarg :hard
:documentation
"Is this a hard newline (always inserted) or optional?
Optional newlines don't insert themselves if they are on a blank line
by themselves.")
)
"Insert a newline, and possibly do indenting.
Specify the :indent argument to enable automatic indentation when newlines
occur in your template.")
(defmethod srecode-insert-method ((sti srecode-template-inserter-newline)
dictionary)
"Insert the STI inserter."
;; To be safe, indent the previous line since the template will
;; change what is there to indent
(let ((i (srecode-dictionary-lookup-name dictionary "INDENT"))
(inbuff (bufferp standard-output))
(doit t)
(pm (point-marker)))
(when (and inbuff (not (oref sti hard)))
;; If this is not a hard newline, we need do the calculation
;; and set "doit" to nil.
(beginning-of-line)
(save-restriction
(narrow-to-region (point) pm)
(when (looking-at "\\s-*$")
(setq doit nil)))
(goto-char pm)
)
;; Do indentation regardless of the newline.
(when (and (eq i t) inbuff)
(indent-according-to-mode)
(goto-char pm))
(when doit
(princ "\n")
;; Indent after the newline, particularly for numeric indents.
(cond ((and (eq i t) (bufferp standard-output))
;; WARNING - indent according to mode requires that standard-output
;; is a buffer!
;; @todo - how to indent in a string???
(setq pm (point-marker))
(indent-according-to-mode)
(goto-char pm))
((numberp i)
(princ (make-string i " ")))
((stringp i)
(princ i))))))
(defmethod srecode-dump ((ins srecode-template-inserter-newline) indent)
"Dump the state of the SRecode template inserter INS."
(call-next-method)
(when (oref ins hard)
(princ " : hard")
))
(defclass srecode-template-inserter-blank (srecode-template-inserter)
((key :initform "\r"
:allocation :class
:documentation
"The character representing this inserter style.
Can't be blank, or it might be used by regular variable insertion.")
(where :initform 'begin
:initarg :where
:documentation
"This should be 'begin or 'end, indicating where to insert a CR.
When set to 'begin, it will insert a CR if we are not at 'bol'.
When set to 'end it will insert a CR if we are not at 'eol'.")
;; @TODO - Add slot and control for the number of blank
;; lines before and after point.
)
"Insert a newline before and after a template, and possibly do indenting.
Specify the :blank argument to enable this inserter.")
(defmethod srecode-insert-method ((sti srecode-template-inserter-blank)
dictionary)
"Make sure there is no text before or after point."
(let ((i (srecode-dictionary-lookup-name dictionary "INDENT"))
(inbuff (bufferp standard-output))
(pm (point-marker)))
(when (and inbuff
;; Don't do this if we are not the active template.
(= (length (oref srecode-template active)) 1))
(when (and (eq i t) inbuff (not (eq (oref sti where) 'begin)))
(indent-according-to-mode)
(goto-char pm))
(cond ((and (eq (oref sti where) 'begin) (not (bolp)))
(princ "\n"))
((eq (oref sti where) 'end)
;; If there is whitespace after pnt, then clear it out.
(when (looking-at "\\s-*$")
(delete-region (point) (point-at-eol)))
(when (not (eolp))
(princ "\n")))
)
(setq pm (point-marker))
(when (and (eq i t) inbuff (not (eq (oref sti where) 'end)))
(indent-according-to-mode)
(goto-char pm))
)))
(defclass srecode-template-inserter-comment (srecode-template-inserter)
((key :initform ?!
:allocation :class
:documentation
"The character code used to identify inserters of this style.")
)
"Allow comments within template coding. This inserts nothing.")
(defmethod srecode-inserter-prin-example :STATIC ((ins srecode-template-inserter-comment)
escape-start escape-end)
"Insert an example using inserter INS.
Arguments ESCAPE-START and ESCAPE-END are the current escape sequences in use."
(princ " ")
(princ escape-start)
(princ "! Miscellaneous text commenting in your template. ")
(princ escape-end)
(terpri)
)
(defmethod srecode-insert-method ((sti srecode-template-inserter-comment)
dictionary)
"Don't insert anything for comment macros in STI."
nil)
(defclass srecode-template-inserter-variable (srecode-template-inserter)
((key :initform nil
:allocation :class
:documentation
"The character code used to identify inserters of this style."))
"Insert the value of a dictionary entry.
If there is no entry, insert nothing.")
(defvar srecode-inserter-variable-current-dictionary nil
"The active dictionary when calling a variable filter.")
(defmethod srecode-insert-variable-secondname-handler
((sti srecode-template-inserter-variable) dictionary value secondname)
"For VALUE handle SECONDNAME behaviors for this variable inserter.
Return the result as a string.
By default, treat as a function name.
If SECONDNAME is nil, return VALUE."
(if secondname
(let ((fcnpart (read secondname)))
(if (fboundp fcnpart)
(let ((srecode-inserter-variable-current-dictionary dictionary))
(funcall fcnpart value))
;; Else, warn.
(srecode-insert-report-error
dictionary
"Variable inserter %s: second argument `%s' is not a function"
(object-print sti) secondname)))
value))
(defmethod srecode-insert-method ((sti srecode-template-inserter-variable)
dictionary)
"Insert the STI inserter."
;; Convert the name into a name/fcn pair
(let* ((name (oref sti :object-name))
(fcnpart (oref sti :secondname))
(val (srecode-dictionary-lookup-name
dictionary name))
(do-princ t)
)
;; Alert if a macro wasn't found.
(when (not val)
(message "Warning: macro %S was not found in the dictionary." name)
(setq val ""))
;; If there was a functional part, call that function.
(cond ;; Strings
((stringp val)
(setq val (srecode-insert-variable-secondname-handler
sti dictionary val fcnpart)))
;; Compound data value
((srecode-dictionary-compound-value-child-p val)
;; Force FCN to be a symbol
(when fcnpart (setq fcnpart (read fcnpart)))
;; Convert compound value to a string with the fcn.
(setq val (srecode-compound-toString val fcnpart dictionary))
;; If the value returned is nil, then it may be a special
;; field inserter that requires us to set do-princ to nil.
(when (not val)
(setq do-princ nil)))
;; Dictionaries... not allowed in this style
((srecode-dictionary-child-p val)
(srecode-insert-report-error
dictionary
"Macro %s cannot insert a dictionary - use section macros instead"
name))
;; Other stuff... convert
(t
(srecode-insert-report-error
dictionary
"Macro %s cannot insert arbitrary data" name)))
;; Output the dumb thing unless the type of thing specifically
;; did the inserting for us.
(when do-princ
(princ val))))
(defclass srecode-template-inserter-ask (srecode-template-inserter-variable)
((key :initform ??
:allocation :class
:documentation
"The character code used to identify inserters of this style.")
(prompt :initarg :prompt
:initform nil
:documentation
"The prompt used to query for this dictionary value.")
(defaultfcn :initarg :defaultfcn
:initform nil
:documentation
"The function which can calculate a default value.")
(read-fcn :initarg :read-fcn
:initform 'read-string
:documentation
"The function used to read in the text for this prompt.")
)
"Insert the value of a dictionary entry.
If there is no entry, prompt the user for the value to use.
The prompt text used is derived from the previous PROMPT command in the
template file.")
(defmethod srecode-inserter-apply-state
((ins srecode-template-inserter-ask) STATE)
"For the template inserter INS, apply information from STATE.
Loop over the prompts to see if we have a match."
(let ((prompts (oref STATE prompts))
)
(while prompts
(when (string= (semantic-tag-name (car prompts))
(oref ins :object-name))
(oset ins :prompt
(semantic-tag-get-attribute (car prompts) :text))
(oset ins :defaultfcn
(semantic-tag-get-attribute (car prompts) :default))
(oset ins :read-fcn
(or (semantic-tag-get-attribute (car prompts) :read)
'read-string))
)
(setq prompts (cdr prompts)))
))
(defmethod srecode-insert-method ((sti srecode-template-inserter-ask)
dictionary)
"Insert the STI inserter."
(let ((val (srecode-dictionary-lookup-name
dictionary (oref sti :object-name))))
(if val
;; Does some extra work. Oh well.
(call-next-method)
;; How is our -ask value determined?
(if srecode-insert-with-fields-in-progress
;; Setup editable fields.
(setq val (srecode-insert-method-field sti dictionary))
;; Ask the question...
(setq val (srecode-insert-method-ask sti dictionary)))
;; After asking, save in the dictionary so that
;; the user can use the same name again later.
(srecode-dictionary-set-value
(srecode-root-dictionary dictionary)
(oref sti :object-name) val)
;; Now that this value is safely stowed in the dictionary,
;; we can do what regular inserters do.
(call-next-method))))
(defmethod srecode-insert-ask-default ((sti srecode-template-inserter-ask)
dictionary)
"Derive the default value for an askable inserter STI.
DICTIONARY is used to derive some values."
(let ((defaultfcn (oref sti :defaultfcn)))
(cond
((stringp defaultfcn)
defaultfcn)
((functionp defaultfcn)
(funcall defaultfcn))
((and (listp defaultfcn)
(eq (car defaultfcn) 'macro))
(srecode-dictionary-lookup-name
dictionary (cdr defaultfcn)))
((null defaultfcn)
"")
(t
(srecode-insert-report-error
dictionary
"Unknown default for prompt: %S" defaultfcn)))))
(defmethod srecode-insert-method-ask ((sti srecode-template-inserter-ask)
dictionary)
"Do the \"asking\" for the template inserter STI.
Use DICTIONARY to resolve values."
(let* ((prompt (oref sti prompt))
(default (srecode-insert-ask-default sti dictionary))
(reader (oref sti :read-fcn))
(val nil)
)
(cond ((eq reader 'y-or-n-p)
(if (y-or-n-p (or prompt
(format "%s? "
(oref sti :object-name))))
(setq val default)
(setq val "")))
((eq reader 'read-char)
(setq val (format
"%c"
(read-char (or prompt
(format "Char for %s: "
(oref sti :object-name))))))
)
(t
(save-excursion
(setq val (funcall reader
(or prompt
(format "Specify %s: "
(oref sti :object-name)))
default
)))))
;; Return our derived value.
val)
)
(defmethod srecode-insert-method-field ((sti srecode-template-inserter-ask)
dictionary)
"Create an editable field for the template inserter STI.
Use DICTIONARY to resolve values."
(let* ((default (srecode-insert-ask-default sti dictionary))
(compound-value
(srecode-field-value (oref sti :object-name)
:firstinserter sti
:defaultvalue default))
)
;; Return this special compound value as the thing to insert.
;; This special compound value will repeat our asked question
;; across multiple locations.
compound-value))
(defmethod srecode-dump ((ins srecode-template-inserter-ask) indent)
"Dump the state of the SRecode template inserter INS."
(call-next-method)
(princ " : \"")
(princ (oref ins prompt))
(princ "\"")
)
(defclass srecode-template-inserter-width (srecode-template-inserter-variable)
((key :initform ?|
:allocation :class
:documentation
"The character code used to identify inserters of this style.")
)
"Inserts the value of a dictionary variable with a specific width.
The second argument specifies the width, and a pad, separated by a colon.
Thus a specification of `10:left' will insert the value of A
to 10 characters, with spaces added to the left. Use `right' for adding
spaces to the right.")
(defmethod srecode-insert-variable-secondname-handler
((sti srecode-template-inserter-width) dictionary value width)
"For VALUE handle WIDTH behaviors for this variable inserter.
Return the result as a string.
By default, treat as a function name."
;; Cannot work without width.
(unless width
(srecode-insert-report-error
dictionary
"Width not specified for variable/width inserter"))
;; Trim or pad to new length
(let* ((split (split-string width ":"))
(width (string-to-number (nth 0 split)))
(second (nth 1 split))
(pad (cond
((or (null second) (string= "right" second))
'right)
((string= "left" second)
'left)
(t
(srecode-insert-report-error
dictionary
"Unknown pad type %s" second)))))
(if (>= (length value) width)
;; Simple case - too long.
(substring value 0 width)
;; We need to pad on one side or the other.
(let ((padchars (make-string (- width (length value)) ? )))
(if (eq pad 'left)
(concat padchars value)
(concat value padchars))))))
(defmethod srecode-inserter-prin-example :STATIC ((ins srecode-template-inserter-width)
escape-start escape-end)
"Insert an example using inserter INS.
Arguments ESCAPE-START and ESCAPE-END are the current escape sequences in use."
(princ " ")
(princ escape-start)
(princ "|A:10:right")
(princ escape-end)
(terpri)
)
(defvar srecode-template-inserter-point-override nil
"Point-positioning method for the SRecode template inserter.
When nil, perform normal point-positioning behavior.
When the value is a cons cell (DEPTH . FUNCTION), call FUNCTION
instead, unless the template nesting depth, measured
by (length (oref srecode-template active)), is greater than
DEPTH.")
(defclass srecode-template-inserter-point (srecode-template-inserter)
((key :initform ?^
:allocation :class
:documentation
"The character code used to identify inserters of this style.")
(point :type (or null marker)
:allocation :class
:documentation
"Record the value of (point) in this class slot.
It is the responsibility of the inserter algorithm to clear this
after a successful insertion."))
"Record the value of (point) when inserted.
The cursor is placed at the ^ macro after insertion.
Some inserter macros, such as `srecode-template-inserter-include-wrap'
will place text at the ^ macro from the included macro.")
(defmethod srecode-inserter-prin-example :STATIC ((ins srecode-template-inserter-point)
escape-start escape-end)
"Insert an example using inserter INS.
Arguments ESCAPE-START and ESCAPE-END are the current escape sequences in use."
(princ " ")
(princ escape-start)
(princ "^")
(princ escape-end)
(terpri)
)
(defmethod srecode-insert-method ((sti srecode-template-inserter-point)
dictionary)
"Insert the STI inserter.
Save point in the class allocated 'point' slot.
If `srecode-template-inserter-point-override' non-nil then this
generalized marker will do something else. See
`srecode-template-inserter-include-wrap' as an example."
;; If `srecode-template-inserter-point-override' is non-nil, its car
;; is the maximum template nesting depth for which the override is
;; valid. Compare this to the actual template nesting depth and
;; maybe use the override function which is stored in the cdr.
(if (and srecode-template-inserter-point-override
(<= (length (oref srecode-template active))
(car srecode-template-inserter-point-override)))
;; Disable the old override while we do this.
(let ((over (cdr srecode-template-inserter-point-override))
(srecode-template-inserter-point-override nil))
(funcall over dictionary))
(oset sti point (point-marker))
))
(defclass srecode-template-inserter-subtemplate (srecode-template-inserter)
()
"Wrap a section of a template under the control of a macro."
:abstract t)
(defmethod srecode-inserter-prin-example :STATIC ((ins srecode-template-inserter-subtemplate)
escape-start escape-end)
"Insert an example using inserter INS.
Arguments ESCAPE-START and ESCAPE-END are the current escape sequences in use."
(call-next-method)
(princ " Template Text to control")
(terpri)
(princ " ")
(princ escape-start)
(princ "/VARNAME")
(princ escape-end)
(terpri)
)
(defmethod srecode-insert-subtemplate ((sti srecode-template-inserter-subtemplate)
dict slot)
"Insert a subtemplate for the inserter STI with dictionary DICT."
;; Make sure that only dictionaries are used.
(unless (srecode-dictionary-child-p dict)
(srecode-insert-report-error
dict
"Only section dictionaries allowed for `%s'"
(eieio-object-name-string sti)))
;; Output the code from the sub-template.
(srecode-insert-method (slot-value sti slot) dict))
(defmethod srecode-insert-method-helper ((sti srecode-template-inserter-subtemplate)
dictionary slot)
"Do the work for inserting the STI inserter.
Loops over the embedded CODE which was saved here during compilation.
The template to insert is stored in SLOT."
(let ((dicts (srecode-dictionary-lookup-name
dictionary (oref sti :object-name))))
(when (not (listp dicts))
(srecode-insert-report-error
dictionary
"Cannot insert section %S from non-section variable."
(oref sti :object-name)))
;; If there is no section dictionary, then don't output anything
;; from this section.
(while dicts
(when (not (srecode-dictionary-p (car dicts)))
(srecode-insert-report-error
dictionary
"Cannot insert section %S from non-section variable."
(oref sti :object-name)))
(srecode-insert-subtemplate sti (car dicts) slot)
(setq dicts (cdr dicts)))))
(defmethod srecode-insert-method ((sti srecode-template-inserter-subtemplate)
dictionary)
"Insert the STI inserter.
Calls back to `srecode-insert-method-helper' for this class."
(srecode-insert-method-helper sti dictionary 'template))
(defclass srecode-template-inserter-section-start (srecode-template-inserter-subtemplate)
((key :initform ?#
:allocation :class
:documentation
"The character code used to identify inserters of this style.")
(template :initarg :template
:documentation
"A template used to frame the codes from this inserter.")
)
"Apply values from a sub-dictionary to a template section.
The dictionary saved at the named dictionary entry will be
applied to the text between the section start and the
`srecode-template-inserter-section-end' macro.")
(defmethod srecode-parse-input ((ins srecode-template-inserter-section-start)
tag input STATE)
"For the section inserter INS, parse INPUT.
Shorten input until the END token is found.
Return the remains of INPUT."
(let* ((out (srecode-compile-split-code tag input STATE
(oref ins :object-name))))
(oset ins template (srecode-template
(eieio-object-name-string ins)
:context nil
:args nil
:code (cdr out)))
(car out)))
(defmethod srecode-dump ((ins srecode-template-inserter-section-start) indent)
"Dump the state of the SRecode template inserter INS."
(call-next-method)
(princ "\n")
(srecode-dump-code-list (oref (oref ins template) code)
(concat indent " "))
)
(defclass srecode-template-inserter-section-end (srecode-template-inserter)
((key :initform ?/
:allocation :class
:documentation
"The character code used to identify inserters of this style.")
)
"All template segments between the section-start and section-end
are treated specially.")
(defmethod srecode-insert-method ((sti srecode-template-inserter-section-end)
dictionary)
"Insert the STI inserter."
)
(defmethod srecode-match-end ((ins srecode-template-inserter-section-end) name)
"For the template inserter INS, do I end a section called NAME?"
(string= name (oref ins :object-name)))
(defclass srecode-template-inserter-include (srecode-template-inserter-subtemplate)
((key :initform ?>
:allocation :class
:documentation
"The character code used to identify inserters of this style.")
(includedtemplate
:initarg :includedtemplate
:documentation
"The template included for this inserter."))
"Include a different template into this one.
The included template will have additional dictionary entries from the subdictionary
stored specified by this macro.")
(defmethod srecode-inserter-prin-example :STATIC ((ins srecode-template-inserter-include)
escape-start escape-end)
"Insert an example using inserter INS.
Arguments ESCAPE-START and ESCAPE-END are the current escape sequences in use."
(princ " ")
(princ escape-start)
(princ ">DICTNAME:contextname:templatename")
(princ escape-end)
(terpri)
)
(defmethod srecode-insert-include-lookup ((sti srecode-template-inserter-include)
dictionary)
"For the template inserter STI, lookup the template to include.
Finds the template with this macro function part and stores it in
this template instance."
(let ((templatenamepart (oref sti :secondname)))
;; If there was no template name, throw an error.
(unless templatenamepart
(srecode-insert-report-error
dictionary
"Include macro `%s' needs a template name"
(oref sti :object-name)))
;; NOTE: We used to cache the template and not look it up a second time,
;; but changes in the template tables can change which template is
;; eventually discovered, so now we always lookup that template.
;; Calculate and store the discovered template
(let ((tmpl (srecode-template-get-table (srecode-table)
templatenamepart))
(active (oref srecode-template active))
ctxt)
(when (not tmpl)
;; If it isn't just available, scan back through
;; the active template stack, searching for a matching
;; context.
(while (and (not tmpl) active)
(setq ctxt (oref (car active) context))
(setq tmpl (srecode-template-get-table (srecode-table)
templatenamepart
ctxt))
(when (not tmpl)
(when (slot-boundp (car active) 'table)
(let ((app (oref (oref (car active) table) application)))
(when app
(setq tmpl (srecode-template-get-table
(srecode-table)
templatenamepart
ctxt app)))
)))
(setq active (cdr active)))
(when (not tmpl)
;; If it wasn't in this context, look to see if it
;; defines its own context
(setq tmpl (srecode-template-get-table (srecode-table)
templatenamepart)))
)
;; Store the found template into this object for later use.
(oset sti :includedtemplate tmpl))
(unless (oref sti includedtemplate)
;; @todo - Call into a debugger to help find the template in question.
(srecode-insert-report-error
dictionary
"No template \"%s\" found for include macro `%s'"
templatenamepart (oref sti :object-name)))))
(defmethod srecode-insert-method ((sti srecode-template-inserter-include)
dictionary)
"Insert the STI inserter.
Finds the template with this macro function part, and inserts it
with the dictionaries found in the dictionary."
(srecode-insert-include-lookup sti dictionary)
;; Insert the template.
;; Our baseclass has a simple way to do this.
(if (srecode-dictionary-lookup-name dictionary (oref sti :object-name))
;; If we have a value, then call the next method
(srecode-insert-method-helper sti dictionary 'includedtemplate)
;; If we don't have a special dictionary, then just insert with the
;; current dictionary.
(srecode-insert-subtemplate sti dictionary 'includedtemplate))
)
;;
;; This template combines the include template and the sectional template.
;; It will first insert the included template, then insert the embedded
;; template wherever the $^$ in the included template was.
;;
;; Since it uses dual inheritance, it will magically get the end-matching
;; behavior of #, with the including feature of >.
;;
(defclass srecode-template-inserter-include-wrap (srecode-template-inserter-include srecode-template-inserter-section-start)
((key :initform ?<
:allocation :class
:documentation
"The character code used to identify inserters of this style.")
)
"Include a different template into this one, and add text at the ^ macro.
The included template will have additional dictionary entries from the subdictionary
stored specified by this macro. If the included macro includes a ^ macro,
then the text between this macro and the end macro will be inserted at
the ^ macro.")
(defmethod srecode-inserter-prin-example :STATIC ((ins srecode-template-inserter-include-wrap)
escape-start escape-end)
"Insert an example using inserter INS.
Arguments ESCAPE-START and ESCAPE-END are the current escape sequences in use."
(princ " ")
(princ escape-start)
(princ "<DICTNAME:contextname:templatename")
(princ escape-end)
(terpri)
(princ " Template Text to insert at ^ macro")
(terpri)
(princ " ")
(princ escape-start)
(princ "/DICTNAME")
(princ escape-end)
(terpri)
)
(defmethod srecode-insert-method ((sti srecode-template-inserter-include-wrap)
dictionary)
"Insert the template STI.
This will first insert the include part via inheritance, then
insert the section it wraps into the location in the included
template where a ^ inserter occurs."
;; Step 1: Look up the included inserter
(srecode-insert-include-lookup sti dictionary)
;; Step 2: Temporarily override the point inserter.
;; We bind `srecode-template-inserter-point-override' to a cons cell
;; (DEPTH . FUNCTION) that has the maximum template nesting depth,
;; for which the override is valid, in DEPTH and a lambda function
;; which implements the wrap insertion behavior in FUNCTION. The
;; maximum valid nesting depth is just the current depth + 1.
(let ((srecode-template-inserter-point-override
(lexical-let ((inserter1 sti))
(cons
;; DEPTH
(+ (length (oref srecode-template active)) 1)
;; FUNCTION
(lambda (dict)
(let ((srecode-template-inserter-point-override nil))
(if (srecode-dictionary-lookup-name
dict (oref inserter1 :object-name))
;; Insert our sectional part with looping.
(srecode-insert-method-helper
inserter1 dict 'template)
;; Insert our sectional part just once.
(srecode-insert-subtemplate
inserter1 dict 'template))))))))
;; Do a regular insertion for an include, but with our override in
;; place.
(call-next-method)))
(provide 'srecode/insert)
;; Local variables:
;; generated-autoload-file: "loaddefs.el"
;; generated-autoload-load-name: "srecode/insert"
;; End:
;;; srecode/insert.el ends here
|