;;;
;;; Program unit management.
;;;
;;; ----------------------------------------------------------------------
;;; 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)
(require 'talk-server)


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

(defvar ts:modules-buffer-other-window tm:pop-other-window-default
  "When true, a new window is opened for the modules buffer.")

(defvar ts:errors-buffer-other-window ()
  "When true, a new window is opened for the errors buffer.")

(defvar ts:pop-error-buffer t
  "When true, the error buffer is automatically shown when analyzing
or testing a module.")


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

(defvar tm:work-prunit-buffer-format "*Modules*"
  "Buffer name for program unit group.")

(defvar ts:signal-action-group-buffer-format "*Errors*"
  "Buffer name for signal action groups.")

(defvar ts:error-pictogram "**"
  "Pictogram used for errors")

(defvar ts:warning-pictogram "*"
  "Pictogram used for warnings")

(defvar ts:analysis-group-header-format
  (format "  Errors: %%s%s, Warnings: %%s%s"
	  ts:error-pictogram ts:warning-pictogram)
  "Format used for analysis group headers.")

(defvar ts:test-group-header-format
  (format "  Errors: %%s%s" ts:error-pictogram)
  "Format used for test group headers.")

(defvar ts:action-group-header-running " [Running]"
  "Used in action groups to flag a running action")

(defvar ts:action-group-header-erroneous " [Errors during run]"
  "Used in action groups to flag an erroneous action")


;; Locations
;; ---------
;;

(tm:defstruct ts:location ()
  ;; A location describes a position in the source. This is a 'symbolic'
  ;; representations of sites, which avoids loading a file to point inside
  ;; it.
  (file
   ;; The source file, a string.
   )
  (generic: ts:location-add-to-site (self site))
  ;; Update SITE so that it points to the described by SELF.
  )

(tm:defstruct ts:file-location ts:location
  ;; A location which points in a file, without further information.
  ()
  (method: ts:location-add-to-site))

(tm:defstruct ts:source-location ts:location
  ;; A location with full information. See the function tm:site-add-source
  ;; for explanations about the fields.
  (start-line
   start-col
   end-line
   end-col
   symbol)
  (method: ts:location-add-to-site))

(defun ts:new-location (file start-line start-col end-line end-col symbol)
  "Create a new ts:location at the given coordinates. If start-line and
friends are provided, create a ts:source-location; otherwise simply create
a ts:file-location."
  (if (null start-line)
      (ts:make-file-location file: file)
    (ts:make-source-location file: file
			     start-line: start-line
			     start-col: start-col
			     end-line: end-line
			     end-col: end-col
			     symbol: symbol)))

(tm:defmethod ts:location-add-to-site ((location ts:file-location) site)
  (tm:site-add-file site (ts:location-file location)))

(tm:defmethod ts:location-add-to-site ((location ts:source-location) site)
  (tm:site-add-source site
		      (ts:location-file location)
		      (ts:source-location-start-line location)
		      (ts:source-location-start-col location)
		      (ts:source-location-end-line location)
		      (ts:source-location-end-col location)
		      (ts:source-location-symbol location)))


;; Action signal
;; -------------
;;

(tm:defstruct ts:action-signal ()
  ;; An action signal describes a Talk error signals emitted during the prunit
  ;; actions 'analyze' and 'test'.
  (message
   ;; The associated error message, a string.
   location
   ;; The error location, a ts:location.
   )
  (generic: ts:action-signal-summary-message (signal))
  ;; Display a summary message for the signal
  )

(tm:defstruct ts:analysis-signal ts:action-signal
  ;; Signal emitted during the analysis.
  (type
   ;; Either the symbol ERROR or the symbol WARNING.
   )
  (method: ts:action-signal-summary-message))

(tm:defstruct ts:test-signal ts:action-signal
  ;; Signal emitted during a test.
  ()
  (method: ts:action-signal-summary-message))

(tm:defmethod ts:action-signal-summary-message ((signal ts:analysis-signal))
  (let* ((message (ts:action-signal-message signal))
	 (type (ts:analysis-signal-type signal))
	 (pictogram (if (eq type 'error) 
			ts:error-pictogram 
		      ts:warning-pictogram)))
    (message "%s %s" pictogram message)))

(tm:defmethod ts:action-signal-summary-message ((signal ts:test-signal))
  (let* ((message (ts:action-signal-message signal)))
    (message "%s %s" ts:error-pictogram message)))


;; Prunit actions
;; --------------
;;
;;

(tm:defstruct ts:prunit-action ()
  ;; A prunit action describes an action made on a prunit: analyze, build,
  ;; load and test.
  (prunit
   ;; Reverse link to the prunit the action is attached to.
   (status default: 'update)
   ;; UPDATE if the action is up to date, INVALID if it has been invalidated
   ;; and must be redone, and RUNNING if it is currently running.
   (completedp default: t)
   ;; T if the action completed, W if it completed with warnings,
   ;; () if there were errors.
   )
  (generic: ts:prunit-action-print (self))
  ;; To print a prunit action on a program-unit's line in a program unit
  ;; group buffer.
  )

(tm:defstruct ts:load-action ts:prunit-action
  (interpretedp
   ;; True if the prunit has been loaded interpreted
   ))

(tm:defstruct ts:build-action ts:prunit-action
  ())

(tm:defstruct ts:signal-action ts:prunit-action
  ;; Super-class of actions for which Talk emits signals, which are recorded
  ;; as objects of type ts:action-signal.
  ;; A site group of type ts:action-group (see below) can be created
  ;; to represent the signal actions.
  (signals
   ;; Signals emitted during this action
   group
   ;; A group representing the signals, or ()
   )
  (generic: ts:signal-action-attach-group (self))
  ;; If the action has a group, return it; otherwise, create one and
  ;; return it.
  )

(tm:defstruct ts:analyze-action ts:signal-action
  ((warnings default: 0)
   ;; Number of warnings
   (errors default: 0)
   ;; Number of errors
   )
  (method: ts:signal-action-attach-group))

(tm:defstruct ts:test-action ts:signal-action
  ((errors default: 0)
   ;; Number of errors
   )
  (method: ts:signal-action-attach-group))


(defun ts:signal-action-delete (action)
  "Function called when a signal action is deleted, that is when the
owner prunit is deleted."
  (let ((group (ts:signal-action-group action)))
    (if group (tm:group-delete group))))


;; Prunits
;; -------
;;

(tm:defstruct ts:prunit tm:item
  ;; A prunit describes a program unit associated to its various operations.
  ;; At any moment, there should be only one prunit object with a given name.
  (name
   ;; Prunit's name, a string
   modifiedp
   ;; True if the source has been modified
   analyzed
   ;; A ts:analyze-action, or ()
   built
   ;; A ts:build-action, or ()
   loaded
   ;; A ts:load-action, or ()
   tested
   ;; A ts:test-action, or ()
   last-signal-action
   ;; Contains the most recent done or shown ts:signal-action
   ))


;; Prunit groups
;; -------------
;;

(tm:defstruct ts:prunit-group tm:group
  ;; A prunit group is a group of prunits.
  ()
  (method: tm:group-remove-item-hook)
  (method: tm:group-print-header)
  (method: tm:group-print-item)
  (method: tm:group-attach-buffer-hook)
  (method: tm:group-buffer-print-help))

(defvar ts:prunit-group-buffer-map ()
  "Prunit group buffer keymap.")

(if ts:prunit-group-buffer-map
    ()
  (setq ts:prunit-group-buffer-map (copy-keymap tm:group-buffer-map))
  (define-key ts:prunit-group-buffer-map "a" 'tmg:show-analysis-group)
  (define-key ts:prunit-group-buffer-map "t" 'tmg:show-test-group)
  (define-key ts:prunit-group-buffer-map "f" 'tmg:edit-source-file)
  (define-key ts:prunit-group-buffer-map "\C-c\C-a"
    'tmg:analyze-prunit-item)
  (define-key ts:prunit-group-buffer-map "\C-c\C-b"
    'tmg:analyze-build-prunit-item)
  (define-key ts:prunit-group-buffer-map "\C-c\C-u\C-l"
    'tmg:update-load-prunit-item)
  (define-key ts:prunit-group-buffer-map "\C-c\C-u\C-a"
    'tmg:update-analyze-prunit-item)
  (define-key ts:prunit-group-buffer-map "\C-c\C-u\C-b"
    'tmg:update-analyze-build-prunit-item)
  (define-key ts:prunit-group-buffer-map "\C-c\C-l"
    'tmg:load-prunit-item)
  (define-key ts:prunit-group-buffer-map "\C-c\C-i"
    'tmg:load-prunit-item-interpreted)
  (define-key ts:prunit-group-buffer-map "\C-c\C-w"
    'tmg:load-prunit-item-workspace)
  (define-key ts:prunit-group-buffer-map "\C-c\C-t"
    'tmg:test-prunit-item))

(tm:defmethod tm:group-attach-buffer-hook ((group ts:prunit-group))
  (use-local-map ts:prunit-group-buffer-map)
  (make-local-variable 'tml:other-screen-p)
  (setq tml:other-screen-p ts:modules-buffer-other-window))
  
(tm:defmethod tm:group-remove-item-hook ((group ts:prunit-group) prunit)
  (let ((analyzed (ts:prunit-analyzed prunit))
	(tested (ts:prunit-tested prunit)))
    (if analyzed (ts:signal-action-delete analyzed))
    (if tested (ts:signal-action-delete tested))))

(defun ts:prunit-group-get-prunit (group name &optional createp)
  "Return the prunit named NAME if it can be found in GROUP. Otherwise,
if optional CREATEP is true, create it and add it to the group; otherwise,
return ()."
  (let ((prunits (tm:group-items group))
	(found-prunit ()))
    (while (and prunits (null found-prunit))
      (let ((prunit (car prunits)))
	(if (string= name (ts:prunit-name prunit))
	    (setq found-prunit prunit)
	  (setq prunits (cdr prunits)))))
    (cond
     (found-prunit found-prunit)
     ((not createp) ())
     (t
      (let ((prunit (ts:make-prunit name: name)))
	(tm:group-add-item group prunit t)
	prunit)))))

(defvar ts:source-column 20
  "Column at which source info is printed.")

(defvar ts:analyze-column 28
  "Column at which analysis info is printed.")

(defvar ts:build-column 36
  "Column at which build info is printed.")

(defvar ts:load-column 44
  "Column at which load info is printed.")

(defvar ts:test-column 52
  "Column at which test info is printed.")

(tm:defmethod tm:group-print-header ((group ts:prunit-group))
  (indent-to-column ts:source-column)
  (insert "Source")
  (indent-to-column ts:analyze-column)
  (insert "Analyze")
  (indent-to-column ts:build-column)
  (insert "Build")
  (indent-to-column ts:load-column)
  (insert "Load")
  (indent-to-column ts:test-column)
  (insert "Test"))

(tm:defmethod tm:group-print-item ((group ts:prunit-group) prunit)
  (let ((name (ts:prunit-name prunit)))
    (insert name)
    (let ((modifiedp (ts:prunit-modifiedp prunit)))
      (if modifiedp
	  (progn
	    (indent-to-column ts:source-column)
	    (insert "*"))))
    (let ((action (ts:prunit-analyzed prunit)))
      (if action
	  (ts:print-prunit-action-at action "A" ts:analyze-column)))
    (let ((action (ts:prunit-built prunit)))
      (if action
	  (ts:print-prunit-action-at action "B" ts:build-column)))
    (let ((action (ts:prunit-loaded prunit)))
      (if action
	  (if (ts:load-action-interpretedp action)
	      (ts:print-prunit-action-at action "I" ts:load-column)
	    (ts:print-prunit-action-at action "L" ts:load-column))))
    (let ((action (ts:prunit-tested prunit)))
      (if action
	  (ts:print-prunit-action-at action "T" ts:test-column)))))

(defun ts:print-prunit-action-at (action text column)
  (indent-to-column column)
  (let* ((status (ts:prunit-action-status action))
	 (completedp (ts:prunit-action-completedp action))
	 (stars (cond
		 ((null completedp) ts:error-pictogram)
		 ((eq completedp 'w) ts:warning-pictogram)
		 (t ""))))
    (cond
     ((eq status 'running) (insert "[" text stars "]"))
     ((eq status 'update) (insert " " text stars " "))
     ((eq status 'invalid) (insert "(" text stars ")")))))


;; Signal items
;; ------------
;;
;;

(tm:defstruct ts:signal-item tm:site-item
  ;; Signal items are site items which point to signal locations.
  ;; They are collected into action groups.
  (signal
   ;; The associated prunit signal
   ))
  

;; Action groups
;; -------------
;;

(tm:defstruct ts:action-group tm:site-group
  ;; An action group is the group corresponding to an action signal.
  ;; It contains signal items.
  (action
   ;; Reverse link to the associated signal action
   )
  (method: tm:group-delete-hook)
  (method: tm:group-attach-buffer-hook))

(tm:defstruct ts:analysis-group ts:action-group
  ()
  (method: tm:group-print-header)
  (method: tm:group-print-item))

(tm:defstruct ts:test-group ts:action-group
  ()
  (method: tm:group-print-header)
  (method: tm:group-print-item))

(defvar ts:action-group-buffer-map ()
  "Action group buffer keymap.")

(if ts:action-group-buffer-map
    ()
  (setq ts:action-group-buffer-map (copy-keymap tm:site-group-bufferp-map))
  (define-key ts:action-group-buffer-map "\C-c\C-a"
    'tmg:analyze-error-prunit)
  (define-key ts:action-group-buffer-map "\C-c\C-b"
    'tmg:analyze-build-error-prunit)
  (define-key ts:action-group-buffer-map "\C-c\C-u\C-l"
    'tmg:update-load-error-prunit)
  (define-key ts:action-group-buffer-map "\C-c\C-u\C-a"
    'tmg:update-analyze-error-prunit)
  (define-key ts:action-group-buffer-map "\C-c\C-u\C-b"
    'tmg:update-analyze-build-error-prunit)
  (define-key ts:action-group-buffer-map "\C-c\C-l"
    'tmg:load-error-prunit)
  (define-key ts:action-group-buffer-map "\C-c\C-i"
    'tmg:load-error-prunit-interpreted)
  (define-key ts:action-group-buffer-map "\C-c\C-w"
    'tmg:load-error-workspace)
  (define-key ts:action-group-buffer-map "\C-c\C-t"
    'tmg:test-error-prunit))

(tm:defmethod tm:group-attach-buffer-hook ((group ts:action-group))
  (call-method tm:group-attach-buffer-hook tm:site-group group)
  (make-variable-buffer-local 'tml:other-screen-p)
  (setq tml:other-screen-p ts:errors-buffer-other-window)
  (use-local-map ts:action-group-buffer-map))

(tm:defmethod tm:group-delete-hook ((group ts:action-group))
  "Update the signal action so that if does not have an associated group
any more."
  (let ((action (ts:action-group-action group)))
    (ts:set-signal-action-group action ())
    t))



;; Action group related methods
;; ----------------------------
;;

(tm:defmethod ts:signal-action-attach-group ((action ts:analyze-action))
  (or (ts:signal-action-group action)
      (let ((group (ts:make-analysis-group action: action)))
	(ts:action-group-add-signals group action)
	(ts:set-signal-action-group action group)
	group)))

(tm:defmethod ts:signal-action-attach-group ((action ts:test-action))
  (or (ts:signal-action-group action)
      (let ((group (ts:make-test-group action: action)))
	(ts:action-group-add-signals group action)
	(ts:set-signal-action-group action group)
	group)))

(defun ts:action-group-add-signals (group action)
  "Create signal items for the signals in the signal action ACTION and add
them to GROUP."
  (let ((signals (ts:signal-action-signals action)))
    (while signals
      (ts:action-group-add-signal group (car signals))
      (setq signals (cdr signals)))))

(defun ts:action-group-add-signal (group signal)
  "Add a signal item for SIGNAL to the action group GROUP."
  (let ((location (ts:action-signal-location signal))
	(site (tm:make-error-site))
	(item (ts:make-signal-item signal: signal)))
    (ts:location-add-to-site location site)
    (tm:site-group-add-item group item site t ())))

(tm:defmethod tm:group-print-header ((group ts:analysis-group))
  (ts:print-action-group-header group "Analysis errors for %s")
  (let* ((action (ts:action-group-action group)))
    (if (eq (ts:prunit-action-status action) 'running)
	(insert (format ts:analysis-group-header-format "" "")
		ts:action-group-header-running)
      (let ((errors (ts:analyze-action-errors action))
	    (warnings (ts:analyze-action-warnings action)))
	(insert (format ts:analysis-group-header-format errors warnings))
	(if (and (= errors 0)
		 (null (ts:prunit-action-completedp action)))
	    (insert ts:action-group-header-erroneous))))
    (newline)))

(tm:defmethod tm:group-print-header ((group ts:test-group))
  (ts:print-action-group-header group "Test errors for %s")
  (let* ((action (ts:action-group-action group)))
    (if (eq (ts:prunit-action-status action) 'running)
	(insert (format ts:test-group-header-format "")
		ts:action-group-header-running)
      (let ((errors (ts:test-action-errors action)))
	(insert (format ts:test-group-header-format errors))
	(if (and (= errors 0)
		 (null (ts:prunit-action-completedp action)))
	    (insert ts:action-group-header-erroneous))))
    (newline)))

(defun ts:print-action-group-header (group format)
  (let* ((action (ts:action-group-action group))
	 (prunit (ts:prunit-action-prunit action))
	 (name (ts:prunit-name prunit)))
    (tm:insert-centered-title (format format name))
    (newline)
    (newline)))

(defvar ts:message-fill-prefix (make-string 6 ? )
  "Fill prefix used to indent error message paragraph.")

(tm:defmethod tm:group-print-item ((group ts:analysis-group) item)
  (let* ((signal (ts:signal-item-signal item))
	 (type (ts:analysis-signal-type signal))
	 (pictogram (cond
		     ((eq type 'error) ts:error-pictogram)
		     (t ts:warning-pictogram))))
    (ts:insert-signal-item-message-and-text pictogram item)))

(tm:defmethod tm:group-print-item ((group ts:test-group) item)
  (ts:insert-signal-item-message-and-text ts:error-pictogram item))

(defun ts:insert-signal-item-message-and-text (pictogram item)
  (let* ((signal (ts:signal-item-signal item))
	 (message (ts:action-signal-message signal)))
    (insert pictogram)
    (ts:insert-paragraph message ts:message-fill-prefix)
    (if (tm:site-extents (tm:site-item-site item))
	(progn
	  (newline)
	  (indent-to-column (length ts:message-fill-prefix) 2)
	  (tm:print-site-item-lineno item)
	  (tm:print-site-item-text item)))))

(defun ts:insert-paragraph (text prefix)
  "Insert TEXT with prefix PREFIX and indent it."
  (let* ((column (length prefix)))
    (indent-to-column column 2)
    (let ((fill-prefix prefix)
	  (fill-column (- (window-width) column 1))
	  (begin (point))
	  (char (aref text 0)))
      (aset text 0 (upcase char))
      (insert text)
      (aset text 0 char)
      (fill-region-as-paragraph begin (point))
      (delete-backward-char 1))))

(defun ts:show-signal-action-group (action gotop)
  (let ((group (ts:signal-action-attach-group action)))
    (tm:group-show-buffer-attach
     group ts:signal-action-group-buffer-format t gotop)))

(defun tm:signal-action-buffer-header-modified (action)
  (let ((group (ts:signal-action-group action)))
    (if group
	(progn
	  (tm:set-group-modifiedp group 'header)
	  (tm:group-refresh-buffer group)))))

(defun tmg:current-error-prunit-name ()
  "Return the name of the prunit we are in its error buffer."
  (let* ((group tml:buffer-group)
	 (action (ts:action-group-action group))
	 (prunit (ts:prunit-action-prunit action))
	 (name (ts:prunit-name prunit)))
    name))
  
(defun tmg:analyze-error-prunit ()
  "Analyze the current prunit item."
  (interactive)
  (ts:analyze-program-unit (tmg:current-error-prunit-name)))

(defun tmg:analyze-build-error-prunit ()
  "Analyze the current prunit item."
  (interactive)
  (ts:analyze-build-program-unit (tmg:current-error-prunit-name)))

(defun tmg:update-load-error-prunit ()
  "Update-load the current prunit item."
  (interactive)
  (ts:update-load-program-unit (tmg:current-error-prunit-name)))

(defun tmg:update-analyze-error-prunit ()
  "Update-analyze the current prunit item."
  (interactive)
  (ts:update-analyze-program-unit (tmg:current-error-prunit-name)))

(defun tmg:update-analyze-build-error-prunit ()
  "Update-analyze-build the current prunit item."
  (interactive)
  (ts:update-analyze-build-program-unit (tmg:current-error-prunit-name)))

(defun tmg:load-error-prunit ()
  "Analyze the current prunit item."
  (interactive)
  (ts:load-program-unit (tmg:current-error-prunit-name)))

(defun tmg:load-error-prunit-interpreted ()
  "Analyze the current prunit item."
  (interactive)
  (ts:load-program-unit-interpreted (tmg:current-error-prunit-name)))

(defun tmg:load-error-workspace ()
  "Analyze the current workspace."
  (interactive)
  (ts:in-workspace (tmg:current-error-prunit-name)))

(defun tmg:test-error-prunit ()
  "Analyze the current prunit item."
  (interactive)
  (ts:test-program-unit (tmg:current-error-prunit-name)))


;; Prunit group bindings
;; ---------------------
;;

(defvar ts:prunit-group-buffer-help
  "f\tedit the source buffer
a\tshow analysis errors
t\tshow test errors
C-c C-a\t\tanalyze
C-c C-b\t\tanalyze & build
C-c C-i\t\tload interpreted
C-C C-t\t\ttest
C-C C-u C-l\tupdate load
C-C C-u C-a\tupdate analyze
C-C C-u C-b\tupdate analyze and build
C-C C-w\t\tin workspace"
  "Additional help message while in prunit group buffer")

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

(defun tmg:show-analysis-group ()
  "Function called in a prunit list buffer to show the prunit's analysis group"
  (interactive)
  (let ((tm:*group-buffer-caller* 'buffer))
    (let ((prunit (tmg:select-point-item)))
      (if prunit
	  (let ((analyzed (ts:prunit-analyzed prunit)))
	    (if analyzed
		(progn
		  (ts:show-signal-action-group analyzed t)
		  (ts:set-prunit-last-signal-action prunit analyzed))))))))

(defun tmg:show-test-group ()
  "Function called in a prunit list buffer to show the prunit's test group"
  (interactive)
  (let ((tm:*group-buffer-caller* 'buffer))
    (let ((prunit (tmg:select-point-item)))
      (if prunit
	  (let ((tested (ts:prunit-tested prunit)))
	    (if tested
		(progn
		  (ts:show-signal-action-group tested t)
		  (ts:set-prunit-last-signal-action prunit tested))))))))

(defun tmg:analyze-prunit-item ()
  "Analyze the current prunit item"
  (interactive)
  (let ((prunit (tmg:select-point-item)))
    (if prunit
	(ts:analyze-program-unit (ts:prunit-name prunit)))))

(defun tmg:analyze-build-prunit-item ()
  "Analyze and build the current prunit item"
  (interactive)
  (let ((prunit (tmg:select-point-item)))
    (if prunit
	(ts:analyze-build-program-unit (ts:prunit-name prunit)))))

(defun tmg:update-load-prunit-item ()
  "Update-load the current prunit item"
  (interactive)
  (let ((prunit (tmg:select-point-item)))
    (if prunit
	(ts:update-load-program-unit (ts:prunit-name prunit)))))

(defun tmg:update-analyze-prunit-item ()
  "Update-analyze the current prunit item"
  (interactive)
  (let ((prunit (tmg:select-point-item)))
    (if prunit
	(ts:update-analyze-program-unit (ts:prunit-name prunit)))))

(defun tmg:update-analyze-build-prunit-item ()
  "Update-analyze-build the current prunit item"
  (interactive)
  (let ((prunit (tmg:select-point-item)))
    (if prunit
	(ts:update-analyze-build-program-unit (ts:prunit-name prunit)))))

(defun tmg:load-prunit-item ()
  "Load the current prunit item"
  (interactive)
  (let ((prunit (tmg:select-point-item)))
    (if prunit
	(ts:load-program-unit (ts:prunit-name prunit)))))

(defun tmg:load-prunit-item-interpreted ()
  "Load the current prunit item"
  (interactive)
  (let ((prunit (tmg:select-point-item)))
    (if prunit
	(ts:load-program-unit-interpreted (ts:prunit-name prunit)))))

(defun tmg:load-prunit-item-workspace ()
  "Load the current prunit item as a workspace"
  (interactive)
  (let ((prunit (tmg:select-point-item)))
    (if prunit
	(ts:in-workspace (ts:prunit-name prunit)))))

(defun tmg:test-prunit-item ()
  "Test the current prunit item"
  (interactive)
  (let ((prunit (tmg:select-point-item)))
    (if prunit
	(ts:test-program-unit (ts:prunit-name prunit)))))

(defun tmg:edit-source-file ()
  "Edit the source of the current prunit item."
  (interactive)
  (let ((prunit (tmg:select-point-item)))
    (if prunit
	(let* ((name (ts:prunit-name prunit))
	       (file (ts:which name '(t td))))
	  (if (null file)
	      (error "file not found for %s" name)
	    (tm:show-buffer (find-file-noselect file) t t))))))


;; Work prunit group
;; -----------------
;;

(tm:defstruct ts:work-prunit-group ts:prunit-group
  ()
  (method: tm:group-delete-hook)
  (method: tm:group-print-header))

(defvar ts:work-prunit-group (ts:make-work-prunit-group)
  "Group containing the currently processed prunits.")

(tm:defmethod tm:group-delete-hook ((group ts:work-prunit-group))
  "Function called when the current prunit group is deleted. Just create
a new, empty one."
  (if (or (not (eq tm:*group-buffer-caller* 'buffer))
          (y-or-n-p "Are you sure you want to kill this group "))
      (progn
	(setq ts:work-prunit-group (ts:make-work-prunit-group))
	t)
    ()))

(tm:defmethod tm:group-print-header ((group ts:work-prunit-group))
  (tm:insert-centered-title "Modules")
  (newline)
  (newline)
  (call-method tm:group-print-header ts:prunit-group group))

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

(defun ts:get-work-prunit (name &optional createp)
  (ts:prunit-group-get-prunit ts:work-prunit-group name createp))

(defun ts:current-work-prunit-p (prunit)
  (eq prunit (tm:group-current-item ts:work-prunit-group)))

(defun tm:work-group-prunit-modified (prunit)
  "To notify that PRUNIT has changed, so that the buffer containing
ts:work-prunit-group is refreshed."
  (tm:group-item-modified ts:work-prunit-group prunit))

(defun tm:last-work-prunit-signal-action (&optional no-error-p)
  "Return the most recent ts:signal-action of the current work prunit. If
there is none, and optional NO-ERROR-P is (), signal an error; otherwise,
just return ()."
  (let ((prunit (tm:group-current-item ts:work-prunit-group)))
    (cond
     (prunit
      (let ((action (ts:prunit-last-signal-action prunit)))
	(cond
	 (action action)
	 (no-error-p ())
	 (t (error "Current module %s not yet analyzed or tested"
		   (ts:prunit-name prunit))))))
     (no-error-p ())
     (t (error "No current module")))))

(defun ts:show-signal-action-group-if-current (prunit action)
  "Show the buffer of ACTION if PRUNIT is the current prunit and 
ts:pop-error-buffer is true."
  (if (and ts:pop-error-buffer (ts:current-work-prunit-p prunit))
      (ts:show-signal-action-group action ())))
  
(defun ts:edit-error-sites ()
  "Edit the error site of the more recently done signal action of the
current prunit."
  (interactive)
  (let ((action (tm:last-work-prunit-signal-action)))
      (ts:show-signal-action-group action t)))

(defun ts:error-site-next ()
  "Select the next error site of the more recently done signal action of the
current prunit."
  (interactive)
    (let ((tm:*group-buffer-caller* 'interactive))
      (let* ((action (tm:last-work-prunit-signal-action))
	     (group (ts:signal-action-attach-group action)))
	(if (null (tm:group-next-selectable-item group))
	    (error "No next error")
	  (ts:print-current-item-summary-message group)))))

(defun ts:error-site-previous ()
  "Select the next error site of the more recently done signal action of the
current prunit."
  (interactive)
  (let ((tm:*group-buffer-caller* 'interactive))
    (let* ((action (tm:last-work-prunit-signal-action))
	   (group (ts:signal-action-attach-group action)))
      (if (not (tm:group-previous-selectable-item group))
	  (error "No previous error")
	(ts:print-current-item-summary-message group)))))

(defun ts:error-site-current ()
  "Select the current error site of the more recently done signal action of the
current prunit."
  (interactive)
  (let* ((action (tm:last-work-prunit-signal-action))
	 (group (ts:signal-action-attach-group action))
	 (item (tm:group-current-item group)))
    (if (null item)
	(message "No errors")
      (tm:site-show (tm:site-item-site item) t t)
      (ts:print-current-item-summary-message group))))

(defun ts:print-current-item-summary-message (group)
  (let* ((item (tm:group-current-item group))
	 (signal (ts:signal-item-signal item)))
    (ts:action-signal-summary-message signal)))


;; File mechanisms
;; ---------------
;;

(add-hook 'tm:write-contents-hook 'ts:invalidate-buffer-prunit)

(defun ts:invalidate-buffer-prunit ()
  "Function called when a buffer in Talk mode is saved."
  (let ((name (tm:buffer-program-unit (current-buffer) t)))
    (if name
	(let ((prunit (ts:get-work-prunit name t)))
	  (cond
	    ((tm:test-file-p (buffer-file-name))
	     (ts:test-source-modified prunit)
	     (tm:work-group-prunit-modified prunit))
	    ((ts:prunit-modifiedp prunit))
	    (t
	     (ts:source-modified prunit)
	     (tm:work-group-prunit-modified prunit)))))))

(defun ts:source-modified (prunit)
  (ts:set-prunit-modifiedp prunit t)
  (ts:invalidate-analysis prunit)
  (ts:invalidate-build prunit)
  (ts:invalidate-load prunit)
  (ts:invalidate-test prunit))

(defun ts:test-source-modified (prunit)
  (ts:invalidate-test prunit))

(defun ts:invalidate-analysis (prunit)
  (let ((analyzed (ts:prunit-analyzed prunit)))
    (if analyzed (ts:set-prunit-action-status analyzed 'invalid))))

(defun ts:invalidate-build (brunit)
  (let ((built (ts:prunit-built prunit)))
    (if built (ts:set-prunit-action-status built 'invalid))))

(defun ts:invalidate-load (prunit)
  (let ((loaded (ts:prunit-loaded prunit)))
    (if loaded (ts:set-prunit-action-status loaded 'invalid))))

(defun ts:invalidate-test (prunit)
  (let ((tested (ts:prunit-tested prunit)))
    (if tested (ts:set-prunit-action-status tested 'invalid))))

(defun ts:run-analysis (prunit)
  (ts:set-prunit-modifiedp prunit ())
  (let ((analyzed (ts:prunit-analyzed prunit)))
    (if analyzed (ts:set-prunit-action-status analyzed 'running)))
  (ts:invalidate-build prunit)
  (ts:invalidate-load prunit)
  (ts:invalidate-test prunit))

(defun ts:run-build (prunit)
  (let ((built (ts:prunit-built prunit)))
    (if built (ts:set-prunit-action-status built 'running)))
  (ts:invalidate-load prunit)
  (ts:invalidate-test prunit))

(defun ts:run-load (prunit)
  (let ((loaded (ts:prunit-loaded prunit)))
    (if loaded (ts:set-prunit-action-status loaded 'running)))
  (ts:invalidate-test prunit))

(defun ts:run-test (prunit)
  (let ((tested (ts:prunit-tested prunit)))
    (if tested (ts:set-prunit-action-status tested 'running))))


;; Analysis
;; --------
;;

(defun ts:start-analysis (name)
  "Function called by Talk at the beginning of an analysis."
  (let* ((prunit (ts:get-work-prunit name t))
	 (action (or (ts:prunit-analyzed prunit)
		     (ts:make-analyze-action prunit: prunit))))
    (ts:set-prunit-analyzed prunit action)
    (ts:set-signal-action-signals action ())
    (ts:set-prunit-action-completedp action t)
    (ts:set-analyze-action-warnings action 0)
    (ts:set-analyze-action-errors action 0)
    (ts:run-analysis prunit)
    (let ((group (ts:signal-action-group action)))
      (if group (tm:group-clear group)))
    (ts:show-signal-action-group-if-current prunit action)
    (ts:set-prunit-last-signal-action prunit action)
    (tm:work-group-prunit-modified prunit)))

(defun ts:analysis-signal (name message type file
				start-line start-col
				end-line end-col symbol)
  "Function called by Talk to signal analysis errors or warnings."
  (let* ((prunit (ts:get-work-prunit name t))
	 (action (ts:prunit-analyzed prunit)))
    (if action				; Prunit could have been deleted
	(let* ((signals (ts:signal-action-signals action))
	       (group (ts:signal-action-group action))
	       (location (ts:new-location file start-line start-col
					  end-line end-col symbol))
	       (signal (ts:make-analysis-signal message: message
						location: location
						type: type)))
	  (cond
	   ((eq type 'error)
	    (ts:set-analyze-action-errors
	     action (+ 1 (ts:analyze-action-errors action)))
	    (ts:set-prunit-action-completedp action ()))
	   (t
	    (ts:set-analyze-action-warnings
	     action (+ 1 (ts:analyze-action-warnings action)))
	    (if (ts:prunit-action-completedp action)
		(ts:set-prunit-action-completedp action 'w))))
	  (ts:set-signal-action-signals action (nconc signals (list signal)))
	  (if group (ts:action-group-add-signal group signal))))))

(defun ts:end-analysis (name errorp)
  "Function called by Talk to signal that an analysis has been finished."
  (let* ((prunit (ts:get-work-prunit name t))
	 (action (ts:prunit-analyzed prunit)))
    (if action
	(progn
	  (if errorp
	      (ts:set-prunit-action-completedp action ()))
	  (ts:set-prunit-action-status action 'update)
	  (tm:signal-action-buffer-header-modified action)
	  (tm:work-group-prunit-modified prunit)))))


;; Build
;; -----
;;

(defun ts:start-build (name)
  "Function called by Talk at the beginning of a build."
  (let* ((prunit (ts:get-work-prunit name t))
	 (action (or (ts:prunit-built prunit)
		     (ts:make-build-action prunit: prunit))))
    (ts:set-prunit-built prunit action)
    (ts:set-prunit-action-completedp action t)
    (ts:run-build prunit)
    (tm:work-group-prunit-modified prunit)))
  
(defun ts:end-build (name errorp)
  "Function called by Talk at the end of a build."
  (let* ((prunit (ts:get-work-prunit name t))
	 (action (ts:prunit-built prunit)))
    (if action
	(progn
	  (ts:set-prunit-action-completedp action (not errorp))
	  (ts:set-prunit-action-status action 'update)
	  (tm:work-group-prunit-modified prunit)))))


;; Load
;; ----
;;

(defun ts:start-load (name interpretedp)
  "Function called by Talk at the beginning of a load."
  (let* ((prunit (ts:get-work-prunit name t))
	 (action (or (ts:prunit-loaded prunit)
		     (ts:make-load-action prunit: prunit))))
    (ts:set-prunit-loaded prunit action)
    (ts:set-load-action-interpretedp action interpretedp)
    (ts:set-prunit-action-completedp action t)
    (ts:run-load prunit)
    (tm:work-group-prunit-modified prunit)))
  
(defun ts:end-load (name errorp)
  "Function called by Talk at the end of a load."
  (let* ((prunit (ts:get-work-prunit name t))
	 (action (ts:prunit-loaded prunit)))
    (if action
	(progn
	  (ts:set-prunit-action-completedp action (not errorp))
	  (ts:set-prunit-action-status action 'update)
	  (tm:work-group-prunit-modified prunit)))))


;; Test
;; ----
;;

(defun ts:start-test (name)
  "Function called by Talk at the beginning of a test."
  (let* ((prunit (ts:get-work-prunit name t))
	 (action (or (ts:prunit-tested prunit)
		     (ts:make-test-action prunit: prunit))))
    (ts:set-prunit-tested prunit action)
    (ts:set-signal-action-signals action ())
    (ts:set-prunit-action-completedp action t)
    (ts:set-test-action-errors action 0)
    (ts:run-test prunit)
    (let ((group (ts:signal-action-group action)))
      (if group (tm:group-clear group)))
    (ts:show-signal-action-group-if-current prunit action)
    (ts:set-prunit-last-signal-action prunit action)
    (tm:work-group-prunit-modified prunit)))

(defun ts:test-signal (name message file
			    start-line start-col
			    end-line end-col)
  "Function called by Talk to signal test errors."
  (let* ((prunit (ts:get-work-prunit name t))
	 (action (ts:prunit-tested prunit)))
    (if action
	(let* ((signals (ts:signal-action-signals action))
	       (group (ts:signal-action-group action))
	       (location (ts:new-location file start-line start-col
					  end-line end-col ()))
	       (signal (ts:make-test-signal message: message
					    location: location)))
	  (ts:set-test-action-errors
	   action (+ 1 (ts:test-action-errors action)))
	  (ts:set-prunit-action-completedp action ())
	  (ts:set-signal-action-signals action (nconc signals (list signal)))
	  (if group (ts:action-group-add-signal group signal))))))

(defun ts:end-test (name errorp)
  "Function called by Talk to signal that a test has been finished."
  (let* ((prunit (ts:get-work-prunit name t))
	 (action (ts:prunit-tested prunit)))
    (if action
	(progn
	  (if errorp
	      (ts:set-prunit-action-completedp action ()))
	  (ts:set-prunit-action-status action 'update)
	  (tm:signal-action-buffer-header-modified action)
	  (tm:work-group-prunit-modified prunit)))))


(provide 'talk-prunit)
