mprodrigues/emacs.d
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Update packages

Browse Source
This commit is contained in:
Mateus Pinto Rodrigues
2018-10-04 13:56:56 -03:00
parent 5d03e5e124
commit d272c43bcd
785 changed files with 367265 additions and 25 deletions
Download Patch File Download Diff File Expand all files Collapse all files

382
elpa/polymode-20180926.2044/poly-lock.el Normal file
View File

@@ -0,0 +1,382 @@
;;; poly-lock.el --- Font lock sub-system 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
;;
;;
;; FONT-LOCK COMPONENTS:
;;
;; All * functions are lazy in poly-lock and jit-lock because they just mark
;; 'fontified nil.
;;
;; fontification-functions -> jit-lock-function / poly-lock-function
;; font-lock-ensure -> font-lock-ensure-function -> jit-lock-fontify-now/poly-lock-fontify-now
;; *font-lock-flush -> font-lock-flush-function -> jit-lock-refontify / poly-lock-flush
;; *font-lock-fontify-buffer -> font-lock-fontify-buffer-function -> jit-lock-refontify / poly-lock-flush
;; font-lock-fontify-region -> font-lock-fontify-region-function -> font-lock-default-fontify-region
;; font-lock-unfontify-region -> font-lock-unfontify-region-function -> font-lock-default-unfontify-region
;; font-lock-unfontify-buffer -> font-lock-unfontify-buffer-function -> font-lock-default-unfontify-buffer
;;
;; Jit-lock components:
;; fontification-functions (called by display engine)
;; --> jit-lock-function
;; --> jit-lock-fontify-now (or deferred through timer/text-properties)
;; --> jit-lock--run-functions
;; --> jit-lock-functions (font-lock-fontify-region bug-reference-fontify etc.)
;;
;;
;; Poly-lock components:
;; fontification-functions
;; --> poly-lock-function
;; --> poly-lock-fontify-now
;; --> jit-lock-fontify-now
;; ...
;;
;; `font-lock-mode' call graph:
;; -> font-lock-function <---- replaced by `poly-lock-mode'
;; -> font-lock-default-function
;; -> font-lock-mode-internal
;; -> font-lock-turn-on-thing-lock
;; -> font-lock-turn-on-thing-lock
;; -> (setq font-lock-flush-function jit-lock-refontify)
;; -> (setq font-lock-ensure-function jit-lock-fontify-now)
;; -> (setq font-lock-fontify-buffer-function jit-lock-refontify)
;; -> (jit-lock-register #'font-lock-fontify-region)
;; -> (add-hook 'jit-lock-functions #'font-lock-fontify-region nil t)
;; -> jit-lock-mode
;;
;;; Commentary:
;;
;;; Code:
(require 'jit-lock)
(require 'polymode-core)
(defvar poly-lock-allow-fontification t)
(defvar poly-lock-allow-background-adjustment t)
(defvar poly-lock-fontification-in-progress nil)
(defvar-local poly-lock-mode nil)
(eval-when-compile
(defmacro with-buffer-prepared-for-poly-lock (&rest body)
"Execute BODY in current buffer, overriding several variables.
Preserves the `buffer-modified-p' state of the current buffer."
(declare (debug t))
`(let ((inhibit-point-motion-hooks t))
(with-silent-modifications
,@body))))
(defun poly-lock-no-jit-lock-in-polymode-buffers (fun arg)
"Don't activate FUN in `polymode' buffers.
When not in polymode buffers apply FUN to ARG."
(unless (or polymode-mode pm/polymode)
(funcall fun arg)))
(pm-around-advice 'jit-lock-mode #'poly-lock-no-jit-lock-in-polymode-buffers)
(defun poly-lock-mode (arg)
"This is the value of `font-lock-function' in all polymode buffers.
Mode activated when ARG is positive; happens when font-lock is
switched on."
(unless polymode-mode
(error "Calling `poly-lock-mode' in a non-polymode buffer (%s)" (current-buffer)))
(setq poly-lock-mode arg)
(if arg
(progn
;; a lot of the following is inspired by what jit-lock does in
;; `font-lock-turn-on-thing-lock'
(setq-local font-lock-support-mode 'poly-lock-mode)
(setq-local font-lock-dont-widen t)
;; Re-use jit-lock registration. Some minor modes (adaptive-wrap)
;; register extra functionality. [Unfortunately `jit-lock-register'
;; calls `jit-lock-mode' which we don't want. Hence the advice. TOTHINK:
;; Simply add-hook to `jit-lock-functions'?]
(jit-lock-register 'font-lock-fontify-region)
;; don't allow other functions
(setq-local fontification-functions '(poly-lock-function))
(setq-local font-lock-flush-function 'poly-lock-flush)
(setq-local font-lock-fontify-buffer-function 'poly-lock-flush)
(setq-local font-lock-ensure-function 'poly-lock-fontify-now)
;; There are some more, jit-lock doesn't change those, neither do we:
;; font-lock-unfontify-region-function (defaults to font-lock-default-unfontify-region)
;; font-lock-unfontify-buffer-function (defualts to font-lock-default-unfontify-buffer)
;; Don't fontify eagerly (and don't abort if the buffer is large). NB:
;; `font-lock-flush' is not triggered if this is nil.
(setq-local font-lock-fontified t)
;; Now we can finally call `font-lock-default-function' because
;; `font-lock-support-mode' is set to "unrecognizible" value, only core
;; font-lock setup happens.
(font-lock-default-function arg)
;; Must happen after call to `font-lock-default-function'
(remove-hook 'after-change-functions 'font-lock-after-change-function t)
(remove-hook 'after-change-functions 'jit-lock-after-change t)
(add-hook 'after-change-functions 'poly-lock-after-change nil t)
;; Reusing jit-lock var becuase modes populate it directly. We are using
;; this in `poly-lock-after-change' below. Taken from `jit-lock
;; initialization.
(add-hook 'jit-lock-after-change-extend-region-functions
'font-lock-extend-jit-lock-region-after-change
nil t))
(remove-hook 'after-change-functions 'poly-lock-after-change t)
(remove-hook 'fontification-functions 'poly-lock-function t))
(current-buffer))
(defun poly-lock-function (start)
"The only function in `fontification-functions' in polymode buffers.
This is the entry point called by the display engine. START is
defined in `fontification-functions'. This function has the same
scope as `jit-lock-function'."
(unless pm-initialization-in-progress
(if (and poly-lock-mode
(not memory-full))
(unless (input-pending-p)
(let ((end (or (text-property-any start (point-max) 'fontified t)
(point-max))))
(when (< start end)
(poly-lock-fontify-now start end))))
(with-buffer-prepared-for-poly-lock
(put-text-property start (point-max) 'fontified t)))))
(defun poly-lock-fontify-now (beg end &optional _verbose)
"Polymode main fontification function.
Fontifies chunk-by chunk within the region BEG END."
(unless (or poly-lock-fontification-in-progress
pm-initialization-in-progress)
(let* ((font-lock-dont-widen t)
(font-lock-extend-region-functions nil)
;; Fontification in one buffer can trigger fontification in another
;; buffer. Particularly, this happens when new indirect buffers are
;; created and `normal-mode' triggers font-lock in those buffers. We
;; avoid this by dynamically binding
;; `poly-lock-fontification-in-progress' and un-setting
;; `fontification-functions' in case re-display suddenly decides to
;; fontify something else in other buffer. There are also font-lock
;; guards in pm--mode-setup.
(poly-lock-fontification-in-progress t)
(fontification-functions nil)
(protect-host (with-current-buffer (pm-base-buffer)
(eieio-oref pm/chunkmode 'protect-font-lock))))
(save-restriction
(widen)
(save-excursion
;; fontify the whole region in host first. It's ok for modes like
;; markdown, org and slim which understand inner modes in a limited way.
(unless protect-host
(let ((span (pm-innermost-span beg)))
(when (or (null (pm-true-span-type span))
;; in inner spans fontify only if region is bigger than the span
(< (nth 2 span) end))
(with-current-buffer (pm-base-buffer)
(with-buffer-prepared-for-poly-lock
(when poly-lock-allow-fontification
(jit-lock-fontify-now beg end))
(put-text-property beg end 'fontified t))))))
(pm-map-over-spans
(lambda (span)
(when (or (pm-true-span-type span)
protect-host)
(with-buffer-prepared-for-poly-lock
(let ((sbeg (nth 1 span))
(send (nth 2 span)))
;; skip empty spans
(when (> send sbeg)
(if (not (and poly-lock-allow-fontification
poly-lock-mode))
(put-text-property sbeg send 'fontified t)
(let ((new-beg (max sbeg beg))
(new-end (min send end)))
(put-text-property new-beg new-end 'fontified nil)
(condition-case-unless-debug err
(if (eieio-oref pm/chunkmode 'protect-font-lock)
(pm-with-narrowed-to-span span
(jit-lock-fontify-now new-beg new-end))
(jit-lock-fontify-now new-beg new-end))
(error
(message "(poly-lock-fontify-now %s %s [span %d %d %s]) -> (%s %s %s): %s"
beg end sbeg send (current-buffer)
font-lock-fontify-region-function new-beg new-end
(error-message-string err))))
;; even if failed set to t
(put-text-property new-beg new-end 'fontified t)))
(when poly-lock-allow-background-adjustment
(poly-lock-adjust-span-face span)))))))
beg end))))
(current-buffer)))
(defun poly-lock-flush (&optional beg end)
"Force refontification of the region BEG..END.
END is extended to the next chunk separator. This function is
placed in `font-lock-flush-function''"
(unless poly-lock-fontification-in-progress
(let ((beg (or beg (point-min)))
(end (or end (point-max))))
(with-buffer-prepared-for-poly-lock
(save-restriction
(widen)
(pm-flush-span-cache beg end)
(put-text-property beg end 'fontified nil))))))
(defvar jit-lock-start)
(defvar jit-lock-end)
(defun poly-lock--extend-region (beg end)
"Our own extension function which runs first on BEG END change.
Assumes widen buffer. Sets `jit-lock-start' and `jit-lock-end'."
;; old span can disappear, shrunk, extend etc
(let* ((old-beg (or (previous-single-property-change end :pm-span)
(point-min)))
(old-end (or (next-single-property-change end :pm-span)
(point-max)))
;; need this here before pm-innermost-span call
(old-beg-obj (nth 3 (get-text-property old-beg :pm-span)))
;; (old-end-obj (nth 3 (get-text-property old-end :pm-span)))
(beg-span (pm-innermost-span beg 'no-cache))
(end-span (if (= beg end)
beg-span
(pm-innermost-span end 'no-cache)))
(sbeg (nth 1 beg-span))
(send (nth 2 end-span)))
(if (< old-beg sbeg)
(let ((new-beg-span (pm-innermost-span old-beg)))
(if (eq old-beg-obj (nth 3 new-beg-span))
;; new span appeared within an old span, don't refontify the old part (common case)
(setq jit-lock-start (min sbeg (nth 2 new-beg-span)))
;; wrong span shrunk to its correct size (rare or never)
(setq jit-lock-start old-beg)))
;; refontify the entire new span
(setq jit-lock-start sbeg))
;; I think it's not possible to do better than this. When region is shrunk,
;; previous region could be incorrectly fontified even if the mode is
;; preserved due to wrong ppss
(setq jit-lock-end (max send old-end))
;; (if (> old-end send)
;; (let ((new-end-span (pm-innermost-span (max (1- old-end) end))))
;; (if (eq old-end-obj (nth 3 new-end-span))
;; ;; new span appeared within an old span, don't refontify the old part (common case)
;; (setq jit-lock-end (max end (nth 1 new-end-span)))
;; ;; wrong span shrunk to its correct size
;; (setq jit-lock-end old-end)))
;; ;; refontify the entire new span
;; (setq jit-lock-end send))
;; Check if the type of following span changed (for example when
;; modification is in head of an auto-chunk). Do this repeatedly till no
;; change. [TOTHINK: Do we need similar extension backwards?]
(let ((go-on t))
(while (and (< jit-lock-end (point-max))
go-on)
(let ((ospan (get-text-property jit-lock-end :pm-span))
(nspan (pm-innermost-span jit-lock-end 'no-cache)))
(if (eq (nth 3 nspan) (nth 3 ospan))
(setq go-on nil)
(setq jit-lock-end (nth 2 nspan))))))
(cons jit-lock-start jit-lock-end)))
(defun poly-lock--extend-region-span (span old-len)
"Call `jit-lock-after-change-extend-region-functions' protected to SPAN.
Extend `jit-lock-start' and `jit-lock-end' by side effect.
OLD-LEN is passed to the extension function."
(let ((beg jit-lock-start)
(end jit-lock-end))
(let ((sbeg (nth 1 span))
(send (nth 2 span)))
;; expand only in top & bottom spans
(when (or (> beg sbeg) (< end send))
(pm-with-narrowed-to-span span
(setq jit-lock-start (max beg sbeg)
jit-lock-end (min end send))
(condition-case err
(progn
;; set jit-lock-start and jit-lock-end by side effect
(run-hook-with-args 'jit-lock-after-change-extend-region-functions
jit-lock-start jit-lock-end old-len))
(error (message "(after-change-extend-region-functions %s %s %s) -> %s"
jit-lock-start jit-lock-end old-len
(error-message-string err))))
(setq jit-lock-start (min beg (max jit-lock-start sbeg))
jit-lock-end (max end (min jit-lock-end send))))
(cons jit-lock-start jit-lock-end)))))
(defun poly-lock-after-change (beg end old-len)
"Mark changed region with 'fontified nil.
Installed in `after-change-functions' and behaves similarly to
`jit-lock-after-change' in what it calls
`jit-lock-after-change-extend-region-functions' in turn but with
the buffer narrowed to the relevant spans. BEG, END and OLD-LEN
are as in `after-change-functions'."
(when (and poly-lock-mode
pm-allow-after-change-hook
(not memory-full))
(with-buffer-prepared-for-poly-lock
(save-excursion
(save-match-data
(save-restriction
(widen)
(poly-lock--extend-region beg end)
(pm-flush-span-cache beg end)
(pm-map-over-spans
(lambda (span) (poly-lock--extend-region-span span old-len))
;; fixme: no-cache is no longer necessary, we flush the region
beg end nil nil nil 'no-cache)
(put-text-property jit-lock-start jit-lock-end 'fontified nil)
(cons jit-lock-start jit-lock-end)))))))
(defun poly-lock--adjusted-background (prop)
;; if > lighten on dark backgroun. Oposite on light.
(color-lighten-name (face-background 'default)
(if (eq (frame-parameter nil 'background-mode) 'light)
(- prop) ;; darken
prop)))
(declare-function pm-get-adjust-face "polymode-methods")
(defun poly-lock-adjust-span-face (span)
"Adjust 'face property of SPAN..
How adjustment is made is defined in :adjust-face slot of the
SPAN's chunkmode."
(interactive "r")
(let ((face (pm-get-adjust-face (nth 3 span) (car span))))
(when face
(with-current-buffer (current-buffer)
(let ((face (or (and (numberp face)
(list (cons 'background-color
(poly-lock--adjusted-background face))))
face)))
(font-lock-prepend-text-property
(nth 1 span) (nth 2 span) 'face face))))))
(provide 'poly-lock)
;;; poly-lock.el ends here

230
elpa/polymode-20180926.2044/polymode-autoloads.el Normal file
View File

@@ -0,0 +1,230 @@
;;; polymode-autoloads.el --- automatically extracted autoloads
;;
;;; Code:
(add-to-list 'load-path (directory-file-name
(or (file-name-directory #$) (car load-path))))
;;;### (autoloads nil "poly-lock" "poly-lock.el" (0 0 0 0))
;;; Generated autoloads from poly-lock.el
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "poly-lock" '("poly-lock-")))
;;;***
;;;### (autoloads nil "polymode" "polymode.el" (0 0 0 0))
;;; Generated autoloads from polymode.el
(autoload 'define-polymode "polymode" "\
Define a new polymode MODE.
This macro defines command MODE and an indicator variable MODE
which becomes t when MODE is active and nil otherwise.
MODE command can be used as both major and minor mode. Using
polymodes as minor modes makes sense when :hostmode (see below)
is not specified, in which case polymode installs only inner
modes and doesn't touch current major mode.
Standard hook MODE-hook is run at the end of the initialization
of each polymode buffer (both indirect and base buffers).
This macro also defines the MODE-map keymap from the :keymap
argument and PARENT-map (see below) and pm-poly/[MODE-NAME]
custom variable which holds a `pm-polymode' configuration object
for this polymode.
PARENT is either the polymode configuration object or a polymode
mode (there is 1-to-1 correspondence between config
objects (`pm-polymode') and mode functions). The new polymode
MODE inherits alll the behavior from PARENT except for the
overwrites specified by the keywords (see below). The new MODE
runs all the hooks from the PARENT-mode and inherits its MODE-map
from PARENT-map.
DOC is an optional documentation string. If present PARENT must
be provided, but can be nil.
BODY is executed after the complete initialization of the
polymode but before MODE-hook. It is executed once for each
polymode buffer - host buffer on initialization and every inner
buffer subsequently created.
Before the BODY code keyword arguments (i.e. alternating keywords
and values) are allowed. The following special keywords
controlling the behavior of the new MODE are supported:
:lighter Optional LIGHTER is displayed in the mode line when the
mode is on. If omitted, it defaults to the :lighter slot of
CONFIG object.
:keymap If nil, a new MODE-map keymap is created what directly
inherits from the PARENT's keymap. The last keymap in the
inheritance chain is always `polymode-minor-mode-map'. If a
keymap it is used directly as it is. If a list of binding of
the form (KEY . BINDING) it is merged the bindings are added to
the newly create keymap.
:after-hook A single form which is evaluated after the mode hooks
have been run. It should not be quoted.
Other keywords are added to the `pm-polymode' configuration
object and should be valid slots in PARENT config object or the
root config `pm-polymode' object if PARENT is nil. By far the
most frequently used slots are:
:hostmode Symbol pointing to a `pm-host-chunkmode' object
specifying the behavior of the hostmode. If missing or nil,
MODE will behave as a minor-mode in the sense that it will
reuse the currently installed major mode and will install only
the inner modes.
:innermodes List of symbols pointing to `pm-inner-chunkmode'
objects which specify the behavior of inner modes (or submodes).
\(fn MODE &optional PARENT DOC &rest BODY)" nil t)
(function-put 'define-polymode 'doc-string-elt '3)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "polymode" '("pm-" "poly")))
;;;***
;;;### (autoloads nil "polymode-base" "polymode-base.el" (0 0 0 0))
;;; Generated autoloads from polymode-base.el
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "polymode-base" '("pm-")))
;;;***
;;;### (autoloads nil "polymode-classes" "polymode-classes.el" (0
;;;;;; 0 0 0))
;;; Generated autoloads from polymode-classes.el
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "polymode-classes" '("pm-")))
;;;***
;;;### (autoloads nil "polymode-compat" "polymode-compat.el" (0 0
;;;;;; 0 0))
;;; Generated autoloads from polymode-compat.el
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "polymode-compat" '("pm-" "polymode-switch-buffer-keep-evil-state-maybe" "*span*")))
;;;***
;;;### (autoloads nil "polymode-core" "polymode-core.el" (0 0 0 0))
;;; Generated autoloads from polymode-core.el
(defvar-local polymode-default-inner-mode nil "\
Inner mode for chunks with unspecified modes.
Intended to be used as local variable in polymode buffers.")
(put 'polymode-default-inner-mode 'safe-local-variable 'symbolp)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "polymode-core" '("polymode-" "*span*")))
;;;***
;;;### (autoloads nil "polymode-debug" "polymode-debug.el" (0 0 0
;;;;;; 0))
;;; Generated autoloads from polymode-debug.el
(autoload 'pm-debug-minor-mode "polymode-debug" "\
Turns on/off useful facilities for debugging polymode.
Key bindings:
\\{pm-debug-minor-mode-map}
\(fn &optional ARG)" t nil)
(autoload 'pm-debug-minor-mode-on "polymode-debug" "\
\(fn)" nil nil)
(defvar pm-debug-mode nil "\
Non-nil if Pm-Debug mode is enabled.
See the `pm-debug-mode' command
for a description of this minor mode.
Setting this variable directly does not take effect;
either customize it (see the info node `Easy Customization')
or call the function `pm-debug-mode'.")
(custom-autoload 'pm-debug-mode "polymode-debug" nil)
(autoload 'pm-debug-mode "polymode-debug" "\
Toggle Pm-Debug minor mode in all buffers.
With prefix ARG, enable Pm-Debug mode if ARG is positive;
otherwise, disable it. If called from Lisp, enable the mode if
ARG is omitted or nil.
Pm-Debug minor mode is enabled in all buffers where
`pm-debug-minor-mode-on' would do it.
See `pm-debug-minor-mode' for more information on Pm-Debug minor mode.
\(fn &optional ARG)" t nil)
(autoload 'pm-toggle-tracing "polymode-debug" "\
Toggle polymode tracing.
With numeric prefix toggle tracing for that LEVEL. Currently
universal argument toggles maximum level of tracing (4). Default
level is 3.
\(fn LEVEL)" t nil)
(autoload 'pm-trace "polymode-debug" "\
Trace function FN.
Use `untrace-function' to untrace or `untrace-all' to untrace all
currently traced functions.
\(fn FN)" t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "polymode-debug" '("pm-")))
;;;***
;;;### (autoloads nil "polymode-export" "polymode-export.el" (0 0
;;;;;; 0 0))
;;; Generated autoloads from polymode-export.el
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "polymode-export" '("polymode-" "pm-")))
;;;***
;;;### (autoloads nil "polymode-methods" "polymode-methods.el" (0
;;;;;; 0 0 0))
;;; Generated autoloads from polymode-methods.el
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "polymode-methods" '("pm-")))
;;;***
;;;### (autoloads nil "polymode-test-utils" "polymode-test-utils.el"
;;;;;; (0 0 0 0))
;;; Generated autoloads from polymode-test-utils.el
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "polymode-test-utils" '("pm-")))
;;;***
;;;### (autoloads nil "polymode-weave" "polymode-weave.el" (0 0 0
;;;;;; 0))
;;; Generated autoloads from polymode-weave.el
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "polymode-weave" '("pm-" "polymode-")))
;;;***
;;;### (autoloads nil nil ("polymode-pkg.el" "polymode-tangle.el")
;;;;;; (0 0 0 0))
;;;***
;; Local Variables:
;; version-control: never
;; no-byte-compile: t
;; no-update-autoloads: t
;; coding: utf-8
;; End:
;;; polymode-autoloads.el ends here

178
elpa/polymode-20180926.2044/polymode-base.el Normal file
View File

@@ -0,0 +1,178 @@
;;; polymode-base.el --- Root Host and Polymode Configuration Objects -*- 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 'polymode-classes)
;; HOST MODES
(defcustom pm-host/ada
(pm-host-chunkmode :name "ada"
:mode 'ada-mode)
"Ada hostmode."
:group 'poly-hostmodes
:type 'object)
(defcustom pm-host/coffee
(pm-host-chunkmode :name "coffee"
:mode 'coffee-mode)
"Coffee hostmode."
:group 'poly-hostmodes
:type 'object)
(defcustom pm-host/fundamental
(pm-host-chunkmode :name "fundamental"
:mode 'fundamental-mode)
"Fundamental host mode."
:group 'poly-hostmodes
:type 'object)
(defcustom pm-host/java
(pm-host-chunkmode :name "js"
:mode 'java-mode)
"Java hostmode."
:group 'poly-hostmodes
:type 'object)
(defcustom pm-host/js
(pm-host-chunkmode :name "js"
:mode 'js-mode)
"Javascript hostmode."
:group 'poly-hostmodes
:type 'object)
(defcustom pm-host/latex
(pm-host-chunkmode :name "latex"
:mode 'latex-mode)
"Latex hostmode."
:group 'poly-hostmodes
:type 'object)
(defcustom pm-host/html
(pm-host-chunkmode :name "html"
:mode 'html-mode)
"HTML hostmode."
:group 'poly-hostmodes
:type 'object)
(defcustom pm-host/R
(pm-host-chunkmode :name "R"
:mode 'r-mode)
"R hostmode."
:group 'poly-hostmodes
:type 'object)
(defcustom pm-host/perl
(pm-host-chunkmode :name "perl"
:mode 'perl-mode)
"Perl hostmode."
:group 'poly-hostmodes
:type 'object)
(defcustom pm-host/ruby
(pm-host-chunkmode :name "ruby"
:mode 'ruby-mode)
"Ruby hostmode."
:group 'poly-hostmodes
:type 'object)
(defcustom pm-host/pascal
(pm-host-chunkmode :name "pascal"
:mode 'pascal-mode)
"Pascal hostmode."
:group 'poly-hostmodes
:type 'object)
(defcustom pm-host/C++
(pm-host-chunkmode :name "C++"
:mode 'c++-mode
:protect-font-lock nil)
"C++ hostmode."
:group 'poly-hostmodes
:type 'object)
(defcustom pm-host/sgml
(pm-host-chunkmode :name "sgml"
:mode 'sgml-mode)
"SGML hostmode."
:group 'poly-hostmodes
:type 'object)
(defcustom pm-host/text
(pm-host-chunkmode :name "text"
:mode 'text-mode)
"Text hostmode."
:group 'poly-hostmodes
:type 'object)
(defcustom pm-host/yaml
(pm-host-chunkmode :name "YAML"
:mode 'yaml-mode)
"YAML chunkmode."
:group 'poly-hostmodes
:type 'object)
;;; ROOT POLYMODES
;; These are simple generic configuration objects. More specialized polymodes
;; should clone these.
(defcustom pm-poly/brew
(pm-polymode :name "brew"
:hostmode 'pm-host/text)
"Brew configuration."
:group 'polymodes
:type 'object)
(defcustom pm-poly/html
(pm-polymode :name "html"
:hostmode 'pm-host/html)
"HTML configuration."
:group 'polymodes
:type 'object)
(defcustom pm-poly/C++
(pm-polymode :name "C++"
:hostmode 'pm-host/C++)
"C++ configuration."
:group 'polymodes
:type 'object)
(defcustom pm-poly/latex
(pm-polymode :name "latex"
:hostmode 'pm-host/latex)
"LaTeX configuration."
:group 'polymodes
:type 'object)
(provide 'polymode-base)
;;; polymode-base.el ends here

396
elpa/polymode-20180926.2044/polymode-classes.el Normal file
View File

@@ -0,0 +1,396 @@
;;; polymode-classes.el --- Core polymode classes -*- 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 'eieio)
(require 'eieio-base)
(require 'eieio-custom)
;; FIXME: fix emacs eieo-named bug #22840 where they wrongly set name of the
;; parent object in clone method
(setq eieio-backward-compatibility nil)
(defvar pm--object-counter 0)
(defun pm--filter-slots (slots)
(delq nil (mapcar (lambda (slot)
(unless (or (= (elt (symbol-name slot) 0) ?-)
(eq slot 'parent-instance)
(eq slot 'name))
(intern (concat ":" (symbol-name slot)))))
slots)))
(defclass pm-root (eieio-instance-inheritor)
((name
:initarg :name
:initform "UNNAMED"
:type string
:custom string
:documentation
"Name of the object used to for display and info.")
(-id
:initform 0
:type number
:documentation
"[Internal] Numeric id to track objects. Every object has an id.")
(-props
:initform '()
:type list
:documentation
"[Internal] Plist used to store various extra metadata such as user history.
Use `pm--prop-get' and `pm--prop-put' to place key value pairs
into this list."))
"Root polymode class.")
(cl-defmethod eieio-object-name-string ((obj pm-root))
(eieio-oref obj 'name))
(cl-defmethod clone ((obj pm-root) &rest params)
(let ((old-name (eieio-oref obj 'name))
(new-obj (apply #'cl-call-next-method obj params)))
(when (equal old-name (eieio-oref new-obj 'name))
(let ((new-name (concat old-name ":")))
(eieio-oset new-obj 'name new-name)))
new-obj))
(defclass pm-polymode (pm-root)
((hostmode
:initarg :hostmode
:initform nil
:type symbol
:custom symbol
:documentation
"Symbol pointing to a `pm-host-chunkmode' object.
When nil, any host-mode will be matched (suitable for
poly-minor-modes. ")
(innermodes
:initarg :innermodes
:type list
:initform nil
:custom (repeat symbol)
:documentation
"List of inner-mode names (symbols) associated with this polymode.")
(exporters
:initarg :exporters
:initform '(pm-exporter/pandoc)
:custom (repeat symbol)
:documentation
"List of names of polymode exporters available for this polymode.")
(exporter
:initarg :exporter
:initform nil
:type symbol
:custom symbol
:documentation
"Current exporter name.
If non-nil should be the name of the default exporter for this
polymode. Can be set with `polymode-set-exporter' command.")
(weavers
:initarg :weavers
:initform '()
:type list
:custom (repeat symbol)
:documentation
"List of names of polymode weavers available for this polymode.")
(weaver
:initarg :weaver
:initform nil
:type symbol
:custom symbol
:documentation
"Current weaver name.
If non-nil this is the default weaver for this polymode. Can be
dynamically set with `polymode-set-weaver'")
(switch-buffer-functions
:initarg :switch-buffer-functions
:initform '()
:type list
:custom (repeat symbol)
:documentation
"List of functions to run at polymode buffer switch.
Each function is run with two arguments, OLD-BUFFER and
NEW-BUFFER.")
(keylist
:initarg :keylist
:initform 'polymode-minor-mode-map
:type (or symbol list)
:custom (choice (symbol :tag "Keymap")
(repeat (cons string symbol)))
:documentation
"A list of elements of the form (KEY . BINDING).
This slot is reserved for building hierarchies through cloning
and should not be used in `define-polymode'.")
(-minor-mode
:initform 'polymode-minor-mode
:type symbol
:documentation
"[Internal] Symbol pointing to minor-mode function.")
(-hostmode
:type (or null pm-chunkmode)
:documentation
"[Dynamic] Dynamically populated `pm-chunkmode' object.")
(-innermodes
:type list
:initform '()
:documentation
"[Dynamic] List of chunkmodes objects.")
(-auto-innermodes
:type list
:initform '()
:documentation
"[Dynamic] List of auto chunkmodes.")
(-buffers
:initform '()
:type list
:documentation
"[Dynamic] Holds all buffers associated with current buffer."))
"Polymode Configuration object.
Each polymode buffer holds a local variable `pm/polymode'
instantiated from this class or a subclass of this class.")
(defvar pm--polymode-slots
(mapcar #'cl--slot-descriptor-name
(eieio-class-slots 'pm-polymode)))
(defclass pm-chunkmode (pm-root)
((mode
:initarg :mode
:initform nil
:type symbol
:custom symbol
:documentation
"Emacs major mode for the chunk's body.
When nil the value of `polymode-default-inner-mode' is used when set;
otherwise `poly-fallback-mode' is used. A special value 'host
means to use the host mode as a fallback in the body of this
chunk.")
(indent-offset
:initarg :indent-offset
:initform 0
:type integer
:custom integer
:documentation
"Offset to add when indenting chunk's line.
Takes effect only when :protect-indent is non-nil.")
(protect-indent
:initarg :protect-indent
:initform nil
:type boolean
:custom boolean
:documentation
"Whether to narrowing to current span before indent.")
(protect-font-lock
:initarg :protect-font-lock
:initform nil
:type boolean
:custom boolean
:documentation
"Whether to narrow to span during font lock.")
(protect-syntax
:initarg :protect-syntax
:initform nil
:type boolean
:custom boolean
:documentation
"Whether to narrow to span when calling `syntax-propertize-function'.")
(adjust-face
:initarg :adjust-face
:initform '()
:type (or number face list)
:custom (choice number face sexp)
:documentation
"Fontification adjustment for the body of the chunk.
It should be either, nil, number, face or a list of text
properties as in `put-text-property' specification. If nil no
highlighting occurs. If a face, use that face. If a number, it is
a percentage by which to lighten/darken the default chunk
background. If positive - lighten the background on dark themes
and darken on light thems. If negative - darken in dark thems and
lighten in light thems.")
(init-functions
:initarg :init-functions
:initform '()
:type list
:custom hook
:documentation
"List of functions called after the initialization.
Functions are called with one argument TYPE in the buffer
associated with this chunkmode's span. TYPE is either 'host,
'head, 'body or 'tail. All init-functions in the inheritance
chain are called in parent-first order. Either customize this
slot or use `object-add-to-list' function.")
(switch-buffer-functions
:initarg :switch-buffer-functions
:initform '()
:type list
:custom hook
:documentation
"List of functions to run at polymode buffer switch.
Each function is run with two arguments, OLD-BUFFER and
NEW-BUFFER. In contrast to identically named slot in
`pm-polymode' class, these functions are run only when NEW-BUFFER
is of this chunkmode.")
(-buffer
:type (or null buffer)
:initform nil))
"Generic chunkmode object.
Please note that by default :protect-xyz slots are nil in
hostmodes and t in innermodes.")
(defclass pm-host-chunkmode (pm-chunkmode)
()
"This chunkmode doesn't know how to compute spans and takes
over all the other space not claimed by other chunkmodes in the
buffer.")
(defclass pm-inner-chunkmode (pm-chunkmode)
((protect-font-lock
:initform t)
(protect-syntax
:initform t)
(protect-indent
:initform t)
(can-nest
:initarg :can-nest
:initform nil
:type boolean
:custom boolean
:documentation
"Non-nil if this chunk can nest within other inner modes.
All chunks can nest within the host-mode.")
(can-overlap
:initarg :can-overlap
:initform nil
:type boolean
:custom boolean
:documentation
"Non-nil if chunks of this type can overlap with other chunks of the same type.
See noweb for an example.")
(head-mode
:initarg :head-mode
:initform 'poly-head-tail-mode
:type symbol
:custom symbol
:documentation
"Chunk's head mode.
If set to 'host or 'body use host or body's mode respectively.")
(tail-mode
:initarg :tail-mode
:initform nil
:type symbol
:custom (choice (const nil :tag "From Head")
function)
:documentation
"Chunk's tail mode.
If set to 'host or 'body use host or body's mode respectively. If
nil, pick the mode from :head-mode slot.")
(head-matcher
:initarg :head-matcher
:type (or string cons function)
:custom (choice string (cons string integer) function)
:documentation
"A regexp, a cons (REGEXP . SUB-MATCH) or a function.
When a function, the matcher must accept one argument that can
take either values 1 (forwards search) or -1 (backward search).
This function must return either nil (no match) or a (cons BEG
END) representing the span of the head or tail respectively. See
the code of `pm-fun-matcher' for a simple example.")
(tail-matcher
:initarg :tail-matcher
:type (or string cons function)
:custom (choice string (cons string integer) function)
:documentation
"A regexp, a cons (REGEXP . SUB-MATCH) or a function.
Like :head-matcher but for the chunk's tail. Currently, it is
always called with the point at the end of the matched head and
with the positive argument (aka match forward).")
(adjust-face
:initform 2)
(head-adjust-face
:initarg :head-adjust-face
:initform 'bold
:type (or number face list)
:custom (choice number face sexp)
:documentation
"Head's face adjustment.
Can be a number, a list of properties or a face.")
(tail-adjust-face
:initarg :tail-adjust-face
:initform nil
:type (or null number face list)
:custom (choice (const :tag "From Head" nil)
number face sexp)
:documentation
"Tail's face adjustment.
A number, a list of properties, a face or nil. When nil, take the
configuration from :head-adjust-face.")
(-head-buffer
:type (or null buffer)
:initform nil
:documentation
"[Internal] This buffer is set automatically to -buffer if
:head-mode is 'body, and to base-buffer if :head-mode is 'host.")
(-tail-buffer
:initform nil
:type (or null buffer)
:documentation
"[Internal] Same as -head-buffer, but for tail span."))
"Inner-chunkmodes represent innermodes (or sub-modes) within a
buffer. Chunks are commonly delimited by head and tail markup but
can be delimited by some other logic (e.g. indentation). In the
latter case, heads or tails have zero length and are not
physically present in the buffer.")
(defclass pm-inner-auto-chunkmode (pm-inner-chunkmode)
((mode-matcher
:initarg :mode-matcher
:type (or string cons function)
:custom (choice string (cons string integer) function)
:documentation
"Matcher used to retrieve the mode's symbol from the chunk's head.
Can be either a regexp string, cons of the form (REGEXP .
SUBEXPR) or a function to be called with no arguments. If a
function, it must return a string name of the mode. Function is
called at the beginning of the head span."))
"Inner chunkmodes with unknown (at definition time) mode of the
body span. The body mode is determined dynamically by retrieving
the name with the :mode-matcher.")
(setq eieio-backward-compatibility t)
(provide 'polymode-classes)
;;; polymode-classes.el ends here

251
elpa/polymode-20180926.2044/polymode-compat.el Normal file
View File

@@ -0,0 +1,251 @@
;;; polymode-compat.el --- Various compatibility fixes for other packages -*- lexical-binding: t -*-
;;
;; Author: Vitalie Spinu
;; Maintainer: Vitalie Spinu
;; Copyright (C) 2013-2018, Vitalie Spinu
;; Version: 0.1
;; URL: https://github.com/vitoshka/polymode
;; Keywords: emacs
;;
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; This file is *NOT* part of GNU Emacs.
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 3, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with 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 'polymode-core)
(require 'advice nil t)
(defgroup polymode-compat nil
"Polymode compatibility settings."
:group 'polymode)
;;; Various Wrappers for Around Advice
(defvar *span* nil)
;; advice doesn't provide named symbols. So we need to define specialized
;; wrappers for some key functions (unfinished)
(defmacro pm-define-wrapp-protected (fun)
"Declare protected function with the name fun--pm-wrapped.
Return new name (symbol). FUN is an unquoted name of a function."
(let* ((fun-name (symbol-name fun))
(new-fun (intern (format "%s--pm-wrapped" fun-name)))
(new-doc (format " Error Protected function created with `pm-define-protected-wrapp'.\n\n%s"
(or (documentation fun) ""))))
`(progn
(defun ,new-fun (&rest args)
,new-doc
(condition-case err
(apply ',fun args)
(error (message "(%s %s): %s"
,fun-name
(mapconcat (lambda (x) (format "%s" x)) args " ")
(error-message-string err)))))
',new-fun)))
(defun pm-apply-protected (fun args)
(when fun
(condition-case-unless-debug err
(apply fun args)
(error (message "(%s %s): %s %s"
(if (symbolp fun)
(symbol-name fun)
"anonymous")
(mapconcat (lambda (x) (format "%s" x)) args " ")
(error-message-string err)
;; (or (and (symbolp fun) "")
;; (replace-regexp-in-string "\n" "" (format "[%s]" fun)))
"[M-x pm-debug-mode RET for more info]")
nil))))
(defun pm-override-output-position (orig-fun &rest args)
"Restrict returned value of ORIG-FUN to fall into the current span.
*span* in `pm-map-over-spans` has precedence over span at point.
ARGS are passed to ORIG-FUN."
(if (and polymode-mode pm/polymode)
(let ((range (or (pm-span-to-range *span*)
(pm-innermost-range)))
(pos (pm-apply-protected orig-fun args)))
(and pos
(min (max pos (car range))
(cdr range))))
(apply orig-fun args)))
(defun pm-override-output-cons (orig-fun &rest args)
"Restrict returned (beg . end) of ORIG-FUN to fall into the current span.
*span* in `pm-map-over-spans` has precedence over span at point.
This will break badly if (point) is not inside expected range.
ARGS are passed to ORIG-FUN."
(if (and polymode-mode pm/polymode)
(let ((range (or (pm-span-to-range *span*)
(pm-innermost-range)))
(be (pm-apply-protected orig-fun args)))
(let ((out (and be
(cons (and (car be)
(min (max (car be) (car range))
(cdr range)))
(and (cdr be)
(max (min (cdr be) (cdr range))
(car range)))))))
out))
(apply orig-fun args)))
(defun pm-narrowed-override-output-cons (orig-fun &rest args)
"Restrict returned (beg . end) of ORIG-FUN to fall into the current span.
Run ORIG-FUN with buffer narrowed to span. *span* in
`pm-map-over-spans` has precedence over span at point. ARGS are
passed to ORIG-FUN."
(if (and polymode-mode pm/polymode)
(let ((*span* (or *span* (pm-innermost-span))))
(pm-with-narrowed-to-span *span*
(apply #'pm-override-output-cons orig-fun args)))
(apply orig-fun args)))
(defun pm-substitute-beg-end (orig-fun beg end &rest args)
"Execute ORIG-FUN with first BEG and END arguments limited to current span.
*span* in `pm-map-over-spans` has precedence over span at point.
ARGS are passed to ORIG-FUN."
(if (and polymode-mode pm/polymode)
(let* ((pos (if (and (<= (point) end) (>= (point) beg))
(point)
end))
(range (or (pm-span-to-range *span*)
(pm-innermost-range pos)))
(new-beg (max beg (car range)))
(new-end (min end (cdr range))))
(pm-apply-protected orig-fun (append (list new-beg new-end) args)))
(apply orig-fun beg end args)))
(defun pm-execute-narrowed-to-span (orig-fun &rest args)
"Execute ORIG-FUN narrowed to the current span.
*span* in `pm-map-over-spans` has precedence over span at point.
ARGS are passed to ORIG-FUN."
(if (and polymode-mode pm/polymode)
(pm-with-narrowed-to-span *span*
(pm-apply-protected orig-fun args))
(apply orig-fun args)))
;;; Flyspel
(defun pm--flyspel-dont-highlight-in-chunkmodes (beg end _poss)
(or (car (get-text-property beg :pm-span))
(car (get-text-property end :pm-span))))
;;; C/C++/Java
(pm-around-advice 'c-before-context-fl-expand-region #'pm-override-output-cons)
;; (advice-remove 'c-before-context-fl-expand-region #'pm-override-output-cons)
(pm-around-advice 'c-state-semi-safe-place #'pm-override-output-position)
;; (advice-remove 'c-state-semi-safe-place #'pm-override-output-position)
;; c-font-lock-fontify-region calls it directly
;; (pm-around-advice 'font-lock-default-fontify-region #'pm-substitute-beg-end)
(pm-around-advice 'c-determine-limit #'pm-execute-narrowed-to-span)
;;; Python
(declare-function pm--first-line-indent "polymode-methods")
(defun pm--python-dont-indent-to-0 (fun)
"Fix indent FUN not to cycle to 0 indentation."
(if (and polymode-mode pm/type)
(let ((last-command (unless (eq (pm--first-line-indent) (current-indentation))
last-command)))
(funcall fun))
(funcall fun)))
(pm-around-advice 'python-indent-line-function #'pm--python-dont-indent-to-0)
;;; Core Font Lock
(defvar font-lock-beg)
(defvar font-lock-end)
(defun pm-check-for-real-change-in-extend-multiline (fun)
"Protect FUN from inf-looping at ‘point-max’.
FUN is `font-lock-extend-region-multiline'. Propagate only real
changes."
;; fixme: report this ASAP!
(let ((obeg font-lock-beg)
(oend font-lock-end)
(change (funcall fun)))
(and change
(not (eq obeg font-lock-beg))
(not (eq oend font-lock-end)))))
(pm-around-advice 'font-lock-extend-region-multiline #'pm-check-for-real-change-in-extend-multiline)
;;; Editing
(pm-around-advice 'fill-paragraph #'pm-execute-narrowed-to-span)
;; (defun polymode-with-save-excursion (orig-fun &rest args)
;; "Execute ORIG-FUN surrounded with `save-excursion'.
;; This function is intended to be used in advises of functions
;; which modify the buffer in the background and thus trigger
;; `pm-switch-to-buffer' on next post-command hook in a wrong place.
;; ARGS are passed to ORIG-FUN."
;; (if polymode-mode
;; (save-excursion
;; (apply orig-fun args))
;; (apply orig-fun args)))
;; We are synchronizing point in pre-command-hook so the following hack is no
;; longer needed. Leaving here as a reference for the time being.
;;
;; `save-buffer` misbehaves because after each replacement modification hooks
;; are triggered and poly buffer is switched in unpredictable fashion (#93).
;; This happens because basic-save-buffer uses save-buffer but not
;; save-excursion. Thus if base and indirect buffer don't have same point, at
;; the end of the function inner buffer will have the point from the base
;; buffer. Can be reproduced with (add-hook 'before-save-hook
;; 'delete-trailing-whitespace nil t) in the base buffer.
;;
;; (pm-around-advice 'basic-save-buffer #'polymode-with-save-excursion)
;; (advice-remove 'basic-save-buffer #'polymode-with-save-excursion)
;; Query replace were probably misbehaving due to unsaved match data (#92). The
;; following is probably not necessary. (pm-around-advice 'perform-replace
;; 'pm-execute-inhibit-modification-hooks)
;;; EVIL
(declare-function evil-change-state "evil-core")
(defun polymode-switch-buffer-keep-evil-state-maybe (old-buffer new-buffer)
(when (and (boundp 'evil-state)
evil-state)
(let ((old-state (buffer-local-value 'evil-state old-buffer))
(new-state (buffer-local-value 'evil-state new-buffer)))
(unless (eq old-state new-state)
(with-current-buffer new-buffer
(evil-change-state old-state))))))
(eval-after-load 'evil-core
'(add-hook 'polymode-switch-buffer-hook 'polymode-switch-buffer-keep-evil-state-maybe))
(provide 'polymode-compat)
;;; polymode-compat.el ends here

1477
elpa/polymode-20180926.2044/polymode-core.el Normal file
View File

File diff suppressed because it is too large Load Diff

457
elpa/polymode-20180926.2044/polymode-debug.el Normal file
View File

@@ -0,0 +1,457 @@
;;; polymode-debug.el --- Interactive debugging utilities for polymode -*- lexical-binding: t -*-
;;
;; Copyright (C) 2016-2018 Vitalie Spinu
;; Author: Vitalie Spinu
;; URL: https://github.com/vspinu/polymode
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; This file is *NOT* part of GNU Emacs.
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 3, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with 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 'polymode-core)
(require 'poly-lock)
(require 'trace)
;;; MINOR MODE
(defvar pm--underline-overlay
(let ((overlay (make-overlay (point) (point))))
(overlay-put overlay 'face '(:underline (:color "tomato" :style wave)))
overlay)
"Overlay used in function `pm-debug-mode'.")
(defvar pm--highlight-overlay
(let ((overlay (make-overlay (point) (point))))
(overlay-put overlay 'face '(:inverse-video t))
overlay)
"Overlay used by `pm-debug-map-over-spans-and-highlight'.")
(defvar pm-debug-minor-mode-map
(let ((map (make-sparse-keymap)))
(define-key map (kbd "M-n M-i") #'pm-debug-info-on-current-span)
(define-key map (kbd "M-n i") #'pm-debug-info-on-current-span)
(define-key map (kbd "M-n M-p") #'pm-debug-print-relevant-variables)
(define-key map (kbd "M-n p") #'pm-debug-print-relevant-variables)
(define-key map (kbd "M-n M-h") #'pm-debug-map-over-spans-and-highlight)
(define-key map (kbd "M-n h") #'pm-debug-map-over-spans-and-highlight)
(define-key map (kbd "M-n M-t t") #'pm-toggle-tracing)
(define-key map (kbd "M-n M-t i") #'pm-debug-toogle-info-message)
(define-key map (kbd "M-n M-t f") #'pm-debug-toggle-fontification)
(define-key map (kbd "M-n M-t p") #'pm-debug-toggle-post-command)
(define-key map (kbd "M-n M-t c") #'pm-debug-toggle-after-change)
(define-key map (kbd "M-n M-t a") #'pm-debug-toggle-all)
(define-key map (kbd "M-n M-t M-t") #'pm-toggle-tracing)
(define-key map (kbd "M-n M-t M-i") #'pm-debug-toogle-info-message)
(define-key map (kbd "M-n M-t M-f") #'pm-debug-toggle-fontification)
(define-key map (kbd "M-n M-t M-p") #'pm-debug-toggle-post-command)
(define-key map (kbd "M-n M-t M-c") #'pm-debug-toggle-after-change)
(define-key map (kbd "M-n M-t M-a") #'pm-debug-toggle-all)
(define-key map (kbd "M-n M-f s") #'pm-debug-fontify-current-span)
(define-key map (kbd "M-n M-f b") #'pm-debug-fontify-current-buffer)
(define-key map (kbd "M-n M-f M-t") #'pm-debug-toggle-fontification)
(define-key map (kbd "M-n M-f M-s") #'pm-debug-fontify-current-span)
(define-key map (kbd "M-n M-f M-b") #'pm-debug-fontify-current-buffer)
map))
;;;###autoload
(define-minor-mode pm-debug-minor-mode
"Turns on/off useful facilities for debugging polymode.
Key bindings:
\\{pm-debug-minor-mode-map}"
nil
" PMDBG"
:group 'polymode
(if pm-debug-minor-mode
(progn
;; this is global hook. No need to complicate with local hooks
(add-hook 'post-command-hook 'pm-debug-highlight-current-span))
(delete-overlay pm--underline-overlay)
(delete-overlay pm--highlight-overlay)
(remove-hook 'post-command-hook 'pm-debug-highlight-current-span)))
;;;###autoload
(defun pm-debug-minor-mode-on ()
;; activating everywhere (in case font-lock infloops in a polymode buffer )
;; this doesn't activate in fundamental mode
(unless (eq major-mode 'minibuffer-inactive-mode)
(pm-debug-minor-mode t)))
;;;###autoload
(define-globalized-minor-mode pm-debug-mode pm-debug-minor-mode pm-debug-minor-mode-on)
;;; INFO
(cl-defgeneric pm-debug-info (chunkmode))
(cl-defmethod pm-debug-info (chunkmode)
(eieio-object-name chunkmode))
(cl-defmethod pm-debug-info ((chunkmode pm-inner-chunkmode))
(format "%s head-matcher:\"%s\" tail-matcher:\"%s\""
(cl-call-next-method)
(eieio-oref chunkmode 'head-matcher)
(eieio-oref chunkmode 'tail-matcher)))
(cl-defmethod pm-debug-info ((_chunkmode pm-inner-auto-chunkmode))
(cl-call-next-method))
(defvar syntax-ppss-wide)
(defvar syntax-ppss-last)
(defun pm--debug-info (&optional span as-list)
(let* ((span (or span (and polymode-mode (pm-innermost-span))))
(message-log-max nil)
(beg (nth 1 span))
(end (nth 2 span))
(obj (nth 3 span))
(type (and span (or (car span) 'host))))
(let ((out (list (current-buffer)
(point-min) (point) (point-max)
major-mode
type beg end
(and obj (pm-debug-info obj))
(format "lppss:%s"
(if pm--emacs>26
(car syntax-ppss-wide)
syntax-ppss-last)))))
(if as-list
out
(apply #'format
"(%s) min:%d pos:%d max:%d || (%s) type:%s span:%s-%s %s %s"
out)))))
(defun pm-debug-info-on-current-span (no-cache)
"Show info on current span.
With NO-CACHE prefix, don't use cached values of the span."
(interactive "P")
(if (not polymode-mode)
(message "not in a polymode buffer")
(let ((span (pm-innermost-span nil no-cache)))
(message (pm--debug-info span))
;; (move-overlay pm--highlight-overlay (nth 1 span) (nth 2 span) (current-buffer))
(pm-debug-flick-region (nth 1 span) (nth 2 span)))))
;;; TOGGLING
(defvar pm-debug-display-info-message nil)
(defun pm-debug-toogle-info-message ()
"Toggle permanent info display."
(interactive)
(setq pm-debug-display-info-message (not pm-debug-display-info-message)))
(defvar poly-lock-allow-fontification)
(defun pm-debug-toggle-fontification ()
"Enable or disable fontification in polymode buffers."
(interactive)
(if poly-lock-allow-fontification
(progn
(message "fontificaiton disabled")
(setq poly-lock-allow-fontification nil
font-lock-mode nil))
(message "fontificaiton enabled")
(setq poly-lock-allow-fontification t
font-lock-mode t)))
(defun pm-debug-toggle-after-change ()
"Allow or disallow polymode actions in `after-change-functions'."
(interactive)
(if pm-allow-after-change-hook
(progn
(message "after-change disabled")
(setq pm-allow-after-change-hook nil))
(message "after-change enabled")
(setq pm-allow-after-change-hook t)))
(defun pm-debug-toggle-post-command ()
"Allow or disallow polymode actions in `post-command-hook'."
(interactive)
(if pm-allow-post-command-hook
(progn
(message "post-command disabled")
(setq pm-allow-post-command-hook nil))
(message "post-command enabled")
(setq pm-allow-post-command-hook t)))
(defun pm-debug-toggle-all ()
"Toggle all polymode guards back and forth."
(interactive)
(if poly-lock-allow-fontification
(progn
(message "fontificaiton, after-chnage and command-hook disabled")
(setq poly-lock-allow-fontification nil
pm-allow-after-change-hook nil
pm-allow-post-command-hook nil))
(message "fontificaiton, after-change and command-hook enabled")
(setq poly-lock-allow-fontification t
pm-allow-after-change-hook t
pm-allow-post-command-hook t)))
;;; FONT-LOCK
(defun pm-debug-fontify-current-span ()
"Fontify current span."
(interactive)
(let ((span (pm-innermost-span))
(poly-lock-allow-fontification t))
(poly-lock-flush (nth 1 span) (nth 2 span))
(poly-lock-fontify-now (nth 1 span) (nth 2 span))))
(defun pm-debug-fontify-current-buffer ()
"Fontify current buffer."
(interactive)
(let ((poly-lock-allow-fontification t))
(poly-lock-flush (point-min) (point-max))
(poly-lock-fontify-now (point-min) (point-max))))
;;; TRACING
(defvar pm-traced-functions
'(
;; core initialization
(0 (pm-initialize
pm--common-setup
pm--mode-setup))
;; core hooks
(1 (polymode-post-command-select-buffer
polymode-before-change-setup
polymode-after-kill-fixes))
;; advises
(2 (pm-override-output-cons
pm-around-advice
polymode-with-current-base-buffer))
;; font-lock
(3 (poly-lock-function
poly-lock-fontify-now
poly-lock-flush
jit-lock-fontify-now
poly-lock-after-change
poly-lock--extend-region-span
poly-lock--extend-region
poly-lock-adjust-span-face))
;; syntax
(4 (pm--call-syntax-propertize-original
polymode-syntax-propertize
polymode-restrict-syntax-propertize-extension
pm--reset-ppss-last))))
(defvar pm--do-trace nil)
;;;###autoload
(defun pm-toggle-tracing (level)
"Toggle polymode tracing.
With numeric prefix toggle tracing for that LEVEL. Currently
universal argument toggles maximum level of tracing (4). Default
level is 3."
(interactive "P")
(setq level (prefix-numeric-value (or level 3)))
(setq pm--do-trace (not pm--do-trace))
(if pm--do-trace
(progn (dolist (kv pm-traced-functions)
(when (<= (car kv) level)
(dolist (fn (cadr kv))
(pm-trace fn))))
(message "Polymode tracing activated"))
(untrace-all)
(message "Polymode tracing deactivated")))
;;;###autoload
(defun pm-trace (fn)
"Trace function FN.
Use `untrace-function' to untrace or `untrace-all' to untrace all
currently traced functions."
(interactive (trace--read-args "Trace: "))
(let ((buff (get-buffer "*Messages*")))
(advice-add
fn :around
(let ((advice (trace-make-advice
fn buff 'background #'pm-trace--tracing-context)))
(lambda (body &rest args)
(when (eq fn 'polymode-before-change-setup)
(with-current-buffer buff
(save-excursion
(goto-char (point-max))
(insert "\n"))))
(if polymode-mode
(apply advice body args)
(apply body args))))
`((name . ,trace-advice-name) (depth . -100)))))
(defun pm-trace-functions-by-regexp (regexp)
"Trace all functions whose name matched REGEXP."
(interactive "sRegex: ")
(cl-loop for sym being the symbols
when (and (fboundp sym)
(not (eq sym 'pm-trace)))
when (string-match regexp (symbol-name sym))
do (pm-trace sym)))
(defun pm-trace--tracing-context ()
(let ((span (or *span*
(get-text-property (point) :pm-span))))
(format " [%s pos:%d(%d-%d) %s%s (%f)]"
(current-buffer) (point) (point-min) (point-max)
(or (when span
(when (not (and (= (point-min) (nth 1 span))
(= (point-max) (nth 2 span))))
"UNPR "))
"")
(when span
(pm-format-span span))
(float-time))))
;; fix object printing
(defun pm-trace--fix-1-arg-for-tracing (arg)
(cond
((eieio-object-p arg) (eieio-object-name arg))
((and (listp arg) (eieio-object-p (nth 3 arg)))
(list (nth 0 arg) (nth 1 arg) (nth 2 arg) (eieio-object-name (nth 3 arg))))
(arg)))
(defun pm-trace--fix-args-for-tracing (orig-fn fn level args context)
(let ((args (or (and (listp args)
(listp (cdr args))
(ignore-errors (mapcar #'pm-trace--fix-1-arg-for-tracing args)))
args)))
(funcall orig-fn fn level args context)))
(advice-add #'trace-entry-message :around #'pm-trace--fix-args-for-tracing)
(advice-add #'trace-exit-message :around #'pm-trace--fix-args-for-tracing)
;; (advice-remove #'trace-entry-message #'pm-trace--fix-args-for-tracing)
;; (advice-remove #'trace-exit-message #'pm-trace--fix-args-for-tracing)
;;; RELEVANT VARIABLES
(defvar pm-debug-relevant-variables
'(
:change (before-change-functions
after-change-functions)
:command (pre-command-hook
post-command-hook)
:font-lock (fontification-functions
font-lock-function
font-lock-flush-function
font-lock-ensure-function
font-lock-fontify-region-function
font-lock-fontify-buffer-function
font-lock-unfontify-region-function
font-lock-unfontify-buffer-function
jit-lock-after-change-extend-region-functions
jit-lock-functions)
:indent (indent-line-function
indent-region-function
pm--indent-line-function-original)
:revert (revert-buffer-function
before-revert-hook
after-revert-hook)
:save (after-save-hook
before-save-hook)
:syntax (syntax-propertize-function
syntax-propertize-extend-region-functions
pm--syntax-propertize-function-original)
))
(defun pm-debug-print-relevant-variables ()
"Print values of relevant hooks and other variables."
(interactive)
(let* ((buff (get-buffer-create "*polymode-vars*"))
(cbuff (current-buffer))
(vars (cl-loop for v on pm-debug-relevant-variables by #'cddr
collect (cons (car v)
(mapcar (lambda (v)
(cons v (buffer-local-value v cbuff)))
(cadr v)))))
(cbuff (current-buffer)))
(require 'pp)
(with-current-buffer buff
(erase-buffer)
(goto-char (point-max))
(insert (format "\n================== %s ===================\n" cbuff))
(insert (pp-to-string vars))
(toggle-truncate-lines -1)
(goto-char (point-max)))
(display-buffer buff)))
;;; HIGHLIGHT
(defun pm-debug-highlight-current-span ()
(when polymode-mode
(with-silent-modifications
(unless (memq this-command '(pm-debug-info-on-current-span
pm-debug-highlight-last-font-lock-error-region))
(delete-overlay pm--highlight-overlay))
(condition-case-unless-debug err
(let ((span (pm-innermost-span)))
(when pm-debug-display-info-message
(message (pm--debug-info span)))
(move-overlay pm--underline-overlay (nth 1 span) (nth 2 span) (current-buffer)))
(error (message "%s" (error-message-string err)))))))
(defun pm-debug-flick-region (start end &optional delay)
(move-overlay pm--highlight-overlay start end (current-buffer))
(run-with-timer (or delay 0.4) nil (lambda () (delete-overlay pm--highlight-overlay))))
(defun pm-debug-map-over-spans-and-highlight ()
"Map over all spans in the buffer and highlight briefly."
(interactive)
(pm-map-over-spans (lambda (span)
(let ((start (nth 1 span))
(end (nth 2 span)))
(pm-debug-flick-region start end)
(sit-for 1)))
(point-min) (point-max) nil nil t))
(defun pm-debug-run-over-check (no-cache)
"Map over all spans and report the time taken.
Switch to buffer is performed on every position in the buffer.
On prefix NO-CACHE don't use cached spans."
(interactive)
(goto-char (point-min))
(let ((start (current-time))
(count 1)
(pm-initialization-in-progress no-cache))
(pm-switch-to-buffer)
(while (< (point) (point-max))
(setq count (1+ count))
(forward-char)
(pm-switch-to-buffer))
(let ((elapsed (float-time (time-subtract (current-time) start))))
(message "Elapsed: %s per-char: %s" elapsed (/ elapsed count)))))
(defun pm-dbg (msg &rest args)
(let ((cbuf (current-buffer))
(cpos (point)))
(with-current-buffer (get-buffer-create "*pm-dbg*")
(save-excursion
(goto-char (point-max))
(insert "\n")
(insert (apply 'format (concat "%f [%s at %d]: " msg)
(float-time) cbuf cpos args))))))
(provide 'polymode-debug)
;;; polymode-debug.el ends here

425
elpa/polymode-20180926.2044/polymode-export.el Normal file
View File

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

477
elpa/polymode-20180926.2044/polymode-methods.el Normal file
View File

@@ -0,0 +1,477 @@
;;; polymode-methods.el --- Methods for polymode classes -*- 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 'polymode-core)
;;; INITIALIZATION
(cl-defgeneric pm-initialize (object)
"Initialize current buffer with OBJECT.")
(cl-defmethod pm-initialize ((config pm-polymode))
"Initialization of host buffers.
Ran by the polymode mode function."
;; Not calling config's '-minor-mode in hosts because this pm-initialize is
;; called from minor-mode itself.
(let* ((hostmode-name (eieio-oref config 'hostmode))
(hostmode (if hostmode-name
(clone (symbol-value hostmode-name))
(pm-host-chunkmode :name "ANY" :mode nil))))
(let ((pm-initialization-in-progress t)
;; Set if nil! This allows unspecified host chunkmodes to be used in
;; minor modes.
(host-mode (or (eieio-oref hostmode 'mode)
(oset hostmode :mode major-mode))))
;; host-mode hooks are run here, but polymode is not initialized
(pm--mode-setup host-mode)
(oset hostmode -buffer (current-buffer))
(oset config -hostmode hostmode)
(setq pm/polymode config
pm/chunkmode hostmode
pm/current t
pm/type nil)
(pm--common-setup)
;; Initialize innermodes
(oset config -innermodes
(mapcar (lambda (sub-name)
(clone (symbol-value sub-name)))
(eieio-oref config 'innermodes)))
;; FIXME: must go into polymode-compat.el
(add-hook 'flyspell-incorrect-hook
'pm--flyspel-dont-highlight-in-chunkmodes nil t))
(pm--run-init-hooks hostmode 'host 'polymode-init-host-hook)))
(cl-defmethod pm-initialize ((chunkmode pm-inner-chunkmode) &optional type mode)
"Initialization of chunkmode (indirect) buffers."
;; run in chunkmode indirect buffer
(setq mode (or mode (pm--get-innermode-mode chunkmode type)))
(let ((pm-initialization-in-progress t)
(new-name (generate-new-buffer-name
(format "%s[%s]" (buffer-name (pm-base-buffer))
(replace-regexp-in-string "poly-\\|-mode" ""
(symbol-name mode))))))
(rename-buffer new-name)
(pm--mode-setup mode)
(pm--move-vars '(pm/polymode buffer-file-coding-system) (pm-base-buffer))
;; fixme: This breaks if different chunkmodes use same-mode buffer. Even for
;; head/tail the value of pm/type will be wrong for tail
(setq pm/chunkmode chunkmode
pm/type (pm-true-span-type chunkmode type))
;; Call polymode mode for the sake of the keymap. Same minor mode which runs
;; in the host buffer but without all the heavy initialization.
(funcall (eieio-oref pm/polymode '-minor-mode))
;; FIXME: should not be here?
(vc-refresh-state)
(pm--common-setup))
(pm--run-init-hooks chunkmode type 'polymode-init-inner-hook))
(defvar poly-lock-allow-fontification)
(defun pm--mode-setup (mode &optional buffer)
;; General major-mode install. Should work for both indirect and base buffers.
;; PM objects are not yet initialized (pm/polymode, pm/chunkmode, pm/type)
(with-current-buffer (or buffer (current-buffer))
;; don't re-install if already there; polymodes can be used as minor modes.
(unless (eq major-mode mode)
(let ((polymode-mode t) ;major-modes might check this
(base (buffer-base-buffer))
;; (font-lock-fontified t)
;; Modes often call font-lock functions directly. We prevent that.
(font-lock-function 'ignore)
(font-lock-flush-function 'ignore)
(font-lock-fontify-buffer-function 'ignore)
;; Mode functions can do arbitrary things. We inhibt all PM hooks
;; because PM objects have not been setup yet.
(pm-allow-after-change-hook nil)
(poly-lock-allow-fontification nil))
;; run-mode-hooks needs buffer-file-name
(when base
(pm--move-vars pm-move-vars-from-base base (current-buffer)))
(condition-case-unless-debug err
(funcall mode)
(error (message "Polymode error (pm--mode-setup '%s): %s" mode (error-message-string err))))))
(setq polymode-mode t)
(current-buffer)))
(defvar syntax-ppss-wide)
(defun pm--common-setup (&optional buffer)
"Run common setup in BUFFER.
Runs after major mode and core polymode structures have been
initialized. Return the buffer."
(with-current-buffer (or buffer (current-buffer))
(object-add-to-list pm/polymode '-buffers (current-buffer))
;; INDENTATION
(setq-local pm--indent-line-function-original indent-line-function)
(setq-local indent-line-function #'pm-indent-line-dispatcher)
(setq-local pm--indent-region-function-original indent-region-function)
(setq-local indent-region-function #'pm-indent-region)
;; SYNTAX
;; Ideally this should be called in some hook to avoid minor-modes messing
;; it up Setting even if syntax-propertize-function is nil to have more
;; control over syntax-propertize--done.
(unless (eq syntax-propertize-function #'polymode-syntax-propertize)
(setq-local pm--syntax-propertize-function-original syntax-propertize-function)
(setq-local syntax-propertize-function #'polymode-syntax-propertize))
(with-no-warnings
;; [OBSOLETE as of 25.1 but we still protect it]
(pm-around-advice syntax-begin-function 'pm-override-output-position))
;; flush ppss in all buffers and hook checks
(add-hook 'before-change-functions 'polymode-before-change-setup t t)
(setq-local syntax-ppss-wide (cons nil nil))
;; HOOKS
(add-hook 'kill-buffer-hook #'polymode-after-kill-fixes nil t)
(add-hook 'post-command-hook #'polymode-post-command-select-buffer nil t)
(add-hook 'pre-command-hook #'polymode-pre-command-synchronize-state nil t)
;; FONT LOCK (see poly-lock.el)
(setq-local font-lock-function 'poly-lock-mode)
;; Font lock is initialized `after-change-major-mode-hook' by means of
;; `run-mode-hooks' and poly-lock won't get installed if polymode is
;; installed as minor mode or interactively. We add font/poly-lock in all
;; buffers because this is how inner buffers are installed.
;; `poly-lock-allow-fontification` is intended for buffers which don't want
;; font-lock.
(setq-local poly-lock-allow-fontification font-lock-mode)
(font-lock-mode t)
(font-lock-flush)
(current-buffer)))
;;; BUFFER CREATION
(cl-defgeneric pm-get-buffer-create (chunkmode &optional type)
"Get the indirect buffer associated with SUBMODE and SPAN-TYPE.
Create and initialize the buffer if does not exist yet.")
(cl-defmethod pm-get-buffer-create ((chunkmode pm-host-chunkmode) &optional type)
(when type
(error "Cannot create host buffer of type '%s'" type))
(let ((buff (eieio-oref chunkmode '-buffer)))
(if (buffer-live-p buff)
buff
(error "Cannot create host buffer for host chunkmode %s" (eieio-object-name chunkmode)))))
(cl-defmethod pm-get-buffer-create ((chunkmode pm-inner-chunkmode) &optional type)
(let ((buff (cl-case type
(body (eieio-oref chunkmode '-buffer))
(head (eieio-oref chunkmode '-head-buffer))
(tail (eieio-oref chunkmode '-tail-buffer))
(t (error "Don't know how to select buffer of type '%s' for chunkmode '%s'"
type (eieio-object-name chunkmode))))))
(if (buffer-live-p buff)
buff
(let ((new-buff (pm--get-innermode-buffer-create chunkmode type)))
(pm--set-innermode-buffer chunkmode type new-buff)))))
(defun pm--get-innermode-buffer-create (chunkmode type)
(let ((mode (pm--get-innermode-mode chunkmode type)))
(or
;; 1. look through existent buffer list
(cl-loop for bf in (eieio-oref pm/polymode '-buffers)
when (and (buffer-live-p bf)
(eq mode (buffer-local-value 'major-mode bf)))
return bf)
;; 2. create new
(with-current-buffer (pm-base-buffer)
(let* ((new-name (generate-new-buffer-name (buffer-name)))
(new-buffer (make-indirect-buffer (current-buffer) new-name)))
(with-current-buffer new-buffer
(pm-initialize chunkmode type mode))
new-buffer)))))
(defun pm--set-innermode-buffer (obj type buff)
"Assign BUFF to OBJ's slot(s) corresponding to TYPE."
(with-slots (-buffer head-mode -head-buffer tail-mode -tail-buffer) obj
(pcase (list type head-mode tail-mode)
(`(body body ,(or `nil `body))
(setq -buffer buff
-head-buffer buff
-tail-buffer buff))
(`(body ,_ body)
(setq -buffer buff
-tail-buffer buff))
(`(body ,_ ,_ )
(setq -buffer buff))
(`(head ,_ ,(or `nil `head))
(setq -head-buffer buff
-tail-buffer buff))
(`(head ,_ ,_)
(setq -head-buffer buff))
(`(tail ,_ ,(or `nil `head))
(setq -tail-buffer buff
-head-buffer buff))
(`(tail ,_ ,_)
(setq -tail-buffer buff))
(_ (error "Type must be one of 'body, 'head or 'tail")))))
;;; SPAN MANIPULATION
(cl-defgeneric pm-get-span (chunkmode &optional pos)
"Ask the CHUNKMODE for the span at point.
Return a list of three elements (TYPE BEG END OBJECT) where TYPE
is a symbol representing the type of the span surrounding
POS (head, tail, body). BEG and END are the coordinates of the
span. OBJECT is a suitable object which is 'responsible' for this
span. This is an object that could be dispatched upon with
`pm-select-buffer'. Should return nil if there is no SUBMODE
specific span around POS. Not to be used in programs directly;
use `pm-innermost-span'.")
(cl-defmethod pm-get-span (chunkmode &optional _pos)
"Return nil.
Base modes usually do not compute spans."
(unless chunkmode
(error "Dispatching `pm-get-span' on a nil object"))
nil)
(cl-defmethod pm-get-span ((chunkmode pm-inner-chunkmode) &optional pos)
"Return a list of the form (TYPE POS-START POS-END SELF).
TYPE can be 'body, 'head or 'tail. SELF is just a chunkmode object
in this case."
(with-slots (head-matcher tail-matcher head-mode tail-mode) chunkmode
(let ((span (pm--span-at-point head-matcher tail-matcher pos
(eieio-oref chunkmode 'can-overlap))))
(when span
(append span (list chunkmode))))))
(cl-defmethod pm-get-span ((_chunkmode pm-inner-auto-chunkmode) &optional _pos)
(let ((span (cl-call-next-method)))
(if (null (car span))
span
(pm--get-auto-span span))))
;; fixme: cache somehow?
(defun pm--get-auto-span (span)
(let* ((proto (nth 3 span))
(type (car span)))
(save-excursion
(goto-char (nth 1 span))
(unless (eq type 'head)
(goto-char (nth 2 span)) ; fixme: add multiline matchers to micro-optimize this
(let ((matcher (pm-fun-matcher (eieio-oref proto 'head-matcher))))
(goto-char (car (funcall matcher -1)))))
(let* ((str (let ((matcher (eieio-oref proto 'mode-matcher)))
(when (stringp matcher)
(setq matcher (cons matcher 0)))
(cond ((consp matcher)
(re-search-forward (car matcher) (point-at-eol) t)
(match-string-no-properties (cdr matcher)))
((functionp matcher)
(funcall matcher)))))
(mode (pm-get-mode-symbol-from-name str (eieio-oref proto 'mode))))
(if (eq mode 'host)
span
;; chunkname:MODE serves as ID (e.g. `markdown-fenced-code:emacs-lisp-mode`).
;; Head/tail/body indirect buffers are shared across chunkmodes and span
;; types.
(let* ((name (concat (pm-object-name proto) ":" (symbol-name mode)))
(outchunk (or
;; a. loop through installed inner modes
(cl-loop for obj in (eieio-oref pm/polymode '-auto-innermodes)
when (equal name (pm-object-name obj))
return obj)
;; b. create new
(let ((innermode (clone proto :name name :mode mode)))
(object-add-to-list pm/polymode '-auto-innermodes innermode)
innermode))))
(setf (nth 3 span) outchunk)
span))))))
;;; INDENT
(defun pm--indent-line-raw (span)
(let ((point (point)))
;; do fast synchronization here
(save-current-buffer
(pm-set-buffer span)
(pm-with-narrowed-to-span span
(goto-char point)
(when pm--indent-line-function-original
(funcall pm--indent-line-function-original))
(setq point (point))))
(goto-char point)))
(defun pm-indent-region (beg end)
"Indent region between BEG and END in polymode buffers.
Function used for `indent-region-function'."
;; (message "(pm-indent-region %d %d)" beg end)
;; cannot use pm-map-over-spans here because of the buffer modification
(let ((inhibit-point-motion-hooks t))
(save-excursion
(while (< beg end)
(let ((span (pm-innermost-span beg)))
(let ((end1 (copy-marker (min (nth 2 span) end))))
(goto-char beg)
(while (and (not (eobp))
(< (point-at-bol) end1))
(pm-indent-line (nth 3 span) span)
(forward-line 1))
(setq beg (point))))))))
(defun pm-indent-line-dispatcher (&optional span)
"Dispatch `pm-indent-line' methods on current SPAN.
Value of `indent-line-function' in polymode buffers."
(let ((span (or span (pm-innermost-span)))
(inhibit-read-only t))
(pm-indent-line (nth 3 span) span)
;; pm-indent-line-dispatcher is intended for interactive use
(pm-switch-to-buffer)))
(cl-defgeneric pm-indent-line (chunkmode &optional span)
"Indent current line.
Protect and call original indentation function associated with
the chunkmode.")
(cl-defmethod pm-indent-line ((chunkmode pm-chunkmode) span)
(let ((bol (point-at-bol))
(span (or span (pm-innermost-span))))
(if (or (< (nth 1 span) bol)
(= bol (point-min))
(null (eieio-oref chunkmode 'protect-indent)))
(pm--indent-line-raw span)
;; first line dispatch to previous span
(let ((delta (- (point) (nth 1 span)))
(prev-span (pm-innermost-span (1- bol))))
(goto-char bol)
(pm-indent-line-dispatcher prev-span)
(goto-char (+ (point) delta))))))
(cl-defmethod pm-indent-line ((chunkmode pm-inner-chunkmode) span)
"Indent line in inner chunkmodes.
When point is at the beginning of head or tail, use parent chunk
to indent."
(let ((pos (point))
(delta nil))
(unwind-protect
(cond
;; 1. in head or tail (we assume head or tail fits in one line for now)
((or (eq 'head (car span))
(eq 'tail (car span)))
(goto-char (nth 1 span))
(when (not (bobp))
(let* ((ind-point (save-excursion (back-to-indentation) (point)))
(ind-span (pm-innermost-span ind-point)))
;; ind-point need not be in prev-span; there might be other spans in between
(if (eq (nth 3 span) (nth 3 ind-span))
(let ((prev-span (pm-innermost-span (1- (nth 1 span)))))
(if (eq 'tail (car span))
(indent-to (pm--head-indent prev-span))
(pm--indent-line-raw prev-span)))
;; fixme: if ind-span is again tail or head?
(pm--indent-line-raw ind-span)))))
;; 2. body
(t
(back-to-indentation)
(if (< (point) (nth 1 span))
;; first body line in the same line with header (re-indent at indentation)
(pm-indent-line-dispatcher)
(setq delta (- pos (save-excursion (back-to-indentation) (point))))
(let ((fl-indent (pm--first-line-indent span)))
(if fl-indent
;; We are not on the 1st line
(progn
;; thus indent according to mode
(pm--indent-line-raw span)
(when (bolp)
;; When original mode's indented to bol, match with the
;; first line indent. Otherwise it's a continuation
;; indentation and we assume the original function did it
;; correctly with respect to previous lines.
(indent-to fl-indent)))
;; On the first line. Indent with respect to header line.
(indent-line-to
(+ ;; (- (point) (point-at-bol)) ;; non-0 if there is code in header line (ignore this case)
(pm--head-indent span) ;; indent with respect to header line
(eieio-oref chunkmode 'indent-offset))))))))
;; keep point on same characters
(when (and delta (> delta 0))
(goto-char (+ (point) delta))))))
(defun pm--first-line-indent (&optional span)
(save-excursion
(let ((pos (point)))
(goto-char (nth 1 (or span (pm-innermost-span))))
;; when body starts at bol move to previous line
(when (and (= (point) (point-at-bol))
(not (bobp)))
(backward-char 1))
(goto-char (point-at-eol))
(skip-chars-forward " \t\n")
(let ((indent (- (point) (point-at-bol))))
(when (< (point-at-eol) pos)
indent)))))
;; SPAN is a body span
(defun pm--head-indent (&optional span)
(save-excursion
(let ((sbeg (nth 1 (or span (pm-innermost-span)))))
(goto-char sbeg)
(backward-char 1)
(let ((head-span (pm-innermost-span)))
(if (eq (car head-span) 'head)
(goto-char (nth 1 head-span))
;; body span is not preceded by a head span. We don't have such
;; practical cases yet, but headless spans are real - indented blocks
;; for instance.
(goto-char sbeg)))
(back-to-indentation)
(- (point) (point-at-bol)))))
;;; FACES
(cl-defgeneric pm-get-adjust-face (chunkmode type))
(cl-defmethod pm-get-adjust-face ((chunkmode pm-chunkmode) _type)
(eieio-oref chunkmode 'adjust-face))
(cl-defmethod pm-get-adjust-face ((chunkmode pm-inner-chunkmode) type)
(cond ((eq type 'head)
(eieio-oref chunkmode 'head-adjust-face))
((eq type 'tail)
(or (eieio-oref chunkmode 'tail-adjust-face)
(eieio-oref chunkmode 'head-adjust-face)))
(t (eieio-oref chunkmode 'adjust-face))))
(provide 'polymode-methods)
(provide 'polymode-methods)
;;; polymode-methods.el ends here

12
elpa/polymode-20180926.2044/polymode-pkg.el Normal file
View File

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

37
elpa/polymode-20180926.2044/polymode-tangle.el Normal file
View File

@@ -0,0 +1,37 @@
;;; polymode-tangle.el --- Tangling facilities for polymodes (stump) -*- 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:
(defgroup polymode-tangle nil
"Polymode Tanglers."
:group 'polymode)
(provide 'polymode-tangle)
;;; polymode-tangle.el ends here

351
elpa/polymode-20180926.2044/polymode-test-utils.el Normal file
View File

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

283
elpa/polymode-20180926.2044/polymode-weave.el Normal file
View File

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

584
elpa/polymode-20180926.2044/polymode.el Normal file
View File

@@ -0,0 +1,584 @@
;;; polymode.el --- Extensible framework for multiple major modes -*- lexical-binding: t -*-
;;
;; Author: Vitalie Spinu
;; Maintainer: Vitalie Spinu
;; Copyright (C) 2013-2018, Vitalie Spinu
;; Version: 0.1.2
;; Package-Requires: ((emacs "25"))
;; URL: https://github.com/vitoshka/polymode
;; Keywords: languages, multi-modes, processes
;;
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; This file is *NOT* part of GNU Emacs.
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 3, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with 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:
;;
;; Documentation at https://polymode.github.io
;;
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Code:
(require 'polymode-core)
(require 'polymode-classes)
(require 'polymode-methods)
(require 'polymode-compat)
(require 'polymode-export)
(require 'polymode-weave)
(require 'polymode-base)
(require 'poly-lock)
(eval-when-compile
(require 'derived))
(defcustom polymode-prefix-key "\M-n"
"Prefix key for the polymode mode keymap.
Not effective after loading the polymode library."
:group 'polymode
:type '(choice string vector))
(defvar polymode-minor-mode-map
(let ((map (make-sparse-keymap)))
(define-key map polymode-prefix-key
(let ((map (make-sparse-keymap)))
;; navigation
(define-key map "\C-n" 'polymode-next-chunk)
(define-key map "\C-p" 'polymode-previous-chunk)
(define-key map "\C-\M-n" 'polymode-next-chunk-same-type)
(define-key map "\C-\M-p" 'polymode-previous-chunk-same-type)
;; chunk manipulation
(define-key map "\M-k" 'polymode-kill-chunk)
(define-key map "\M-m" 'polymode-mark-or-extend-chunk)
(define-key map "\C-t" 'polymode-toggle-chunk-narrowing)
;; backends
(define-key map "e" 'polymode-export)
(define-key map "E" 'polymode-set-exporter)
(define-key map "w" 'polymode-weave)
(define-key map "W" 'polymode-set-weaver)
(define-key map "t" 'polymode-tangle)
(define-key map "T" 'polymode-set-tangler)
(define-key map "$" 'polymode-show-process-buffer)
;; todo: add polymode-goto-process-buffer
map))
(define-key map [menu-bar Polymode]
(cons "Polymode"
(let ((map (make-sparse-keymap "Polymode")))
(define-key-after map [next]
'(menu-item "Next chunk" polymode-next-chunk))
(define-key-after map [previous]
'(menu-item "Previous chunk" polymode-previous-chunk))
(define-key-after map [next-same]
'(menu-item "Next chunk same type" polymode-next-chunk-same-type))
(define-key-after map [previous-same]
'(menu-item "Previous chunk same type" polymode-previous-chunk-same-type))
(define-key-after map [mark]
'(menu-item "Mark or extend chunk" polymode-mark-or-extend-chunk))
(define-key-after map [kill]
'(menu-item "Kill chunk" polymode-kill-chunk))
map)))
map)
"The minor mode keymap which is inherited by all polymodes.")
(defvaralias 'polymode-mode-map 'polymode-minor-mode-map)
;;; COMMANDS
(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))))
(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))
(defun polymode-next-chunk (&optional N)
"Go N chunks forwards.
Return the number of actually moved over chunks."
(interactive "p")
(pm-goto-span-of-type '(nil body) N)
;; If head/tail end before eol we move to the next line
(when (looking-at "\\s *$")
(forward-line 1))
(pm-switch-to-buffer))
;;fixme: problme with long chunks .. point is recentered
;;todo: merge into next-chunk
(defun polymode-previous-chunk (&optional N)
"Go N chunks backwards .
Return the number of chunks jumped over."
(interactive "p")
(polymode-next-chunk (- N)))
(defun polymode-next-chunk-same-type (&optional N)
"Go to next N chunk.
Return the number of chunks of the same type moved over."
(interactive "p")
(let* ((sofar 0)
(back (< N 0))
(beg (if back (point-min) (point)))
(end (if back (point) (point-max)))
(N (if back (- N) N))
this-type this-name)
(condition-case-unless-debug nil
(pm-map-over-spans
(lambda (span)
(unless (memq (car span) '(head tail))
(when (and (equal this-name
(eieio-object-name (car (last span))))
(eq this-type (car span)))
(setq sofar (1+ sofar)))
(unless this-name
(setq this-name (eieio-object-name (car (last span)))
this-type (car span)))
(when (>= sofar N)
(signal 'quit nil))))
beg end nil back)
(quit (when (looking-at "\\s *$")
(forward-line)))
(pm-switch-to-buffer))
sofar))
(defun polymode-previous-chunk-same-type (&optional N)
"Go to previous N chunk.
Return the number of chunks of the same type moved over."
(interactive "p")
(polymode-next-chunk-same-type (- N)))
(defun pm--kill-span (types)
(let ((span (pm-innermost-span)))
(when (memq (car span) types)
(delete-region (nth 1 span) (nth 2 span)))))
(defun polymode-kill-chunk ()
"Kill current chunk."
(interactive)
(pcase (pm-innermost-span)
(`(,(or `nil `host) ,beg ,end ,_) (delete-region beg end))
(`(body ,beg ,_ ,_)
(goto-char beg)
(pm--kill-span '(body))
(pm--kill-span '(head tail))
(pm--kill-span '(head tail)))
(`(tail ,beg ,end ,_)
(if (eq beg (point-min))
(delete-region beg end)
(goto-char (1- beg))
(polymode-kill-chunk)))
(`(head ,_ ,end ,_)
(goto-char end)
(polymode-kill-chunk))
(_ (error "Canoot find chunk to kill"))))
(defun polymode-toggle-chunk-narrowing ()
"Toggle narrowing of the body of current chunk."
(interactive)
(if (buffer-narrowed-p)
(progn (widen) (recenter))
(pcase (pm-innermost-span)
(`(head ,_ ,end ,_)
(goto-char end)
(pm-narrow-to-span))
(`(tail ,beg ,_ ,_)
(if (eq beg (point-min))
(error "Invalid chunk")
(goto-char (1- beg))
(pm-narrow-to-span)))
(_ (pm-narrow-to-span)))))
(defun pm-chunk-range (&optional pos)
(setq pos (or pos (point)))
(let ((span (pm-innermost-span pos))
(pmin (point-min))
(pmax (point-max))
beg end)
(cl-case (car span)
((nil) (pm-span-to-range span))
(body (cons (if (= pmin (nth 1 span))
pmin
(nth 1 (pm-innermost-span (1- (nth 1 span)))))
(if (= pmax (nth 2 span))
pmax
(nth 2 (pm-innermost-span (nth 2 span))))))
(head (if (= pmax (nth 2 span))
(pm-span-to-range span)
(pm-chunk-range (nth 2 span))))
(tail (if (= pmin (nth 1 span))
(pm-span-to-range span)
(pm-chunk-range (1- (nth 1 span))))))))
(defun polymode-mark-or-extend-chunk ()
"DWIM command to repeatedly mark chunk or extend region.
When no region is active, mark the current span if in body of a
chunk or the whole chunk if in head or tail. On repeated
invocation extend the region either forward or backward. You need
not use the prefix key on repeated invocation. For example
assuming we are in the body of the inner chunk and this command
is bound on \"M-n M-m\" (the default)
[M-n M-m M-m M-m] selects body, expand selection to chunk then
expand selection to previous chunk
[M-n M-m C-x C-x M-m] selects body, expand selection to chunk,
then reverse point and mark, then extend the
selection to the following chunk"
(interactive)
(let ((span (pm-innermost-span)))
(if (region-active-p)
(if (< (mark) (point))
;; forward extension
(if (eobp)
(user-error "End of buffer")
(if (eq (car span) 'head)
(goto-char (cdr (pm-chunk-range)))
(goto-char (nth 2 span))
;; special dwim when extending from body
(when (and (eq (car span) 'tail)
(not (= (point-min) (nth 1 span))))
(let ((body-span (pm-innermost-span (1- (nth 1 span)))))
(when (and (= (nth 1 body-span) (mark))
(not (= (nth 1 body-span) (point-min))))
(let ((head-span (pm-innermost-span (1- (nth 1 body-span)))))
(when (eq (car head-span) 'head)
(set-mark (nth 1 head-span)))))))))
;; backward extension
(if (bobp)
(user-error "Beginning of buffer")
(goto-char (car (if (= (point) (nth 1 span))
(pm-chunk-range (1- (point)))
(pm-chunk-range (point)))))
;; special dwim when extending from body
(when (and (eq (car span) 'body)
(= (nth 2 span) (mark)))
(let ((tail-span (pm-innermost-span (nth 2 span))))
(when (eq (car tail-span) 'tail)
(set-mark (nth 2 tail-span)))))))
(let ((range (if (memq (car span) '(nil body))
(pm-span-to-range span)
(pm-chunk-range))))
(set-mark (cdr range))
(goto-char (car range)))))
(let ((map (make-sparse-keymap)))
(define-key map (vector last-command-event) #'polymode-mark-or-extend-chunk)
(define-key map (car (where-is-internal #'exchange-point-and-mark)) #'exchange-point-and-mark)
(let ((ev (event-basic-type last-command-event)))
(define-key map (vector ev) #'polymode-mark-or-extend-chunk))
(set-transient-map map (lambda () (eq this-command 'exchange-point-and-mark)))))
(defun polymode-show-process-buffer ()
"Show the process buffer used by weaving and exporting programs."
(interactive)
(let ((buf (cl-loop for b being the buffers
if (buffer-local-value 'pm--process-buffer b)
return b)))
(if buf
(pop-to-buffer buf `(nil . ((inhibit-same-window . ,pop-up-windows))))
(message "No polymode process buffers found."))))
;;; DEFINE
(defun pm--config-name (symbol &optional must-exist)
(let ((config-name
(if (and (boundp symbol)
(symbol-value symbol)
(object-of-class-p (symbol-value symbol) 'pm-polymode))
symbol
(let ((poly-name (replace-regexp-in-string "pm-poly/\\|poly-\\|-mode\\|-minor-mode" ""
(symbol-name symbol))))
(intern (concat "pm-poly/" poly-name))))))
(when must-exist
(unless (boundp config-name)
(error "No pm-polymode config object with name `%s'" config-name))
(unless (object-of-class-p (symbol-value config-name) 'pm-polymode)
(error "`%s' is not a `pm-polymode' config object" config-name)))
config-name))
(defun pm--get-keylist.keymap-from-parent (keymap parent-conf)
(let ((keylist (copy-sequence keymap))
(pi parent-conf)
(parent-map))
(while pi
(let ((map (and (slot-boundp pi :keylist)
(eieio-oref pi 'keylist))))
(when map
(if (and (symbolp map)
(keymapp (symbol-value map)))
;; if one of the parent's :keylist is a keymap, use it as our
;; parent-map and stop further descent
(setq parent-map map
pi nil)
;; list, descend to next parent and append the key list to keylist
(setq pi (and (slot-boundp pi :parent-instance)
(eieio-oref pi 'parent-instance))
keylist (append map keylist))))))
(when (and parent-map (symbolp parent-map))
(setq parent-map (symbol-value parent-map)))
(cons (reverse keylist)
(or parent-map polymode-minor-mode-map))))
;;;###autoload
(defmacro define-polymode (mode &optional parent doc &rest body)
"Define a new polymode MODE.
This macro defines command MODE and an indicator variable MODE
which becomes t when MODE is active and nil otherwise.
MODE command can be used as both major and minor mode. Using
polymodes as minor modes makes sense when :hostmode (see below)
is not specified, in which case polymode installs only inner
modes and doesn't touch current major mode.
Standard hook MODE-hook is run at the end of the initialization
of each polymode buffer (both indirect and base buffers).
This macro also defines the MODE-map keymap from the :keymap
argument and PARENT-map (see below) and pm-poly/[MODE-NAME]
custom variable which holds a `pm-polymode' configuration object
for this polymode.
PARENT is either the polymode configuration object or a polymode
mode (there is 1-to-1 correspondence between config
objects (`pm-polymode') and mode functions). The new polymode
MODE inherits alll the behavior from PARENT except for the
overwrites specified by the keywords (see below). The new MODE
runs all the hooks from the PARENT-mode and inherits its MODE-map
from PARENT-map.
DOC is an optional documentation string. If present PARENT must
be provided, but can be nil.
BODY is executed after the complete initialization of the
polymode but before MODE-hook. It is executed once for each
polymode buffer - host buffer on initialization and every inner
buffer subsequently created.
Before the BODY code keyword arguments (i.e. alternating keywords
and values) are allowed. The following special keywords
controlling the behavior of the new MODE are supported:
:lighter Optional LIGHTER is displayed in the mode line when the
mode is on. If omitted, it defaults to the :lighter slot of
CONFIG object.
:keymap If nil, a new MODE-map keymap is created what directly
inherits from the PARENT's keymap. The last keymap in the
inheritance chain is always `polymode-minor-mode-map'. If a
keymap it is used directly as it is. If a list of binding of
the form (KEY . BINDING) it is merged the bindings are added to
the newly create keymap.
:after-hook A single form which is evaluated after the mode hooks
have been run. It should not be quoted.
Other keywords are added to the `pm-polymode' configuration
object and should be valid slots in PARENT config object or the
root config `pm-polymode' object if PARENT is nil. By far the
most frequently used slots are:
:hostmode Symbol pointing to a `pm-host-chunkmode' object
specifying the behavior of the hostmode. If missing or nil,
MODE will behave as a minor-mode in the sense that it will
reuse the currently installed major mode and will install only
the inner modes.
:innermodes List of symbols pointing to `pm-inner-chunkmode'
objects which specify the behavior of inner modes (or submodes)."
(declare
(doc-string 3)
(debug (&define name
[&optional [&not keywordp] name]
[&optional stringp]
[&rest [keywordp sexp]]
def-body)))
(if (keywordp parent)
(progn
(push doc body)
(push parent body)
(setq doc nil
parent nil))
(when (keywordp doc)
(progn
(push doc body)
(setq doc nil))))
(unless (symbolp parent)
(error "PARENT must be a name of a `pm-polymode' config or a polymode mode function"))
(let* ((last-message (make-symbol "last-message"))
(mode-name (symbol-name mode))
(config-name (pm--config-name mode))
(root-name (replace-regexp-in-string "poly-\\|-mode" "" mode-name))
(keymap-name (intern (concat mode-name "-map")))
keymap slots after-hook keyw lighter)
;; Check keys
(while (keywordp (setq keyw (car body)))
(setq body (cdr body))
(pcase keyw
(`:lighter (setq lighter (purecopy (pop body))))
(`:keymap (setq keymap (pop body)))
(`:after-hook (setq after-hook (pop body)))
(`:keylist (error ":keylist is not allowed in `define-polymode'"))
(_ (push (pop body) slots) (push keyw slots))))
`(progn
;; Define the variable to enable or disable the mode.
(defvar-local ,mode nil ,(format "Non-nil if `%s' polymode is enabled." mode))
(let* ((parent ',parent)
(keymap ,keymap)
(parent-conf-name (and parent (pm--config-name parent 'must-exist)))
(parent-conf (and parent-conf-name (symbol-value parent-conf-name))))
;; define the minor-mode's keymap
(defvar ,keymap-name
(if (keymapp keymap)
keymap
(let ((parent-map (unless (keymapp keymap)
;; keymap is either nil or a list
(cond
;; 1. if parent is config object, merge all list
;; keymaps from parents
((eieio-object-p parent-conf)
(let ((klist.kmap (pm--get-keylist.keymap-from-parent
keymap (symbol-value parent))))
(setq keymap (car klist.kmap))
(cdr klist.kmap)))
;; 2. If parent is polymode function, take the
;; minor-mode from the parent config
(parent-conf
(derived-mode-map-name
(eieio-oref parent-conf '-minor-mode)))
;; 3. nil
(t 'polymode-minor-mode-map)))))
(easy-mmode-define-keymap keymap nil nil (list :inherit parent-map))))
,(format "Keymap for %s." mode-name))
,@(unless (eq parent config-name)
`((defcustom ,config-name nil
,(format "Configuration object for `%s' polymode." mode)
:group 'polymodes
:type 'object)
;; setting in two steps as defcustom is not re-evaluated on repeated evals
(setq ,config-name
(if parent-conf-name
(clone parent-conf
:name ,(symbol-name config-name)
,@slots)
(pm-polymode :name ,(symbol-name config-name)
,@slots)))))
;; The actual mode function:
(defun ,mode (&optional arg)
,(format "%s\n\n\\{%s}"
;; fixme: add inheretance info here and warning if body is
;; non-nil (like in define-mirror-mode)
(or doc (format "Polymode %s." root-name))
keymap-name)
(interactive)
(let ((,last-message (current-message))
(state (cond
((numberp arg) (> arg 0))
(arg t)
((not ,mode)))))
(setq ,mode state)
;; The 'unless' is needed because inner modes during
;; initialization call the same polymode minor-mode which
;; triggers this `pm-initialize'.
(unless (buffer-base-buffer)
(when ,mode
(let ((obj (clone ,config-name)))
(eieio-oset obj '-minor-mode ',mode)
(pm-initialize obj))
;; when host mode is reset in pm-initialize we end up with now
;; minor mode in hosts
(setq ,mode t)))
;; body and hooks are executed in all buffers!
,@body
(unless (buffer-base-buffer)
;; Avoid overwriting a message shown by the body,
;; but do overwrite previous messages.
(when (and (called-interactively-p 'any)
(or (null (current-message))
(not (equal ,last-message
(current-message)))))
(message ,(format "%s enabled" (concat root-name " polymode")))))
(force-mode-line-update)
(pm--run-derived-mode-hooks ,config-name)
,@(when after-hook `(,after-hook)))
;; Return the new state
,mode)
(add-minor-mode ',mode ,(or lighter " PM") ,keymap-name)))))
(define-minor-mode polymode-minor-mode
"Polymode minor mode, used to make everything work."
nil " PM")
(define-derived-mode poly-head-tail-mode prog-mode "HeadTail"
"Default major mode for polymode head and tail spans."
(let ((base (pm-base-buffer)))
;; (#119) hideshow needs comment regexp and throws if not found. We are
;; using these values from the host mode which should have been installed
;; already.
(setq-local comment-start (buffer-local-value 'comment-start base))
(setq-local comment-end (buffer-local-value 'comment-end base))))
(define-derived-mode poly-fallback-mode prog-mode "FallBack"
;; fixme:
;; 1. doesn't work as fallback for hostmode
;; 2. highlighting is lost (Rnw with inner fallback)
"Default major mode for modes which were not found.
This is better than fundamental-mode because it allows running
globalized minor modes and can run user hooks.")
;;; FONT-LOCK
;; indulge elisp font-lock :)
(dolist (mode '(emacs-lisp-mode lisp-interaction-mode))
(font-lock-add-keywords
mode
'(("(\\(define-polymode\\)\\s +\\(\\(\\w\\|\\s_\\)+\\)"
(1 font-lock-keyword-face)
(2 font-lock-variable-name-face)))))
(provide 'polymode)
;;; polymode.el ends here