The Inbox: Tools-ct.950.mcz

Christoph Thiede uploaded a new version of Tools to project The Inbox:
http://source.squeak.org/inbox/Tools-ct.950.mcz

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

Name: Tools-ct.950
Author: ct
Time: 24 February 2020, 8:55:41.554226 pm
UUID: 3f1a063b-be48-2147-a07c-40c4ba4cf5ec
Ancestors: Tools-ct.948

Adds support for dragging methods on a class in a browser

Committed again and replaces Tools-ct.949 due to a stupid slip (forgot one method).

=============== Diff against Tools-ct.948 ===============

Item was changed:
  ----- Method: Browser>>buildClassListWith: (in category 'toolbuilder') -----
  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:;
+ dropAccept: #wantsClassListDrop:;
+ dropItem: #dropOnClassList:at:shouldCopy:].
+ ^ listSpec
- SystemBrowser browseWithDragNDrop
- ifTrue:[listSpec dragItem: #dragFromClassList:].
-
- ^listSpec
  !

Item was added:
+ ----- Method: Browser>>dropOnClassList:at:shouldCopy: (in category 'drag and drop') -----
+ dropOnClassList: method at: index shouldCopy: shouldCopy
+
+ ^ self
+ moveMethod: method
+ shouldCopy: shouldCopy
+ class: (self environment classNamed: (self defaultClassList at: index))
+ category: [:sourceClass :areClassesRelated |
+ areClassesRelated
+ ifTrue: [sourceClass whichCategoryIncludesSelector: method selector]
+ ifFalse: [nil]]!

Item was changed:
  ----- Method: Browser>>dropOnMessageCategories:at:shouldCopy: (in category 'drag and drop') -----
  dropOnMessageCategories: method at: index shouldCopy: shouldCopy
 
+ ^ self
+ moveMethod: method
+ shouldCopy: shouldCopy
+ class: self selectedClassOrMetaClass
+ category: (self messageCategoryList at: index)!
- | sourceClass destinationClass category |
- (method isKindOf: CompiledMethod)
- ifFalse: [^ self inform: 'Can only drop methods' translated].
- sourceClass := method methodClass.
- destinationClass := self selectedClassOrMetaClass.
- sourceClass == destinationClass ifTrue: [
- category := self messageCategoryList at: index.
- category = ClassOrganizer allCategory ifTrue: [^ false].
- destinationClass organization classify: method selector under: category suppressIfDefault: false logged: true.
- self changed: #messageCategoryList.
- self changed: #messageList.
- ^ true ].
- (shouldCopy
- or: [ (destinationClass inheritsFrom: sourceClass) ]
- or: [ (sourceClass inheritsFrom: destinationClass) ]
- or: [ sourceClass theNonMetaClass == destinationClass theNonMetaClass ])
- ifFalse: [
- (self confirm: (
- 'Classes "{1}" and "{2}" are unrelated.\Are you sure you want to move this method?' withCRs translated
- format: { sourceClass. destinationClass }))
- ifFalse: [ ^ false ] ].
- destinationClass
- compile: method getSource
- classified: (self messageCategoryList at: index)
- withStamp: method timeStamp
- notifying: nil.
- shouldCopy ifFalse: [
- sourceClass removeSelector: method selector ].
- self selectMessageNamed: method selector.
- ^ true!

Item was added:
+ ----- Method: Browser>>moveMethod:shouldCopy:class:category: (in category 'drag and drop') -----
+ moveMethod: method shouldCopy: shouldCopy class: destinationClass category: categoryOrBlock
+
+ | sourceClass areClassesRelated category |
+ (method isKindOf: CompiledMethod)
+ ifFalse: [^ self inform: 'Can only drop methods' translated].
+ sourceClass := method methodClass.
+ areClassesRelated := (destinationClass inheritsFrom: sourceClass)
+ or: [ (sourceClass inheritsFrom: destinationClass) ]
+ or: [ sourceClass theNonMetaClass == destinationClass theNonMetaClass ].
+ (shouldCopy or: [areClassesRelated]) ifFalse: [
+ (self confirm: ('Classes "{1}" and "{2}" are unrelated.\Are you sure you want to move this method?' withCRs translated
+ format: { sourceClass. destinationClass }))
+ ifFalse: [ ^ false ] ].
+ category := categoryOrBlock isBlock
+ ifTrue: [categoryOrBlock value: sourceClass value: areClassesRelated]
+ ifFalse: [categoryOrBlock].
+ sourceClass == destinationClass
+ ifTrue: [
+ category = ClassOrganizer allCategory ifTrue: [^ false].
+ destinationClass organization classify: method selector under: category suppressIfDefault: false logged: true ]
+ ifFalse: [
+ destinationClass
+ compile: method getSource
+ classified: category
+ withStamp: method timeStamp
+ notifying: nil.
+ shouldCopy ifFalse: [
+ sourceClass removeSelector: method selector ] ].
+ self setClass: destinationClass selector: method selector.
+ ^ true!

Item was added:
+ ----- Method: Browser>>wantsClassListDrop: (in category 'drag and drop') -----
+ wantsClassListDrop: anObject
+
+ ^ anObject isKindOf: CompiledMethod!

Am Mo., 24. Feb. 2020 um 20:55 Uhr schrieb <[hidden email]>:
>
> -       (method isKindOf: CompiledMethod)
...
> + wantsClassListDrop: anObject
> +
> +       ^ anObject isKindOf: CompiledMethod!
>

Better use isCompiledMethod, since it is already there.

Also worth noting that #isKindOf: is rarely a good choice since
a) it is fairly slow
b) it is looking only at a specific class hierarchy

a) is just annoying when you find it in a loop in a loop in a critical part of code. b) is quite often a design mistake found when somebody is still thinking 'types' and not 'protocols'.


tim
--
tim Rowledge; [hidden email]; http://www.rowledge.org/tim
"E=Mc^5...nahhh...E=Mc^4...nahh...E=Mc^3...ah, the hell with it."