;;;
;;; Communication utilities.
;;;
;;; ----------------------------------------------------------------------
;;; 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
;;; ----------------------------------------------------------------------
;;;


(require 'talk-mode)
(require 'talk-groups)
(require 'talk-sites)

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

(defvar ts:database-query-p t
  "When true, query databases to search definitions.")


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

(defvar ts:talk-eval-format "(internal.emacs-eval)"
  "Talk command to evaluate an expression.")

(defvar ts:talk-macroexpand-format "(internal.emacs-macroexpand %s %s)"
  "Talk command to macroexpand an expression.")

(defvar ts:talk-who-exports-format "(internal.emacs-who-exports '%s)"
  "Talk command to get the exporters of a definition.")

(defvar ts:talk-which-format "(internal.emacs-which '%s '%s)"
  "Talk command to get the path of a program unit.")

(defvar ts:talk-analyze-format "(internal.emacs-analyze '%s)"
  "Talk command to analyze a program unit.")

(defvar ts:talk-analyze-build-format "(internal.emacs-build '%s)"
  "Talk command to analyze and build a program unit.")

(defvar ts:talk-update-load-format "(internal.emacs-update '%s 'load)"
  "Talk command to update-load a program unit.")

(defvar ts:talk-update-analyze-format "(internal.emacs-update '%s 'analyze)"
  "Talk command to update-analyze a program unit.")

(defvar ts:talk-update-analyze-build-format 
  "(internal.emacs-update '%s 'build)"
  "Talk command to update a program unit.")

(defvar ts:talk-load-format "(internal.emacs-load '%s %s)"
  "Talk command to load a program unit.")

(defvar ts:talk-in-workspace-format "(internal.emacs-in-workspace '%s)"
  "Talk command to put ourselves into a workspace.")

(defvar ts:talk-test-format "(internal.emacs-test '%s)"
  "Talk command to test a program unit.")

(defvar ts:talk-set-breakpoint-format
  "(internal.emacs-set-breakpoint '%s %s %s)"
  "Talk command to set a breakpoint.")

(defvar ts:talk-clear-breakpoint-format
  "(internal.emacs-clear-breakpoint %s)"
  "Talk command to clear a breakpoint.")

(defvar ts:macroexpansion-buffer-name "*Macroexpansion*"
  "Name of the buffer used to show macro-expansions.")

(defvar tm:breakpoint-buffer-format "*Breakpoints%s*"
  "Buffer name for breakpoint site group.")


;; Key maps
;; --------
;;

(global-set-key "\C-c\C-p"	'ts:edit-prunit-group)
(global-set-key "\C-c?"		'ts:edit-error-sites)

(define-key tm:talk-mode-map "\C-c\C-e" 'ts:eval-expression)
(define-key tm:talk-mode-map "\C-c\C-m" 'ts:macroexpand-expression)
(define-key tm:talk-mode-map "\C-c\C-b" 'ts:analyze-build-this-program-unit)
(define-key tm:talk-mode-map "\C-c\C-u\C-b"
  'ts:update-analyze-build-this-program-unit)
(define-key tm:talk-mode-map "\C-c\C-l" 'ts:load-this-program-unit)
(define-key tm:talk-mode-map "\C-c\C-u\C-l"
  'ts:update-load-this-program-unit)
(define-key tm:talk-mode-map "\C-c\C-w" 'ts:in-this-workspace)
(define-key tm:talk-mode-map "\C-c\C-i" 'ts:load-this-program-unit-interpreted)
(define-key tm:talk-mode-map "\C-c\C-a" 'ts:analyze-this-program-unit)
(define-key tm:talk-mode-map "\C-c\C-u\C-a" 
  'ts:update-analyze-this-program-unit)
(define-key tm:talk-mode-map "\C-c\C-t" 'ts:test-this-program-unit)
(define-key tm:talk-mode-map "\C-c/"	'ts:set-breakpoint)
(define-key tm:talk-mode-map "\C-c\C-d" 'ts:clear-breakpoint)
(define-key tm:talk-mode-map "\C-c\C-q?" 'ts:edit-breakpoint-sites)
(define-key tm:talk-mode-map "\C-c,"	'ts:error-site-next)
(define-key tm:talk-mode-map "\C-c'"	'ts:error-site-previous)
(define-key tm:talk-mode-map "\C-c="	'ts:error-site-current)
(define-key tm:talk-mode-map "\C-c\C-f" 'ts:find-program-unit)


;; Expression evaluation
;; ---------------------
;;

(defun ts:eval-expression ()
  "Evaluate the current expression with the current Talk server."
  (interactive)
  (let* ((sexp (tm:sexp-at-point))
	 (start (car sexp))
	 (end (cdr sexp))
	 (server (ts:get-current-server))
	 (buffer (current-buffer))
	 (package (tm:buffer-read-package buffer)))
    (ts:insert-pseudo-input-region server buffer start end)
    (ts:send-form server package buffer start end)
    (ts:remote-eval (format ts:talk-eval-format) server)))

(defun ts:insert-pseudo-input-region (server source-buffer start end)
  (let ((process (ts:get-server-talk-process server)))
    (if process
	(let ((buffer (process-buffer process)))
	  (tm:show-buffer buffer () () 'end)
	  (save-excursion
	    (set-buffer buffer)
	    (tpp:insert-buffer-substring source-buffer start end
					 tp:max-pseudo-input-lines
					 'pseudo-user-input))))))

(defun ts:insert-pseudo-input (server string)
  (let ((process (ts:get-server-talk-process server)))
    (if process
	(let ((buffer (process-buffer process)))
	  (tm:show-buffer buffer () () 'end)
	  (save-excursion
	    (set-buffer buffer)
	    (tpp:insert string 'pseudo-user-input t))))))


;; Expression macroexpansion
;; -------------------------
;;

(defun ts:macroexpand-expression ()
  "Macroexpand the current expression with the current Talk server
and display the result."
  (interactive)
  (let* ((sexp (tm:sexp-at-point))
	 (start (car sexp))
	 (end (cdr sexp))
	 (server (ts:get-current-server))
	 (buffer (current-buffer))
	 (package (tm:buffer-read-package buffer))
	 (mexpand-buffer (get-buffer ts:macroexpansion-buffer-name))
	 (width (window-width
		 (or (and mexpand-buffer
			  (get-buffer-window mexpand-buffer))
		     (selected-window)))))
    (ts:send-form server package buffer start end)
    (if (not (string= (buffer-name) ts:macroexpansion-buffer-name))
	(let ((lmargin 0)
	      (rmargin (max 40 (- width 5))))
	  (ts:remote-eval (format ts:talk-macroexpand-format lmargin rmargin)
			  server)
	  (ts:show-data-buffer ts:macroexpansion-buffer-name))
      (let* ((lmargin (save-excursion
			(goto-char start)
			(current-column)))
	     (rmargin (max (+ lmargin 20) (- width 5))))
	(ts:remote-eval (format ts:talk-macroexpand-format lmargin rmargin)
			server)
	(ts:insert-data-buffer start end)))
    (save-excursion
      (set-buffer ts:macroexpansion-buffer-name)
      (make-local-variable 'tml:default-buffer-package)
      (setq tml:default-buffer-package package))))


;; Who exports
;; -----------
;;

(defun ts:who-exports (package pname)
  "Return the list of modules exporting symbol with PACKAGE and PNAME.
The liste contains element of the form (path type module), where:
  - path is the pathname (a string) of the description file, if it was found,
    otherwise ().
  - type is the export type.
  - module is the module name."
  (let* ((server (ts:get-current-server))
	 (full-symbol (tm:make-symbol package pname))
	 (form (format ts:talk-who-exports-format 
		       full-symbol)))
    (ts:remote-eval form server)
    (ts:read-from-data-buffer)))

(defun ts:search-exported-defs (search package pname)
  "Update the SEARCH with the definitions of symbol with PACKAGE and PNAME,
querying the databases through the Talk process."
  (cond
   ((not ts:database-query-p) ())
   ((null (ts:get-current-server t))
    (list (list 'message "No running process; cannot look in databases.")))
   ((eq package 'unknown)
    (list (list 'message "Unknown package; cannot look in databases.")))
   (t
    (let ((exports (ts:who-exports package pname)))
      (while exports
	(let* ((export (car exports))
	       (desc-file (nth 0 export))
	       (type (nth 1 export))
	       (module (nth 2 export)))
	  (tm:push-search-place
	   search
	   (list 'ts:definitions-in-module
		 package pname desc-file type module))
	  (setq exports (cdr exports))))))))

(defun ts:definitions-in-module (search package pname desc-file type module)
  "Update the SEARCH with the definitions of symbol with PACKAGE and PNAME
of type TYPE in the module MODULE."
  (if (null desc-file)
      (tm:push-search-place
       search 
       (list 'message
	     (format "Module %s exporting %s %s not in (path)"
		     module type (tm:make-symbol package pname))))
    (let ((source (tm:desc-file-readable-source-file desc-file)))
      (if (null source)
	  (tm:push-search-place
	   search
	   (list 'message
		 (format "Source for %s exporting %s %s not found"
			 module type (tm:make-symbol package pname))))
	(let* ((buffer (tm:find-file-noselect source)))
	  (if (not (memq buffer (tm:search-seen-buffers search)))
	      (tm:search-def-in-buffer search package pname buffer t)))))))


;; Which
;; -----
;;

(defvar ts:which-result ()
  "Variable used by Talk to transmit the result of a which")

(defun ts:set-which-result (path)
  "Function called by Talk to return the result of a which."
  (setq ts:which-result path))

(defun ts:which (name types)
  "Return the path of the program unit NAME of any one of the types TYPES, 
or () if  not found."
  (let* ((server (ts:get-current-server))
	 (form (format ts:talk-which-format name types)))
    (ts:remote-eval form server)
    ts:which-result))

(defun ts:find-program-unit ()
  "Edit the Talk file named NAME, calling Talk for getting its path
using WHICH. If NAME has an extension, look for a file with this extension;
otherwise, look first for a .t file then for a .td file."
  (interactive)
  (ts:get-current-server)
  (let* ((name (read-string "Program unit: " (tm:symbol-at-point-string ()))))
    (if (not (string= name ""))
	(let* ((ext (tm:file-extension name))
	       (radix (tm:file-without-extension name))
	       (types (cond
		       ((null ext) '(t td))
		       ((string= ext ".t") '(t))
		       ((string= ext ".td") '(td))
		       ((string= ext ".tt") '(tt))
		       ((string= ext ".c") '(c))
		       ((string= ext ".h") '(h))
		       ((string= ext ".cc") '(cpp))
		       ((string= ext ".C") '(cpp))
		       (t (error "incorrect extension for %s" name))))
	       (file (ts:which radix types)))
	  (if (null file)
	      (error "file not found for %s" name)
	    (tm:show-buffer (find-file-noselect file) t t))))))


;; Build/analyze/load
;; ------------------
;;

(defun ts:save-program-unit-buffers (name)
  "Ask the user for saving the buffers associated with the prunit NAME."
  (tm:save-some-buffers (tm:program-unit-buffers name)))

(defun ts:program-unit-action (name pseudo-input format &rest args)
  "Applies the action described by FORMAT and ARGS to the prunit named NAME.
Also insert PSEUDO-INPUT as if it was typed by the user."
  (let ((server (ts:get-current-server)))
    (ts:save-program-unit-buffers name)
    (let ((prunit (ts:get-work-prunit name t)))
      (tm:set-group-current-item ts:work-prunit-group prunit))
    (ts:insert-pseudo-input server (format pseudo-input name))
    (ts:remote-eval (apply 'format format name args) server)))

(defun ts:analyze-build-program-unit (prunit)
  "Analyze and build PRUNIT"
  (interactive)
  (ts:program-unit-action
   prunit tp:build-program-unit-fmt ts:talk-analyze-build-format))

(defun ts:analyze-build-this-program-unit ()
  "Analyze and build the program unit associated with the current buffer."
  (interactive)
  (ts:analyze-build-program-unit (tm:current-buffer-program-unit)))

(defun ts:analyze-program-unit (prunit)
  "Analyze PRUNIT."
  (interactive)
  (ts:program-unit-action
   prunit tp:analyze-program-unit-fmt ts:talk-analyze-format))

(defun ts:analyze-this-program-unit ()
  "Analyze the program unit associated with the current buffer."
  (interactive)
  (ts:analyze-program-unit (tm:current-buffer-program-unit)))

(defun ts:update-load-program-unit (prunit)
  "Update-load PRUNIT."
  (interactive)
  (ts:program-unit-action
   prunit tp:update-load-program-unit-fmt
   ts:talk-update-load-format))

(defun ts:update-analyze-program-unit (prunit)
  "Analyze PRUNIT."
  (interactive)
  (ts:program-unit-action
   prunit tp:update-analyze-program-unit-fmt 
   ts:talk-update-analyze-format))

(defun ts:update-analyze-build-program-unit (prunit)
  "Analyze PRUNIT."
  (interactive)
  (ts:program-unit-action
   prunit tp:update-analyze-build-program-unit-fmt 
   ts:talk-update-analyze-build-format))

(defun ts:update-load-this-program-unit ()
  "Update-load the program unit associated with the current buffer."
  (interactive)
  (ts:update-load-program-unit (tm:current-buffer-program-unit)))

(defun ts:update-analyze-this-program-unit ()
  "Update-analyze the program unit associated with the current buffer."
  (interactive)
  (ts:update-analyze-program-unit (tm:current-buffer-program-unit)))

(defun ts:update-analyze-build-this-program-unit ()
  "Update the program unit associated with the current buffer."
  (interactive)
  (ts:update-analyze-build-program-unit (tm:current-buffer-program-unit)))

(defun ts:test-program-unit (prunit)
  "Test PRUNIT"
  (interactive)
  (ts:program-unit-action
   prunit tp:test-program-unit-fmt ts:talk-test-format))

(defun ts:test-this-program-unit ()
  "Test the program unit associated with the current buffer."
  (interactive)
  (ts:test-program-unit (tm:current-buffer-program-unit)))

(defun ts:load-program-unit (prunit)
  "Load PRUNIT"
  (interactive)
  (ts:program-unit-action
   prunit tp:load-program-unit-fmt ts:talk-load-format "()"))

(defun ts:load-this-program-unit ()
  "Load the program unit associated with the current buffer."
  (interactive)
  (ts:load-program-unit (tm:current-buffer-program-unit)))

(defun ts:load-program-unit-interpreted (prunit)
  "Build PRUNIT."
  (interactive)
  (ts:program-unit-action
   prunit tp:load-program-unit-interpreted-fmt ts:talk-load-format "t"))

(defun ts:load-this-program-unit-interpreted ()
  "Build the program unit associated with the current buffer."
  (interactive)
  (ts:load-program-unit-interpreted (tm:current-buffer-program-unit)))

(defun ts:in-workspace (wsp)
  "Go into WSP"
  (interactive)
  (ts:program-unit-action
   wsp tp:in-workspace-fmt ts:talk-in-workspace-format))

(defun ts:in-this-workspace ()
  "Load the workspace associated with the current buffer."
  (interactive)
  (ts:in-workspace (tm:current-buffer-program-unit)))

;; Breakpoints
;; -----------
;;

(tm:defstruct ts:breakpoint-item tm:site-item
  (address
   ;; A string representing the address of the broken node
   ))

(tm:defstruct ts:breakpoint-group tm:site-group
  ()
  (method: tm:group-remove-item-hook)
  (method: tm:group-print-header)
  (method: tm:group-delete-hook))

(defvar ts:breakpoint-group (ts:make-breakpoint-group)
  "Group containing the breakpoint sites group.")

(tm:defmethod tm:group-delete-hook ((group ts:breakpoint-group))
  "Function called when the breakpoint group is deleted. Just create a new
empty one, since breakpoints can be created at any moment by Talk."
  (setq ts:breakpoint-group (ts:make-breakpoint-group)))

(tm:defmethod tm:group-remove-item-hook ((group ts:breakpoint-group) item)
  "Function called when a item is deleted in a breakpoint group. If the node
address is (), then the node has already been unbroken by Talk; otherwise,
we require Talk to unbreak it."
  (let ((address (ts:breakpoint-item-address item)))
    (if address ;; Protected against errors to avoid aborting group deletion.
	(progn
	  (ts:set-breakpoint-item-address item ())
	  (condition-case ()
	      (let ((server (ts:get-current-server)))
		(ts:remote-eval
		 (format ts:talk-clear-breakpoint-format address)
		 server
		 t))
	    (error ())))))
  (call-method tm:group-remove-item-hook tm:site-group group item))

(tm:defmethod tm:group-print-header ((group ts:breakpoint-group))
  (tm:insert-centered-title "Breakpoints")
  (newline)
  (newline))

(defun ts:set-breakpoint ()
  "Set a breakpoint."
  (interactive)
  (let ((buffer (current-buffer)))
    (if (not (tm:source-buffer-p buffer))
	(error "%s is not a source file buffer" (buffer-name buffer)))
    (let* ((module (tm:buffer-program-unit buffer))
	   (position (ts:expression-to-break))
	   (line (car position))
	   (column (cdr position))
	   (server (ts:get-current-server)))
      (ts:remote-eval
       (format ts:talk-set-breakpoint-format module line column)
       server
       t))))

(defun ts:clear-breakpoint ()
  "Clear the closest breakpoint on the line."
  (interactive)
  (let ((item (tm:site-group-closest-item ts:breakpoint-group)))
    (if (null item)
	(error "no breakpoint at this point")
      (tm:group-remove-item ts:breakpoint-group item))))

(defun ts:expression-to-break ()
  "Return the expression to break next to the current point, as a
pair (line . column)"
  (save-excursion
    (let* ((expr (tm:sexp-at-point))
	   (start (car expr)))
      (goto-char start)
      (cons (tm:current-line) (tm:current-line-character)))))

(defun ts:edit-breakpoint-sites ()
  (interactive)
  "Edit the breakpoint sites in a buffer."
  (tm:group-show-buffer-attach ts:breakpoint-group
			       tm:breakpoint-buffer-format
			       ()
			       t))


;; Stepping
;; --------
;;

(defvar ts:step-site ()
  "Current step site, or () if we are not stepping.")

(defun ts:step-expression (file start-line start-col 
				end-line end-col
				symbol type)
  "Step into the expression at the given coordinates; see function
ts:add-source-extents for details on the arguments. TYPE may be
aither the symbol ENTERING or the symbol EXITING."
  (if ts:step-site (tm:site-delete ts:step-site))
  (setq ts:step-site
	(if (eq type 'entering)
	    (tm:make-step-in-site)
	  (tm:make-step-out-site)))
  (tm:site-add-source ts:step-site 
		      file start-line start-col
		      end-line end-col symbol)
  (tm:site-show ts:step-site))

(defun ts:unstep-last-expression ()
  "Delete the current step site."
  (if ts:step-site
      (progn
	(tm:site-delete ts:step-site)
	(setq ts:step-site ()))))


;; Breakpoints
;; -----------
;;

(defun ts:broken-node (address file start-line start-col end-line end-col)
  "Function called by Talk to signal that a node with ADDRESS (a string)
and with the following coordinates has been broken."
  (let* ((site (tm:make-breakpoint-site))
	 (item (ts:make-breakpoint-item address: address)))
    (tm:site-add-source site
			file start-line start-col
			end-line end-col ())
    (tm:site-group-add-item ts:breakpoint-group item site t t)))

(defun ts:unbroken-node (address)
  "Function called by Talk to signal that a node with ADDRESS has
been unbroken."
  (let ((items (tm:group-items ts:breakpoint-group))
	(found-item ()))
    (while (and items (null found-item))
      (let* ((item (car items))
	     (item-address (ts:breakpoint-item-address item)))
	(if (and item-address (string= item-address address))
	    (setq found-item item)
	  (setq items (cdr items)))))
    (if found-item
	(progn ; Breakpoint already reset by Talk
	  (ts:set-breakpoint-item-address found-item ())
	  (tm:group-remove-item ts:breakpoint-group found-item)))))

(require 'talk-prunit)
(require 'talk-server)
(provide 'talk-comm)
