;;;
;;; Talk sites.
;;;
;;; ----------------------------------------------------------------------
;;; This file is part of ILOG Talk.
;;; Inquiries to ILOG S.A.
;;;              9 rue de Verdun, BP 85,
;;;              94253 Gentilly Cedex, France.
;;;
;;; Copyright (c) 1993-1996 by ILOG
;;; ----------------------------------------------------------------------
;;;
;;; Name prefixes:
;;;
;;; tm		General prefix for Talk Mode mode identifiers.
;;;

(require 'talk-macros)
(require 'talk-struct)
(require 'talk-groups)


;; Parameters
;; ----------
;;

(defvar tm:volatile-highlighting-p t
  "When set to T, the highlighting of a site, the creation of a region or
the insertion of characters automatically dehighlights any other site in the
buffer.")



;; Global variables
;; ----------------
;;

(defvar tm:max-text-line-length 120
  "Maximum length of a string the function tm:site-text-substring can
return.")


;; Buffer-specific variables
;; -------------------------
;;

(make-variable-buffer-local 'tml:highlighted-site)
;;  Contains the last buffer's highlighted site.
(set-default 'tml:highlighted-site ())


;; Site structure
;; --------------
;;
;; A site is a set of extents (ie, text intervals) in a given buffer.
;;

(tm:defstruct tm:site ()
   (bufname
    ;; Name of the buffer of the site.
    (extents default: ())
    ;; List of site's extents
    )
   (generic: tm:site-make-extent (self begin end))
   ;; Function to create an extent
   (generic: tm:site-delete-extent (self extent))
   ;; Function to delete an extent
   (generic: tm:site-highlight-extent (self extent))
   ;; Function to highlight a site extent
   (generic: tm:site-dehighlight-extent (self extent))
   ;; Function to dehighlight a site extent
   (generic: tm:site-show-extent (self extent herep gotop))
   ;; Function to show an extent. HEREP and GOTOP are the same as for
   ;; tm:show-buffer
   (generic: tm:site-extent-showable-p (self extent))
   ;; Return T if the site can be shown.
   (generic: tm:site-extent-hot-point (self extent))
   ;; Return the extent's hot point, when the point must be moved when
   ;; showing the site.
   (generic: tm:site-sticky-p (self))
   ;; Return T if the site is sticky, ie even when tm:volatile-highlighting-p
   ;; is true, it is not dehighlighted when another site is highlighted.
   (method: tm:site-make-extent)
   (method: tm:site-delete-extent)
   (method: tm:site-highlight-extent)
   (method: tm:site-dehighlight-extent)
   (method: tm:site-show-extent)
   (method: tm:site-extent-showable-p)
   (method: tm:site-extent-hot-point)
   (method: tm:site-sticky-p)
)

(tm:defmethod tm:site-sticky-p ((site tm:site))
  ())

(tm:defstruct tm:search-site tm:site
  ()
  (method: tm:site-highlight-extent))

(tm:defstruct tm:step-in-site tm:site
  ()
  (method: tm:site-highlight-extent))

(tm:defstruct tm:step-out-site tm:site
  ()
  (method: tm:site-highlight-extent)
  (method: tm:site-extent-hot-point))

(tm:defstruct tm:breakpoint-site tm:site
  ()
  (method: tm:site-make-extent)
  (method: tm:site-highlight-extent)
  (method: tm:site-sticky-p))

(tm:defstruct tm:error-site tm:site
  ()
  (method: tm:site-highlight-extent))

(tm:defmethod tm:site-sticky-p ((site tm:breakpoint-site))
  t)


;; Manipulation functions
;; ----------------------
;;

(defun tm:site-add-extent (site begin end)
  "Add to SITE an extent from BEGIN to END."
  (let* ((extent (tm:site-make-extent site begin end)))
    (tm:set-site-extents site (cons extent (tm:site-extents site)))))

(defun tm:site-showable-p (site)
  "Return T if any extent in SITE can be shown, and () otherwise."
  (let ((buffer (get-buffer (tm:site-bufname site)))
	(extents (tm:site-extents site)))
    (and buffer
	 (let ((result t))
	   (while (and extents result)
	     (setq result (tm:site-extent-showable-p site (car extents)))
	     (setq extents (cdr extents)))
	   result))))

(defun tm:site-show (site &optional herep gotop)
  "Highlight and show the first extent in SITE."
  (tm:site-highlight site)
  (let* ((extents (tm:site-extents site)))
    (if extents
	(tm:site-show-extent site (car extents) herep gotop)
      (let ((buffer (get-buffer (tm:site-bufname site))))
	(if buffer
	    (tm:show-buffer buffer herep gotop))))))

(defun tm:site-highlight (site)
  "Highlight all the extents in SITE."
  (if (and tm:volatile-highlighting-p
	   (not (tm:site-sticky-p site)))
      (let* ((bufname (tm:site-bufname site))
	     (buffer (get-buffer bufname)))
	(save-excursion
	  (set-buffer buffer)
	  (if tml:highlighted-site
	      (tm:site-dehighlight tml:highlighted-site))
	  (setq tml:highlighted-site site))))
  (let* ((extents (tm:site-extents site)))
    (while extents
      (tm:site-highlight-extent site (car extents))
      (setq extents (cdr extents)))))

(defun tm:site-dehighlight (site)
  "Dehighlight all the extents in SITE."
  (let* ((extents (tm:site-extents site)))
    (while extents
      (tm:site-dehighlight-extent site (car extents))
      (setq extents (cdr extents))))
  (if (eq site tml:highlighted-site)
      (setq tml:highlighted-site ())))

(defun tm:site-delete (site)
  "Delete all the extents in SITE."
  (let ((extents (tm:site-extents site)))
    (while extents
      (tm:site-delete-extent site (car extents))
      (setq extents (cdr extents))))
    (if (eq site tml:highlighted-site)
	(setq tml:highlighted-site ())))


;; Site text substring
;; -------------------
;;

(defun tm:site-text-substring (site &optional restrictp)
  "Return a string representing a summerization of the site.
If optional RESTRICTP is true, restrict the string to the site. Otherwise,
use the whole first line.
Return () if there is no text in the site."
  (let ((extent (car (tm:site-extents site)))
	(buffer (get-buffer (tm:site-bufname site))))
    (cond
     ((or (null extent) (null buffer))
      ())
     ((not (tm:site-extent-showable-p site extent))
      ())
     (t
      (save-excursion
	(set-buffer buffer)
	(let* ((start ())
	       (end ()))
	  (condition-case ()
	      (save-excursion
		(goto-char (tm:extent-start-position extent))
		(if (not restrictp)
		    (progn
		      (beginning-of-line)
		      (skip-chars-forward " \t")
		      (setq start (point))
		      (end-of-line)
		      (setq end (point)))
		  (progn
		    (setq start (point))
		    (setq end (tm:extent-end-position extent))
		    (end-of-line)
		    (if (> end (point))
			(setq end (point)))))
		(if (> (- end start) tm:max-text-line-length)
		    (setq end (+ start tm:max-text-line-length))))
	    (error (setq start ())))
	  (if (null start)
	      ()
	    (buffer-substring start end))))))))


;; Site for source expression
;; --------------------------
;;

(defun tm:site-add-source (site file start-line start-col
				end-line end-col symbol)
  "Update SITE to point in FILE between point at (START-LINE,
START-COL) and point at (END-LINE, END-COL); if SYMBOL if non-nil,
then it is a pair (package . pname) and the site is restricted to the
text matching with the corresponding symbol."
  (let* ((buffer (tm:find-file-noselect file))
	 (bufname (buffer-name buffer)))
    (tm:set-site-bufname site bufname)
    (save-excursion
      (set-buffer buffer)
      (save-excursion
	(let ((start (progn 
		       (goto-line start-line) 
		       (condition-case () (forward-char start-col) (error ()))
		       (point)))
	      (end (progn
		     (goto-line end-line)
		     (condition-case () (forward-char end-col) (error ()))
		     (point))))
	  (if (null symbol)
	      (tm:site-add-extent site start end)
	    (let* ((package (car symbol))
		   (pname (cdr symbol))
		   (regexp (tm:reference-regexp package pname buffer))
		   (pairs ()))
	      (goto-char start)
	      (while (re-search-forward regexp end t)
		(setq pairs (cons (cons (match-end 1)
					(1- (point)))
				  pairs)))
	      (if (null pairs)
		  (tm:site-add-extent site start end)
		(while (not (null pairs))
		  (let ((pair (car pairs)))
		    (tm:site-add-extent site (car pair) (cdr pair))
		    (setq pairs (cdr pairs))))))))))))

(defun tm:site-add-file (site file)
  "Update SITE to point, with no extent, in FILE."
  (let* ((buffer (tm:find-file-noselect file))
	 (bufname (buffer-name buffer)))
    (tm:set-site-bufname site bufname)))


;; Site groups
;; -----------
;;
;; A site group is a group of site items.
;;

(tm:defstruct tm:site-item tm:item
  (site
   ;; The site
   text
   ;; The text of the site
   ))

(tm:defstruct tm:site-group tm:group
  ()
  (method: tm:group-remove-item-hook)
  (method: tm:group-select-item-hook)
  (method: tm:group-deselect-item-hook)
  (method: tm:group-item-selectable-p)
  (method: tm:group-print-item)
  (method: tm:group-attach-buffer-hook)
  (method: tm:group-buffer-print-help))

(defvar tm:site-group-bufferp-map ()
  "Site group buffer keymap.")

(if tm:site-group-bufferp-map
    ()
  (setq tm:site-group-bufferp-map (copy-keymap tm:group-buffer-map))
  (define-key tm:site-group-bufferp-map "f" 'tmg:select-and-follow-site)
  (define-key tm:site-group-bufferp-map " " 'tmg:select-and-show-site))

(defun tm:site-group-add-item (group item site selectp restrictp)
  "Add ITEM to GROUP. The fields SITE and TEXT of ITEM are initialized
according to SITE. For SELECTP and RESTRICTP, see tm:group-add-item and
tm:site-text-substring."
  (tm:set-site-item-site item site)
  (tm:set-site-item-text item (tm:site-text-substring site restrictp))
  (tm:group-add-item group item selectp))

(tm:defmethod tm:group-remove-item-hook ((group tm:site-group) item)
  (tm:site-delete (tm:site-item-site item)))

(tm:defmethod tm:group-select-item-hook ((group tm:site-group) item)
  (let ((site (tm:site-item-site item)))
    (tm:site-highlight site)
    (cond
     ((null tm:*group-buffer-caller*))
     ((eq tm:*group-buffer-caller* 'buffer)
      (tm:site-show site () ()))
     ((eq tm:*group-buffer-caller* 'interactive)
      (tm:site-show site t t)))))

(tm:defmethod tm:group-deselect-item-hook ((group tm:site-group) item)
  (tm:site-dehighlight (tm:site-item-site item)))

(tm:defmethod tm:group-item-selectable-p ((group tm:site-group) item)
  (tm:site-showable-p (tm:site-item-site item)))

(tm:defmethod tm:group-print-item ((group tm:site-group) item)
  "Function to print a site item in a site group buffer."
  (tm:print-site-item-buffer item)
  (indent-to-column 20 1)
  (tm:print-site-item-text item))

(defun tm:print-site-item-buffer (item)
  "Function to insert a site item buffer name."
  (let* ((site (tm:site-item-site item))
	 (bufname (tm:site-bufname site)))
    (if (get-buffer bufname)
	(insert bufname)
      (insert bufname " killed"))))

(defun tm:print-site-item-lineno (item)
  "Function to insert a site item line number."
  (let* ((site (tm:site-item-site item))
	 (extents (tm:site-extents site)))
    (if (or (not (tm:site-showable-p site)) (null extents))
	(insert "       ")
      (let* ((bufname (tm:site-bufname site))
	     (buffer (get-buffer bufname))
	     (lineno (save-excursion
		       (set-buffer buffer)
		       (save-excursion
			 (goto-char (tm:extent-start-position (car extents)))
			 (tm:current-line)))))
	(insert (format "%5d: " lineno))))))

(defun tm:print-site-item-text (item)
  "Insert on one line a summerization of the site item site."
  (let* ((site (tm:site-item-site item))
	 (text (tm:site-item-text item)))
    (if text (insert text))))

(tm:defmethod tm:group-attach-buffer-hook ((group tm:site-group))
  (use-local-map tm:site-group-bufferp-map))

(defun tmg:select-and-follow-site ()
  "Select and follow the currently pointed item."
  (interactive)
  (let ((tm:*group-buffer-caller* 'buffer))
    (let ((item (tmg:select-point-item)))
      (if item
	  (let ((site (tm:site-item-site item)))
	    (if (not (tm:site-showable-p site))
		(error "cannot follow this site")
	      (tm:site-show site () t)))))))

(defun tmg:select-and-show-site ()
  "Select and show the currently pointed item."
  (interactive)
  (let ((tm:*group-buffer-caller* 'buffer))
    (let ((item (tmg:select-point-item)))
      (if item
	  (let ((site (tm:site-item-site item)))
	    (if (not (tm:site-showable-p site))
		(error "cannot show this site")
	      (tm:site-show site () ())))))))

(defvar tm:site-group-buffer-help
  "f\tfollow the source"
  "Additional help message while in site group buffer")

(tm:defmethod tm:group-buffer-print-help ((group tm:site-group))
  (call-method tm:group-buffer-print-help tm:group group)
  (princ tm:site-group-buffer-help))


;; Site groups utilities
;; ---------------------
;;

(defun tm:site-group-closest-item (group)
  "Return the item whose site is closest to the current point and on the
same line, or () if not found."
  (let ((items (tm:group-items group))
	(found-item ())
	(min-point (point))
	(max-point (save-excursion (end-of-line) (point))))
    (while items
      (let* ((item (car items))
	     (site (tm:site-item-site item))
	     (extents (tm:site-extents site)))
	(if extents
	    (let* ((extent (car extents))
		   (start-pos (tm:extent-start-position extent)))
	      (if (and (>= start-pos min-point)
		       (<= start-pos max-point))
		  (progn
		    (setq found-item item)
		    (setq max-point start-pos)))))
	(setq items (cdr items))))
    found-item))

(if emacs19p
    (require 'talk-sites19)
  (require 'talk-sites18))

(provide 'talk-sites)
