A new version of HelpSystem-Core was added to project The Inbox:
http://source.squeak.org/inbox/HelpSystem-Core-ct.124.mcz

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

Name: HelpSystem-Core-ct.124
Author: ct
Time: 13 October 2019, 10:52:10.160932 pm
UUID: e2346e98-30c4-964f-b015-dca8545b841c
Ancestors: HelpSystem-Core-ct.123, HelpSystem-Core-ct.122

Adds protocol & UI for subtopic management (#addSubtopic & #removeSubtopic)

This commit is indeed intended to have two ancestors.

=============== Diff against HelpSystem-Core-ct.123 ===============

Item was added:
+ ----- Method: AbstractHelpTopic>>canAddSubtopic (in category 'testing') -----
+ canAddSubtopic
+ 
+ 	^ false!

Item was added:
+ ----- Method: AbstractHelpTopic>>canRemoveSubtopic (in category 'testing') -----
+ canRemoveSubtopic
+ 
+ 	^ false!

Item was added:
+ ----- Method: AbstractHelpTopic>>isClassBasedHelpTopic (in category 'testing') -----
+ isClassBasedHelpTopic
+ 
+ 	^ false!

Item was changed:
  ----- Method: AbstractHelpTopic>>topicMenu:parentTopic: (in category 'menus') -----
  topicMenu: aMenu parentTopic: parentTopic
  
+ 	| editMenu |
  	aMenu
  		add: 'Inspect (i)' translated target: self action: #inspect;
  		add: 'Explore (I)' translated target: self action: #explore.
  	(self canBrowseTopicFromParent: parentTopic)
  		ifTrue: [
  			aMenu add: 'Browse (b)' translated
  				target: self
  				selector: #browseTopicFromParent:
  				argumentList: {parentTopic} ].
  	
+ 	editMenu := aMenu class new target: self.
+ 	self canAddSubtopic ifTrue: [
+ 		editMenu add: 'Add topic...' translated
+ 			target: self
+ 			action: #addSubtopic ].
+ 	parentTopic canRemoveSubtopic ifTrue: [
+ 		editMenu add: 'Remove topic (x)' translated
+ 			target: parentTopic
+ 			selector: #removeSubtopic:
+ 			argumentList: {self} ].
+ 	editMenu hasItems ifTrue: [ aMenu
+ 		addLine;
+ 		addAllFrom: editMenu ].
+ 	
  	^ aMenu!

Item was changed:
  ----- Method: AbstractHelpTopic>>topicMenuKey:fromParent: (in category 'menus') -----
  topicMenuKey: aChar fromParent: parentTopic
  
  	aChar
  		caseOf: {
  			[$b] ->	[(self canBrowseTopicFromParent: parentTopic)
  				ifTrue: [ self browseTopicFromParent: parentTopic ]].
  			[$i] ->	[self inspect].
+ 			[$I] ->	[self explore].
+ 			[$x] ->	[parentTopic canRemoveSubtopic ifTrue: [
+ 				parentTopic removeSubtopic: self ]] }
- 			[$I] ->	[self explore] }
  		otherwise:	[^ false].
  	^ true!

Item was added:
+ ----- Method: ClassBasedHelpTopic>>addMethodTopic (in category 'editing') -----
+ addMethodTopic
+ 
+ 	| title key needsToStorePages oldPages topic |
+ 	title := UIManager default request: 'Please enter a topic name:' translated.
+ 	title isEmptyOrNil ifTrue: [^ nil].
+ 	key := self makeUniqueKeyFrom: (title asIdentifier: false).
+ 	needsToStorePages := self needsToStorePages.
+ 	needsToStorePages ifTrue: [
+ 		(self okToWriteSelector: #pages)
+ 			ifFalse: [^ false].
+ 		oldPages := self helpClass pages].
+ 	topic := HelpTopic named: title.
+ 	topic key: key.
+ 	self accept: '' for: topic.
+ 	needsToStorePages ifTrue: [
+ 		self storePages: (oldPages copyWith: key)].
+ 	self refresh.
+ 	^ self subtopics detect: [:other | other key = key]!

Item was added:
+ ----- Method: ClassBasedHelpTopic>>addSubclassTopic (in category 'editing') -----
+ addSubclassTopic
+ 
+ 	| className title subclass |
+ 	title := UIManager default request: 'Please enter a book name:' translated.
+ 	title isEmptyOrNil ifTrue: [^ nil].
+ 	className := UIManager default request: 'Please enter a class name:' translated initialAnswer: (title asIdentifier: true).
+ 	className isEmptyOrNil ifTrue: [^ nil].
+ 	className := className asSymbol.
+ 	Smalltalk at: className ifPresent: [:class | self inform: 'Class already exists' translated. ^ nil].
+ 	subclass := self helpClass subclass: className
+ 		instanceVariableNames: ''
+ 		classVariableNames: ''
+ 		poolDictionaries: ''
+ 		category: self helpClass category.
+ 	subclass theMetaClass
+ 		compile: (String streamContents: [:stream |
+ 			stream nextPutAll: #bookName;
+ 				crtab; nextPutAll: '<generated>';
+ 				crtab; nextPut: $^;
+ 				store: title])
+ 			classified: #accessing.
+ 	subclass asHelpTopic storePages: #().
+ 	self refresh.
+ 	^ self subtopics detect: [:topic | topic isClassBasedHelpTopic and: [topic helpClass = subclass]]!

Item was added:
+ ----- Method: ClassBasedHelpTopic>>addSubtopic (in category 'editing') -----
+ addSubtopic
+ 
+ 	| strategy |
+ 	strategy := UIManager default
+ 		chooseFrom: (#('Add a method' 'Add a subclass') collect: #translated)
+ 		values: #(addMethodTopic addSubclassTopic)
+ 		title: 'Choose kind of subtopic' translated.
+ 	strategy ifNil: [^ self].
+ 	^ self perform: strategy!

Item was added:
+ ----- Method: ClassBasedHelpTopic>>canAddSubtopic (in category 'testing') -----
+ canAddSubtopic
+ 
+ 	^ true!

Item was added:
+ ----- Method: ClassBasedHelpTopic>>canRemoveSubtopic (in category 'testing') -----
+ canRemoveSubtopic
+ 
+ 	^ true!

Item was added:
+ ----- Method: ClassBasedHelpTopic>>isClassBasedHelpTopic (in category 'testing') -----
+ isClassBasedHelpTopic
+ 
+ 	^ true!

Item was added:
+ ----- Method: ClassBasedHelpTopic>>makeUniqueKeyFrom: (in category 'editing') -----
+ makeUniqueKeyFrom: aKey
+ 
+ 	| keyIndex newKey |
+ 	newKey := aKey.
+ 	keyIndex := 0.
+ 	[(self subtopics anySatisfy: [:existing | existing key = newKey])]
+ 		whileTrue: [newKey := newKey , (keyIndex := keyIndex + 1)].
+ 	^ newKey asSymbol!

Item was added:
+ ----- Method: ClassBasedHelpTopic>>needsToStorePages (in category 'testing') -----
+ needsToStorePages
+ 
+ 	| method |
+ 	method := self helpClass theMetaClass lookupSelector: #pages.
+ 	method ifNil: [^ true].
+ 	^ (method hasPragma: #pageInvariant) not!

Item was added:
+ ----- Method: ClassBasedHelpTopic>>okToRemoveClass (in category 'editing') -----
+ okToRemoveClass
+ 
+ 	| message |
+ 	message := (
+ 		'Are you certain that you want to remove\the class {1}\'
+ 		, (self helpClass subclasses ifEmpty: [''] ifNotEmpty: ['and all its {2} subclasses\'])
+ 		, 'from the system?')
+ 			withCRs translated format: {self helpClass. self helpClass subclasses size}.
+ 	^ self confirm: message!

Item was added:
+ ----- Method: ClassBasedHelpTopic>>okToWriteSelector: (in category 'editing') -----
+ okToWriteSelector: aSelector
+ 
+ 	| method |
+ 	method := self helpClass theMetaClass compiledMethodAt: aSelector ifAbsent: [^ true].
+ 	(method hasPragma: #generated) ifTrue: [^ true].
+ 	^ (UIManager default
+ 		chooseFrom: (#('Override it' 'Don''t override, but browse it' 'Cancel') collect: #translated)
+ 		values: { [true]. [method browse. false]. [false] }
+ 		title: ('This will override the existing method\{1}!!\Proceed anyway?' withCRs translated asText
+ 			format: {method reference asText
+ 				addAttribute: (TextLink new classAndMethod: method reference);
+ 				yourself })) value!

Item was added:
+ ----- Method: ClassBasedHelpTopic>>removeSubtopic: (in category 'editing') -----
+ removeSubtopic: aTopic
+ 
+ 	| needsToStorePages confirmation oldPages |
+ 	aTopic isClassBasedHelpTopic
+ 		ifTrue: [
+ 			| result |
+ 			result := aTopic removeTopicClass.
+ 			result ifTrue: [self refresh].
+ 			^ result].
+ 	
+ 	aTopic key ifNil: [
+ 		self inform: 'Could not find topic' translated.
+ 		^ false].
+ 	(self confirm: ('Are you sure you want to REMOVE the topic "{1}" from "{2}"?' translated format: {aTopic title. self title}))
+ 		ifFalse: [^ false].
+ 	needsToStorePages := self needsToStorePages.
+ 	needsToStorePages ifTrue: [
+ 		(self okToWriteSelector: #pages)
+ 			ifFalse: [^ false].
+ 		oldPages := self helpClass pages].
+ 	confirmation := self systemNavigation
+ 		confirmRemovalOf: aTopic key
+ 		on: self helpClass theMetaClass.
+ 	confirmation = 3 ifTrue: [^ false].
+ 	self helpClass theMetaClass removeSelector: aTopic key.
+ 	needsToStorePages ifTrue: [
+ 		self storePages: (oldPages copyWithout: aTopic key)].
+ 	
+ 	self refresh.
+ 	confirmation = 2 ifTrue: [
+ 		self systemNavigation browseAllCallsOn: aTopic key].
+ 	^ true!

Item was added:
+ ----- Method: ClassBasedHelpTopic>>removeTopicClass (in category 'editing') -----
+ removeTopicClass
+ 
+ 	self okToRemoveClass ifFalse: [^ false].
+ 	self helpClass removeFromSystem.
+ 	^ true!

Item was added:
+ ----- Method: ClassBasedHelpTopic>>storePages: (in category 'editing') -----
+ storePages: keys
+ 
+ 	| class |
+ 	class := self helpClass theMetaClass.
+ 	class
+ 		compile: (String streamContents: [:stream |
+ 			stream
+ 				nextPutAll: 'pages'.
+ 			(class includesSelector: #pages)
+ 				ifFalse: [ stream
+ 					crtab; nextPutAll: '<pageInvariant>';
+ 					crtab; nextPutAll: '^ self class methodsInCategory: #pages' ]
+ 				ifTrue: [ stream
+ 					crtab; nextPutAll: '<generated>';
+ 					crtab; nextPut: $^;
+ 					store: keys ]])
+ 		classified: #accessing.!