450 lines
17 KiB
EmacsLisp
450 lines
17 KiB
EmacsLisp
;;; polymode.el --- Versatile multiple modes with extensive literate programming support
|
||
;;
|
||
;; Filename: polymode.el
|
||
;; Author: Spinu Vitalie
|
||
;; Maintainer: Spinu Vitalie
|
||
;; Copyright (C) 2013-2014, Spinu Vitalie, all rights reserved.
|
||
;; Version: 1.0
|
||
;; Package-Requires: ((emacs "24"))
|
||
;; 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:
|
||
;;
|
||
;; Extensible, fast, objected-oriented multimode specifically designed for
|
||
;; literate programming. Extensible support for weaving, tangling and export.
|
||
;;
|
||
;; Usage: https://github.com/vspinu/polymode
|
||
;;
|
||
;; Design new polymodes: https://github.com/vspinu/polymode/tree/master/modes
|
||
;;
|
||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
;;
|
||
;;; Code:
|
||
|
||
(require 'polymode-core)
|
||
(require 'polymode-classes)
|
||
(require 'polymode-methods)
|
||
(require 'polymode-compat)
|
||
(require 'polymode-debug)
|
||
(require 'polymode-export)
|
||
(require 'polymode-weave)
|
||
(require 'poly-lock)
|
||
(require 'poly-base)
|
||
|
||
(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-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)
|
||
(define-key map "\M-i" 'polymode-insert-new-chunk)
|
||
;; 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))
|
||
(define-key-after map [insert]
|
||
'(menu-item "Insert new chunk" polymode-insert-new-chunk))
|
||
map)))
|
||
map)
|
||
"The default minor mode keymap that is active in all polymode
|
||
modes.")
|
||
|
||
|
||
;;; COMMANDS
|
||
(defvar *span*)
|
||
(defun polymode-next-chunk (&optional N)
|
||
"Go COUNT chunks forwards.
|
||
Return, how many chucks actually jumped 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)))
|
||
(condition-case nil
|
||
(pm-map-over-spans
|
||
(lambda ()
|
||
(unless (memq (car *span*) '(head tail))
|
||
(when (>= sofar N)
|
||
(signal 'quit nil))
|
||
(setq sofar (1+ sofar))))
|
||
beg end nil back)
|
||
(quit (when (looking-at "\\s *$")
|
||
(forward-line)))
|
||
(pm-switch-to-buffer))
|
||
sofar))
|
||
|
||
;;fixme: problme with long chunks .. point is recentered
|
||
;;todo: merge into next-chunk
|
||
(defun polymode-previous-chunk (&optional N)
|
||
"Go COUNT chunks backwards .
|
||
Return, how many chucks actually jumped over."
|
||
(interactive "p")
|
||
(polymode-next-chunk (- N)))
|
||
|
||
(defun polymode-next-chunk-same-type (&optional N)
|
||
"Go to next COUNT chunk.
|
||
Return, how many chucks actually jumped 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-class)
|
||
(condition-case nil
|
||
(pm-map-over-spans
|
||
(lambda ()
|
||
(unless (memq (car *span*) '(head tail))
|
||
(when (and (equal this-class
|
||
(eieio-object-name (car (last *span*))))
|
||
(eq this-type (car *span*)))
|
||
(setq sofar (1+ sofar)))
|
||
(unless this-class
|
||
(setq this-class (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 previus COUNT chunk.
|
||
Return, how many chucks actually jumped over."
|
||
(interactive "p")
|
||
(polymode-next-chunk-same-type (- N)))
|
||
|
||
(defun pm--kill-span (types)
|
||
(let ((span (pm-get-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-get-innermost-span)
|
||
(`(,(or `nil `host) ,beg ,end ,_) (delete-region beg end))
|
||
(`(body ,beg ,end ,_)
|
||
(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 current chunk."
|
||
(interactive)
|
||
(if (buffer-narrowed-p)
|
||
(progn (widen) (recenter))
|
||
(pcase (pm-get-innermost-span)
|
||
(`(head ,_ ,end ,_)
|
||
(goto-char end)
|
||
(pm-narrow-to-span))
|
||
(`(tail ,beg ,end ,_)
|
||
(if (eq beg (point-min))
|
||
(error "Invalid chunk")
|
||
(goto-char (1- beg))
|
||
(pm-narrow-to-span)))
|
||
(_ (pm-narrow-to-span)))))
|
||
|
||
|
||
(defun polymode-mark-or-extend-chunk ()
|
||
(interactive)
|
||
(error "Not implemented yet"))
|
||
|
||
(defun polymode-insert-new-chunk ()
|
||
(interactive)
|
||
(error "Not implemented yet"))
|
||
|
||
(defun polymode-show-process-buffer ()
|
||
(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."))))
|
||
|
||
|
||
;;; HOOKS
|
||
;; In addition to these hooks there is poly-lock-after-change which is placed in
|
||
;; after-change-functions. See poly-lock.el
|
||
|
||
(defun polymode-post-command-select-buffer ()
|
||
"Select the appropriate (indirect) buffer corresponding to point's context.
|
||
This funciton is placed in local `post-command-hook'."
|
||
(when (and pm-allow-post-command-hook
|
||
polymode-mode
|
||
pm/chunkmode)
|
||
(condition-case err
|
||
(pm-switch-to-buffer)
|
||
(error (message "(pm-switch-to-buffer %s): %s"
|
||
(point) (error-message-string err))))))
|
||
|
||
(defun polymode-before-change-setup (beg end)
|
||
"Run `syntax-ppss-flush-cache' in all polymode buffers.
|
||
This function is placed in `before-change-functions' hook."
|
||
;; Modification hooks are run only in current buffer and not in other (base or
|
||
;; indirect) buffers. Thus some actions like flush of ppss cache must be taken
|
||
;; care explicitly. We run some safety hooks checks here as well.
|
||
(dolist (buff (oref pm/polymode -buffers))
|
||
;; The following two checks are unnecessary by poly-lock design, but we are
|
||
;; checking them here, just in case.
|
||
;; VS[06-03-2016]: `fontification-functions' probably should be checked as well.
|
||
(when (memq 'font-lock-after-change-function after-change-functions)
|
||
(remove-hook 'after-change-functions 'font-lock-after-change-function t))
|
||
(when (memq 'jit-lock-after-change after-change-functions)
|
||
(remove-hook 'after-change-functions 'jit-lock-after-change t))
|
||
|
||
(with-current-buffer buff
|
||
;; now `syntax-ppss-flush-cache is harmless, but who knows in the future.
|
||
(when (memq 'syntax-ppss-flush-cache before-change-functions)
|
||
(remove-hook 'before-change-functions 'syntax-ppss-flush-cache t))
|
||
(syntax-ppss-flush-cache beg end))))
|
||
|
||
|
||
;;; DEFINE
|
||
;;;###autoload
|
||
(defmacro define-polymode (mode config &optional keymap &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 is similar to standard emacs major modes and it can
|
||
be used in `auto-mode-alist'. Standard hook MODE-hook is run at
|
||
the end of the initialization of each polymode buffer (both
|
||
indirect and base buffers). Additionally MODE-map is created
|
||
based on the CONFIG's :map slot and the value of the :keymap
|
||
argument; see below.
|
||
|
||
CONFIG is a name of a config object representing the mode.
|
||
|
||
MODE command can also be use as a minor mode. Current major mode
|
||
is not reinitialized if it coincides with the :mode slot of
|
||
CONFIG object or if the :mode slot is nil.
|
||
|
||
BODY contains code to be executed after the complete
|
||
initialization of the polymode (`pm-initialize') and before
|
||
running MODE-hook. Before the BODY code, you can write keyword
|
||
arguments, i.e. alternating keywords and values. The following
|
||
special keywords are supported:
|
||
|
||
:lighter SPEC 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 MAP Same as the KEYMAP argument.
|
||
|
||
If nil, a new MODE-map keymap is created what
|
||
directly inherits from the keymap defined by
|
||
the :map slot of CONFIG object. In most cases it
|
||
is a simple map inheriting form
|
||
`polymode-mode-map'. If t or an alist (of
|
||
bindings suitable to be passed to
|
||
`easy-mmode-define-keymap') a keymap MODE-MAP is
|
||
build by mergin this alist with the :map
|
||
specification of the CONFIG object. If a symbol,
|
||
it should be a variable whose value is a
|
||
keymap. No MODE-MAP is automatically created in
|
||
the latter case and :map slot of the CONFIG
|
||
object is ignored.
|
||
|
||
:after-hook A single lisp form which is evaluated after the mode hooks
|
||
have been run. It should not be quoted."
|
||
(declare
|
||
(debug (&define name name
|
||
[&optional [¬ keywordp] sexp]
|
||
[&rest [keywordp sexp]]
|
||
def-body)))
|
||
|
||
|
||
(when (keywordp keymap)
|
||
(push keymap body)
|
||
(setq keymap nil))
|
||
|
||
(let* ((last-message (make-symbol "last-message"))
|
||
(mode-name (symbol-name mode))
|
||
(pretty-name (concat
|
||
(replace-regexp-in-string "poly-\\|-mode" "" mode-name)
|
||
" polymode"))
|
||
(keymap-sym (intern (concat mode-name "-map")))
|
||
(hook (intern (concat mode-name "-hook")))
|
||
(extra-keywords nil)
|
||
(after-hook nil)
|
||
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)))
|
||
(_ (push keyw extra-keywords) (push (pop body) extra-keywords))))
|
||
|
||
`(progn
|
||
:autoload-end
|
||
|
||
;; Define the variable to enable or disable the mode.
|
||
(defvar ,mode nil ,(format "Non-nil if %s mode is enabled." pretty-name))
|
||
(make-variable-buffer-local ',mode)
|
||
|
||
(let* ((keymap ,keymap)
|
||
(config ',config)
|
||
(lighter (or ,lighter
|
||
(oref (symbol-value config) :lighter)))
|
||
key-alist)
|
||
|
||
(unless (keymapp keymap)
|
||
;; keymap is either nil or list. Iterate through parents' :map slot
|
||
;; and gather keys.
|
||
(setq key-alist keymap)
|
||
(let* ((pi (symbol-value config))
|
||
map mm-name)
|
||
(while pi
|
||
(setq map (and (slot-boundp pi :map)
|
||
(oref pi :map)))
|
||
(if (and (symbolp map)
|
||
(keymapp (symbol-value map)))
|
||
;; If one of the parent's :map is a keymap, use it as our
|
||
;; keymap and stop further descent.
|
||
(setq keymap (symbol-value map)
|
||
pi nil)
|
||
;; Descend to next parent and append the key list to key-alist
|
||
(setq pi (and (slot-boundp pi :parent-instance)
|
||
(oref pi :parent-instance))
|
||
key-alist (append key-alist map))))))
|
||
|
||
(unless keymap
|
||
;; If we couldn't figure out the original keymap:
|
||
(setq keymap polymode-mode-map))
|
||
|
||
;; Define the minor-mode keymap:
|
||
(defvar ,keymap-sym
|
||
(easy-mmode-define-keymap key-alist nil nil `(:inherit ,keymap))
|
||
,(format "Keymap for %s." pretty-name))
|
||
|
||
;; The actual mode function:
|
||
(defun ,mode (&optional arg) ,(format "%s.\n\n\\{%s}" pretty-name keymap-sym)
|
||
(interactive)
|
||
(unless ,mode
|
||
(let ((,last-message (current-message)))
|
||
(unless pm/polymode ;; don't reinstall for time being
|
||
(let ((config (clone ,config)))
|
||
(oset config :minor-mode ',mode)
|
||
(pm-initialize config)))
|
||
;; set our "minor" mode
|
||
(setq ,mode t)
|
||
,@body
|
||
(run-hooks ',hook)
|
||
;; 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" pretty-name)))
|
||
,@(when after-hook `(,after-hook))
|
||
(force-mode-line-update)))
|
||
;; Return the new setting.
|
||
,mode)
|
||
|
||
(add-minor-mode ',mode lighter ,keymap-sym)))))
|
||
|
||
(define-minor-mode polymode-minor-mode
|
||
"Polymode minor mode, used to make everything work."
|
||
nil " PM" polymode-mode-map)
|
||
|
||
(define-derived-mode poly-head-tail-mode prog-mode "HeadTail"
|
||
"Default major mode for polymode head and tail spans.")
|
||
|
||
(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
|