A new version of HelpSystem-Core was added to project The Inbox: http://source.squeak.org/inbox/HelpSystem-Core-tpr.143.mcz
==================== Summary ====================
Name: HelpSystem-Core-tpr.143 Author: tpr Time: 31 July 2023, 1:27:20.173257 pm UUID: 092f5e99-4701-4fce-8526-d09f98bd80de Ancestors: HelpSystem-Core-mt.142, HelpSystem-Core-tpr.142.partial
An attempt at bringing ct's HelpBrowser editing improvements up to date so we can incorporate them. This primarily adds the ability to add/remove (sub)topics, which makes editing Help info much simpler, which in turn might encourage people to expend it.
=============== Diff against HelpSystem-Core-mt.142 ===============
Item was changed: ----- Method: AbstractHelpTopic>>accept:for: (in category 'editing') ----- accept: newContents for: subtopic + "If this topic is editable, this will be the callback to update its contents."! - "If this topic is editable, this will be the callback to update its contents." - ^ false!
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 | - (self canBrowseTopicFromParent: parentTopic) - ifTrue: [ - aMenu - add: 'browse (b)' translated - target: self - selector: #browseTopicFromParent: - argumentList: {parentTopic}; - addLine ]. 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} ]. - add: 'inspect (i)' translated target: self action: #inspect; - add: 'explore (I)' translated target: self action: #explore. + 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 changed: ----- Method: ClassBasedHelpTopic>>accept:for: (in category 'editing') ----- accept: newContents for: subtopic "Supports indirect content storage in classes other than helpClass." | topicClass topicMethodSelector code indirect | + (subtopic respondsTo: #contentsAsIs) ifFalse: + [^ self inform: 'Cannot store into this topic' translated]. - (subtopic respondsTo: #contentsAsIs) - ifFalse: [^ self inform: 'Cannot store into this topic' translated]. (indirect := subtopic contentsAsIs isMessageSend) + ifFalse: + [topicClass := self helpClass. - ifFalse: [ - topicClass := self helpClass. topicMethodSelector := subtopic key asLegalSelector asSymbol] + ifTrue: + [topicClass := subtopic contentsAsIs receiver. - ifTrue: [ - topicClass := subtopic contentsAsIs receiver. topicMethodSelector := subtopic contentsAsIs selector]. (topicClass class includesSelector: topicMethodSelector) ==> [self okToWriteSelector: topicMethodSelector] ifFalse: [^ false]. + code := String streamContents: + [:s| - code := String streamContents:[:s| s nextPutAll: topicMethodSelector. s crtab; nextPutAll: '"This method was automatically generated. Edit it using:"'. s crtab; nextPutAll: '"', self helpClass name,' edit: ', subtopic key storeString,'"'. + indirect + ifTrue: [s crtab; nextPutAll: '^ ('] + ifFalse: + [s crtab; nextPutAll: '<generated>'. + s crtab; nextPutAll: '^(HelpTopic'. + s crtab: 2; nextPutAll: 'title: ', subtopic title storeString. + s crtab: 2; nextPutAll: 'contents: ']. - indirect ifTrue: [s crtab; nextPutAll: '^ ('] ifFalse: [ - s crtab; nextPutAll: '<generated>'. - s crtab; nextPutAll: '^(HelpTopic'. - s crtab: 2; nextPutAll: 'title: ', subtopic title storeString. - s crtab: 2; nextPutAll: 'contents: ']. + s cr; nextPutAll: (String streamContents: + [:c| + c nextChunkPutWithStyle: newContents]) storeString. - s cr; nextPutAll: (String streamContents:[:c| c nextChunkPutWithStyle: newContents]) storeString. s nextPutAll:' readStream nextChunkText)'. + indirect ifFalse: + [subtopic key ifNotNil: + [s crtab: 3; nextPutAll: 'key: ', subtopic key storeString; nextPutAll: ';']. + subtopic shouldStyle ifNotNil: + [s crtab: 3; nextPutAll: 'shouldStyle: ', subtopic shouldStyle storeString; nextPutAll: ';']. + s crtab: 3; nextPutAll: 'yourself']]. - indirect ifFalse: [ - subtopic key ifNotNil: [s crtab: 3; nextPutAll: 'key: ', subtopic key storeString; nextPutAll: ';']. - subtopic shouldStyle ifNotNil: [s crtab: 3; nextPutAll: 'shouldStyle: ', subtopic shouldStyle storeString; nextPutAll: ';']. - s crtab: 3; nextPutAll: 'yourself'] - ].
topicClass class compile: code classified: ((topicClass class organization categoryOfElement: topicMethodSelector) ifNil:['pages']). ^ 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>>removeSubtopic: (in category 'editing') ----- + removeSubtopic: aTopic + + | needsToStorePages 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) ifTrue: + [(self okToWriteSelector: #pages) + ifFalse: [^ false]. + oldPages := self helpClass pages]. + + (self systemNavigation + confirmAndRemoveSelector: aTopic key + class: self helpClass theMetaClass) + ifFalse: [^ false]. + + needsToStorePages ifTrue: + [self storePages: (oldPages copyWithout: aTopic key)]. + self refresh. + ^ 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.!
Item was changed: ----- Method: ClassBasedHelpTopic>>updateSubtopics (in category 'updating') ----- updateSubtopics "build a list of subtopics; start with the list of page names specified by the helpClass' #pages method, remembering that it is an ordered list of - selectors that return a HelpTopic, - or the name of a class that must in turn provide help topics etc. This allows for hierarchies with 'subtrees in the middle'. The order of the pages reflects the order of the selectors and class names given. Then all the subclasses that are not #ignore'd and not already included are added. Finally the list of class names and messages is used to assemble the actual help topics. Questions: is it actually useful to include the possibility of class names as per the CustomHelpHelpBuilder>createTopicFrom: code? is the #ignore testing worth keeping?" | pages | pages := (self helpClass pages collect: [:pageSelectorOrClassName | (Smalltalk hasClassNamed: pageSelectorOrClassName asString) ifTrue: [Smalltalk classNamed: pageSelectorOrClassName asString] ifFalse: [pageSelectorOrClassName]]) asOrderedCollection.
self helpClass subclasses + reject: [:cls | cls ignore] - select: [:cls | cls ignore not] thenDo: [:cls | pages addIfNotPresent: cls].
+ ^ subtopics := pages withIndexCollect: + [:pageSelectorOrClass :pagePriority | - ^ subtopics := pages withIndexCollect: [:pageSelectorOrClass :pagePriority | pageSelectorOrClass isBehavior ifFalse: [(self helpClass perform: pageSelectorOrClass) priority: pagePriority - pages size; key: pageSelectorOrClass; in: [:topic | "Use my choice of styling if my subtopics do not care." topic shouldStyle ifNil: [topic shouldStyle: self usesCodeStyling]]; yourself] ifTrue: [pageSelectorOrClass asHelpTopic]]!
Item was changed: ----- Method: CustomHelp class>>edit: (in category 'editing') ----- edit: aSelector
+ (HelpBrowser openOn: self asHelpTopic) model showTopicNamed: aSelector! - (HelpBrowser openOn: self asHelpTopic) model showTopicNamed: aSelector.. - !
Item was changed: ----- Method: DirectoryBasedHelpTopic>>accept:for: (in category 'editing') ----- accept: newContents for: subtopic
FileStream forceNewFileNamed: subtopic fileEntry fullName do: [:strm | strm nextChunkPutWithStyle: newContents]. - ^ true !
Item was changed: ----- Method: FileBasedHelpTopic>>accept:for: (in category 'editing') ----- accept: newContents for: subtopic
FileStream forceNewFileNamed: self fileEntry fullName do: [:strm | strm nextChunkPutWithStyle: newContents]. + - ^ true !
On 2023-07-31, at 8:27 PM, commits@source.squeak.org wrote: An attempt at bringing ct's HelpBrowser editing improvements up to date so we can incorporate them. This primarily adds the ability to add/remove (sub)topics, which makes editing Help info much simpler, which in turn might encourage people to expend it.
Please test this and bang at the help browser a bit. I'd like to get this functionality in the system soon. There is some more interesting stuff to do with handling html based help (ie loading the swiki pages) that needs more careful checking; not least because we could also consider using the HtmlParser etc to read the content and process it before displaying.
tim -- tim Rowledge; tim@rowledge.org; http://www.rowledge.org/tim Design simplicity: It was developed on a shoe-string budget.
squeak-dev@lists.squeakfoundation.org