Marcel Taeumel uploaded a new version of Tools to project The Inbox:
http://source.squeak.org/inbox/Tools-mt.536.mcz

==================== Summary ====================

Name: Tools-mt.536
Author: mt
Time: 1 March 2015, 9:35:39.627 pm
UUID: 1ab7460c-c7be-f647-a881-9bca8ab6e605
Ancestors: Tools-mt.535

NEW TOOL: Object Collection Tool

Drag and drop classes or methods from the browser into it to open mini-editors in a list. Dropping morphs will open an object explorer for that morph.

ObjectCollectionTool open.

=============== Diff against Tools-mt.535 ===============

Item was added:
+ Morph subclass: #ObjectCollectionItem
+ 	instanceVariableNames: 'object'
+ 	classVariableNames: ''
+ 	poolDictionaries: ''
+ 	category: 'Tools-Browser'!

Item was added:
+ ----- Method: ObjectCollectionItem class>>on:object: (in category 'instance creation') -----
+ on: aMorph object: anObject
+ 
+ 	aMorph
+ 		hResizing: #spaceFill;
+ 		vResizing: #spaceFill.
+ 	
+ 	^ self new
+ 		object: anObject;
+ 		addMorphFront: aMorph;
+ 		yourself!

Item was added:
+ ----- Method: ObjectCollectionItem>>fastFramingOn (in category 'compatibility') -----
+ fastFramingOn
+ 	"Compatibility with system window interface. Needed by grip morphs."
+ 	
+ 	^ false!

Item was added:
+ ----- Method: ObjectCollectionItem>>initialize (in category 'initialization') -----
+ initialize
+ 
+ 	super initialize.
+ 	self
+ 		height: 200;
+ 		color: Color transparent;
+ 		layoutPolicy: TableLayout new;
+ 		listDirection: #topToBottom;
+ 		hResizing: #spaceFill;
+ 		vResizing: #rigid.
+ 
+ 	self addMorph: (BottomGripMorph new target: self).!

Item was added:
+ ----- Method: ObjectCollectionItem>>object (in category 'accessing') -----
+ object
+ 
+ 	^ object!

Item was added:
+ ----- Method: ObjectCollectionItem>>object: (in category 'accessing') -----
+ object: anObject
+ 
+ 	object := anObject.!

Item was added:
+ Morph subclass: #ObjectCollectionPane
+ 	instanceVariableNames: 'model'
+ 	classVariableNames: ''
+ 	poolDictionaries: ''
+ 	category: 'Tools-Browser'!

Item was added:
+ ----- Method: ObjectCollectionPane>>acceptDroppingMorph:event: (in category 'drag and drop') -----
+ acceptDroppingMorph: aMorph event: evt
+ 
+ 	self model
+ 		acceptDroppingMorph: aMorph
+ 		event: evt
+ 		inMorph: self.!

Item was added:
+ ----- Method: ObjectCollectionPane>>adoptPaneColor: (in category 'accessing') -----
+ adoptPaneColor: c
+ 
+ 	self
+ 		color: c;
+ 		borderColor: c darker darker.
+ 		
+ 	super adoptPaneColor: c.!

Item was added:
+ ----- Method: ObjectCollectionPane>>drawOn: (in category 'initialization') -----
+ drawOn: aCanvas
+ 
+ 	super drawOn: aCanvas.
+ 
+ 	('Drop objects here or in-between. Close editors with CMD+W.' asText
+ 		addAttribute: (TextColor color: self borderStyle color darker);
+ 		asMorph)
+ 			center: (self center x @ (self bottom - 10));
+ 			drawOn: aCanvas.!

Item was added:
+ ----- Method: ObjectCollectionPane>>initialize (in category 'initialization') -----
+ initialize
+ 
+ 	super initialize.
+ 	self
+ 		height: 200;
+ 		layoutPolicy: TableLayout new;
+ 		layoutInset: (0 at 0 corner: 0 at 25);
+ 		listDirection: #topToBottom;
+ 		hResizing: #spaceFill;
+ 		vResizing: #shrinkWrap;
+ 		dropEnabled: true.!

Item was added:
+ ----- Method: ObjectCollectionPane>>model (in category 'accessing') -----
+ model
+ 
+ 	^ model!

Item was added:
+ ----- Method: ObjectCollectionPane>>model: (in category 'accessing') -----
+ model: anObjectCollectionTool
+ 
+ 	model := anObjectCollectionTool.!

Item was added:
+ ----- Method: ObjectCollectionPane>>removedMorph: (in category 'submorphs-add/remove') -----
+ removedMorph: anItem
+ 
+ 	self model removeObject: anItem object.!

Item was added:
+ ----- Method: ObjectCollectionPane>>submorphAt: (in category 'submorphs-accessing') -----
+ submorphAt: position
+ 
+ 	^ (self morphsAt: position) 
+ 		detect: [:m | self submorphs includes: m]
+ 		ifNone: []!

Item was added:
+ ----- Method: ObjectCollectionPane>>wantsDroppedMorph:event: (in category 'drag and drop') -----
+ wantsDroppedMorph: aMorph event: evt
+ 
+ 	^ self model
+ 		wantsDroppedMorph: aMorph
+ 		event: evt
+ 		inMorph: self!

Item was added:
+ Model subclass: #ObjectCollectionTool
+ 	instanceVariableNames: 'objects'
+ 	classVariableNames: ''
+ 	poolDictionaries: ''
+ 	category: 'Tools-Browser'!

Item was added:
+ ----- Method: ObjectCollectionTool class>>open (in category 'instance creation') -----
+ open
+ 
+ 	^ (ToolBuilder open: self new) model!

Item was added:
+ ----- Method: ObjectCollectionTool class>>windowColorSpecification (in category 'instance creation') -----
+ windowColorSpecification
+ 	"WindowColorRegistry refresh."
+ 	
+ 	^ WindowColorSpec
+ 		classSymbol: self name
+ 		wording: 'Object Collection Tool'
+ 		brightColor: #lightGreen
+ 		pastelColor: #paleGreen
+ 		helpMessage: ''!

Item was added:
+ ----- Method: ObjectCollectionTool>>acceptDroppingMorph:event:inMorph: (in category 'drag and drop') -----
+ acceptDroppingMorph: transferMorph event: dropEvent inMorph: collectionPane
+ 
+ 	| object |
+ 	object := (transferMorph respondsTo: #passenger)
+ 			ifTrue: [transferMorph passenger]
+ 			ifFalse: [transferMorph].
+ 	self
+ 		buildWidgetFor: object
+ 		then: [:widget |
+ 			(ObjectCollectionItem on: widget object: object) in: [:newItem |
+ 				(collectionPane submorphAt: dropEvent position) 
+ 					ifNil: [collectionPane addMorphBack: newItem]
+ 					ifNotNil: [:m |
+ 						dropEvent position y < m center y
+ 							ifTrue: [collectionPane addMorph: newItem inFrontOf: m]
+ 							ifFalse: [collectionPane addMorph: newItem behind: m]] ].
+ 			self addObject: object].
+ 
+ 	.!

Item was added:
+ ----- Method: ObjectCollectionTool>>addObject: (in category 'accessing - objects') -----
+ addObject: anObject
+ 
+ 	self objects add: anObject.
+ 	self changed: #labelString !

Item was added:
+ ----- Method: ObjectCollectionTool>>buildWidgetFor:then: (in category 'widgets') -----
+ buildWidgetFor: anObject then: actionBlock
+ 
+ 	(anObject isKindOf: CompiledMethod)
+ 		ifTrue: [^ self buildWidgetForCompiledMethod: anObject then: actionBlock].
+ 	(anObject isKindOf: ClassDescription)
+ 		ifTrue: [^ self buildWidgetForClassDescription: anObject then: actionBlock].
+ 
+ 	self buildWidgetForObject: anObject then: actionBlock.!

Item was added:
+ ----- Method: ObjectCollectionTool>>buildWidgetForClassDescription:then: (in category 'widgets') -----
+ buildWidgetForClassDescription: cls then: actionBlock
+ 
+ 	| builder spec menu |
+ 	menu := MenuMorph new
+ 		defaultTarget: [:symbol |
+ 			builder := ToolBuilder default.
+ 			spec := Browser new
+ 				selectSystemCategory: cls category;
+ 				selectClass: cls;
+ 				metaClassIndicated: (symbol = #meta);
+ 				editSelection: #editClass;
+ 				buildCodePaneWith: builder.
+ 			actionBlock value: (builder build: spec)];
+ 		
+ 		add: cls theNonMetaClass name selector: #value: argument: #nonMeta;
+ 		add: cls theMetaClass name selector: #value: argument: #meta;
+ 		popUpAt: self currentEvent position forHand: self currentHand in: self currentWorld.
+ 	
+ 	"We need to trick the window, which will overlap the menu here."
+ 	Project current addDeferredUIMessage:[menu comeToFront].!

Item was added:
+ ----- Method: ObjectCollectionTool>>buildWidgetForCompiledMethod:then: (in category 'widgets') -----
+ buildWidgetForCompiledMethod: method then: actionBlock
+ 
+ 	| builder spec |
+ 	builder := ToolBuilder default.
+ 	spec := Browser new
+ 				selectSystemCategory: method methodClass category;
+ 				selectClass: method methodClass;
+ 				metaClassIndicated: method methodClass isMeta;
+ 				selectMessageNamed: method selector;
+ 				editSelection: #editMessage;
+ 				buildCodePaneWith: builder.
+ 	
+ 	"MethodHolder new
+ 		methodClass: method methodClass methodSelector: method selector;
+ 		buildCodePaneWith: builder."
+ 		
+ 	actionBlock value: (builder build: spec).!

Item was added:
+ ----- Method: ObjectCollectionTool>>buildWidgetForObject:then: (in category 'widgets') -----
+ buildWidgetForObject: anObject then: actionBlock
+ 	"Fall-back if nothing more special can be found."
+ 	
+ 	actionBlock value: (
+ 		"Get rid of the system window."
+ 		Morph new
+ 			changeProportionalLayout;
+ 			color: Color transparent;
+ 			addAllMorphs: (ObjectExplorer new explorerFor: Morph new) paneMorphs;
+ 			yourself).
+ !

Item was added:
+ ----- Method: ObjectCollectionTool>>buildWith: (in category 'toolbuilder') -----
+ buildWith: builder
+ 
+ 	| windowSpec scrollSpec morph |
+ 	windowSpec := builder pluggableWindowSpec new.
+ 	windowSpec
+ 		model: self;
+ 		label: #labelString;
+ 		children: OrderedCollection new.
+ 
+ 	scrollSpec := builder pluggableScrollPaneSpec new.
+ 	scrollSpec
+ 		name: #scrollPane;
+ 		model: self;
+ 		hScrollBarPolicy: #never;
+ 		vScrollBarPolicy: #whenNeeded;
+ 		borderWidth: 0;
+ 		morph: (ObjectCollectionPane new
+ 			model: self;
+ 			yourself);
+ 		frame: (0 at 0 corner: 1 at 1).
+ 	windowSpec children add: scrollSpec.
+ 
+ 	morph := builder build: windowSpec.
+ 
+ 	"Set the layout policy for the transform morph."
+ 	(builder widgetAt: #scrollPane) scroller
+ 		layoutPolicy: TableLayout new;
+ 		color: morph paneColor darker darker.
+ 	(builder widgetAt: #scrollPane) morph
+ 		color: morph paneColor.
+ 	ActiveHand addKeyboardListener: self.
+ 
+ 	^ morph!

Item was added:
+ ----- Method: ObjectCollectionTool>>defaultBackgroundColor (in category 'user interface') -----
+ defaultBackgroundColor
+ 
+ 	self flag: #refactor. "mt: Does not use the preference mechansim."
+ 	^ Color colorFrom: self class windowColorSpecification brightColor!

Item was added:
+ ----- Method: ObjectCollectionTool>>handleListenEvent: (in category 'events-processing') -----
+ handleListenEvent: anEvent
+ 
+ 	"Has something keyboard focus at all?"
+ 	anEvent hand keyboardFocus ifNil: [^ self].
+ 
+ 	"CMD+W?"
+ 	((anEvent isKeystroke
+ 		and: [anEvent commandKeyPressed])
+ 		and: [anEvent keyCharacter = $w])
+ 			ifFalse: [^ self].
+ 
+ 	"Has keyboard?"
+ 	(anEvent hand keyboardFocus firstOwnerSuchThat: [:m |
+ 		m isSystemWindow and: [m model == self]])
+ 			ifNil: [^ self].
+ 			
+ 	"Which item is it?"
+ 	(anEvent hand keyboardFocus firstOwnerSuchThat: [:m |
+ 		m owner class = ObjectCollectionPane]) delete.!

Item was added:
+ ----- Method: ObjectCollectionTool>>labelString (in category 'user interface') -----
+ labelString
+ 
+ 	^ 'Object Collection Tool ({1})' format: {self objects size}!

Item was added:
+ ----- Method: ObjectCollectionTool>>objects (in category 'accessing - objects') -----
+ objects
+ 
+ 	^ objects ifNil: [objects := OrderedCollection new]!

Item was added:
+ ----- Method: ObjectCollectionTool>>removeObject: (in category 'accessing - objects') -----
+ removeObject: anObject
+ 
+ 	self objects remove: anObject.
+ 	self changed: #labelString !

Item was added:
+ ----- Method: ObjectCollectionTool>>wantsDroppedMorph:event:inMorph: (in category 'drag and drop') -----
+ wantsDroppedMorph: transferMorph event: dropEvent inMorph: collectionPane
+ 
+ 	^ collectionPane dropEnabled!

Item was added:
+ ----- Method: ObjectCollectionTool>>windowIsClosing (in category 'updating') -----
+ windowIsClosing
+ 
+ 	ActiveHand removeKeyboardListener: self.!