lisp/yard.el

   1 ;;; The Emacs Lisp YARD: Yet Another Run command Directory. Some
   2 ;;; useful Emacs Lisp functions for my Emacs rc files. Any
   3 ;;; similarities to snippets of elisp found around the web may or may
   4 ;;; not be accidental.
   5
   6 (defun yard-directory-sub-directories (dirs)
   7   "Returns a list of the subdirectories for each directory in dirs."
   8   (delq nil
   9         (mapcar (lambda (x) (and (file-directory-p x) x))
  10                 (apply 'append
  11                        (let (sub-dirs)
  12                          (dolist (dir dirs sub-dirs)
  13                            (setq sub-dirs
  14                                  (cons (directory-files dir t "[[:word:]]+")
  15                                        sub-dirs))))))))
  16
  17 ;;; Helpers for setting up Lisp indentation.
  18 (defun yard-set-lisp-indent (indent-function)
  19   (set (make-local-variable 'lisp-indent-function) indent-function))
  20
  21 (defun yard-set-elisp-indent ()
  22   (yard-set-lisp-indent 'lisp-indent-function))
  23
  24 (defun yard-set-common-lisp-indent ()
  25   (yard-set-lisp-indent 'common-lisp-indent-function))
  26
  27 ;;; Functions for opening a file as root with tramp.
  28 (defvar yard-root-find-file-prefix "/sudo:root@localhost:"
  29   "The prefix used to open a file with `yard-root-find-file'.")
  30
  31 (defvar yard-root-find-file-history nil
  32   "A list holding files previously opened with `yard-root-find-file'.")
  33
  34 (defvar yard-root-find-file-hook nil
  35   "A hook for functions to run after a file has been opened with
  36   `yard-root-find-file'.")
  37
  38 (defun yard-root-find-file ()
  39   "Open a file as the root user. Prepends
  40   `yard-root-find-file-prefix' to the selected file name for
  41   access with tramp."
  42   (interactive)
  43   (require 'tramp)
  44   (let* ((file-name-history yard-root-find-file-history)
  45          (name (or buffer-file-name default-directory))
  46          (tramp (and (tramp-tramp-file-p name)
  47                      (tramp-dissect-file-name name)))
  48          path dir file)
  49     (when tramp
  50       (setq path (tramp-file-name-localname tramp)
  51             dir (file-name-directory path)))
  52     (when (setq file (read-file-name "Find file (root): " dir path))
  53       (find-file (concat yard-root-find-file-prefix file))
  54       (setq yard-root-find-file-history file-name-history)
  55       (run-hooks yard-root-find-file-hook))))
  56
  57 ;;; Toggle window dedication to lock or pin a window.
  58 (defun yard-toggle-window-dedication ()
  59   "Toggles a window from dedicated to not dedicated. See Info
  60 node `Dedicated Windows'."
  61   (interactive)
  62   (let ((window (selected-window)))
  63     (set-window-dedicated-p window
  64                             (not (window-dedicated-p window)))
  65     (message (if (window-dedicated-p window)
  66                  "Window %s dedicated"
  67                "Window %s not dedicated")
  68              window)))
  69
  70 (defun yard-slime-send-dwim (arg)
  71   "Send the code form you want to SLIME (Do What I Mean)
  72 If the region is active it is copied to the SLIME REPL.
  73 Else, if the point is at an opening paren the sexp immediately
  74 following the point is copied to the SLIME REPL.
  75 Else, if the point directly after a closing paren, the sexp
  76 immediately preceding the point is copied to the SLIME REPL.
  77 Else, the top level sexp enclosing the point is copied to the
  78 SLIME REPL."
  79   (interactive "P")
  80   (save-excursion
  81     (cond (mark-active
  82            (copy-region-as-kill (mark) (point)))
  83           ((eq (char-after) ?\()
  84            (let ((beg (point))
  85                  (end (save-excursion (forward-sexp) (point))))
  86              (copy-region-as-kill beg end)))
  87           ((eq (char-before) ?\))
  88            (let ((end (point))
  89                  (beg (save-excursion (backward-sexp) (point))))
  90              (copy-region-as-kill beg end)))
  91           (t
  92            (let* ((beg (progn (beginning-of-defun)
  93                               (point)))
  94                  (end (save-excursion (end-of-defun) (point))))
  95              (copy-region-as-kill beg end))))
  96     (save-window-excursion
  97       (switch-to-buffer (slime-output-buffer))
  98       (goto-char (point-max))
  99       (when (string-match "\n\\|
" (car kill-ring))
 100         (slime-repl-newline-and-indent))
 101       (yank)
 102       (when arg
 103         (slime-repl-return)))))
 104
 105 (defun yard-enclose-region-in-src-block ()
 106   (interactive)
 107   (let* ((beg (if (region-active-p) (region-beginning) (point)))
 108          (end (if (region-active-p) (region-end) (point))))
 109     (goto-char end)
 110     (unless (eq (char-before) ?\n) (insert "\n"))
 111     (insert "#+END_SRC\n")
 112     (goto-char beg)
 113     (beginning-of-line)
 114     (insert "#+BEGIN_SRC\n")
 115     (backward-char)))
 116
 117 ;;; Automatic minor modes.
 118 (defvar yard-auto-minor-mode-alist ()
 119   "Alist of file name patterns vs corresponding minor mode
 120 functions. Closely mimics `auto-mode-alist'.")
 121
 122 (defun yard-set-auto-minor-mode ()
 123   "Select minor modes appropriate for curent buffer.
 124
 125 To find the right minor modes, this function compares the
 126 filename against all entries in `yard-auto-minor-mode-alist' and
 127 enables the specified minor modes."
 128   (when buffer-file-name
 129     (let ((remote-id (file-remote-p buffer-file-name))
 130           (name buffer-file-name))
 131       ;; Clean up the file name for this buffer.
 132       (setq name (file-name-sans-versions name))
 133       (when (and (stringp remote-id)
 134                  (string-match-p (regexp-quote remote-id) name))
 135         (setq name (substring name (match-end 0))))
 136       (dolist (entry yard-auto-minor-mode-alist)
 137         (when (and (car entry) (cdr entry))
 138           (if (string-match (car entry) name)
 139               (funcall (cdr entry))))))))
 140
 141 (defvar yard-super-meta-mode-syntax-table
 142   (let ((table (make-syntax-table lisp-mode-syntax-table)))
 143     (modify-syntax-entry ?\@ "'" table)
 144     (modify-syntax-entry ?\$ "'" table)
 145     (modify-syntax-entry ?\! "'" table)
 146     (modify-syntax-entry ?\% "'" table)
 147     (modify-syntax-entry ?\? "'" table)
 148     (modify-syntax-entry ?\{ "(}" table)
 149     (modify-syntax-entry ?\} "){" table)
 150     (modify-syntax-entry ?\[ "(]" table)
 151     (modify-syntax-entry ?\] ")[" table)
 152     table)
 153   "Syntax table used in `yard-super-meta-mode'.")
 154
 155 (define-derived-mode yard-super-meta-mode lisp-mode
 156   "Super Meta"
 157   "Major mode for editing documents using the Super Meta embedded
 158   DSL (as Embedded in Common Lisp)."
 159   :syntax-table yard-super-meta-mode-syntax-table
 160   (define-key paredit-mode-map
 161     (kbd "{") 'paredit-open-curly)
 162   (define-key paredit-mode-map
 163     (kbd "}") 'paredit-close-curly))
 164
 165 (defvar yard-terminal-counter 1)
 166
 167 (defadvice term (after yard-rename-term-buffer first () disable)
 168   "Rename the buffer created by ``term'' in order to support
 169 multiple buffers created this way."
 170   (rename-buffer (concat "*terminal-"
 171                          (number-to-string yard-terminal-counter)
 172                          "*")
 173                  t)
 174   (incf yard-terminal-counter))
 175
 176 (defun yard-sort-words (reverse beginning end)
 177   "Sort words in region alphabetically. Prefixed with negative
 178 \\[universal-argument], sorts in referse.
 179
 180 The variable `sort-fold-case' determines whether alphabetic case
 181 affects the sort order.
 182
 183 See `sort-regexp-fields'."
 184   (interactive "*P\nr")
 185   (sort-regexp-fields reverse "\\w+" "\\&" beginning end))
 186
 187 (defun yard-get-environment-path ()
 188   "Return a list of the paths in the environment variable PATH."
 189   (split-string (getenv "PATH") path-separator))