Merge pull request #634 from moosetechnology/add-visualizations

Add visualizations

src/BaselineOfFamix/BaselineOfFamix.class.st

@@ -161,6 +161,8 @@ BaselineOfFamix >> packages: spec [
 		with: [ spec requires: #( 'Moose-Core' 'SingularizePluralize' ) ];
 		package: 'Famix-MetamodelGeneration'
 		with: [ spec requires: #( 'Famix-MetamodelBuilder-Core' ) ];
+		package: 'Famix-Visualizations'
+		with: [ spec requires: #( 'Famix-Traits' 'Fame' 'Moose-Core' ) ];
 		package: 'Famix-BasicInfrastructure'
 		with: [ spec requires: #( 'Famix-MetamodelGeneration' ) ];
 		package: 'Famix-Smalltalk-Utils'
@@ -277,10 +279,12 @@ BaselineOfFamix >> packages: spec [
 		with: [ spec requires: #( 'Famix-TestComposedMetamodel-Entities' ) ];
 		package: 'Famix-Deprecated'
 		with: [
-			spec requires: #( 'Core' 'ModelJava' 'ModelSmalltalk' 'Tests' ) ];
+			spec requires: #( 'Core' 'ModelJava' 'ModelSmalltalk'
+				   'Tests' ) ];
 		package: 'Famix-UMLDocumentor' with: [ spec requires: #( 'Core' ) ];
 		package: 'Famix-UMLDocumentor-Tests' with: [
-			spec requires: #( 'Famix-UMLDocumentor' 'FamixDocumentor-TestMetaModel' ) ];
+			spec requires:
+					#( 'Famix-UMLDocumentor' 'FamixDocumentor-TestMetaModel' ) ];
 		package: 'FamixDocumentor-TestMetaModel'
 ]
 

src/Famix-Visualizations/FM3Class.extension.st

@@ -0,0 +1,7 @@
+Extension { #name : #FM3Class }
+
+{ #category : #'*Famix-Visualizations' }
+FM3Class >> connections [
+
+	^ FameClassConnections forFameClass: self
+]

src/Famix-Visualizations/FameClassConnections.class.st

@@ -0,0 +1,178 @@
+"
+I show commplex properties of a F3Class.
+
+The class is shown in blue, as well as its complex properties.
+The opposites of these properties are shown in gray, as well as their type.
+In light blue is shown the relation between each property and its opposite.
+"
+Class {
+	#name : #FameClassConnections,
+	#superclass : #MooseAbstractVisualization,
+	#instVars : [
+		'fameClass'
+	],
+	#category : #'Famix-Visualizations-Fame'
+}
+
+{ #category : #accessing }
+FameClassConnections class >> defaultTitle [
+	^ 'Connections'
+]
+
+{ #category : #'as yet unclassified' }
+FameClassConnections class >> forFameClass: aFM3Class [
+	^ self new
+		fameClass: aFM3Class;
+		yourself
+]
+
+{ #category : #accessing }
+FameClassConnections class >> icon [
+	^ MooseIcons mooseDependencies
+]
+
+{ #category : #building }
+FameClassConnections >> build [
+	| classNode complexPropertyTypes complexProperties oppositeProperties |
+	classNode := self buildClassNode.
+	complexPropertyTypes := self buildOppositeClassesNodes.
+	complexProperties := self buildPropertiesNodes.
+	oppositeProperties := self buildOppositePropertiesNodes.
+	self connectClassNode: classNode toProperties: complexProperties.
+	self
+		connectProperties: complexProperties
+		toOpposites: oppositeProperties.
+	self
+		connectOpposites: oppositeProperties
+		toClass: classNode
+		orOtherType: complexPropertyTypes.
+	canvas pushBackEdges.
+	RSForceBasedLayout new on: canvas nodes.
+	super build
+]
+
+{ #category : #building }
+FameClassConnections >> buildClassNode [
+	| classNode |
+	classNode := (self nodeFor: fameClass)
+		color: self highlightColor;
+		size: self typeNodeSize;
+		yourself.
+	canvas add: classNode.
+	^ classNode
+]
+
+{ #category : #building }
+FameClassConnections >> buildLegend [
+	| legend |
+	legend := RSLegend new.
+	legend container: self canvas.
+	legend onDemand.
+	legend title: self class defaultTitle.
+	legend
+		text: 'FM3Class and its complex properties'
+		withCircleColor: self highlightColor.
+	legend
+		text: 'Properties opposites and their type (can be the FM3Class)'
+		withCircleColor: self oppositeColor.
+	legend
+		text: 'Opposites relations'
+		withBoxColor: (self highlightColor alpha: 0.5).
+	legend build
+]
+
+{ #category : #building }
+FameClassConnections >> buildOppositeClassesNodes [
+	| nodes |
+	nodes := (((fameClass complexProperties collect: #type) \ {fameClass})
+		asSet
+		collect: [ :class | 
+			(self nodeFor: class)
+				color: self oppositeColor;
+				size: self typeNodeSize;
+				yourself ]) asArray.
+	canvas addAll: nodes.
+	^ nodes
+]
+
+{ #category : #building }
+FameClassConnections >> buildOppositePropertiesNodes [
+	| nodes |
+	nodes := (fameClass complexProperties
+		collect: #opposite
+		thenReject: #isNil)
+		collect: [ :opposite | 
+			(self nodeFor: opposite)
+				color: self oppositeColor;
+				yourself ].
+	canvas addAll: nodes.
+	^ nodes
+]
+
+{ #category : #building }
+FameClassConnections >> buildPropertiesNodes [
+	| nodes |
+	nodes := fameClass complexProperties
+		collect: [ :property | 
+			(self nodeFor: property)
+				color: self highlightColor;
+				yourself ].
+	canvas addAll: nodes.
+	^ nodes
+]
+
+{ #category : #building }
+FameClassConnections >> connectClassNode: classNode toProperties: complexProperties [
+	RSEdgeBuilder line
+		color: self highlightColor;
+		fromShapes: {classNode};
+		toShapes: complexProperties;
+		connectToAll: #complexProperties
+]
+
+{ #category : #building }
+FameClassConnections >> connectOpposites: oppositeProperties toClass: classNode orOtherType: complexPropertyTypes [
+	RSEdgeBuilder line
+		color: self oppositeColor;
+		fromShapes: oppositeProperties;
+		toShapes: {classNode} , complexPropertyTypes;
+		connectTo: #mmClass
+]
+
+{ #category : #building }
+FameClassConnections >> connectProperties: complexProperties toOpposites: oppositeProperties [
+	RSEdgeBuilder line
+		color: (self highlightColor alpha: 0.5);
+		fromShapes: complexProperties;
+		toShapes: oppositeProperties;
+		connectTo: #opposite
+]
+
+{ #category : #accessing }
+FameClassConnections >> fameClass: aFM3Class [
+	fameClass := aFM3Class
+]
+
+{ #category : #shapes }
+FameClassConnections >> highlightColor [
+	^ Color blue
+]
+
+{ #category : #shapes }
+FameClassConnections >> nodeFor: aModel [
+	^ RSCircle new
+		model: aModel;
+		popupText: #name;
+		draggable;
+		yourself
+]
+
+{ #category : #shapes }
+FameClassConnections >> oppositeColor [
+	^ Color lightGray
+]
+
+{ #category : #shapes }
+FameClassConnections >> typeNodeSize [
+	^ 20
+]

src/Famix-Visualizations/FamixAnnotationTypeGroup.extension.st

@@ -0,0 +1,14 @@
+Extension { #name : #FamixAnnotationTypeGroup }
+
+{ #category : #'*Famix-Visualizations' }
+FamixAnnotationTypeGroup >> annotationConstellation [
+
+	^ FamixAnnotationTypeGroupConstellation forAnnotationTypeGroup: self
+]
+
+{ #category : #'*Famix-Visualizations' }
+FamixAnnotationTypeGroup >> inspectorShowAnnotationConstellation [
+
+	<inspectorPresentationOrder: 10 title: 'Annotation Constellation'>
+	^ self annotationConstellation asInspectorPresenter
+]

src/Famix-Visualizations/FamixAnnotationTypeGroupConstellation.class.st

@@ -0,0 +1,112 @@
+"
+I show annotationTypes and the entities annotated with their instances.
+"
+Class {
+	#name : #FamixAnnotationTypeGroupConstellation,
+	#superclass : #MooseAbstractVisualization,
+	#instVars : [
+		'famixAnnotationTypeGroup'
+	],
+	#category : #'Famix-Visualizations-Core'
+}
+
+{ #category : #accessing }
+FamixAnnotationTypeGroupConstellation class >> defaultTitle [
+	^ 'Annotations constellation'
+]
+
+{ #category : #public }
+FamixAnnotationTypeGroupConstellation class >> forAnnotationTypeGroup: aFamixAnnotationTypeGroup [
+	^ self new
+		famixAnnotationTypeGroup: aFamixAnnotationTypeGroup;
+		yourself
+]
+
+{ #category : #accessing }
+FamixAnnotationTypeGroupConstellation class >> icon [
+	^ MooseIcons mooseDependencies
+]
+
+{ #category : #building }
+FamixAnnotationTypeGroupConstellation >> build [
+	| containerNodes annotationLabels |
+	containerNodes := self buildAnnotationContainerNodes.
+	annotationLabels := self buildAnnotationTypeLabels.
+	self connectLabels: annotationLabels toNodes: containerNodes.
+	RSForceBasedLayout on: canvas nodes.
+	canvas pushBackEdges.
+	super build
+]
+
+{ #category : #building }
+FamixAnnotationTypeGroupConstellation >> buildAnnotationContainerNodes [
+	| annotationContainers nodes |
+	annotationContainers := famixAnnotationTypeGroup
+		flatCollectAsSet:
+			[ :annotationType | annotationType instances collect: #annotatedEntity ].
+	nodes := annotationContainers
+		collect: [ :c | self nodeForAnnotatedEntity: c ].
+	canvas addAll: nodes.
+	^ nodes
+]
+
+{ #category : #building }
+FamixAnnotationTypeGroupConstellation >> buildAnnotationTypeLabels [
+	| labels |
+	labels := famixAnnotationTypeGroup
+		collect:
+			[ :annotationType | self labelForAnnotationType: annotationType ].
+	canvas addAll: labels.
+	^ labels
+]
+
+{ #category : #building }
+FamixAnnotationTypeGroupConstellation >> buildLegend [
+	| legend |
+	legend := RSLegend new.
+	legend container: self canvas.
+	legend onDemand.
+	legend title: self class defaultTitle.
+	legend
+		text: 'Annotation types and the entities using their instances'.
+	legend text: 'Annotated entities' withCircleColor: self nodeColor.
+	legend build
+]
+
+{ #category : #building }
+FamixAnnotationTypeGroupConstellation >> connectLabels: annotationLabels toNodes: containerNodes [
+	RSLineBuilder line
+		fromShapes: annotationLabels;
+		toShapes: containerNodes;
+		color: Color veryLightGray;
+		connectToAll:
+				[ :annotationType | annotationType instances collect: #annotatedEntity ]
+]
+
+{ #category : #initialization }
+FamixAnnotationTypeGroupConstellation >> famixAnnotationTypeGroup: aFamixAnnotationTypeGroup [
+	famixAnnotationTypeGroup := aFamixAnnotationTypeGroup
+]
+
+{ #category : #shapes }
+FamixAnnotationTypeGroupConstellation >> labelForAnnotationType: annotationType [
+	^ (RSLabel text: annotationType name model: annotationType)
+		draggable;
+		color: Color black;
+		yourself
+]
+
+{ #category : #shapes }
+FamixAnnotationTypeGroupConstellation >> nodeColor [
+	^ Color lightGray
+]
+
+{ #category : #shapes }
+FamixAnnotationTypeGroupConstellation >> nodeForAnnotatedEntity: entity [
+	^ RSCircle new
+		model: entity;
+		color: self nodeColor;
+		popup;
+		draggable;
+		yourself
+]

src/Famix-Visualizations/FamixNamespaceGroup.extension.st

@@ -0,0 +1,20 @@
+Extension { #name : #FamixNamespaceGroup }
+
+{ #category : #'*Famix-Visualizations' }
+FamixNamespaceGroup >> hierarchy [
+
+	^ FamixNamespaceGroupHierarchy forNamespaceGroup: self
+]
+
+{ #category : #'*Famix-Visualizations' }
+FamixNamespaceGroup >> inspectorShowInHierarchy [
+
+	<inspectorPresentationOrder: 10 title: 'Hierarchy'>
+	^ self withinOverallHierarchy asInspectorPresenter
+]
+
+{ #category : #'*Famix-Visualizations' }
+FamixNamespaceGroup >> withinOverallHierarchy [
+
+	^ FamixNamespaceGroupOverallHierarchy forNamespaceGroup: self
+]