From f9197efb5d04e61f30206405b93ffbadca550e51 Mon Sep 17 00:00:00 2001 From: Nelson Elhage Date: Sun, 25 Aug 2019 18:41:23 -0700 Subject: [PATCH] tla-tools --- .gitmodules | 3 + dot-emacs | 5 +- elpa/polymode-20190714.2017/poly-lock.el | 561 +++++ .../polymode-autoloads.el | 217 ++ elpa/polymode-20190714.2017/polymode-base.el | 122 + .../polymode-classes.el | 495 ++++ .../polymode-20190714.2017/polymode-compat.el | 373 +++ elpa/polymode-20190714.2017/polymode-core.el | 2129 +++++++++++++++++ elpa/polymode-20190714.2017/polymode-debug.el | 557 +++++ .../polymode-20190714.2017/polymode-export.el | 449 ++++ .../polymode-methods.el | 684 ++++++ elpa/polymode-20190714.2017/polymode-pkg.el | 12 + .../polymode-20190714.2017/polymode-tangle.el | 35 + .../polymode-test-utils.el | 466 ++++ elpa/polymode-20190714.2017/polymode-weave.el | 281 +++ elpa/polymode-20190714.2017/polymode.el | 690 ++++++ site/tla-tools | 1 + 17 files changed, 7079 insertions(+), 1 deletion(-) create mode 100644 elpa/polymode-20190714.2017/poly-lock.el create mode 100644 elpa/polymode-20190714.2017/polymode-autoloads.el create mode 100644 elpa/polymode-20190714.2017/polymode-base.el create mode 100644 elpa/polymode-20190714.2017/polymode-classes.el create mode 100644 elpa/polymode-20190714.2017/polymode-compat.el create mode 100644 elpa/polymode-20190714.2017/polymode-core.el create mode 100644 elpa/polymode-20190714.2017/polymode-debug.el create mode 100644 elpa/polymode-20190714.2017/polymode-export.el create mode 100644 elpa/polymode-20190714.2017/polymode-methods.el create mode 100644 elpa/polymode-20190714.2017/polymode-pkg.el create mode 100644 elpa/polymode-20190714.2017/polymode-tangle.el create mode 100644 elpa/polymode-20190714.2017/polymode-test-utils.el create mode 100644 elpa/polymode-20190714.2017/polymode-weave.el create mode 100644 elpa/polymode-20190714.2017/polymode.el create mode 160000 site/tla-tools diff --git a/.gitmodules b/.gitmodules index bd8db3a..73f912c 100644 --- a/.gitmodules +++ b/.gitmodules @@ -25,3 +25,6 @@ [submodule "site/mmm-mode"] path = site/mmm-mode url = git://github.com/purcell/mmm-mode.git +[submodule "site/tla-tools"] + path = site/tla-tools + url = https://github.com/mrc/tla-tools diff --git a/dot-emacs b/dot-emacs index e835c3e..af817a0 100644 --- a/dot-emacs +++ b/dot-emacs @@ -1565,7 +1565,7 @@ surrounding xml expression" '(confirm-kill-processes nil t) '(package-selected-packages (quote - (company-lsp yasnippet racer magit-popup rust-mode web-mode visual-fill-column lsp-mode lsp-ui markdown-mode counsel helm-ls-git helm-git-files yaml-mode js2-mode caddyfile-mode ledger-mode scala-mode graphviz-dot-mode git-link web-mode flycheck-clangcheck visual-fill-column ac-rtags company-rtags rtags company-racer racer flycheck-rust rust-mode flycheck-ocaml tuareg lua-mode gnuplot gnuplot-mode thrift terraform-mode seq ruby-tools ruby-mode ruby-electric rubocop popwin magit-gh-pulls magit-gerrit javaimp inf-ruby helm go-eldoc fuzzy flycheck f exec-path-from-shell edit-server debian-changelog-mode dash-at-point company-go coffee-mode cmake-mode clojure-mode clang-format bison-mode auto-complete))) + (polymode company-lsp yasnippet racer magit-popup rust-mode web-mode visual-fill-column lsp-mode lsp-ui markdown-mode counsel helm-ls-git helm-git-files yaml-mode js2-mode caddyfile-mode ledger-mode scala-mode graphviz-dot-mode git-link web-mode flycheck-clangcheck visual-fill-column ac-rtags company-rtags rtags company-racer racer flycheck-rust rust-mode flycheck-ocaml tuareg lua-mode gnuplot gnuplot-mode thrift terraform-mode seq ruby-tools ruby-mode ruby-electric rubocop popwin magit-gh-pulls magit-gerrit javaimp inf-ruby helm go-eldoc fuzzy flycheck f exec-path-from-shell edit-server debian-changelog-mode dash-at-point company-go coffee-mode cmake-mode clojure-mode clang-format bison-mode auto-complete))) '(safe-local-variable-values (quote ((encoding . utf-8) @@ -1577,3 +1577,6 @@ surrounding xml expression" (load local-config))) (require 'sorbet-lsp) + +(load "tla-tools/tla-tools.el") +(load "tla-tools/tla-pcal-mode") diff --git a/elpa/polymode-20190714.2017/poly-lock.el b/elpa/polymode-20190714.2017/poly-lock.el new file mode 100644 index 0000000..8b3187c --- /dev/null +++ b/elpa/polymode-20190714.2017/poly-lock.el @@ -0,0 +1,561 @@ +;;; 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/vspinu/polymode +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; This file is *NOT* part of GNU Emacs. +;; +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 3, or +;; (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . +;; +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; 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") +(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 (list :background + (poly-lock--adjusted-background face)))) + face))) + (when face + (font-lock-append-text-property + (nth 1 span) (nth 2 span) 'face face))))) + +(provide 'poly-lock) +;;; poly-lock.el ends here diff --git a/elpa/polymode-20190714.2017/polymode-autoloads.el b/elpa/polymode-20190714.2017/polymode-autoloads.el new file mode 100644 index 0000000..882fa72 --- /dev/null +++ b/elpa/polymode-20190714.2017/polymode-autoloads.el @@ -0,0 +1,217 @@ +;;; polymode-autoloads.el --- automatically extracted autoloads +;; +;;; Code: +(add-to-list 'load-path (directory-file-name (or (file-name-directory #$) (car load-path)))) + +;;;### (autoloads nil "polymode" "../../../.emacs.d/elpa/polymode-20190714.2017/polymode.el" +;;;;;; "699dfad7a26a6b8d3fdd2be900b339de") +;;; Generated autoloads from ../../../.emacs.d/elpa/polymode-20190714.2017/polymode.el + +(autoload 'define-polymode "polymode" "\ +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). + +\(fn MODE &optional PARENT DOC &rest BODY)" nil t) + +(function-put 'define-polymode 'doc-string-elt '3) + +;;;*** + +;;;### (autoloads nil "polymode-core" "../../../.emacs.d/elpa/polymode-20190714.2017/polymode-core.el" +;;;;;; "d089e1d132a4b4fcae437bbd478fa043") +;;; Generated autoloads from ../../../.emacs.d/elpa/polymode-20190714.2017/polymode-core.el + +(defvar-local polymode-default-inner-mode nil "\ +Inner mode for chunks with unspecified modes. +Intended to be used as local variable in polymode buffers. A +special value 'host means use the host mode.") + +(put 'polymode-default-inner-mode 'safe-local-variable 'symbolp) + +(autoload 'define-hostmode "polymode-core" "\ +Define a hostmode with name NAME. +Optional PARENT is a name of a hostmode to be derived (cloned) +from. If missing, the optional documentation string DOC is +generated automatically. KEY-ARGS is a list of key-value pairs. +See the documentation of the class `pm-host-chunkmode' for +possible values. + +\(fn NAME &optional PARENT DOC &rest KEY-ARGS)" nil t) + +(function-put 'define-hostmode 'doc-string-elt '3) + +(autoload 'define-innermode "polymode-core" "\ +Ddefine an innermode with name NAME. +Optional PARENT is a name of a innermode to be derived (cloned) +from. If missing the optional documentation string DOC is +generated automatically. KEY-ARGS is a list of key-value pairs. +See the documentation of the class `pm-inner-chunkmode' for +possible values. + +\(fn NAME &optional PARENT DOC &rest KEY-ARGS)" nil t) + +(function-put 'define-innermode 'doc-string-elt '3) + +(autoload 'define-auto-innermode "polymode-core" "\ +Ddefine an auto innermode with name NAME. +Optional PARENT is a name of an auto innermode to be +derived (cloned) from. If missing the optional documentation +string DOC is generated automatically. KEY-ARGS is a list of +key-value pairs. See the documentation of the class +`pm-inner-auto-chunkmode' for possible values. + +\(fn NAME &optional PARENT DOC &rest KEY-ARGS)" nil t) + +(function-put 'define-auto-innermode 'doc-string-elt '3) + +;;;*** + +;;;### (autoloads nil "polymode-debug" "../../../.emacs.d/elpa/polymode-20190714.2017/polymode-debug.el" +;;;;;; "18f81b35c4990313b04707549de9c330") +;;; Generated autoloads from ../../../.emacs.d/elpa/polymode-20190714.2017/polymode-debug.el + +(autoload 'pm-debug-minor-mode "polymode-debug" "\ +Turns on/off useful facilities for debugging polymode. + +Key bindings: +\\{pm-debug-minor-mode-map} + +\(fn &optional ARG)" t nil) + +(autoload 'pm-debug-minor-mode-on "polymode-debug" "\ + + +\(fn)" nil nil) + +(defvar pm-debug-mode nil "\ +Non-nil if Pm-Debug mode is enabled. +See the `pm-debug-mode' command +for a description of this minor mode. +Setting this variable directly does not take effect; +either customize it (see the info node `Easy Customization') +or call the function `pm-debug-mode'.") + +(custom-autoload 'pm-debug-mode "polymode-debug" nil) + +(autoload 'pm-debug-mode "polymode-debug" "\ +Toggle Pm-Debug minor mode in all buffers. +With prefix ARG, enable Pm-Debug mode if ARG is positive; +otherwise, disable it. If called from Lisp, enable the mode if +ARG is omitted or nil. + +Pm-Debug minor mode is enabled in all buffers where +`pm-debug-minor-mode-on' would do it. +See `pm-debug-minor-mode' for more information on Pm-Debug minor mode. + +\(fn &optional ARG)" t nil) + +(autoload 'pm-toggle-tracing "polymode-debug" "\ +Toggle polymode tracing. +With numeric prefix toggle tracing for that LEVEL. Currently +universal argument toggles maximum level of tracing (4). Default +level is 3. + +\(fn LEVEL)" t nil) + +(autoload 'pm-trace "polymode-debug" "\ +Trace function FN. +Use `untrace-function' to untrace or `untrace-all' to untrace all +currently traced functions. + +\(fn FN)" t nil) + +(autoload 'pm-debug-relevant-variables "polymode-debug" "\ +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. + +\(fn &optional OUT-TYPE)" t nil) + +;;;*** + +;;;### (autoloads nil nil ("../../../.emacs.d/elpa/polymode-20190714.2017/poly-lock.el" +;;;;;; "../../../.emacs.d/elpa/polymode-20190714.2017/polymode-autoloads.el" +;;;;;; "../../../.emacs.d/elpa/polymode-20190714.2017/polymode-base.el" +;;;;;; "../../../.emacs.d/elpa/polymode-20190714.2017/polymode-classes.el" +;;;;;; "../../../.emacs.d/elpa/polymode-20190714.2017/polymode-compat.el" +;;;;;; "../../../.emacs.d/elpa/polymode-20190714.2017/polymode-core.el" +;;;;;; "../../../.emacs.d/elpa/polymode-20190714.2017/polymode-debug.el" +;;;;;; "../../../.emacs.d/elpa/polymode-20190714.2017/polymode-export.el" +;;;;;; "../../../.emacs.d/elpa/polymode-20190714.2017/polymode-methods.el" +;;;;;; "../../../.emacs.d/elpa/polymode-20190714.2017/polymode-pkg.el" +;;;;;; "../../../.emacs.d/elpa/polymode-20190714.2017/polymode-tangle.el" +;;;;;; "../../../.emacs.d/elpa/polymode-20190714.2017/polymode-test-utils.el" +;;;;;; "../../../.emacs.d/elpa/polymode-20190714.2017/polymode-weave.el" +;;;;;; "../../../.emacs.d/elpa/polymode-20190714.2017/polymode.el") +;;;;;; (23907 14514 775973 576000)) + +;;;*** + +;; Local Variables: +;; version-control: never +;; no-byte-compile: t +;; no-update-autoloads: t +;; End: +;;; polymode-autoloads.el ends here diff --git a/elpa/polymode-20190714.2017/polymode-base.el b/elpa/polymode-20190714.2017/polymode-base.el new file mode 100644 index 0000000..fe57374 --- /dev/null +++ b/elpa/polymode-20190714.2017/polymode-base.el @@ -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/vspinu/polymode +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; This file is *NOT* part of GNU Emacs. +;; +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 3, or +;; (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; 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 diff --git a/elpa/polymode-20190714.2017/polymode-classes.el b/elpa/polymode-20190714.2017/polymode-classes.el new file mode 100644 index 0000000..e229034 --- /dev/null +++ b/elpa/polymode-20190714.2017/polymode-classes.el @@ -0,0 +1,495 @@ +;;; polymode-classes.el --- Core polymode classes -*- lexical-binding: t -*- +;; +;; Copyright (C) 2013-2019, Vitalie Spinu +;; Author: Vitalie Spinu +;; URL: https://github.com/vspinu/polymode +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; This file is *NOT* part of GNU Emacs. +;; +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 3, or +;; (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: +;; +;;; Code: + +(require 'eieio) +(require 'eieio-base) +(require 'eieio-custom) + +;; FIXME: fix emacs eieo-named bug #22840 where they wrongly set name of the +;; parent object in clone method + +(setq eieio-backward-compatibility nil) + +(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.") + +(setq eieio-backward-compatibility t) + +(provide 'polymode-classes) +;;; polymode-classes.el ends here diff --git a/elpa/polymode-20190714.2017/polymode-compat.el b/elpa/polymode-20190714.2017/polymode-compat.el new file mode 100644 index 0000000..edf0cc2 --- /dev/null +++ b/elpa/polymode-20190714.2017/polymode-compat.el @@ -0,0 +1,373 @@ +;;; 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/vitoshka/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 . +;; +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; 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)) + (name (buffer-name))) + (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") +(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) +;;; polymode-compat.el ends here diff --git a/elpa/polymode-20190714.2017/polymode-core.el b/elpa/polymode-20190714.2017/polymode-core.el new file mode 100644 index 0000000..d4accb2 --- /dev/null +++ b/elpa/polymode-20190714.2017/polymode-core.el @@ -0,0 +1,2129 @@ +;; polymode-core.el --- Core initialization and utilities for polymode -*- lexical-binding: t -*- +;; +;; Copyright (C) 2013-2019, Vitalie Spinu +;; Author: Vitalie Spinu +;; URL: https://github.com/vspinu/polymode +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; This file is *NOT* part of GNU Emacs. +;; +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 3, or +;; (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: +;; +;;; Code: + +(require 'gv) +(require 'font-lock) +(require 'color) +(require 'polymode-classes) +(require 'format-spec) +(require 'subr-x) +(eval-when-compile + (require 'cl-lib) + (require 'derived)) + + +;;; ESSENTIAL DECLARATIONS +(defvar *span* nil) +(defvar-local pm/polymode nil) +(put 'pm/polymode 'permanent-local t) +(defvar-local pm/chunkmode nil) +(defvar-local pm/current nil) ;; fixme: unused +(defvar-local pm/type nil) ;; fixme: remove this +(defvar-local polymode-mode nil + "Non-nil if current \"mode\" is a polymode.") +(defvar pm--emacs>26 (version<= "26" emacs-version)) + +;; overwrites +(defvar-local pm--indent-region-function-original nil) +(defvar-local pm--fill-forward-paragraph-original nil) +(defvar-local pm--indent-line-function-original nil) +(defvar-local pm--syntax-propertize-function-original nil) + +;; silence the compiler +(defvar pm--output-file nil) +(defvar pm--input-buffer nil) +(defvar pm--input-file nil) +(defvar pm--export-spec nil) +(defvar pm--input-not-real nil) +(defvar pm--output-not-real nil) + +;; methods api from polymode-methods.el +(declare-function pm-initialize "polymode-methods") +(declare-function pm-get-buffer-of-mode "polymode-methods") +(declare-function pm-get-buffer-create "polymode-methods") +(declare-function pm-get-adjust-face "polymode-methods") +(declare-function pm-get-span "polymode-methods") + +;; eieio silence "unknown slot" +;; http://emacs.1067599.n8.nabble.com/Fixing-quot-Unknown-slot-quot-warnings-td419119.html +(eval-when-compile + (defclass dummy () + ((function) (from-to)))) + +(defun pm-object-name (obj) + ;; gives warnings on e25,26 but fine in e27 + (with-no-warnings + (eieio-object-name-string obj))) + +;; SHIELDS + +(defvar pm-allow-after-change-hook t) + +(defvar pm-allow-post-command-hook t) +(defun polymode-disable-post-command () + (when polymode-mode + (setq pm-allow-post-command-hook nil))) +(defun polymode-enable-post-command () + (when polymode-mode + (setq pm-allow-post-command-hook t))) + +;; We need this during cascaded call-next-method in pm-initialize. -innermodes +;; are initialized after the hostmode setup has taken place. This means that +;; pm-get-span and all the functionality that relies on it will fail to work +;; correctly during the initialization in the call-next-method. This is +;; particularly relevant to font-lock setup and user hooks. +(defvar pm-initialization-in-progress nil) + +(defvar pm-hide-implementation-buffers t) +(defvar-local pm--core-buffer-name nil) + +(defun pm--hidden-buffer-name () + (generate-new-buffer-name (concat " " pm--core-buffer-name))) + +(defun pm--visible-buffer-name () + (generate-new-buffer-name + (replace-regexp-in-string "^ +" "" pm--core-buffer-name))) + + + +;;; CUSTOM + +;;;###autoload +(defvar-local polymode-default-inner-mode nil + "Inner mode for chunks with unspecified modes. +Intended to be used as local variable in polymode buffers. A +special value 'host means use the host mode.") +;;;###autoload +(put 'polymode-default-inner-mode 'safe-local-variable 'symbolp) + +(defgroup polymode nil + "Object oriented framework for multiple modes based on indirect buffers" + :link '(emacs-commentary-link "polymode") + :group 'tools) + +(defgroup poly-modes nil + "Polymode Configuration Objects" + :group 'polymode) + +(defgroup poly-hostmodes nil + "Polymode Host Chunkmode Objects" + :group 'polymode) + +(defgroup poly-innermodes nil + "Polymode Chunkmode Objects" + :group 'polymode) + +(defcustom polymode-display-output-file t + "Whether to display woven and exported output buffers. +When non-nil automatically visit and call `display-buffer' on +output files from processor engines (e.g. weavers and exporters). +Can also be a function, in which case it is called with the +output file name as the only argument. If this function returns +non-nil, the file is visited and displayed with `display-buffer'. +See `display-buffer-alist' for how to customize the display." + :group 'polymode + :type '(choice (const t) (const nil) function)) + +(defcustom polymode-display-process-buffers t + "When non-nil, display weaving and exporting process buffers." + :group 'polymode + :type 'boolean) + +(defcustom polymode-skip-processing-when-unmodified t + "If non-nil, consider modification times of input and output files. +Skip weaving or exporting process when output file is more recent +than the input file." + :group 'polymode + :type 'boolean) + +(define-obsolete-variable-alias 'polymode-mode-name-override-alist 'polymode-mode-name-aliases "2018-08") +(define-obsolete-variable-alias 'polymode-mode-name-alias-alist 'polymode-mode-name-aliases "2019-04") +(defcustom polymode-mode-name-aliases + '((elisp . emacs-lisp) + (el . emacs-lisp) + (bash . sh-mode)) + "An alist of inner mode overrides. +When inner mode is automatically detected from the header of the +inner chunk (such as in markdown mode), the detected symbol might +not correspond to the desired mode. This alist maps discovered +symbols into desired modes. For example + + (add-to-list 'polymode-mode-name-aliases '(julia . ess-julia)) + +will cause installation of `ess-julia-mode' in markdown ```julia chunks." + :group 'polymode + :type 'alist) + +(defvar polymode-mode-abbrev-aliases nil + "An alist of abbreviation mappings from mode names to their abbreviations. +Used to compute mode post-fixes in buffer names. Example: + + (add-to-list 'polymode-mode-abbrevs-aliases '(\"ess-r\" . \"R\"))") + +(defvar polymode-before-switch-buffer-hook nil + "Hook run just before switching to a different polymode buffer. +Each function is run with two arguments `old-buffer' and +`new-buffer'. This hook is commonly used to transfer state +between buffers. Hook is run before transfer of variables, modes +and overlays.") + +(define-obsolete-variable-alias 'polymode-switch-buffer-hook 'polymode-after-switch-buffer-hook "v0.2") +(defvar polymode-after-switch-buffer-hook nil + "Hook run after switching to a different polymode buffer. +Each function is run with two arguments `old-buffer' and +`new-buffer'. This hook is commonly used to transfer state +between buffers. Slot :switch-buffer-functions in `pm-polymode' +and `pm-chunkmode' objects provides same functionality for +narrower scope.") + +(defvar polymode-init-host-hook nil + "Hook run on initialization of every hostmode. +Ran in a base buffer from `pm-initialze' +methods. Slot :init-functions in `pm-polymode' objects provides +similar hook for more focused scope. See +`polymode-init-inner-hook' and :init-functions slot in +`pm-chunkmode' objects for similar hooks for inner chunkmodes.") + +(defvar polymode-init-inner-hook nil + "Hook run on initialization of every `pm-chunkmode' object. +The hook is run in chunkmode's body buffer from `pm-initialze' +`pm-chunkmode' methods. Slot :init-functions `pm-chunkmode' +objects provides same functionality for narrower scope. See also +`polymode-init-host-hook'.") + + +;;; Mode Macros + +(defun polymode--define-chunkmode (constructor name parent doc key-args) + (let* ((type (format "%smode" + (replace-regexp-in-string + "-.*$" "" (replace-regexp-in-string "^pm-" "" (symbol-name constructor))))) + (sname (symbol-name name)) + (root-name (replace-regexp-in-string (format "poly-\\|-%s" type) "" sname))) + (when (keywordp parent) + (progn + (push doc key-args) + (push parent key-args) + (setq doc nil parent nil))) + + (unless (stringp doc) + (when (keywordp doc) + (push doc key-args)) + (setq doc (format "%s for %s chunks." (capitalize type) root-name))) + + (unless (string-match-p (format "-%s$" type) sname) + (error "%s must end in '-%s'" (capitalize type) type)) + (unless (symbolp parent) + ;; fixme: check inheritance + (error "PARENT must be a name of an `%s'" type)) + + `(progn + (makunbound ',name) + (defvar ,name + ,(if parent + `(pm--safe-clone ',constructor ,parent :name ,root-name ,@key-args) + `(,constructor :name ,root-name ,@key-args)) + ,doc)) + ;; `(progn + ;; (defvar ,name) + ;; (defcustom ,name nil + ;; ,doc + ;; :group ',(intern (format "poly-%ss" type)) + ;; :type 'object) + ;; (setq ,name + ;; ,(if parent + ;; `(clone ,parent :name ,root-name ,@key-args) + ;; `(,constructor :name ,root-name ,@key-args)))) + )) + +;;;###autoload +(defmacro define-hostmode (name &optional parent doc &rest key-args) + "Define a hostmode with name NAME. +Optional PARENT is a name of a hostmode to be derived (cloned) +from. If missing, the optional documentation string DOC is +generated automatically. KEY-ARGS is a list of key-value pairs. +See the documentation of the class `pm-host-chunkmode' for +possible values." + (declare (doc-string 3)) + (polymode--define-chunkmode 'pm-host-chunkmode name parent doc key-args)) + +;;;###autoload +(defmacro define-innermode (name &optional parent doc &rest key-args) + "Ddefine an innermode with name NAME. +Optional PARENT is a name of a innermode to be derived (cloned) +from. If missing the optional documentation string DOC is +generated automatically. KEY-ARGS is a list of key-value pairs. +See the documentation of the class `pm-inner-chunkmode' for +possible values." + (declare (doc-string 3)) + (polymode--define-chunkmode 'pm-inner-chunkmode name parent doc key-args)) + +;;;###autoload +(defmacro define-auto-innermode (name &optional parent doc &rest key-args) + "Ddefine an auto innermode with name NAME. +Optional PARENT is a name of an auto innermode to be +derived (cloned) from. If missing the optional documentation +string DOC is generated automatically. KEY-ARGS is a list of +key-value pairs. See the documentation of the class +`pm-inner-auto-chunkmode' for possible values." + (declare (doc-string 3)) + (polymode--define-chunkmode 'pm-inner-auto-chunkmode name parent doc key-args)) + + + +;;; MESSAGES + +(defvar pm-extra-span-info nil) + +(defun pm-format-span (&optional span prefixp) + (let* ((span (cond + ((number-or-marker-p span) (pm-innermost-span span)) + ((null span) (pm-innermost-span)) + (span))) + (message-log-max nil) + (beg (nth 1 span)) + (end (nth 2 span)) + (type (and span (or (car span) 'host))) + (oname (if span + (eieio-object-name (nth 3 span)) + (current-buffer))) + (extra (if pm-extra-span-info + (format (if prefixp "%s " " (%s)") pm-extra-span-info) + ""))) + (if prefixp + (format "%s[%s %s-%s %s]" extra type beg end oname) + (format "[%s %s-%s %s]%s" type beg end oname extra)))) + + +;;; SPANS + +(defsubst pm-base-buffer () + "Return base buffer of current buffer, or the current buffer if it's direct." + (or (buffer-base-buffer (current-buffer)) + (current-buffer))) + +(defun pm-span-mode (&optional span) + "Retrieve the major mode associated with SPAN." + (pm--true-mode-symbol + (buffer-local-value 'major-mode (pm-span-buffer span)))) + +(defun pm-span-buffer (&optional span) + "Retrieve the buffer associated with SPAN." + (setq span (or span (pm-innermost-span))) + (let* ((chunkmode (nth 3 span)) + (type (pm-true-span-type span))) + (if type + (pm-get-buffer-create chunkmode type) + ;; ignore span's chunkmode as inner spans can request host span + (pm-get-buffer-create (oref pm/polymode -hostmode))))) + +(defun pm-true-span-type (chunkmode &optional type) + "Retrieve the TYPE of buffer to be installed for CHUNKMODE. +`pm-innermost-span' returns a raw type (head, body or tail) but +the actual type installed depends on the values of :host-mode and +:tail-mode of the CHUNKMODE object. Always return nil if TYPE is +nil (aka a host span). CHUNKMODE could also be a span, in which +case TYPE is ignored." + ;; fixme: this works on inner modes only. Fix naming. + (when (listp chunkmode) + ;; a span + (setq type (car chunkmode) + chunkmode (nth 3 chunkmode))) + (when (object-of-class-p chunkmode 'pm-inner-chunkmode) + (unless (or (null type) (eq type 'host)) + (with-slots (mode head-mode tail-mode fallback-mode) chunkmode + (cond ((eq type 'body) + (unless (or (eq mode 'host) + ;; for efficiency don't check if modes are valid + (and (null mode) + (if polymode-default-inner-mode + (eq polymode-default-inner-mode 'host) + (eq fallback-mode 'host)))) + 'body)) + ((eq type 'head) + (cond ((eq head-mode 'host) nil) + ((eq head-mode 'body) 'body) + (t 'head))) + ((eq type 'tail) + (cond ((eq tail-mode 'host) nil) + ((eq tail-mode 'body) 'body) + (t 'tail))) + (t (error "Type must be one of nil, 'host, 'head, 'tail or 'body"))))))) + +(defun pm-cache-span (span) + ;; cache span + (unless pm-initialization-in-progress + (with-silent-modifications + ;; (message "caching: %s %s" (car span) (pm-span-to-range span)) + (let ((sbeg (nth 1 span)) + (send (nth 2 span))) + (put-text-property sbeg send :pm-span span) + (put-text-property sbeg send :pm-mode (pm-span-mode span)))))) + +(defun pm-flush-span-cache (beg end &optional buffer) + (with-silent-modifications + (remove-list-of-text-properties beg end '(:pm-span) buffer))) + +(defun pm--outspan-p (span thespan) + "Non-nil if SPAN outspans THESPAN. +Return non-nil if SPAN contains THESPAN's chunk (strictly from +the front)." + (let ((type (car thespan)) + (beg (nth 1 thespan)) + (end (nth 2 thespan)) + (sbeg (nth 1 span)) + (send (nth 2 span))) + ;; The following check is to ensure that the outer span really + ;; spans outside of the entire thespan's chunk (poly-markdown#6) + (and + (< sbeg beg) + (cond + ((eq type 'body) + (and (let ((hspan (pm-get-span (nth 3 thespan) (1- beg)))) + (< sbeg (nth 1 hspan))) + ;; Ends might coincide due to eob + (if (< end send) + (let ((tspan (pm-get-span (nth 3 thespan) (1+ end)))) + (<= (nth 2 tspan) send)) + (= end send)))) + ((eq type 'tail) + (let ((bspan (pm-get-span (nth 3 thespan) (1- beg)))) + (when (< sbeg (nth 1 bspan)) + (let ((hspan (pm-get-span (nth 3 thespan) (1- (nth 1 bspan))))) + (< sbeg (nth 1 hspan)))))) + ;; Ends might coincide due to eob + ((eq type 'head) + (if (< end send) + (let ((bspan (pm-get-span (nth 3 thespan) (1+ end)))) + (if (< (nth 2 bspan) send) + (let ((tspan (pm-get-span (nth 3 thespan) (1+ (nth 2 bspan))))) + (<= (nth 2 tspan) send)) + (= (nth 2 bspan) send))) + (= end send))))))) + +(defun pm--intersect-spans (thespan span) + ;; ASSUMPTION: first thespan should be of the form (nil MIN MAX HOSTMODE) + (when span + (let ((allow-nested (eieio-oref (nth 3 span) 'allow-nested)) + (is-host (null (car span)))) + (cond + ;; 1. nil means host and it can be an intersection of spans returned + ;; by two neighboring inner chunkmodes. When `allow-nested` is + ;; 'always the innermode essentially behaves like the host-mode. + ((or is-host (eq allow-nested 'always)) + ;; when span is already an inner span, new host spans are irrelevant + (unless (car thespan) + (setq thespan + (list (unless is-host (car span)) + (max (nth 1 span) (nth 1 thespan)) + (min (nth 2 span) (nth 2 thespan)) + (nth 3 (if is-host thespan span)))))) + ;; 2. Inner span + ((and (>= (nth 1 span) (nth 1 thespan)) + (<= (nth 2 span) (nth 2 thespan))) + ;; Accepted only nested spans. In case of crossing (incorrect spans), + ;; first span wins. + (when (or (null (car thespan)) + (eieio-oref (nth 3 span) 'can-nest)) + (setq thespan span))) + ;; 3. Outer span; overwrite previous span if nesting is not allowed. + ;; This case is very hard because it can result in big invalid span + ;; when a head occurs within a inner-chunk. For example $ for inline + ;; latex can occur within R or python. The hard way to fix this would + ;; require non-local information (e.g. checking if outer span's + ;; extremities are within a host span) and still might not be the full + ;; proof solution. Instead, make use of 'allow-nested property. + ((and (eq allow-nested t) + (car thespan) ; span is an inner span + (not (eieio-oref (nth 3 thespan) 'can-nest)) + (pm--outspan-p span thespan)) + (setq thespan span))))) + thespan) + +(defun pm--get-intersected-span (config &optional pos) + ;; fixme: host should be last, to take advantage of the chunkmodes computation? + (let* ((start (point-min)) + (end (point-max)) + (pos (or pos (point))) + (hostmode (oref config -hostmode)) + (chunkmodes (cons hostmode (oref config -innermodes))) + (thespan (list nil start end hostmode))) + (dolist (cm chunkmodes) + ;; Optimization opportunity: this searches till the end of buffer but the + ;; outermost pm-get-span caller has computed a few spans already so we can + ;; pass limits or narrow to pre-computed span. + (setq thespan (pm--intersect-spans thespan (pm-get-span cm pos)))) + + (unless (and (<= start end) (<= pos end) (>= pos start)) + (error "Bad polymode selection: span:%s pos:%s" + (list start end) pos)) + (pm-cache-span thespan) + thespan)) + +(defun pm--chop-span (span beg end) + ;; destructive! + (when (> beg (nth 1 span)) + (setcar (cdr span) beg)) + (when (< end (nth 2 span)) + (setcar (cddr span) end)) + span) + +(defun pm--innermost-span (config &optional pos) + (let ((pos (or pos (point))) + (omin (point-min)) + (omax (point-max)) + ;; `re-search-forward' and other search functions trigger full + ;; `internal--syntax-propertize' on the whole buffer on every + ;; single buffer modification. This is a small price to pay for a + ;; much improved efficiency in modes which heavily rely on + ;; `syntax-propertize' like `markdown-mode'. + (parse-sexp-lookup-properties nil) + (case-fold-search t)) + (save-excursion + (save-restriction + (widen) + (let ((span (pm--get-intersected-span config pos))) + (if (= omax pos) + (when (and (= omax (nth 1 span)) + (> omax omin)) + ;; When pos == point-max and it's beg of span, return the + ;; previous span. This occurs because the computation of + ;; pm--get-intersected-span is done on a widened buffer. + (setq span (pm--get-intersected-span config (1- pos)))) + (when (= pos (nth 2 span)) + (error "Span ends at %d in (pm--inermost-span %d) %s" + pos pos (pm-format-span span)))) + (pm--chop-span span omin omax)))))) + +(defun pm--cached-span (&optional pos) + ;; fixme: add basic miss statistics + (unless pm-initialization-in-progress + (let* ((omin (point-min)) + (omax (point-max)) + (pos (or pos (point))) + (pos (if (= pos omax) + (max (point-min) (1- pos)) + pos)) + (span (get-text-property pos :pm-span))) + (when span + (save-restriction + (widen) + (let* ((beg (nth 1 span)) + (end (1- (nth 2 span)))) + (when (and (< end (point-max)) ; buffer size might have changed + (<= pos end) + (<= beg pos) + (eq span (get-text-property beg :pm-span)) + (eq span (get-text-property end :pm-span)) + (not (eq span (get-text-property (1+ end) :pm-span))) + (or (= beg (point-min)) + (not (eq span (get-text-property (1- beg) :pm-span))))) + (pm--chop-span (copy-sequence span) omin omax)))))))) + +(define-obsolete-function-alias 'pm-get-innermost-span 'pm-innermost-span "2018-08") +(defun pm-innermost-span (&optional pos no-cache) + "Get span object at POS. +If NO-CACHE is non-nil, don't use cache and force re-computation +of the span. Return a cons (type start end chunkmode). POS +defaults to point. Guarantied to return a non-empty span." + (when (and pos (or (< pos (point-min)) (> pos (point-max)))) + (signal 'args-out-of-range + (list :pos pos + :point-min (point-min) + :point-max (point-max)))) + (save-match-data + (or (unless no-cache + (pm--cached-span pos)) + (pm--innermost-span pm/polymode pos)))) + +(defun pm-span-to-range (span) + (and span (cons (nth 1 span) (nth 2 span)))) + +(define-obsolete-function-alias 'pm-get-innermost-range 'pm-innermost-range "2018-08") +(defun pm-innermost-range (&optional pos no-cache) + (pm-span-to-range (pm-innermost-span pos no-cache))) + +(defun pm-fun-matcher (matcher) + "Make a function matcher given a MATCHER. +MATCHER is one of the forms accepted by \=`pm-inner-chunkmode''s +:head-matcher slot." + (cond + ((stringp matcher) + (lambda (ahead) + (if (< ahead 0) + (if (re-search-backward matcher nil t) + (cons (match-beginning 0) (match-end 0))) + (if (re-search-forward matcher nil t) + (cons (match-beginning 0) (match-end 0)))))) + ((functionp matcher) + matcher) + ((consp matcher) + (lambda (ahead) + (when (re-search-forward (car matcher) nil t ahead) + (cons (match-beginning (cdr matcher)) + (match-end (cdr matcher)))))) + (t (error "Head and tail matchers must be either regexp strings, cons cells or functions")))) + +(defun pm-same-indent-tail-matcher (_arg) + "Get the end position of block with the higher indent than the current column. +Used as tail matcher for blocks identified by same indent. See +function `poly-slim-mode' for examples. ARG is ignored; always search +forward." + ;; we are at the head end; so either use head indent or this code indent + (let* ((cur-indent (current-indentation)) + (cur-col (current-column)) + (block-col (if (< cur-indent cur-col) + cur-indent + (1- cur-indent))) + (end (point-at-eol))) + (forward-line 1) + (while (and (not (eobp)) + (or (looking-at-p "[ \t]*$") + (and (> (current-indentation) block-col) + (setq end (point-at-eol))))) + (forward-line 1)) + ;; end at bol for the sake of indentation + (setq end (min (point-max) (1+ end))) + (cons end end))) + +(defun pm--get-property-nearby (property accessor ahead) + (let ((ahead (> ahead 0))) + (let* ((pos (if ahead + (if (get-text-property (point) property) + (point) + (next-single-property-change (point) property)) + (previous-single-property-change (point) property))) + (val (when pos + (or (get-text-property pos property) + (and (setq pos (previous-single-property-change pos property nil (point-min))) + (get-text-property pos property)))))) + (when val + (if accessor + (let ((val (save-excursion + (goto-char pos) + (funcall accessor val)))) + (cond + ((numberp val) (cons val val)) + ((consp val) (cons (car val) (if (listp (cdr val)) + (cadr val) + (cdr val)))) + (t (cons pos (next-single-property-change pos property nil (point-max)))))) + (cons pos (next-single-property-change pos property nil (point-max)))))))) + +(defun pm-make-text-property-matcher (property &optional accessor) + "Return a head or tail matcher for PROPERTY with ACCESSOR. +ACCESSOR is either a function or a keyword. When a function it is +applied to the PROPERTY's value to retrieve the position of the +head in the buffer. It should return either a number in which +case head has 0 length, a cons of the form (BEG . END), or a +list (BEG END). ACCESSOR is called at the beginning of the +PROPERTY region. When ACCESSOR is nil the head span is the region +covered by the same value of PROPERTY. When ACCESSOR is a keyword +the property is searched as when ACCESSOR is nil but is adapted +according to the keyword. Currently :inc-end means increment the +END of the span, when :dec-beg, decrement the beginning of the +span." + (lambda (ahead) + (if (keywordp accessor) + (let ((loc (pm--get-property-nearby property nil ahead))) + (when loc + (cond + ((eq accessor :inc-end) (setcdr loc (1+ (cdr loc)))) + ((eq accessor :dec-beg) (setcar loc (1- (cdr loc)))) + (t (error "Invalid ACCESSOR keyword"))) + loc)) + (pm--get-property-nearby property accessor ahead)))) + +(defun pm--span-at-point (head-matcher tail-matcher &optional pos can-overlap do-chunk) + "Span detector with head and tail matchers. +HEAD-MATCHER and TAIL-MATCHER is as in :head-matcher slot of +`pm-inner-chunkmode' object. POS defaults to (point). When +CAN-OVERLAP is non-nil nested chunks of this type are allowed. + +Return a list of the form (TYPE SPAN-START SPAN-END) where TYPE +is one of the following symbols: + nil - pos is between ‘point-min’ and head-matcher, or between + tail-matcher and ‘point-max’ + body - pos is between head-matcher and tail-matcher (exclusively) + head - head span + tail - tail span + +Non-nil DO-CHUNK makes this function return a list of the +form (TYPE HEAD-START HEAD-END TAIL-START TAIL-END)." + (setq pos (or pos (point))) + (save-restriction + (widen) + (save-excursion + (goto-char pos) + (let* ((at-max (= pos (point-max))) + (head-matcher (pm-fun-matcher head-matcher)) + (tail-matcher (pm-fun-matcher tail-matcher)) + (head1 (funcall head-matcher -1))) + (if head1 + (if (or (< pos (cdr head1)) + (and at-max (= (cdr head1) pos))) + ;; -----| + ;; host)[head) ; can occur with sub-head == 0 only + (if do-chunk + (pm--find-tail-from-head pos head1 head-matcher tail-matcher can-overlap 'head) + (list 'head (car head1) (cdr head1))) + ;; ------------------------ + ;; host)[head)[body)[tail)[host)[head)[body) + (pm--find-tail-from-head pos head1 head-matcher tail-matcher can-overlap do-chunk)) + ;; ---------- + ;; host)[head)[body)[tail)[host + (goto-char (point-min)) + (let ((head2 (funcall head-matcher 1))) + (if head2 + (if (< pos (car head2)) + ;; ---- + ;; host)[head)[body)[tail)[host + (if do-chunk + (list nil (point-min) (point-min) (car head2) (car head2)) + (list nil (point-min) (car head2))) + (if (< pos (cdr head2)) + ;; ----- + ;; host)[head)[body)[tail)[host + (if do-chunk + (pm--find-tail-from-head pos head2 head-matcher tail-matcher can-overlap 'head) + (list 'head (car head2) (cdr head2))) + ;; ----------------- + ;; host)[head)[body)[tail)[host + (pm--find-tail-from-head pos head2 head-matcher tail-matcher can-overlap do-chunk))) + ;; no span found + nil))))))) + +;; fixme: find a simpler way with recursion where head-matcher and tail-matcher could be reversed +(defun pm--find-tail-from-head (pos head head-matcher tail-matcher can-overlap do-chunk) + (goto-char (cdr head)) + (let ((tail (funcall tail-matcher 1)) + (at-max (= pos (point-max))) + (type 'tail)) + (when can-overlap + (save-excursion + ;; search for next head and pick the earliest + (goto-char (cdr head)) + (let ((match (funcall head-matcher 1))) + (when (or (null tail) + (and match (< (car match) (car tail)))) + (setq tail match + type 'head))))) + (if tail + (if (< pos (car tail)) + ;; ----- + ;; host)[head)[body)[tail)[host)[head) + (if do-chunk + (list (if (eq do-chunk t) 'body do-chunk) + (car head) (cdr head) (car tail) (cdr tail)) + (list 'body (cdr head) (car tail))) + (if (or (< pos (cdr tail)) + (and at-max (= pos (cdr tail)))) + ;; ----- + ;; host)[head)[body)[tail)[host)[head) + (if do-chunk + (if (eq type 'tail) + (list (if (eq do-chunk t) 'tail do-chunk) + (car head) (cdr head) (car tail) (cdr tail)) + ;; can-overlap case + (pm--find-tail-from-head pos tail head-matcher tail-matcher can-overlap do-chunk)) + (list type (car tail) (cdr tail))) + (goto-char (cdr tail)) + ;; ----------- + ;; host)[head)[body)[tail)[host)[head) + (let ((match (funcall head-matcher 1)) + (type 'head)) + (when can-overlap + (save-excursion + ;; search for next head and pick the earliest + (goto-char (cdr tail)) + (let ((match2 (funcall tail-matcher 1))) + (when (or (null match) + (and match2 (< (car match2) (car match)))) + (setq match match2 + type 'tail))))) + (if match + (if (< pos (car match)) + ;; ----- + ;; host)[head)[body)[tail)[host)[head) + (if do-chunk + (list nil (cdr tail) (cdr tail) (car match) (car match)) + (list nil (cdr tail) (car match))) + (if (or (< pos (cdr match)) + (and at-max (= pos (cdr match)))) + ;; ----- + ;; host)[head)[body)[tail)[host)[head)[body + (if do-chunk + (if (eq type 'tail) + ;; can-overlap case + (list (if (eq do-chunk t) 'tail do-chunk) + (car head) (cdr head) (car match) (cdr match)) + (pm--find-tail-from-head pos match head-matcher tail-matcher can-overlap 'head)) + (list type (car match) (cdr match))) + ;; ---- + ;; host)[head)[body)[tail)[host)[head)[body + (pm--find-tail-from-head pos match head-matcher tail-matcher can-overlap do-chunk))) + ;; ----- + ;; host)[head)[body)[tail)[host) + (if do-chunk + (list nil (cdr tail) (cdr tail) (point-max) (point-max)) + (list nil (cdr tail) (point-max))))))) + ;; ----- + ;; host)[head)[body) + (if do-chunk + (list (if (eq do-chunk t) 'body do-chunk) (cdr head) (cdr head) (point-max) (point-max)) + (list 'body (cdr head) (point-max)))))) + +(defun pm--next-chunk (head-matcher tail-matcher &optional pos can-overlap) + "Forward only span detector. +For HEAD-MATCHER, TAIL-MATCHER, POS and CAN-OVERLAP see +`pm--span-at-point'. Return a list of the form (HEAD-START +HEAD-END TAIL-START TAIL-END). Can return nil if there are no +forward spans from pos." + (setq pos (or pos (point))) + (save-restriction + (widen) + (save-excursion + (goto-char pos) + (let ((parse-sexp-lookup-properties nil) + (case-fold-search t) + (head-matcher (pm-fun-matcher head-matcher)) + (tail-matcher (pm-fun-matcher tail-matcher)) + (head nil)) + ;; start from bol !! ASSUMPTION !! + (forward-line 0) + (setq head (funcall head-matcher 1)) + (while (and head (< (car head) pos)) + (setq head (funcall head-matcher 1))) + (when head + (goto-char (cdr head)) + (let ((tail (or (funcall tail-matcher 1) + (cons (point-max) (point-max))))) + (when can-overlap + (goto-char (cdr head)) + (when-let ((hbeg (car (funcall head-matcher 1)))) + (when (< hbeg (car tail)) + (setq tail (cons hbeg hbeg))))) + (list (car head) (cdr head) (car tail) (cdr tail)))))))) + +(defun pm-goto-span-of-type (type N) + "Skip to N - 1 spans of TYPE and stop at the start of a span of TYPE. +TYPE is either a symbol or a list of symbols of span types." + (let* ((sofar 0) + (types (if (symbolp type) + (list type) + type)) + (back (< N 0)) + (N (if back (- N) N)) + (beg (if back (point-min) (point))) + (end (if back (point) (point-max)))) + (unless (memq (car (pm-innermost-span)) types) + (setq sofar 1)) + (condition-case nil + (pm-map-over-spans + (lambda (span) + (when (memq (car span) types) + (goto-char (nth 1 span)) + (when (>= sofar N) + (signal 'quit nil)) + (setq sofar (1+ sofar)))) + beg end nil back) + (quit nil)) + sofar)) + + +;;; OBJECT HOOKS + +(defun pm--run-derived-mode-hooks () + ;; Minor modes run-hooks, major-modes run-mode-hooks. Polymodes is a minor + ;; mode but with major-mode flavor. We run hooks of all modes stored in + ;; '-minor-mode slot of all parent objects in parent-first order. + (let* ((this-mode (eieio-oref pm/polymode '-minor-mode)) + (this-state (symbol-value this-mode))) + (mapc (lambda (mm) + (let ((old-state (symbol-value mm))) + (unwind-protect + (progn + (set mm this-state) + (run-hooks (derived-mode-hook-name mm))) + (set mm old-state)))) + (pm--collect-parent-slots pm/polymode '-minor-mode)))) + +(defun pm--run-init-hooks (object type &optional emacs-hook) + (unless pm-initialization-in-progress + (when emacs-hook + (run-hooks emacs-hook)) + (pm--run-hooks object :init-functions (or type 'host)))) + +(defun pm--collect-parent-slots (object slot &optional do-when inclusive) + "Descend into parents of OBJECT and return a list of SLOT values. +Returned list is in parent first order. If non-nil DO-WHEN must +be a function which would take an object and return non-nil if +the recursion should descend into the parent. When nil, all +parents are descended. If INCLUSIVE is non-nil, include the slot +of the first object for which DO-WHEN failed." + (let ((inst object) + (vals nil) + (failed nil)) + (while inst + (if (not (slot-boundp inst slot)) + (setq inst (and (slot-boundp inst :parent-instance) + (eieio-oref inst 'parent-instance))) + (push (eieio-oref inst slot) vals) + (setq inst (and + (or (null do-when) + (if failed + (progn (setq failed nil) t) + (or (funcall do-when inst) + (and inclusive + (setq failed t))))) + (slot-boundp inst :parent-instance) + (eieio-oref inst 'parent-instance))))) + vals)) + +(defun pm--run-hooks (object slot &rest args) + "Run hooks from SLOT of OBJECT and its parent instances. +Parents' hooks are run first." + (let ((funs (delete-dups + (copy-sequence + (apply #'append + (pm--collect-parent-slots object slot)))))) + (if args + (mapc (lambda (fn) + (apply fn args)) + funs) + (mapc #'funcall funs)))) + + +;;; BUFFER SELECTION + +;; Transfer of the buffer-undo-list is managed internally by emacs +(define-obsolete-variable-alias 'pm-move-vars-from-base 'polymode-move-these-vars-from-base-buffer "v0.1.6") +(defvar polymode-move-these-vars-from-base-buffer + '(buffer-file-name + ;; ideally this one should be merged across all buffers + buffer-display-table + outline-regexp + outline-level + polymode-default-inner-mode + tab-width) + "Variables transferred from base buffer on buffer switch.") + +(define-obsolete-variable-alias 'pm-move-vars-from-old-buffer 'polymode-move-these-vars-from-old-buffer "v0.1.6") +(defvar polymode-move-these-vars-from-old-buffer + '(buffer-face-mode + buffer-face-mode-face + buffer-face-mode-remapping + buffer-invisibility-spec + buffer-read-only + buffer-undo-list + buffer-undo-tree + display-line-numbers + face-remapping-alist + isearch-mode ; this seems to be enough to avoid isearch glitching + line-move-visual + overwrite-mode + selective-display + text-scale-mode + text-scale-mode-amount + truncate-lines + truncate-partial-width-windows + word-wrap) + "Variables transferred from old buffer on buffer switch.") + +(defvar polymode-move-these-minor-modes-from-base-buffer nil + "List of minor modes to move from base buffer.") +(defvar polymode-move-these-minor-modes-from-old-buffer + '(linum-mode + visual-line-mode + visual-fill-column-mode + writeroom-mode) + "List of minor modes to move from the old buffer.") + +(defun pm-own-buffer-p (&optional buffer) + "Return t if BUFFER is owned by polymode. +Owning a buffer means that the BUFFER is either the base buffer +or an indirect implementation buffer. If nil, the buffer was +created outside of polymode with `clone-indirect-buffer'." + (when pm/polymode + (memq (or buffer (current-buffer)) + (eieio-oref pm/polymode '-buffers)))) + +(defun pm-select-buffer (span &optional visibly) + "Select the buffer associated with SPAN. +Install a new indirect buffer if it is not already installed. +Chunkmode's class should define `pm-get-buffer-create' method. If +VISIBLY is non-nil perform extra adjustment for \"visual\" buffer +switch." + (let ((buffer (pm-span-buffer span)) + (own (pm-own-buffer-p)) + (cbuf (current-buffer))) + ;; FIXME: investigate why this one is still needed. + ;; polymode-syntax-propertize should have taken care of it. + (with-current-buffer buffer + (pm--reset-ppss-cache span)) + (when (and own visibly) + ;; always sync to avoid issues with tooling working in different buffers + (pm--synchronize-points cbuf) + (let ((mode (or (eieio-oref (nth 3 span) 'keep-in-mode) + (eieio-oref pm/polymode 'keep-in-mode)))) + (setq buffer (cond + ((null mode) buffer) + ((eq mode 'host) (pm-base-buffer)) + (mode (or (pm-get-buffer-of-mode mode) + ;; not throwing because in auto-modes mode might not + ;; be installed yet and there is no way install it + ;; from here + buffer)))))) + ;; (message "setting buffer %d-%d [%s]" (nth 1 span) (nth 2 span) cbuf) + ;; no further action if BUFFER is already the current buffer + (unless (eq buffer cbuf) + (when (and own visibly) + (run-hook-with-args 'polymode-before-switch-buffer-hook + cbuf buffer)) + (pm--move-vars polymode-move-these-vars-from-base-buffer + (pm-base-buffer) buffer) + (pm--move-vars polymode-move-these-vars-from-old-buffer + cbuf buffer) + (if visibly + ;; Slow, visual selection. Don't perform in foreign indirect buffers. + (when own + (pm--select-existing-buffer-visibly buffer)) + (set-buffer buffer))))) + +(defvar text-scale-mode) +(defvar text-scale-mode-amount) +(defun pm--select-existing-buffer-visibly (new-buffer) + (let ((old-buffer (current-buffer)) + (point (point)) + (window-start (window-start)) + (visible (pos-visible-in-window-p)) + (ractive (region-active-p)) + (mkt (mark t))) + + (when pm-hide-implementation-buffers + (rename-buffer (pm--hidden-buffer-name))) + + (setq pm/current nil) + + (pm--move-minor-modes polymode-move-these-minor-modes-from-base-buffer + (pm-base-buffer) new-buffer) + (pm--move-minor-modes polymode-move-these-minor-modes-from-old-buffer + old-buffer new-buffer) + + (pm--move-overlays old-buffer new-buffer) + + (switch-to-buffer new-buffer) + (bury-buffer-internal old-buffer) + (set-window-prev-buffers nil (assq-delete-all old-buffer (window-prev-buffers nil))) + + (setq pm/current t) + + ;; fixme: what is the right way to do this ... activate-mark-hook? + (if (not ractive) + (deactivate-mark) + (set-mark mkt) + (activate-mark)) + + (when pm-hide-implementation-buffers + (rename-buffer (pm--visible-buffer-name))) + + ;; avoid display jumps + (goto-char point) + (when visible + (set-window-start (get-buffer-window new-buffer t) window-start)) + + (run-hook-with-args 'polymode-after-switch-buffer-hook old-buffer new-buffer) + (pm--run-hooks pm/polymode :switch-buffer-functions old-buffer new-buffer) + (pm--run-hooks pm/chunkmode :switch-buffer-functions old-buffer new-buffer))) + +(defun pm--move-overlays (from-buffer to-buffer) + (with-current-buffer from-buffer + (mapc (lambda (o) + (unless (or (overlay-get o 'linum-str) + (overlay-get o 'yas--snippet)) + (move-overlay o (overlay-start o) (overlay-end o) to-buffer))) + (overlays-in 1 (1+ (buffer-size)))))) + +(defun pm--move-vars (vars from-buffer &optional to-buffer) + (let ((to-buffer (or to-buffer (current-buffer)))) + (unless (eq to-buffer from-buffer) + (with-current-buffer to-buffer + (dolist (var vars) + (when (default-boundp var) + (make-variable-buffer-local var) + (set var (buffer-local-value var from-buffer)))))))) + +(defun pm--move-minor-modes (modes from-buffer &optional to-buffer) + (let ((to-buffer (or to-buffer (current-buffer)))) + (unless (eq to-buffer from-buffer) + (with-current-buffer to-buffer + (dolist (m modes) + (when (default-boundp m) + (let ((from-state (buffer-local-value m from-buffer))) + (unless (equal from-state (symbol-value m)) + (funcall (symbol-function m) (if from-state 1 -1)))))))))) + +(defun pm-set-buffer (&optional pos-or-span) + "Set buffer to polymode buffer appropriate for POS-OR-SPAN. +This is done with `set-buffer' and no visual adjustments (like +overlay transport) are done. See `pm-switch-to-buffer' for a more +comprehensive alternative." + (let ((span (if (or (null pos-or-span) + (number-or-marker-p pos-or-span)) + (pm-innermost-span pos-or-span) + pos-or-span))) + (pm-select-buffer span))) + +;; NB: Polymode functions used in emacs utilities should not switch buffers +;; under any circumstances. Switching should happen only in post-command. For +;; example `pm-indent-line-dispatcher' used to switch buffers, but it was called +;; from electric-indent-post-self-insert-function in post-self-insert-hook which +;; was triggered by self-insert-command called from `newline'. `newline' sets a +;; temporary local post-self-insert-hook and makes the assumption that buffer +;; stays the same. It was moved away from original buffer by polymode's +;; indentation dispatcher its post-self-insert-hook hanged permanently in the +;; old buffer (#226). +(defun pm-switch-to-buffer (&optional pos-or-span) + "Bring the appropriate polymode buffer to front. +POS-OR-SPAN can be either a position in a buffer or a span. All +expensive adjustment for a visible switch (like overlay +transport) are performed." + (let ((span (if (or (null pos-or-span) + (number-or-marker-p pos-or-span)) + (pm-innermost-span pos-or-span) + pos-or-span))) + (pm-select-buffer span 'visibly))) + +(defun pm-map-over-modes (fn beg end) + (when (< beg end) + (save-restriction + (widen) + (let* ((hostmode (eieio-oref pm/polymode '-hostmode)) + (pos beg) + (ttype 'dummy) + span nspan nttype) + (when (< (point-min) beg) + (setq span (pm-innermost-span beg) + beg (nth 1 span) + pos (nth 2 span) + ttype (pm-true-span-type span)) + (while (and (memq (car span) '(head body)) + (< pos end)) + (setq nspan (pm-innermost-span (nth 2 span)) + nttype (pm-true-span-type nspan)) + (if (eq ttype nttype) + (setq pos (nth 2 nspan)) + (with-current-buffer (pm-span-buffer span) + (funcall fn beg pos)) + (setq beg (nth 1 nspan) + pos (nth 2 nspan))) + (setq span nspan + ttype nttype))) + (when (< pos end) + (let ((ichunks (cl-loop for im in (eieio-oref pm/polymode '-innermodes) + collect (cons im nil))) + (tichunks nil) + (spans nil)) + (while (< pos end) + ;; 1. recompute outdated chunks + (setq tichunks nil) + (dolist (ichunk ichunks) + (if (and (cdr ichunk) + (< pos (nth 5 ichunk))) + (push ichunk tichunks) + (let ((nchunk (pm-next-chunk (car ichunk) pos))) + (when nchunk + (push (cons (car ichunk) nchunk) tichunks))))) + (setq ichunks (reverse tichunks)) + ;; 2. Compute all (next) spans + (setq spans nil) + (dolist (ichunk ichunks) + (let ((chunk (cdr ichunk))) + (let ((span (cond + ((< pos (nth 1 chunk)) (list nil pos (nth 1 chunk) (car chunk))) + ((< pos (nth 2 chunk)) (list 'head (nth 1 chunk) (nth 2 chunk) (car chunk))) + ((< pos (nth 3 chunk)) (list 'body (nth 2 chunk) (nth 3 chunk) (car chunk))) + ((< pos (nth 4 chunk)) (list 'tail (nth 3 chunk) (nth 4 chunk) (car chunk)))))) + (push span spans)))) + (setq spans (nreverse spans)) + ;; 3. Intersect + (setq nspan (list nil pos (point-max) hostmode)) + (dolist (s spans) + (setq nspan (pm--intersect-spans nspan s))) + ;; (setq pm--span-counter (1+ pm--span-counter)) ;; for debugging + (pm-cache-span nspan) + (setq nttype (pm-true-span-type nspan)) + ;; 4. funcall on region if type changed + (unless (eq ttype nttype) + (when span + (with-current-buffer (pm-span-buffer span) + (funcall fn beg pos))) + (setq ttype nttype + beg (nth 1 nspan))) + (setq span nspan + pos (nth 2 nspan))))) + (with-current-buffer (pm-span-buffer span) + (funcall fn beg pos)))))) + +;; ;; do not delete: speed and consistency checks +;; (defvar pm--span-counter 0) +;; (defvar pm--mode-counter 0) +;; (defun pm-debug-map-over-modes-test (&optional beg end) +;; (interactive) +;; (setq pm--span-counter 0) +;; (setq pm--mode-counter 0) +;; (pm-map-over-modes +;; (lambda (beg end) +;; (setq pm--mode-counter (1+ pm--mode-counter))) +;; (or beg (point-min)) +;; (or end (point-max))) +;; (cons pm--span-counter pm--mode-counter)) +;; (defun pm-debug-map-over-spans-test (&optional beg end) +;; (interactive) +;; (setq pm--span-counter 0) +;; (pm-map-over-spans +;; (lambda (span) +;; (setq pm--span-counter (1+ pm--span-counter))) +;; (or beg (point-min)) +;; (or end (point-max))) +;; pm--span-counter) + +(defun pm-map-over-spans (fun &optional beg end count backwardp visibly no-cache) + "For all spans between BEG and END, execute FUN. +FUN is a function of one argument a span object (also available +in a dynamic variable *span*). Buffer is *not* narrowed to the +span, nor point is moved. If COUNT is non-nil, jump at most that +many times. If BACKWARDP is non-nil, map backwards. Point +synchronization across indirect buffers is not taken care of. +Modification of the buffer during mapping is an undefined +behavior." + ;; Important! Don't forget to save-excursion when calling map-overs-spans and + ;; synchronize points if needed. Mapping can end in different buffer and + ;; invalidate the caller assumptions. + (save-restriction + (widen) + (setq beg (or beg (point-min)) + end (if end + (min end (point-max)) + (point-max))) + (unless count + (setq count most-positive-fixnum)) + (let* ((nr 0) + (pos (if backwardp end beg)) + (*span* (pm-innermost-span pos no-cache))) + (while *span* + (setq nr (1+ nr)) + (pm-select-buffer *span* visibly) + ;; FUN might change buffer and invalidate our *span*. Should we care or + ;; reserve pm-map-over-spans for "read-only" actions only? Does + ;; after-change run immediately or after this function ends? + (funcall fun *span*) + ;; enter previous/next chunk + (setq pos + (if backwardp + (max 1 (1- (nth 1 *span*))) + (min (point-max) (nth 2 *span*)))) + (setq *span* + (and (if backwardp + (> pos beg) + (< pos end)) + (< nr count) + (pm-innermost-span pos no-cache))))))) + +(defun pm-narrow-to-span (&optional span) + "Narrow to current SPAN." + (interactive) + (unless (= (point-min) (point-max)) + (let ((span (or span + (pm-innermost-span)))) + (let ((sbeg (nth 1 span)) + (send (nth 2 span))) + (unless pm--emacs>26 + (pm--reset-ppss-cache span)) + (narrow-to-region sbeg send))))) + +(defmacro pm-with-narrowed-to-span (span &rest body) + (declare (indent 1) (debug body)) + `(save-restriction + (pm-narrow-to-span ,span) + ,@body)) + + + +;;; HOOKS +;; There is also `poly-lock-after-change' in poly-lock.el + +(defun polymode-flush-syntax-ppss-cache (beg end _) + "Run `syntax-ppss-flush-cache' from BEG to END in all polymode buffers." + ;; Modification hooks are run only in current buffer and not in other (base or + ;; indirect) buffers. Thus some actions like flush of ppss cache must be taken + ;; care explicitly. We run some safety hooks checks here as well. + (dolist (buff (oref pm/polymode -buffers)) + (when (buffer-live-p buff) + (with-current-buffer buff + ;; micro-optimization to avoid calling the flush twice + (when (memq 'syntax-ppss-flush-cache before-change-functions) + (remove-hook 'before-change-functions 'syntax-ppss-flush-cache t)) + ;; need to be the first to avoid breaking preceding hooks + (unless (eq (car after-change-functions) + 'polymode-flush-syntax-ppss-cache) + (delq 'polymode-flush-syntax-ppss-cache after-change-functions) + (add-hook 'after-change-functions 'polymode-flush-syntax-ppss-cache nil t)) + (syntax-ppss-flush-cache beg end) + ;; Check if something has changed our hooks. (Am I theoretically paranoid or + ;; this is indeed needed?) `fontification-functions' (and others?) should be + ;; checked as well I guess. + ;; (when (memq 'font-lock-after-change-function after-change-functions) + ;; (remove-hook 'after-change-functions 'font-lock-after-change-function t)) + ;; (when (memq 'jit-lock-after-change after-change-functions) + ;; (remove-hook 'after-change-functions 'jit-lock-after-change t)) + )))) + +(defun polymode-pre-command-synchronize-state () + "Synchronize state between buffers. +Currently synchronize points only. Runs in local `pre-command-hook'." + (pm--synchronize-points (current-buffer))) + +(defun polymode-post-command-select-buffer () + "Select the appropriate (indirect) buffer corresponding to point's context. +This funciton is placed in local `post-command-hook'." + (when (and pm-allow-post-command-hook + polymode-mode + pm/chunkmode) + (condition-case err + (pm-switch-to-buffer) + (error (message "(pm-switch-to-buffer %s): %s" + (point) (error-message-string err)))))) + +(defvar-local pm--killed nil) +(defun polymode-after-kill-fixes () + "Various fixes for polymode indirect buffers." + (when (pm-own-buffer-p) + (let ((base (pm-base-buffer))) + (set-buffer-modified-p nil) + ;; Prevent various tools like `find-file' to re-find this file. + ;; + ;; We use buffer-list instead of `-buffers' slot here because on some + ;; occasions there are other indirect buffers (e.g. switch from polymode + ;; to other mode and then back, or when user or a tool (e.g. org-capture) + ;; creates an indirect buffer manually). + (dolist (b (buffer-list)) + (when (and (buffer-live-p b) + (eq (buffer-base-buffer b) base)) + (with-current-buffer b + (setq pm--killed t) + (setq buffer-file-name nil) + (setq buffer-file-number nil) + (setq buffer-file-truename nil))))))) + +(defun pm-turn-polymode-off (&optional new-mode) + "Remove all polymode indirect buffers and install NEW-MODE if any. +NEW-MODE can be t in which case mode is picked from the +`pm/polymode' object." + (when pm/polymode + (let* ((base (pm-base-buffer)) + (mmode (buffer-local-value 'major-mode base)) + (kill-buffer-hook (delete 'polymode-after-kill-fixes (copy-sequence kill-buffer-hook)))) + ;; remove only our own indirect buffers + (dolist (b (eieio-oref pm/polymode '-buffers)) + (unless (eq b base) + (kill-buffer b))) + (with-current-buffer base + (setq pm/polymode nil) + (when new-mode + (if (eq new-mode t) + (funcall mmode) + (funcall new-mode))))))) + +(defun polymode-after-change-major-mode-cleanup () + "Remove all polymode implementation buffers on mode change." + ;; pm/polymode is permanent local. Nil polymode-mode means that the user + ;; called another mode on top of polymode. + (when (and pm/polymode (not polymode-mode)) + ;; if another mode was called from an innermode, it was installed in a wrong place + (let* ((base (pm-base-buffer)) + (mmode (unless (eq base (current-buffer)) + major-mode))) + (unless (eq base (current-buffer)) + (when (eq (window-buffer) (current-buffer)) + (switch-to-buffer base))) + (pm-turn-polymode-off mmode)))) + +(add-hook 'after-change-major-mode-hook #'polymode-after-change-major-mode-cleanup) + + +;;; CORE ADVICE + +(defun pm-around-advice (fun advice) + "Apply around ADVICE to FUN. +If FUN is a list, apply ADVICE to each element of it." + (cond ((listp fun) + (dolist (el fun) (pm-around-advice el advice))) + ((and (symbolp fun) + (not (advice-member-p advice fun))) + (advice-add fun :around advice)))) + +(defun polymode-inhibit-during-initialization (orig-fun &rest args) + "Don't run ORIG-FUN (with ARGS) during polymode setup." + (unless pm-initialization-in-progress + (apply orig-fun args))) + +(defun polymode-with-current-base-buffer (orig-fun &rest args) + "Switch to base buffer and apply ORIG-FUN to ARGS. +Used in advises." + (if (and polymode-mode + (not pm--killed) + (buffer-live-p (buffer-base-buffer))) + (let (;; (pm-initialization-in-progress t) ; just in case + (cur-buf (current-buffer)) + (base (buffer-base-buffer)) + (first-arg (car-safe args))) + (prog1 (with-current-buffer base + (if (or (eq first-arg cur-buf) + (equal first-arg (buffer-name cur-buf))) + (apply orig-fun base (cdr args)) + (apply orig-fun args))) + ;; The sync of points doesn't work as expected in the following corner + ;; case: if current buffer is an indirect one and a function operates + ;; on the base buffer (like save-buffer) and somehow inadvertently + ;; moves points in the indirect buffer then we synchronize wrong point + ;; (from the current indirect buffer). For unclear reasons the very + ;; low level scan-lists moves points in indirect buffers (FIXME: EMACS + ;; bug, report ASAP). Unfortunately save-excursion protects only from + ;; point moves in the current buffer. + (when pm/polymode + (pm--synchronize-points base)))) + (apply orig-fun args))) + +;; (pm-around-advice #'kill-buffer #'polymode-with-current-base-buffer) +(pm-around-advice #'find-alternate-file #'polymode-with-current-base-buffer) +(pm-around-advice #'write-file #'polymode-with-current-base-buffer) +(pm-around-advice #'basic-save-buffer #'polymode-with-current-base-buffer) +;; (advice-remove #'kill-buffer #'polymode-with-current-base-buffer) +;; (advice-remove #'find-alternate-file #'polymode-with-current-base-buffer) + + +;;; FILL + +;; FIXME: this is an incomplete heuristic and breaks on adjacent multi-span +;; fill-region depending on the mode's fill-forward-paragraph-function. For a +;; complete solution one might likely need to define fill-paragraph-function as +;; well. +(defun polymode-fill-forward-paragraph (&optional arg) + "Function for `fill-forward-paragraph-function'. +ARG is the same as in `forward-paragraph'" + (let* ((neg (< arg 0)) + (cur-span (pm-innermost-span (if neg (1- (point)) (point)))) + (cur-mode (pm-span-mode cur-span)) + (out (funcall (or pm--fill-forward-paragraph-original + #'forward-paragraph) + arg)) + (new-mode (pm-span-mode (pm-innermost-span (point))))) + (unless (eq cur-mode new-mode) + ;; adjust to the most recent span border and hope for the best + (pm-goto-span-of-type (car cur-span) (if neg 1 -1))) + out)) + + +;;; SYNTAX + +(defun pm--call-syntax-propertize-original (start end) + (condition-case err + (funcall pm--syntax-propertize-function-original start end) + (error + (message "ERROR: (%s %d %d) -> %s" + (if (symbolp pm--syntax-propertize-function-original) + pm--syntax-propertize-function-original + (format "polymode-syntax-propertize:%s" major-mode)) + start end + ;; (backtrace) + (error-message-string err))))) + +(defun polymode-syntax-propertize-extend-region-in-host (start end) + (let ((base (pm-base-buffer)) + (min (point-min)) + (max (point-max))) + (when base + (with-current-buffer base + (save-restriction + (narrow-to-region min max) + ;; Relevant part from syntax-propertize + (let ((funs syntax-propertize-extend-region-functions) + (extended nil)) + (while funs + (let* ((syntax-propertize--done most-positive-fixnum) + (fn (pop funs)) + (new (unless (eq fn 'syntax-propertize-wholelines) + (funcall fn start end)))) + (when (and new + (or (< (car new) start) + (> (cdr new) end))) + (setq extended t + start (car new) + end (cdr new)) + ;; If there's been a change, we should go through the list again + ;; since this new position may warrant a different answer from + ;; one of the funs we've already seen. + (unless (eq funs (cdr syntax-propertize-extend-region-functions)) + (setq funs syntax-propertize-extend-region-functions))))) + (when extended (cons start end)))))))) + +;; used for hard debugging of syntax properties in batch mode +(defun pm--syntax-after (pos) + (let ((syntax (syntax-after pos))) + (with-temp-buffer + (internal-describe-syntax-value syntax) + (buffer-string)))) + +;; called from syntax-propertize and thus at the beginning of syntax-ppss +(defun polymode-syntax-propertize (beg end) + ;; (message "SP:%d-%d" beg end) + (unless pm-initialization-in-progress + (save-restriction + (widen) + (save-excursion + + ;; some modes don't save data in their syntax propertize functions + (save-match-data + (let ((real-end end) + (base (pm-base-buffer)) + (protect-host (with-current-buffer (pm-base-buffer) + (eieio-oref pm/chunkmode 'protect-syntax)))) + + ;; 1. host if no protection + (unless protect-host + (with-current-buffer base + (set 'syntax-propertize--done end) + ;; (message "sp:%s:%d-%d" major-mode beg end) + (when pm--syntax-propertize-function-original + ;; For syntax matchers the host mode syntax prioritization + ;; should be smart enough to install relevant elements around + ;; end for the followup map-over-modes to work correctly. + (pm--call-syntax-propertize-original beg end)))) + + ;; 2. all others + (let ((last-ppss nil)) + (pm-map-over-modes + (lambda (mbeg mend) + ;; Cannot set this earlier because some buffers might not be + ;; created when this function is called. One major reason to + ;; set this here is to avoid recurring into syntax-propertize + ;; when propertize functions call syntax-ppss. `setq' doesn't + ;; have an effect because the var is let bound but `set' + ;; works. + (set 'syntax-propertize--done (max end mend)) + ;; (message "sp:%s:%d-%d" major-mode (max beg mbeg) mend) + (if (eq base (current-buffer)) + (when protect-host + (pm--reset-ppss-cache-0 mbeg last-ppss) + (when pm--syntax-propertize-function-original + (pm--call-syntax-propertize-original (max beg mbeg) mend)) + (setq last-ppss (syntax-ppss mend))) + (pm--reset-ppss-cache-0 mbeg) + (when pm--syntax-propertize-function-original + (pm--call-syntax-propertize-original (max beg mbeg) mend)))) + beg end)))))))) + +(defvar syntax-ppss-wide) +(defvar syntax-ppss-last) +(defvar syntax-ppss-cache) +(defun pm--reset-ppss-cache (span) + "Reset `syntax-ppss-last' cache if it was recorded before SPAN's start." + (let ((sbeg (nth 1 span)) + new-ppss) + (unless (car span) + ;; Host chunk is special. Pick ppss from end of last span. Body chunks + ;; with nested inner chunks should be treated the same but no practical + ;; example showed so far. + (save-restriction + (widen) + (save-excursion + (let ((pos sbeg)) + (while (and (null new-ppss) + (not (= pos (point-min)))) + (let ((prev-span (pm-innermost-span (1- pos)))) + (if (null (car prev-span)) + (setq new-ppss (syntax-ppss pos)) + (setq pos (nth 1 prev-span))))))))) + (pm--reset-ppss-cache-0 sbeg new-ppss))) + +(defun pm--reset-ppss-cache-0 (pos &optional new-ppss) + (unless new-ppss + (setq new-ppss (list 0 nil pos nil nil nil 0 nil nil nil nil))) + ;; in emacs 26 there are two caches syntax-ppss-wide and + ;; syntax-ppss-narrow. The latter is reset automatically each time a + ;; different narrowing is in place so we don't deal with it for now. + (let ((cache (if pm--emacs>26 + (cdr syntax-ppss-wide) + syntax-ppss-cache))) + (while (and cache (>= (caar cache) pos)) + (setq cache (cdr cache))) + (setq cache (cons (cons pos new-ppss) cache)) + (if pm--emacs>26 + ;; syntax-ppss involves an aggressive cache cleaning; protect for one + ;; such cleaning by double entry + (setq syntax-ppss-wide (cons (car cache) cache)) + (setq syntax-ppss-cache cache) + (setq syntax-ppss-last (cons pos new-ppss)))) + new-ppss) + + +;; (defun polymode-reset-ppss-cache (&optional pos) +;; "Reset `syntax-ppss' cache to POS in polymode buffers. +;; Used in :before advice of `syntax-ppss'." +;; (when polymode-mode +;; (pm--reset-ppss-cache (pm-innermost-span pos)))) + +;; (advice-add #'syntax-ppss :before #'polymode-reset-ppss-cache) +;; (unless pm--emacs>26 +;; (advice-add #'syntax-ppss :before #'polymode-reset-ppss-cache)) + +;; (defun polymode-restrict-syntax-propertize-extension (orig-fun beg end) +;; (if (and polymode-mode pm/polymode) +;; (let ((span (pm-innermost-span beg))) +;; (if (eieio-oref (nth 3 span) 'protect-syntax) +;; (let ((range (pm-span-to-range span))) +;; (if (and (eq beg (car range)) +;; (eq end (cdr range))) +;; ;; in the most common case when span == beg-end, simply return +;; range +;; (let ((be (funcall orig-fun beg end))) +;; (and be +;; (cons (max (car be) (car range)) +;; (min (cdr be) (cdr range))))))) +;; (funcall orig-fun beg end))) +;; (funcall orig-fun beg end))) + + +;;; INTERNAL UTILITIES + +(defun pm--set-transient-map (commands) + "Set transient map with COMMANDS. +COMMANDS is a list of commands which are bound to their +accessible keys as well as the basic event of those keys. Used +for \"cycling\" commands." + (let ((map (make-sparse-keymap))) + (mapc (lambda (cmd) + (mapc (lambda (vec) + (define-key map vec cmd) + (let ((basic-ev (elt vec (1- (length vec))))) + (define-key map (vector basic-ev) cmd))) + (where-is-internal cmd))) + commands) + (set-transient-map map))) + +(defun pm--display-file (ofile) + (when ofile + ;; errors might occur (most notably with open-with package errors are intentional) + ;; We need to catch those if we want to display multiple files like with Rmarkdown + (condition-case-unless-debug err + (let ((buff (get-file-buffer ofile))) + (when buff + (with-current-buffer buff + (with-demoted-errors "Error while reverting: %s" + ;; FIXME: something is not right with pdflatex export with + ;; pdf-tools viewer within emacs + (revert-buffer t t)))) + (when (if (functionp polymode-display-output-file) + (funcall polymode-display-output-file ofile) + polymode-display-output-file) + (if (string-match-p "html\\|htm$" ofile) + (browse-url ofile) + (display-buffer (find-file-noselect ofile 'nowarn))))) + (error (message "Error while displaying '%s': %s" + (file-name-nondirectory ofile) + (error-message-string err)))))) + +(defun pm--symbol-name (str-or-symbol) + (if (symbolp str-or-symbol) + (symbol-name str-or-symbol) + str-or-symbol)) + +(defun pm--true-mode-symbol (mode) + "Resolve aliases of MODE and return the true MODE name." + (while (and mode (symbolp (symbol-function mode))) + (setq mode (symbol-function mode))) + mode) + +(defun pm--get-existing-mode (mode fallback) + "Return MODE symbol if it's defined and is a valid function. +If so, return it, otherwise check in turn +`polymode-default-inner-mode', the FALLBACK and ultimately +`poly-fallback-mode'." + (pm--true-mode-symbol + (cond ((fboundp mode) mode) + ((eq polymode-default-inner-mode 'host) (buffer-local-value 'major-mode (pm-base-buffer))) + ((fboundp polymode-default-inner-mode) polymode-default-inner-mode) + ((eq fallback 'host) (buffer-local-value 'major-mode (pm-base-buffer))) + ((fboundp fallback) fallback) + (t 'poly-fallback-mode)))) + +(defun pm--get-innermode-mode (chunkmode type) + "Retrieve the mode name of for inner CHUNKMODE for span of TYPE." + (pm--get-existing-mode + (cl-case (pm-true-span-type chunkmode type) + (body (eieio-oref chunkmode 'mode)) + (head (eieio-oref chunkmode 'head-mode)) + (tail (eieio-oref chunkmode 'tail-mode)) + (t (error "Invalid type (%s); must be one of body, head tail" type))) + (eieio-oref chunkmode 'fallback-mode))) + +;; Used in auto innermode detection only and can return symbol 'host as that's +;; needed in pm--get-auto-chunkmode. +(defun pm-get-mode-symbol-from-name (name &optional fallback) + "Guess and return mode function from short NAME. +Return FALLBACK if non-nil, otherwise the value of +`polymode-default-inner-mode' if non-nil, otherwise value of slot +:fallback-mode which globally defaults to `poly-fallback-mode'." + (pm--true-mode-symbol + (cond + ;; anonymous chunk + ((or (null name) + (and (stringp name) (= (length name) 0))) + (or + (when (or (eq polymode-default-inner-mode 'host) + (fboundp polymode-default-inner-mode)) + polymode-default-inner-mode) + (when (or (eq fallback 'host) + (fboundp fallback)) + fallback) + 'poly-fallback-mode)) + ;; proper mode symbol + ((and (symbolp name) (fboundp name) name)) + ;; compute from name + ((let* ((str (pm--symbol-name + (or (cdr (assq (intern (pm--symbol-name name)) + polymode-mode-name-aliases)) + name))) + (mname (concat str "-mode"))) + (or + ;; direct search + (let ((mode (intern mname))) + (when (fboundp mode) + mode)) + ;; downcase + (let ((mode (intern (downcase mname)))) + (when (fboundp mode) + mode)) + ;; auto-mode alist + (let ((dummy-file (concat "a." str))) + (cl-loop for (k . v) in auto-mode-alist + if (and (string-match-p k dummy-file) + (not (string-match-p "^poly-" (symbol-name v)))) + return v)) + (when (or (eq polymode-default-inner-mode 'host) + (fboundp polymode-default-inner-mode)) + polymode-default-inner-mode) + (when (or (eq fallback 'host) + (fboundp fallback)) + fallback) + 'poly-fallback-mode)))))) + +(defun pm--oref-with-parents (object slot) + "Merge slots SLOT from the OBJECT and all its parent instances." + (let (VALS) + (while object + (setq VALS (append (and (slot-boundp object slot) ; don't cascade + (eieio-oref object slot)) + VALS) + object (and (slot-boundp object :parent-instance) + (eieio-oref object 'parent-instance)))) + VALS)) + +(defun pm--abrev-names (abrev-regexp list) + "Abbreviate names in LIST by erasing ABREV-REGEXP matches. +Elements of LIST can be either strings or symbols." + (mapcar (lambda (nm) + (let* ((str-nm (if (symbolp nm) + (symbol-name nm) + nm)) + (prefix (replace-regexp-in-string "^poly-[^-]+\\(.+\\)" "" str-nm nil nil 1)) + (is-lib (or (string= prefix "poly-r") ; ugly special case as the library is called poly-R + (featurep (intern prefix))))) + (cons (replace-regexp-in-string abrev-regexp "" + (if is-lib + (replace-regexp-in-string "^poly-[^-]+-" "" str-nm) + str-nm)) + str-nm))) + list)) + +(defun pm--object-value (obj) + (cond + ((functionp obj) + (funcall obj)) + ((symbolp obj) + (symbol-value obj)) + (t obj))) + +(defun pm--oref-value (object slot) + (pm--object-value (eieio-oref object slot))) + +(defun pm--prop-put (key val &optional object) + (oset (or object pm/polymode) -props + (plist-put (oref (or object pm/polymode) -props) key val))) + +(defun pm--prop-get (key &optional object) + (plist-get (oref (or object pm/polymode) -props) key)) + +(defun pm--comment-region (beg end) + ;; mark as syntactic comment + (when (> end 1) + (with-silent-modifications + (let ((beg (or beg (region-beginning))) + (end (or end (region-end)))) + (let ((ch-beg (char-after beg)) + (ch-end (char-before end))) + (add-text-properties beg (1+ beg) + (list 'syntax-table (cons 11 ch-beg) + 'rear-nonsticky t + 'polymode-comment 'start)) + (add-text-properties (1- end) end + (list 'syntax-table (cons 12 ch-end) + 'rear-nonsticky t + 'polymode-comment 'end))))))) + +(defun pm--uncomment-region (beg end) + ;; Remove all syntax-table properties. + ;; fixme: this beggs for problems + (when (> end 1) + (with-silent-modifications + (let ((props '(syntax-table nil rear-nonsticky nil polymode-comment nil))) + (remove-text-properties (max beg (point-min)) (min end (point-max)) props) + ;; (remove-text-properties beg (1+ beg) props) + ;; (remove-text-properties end (1- end) props) + )))) + +(defun pm--synchronize-points (&optional buffer) + "Synchronize the point in polymode buffers with the point in BUFFER." + (setq buffer (current-buffer)) + (when (and polymode-mode + (buffer-live-p buffer)) + (let* ((bufs (eieio-oref pm/polymode '-buffers)) + ;; (buffer (or buffer + ;; (cl-loop for b in bufs + ;; if (and (buffer-live-p b) + ;; (buffer-local-value 'pm/current b)) + ;; return b) + ;; (current-buffer))) + (pos (with-current-buffer buffer (point)))) + (dolist (b bufs) + (when (buffer-live-p b) + (with-current-buffer b + (goto-char pos))))))) + +(defun pm--completing-read (prompt collection &optional predicate require-match + initial-input hist def inherit-input-method) + ;; Wrapper for `completing-read'. + ;; Take care when collection is an alist of (name . meta-info). If + ;; so, asks for names, but returns meta-info for that name. Enforce + ;; require-match = t. Also takes care of adding the most relevant + ;; DEF from history. + (if (and (listp collection) + (listp (car collection))) + (let* ((candidates (mapcar #'car collection)) + (thirst (and hist + (delq nil (mapcar (lambda (x) (car (member x candidates))) + (symbol-value hist))))) + (def (or def (car thirst) (car candidates)))) + (assoc (completing-read prompt candidates predicate t initial-input hist def inherit-input-method) + collection)) + (completing-read prompt collection predicate require-match initial-input hist def inherit-input-method))) + + +;;; WEAVING and EXPORTING +;; fixme: move all these into separate polymode-process.el? +(defvar polymode-exporter-output-file-format) +(defvar polymode-weaver-output-file-format) +(declare-function pm-export "polymode-export") +(declare-function pm-weave "polymode-weave") +(declare-function comint-exec "comint") +(declare-function comint-mode "comint") + +(defun pm--wrap-callback (processor slot _ifile) + ;; replace processor :sentinel or :callback temporally in order to export-spec as a + ;; followup step or display the result + (let ((sentinel1 (eieio-oref processor slot)) + (cur-dir default-directory) + (exporter (symbol-value (eieio-oref pm/polymode 'exporter))) + (obuffer (current-buffer))) + (if pm--export-spec + ;; 2-stage weaver->exporter + (let ((espec pm--export-spec)) + (lambda (&rest args) + (with-current-buffer obuffer + (let ((wfile (apply sentinel1 args)) + (pm--export-spec nil) + (pm--input-not-real t)) + ;; If no wfile, probably errors occurred. So we stop. + (when wfile + (when (listp wfile) + ;; In an unlikely situation weaver can generate multiple + ;; files. Pick the first one. + (setq wfile (car wfile))) + (pm-export exporter (car espec) (cdr espec) wfile)))))) + (lambda (&rest args) + (with-current-buffer obuffer + (let ((ofile (apply sentinel1 args))) + (when ofile + (let ((ofiles (if (listp ofile) ofile (list ofile)))) + (dolist (f ofiles) + (pm--display-file (expand-file-name f cur-dir))))))))))) + +(defun pm--file-mod-time (file) + (and (stringp file) + (file-exists-p file) + (nth 5 (file-attributes file)))) + +(defvar-local pm--process-buffer nil) +;; Simplified version of TeX-run-TeX. Run shell COMMAND interactively in BUFFER. +;; Run COMMAND in a buffer (in comint-shell-mode) in order to be able to accept +;; user interaction. +(defun pm--run-shell-command (command sentinel buff-name message) + (require 'comint) + (let* ((buffer (get-buffer-create buff-name)) + (process nil) + ;; weave/export buffers are re-usable; need to transfer some vars + (dd default-directory) + ;; (command (shell-quote-argument command)) + (inhibit-read-only t)) + (with-current-buffer buffer + (setq-local default-directory dd) + (setq buffer-read-only nil) + (erase-buffer) + (insert message) + (comint-exec buffer buff-name shell-file-name nil + (list shell-command-switch command)) + (setq process (get-buffer-process buffer)) + (comint-mode) + (goto-address-mode 1) + (set-process-sentinel process sentinel) + (setq pm--process-buffer t) + (set-marker (process-mark process) (point-max)) + ;; for communication with sentinel + (process-put process :output-file pm--output-file) + (process-put process :output-file-mod-time (pm--file-mod-time pm--output-file)) + (process-put process :input-file pm--input-file) + (when polymode-display-process-buffers + (display-buffer buffer `(nil . ((inhibit-same-window . ,pop-up-windows))))) + nil))) + +(defun pm--make-shell-command-sentinel (action) + (lambda (process _name) + "Sentinel built with `pm--make-shell-command-sentinel'." + (let ((buff (process-buffer process)) + (status (process-exit-status process))) + (if (> status 0) + (progn + (message "Errors during %s; process exit status %d" action status) + (ding) (sit-for 1) + nil) + (with-current-buffer buff + (let ((ofile (process-get process :output-file))) + (cond + ;; 1. output-file guesser + ((functionp ofile) (funcall ofile)) + ;; 2. string + (ofile + (let ((otime (process-get process :output-file-mod-time)) + (ntime (pm--file-mod-time ofile))) + (if (or (null ntime) + (and otime + (not (time-less-p otime ntime)))) + ;; mod time didn't change + ;; tothink: shall we still return ofile for display? + (progn + (display-buffer (current-buffer)) + (message "Output file unchanged. Either input unchanged or errors during %s." action) + (ding) (sit-for 1) + ofile) + ;; else, all is good, we return the file name + ;; (display-buffer (current-buffer)) + (message "Done with %s" action) + ofile))) + ;; 3. output file is not known; display process buffer + (t (display-buffer (current-buffer)) nil)))))))) + +(fset 'pm-default-shell-export-sentinel (pm--make-shell-command-sentinel "export")) +(fset 'pm-default-shell-weave-sentinel (pm--make-shell-command-sentinel "weaving")) + +(defun pm--make-selector (specs elements) + (cond ((functionp elements) elements) + ((listp elements) + (let ((spec-alist (cl-mapcar #'cons specs elements))) + (lambda (selsym &rest _ignore) + (cdr (assoc selsym spec-alist))))) + (t (error "Elements argument must be either a list or a function")))) + +(defun pm--selector (processor type id) + (let ((spec (or (assoc id (eieio-oref processor type)) + (error "%s spec '%s' cannot be found in '%s'" + (symbol-name type) id (eieio-object-name processor)))) + (names (cond + ;; exporter slots + ((eq type :from) '(regexp doc command)) + ((eq type :to) '(ext doc t-spec)) + ;; weaver slot + ((eq type :from-to) '(regexp ext doc command)) + (t (error "Invalid type '%s'" type))))) + (cons id (pm--make-selector names (cdr spec))))) + +(defun pm--selector-match (el &optional file) + (let* ((id (car el)) + (regexp (funcall (cdr el) 'regexp id))) + (or (funcall (cdr el) 'match id file) + (and regexp + (string-match-p regexp (or file buffer-file-name)))))) + +(defun pm--matched-selectors (translator slot) + (let ((translator (if (symbolp translator) + (symbol-value translator) + translator))) + (cl-loop for el in (pm--selectors translator slot) + when (pm--selector-match el) + collect el))) + +(defun pm--selectors (processor type) + (let ((ids (mapcar #'car (eieio-oref processor type)))) + (mapcar (lambda (id) (pm--selector processor type id)) ids))) + +(defun pm--output-command.file (output-file-format sfrom &optional sto quote) + ;; !!Must be run in input buffer!! + (cl-flet ((squote (arg) (or (and (stringp arg) + (if quote (shell-quote-argument arg) arg)) + ""))) + (let* ((el (or sto sfrom)) + (base-ofile (or (funcall (cdr el) 'output-file (car el)) + (let ((ext (funcall (cdr el) 'ext (car el)))) + (when ext + (concat (format output-file-format + (file-name-base buffer-file-name)) + "." ext))))) + (ofile (and (stringp base-ofile) + (expand-file-name base-ofile))) + (oname (and (stringp base-ofile) + (file-name-base base-ofile))) + (t-spec (and sto (funcall (cdr sto) 't-spec (car sto)))) + (command-w-formats (or (and sto (funcall (cdr sto) 'command (car sto))) + (and (listp t-spec) (car t-spec)) + (funcall (cdr sfrom) 'command (car sfrom)))) + (command (format-spec command-w-formats + (list (cons ?i (squote (file-name-nondirectory buffer-file-name))) + (cons ?I (squote buffer-file-name)) + (cons ?o (squote base-ofile)) + (cons ?O (squote ofile)) + (cons ?b (squote oname)) + (cons ?t (squote t-spec)))))) + (cons command (or ofile base-ofile))))) + +(defun pm--process-internal (processor from to ifile &optional callback quote) + (let ((is-exporter (object-of-class-p processor 'pm-exporter))) + (if is-exporter + (unless (and from to) + (error "For exporter both FROM and TO must be supplied (from: %s, to: %s)" from to)) + (unless from + ;; it represents :from-to slot + (error "For weaver FROM must be supplied (from: %s)" from))) + (let* ((sfrom (if is-exporter + (pm--selector processor :from from) + (pm--selector processor :from-to from))) + (sto (and is-exporter (pm--selector processor :to to))) + (ifile (or ifile buffer-file-name)) + ;; fixme: nowarn is only right for inputs from weavers, you need to + ;; save otherwise + (ibuffer (if pm--input-not-real + ;; for exporter input we silently re-fetch the file + ;; even if it was modified + (find-file-noselect ifile t) + ;; if real user file, get it or fetch it + (or (get-file-buffer ifile) + (find-file-noselect ifile)))) + (output-format (if is-exporter + polymode-exporter-output-file-format + polymode-weaver-output-file-format))) + (when (buffer-live-p ibuffer) + (with-current-buffer ibuffer + ;; FIXME: could be deleted buffer in weaver->exporter pipeline? + (save-buffer) + (let ((comm.ofile (pm--output-command.file output-format sfrom sto quote))) + (let* ((pm--output-file (cdr comm.ofile)) + (pm--input-file ifile) + ;; skip weaving step if possible + ;; :fixme this should not happen after weaver/exporter change + ;; or after errors in previous exporter + (omt (and polymode-skip-processing-when-unmodified + (stringp pm--output-file) + (pm--file-mod-time pm--output-file))) + (imt (and omt (pm--file-mod-time pm--input-file))) + (action (if is-exporter "exporting" "weaving")) + (ofile (if (and imt (time-less-p imt omt)) + (progn + (message "Not re-%s as input file '%s' hasn't changed" + (file-name-nondirectory ifile) action) + pm--output-file) + (message "%s '%s' with '%s' ..." + (capitalize action) + (file-name-nondirectory ifile) + (eieio-object-name processor)) + (let ((fn (with-no-warnings + (eieio-oref processor 'function))) + ;; `to` is nil for weavers + (args (delq nil (list from to))) + (comm (car comm.ofile))) + (if callback + ;; the display is handled within the + ;; callback and return value of :function + ;; slot is ignored + (progn (apply fn comm callback args) + nil) + (apply fn comm args)))))) + (when ofile + (if pm--export-spec + ;; same logic as in pm--wrap-callback + (let ((pm--input-not-real t) + (espec pm--export-spec) + (pm--export-spec nil)) + (when (listp ofile) + (setq ofile (car ofile))) + (pm-export (symbol-value (eieio-oref pm/polymode 'exporter)) + (car espec) (cdr espec) + ofile)) + (pm--display-file ofile)))))))))) + +;; (defun replace-poly-spec () +;; (interactive) +;; (when (re-search-forward "defcustom +pm-\\(inner\\|host\\|poly\\)/\\([^ \n]+\\)" nil t) +;; (let* ((mode (match-string 2)) +;; (type (match-string 1)) +;; (new-name (format "poly-%s-%smode" mode type))) +;; (previous-line 1) +;; (insert (format "(define-obsolete-variable-alias 'pm-%s/%s '%s \"v0.2\")\n" type mode new-name)) +;; (insert (format "(define-%smode %s\n)" type new-name))))) + +(provide 'polymode-core) +;;; polymode-core.el ends here diff --git a/elpa/polymode-20190714.2017/polymode-debug.el b/elpa/polymode-20190714.2017/polymode-debug.el new file mode 100644 index 0000000..446a8d3 --- /dev/null +++ b/elpa/polymode-20190714.2017/polymode-debug.el @@ -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/vspinu/polymode +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; This file is *NOT* part of GNU Emacs. +;; +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 3, or +;; (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; + +;;; 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-print-relevant-variables) + (define-key map (kbd "M-n p") #'pm-debug-print-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-fast-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 diff --git a/elpa/polymode-20190714.2017/polymode-export.el b/elpa/polymode-20190714.2017/polymode-export.el new file mode 100644 index 0000000..9ee3211 --- /dev/null +++ b/elpa/polymode-20190714.2017/polymode-export.el @@ -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/vspinu/polymode +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; This file is *NOT* part of GNU Emacs. +;; +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 3, or +;; (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; + +;;; 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 diff --git a/elpa/polymode-20190714.2017/polymode-methods.el b/elpa/polymode-20190714.2017/polymode-methods.el new file mode 100644 index 0000000..dff0afe --- /dev/null +++ b/elpa/polymode-20190714.2017/polymode-methods.el @@ -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/vspinu/polymode +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; This file is *NOT* part of GNU Emacs. +;; +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 3, or +;; (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; 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. + (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)) + ;; Call polymode mode for the sake of the keymap. Same minor mode which runs + ;; in the host buffer but without all the heavy initialization. + (funcall (eieio-oref pm/polymode '-minor-mode)) + ;; 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)) + +(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 diff --git a/elpa/polymode-20190714.2017/polymode-pkg.el b/elpa/polymode-20190714.2017/polymode-pkg.el new file mode 100644 index 0000000..0e6e43b --- /dev/null +++ b/elpa/polymode-20190714.2017/polymode-pkg.el @@ -0,0 +1,12 @@ +(define-package "polymode" "20190714.2017" "Extensible framework for multiple major modes" + '((emacs "25")) + :keywords + '("languages" "multi-modes" "processes") + :authors + '(("Vitalie Spinu")) + :maintainer + '("Vitalie Spinu") + :url "https://github.com/vitoshka/polymode") +;; Local Variables: +;; no-byte-compile: t +;; End: diff --git a/elpa/polymode-20190714.2017/polymode-tangle.el b/elpa/polymode-20190714.2017/polymode-tangle.el new file mode 100644 index 0000000..83eb5e2 --- /dev/null +++ b/elpa/polymode-20190714.2017/polymode-tangle.el @@ -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/vspinu/polymode +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; This file is *NOT* part of GNU Emacs. +;; +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 3, or +;; (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: +;; +;;; Code: + +(defgroup polymode-tangle nil + "Polymode Tanglers." + :group 'polymode) + +(provide 'polymode-tangle) +;;; polymode-tangle.el ends here diff --git a/elpa/polymode-20190714.2017/polymode-test-utils.el b/elpa/polymode-20190714.2017/polymode-test-utils.el new file mode 100644 index 0000000..85b4c2b --- /dev/null +++ b/elpa/polymode-20190714.2017/polymode-test-utils.el @@ -0,0 +1,466 @@ +;;; polymode-test-utils.el --- Testing utilities for polymode -*- lexical-binding: t -*- +;; +;; Copyright (C) 2018-2019, Vitalie Spinu +;; Author: Vitalie Spinu +;; URL: https://github.com/vspinu/polymode +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; This file is *NOT* part of GNU Emacs. +;; +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 3, or +;; (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; +;;; Commentary: +;; +;; This file should be loaded only in tests. +;; +;;; Code: + +(setq eieio-backward-compatibility nil) + +(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 diff --git a/elpa/polymode-20190714.2017/polymode-weave.el b/elpa/polymode-20190714.2017/polymode-weave.el new file mode 100644 index 0000000..510c8cc --- /dev/null +++ b/elpa/polymode-20190714.2017/polymode-weave.el @@ -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/vspinu/polymode +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; This file is *NOT* part of GNU Emacs. +;; +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 3, or +;; (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; 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 diff --git a/elpa/polymode-20190714.2017/polymode.el b/elpa/polymode-20190714.2017/polymode.el new file mode 100644 index 0000000..2e530f0 --- /dev/null +++ b/elpa/polymode-20190714.2017/polymode.el @@ -0,0 +1,690 @@ +;;; 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 +;; Package-Requires: ((emacs "25")) +;; URL: https://github.com/vitoshka/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 . +;; +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; 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 "") #'polymode-eval-buffer-from-beg-to-point) + (define-key polymode-eval-map (kbd "") #'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 [¬ 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 indirect buffers only. Inner modes during + ;; initialization call this polymode minor-mode which triggers + ;; this `pm-initialize'. + (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 diff --git a/site/tla-tools b/site/tla-tools new file mode 160000 index 0000000..8f9e0c7 --- /dev/null +++ b/site/tla-tools @@ -0,0 +1 @@ +Subproject commit 8f9e0c70b755c31117ed0c4f27e4b7c7127976d5