1478 lines
59 KiB
EmacsLisp
1478 lines
59 KiB
EmacsLisp
;; polymode-core.el --- Core initialization and utilities for polymode -*- lexical-binding: t -*-
|
||
;;
|
||
;; Copyright (C) 2013-2018, Vitalie Spinu
|
||
;; Author: Vitalie Spinu
|
||
;; URL: https://github.com/vspinu/polymode
|
||
;;
|
||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
;;
|
||
;; This file is *NOT* part of GNU Emacs.
|
||
;;
|
||
;; This program is free software; you can redistribute it and/or
|
||
;; modify it under the terms of the GNU General Public License as
|
||
;; published by the Free Software Foundation; either version 3, or
|
||
;; (at your option) any later version.
|
||
;;
|
||
;; This program is distributed in the hope that it will be useful,
|
||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||
;; General Public License for more details.
|
||
;;
|
||
;; You should have received a copy of the GNU General Public License
|
||
;; along with this program; see the file COPYING. If not, write to
|
||
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth
|
||
;; Floor, Boston, MA 02110-1301, USA.
|
||
;;
|
||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
;;
|
||
;;; Commentary:
|
||
;;
|
||
;;; Code:
|
||
|
||
(require 'gv)
|
||
(require 'font-lock)
|
||
(require 'color)
|
||
(require 'polymode-classes)
|
||
(require 'format-spec)
|
||
(eval-when-compile
|
||
(require 'cl-lib)
|
||
(require 'derived))
|
||
|
||
|
||
;;; ESSENTIAL DECLARATIONS
|
||
(defvar *span* nil)
|
||
(defvar-local pm/polymode nil)
|
||
(defvar-local pm/chunkmode nil)
|
||
(defvar-local pm/current nil)
|
||
(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--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-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)
|
||
;; We need this during cascaded call-next-method in pm-initialize. -innermodes
|
||
;; are initialized after the hostmode setup has taken place. This means that
|
||
;; pm-get-span and all the functionality that relies on it will fail to work
|
||
;; correctly during the initialization in the call-next-method. This is
|
||
;; particularly relevant to font-lock setup and user hooks.
|
||
(defvar pm-initialization-in-progress nil)
|
||
|
||
|
||
;; CUSTOM
|
||
|
||
;;;###autoload
|
||
(defvar-local polymode-default-inner-mode nil
|
||
"Inner mode for chunks with unspecified modes.
|
||
Intended to be used as local variable in polymode buffers.")
|
||
;;;###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-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-alias-alist "2018-08")
|
||
(defcustom polymode-mode-name-alias-alist
|
||
'((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-override-alist '(julia . ess-julia))
|
||
|
||
will cause installation of `ess-julia-mode' in markdown ```julia chunks."
|
||
:group 'polymode
|
||
:type 'alist)
|
||
|
||
(defvar polymode-switch-buffer-hook nil
|
||
"Hook run on switching to a different buffer.
|
||
Each function is run with two arguments `old-buffer' and
|
||
`new-buffer'. This hook is commonly used to transfer state
|
||
between buffers. The hook is run in a new buffer, but you should
|
||
not rely on that. 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'.")
|
||
|
||
|
||
;;; 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 %d-%d %s]" extra type beg end oname)
|
||
(format "[%s %d-%d %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-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)
|
||
(pm-get-buffer-create (oref pm/polymode -hostmode)))))
|
||
|
||
(defun pm-span-mode (&optional span)
|
||
"Retrieve the major mode associated with SPAN."
|
||
(with-current-buffer (pm-span-buffer span)
|
||
major-mode))
|
||
|
||
(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 ant
|
||
: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)))
|
||
(unless (or (null type) (eq type 'host))
|
||
(with-slots (mode head-mode tail-mode) chunkmode
|
||
(cond ((and (eq type 'body)
|
||
(eq mode 'host))
|
||
nil)
|
||
((or (eq type 'body)
|
||
(and (eq type 'head)
|
||
(eq head-mode 'body))
|
||
(and (eq type 'tail)
|
||
(or (eq tail-mode 'body)
|
||
(and (null tail-mode)
|
||
(eq head-mode 'body)))))
|
||
'body)
|
||
((or (and (eq type 'head)
|
||
(eq head-mode 'host))
|
||
(and (eq type 'tail)
|
||
(or (eq tail-mode 'host)
|
||
(and (null tail-mode)
|
||
(eq head-mode 'host)))))
|
||
nil)
|
||
((eq type 'head)
|
||
'head)
|
||
((eq type 'tail)
|
||
(if tail-mode
|
||
'tail
|
||
'head))
|
||
(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--intersect-spans (config &optional pos)
|
||
;; fixme: host should be last, to take advantage of the chunkmodes computation?
|
||
(let* ((start (point-min))
|
||
(end (point-max))
|
||
(pos (or pos (point)))
|
||
(span (list nil start end nil))
|
||
(chunk-modes (cons (oref config -hostmode)
|
||
(oref config -innermodes)))
|
||
val)
|
||
(dolist (im chunk-modes)
|
||
;; Optimization opportunity: this searches till the end of buffer but the
|
||
;; outermost pm-get-span caller has computed a few span already so we can
|
||
;; pass limits or narrow to pre-computed span.
|
||
(setq val (pm-get-span im pos))
|
||
;; (message "[%d] span: %S imode: %s" (point) (pm-span-to-range span) (pm-debug-info im))
|
||
(when val
|
||
(cond
|
||
;; 1. ;; nil car means host and it can be an intersection of spans returned
|
||
;; by 2 different neighbour inner chunkmodes
|
||
((null (car val))
|
||
(setq start (max (nth 1 val)
|
||
(nth 1 span))
|
||
end (min (nth 2 val)
|
||
(nth 2 span)))
|
||
(setcar (cdr span) start)
|
||
(setcar (cddr span) end))
|
||
;; 2. Inner span
|
||
((or (> (nth 1 val) start)
|
||
(< (nth 2 val) end))
|
||
(when (or (null (car span))
|
||
(eieio-oref (nth 3 val) 'can-nest))
|
||
(setq span val
|
||
start (nth 1 val)
|
||
end (nth 2 val))))
|
||
;; 3. Outer span; overwrite previous span if nesting is not allowed.
|
||
;; This case can probably result in unexpected outcome when there are 3
|
||
;; levels of nesting with inter-changeable :can-nest property.
|
||
((and (car span)
|
||
(not (eieio-oref (nth 3 span) 'can-nest)))
|
||
(setq span val
|
||
start (nth 1 val)
|
||
end (nth 2 val))))))
|
||
|
||
(unless (and (<= start end) (<= pos end) (>= pos start))
|
||
(error "Bad polymode selection: span:%s pos:%s"
|
||
(list start end) pos))
|
||
|
||
(when (null (car span)) ; chunkmodes can compute the host span by returning nil span type
|
||
(setcar (last span) (oref config -hostmode)))
|
||
|
||
(pm-cache-span span)
|
||
|
||
span))
|
||
|
||
(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-match-data
|
||
(save-excursion
|
||
(save-restriction
|
||
(widen)
|
||
(let ((span (pm--intersect-spans config pos)))
|
||
(if (= omax pos)
|
||
(when (and (= omax (nth 1 span))
|
||
(> omax omin))
|
||
;; When pos == point-max and it's beg of span, return the
|
||
;; previous span. This occurs because the computation of
|
||
;; pm--intersect-spans is done on a widened buffer.
|
||
(setq span (pm--intersect-spans config (1- pos))))
|
||
(when (= pos (nth 2 span))
|
||
(error "Span ends at %d in (pm-inermost-span %d) %s"
|
||
pos pos (pm-format-span span))))
|
||
(pm--chop-span span omin omax)))))))
|
||
|
||
(defun pm--cached-span (&optional pos)
|
||
;; fixme: add basic miss statistics
|
||
(unless pm-initialization-in-progress
|
||
(let* ((omin (point-min))
|
||
(omax (point-max))
|
||
(pos (or pos (point)))
|
||
(pos (if (= pos omax)
|
||
(max (point-min) (1- pos))
|
||
pos))
|
||
(span (get-text-property pos :pm-span)))
|
||
(when span
|
||
(save-restriction
|
||
(widen)
|
||
(let* ((beg (nth 1 span))
|
||
(end (max beg (1- (nth 2 span)))))
|
||
(when (and (< end (point-max)) ; buffer size might have changed
|
||
(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))))
|
||
(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 a function which 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). When ACCESSOR is
|
||
missing the head span is the region covered by the same value of
|
||
PROPERTY. ACCESSOR is called at the beginning of the PROPERTY
|
||
region."
|
||
(lambda (ahead)
|
||
(pm--get-property-nearby property accessor ahead)))
|
||
|
||
|
||
(defun pm--span-at-point (head-matcher tail-matcher &optional pos can-overlap)
|
||
"Span detector with head and tail matchers.
|
||
HEAD-MATCHER and TAIL-MATCHER is as in :head-matcher slot of
|
||
`pm-inner-chunkmode' object. POS defaults to (point). When
|
||
CAN-OVERLAP is non-nil nested chunks of this type are allowed.
|
||
|
||
Return a list of the form (TYPE SPAN-START SPAN-END) where TYPE
|
||
is one of the following symbols:
|
||
nil - pos is between ‘point-min’ and head-matcher, or between
|
||
tail-matcher and ‘point-max’
|
||
body - pos is between head-matcher and tail-matcher (exclusively)
|
||
head - head span
|
||
tail - tail span"
|
||
(setq pos (or pos (point)))
|
||
(save-restriction
|
||
(widen)
|
||
(save-excursion
|
||
(goto-char pos)
|
||
(let* ((at-max (= pos (point-max)))
|
||
(head-matcher (pm-fun-matcher head-matcher))
|
||
(tail-matcher (pm-fun-matcher tail-matcher))
|
||
(head1 (funcall head-matcher -1)))
|
||
(if head1
|
||
(if (or (< pos (cdr head1))
|
||
(and at-max (= (cdr head1) pos)))
|
||
;; -----|
|
||
;; host)[head) ; can occur with sub-head == 0 only
|
||
(list 'head (car head1) (cdr head1))
|
||
;; ------------------------
|
||
;; host)[head)[body)[tail)[host)[head)[body)
|
||
(pm--find-tail-from-head pos head1 head-matcher tail-matcher can-overlap))
|
||
;; ----------
|
||
;; host)[head)[body)[tail)[host
|
||
(goto-char (point-min))
|
||
(let ((head2 (funcall head-matcher 1)))
|
||
(if head2
|
||
(if (< pos (car head2))
|
||
;; ----
|
||
;; host)[head)[body)[tail)[host
|
||
(list nil (point-min) (car head2))
|
||
(if (< pos (cdr head2))
|
||
;; -----
|
||
;; host)[head)[body)[tail)[host
|
||
(list 'head (car head2) (cdr head2))
|
||
;; -----------------
|
||
;; host)[head)[body)[tail)[host
|
||
(pm--find-tail-from-head pos head2 head-matcher tail-matcher can-overlap)))
|
||
;; no span found
|
||
nil)))))))
|
||
|
||
;; fixme: find a simpler way with recursion where head-matcher and tail-matcher could be reversed
|
||
(defun pm--find-tail-from-head (pos head head-matcher tail-matcher can-overlap)
|
||
(goto-char (cdr head))
|
||
(let ((tail (funcall tail-matcher 1))
|
||
(at-max (= pos (point-max)))
|
||
(type 'tail))
|
||
(when can-overlap
|
||
(save-excursion
|
||
;; search for next head and pick the earliest
|
||
(goto-char (cdr head))
|
||
(let ((match (funcall head-matcher 1)))
|
||
(when (or (null tail)
|
||
(and match (< (car match) (car tail))))
|
||
(setq tail match
|
||
type 'head)))))
|
||
(if tail
|
||
(if (< pos (car tail))
|
||
;; -----
|
||
;; host)[head)[body)[tail)[host)[head)
|
||
(list 'body (cdr head) (car tail))
|
||
(if (or (< pos (cdr tail))
|
||
(and at-max (= pos (cdr tail))))
|
||
;; -----
|
||
;; host)[head)[body)[tail)[host)[head)
|
||
(list type (car tail) (cdr tail))
|
||
(goto-char (cdr tail))
|
||
;; -----------
|
||
;; host)[head)[body)[tail)[host)[head)
|
||
(let ((match (funcall head-matcher 1))
|
||
(type 'head))
|
||
(when can-overlap
|
||
(save-excursion
|
||
;; search for next head and pick the earliest
|
||
(goto-char (cdr tail))
|
||
(let ((match2 (funcall tail-matcher 1)))
|
||
(when (or (null match)
|
||
(and match2 (< (car match2) (car match))))
|
||
(setq match match2
|
||
type 'tail)))))
|
||
(if match
|
||
(if (< pos (car match))
|
||
;; -----
|
||
;; host)[head)[body)[tail)[host)[head)
|
||
(list nil (cdr tail) (car match))
|
||
(if (or (< pos (cdr match))
|
||
(and at-max (= pos (cdr match))))
|
||
;; -----
|
||
;; host)[head)[body)[tail)[host)[head)[body
|
||
(list type (car match) (cdr match))
|
||
;; ----
|
||
;; host)[head)[body)[tail)[host)[head)[body
|
||
(pm--find-tail-from-head pos match head-matcher tail-matcher can-overlap)))
|
||
;; -----
|
||
;; host)[head)[body)[tail)[host)
|
||
(list nil (cdr tail) (point-max))))))
|
||
;; -----
|
||
;; host)[head)[body)
|
||
(list 'body (cdr head) (point-max)))))
|
||
|
||
|
||
;;; OBJECT HOOKS
|
||
|
||
(defun pm--run-derived-mode-hooks (config)
|
||
;; Minor modes run-hooks, major-modes run-mode-hooks.
|
||
;; Polymodes is a minor mode but with major-mode flavor. We
|
||
;; run all parent hooks in reversed order here.
|
||
(let ((this-mode (eieio-oref config '-minor-mode)))
|
||
(mapc (lambda (mm)
|
||
(let ((old-mm (symbol-value mm)))
|
||
(unwind-protect
|
||
(progn
|
||
(set mm (symbol-value this-mode))
|
||
(run-hooks (derived-mode-hook-name mm)))
|
||
(set mm old-mm))))
|
||
(pm--collect-parent-slots config '-minor-mode))))
|
||
|
||
(defun pm--run-init-hooks (object type &optional emacs-hook)
|
||
(unless pm-initialization-in-progress
|
||
(pm--run-hooks object :init-functions (or type 'host))
|
||
(when emacs-hook
|
||
(run-hooks emacs-hook))))
|
||
|
||
(defun pm--collect-parent-slots (object slot)
|
||
"Descend into parents of OBJECT and return a list of SLOT values.
|
||
Returned list is in parent first order."
|
||
(let ((inst object)
|
||
(vals nil))
|
||
(while inst
|
||
(when (slot-boundp inst slot)
|
||
(push (eieio-oref inst slot) vals))
|
||
(setq inst (and (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
|
||
(defvar pm-move-vars-from-base '(buffer-file-name)
|
||
"Variables transferred from base buffer on buffer switch.")
|
||
|
||
(defvar pm-move-vars-from-old-buffer
|
||
'(buffer-undo-list
|
||
buffer-invisibility-spec
|
||
selective-display
|
||
overwrite-mode
|
||
truncate-lines
|
||
word-wrap
|
||
line-move-visual
|
||
truncate-partial-width-windows)
|
||
"Variables transferred from old buffer on buffer switch.")
|
||
|
||
(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)))
|
||
(with-current-buffer buffer
|
||
;; (message (pm--debug-info span))
|
||
(pm--reset-ppss-last span))
|
||
(when visibly
|
||
;; always synchronize points to avoid interference from tooling working in
|
||
;; different buffers
|
||
(pm--synchronize-points (current-buffer)))
|
||
;; (message "setting buffer %d-%d [%s]" (nth 1 span) (nth 2 span) (current-buffer))
|
||
;; no further action if BUFFER is already the current buffer
|
||
(when (and (not (eq buffer (current-buffer)))
|
||
(buffer-live-p buffer))
|
||
(let ((base (pm-base-buffer)))
|
||
(pm--move-vars pm-move-vars-from-old-buffer (current-buffer) buffer)
|
||
(pm--move-vars pm-move-vars-from-base base buffer))
|
||
(if visibly
|
||
;; slow, visual selection
|
||
(pm--select-existing-buffer-visibly buffer)
|
||
;; fast set-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))
|
||
(vlm visual-line-mode)
|
||
(ractive (region-active-p))
|
||
;; text-scale-mode
|
||
(scale (and (boundp 'text-scale-mode) text-scale-mode))
|
||
(scale-amount (and (boundp 'text-scale-mode-amount) text-scale-mode-amount))
|
||
(hl-line (and (boundp 'hl-line-mode) hl-line-mode))
|
||
(mkt (mark t))
|
||
(bro buffer-read-only))
|
||
|
||
(setq pm/current nil)
|
||
(when hl-line
|
||
(hl-line-mode -1))
|
||
|
||
(pm--move-overlays old-buffer new-buffer)
|
||
|
||
(switch-to-buffer new-buffer)
|
||
(bury-buffer-internal old-buffer)
|
||
|
||
(setq pm/current t)
|
||
|
||
(unless (eq bro buffer-read-only)
|
||
(read-only-mode (if bro 1 -1)))
|
||
(pm--adjust-visual-line-mode vlm)
|
||
|
||
(when (and (boundp 'text-scale-mode-amount)
|
||
(not (and (eq scale text-scale-mode)
|
||
(= scale-amount text-scale-mode-amount))))
|
||
(if scale
|
||
(text-scale-set scale-amount)
|
||
(text-scale-set 0)))
|
||
|
||
;; fixme: what is the right way to do this ... activate-mark-hook?
|
||
(if (not ractive)
|
||
(deactivate-mark)
|
||
(set-mark mkt)
|
||
(activate-mark))
|
||
|
||
;; avoid display jumps
|
||
(goto-char point)
|
||
(when visible
|
||
(set-window-start (get-buffer-window new-buffer t) window-start))
|
||
|
||
(when hl-line
|
||
(hl-line-mode 1))
|
||
|
||
(run-hook-with-args 'polymode-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 (eq 'linum-str (car (overlay-properties o)))
|
||
(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)
|
||
(and (boundp var)
|
||
(set var (buffer-local-value var from-buffer))))))))
|
||
|
||
(defun pm--adjust-visual-line-mode (vlm)
|
||
(unless (eq visual-line-mode vlm)
|
||
(if (null vlm)
|
||
(visual-line-mode -1)
|
||
(visual-line-mode 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)))
|
||
|
||
(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-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*). It is executed with point at the
|
||
beginning of the span. Buffer is *not* narrowed to the span. If
|
||
COUNT is non-nil, jump at most that many times. If BACKWARDP is
|
||
non-nil, map backwards."
|
||
;; Important! Don't forget to save-excursion when calling map-overs-spans.
|
||
;; 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?
|
||
(goto-char (nth 1 *span*))
|
||
(save-excursion
|
||
(funcall fun *span*))
|
||
;; enter previous/next chunk
|
||
(if backwardp
|
||
(goto-char (max 1 (1- (nth 1 *span*))))
|
||
(goto-char (min (point-max) (nth 2 *span*))))
|
||
(setq *span*
|
||
(and (if backwardp
|
||
(> (point) beg)
|
||
(< (point) end))
|
||
(< nr count)
|
||
(pm-innermost-span (point) no-cache)))))))
|
||
|
||
(defun pm-map-over-modes (fun &optional beg end)
|
||
"Execute FUN on regions of the same `major-mode' between BEG and END.
|
||
FUN is a function of 2 arguments beginning and end of region and
|
||
with the mode's buffer current. Point is at the beginning of the
|
||
region. Buffer is *not* narrowed to the region."
|
||
(setq beg (or beg (point-min))
|
||
end (if end
|
||
(min end (point-max))
|
||
(point-max)))
|
||
(save-restriction
|
||
(widen)
|
||
(let ((span (pm-innermost-span beg))
|
||
(end1))
|
||
;; ensure that :pm-mode property is correct
|
||
(while (< (nth 2 span) end)
|
||
(setq span (pm-innermost-span (nth 2 span))))
|
||
(while (< beg end)
|
||
(setq end1 (next-single-property-change beg :pm-mode nil (point-max)))
|
||
(goto-char beg)
|
||
(pm-set-buffer beg)
|
||
(funcall fun beg end1)
|
||
(setq beg end1)))))
|
||
|
||
(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-last 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
|
||
;; In addition to these hooks there is `poly-lock-after-change' in poly-lock.el
|
||
|
||
(defun polymode-pre-command-synchronize-state ()
|
||
"Synchronize state between buffers.
|
||
Currently point only."
|
||
(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))))))
|
||
|
||
(defun polymode-before-change-setup (beg end)
|
||
"Run `syntax-ppss-flush-cache' from BEG to END in all polymode buffers.
|
||
This function is placed in `before-change-functions' hook."
|
||
;; 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
|
||
;; now `syntax-ppss-flush-cache is harmless, but who knows in the future.
|
||
(when (memq 'syntax-ppss-flush-cache before-change-functions)
|
||
(remove-hook 'before-change-functions 'syntax-ppss-flush-cache 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))
|
||
))))
|
||
|
||
(defvar-local pm--killed nil)
|
||
(defun polymode-after-kill-fixes ()
|
||
"Various fixes for polymode indirect buffers."
|
||
(when pm/polymode
|
||
(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 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)))))))
|
||
|
||
|
||
;;; 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-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 pm/polymode
|
||
(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)))
|
||
(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))))
|
||
(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)
|
||
;; (advice-remove #'kill-buffer #'pm-with-current-base-buffer)
|
||
;; (advice-remove #'find-alternate-file #'pm-with-current-base-buffer)
|
||
|
||
|
||
;;; 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)))))
|
||
|
||
;; called from syntax-propertize and thus at the beginning of syntax-ppss
|
||
(defun polymode-syntax-propertize (start end)
|
||
;; fixme: not entirely sure if this is really needed
|
||
(dolist (b (oref pm/polymode -buffers))
|
||
(when (buffer-live-p b)
|
||
(with-current-buffer b
|
||
;; `setq' doesn't have an effect because the var is let bound; `set' works
|
||
(set 'syntax-propertize--done end))))
|
||
|
||
(unless pm-initialization-in-progress
|
||
(save-restriction
|
||
(widen)
|
||
(save-excursion
|
||
(let ((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 (pm-base-buffer)
|
||
(when pm--syntax-propertize-function-original
|
||
(pm--call-syntax-propertize-original start end))))
|
||
;; 2. all others
|
||
(pm-map-over-spans
|
||
(lambda (span)
|
||
(when (and pm--syntax-propertize-function-original
|
||
(or (pm-true-span-type span)
|
||
protect-host))
|
||
(let ((pos0 (max (nth 1 span) start))
|
||
(pos1 (min (nth 2 span) end)))
|
||
(if (eieio-oref (nth 3 span) 'protect-syntax)
|
||
(pm--call-syntax-propertize-original pos0 pos1)))))
|
||
start end))))))
|
||
|
||
(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)))
|
||
|
||
(defvar syntax-ppss-wide)
|
||
(defvar syntax-ppss-last)
|
||
(defun pm--reset-ppss-last (span)
|
||
"Reset `syntax-ppss-last' cache if it was recorded before SPAN's start."
|
||
;; host chunk is special; body chunks with nested inner chunks should be
|
||
;; treated the same but no practical example showed so far
|
||
(let ((sbeg (nth 1 span))
|
||
new-ppss)
|
||
(unless (car span)
|
||
(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 (cons sbeg (syntax-ppss (1- pos))))
|
||
(setq pos (nth 1 prev-span)))))))))
|
||
(unless new-ppss
|
||
(setq new-ppss (list sbeg 0 nil sbeg nil nil nil 0 nil nil nil nil)))
|
||
(if pm--emacs>26
|
||
;; 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 (cdr syntax-ppss-wide)))
|
||
(while (and cache (>= (caar cache) sbeg))
|
||
(setq cache (cdr cache)))
|
||
(setq cache (cons new-ppss cache))
|
||
(setq syntax-ppss-wide (cons new-ppss cache)))
|
||
(setq syntax-ppss-last new-ppss))))
|
||
|
||
|
||
;;; INTERNAL UTILITIES
|
||
|
||
(defvar polymode-display-output-file t
|
||
"When non-nil automatically display output file in Emacs.
|
||
This is temporary variable, it might be changed or removed in the
|
||
near future.")
|
||
|
||
(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)))
|
||
;; silently kill and re-open
|
||
(when buff
|
||
(with-current-buffer buff
|
||
(revert-buffer t t)))
|
||
(when 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--get-existing-mode (mode)
|
||
"Return MODE symbol if it's defined and is a valid function.
|
||
If so, return it, otherwise the value of
|
||
`polymode-default-inner-mode' if non-nil and a valid function symbol,
|
||
otherwise `poly-fallback-mode'."
|
||
(cond ((fboundp mode) mode)
|
||
((fboundp polymode-default-inner-mode) polymode-default-inner-mode)
|
||
(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)))))
|
||
|
||
(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
|
||
`poly-fallback-mode'."
|
||
(cond
|
||
;; anonymous chunk
|
||
((or (null name)
|
||
(and (stringp name) (= (length name) 0)))
|
||
(or
|
||
(when (fboundp polymode-default-inner-mode)
|
||
polymode-default-inner-mode)
|
||
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-override-alist))
|
||
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))
|
||
;; default-inner-mode is for anonymous chunks only
|
||
;; (when (fboundp polymode-default-inner-mode)
|
||
;; polymode-default-inner-mode)
|
||
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 (list abrev-regexp)
|
||
"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)))
|
||
(cons (replace-regexp-in-string abrev-regexp "" str-nm)
|
||
str-nm)))
|
||
list))
|
||
|
||
(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.
|
||
By default BUFFER is the buffer where `pm/current' is t."
|
||
(when polymode-mode
|
||
(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))
|
||
(thist (and hist
|
||
(delq nil (mapcar (lambda (x) (car (member x candidates)))
|
||
(symbol-value hist)))))
|
||
(def (or def (car thist))))
|
||
(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
|
||
(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))
|
||
)
|
||
(with-current-buffer buffer
|
||
(setq-local default-directory dd)
|
||
(read-only-mode -1)
|
||
(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)
|
||
(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-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 ((listp elements)
|
||
(let ((spec-alist (cl-mapcar #'cons specs elements)))
|
||
(lambda (selsym &rest _ignore)
|
||
(cdr (assoc selsym spec-alist)))))
|
||
((functionp elements) elements)
|
||
(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)))))
|
||
(pm--make-selector names (cdr spec))))
|
||
|
||
(defun pm--selector-match (selector &optional file)
|
||
(or (funcall selector 'match file)
|
||
(string-match-p (funcall selector 'regexp)
|
||
(or file buffer-file-name))))
|
||
|
||
(defun pm--selectors (processor type)
|
||
(let ((ids (mapcar #'car (eieio-oref processor type))))
|
||
(mapcar (lambda (id) (cons 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* ((base-ofile (or (funcall (or sto sfrom) 'output-file)
|
||
(let ((ext (funcall (or sto sfrom) 'ext)))
|
||
(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 sto 't-spec)))
|
||
(command-w-formats (or (and sto (funcall sto 'command))
|
||
(and (listp t-spec) (car t-spec))
|
||
(funcall sfrom 'command)))
|
||
(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)))
|
||
(with-current-buffer ibuffer
|
||
(save-buffer)
|
||
(let ((comm.ofile (pm--output-command.file output-format sfrom sto quote)))
|
||
(message "%s '%s' with '%s' ..." (if is-exporter "Exporting" "Weaving")
|
||
(file-name-nondirectory ifile) (eieio-object-name processor))
|
||
(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)))
|
||
(ofile (or (and imt (time-less-p imt omt) pm--output-file)
|
||
(let ((fun (with-no-warnings
|
||
(eieio-oref processor 'function)))
|
||
(args (delq nil (list callback from to))))
|
||
(apply fun (car comm.ofile) args)))))
|
||
;; ofile is non-nil in two cases:
|
||
;; -- synchronous back-ends (very uncommon)
|
||
;; -- when output is transitional (not real) and mod time of input < output
|
||
(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)))))))))
|
||
|
||
(provide 'polymode-core)
|
||
;;; polymode-core.el ends here
|