;;; cogre-uml.el --- UML support for COGRE

;;; Copyright (C) 2001, 2002, 2003, 2004, 2007 Eric M. Ludlam

;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: oop, uml
;; X-RCS: $Id: uml-create.el,v 1.15 2007/04/15 14:58:55 zappo Exp $

;; This file is not part of GNU Emacs.

;; This 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, or (at your option)
;; any later version.

;; This software 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 GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;;; Commentary:
;;
;; Routines used to create UML diagrams from Semantic generated reverse
;; engineered token databases.

(require 'cogre-uml)
(require 'semantic)
(require 'semanticdb)
(require 'semanticdb-find)

;;; Code:
(defclass cogre-semantic-uml-graph (cogre-graph)
  nil
  "This graph is for semantic oriented UML diagrams.")

(defmethod cogre-insert-class-list ((graph cogre-semantic-uml-graph))
  "Return a list of classes GRAPH will accept."
  (append (eieio-build-class-alist 'cogre-link)
	  (eieio-build-class-alist 'cogre-semantic-class)
	  (eieio-build-class-alist 'cogre-package)))

(defclass cogre-semantic-class (cogre-class)
  nil
  "A Class node linked to semantic parsed buffers.
Inherits from the default UML class node type, and adds user
interfacing which links working with this node directly to source
code.")

(defmethod cogre-save ((graph cogre-semantic-uml-graph))
  "Save the current GRAPH."
  ;; Autogenerated graphcs have semantic tags in them which are often
  ;; linked via overlay into a buffer.  We need to write something
  ;; special to unlink (clone?) those tags so they are saveable.
  ;;(error "You cannot save autogenerated graphs")
  
  ;; Doing this allows the graph to be saved.  Some bugs in saving
  ;; these graphs have been made.  Try it out for a while.
  (call-next-method)
  )

(defmethod initialize-instance ((this cogre-semantic-class) &optional fields)
  "When interactively creating a class node THIS, query for the class name.
Optional argument FIELDS are not used."
  (call-next-method)
  (if (string-match "^Class[0-9]*" (oref this object-name))
      ;; In this case, we have a default class object-name, so try and query
      ;; for the real class (from sources) which we want to use.
      (let* ((class (or (oref this class) (cogre-read-class-name)))
	     (tag (if (semantic-tag-p class)
		      class
		    (car
		     (semanticdb-strip-find-results
		      (semanticdb-brute-deep-find-tags-by-name class)
		      t))))
	     )
	(when tag
	  ;; We need to clone the tag to unlink our storage from any
	  ;; buffer it may be associated with.
	  (setq tag (semantic-tag-copy tag nil t)))

	(if (semantic-tag-p class) (setq class (semantic-tag-name class)))
	(if (and tag (eq (semantic-tag-class tag) 'type)
		 (or (string= (semantic-tag-type tag) "class")
		     (string= (semantic-tag-type tag) "struct")))
	    (let ((slots (semantic-tag-type-members tag))
		  (extmeth (semantic-tag-external-member-children tag t))
		  attrib method)
	      ;; Bin them up
	      (while slots
		(cond
		 ;; A plain string, a simple language, just do attributes.
		 ((stringp (car slots))
		  (setq attrib (cons (list (car slots) 'variable nil)
				     attrib))
		  )
		 ;; Variable decl is an attribute
		 ((eq (semantic-tag-class (car slots)) 'variable)
		  (setq attrib (cons (car slots) attrib)))
		 ;; A function decle is a method.
		 ((eq (semantic-tag-class (car slots)) 'function)
		  (setq method (cons (car slots) method)))
		 )
		(setq slots (cdr slots)))
	      ;; Add in all those extra methods
	      (while extmeth
		(let ((sl (cdr (car extmeth))))
		  (while sl
		    (if (eq (semantic-tag-class (car sl)) 'function)
			(setq method (cons (car sl) method)))
		    (setq sl (cdr sl))))
		(setq extmeth (cdr extmeth)))
	      ;; Put them into the class.
	      (oset this object-name class)
	      (oset this class tag)
	      (oset this attributes (nreverse attrib))
	      (oset this methods (nreverse method))
	      ;; Tada!
	      )
	  ;; We couldn't find a semantic tag for this class, so just
	  ;; put the name in there.
	  (cond ((stringp class)
		 (oset this object-name class))
		((and (listp class)
		      (stringp (car class)))
		 (oset this object-name (car class)))
		(t nil))
	  (oset this class nil)
	  (oset this attributes nil)
	  (oset this methods nil)
	  )))
  this)

;; Saving such graphs is not good!  We can't reliably restore the overlays
;; since we should switch to the originating buffer for every one!  Yuck!

;; (defmethod cogre-element-pre-serialize ((node cogre-semantic-class))
;;   "Prepare the current NODE to be serialized.
;; Deoverlay all semantic tokens referenced."
;;   (call-next-method)
;;   (semantic-deoverlay-list (oref node class))
;;   (semantic-deoverlay-list (oref node attributes))
;;   (semantic-deoverlay-list (oref node methods))
;;   )

;; (defmethod cogre-element-post-serialize ((node cogre-semantic-class))
;;   "Restore overlays in NODE after being loaded from disk.
;; Also called after a graph was saved to restore all objects.
;; Reverses `cogre-graph-pre-serialize'."
;;   (call-next-method)
;;   (semantic-overlay-list (oref node class))
;;   (semantic-overlay-list (oref node attributes))
;;   (semantic-overlay-list (oref node methods))
;;   )

(defcustom cogre-token->uml-function 'semantic-uml-abbreviate-nonterminal
  "Function to use to create strings for tokens in CLASS nodes."
  :group 'cogre
  :type semantic-format-tag-functions)


(defmethod cogre-uml-stoken->uml ((class cogre-semantic-class) stoken &optional text)
  "For CLASS convert a Semantic token STOKEN into a uml definition.
Optional TEXT property is passed down."
  ;; We need to disable images because our diagram is still
  ;; pretty unstable.
  (let ((semantic-format-use-images-flag nil))
    (call-next-method class stoken
		      (save-excursion
			(let ((tb (or (semantic-tag-buffer stoken)
				      (semantic-tag-buffer (oref class class)))))
			  (if tb (set-buffer tb))
			  (funcall cogre-token->uml-function
				   stoken
				   (oref class class)
				   t))))
    ))

(defmethod cogre-entered ((class cogre-semantic-class) start end)
  "Method called when the cursor enters CLASS.
START and END cover the region with the property."
  (cogre-uml-source-display class (point))
  (call-next-method))

(defmethod cogre-left ((class cogre-semantic-class) start end)
  "Method called when the cursor exits CLASS.
START and END cover the region with the property."
  (call-next-method))

;;; Screen Manager
;;
;; Manage the display of the source buffer somewhere near the class diagram
;; in a nice way.
(defcustom cogre-uml-source-display-method
  'cogre-uml-source-display-bottom
  "A Function called to display a source buffer associated with a Graph.
This function can be anything, or nil, though the following options
are preferred:
 `cogre-uml-source-display-bottom' - in a window on the bottom of the frame.
 `cogre-uml-source-display-top' - in a window on the top of the frame.
The function specified must take a `point-marker' to specify the
location that is to be displayed."
  :group 'cogre
  :type '(choice (const 'cogre-uml-source-display-bottom)
		 (const 'cogre-uml-source-display-top)
		 ))

(defcustom cogre-uml-browse-token-hook nil
  "*Hooks run when a token is browsed by the COGRE graph.
Each hook takes one argument, and one optional argument, the token
being browsed too, and a containing parent token, if available.
This is run when the token is first found, not during the actual
browse.  The token will be under point when this hook is called.
Changing window configurations is not recommended."
  :group 'cogre
  :type 'function
  )

(defun cogre-uml-browse-token-highlight-hook-fn (tok &optional parent)
  "Momentarilly highlight TOK.  Ignore PARENT.
Function useable by `cogre-uml-browse-token-hook'."
  (semantic-momentary-highlight-tag tok))

(defmethod cogre-uml-source-marker ((class cogre-semantic-class) token)
  "Return a marker position for a CLASS containing TOKEN.
This returned marker will be in the source file of the attribute,
method, or class definition.  nil if there is not match."
  (let ((semc (oref class class))
	(p nil))
    (cond ((and token (semantic-tag-with-position-p token))
	   (setq p (save-excursion
		     (semantic-go-to-tag token)
		     (run-hook-with-args
		      'cogre-uml-browse-token-hook
		      token)
		     (point-marker))
		 ))
	  ((and token (semantic-tag-with-position-p semc))
	   (setq p (save-excursion
		     (semantic-go-to-tag token semc)
		     (run-hook-with-args
		      'cogre-uml-browse-token-hook
		      token semc)
		     (point-marker))
		 ))
	  ((and semc (semantic-tag-with-position-p semc))
	   (setq p (save-excursion
		     (semantic-go-to-tag semc)
		     (run-hook-with-args
		      'cogre-uml-browse-token-hook
		      semc)
		     (point-marker))
		 ))
	  (t nil))
    p))

(defmethod cogre-uml-source-display ((class cogre-semantic-class) point)
  "Display source code associated with CLASS based on text at POINT.
The text must be handled by an overlay of some sort which has the
semantic token we need as a property.  If not, then nothing happens.
Uses `cogre-uml-source-display-method'."
  (let* ((sem (get-text-property point 'semantic))
	 (p (cogre-uml-source-marker class sem)))
    (when p
      (save-excursion
	(funcall cogre-uml-source-display-method p))
      ))
  )

(defmethod cogre-activate ((class cogre-semantic-class))
  "Activate CLASS.
This could be as simple as displaying the current state,
customizing the object, or performing some complex task."
  (let* ((sem (get-text-property (point) 'semantic))
	 (p (cogre-uml-source-marker class sem))
	 (cp (point-marker)))
    (if (not p)
	(error "No source to jump to")
      ;; Activating is the reverse of just showing the sorce
      (switch-to-buffer (marker-buffer p))
      (funcall cogre-uml-source-display-method cp)
      ))
  )

(defcustom cogre-uml-source-display-window-size 5
  "Size of same-frame window displaying source code."
  :group 'cogre
  :type 'integer)

(defun cogre-uml-source-display-bottom (m)
  "Display point M in a small buffer on the bottom of the current frame."
  (if (not (eq (next-window) (selected-window)))
      (cogre-uml-source-display-other-window m)
    (split-window-vertically (- (window-height)
				cogre-uml-source-display-window-size
				1))
    (other-window 1)
    (switch-to-buffer (marker-buffer m) t)
    (recenter 1)
    (goto-char m)
    (other-window -1))
  )

(defun cogre-uml-source-display-other-window (m)
  "Display point M in other window."
  (other-window 1)
  (switch-to-buffer (marker-buffer m) t)
  (goto-char m)
  (recenter 1)
  (other-window -1)
  )

;;; Auto-Graph generation
;;
;; Functions for creating a graph from semantic parts.
(defvar cogre-class-history nil
  "History for inputting class names.")

(defun cogre-read-class-name ()
  "Read in a class name to be used by a cogre node."
  (let ((finddefaultlist (semantic-find-tag-by-overlay))
	class prompt stream
	)
    ;; Assume the top most item is the all encompassing class.
    (if finddefaultlist
	(setq class (car finddefaultlist)))
    ;; Make sure our class is really a class
    (if (not (and
	      class
	      (eq (semantic-tag-class class) 'type)
	      (string= (semantic-tag-type class) "class")))
	(setq class nil)
      (setq class (semantic-tag-name class)))
    ;; Create a prompt
    (setq prompt (if class (concat "Class (default " class "): ") "Class: "))
    ;; Get the stream used for completion.
    (let ((types (semanticdb-strip-find-results
		  (semanticdb-brute-find-tags-by-class 'type)
		  ;; Don't find-file-match.  Just need names.
		  )))
      (setq stream (semantic-find-tags-by-type "class" types)))
    ;; Do the query
    (completing-read prompt stream
		     nil nil nil 'cogre-class-history
		     class)
    ))

;;;###autoload
(defun cogre-uml-quick-class (class)
  "Create a new UML diagram based on CLASS showing only immediate lineage.
The parent to CLASS, CLASS, and all of CLASSes children will be shown."
  (interactive (list (cogre-read-class-name)))
  (let* ((class-tok (car (semanticdb-strip-find-results
			  (semanticdb-brute-deep-find-tags-by-name class) t)))
	 (class-node nil)
	 (parent (semantic-tag-type-superclasses class-tok))
	 (parent-nodes nil)
	 (children (semanticdb-find-nonterminal-by-function
		    (lambda (stream sp si)
		      (semantic-brute-find-tag-by-function
		       (lambda (tok)
			 (and (eq (semantic-tag-class tok) 'type)
			      (or (member class
					  (semantic-tag-type-superclasses tok))
				  (member class
					  (semantic-tag-type-interfaces tok)))))
		       stream sp si))
		    nil nil nil t t))
	 (children-nodes nil)
	 (ymax 0)
	 (xmax 0)
	 (x-accum 0)
	 (y-accum 0))
    ;; Create a new graph
    (cogre class 'cogre-semantic-uml-graph)
    (goto-char (point-min))
    ;; Create all the parent nodes in the graph, and align them.
    (while parent
      (setq parent-nodes
	    (cons (make-instance cogre-semantic-class
				 :position (vector x-accum y-accum)
				 :class (car parent))
		  parent-nodes))
      (cogre-node-rebuild (car parent-nodes))
      (setq x-accum (+ x-accum
		       (length (car (oref (car parent-nodes) rectangle)))
		       cogre-horizontal-margins))
      (setq ymax (max ymax (length (oref (car parent-nodes) rectangle))))
      (setq parent (cdr parent)))
    (setq xmax (- x-accum cogre-horizontal-margins))
    ;; Create this class
    (setq x-accum 0)
    (setq y-accum (+ y-accum ymax cogre-vertical-margins))
    (setq class-node
	  (make-instance 'cogre-semantic-class
			 :position (vector x-accum y-accum)
			 :class class-tok))
    (cogre-node-rebuild class-node)
    (setq ymax (length (oref class-node rectangle)))
    ;; Creawte all the children nodes, and align them.
    (setq x-accum 0)
    (setq y-accum (+ y-accum ymax cogre-vertical-margins))
    (while children
      (let ((c (cdr (car children))))
	(while c
	  (setq children-nodes
		(cons (make-instance 'cogre-semantic-class
				     :position (vector x-accum y-accum)
				     :class (car c))
		      children-nodes))
	  (cogre-node-rebuild (car children-nodes))
	  (setq x-accum (+ x-accum
			   (length (car (oref (car children-nodes) rectangle)))
			   cogre-horizontal-margins))
	  (setq c (cdr c))))
      (setq children (cdr children)))
    (setq xmax (max xmax (- x-accum cogre-horizontal-margins)))
    ;; Center all the nodes to eachother.
    (let ((shift 0)
	  (delta 0)
	  (lines (list parent-nodes
		       (list class-node)
		       children-nodes))
	  (maxn nil)
	  )
      (while lines
	(setq maxn (car (car lines)))
	(when maxn
	  ;;(cogre-node-rebuild maxn)
	  (setq delta (- xmax (aref (oref maxn position) 0)
			 (length (car (oref maxn rectangle)))))
	  (when (> delta 0)
	    (setq shift (/ delta 2))
	    (mapcar (lambda (n) (cogre-move-delta n shift 0))
		    (car lines))))
	(setq lines (cdr lines)))
      )
    ;; Link everyone together
    (let ((n parent-nodes))
      (while n
	(make-instance 'cogre-inherit :start class-node :end (car n))
	(setq n (cdr n)))
      (setq n children-nodes)
      (while n
	(make-instance 'cogre-inherit :start (car n) :end class-node)
	(setq n (cdr n))))
    ;; Refresh the graph
    (cogre-refresh)
    ))

;;;###autoload
(defun cogre-uml-create (class)
  "Create a new UML diagram, with CLASS as the root node.
CLASS must be a type in the current project."
  (interactive (list (cogre-read-class-name)))
  (let ((root (semanticdb-strip-find-results
	       (semanticdb-find-tags-by-name class) t))
	)
    ;; Implement this some day.
    ))

(provide 'uml-create)

;;; uml-create.el ends here