The Trunk: Morphic-mt.1026.mcz

Marcel Taeumel uploaded a new version of Morphic to project The Trunk:
http://source.squeak.org/trunk/Morphic-mt.1026.mcz

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

Name: Morphic-mt.1026
Author: mt
Time: 4 November 2015, 6:49:25.917 pm
UUID: a15f3e14-7c49-4d00-988f-ab69d4a499f8
Ancestors: Morphic-mt.1025

Refactors and cleans-up drag-and-drop mechanism used by pluggable lists and trees.

=============== Diff against Morphic-mt.1025 ===============

Item was changed:
  ----- Method: PluggableListMorph>>startDrag: (in category 'drag and drop') -----
  startDrag: evt
+
+ | item itemMorph |
+ evt hand hasSubmorphs ifTrue: [^ self].
+ self model okToChange ifFalse: [^ self].
+
+ item := self selection ifNil: [^ self].
+ itemMorph := StringMorph contents: item asStringOrText.
 
+ [ "Initiate drag."
+ (self model dragPassengerFor: itemMorph inMorph: self) ifNotNil: [:passenger | | ddm |
+ ddm := (self valueOfProperty: #dragTransferClass ifAbsent: [TransferMorph]) withPassenger: passenger from: self.
+ ddm dragTransferType: (self model dragTransferTypeForMorph: self).
+ ddm updateFromUserInputEvent: evt.
+ self model dragStartedFor: itemMorph transferMorph: ddm.
+ evt hand grabMorph: ddm]
+ ] ensure: [
+ Cursor normal show.
+ evt hand releaseMouseFocus: self].!
- evt hand hasSubmorphs
- ifTrue: [^ self].
- [ | draggedItem draggedItemMorph passenger ddm |
- (self dragEnabled and: [model okToChange])
- ifFalse: [^ self].
- (draggedItem := self selection)
- ifNil: [^ self].
- draggedItemMorph := StringMorph contents: draggedItem asStringOrText.
- passenger := self model dragPassengerFor: draggedItemMorph inMorph: self.
- passenger
- ifNil: [^ self].
- ddm := TransferMorph withPassenger: passenger from: self.
- ddm
- dragTransferType: (self model dragTransferTypeForMorph: self).
- Preferences dragNDropWithAnimation
- ifTrue: [self model dragAnimationFor: draggedItemMorph transferMorph: ddm].
- evt hand grabMorph: ddm]
- ensure: [Cursor normal show.
- evt hand releaseMouseFocus: self]!

Item was changed:
+ ----- Method: PluggableListMorph>>wantsDroppedMorph:event: (in category 'drag and drop') -----
- ----- Method: PluggableListMorph>>wantsDroppedMorph:event: (in category 'dropping/grabbing') -----
  wantsDroppedMorph: aMorph event: anEvent
  ^ self model wantsDroppedMorph: aMorph event: anEvent inMorph: self!

Item was changed:
+ ----- Method: SimpleHierarchicalListMorph>>acceptDroppingMorph:event: (in category 'drag and drop') -----
- ----- Method: SimpleHierarchicalListMorph>>acceptDroppingMorph:event: (in category 'dropping/grabbing') -----
  acceptDroppingMorph: aMorph event: evt
 
  self model
  acceptDroppingMorph: aMorph
  event: evt
  inMorph: self.
  self resetPotentialDropMorph.
  evt hand releaseMouseFocus: self.
  Cursor normal show.
  !

Item was changed:
+ ----- Method: SimpleHierarchicalListMorph>>potentialDropMorph (in category 'drag and drop') -----
- ----- Method: SimpleHierarchicalListMorph>>potentialDropMorph (in category 'dropping/grabbing') -----
  potentialDropMorph
  ^potentialDropMorph!

Item was changed:
+ ----- Method: SimpleHierarchicalListMorph>>potentialDropMorph: (in category 'drag and drop') -----
- ----- Method: SimpleHierarchicalListMorph>>potentialDropMorph: (in category 'dropping/grabbing') -----
  potentialDropMorph: aMorph
  potentialDropMorph := aMorph.
  aMorph highlightForDrop!

Item was changed:
+ ----- Method: SimpleHierarchicalListMorph>>resetPotentialDropMorph (in category 'drag and drop') -----
- ----- Method: SimpleHierarchicalListMorph>>resetPotentialDropMorph (in category 'dropping/grabbing') -----
  resetPotentialDropMorph
  potentialDropMorph ifNotNil: [
  potentialDropMorph resetHighlightForDrop.
  potentialDropMorph := nil]
  !

Item was changed:
  ----- Method: SimpleHierarchicalListMorph>>setSelectedMorph: (in category 'selection') -----
  setSelectedMorph: aMorph
 
+ "Avoid unnecessary model callbacks."
+ self selectedMorph == aMorph ifTrue: [^ self].
+
  model
  perform: (setSelectionSelector ifNil: [^self])
  with: aMorph complexContents "leave last wrapper in place"
 
   !

Item was changed:
+ ----- Method: SimpleHierarchicalListMorph>>startDrag: (in category 'drag and drop') -----
- ----- Method: SimpleHierarchicalListMorph>>startDrag: (in category 'event handling') -----
  startDrag: evt
+
+ | itemMorph |
+ evt hand hasSubmorphs ifTrue: [^ self].
+ self model okToChange ifFalse: [^ self].
+
+ itemMorph := scroller submorphs
+ detect: [:any | any highlightedForMouseDown]
+ ifNone: [^ self].
+
+ "Prepare visuals."
- | ddm itemMorph passenger |
- self dragEnabled
- ifTrue: [itemMorph := scroller submorphs
- detect: [:any | any highlightedForMouseDown]
- ifNone: []].
- (itemMorph isNil
- or: [evt hand hasSubmorphs])
- ifTrue: [^ self].
  itemMorph highlightForMouseDown: false.
+ self setSelectedMorph: itemMorph.
+
+ [ "Initiate drag."
+ (self model dragPassengerFor: itemMorph inMorph: self) ifNotNil: [:passenger | | ddm |
+ ddm := (self valueOfProperty: #dragTransferClass ifAbsent: [TransferMorph]) withPassenger: passenger from: self.
+ ddm dragTransferType: (self model dragTransferTypeForMorph: self).
+ ddm updateFromUserInputEvent: evt.
+ self model dragStartedFor: itemMorph transferMorph: ddm.
- itemMorph ~= self selectedMorph
- ifTrue: [self setSelectedMorph: itemMorph].
- passenger := self model dragPassengerFor: itemMorph inMorph: self.
- passenger
- ifNotNil: [ddm := TransferMorph withPassenger: passenger from: self.
- ddm
- dragTransferType: (self model dragTransferTypeForMorph: self).
- Preferences dragNDropWithAnimation
- ifTrue: [self model dragAnimationFor: itemMorph transferMorph: ddm].
  evt hand grabMorph: ddm].
+ ] ensure: [
+ Cursor normal show.
+ evt hand releaseMouseFocus: self].!
- evt hand releaseMouseFocus: self!

Item was changed:
+ ----- Method: SimpleHierarchicalListMorph>>wantsDroppedMorph:event: (in category 'drag and drop') -----
- ----- Method: SimpleHierarchicalListMorph>>wantsDroppedMorph:event: (in category 'dropping/grabbing') -----
  wantsDroppedMorph: aMorph event: anEvent
  ^ self model wantsDroppedMorph: aMorph event: anEvent inMorph: self!

Item was changed:
  ----- Method: TransferMorph class>>withPassenger: (in category 'instance creation') -----
  withPassenger: anObject
+
+ ^ self
+ withPassenger: anObject
+ from: nil!
- ^ self withPassenger: anObject from: nil!

Item was changed:
  ----- Method: TransferMorph class>>withPassenger:from: (in category 'instance creation') -----
  withPassenger: anObject from: source
+
+ ^ self new
+ passenger: anObject;
+ source: source;
+ yourself!
- | ddm |
- ddm := self new.
- ddm passenger: anObject.
- ddm source: source.
- Sensor shiftPressed ifTrue: [ddm shouldCopy: true].
- ^ ddm!

Item was changed:
  ----- Method: TransferMorph>>aboutToBeGrabbedBy: (in category 'dropping/grabbing') -----
  aboutToBeGrabbedBy: aHand
  "The receiver is being grabbed by a hand.                          
  Perform necessary adjustments (if any) and return the actual morph    
      that should be added to the hand."
  "Since this morph has been initialized automatically with bounds origin  
      0@0, we have to move it to aHand position."
  super aboutToBeGrabbedBy: aHand.
+
+ self align: self fullBounds bottomLeft with: aHand position.
- self draggedMorph.
- self align: self bottomLeft with: aHand position.
  aHand newKeyboardFocus: self.!

Item was removed:
- ----- Method: TransferMorph>>delete (in category 'submorphs-add/remove') -----
- delete
- "See also >>justDroppedInto:event:."
- self changed: #deleted.
- self breakDependents.
- super delete!

Item was added:
+ ----- Method: TransferMorph>>doCopy (in category 'event handling') -----
+ doCopy
+
+ copy := true.
+ self updateCopyIcon.!

Item was added:
+ ----- Method: TransferMorph>>doMove (in category 'event handling') -----
+ doMove
+
+ copy := false.
+ self updateCopyIcon.!

Item was changed:
+ ----- Method: TransferMorph>>dragTransferType (in category 'accessing') -----
- ----- Method: TransferMorph>>dragTransferType (in category 'drag and drop') -----
  dragTransferType
  ^transferType!

Item was removed:
- ----- Method: TransferMorph>>draggedMorph (in category 'accessing') -----
- draggedMorph
- draggedMorph ifNil: [self initDraggedMorph].
- ^draggedMorph!

Item was removed:
- ----- Method: TransferMorph>>draggedMorph: (in category 'accessing') -----
- draggedMorph: aMorph
- draggedMorph := aMorph!

Item was removed:
- ----- Method: TransferMorph>>initDraggedMorph (in category 'private') -----
- initDraggedMorph
- draggedMorph ifNotNil: [^self].
- draggedMorph := self passenger asDraggableMorph.
- self addMorphBack: draggedMorph.
- self updateCopyIcon.
- self changed; fullBounds!

Item was changed:
  ----- Method: TransferMorph>>initialize (in category 'initialization') -----
  initialize
+
- "initialize the state of the receiver"
  super initialize.
+
+ self
+ changeTableLayout;
+ listDirection: #leftToRight;
- self layoutPolicy: TableLayout new.
- self listDirection: #leftToRight;
  hResizing: #shrinkWrap;
  vResizing: #shrinkWrap;
  layoutInset: 3;
+ cellInset: 3;
  wrapCentering: #center;
+ cellPositioning: #leftCenter;
+ setProperty: #indicateKeyboardFocus toValue: #never.
+
+ self doMove.
+
+ self on: #keyStroke send: #keyStroke: to: self.
+ self on: #keyUp send: #updateFromUserInputEvent: to: self.
+ self on: #keyDown send: #updateFromUserInputEvent: to: self.!
- cellPositioning: #leftCenter.
- copy := false.
- self on: #keyStroke send: #keyStroke: to: self!

Item was changed:
  ----- Method: TransferMorph>>keyStroke: (in category 'event handling') -----
  keyStroke: evt
  "Abort the drag on an escape"
+
+ evt keyCharacter = Character escape ifTrue: [self delete].!
- evt keyCharacter ~= Character escape ifTrue: [ ^self ].
- self delete.!

Item was removed:
- ----- Method: TransferMorph>>move (in category 'accessing') -----
- move
- copy := false!

Item was changed:
  ----- Method: TransferMorph>>passenger: (in category 'accessing') -----
  passenger: anObject
+
+ passenger := anObject.
+
+ self
+ removeAllMorphs;
+ addMorph: passenger asDraggableMorph;
+ updateCopyIcon.!
- passenger := anObject!

Item was removed:
- ----- Method: TransferMorph>>privateFullMoveBy: (in category 'private') -----
- privateFullMoveBy: delta
- super privateFullMoveBy: delta.
- self changed: #position!

Item was removed:
- ----- Method: TransferMorph>>shouldCopy: (in category 'accessing') -----
- shouldCopy: aBoolean
- copy := aBoolean.!

Item was added:
+ ----- Method: TransferMorph>>shouldMove (in category 'accessing') -----
+ shouldMove
+ ^ self shouldCopy not!

Item was removed:
- ----- Method: TransferMorph>>step (in category 'stepping and presenter') -----
- step
- self shouldCopy: self primaryHand lastEvent shiftPressed.
- self updateCopyIcon!

Item was removed:
- ----- Method: TransferMorph>>stepTime (in category 'stepping and presenter') -----
- stepTime
- ^100!

Item was changed:
  ----- Method: TransferMorph>>updateCopyIcon (in category 'private') -----
  updateCopyIcon
+
+ (self submorphNamed: #tmCopyIcon)
+ ifNil: [self shouldCopy ifTrue: [
+ self addMorphFront: (ImageMorph new image: CopyPlusIcon; name: #tmCopyIcon; yourself)]]
+ ifNotNil: [:copyIcon | self shouldCopy ifFalse: [
+ copyIcon delete]]!
- | copyIcon |
- copyIcon := self submorphWithProperty: #tmCopyIcon.
- (self shouldCopy and: [ copyIcon isNil ]) ifTrue: [
- ^self addMorphFront: ((ImageMorph new image: CopyPlusIcon) setProperty: #tmCopyIcon toValue: true)
- ].
- (self shouldCopy not and: [ copyIcon notNil ]) ifTrue: [
- copyIcon delete
- ]!

Item was added:
+ ----- Method: TransferMorph>>updateFromUserInputEvent: (in category 'event handling') -----
+ updateFromUserInputEvent: evt
+
+ evt shiftPressed
+ ifTrue: [self doCopy]
+ ifFalse: [self doMove].!

Item was removed:
- Morph subclass: #TransferMorphAnimation
- instanceVariableNames: 'transferMorph'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Morphic-Support'!

Item was removed:
- ----- Method: TransferMorphAnimation class>>on: (in category 'instance creation') -----
- on: aTransferMorph
- ^self new on: aTransferMorph!

Item was removed:
- ----- Method: TransferMorphAnimation>>on: (in category 'initialization') -----
- on: aTransferMorph
-
- self flag: #bob. "there was a reference to World, but the class seems to be unused"
-
- self color: Color transparent.
- transferMorph := aTransferMorph.
- transferMorph addDependent: self.
- ActiveWorld addMorph: self "or perhaps aTransferMorph world"!

Item was removed:
- ----- Method: TransferMorphAnimation>>transferMorph (in category 'accessing') -----
- transferMorph
- ^transferMorph!

Item was removed:
- ----- Method: TransferMorphAnimation>>update: (in category 'updating') -----
- update: aSymbol
- aSymbol == #deleted
- ifTrue: [self delete].
- aSymbol == #position
- ifTrue: [self updateAnimation].
- self changed!

Item was removed:
- ----- Method: TransferMorphAnimation>>updateAnimation (in category 'update') -----
- updateAnimation!

Item was removed:
- TransferMorphAnimation subclass: #TransferMorphLineAnimation
- instanceVariableNames: 'polygon'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Morphic-Support'!

Item was removed:
- ----- Method: TransferMorphLineAnimation>>initPolygon (in category 'initialization') -----
- initPolygon
- polygon := (LineMorph from: self transferMorph source bounds center
- to: self transferMorph bounds center
- color: Color black width: 2)
- dashedBorder: {10. 10. Color white}.
- self addMorph: polygon
- !

Item was removed:
- ----- Method: TransferMorphLineAnimation>>on: (in category 'initialization') -----
- on: aTransferMorph
- super on: aTransferMorph.
- self initPolygon!

Item was removed:
- ----- Method: TransferMorphLineAnimation>>updateAnimation (in category 'update') -----
- updateAnimation
- polygon verticesAt: 2 put: self transferMorph center!