;;!emacs
;; $Id:
;;
;; FILE:         hib-kbd.el
;; SUMMARY:      Implicit button type for key sequences delimited with {}.
;; USAGE:        GNU Emacs Lisp Library
;;
;; AUTHOR:       Bob Weiner
;; ORG:          Brown U.
;;
;; ORIG-DATE:    22-Nov-91 at 01:37:57
;; LAST-MOD:     30-Sep-92 at 20:04:46 by Bob Weiner
;;
;; This file is part of Hyperbole.
;; 
;; Copyright (C) 1991, Brown University, Providence, RI
;; Developed with support from Motorola Inc.
;; 
;; Permission to use, modify and redistribute this software and its
;; documentation for any purpose other than its incorporation into a
;; commercial product is hereby granted without fee.  A distribution fee
;; may be charged with any redistribution.  Any distribution requires
;; that the above copyright notice appear in all copies, that both that
;; copyright notice and this permission notice appear in supporting
;; documentation, and that neither the name of Brown University nor the
;; author's name be used in advertising or publicity pertaining to
;; distribution of the software without specific, written prior permission.
;; 
;; Brown University makes no representations about the suitability of this
;; software for any purpose.  It is provided "as is" without express or
;; implied warranty.
;;
;;
;; DESCRIPTION:  
;;
;;   A click of the Hyperbole execution key on a key sequence executes its
;;   command binding.
;;
;;   A click of the Hyperbole help key on a key sequence displays the
;;   documentation for its command binding.
;;
;;   Key sequences should be in human readable form, e.g. {C-b}.
;;   Forms such as {\C-b}, {\^b}, and {^b} will not be recognized.
;;
;; DESCRIP-END.

;;; ************************************************************************
;;; Public implicit button types
;;; ************************************************************************
  
(defact kbd-key (key-sequence)
  "Executes the function binding for KEY-SEQUENCE, delimited by {}.
Returns t if a KEY-SEQUENCE has a binding, else nil."
  (interactive "kKeyboard key to execute (no {}): ")
  (kbd-key:act key-sequence))

(defib kbd-key ()
  "Executes a key sequence delimited by curly braces.
Key sequences should be in human readable form, e.g. {C-b}.
Forms such as {\C-b}, {\^b}, and {^b} will not be recognized."
  (if (and (fboundp 'br-in-browser) (br-in-browser))
      nil
    (let* ((seq-and-pos (or (hbut:label-p t "{`" "'}" t)
			    (hbut:label-p t "{" "}" t)))
	   (key-sequence (car seq-and-pos))
	   (binding (and (stringp key-sequence)
			 (key-binding (kbd-key:normalize key-sequence)))))
      (and binding (not (integerp binding))
	   (ibut:label-set seq-and-pos)
	   (hact 'kbd-key key-sequence)))))

;;; ************************************************************************
;;; Public functions
;;; ************************************************************************

(defun kbd-key:act (key-sequence)
  "Executes the command binding for KEY-SEQUENCE.
Returns t if KEY-SEQUENCE has a binding, else nil."
  (interactive "kKeyboard key to execute (no {}): ")
  (setq current-prefix-arg nil) ;; kbd-key:normalize below sets it.
  (let ((binding (key-binding (kbd-key:normalize key-sequence))))
    (if binding
	(progn (call-interactively binding) t))))

(defun kbd-key:doc (key &optional full)
  "Shows first line of doc for binding of keyboard KEY in minibuffer.
With optional FULL, displays full documentation for command."
  (interactive "kKey sequence: \nP")
  (let* ((cmd (let ((cmd (key-binding (kbd-key:normalize key))))
		(if (not (integerp cmd)) cmd)))
	 (doc (and cmd (documentation cmd)))
	 (end-line))
    (if doc
	(or full
	    (setq end-line (string-match "[\n]" doc)
		  doc (substitute-command-keys (substring doc 0 end-line))))
      (setq doc (format "No documentation for {%s} %s" key (or cmd ""))))
    (if (and cmd doc)
	(if full
	    (describe-function cmd)
	  (message doc)))))

(defun kbd-key:help (but)
  "Display documentation for binding of keyboard key given by BUT's label."
  (let ((kbd-key (hbut:key-to-label (hattr:get but 'lbl-key))))
    (and kbd-key (kbd-key:doc kbd-key 'full))))

(defun kbd-key:normalize (key-sequence)
  "Returns KEY-SEQUENCE normalized into a form that can be parsed by commands."
  (interactive "kKeyboard key sequence to normalize (no {}): ")
  (let ((start) (end) (norm-key-seq (copy-sequence key-sequence))
	(obuf (current-buffer))
	(case-fold-search nil) (case-replace t))
    ;; Quote Control and Meta key names
    (setq norm-key-seq (hypb:replace-match-string
			"[ \t\n\^M]+" norm-key-seq "")
	  norm-key-seq (hypb:replace-match-string
			"@key{SPC}\\|SPC"    norm-key-seq "\040")
	  norm-key-seq (hypb:replace-match-string
			"@key{DEL}\\|DEL"    norm-key-seq "\177")
	  norm-key-seq (hypb:replace-match-string
			"@key{RET}\\|@key{RTN}\\|RET\\|RTN"
			norm-key-seq "\015")
	  norm-key-seq (hypb:replace-match-string
			"ESCESC" norm-key-seq "\233")
	  norm-key-seq (hypb:replace-match-string
			"@key{ESC}\\|ESC"    norm-key-seq "M-")
	  ;; Unqote special {} chars.
	  norm-key-seq (hypb:replace-match-string "\\\\\\([{}]\\)"
						  norm-key-seq "\\1")
	  )
    (while (string-match "\\`\\(C-u\\|M-\\)\\(-?[0-9]+\\)" norm-key-seq)
      (setq current-prefix-arg
	    (string-to-int (substring norm-key-seq (match-beginning 2)
				      (match-end 2)))
	    norm-key-seq (substring norm-key-seq (match-end 0))))
    (let (arg-val)
      (while (string-match "\\`C-u" norm-key-seq)
	(if (or (not (listp current-prefix-arg))
		(not (integerp (setq arg-val (car current-prefix-arg)))))
	    (setq current-prefix-arg '(1)
		  arg-val 1))
	(setq arg-val (* arg-val 4)
	      current-prefix-arg (cons arg-val nil)
	      norm-key-seq (substring norm-key-seq (match-end 0)))))
    (setq norm-key-seq (hypb:replace-match-string
			"C-\\(.\\)" norm-key-seq
			'(lambda (str)
			   (char-to-string
			    (1+ (- (downcase
				    (string-to-char
				     (substring str (match-beginning 1)
						(1+ (match-beginning 1)))))
				   ?a))))))
    (hypb:replace-match-string
     "M-\\(.\\)" norm-key-seq
     '(lambda (str)
	(char-to-string (+ (downcase (string-to-char
				      (substring str (match-beginning 1)
						 (1+ (match-beginning 1)))))
			   128))))))

(provide 'hib-kbd)