cgit.sxemacs.org Git - packages/blob - xemacs-packages/cogre/uml-create.el

   1  ;;; cogre-uml.el --- UML support for COGRE
   2
   3 ;;; Copyright (C) 2001, 2002, 2003, 2004, 2007 Eric M. Ludlam
   4
   5 ;; Author: Eric M. Ludlam <zappo@gnu.org>
   6 ;; Keywords: oop, uml
   7 ;; X-RCS: $Id: uml-create.el,v 1.1 2007-11-26 15:04:26 michaels Exp $
   8
   9 ;; This file is not part of GNU Emacs.
  10
  11 ;; This is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15
  16 ;; This software is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  24 ;; Boston, MA 02110-1301, USA.
  25
  26 ;;; Commentary:
  27 ;;
  28 ;; Routines used to create UML diagrams from Semantic generated reverse
  29 ;; engineered token databases.
  30
  31 (require 'cogre-uml)
  32 (require 'semantic)
  33 (require 'semanticdb)
  34 (require 'semanticdb-find)
  35
  36 ;;; Code:
  37 (defclass cogre-semantic-uml-graph (cogre-graph)
  38   nil
  39   "This graph is for semantic oriented UML diagrams.")
  40
  41 (defmethod cogre-insert-class-list ((graph cogre-semantic-uml-graph))
  42   "Return a list of classes GRAPH will accept."
  43   (append (eieio-build-class-alist 'cogre-link)
  44           (eieio-build-class-alist 'cogre-semantic-class)
  45           (eieio-build-class-alist 'cogre-package)))
  46
  47 (defclass cogre-semantic-class (cogre-class)
  48   nil
  49   "A Class node linked to semantic parsed buffers.
  50 Inherits from the default UML class node type, and adds user
  51 interfacing which links working with this node directly to source
  52 code.")
  53
  54 (defmethod cogre-save ((graph cogre-semantic-uml-graph))
  55   "Save the current GRAPH."
  56   ;; Autogenerated graphcs have semantic tags in them which are often
  57   ;; linked via overlay into a buffer.  We need to write something
  58   ;; special to unlink (clone?) those tags so they are saveable.
  59   ;;(error "You cannot save autogenerated graphs")
  60
  61   ;; Doing this allows the graph to be saved.  Some bugs in saving
  62   ;; these graphs have been made.  Try it out for a while.
  63   (call-next-method)
  64   )
  65
  66 (defmethod initialize-instance ((this cogre-semantic-class) &optional fields)
  67   "When interactively creating a class node THIS, query for the class name.
  68 Optional argument FIELDS are not used."
  69   (call-next-method)
  70   (if (string-match "^Class[0-9]*" (oref this object-name))
  71       ;; In this case, we have a default class object-name, so try and query
  72       ;; for the real class (from sources) which we want to use.
  73       (let* ((class (or (oref this class) (cogre-read-class-name)))
  74              (tag (if (semantic-tag-p class)
  75                       class
  76                     (car
  77                      (semanticdb-strip-find-results
  78                       (semanticdb-brute-deep-find-tags-by-name class)
  79                       t))))
  80              )
  81         (when tag
  82           ;; We need to clone the tag to unlink our storage from any
  83           ;; buffer it may be associated with.
  84           (setq tag (semantic-tag-copy tag nil t)))
  85
  86         (if (semantic-tag-p class) (setq class (semantic-tag-name class)))
  87         (if (and tag (eq (semantic-tag-class tag) 'type)
  88                  (or (string= (semantic-tag-type tag) "class")
  89                      (string= (semantic-tag-type tag) "struct")))
  90             (let ((slots (semantic-tag-type-members tag))
  91                   (extmeth (semantic-tag-external-member-children tag t))
  92                   attrib method)
  93               ;; Bin them up
  94               (while slots
  95                 (cond
  96                  ;; A plain string, a simple language, just do attributes.
  97                  ((stringp (car slots))
  98                   (setq attrib (cons (list (car slots) 'variable nil)
  99                                      attrib))
 100                   )
 101                  ;; Variable decl is an attribute
 102                  ((eq (semantic-tag-class (car slots)) 'variable)
 103                   (setq attrib (cons (car slots) attrib)))
 104                  ;; A function decle is a method.
 105                  ((eq (semantic-tag-class (car slots)) 'function)
 106                   (setq method (cons (car slots) method)))
 107                  )
 108                 (setq slots (cdr slots)))
 109               ;; Add in all those extra methods
 110               (while extmeth
 111                 (let ((sl (cdr (car extmeth))))
 112                   (while sl
 113                     (if (eq (semantic-tag-class (car sl)) 'function)
 114                         (setq method (cons (car sl) method)))
 115                     (setq sl (cdr sl))))
 116                 (setq extmeth (cdr extmeth)))
 117               ;; Put them into the class.
 118               (oset this object-name class)
 119               (oset this class tag)
 120               (oset this attributes (nreverse attrib))
 121               (oset this methods (nreverse method))
 122               ;; Tada!
 123               )
 124           ;; We couldn't find a semantic tag for this class, so just
 125           ;; put the name in there.
 126           (cond ((stringp class)
 127                  (oset this object-name class))
 128                 ((and (listp class)
 129                       (stringp (car class)))
 130                  (oset this object-name (car class)))
 131                 (t nil))
 132           (oset this class nil)
 133           (oset this attributes nil)
 134           (oset this methods nil)
 135           )))
 136   this)
 137
 138 ;; Saving such graphs is not good!  We can't reliably restore the overlays
 139 ;; since we should switch to the originating buffer for every one!  Yuck!
 140
 141 ;; (defmethod cogre-element-pre-serialize ((node cogre-semantic-class))
 142 ;;   "Prepare the current NODE to be serialized.
 143 ;; Deoverlay all semantic tokens referenced."
 144 ;;   (call-next-method)
 145 ;;   (semantic-deoverlay-list (oref node class))
 146 ;;   (semantic-deoverlay-list (oref node attributes))
 147 ;;   (semantic-deoverlay-list (oref node methods))
 148 ;;   )
 149
 150 ;; (defmethod cogre-element-post-serialize ((node cogre-semantic-class))
 151 ;;   "Restore overlays in NODE after being loaded from disk.
 152 ;; Also called after a graph was saved to restore all objects.
 153 ;; Reverses `cogre-graph-pre-serialize'."
 154 ;;   (call-next-method)
 155 ;;   (semantic-overlay-list (oref node class))
 156 ;;   (semantic-overlay-list (oref node attributes))
 157 ;;   (semantic-overlay-list (oref node methods))
 158 ;;   )
 159
 160 (defcustom cogre-token->uml-function 'semantic-uml-abbreviate-nonterminal
 161   "Function to use to create strings for tokens in CLASS nodes."
 162   :group 'cogre
 163   :type semantic-format-tag-functions)
 164
 165
 166 (defmethod cogre-uml-stoken->uml ((class cogre-semantic-class) stoken &optional text)
 167   "For CLASS convert a Semantic token STOKEN into a uml definition.
 168 Optional TEXT property is passed down."
 169   ;; We need to disable images because our diagram is still
 170   ;; pretty unstable.
 171   (let ((semantic-format-use-images-flag nil))
 172     (call-next-method class stoken
 173                       (save-excursion
 174                         (let ((tb (or (semantic-tag-buffer stoken)
 175                                       (semantic-tag-buffer (oref class class)))))
 176                           (if tb (set-buffer tb))
 177                           (funcall cogre-token->uml-function
 178                                    stoken
 179                                    (oref class class)
 180                                    t))))
 181     ))
 182
 183 (defmethod cogre-entered ((class cogre-semantic-class) start end)
 184   "Method called when the cursor enters CLASS.
 185 START and END cover the region with the property."
 186   (cogre-uml-source-display class (point))
 187   (call-next-method))
 188
 189 (defmethod cogre-left ((class cogre-semantic-class) start end)
 190   "Method called when the cursor exits CLASS.
 191 START and END cover the region with the property."
 192   (call-next-method))
 193
 194 ;;; Screen Manager
 195 ;;
 196 ;; Manage the display of the source buffer somewhere near the class diagram
 197 ;; in a nice way.
 198 (defcustom cogre-uml-source-display-method
 199   'cogre-uml-source-display-bottom
 200   "A Function called to display a source buffer associated with a Graph.
 201 This function can be anything, or nil, though the following options
 202 are preferred:
 203  `cogre-uml-source-display-bottom' - in a window on the bottom of the frame.
 204  `cogre-uml-source-display-top' - in a window on the top of the frame.
 205 The function specified must take a `point-marker' to specify the
 206 location that is to be displayed."
 207   :group 'cogre
 208   :type '(choice (const 'cogre-uml-source-display-bottom)
 209                  (const 'cogre-uml-source-display-top)
 210                  ))
 211
 212 (defcustom cogre-uml-browse-token-hook nil
 213   "*Hooks run when a token is browsed by the COGRE graph.
 214 Each hook takes one argument, and one optional argument, the token
 215 being browsed too, and a containing parent token, if available.
 216 This is run when the token is first found, not during the actual
 217 browse.  The token will be under point when this hook is called.
 218 Changing window configurations is not recommended."
 219   :group 'cogre
 220   :type 'function
 221   )
 222
 223 (defun cogre-uml-browse-token-highlight-hook-fn (tok &optional parent)
 224   "Momentarilly highlight TOK.  Ignore PARENT.
 225 Function useable by `cogre-uml-browse-token-hook'."
 226   (semantic-momentary-highlight-tag tok))
 227
 228 (defmethod cogre-uml-source-marker ((class cogre-semantic-class) token)
 229   "Return a marker position for a CLASS containing TOKEN.
 230 This returned marker will be in the source file of the attribute,
 231 method, or class definition.  nil if there is not match."
 232   (let ((semc (oref class class))
 233         (p nil))
 234     (cond ((and token (semantic-tag-with-position-p token))
 235            (setq p (save-excursion
 236                      (semantic-go-to-tag token)
 237                      (run-hook-with-args
 238                       'cogre-uml-browse-token-hook
 239                       token)
 240                      (point-marker))
 241                  ))
 242           ((and token (semantic-tag-with-position-p semc))
 243            (setq p (save-excursion
 244                      (semantic-go-to-tag token semc)
 245                      (run-hook-with-args
 246                       'cogre-uml-browse-token-hook
 247                       token semc)
 248                      (point-marker))
 249                  ))
 250           ((and semc (semantic-tag-with-position-p semc))
 251            (setq p (save-excursion
 252                      (semantic-go-to-tag semc)
 253                      (run-hook-with-args
 254                       'cogre-uml-browse-token-hook
 255                       semc)
 256                      (point-marker))
 257                  ))
 258           (t nil))
 259     p))
 260
 261 (defmethod cogre-uml-source-display ((class cogre-semantic-class) point)
 262   "Display source code associated with CLASS based on text at POINT.
 263 The text must be handled by an overlay of some sort which has the
 264 semantic token we need as a property.  If not, then nothing happens.
 265 Uses `cogre-uml-source-display-method'."
 266   (let* ((sem (get-text-property point 'semantic))
 267          (p (cogre-uml-source-marker class sem)))
 268     (when p
 269       (save-excursion
 270         (funcall cogre-uml-source-display-method p))
 271       ))
 272   )
 273
 274 (defmethod cogre-activate ((class cogre-semantic-class))
 275   "Activate CLASS.
 276 This could be as simple as displaying the current state,
 277 customizing the object, or performing some complex task."
 278   (let* ((sem (get-text-property (point) 'semantic))
 279          (p (cogre-uml-source-marker class sem))
 280          (cp (point-marker)))
 281     (if (not p)
 282         (error "No source to jump to")
 283       ;; Activating is the reverse of just showing the sorce
 284       (switch-to-buffer (marker-buffer p))
 285       (funcall cogre-uml-source-display-method cp)
 286       ))
 287   )
 288
 289 (defcustom cogre-uml-source-display-window-size 5
 290   "Size of same-frame window displaying source code."
 291   :group 'cogre
 292   :type 'integer)
 293
 294 (defun cogre-uml-source-display-bottom (m)
 295   "Display point M in a small buffer on the bottom of the current frame."
 296   (if (not (eq (next-window) (selected-window)))
 297       (cogre-uml-source-display-other-window m)
 298     (split-window-vertically (- (window-height)
 299                                 cogre-uml-source-display-window-size
 300                                 1))
 301     (other-window 1)
 302     (switch-to-buffer (marker-buffer m) t)
 303     (recenter 1)
 304     (goto-char m)
 305     (other-window -1))
 306   )
 307
 308 (defun cogre-uml-source-display-other-window (m)
 309   "Display point M in other window."
 310   (other-window 1)
 311   (switch-to-buffer (marker-buffer m) t)
 312   (goto-char m)
 313   (recenter 1)
 314   (other-window -1)
 315   )
 316
 317 ;;; Auto-Graph generation
 318 ;;
 319 ;; Functions for creating a graph from semantic parts.
 320 (defvar cogre-class-history nil
 321   "History for inputting class names.")
 322
 323 (defun cogre-read-class-name ()
 324   "Read in a class name to be used by a cogre node."
 325   (let ((finddefaultlist (semantic-find-tag-by-overlay))
 326         class prompt stream
 327         )
 328     ;; Assume the top most item is the all encompassing class.
 329     (if finddefaultlist
 330         (setq class (car finddefaultlist)))
 331     ;; Make sure our class is really a class
 332     (if (not (and
 333               class
 334               (eq (semantic-tag-class class) 'type)
 335               (string= (semantic-tag-type class) "class")))
 336         (setq class nil)
 337       (setq class (semantic-tag-name class)))
 338     ;; Create a prompt
 339     (setq prompt (if class (concat "Class (default " class "): ") "Class: "))
 340     ;; Get the stream used for completion.
 341     (let ((types (semanticdb-strip-find-results
 342                   (semanticdb-brute-find-tags-by-class 'type)
 343                   ;; Don't find-file-match.  Just need names.
 344                   )))
 345       (setq stream (semantic-find-tags-by-type "class" types)))
 346     ;; Do the query
 347     (completing-read prompt stream
 348                      nil nil nil 'cogre-class-history
 349                      class)
 350     ))
 351
 352 ;;;###autoload
 353 (defun cogre-uml-quick-class (class)
 354   "Create a new UML diagram based on CLASS showing only immediate lineage.
 355 The parent to CLASS, CLASS, and all of CLASSes children will be shown."
 356   (interactive (list (cogre-read-class-name)))
 357   (let* ((class-tok (car (semanticdb-strip-find-results
 358                           (semanticdb-brute-deep-find-tags-by-name class) t)))
 359          (class-node nil)
 360          (parent (semantic-tag-type-superclasses class-tok))
 361          (parent-nodes nil)
 362          (children (semanticdb-find-nonterminal-by-function
 363                     (lambda (stream sp si)
 364                       (semantic-brute-find-tag-by-function
 365                        (lambda (tok)
 366                          (and (eq (semantic-tag-class tok) 'type)
 367                               (or (member class
 368                                           (semantic-tag-type-superclasses tok))
 369                                   (member class
 370                                           (semantic-tag-type-interfaces tok)))))
 371                        stream sp si))
 372                     nil nil nil t t))
 373          (children-nodes nil)
 374          (ymax 0)
 375          (xmax 0)
 376          (x-accum 0)
 377          (y-accum 0))
 378     ;; Create a new graph
 379     (cogre class 'cogre-semantic-uml-graph)
 380     (goto-char (point-min))
 381     ;; Create all the parent nodes in the graph, and align them.
 382     (while parent
 383       (setq parent-nodes
 384             (cons (make-instance cogre-semantic-class
 385                                  :position (vector x-accum y-accum)
 386                                  :class (car parent))
 387                   parent-nodes))
 388       (cogre-node-rebuild (car parent-nodes))
 389       (setq x-accum (+ x-accum
 390                        (length (car (oref (car parent-nodes) rectangle)))
 391                        cogre-horizontal-margins))
 392       (setq ymax (max ymax (length (oref (car parent-nodes) rectangle))))
 393       (setq parent (cdr parent)))
 394     (setq xmax (- x-accum cogre-horizontal-margins))
 395     ;; Create this class
 396     (setq x-accum 0)
 397     (setq y-accum (+ y-accum ymax cogre-vertical-margins))
 398     (setq class-node
 399           (make-instance 'cogre-semantic-class
 400                          :position (vector x-accum y-accum)
 401                          :class class-tok))
 402     (cogre-node-rebuild class-node)
 403     (setq ymax (length (oref class-node rectangle)))
 404     ;; Creawte all the children nodes, and align them.
 405     (setq x-accum 0)
 406     (setq y-accum (+ y-accum ymax cogre-vertical-margins))
 407     (while children
 408       (let ((c (cdr (car children))))
 409         (while c
 410           (setq children-nodes
 411                 (cons (make-instance 'cogre-semantic-class
 412                                      :position (vector x-accum y-accum)
 413                                      :class (car c))
 414                       children-nodes))
 415           (cogre-node-rebuild (car children-nodes))
 416           (setq x-accum (+ x-accum
 417                            (length (car (oref (car children-nodes) rectangle)))
 418                            cogre-horizontal-margins))
 419           (setq c (cdr c))))
 420       (setq children (cdr children)))
 421     (setq xmax (max xmax (- x-accum cogre-horizontal-margins)))
 422     ;; Center all the nodes to eachother.
 423     (let ((shift 0)
 424           (delta 0)
 425           (lines (list parent-nodes
 426                        (list class-node)
 427                        children-nodes))
 428           (maxn nil)
 429           )
 430       (while lines
 431         (setq maxn (car (car lines)))
 432         (when maxn
 433           ;;(cogre-node-rebuild maxn)
 434           (setq delta (- xmax (aref (oref maxn position) 0)
 435                          (length (car (oref maxn rectangle)))))
 436           (when (> delta 0)
 437             (setq shift (/ delta 2))
 438             (mapcar (lambda (n) (cogre-move-delta n shift 0))
 439                     (car lines))))
 440         (setq lines (cdr lines)))
 441       )
 442     ;; Link everyone together
 443     (let ((n parent-nodes))
 444       (while n
 445         (make-instance 'cogre-inherit :start class-node :end (car n))
 446         (setq n (cdr n)))
 447       (setq n children-nodes)
 448       (while n
 449         (make-instance 'cogre-inherit :start (car n) :end class-node)
 450         (setq n (cdr n))))
 451     ;; Refresh the graph
 452     (cogre-refresh)
 453     ))
 454
 455 ;;;###autoload
 456 (defun cogre-uml-create (class)
 457   "Create a new UML diagram, with CLASS as the root node.
 458 CLASS must be a type in the current project."
 459   (interactive (list (cogre-read-class-name)))
 460   (let ((root (semanticdb-strip-find-results
 461                (semanticdb-find-tags-by-name class) t))
 462         )
 463     ;; Implement this some day.
 464     ))
 465
 466 (provide 'uml-create)
 467
 468 ;;; uml-create.el ends here