marcuskammer/emacs.d
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions
emacs.d/elpa/polymode-20190714.2017/polymode-core.el
Marcus Kammer 2230e2f4d4 Add ein package
2019-11-30 08:46:49 +01:00

2129 lines
88 KiB
EmacsLisp
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

This file contains Unicode characters that might be confused with other characters. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

;; 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 <https://www.gnu.org/licenses/>.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; 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
Reference in a new issue View git blame Copy permalink