cogre / uml-create.el

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
 ;;; 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$

;; 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
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.