'From Squeak6.0alpha of 25 April 2021 [latest update: #20458] on 25 April 2021 at 11:55:34 pm'!
"Change Set:		world-drag-classes
Date:			25 April 2021
Author:			Christoph Thiede

<your descriptive text goes here>"

Installer new primMerge: 'Tools-ct.961.mcz' from: MCRepository inbox!


!CodeHolder methodsFor: 'morphic ui' stamp: 'ct 4/25/2021 22:47'!
representsSameBrowseeAs: anotherCodeHolder

	^ self hasUnacceptedEdits not
		and: [self selectedClass == anotherCodeHolder selectedClass]
		and: [self selectedMessage = anotherCodeHolder selectedMessage]! !


!Browser methodsFor: 'drag and drop' stamp: 'ct 4/25/2021 23:47'!
dragFromMessageCategoryList: index

	| class |
	class := self selectedClassOrMetaClass.
	^ (class methodsInCategory: (self messageCategoryList at: index))
		collect: [:selector | (class >> selector) methodReference]! !

!Browser methodsFor: 'drag and drop' stamp: 'ct 4/25/2021 23:04'!
dragFromSystemCategoryList: index

	^ self systemCategoryList at: index! !

!Browser methodsFor: 'drag and drop' stamp: 'ct 4/25/2021 22:40'!
dragTypeForClassListAt: index

	^ #sourceCode! !

!Browser methodsFor: 'drag and drop' stamp: 'ct 4/25/2021 23:46'!
dragTypeForMessageCategoryListAt: index

	^ #sourceCodes! !

!Browser methodsFor: 'drag and drop' stamp: 'ct 4/25/2021 23:06'!
dragTypeForSystemCategoryListAt: index

	^ #(sourceCodeOrganization systemCategory)! !

!Browser methodsFor: 'message functions' stamp: 'ct 4/25/2021 22:50'!
browseMethodFull

	| systemWindow |
	systemWindow := Smalltalk classNamed: #SystemWindow.
	systemWindow ifNil: [^ super browseMethodFull].
	
	^ systemWindow reuseWindows: false during: [
		super browseMethodFull]! !

!Browser methodsFor: 'toolbuilder' stamp: 'ct 4/25/2021 22:40'!
buildClassListWith: builder

	| listSpec |
	listSpec := builder pluggableListSpec new.
	listSpec 
		model: self;
		list: #classList;
		getIndex: #classListIndex; 
		setIndex: #classListIndex:;
		icon: #classIconAt:; 
		menu: #classListMenu:shifted:; 
		keyPress: #classListKey:from:.
	SystemBrowser browseWithDragNDrop ifTrue:[
		listSpec
			dragItem: #dragFromClassList:;
			dragType: #dragTypeForClassListAt:].
	^ listSpec! !

!Browser methodsFor: 'toolbuilder' stamp: 'ct 4/25/2021 23:35'!
buildMessageCategoryListWith: builder
	| listSpec |
	listSpec := builder pluggableListSpec new.
	listSpec 
		model: self;
		list: #messageCategoryList; 
		getIndex: #messageCategoryListIndex; 
		setIndex: #messageCategoryListIndex:; 
		menu: #messageCategoryMenu:; 
		keyPress: #messageCategoryListKey:from:.
	SystemBrowser browseWithDragNDrop ifTrue:[
		listSpec
			dragItem: #dragFromMessageCategoryList:;
			dragType: #dragTypeForMessageCategoryListAt:;
			dropAccept: #wantsMessageCategoriesDrop:;
			dropItem: #dropOnMessageCategories:at:].
	^listSpec! !

!Browser methodsFor: 'toolbuilder' stamp: 'ct 4/25/2021 23:04'!
buildSystemCategoryListWith: builder
	| listSpec |
	listSpec := builder pluggableListSpec new.
	listSpec 
		model: self;
		list: #systemCategoryList; 
		getIndex: #systemCategoryListIndex; 
		setIndex: #systemCategoryListIndex:; 
		menu: #systemCategoryMenu:; 
		keyPress: #systemCatListKey:from:.
	SystemBrowser browseWithDragNDrop ifTrue:[
		listSpec
			dragItem: #dragFromSystemCategoryList:;
			dragType: #dragTypeForSystemCategoryListAt:;
			dropAccept: #wantsSystemCategoriesDrop:;
			dropItem: #dropOnSystemCategories:at:].
	^listSpec! !


!PackagePaneBrowser methodsFor: 'toolbuilder' stamp: 'ct 4/25/2021 23:34'!
buildPackageListWith: builder
	| listSpec |
	listSpec := builder pluggableListSpec new.
	listSpec 
		model: self;
		list: #packageList; 
		getIndex: #packageListIndex; 
		setIndex: #packageListIndex:; 
		menu: #packageMenu:; 
		keyPress: #packageListKey:from:.
	SystemBrowser browseWithDragNDrop ifTrue:[
		listSpec
			dragItem: #dragFromPackageList:;
			dragType: #dragTypeForPackageListAt:].
	^listSpec! !

!PackagePaneBrowser methodsFor: 'drag and drop' stamp: 'ct 4/25/2021 23:28'!
dragFromPackageList: index

	^ self packageList at: index! !

!PackagePaneBrowser methodsFor: 'drag and drop' stamp: 'ct 4/25/2021 23:28'!
dragTypeForPackageListAt: index

	^ #(sourceCodeOrganization package)! !


!PasteUpMorph methodsFor: 'dropping/grabbing' stamp: 'ct 4/25/2021 23:45'!
acceptDroppingMorph: dropped event: evt
	"The supplied morph, known to be acceptable to the receiver, is now to be assimilated; the precipitating event is supplied"

	| aMorph |
	(self isWorldMorph and: [dropped isTransferMorph]) ifTrue: [
		dropped dragTransferType = #filesAndDirectories
			ifTrue: [^ self dropFiles: dropped passenger event: evt].
		dropped dragTransferType = #sourceCode
			ifTrue: [^ self dropSourceCode: dropped passenger event: evt].
		dropped dragTransferType = #sourceCodes
			ifTrue: [^ self dropSourceCodes: dropped passenger event: evt].
		(dropped dragTransferType isEmptyOrNil not and: [dropped dragTransferType first = #sourceCodeOrganization])
			ifTrue: [^ self dropSourceCodeOrganization: dropped passenger type: dropped dragTransferType allButFirst event: evt]].
	
	aMorph := self morphToDropFrom: dropped.
	self isWorldMorph
		ifFalse: [super acceptDroppingMorph: aMorph event: evt]
		ifTrue: 
			["Add the given morph to this world and start stepping it if it wants to be."
			aMorph isInWorld ifFalse: [aMorph position: evt position].
			self addMorphFront: aMorph.
			(aMorph fullBounds intersects: self viewBox) ifFalse:
				[Beeper beep.
				aMorph position: self bounds center]].
	
	aMorph submorphsDo: [:m | (m isKindOf: HaloMorph) ifTrue: [m delete]].
	aMorph allMorphsDo:  "Establish any penDown morphs in new world"
		[:m | | tfm mm |
		m player ifNotNil:
			[m player getPenDown ifTrue:
				[((mm := m player costume) notNil and: [(tfm := mm owner transformFrom: self) notNil])
					ifTrue: [self noteNewLocation: (tfm localPointToGlobal: mm referencePosition)
									forPlayer: m player]]]].
	
	self isPartsBin
		ifTrue:
			[aMorph isPartsDonor: true.
			aMorph stopSteppingSelfAndSubmorphs.
			aMorph suspendEventHandler]
		ifFalse:
			[self world startSteppingSubmorphsOf: aMorph].
	
"	self presenter morph: aMorph droppedIntoPasteUpMorph: self."
	self showingListView ifTrue:
		[self sortSubmorphsBy: (self valueOfProperty: #sortOrder).
		self currentWorld abandonAllHalos].
	
	self bringTopmostsToFront.! !

!PasteUpMorph methodsFor: 'dropping/grabbing' stamp: 'ct 4/25/2021 23:46'!
wantsDroppedTransferMorph: transferMorph

	^ self hasTransferMorphConverter
		or: [transferMorph dragTransferType = #filesAndDirectories]
		or: [transferMorph dragTransferType = #sourceCode]
		or: [transferMorph dragTransferType = #sourceCodes]
		or: [transferMorph dragTransferType isEmptyOrNil not and: [transferMorph dragTransferType first = #sourceCodeOrganization]]! !

!PasteUpMorph methodsFor: 'event handling' stamp: 'ct 4/25/2021 22:58'!
dropSourceCode: anObject event: evt

	| tool |
	(anObject isMethodReference and: [anObject isValid])
		ifTrue: [^ self dropSourceCode: anObject compiledMethod event: evt].
	
	anObject isCompiledMethod
		ifTrue: [
			tool := CodeHolder new
				setClass: anObject methodClass
				selector: anObject selector].
	anObject isBehavior
		ifTrue: [
			tool := SystemBrowser default new
				setClass: anObject].
	
	tool ifNotNil: [
		SystemWindow reuseWindows: false during: [
			| window |
			window := ToolBuilder open: tool.
			window center: evt position.
			window bounds: (window bounds translatedToBeWithin: self bounds)].
		^ self].
	
	anObject isString
		ifTrue: [anObject edit].! !

!PasteUpMorph methodsFor: 'event handling' stamp: 'ct 4/25/2021 23:43'!
dropSourceCodeOrganization: anObject type: organizationType event: evt

	| tool |
	organizationType isEmpty ifTrue: [^ self].
	
	organizationType first = #systemCategory ifTrue: [
		tool := SystemBrowser default new
			selectSystemCategory: anObject].
	organizationType first = #package ifTrue: [
		tool := PackagePaneBrowser new
			selectPackageNamed: anObject].
	
	tool ifNil: [^ self].
	
	SystemWindow reuseWindows: false during: [
		| window |
		window := ToolBuilder open: tool.
		window center: evt position.
		window bounds: (window bounds translatedToBeWithin: self bounds)].! !

!PasteUpMorph methodsFor: 'event handling' stamp: 'ct 4/25/2021 23:49'!
dropSourceCodes: someObjects event: evt

	| tool |
	tool := (Preferences traceMessages ifTrue: [MessageTrace] ifFalse: [MessageSet])
		messageList: someObjects.
	tool autoSelectString: nil.
	
	SystemWindow reuseWindows: false during: [
		| window |
		window := ToolBuilder open: tool.
		window center: evt position.
		window bounds: (window bounds translatedToBeWithin: self bounds)].! !


!SystemWindow class methodsFor: 'preferences' stamp: 'ct 4/25/2021 22:50'!
reuseWindows: aBoolean during: aBlock

	| previous |
	previous := self reuseWindows.
	self reuseWindows: aBoolean.
	^ aBlock ensure: [
		self reuseWindows: previous]! !


!SystemWindow class reorganize!
('initializing' borderWidth classVersion closeBoxImage closeBoxImageFlat closeBoxImageGradient collapseBoxImage collapseBoxImageFlat collapseBoxImageGradient expandBoxImage expandBoxImageFlat expandBoxImageGradient menuBoxImage menuBoxImageFlat menuBoxImageGradient refreshAllWindows)
('instance creation' labelled:)
('new-morph participation' includeInNewMorphMenu)
('top window' bringWindowUnderHandToFront clearTopWindow closeTopWindow deleteTopWindow keyWindow noteTopWindowIn: sendTopWindowToBack topWindow wakeUpTopWindowUponStartup windowsIn: windowsIn:satisfying:)
('preferences' boxExtent clickOnLabelToEdit clickOnLabelToEdit: closeBoxFrame doubleClickOnLabelToExpand doubleClickOnLabelToExpand: dragToEdges dragToEdges: expandBoxFrame gradientWindow gradientWindow: hideExpandButton hideExpandButton: menuBoxFrame moveMenuButtonRight moveMenuButtonRight: resizeAlongEdges resizeAlongEdges: reuseWindows reuseWindows: reuseWindows:during: roundedWindowCorners roundedWindowCorners: themeProperties windowTitleActiveOnFirstClick windowTitleActiveOnFirstClick: windowsRaiseOnClick windowsRaiseOnClick:)
('private' reconfigureWindowsForFocus)
('*Etoys-Squeakland-top window' rotateWindows sendTopWindowBackOne)
!

Browser removeSelector: #representsSameBrowseeAs:!

!CodeHolder reorganize!
('annotation' addPriorVersionsCountForSelector:ofClass:to: annotation annotation: annotationForClassCommentFor: annotationForClassDefinitionFor: annotationForHierarchyFor: annotationForSelector:ofClass: annotationPaneMenu:shifted: annotationRequests annotationSeparator defaultAnnotationPaneHeight defaultButtonPaneHeight)
('categories' categoryFromUserWithPrompt:for: categoryOfCurrentMethod changeCategory letUserReclassify:in: methodCategoryChanged selectedMessageCategoryName selectedSystemCategoryName)
('categories & search pane' listPaneWithSelector: newSearchPane searchPane)
('commands' adoptMessageInCurrentChangeset browseImplementors browseSenders copyUpOrCopyDown offerMenu offerShiftedClassListMenu offerUnshiftedClassListMenu removeClass shiftedYellowButtonActivity spawn: spawnToClass: spawnToCollidingClass: unshiftedYellowButtonActivity)
('construction' buildClassBrowserEditString: buildMessageBrowserEditString: buildMessageCategoryBrowserForCategory:class:selector:editString: buildMorphicCodePaneWith:)
('contents' commentContents contents contentsChanged contentsSymbol contentsSymbol: editContents editContentsWithDefault: isModeStyleable)
('controls' codePaneProvenanceString contentsSymbolQuints decorateButtons optionalButtonPairs sourceAndDiffsQuintsOnly)
('diffs' defaultDiffsSymbol diffFromPriorSourceFor: installTextualCodingPane restoreTextualCodingPane showDiffs showDiffs: showPrettyDiffs: showRegularDiffs: showingAnyKindOfDiffs showingPrettyDiffs showingPrettyDiffsString showingRegularDiffs showingRegularDiffsString toggleDiffing togglePlainSource togglePrettyDiffing togglePrettyPrint toggleRegularDiffing wantsDiffFeedback)
('message category functions' canShowMultipleMessageCategories)
('message list' decompiledSourceIntoContents decompiledSourceIntoContentsWithTempNames: formattedLabel: formattedLabel:forSelector:inClass: messageHelpForMethod: messageHelpTruncated: selectedBytecodes selectedMessage sourceStringPrettifiedAndDiffed validateMessageSource:forSelector:inClass:)
('message list menu' messageListKey:from: messageListMenuMore: shiftedMessageListMore:)
('misc' addModelItemsToWindowMenu: getSelectorAndSendQuery:to: getSelectorAndSendQuery:to:with: informPossiblyCorruptSource isThereAnOverride isThisAnOverride modelWakeUpIn: okayToAccept priorSourceOrNil refreshAnnotation refusesToAcceptCode releaseCachedState sampleInstanceOfSelectedClass sendQuery:to: setClassAndSelectorIn: suggestCategoryToSpawnedBrowser: useSelector:orGetSelectorAndSendQuery:to:)
('self-updating' didCodeChangeElsewhere stepIn: updateCodePaneIfNeeded updateListsAndCodeIn: wantsStepsIn:)
('toolbuilder' annotationFrame annotationPaneHeight buildAnnotationPaneWith: buildCodePaneWith: buildCodeProvenanceButtonWith: buildOptionalButtonsWith: buttonHeight inheritanceButtonColor inheritanceButtonEnabled optionalButtonsFrame receiverClass textFrame versionsButtonEnabled)
('traits' makeSampleInstance showUnreferencedClassVars showUnreferencedInstVars spawnHierarchy)
('what to show' offerWhatToShowMenu prettyPrintString setContentsToForceRefetch showByteCodes: showDecompile: showDocumentation: showingByteCodes showingByteCodesString showingDecompile showingDecompileString showingDocumentation showingDocumentationString showingEditContentsOption showingPlainSource showingPlainSourceString showingPrettyPrint showingSource toggleDecompile toggleShowDocumentation toggleShowingByteCodes wantsCodeProvenanceButton)
('*services-base' messageListMenuServices: requestor)
('*Protocols-Tools' spawnFullProtocol spawnProtocol)
('*Etoys-tiles' showTiles: showingTiles showingTilesString)
('multi-window support' multiWindowState multiWindowState:)
('message functions' exploreMethod inspectMethod)
('*SUnitTools-running' testBinarySelectorNames testBrowseClassNamed:possibleMessageNamed: testFindTest testFindTested testRunSuite: testSelectorFrom:)
('*SUnitTools-message list functions' testDebugTest testRunTest)
('*SUnitTools-menus' testsMessageListMenu: testsTestFindingMenu:)
('breakpoints' toggleBreakOnEntry)
('code pane' aboutToStyle: compileMessage:notifying:)
('accessing' contents:notifying: metaClassIndicated selectedClass selectedClassOrMetaClass selectedMessageName)
('initialize-release' defaultBrowserTitle labelString setClass:selector:)
('morphic ui' representsSameBrowseeAs:)
!

