[squeak-dev] The Inbox: HelpSystem-Core-ct.124.mcz
Thiede, Christoph
Christoph.Thiede at student.hpi.uni-potsdam.de
Sun Oct 13 20:52:53 UTC 2019
[cid:09a310f6-32c6-44cb-834e-62b19a2714c9]
________________________________
Von: Squeak-dev <squeak-dev-bounces at lists.squeakfoundation.org> im Auftrag von commits at source.squeak.org <commits at source.squeak.org>
Gesendet: Sonntag, 13. Oktober 2019 22:52:12
An: squeak-dev at lists.squeakfoundation.org
Betreff: [squeak-dev] 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.!
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://lists.squeakfoundation.org/pipermail/squeak-dev/attachments/20191013/0393199b/attachment-0001.html>
-------------- next part --------------
A non-text attachment was scrubbed...
Name: pastedImage.png
Type: image/png
Size: 27116 bytes
Desc: pastedImage.png
URL: <http://lists.squeakfoundation.org/pipermail/squeak-dev/attachments/20191013/0393199b/attachment-0001.png>
More information about the Squeak-dev
mailing list
|