dot/emacs: Bind a key to `magit-toggle-buffer-lock'.

[profile] / bin / hyperspec

#! /bin/sh
'': "-*-emacs-lisp-*-"; exec emacs --no-site-file --batch --load "$0" -- "$@"
;;;
;;; Look things up in the Common Lisp Hyperspec.
;;;
;;; (c) 2008 Mark Wooding
;;;

;;;----- Licensing notice ---------------------------------------------------
;;;
;;; 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 2 of the License, 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; if not, write to the Free Software
;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA

;;;--------------------------------------------------------------------------
;;; External dependencies.

;; We need the hyperspec library, obviously.
(require 'hyperspec)

;; The init file probably has customizations for the Hyperspec library, in
;; particular where the local Hyperspec files are.
;;
;; Hacking here to suppress messages from the init file, and also to protect
;; us from errors in it.
(setq mdw-fast-startup t)
(let ((original-message (symbol-function 'message)))
  (unwind-protect
      (progn
	(fset 'message #'(lambda (&rest hunoz) nil))
	(condition-case signal (load-file "~/.emacs")
	  (error (funcall original-message
			  "hyperspec (warning): .emacs erred: %s."
			  signal))))
    (fset 'message original-message)))

;; No.
(setq kill-emacs-hook nil)

;;;--------------------------------------------------------------------------
;;; Utilities.

(defvar quis "hyperspec")

(defun die (&rest format-args)
  (message "%s: %s" quis (apply #'format format-args))
  (kill-emacs 1))

(defvar usage-string "Usage: hyperspec -l | KEY")

(defun die-usage ()
  (message "%s" usage-string)
  (kill-emacs 1))

;;;--------------------------------------------------------------------------
;;; Look up a string and find its URL in the Hyperspec.

(defmacro some-var (&rest vars)
  (let ((v (gensym)))
    `(let ((,v (find-if #'boundp ',vars)))
       (if ,v (symbol-value ,v)
	 (error "huh")))))

(defun hyperspec-urls (key)
  "Return a list of hyperspec URLs corresponding to KEY."
  (let ((urls nil)
	(lookups (list (list (downcase key)
			     (some-var common-lisp-hyperspec--symbols
				       common-lisp-hyperspec-symbols)
			     #'(lambda (values)
				 (mapcar (lambda (value)
					   (concat common-lisp-hyperspec-root
						   "Body/"
						   value))
					 values)))
		       (list (downcase key)
			     (some-var common-lisp-hyperspec--issuex-symbols
				       common-lisp-hyperspec-issuex-symbols)
			     #'(lambda (value)
				 (list (concat common-lisp-hyperspec-root
					       "Issues/"
					       value)))))))
    (when (= (aref key 0) ?~)
      (push (list (substring key 1)
		  (some-var common-lisp-hyperspec--format-characters
			    common-lisp-hyperspec-format-characters)
		  #'(lambda (values)
		      (mapcar #'common-lisp-hyperspec-section
			      values)))
	    lookups))
    (dolist (lookup lookups)
      (let* ((name (car lookup))
	     (table (cadr lookup))
	     (format (car (cddr lookup)))
	     (value (cond ((vectorp table)
			   (let ((symbol (intern-soft name table)))
			     (and symbol
				  (boundp symbol)
				  (symbol-value symbol))))
			  ((hash-table-p table)
			   (gethash name table))
			  (t
			   (error "what even?")))))
	(when value
	  (setq urls (nconc urls (funcall format value))))))
    urls))

(defun good-symbols (table &optional filter)
  "Return the list of bound symbols in TABLE for which FILTER returns
non-nil; FILTER defaults to always-true if unspecified."
  (let ((syms nil))
    (cond ((vectorp table)
	   (mapatoms (lambda (sym)
		       (when (and (boundp sym)
				  (or (not filter)
				      (funcall filter sym)))
			 (push (symbol-name sym) syms)))
		     table))
	  ((hash-table-p table)
	   (maphash (lambda (key value)
		      (when (or (not filter) (funcall filter key))
			(push key syms)))
		    table))
	  (t
	   (error "what even?")))
    (sort syms #'string<)))

(defun hyperspec-keys ()
  "Return the list of all valid hyperspec lookup keys.  Useful for
completion."
  (nconc (good-symbols (some-var common-lisp-hyperspec--symbols
				 common-lisp-hyperspec-symbols))
	 (mapcar #'(lambda (name)
		     (format "~%c" (aref name 0)))
		 (good-symbols (some-var common-lisp-hyperspec--format-characters
					 common-lisp-hyperspec-format-characters)
			       #'(lambda (name)
				   (and (>= (length name) 3)
					(= (aref name 2) ?-)
					(let ((ch (aref name 0)))
					  (= ch (downcase ch)))))))
	 (good-symbols (some-var common-lisp-hyperspec--issuex-symbols
				 common-lisp-hyperspec-issuex-symbols))))

;;;--------------------------------------------------------------------------
;;; Parse the command line.

(defvar key nil)
(defvar mode 'url)

(defvar options
  '((("-h" "--help") . help)
    (("-l" "--list") . (lambda () (setq mode 'list)))))

(defun help ()
  (princ usage-string)
  (princ "

Write to stdout a URL to the Hyperspec page describing KEY.

Options:
  -h, --help		Show this help message.
  -l, --list		Write to stdout a list of acceptable KEYS.
")
  (kill-emacs))

;; Parse the command-line options.
(pop command-line-args-left)
(catch 'done
  (while t
    (unless command-line-args-left
      (throw 'done nil))
    (let ((opt (pop command-line-args-left)))
      (cond ((string= opt "--")
	     (throw 'done nil))
	    ((not (eq (aref opt 0) ?-))
	     (push opt command-line-args-left)
	     (throw 'done nil))
	    (t
	     (catch 'found
	       (dolist (def options)
		 (when (member opt (car def))
		   (funcall (cdr def))
		   (throw 'found nil)))
	       (die "Unknown option `%s'." opt)))))))

;; Check the non-option arguments.
(cond ((eq mode 'url)
       (unless (= (length command-line-args-left) 1)
	 (die-usage))
       (let* ((key (car command-line-args-left))
	      (urls (hyperspec-urls key)))
	 (mapcar #'(lambda (url) (princ url) (terpri)) urls)))
      ((eq mode 'list)
       (unless (null command-line-args-left)
	 (die-usage))
       (mapc (lambda (item) (princ item) (terpri))
	     (hyperspec-keys))))

;;;----- That's all, folks --------------------------------------------------