;;;
;;; Major mode for editing talk descriptors.
;;;
;;; ----------------------------------------------------------------------
;;; 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:
;;;
;;; td		General prefix for descriptor related identifiers.
;;;


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

(defvar td:source-header-format
";;; ----------------------------------------------------------------------
;;;
;;; <NAME>: <point>Undescribed module
;;;
;;; ----------------------------------------------------------------------
;;;
;;; Created by <user-name> on <date>
;;;

"
   "A format to use for source file headers.")

(defvar td:test-header-format
";;; ----------------------------------------------------------------------
;;;
;;; Test file for <NAME>
;;;
;;; ----------------------------------------------------------------------
;;;
;;; Created by <user-name> on <date>
;;;

        (test-series \"[<point>Undescribed test series]\")

"
   "A format to use for test file headers.")


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

(defvar td:module-descriptor-format
"type:           module
name:           <name>
description:    \"<point>Undescribed module\"
package:        default
export:         ((<name>
                ))
level:          debug"
   "A format to use as initial module descriptor contents")

(defvar td:library-descriptor-format
"type:           library
name:           <name>
description:    \"<point>Undescribed library\"
package:        default
modules:        ()"
   "A format to use as initial library descriptor contents")

(defvar td:executable-descriptor-format
"type:           executable
name:           <name>
description:    \"<point>Undescribed executable\"
package:        default
initialize:     ()
startup:        ()
image-size:     1000000"
   "A format to use as initial executable descriptor contents")

(defvar td:workspace-descriptor-format
"type:           workspace
name:           <name>
description:    \"<point>Undescribed workspace\"
required:       (talkws)
package:        default
root-directory: #f\"${HOME}/talk-play\"
directories:    (#f\"src\")
environment-parameters: 
                ((default-o-directory: #f\"${PORTNAME}/o\")
                 (default-c-directory: #f\"c\")
                 (default-tx-directory: #f\"${PORTNAME}\")
                 (default-pag-directory: #f\"${PORTNAME}/o\")
                 (default-so-directory: #f\"lib/${PORTNAME}\")
                 (default-package: default))
program-units:  ()"
   "A format to use as initial workspace descriptor contents")


;; Module header
;; -------------
;;

(defun td:insert-td-format-string (fmt name)
  "FMT is a string which may contain the following directives:
	- <name>: the name of the program unit, given in NAME;
	- <NAME>: the name of the program unit in uppercase;
	- <user-login>: the login name of the user;
	- <user-name>: the full name of the user;
	- <date>: the full current date;
	- <year>: the year
	- <point>: the position where the point is put."
  (let ((start (point)))
    (insert fmt)
    (if (not (bolp))
	(newline))
    (save-restriction
      (narrow-to-region start (point))
      (td:replace-string "<name>" name)
      (td:replace-string "<NAME>" (upcase name))
      (td:replace-string "<user-login>" (user-login-name))
      (td:replace-string "<user-name>" (user-full-name))
      (td:replace-string "<date>" (current-time-string))
      (td:replace-string "<year>" (substring (current-time-string) 20))
      (goto-char (point-min))
      (if (search-forward "<point>" () 'goto-end)
	  (replace-match "")))))

(defun td:replace-string (from to)
  "Replace FROM with TO everywhere."
  (goto-char (point-min))
  (let ((case-fold-search ()))
    (while (search-forward from nil t)
      (replace-match to nil t))))

(add-hook 'find-file-not-found-hooks 'td:find-file-not-found-hook)

(defun td:find-file-not-found-hook ()
  "Function called for a newly created file. Automatically insert a
templace."
  (td:insert-template)
  ())				; Return () or no other hook will be
				; executed

(defun td:insert-new-file-template ()
  "Insert a template if the current buffer is empty and correspond to a
file not yet saved."
  (if (and (eq (point-min) (point-max))
	   (not (buffer-modified-p (current-buffer)))
	   (let ((file (buffer-file-name)))
	     (and file (not (file-exists-p file)))))
      (td:insert-template)))

(defun td:insert-template ()
  "Insert a template, according to the current buffer's file extension."
  (let ((file (buffer-file-name (current-buffer))))
    (cond
      ((tm:source-file-p file)
       (let ((name (tm:file-program-unit file)))
	 (td:insert-td-format-string td:source-header-format name)))
      ((tm:test-file-p file)
       (let ((name (tm:file-program-unit file)))
	 (td:insert-td-format-string td:test-header-format name)))
      ((tm:desc-file-p file)
       (let* ((name (tm:file-program-unit file))
	      (type (td:get-file-type name file)))
	 (cond
	   ((string= type ""))
	   ((string= type "module")
	    (td:insert-td-format-string td:module-descriptor-format name))
	   ((string= type "library")
	    (td:insert-td-format-string td:library-descriptor-format name))
	   ((string= type "executable")
	    (td:insert-td-format-string td:executable-descriptor-format name))
	   ((string= type "workspace")
	    (td:insert-td-format-string td:workspace-descriptor-format name)))
	 )))))

(defun td:get-file-type (prunit file)
  (let ((default
	  (cond
	    ((file-exists-p (tm:desc-file-source-file file)) "m")
	    ((string-match "^lib" prunit) "l")
	    ((string-match "ws$" prunit) "w")
	    (t "e"))))
    (completing-read
     "Insert description? (module, library, executable, or workspace) "
     '(("module") ("library")
       ("executable") ("workspace"))
     () t default)))
  
(provide 'talk-desc)
