The Inbox: HelpSystem-Core-ct.124.mcz

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.!