;;; pn-mode.el --- major mode for editing Maria Petri Nets under Emacs

;; Copyright © 1999 Marko Mäkelä <msmakela@tcs.hut.fi>

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2 of the License, or
;; (at your option) any later version.
  
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.
  
;; You should have received a copy of the GNU General Public License
;; along with this program; if not, write to the Free Software
;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

;;; Commentary:

;; This package provides a major mode for editing Petri Nets.  It provides
;; mainly syntax highlighting and support for indentation.

;;; Code:

(require 'cc-mode)

(defvar pn-mode-abbrev-table nil
  "Abbrev table in use in Petri Net mode.")
(define-abbrev-table 'pn-mode-abbrev-table ())

(defvar pn-mode-map nil
  "Keymap used in pn-mode buffers.")
(if pn-mode-map
    nil
  (setq pn-mode-map (c-make-inherited-keymap)))

(require 'easymenu)
(defvar pn-mode-menu nil
  "Menu bar used in pn-mode.")

(easy-menu-define pn-mode-menu pn-mode-map "Petri Net Mode Commands"
		  (c-mode-menu "Petri Net"))

;;;###autoload
(defvar pn-mode-syntax-table nil
  "Syntax table used in pn-mode buffers.")
(if pn-mode-syntax-table
    ()
  (setq pn-mode-syntax-table (make-syntax-table))
  (c-populate-syntax-table pn-mode-syntax-table))

;; Syntax highlighting

(defconst pn-font-lock-keywords-1 nil
  "Subdued level highlighting for pn-mode.")
(defconst pn-font-lock-keywords-2 nil
  "Medium level highlighting for pn-mode.
See also `pn-font-lock-extra-types'.")
(defconst pn-font-lock-keywords-3 nil
  "Gaudy level highlighting for pn-mode.
See also `pn-font-lock-extra-types'.")

(let* ((pn-keywords
	(eval-when-compile
	  (concat "\\<\\("
		  (regexp-opt
		   '("queue" "stack" "struct" "union" "enum" "atom"
		     "subnet" "place"
		     "trans" "in" "out" "gate" "hide" "typedef"
		     "prop" "reject" "deadlock"
		     "strongly_fair" "weakly_fair" "enabled" "const"))
		  "\\)\\>")))
       (pn-type-types
	`(mapconcat 'identity
		    (cons
		     (,@ (eval-when-compile
			   (regexp-opt
			    '("bool" "int" "unsigned" "char" "id"))))
		     pn-font-lock-extra-types)
		    "\\|"))
       (pn-type-depth `(regexp-opt-depth (,@ pn-type-types)))
       (pn-errors
	(eval-when-compile (concat "\\<\\("
				   (regexp-opt '("undefined" "fatal"))
				   "\\)\\>")))
       (pn-literals
	(eval-when-compile (concat "\\<\\("
				   (regexp-opt '("true" "false" "empty"))
				   "\\)\\>")))
       (pn-operators
	(eval-when-compile (concat "\\<\\("
				   (regexp-opt
				    '("is" "until" "release"
				      "subset" "intersect" "equals" "minus"
				      "cardinality" "map"))
				   "\\)\\>")))
       )
  (setq pn-font-lock-keywords-1
	(list
	 ;; Keywords
	 pn-keywords
	 ;; Preprocessor directives
	 '("^#[ \t]*\\(\\sw+\\)\\>[ \t!]*\\(\\sw+\\)?"
	   (1 font-lock-builtin-face)
	   (2 font-lock-variable-name-face nil t))
	 ;; Literals (constants)
	 (cons pn-literals 'font-lock-constant-face)
	 ;; Operators (reserved words)
	 (cons pn-operators 'font-lock-builtin-face)
	 ;; Undefined literals
	 (cons pn-errors 'font-lock-warning-face)))
  (setq pn-font-lock-keywords-2
	(append pn-font-lock-keywords-1
		(list
		 ;; Type names
		 `(eval .
			(cons (concat "\\<\\(" (,@ pn-type-types) "\\)\\>")
			      'font-lock-type-face))
		 ;; Transition names
		 '("\\<trans[ \t]+\\(\\sw+\\)"
		   (1 font-lock-function-name-face keep))
		 ;; Place names
		 '("\\<place[ \t]+\\(\\sw+\\)"
		   (1 font-lock-string-face keep))
		 ;; State proposition names
		 '("\\<prop[ \t]+\\(\\sw+\\)"
		   (1 font-lock-variable-name-face keep))
		 ;; Submarking variable names
		 '("\\<subset[ \t]+\\(\\sw+\\)[ \t]*{"
		   (1 font-lock-variable-name-face keep))
		 ;; Mapping variable names
		 '("\\<map[ \t]+\\(\\sw+\\)[ \t]*\\(#[ \t]*\\(\\sw+\\)[ \t]*\\)?{"
		   (1 font-lock-variable-name-face keep)
		   (3 font-lock-variable-name-face keep t)))))
  (setq pn-font-lock-keywords-3
	(append pn-font-lock-keywords-2
		(list
		 ;; Fontify all type specifiers plus their items.
		 `(eval .
			(list (concat "\\<\\(" (,@ pn-type-types) "\\)\\>"
				      "\\([ \t]+\\sw+\\)*\\>")
			      ;; Fontify each declaration item.
			      (list 'font-lock-match-c-style-declaration-item-and-skip-to-next
				    ;; Start with point after all specifiers.
				    (list 'goto-char
					  (list 'or
						(list 'match-beginning
						      (+ (,@ pn-type-depth) 2))
						'(match-end 1)))
				    ;; Finish with point after first specifier.
				    '(goto-char (match-end 1))
				    ;; Fontify as a variable or function name.
				    '(1 (if (match-beginning 2)
					    font-lock-function-name-face
					  font-lock-variable-name-face)))))
		 ;; Fontify structures, or typedef names, plus their items.
		 '("\\(}\\)[ \t]*\\sw"
		   (font-lock-match-c-style-declaration-item-and-skip-to-next
		    (goto-char (match-end 1)) nil
		    (1 (if (match-beginning 2)
			   font-lock-function-name-face
			 font-lock-variable-name-face))))
		 ;; Numeric constants
		 '("\\<\\(0[0-7]*\\|0x[0-9a-fA-F]+\\|[1-9][0-9]*\\)\\>"
		   (1 font-lock-constant-face))))))

(defvar pn-font-lock-keywords pn-font-lock-keywords-1
  "Default expressions to highlight in Petri Net mode.
See also `pn-font-lock-extra-types'.")

(defcustom pn-font-lock-extra-types '()
  "*List of extra types to fontify in Petri Net mode.
Each list item should be a regexp not containing word-delimiters.
For example, a value of (\"token\" \"\\\\sw+_t\") means the word token
and words ending in _t are treated as type names.

The value of this variable is used when Font Lock mode is turned on."
  :type 'font-lock-extra-types-widget
  :group 'font-lock-extra-types)

(defvar pn-imenu-generic-expression
  (let ((name-or-string
	 "\\([A-Za-z_][A-Za-z0-9_]*\\>\\|\"\\([^\"]+\\|\\\\.\\)*\"\\)"))
    (list
     (list "Transitions"
	   (concat "^\\s-*trans\\s-+" name-or-string) 1)
     (list "Places"
	   (concat "^\\s-*place\\s-+" name-or-string
		   "\\(\\s-+[A-Za-z_]\\|\\s-*[()\"]\\)") 1)
     (list "Types"
	   (concat "^typedef\\s-+.+\\s-+" name-or-string ";$") 1)))
  "The regex pattern to use for creating a buffer index for Petri Nets.

See `imenu-generic-expression'.")
;;;###autoload
(defun pn-mode ()
  "Major mode for editing Maria Petri Net models.

To see what version of CC Mode you are running, enter `\\[c-version]'.

The hook variable `pn-mode-hook' is run with no args, if that
variable is bound and has a non-nil value.  Also the hook
`c-mode-common-hook' is run first.

Key bindings:
\\{pn-mode-map}"
  (interactive)
  (c-initialize-cc-mode)
  (kill-all-local-variables)
  (set-syntax-table pn-mode-syntax-table)
  (setq major-mode 'pn-mode
	mode-name "Petri Net"
	local-abbrev-table pn-mode-abbrev-table)
  (use-local-map pn-mode-map)
  (c-common-init)
  (setq comment-start "// "
	comment-end ""
	c-conditional-key "\\b\\(in\\|out\\)\\b[^_]"
 	c-comment-start-regexp "/[/*]"
	c-recognize-knr-p nil)
  (make-local-variable 'font-lock-defaults)
  (setq font-lock-defaults
	'((pn-font-lock-keywords
	  pn-font-lock-keywords-1
	  pn-font-lock-keywords-2
	  pn-font-lock-keywords-3)
	  nil nil ((?_ . "w"))))
  (make-local-variable 'imenu-generic-expression)
  (setq imenu-generic-expression pn-imenu-generic-expression
	imenu-case-fold-search nil)
  (run-hooks 'c-mode-common-hook)
  (run-hooks 'pn-mode-hook)
  (c-update-modeline))

(add-to-list 'auto-mode-alist '("\\.pn\\'" . pn-mode))
(if (featurep 'speedbar)
    (speedbar-add-supported-extension ".pn"))
(provide 'pn-mode)
