daniel/emacs
1
2
Fork 0
Code Issues 7 Pull Requests Projects Releases Wiki Activity

add lisp packages

Browse Source
This commit is contained in:
Daniel Weschke
2020-12-05 21:29:49 +01:00
parent 85e20365ae
commit a6e2395755
7272 changed files with 1363243 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

562
lisp/polymode/poly-lock.el Normal file
View File

@@ -0,0 +1,562 @@
;;; poly-lock.el --- Font lock sub-system for polymode -*- lexical-binding: t -*-
;;
;; Copyright (C) 2013-2019, Vitalie Spinu
;; Author: Vitalie Spinu
;; URL: https://github.com/polymode/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 GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
;;
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Commentary:
;;
;;; Code:
;; FONT-LOCK COMPONENTS:
;;
;; All * functions are lazy in poly-lock and jit-lock because they just mark
;; 'fontified nil.
;;
;; fontification-functions -> jit-lock-function / poly-lock-function
;; font-lock-ensure -> font-lock-ensure-function -> jit-lock-fontify-now/poly-lock-fontify-now
;; *font-lock-flush -> font-lock-flush-function -> jit-lock-refontify / poly-lock-flush
;; *font-lock-fontify-buffer -> font-lock-fontify-buffer-function -> jit-lock-refontify / poly-lock-flush
;; font-lock-fontify-region -> font-lock-fontify-region-function -> font-lock-default-fontify-region
;; font-lock-unfontify-region -> font-lock-unfontify-region-function -> font-lock-default-unfontify-region
;; font-lock-unfontify-buffer -> font-lock-unfontify-buffer-function -> font-lock-default-unfontify-buffer
;;
;; Jit-lock components:
;; fontification-functions (called by display engine)
;; --> jit-lock-function
;; --> jit-lock-fontify-now (or deferred through timer/text-properties)
;; --> jit-lock--run-functions
;; --> jit-lock-functions (font-lock-fontify-region bug-reference-fontify etc.)
;;
;;
;; Poly-lock components:
;; fontification-functions
;; --> poly-lock-function
;; --> poly-lock-fontify-now
;; --> jit-lock-fontify-now
;; ...
;;
;; `font-lock-mode' call graph:
;; -> font-lock-function <---- replaced by `poly-lock-mode'
;; -> font-lock-default-function
;; -> font-lock-mode-internal
;; -> font-lock-turn-on-thing-lock
;; -> font-lock-turn-on-thing-lock
;; -> (setq font-lock-flush-function jit-lock-refontify)
;; -> (setq font-lock-ensure-function jit-lock-fontify-now)
;; -> (setq font-lock-fontify-buffer-function jit-lock-refontify)
;; -> (jit-lock-register #'font-lock-fontify-region)
;; -> (add-hook 'jit-lock-functions #'font-lock-fontify-region nil t)
;; -> jit-lock-mode
(require 'jit-lock)
(require 'polymode-core)
(defvar poly-lock-allow-fontification t)
(defvar poly-lock-allow-background-adjustment t)
(defvar poly-lock-fontification-in-progress nil)
(defvar poly-lock-defer-after-change t)
(defvar-local poly-lock-mode nil)
(eval-when-compile
(defmacro with-buffer-prepared-for-poly-lock (&rest body)
"Execute BODY in current buffer, overriding several variables.
Preserves the `buffer-modified-p' state of the current buffer."
(declare (debug t))
`(let ((inhibit-point-motion-hooks t))
(with-silent-modifications
,@body))))
;; FIXME: Can this hack be avoided if poly-lock is registered in
;; `font-lock-support-mode'?
(defun poly-lock-no-jit-lock-in-polymode-buffers (fun arg)
"Don't activate FUN in `polymode' buffers.
When not in polymode buffers apply FUN to ARG."
(unless polymode-mode
(funcall fun arg)))
(pm-around-advice 'jit-lock-mode #'poly-lock-no-jit-lock-in-polymode-buffers)
;; see the comment in pm--mode-setup for these
(pm-around-advice 'font-lock-fontify-region #'polymode-inhibit-during-initialization)
(pm-around-advice 'font-lock-fontify-buffer #'polymode-inhibit-during-initialization)
(pm-around-advice 'font-lock-ensure #'polymode-inhibit-during-initialization)
(defun poly-lock-mode (arg)
"This is the value of `font-lock-function' in all polymode buffers.
Mode activated when ARG is positive; happens when font-lock is
switched on."
(unless polymode-mode
(error "Calling `poly-lock-mode' in a non-polymode buffer (%s)" (current-buffer)))
(setq poly-lock-mode arg)
(if arg
(progn
;; a lot of the following is inspired by what jit-lock does in
;; `font-lock-turn-on-thing-lock'
(setq-local font-lock-support-mode 'poly-lock-mode)
(setq-local font-lock-dont-widen t)
;; Re-use jit-lock registration. Some minor modes (adaptive-wrap)
;; register extra functionality. [Unfortunately `jit-lock-register'
;; calls `jit-lock-mode' which we don't want. Hence the advice. TOTHINK:
;; Simply add-hook to `jit-lock-functions'?]
(jit-lock-register 'font-lock-fontify-region)
;; don't allow other functions
(setq-local fontification-functions '(poly-lock-function))
(setq-local font-lock-flush-function 'poly-lock-flush)
(setq-local font-lock-fontify-buffer-function 'poly-lock-flush)
(setq-local font-lock-ensure-function 'poly-lock-fontify-now)
;; There are some more, jit-lock doesn't change those, neither do we:
;; font-lock-unfontify-region-function (defaults to font-lock-default-unfontify-region)
;; font-lock-unfontify-buffer-function (defualts to font-lock-default-unfontify-buffer)
;; Don't fontify eagerly (and don't abort if the buffer is large). NB:
;; `font-lock-flush' is not triggered if this is nil.
(setq-local font-lock-fontified t)
;; Now we can finally call `font-lock-default-function' because
;; `font-lock-support-mode' is set to "unrecognizible" value, only core
;; font-lock setup happens.
(font-lock-default-function arg)
;; Must happen after call to `font-lock-default-function'
(remove-hook 'after-change-functions 'font-lock-after-change-function t)
(remove-hook 'after-change-functions 'jit-lock-after-change t)
(add-hook 'after-change-functions 'poly-lock-after-change nil t)
;; Reusing jit-lock var becuase modes populate it directly. We are using
;; this in `poly-lock-after-change' below. Taken from `jit-lock
;; initialization.
(add-hook 'jit-lock-after-change-extend-region-functions
'font-lock-extend-jit-lock-region-after-change
nil t))
(remove-hook 'after-change-functions 'poly-lock-after-change t)
(remove-hook 'fontification-functions 'poly-lock-function t))
(current-buffer))
(defvar poly-lock-chunk-size 2500
"Poly-lock fontifies chunks of at most this many characters at a time.")
(defun poly-lock-function (start)
"The only function in `fontification-functions' in polymode buffers.
This is the entry point called by the display engine. START is
defined in `fontification-functions'. This function has the same
scope as `jit-lock-function'."
(unless pm-initialization-in-progress
(if (and poly-lock-mode (not memory-full))
(unless (input-pending-p)
(let ((end (min (or (text-property-any start (point-max) 'fontified t)
(point-max))
(+ start poly-lock-chunk-size))))
(when (< start end)
(poly-lock-fontify-now start end))))
(with-buffer-prepared-for-poly-lock
(put-text-property start (point-max) 'fontified t)))))
(defun poly-lock-fontify-now (beg end &optional _verbose)
"Polymode main fontification function.
Fontifies chunk-by chunk within the region BEG END."
(unless (or poly-lock-fontification-in-progress
pm-initialization-in-progress)
(let* ((font-lock-dont-widen t)
;; For now we fontify entire chunks at once. This simplicity is
;; warranted in multi-mode use cases.
(font-lock-extend-region-functions nil)
;; Fontification in one buffer can trigger fontification in another
;; buffer. Particularly, this happens when new indirect buffers are
;; created and `normal-mode' triggers font-lock in those buffers. We
;; avoid this by dynamically binding
;; `poly-lock-fontification-in-progress' and un-setting
;; `fontification-functions' in case re-display suddenly decides to
;; fontify something else in other buffer. There are also font-lock
;; guards in pm--mode-setup.
(poly-lock-fontification-in-progress t)
(fontification-functions nil)
(protect-host (or
(with-current-buffer (pm-base-buffer)
(eieio-oref pm/chunkmode 'protect-font-lock))
;; HACK: Some inner modes use syntax-table text
;; property. If there is, for example, a comment
;; syntax somewhere in the body span, havoc is spelled
;; in font-lock-fontify-syntactically-region which
;; calls parse-partial-sexp. For example fortran block
;; in ../poly-markdown/tests/input/markdown.md. We do
;; our best and protect the host in such cases.
(/= (next-single-property-change beg 'syntax-table nil end)
end))))
(save-restriction
(widen)
(save-excursion
;; TEMPORARY HACK: extend to the next span boundary in code blocks
;; (needed because re-display fontifies by small regions)
(let ((end-span (pm-innermost-span end)))
(if (car end-span)
(when (< (nth 1 end-span) end)
(setq end (nth 2 end-span)))
;; in host extend to paragraphs as in poly-lock--extend-region
(goto-char end)
(when (search-forward "\n\n" nil t)
(setq end (min (1- (point)) (nth 2 end-span))))))
;; Fontify the whole region in host first. It's ok for modes like
;; markdown, org and slim which understand inner mode chunks.
(unless protect-host
(let ((span (pm-innermost-span beg)))
(when (or (null (pm-true-span-type span))
;; in inner spans fontify only if region is bigger than the span
(< (nth 2 span) end))
(with-current-buffer (pm-base-buffer)
(with-buffer-prepared-for-poly-lock
(when poly-lock-allow-fontification
(put-text-property beg end 'fontified nil) ; just in case
;; (message "jlrf-host:%d-%d %s" beg end major-mode)
(condition-case-unless-debug err
;; NB: Some modes fontify beyond the limits (org-mode).
;; We need a reliably way to detect the actual limit of
;; the fontification.
(save-restriction
(widen)
(jit-lock--run-functions beg end))
(error
(message "(jit-lock--run-functions %s %s) [UNPR HOST %s]: %s"
beg end (current-buffer) (error-message-string err)))))
(put-text-property beg end 'fontified t))))))
(pm-map-over-spans
(lambda (span)
(when (or (pm-true-span-type span)
protect-host)
(let ((sbeg (nth 1 span))
(send (nth 2 span)))
;; skip empty spans
(with-buffer-prepared-for-poly-lock
(when (> send sbeg)
(if (not (and poly-lock-allow-fontification
poly-lock-mode))
(put-text-property sbeg send 'fontified t)
(let ((new-beg (max sbeg beg))
(new-end (min send end)))
(put-text-property new-beg new-end 'fontified nil)
;; (message "jlrf:%d-%d %s" new-beg new-end major-mode)
(condition-case-unless-debug err
(if (eieio-oref pm/chunkmode 'protect-font-lock)
(pm-with-narrowed-to-span span
(jit-lock--run-functions new-beg new-end))
(jit-lock--run-functions new-beg new-end))
(error
(message "(jit-lock--run-functions %s %s) [span %d %d %s] -> (font-lock-default-fontify-region %s %s): %s"
new-beg new-end sbeg send (current-buffer) new-beg new-end
(error-message-string err))))
;; even if failed set to t
(put-text-property new-beg new-end 'fontified t)))
(when poly-lock-allow-background-adjustment
(poly-lock-adjust-span-face span)))))))
beg end))))
(current-buffer)))
(defun poly-lock-flush (&optional beg end)
"Force refontification of the region BEG..END.
This function is placed in `font-lock-flush-function''"
(unless poly-lock-fontification-in-progress
(let ((beg (or beg (point-min)))
(end (or end (point-max))))
(with-buffer-prepared-for-poly-lock
(save-restriction
(widen)
(pm-flush-span-cache beg end)
(put-text-property beg end 'fontified nil))))))
(defvar jit-lock-start)
(defvar jit-lock-end)
(defun poly-lock--extend-region (beg end)
"Our own extension function which runs first on BEG END change.
Assumes widen buffer. Sets `jit-lock-start' and `jit-lock-end'."
;; NB: Debug this like
;; (with-silent-modifications (insert "`") (poly-lock-after-change 65 66 0))
;; FIXME: this one extends to whole spans; not good. old span can disappear,
;; shrunk, extend etc
;; TOCHECK: Pretty surely we need not use 'no-cache here.
;; With differed after change, any function calling pm-innermost-span (mostly
;; syntax-propertize) will reset the spans, so the extension relying on
;; :pm-span cache will not detect the change. Use instead the especially setup
;; for this purpose :pm-span-old cache in poly-lock-after-change.
(let* ((prop-name (if poly-lock-defer-after-change :pm-span-old :pm-span))
(old-beg (or (previous-single-property-change beg prop-name)
(point-min)))
(old-end (or (next-single-property-change end prop-name)
(point-max)))
;; need this here before pm-innermost-span call
(old-beg-obj (nth 3 (get-text-property old-beg prop-name)))
(beg-span (pm-innermost-span beg 'no-cache))
(end-span (if (<= end (nth 2 beg-span))
beg-span
(pm-innermost-span end 'no-cache)))
(sbeg (nth 1 beg-span))
(send (nth 2 end-span)))
(if (< old-beg sbeg)
(let ((new-beg-span (pm-innermost-span old-beg)))
(if (eq old-beg-obj (nth 3 new-beg-span)) ; old-beg == (nth 1 new-beg-span) for sure
;; new span appeared within an old span, don't refontify the old part (common case)
(setq jit-lock-start (min sbeg (nth 2 new-beg-span)))
;; wrong span shrunk to its correct size (rare or never)
(setq jit-lock-start old-beg)))
;; refontify the entire new span
(setq jit-lock-start sbeg))
;; (dbg (pm-format-span beg-span))
;; always include head
(when (and (eq (car beg-span) 'tail)
(> jit-lock-start (point-min)))
(setq jit-lock-start (nth 1 (pm-innermost-span (1- jit-lock-start)))))
(when (and (eq (car beg-span) 'body)
(> jit-lock-start (point-min)))
(setq jit-lock-start (nth 1 (pm-innermost-span (1- jit-lock-start)))))
;; I think it's not possible to do better than this. When region is shrunk,
;; previous region could be incorrectly fontified even if the mode is
;; preserved due to wrong ppss
(setq jit-lock-end (max send old-end))
;; Check if the type of following span changed (for example when
;; modification is in head of an auto-chunk). Do this repeatedly till no
;; change. [TOTHINK: Do we need similar extension backwards?]
(let ((go-on t))
(while (and (< jit-lock-end (point-max))
go-on)
(let ((ospan (get-text-property jit-lock-end prop-name))
(nspan (pm-innermost-span jit-lock-end 'no-cache)))
;; (dbg "N" (pm-format-span nspan))
;; (dbg "O" (pm-format-span ospan))
;; if spans have just been moved by buffer modification, stop
(if ospan
(if (and (eq (nth 3 nspan) (nth 3 ospan))
(= (- (nth 2 nspan) (nth 1 nspan))
(- (nth 2 ospan) (nth 1 ospan))))
(setq go-on nil)
(setq jit-lock-end (nth 2 nspan)
end-span nspan))
(setq go-on nil
jit-lock-end (point-max))))))
;; This extension is needed because some host modes (org) either don't
;; fontify the head correctly when tail is not there or worse, fontify
;; larger spans than asked for. It's mostly for unprotected hosts, but
;; doing it here for all cases to err on the safe side.
;; always include body of the head
(when (and (eq (car end-span) 'head)
(< jit-lock-end (point-max)))
(setq end-span (pm-innermost-span jit-lock-end)
jit-lock-end (nth 2 end-span)))
;; always include tail
(when (and (eq (car end-span) 'body)
(< jit-lock-end (point-max)))
(setq jit-lock-end (nth 2 (pm-innermost-span jit-lock-end))
end-span (pm-innermost-span jit-lock-end)))
;; Temporary hack for large host mode chunks - narrow to empty lines
(when (> (* 2 poly-lock-chunk-size)
(- jit-lock-end jit-lock-start))
(when (eq (car beg-span) nil)
(let ((tbeg (min beg (nth 2 beg-span))))
(when (> (- tbeg jit-lock-start) poly-lock-chunk-size)
(goto-char (- tbeg poly-lock-chunk-size))
(when (search-backward "\n\n" nil t)
(setq jit-lock-start (max jit-lock-start (1+ (point))))))))
(when (eq (car end-span) nil)
(let ((tend (max end (nth 1 end-span))))
(when (> (- jit-lock-end tend) poly-lock-chunk-size)
(goto-char (+ tend poly-lock-chunk-size))
(when (search-forward "\n\n" nil t)
(setq jit-lock-end (min jit-lock-end (1- (point)))))))))
(cons jit-lock-start jit-lock-end)))
;; (defun poly-lock--jit-lock-extend-region-span (span old-len)
;; "Call `jit-lock-after-change-extend-region-functions' protected to SPAN.
;; Extend `jit-lock-start' and `jit-lock-end' by side effect.
;; OLD-LEN is passed to the extension function."
;; ;; FIXME: for multi-span regions this function seems to reset
;; ;; jit-lock-start/end to spans limits
;; (let ((beg jit-lock-start)
;; (end jit-lock-end))
;; (let ((sbeg (nth 1 span))
;; (send (nth 2 span)))
;; (when (or (> beg sbeg) (< end send))
;; (pm-with-narrowed-to-span span
;; (setq jit-lock-start (max beg sbeg)
;; jit-lock-end (min end send))
;; (condition-case err
;; (progn
;; ;; set jit-lock-start and jit-lock-end by side effect
;; (run-hook-with-args 'jit-lock-after-change-extend-region-functions
;; jit-lock-start jit-lock-end old-len))
;; (error (message "(after-change-extend-region-functions %s %s %s) -> %s"
;; jit-lock-start jit-lock-end old-len
;; (error-message-string err))))
;; ;; FIXME: this is not in the right buffer, we need to do it in the
;; ;; original buffer.
;; (setq jit-lock-start (min beg (max jit-lock-start sbeg))
;; jit-lock-end (max end (min jit-lock-end send))))
;; (cons jit-lock-start jit-lock-end)))))
(defvar-local poly-lock--timer nil)
(defvar-local poly-lock--beg-change most-positive-fixnum)
(defvar-local poly-lock--end-change most-negative-fixnum)
(defun poly-lock--after-change-internal (buffer _old-len)
(when (buffer-live-p buffer)
(with-current-buffer buffer
(setq poly-lock--timer nil)
;; FIXME: timers can overlap; remove this check with global timer
(when (> poly-lock--end-change 0)
(with-buffer-prepared-for-poly-lock
(save-excursion
(save-restriction
(widen)
(let ((beg poly-lock--beg-change)
(end (min (point-max) poly-lock--end-change)))
(setq poly-lock--beg-change most-positive-fixnum
poly-lock--end-change most-negative-fixnum)
(save-match-data
(poly-lock--extend-region beg end)
;; no need for 'no-cache; poly-lock--extend-region re-computed the spans
;; FIXME: currently poly-lock--extend-region extends to whole
;; spans, which could get crazy for very large chunks, but
;; seems to work really well with the deferred after-change
;; hook. So the following jit-lock extensions are not needed
;; and probably even harm.
;; This extension hooks are run for major-mode's syntactic
;; hacks mostly and not that much for actual extension. For
;; example, markdown can syntactically propertize in this hook
;; markdown-font-lock-extend-region-function. Call on the
;; entire region host hooks to account for such patterns.
;; (let ((hostmode (oref pm/polymode -hostmode)))
;; (unless (eieio-oref hostmode 'protect-font-lock)
;; (with-current-buffer (pm-base-buffer)
;; (run-hook-with-args 'jit-lock-after-change-extend-region-functions
;; beg end old-len)
;; (setq beg jit-lock-start
;; end jit-lock-end)))
;; (let ((bspan (pm-innermost-span jit-lock-start)))
;; ;; FIXME: these are currently always protected and set
;; ;; jit-lock-end/start in their own buffers, not the buffer
;; ;; which invoked the after-change-hook
;; (unless (eq (nth 3 bspan) hostmode)
;; (poly-lock--jit-lock-extend-region-span bspan old-len))
;; (when (< (nth 2 bspan) jit-lock-end)
;; (let ((espan (pm-innermost-span jit-lock-end)))
;; (unless (eq (nth 3 espan) hostmode)
;; (poly-lock--jit-lock-extend-region-span espan old-len)))))
;; )
;; ;; Why is this still needed? poly-lock--extend-region re-computes the spans
;; (pm-flush-span-cache jit-lock-start jit-lock-end)
;; (dbg (cb) jit-lock-start jit-lock-end)
;; (put-text-property jit-lock-end jit-lock-end :poly-lock-refontify nil)
(put-text-property jit-lock-start jit-lock-end 'fontified nil))))))))))
(defun poly-lock-after-change (beg end old-len)
"Mark changed region with 'fontified nil.
Extend the region to spans which need to be updated. BEG, END and
OLD-LEN are as in `after-change-functions'. When
`poly-lock-defer-after-change' is non-nil (the default), run fontification"
(when (and poly-lock-mode
pm-allow-after-change-hook
(not memory-full))
;; Extension is slow but after-change functions can be called in rapid
;; succession (#200 with string-rectangle on which combine-change-calls is
;; of little help). Thus we do that in a timer.
(when (timerp poly-lock--timer)
;; FIXME: Instead of local timer, make a global one iterating over
;; relevant buffers
(cancel-timer poly-lock--timer))
(if poly-lock-defer-after-change
(progn
(with-silent-modifications
;; don't re-fontify before we extend
(put-text-property beg end 'fontified t)
(setq poly-lock--beg-change (min beg end poly-lock--beg-change)
poly-lock--end-change (max beg end poly-lock--end-change))
;; between this call and deferred extension pm-inner-span can be
;; called, so we cache a few :pm-span properties around beg/end
(poly-lock--cache-pm-span-property beg end))
(setq-local poly-lock--timer
(run-at-time 0.05 nil #'poly-lock--after-change-internal
(current-buffer) old-len)))
(setq poly-lock--beg-change beg
poly-lock--end-change end)
(poly-lock--after-change-internal (current-buffer) old-len))))
(defun poly-lock--cache-pm-span-property (beg end)
;; cache one previous and 5 forward spans
(let ((new-beg (or (previous-single-property-change beg :pm-span)
(point-min))))
(put-text-property new-beg beg :pm-span-old (get-text-property new-beg :pm-span)))
(let ((i 5))
(while (and (< 0 i) (< end (point-max)))
(let ((new-end (or (next-single-property-change end :pm-span)
(point-max))))
(put-text-property new-end end :pm-span-old (get-text-property (1- new-end) :pm-span))
(setq end new-end
i (1- i))))))
(defun poly-lock--adjusted-background (prop)
;; if > lighten on dark backgroun. Oposite on light.
(color-lighten-name (face-background 'default)
(if (eq (frame-parameter nil 'background-mode) 'light)
(- prop) ;; darken
prop)))
(declare-function pm-get-adjust-face "polymode-methods")
(defvar poly-lock--extra-span-props (when (fboundp 'set-face-extend) (list :extend t)))
(defun poly-lock-adjust-span-face (span)
"Adjust 'face property of SPAN..
How adjustment is made is defined in :adjust-face slot of the
SPAN's chunkmode."
(interactive "r")
(let ((face (pm-get-adjust-face (nth 3 span) (car span))))
(let ((face (if (numberp face)
(unless (= face 0)
(list (append (list :background (poly-lock--adjusted-background face))
poly-lock--extra-span-props)))
face)))
(when face
(font-lock-append-text-property
(nth 1 span) (nth 2 span) 'face face)))))
(provide 'poly-lock)
;;; poly-lock.el ends here

122
lisp/polymode/polymode-base.el Normal file
View File

@@ -0,0 +1,122 @@
;;; polymode-base.el --- Root Host and Polymode Configuration Objects -*- lexical-binding: t -*-
;;
;; Copyright (C) 2013-2019, Vitalie Spinu
;; Author: Vitalie Spinu
;; URL: https://github.com/polymode/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 GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Commentary:
;;
;;; Code:
(require 'polymode-core)
;; HOST MODES
(define-obsolete-variable-alias 'pm-host/ada 'poly-ada-hostmode "v0.2")
(define-hostmode poly-ada-hostmode :mode 'ada-mode)
(define-obsolete-variable-alias 'pm-host/coffee 'poly-coffee-hostmode "v0.2")
(define-hostmode poly-coffee-hostmode :mode 'coffee-mode)
(define-obsolete-variable-alias 'pm-host/emacs-lisp 'poly-emacs-lisp-hostmode "v0.2")
(define-hostmode poly-emacs-lisp-hostmode :mode 'emacs-lisp-mode)
(define-obsolete-variable-alias 'pm-host/fundamental 'poly-fundamental-hostmode "v0.2")
(define-hostmode poly-fundamental-hostmode :mode 'fundamental-mode)
(define-obsolete-variable-alias 'pm-host/java 'poly-java-hostmode "v0.2")
(define-hostmode poly-java-hostmode :mode 'java-mode)
(define-obsolete-variable-alias 'pm-host/js 'poly-js-hostmode "v0.2")
(define-hostmode poly-js-hostmode :mode 'js-mode)
(define-obsolete-variable-alias 'pm-host/latex 'poly-latex-hostmode "v0.2")
(define-hostmode poly-latex-hostmode :mode 'latex-mode)
(define-obsolete-variable-alias 'pm-host/html 'poly-html-hostmode "v0.2")
(define-hostmode poly-html-hostmode
:mode 'html-mode
:indent-offset 'sgml-basic-offset
:protect-font-lock nil
:protect-syntax t)
(define-obsolete-variable-alias 'pm-host/R 'poly-R-hostmode "v0.2")
(define-hostmode poly-R-hostmode :mode 'R-mode)
(define-obsolete-variable-alias 'pm-host/perl 'poly-perl-hostmode "v0.2")
(define-hostmode poly-perl-hostmode :mode 'perl-mode)
(define-obsolete-variable-alias 'pm-host/ruby 'poly-ruby-hostmode "v0.2")
(define-hostmode poly-ruby-hostmode :mode 'ruby-mode)
(define-obsolete-variable-alias 'pm-host/pascal 'poly-pascal-hostmode "v0.2")
(define-hostmode poly-pascal-hostmode :mode 'pascal-mode)
(define-obsolete-variable-alias 'pm-host/C++ 'poly-c++-hostmode "v0.2")
(define-hostmode poly-c++-hostmode :mode 'C++-mode :protect-font-lock nil)
(define-obsolete-variable-alias 'pm-host/sgml 'poly-sgml-hostmode "v0.2")
(define-hostmode poly-sgml-hostmode :mode 'sgml-mode)
(define-obsolete-variable-alias 'pm-host/text 'poly-text-hostmode "v0.2")
(define-hostmode poly-text-hostmode :mode 'text-mode)
(define-obsolete-variable-alias 'pm-host/yaml 'poly-yaml-hostmode "v0.2")
(define-hostmode poly-yaml-hostmode :mode 'yaml-mode)
;;; ROOT POLYMODES
;; These are simple generic configuration objects. More specialized polymodes
;; should clone these.
(define-obsolete-variable-alias 'pm-poly/brew 'poly-brew-root-polymode "v0.2")
(defvar poly-brew-root-polymode
(pm-polymode :name "brew-root" :hostmode 'poly-text-hostmode)
"Brew root configuration.")
(define-obsolete-variable-alias 'pm-poly/html 'poly-html-root-polymode "v0.2")
(defvar poly-html-root-polymode
(pm-polymode :name "html-root" :hostmode 'poly-html-hostmode)
"HTML root configuration.")
(define-obsolete-variable-alias 'pm-poly/C++ 'poly-c++-root-polymode "v0.2")
(defvar poly-c++-root-polymode
(pm-polymode :name "c++-root" :hostmode 'poly-c++-hostmode)
"C++ root configuration.")
(define-obsolete-variable-alias 'pm-poly/latex 'poly-latex-root-polymode "v0.2")
(defvar poly-latex-root-polymode
(pm-polymode :name "latex-root" :hostmode 'poly-latex-hostmode)
"LaTeX root configuration.")
(defvar poly-js-root-polymode
(pm-polymode :name "js-root" :hostmode 'poly-js-hostmode)
"JS root polymode.")
(defvar poly-coffee-root-polymode
(pm-polymode :name "coffee-root" :hostmode 'poly-coffee-hostmode)
"JS root polymode.")
(provide 'polymode-base)
;;; polymode-base.el ends here

488
lisp/polymode/polymode-classes.el Normal file
View File

@@ -0,0 +1,488 @@
;;; polymode-classes.el --- Core polymode classes -*- lexical-binding: t -*-
;;
;; Copyright (C) 2013-2019, Vitalie Spinu
;; Author: Vitalie Spinu
;; URL: https://github.com/polymode/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 GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Commentary:
;;
;;; Code:
(require 'eieio)
(require 'eieio-base)
(require 'eieio-custom)
(defvar pm--object-counter 0)
(defun pm--filter-slots (slots)
(delq nil (mapcar (lambda (slot)
(unless (or (= (elt (symbol-name slot) 0) ?-)
(eq slot 'parent-instance)
(eq slot 'name))
(intern (concat ":" (symbol-name slot)))))
slots)))
(defclass pm-root (eieio-instance-inheritor)
((name
:initarg :name
:initform "UNNAMED"
:type string
:custom string
:documentation
"Name of the object used to for display and info.")
(-props
:initform '()
:type list
:documentation
"[Internal] Plist used to store various extra metadata such as user history.
Use `pm--prop-get' and `pm--prop-put' to place key value pairs
into this list."))
"Root polymode class.")
(cl-defmethod eieio-object-name-string ((obj pm-root))
(eieio-oref obj 'name))
(cl-defmethod clone ((obj pm-root) &rest params)
(let ((new-obj (cl-call-next-method obj)))
;; Emacs bug: clone method for eieio-instance-inheritor instantiates all
;; slots for cloned objects. We want them unbound to allow for the healthy
;; inheritance.
(pm--complete-clonned-object new-obj obj params)))
(defun pm--complete-clonned-object (new-obj old-obj params)
(let ((old-name (eieio-oref old-obj 'name)))
(when (equal old-name (eieio-oref new-obj 'name))
(let ((new-name (concat old-name ":")))
(eieio-oset new-obj 'name new-name))))
(dolist (descriptor (eieio-class-slots (eieio-object-class old-obj)))
(let ((slot (eieio-slot-descriptor-name descriptor)))
(unless (memq slot '(parent-instance name))
(slot-makeunbound new-obj slot))))
(when params
(shared-initialize new-obj params))
new-obj)
(defun pm--safe-clone (end-class obj &rest params)
"Clone to an object of END-CLASS.
If END-CLASS is same as class of OBJ then just call `clone'.
Otherwise do a bit more work by setting extra slots of the
end-class. PARAMS are passed to clone or constructor functions."
(if (eq end-class (eieio-object-class obj))
(apply #'clone obj params)
(let ((new-obj (pm--complete-clonned-object
(apply end-class params)
obj params)))
(eieio-oset new-obj 'parent-instance obj)
new-obj)))
(defclass pm-polymode (pm-root)
((hostmode
:initarg :hostmode
:initform nil
:type symbol
:custom symbol
:documentation
"Symbol pointing to a `pm-host-chunkmode' object.
When nil, any host-mode will be matched (suitable for
poly-minor-modes. ")
(innermodes
:initarg :innermodes
:type list
:initform nil
:custom (repeat symbol)
:documentation
"List of inner-mode names (symbols) associated with this polymode.
A special marker :inherit in this list is replaced with the
innermodes of the parent. This allows for a simple way to add
innermodes to the child without explicitly listing all the
innermodes of the parent.")
(exporters
:initarg :exporters
:initform '(pm-exporter/pandoc)
:custom (repeat symbol)
:documentation
"List of names of polymode exporters available for this polymode.")
(exporter
:initarg :exporter
:initform nil
:type symbol
:custom symbol
:documentation
"Current exporter name.
If non-nil should be the name of the default exporter for this
polymode. Can be set with `polymode-set-exporter' command.")
(weavers
:initarg :weavers
:initform '()
:type list
:custom (repeat symbol)
:documentation
"List of names of polymode weavers available for this polymode.")
(weaver
:initarg :weaver
:initform nil
:type symbol
:custom symbol
:documentation
"Current weaver name.
If non-nil this is the default weaver for this polymode. Can be
dynamically set with `polymode-set-weaver'")
(switch-buffer-functions
:initarg :switch-buffer-functions
:initform '()
:type list
:custom (repeat symbol)
:documentation
"List of functions to run at polymode buffer switch.
Each function is run with two arguments, OLD-BUFFER and
NEW-BUFFER.")
(keylist
:initarg :keylist
:initform 'polymode-minor-mode-map
:type (or symbol list)
:custom (choice (symbol :tag "Keymap")
(repeat (cons string symbol)))
:documentation
"A list of elements of the form (KEY . BINDING).
This slot is reserved for building hierarchies through cloning
and should not be used in `define-polymode'.")
(keep-in-mode
:initarg :keep-in-mode
:initform nil
:type symbol
:custom symbol
:documentation
;; NB: Using major-modes instead of innermode symbols for the sake of
;; simplicity of the implementation and to allow for auto-modes.
"Major mode to keep in when polymode switches implementation buffers.
When a special symbol 'host, keep in hostmode. The buffer with
this major mode must be installed by one of the innermodes or the
hostmode. If multiple innermodes installed buffers of this mode,
the first buffer is used.")
(-minor-mode
:initform 'polymode-minor-mode
:initarg -minor-mode
:type symbol
:documentation
"[Internal] Symbol pointing to minor-mode function.")
(-hostmode
:type (or null pm-chunkmode)
:documentation
"[Dynamic] Dynamically populated `pm-chunkmode' object.")
(-innermodes
:type list
:initform '()
:documentation
"[Dynamic] List of chunkmodes objects.")
(-auto-innermodes
:type list
:initform '()
:documentation
"[Dynamic] List of auto chunkmodes.")
(-buffers
:initform '()
:type list
:documentation
"[Dynamic] Holds all buffers associated with current buffer."))
"Polymode Configuration object.
Each polymode buffer holds a local variable `pm/polymode'
instantiated from this class or a subclass of this class.")
(defclass pm-chunkmode (pm-root)
((mode
:initarg :mode
:initform nil
:type symbol
:custom symbol
:documentation
"Emacs major mode for the chunk's body.
If :mode slot is nil (anonymous chunkmodes), use the value of
`polymode-default-inner-mode' is when set, or use the value of
the slot :fallback-mode. A special value 'host means to use the
host mode (useful auto-chunkmodes only).")
(fallback-mode
:initarg :fallback-mode
:initform 'poly-fallback-mode
:type symbol
:custom symbol
:documentation
"Mode to use when mode lookup fails for various reasons. Can
take a special value 'host. Note that, when set,
`polymode-default-inner-mode' takes precedence over this
value.")
(allow-nested
:initarg :allow-nested
:initform t
:type symbol
:custom symbol
:documentation
"Non-nil if other inner-modes are allowed to nest within this
inner-mode.")
(indent-offset
:initarg :indent-offset
:initform 2
:type (or number symbol)
:custom (choice number symbol)
:documentation
"Indentation offset for this mode.
Currently this is only used in +indent and -indent cookies which
when placed on a line cause manual shift in indentation with
respect to how polymode would normally indent a line. Should be
used in cases when indentation of the line is incorrect. Can be a
number, a variable name or a function name to be called with no
arguments.")
(pre-indent-offset
:initarg :pre-indent-offset
:initform 0
:type (or number function)
:custom (choice number function)
:documentation
"Function to compute the offset first line of this chunk.
Offset is relative to how the host mode would indent it. Called
with no-arguments with the point at the begging of the chunk.")
(post-indent-offset
:initarg :post-indent-offset
:initform 0
:type (or number function)
:custom (choice number function)
:documentation
"Function to compute the offset of the following line after this chunk.
Offset is relative to how the host mode would indent it. Called
without arguments with point at the end of the chunk but before
the trailing white spaces if any.")
(protect-indent
:initarg :protect-indent
:initform nil
:type boolean
:custom boolean
:documentation
"Whether to narrowing to current span before indent.")
(protect-font-lock
:initarg :protect-font-lock
:initform nil
:type boolean
:custom boolean
:documentation
"Whether to narrow to span during font lock.")
(protect-syntax
:initarg :protect-syntax
:initform nil
:type boolean
:custom boolean
:documentation
"Whether to narrow to span when calling `syntax-propertize-function'.")
(adjust-face
:initarg :adjust-face
:initform nil
:type (or number face list)
:custom (choice number face sexp)
:documentation
"Fontification adjustment for the body of the chunk.
It should be either, nil, number, face or a list of text
properties as in `put-text-property' specification. If nil or 0
no highlighting occurs. If a face, use that face. If a number, it
is a percentage by which to lighten/darken the default chunk
background. If positive - lighten the background on dark themes
and darken on light thems. If negative - darken in dark thems and
lighten in light thems.")
(init-functions
:initarg :init-functions
:initform '()
:type list
:custom hook
:documentation
"List of functions called after the initialization.
Functions are called with one argument TYPE in the buffer
associated with this chunkmode's span. TYPE is either 'host,
'head, 'body or 'tail. All init-functions in the inheritance
chain are called in parent-first order. Either customize this
slot or use `object-add-to-list' function.")
(switch-buffer-functions
:initarg :switch-buffer-functions
:initform '()
:type list
:custom hook
:documentation
"List of functions to run at polymode buffer switch.
Each function is run with two arguments, OLD-BUFFER and
NEW-BUFFER. In contrast to identically named slot in
`pm-polymode' class, these functions are run only when NEW-BUFFER
is of this chunkmode.")
(keep-in-mode
:initarg :keep-in-mode
:initform nil
:type symbol
:custom symbol
:documentation
"Major mode to keep in when polymode switches implementation buffers.
When a special symbol 'host, keep in hostmode. The buffer with
this major mode must be installed by one of the innermodes or the
hostmode. If multiple innermodes installed buffers of this mode,
the first buffer is used.")
(-buffer
:type (or null buffer)
:initform nil))
"Generic chunkmode object.
Please note that by default :protect-xyz slots are nil in
hostmodes and t in innermodes.")
(defclass pm-host-chunkmode (pm-chunkmode)
((allow-nested
;; currently ignored in code as it doesn't make sense to not allow
;; innermodes in hosts
:initform 'always))
"This chunkmode doesn't know how to compute spans and takes
over all the other space not claimed by other chunkmodes in the
buffer.")
(defclass pm-inner-chunkmode (pm-chunkmode)
((protect-font-lock
:initform t)
(protect-syntax
:initform t)
(protect-indent
:initform t)
(body-indent-offset
:initarg :body-indent-offset
:initform 0
:type (or number symbol function)
:custom (choice number symbol)
:documentation
"Indentation offset of the body span relative to the head.
Can be a number, symbol holding a number or a function. When a
function, it is called with no arguments at the beginning of the
body span.")
(can-nest
:initarg :can-nest
:initform nil
:type boolean
:custom boolean
:documentation
"Non-nil if this inner-mode can nest within other inner-modes.
All chunks can nest within the host-mode.")
(can-overlap
:initarg :can-overlap
:initform nil
:type boolean
:custom boolean
:documentation
"Non-nil if chunks of this type can overlap with other chunks of the same type.
See noweb for an example.")
(head-mode
:initarg :head-mode
:initform 'poly-head-tail-mode
:type symbol
:custom symbol
:documentation
"Chunk's head mode.
If set to 'host or 'body use host or body's mode respectively.")
(tail-mode
:initarg :tail-mode
:initform 'poly-head-tail-mode
:type symbol
:custom (choice (const nil :tag "From Head")
function)
:documentation
"Chunk's tail mode.
If set to 'host or 'body use host or body's mode respectively.")
(head-matcher
:initarg :head-matcher
:type (or string cons function)
:custom (choice string (cons string integer) function)
:documentation
"A regexp, a cons (REGEXP . SUB-MATCH) or a function.
When a function, the matcher must accept one argument that can
take either values 1 (forwards search) or -1 (backward search)
and behave similarly to how search is performed by
`re-search-forward' function. This function must return either
nil (no match) or a (cons BEG END) representing the span of the
head or tail respectively. See the code of `pm-fun-matcher' for a
simple example.")
(tail-matcher
:initarg :tail-matcher
:type (or string cons function)
:custom (choice string (cons string integer) function)
:documentation
"A regexp, a cons (REGEXP . SUB-MATCH) or a function.
Like :head-matcher but for the chunk's tail. Currently, it is
always called with the point at the end of the matched head and
with the positive argument (aka match forward).")
(adjust-face
:initform 2)
(head-adjust-face
:initarg :head-adjust-face
:initform 'bold
:type (or number face list)
:custom (choice number face sexp)
:documentation
"Head's face adjustment.
Can be a number, a list of properties or a face.")
(tail-adjust-face
:initarg :tail-adjust-face
:initform nil
:type (or null number face list)
:custom (choice (const :tag "From Head" nil)
number face sexp)
:documentation
"Tail's face adjustment.
A number, a list of properties, a face or nil. When nil, take the
configuration from :head-adjust-face.")
(-head-buffer
:type (or null buffer)
:initform nil
:documentation
"[Internal] This buffer is set automatically to -buffer if
:head-mode is 'body, and to base-buffer if :head-mode is 'host.")
(-tail-buffer
:initform nil
:type (or null buffer)
:documentation
"[Internal] Same as -head-buffer, but for tail span."))
"Inner-chunkmodes represent innermodes (or sub-modes) within a
buffer. Chunks are commonly delimited by head and tail markup but
can be delimited by some other logic (e.g. indentation). In the
latter case, heads or tails have zero length and are not
physically present in the buffer.")
(defclass pm-inner-auto-chunkmode (pm-inner-chunkmode)
((mode-matcher
:initarg :mode-matcher
:type (or string cons function)
:custom (choice string (cons string integer) function)
:documentation
"Matcher used to retrieve the mode's symbol from the chunk's head.
Can be either a regexp string, cons of the form (REGEXP .
SUBEXPR) or a function to be called with no arguments. If a
function, it must return a string name of the mode. Function is
called at the beginning of the head span."))
"Inner chunkmodes with unknown (at definition time) mode of the
body span. The body mode is determined dynamically by retrieving
the name with the :mode-matcher.")
(provide 'polymode-classes)
;;; polymode-classes.el ends here

390
lisp/polymode/polymode-compat.el Normal file
View File

@@ -0,0 +1,390 @@
;;; polymode-compat.el --- Various compatibility fixes for other packages -*- lexical-binding: t -*-
;;
;; Author: Vitalie Spinu
;; Maintainer: Vitalie Spinu
;; Copyright (C) 2013-2019, Vitalie Spinu
;; Version: 0.1
;; URL: https://github.com/polymode/polymode
;; Keywords: emacs
;;
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; 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 GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
;;
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Commentary:
;;
;;
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Code:
(require 'polymode-core)
(require 'advice nil t)
(defgroup polymode-compat nil
"Polymode compatibility settings."
:group 'polymode)
;;; emacs 25 compat
(unless (fboundp 'assoc-delete-all)
(defun assoc-delete-all (key alist &optional test)
"Delete from ALIST all elements whose car is KEY.
Compare keys with TEST. Defaults to `equal'.
Return the modified alist.
Elements of ALIST that are not conses are ignored."
(unless test (setq test #'equal))
(while (and (consp (car alist))
(funcall test (caar alist) key))
(setq alist (cdr alist)))
(let ((tail alist) tail-cdr)
(while (setq tail-cdr (cdr tail))
(if (and (consp (car tail-cdr))
(funcall test (caar tail-cdr) key))
(setcdr tail (cdr tail-cdr))
(setq tail tail-cdr))))
alist)
(defun assq-delete-all (key alist)
"Delete from ALIST all elements whose car is `eq' to KEY.
Return the modified alist.
Elements of ALIST that are not conses are ignored."
(assoc-delete-all key alist #'eq)))
;;; Various Wrappers for Around Advice
(defvar *span* nil)
;; advice doesn't provide named symbols. So we need to define specialized
;; wrappers for some key functions (unfinished)
(defmacro pm-define-wrapp-protected (fun)
"Declare protected function with the name fun--pm-wrapped.
Return new name (symbol). FUN is an unquoted name of a function."
(let* ((fun-name (symbol-name fun))
(new-fun (intern (format "%s--pm-wrapped" fun-name)))
(new-doc (format " Error Protected function created with `pm-define-protected-wrapp'.\n\n%s"
(or (documentation fun) ""))))
`(progn
(defun ,new-fun (&rest args)
,new-doc
(condition-case err
(apply ',fun args)
(error (message "(%s %s): %s"
,fun-name
(mapconcat (lambda (x) (format "%s" x)) args " ")
(error-message-string err)))))
',new-fun)))
(defun pm-apply-protected (fun args)
(when fun
(condition-case-unless-debug err
(apply fun args)
(error (message "(%s %s): %s %s"
(if (symbolp fun)
(symbol-name fun)
"anonymous")
(mapconcat (lambda (x) (format "%s" x)) args " ")
(error-message-string err)
;; (or (and (symbolp fun) "")
;; (replace-regexp-in-string "\n" "" (format "[%s]" fun)))
"[M-x pm-debug-mode RET for more info]")
nil))))
(defun pm-override-output-position (orig-fun &rest args)
"Restrict returned value of ORIG-FUN to fall into the current span.
*span* in `pm-map-over-spans` has precedence over span at point.
ARGS are passed to ORIG-FUN."
(if (and polymode-mode pm/polymode)
(let ((range (or (pm-span-to-range *span*)
(pm-innermost-range)))
(pos (pm-apply-protected orig-fun args)))
(and pos
(min (max pos (car range))
(cdr range))))
(apply orig-fun args)))
(defun pm-override-output-cons (orig-fun &rest args)
"Restrict returned (beg . end) of ORIG-FUN to fall into the current span.
*span* in `pm-map-over-spans` has precedence over span at point.
This will break badly if (point) is not inside expected range.
ARGS are passed to ORIG-FUN."
(if (and polymode-mode pm/polymode)
(let ((range (or (pm-span-to-range *span*)
(pm-innermost-range)))
(be (pm-apply-protected orig-fun args)))
(let ((out (and be
(cons (and (car be)
(min (max (car be) (car range))
(cdr range)))
(and (cdr be)
(max (min (cdr be) (cdr range))
(car range)))))))
out))
(apply orig-fun args)))
(defun pm-narrowed-override-output-cons (orig-fun &rest args)
"Restrict returned (beg . end) of ORIG-FUN to fall into the current span.
Run ORIG-FUN with buffer narrowed to span. *span* in
`pm-map-over-spans` has precedence over span at point. ARGS are
passed to ORIG-FUN."
(if (and polymode-mode pm/polymode)
(let ((*span* (or *span* (pm-innermost-span))))
(pm-with-narrowed-to-span *span*
(apply #'pm-override-output-cons orig-fun args)))
(apply orig-fun args)))
(defun pm-substitute-beg-end (orig-fun beg end &rest args)
"Execute ORIG-FUN with first BEG and END arguments limited to current span.
*span* in `pm-map-over-spans` has precedence over span at point.
ARGS are passed to ORIG-FUN."
(if (and polymode-mode pm/polymode)
(let* ((pos (if (and (<= (point) end) (>= (point) beg))
(point)
end))
(range (or (pm-span-to-range *span*)
(pm-innermost-range pos)))
(new-beg (max beg (car range)))
(new-end (min end (cdr range))))
(pm-apply-protected orig-fun (append (list new-beg new-end) args)))
(apply orig-fun beg end args)))
(defun pm-execute-narrowed-to-span (orig-fun &rest args)
"Execute ORIG-FUN narrowed to the current span.
*span* in `pm-map-over-spans` has precedence over span at point.
ARGS are passed to ORIG-FUN."
(if (and polymode-mode pm/polymode)
(pm-with-narrowed-to-span *span*
(pm-apply-protected orig-fun args))
(apply orig-fun args)))
;;; Flyspel
(defun pm--flyspel-dont-highlight-in-chunkmodes (beg end _poss)
(or (car (get-text-property beg :pm-span))
(car (get-text-property end :pm-span))))
;;; C/C++/Java
(pm-around-advice 'c-before-context-fl-expand-region #'pm-override-output-cons)
;; (advice-remove 'c-before-context-fl-expand-region #'pm-override-output-cons)
(pm-around-advice 'c-state-semi-safe-place #'pm-override-output-position)
;; (advice-remove 'c-state-semi-safe-place #'pm-override-output-position)
;; c-font-lock-fontify-region calls it directly
;; (pm-around-advice 'font-lock-default-fontify-region #'pm-substitute-beg-end)
(pm-around-advice 'c-determine-limit #'pm-execute-narrowed-to-span)
;;; Python
(declare-function pm--first-line-indent "polymode-methods")
(defun pm--python-dont-indent-to-0 (fun)
"Fix indent FUN not to cycle to 0 indentation."
(if (and polymode-mode pm/type)
(let ((last-command (unless (eq (pm--first-line-indent) (current-indentation))
last-command)))
(funcall fun))
(funcall fun)))
(pm-around-advice 'python-indent-line-function #'pm--python-dont-indent-to-0)
;;; Core Font Lock
(defvar font-lock-beg)
(defvar font-lock-end)
(defun pm-check-for-real-change-in-extend-multiline (fun)
"Protect FUN from inf-looping at ‘point-max’.
FUN is `font-lock-extend-region-multiline'. Propagate only real
changes."
;; fixme: report this ASAP!
(let ((obeg font-lock-beg)
(oend font-lock-end)
(change (funcall fun)))
(and change
(not (eq obeg font-lock-beg))
(not (eq oend font-lock-end)))))
(pm-around-advice #'font-lock-extend-region-multiline
#'pm-check-for-real-change-in-extend-multiline)
;;; Editing
;; (pm-around-advice 'fill-paragraph #'pm-execute-narrowed-to-span)
;; (advice-remove 'fill-paragraph #'pm-execute-narrowed-to-span)
;; Synchronization of points does not work always as expected because some low
;; level functions move indirect buffers' points when operate in the base
;; buffer. See comment in `polymode-with-current-base-buffer'.
;; (defun polymode-with-save-excursion (orig-fun &rest args)
;; "Execute ORIG-FUN surrounded with `save-excursion'.
;; This function is intended to be used in advises of functions
;; which modify the buffer in the background and thus trigger
;; `pm-switch-to-buffer' on next post-command hook in a wrong place.
;; ARGS are passed to ORIG-FUN."
;; (if polymode-mode
;; (save-excursion
;; (apply orig-fun args))
;; (apply orig-fun args)))
;;
;; `save-buffer` misbehaves because after each replacement modification hooks
;; are triggered and poly buffer is switched in unpredictable fashion (#93).
;; This happens because basic-save-buffer uses save-buffer but not
;; save-excursion. Thus if base and indirect buffer don't have same point, at
;; the end of the function inner buffer will have the point from the base
;; buffer. Can be reproduced with (add-hook 'before-save-hook
;; 'delete-trailing-whitespace nil t) in the base buffer.
;;
;; (pm-around-advice 'basic-save-buffer #'polymode-with-save-excursion)
;; (advice-remove 'basic-save-buffer #'polymode-with-save-excursion)
;; Query replace were probably misbehaving due to unsaved match data (#92). The
;; following is probably not necessary. (pm-around-advice 'perform-replace
;; 'pm-execute-inhibit-modification-hooks)
;; No longer needed. See comment at pm-switch-to-buffer.
;; (defun polymode-newline-remove-hook-in-orig-buffer (fn &rest args)
;; "`newline' temporary sets `post-self-insert-hook' and removes it in wrong buffer.
;; This ARGS are passed to `newline'."
;; (if polymode-mode
;; (let* ((cbuf (current-buffer))
;; (old-hook (buffer-local-value 'post-self-insert-hook cbuf)))
;; (prog1 (apply fn args)
;; (unless (eq cbuf (current-buffer))
;; (unless (eq old-hook (buffer-local-value 'post-self-insert-hook cbuf))
;; (with-current-buffer cbuf
;; (if old-hook
;; (setq post-self-insert-hook old-hook)
;; (kill-local-variable 'post-self-insert-hook)))))))
;; (apply fn args)))
;; (pm-around-advice 'newline #'polymode-newline-remove-hook-in-orig-buffer)
;;; DESKTOP SAVE #194 #240
;; NB: desktop-save will not save indirect buffer.
;; For base buffer, if it's hidden as per #34, we will save it unhide by removing left whitespaces.
(defun polymode-fix-desktop-buffer-info (fn buffer)
"Unhide poly-mode base buffer which is hidden as per #34.
This is done by modifying `uniquify-buffer-base-name' to `pm--core-buffer-name'."
(with-current-buffer buffer
(let ((out (funcall fn buffer)))
(when (and polymode-mode
(not (buffer-base-buffer))
(not (car out)))
(setf (car out) pm--core-buffer-name))
out)))
(declare-function desktop-buffer-info "desktop")
(with-eval-after-load "desktop"
(advice-add #'desktop-buffer-info :around #'polymode-fix-desktop-buffer-info))
(defun polymode-fix-desktop-save-buffer-p (_ bufname &rest _args)
"Dont save polymode buffers which are indirect buffers."
(with-current-buffer bufname
(not (and polymode-mode
(buffer-base-buffer)))))
(declare-function desktop-save-buffer-p "desktop")
(with-eval-after-load "desktop"
(advice-add #'desktop-save-buffer-p :before-while #'polymode-fix-desktop-save-buffer-p))
;;; MATLAB #199
;; matlab-mode is an old non-standard mode which doesn't trigger
;; `after-change-major-mode-hook`. As a result polymode cannot detect that
;; font-lock-mode is on and sets the `poly-lock-allow-fontification` to nil.
;; Explicitly trigger font-lock as a workaround.
(add-hook 'matlab-mode-hook (lambda () (font-lock-mode t)))
;;; Undo Tree (#230)
;; Not clear why this fix works, or even why the problem occurs.
(declare-function make-undo-tree "undo-tree")
(defvar buffer-undo-tree)
(defun polymode-init-undo-tree-maybe ()
(when (and (boundp 'undo-tree-mode)
undo-tree-mode
(null buffer-undo-tree))
(setq buffer-undo-tree (make-undo-tree))))
(eval-after-load 'undo-tree
'(add-hook 'polymode-init-inner-hook 'polymode-init-undo-tree-maybe))
;;; EVIL
(declare-function evil-change-state "evil-core")
(defun polymode-switch-buffer-keep-evil-state-maybe (old-buffer new-buffer)
(when (and (boundp 'evil-state)
evil-state)
(let ((old-state (buffer-local-value 'evil-state old-buffer))
(new-state (buffer-local-value 'evil-state new-buffer)))
(unless (eq old-state new-state)
(with-current-buffer new-buffer
(evil-change-state old-state))))))
(eval-after-load 'evil-core
'(add-hook 'polymode-after-switch-buffer-hook 'polymode-switch-buffer-keep-evil-state-maybe))
;;; HL line
(defvar hl-line-mode)
(defvar global-hl-line-mode)
(declare-function hl-line-unhighlight "hl-line")
(declare-function global-hl-line-unhighlight "hl-line")
(add-to-list 'polymode-move-these-minor-modes-from-old-buffer 'hl-line-mode)
(defun polymode-switch-buffer-hl-unhighlight (old-buffer _new-buffer)
(with-current-buffer old-buffer
;; We are moving hl-line-mode already
(when hl-line-mode
(hl-line-unhighlight))
(when global-hl-line-mode
(global-hl-line-unhighlight))))
(eval-after-load 'hl-line
'(add-hook 'polymode-after-switch-buffer-hook 'polymode-switch-buffer-hl-unhighlight))
;;; YAS
(with-eval-after-load "yasnippet"
(add-hook 'yas-before-expand-snippet-hook #'polymode-disable-post-command)
(add-hook 'yas-after-exit-snippet-hook #'polymode-enable-post-command))
(provide 'polymode-compat)
;;; Multiple cursors
(defvar mc--executing-command-for-fake-cursor)
(defun polymode-disable-post-command-with-multiple-cursors (orig-fun &rest args)
(unless mc--executing-command-for-fake-cursor
(polymode-disable-post-command)
(apply orig-fun args)
(polymode-enable-post-command)))
(with-no-warnings
(with-eval-after-load "multiple-cursors-core"
(advice-add #'mc/execute-this-command-for-all-cursors :around
#'polymode-disable-post-command-with-multiple-cursors)))
;;; polymode-compat.el ends here

2139
lisp/polymode/polymode-core.el Normal file
View File

File diff suppressed because it is too large Load Diff

557
lisp/polymode/polymode-debug.el Normal file
View File

@@ -0,0 +1,557 @@
;;; polymode-debug.el --- Interactive debugging utilities for polymode -*- lexical-binding: t -*-
;;
;; Copyright (C) 2016-2018 Vitalie Spinu
;; Author: Vitalie Spinu
;; URL: https://github.com/polymode/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 GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Commentary:
;;
;;; Code:
(require 'polymode-core)
(require 'poly-lock)
(require 'trace)
;;; MINOR MODE
(defvar pm--underline-overlay
(let ((overlay (make-overlay (point) (point))))
(overlay-put overlay 'face '(:underline (:color "tomato" :style wave)))
overlay)
"Overlay used in function `pm-debug-mode'.")
(defvar pm--highlight-overlay
(let ((overlay (make-overlay (point) (point))))
(overlay-put overlay 'face '(:inverse-video t))
overlay)
"Overlay used by `pm-debug-map-over-spans-and-highlight'.")
(defvar pm-debug-minor-mode-map
(let ((map (make-sparse-keymap)))
(define-key map (kbd "M-n M-i") #'pm-debug-info-on-current-span)
(define-key map (kbd "M-n i") #'pm-debug-info-on-current-span)
(define-key map (kbd "M-n M-p") #'pm-debug-relevant-variables)
(define-key map (kbd "M-n p") #'pm-debug-relevant-variables)
(define-key map (kbd "M-n M-h") #'pm-debug-map-over-spans-and-highlight)
(define-key map (kbd "M-n h") #'pm-debug-map-over-spans-and-highlight)
(define-key map (kbd "M-n M-t t") #'pm-toggle-tracing)
(define-key map (kbd "M-n M-t i") #'pm-debug-toogle-info-message)
(define-key map (kbd "M-n M-t f") #'pm-debug-toggle-fontification)
(define-key map (kbd "M-n M-t p") #'pm-debug-toggle-post-command)
(define-key map (kbd "M-n M-t c") #'pm-debug-toggle-after-change)
(define-key map (kbd "M-n M-t a") #'pm-debug-toggle-all)
(define-key map (kbd "M-n M-t M-t") #'pm-toggle-tracing)
(define-key map (kbd "M-n M-t M-i") #'pm-debug-toogle-info-message)
(define-key map (kbd "M-n M-t M-f") #'pm-debug-toggle-fontification)
(define-key map (kbd "M-n M-t M-p") #'pm-debug-toggle-post-command)
(define-key map (kbd "M-n M-t M-c") #'pm-debug-toggle-after-change)
(define-key map (kbd "M-n M-t M-a") #'pm-debug-toggle-all)
(define-key map (kbd "M-n M-f s") #'pm-debug-fontify-current-span)
(define-key map (kbd "M-n M-f b") #'pm-debug-fontify-current-buffer)
(define-key map (kbd "M-n M-f M-t") #'pm-debug-toggle-fontification)
(define-key map (kbd "M-n M-f M-s") #'pm-debug-fontify-current-span)
(define-key map (kbd "M-n M-f M-b") #'pm-debug-fontify-current-buffer)
map))
;;;###autoload
(define-minor-mode pm-debug-minor-mode
"Turns on/off useful facilities for debugging polymode.
Key bindings:
\\{pm-debug-minor-mode-map}"
nil
" PMDBG"
:group 'polymode
(if pm-debug-minor-mode
(progn
;; this is global hook. No need to complicate with local hooks
(add-hook 'post-command-hook 'pm-debug-highlight-current-span))
(delete-overlay pm--underline-overlay)
(delete-overlay pm--highlight-overlay)
(remove-hook 'post-command-hook 'pm-debug-highlight-current-span)))
;;;###autoload
(defun pm-debug-minor-mode-on ()
;; activating everywhere (in case font-lock infloops in a polymode buffer )
;; this doesn't activate in fundamental mode
(unless (eq major-mode 'minibuffer-inactive-mode)
(pm-debug-minor-mode t)))
;;;###autoload
(define-globalized-minor-mode pm-debug-mode pm-debug-minor-mode pm-debug-minor-mode-on)
;;; INFO
(cl-defgeneric pm-debug-info (chunkmode))
(cl-defmethod pm-debug-info (chunkmode)
(eieio-object-name chunkmode))
(cl-defmethod pm-debug-info ((chunkmode pm-inner-chunkmode))
(format "%s head-matcher:\"%s\" tail-matcher:\"%s\""
(cl-call-next-method)
(eieio-oref chunkmode 'head-matcher)
(eieio-oref chunkmode 'tail-matcher)))
(cl-defmethod pm-debug-info ((_chunkmode pm-inner-auto-chunkmode))
(cl-call-next-method))
(defvar syntax-ppss-wide)
(defvar syntax-ppss-last)
(defun pm--debug-info (&optional span as-list)
(let* ((span (or span (and polymode-mode (pm-innermost-span))))
(message-log-max nil)
(beg (nth 1 span))
(end (nth 2 span))
(obj (nth 3 span))
(type (and span (or (car span) 'host))))
(let ((out (list (current-buffer)
(point-min) (point) (point-max)
major-mode
type beg end
(and obj (pm-debug-info obj))
(format "lppss:%s"
(if pm--emacs>26
(car syntax-ppss-wide)
syntax-ppss-last)))))
(if as-list
out
(apply #'format
"(%s) min:%d pos:%d max:%d || (%s) type:%s span:%s-%s %s %s"
out)))))
(defun pm-debug-info-on-current-span (no-cache)
"Show info on current span.
With NO-CACHE prefix, don't use cached values of the span."
(interactive "P")
(if (not polymode-mode)
(message "not in a polymode buffer")
(let ((span (pm-innermost-span nil no-cache)))
(message (pm--debug-info span))
;; (move-overlay pm--highlight-overlay (nth 1 span) (nth 2 span) (current-buffer))
(pm-debug-flick-region (nth 1 span) (nth 2 span)))))
(defun pm-debug-report-points (&optional where)
(when polymode-mode
(let* ((bufs (eieio-oref pm/polymode '-buffers))
(poses (mapcar (lambda (b)
(format "%s:%d" b (with-current-buffer b (point))))
bufs)))
(message "<%s> cb:%s %s" (or where "") (current-buffer) poses)))
nil)
;;; TOGGLING
(defvar pm-debug-display-info-message nil)
(defun pm-debug-toogle-info-message ()
"Toggle permanent info display."
(interactive)
(setq pm-debug-display-info-message (not pm-debug-display-info-message)))
(defvar poly-lock-allow-fontification)
(defun pm-debug-toggle-fontification ()
"Enable or disable fontification in polymode buffers."
(interactive)
(if poly-lock-allow-fontification
(progn
(message "fontificaiton disabled")
(dolist (b (buffer-list))
(with-current-buffer b
(when polymode-mode
(setq poly-lock-allow-fontification nil
font-lock-mode nil
fontification-functions nil)))))
(message "fontificaiton enabled")
(dolist (b (buffer-list))
(with-current-buffer b
(when polymode-mode
(setq poly-lock-allow-fontification t
font-lock-mode t
fontification-functions '(poly-lock-function)))))))
(defun pm-debug-toggle-after-change ()
"Allow or disallow polymode actions in `after-change-functions'."
(interactive)
(if pm-allow-after-change-hook
(progn
(message "after-change disabled")
(setq pm-allow-after-change-hook nil))
(message "after-change enabled")
(setq pm-allow-after-change-hook t)))
(defun pm-debug-toggle-post-command ()
"Allow or disallow polymode actions in `post-command-hook'."
(interactive)
(if pm-allow-post-command-hook
(progn
(message "post-command disabled")
(setq pm-allow-post-command-hook nil))
(message "post-command enabled")
(setq pm-allow-post-command-hook t)))
(defun pm-debug-toggle-all ()
"Toggle all polymode guards back and forth."
(interactive)
(if poly-lock-allow-fontification
(progn
(message "fontificaiton, after-chnage and command-hook disabled")
(setq poly-lock-allow-fontification nil
pm-allow-after-change-hook nil
pm-allow-post-command-hook nil))
(message "fontificaiton, after-change and command-hook enabled")
(setq poly-lock-allow-fontification t
pm-allow-after-change-hook t
pm-allow-post-command-hook t)))
;;; FONT-LOCK
(defun pm-debug-fontify-current-span ()
"Fontify current span."
(interactive)
(let ((span (pm-innermost-span))
(poly-lock-allow-fontification t))
(poly-lock-flush (nth 1 span) (nth 2 span))
(poly-lock-fontify-now (nth 1 span) (nth 2 span))))
(defun pm-debug-fontify-current-buffer ()
"Fontify current buffer."
(interactive)
(let ((poly-lock-allow-fontification t))
(font-lock-unfontify-buffer)
(poly-lock-flush (point-min) (point-max))
(poly-lock-fontify-now (point-min) (point-max))))
;;; TRACING
(defvar pm-traced-functions
'(
;; core initialization
(0 (pm-initialize
pm--common-setup
pm--mode-setup))
;; core hooks
(1 (polymode-post-command-select-buffer
polymode-after-kill-fixes
;; this one indicates the start of a sequence
poly-lock-after-change))
;; advises
(2 (pm-override-output-cons
pm-around-advice
polymode-with-current-base-buffer))
;; font-lock
(3 (font-lock-default-fontify-region
font-lock-fontify-keywords-region
font-lock-fontify-region
font-lock-fontify-syntactically-region
font-lock-unfontify-region
jit-lock--run-functions
jit-lock-fontify-now
poly-lock--after-change-internal
poly-lock--extend-region
poly-lock--extend-region-span
poly-lock-after-change
poly-lock-flush
poly-lock-fontify-now
poly-lock-function))
;; syntax
(4 (syntax-ppss
pm--call-syntax-propertize-original
polymode-syntax-propertize
polymode-restrict-syntax-propertize-extension
pm-flush-syntax-ppss-cache
pm--reset-ppss-cache))
;; core functions
(5 (pm-select-buffer
pm-map-over-spans
pm--get-intersected-span
pm--cached-span))
;; (13 . "^syntax-")
(14 . "^polymode-")
(15 . "^pm-")))
(defvar pm--do-trace nil)
;;;###autoload
(defun pm-toggle-tracing (level)
"Toggle polymode tracing.
With numeric prefix toggle tracing for that LEVEL. Currently
universal argument toggles maximum level of tracing (4). Default
level is 3."
(interactive "P")
(setq level (prefix-numeric-value (or level 3)))
(with-current-buffer (get-buffer-create "*Messages*")
(read-only-mode -1))
(setq pm--do-trace (not pm--do-trace))
(if pm--do-trace
(progn (dolist (kv pm-traced-functions)
(when (<= (car kv) level)
(if (stringp (cdr kv))
(pm-trace-functions-by-regexp (cdr kv))
(dolist (fn (cadr kv))
(pm-trace fn)))))
(message "Polymode tracing activated"))
(untrace-all)
(message "Polymode tracing deactivated")))
;;;###autoload
(defun pm-trace (fn)
"Trace function FN.
Use `untrace-function' to untrace or `untrace-all' to untrace all
currently traced functions."
(interactive (trace--read-args "Trace: "))
(let ((buff (get-buffer "*Messages*")))
(unless (advice-member-p trace-advice-name fn)
(advice-add
fn :around
(let ((advice (trace-make-advice
fn buff 'background
#'pm-trace--tracing-context)))
(lambda (body &rest args)
(when (eq fn 'polymode-flush-syntax-ppss-cache)
(with-current-buffer buff
(save-excursion
(goto-char (point-max))
(insert "\n"))))
(if polymode-mode
(apply advice body args)
(apply body args))))
`((name . ,trace-advice-name)
(depth . -100))))))
(defun pm-trace-functions-by-regexp (regexp)
"Trace all functions whose name matched REGEXP."
(interactive "sRegex: ")
(cl-loop for sym being the symbols
when (and (fboundp sym)
(not (memq sym '(pm-toggle-tracing
pm-trace--tracing-context
pm-format-span
pm-fun-matcher
pm--find-tail-from-head)))
(not (string-match "^pm-\\(trace\\|debug\\)" (symbol-name sym)))
(string-match regexp (symbol-name sym)))
do (pm-trace sym)))
(defun pm-trace--tracing-context ()
(let ((span (or *span*
(get-text-property (point) :pm-span))))
(format " [%s pos:%d(%d-%d) %s%s (%f)]"
(current-buffer) (point) (point-min) (point-max)
(or (when span
(when (not (and (= (point-min) (nth 1 span))
(= (point-max) (nth 2 span))))
"UNPR "))
"")
(when span
(pm-format-span span))
(float-time))))
;; fix object printing
(defun pm-trace--fix-1-arg-for-tracing (arg)
(cond
((eieio-object-p arg) (eieio-object-name arg))
((and (listp arg) (eieio-object-p (nth 3 arg)))
(list (nth 0 arg) (nth 1 arg) (nth 2 arg) (eieio-object-name (nth 3 arg))))
(arg)))
(defun pm-trace--fix-args-for-tracing (orig-fn fn level args context)
(let ((args (or (and (listp args)
(listp (cdr args))
(ignore-errors (mapcar #'pm-trace--fix-1-arg-for-tracing args)))
args)))
(funcall orig-fn fn level args context)))
(advice-add #'trace-entry-message :around #'pm-trace--fix-args-for-tracing)
(advice-add #'trace-exit-message :around #'pm-trace--fix-args-for-tracing)
;; (advice-remove #'trace-entry-message #'pm-trace--fix-args-for-tracing)
;; (advice-remove #'trace-exit-message #'pm-trace--fix-args-for-tracing)
;;; RELEVANT VARIABLES
(defvar pm-debug-relevant-variables
`(:change
(before-change-functions after-change-functions)
:command (pre-command-hook
post-command-hook)
:font-lock (fontification-functions
font-lock-function
font-lock-flush-function
font-lock-ensure-function
font-lock-fontify-region-function
font-lock-fontify-buffer-function
font-lock-unfontify-region-function
font-lock-unfontify-buffer-function
jit-lock-after-change-extend-region-functions
jit-lock-functions
poly-lock-defer-after-change)
;; If any of these are reset by host mode it can create issues with
;; font-lock and syntax (e.g. scala-mode in #195)
:search (parse-sexp-lookup-properties
parse-sexp-ignore-comments
;; (syntax-table)
;; font-lock-syntax-table
case-fold-search)
:indent (indent-line-function
indent-region-function
pm--indent-line-function-original)
:revert (revert-buffer-function
before-revert-hook
after-revert-hook)
:save (after-save-hook
before-save-hook
write-contents-functions
local-write-file-hooks
write-file-functions)
:syntax (syntax-propertize-function
syntax-propertize-extend-region-functions
pm--syntax-propertize-function-original)))
;;;###autoload
(defun pm-debug-relevant-variables (&optional out-type)
"Get the relevant polymode variables.
If OUT-TYPE is 'buffer, print the variables in the dedicated
buffer, if 'message issue a message, if nil just return a list of values."
(interactive (list 'buffer))
(let* ((cbuff (current-buffer))
(vars (cl-loop for v on pm-debug-relevant-variables by #'cddr
collect (cons (car v)
(mapcar (lambda (v)
(cons v (buffer-local-value v cbuff)))
(cadr v))))))
(require 'pp)
(cond
((eq out-type 'buffer)
(with-current-buffer (get-buffer-create "*polymode-vars*")
(erase-buffer)
(goto-char (point-max))
(insert (format "\n================== %s ===================\n" cbuff))
(insert (pp-to-string vars))
(toggle-truncate-lines -1)
(goto-char (point-max))
(view-mode)
(display-buffer (current-buffer))))
((eq out-type 'message)
(message "%s" (pp-to-string vars)))
(t vars))))
(defun pm-debug-diff-local-vars (&optional buffer1 buffer2)
"Print differences between local variables in BUFFER1 and BUFFER2."
(interactive)
(let* ((buffer1 (or buffer1 (read-buffer "Buffer1: " (buffer-name (current-buffer)))))
(buffer2 (or buffer2 (read-buffer "Buffer2: " (buffer-name (nth 2 (buffer-list))))))
(vars1 (buffer-local-variables (get-buffer buffer1)))
(vars2 (buffer-local-variables (get-buffer buffer2)))
(all-keys (delete-dups (append (mapcar #'car vars1)
(mapcar #'car vars2))))
(out-buf (get-buffer-create "*pm-debug-output")))
(with-current-buffer out-buf
(erase-buffer)
(pp (delq nil
(mapcar (lambda (k)
(let ((val1 (cdr (assoc k vars1)))
(val2 (cdr (assoc k vars2))))
(unless (equal val1 val2)
(list k val1 val2))))
all-keys))
out-buf))
(pop-to-buffer out-buf)))
;;; HIGHLIGHT
(defun pm-debug-highlight-current-span ()
(when polymode-mode
(with-silent-modifications
(unless (memq this-command '(pm-debug-info-on-current-span
pm-debug-highlight-last-font-lock-error-region))
(delete-overlay pm--highlight-overlay))
(condition-case-unless-debug err
(let ((span (pm-innermost-span)))
(when pm-debug-display-info-message
(message (pm--debug-info span)))
(move-overlay pm--underline-overlay (nth 1 span) (nth 2 span) (current-buffer)))
(error (message "%s" (error-message-string err)))))))
(defun pm-debug-flick-region (start end &optional delay)
(move-overlay pm--highlight-overlay start end (current-buffer))
(run-with-timer (or delay 0.4) nil (lambda () (delete-overlay pm--highlight-overlay))))
(defun pm-debug-map-over-spans-and-highlight ()
"Map over all spans in the buffer and highlight briefly."
(interactive)
(pm-map-over-spans (lambda (span)
(let ((start (nth 1 span))
(end (nth 2 span)))
(pm-debug-flick-region start end)
(sit-for 1)))
(point-min) (point-max) nil nil t))
(defun pm-debug-map-over-modes-and-highlight (&optional beg end)
"Map over all spans between BEG and END and highlight modes."
(interactive)
(let ((cbuf (current-buffer)))
(pm-map-over-modes
(lambda (beg end)
(goto-char beg)
;; (dbg beg end (pm-format-span))
(with-current-buffer cbuf
(recenter-top-bottom)
(pm-debug-flick-region (max beg (point-min))
(min end (point-max))))
(sit-for 1))
(or beg (point-min))
(or end (point-max)))))
(defun pm-debug-run-over-check (no-cache)
"Map over all spans and report the time taken.
Switch to buffer is performed on every position in the buffer.
On prefix NO-CACHE don't use cached spans."
(interactive)
(goto-char (point-min))
(let ((start (current-time))
(count 1)
(pm-initialization-in-progress no-cache))
(pm-switch-to-buffer)
(while (< (point) (point-max))
(setq count (1+ count))
(forward-char)
(pm-switch-to-buffer))
(let ((elapsed (float-time (time-subtract (current-time) start))))
(message "Elapsed: %s per-char: %s" elapsed (/ elapsed count)))))
(defun pm-dbg (msg &rest args)
(let ((cbuf (current-buffer))
(cpos (point)))
(with-current-buffer (get-buffer-create "*pm-dbg*")
(save-excursion
(goto-char (point-max))
(insert "\n")
(insert (apply 'format (concat "%f [%s at %d]: " msg)
(float-time) cbuf cpos args))))))
(provide 'polymode-debug)
;;; polymode-debug.el ends here

449
lisp/polymode/polymode-export.el Normal file
View File

@@ -0,0 +1,449 @@
;;; polymode-export.el --- Exporting facilities for polymodes -*- lexical-binding: t -*-
;;
;; Copyright (C) 2013-2019, Vitalie Spinu
;; Author: Vitalie Spinu
;; URL: https://github.com/polymode/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 GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Commentary:
;;
;;; Code:
(require 'polymode-core)
(require 'polymode-classes)
(defgroup polymode-export nil
"Polymode Exporters"
:group 'polymode)
(defcustom polymode-exporter-output-file-format "%s-exported"
"Format of the exported files.
%s is substituted with the current file name sans extension."
:group 'polymode-export
:type 'string)
(defclass pm-exporter (pm-root)
((from
:initarg :from
:initform '()
:type list
:custom list
:documentation
"Input exporter specifications.
This is an alist of elements of the form (id regexp doc
commmand) or (id . selector). ID is the unique identifier of
the spec. REGEXP is a regexp which, if matched on current
file name, implies that the current file can be exported
with this specification. DOC is a short help string shown
during interactive export. COMMAND is the exporter
command (string). It can contain the following format specs:
%i - input file (no dir)
%I - input file (full path)
%o - output file (no dir)
%O - output file (full path)
%b - output file (base name only)
%t - 4th element of the :to spec
When specification is of the form (id . selector), SELECTOR
is a function of variable arguments that accepts at least
one argument ACTION. ACTION is a symbol and can be one of
the following:
match - must return non-nil if this specification
applies to the file that current buffer is visiting,
or :nomatch if specification does not apply. This
selector can receive an optional file-name
argument. In that case the decision must be made
solely on that file and current buffer must be
ignored. This is useful for matching exporters to
weavers when exported file does not exist yet.
regexp - return a string which is used to match input
file name. If nil, `match' selector must return
non-nil value. This selector is ignored if `match'
returned non-nil.
doc - return documentation string
commmand - return a string with optional %i, %f,
etc. format specs as described above. It will be
passed to the processing :function.")
(to
:initarg :to
:initform '()
:type list
:custom list
:documentation
"
Output specifications alist. Each element is either a list
of the form (id ext doc t-spec) or a cons (id . selector).
In the former case EXT is an extension of the output file.
DOC is a short documentation string. t-spec is a string what
is substituted instead of %t in :from spec commmand.
`t-spec' can be a list of one element '(command), in which
case the whole :from spec command is substituted with
command from %t-spec.
When specification is of the form (id . selector), SELECTOR
is a function of variable arguments with first two arguments
being ACTION and ID of the specification. This function is
called in a buffer visiting input file. ACTION is a symbol
and can one of the following:
output-file - return an output file name or a list of file
names. Receives input-file as argument. If this
command returns nil, the output is built from input
file and value of 'output-ext command.
This selector can also return a function. This
function will be called in the callback or sentinel of
the weaving process after the weaving was
completed. This function should sniff the output of
the process for errors or file names. It must return a
file name, a list of file names or nil if no such
files have been detected.
ext - extension of output file. If nil and `output-file'
also returned nil, the exporter won't be able to
identify the output file and no automatic display or
preview will be available.
doc - return documentation string
command - return a string to be used instead of
the :from command. If nil, :from spec command is used.
t-spec - return a string to be substituted as %t :from
spec in :from command. If `command' selector returned
non-nil, this spec is ignored.")
(function
:initarg :function
:initform (lambda (command from to)
(error "Function not defined for this exporter"))
:type (or symbol function)
:documentation
"Function to process the commmand. Must take 3 arguments
COMMAND, FROM-ID and TO-ID and return an output file name or
a list of output file names. COMMAND is the 4th argument of
:from spec with all the formats substituted. FROM-ID is the
id of requested :from spec, TO-ID is the id of the :to
spec."))
"Root exporter class.")
(defclass pm-callback-exporter (pm-exporter)
((callback
:initarg :callback
:initform nil
:type (or symbol function)
:documentation
"Callback function to be called by function in :function
slot. Callback must return an output file name or a list of
output file-names. There is no default callback."))
"Class to represent asynchronous exporters.
:function slot must be a function with 4 arguments COMMAND,
CALLBACK, FROM-ID and TO-ID.")
(defclass pm-shell-exporter (pm-exporter)
((function
:initform 'pm-default-shell-export-function)
(sentinel
:initarg :sentinel
:initform 'pm-default-shell-export-sentinel
:type (or symbol function)
:documentation
"Sentinel function to be called by :function when a shell
call is involved. Sentinel should return the output file
name.")
(quote
:initarg :quote
:initform nil
:type boolean
:documentation "Non-nil when file arguments must be quoted
with `shell-quote-argument'."))
"Class to represent exporters that call external processes.")
(defun pm-default-shell-export-function (command sentinel from to)
"Run exporting COMMAND interactively to convert FROM to TO.
Run command in a buffer (in comint-shell-mode) so that it accepts
user interaction. This is a default function in all exporters
that call a shell command. SENTINEL is the process sentinel."
(pm--run-shell-command command sentinel "*polymode export*"
(concat "Exporting " from "-->" to " with command:\n\n "
command "\n\n")))
;;; METHODS
(cl-defgeneric pm-export (exporter from to &optional ifile)
"Process IFILE with EXPORTER.")
(cl-defmethod pm-export ((exporter pm-exporter) from to &optional ifile)
(pm--process-internal exporter from to ifile))
(cl-defmethod pm-export ((exporter pm-callback-exporter) from to &optional ifile)
(let ((cb (pm--wrap-callback exporter :callback ifile)))
(pm--process-internal exporter from to ifile cb)))
(cl-defmethod pm-export ((exporter pm-shell-exporter) from to &optional ifile)
(let ((cb (pm--wrap-callback exporter :sentinel ifile)))
(pm--process-internal exporter from to ifile cb (eieio-oref exporter 'quote))))
;; UI
(defvar pm--exporter-hist nil)
(defvar pm--export:from-hist nil)
(defvar pm--export:from-last nil)
(defvar pm--export:to-hist nil)
(defvar pm--export:to-last nil)
(declare-function polymode-set-weaver "polymode-weave")
(declare-function pm-weave "polymode-weave")
(defun polymode-export (&optional from to)
"Export current file.
FROM and TO are the ids of the :from and :to slots of the current
exporter. If the current exporter hasn't been set yet, set the
exporter with `polymode-set-exporter'. You can always change the
exporter manually by invoking `polymode-set-exporter'.
When FROM or TO are missing they are determined automatically
from the current exporter's specifications and file's
extension. If no appropriate export specification has been found,
look into current weaver and try to match weaver's output to
exporters input extension. When such combination is possible,
settle on weaving first and exporting the weaved output. When
none of the above worked, ask the user for `from' and `to' specs.
When called with prefix argument, ask for FROM and TO
interactively. See constructor function ‘pm-exporter’ for the
complete specification."
(interactive "P")
(cl-flet ((to-name.id (el) (let* ((ext (funcall (cdr el) 'ext (car el)))
(name (if ext
(format "%s (%s)" (funcall (cdr el) 'doc (car el)) ext)
(funcall (cdr el) 'doc (car el)))))
(cons name (car el))))
(from-name.id (el) (cons (funcall (cdr el) 'doc (car el)) (car el))))
(let* ((exporter (symbol-value (or (eieio-oref pm/polymode 'exporter)
(polymode-set-exporter t))))
(fname (file-name-nondirectory buffer-file-name))
(gprompt nil)
(case-fold-search t)
(from-opts (mapcar #'from-name.id (pm--selectors exporter :from)))
(from-id
(cond
;; A: guess from spec
((null from)
(or
;; 1. repeated export; don't ask
pm--export:from-last
;; 2. select :from entries which match to current context
(let ((matched (pm--matched-selectors exporter :from)))
(when matched
(if (> (length matched) 1)
(cdr (pm--completing-read "Multiple `from' specs matched. Choose one: "
(mapcar #'from-name.id matched)))
(caar matched))))
;; 3. guess from weaver and return a cons (weaver-id . exporter-id)
(let ((weaver (symbol-value (or (eieio-oref pm/polymode 'weaver)
(progn
(setq gprompt "Choose `from' spec: ")
(polymode-set-weaver))))))
(when weaver
;; fixme: weaver was not yet ported to selectors
;; fixme: currently only first match is returned
(let ((pair (cl-loop for w in (eieio-oref weaver 'from-to)
;; weaver input extension matches the filename
if (string-match-p (nth 1 w) fname)
return (cl-loop for el in (pm--selectors exporter :from)
;; input exporter extensnion matches weaver output extension
when (pm--selector-match el (concat "dummy." (nth 2 w)))
return (cons (car w) (car el))))))
(when pair
(message "Matching weaver found. Weaving to '%s' first." (car pair))
pair))))
;; 4. nothing matched; ask
(let* ((prompt (or gprompt "No `from' specs matched. Choose one: "))
(sel (pm--completing-read prompt from-opts nil t nil 'pm--export:from-hist)))
(cdr sel))))
;; B: C-u, force a :from spec
((equal from '(4))
(cdr (if (> (length from-opts) 1)
(pm--completing-read "Input type: " from-opts nil t nil 'pm--export:from-hist)
(car from-opts))))
;; C. string
((stringp from)
(if (assoc from (eieio-oref exporter 'from))
from
(error "Cannot find `from' spec '%s' in %s exporter"
from (eieio-object-name exporter))))
;; D. error
(t (error "'from' argument must be nil, universal argument or a string"))))
(to-opts (mapcar #'to-name.id (pm--selectors exporter :to)))
(to-id
(cond
;; A. guess from spec
((null to)
(or
;; 1. repeated export; don't ask and use first entry in history
(unless (equal from '(4))
pm--export:to-last)
;; 2. First export or C-u
(if (= (length to-opts) 1)
(cdar to-opts)
(cdr (pm--completing-read "Export to: " to-opts nil t nil 'pm--export:to-hist)))))
;; B. string
((stringp to)
(if (assoc to (eieio-oref exporter 'to))
to
(error "Cannot find output spec '%s' in %s exporter"
to (eieio-object-name exporter))))
;; C . Error
(t (error "'to' argument must be nil or a string")))))
(setq-local pm--export:from-last from-id)
(setq-local pm--export:to-last to-id)
(if (consp from-id)
;; run through weaver
(let ((pm--export-spec (cons (cdr from-id) to-id))
(pm--output-not-real t))
(pm-weave (symbol-value (eieio-oref pm/polymode 'weaver)) (car from-id)))
(pm-export exporter from-id to-id)))))
(defun polymode-set-exporter (&optional no-ask-if-1)
"Interactively set exporter for the current file.
If NO-ASK-IF-1 is non-nil, don't ask if there is only one exporter."
(interactive)
(unless pm/polymode
(error "No pm/polymode object found. Not in polymode buffer?"))
(let* ((weavers (delete-dups (pm--oref-with-parents pm/polymode :weavers)))
(exporters (pm--abrev-names
"pm-exporter/\\|-exporter"
(cl-delete-if-not
(lambda (el)
(or (pm--matched-selectors el :from)
;; FIXME: rewrite this abomination
;; Match weaver to the exporter.
(cl-loop for weaver in weavers
if (cl-loop for w in (eieio-oref (symbol-value weaver) 'from-to)
;; weaver input extension matches the filename
if (string-match-p (nth 1 w) buffer-file-name)
return (cl-loop for el in (pm--selectors (symbol-value el) :from)
;; input exporter extensnion matches weaver output extension
when (pm--selector-match el (concat "dummy." (nth 2 w)))
return t))
return t)))
(delete-dups (pm--oref-with-parents pm/polymode :exporters)))))
(sel (if exporters
(if (and no-ask-if-1 (= (length exporters) 1))
(car exporters)
(pm--completing-read "Choose exporter: " exporters nil t nil 'pm--exporter-hist))
(user-error "No valid exporters in current context")))
(out (intern (cdr sel))))
(setq pm--exporter-hist (delete-dups pm--exporter-hist))
(setq-local pm--export:from-last nil)
(setq-local pm--export:to-last nil)
(oset pm/polymode :exporter out)
out))
(defmacro polymode-register-exporter (exporter default &rest configs)
"Add EXPORTER to :exporters slot of all config objects in CONFIGS.
When DEFAULT is non-nil, also make EXPORTER the default exporter
for each polymode in CONFIGS."
`(dolist (pm ',configs)
(object-add-to-list (symbol-value pm) :exporters ',exporter)
(when ,default (oset (symbol-value pm) :exporter ',exporter))))
;;; GLOBAL EXPORTERS
(define-obsolete-variable-alias 'pm-exporter/pandoc 'poly-pandoc-exporter "v0.2")
(defcustom poly-pandoc-exporter
(pm-shell-exporter
:name "pandoc"
:from
'(;; ("json" "\\.json\\'" "JSON native AST" "pandoc %i -f json -t %t -o %o")
("markdown" "\\.md\\'" "pandoc's markdown" "pandoc %i -f markdown -t %t -o %o")
("markdown_strict" "\\.md\\'" "original markdown" "pandoc %i -f markdown_strict -t %t -o %o")
("markdown_phpextra" "\\.md\\'" "PHP markdown" "pandoc %i -f markdown_phpextra -t %t -o %o")
("markdown_phpextra" "\\.md\\'" "github markdown" "pandoc %i -f markdown_phpextra -t %t -o %o")
("textile" "\\.textile\\'" "Textile" "pandoc %i -f textile -t %t -o %o")
("rst" "\\.rst\\'" "reStructuredText" "pandoc %i -f rst -t %t -o %o")
("html" "\\.x?html?\\'" "HTML" "pandoc %i -f html -t %t -o %o")
("docbook" "\\.xml\\'" "DocBook" "pandoc %i -f docbook -t %t -o %o")
("mediawiki" "\\.wiki\\'" "MediaWiki" "pandoc %i -f mediawiki -t %t -o %o")
("latex" "\\.tex\\'" "LaTeX" "pandoc %i -f latex -t %t -o %o"))
:to
'(;; ("json" "json" "JSON version of native AST" "json")
("plain" "txt" "plain text" "plain")
("markdown" "md" "pandoc's extended markdown" "markdown")
("markdown_strict" "md" "original markdown" "markdown_strict")
("markdown_phpextra" "md" "PHP extended markdown" "markdown_phpextra")
("markdown_github" "md" "github extended markdown" "markdown_github")
("rst" "rst" "reStructuredText" "rst")
("html" "html" "XHTML 1" "html")
("html5" "html" "HTML 5" "html5")
("latex" "tex" "LaTeX" "latex")
("beamer" "tex" "LaTeX beamer" "beamer")
("context" "tex" "ConTeXt" "context")
("man" "man" "groff man" "man")
("mediawiki" "wiki" "MediaWiki markup" "mediawiki")
("textile" "textile" "Textile" "textile")
("org" "org" "Emacs Org-Mode" "org")
("texinfo" "info" "GNU Texinfo" "texinfo")
("docbook" "xml" "DocBook XML" "docbook")
("opendocument" "xml" "OpenDocument XML" "opendocument")
("odt" "odt" "OpenOffice text document" "odt")
("pdf" "pdf" "Portable Document Format" "latex")
("docx" "docx" "Word docx" "docx")
("epub" "epub" "EPUB book" "epub")
("epub3" "epub" "EPUB v3" "epub3")
("fb2" "fb" "FictionBook2 e-book" "fb2")
("asciidoc" "txt" "AsciiDoc" "asciidoc")
("slidy" "html" "Slidy HTML slide show" "slidy")
("slideous" "html" "Slideous HTML slide show" "slideous")
("dzslides" "html" "HTML5 slide show" "dzslides")
("s5" "html" "S5 HTML slide show" "s5")
("rtf" "rtf" "rich text format" "rtf"))
:function 'pm-default-shell-export-function
:sentinel 'pm-default-shell-export-sentinel)
"Pandoc exporter."
:group 'polymode-export
:type 'object)
(provide 'polymode-export)
;;; polymode-export.el ends here

684
lisp/polymode/polymode-methods.el Normal file
View File

@@ -0,0 +1,684 @@
;;; polymode-methods.el --- Methods for polymode classes -*- lexical-binding: t -*-
;;
;; Copyright (C) 2013-2019, Vitalie Spinu
;; Author: Vitalie Spinu
;; URL: https://github.com/polymode/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 GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Commentary:
;;
;;; Code:
(require 'polymode-core)
;;; INITIALIZATION
(cl-defgeneric pm-initialize (object)
"Initialize current buffer with OBJECT.")
(cl-defmethod pm-initialize ((config pm-polymode))
"Initialization of host buffers.
Ran by the polymode mode function."
;; Not calling config's '-minor-mode in hosts because this pm-initialize is
;; called from minor-mode itself in base buffers.
(let* ((hostmode-name (eieio-oref config 'hostmode))
(hostmode (if hostmode-name
(clone (symbol-value hostmode-name))
(pm-host-chunkmode :name "ANY" :mode nil))))
(let ((pm-initialization-in-progress t)
;; Set if nil! This allows unspecified host chunkmodes to be used in
;; minor modes.
(host-mode (or (eieio-oref hostmode 'mode)
(oset hostmode :mode major-mode))))
;; host-mode hooks are run here, but polymode is not initialized
(pm--mode-setup host-mode)
(oset hostmode -buffer (current-buffer))
(oset config -hostmode hostmode)
(setq pm--core-buffer-name (buffer-name)
pm/polymode config
pm/chunkmode hostmode
pm/current t
pm/type nil)
(pm--common-setup)
;; Initialize innermodes
(pm--initialize-innermodes config)
;; FIXME: must go into polymode-compat.el
(add-hook 'flyspell-incorrect-hook
'pm--flyspel-dont-highlight-in-chunkmodes nil t))
(pm--run-init-hooks hostmode 'host 'polymode-init-host-hook)))
(defun pm--initialize-innermodes (config)
(let ((inner-syms (delete-dups
(delq :inherit
(apply #'append
(pm--collect-parent-slots
config 'innermodes
(lambda (obj)
(memq :inherit
(eieio-oref obj 'innermodes)))))))))
(oset config -innermodes
(mapcar (lambda (sub-name)
(clone (symbol-value sub-name)))
inner-syms))))
(cl-defmethod pm-initialize ((chunkmode pm-inner-chunkmode) &optional type mode)
"Initialization of the innermodes' (indirect) buffers."
;; run in chunkmode indirect buffer
(setq mode (or mode (pm--get-innermode-mode chunkmode type)))
(let* ((pm-initialization-in-progress t)
(post-fix (replace-regexp-in-string "poly-\\|-mode" "" (symbol-name mode)))
(core-name (format "%s[%s]" (buffer-name (pm-base-buffer))
(or (cdr (assoc post-fix polymode-mode-abbrev-aliases))
post-fix)))
(new-name (generate-new-buffer-name core-name)))
(rename-buffer new-name)
(pm--mode-setup mode)
(pm--move-vars '(pm/polymode buffer-file-coding-system) (pm-base-buffer))
;; FIXME: This breaks if different chunkmodes use same-mode buffer. Even for
;; head/tail the value of pm/type will be wrong for tail
(setq pm--core-buffer-name core-name
pm/chunkmode chunkmode
pm/type (pm-true-span-type chunkmode type))
;; FIXME: should not be here?
(vc-refresh-state)
(pm--common-setup)
(add-hook 'syntax-propertize-extend-region-functions
#'polymode-syntax-propertize-extend-region-in-host
-90 t)
(pm--move-vars polymode-move-these-vars-from-base-buffer (pm-base-buffer))
;; If this rename happens before the mode setup font-lock doesn't work in
;; inner buffers.
(when pm-hide-implementation-buffers
(rename-buffer (generate-new-buffer-name (concat " " pm--core-buffer-name)))))
(pm--run-init-hooks chunkmode type 'polymode-init-inner-hook)
;; Call polymode mode for the sake of the keymap and hook. Same minor mode
;; which runs in the host buffer but without recursive call to `pm-initialize'.
(funcall (eieio-oref pm/polymode '-minor-mode)))
(defvar poly-lock-allow-fontification)
(defun pm--mode-setup (mode &optional buffer)
;; General major-mode install. Should work for both indirect and base buffers.
;; PM objects are not yet initialized (pm/polymode, pm/chunkmode, pm/type)
(with-current-buffer (or buffer (current-buffer))
;; don't re-install if already there; polymodes can be used as minor modes.
(unless (eq major-mode mode)
(let ((polymode-mode t) ;major-modes might check this
(base (buffer-base-buffer))
;; Some modes (or minor-modes which are run in their hooks) call
;; font-lock functions directly on the entire buffer (#212 for an
;; example). They were inhibited here before, but these variables
;; are designed to be set by modes, so our setup doesn't have an
;; effect in those cases and we get "Making xyz buffer-local while
;; locally let-bound!" warning which seems to be harmless but
;; annoying. The only solution seems to be to advice those
;; functions, particularly `font-lock-fontify-region`.
;; (font-lock-flush-function 'ignore)
;; (font-lock-ensure-function 'ignore)
;; (font-lock-fontify-buffer-function 'ignore)
;; (font-lock-fontify-region-function 'ignore)
(font-lock-function 'ignore)
;; Mode functions can do arbitrary things. We inhibt all PM hooks
;; because PM objects have not been setup yet.
(pm-allow-after-change-hook nil)
(poly-lock-allow-fontification nil))
;; run-mode-hooks needs buffer-file-name, so we transfer base vars twice
(when base
(pm--move-vars polymode-move-these-vars-from-base-buffer base))
(condition-case-unless-debug err
;; !! run-mode-hooks and hack-local-variables run here
(funcall mode)
(error (message "Polymode error (pm--mode-setup '%s): %s"
mode (error-message-string err))))
;; In emacs 27 this is called from run-mode-hooks
(and (bound-and-true-p syntax-propertize-function)
(not (local-variable-p 'parse-sexp-lookup-properties))
(setq-local parse-sexp-lookup-properties t))))
(setq polymode-mode t)
(current-buffer)))
(defvar syntax-ppss-wide)
(defun pm--common-setup (&optional buffer)
"Run common setup in BUFFER.
Runs after major mode and core polymode structures have been
initialized. Return the buffer."
(with-current-buffer (or buffer (current-buffer))
(object-add-to-list pm/polymode '-buffers (current-buffer))
;; INDENTATION
(setq-local pm--indent-line-function-original
(if (memq indent-line-function '(indent-relative indent-relative-maybe))
#'pm--indent-line-basic
indent-line-function))
(setq-local indent-line-function #'pm-indent-line-dispatcher)
(setq-local pm--indent-region-function-original
(if (memq indent-region-function '(nil indent-region-line-by-line))
#'pm--indent-region-line-by-line
indent-region-function))
(setq-local indent-region-function #'pm-indent-region)
;; FILL
(setq-local pm--fill-forward-paragraph-original fill-forward-paragraph-function)
(setq-local fill-forward-paragraph-function #'polymode-fill-forward-paragraph)
;; HOOKS
(add-hook 'kill-buffer-hook #'polymode-after-kill-fixes nil t)
(add-hook 'post-command-hook #'polymode-post-command-select-buffer nil t)
(add-hook 'pre-command-hook #'polymode-pre-command-synchronize-state nil t)
;; FONT LOCK (see poly-lock.el)
(setq-local font-lock-function 'poly-lock-mode)
;; Font lock is a globalized minor mode and is thus initialized in
;; `after-change-major-mode-hook' within `run-mode-hooks'. As a result
;; poly-lock won't get installed if polymode is installed as a minor mode or
;; interactively. We add font/poly-lock in all buffers (because this is how
;; inner buffers are installed) but use `poly-lock-allow-fontification' to
;; disallow fontification in buffers which don't want font-lock (aka those
;; buffers where `turn-on-font-lock-if-desired' doesn't activate font-lock).
(turn-on-font-lock-if-desired) ; <- need this for the sake of poly-minor-modes
;; FIXME: can poly-lock-mode be used here instead?
(setq-local poly-lock-allow-fontification font-lock-mode)
;; Make sure to re-install with our font-lock-function as
;; `turn-on-font-lock-if-desired' from above might actually not call it.
(font-lock-mode t)
(font-lock-flush)
;; SYNTAX (must be done after font-lock for after-change order)
(with-no-warnings
;; [OBSOLETE as of 25.1 but we still protect it]
(pm-around-advice syntax-begin-function 'pm-override-output-position))
;; (advice-remove 'c-beginning-of-syntax #'pm-override-output-position)
;; Ideally this should be called in some hook to avoid minor-modes messing
;; it up. Setting even if syntax-propertize-function is nil to have more
;; control over syntax-propertize--done.
(unless (eq syntax-propertize-function #'polymode-syntax-propertize)
(setq-local pm--syntax-propertize-function-original syntax-propertize-function)
(setq-local syntax-propertize-function #'polymode-syntax-propertize))
(setq-local syntax-ppss-wide (cons nil nil))
;; Flush ppss in all buffers. Must be done in first after-change (see
;; https://lists.gnu.org/archive/html/emacs-devel/2019-03/msg00500.html)
;; TODO: Consider just advising syntax-ppss-flush-cache once the above is
;; fixed in emacs.
(add-hook 'after-change-functions 'polymode-flush-syntax-ppss-cache nil t)
(current-buffer)))
;;; BUFFER CREATION
(cl-defgeneric pm-get-buffer-create (chunkmode &optional type)
"Get the indirect buffer associated with SUBMODE and SPAN-TYPE.
Create and initialize the buffer if does not exist yet.")
(cl-defmethod pm-get-buffer-create ((chunkmode pm-host-chunkmode) &optional type)
(when type
(error "Cannot create host buffer of type '%s'" type))
(let ((buff (eieio-oref chunkmode '-buffer)))
(if (buffer-live-p buff)
buff
(error "Cannot create host buffer for host chunkmode %s" (eieio-object-name chunkmode)))))
(cl-defmethod pm-get-buffer-create ((chunkmode pm-inner-chunkmode) &optional type)
(let ((buff (cl-case type
(body (eieio-oref chunkmode '-buffer))
(head (eieio-oref chunkmode '-head-buffer))
(tail (eieio-oref chunkmode '-tail-buffer))
(t (error "Don't know how to select buffer of type '%s' for chunkmode '%s'"
type (eieio-object-name chunkmode))))))
(if (buffer-live-p buff)
buff
(let ((new-buff (pm--get-innermode-buffer-create chunkmode type)))
(pm--set-innermode-buffer chunkmode type new-buff)))))
(defun pm--get-innermode-buffer-create (chunkmode type &optional force-new)
(let ((mode (pm--get-innermode-mode chunkmode type)))
(or
;; 1. search through the existing buffer list
(unless force-new
(cl-loop for bf in (eieio-oref pm/polymode '-buffers)
when (let ((out (and (buffer-live-p bf)
(eq mode (buffer-local-value 'major-mode bf)))))
out)
return bf))
;; 2. create new
(with-current-buffer (pm-base-buffer)
(let* ((new-name (generate-new-buffer-name (buffer-name)))
(new-buffer (make-indirect-buffer (current-buffer) new-name)))
(with-current-buffer new-buffer
(pm-initialize chunkmode type mode))
new-buffer)))))
(defun pm-get-buffer-of-mode (mode)
(let ((mode (pm--true-mode-symbol mode)))
(or
;; 1. search through the existing buffer list
(cl-loop for bf in (eieio-oref pm/polymode '-buffers)
when (and (buffer-live-p bf)
(eq mode (buffer-local-value 'major-mode bf)))
return bf)
;; 2. create new if body mode matched
(cl-loop for imode in (eieio-oref pm/polymode '-innermodes)
when (eq mode (eieio-oref imode 'mode))
return (pm--get-innermode-buffer-create imode 'body 'force)))))
(defun pm--set-innermode-buffer (obj type buff)
"Assign BUFF to OBJ's slot(s) corresponding to TYPE."
(with-slots (-buffer head-mode -head-buffer tail-mode -tail-buffer) obj
(pcase (list type head-mode tail-mode)
(`(body body ,(or `nil `body))
(setq -buffer buff
-head-buffer buff
-tail-buffer buff))
(`(body ,_ body)
(setq -buffer buff
-tail-buffer buff))
(`(body ,_ ,_ )
(setq -buffer buff))
(`(head ,_ ,(or `nil `head))
(setq -head-buffer buff
-tail-buffer buff))
(`(head ,_ ,_)
(setq -head-buffer buff))
(`(tail ,_ ,(or `nil `head))
(setq -tail-buffer buff
-head-buffer buff))
(`(tail ,_ ,_)
(setq -tail-buffer buff))
(_ (error "Type must be one of 'body, 'head or 'tail")))))
;;; SPAN MANIPULATION
(cl-defgeneric pm-get-span (chunkmode &optional pos)
"Ask the CHUNKMODE for the span at point.
Return a list of three elements (TYPE BEG END OBJECT) where TYPE
is a symbol representing the type of the span surrounding
POS (head, tail, body). BEG and END are the coordinates of the
span. OBJECT is a suitable object which is 'responsible' for this
span. This is an object that could be dispatched upon with
`pm-select-buffer'. Should return nil if there is no SUBMODE
specific span around POS. Not to be used in programs directly;
use `pm-innermost-span'.")
(cl-defmethod pm-get-span (chunkmode &optional _pos)
"Return nil.
Host modes usually do not compute spans."
(unless chunkmode
(error "Dispatching `pm-get-span' on a nil object"))
nil)
(cl-defmethod pm-get-span ((chunkmode pm-inner-chunkmode) &optional pos)
"Return a list of the form (TYPE POS-START POS-END SELF).
TYPE can be 'body, 'head or 'tail. SELF is the CHUNKMODE."
(with-slots (head-matcher tail-matcher head-mode tail-mode) chunkmode
(let ((span (pm--span-at-point head-matcher tail-matcher pos
(eieio-oref chunkmode 'can-overlap))))
(when span
(append span (list chunkmode))))))
(cl-defmethod pm-get-span ((_chunkmode pm-inner-auto-chunkmode) &optional _pos)
(let ((span (cl-call-next-method)))
(if (null (car span))
span
(setf (nth 3 span) (apply #'pm--get-auto-chunkmode span))
span)))
;; (defun pm-get-chunk (ichunkmode &optional pos)
;; (with-slots (head-matcher tail-matcher head-mode tail-mode) ichunkmode
;; (pm--span-at-point
;; head-matcher tail-matcher (or pos (point))
;; (eieio-oref ichunkmode 'can-overlap)
;; t)))
(cl-defgeneric pm-next-chunk (chunkmode &optional pos)
"Ask the CHUNKMODE for the chunk after POS.
Return a list of three elements (CHUNKMODE HEAD-BEG HEAD-END
TAIL-BEG TAIL-END).")
(cl-defmethod pm-next-chunk (_chunkmode &optional _pos)
nil)
(cl-defmethod pm-next-chunk ((chunkmode pm-inner-chunkmode) &optional pos)
(with-slots (head-matcher tail-matcher head-mode tail-mode) chunkmode
(let ((raw-chunk (pm--next-chunk
head-matcher tail-matcher (or pos (point))
(eieio-oref chunkmode 'can-overlap))))
(when raw-chunk
(cons chunkmode raw-chunk)))))
(cl-defmethod pm-next-chunk ((chunkmode pm-inner-auto-chunkmode) &optional pos)
(with-slots (head-matcher tail-matcher head-mode tail-mode) chunkmode
(let ((raw-chunk (pm--next-chunk
head-matcher tail-matcher (or pos (point))
(eieio-oref chunkmode 'can-overlap))))
(when raw-chunk
(cons (pm--get-auto-chunkmode 'head (car raw-chunk) (cadr raw-chunk) chunkmode)
raw-chunk)))))
;; FIXME: cache somehow?
(defun pm--get-auto-chunkmode (type beg end proto)
(save-excursion
(goto-char beg)
(unless (eq type 'head)
(goto-char end) ; fixme: add multiline matchers to micro-optimize this
(let ((matcher (pm-fun-matcher (eieio-oref proto 'head-matcher))))
;; can be multiple incomplete spans within a span
(while (< beg (goto-char (car (funcall matcher -1)))))))
(let* ((str (let ((matcher (eieio-oref proto 'mode-matcher)))
(when (stringp matcher)
(setq matcher (cons matcher 0)))
(cond ((consp matcher)
(re-search-forward (car matcher) (point-at-eol) t)
(match-string-no-properties (cdr matcher)))
((functionp matcher)
(funcall matcher)))))
(mode (pm-get-mode-symbol-from-name str (eieio-oref proto 'fallback-mode))))
(if (eq mode 'host)
(oref pm/polymode -hostmode)
;; chunkname:MODE serves as ID (e.g. `markdown-fenced-code:emacs-lisp-mode`).
;; Head/tail/body indirect buffers are shared across chunkmodes and span
;; types.
(let ((automodes (eieio-oref pm/polymode '-auto-innermodes)))
(if (memq proto automodes)
;; a. if proto already part of the list return
proto
(let ((name (concat (pm-object-name proto) ":" (symbol-name mode))))
(or
;; b. loop through installed inner modes
(cl-loop for obj in automodes
when (equal name (pm-object-name obj))
return obj)
;; c. create new
(let ((innermode (clone proto :name name :mode mode)))
(object-add-to-list pm/polymode '-auto-innermodes innermode)
innermode)))))))))
;;; INDENT
;; indent-region-line-by-line for polymode buffers (more efficient, works on
;; emacs 25, but no progress reporter)
(defun pm--indent-region-line-by-line (start end)
(save-excursion
;; called from pm--indent-raw; so we know we are in the same span with
;; buffer set and narrowed to span if 'protect-indent is non-nil
(let ((span (pm-innermost-span start)))
(setq end (copy-marker end))
(goto-char start)
(while (< (point) end)
(unless (and (bolp) (eolp))
;; fixme: html-erb jumps line here; need save-excursion. why?
(save-excursion (pm-indent-line (nth 3 span) span)))
(forward-line 1))
(move-marker end nil))))
(defun pm--indent-line-basic ()
"Used as `indent-line-function' for modes with tab indent."
;; adapted from indent-according-to-mode
(let ((column (save-excursion
(beginning-of-line)
(if (bobp) 0
(beginning-of-line 0)
(if (looking-at "[ \t]*$") 0 (current-indentation))))))
(if (<= (current-column) (current-indentation))
(indent-line-to column)
(save-excursion (indent-line-to column)))))
(defun pm--indent-raw (span fn-sym &rest args)
;; fixme: do save-excursion instead of this?
(let ((point (point)))
;; do fast synchronization here
(save-current-buffer
(pm-set-buffer span)
(goto-char point)
(let ((fn (symbol-value fn-sym)))
(when fn
(if (eieio-oref (nth 3 span) 'protect-indent)
(pm-with-narrowed-to-span span
(apply fn args))
(apply fn args))))
(setq point (point)))
(goto-char point)))
(defun pm--indent-line-raw (span)
(pm--indent-raw span 'pm--indent-line-function-original)
(pm--reindent-with+-indent span (point-at-bol) (point-at-eol)))
(defun pm--indent-region-raw (span beg end)
(pm--indent-raw span 'pm--indent-region-function-original beg end)
(pm--reindent-with+-indent span beg end))
(defun pm-indent-region (beg end)
"Indent region between BEG and END in polymode buffers.
Function used for `indent-region-function'."
;; (message "(pm-indent-region %d %d)" beg end)
;; cannot use pm-map-over-spans here because of the buffer modifications
(let ((inhibit-point-motion-hooks t)
(end (copy-marker end)))
(save-excursion
(while (< beg end)
(goto-char beg)
(back-to-indentation)
(setq beg (point))
(let ((span (pm-innermost-span beg 'no-cache)))
(let* ((end-span (copy-marker (nth 2 span)))
(end1 (min end end-span)))
(goto-char beg)
;; (pm-switch-to-buffer)
;; indent first line separately
(pm-indent-line (nth 3 span) span)
(beginning-of-line 2)
(when (< (point) end1)
;; we know that span end was moved, hard reset without recomputation
(setf (nth 2 span) end-span)
(pm--indent-region-raw span (point) end1))
(setq beg (max end1 (point)))))))
(move-marker end nil)))
(defun pm-indent-line-dispatcher (&optional span)
"Dispatch `pm-indent-line' methods on current SPAN.
Value of `indent-line-function' in polymode buffers."
;; NB: No buffer switching in indentation functions. See comment at
;; pm-switch-to-buffer.
(let ((span (or span (pm-innermost-span
(save-excursion (back-to-indentation) (point)))))
(inhibit-read-only t))
(pm-indent-line (nth 3 span) span)))
(cl-defgeneric pm-indent-line (chunkmode &optional span)
"Indent current line.
Protect and call original indentation function associated with
the chunkmode.")
(cl-defmethod pm-indent-line ((_chunkmode pm-chunkmode) span)
(let ((pos (point))
(delta))
(back-to-indentation)
(setq delta (- pos (point)))
(let* ((bol (point-at-bol))
(span (or span (pm-innermost-span)))
(prev-span-pos)
(first-line (save-excursion
(goto-char (nth 1 span))
(unless (bobp)
(setq prev-span-pos (1- (point))))
(forward-line)
(<= bol (point)))))
(pm--indent-line-raw span)
(when (and first-line prev-span-pos)
(pm--reindent-with-extra-offset (pm-innermost-span prev-span-pos)
'post-indent-offset)))
(when (and delta (> delta 0))
(goto-char (+ (point) delta)))))
(cl-defmethod pm-indent-line ((_chunkmode pm-inner-chunkmode) span)
"Indent line in inner chunkmodes.
When point is at the beginning of head or tail, use parent chunk
to indent."
(let ((pos (point))
(delta))
(back-to-indentation)
(setq delta (- pos (point)))
(unwind-protect
(cond
;; 1. HEAD or TAIL (we assume head or tail fits in one line for now)
((or (eq 'head (car span))
(eq 'tail (car span)))
(goto-char (nth 1 span))
(when (not (bobp))
;; ind-point need not be in prev-span; there might be other spans in between
(let ((prev-span (pm-innermost-span (1- (point)))))
(if (eq 'tail (car span))
(indent-line-to (pm--head-indent prev-span))
;; head indent and adjustments
;; (pm-indent-line (nth 3 prev-span) prev-span)
(pm--indent-line-raw prev-span)
(let ((prev-tail-pos (save-excursion
(beginning-of-line)
(skip-chars-backward " \t\n")
(if (bobp) (point) (1- (point))))))
(setq prev-span (pm-innermost-span prev-tail-pos)))
(pm--reindent-with-extra-offset prev-span 'post-indent-offset)
(pm--reindent-with-extra-offset span 'pre-indent-offset)))))
;; 2. BODY
(t
(if (< (point) (nth 1 span))
;; first body line in the same line with header (re-indent at indentation)
(pm-indent-line-dispatcher)
(let ((fl-indent (pm--first-line-indent span)))
(if fl-indent
;; We are not on the 1st line
(progn
;; thus indent according to mode
(pm--indent-line-raw span)
(when (bolp)
;; When original mode's indented to bol, match with the
;; first line indent. Otherwise it's a continuation
;; indentation and we assume the original function did it
;; correctly with respect to previous lines.
(indent-to fl-indent)))
;; On the first line. Indent with respect to header line.
(let ((delta (save-excursion
(goto-char (nth 1 span))
(+
(pm--oref-value (nth 3 span) 'body-indent-offset)
(cond
;; empty line
((looking-at-p "[ \t]*$") 0)
;; inner span starts at bol; honor +-indent cookie
((= (point) (point-at-bol))
(pm--+-indent-offset-on-this-line span))
;; code after header
(t
(end-of-line)
(skip-chars-forward "\t\n")
(pm--indent-line-raw span)
(- (point) (point-at-bol))))))))
(indent-line-to
;; indent with respect to header line
(+ delta (pm--head-indent span)))))))))
;; keep point on same characters
(when (and delta (> delta 0))
(goto-char (+ (point) delta))))))
(defun pm--first-line-indent (&optional span)
(save-excursion
(let ((pos (point)))
(goto-char (nth 1 (or span (pm-innermost-span))))
;; when body starts at bol move to previous line
(when (and (= (point) (point-at-bol))
(not (bobp)))
(backward-char 1))
(skip-chars-forward " \t\n")
(when (< (point-at-eol) pos)
(- (point) (point-at-bol))))))
;; SPAN is a body span; do nothing if narrowed to body
(defun pm--head-indent (&optional span)
(save-restriction
(widen)
(save-excursion
(let ((sbeg (nth 1 (or span (pm-innermost-span)))))
(goto-char sbeg)
(backward-char 1)
(let ((head-span (pm-innermost-span)))
(if (eq (car head-span) 'head)
(goto-char (nth 1 head-span))
;; body span is not preceded by a head span. We don't have such
;; practical cases yet, but headless spans are real - indented blocks
;; for instance.
(goto-char sbeg)))
(back-to-indentation)
(- (point) (point-at-bol))))))
(defun pm--+-indent-offset-on-this-line (span)
(if (re-search-forward "\\([+-]\\)indent" (point-at-eol) t)
(let ((basic-offset (pm--oref-value (nth 3 span) 'indent-offset)))
(if (string= (match-string 1) "-")
(- basic-offset)
basic-offset))
0))
(defun pm--reindent-with+-indent (span beg end)
(save-excursion
(goto-char beg)
(let ((basic-offset (pm--oref-value (nth 3 span) 'indent-offset)))
(while (and (< (point) end)
(re-search-forward "\\([+-]\\)indent" end t))
(let ((offset (if (string= (match-string 1) "-")
(- basic-offset)
basic-offset)))
(indent-line-to (max 0 (+ (current-indentation) offset)))
(forward-line))))))
(defun pm--reindent-with-extra-offset (span offset-type &optional offset2)
(let ((offset (eieio-oref (nth 3 span) offset-type)))
(unless (and (numberp offset) (= offset 0))
(let ((pos (nth (if (eq offset-type 'post-indent-offset) 2 1) span)))
(save-excursion
(goto-char pos)
(setq offset (pm--object-value offset)))
(indent-line-to (max 0 (+ (current-indentation) offset (or offset2 0))))))))
;;; FACES
(cl-defgeneric pm-get-adjust-face (chunkmode type))
(cl-defmethod pm-get-adjust-face ((chunkmode pm-chunkmode) _type)
(eieio-oref chunkmode 'adjust-face))
(cl-defmethod pm-get-adjust-face ((chunkmode pm-inner-chunkmode) type)
(cond ((eq type 'head)
(eieio-oref chunkmode 'head-adjust-face))
((eq type 'tail)
(or (eieio-oref chunkmode 'tail-adjust-face)
(eieio-oref chunkmode 'head-adjust-face)))
(t (eieio-oref chunkmode 'adjust-face))))
(provide 'polymode-methods)
;;; polymode-methods.el ends here

12
lisp/polymode/polymode-pkg.el Normal file
View File

@@ -0,0 +1,12 @@
(define-package "polymode" "20200606.1106" "Extensible framework for multiple major modes"
'((emacs "25"))
:commit "3284ff10017d280ba82f27dc20fe5223b0df709c" :keywords
'("languages" "multi-modes" "processes")
:authors
'(("Vitalie Spinu"))
:maintainer
'("Vitalie Spinu")
:url "https://github.com/polymode/polymode")
;; Local Variables:
;; no-byte-compile: t
;; End:

35
lisp/polymode/polymode-tangle.el Normal file
View File

@@ -0,0 +1,35 @@
;;; polymode-tangle.el --- Tangling facilities for polymodes (stump) -*- lexical-binding: t -*-
;;
;; Copyright (C) 2013-2019, Vitalie Spinu
;; Author: Vitalie Spinu
;; URL: https://github.com/polymode/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 GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Commentary:
;;
;;; Code:
(defgroup polymode-tangle nil
"Polymode Tanglers."
:group 'polymode)
(provide 'polymode-tangle)
;;; polymode-tangle.el ends here

464
lisp/polymode/polymode-test-utils.el Normal file
View File

@@ -0,0 +1,464 @@
;;; polymode-test-utils.el --- Testing utilities for polymode -*- lexical-binding: t -*-
;;
;; Copyright (C) 2018-2019, Vitalie Spinu
;; Author: Vitalie Spinu
;; URL: https://github.com/polymode/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 GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;
;;; Commentary:
;;
;; This file should be loaded only in tests.
;;
;;; Code:
(require 'ert)
(require 'polymode)
(eval-when-compile
(require 'cl-lib))
;; (require 'font-lock)
;; (global-font-lock-mode t)
;; (add-hook 'after-change-major-mode-hook #'global-font-lock-mode-enable-in-buffers)
;; (message "ACMH: %s GFL:%s" after-change-major-mode-hook global-font-lock-mode)
(setq ert-batch-backtrace-right-margin 200)
(defvar pm-verbose (getenv "PM_VERBOSE"))
(defvar pm-test-current-change-set nil)
(defun pm-test-get-file (name)
"Find the file with NAME from inside a poly-xyz repo.
Look into tests/input directory then in samples directory."
(let ((files (list (expand-file-name (format "./tests/input/%s" name) default-directory)
(expand-file-name (format "./input/%s" name) default-directory)
(expand-file-name (format "./samples/%s" name) default-directory)
(expand-file-name (format "../samples/%s" name) default-directory))))
(or (cl-loop for f in files
if (file-exists-p f) return f)
(error "No file with name '%s' found in '%s'" name default-directory))))
(defun pm-test-matcher (string span-alist matcher &optional dry-run)
(with-temp-buffer
(insert string)
(goto-char (point-min))
(let (prev-span)
(when dry-run
(message "("))
(while (not (eobp))
(if dry-run
(let ((span (funcall matcher)))
(unless (equal prev-span span)
(setq prev-span span)
(message " (%d . %S)" (nth 1 span) span)))
(let* ((span (funcall matcher))
(sbeg (nth 1 span))
(ref-span (alist-get sbeg span-alist)))
(unless (equal span ref-span)
(ert-fail (list :pos (point) :span span :ref-span ref-span)))
(when (and prev-span
(not (or (eq (nth 1 prev-span) sbeg)
(eq (nth 2 prev-span) sbeg))))
(ert-fail (list :pos (point) :span span :prev-span prev-span)))
(setq prev-span span)))
(forward-char 1))
(when dry-run
(message ")"))
nil)))
(defmacro pm-test-run-on-string (mode string &rest body)
"Run BODY in a temporary buffer containing STRING in MODE.
MODE is a quoted symbol."
(declare (indent 1) (debug (form form body)))
`(let ((*buf* "*pm-test-string-buffer*"))
(when (get-buffer *buf*)
(kill-buffer *buf*))
(with-current-buffer (get-buffer-create *buf*)
(insert (substring-no-properties ,string))
(funcall ,mode)
(setq-default indent-tabs-mode nil)
;; In emacs 27 this is called from run-mode-hooks
(and (bound-and-true-p syntax-propertize-function)
(not (local-variable-p 'parse-sexp-lookup-properties))
(setq-local parse-sexp-lookup-properties t))
(goto-char (point-min))
(let ((poly-lock-allow-background-adjustment nil))
(when polymode-mode
;; font-lock not activated in batch mode
(setq-local poly-lock-allow-fontification t)
(poly-lock-mode t))
(font-lock-ensure)
,@body)
(current-buffer))))
(defun pm-test-spans (mode string)
(declare (indent 1))
(pm-test-run-on-string mode
string
(pm-map-over-spans
(lambda (span)
(let ((range0 (pm-span-to-range span)))
(goto-char (car range0))
(while (< (point) (cdr range0))
(let ((range-pos (pm-innermost-range (point) 'no-cache)))
(unless (equal range0 range-pos)
(switch-to-buffer (current-buffer))
(ert-fail (list :pos (point)
:range0 range0
:range-pos range-pos))))
(forward-char)))))))
(defun pm-test-spans-on-file (mode file-name)
(let ((file (pm-test-get-file file-name)))
(pm-test-spans mode
(with-current-buffer (find-file-noselect file)
(substring-no-properties (buffer-string))))))
(defmacro pm-test-run-on-file (mode file-name &rest body)
"Run BODY in a buffer with the content of FILE-NAME in MODE."
(declare (indent 2) (debug (sexp sexp body)))
(let ((pre-form (when (eq (car body) :pre-form)
(prog1 (cadr body)
(setq body (cddr body))))))
`(let ((poly-lock-allow-background-adjustment nil)
;; snapshot it during the expansion to be able to run polymode-organization tests
(file ,(pm-test-get-file file-name))
(pm-extra-span-info nil)
(buf "*pm-test-file-buffer*"))
(when (get-buffer buf)
(kill-buffer buf))
(with-current-buffer (get-buffer-create buf)
(when pm-verbose
(message "\n=================== testing %s =======================" file))
(switch-to-buffer buf)
(insert-file-contents file)
(remove-hook 'text-mode-hook 'flyspell-mode) ;; triggers "too much reentrancy" error
(let ((inhibit-message (not pm-verbose)))
(funcall-interactively ',mode))
;; (flyspell-mode -1) ;; triggers "too much reentrancy" error
(hack-local-variables 'ignore-mode)
(goto-char (point-min))
,pre-form
;; need this to activate all chunks
(font-lock-ensure)
(goto-char (point-min))
(save-excursion
(let ((font-lock-mode t))
(pm-map-over-spans
(lambda (_)
(setq font-lock-mode t)
;; This is not picked up because font-lock is nil on innermode
;; initialization. Don't know how to fix this more elegantly.
;; For now our tests are all with font-lock, so we are fine for
;; now.
;; !! Font-lock is not activated in batch mode !!
(setq-local poly-lock-allow-fontification t)
(poly-lock-mode t)
;; redisplay is not triggered in batch and often it doesn't trigger
;; fontification in X either (waf?)
(add-hook 'after-change-functions #'pm-test-invoke-fontification t t))
(point-min) (point-max))))
(font-lock-ensure)
,@body
(current-buffer)))))
(defun pm-test-span-faces (span &optional allow-failed-faces)
;; head/tail is usually highlighted incorrectly by host modes when only head
;; is in the buffer, so we just skip those head-tails which have
;; :head/tail-mode 'host
(when (eq (car span) (pm-true-span-type *span*))
(let* ((poly-lock-allow-background-adjustment nil)
(sbeg (nth 1 span))
(send (nth 2 span))
(smode major-mode)
(stext (buffer-substring-no-properties sbeg send))
;; other buffer
(ref-buf (pm-test-run-on-string smode stext))
(ref-pos 1))
(when pm-verbose
(message "---- testing %s ----" (pm-format-span span t)))
;; NB: String delimiters '' in pascal mode don't work in batch
;; (require 'polymode-debug)
;; (when (and (eq smode 'pascal-mode)
;; (> (buffer-size ref-buf) 29)
;; (> (buffer-size) 700))
;; (message "%s"
;; (list
;; :parse-sexp-lookup-properties parse-sexp-lookup-properties
;; :font-lock-keywords-only font-lock-keywords-only
;; :font-lock-syntactic-face-function font-lock-syntactic-face-function
;; :font-lock-sk font-lock-syntactic-keywords
;; :syntax-prop-fun syntax-propertize-function
;; :ppss (syntax-ppss 675)
;; :char (pm--syntax-after 675)))
;; (with-current-buffer ref-buf
;; (message "%s"
;; (list
;; :parse-sexp-lookup-properties parse-sexp-lookup-properties
;; :font-lock-keywords-only font-lock-keywords-only
;; :font-lock-syntactic-face-function font-lock-syntactic-face-function
;; :font-lock-sk font-lock-syntactic-keywords
;; :syntax-prop-fun syntax-propertize-function
;; :ppss-29 (syntax-ppss 29)
;; :char-29 (pm--syntax-after 29)))))
(while ref-pos
(let* ((pos (1- (+ ref-pos sbeg)))
(face (get-text-property pos 'face))
(ref-face (get-text-property ref-pos 'face ref-buf)))
(unless (or
;; in markdown fence regexp matches end of line; it's likely
;; to be a common mismatch between host mode and polymode,
;; thus don't check first pos if it's a new line
(and (= ref-pos 1)
(with-current-buffer ref-buf
(eq (char-after 1) ?\n)))
(member face allow-failed-faces)
(equal face ref-face))
(let ((data
(append
(when pm-test-current-change-set
(list :change pm-test-current-change-set))
(list
;; :af poly-lock-allow-fontification
;; :fl font-lock-mode
:face face
:ref-face ref-face
:pos pos
:ref-pos ref-pos
:line (progn (goto-char pos)
(buffer-substring-no-properties (point-at-bol) (point-at-eol)))
:ref-line (with-current-buffer ref-buf
(goto-char ref-pos)
(buffer-substring-no-properties (point-at-bol) (point-at-eol)))
:mode smode))))
;; for the interactive convenience
(switch-to-buffer (current-buffer))
(ert-fail data)))
(setq ref-pos (next-single-property-change ref-pos 'face ref-buf)))))))
(defun pm-test-faces (&optional allow-failed-faces)
"Execute `pm-test-span-faces' for every span in the buffer.
ALLOW-FAILED-FACES should be a list of faces on which failures
are OK."
(save-excursion
(pm-map-over-spans
(lambda (span) (pm-test-span-faces span allow-failed-faces)))))
(defun pm-test-goto-loc (loc)
"Go to LOC and switch to polymode indirect buffer.
LOC can be either
- a number giving position in the buffer
- regexp to search for from ‘point-min’
- a cons of the form (ROW . COL)
In the last case ROW can be either a number or a regexp to search
for and COL either a column number or symbols beg or end
indicating beginning or end of the line. When COL is nil, goto
indentation."
(cond
((numberp loc)
(goto-char loc))
((stringp loc)
(goto-char (point-min))
(re-search-forward loc))
((consp loc)
(goto-char (point-min))
(let ((row (car loc)))
(goto-char (point-min))
(cond
((stringp row)
(re-search-forward row))
((numberp row)
(forward-line (1- row)))
(t (error "Invalid row spec %s" row))))
(let* ((col (cdr loc))
(col (if (listp col)
(car col)
col)))
(cond
((numberp col)
(forward-char col))
((eq col 'end)
(end-of-line))
((eq col 'beg)
(beginning-of-line))
((null col)
(back-to-indentation))
(t (error "Invalid col spec %s" col))))))
(when polymode-mode
;; pm-set-buffer would do for programs but not for interactive debugging
(pm-switch-to-buffer (point))))
(defun pm-test-goto-loc-other-window ()
"Utility to navigate to loc at point in other buffer.
LOC is as in `pm-test-goto-loc'."
(interactive)
(let ((loc (or (sexp-at-point)
(read--expression "Loc: "))))
(when (symbolp loc)
(setq loc (string-to-number (thing-at-point 'word))))
(other-window 1)
(pm-test-goto-loc loc)))
(defun pm-test-invoke-fontification (&rest _ignore)
"Mimic calls to fontification functions by redisplay.
Needed because redisplay is not triggered in batch mode."
(when fontification-functions
(save-match-data
(save-restriction
(widen)
(save-excursion
(let (pos)
(while (setq pos (text-property-any (point-min) (point-max) 'fontified nil))
(let ((inhibit-modification-hooks t)
(poly-lock-defer-after-change nil)
(inhibit-redisplay t))
(when pm-verbose
(message "after change fontification-functions (%s)" pos))
(run-hook-with-args 'fontification-functions pos)))))))))
(defmacro pm-test-poly-lock (mode file &rest change-sets)
"Test font-lock for MODE and FILE.
CHANGE-SETS is a collection of forms of the form (NAME-LOC &rest
BODY). NAME-LOC is a list of the form (NAME LOCK) where NAME is a
symbol, LOC is the location as in `pm-test-goto-loc'. Before and
after execution of the BODY ‘undo-boundary’ is set and after the
execution undo is called once. After each change-set
`pm-test-faces' on the whole file is run."
(declare (indent 2)
(debug (sexp sexp &rest ((name sexp) &rest form))))
`(kill-buffer
(pm-test-run-on-file ,mode ,file
(pm-test-faces)
(dolist (cset ',change-sets)
(let ((poly-lock-defer-after-change nil)
(pm-test-current-change-set (caar cset)))
(setq pm-extra-span-info (caar cset))
(undo-boundary)
(pm-test-goto-loc (nth 1 (car cset)))
(eval (cons 'progn (cdr cset)))
(undo-boundary)
(pm-test-faces)
(let ((inhibit-message (not pm-verbose)))
(undo)))))))
(defun pm-test--run-indentation-tests ()
"Run an automatic batch of indentation tests.
First run `indent-line' on every line and compare original and
indented version. Then compute stasrt,middle and end points of
each span and call `indent-region' on a shuffled set of these
points."
(goto-char (point-min))
(set-buffer-modified-p nil)
(while (not (eobp))
(let ((orig-line (buffer-substring-no-properties (point-at-eol) (point-at-bol))))
(unless (string-match-p "no-indent-test" orig-line)
(undo-boundary)
;; (pm-switch-to-buffer)
;; (message "line:%d pos:%s buf:%s ppss:%s spd:%s"
;; (line-number-at-pos) (point) (current-buffer)
;; (syntax-ppss) syntax-propertize--done)
(pm-indent-line-dispatcher)
(unless (equal orig-line (buffer-substring-no-properties (point-at-eol) (point-at-bol)))
(undo-boundary)
(pm-switch-to-buffer (point))
(ert-fail (list :pos (point) :line (line-number-at-pos)
:mode major-mode
:indent-line (buffer-substring-no-properties (point-at-bol) (point-at-eol)))))))
(forward-line 1))
(let (points1 points2)
(pm-map-over-spans (lambda (span) (push (/ (+ (nth 1 span) (nth 2 span)) 2) points1)))
(random "some-seed")
(let ((len (length points1)))
(dotimes (_ len)
(push (elt points1 (random len)) points2)))
(let ((points2 (reverse points1)))
(cl-mapc
(lambda (beg end)
(unless (= beg end)
(let ((orig-region (buffer-substring-no-properties beg end)))
(unless (string-match-p "no-indent-test" orig-region)
(undo-boundary)
(indent-region beg end)
(unless (equal orig-region (buffer-substring-no-properties beg end))
(undo-boundary)
(pm-switch-to-buffer beg)
(ert-fail `(indent-region ,beg ,end)))))))
points1 points2))))
(defmacro pm-test-indentation (mode file)
"Test indentation for MODE and FILE."
`(pm-test-run-on-file ,mode ,file
(undo-boundary)
(let ((inhibit-message (not pm-verbose)))
(unwind-protect
(pm-test--run-indentation-tests)
(undo-boundary)))))
(defmacro pm-test-file-indent (mode file-with-indent &optional file-no-indent)
`(pm-test-run-on-file ,mode ,(or file-no-indent file-with-indent)
(let ((indent-tabs-mode nil)
(right (with-current-buffer (find-file-noselect
,(pm-test-get-file file-with-indent))
(substring-no-properties (buffer-string))))
(inhibit-message t))
(unless ,file-no-indent
(goto-char 1)
(while (re-search-forward "^[ \t]+" nil t)
(replace-match ""))
(goto-char 1))
(indent-region (point-min) (point-max))
(let ((new (substring-no-properties (buffer-string))))
(unless (string= right new)
(require 'pascal)
(let ((pos (1+ (pascal-string-diff right new))))
(ert-fail (list "Wrong indent" :pos pos
:ref (with-temp-buffer
(insert right)
(goto-char pos)
(buffer-substring-no-properties (point-at-bol) (point-at-eol)))
:new (progn
(goto-char pos)
(buffer-substring-no-properties (point-at-bol) (point-at-eol)))))))))))
(defmacro pm-test-map-over-modes (mode file)
`(pm-test-run-on-file ,mode ,file
(let ((beg (point-min))
(end (point-max)))
(with-buffer-prepared-for-poly-lock
(remove-text-properties beg end '(:pm-span :pm-face)))
(pm-map-over-modes (lambda (b e)) beg end)
(while (< beg end)
(let ((span (get-text-property beg :pm-span))
(mid (next-single-property-change beg :pm-span nil end)))
(dolist (pos (list beg
(/ (+ beg mid) 2)
(1- mid)))
(let ((ispan (pm-innermost-span pos t)))
(unless (equal span ispan)
(let ((span (copy-sequence span))
(ispan (copy-sequence ispan)))
(setf (nth 3 span) (eieio-object-name (nth 3 span)))
(setf (nth 3 ispan) (eieio-object-name (nth 3 ispan)))
(pm-switch-to-buffer pos)
(ert-fail (list :pos pos :mode-span span :innermost-span ispan))))))
(setq beg (nth 2 span)))))))
(provide 'polymode-test-utils)
;;; polymode-test-utils.el ends here

281
lisp/polymode/polymode-weave.el Normal file
View File

@@ -0,0 +1,281 @@
;;; polymode-weave.el --- Weaving facilities for polymodes -*- lexical-binding: t -*-
;;
;; Copyright (C) 2013-2019, Vitalie Spinu
;; Author: Vitalie Spinu
;; URL: https://github.com/polymode/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 GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Commentary:
;;
;;; Code:
(require 'polymode-core)
(require 'polymode-classes)
(defgroup polymode-weave nil
"Polymode Weavers"
:group 'polymode)
(define-obsolete-variable-alias 'polymode-weave-output-file-format 'polymode-weaver-output-file-format "2018-08")
(defcustom polymode-weaver-output-file-format "%s-woven"
"Format of the weaved files.
%s is substituted with the current file name sans extension."
:group 'polymode-weave
:type 'string)
(defclass pm-weaver (pm-root)
((from-to
:initarg :from-to
:initform '()
:type list
:custom list
:documentation
"
Input-output specifications. An alist with elements of the
form (id reg-from ext-to doc command) or (id . selector).
In both cases ID is the unique identifier of the spec. In
the former case REG-FROM is a regexp used to identify if
current file can be weaved with the spec. EXT-TO is the
extension of the output file. DOC is a short help string
used for interactive completion and messages. COMMAND is a
weaver specific specific command. It can contain the
following format specs:
%i - input file (no dir)
%I - input file (full path)
%o - output file (no dir)
%O - output file (full path)
%b - output file (base name only)
%t - 4th element of the :to spec
When specification is of the form (id . selector), SELECTOR
is a function of variable arguments with first two arguments
being ACTION and ID of the specification. This function is
called in a buffer visiting input file. ACTION is a symbol
and can one of the following:
match - must return non-nil if this specification
applies to the file that current buffer is visiting,
or :nomatch if specification does not apply.
regexp - return a string which is used to match input
file name. If nil, `match' selector must return
non-nil value. This selector is ignored if `match'
returned non-nil.
output-file - return an output file name or a list of
file names. Receives input-file as argument. If this
command returns nil, the output is built from the
input file name and value of 'output-ext command.
This selector can also return a function. This
function will be called in the callback or sentinel of
the weaving process after the weaving was
completed. This function should sniff the output of
the process for errors or file names. It must return a
file name, a list of file names or nil if no such
files have been detected.
ext - extension of output file. If nil and
`output' also returned nil, the exporter won't be able
to identify the output file and no automatic display
or preview will be available.
doc - return documentation string
command - return a string to be used instead of
the :from command. If nil, :from spec command is used.")
(function
:initarg :function
:initform (lambda (command id)
(error "No weaving function declared for this weaver"))
:type (or symbol function)
:documentation
"Function to perform the weaving. Must take 2 arguments
COMMAND and ID. COMMAND is the 5th argument of :from-to spec
with all the formats substituted. ID is the id the
corresponding element in :from-to spec.
If this function returns a filename that file will be
displayed to the user."))
"Root weaver class.")
(defclass pm-callback-weaver (pm-weaver)
((callback
:initarg :callback
:initform nil
:type (or symbol function)
:documentation
"Callback function to be called by :function. There is no
default callback. Callbacks must return the output file."))
"Class to represent weavers that call processes spanned by
Emacs.")
(defclass pm-shell-weaver (pm-weaver)
((function
:initform 'pm-default-shell-weave-function)
(sentinel
:initarg :sentinel
:initform 'pm-default-shell-weave-sentinel
:type (or symbol function)
:documentation
"Sentinel function to be called by :function when a shell
call is involved. Sentinel must return the output file
name.")
(quote
:initarg :quote
:initform nil
:type boolean
:documentation "Non-nil when file arguments must be quoted
with `shell-quote-argument'."))
"Class for weavers that call external processes.")
(defun pm-default-shell-weave-function (command sentinel from-to-id &rest _args)
"Run weaving COMMAND interactively with SENTINEL.
Run command in a buffer (in comint-shell-mode) so that it accepts
user interaction. This is a default function in all weavers that
call a shell command. FROM-TO-ID is the idea of the weaver. ARGS
are ignored."
(pm--run-shell-command command sentinel "*polymode weave*"
(concat "weaving " from-to-id " with command:\n\n "
command "\n\n")))
;;; METHODS
(declare-function pm-export "polymode-export")
(cl-defgeneric pm-weave (weaver from-to-id &optional ifile)
"Weave current FILE with WEAVER.
WEAVER is an object of class `pm-weaver'. EXPORT is a list of the
form (FROM TO) suitable to be passed to `polymode-export'. If
EXPORT is provided, corresponding exporter's (from to)
specification will be called.")
(cl-defmethod pm-weave ((weaver pm-weaver) from-to-id &optional ifile)
(pm--process-internal weaver from-to-id nil ifile))
(cl-defmethod pm-weave ((weaver pm-callback-weaver) fromto-id &optional ifile)
(let ((cb (pm--wrap-callback weaver :callback ifile))
;; with transitory output, callback might not run
(pm--export-spec (and pm--output-not-real pm--export-spec)))
(pm--process-internal weaver fromto-id nil ifile cb)))
(cl-defmethod pm-weave ((weaver pm-shell-weaver) fromto-id &optional ifile)
(let ((cb (pm--wrap-callback weaver :sentinel ifile))
;; with transitory output, callback might not run
(pm--export-spec (and pm--output-not-real pm--export-spec)))
(pm--process-internal weaver fromto-id nil ifile cb (eieio-oref weaver 'quote))))
;; UI
(defvar-local pm--weaver-hist nil)
(defvar-local pm--weave:fromto-hist nil)
(defvar-local pm--weave:fromto-last nil)
(defun polymode-weave (&optional from-to)
"Weave current file.
First time this command is called in a buffer the user is asked
for the weaver to use from a list of known weavers.
FROM-TO is the id of the specification declared in :from-to slot
of the current weaver. If the weaver hasn't been set yet, set the
weaver with `polymode-set-weaver'. You can always change the
weaver manually by invoking `polymode-set-weaver'.
If `from-to' dismissing detect automatically based on current
weaver :from-to specifications. If this detection is ambiguous
ask the user.
When `from-to' is universal argument ask user for specification
for the specification. See also `pm-weaveer' for the complete
specification."
(interactive "P")
(cl-flet ((name.id (el) (cons (funcall (cdr el) 'doc (car el)) (car el))))
(let* ((weaver (symbol-value (or (eieio-oref pm/polymode 'weaver)
(polymode-set-weaver))))
(case-fold-search t)
(opts (mapcar #'name.id (pm--selectors weaver :from-to)))
(ft-id
(cond
;; A. guess from-to spec
((null from-to)
(or
;; 1. repeated weaving; don't ask
pm--weave:fromto-last
;; 2. select :from entries which match to current file
(let ((matched (pm--matched-selectors weaver :from-to)))
(when matched
(if (> (length matched) 1)
(cdr (pm--completing-read "Multiple `from-to' specs matched. Choose one: "
(mapcar #'name.id matched)))
(caar matched))))
;; 3. nothing matched, ask
(let* ((prompt "No `from-to' specs matched. Choose one: ")
(sel (pm--completing-read prompt opts nil t nil 'pm--weave:fromto-hist)))
(cdr sel))))
;; B. C-u, force a :from-to spec
((equal from-to '(4))
(cdr (if (> (length opts) 1)
(pm--completing-read "Weaver type: " opts nil t nil 'pm--weave:fromto-hist)
(car opts))))
;; C. string
((stringp from-to)
(if (assoc from-to (eieio-oref weaver 'from-to))
from-to
(error "Cannot find `from-to' spec '%s' in %s weaver"
from-to (eieio-object-name weaver))))
(t (error "'from-to' argument must be nil, universal argument or a string")))))
(setq-local pm--weave:fromto-last ft-id)
(pm-weave weaver ft-id))))
(defmacro polymode-register-weaver (weaver default &rest configs)
"Add WEAVER to :weavers slot of all config objects in CONFIGS.
When DEFAULT is non-nil, also make weaver the default WEAVER for
each polymode in CONFIGS."
`(dolist (pm ',configs)
(object-add-to-list (symbol-value pm) :weavers ',weaver)
(when ,default (oset (symbol-value pm) :weaver ',weaver))))
(defun polymode-set-weaver ()
"Set the current weaver for this polymode."
(interactive)
(unless pm/polymode
(error "No pm/polymode object found. Not in polymode buffer?"))
(let* ((weavers (pm--abrev-names
"pm-weaver/\\|-weaver$"
(delete-dups (pm--oref-with-parents pm/polymode :weavers))))
(sel (pm--completing-read "Choose weaver: " weavers nil t nil 'pm--weaver-hist))
(out (intern (cdr sel))))
(setq pm--weaver-hist (delete-dups pm--weaver-hist))
(setq-local pm--weave:fromto-last nil)
(oset pm/polymode :weaver out)
out))
(provide 'polymode-weave)
;;; polymode-weave.el ends here

688
lisp/polymode/polymode.el Normal file
View File

@@ -0,0 +1,688 @@
;;; polymode.el --- Extensible framework for multiple major modes -*- lexical-binding: t -*-
;;
;; Author: Vitalie Spinu
;; Maintainer: Vitalie Spinu
;; Copyright (C) 2013-2019, Vitalie Spinu
;; Version: 0.2.2
;; Package-Requires: ((emacs "25"))
;; URL: https://github.com/polymode/polymode
;; Keywords: languages, multi-modes, processes
;;
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; 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 GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
;;
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Commentary:
;;
;; Documentation at https://polymode.github.io
;;
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Code:
(require 'polymode-core)
(require 'polymode-classes)
(require 'polymode-methods)
(require 'polymode-compat)
(require 'polymode-export)
(require 'polymode-weave)
(require 'polymode-base)
(require 'poly-lock)
(require 'easymenu)
(require 'derived)
(defvar polymode-prefix-key nil
"[Obsoleted] Prefix key for the polymode mode keymap.
Not effective after loading the polymode library.")
(make-obsolete-variable 'polymode-prefix-key "Unbind in `polymode-mode-map'" "v0.1.6")
(defvar polymode-map
(let ((map (define-prefix-command 'polymode-map)))
;; eval
(define-key map "v" 'polymode-eval-map)
;; navigation
(define-key map "\C-n" 'polymode-next-chunk)
(define-key map "\C-p" 'polymode-previous-chunk)
(define-key map "\C-\M-n" 'polymode-next-chunk-same-type)
(define-key map "\C-\M-p" 'polymode-previous-chunk-same-type)
;; chunk manipulation
(define-key map "\M-k" 'polymode-kill-chunk)
(define-key map "\M-m" 'polymode-mark-or-extend-chunk)
(define-key map "\C-t" 'polymode-toggle-chunk-narrowing)
;; backends
(define-key map "e" 'polymode-export)
(define-key map "E" 'polymode-set-exporter)
(define-key map "w" 'polymode-weave)
(define-key map "W" 'polymode-set-weaver)
(define-key map "t" 'polymode-tangle)
(define-key map "T" 'polymode-set-tangler)
(define-key map "$" 'polymode-show-process-buffer)
map)
"Polymode prefix map.
Lives on `polymode-prefix-key' in polymode buffers.")
(defvaralias 'polymode-mode-map 'polymode-minor-mode-map)
(defvar polymode-minor-mode-map
(let ((map (make-sparse-keymap)))
(define-key map (or polymode-prefix-key "\M-n") 'polymode-map)
map)
"The minor mode keymap which is inherited by all polymodes.")
(easy-menu-define polymode-menu polymode-minor-mode-map
"Menu for polymode."
'("Polymode"
["Next chunk" polymode-next-chunk]
["Previous chunk" polymode-previous-chunk]
["Next chunk same type" polymode-next-chunk-same-type]
["Previous chunk same type" polymode-previous-chunk-same-type]
["Mark or extend chunk" polymode-mark-or-extend-chunk]
["Kill chunk" polymode-kill-chunk]
"--"
["Weave" polymode-weave]
["Set Weaver" polymode-set-weaver]
"--"
["Export" polymode-export]
["Set Exporter" polymode-set-exporter]))
;;; NAVIGATION
(defun polymode-next-chunk (&optional N)
"Go N chunks forwards.
Return the number of actually moved over chunks. This command is
a \"cycling\" command (see `polymode-next-chunk-same-type' for an
example)."
(interactive "p")
(pm-goto-span-of-type '(nil body) N)
;; If head/tail end before eol we move to the next line
(when (looking-at "\\s *$")
(forward-line 1))
(pm--set-transient-map (list #'polymode-previous-chunk
#'polymode-next-chunk)))
;;fixme: problme with long chunks .. point is recentered
;;todo: merge into next-chunk
(defun polymode-previous-chunk (&optional N)
"Go N chunks backwards.
This command is a \"cycling\" command (see
`polymode-next-chunk-same-type' for an example). Return the
number of chunks jumped over."
(interactive "p")
(polymode-next-chunk (- N)))
(defun polymode-next-chunk-same-type (&optional N)
"Go to next N chunk.
Return the number of chunks of the same type moved over. This
command is a \"cycling\" command in the sense that you can repeat
the basic key without the prefix multiple times to invoke the
command multiple times."
(interactive "p")
(let* ((sofar 0)
(back (< N 0))
(beg (if back (point-min) (point)))
(end (if back (point) (point-max)))
(N (if back (- N) N))
(orig-pos (point))
(pos (point))
this-type this-name)
(condition-case-unless-debug nil
(pm-map-over-spans
(lambda (span)
(unless (memq (car span) '(head tail))
(when (and (equal this-name
(eieio-object-name-string (nth 3 span)))
(eq this-type (car span)))
(setq pos (nth 1 span))
(setq sofar (1+ sofar)))
(unless this-name
(setq this-name (eieio-object-name-string (nth 3 span))
this-type (car span)))
(when (>= sofar N)
(signal 'quit nil))))
beg end nil back)
(quit (when (looking-at "\\s *$")
(forward-line))))
(goto-char pos)
(when (or (eobp) (bobp) (eq pos orig-pos))
(message "No more chunks of type %s" this-name)
(ding))
(pm--set-transient-map (list #'polymode-previous-chunk-same-type
#'polymode-next-chunk-same-type))
sofar))
(defun polymode-previous-chunk-same-type (&optional N)
"Go to previous N chunk.
Return the number of chunks of the same type moved over."
(interactive "p")
(polymode-next-chunk-same-type (- N)))
;;; KILL and NARROWING
(defun pm--kill-span (types)
(let ((span (pm-innermost-span)))
(when (memq (car span) types)
(delete-region (nth 1 span) (nth 2 span)))))
(defun polymode-kill-chunk ()
"Kill current chunk."
(interactive)
(pcase (pm-innermost-span)
(`(,(or `nil `host) ,beg ,end ,_) (delete-region beg end))
(`(body ,beg ,_ ,_)
(goto-char beg)
(pm--kill-span '(body))
(pm--kill-span '(head tail))
(pm--kill-span '(head tail)))
(`(tail ,beg ,end ,_)
(if (eq beg (point-min))
(delete-region beg end)
(goto-char (1- beg))
(polymode-kill-chunk)))
(`(head ,_ ,end ,_)
(goto-char end)
(polymode-kill-chunk))
(_ (error "Canoot find chunk to kill"))))
(defun polymode-toggle-chunk-narrowing ()
"Toggle narrowing of the body of current chunk."
(interactive)
(if (buffer-narrowed-p)
(progn (widen) (recenter))
(pcase (pm-innermost-span)
(`(head ,_ ,end ,_)
(goto-char end)
(pm-narrow-to-span))
(`(tail ,beg ,_ ,_)
(if (eq beg (point-min))
(error "Invalid chunk")
(goto-char (1- beg))
(pm-narrow-to-span)))
(_ (pm-narrow-to-span)))))
(defun pm-chunk-range (&optional pos)
"Return a range (BEG . END) for a chunk at POS."
(setq pos (or pos (point)))
(let ((span (pm-innermost-span pos))
(pmin (point-min))
(pmax (point-max)))
(cl-case (car span)
((nil) (pm-span-to-range span))
(body (cons (if (= pmin (nth 1 span))
pmin
(nth 1 (pm-innermost-span (1- (nth 1 span)))))
(if (= pmax (nth 2 span))
pmax
(nth 2 (pm-innermost-span (nth 2 span))))))
(head (if (= pmax (nth 2 span))
(pm-span-to-range span)
(pm-chunk-range (nth 2 span))))
(tail (if (= pmin (nth 1 span))
(pm-span-to-range span)
(pm-chunk-range (1- (nth 1 span))))))))
(defun polymode-mark-or-extend-chunk ()
"DWIM command to repeatedly mark chunk or extend region.
When no region is active, mark the current span if in body of a
chunk or the whole chunk if in head or tail. On repeated
invocation extend the region either forward or backward. You need
not use the prefix key on repeated invocation. For example
assuming we are in the body of the inner chunk and this command
is bound on M\\=-n M\\=-m (the default)
[M\\=-n M\\=-m M\\=-m M\\=-m] selects body, expand selection to chunk then
expand selection to previous chunk
[M\\=-n M\\=-m C\\=-x C\\=-x M\\=-m] selects body, expand selection to chunk,
then reverse point and mark, then extend the
selection to the following chunk"
(interactive)
(let ((span (pm-innermost-span)))
(if (region-active-p)
(if (< (mark) (point))
;; forward extension
(if (eobp)
(user-error "End of buffer")
(if (eq (car span) 'head)
(goto-char (cdr (pm-chunk-range)))
(goto-char (nth 2 span))
;; special dwim when extending from body
(when (and (eq (car span) 'tail)
(not (= (point-min) (nth 1 span))))
(let ((body-span (pm-innermost-span (1- (nth 1 span)))))
(when (and (= (nth 1 body-span) (mark))
(not (= (nth 1 body-span) (point-min))))
(let ((head-span (pm-innermost-span (1- (nth 1 body-span)))))
(when (eq (car head-span) 'head)
(set-mark (nth 1 head-span)))))))))
;; backward extension
(if (bobp)
(user-error "Beginning of buffer")
(goto-char (car (if (= (point) (nth 1 span))
(pm-chunk-range (1- (point)))
(pm-chunk-range (point)))))
;; special dwim when extending from body
(when (and (eq (car span) 'body)
(= (nth 2 span) (mark)))
(let ((tail-span (pm-innermost-span (nth 2 span))))
(when (eq (car tail-span) 'tail)
(set-mark (nth 2 tail-span)))))))
(let ((range (if (memq (car span) '(nil body))
(pm-span-to-range span)
(pm-chunk-range))))
(set-mark (cdr range))
(goto-char (car range)))))
(let ((map (make-sparse-keymap)))
(define-key map (vector last-command-event) #'polymode-mark-or-extend-chunk)
(define-key map (car (where-is-internal #'exchange-point-and-mark)) #'exchange-point-and-mark)
(let ((ev (event-basic-type last-command-event)))
(define-key map (vector ev) #'polymode-mark-or-extend-chunk))
(set-transient-map map (lambda () (eq this-command 'exchange-point-and-mark)))))
(defun polymode-show-process-buffer ()
"Show the process buffer used by weaving and exporting programs."
(interactive)
(let ((buf (cl-loop for b being the buffers
if (buffer-local-value 'pm--process-buffer b)
return b)))
(if buf
(pop-to-buffer buf `(nil . ((inhibit-same-window . ,pop-up-windows))))
(message "No polymode process buffers found."))))
;;; EVALUATION
(defvar polymode-eval-map
(let (polymode-eval-map)
(define-prefix-command 'polymode-eval-map)
(define-key polymode-eval-map "v" #'polymode-eval-region-or-chunk)
(define-key polymode-eval-map "b" #'polymode-eval-buffer)
(define-key polymode-eval-map "u" #'polymode-eval-buffer-from-beg-to-point)
(define-key polymode-eval-map "d" #'polymode-eval-buffer-from-point-to-end)
(define-key polymode-eval-map (kbd "<up>") #'polymode-eval-buffer-from-beg-to-point)
(define-key polymode-eval-map (kbd "<down>") #'polymode-eval-buffer-from-point-to-end)
polymode-eval-map)
"Keymap for polymode evaluation commands.")
(defvar-local polymode-eval-region-function nil
"Function taking three arguments which does mode specific evaluation.
First two arguments are BEG and END of the region. The third
argument is the message describing the evaluation type. If the
value of this variable is non-nil in the host mode then all inner
spans are evaluated within the host buffer and values of this
variable for the inner modes are ignored.")
(defun polymode-eval-region (beg end &optional msg)
"Eval all spans within region defined by BEG and END.
MSG is a message to be passed to `polymode-eval-region-function';
defaults to \"Eval region\"."
(interactive "r")
(save-excursion
(let* ((base (pm-base-buffer))
(host-fun (buffer-local-value 'polymode-eval-region-function base))
(msg (or msg "Eval region"))
evalled mapped)
(if host-fun
(pm-map-over-spans
(lambda (span)
(when (eq (car span) 'body)
(with-current-buffer base
(funcall host-fun (max beg (nth 1 span)) (min end (nth 2 span)) msg))))
beg end)
(pm-map-over-spans
(lambda (span)
(when (eq (car span) 'body)
(setq mapped t)
(when polymode-eval-region-function
(setq evalled t)
(funcall polymode-eval-region-function
(max beg (nth 1 span))
(min end (nth 2 span))
msg))))
beg end)
(unless mapped
(user-error "No inner spans in the region"))
(unless evalled
(user-error "None of the inner spans have `polymode-eval-region-function' defined"))))))
(defun polymode-eval-chunk (span-or-pos &optional no-error)
"Eval the body span of the inner chunk at point.
SPAN-OR-POS is either a span or a point. When NO-ERROR is
non-nil, don't throw if `polymode-eval-region-function' is nil."
(interactive "d")
(let* ((span (if (number-or-marker-p span-or-pos)
(pm-innermost-span span-or-pos)
span-or-pos))
(body-span (pcase (car span)
('head (pm-innermost-span (nth 2 span)))
('tail (pm-innermost-span (1- (nth 1 span))))
('body span)
(_ (user-error "Not in an inner chunk"))))
(base (pm-base-buffer))
(host-fun (buffer-local-value 'polymode-eval-region-function base))
(msg "Eval chunk"))
(save-excursion
(pm-set-buffer body-span)
(if host-fun
(with-current-buffer base
(funcall host-fun (nth 1 body-span) (nth 2 body-span) msg))
(if polymode-eval-region-function
(funcall polymode-eval-region-function (nth 1 body-span) (nth 2 body-span) msg)
(unless no-error
(error "Undefined `polymode-eval-region-function' in buffer %s" (current-buffer))))))))
(defun polymode-eval-region-or-chunk ()
"Eval all inner chunks in region if active, or current chunk otherwise."
(interactive)
(if (use-region-p)
(polymode-eval-region (region-beginning) (region-end))
(polymode-eval-chunk (point))))
(defun polymode-eval-buffer ()
"Eval all inner chunks in the buffer."
(interactive)
(polymode-eval-region (point-min) (point-max) "Eval buffer"))
(defun polymode-eval-buffer-from-beg-to-point ()
"Eval all inner chunks from beginning of buffer till point."
(interactive)
(polymode-eval-region (point-min) (point) "Eval buffer till point"))
(defun polymode-eval-buffer-from-point-to-end ()
"Eval all inner chunks from point to the end of buffer."
(interactive)
(polymode-eval-region (point) (point-max) "Eval buffer till end"))
;;; DEFINE
(defun pm--config-name (symbol &optional must-exist)
(let* ((poly-name (replace-regexp-in-string "pm-poly/\\|poly-\\|-mode\\|-polymode\\|-minor-mode" ""
(symbol-name symbol)))
(config-name
(if (and (boundp symbol)
(symbol-value symbol)
(object-of-class-p (symbol-value symbol) 'pm-polymode))
symbol
(intern (concat "poly-" poly-name "-polymode")))))
(when must-exist
(unless (boundp config-name)
(let ((old-config-name (intern (concat "pm-poly/" poly-name))))
(if (boundp old-config-name)
(setq config-name old-config-name)
(error "No pm-polymode config object with name `%s'" config-name))))
(unless (object-of-class-p (symbol-value config-name) 'pm-polymode)
(error "`%s' is not a `pm-polymode' config object" config-name)))
config-name))
(defun pm--get-keylist.keymap-from-parent (keymap parent-conf)
(let ((keylist (copy-sequence keymap))
(pi parent-conf)
(parent-map))
(while pi
(let ((map (and (slot-boundp pi :keylist)
(eieio-oref pi 'keylist))))
(when map
(if (and (symbolp map)
(keymapp (symbol-value map)))
;; if one of the parent's :keylist is a keymap, use it as our
;; parent-map and stop further descent
(setq parent-map map
pi nil)
;; list, descend to next parent and append the key list to keylist
(setq pi (and (slot-boundp pi :parent-instance)
(eieio-oref pi 'parent-instance))
keylist (append map keylist))))))
(when (and parent-map (symbolp parent-map))
(setq parent-map (symbol-value parent-map)))
(cons (reverse keylist)
(or parent-map polymode-minor-mode-map))))
;;;###autoload
(defmacro define-polymode (mode &optional parent doc &rest body)
"Define a new polymode MODE.
This macro defines command MODE and an indicator variable MODE
which becomes t when MODE is active and nil otherwise.
MODE command can be used as both major and minor mode. Using
polymodes as minor modes makes sense when :hostmode (see below)
is not specified, in which case polymode installs only inner
modes and doesn't touch current major mode.
Standard hook MODE-hook is run at the end of the initialization
of each polymode buffer (both indirect and base buffers).
This macro also defines the MODE-map keymap from the :keymap
argument and PARENT-map (see below) and poly-[MODE-NAME]-polymode
variable which holds an object of class `pm-polymode' which holds
the entire configuration for this polymode.
PARENT is either the polymode configuration object or a polymode
mode (there is 1-to-1 correspondence between config
objects (`pm-polymode') and mode functions). The new polymode
MODE inherits alll the behavior from PARENT except for the
overwrites specified by the keywords (see below). The new MODE
runs all the hooks from the PARENT-mode and inherits its MODE-map
from PARENT-map.
DOC is an optional documentation string. If present PARENT must
be provided, but can be nil.
BODY is executed after the complete initialization of the
polymode but before MODE-hook. It is executed once for each
polymode buffer - host buffer on initialization and every inner
buffer subsequently created.
Before the BODY code keyword arguments (i.e. alternating keywords
and values) are allowed. The following special keywords
controlling the behavior of the new MODE are supported:
:lighter Optional LIGHTER is displayed in the mode line when the
mode is on. If omitted, it defaults to the :lighter slot of
CONFIG object.
:keymap If nil, a new MODE-map keymap is created what directly
inherits from the PARENT's keymap. The last keymap in the
inheritance chain is always `polymode-minor-mode-map'. If a
keymap it is used directly as it is. If a list of binding of
the form (KEY . BINDING) it is merged the bindings are added to
the newly create keymap.
:after-hook A single form which is evaluated after the mode hooks
have been run. It should not be quoted.
Other keywords are added to the `pm-polymode' configuration
object and should be valid slots in PARENT config object or the
root config `pm-polymode' object if PARENT is nil. By far the
most frequently used slots are:
:hostmode Symbol pointing to a `pm-host-chunkmode' object
specifying the behavior of the hostmode. If missing or nil,
MODE will behave as a minor-mode in the sense that it will
reuse the currently installed major mode and will install only
the inner modes.
:innermodes List of symbols pointing to `pm-inner-chunkmode'
objects which specify the behavior of inner modes (or submodes)."
(declare
(doc-string 3)
(debug (&define name
[&optional [&not keywordp] name]
[&optional stringp]
[&rest [keywordp sexp]]
def-body)))
(let* ((last-message (make-symbol "last-message"))
(mode-name (symbol-name mode))
(config-name (pm--config-name mode))
(root-name (replace-regexp-in-string "poly-\\|-mode" "" mode-name))
(keymap-name (intern (concat mode-name "-map")))
keymap keylist slots after-hook keyw lighter)
(if (keywordp parent)
(progn
(push doc body)
(push parent body)
(setq doc nil
parent nil))
(unless (stringp doc)
(push doc body)
(setq doc (format "Polymode for %s." root-name))))
(unless (symbolp parent)
(error "PARENT must be a name of a `pm-polymode' config or a polymode mode function"))
;; Check keys
(while (keywordp (setq keyw (car body)))
(setq body (cdr body))
(pcase keyw
(`:lighter (setq lighter (purecopy (pop body))))
(`:keymap (setq keymap (pop body)))
(`:after-hook (setq after-hook (pop body)))
(`:keylist (setq keylist (pop body)))
(_ (push (pop body) slots) (push keyw slots))))
`(progn
;; Define the variable to enable or disable the mode.
(defvar-local ,mode nil ,(format "Non-nil if `%s' polymode is enabled." mode))
(let* ((parent ',parent)
(keymap ,keymap)
(keylist ,keylist)
(parent-conf-name (and parent (pm--config-name parent 'must-exist)))
(parent-conf (and parent-conf-name (symbol-value parent-conf-name))))
;; define the minor-mode's keymap
(makunbound ',keymap-name)
(defvar ,keymap-name
(if (keymapp keymap)
keymap
(let ((parent-map (unless (keymapp keymap)
;; keymap is either nil or a list
(cond
;; 1. if parent is config object, merge all list
;; keymaps from parents
((eieio-object-p (symbol-value parent))
(let ((klist.kmap (pm--get-keylist.keymap-from-parent
keymap (symbol-value parent))))
(setq keymap (append keylist (car klist.kmap)))
(cdr klist.kmap)))
;; 2. If parent is polymode function, take the
;; minor-mode from the parent config
(parent
(symbol-value
(derived-mode-map-name
(eieio-oref parent-conf '-minor-mode))))
;; 3. nil
(t polymode-minor-mode-map)))))
(easy-mmode-define-keymap keymap nil nil (list :inherit parent-map))))
,(format "Keymap for %s." mode-name))
,@(unless (eq parent config-name)
`((makunbound ',config-name)
(defvar ,config-name
(if parent-conf-name
(clone parent-conf
:name ,(symbol-name config-name)
'-minor-mode ',mode
,@slots)
(pm-polymode :name ,(symbol-name config-name)
'-minor-mode ',mode
,@slots))
,(format "Configuration object for `%s' polymode." mode))))
;; The actual mode function:
(defun ,mode (&optional arg)
,(format "%s\n\n\\{%s}"
;; fixme: add inheretance info here and warning if body is
;; non-nil (like in define-mirror-mode)
doc keymap-name)
(interactive)
(let ((,last-message (current-message))
(state (cond
((numberp arg) (> arg 0))
(arg t)
((not ,mode)))))
(setq ,mode state)
(if state
(unless (buffer-base-buffer)
;; Call in host (base) buffers only.
(when ,mode
(let ((obj (clone ,config-name)))
;; (eieio-oset obj '-minor-mode ',mode)
(pm-initialize obj))
;; when host mode is reset in pm-initialize we end up with new
;; minor mode in hosts
(setq ,mode t)))
(let ((base (pm-base-buffer)))
(pm-turn-polymode-off t)
(switch-to-buffer base)))
;; `body` and `hooks` are executed in all buffers; pm/polymode has been set
,@body
(when state
(pm--run-derived-mode-hooks)
,@(when after-hook `(,after-hook)))
(unless (buffer-base-buffer)
;; Avoid overwriting a message shown by the body,
;; but do overwrite previous messages.
(when (and (called-interactively-p 'any)
(or (null (current-message))
(not (equal ,last-message
(current-message)))))
(message ,(concat root-name " polymode %s")
(if state "enabled" "disabled"))))
(force-mode-line-update))
;; Return the new state
,mode)
(add-minor-mode ',mode ,(or lighter " PM") ,keymap-name)))))
(define-minor-mode polymode-minor-mode
"Polymode minor mode, used to make everything work."
nil " PM")
(define-derived-mode poly-head-tail-mode prog-mode "HeadTail"
"Default major mode for polymode head and tail spans."
(let ((base (pm-base-buffer)))
;; (#119) hideshow needs comment regexp and throws if not found. We are
;; using these values from the host mode which should have been installed
;; already.
(setq-local comment-start (buffer-local-value 'comment-start base))
(setq-local comment-end (buffer-local-value 'comment-end base))))
(define-derived-mode poly-fallback-mode prog-mode "FallBack"
;; fixme:
;; 1. doesn't work as fallback for hostmode
;; 2. highlighting is lost (Rnw with inner fallback)
"Default major mode for modes which were not found.
This is better than fundamental-mode because it allows running
globalized minor modes and can run user hooks.")
;; indulge elisp font-lock (FIXME: check if this is needed; why host/inner defs work?)
(dolist (mode '(emacs-lisp-mode lisp-interaction-mode))
(font-lock-add-keywords
mode
'(("(\\(define-polymode\\)\\s +\\(\\(\\w\\|\\s_\\)+\\)"
(1 font-lock-keyword-face)
(2 font-lock-variable-name-face)))))
(provide 'polymode)
;;; polymode.el ends here