;;!emacs
;; $Id: 
;;
;; FILE:         hibtypes.el
;; SUMMARY:      Hyperbole System Implicit Button Types.
;; USAGE:        GNU Emacs Lisp Library
;;
;; AUTHOR:       Bob Weiner
;; ORG:          Brown U.
;;
;; ORIG-DATE:    19-Sep-91 at 20:45:31
;; LAST-MOD:     11-Oct-92 at 14:48:33 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:  
;;
;;   See doc for 'ibtype:create' for details on implicit button type creation.
;;
;;   Define implicit button types in REVERSE order that you want their
;;   predicates tested by the Hyperbole evaluator, i.e. most important last.
;;
;;   Each implicit button type should use the 'ibut:label-set' to setup any
;;   button label attributes before performing an action.
;;
;;   Actions are performed by calling 'hact' with an actype and any number of
;;   arguments that the actype takes.
;;
;; DESCRIP-END.

;;; ************************************************************************
;;; Other required Elisp libraries
;;; ************************************************************************

(require 'hactypes)

;;; ************************************************************************
;;; Public implicit button types
;;; ************************************************************************
  
(run-hooks 'hibtypes:begin-load-hook)

;;; ========================================================================
;;; Handles internal references within an annotated bibliography, delimiters=[]
;;; ========================================================================

(defib annot-bib ()
  "Displays annotated bibliography entries referenced internally.
References must be delimited by square brackets, must begin with a
word constituent character, and must not be in buffers whose
names begin with a ' ' or '*' character."
  (and (not (bolp))
       (let ((chr (aref (buffer-name) 0)))
	 (not (or (= chr ? ) (= chr ?*))))
       (let* ((ref-and-pos (hbut:label-p t "[" "]" t))
	      (ref (car ref-and-pos)))
	 (and ref (= ?w (char-syntax (aref ref 0)))
	      (progn (ibut:label-set ref-and-pos)
		     (hact 'annot-bib ref))))))

;;; ========================================================================
;;; Summarizes an Internet rfc for random access browsing by section.
;;; ========================================================================

(defib rfc-toc ()
  "Summarizes contents of an Internet rfc from anywhere within rfc buffer.
Each line in summary may be selected to jump to section."
  (let ((case-fold-search t)
	(toc)
	(opoint (point)))
    (if (and (string-match "rfc" (buffer-name))
	     (goto-char (point-min))
	     (progn (setq toc (search-forward "Table of Contents" nil t))
		    (re-search-forward "^[ \t]*1.0?[ \t]+[^ \t\n]" nil t
				       (and toc 2))))
	(progn (beginning-of-line)
	       (ibut:label-set (buffer-name))
	       (hact 'rfc-toc (buffer-name) opoint))
      (goto-char opoint)
      nil)))

;;; ========================================================================
;;; Makes directory summaries into file list menus.
;;; ========================================================================

(defib dir-summary ()
  "Detects filename buttons in files named \"MANIFEST\" or \"DIR\".
Displays selected files.
Each file name must be at the beginning of the line and must be followed
by one or more spaces and then another non-space, non-parenthesis, non-brace
character."
  (if buffer-file-name
      (let ((file (file-name-nondirectory buffer-file-name))
	    entry start end)
	(if (or (string= file "DIR") (string= file "MANIFEST"))
	    (save-excursion
	      (beginning-of-line)
	      (if (looking-at "\\([^(){}* \t\n]+\\)[ \t]+[^(){}* \t\n]")
		  (progn
		    (setq entry (buffer-substring
				 (match-beginning 1) (match-end 1))
			  start (match-beginning 1)
			  end (match-end 1))
		    (if (file-exists-p entry)
			(progn (ibut:label-set entry start end)
			       (hact 'link-to-file entry))))))))))

;;; ========================================================================
;;; Executes or documents command bindings of brace delimited key sequences.
;;; ========================================================================

(require 'hib-kbd)

;;; ========================================================================
;;; Jumps to source line associated with grep or compilation error messages.
;;; With credit to Michael Lipp and Mike Williams for the idea.
;;; ========================================================================

(defib grep-msg ()
  "Jumps to line associated with grep or compilation error msgs.
Messages are recognized in any buffer."
  (progn
    (if (equal (buffer-name) "*compilation*")
	(progn
	  (require 'compile)
	  ;; Make sure we have a parsed error-list
	  (if (eq compilation-error-list t)
	      (progn (compilation-forget-errors)
		     (setq compilation-parsing-end 1)))
	  (if (not compilation-error-list)
	      (save-excursion
		(set-buffer-modified-p nil)
		(compilation-parse-errors)))))
    ;; Locate and parse grep messages found in any buffer.
    (let* ((file) (line-num) (but-label))
      (save-excursion
	(beginning-of-line)
	(if (looking-at "\\([^ \t\n\^M]+\\):\\([0-9]+\\):")
	    (progn
	      (setq file (buffer-substring (match-beginning 1)
					   (match-end 1))
		    line-num (buffer-substring (match-beginning 2)
					       (match-end 2))
		    but-label (concat file ":" line-num)
		    line-num (string-to-int line-num))
	      (ibut:label-set but-label)
	      (hact 'link-to-file-line file line-num)))))))

;;; ========================================================================
;;; Makes Internet RFC references retrieve the RFC.
;;; ========================================================================

(defib rfc ()
  "Retrieves and displays an Internet rfc referenced at point.
Requires ange-ftp.  The following formats are recognized:  RFC822, rfc-822,
and RFC 822."
  (if (and (featurep 'ange-ftp) (not (eq major-mode 'dired-mode)))
      (let ((case-fold-search t)
	    (rfc-num nil))
	(save-excursion
	  (skip-chars-backward "-rRfFcC0-9")
	  (if (looking-at "rfc[- ]?\\([0-9]+\\)")
	      (progn
		(setq rfc-num 
		      (buffer-substring (match-beginning 1) (match-end 1)))
		(ibut:label-set
		 (buffer-substring (match-beginning 0) (match-end 0)))
		(hact 'link-to-rfc rfc-num)))))))

;;; ========================================================================
;;; Makes Hyperbole mail addresses output Hyperbole envir info.
;;; ========================================================================

(defib hyp-address ()
  "Makes Hyperbole mail address a button which inserts Hyperbole envir info.
Useful when sending mail to a Hyperbole mail list.
See `hyp-envir' action type."
  (if (memq major-mode (list hmail:composer hnews:composer))
      (let ((addr (find-tag-default)))
	(cond ((set:member addr (list "hyperbole" "hyperbole@cs.brown.edu"))
	       (hact 'hyp-config))
	      ((set:member addr
			   (list "hyperbole-request"
				 "hyperbole-request@cs.brown.edu"))
	       (hact 'hyp-request))
	      ))))

;;; ========================================================================
;;; Makes source entries in Hyperbole reports selectable.
;;; ========================================================================

(defib hyp-source ()
  "Makes source entries in Hyperbole reports into buttons that jump to source."
  (save-excursion
    (beginning-of-line)
    (if (looking-at hbut:source-prefix)
	(let ((src (hbut:source)))
	  (if src
	      (progn (if (not (stringp src)) (setq src (prin1-to-string src)))
		     (ibut:label-set src (point) (progn (end-of-line) (point)))
		     (hact 'hyp-source src)))))))

;;; ========================================================================
;;; Shows man page associated with a man apropos entry.
;;; ========================================================================

(defib man-apropos ()
  "Makes man apropos entries display associated man pages when selected."
  (save-excursion
    (beginning-of-line)
    (let ((nm "[^ \t\n!@,][^ \t\n,]*")
	  topic)
      (and (looking-at
	    (concat
	     "^\\(\\*[ \t]+[!@]\\)?\\(" nm "[ \t]*,[ \t]*\\)*\\(" nm "\\)[ \t]*"
	     "\\(([-0-9a-zA-z]+)\\)\\(::\\)?[ \t]+-[ \t]+[^ \t\n]"))
	   (setq topic
		 (concat (buffer-substring (match-beginning 3) (match-end 3))
			 (buffer-substring (match-beginning 4) (match-end 4))))
	   (ibut:label-set topic (match-beginning 3) (match-end 4))
	   (hact 'man-show topic)))))

;;; ========================================================================
;;; Displays files and directories when double quoted pathname is activated.
;;; ========================================================================

(defib pathname ()
  "Makes a delimited, valid pathname display the path entry.
Also works for delimited and non-delimited ange-ftp pathnames.
See 'hpath:at-p' for possible delimiters."
     (let ((path (hpath:at-p)))
       (if path
	   (progn (ibut:label-set path)
		  (hact 'link-to-file path)))))

;;; ========================================================================
;;; Displays Info nodes when double quoted "(file)node" button is activated.
;;; ========================================================================

(defib Info-node ()
  "Makes \"(file)node\" buttons display the associated Info node."
  (let ((node-ref (hpath:is-p (hbut:label-p t "\"" "\"") nil t)))
    (and node-ref (string-match "([^\)]+)" node-ref)
	 (ibut:label-set node-ref)
	 (hact 'link-to-Info-node node-ref))))


(run-hooks 'hibtypes:end-load-hook)
(provide 'hibtypes)