The Trunk: Tools-jr.860.mcz

Marcel Taeumel uploaded a new version of Tools to project The Trunk:
http://source.squeak.org/trunk/Tools-jr.860.mcz

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

Name: Tools-jr.860
Author: jr
Time: 10 August 2019, 8:27:40.074208 pm
UUID: 6e619c24-626c-3546-97a5-b5d42521f625
Ancestors: Tools-jr.859

Deduplicate code for message list help texts

Also fix tool building code that did not use the correct setter for the list item help selector.

=============== Diff against Tools-mt.858 ===============

Item was added:
+ ----- Method: CodeHolder>>messageHelpForMethod: (in category 'message list') -----
+ messageHelpForMethod: aMethod
+ "Answer the formatted help text for a method."
+ "Show the first n lines of the source code of the method."
+ | source formatted lineCount |
+ source := aMethod getSource.
+ formatted := (Smalltalk classNamed: #SHTextStylerST80)
+ ifNil: [ source asText ]
+ ifNotNil: [ :textStylerClass |
+ textStylerClass new
+ classOrMetaClass: aMethod methodClass;
+ styledTextFor: source asText ].
+
+ lineCount := 0.
+ source doWithIndex: [:char :index |
+ char = Character cr ifTrue: [lineCount := lineCount + 1].
+ lineCount > 10 ifTrue: [
+ formatted := formatted copyFrom: 1 to: index-1.
+ formatted append: ' [...]'.
+ ^ formatted]].
+
+ ^ formatted!

Item was changed:
  ----- Method: Debugger>>buildNotifierWith:label:message: (in category 'toolbuilder') -----
  buildNotifierWith: builder label: label message: messageString
  | windowSpec listSpec textSpec panelSpec quads |
  windowSpec := builder pluggableWindowSpec new
  model: self;
  extent: self initialExtentForNotifier;
  label: label;
  children: OrderedCollection new.
 
  panelSpec := builder pluggablePanelSpec new.
  panelSpec children: OrderedCollection new.
  quads := self preDebugButtonQuads.
  (self interruptedContext selector == #doesNotUnderstand:) ifTrue: [
  quads := quads copyWith:
  { 'Create'. #createMethod. #magenta. 'create the missing method' }
  ].
  (#(#notYetImplemented #shouldBeImplemented #requirement) includes: self interruptedContext selector) ifTrue: [
  quads := quads copyWith:
  { 'Create'. #createImplementingMethod. #magenta. 'implement the marked method' }
  ].
  (self interruptedContext selector == #subclassResponsibility) ifTrue: [
  quads := quads copyWith:
  { 'Create'. #createOverridingMethod. #magenta. 'create the missing overriding method' }
  ].
  quads do:[:spec| | buttonSpec |
  buttonSpec := builder pluggableButtonSpec new.
  buttonSpec model: self.
  buttonSpec label: spec first.
  buttonSpec action: spec second.
  buttonSpec help: spec fourth.
  panelSpec children add: buttonSpec.
  ].
  panelSpec layout: #horizontal. "buttons"
  panelSpec frame: self preDebugButtonQuadFrame.
  windowSpec children add: panelSpec.
 
  Preferences eToyFriendly | messageString notNil ifFalse:[
  listSpec := builder pluggableListSpec new.
  listSpec
  model: self;
  list: #contextStackList;
  getIndex: #contextStackIndex;
  setIndex: #debugAt:;
  icon: #messageIconAt:;
+ helpItem: #messageHelpAt:;
- help: #messageHelpAt:;
  frame: self contextStackFrame.
  windowSpec children add: listSpec.
  ] ifTrue:[
  message := messageString.
  textSpec := builder pluggableTextSpec new.
  textSpec
  model: self;
  getText: #preDebugMessageString;
  setText: nil;
  selection: nil;
  menu: #debugProceedMenu:;
  frame: self contextStackFrame.
  windowSpec children add: textSpec.
  ].
 
  ^windowSpec!

Item was changed:
  ----- Method: Debugger>>messageHelpAt: (in category 'context stack (message list)') -----
  messageHelpAt: anIndex
  "Show the first n lines of the sources code of the selected message."
 
+ | method |
- | method source formatted lineCount |
  Preferences balloonHelpInMessageLists ifFalse: [^ nil].
  contextStack size < anIndex ifTrue: [^ nil].
 
  method := (contextStack at: anIndex) method.
+ ^ self messageHelpForMethod: method.!
-
- source := method getSource.
- formatted := (Smalltalk classNamed: #SHTextStylerST80)
- ifNil: [ source asText ]
- ifNotNil: [ :textStylerClass |
- textStylerClass new
- classOrMetaClass: method methodClass;
- styledTextFor: source asText ].
-
- lineCount := 0.
- source doWithIndex: [:char :index |
- char = Character cr ifTrue: [lineCount := lineCount + 1].
- lineCount > 10 ifTrue: [
- formatted := formatted copyFrom: 1 to: index-1.
- formatted append: ' [...]'.
- ^ formatted]].
-
- ^ formatted!

Item was changed:
  ----- Method: MessageSet>>buildMessageListWith: (in category 'toolbuilder') -----
  buildMessageListWith: builder
  | listSpec |
  listSpec := builder pluggableListSpec new.
  listSpec
  model: self;
  list: #messageList;
  getIndex: #messageListIndex;
  setIndex: #messageListIndex:;
  icon: #messageIconAt:;
+ helpItem: #messageHelpAt:;
- help: #messageHelpAt:;
  menu: #messageListMenu:shifted:;
  keyPress: #messageListKey:from:.
  SystemBrowser browseWithDragNDrop
  ifTrue:[listSpec dragItem: #dragFromMessageList:].
  ^listSpec
  !

Item was changed:
  ----- Method: MessageSet>>contents:notifying: (in category 'private') -----
  contents: aString notifying: aController
  "Compile the code in aString. Notify aController of any syntax errors.
  Answer false if the compilation fails. Otherwise, if the compilation
  created a new method, deselect the current selection. Then answer true."
 
+ | category class oldSelector |
- | category selector class oldSelector |
  self okayToAccept ifFalse: [^ false].
+ class := self targetForContents: aString.
- self setClassAndSelectorIn: [:c :os | class := c.  oldSelector := os].
  class ifNil: [^ false].
+ self setClassAndSelectorIn: [:c :os | oldSelector := os].
+ (self contents: aString specialSelector: oldSelector in: class notifying: aController)
+ ifTrue: [^ false].
- (oldSelector ~~ nil and: [oldSelector first isUppercase]) ifTrue:
- [oldSelector = #Comment ifTrue:
- [class comment: aString stamp: Utilities changeStamp.
- self changed: #annotation.
-   self clearUserEditFlag.
- ^ false].
- oldSelector = #Definition ifTrue:
- ["self defineClass: aString notifying: aController."
- class subclassDefinerClass
- evaluate: aString
- notifying: aController
- logged: true.
- self clearUserEditFlag.
-   ^ false].
- oldSelector = #Hierarchy ifTrue:
- [self inform: 'To change the hierarchy, edit the class definitions'.
- ^ false]].
  "Normal method accept"
+ category := self selectedMessageCategoryName.
+ ^ self contents: aString
+ oldSelector: oldSelector
+ in: class
+ classified: category
+ notifying: aController!
- category := class organization categoryOfElement: oldSelector.
- selector := class compile: aString
- classified: category
- notifying: aController.
- selector == nil ifTrue: [^ false].
- self noteAcceptanceOfCodeFor: selector.
- selector == oldSelector ifFalse:
- [self reformulateListNoting: selector].
- contents := aString copy.
- self changed: #annotation.
- ^ true!

Item was added:
+ ----- Method: MessageSet>>contents:oldSelector:in:classified:notifying: (in category 'private') -----
+ contents: aString oldSelector: oldSelector in: aClass classified: category notifying: aController
+ "Compile the code in aString. Notify aController of any syntax errors.
+ Answer false if the compilation fails. Otherwise, if the compilation
+ created a new method, deselect the current selection. Then answer true."
+ | selector |
+ selector := aClass compile: aString
+ classified: category
+ notifying: aController.
+ selector == nil ifTrue: [^ false].
+ self noteAcceptanceOfCodeFor: selector.
+ selector == oldSelector ifFalse:
+ [self reformulateListNoting: selector].
+ contents := aString copy.
+ self changed: #annotation.
+ ^ true!

Item was added:
+ ----- Method: MessageSet>>contents:specialSelector:in:notifying: (in category 'private') -----
+ contents: aString specialSelector: oldSelector in: aClass notifying: aController
+ "If the selector is a fake to denote a different definition than that of a method,
+ try to change that different object. Answer whether a special selector was found and
+ handled."
+ (oldSelector ~~ nil and: [oldSelector first isUppercase]) ifFalse: [^ false].
+ oldSelector = #Comment ifTrue:
+ [aClass comment: aString stamp: Utilities changeStamp.
+ self changed: #annotation.
+   self clearUserEditFlag.
+ ^ true].
+ oldSelector = #Definition ifTrue:
+ ["self defineClass: aString notifying: aController."
+ aClass subclassDefinerClass
+ evaluate: aString
+ notifying: aController
+ logged: true.
+ self clearUserEditFlag.
+   ^ true].
+ oldSelector = #Hierarchy ifTrue:
+ [self inform: 'To change the hierarchy, edit the class definitions'.
+ ^ true].
+ ^ false!

Item was changed:
  ----- Method: MessageSet>>messageHelpAt: (in category 'message list') -----
  messageHelpAt: anIndex
  "Show the first n lines of the sources code of the selected message."
 
+ | reference |
- | reference source formatted lineCount |
  Preferences balloonHelpInMessageLists ifFalse: [^ nil].
  self messageList size < anIndex ifTrue: [^ nil].
 
  reference := self messageList at: anIndex.
  reference isValid ifFalse: [^ nil].
+ ^ self messageHelpForMethod: reference compiledMethod!
-
- source := reference compiledMethod getSource.
- formatted := (Smalltalk classNamed: #SHTextStylerST80)
- ifNil: [ source asText ]
- ifNotNil: [ :textStylerClass |
- textStylerClass new
- classOrMetaClass: reference actualClass;
- styledTextFor: source asText ].
-
- lineCount := 0.
- source doWithIndex: [:char :index |
- char = Character cr ifTrue: [lineCount := lineCount + 1].
- lineCount > 10 ifTrue: [
- formatted := formatted copyFrom: 1 to: index-1.
- formatted append: ' [...]'.
- ^ formatted]].
-
- ^ formatted!

Item was added:
+ ----- Method: MessageSet>>targetForContents: (in category 'private') -----
+ targetForContents: aString
+ "Answer the behavior into which the contents will be accepted."
+ self setClassAndSelectorIn: [:c :os | ^ c].
+ ^ nil "fail safe for overriding implementations of setClassAndSelectorIn:"!

Item was changed:
  ----- Method: MessageTrace>>buildMessageListWith: (in category 'private initializing') -----
  buildMessageListWith: builder
  | listSpec |
  listSpec := builder pluggableAlternateMultiSelectionListSpec new.
  listSpec
  model: self ;
  list: #messageList ;
  getIndex: #messageListIndex ;
  setIndex: #toggleSelectionAt:shifted:controlled: ;
  icon: #messageIconAt:;
+ helpItem: #messageHelpAt:;
- help: #messageHelpAt:;
  menu: #messageListMenu:shifted: ;
  getSelectionList: #isMessageSelectedAt: ;
  setSelectionList: #messageAt:beSelected: ;
  keyPress: #messageListKey:from:.
  SystemBrowser browseWithDragNDrop
  ifTrue: [ listSpec dragItem: #dragFromMessageList: ].
  ^ listSpec!

Item was changed:
  ----- Method: TimeProfileBrowser>>messageHelpAt: (in category 'message list') -----
  messageHelpAt: anIndex
  "Show the first n lines of the sources code of the selected message."
 
+ | reference |
- | reference source formatted lineCount |
  Preferences balloonHelpInMessageLists ifFalse: [^ nil].
  self messageList size < anIndex ifTrue: [^ nil].
 
  reference := (self methodReferences at: anIndex) ifNil: [ ^nil ].
  reference isValid ifFalse: [ ^nil ].
+ ^ self messageHelpForMethod: reference compiledMethod!
-
- source := reference compiledMethod getSource.
- formatted := (Smalltalk classNamed: #SHTextStylerST80)
- ifNil: [ source asText ]
- ifNotNil: [ :textStylerClass |
- textStylerClass new
- classOrMetaClass: reference actualClass;
- styledTextFor: source asText ].
-
- lineCount := 0.
- source doWithIndex: [:char :index |
- char = Character cr ifTrue: [lineCount := lineCount + 1].
- lineCount > 10 ifTrue: [
- formatted := formatted copyFrom: 1 to: index-1.
- formatted append: ' [...]'.
- ^ formatted]].
-
- ^ formatted!