;;; -*- lexical-binding: t -*- ;;; core-micro-state.el --- Spacemacs Core File ;; ;; Copyright (c) 2012-2016 Sylvain Benner & Contributors ;; ;; Author: Sylvain Benner ;; URL: https://github.com/syl20bnr/spacemacs ;; ;; This file is not part of GNU Emacs. ;; ;;; License: GPLv3 (require 'corelv) (defun spacemacs/defface-micro-state-faces () "Define faces for micro-states." (let* ((hname 'spacemacs-micro-state-header-face) (bname 'spacemacs-micro-state-binding-face) (box '(:line-width -1 :color (plist-get (face-attribute 'mode-line :box) :color))) (err (face-attribute 'error :foreground))) (eval `(defface ,hname '((t ())) "Face for micro-state header in echo area. The header is the name of the micro-state." :group 'spacemacs)) (set-face-attribute hname nil :background "DarkGoldenrod2" :foreground "black" :bold t :box box) (eval `(defface ,bname '((t ())) "Face for micro-state key binding in echo area. Characters enclosed in `[]' will have this face applied to them." :group 'spacemacs)) (set-face-attribute bname nil :foreground err :bold t))) (spacemacs/defface-micro-state-faces) (defun spacemacs//micro-state-set-minibuffer-height (str) "Set the max mini windows size given a string STR." (let ((line-count (1+ (how-many-str "\n" str)))) (when (and (> line-count max-mini-window-height) (> line-count 10)) (setq max-mini-window-height line-count)))) (defmacro spacemacs|define-micro-state (name &rest props) "Define a micro-state called NAME. NAME is a symbol. Available PROPS: `:on-enter SEXP' Evaluate SEXP when the micro-state is switched on. `:on-exit SEXP' Evaluate SEXP when leaving the micro-state. `:doc STRING or SEXP' A STRING or a SEXP that evaluates to a string. `:use-minibuffer BOOLEAN' If non nil then the minibuffer is used to display the documenation strings. Default is nil. `:disable-evil-leader BOOLEAN' If non nil then the evil leader has no effect when the micro state is active. Default to nil. `:persistent BOOLEAN' If BOOLEAN is non nil then the micro-state never exits. A binding with an explicitly set `exit t' property is required. Default is nil. `:execute-binding-on-enter BOOLEAN' If BOOLEAN is non nil then execute the micro-state command bound to to the pressed key that started the micro-state. `:bindings EXPRESSIONS' One or several EXPRESSIONS with the form (STRING1 SYMBOL1 :doc STRING :pre SEXP :post SEXP :exit SYMBOL) where: - STRING1 is a key to be bound to the function or key map SYMBOL1. - :doc STRING or SEXP is a STRING or an SEXP that evalutes to a string - :pre is an SEXP evaluated before the bound action - :post is an SEXP evaluated after the bound action - :exit SYMBOL or SEXP, if non nil then pressing this key will leave the micro-state (default is nil). Important note: due to inner working of transient-maps in Emacs the `:exit' keyword is evaluate *before* the actual execution of the bound command. All properties supported by `spacemacs//create-key-binding-form' can be used." (declare (indent 1)) (let* ((func (spacemacs//micro-state-func-name name)) (doc (spacemacs/mplist-get props :doc)) (persistent (plist-get props :persistent)) (disable-leader (plist-get props :disable-evil-leader)) (msg-func (if (plist-get props :use-minibuffer) 'message 'corelv-message)) (exec-binding (plist-get props :execute-binding-on-enter)) (on-enter (spacemacs/mplist-get props :on-enter)) (on-exit (spacemacs/mplist-get props :on-exit)) (bindings (spacemacs/mplist-get props :bindings)) (wrappers (spacemacs//micro-state-create-wrappers name doc msg-func disable-leader bindings)) (keymap-body (spacemacs//micro-state-fill-map-sexps wrappers)) (bindkeys (spacemacs//create-key-binding-form props func))) `(progn (defun ,func () ,(format "%S micro-state." name) (interactive) ,@on-enter (let ((doc ,@doc)) (when doc (spacemacs//micro-state-set-minibuffer-height doc) (apply ',msg-func (list (spacemacs//micro-state-propertize-doc (format "%S: %s" ',name doc)))))) ,(when exec-binding (spacemacs//micro-state-auto-execute bindings)) (,(if (version< emacs-version "24.4") 'set-temporary-overlay-map 'set-transient-map) (let ((map (make-sparse-keymap))) ,@keymap-body map) ',(spacemacs//micro-state-create-exit-func name wrappers persistent on-exit))) ,@bindkeys))) (defun spacemacs//micro-state-func-name (name) "Return the name of the micro-state function." (intern (format "spacemacs/%S-micro-state" name))) (defun spacemacs//micro-state-auto-execute (bindings) "Auto execute the binding corresponding to `this-command-keys'." `(let* ((key (substring (this-command-keys) (1- (length (this-command-keys))))) (binding (assoc key ',bindings))) (when binding (call-interactively (cadr binding))))) (defun spacemacs//micro-state-create-wrappers (name doc msg-func disable-leader bindings) "Return an alist (key wrapper) for each binding in BINDINGS." (mapcar (lambda (x) (spacemacs//micro-state-create-wrapper name doc msg-func x)) (append bindings ;; force SPC to quit the micro-state to avoid a edge case ;; with evil-leader (list `(,dotspacemacs-leader-key ,(unless disable-leader 'spacemacs-default-map) :exit t))))) (defun spacemacs//micro-state-create-wrapper (name default-doc msg-func binding) "Create a wrapper of FUNC and return a tuple (key wrapper BINDING)." (let* ((key (car binding)) (wrapped (cadr binding)) (binding-doc (spacemacs/mplist-get binding :doc)) (binding-pre (spacemacs/mplist-get binding :pre)) (binding-post (spacemacs/mplist-get binding :post)) (wrapper-name (intern (format "spacemacs//%S-%S-%s" name wrapped key))) (doc-body `((let ((bdoc ,@binding-doc) (defdoc ,@default-doc)) (if bdoc (apply ',msg-func (list (spacemacs//micro-state-propertize-doc (format "%S: %s" ',name bdoc)))) (when (and defdoc ',wrapped (not (plist-get ',binding :exit))) (spacemacs//micro-state-set-minibuffer-height defdoc) (apply ',msg-func (list (spacemacs//micro-state-propertize-doc (format "%S: %s" ',name defdoc)))) defdoc))))) (wrapper-func (if (and (boundp wrapped) (eval `(keymapp ,wrapped))) wrapped `(defun ,wrapper-name () "Auto-generated function" (interactive) ,@binding-pre (let ((throwp t)) (catch 'exit (when (fboundp ',wrapped) (setq this-command ',wrapped) (call-interactively ',wrapped) (setq last-command ',wrapped)) (setq throwp nil)) ,@binding-post (when throwp (throw 'exit nil))) (when ,@doc-body (spacemacs//micro-state-set-minibuffer-height ,@doc-body) ,@doc-body))))) (append (list (car binding) (eval wrapper-func)) binding))) (defun spacemacs//micro-state-fill-map-sexps (wrappers) "Return a list of `define-key' sexp to fill the micro-state temporary map." (mapcar (lambda (x) `(define-key map ,(kbd (car x)) ',(cadr x))) wrappers)) (defun spacemacs//micro-state-create-exit-func (name wrappers persistent on-exit) "Return a function to execute when leaving the micro-state. The returned function returns nil if the executed command exits the micro-state." (let ((func (intern (format "spacemacs//%s-on-exit" name)))) (eval `(defun ,func () "Function executed after each micro-state command." (let* ((cur-wrapper (spacemacs//get-current-wrapper ',name ',wrappers)) (exitp (if cur-wrapper (plist-get cur-wrapper :exit) ,(not persistent)))) (when (listp exitp) (setq exitp (eval exitp))) (when exitp ,@on-exit (spacemacs//micro-state-close-window)) (not exitp)))))) (defun spacemacs//get-current-wrapper (name wrappers) "Return the wrapper being executed. Return nil if no wrapper is being executed (i.e. an unbound key has been pressed)." (let ((micro-state-fun (spacemacs//micro-state-func-name name))) (catch 'found (dolist (wrapper wrappers) (let ((key (car wrapper)) (func (cadr wrapper))) (if (and (or (eq this-command micro-state-fun) (eq this-command func)) (equal (this-command-keys) (kbd key))) (throw 'found wrapper)))) nil))) (defun spacemacs//micro-state-propertize-doc (doc) "Return a propertized doc string from DOC." (when (string-match "^\\(.+?\\):\\([[:ascii:]]*\\)$" doc) (let* ((header (match-string 1 doc)) (pheader (when header (propertize (concat " " header " ") 'face 'spacemacs-micro-state-header-face))) (tail (spacemacs//micro-state-propertize-doc-rec (match-string 2 doc)))) (concat pheader tail)))) (defun spacemacs//micro-state-propertize-doc-rec (doc) "Recursively propertize keys" (if (string-match "^\\([[:ascii:]]*?\\)\\(\\[.+?\\]\\)\\([[:ascii:]]*\\)$" doc) (let* ((head (match-string 1 doc)) (key (match-string 2 doc)) (pkey (when key (propertize key 'face 'spacemacs-micro-state-binding-face))) (tail (spacemacs//micro-state-propertize-doc-rec (match-string 3 doc)))) (concat head pkey tail)) doc)) (defun spacemacs//micro-state-close-window () "Close micro-state help window." (when (window-live-p corelv-wnd) (let ((buf (window-buffer corelv-wnd))) (delete-window corelv-wnd) (kill-buffer buf)))) ;; Transient states (based on hydras) ;; (defmacro spacemacs|remove-transient-state-bindings (transient-state &rest bindings) ;; "Remove bindings from TRANSIENT-STATE. Each element of BINDINGS ;; should be a string to be passed to `kbd'." ;; (declare (indent 1)) ;; (let ((add-bindings ;; (intern (format "spacemacs-%s-transient-state-remove-bindings" ;; transient-state)))) ;; `(progn ;; (defvar ,remove-bindings nil ;; ,(format "Bindings to remove from the %s transient state" ;; transient-state)) ;; (dolist (binding ',bindings) ;; (push binding ,remove-bindings))))) ;; (defmacro spacemacs|add-transient-state-bindings (transient-state &rest bindings) ;; "Add bindings to TRANSIENT-STATE. Bindings take the same form as ;; they do in `spacemacs|define-transient-state'." ;; (declare (indent 1)) ;; (let ((add-bindings ;; (intern (format "spacemacs-%s-transient-state-add-bindings" ;; transient-state)))) ;; `(progn ;; (defvar ,add-bindings nil ;; ,(format "Additional bindings for the %s transient state" ;; transient-state)) ;; (dolist (binding ',bindings) ;; (push binding ,add-bindings))))) (defun spacemacs//transient-state-func-name (name) "Return the name of the transient state function." (intern (format "spacemacs/%S-transient-state" name))) (defun spacemacs//transient-state-body-func-name (name) "Return the name of the transient state function." (intern (format "spacemacs/%S-transient-state/body" name))) (defface spacemacs-transient-state-title-face '((t :inherit header-line)) "Face for title of transient states.") (defmacro spacemacs|define-transient-state (name &rest props) "Define a transient state called NAME. NAME is a symbol. Available PROPS: `:on-enter SEXP' Evaluate SEXP when the transient state is switched on. `:on-exit SEXP' Evaluate SEXP when leaving the transient state. `:doc STRING or SEXP' A docstring supported by `defhydra'. `:title STRING' Provide a title in the header of the transient state `:columns INTEGER' Automatically generate :doc with this many number of columns. `:hint BOOLEAN' Whether to automatically add hints to the docstring. Default is nil. `:foreign-keys SYMBOL' What to do when keys not bound in the transient state are entered. This can be nil (default), which means to exit the transient state, warn, which means to not exit but warn the user that the key is not part of the transient state, or run, which means to try to run the key binding without exiting. `:entry-binding MAP KEY' Key binding to use for entering the transient state. `:bindings EXPRESSIONS' One or several EXPRESSIONS with the form (STRING1 SYMBOL1 DOCSTRING :exit SYMBOL) where: - STRING1 is a key to be bound to the function or key map SYMBOL1. - DOCSTRING is a STRING or an SEXP that evaluates to a string - :exit SYMBOL or SEXP, if non nil then pressing this key will leave the transient state (default is nil). Important note: due to inner working of transient-maps in Emacs the `:exit' keyword is evaluate *before* the actual execution of the bound command. All properties supported by `spacemacs//create-key-binding-form' can be used." (declare (indent 1)) (let* ((func (spacemacs//transient-state-func-name name)) (body-func (spacemacs//transient-state-body-func-name name)) (entry-binding (spacemacs/mplist-get props :entry-binding)) (add-bindings (intern (format "spacemacs-%s-transient-state-add-bindings" name))) (remove-bindings (intern (format "spacemacs-%s-transient-state-remove-bindings" name))) (bindings (spacemacs/mplist-get props :bindings)) (bindings (if (and (boundp remove-bindings) (listp (symbol-value remove-bindings))) (cl-remove-if (lambda (bnd) (member (car bnd) (symbol-value remove-bindings))) bindings) bindings)) (bindings (append bindings (when (and (boundp add-bindings) (listp (symbol-value add-bindings))) (symbol-value add-bindings)))) (doc (or (plist-get props :doc) "\n")) (title (plist-get props :title)) (hint-var (intern (format "%s/hint" func))) (columns (plist-get props :columns)) (entry-sexp (plist-get props :on-enter)) (exit-sexp (plist-get props :on-exit)) (hint (plist-get props :hint)) (foreign-keys (plist-get props :foreign-keys)) (bindkeys (spacemacs//create-key-binding-form props body-func))) `(progn (defhydra ,func (,(car entry-binding) ,(cadr entry-binding) :hint ,hint :columns ,columns :foreign-keys ,foreign-keys :body-pre ,entry-sexp :before-exit ,exit-sexp) ,doc ,@bindings) (when ,title (setq ,hint-var (list 'concat (propertize ,title 'face 'spacemacs-transient-state-title-face) "\n" ,hint-var))) ,@bindkeys))) (provide 'core-micro-state)