forked from polymode/polymode
-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathpolymode-core.el
1931 lines (1764 loc) · 79.6 KB
/
polymode-core.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
;; polymode-core.el --- Core initialization and utilities for polymode -*- lexical-binding: t -*-
;;
;; Copyright (C) 2013-2018, Vitalie Spinu
;; Author: Vitalie Spinu
;; URL: https://github.com/vspinu/polymode
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; 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, 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; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth
;; Floor, Boston, MA 02110-1301, USA.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Commentary:
;;
;;; Code:
(require 'gv)
(require 'font-lock)
(require 'color)
(require 'polymode-classes)
(require 'format-spec)
(eval-when-compile
(require 'cl-lib)
(require 'derived))
;;; ESSENTIAL DECLARATIONS
(defvar *span* nil)
(defvar-local pm/polymode nil)
(put 'pm/polymode 'permanent-local t)
(defvar-local pm/chunkmode nil)
(defvar-local pm/current nil) ;; fixme: unused
(defvar-local pm/type nil) ;; fixme: remove this
(defvar-local polymode-mode nil
"Non-nil if current \"mode\" is a polymode.")
(defvar pm--emacs>26 (version<= "26" emacs-version))
;; overwrites
(defvar-local pm--indent-region-function-original nil)
(defvar-local pm--fill-forward-paragraph-original nil)
(defvar-local pm--indent-line-function-original nil)
(defvar-local pm--syntax-propertize-function-original nil)
;; silence the compiler
(defvar pm--output-file nil)
(defvar pm--input-buffer nil)
(defvar pm--input-file nil)
(defvar pm--export-spec nil)
(defvar pm--input-not-real nil)
(defvar pm--output-not-real nil)
;; methods api from polymode-methods.el
(declare-function pm-initialize "polymode-methods")
(declare-function pm-get-buffer-of-mode "polymode-methods")
(declare-function pm-get-buffer-create "polymode-methods")
(declare-function pm-get-adjust-face "polymode-methods")
(declare-function pm-get-span "polymode-methods")
;; eieio silence "unknown slot"
;; http://emacs.1067599.n8.nabble.com/Fixing-quot-Unknown-slot-quot-warnings-td419119.html
(eval-when-compile
(defclass dummy ()
((function) (from-to))))
(defun pm-object-name (obj)
;; gives warnings on e25,26 but fine in e27
(with-no-warnings
(eieio-object-name-string obj)))
;; SHIELDS
(defvar pm-allow-after-change-hook t)
(defvar pm-allow-post-command-hook t)
(defun polymode-disable-post-command ()
(when polymode-mode
(setq pm-allow-post-command-hook nil)))
(defun polymode-enable-post-command ()
(when polymode-mode
(setq pm-allow-post-command-hook t)))
;; We need this during cascaded call-next-method in pm-initialize. -innermodes
;; are initialized after the hostmode setup has taken place. This means that
;; pm-get-span and all the functionality that relies on it will fail to work
;; correctly during the initialization in the call-next-method. This is
;; particularly relevant to font-lock setup and user hooks.
(defvar pm-initialization-in-progress nil)
;;; CUSTOM
;;;###autoload
(defvar-local polymode-default-inner-mode nil
"Inner mode for chunks with unspecified modes.
Intended to be used as local variable in polymode buffers. A
special value 'host means use the host mode.")
;;;###autoload
(put 'polymode-default-inner-mode 'safe-local-variable 'symbolp)
(defgroup polymode nil
"Object oriented framework for multiple modes based on indirect buffers"
:link '(emacs-commentary-link "polymode")
:group 'tools)
(defgroup poly-modes nil
"Polymode Configuration Objects"
:group 'polymode)
(defgroup poly-hostmodes nil
"Polymode Host Chunkmode Objects"
:group 'polymode)
(defgroup poly-innermodes nil
"Polymode Chunkmode Objects"
:group 'polymode)
(defcustom polymode-display-output-file t
"Whether to display woven and exported output buffers.
When non-nil automatically visit and call `display-buffer' on
output files from processor engines (e.g. weavers and exporters).
Can also be a function, in which case it is called with the
output file name as the only argument. If this function returns
non-nil, the file is visited and displayed with `display-buffer'.
See `display-buffer-alist' for how to customize the display."
:group 'polymode
:type '(choice (const t) (const nil) function))
(defcustom polymode-display-process-buffers t
"When non-nil, display weaving and exporting process buffers."
:group 'polymode
:type 'boolean)
(defcustom polymode-skip-processing-when-unmodified t
"If non-nil, consider modification times of input and output files.
Skip weaving or exporting process when output file is more recent
than the input file."
:group 'polymode
:type 'boolean)
(define-obsolete-variable-alias 'polymode-mode-name-override-alist 'polymode-mode-name-aliases "2018-08")
(define-obsolete-variable-alias 'polymode-mode-name-alias-alist 'polymode-mode-name-aliases "2019-04")
(defcustom polymode-mode-name-aliases
'((elisp . emacs-lisp)
(el . emacs-lisp)
(bash . sh-mode))
"An alist of inner mode overrides.
When inner mode is automatically detected from the header of the
inner chunk (such as in markdown mode), the detected symbol might
not correspond to the desired mode. This alist maps discovered
symbols into desired modes. For example
(add-to-list 'polymode-mode-name-aliases '(julia . ess-julia))
will cause installation of `ess-julia-mode' in markdown ```julia chunks."
:group 'polymode
:type 'alist)
(defvar polymode-mode-abbrev-aliases nil
"An alist of abbreviation mappings from mode names to their abbreviations.
Used to compute mode post-fixes in buffer names. Example:
(add-to-list 'polymode-mode-abbrevs-aliases '(\"ess-r\" . \"R\"))")
(defvar polymode-before-switch-buffer-hook nil
"Hook run just before switching to a different polymode buffer.
Each function is run with two arguments `old-buffer' and
`new-buffer'. This hook is commonly used to transfer state
between buffers. Hook is run before transfer of variables, modes
and overlays.")
(define-obsolete-variable-alias 'polymode-switch-buffer-hook 'polymode-after-switch-buffer-hook "v0.2")
(defvar polymode-after-switch-buffer-hook nil
"Hook run after switching to a different polymode buffer.
Each function is run with two arguments `old-buffer' and
`new-buffer'. This hook is commonly used to transfer state
between buffers. Slot :switch-buffer-functions in `pm-polymode'
and `pm-chunkmode' objects provides same functionality for
narrower scope.")
(defvar polymode-init-host-hook nil
"Hook run on initialization of every hostmode.
Ran in a base buffer from `pm-initialze'
methods. Slot :init-functions in `pm-polymode' objects provides
similar hook for more focused scope. See
`polymode-init-inner-hook' and :init-functions slot in
`pm-chunkmode' objects for similar hooks for inner chunkmodes.")
(defvar polymode-init-inner-hook nil
"Hook run on initialization of every `pm-chunkmode' object.
The hook is run in chunkmode's body buffer from `pm-initialze'
`pm-chunkmode' methods. Slot :init-functions `pm-chunkmode'
objects provides same functionality for narrower scope. See also
`polymode-init-host-hook'.")
;;; Mode Macros
(defun polymode--define-chunkmode (constructor name parent doc key-args)
(let* ((type (format "%smode"
(replace-regexp-in-string
"-.*$" "" (replace-regexp-in-string "^pm-" "" (symbol-name constructor)))))
(sname (symbol-name name))
(root-name (replace-regexp-in-string (format "poly-\\|-%s" type) "" sname)))
(when (keywordp parent)
(progn
(push doc key-args)
(push parent key-args)
(setq doc nil parent nil)))
(unless (stringp doc)
(when (keywordp doc)
(push doc key-args))
(setq doc (format "%s for %s chunks." (capitalize type) root-name)))
(unless (string-match-p (format "-%s$" type) sname)
(error "%s must end in '-%s'" (capitalize type) type))
(unless (symbolp parent)
;; fixme: check inheritance
(error "PARENT must be a name of an `%s'" type))
`(progn
(makunbound ',name)
(defvar ,name
,(if parent
`(pm--safe-clone ',constructor ,parent :name ,root-name ,@key-args)
`(,constructor :name ,root-name ,@key-args))
,doc))
;; `(progn
;; (defvar ,name)
;; (defcustom ,name nil
;; ,doc
;; :group ',(intern (format "poly-%ss" type))
;; :type 'object)
;; (setq ,name
;; ,(if parent
;; `(clone ,parent :name ,root-name ,@key-args)
;; `(,constructor :name ,root-name ,@key-args))))
))
;;;###autoload
(defmacro define-hostmode (name &optional parent doc &rest key-args)
"Define a hostmode with name NAME.
Optional PARENT is a name of a hostmode to be derived (cloned)
from. If missing, the optional documentation string DOC is
generated automatically. KEY-ARGS is a list of key-value pairs.
See the documentation of the class `pm-host-chunkmode' for
possible values."
(declare (doc-string 3))
(polymode--define-chunkmode 'pm-host-chunkmode name parent doc key-args))
;;;###autoload
(defmacro define-innermode (name &optional parent doc &rest key-args)
"Ddefine an innermode with name NAME.
Optional PARENT is a name of a innermode to be derived (cloned)
from. If missing the optional documentation string DOC is
generated automatically. KEY-ARGS is a list of key-value pairs.
See the documentation of the class `pm-inner-chunkmode' for
possible values."
(declare (doc-string 3))
(polymode--define-chunkmode 'pm-inner-chunkmode name parent doc key-args))
;;;###autoload
(defmacro define-auto-innermode (name &optional parent doc &rest key-args)
"Ddefine an auto innermode with name NAME.
Optional PARENT is a name of an auto innermode to be
derived (cloned) from. If missing the optional documentation
string DOC is generated automatically. KEY-ARGS is a list of
key-value pairs. See the documentation of the class
`pm-inner-auto-chunkmode' for possible values."
(declare (doc-string 3))
(polymode--define-chunkmode 'pm-inner-auto-chunkmode name parent doc key-args))
;;; MESSAGES
(defvar pm-extra-span-info nil)
(defun pm-format-span (&optional span prefixp)
(let* ((span (cond
((number-or-marker-p span) (pm-innermost-span span))
((null span) (pm-innermost-span))
(span)))
(message-log-max nil)
(beg (nth 1 span))
(end (nth 2 span))
(type (and span (or (car span) 'host)))
(oname (if span
(eieio-object-name (nth 3 span))
(current-buffer)))
(extra (if pm-extra-span-info
(format (if prefixp "%s " " (%s)") pm-extra-span-info)
"")))
(if prefixp
(format "%s[%s %s-%s %s]" extra type beg end oname)
(format "[%s %s-%s %s]%s" type beg end oname extra))))
;;; SPANS
(defsubst pm-base-buffer ()
"Return base buffer of current buffer, or the current buffer if it's direct."
(or (buffer-base-buffer (current-buffer))
(current-buffer)))
(defun pm-span-mode (&optional span)
"Retrieve the major mode associated with SPAN."
(pm--true-mode-symbol
(buffer-local-value 'major-mode (pm-span-buffer span))))
(defun pm-span-buffer (&optional span)
"Retrieve the buffer associated with SPAN."
(setq span (or span (pm-innermost-span)))
(let* ((chunkmode (nth 3 span))
(type (pm-true-span-type span)))
(if type
(pm-get-buffer-create chunkmode type)
;; ignore span's chunkmode as inner spans can request host span
(pm-get-buffer-create (oref pm/polymode -hostmode)))))
(defun pm-true-span-type (chunkmode &optional type)
"Retrieve the TYPE of buffer to be installed for CHUNKMODE.
`pm-innermost-span' returns a raw type (head, body or tail) but
the actual type installed depends on the values of :host-mode and
:tail-mode of the CHUNKMODE object. Always return nil if TYPE is
nil (aka a host span). CHUNKMODE could also be a span, in which
case TYPE is ignored."
;; fixme: this works on inner modes only. Fix naming.
(when (listp chunkmode)
;; a span
(setq type (car chunkmode)
chunkmode (nth 3 chunkmode)))
(when (object-of-class-p chunkmode 'pm-inner-chunkmode)
(unless (or (null type) (eq type 'host))
(with-slots (mode head-mode tail-mode fallback-mode) chunkmode
(cond ((eq type 'body)
(unless (or (eq mode 'host)
;; for efficiency don't check if modes are valid
(and (null mode)
(if polymode-default-inner-mode
(eq polymode-default-inner-mode 'host)
(eq fallback-mode 'host))))
'body))
((eq type 'head)
(cond ((eq head-mode 'host) nil)
((eq head-mode 'body) 'body)
(t 'head)))
((eq type 'tail)
(cond ((eq tail-mode 'host) nil)
((eq tail-mode 'body) 'body)
(t 'tail)))
(t (error "Type must be one of nil, 'host, 'head, 'tail or 'body")))))))
(defun pm-cache-span (span)
;; cache span
(unless pm-initialization-in-progress
(with-silent-modifications
;; (message "caching: %s %s" (car span) (pm-span-to-range span))
(let ((sbeg (nth 1 span))
(send (nth 2 span)))
(put-text-property sbeg send :pm-span span)
(put-text-property sbeg send :pm-mode (pm-span-mode span))))))
(defun pm-flush-span-cache (beg end &optional buffer)
(with-silent-modifications
(remove-list-of-text-properties beg end '(:pm-span) buffer)))
(defun pm--outspan-p (span thespan)
"Non-nil if SPAN outspans THESPAN.
Return non-nil if SPAN contains THESPAN's chunk (strictly from
the front)."
(let ((type (car thespan))
(beg (nth 1 thespan))
(end (nth 2 thespan))
(sbeg (nth 1 span))
(send (nth 2 span)))
;; The following check is to ensure that the outer span really
;; spans outside of the entire thespan's chunk (poly-markdown#6)
(and
(< sbeg beg)
(cond
((eq type 'body)
(and (let ((hspan (pm-get-span (nth 3 thespan) (1- beg))))
(< sbeg (nth 1 hspan)))
;; Ends might coincide due to eob
(if (< end send)
(let ((tspan (pm-get-span (nth 3 thespan) (1+ end))))
(<= (nth 2 tspan) send))
(= end send))))
((eq type 'tail)
(let ((bspan (pm-get-span (nth 3 thespan) (1- beg))))
(when (< sbeg (nth 1 bspan))
(let ((hspan (pm-get-span (nth 3 thespan) (1- (nth 1 bspan)))))
(< sbeg (nth 1 hspan))))))
;; Ends might coincide due to eob
((eq type 'head)
(if (< end send)
(let ((bspan (pm-get-span (nth 3 thespan) (1+ end))))
(if (< (nth 2 bspan) send)
(let ((tspan (pm-get-span (nth 3 thespan) (1+ (nth 2 bspan)))))
(<= (nth 2 tspan) send))
(= (nth 2 bspan) send)))
(= end send)))))))
(defun pm--intersect-spans (config &optional pos)
;; fixme: host should be last, to take advantage of the chunkmodes computation?
(let* ((start (point-min))
(end (point-max))
(pos (or pos (point)))
(hostmode (oref config -hostmode))
(chunkmodes (cons hostmode (oref config -innermodes)))
(thespan (list nil start end hostmode))
span)
(dolist (cm chunkmodes)
;; Optimization opportunity: this searches till the end of buffer but the
;; outermost pm-get-span caller has computed a few span already so we can
;; pass limits or narrow to pre-computed span.
(when (setq span (pm-get-span cm pos))
(let ((allow-nested (eieio-oref (nth 3 span) 'allow-nested))
(is-body (null (car span))))
(cond
;; 1. nil means host and it can be an intersection of spans returned
;; by two neighboring inner chunkmodes. When `allow-nested` is
;; 'always the innermode essentially behaves like the host-mode.
((or is-body
(eq allow-nested 'always))
;; when span is already an inner span, new host spans are irrelevant
(unless (car thespan)
(setq start (max (nth 1 span)
(nth 1 thespan))
end (min (nth 2 span)
(nth 2 thespan)))
(unless is-body
(setq thespan span))
(setcar (cdr thespan) start)
(setcar (cddr thespan) end)))
;; 2. Inner span
((or (> (nth 1 span) start)
(< (nth 2 span) end))
;; NB: no check if boundaries of two inner spans crossing; assume
;; correct matchers. In case of crossing, if 'can-nest is t then later
;; chunkmode wins otherwise the former one.
(when (or (null (car thespan))
(eieio-oref (nth 3 span) 'can-nest))
(setq thespan span
start (nth 1 span)
end (nth 2 span))))
;; 3. Outer span; overwrite previous span if nesting is not allowed.
;; This case is very hard because it can result in big invalid span
;; when a head occurs within a inner-chunk. For example $ for inline
;; latex can occur within R or python. The hard way to fix this would
;; require non-local information (e.g. checking if outer span's
;; extremities are within a host span) and still might not be the full
;; proof solution. Instead, make use of 'allow-nested property.
((and (eq allow-nested t)
(car thespan) ; span is an inner span
(not (eieio-oref (nth 3 thespan) 'can-nest))
(pm--outspan-p span thespan))
(setq thespan span
start (nth 1 span)
end (nth 2 span)))))))
(unless (and (<= start end) (<= pos end) (>= pos start))
(error "Bad polymode selection: span:%s pos:%s"
(list start end) pos))
(pm-cache-span thespan)
thespan))
(defun pm--chop-span (span beg end)
;; destructive!
(when (> beg (nth 1 span))
(setcar (cdr span) beg))
(when (< end (nth 2 span))
(setcar (cddr span) end))
span)
(defun pm--innermost-span (config &optional pos)
(let ((pos (or pos (point)))
(omin (point-min))
(omax (point-max))
;; `re-search-forward' and other search functions trigger full
;; `internal--syntax-propertize' on the whole buffer on every
;; single buffer modification. This is a small price to pay for a
;; much improved efficiency in modes which heavily rely on
;; `syntax-propertize' like `markdown-mode'.
(parse-sexp-lookup-properties nil)
(case-fold-search t))
(save-excursion
(save-restriction
(widen)
(let ((span (pm--intersect-spans config pos)))
(if (= omax pos)
(when (and (= omax (nth 1 span))
(> omax omin))
;; When pos == point-max and it's beg of span, return the
;; previous span. This occurs because the computation of
;; pm--intersect-spans is done on a widened buffer.
(setq span (pm--intersect-spans config (1- pos))))
(when (= pos (nth 2 span))
(error "Span ends at %d in (pm--inermost-span %d) %s"
pos pos (pm-format-span span))))
(pm--chop-span span omin omax))))))
(defun pm--cached-span (&optional pos)
;; fixme: add basic miss statistics
(unless pm-initialization-in-progress
(let* ((omin (point-min))
(omax (point-max))
(pos (or pos (point)))
(pos (if (= pos omax)
(max (point-min) (1- pos))
pos))
(span (get-text-property pos :pm-span)))
(when span
(save-restriction
(widen)
(let* ((beg (nth 1 span))
(end (1- (nth 2 span))))
(when (and (< end (point-max)) ; buffer size might have changed
(<= pos end)
(<= beg pos)
(eq span (get-text-property beg :pm-span))
(eq span (get-text-property end :pm-span))
(not (eq span (get-text-property (1+ end) :pm-span)))
(or (= beg (point-min))
(not (eq span (get-text-property (1- beg) :pm-span)))))
(pm--chop-span (copy-sequence span) omin omax))))))))
(define-obsolete-function-alias 'pm-get-innermost-span 'pm-innermost-span "2018-08")
(defun pm-innermost-span (&optional pos no-cache)
"Get span object at POS.
If NO-CACHE is non-nil, don't use cache and force re-computation
of the span. Return a cons (type start end chunkmode). POS
defaults to point. Guarantied to return a non-empty span."
(when (and pos (or (< pos (point-min)) (> pos (point-max))))
(signal 'args-out-of-range
(list :pos pos
:point-min (point-min)
:point-max (point-max))))
(save-match-data
(or (unless no-cache
(pm--cached-span pos))
(pm--innermost-span pm/polymode pos))))
(defun pm-span-to-range (span)
(and span (cons (nth 1 span) (nth 2 span))))
(define-obsolete-function-alias 'pm-get-innermost-range 'pm-innermost-range "2018-08")
(defun pm-innermost-range (&optional pos no-cache)
(pm-span-to-range (pm-innermost-span pos no-cache)))
(defun pm-fun-matcher (matcher)
"Make a function matcher given a MATCHER.
MATCHER is one of the forms accepted by \=`pm-inner-chunkmode''s
:head-matcher slot."
(cond
((stringp matcher)
(lambda (ahead)
(if (< ahead 0)
(if (re-search-backward matcher nil t)
(cons (match-beginning 0) (match-end 0)))
(if (re-search-forward matcher nil t)
(cons (match-beginning 0) (match-end 0))))))
((functionp matcher)
matcher)
((consp matcher)
(lambda (ahead)
(when (re-search-forward (car matcher) nil t ahead)
(cons (match-beginning (cdr matcher))
(match-end (cdr matcher))))))
(t (error "Head and tail matchers must be either regexp strings, cons cells or functions"))))
(defun pm-same-indent-tail-matcher (_arg)
"Get the end position of block with the higher indent than the current column.
Used as tail matcher for blocks identified by same indent. See
function `poly-slim-mode' for examples. ARG is ignored; always search
forward."
;; we are at the head end; so either use head indent or this code indent
(let* ((cur-indent (current-indentation))
(cur-col (current-column))
(block-col (if (< cur-indent cur-col)
cur-indent
(1- cur-indent)))
(end (point-at-eol)))
(forward-line 1)
(while (and (not (eobp))
(or (looking-at-p "[ \t]*$")
(and (> (current-indentation) block-col)
(setq end (point-at-eol)))))
(forward-line 1))
;; end at bol for the sake of indentation
(setq end (min (point-max) (1+ end)))
(cons end end)))
(defun pm--get-property-nearby (property accessor ahead)
(let ((ahead (> ahead 0)))
(let* ((pos (if ahead
(if (get-text-property (point) property)
(point)
(next-single-property-change (point) property))
(previous-single-property-change (point) property)))
(val (when pos
(or (get-text-property pos property)
(and (setq pos (previous-single-property-change pos property nil (point-min)))
(get-text-property pos property))))))
(when val
(if accessor
(let ((val (save-excursion
(goto-char pos)
(funcall accessor val))))
(cond
((numberp val) (cons val val))
((consp val) (cons (car val) (if (listp (cdr val))
(cadr val)
(cdr val))))
(t (cons pos (next-single-property-change pos property nil (point-max))))))
(cons pos (next-single-property-change pos property nil (point-max))))))))
(defun pm-make-text-property-matcher (property &optional accessor)
"Return a head or tail matcher for PROPERTY with ACCESSOR.
ACCESSOR is either a function or a keyword. When a function it is
applied to the PROPERTY's value to retrieve the position of the
head in the buffer. It should return either a number in which
case head has 0 length, a cons of the form (BEG . END), or a
list (BEG END). ACCESSOR is called at the beginning of the
PROPERTY region. When ACCESSOR is nil the head span is the region
covered by the same value of PROPERTY. When ACCESSOR is a keyword
the property is searched as when ACCESSOR is nil but is adapted
according to the keyword. Currently :inc-end means increment the
END of the span, when :dec-beg, decrement the beginning of the
span."
(lambda (ahead)
(if (keywordp accessor)
(let ((loc (pm--get-property-nearby property nil ahead)))
(when loc
(cond
((eq accessor :inc-end) (setcdr loc (1+ (cdr loc))))
((eq accessor :dec-beg) (setcar loc (1- (cdr loc))))
(t (error "Invalid ACCESSOR keyword")))
loc))
(pm--get-property-nearby property accessor ahead))))
(defun pm--span-at-point (head-matcher tail-matcher &optional pos can-overlap)
"Span detector with head and tail matchers.
HEAD-MATCHER and TAIL-MATCHER is as in :head-matcher slot of
`pm-inner-chunkmode' object. POS defaults to (point). When
CAN-OVERLAP is non-nil nested chunks of this type are allowed.
Return a list of the form (TYPE SPAN-START SPAN-END) where TYPE
is one of the following symbols:
nil - pos is between ‘point-min’ and head-matcher, or between
tail-matcher and ‘point-max’
body - pos is between head-matcher and tail-matcher (exclusively)
head - head span
tail - tail span"
(setq pos (or pos (point)))
(save-restriction
(widen)
(save-excursion
(goto-char pos)
(let* ((at-max (= pos (point-max)))
(head-matcher (pm-fun-matcher head-matcher))
(tail-matcher (pm-fun-matcher tail-matcher))
(head1 (funcall head-matcher -1)))
(if head1
(if (or (< pos (cdr head1))
(and at-max (= (cdr head1) pos)))
;; -----|
;; host)[head) ; can occur with sub-head == 0 only
(list 'head (car head1) (cdr head1))
;; ------------------------
;; host)[head)[body)[tail)[host)[head)[body)
(pm--find-tail-from-head pos head1 head-matcher tail-matcher can-overlap))
;; ----------
;; host)[head)[body)[tail)[host
(goto-char (point-min))
(let ((head2 (funcall head-matcher 1)))
(if head2
(if (< pos (car head2))
;; ----
;; host)[head)[body)[tail)[host
(list nil (point-min) (car head2))
(if (< pos (cdr head2))
;; -----
;; host)[head)[body)[tail)[host
(list 'head (car head2) (cdr head2))
;; -----------------
;; host)[head)[body)[tail)[host
(pm--find-tail-from-head pos head2 head-matcher tail-matcher can-overlap)))
;; no span found
nil)))))))
;; fixme: find a simpler way with recursion where head-matcher and tail-matcher could be reversed
(defun pm--find-tail-from-head (pos head head-matcher tail-matcher can-overlap)
(goto-char (cdr head))
(let ((tail (funcall tail-matcher 1))
(at-max (= pos (point-max)))
(type 'tail))
(when can-overlap
(save-excursion
;; search for next head and pick the earliest
(goto-char (cdr head))
(let ((match (funcall head-matcher 1)))
(when (or (null tail)
(and match (< (car match) (car tail))))
(setq tail match
type 'head)))))
(if tail
(if (< pos (car tail))
;; -----
;; host)[head)[body)[tail)[host)[head)
(list 'body (cdr head) (car tail))
(if (or (< pos (cdr tail))
(and at-max (= pos (cdr tail))))
;; -----
;; host)[head)[body)[tail)[host)[head)
(list type (car tail) (cdr tail))
(goto-char (cdr tail))
;; -----------
;; host)[head)[body)[tail)[host)[head)
(let ((match (funcall head-matcher 1))
(type 'head))
(when can-overlap
(save-excursion
;; search for next head and pick the earliest
(goto-char (cdr tail))
(let ((match2 (funcall tail-matcher 1)))
(when (or (null match)
(and match2 (< (car match2) (car match))))
(setq match match2
type 'tail)))))
(if match
(if (< pos (car match))
;; -----
;; host)[head)[body)[tail)[host)[head)
(list nil (cdr tail) (car match))
(if (or (< pos (cdr match))
(and at-max (= pos (cdr match))))
;; -----
;; host)[head)[body)[tail)[host)[head)[body
(list type (car match) (cdr match))
;; ----
;; host)[head)[body)[tail)[host)[head)[body
(pm--find-tail-from-head pos match head-matcher tail-matcher can-overlap)))
;; -----
;; host)[head)[body)[tail)[host)
(list nil (cdr tail) (point-max))))))
;; -----
;; host)[head)[body)
(list 'body (cdr head) (point-max)))))
(defun pm-goto-span-of-type (type N)
"Skip to N - 1 spans of TYPE and stop at the start of a span of TYPE.
TYPE is either a symbol or a list of symbols of span types."
(let* ((sofar 0)
(types (if (symbolp type)
(list type)
type))
(back (< N 0))
(N (if back (- N) N))
(beg (if back (point-min) (point)))
(end (if back (point) (point-max))))
(unless (memq (car (pm-innermost-span)) types)
(setq sofar 1))
(condition-case nil
(pm-map-over-spans
(lambda (span)
(when (memq (car span) types)
(goto-char (nth 1 span))
(when (>= sofar N)
(signal 'quit nil))
(setq sofar (1+ sofar))))
beg end nil back)
(quit nil))
sofar))
;;; OBJECT HOOKS
(defun pm--run-derived-mode-hooks ()
;; Minor modes run-hooks, major-modes run-mode-hooks. Polymodes is a minor
;; mode but with major-mode flavor. We run hooks of all modes stored in
;; '-minor-mode slot of all parent objects in parent-first order.
(let* ((this-mode (eieio-oref pm/polymode '-minor-mode))
(this-state (symbol-value this-mode)))
(mapc (lambda (mm)
(let ((old-state (symbol-value mm)))
(unwind-protect
(progn
(set mm this-state)
(run-hooks (derived-mode-hook-name mm)))
(set mm old-state))))
(pm--collect-parent-slots pm/polymode '-minor-mode))))
(defun pm--run-init-hooks (object type &optional emacs-hook)
(unless pm-initialization-in-progress
(when emacs-hook
(run-hooks emacs-hook))
(pm--run-hooks object :init-functions (or type 'host))))
(defun pm--collect-parent-slots (object slot &optional do-when inclusive)
"Descend into parents of OBJECT and return a list of SLOT values.
Returned list is in parent first order. If non-nil DO-WHEN must
be a function which would take an object and return non-nil if
the recursion should descend into the parent. When nil, all
parents are descended. If INCLUSIVE is non-nil, include the slot
of the first object for which DO-WHEN failed."
(let ((inst object)
(vals nil)
(failed nil))
(while inst
(if (not (slot-boundp inst slot))
(setq inst (and (slot-boundp inst :parent-instance)
(eieio-oref inst 'parent-instance)))
(push (eieio-oref inst slot) vals)
(setq inst (and
(or (null do-when)
(if failed
(progn (setq failed nil) t)
(or (funcall do-when inst)
(and inclusive
(setq failed t)))))
(slot-boundp inst :parent-instance)
(eieio-oref inst 'parent-instance)))))
vals))
(defun pm--run-hooks (object slot &rest args)
"Run hooks from SLOT of OBJECT and its parent instances.
Parents' hooks are run first."
(let ((funs (delete-dups
(copy-sequence
(apply #'append
(pm--collect-parent-slots object slot))))))
(if args
(mapc (lambda (fn)
(apply fn args))
funs)
(mapc #'funcall funs))))
;;; BUFFER SELECTION
;; Transfer of the buffer-undo-list is managed internally by emacs
(define-obsolete-variable-alias 'pm-move-vars-from-base 'polymode-move-these-vars-from-base-buffer "v0.1.6")
(defvar polymode-move-these-vars-from-base-buffer
'(buffer-file-name
;; ideally this one should be merged across all buffers
buffer-display-table
outline-regexp
outline-level
polymode-default-inner-mode
tab-width)
"Variables transferred from base buffer on buffer switch.")
(define-obsolete-variable-alias 'pm-move-vars-from-old-buffer 'polymode-move-these-vars-from-old-buffer "v0.1.6")
(defvar polymode-move-these-vars-from-old-buffer
'(buffer-face-mode
buffer-face-mode-face
buffer-face-mode-remapping
buffer-invisibility-spec
buffer-read-only
buffer-undo-list
buffer-undo-tree
display-line-numbers
face-remapping-alist
isearch-mode ; this seems to be enough to avoid isearch glitching
line-move-visual
overwrite-mode
selective-display
text-scale-mode
text-scale-mode-amount
truncate-lines
truncate-partial-width-windows
word-wrap)
"Variables transferred from old buffer on buffer switch.")
(defvar polymode-move-these-minor-modes-from-base-buffer nil
"List of minor modes to move from base buffer.")
(defvar polymode-move-these-minor-modes-from-old-buffer
'(linum-mode
visual-line-mode
visual-fill-column-mode
writeroom-mode)
"List of minor modes to move from the old buffer.")
(defun pm-own-buffer-p (&optional buffer)
"Return t if BUFFER is owned by polymode.
Owning a buffer means that the BUFFER is either the base buffer
or an indirect implementation buffer. If nil, the buffer was
created outside of polymode with `clone-indirect-buffer'."
(when pm/polymode
(memq (or buffer (current-buffer))
(eieio-oref pm/polymode '-buffers))))
(defun pm-select-buffer (span &optional visibly)
"Select the buffer associated with SPAN.
Install a new indirect buffer if it is not already installed.
Chunkmode's class should define `pm-get-buffer-create' method. If
VISIBLY is non-nil perform extra adjustment for \"visual\" buffer
switch."
(let ((buffer (pm-span-buffer span))
(own (pm-own-buffer-p))
(cbuf (current-buffer)))
(with-current-buffer buffer
(pm--reset-ppss-cache span))
(when (and own visibly)
;; always sync to avoid issues with tooling working in different buffers
(pm--synchronize-points cbuf)
(let ((mode (or (eieio-oref (nth 3 span) 'keep-in-mode)
(eieio-oref pm/polymode 'keep-in-mode))))
(setq buffer (cond
((null mode) buffer)
((eq mode 'host) (pm-base-buffer))
(mode (or (pm-get-buffer-of-mode mode)
;; not throwing because in auto-modes mode might not
;; be installed yet and there is no way install it
;; from here
buffer))))))
;; (message "setting buffer %d-%d [%s]" (nth 1 span) (nth 2 span) cbuf)
;; no further action if BUFFER is already the current buffer
(unless (eq buffer cbuf)
(when (and own visibly)
(run-hook-with-args 'polymode-before-switch-buffer-hook
cbuf buffer))
(pm--move-vars polymode-move-these-vars-from-base-buffer
(pm-base-buffer) buffer)
(pm--move-vars polymode-move-these-vars-from-old-buffer
cbuf buffer)
(if visibly
;; Slow, visual selection. Don't perform in foreign indirect buffers.
(when own
(pm--select-existing-buffer-visibly buffer))
(set-buffer buffer)))))
(defvar text-scale-mode)
(defvar text-scale-mode-amount)
(defun pm--select-existing-buffer-visibly (new-buffer)
(let ((old-buffer (current-buffer))
(point (point))
(window-start (window-start))
(visible (pos-visible-in-window-p))
(ractive (region-active-p))
(mkt (mark t)))
(setq pm/current nil)
(pm--move-minor-modes polymode-move-these-minor-modes-from-base-buffer
(pm-base-buffer) new-buffer)
(pm--move-minor-modes polymode-move-these-minor-modes-from-old-buffer
old-buffer new-buffer)
(pm--move-overlays old-buffer new-buffer)
(switch-to-buffer new-buffer)
(bury-buffer-internal old-buffer)
(set-window-prev-buffers nil (assq-delete-all old-buffer (window-prev-buffers nil)))
(setq pm/current t)
;; fixme: what is the right way to do this ... activate-mark-hook?
(if (not ractive)
(deactivate-mark)
(set-mark mkt)
(activate-mark))
;; avoid display jumps
(goto-char point)
(when visible
(set-window-start (get-buffer-window new-buffer t) window-start))
(run-hook-with-args 'polymode-after-switch-buffer-hook old-buffer new-buffer)
(pm--run-hooks pm/polymode :switch-buffer-functions old-buffer new-buffer)
(pm--run-hooks pm/chunkmode :switch-buffer-functions old-buffer new-buffer)))
(defun pm--move-overlays (from-buffer to-buffer)
(with-current-buffer from-buffer
(mapc (lambda (o)
(unless (or (overlay-get o 'linum-str)
(overlay-get o 'yas--snippet))
(move-overlay o (overlay-start o) (overlay-end o) to-buffer)))
(overlays-in 1 (1+ (buffer-size))))))
(defun pm--move-vars (vars from-buffer &optional to-buffer)
(let ((to-buffer (or to-buffer (current-buffer))))
(unless (eq to-buffer from-buffer)