[squeak-dev] The Trunk: HelpSystem-Core-mt.68.mczcommits at source.squeak.org commits at source.squeak.orgSun Apr 12 15:52:49 UTC 2015
Marcel Taeumel uploaded a new version of HelpSystem-Core to project The Trunk: http://source.squeak.org/trunk/HelpSystem-Core-mt.68.mcz ==================== Summary ==================== Name: HelpSystem-Core-mt.68 Author: mt Time: 12 April 2015, 5:52:42.706 pm UUID: 31491b8c-3fee-eb48-8c6c-d59bf06a465d Ancestors: HelpSystem-Core-mt.67 Concurrent search added to help browser. Having this, we can also search web contents. =============== Diff against HelpSystem-Core-mt.67 =============== Item was changed: + Model subclass: #AbstractHelpTopic - Object subclass: #AbstractHelpTopic instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'HelpSystem-Core-Model'! !AbstractHelpTopic commentStamp: 'mt 3/24/2015 16:26' prior: 0! A HelpTopic provides content information that can be used as a help to the user. It can be labeled with a title and marked with an (optional) icon. Help topics form a hierarchy since any topic is able to have zero or more subtopics. ! Item was added: + ----- Method: AbstractHelpTopic>>isSearchable (in category 'testing') ----- + isSearchable + + ^ true! Item was added: + ----- Method: AbstractHelpTopic>>priorityForSearch (in category 'accessing') ----- + priorityForSearch + + ^ 0! Item was changed: AbstractHelpTopic subclass: #ClassBasedHelpTopic + instanceVariableNames: 'helpClass subtopics' - instanceVariableNames: 'helpClass' classVariableNames: '' poolDictionaries: '' category: 'HelpSystem-Core-Model'! !ClassBasedHelpTopic commentStamp: 'mt 3/24/2015 16:28' prior: 0! This kind of topic uses subclasses and methods to encode books and pages.! Item was changed: ----- Method: ClassBasedHelpTopic>>subtopics (in category 'accessing') ----- subtopics + ^ subtopics ifNil: [self updateSubtopics]! - | pages | - pages := (self helpClass pages collect: [:pageSelectorOrClassName | - (Smalltalk hasClassNamed: pageSelectorOrClassName asString) - ifTrue: [Smalltalk classNamed: pageSelectorOrClassName asString] - ifFalse: [pageSelectorOrClassName]]) asOrderedCollection. - - self helpClass subclasses do: [:cls | - pages addIfNotPresent: cls]. - - ^ pages withIndexCollect: [:pageSelectorOrClass :priority | - pageSelectorOrClass isBehavior - ifFalse: [(self helpClass perform: pageSelectorOrClass) priority: priority - pages size; yourself] - ifTrue: [pageSelectorOrClass asHelpTopic]]! Item was added: + ----- Method: ClassBasedHelpTopic>>updateSubtopics (in category 'updating') ----- + updateSubtopics + + | pages | + pages := (self helpClass pages collect: [:pageSelectorOrClassName | + (Smalltalk hasClassNamed: pageSelectorOrClassName asString) + ifTrue: [Smalltalk classNamed: pageSelectorOrClassName asString] + ifFalse: [pageSelectorOrClassName]]) asOrderedCollection. + + self helpClass subclasses do: [:cls | + pages addIfNotPresent: cls]. + + ^ subtopics := pages withIndexCollect: [:pageSelectorOrClass :priority | + pageSelectorOrClass isBehavior + ifFalse: [(self helpClass perform: pageSelectorOrClass) priority: priority - pages size; yourself] + ifTrue: [pageSelectorOrClass asHelpTopic]]! Item was changed: + Model subclass: #HelpBrowser + instanceVariableNames: 'rootTopic currentTopic result searchTopic topicPath toplevelTopics' - Object subclass: #HelpBrowser - instanceVariableNames: 'rootTopic topic result' classVariableNames: 'DefaultHelpBrowser' poolDictionaries: '' category: 'HelpSystem-Core-UI'! !HelpBrowser commentStamp: 'tbn 3/8/2010 09:33' prior: 0! A HelpBrowser is used to display a hierarchy of help topics and their contents. Instance Variables rootTopic: <HelpTopic> window: <StandardWindow> treeMorph: <PluggableTreeMorph> contentMorph: <Morph> rootTopic - xxxxx window - xxxxx treeMorph - xxxxx contentMorph - xxxxx ! Item was changed: ----- Method: HelpBrowser>>accept: (in category 'actions') ----- accept: text "Accept edited text. Compile it into a HelpTopic" | code topicClass topicMethod | (self find: self topic contents) asArray ifNotEmpty: [:refs | topicClass := refs first actualClass theNonMetaClass. topicMethod := refs first selector]. code := String streamContents:[:s| s nextPutAll: topicMethod. s crtab; nextPutAll: '"This method was automatically generated. Edit it using:"'. s crtab; nextPutAll: '"', self name,' edit: ', topicMethod storeString,'"'. s crtab; nextPutAll: '^HelpTopic'. + s crtab: 2; nextPutAll: 'title: ', currentTopic title storeString. - s crtab: 2; nextPutAll: 'title: ', topic title storeString. s crtab: 2; nextPutAll: 'contents: '. s cr; nextPutAll: (String streamContents:[:c| c nextChunkPutWithStyle: text]) storeString. s nextPutAll:' readStream nextChunkText'. ]. topicClass class compile: code classified: ((topicClass class organization categoryOfElement: topicMethod) ifNil:['pages']). self flag: #fixme. "mt: Update will not work because the topic builder eagerly cached all the contents and lost track of its origins. We need to get rid of the topic builders and create topic contents lazily resp. live." + self changed: #toplevelTopics.. + self changed: #currentTopic. - self changed: #topics. - self changed: #topic. self changed: #topicContents. ! Item was changed: ----- Method: HelpBrowser>>buildWith: (in category 'toolbuilder') ----- buildWith: builder + | windowSpec treeSpec textSpec searchSpec | - | windowSpec treeSpec textSpec | windowSpec := builder pluggableWindowSpec new. windowSpec model: self; children: OrderedCollection new; label: #label. + searchSpec := builder pluggableInputFieldSpec new. + searchSpec + model: self; + getText: #searchTerm; + setText: #searchTerm:; + help: 'Search...'; + frame: (LayoutFrame + fractions: (0 at 0 corner: 1 at 0) + offsets: (0 at 0 corner: 0@ (Preferences standardDefaultTextFont height * 2))). + windowSpec children add: searchSpec. + treeSpec := builder pluggableTreeSpec new. treeSpec model: self; nodeClass: HelpTopicListItemWrapper; + roots: #toplevelTopics; + getSelected: #currentTopic; + setSelected: #currentTopic:; + getSelectedPath: #currentTopicPath; - roots: #topics; - getSelected: #topic; - setSelected: #topic:; - menu: #menu:; autoDeselect: false; + frame: (LayoutFrame + fractions: (0 at 0 corner: 0.3 at 1) + offsets: (0@ (Preferences standardDefaultTextFont height * 2) corner: 0 at 0)). - frame: (0 at 0 corner: 0.3 at 1). windowSpec children add: treeSpec. textSpec := builder pluggableTextSpec new. textSpec model: self; getText: #topicContents; setText: #accept:; menu: #codePaneMenu:shifted:; + frame: (LayoutFrame + fractions: (0.3 at 0.0 corner: 1 at 1) + offsets: (0@ (Preferences standardDefaultTextFont height * 2) corner: 0 at 0)). - frame: (0.3 at 0 corner: 1 at 1). windowSpec children add: textSpec. ^ builder build: windowSpec! Item was added: + ----- Method: HelpBrowser>>currentTopic (in category 'accessing') ----- + currentTopic + + ^ currentTopic! Item was added: + ----- Method: HelpBrowser>>currentTopic: (in category 'accessing') ----- + currentTopic: aHelpTopic + + self currentTopic == aHelpTopic ifTrue: [^ self]. + + currentTopic := aHelpTopic. + topicPath := nil. + + self changed: #currentTopic. + self changed: #topicContents.! Item was added: + ----- Method: HelpBrowser>>currentTopicPath (in category 'accessing') ----- + currentTopicPath + "Only used for dynamic dispatch. Should be nil or empty on manual evaluation. See #topic:." + + ^ topicPath ifNil: [#()]! Item was added: + ----- Method: HelpBrowser>>currentTopicPath: (in category 'accessing') ----- + currentTopicPath: someTopics + "Use the tree structure to select a nested topic." + + topicPath := someTopics. + self changed: #currentTopicPath.! Item was changed: ----- Method: HelpBrowser>>findAgain (in category 'actions') ----- findAgain | i | + (i := result indexOf: currentTopic) ~= 0 - (i := result indexOf: topic) ~= 0 ifTrue: [i = result size ifTrue: [(self confirm: 'Start over?') ifTrue: [i := 1] ifFalse: [^ self]]. self onItemClicked: (result at: i + 1)]! Item was changed: ----- Method: HelpBrowser>>rootTopic: (in category 'accessing') ----- rootTopic: aHelpTopic rootTopic := aHelpTopic asHelpTopic. + self toplevelTopics: ((self rootTopic ifNil: [#()] ifNotNil: #subtopics) sorted, {self searchTopic}). + self changed: #label.! - self changed: #label. - self changed: #topics.! Item was added: + ----- Method: HelpBrowser>>searchTerm (in category 'searching') ----- + searchTerm + + ^ '' "Reset. Terms are cached in SearchTopic instances."! Item was added: + ----- Method: HelpBrowser>>searchTerm: (in category 'searching') ----- + searchTerm: aString + "Spawn a new search topic." + + | topic | + topic := self searchTopic subtopics + detect: [:t | t term = aString] + ifNone: [ | newTopic | + newTopic := SearchTopic new + term: aString; + yourself. + self searchTopic addSubtopic: newTopic. + newTopic addDependent: self. "Tell me about your updates." + newTopic]. + + "self changed: #searchTerm." + + "Select results and expand searches node if necessary." + self currentTopicPath: {self searchTopic. topic}. + self assert: self currentTopic == topic. + + topic + topicsToSearch: self toplevelTopics allButLast; + startSearch.! Item was added: + ----- Method: HelpBrowser>>searchTopic (in category 'searching') ----- + searchTopic + + ^ searchTopic ifNil: [searchTopic := HelpTopic new + title: 'Search Results'; + addDependent: self; + yourself]! Item was removed: - ----- Method: HelpBrowser>>topic (in category 'accessing') ----- - topic - - ^ topic! Item was removed: - ----- Method: HelpBrowser>>topic: (in category 'accessing') ----- - topic: aHelpTopic - - self topic == aHelpTopic ifTrue: [^ self]. - - topic := aHelpTopic. - - self changed: #topic. - self changed: #topicContents.! Item was changed: ----- Method: HelpBrowser>>topicContents (in category 'accessing - ui') ----- topicContents + ^ (self currentTopic ifNil: [self rootTopic]) ifNil: '' ifNotNil: #contents! - ^ (self topic ifNil: [self rootTopic]) ifNil: '' ifNotNil: #contents! Item was removed: - ----- Method: HelpBrowser>>topics (in category 'accessing - ui') ----- - topics - - ^ (self rootTopic ifNil: [#()] ifNotNil: #subtopics) sorted! Item was added: + ----- Method: HelpBrowser>>toplevelTopics (in category 'accessing') ----- + toplevelTopics + + ^ toplevelTopics ifNil: [#()]! Item was added: + ----- Method: HelpBrowser>>toplevelTopics: (in category 'accessing') ----- + toplevelTopics: someTopics + + toplevelTopics := someTopics. + self changed: #toplevelTopics.! Item was added: + ----- Method: HelpBrowser>>update:with: (in category 'updating') ----- + update: aspect with: object + + aspect == #contents ifTrue: [ + object == self currentTopic ifTrue: [self changed: #topicContents]]. + aspect == #searchResultSelected ifTrue: [ + self currentTopicPath: object].! Item was added: + ----- Method: HelpBrowser>>windowIsClosing (in category 'updating') ----- + windowIsClosing + + super windowIsClosing. + + self searchTopic subtopics do: [:topic | + topic stopSearch].! Item was changed: ----- Method: HelpTopic>>addSubtopic: (in category 'accessing') ----- addSubtopic: aTopic "Adds the given topic to the receivers collection of subtopics" self subtopics add: aTopic. + self changed: #subtopicAdded with: aTopic. ^aTopic! Item was added: + ----- Method: HelpTopicListItemWrapper>>update:with: (in category 'accessing') ----- + update: aspect with: object + + super update: aspect with: object. + + "Map the domain-specific aspect to a framework-specific one." + aspect = #subtopicAdded ifTrue: [ + self changed: #contents].! Item was changed: AbstractHelpTopic subclass: #HtmlHelpTopic + instanceVariableNames: 'url document selectBlock convertBlock subtopicUrls subtopics level' - instanceVariableNames: 'url cache selectBlock convertBlock subtopicUrls' classVariableNames: '' poolDictionaries: '' category: 'HelpSystem-Core-Model'! Item was changed: ----- Method: HtmlHelpTopic>>contents (in category 'accessing') ----- contents | start end | start := (self document findString: '<body'). start := (self document findString: '>' startingAt: start) + 1. end := self document findString: '</body>' startingAt: start. + start > end ifTrue: [^ self document]. - start > end ifTrue: [^ '']. ^ (self document copyFrom: start to: end - 1) asUnHtml withBlanksTrimmed! Item was changed: ----- Method: HtmlHelpTopic>>document (in category 'accessing') ----- document + ^ document ifNil: [document := + [ + (HTTPSocket httpGet: self url accept: 'text/html') contents + ] on: Error do: [:err | err printString]]! - ^ cache ifNil: [cache := (HTTPSocket httpGet: self url accept: 'text/html') contents]! Item was added: + ----- Method: HtmlHelpTopic>>fetchSubtopics (in category 'caching') ----- + fetchSubtopics + "If this method is called from another process than the ui process, there will be no progress shown." + + | updateBlock | + updateBlock := [:topic | topic document; subtopicUrls]. + + Project current uiProcess == Processor activeProcess + ifFalse: [self subtopics do: updateBlock] + ifTrue: [self subtopics + do: updateBlock + displayingProgress: [:topic | 'Fetching documents ... ', topic url]].! Item was added: + ----- Method: HtmlHelpTopic>>isSearchable (in category 'testing') ----- + isSearchable + + ^ self level < 2! Item was added: + ----- Method: HtmlHelpTopic>>level (in category 'accessing') ----- + level + + ^ level ifNil: [level := 1]! Item was added: + ----- Method: HtmlHelpTopic>>level: (in category 'accessing') ----- + level: anInteger + + level := anInteger.! Item was added: + ----- Method: HtmlHelpTopic>>priorityForSearch (in category 'accessing') ----- + priorityForSearch + + ^ 999 "very late"! Item was added: + ----- Method: HtmlHelpTopic>>refresh (in category 'caching') ----- + refresh + "Re-fetch document and all referenced urls." + + document := nil. + subtopics := nil. + + self changed: #contents. "See #contents. It is based on document." + self changed: #subtopics.! Item was changed: ----- Method: HtmlHelpTopic>>subtopics (in category 'accessing') ----- subtopics | start end urls | + subtopics ifNotNil: [^ subtopics]. + urls := OrderedCollection new. start := self document findString: '<a '. [start > 0] whileTrue: [ start := self document findString: 'href' startingAt: start. start := (self document findString: '"' startingAt: start) + 1. end := self document findString: '"' startingAt: start. urls addIfNotPresent: (self document copyFrom: start to: end - 1). start := self document findString: '<a ' startingAt: start.]. + subtopics := (self subtopicUrls collect: [:url | self class new + level: self level + 1; - ^ (self subtopicUrls collect: [:url | self class new url: url; selectBlock: self selectBlock; + convertBlock: self convertBlock]). + + Project current uiProcess == Processor activeProcess + ifTrue: [self fetchSubtopics]. + + ^ subtopics! - convertBlock: self convertBlock]) - do: [:topic | topic document; subtopicUrls "download now"] displayingProgress: [:topic | 'Fetching documents ... ', topic url]; - yourself! Item was changed: ----- Method: HtmlHelpTopic>>title (in category 'accessing') ----- title | start end | start := (self document findString: '<title') + 6. start := (self document findString: '>' startingAt: start) + 1. end := self document findString: '</title>' startingAt: start. + start > end ifTrue: [^ self url asUrl authority]. - start > end ifTrue: [^ self url printStringLimitedTo: 10]. ^ self document copyFrom: start to: end - 1! Item was added: + AbstractHelpTopic subclass: #SearchTopic + instanceVariableNames: 'term process results resultText topicsToSearch mutex updatePending' + classVariableNames: '' + poolDictionaries: '' + category: 'HelpSystem-Core-Model'! Item was added: + ----- Method: SearchTopic>><= (in category 'comparing') ----- + <= anotherHelpTopic + + ^ true "Keep insertion order in parent topic."! Item was added: + ----- Method: SearchTopic>>contents (in category 'accessing') ----- + contents + + ^ resultText ifNil: [self updateResultText]! Item was added: + ----- Method: SearchTopic>>find:in:results: (in category 'as yet unclassified') ----- + find: term in: path results: results + + | resultTemplate c topic | + topic := path last. + resultTemplate := Array new: 5. + (topic title asString findString: term startingAt: 1 caseSensitive: false) in: [:index | + index > 0 ifTrue: [resultTemplate at: 2 put: (index to: index + term size)]]. + + ((c := topic contents asString withSqueakLineEndings) findString: term startingAt: 1 caseSensitive: false) in: [:index | + index > 0 ifTrue: [ + | leadingContext trailingContext i | + leadingContext := 0. + trailingContext := 0. + i := index. + [i notNil] whileTrue: [ + (leadingContext = 2 or: [i = 1]) + ifTrue: [ + leadingContext := i = 1 ifTrue: [i] ifFalse: [i+1]. + i := nil] + ifFalse: [ + ((c at: i) = Character cr) ifTrue: [ + leadingContext := leadingContext + 1]. + i := i - 1] ]. + i := index + term size. + [i notNil] whileTrue: [ + (trailingContext = 2 or: [i = c size]) + ifTrue: [ + trailingContext := i = c size ifTrue: [i] ifFalse: [i-1]. + i := nil] + ifFalse: [ + ((c at: i) = Character cr) ifTrue: [ + trailingContext := trailingContext + 1]. + i := i + 1] ]. + + resultTemplate + at: 1 put: path; + at: 3 put: (index - leadingContext + 1 to: index - leadingContext + term size); + at: 4 put: (c copyFrom: leadingContext to: trailingContext); + at: 5 put: leadingContext. + + self mutex critical: [ results add: resultTemplate ]. + self triggerUpdateContents. + + ] ]. + + topic isSearchable ifTrue: [ + topic subtopics do: [:t | self find: term in: path, {t} results: results]].! Item was added: + ----- Method: SearchTopic>>mutex (in category 'as yet unclassified') ----- + mutex + + ^ mutex ifNil: [mutex := Mutex new]! Item was added: + ----- Method: SearchTopic>>printResultEntry: (in category 'as yet unclassified') ----- + printResultEntry: entry + + | resultEntry topic | + resultEntry := '' asText. + topic := entry first last. + + entry second notNil + ifFalse: [resultEntry append: ( + (topic title) asText + addAttribute: TextEmphasis bold)] + ifTrue: [resultEntry append: ( + (topic title) asText + addAttribute: TextEmphasis bold; + addAttribute: (TextColor color: Color green muchDarker) + from: entry second first + to: entry second last)]. + + resultEntry append: (' (open topic)' asText + addAttribute: (PluggableTextAttribute evalBlock: [self changed: #searchResultSelected with: entry first])). + + resultEntry append: String cr. + + entry fourth in: [:contents | + | text | + text := contents asText. + text + addAttribute: (TextColor color: Color green muchDarker) + from: entry third first + to: entry third last; + addAttribute: TextEmphasis bold + from: entry third first + to: entry third last. + resultEntry + append: text withBlanksTrimmed; + append: '\\' withCRs. + + ]. + + ^ resultEntry! Item was added: + ----- Method: SearchTopic>>startSearch (in category 'as yet unclassified') ----- + startSearch + + self stopSearch. + results := OrderedCollection new. + + self topicsToSearch ifEmpty: [ + self changed: #contents. + ^ self]. + + process := [ + + (self topicsToSearch + sorted: [:t1 :t2 | t1 priorityForSearch <= t2 priorityForSearch]) + do: [:topic | + | nestedResults | + nestedResults := OrderedCollection new. + self mutex critical: [results add: topic -> nestedResults]. + self find: self term in: {topic} results: nestedResults]. + + results add: 'Search finished.'. + self triggerUpdateContents. + + ] forkAt: 35.! Item was added: + ----- Method: SearchTopic>>stopSearch (in category 'as yet unclassified') ----- + stopSearch + + process ifNotNil: #terminate. + process := nil.! Item was added: + ----- Method: SearchTopic>>term (in category 'accessing') ----- + term + + ^ term! Item was added: + ----- Method: SearchTopic>>term: (in category 'accessing') ----- + term: aString + + term := aString.! Item was added: + ----- Method: SearchTopic>>title (in category 'accessing') ----- + title + + ^ '''', self term, ''''! Item was added: + ----- Method: SearchTopic>>topicsToSearch (in category 'accessing') ----- + topicsToSearch + + ^ topicsToSearch ifNil: [#()]! Item was added: + ----- Method: SearchTopic>>topicsToSearch: (in category 'accessing') ----- + topicsToSearch: someTopics + + topicsToSearch := someTopics.! Item was added: + ----- Method: SearchTopic>>triggerUpdateContents (in category 'as yet unclassified') ----- + triggerUpdateContents + + self mutex critical: [ + updatePending == true ifFalse: [ + updatePending := true. + Project current addDeferredUIMessage: [ActiveWorld + addAlarm: #updateContents withArguments: #() + for: self at: Time millisecondClockValue + 250] ] ]. + ! Item was added: + ----- Method: SearchTopic>>updateContents (in category 'as yet unclassified') ----- + updateContents + + self mutex critical: [ updatePending := false ]. + + resultText := nil. + self changed: #contents with: self.! Item was added: + ----- Method: SearchTopic>>updateResultText (in category 'as yet unclassified') ----- + updateResultText + + resultText := '' asText. + + self mutex critical: [ + results ifNil: [^ resultText]. + results do: [:topicToResult | + topicToResult isString + ifTrue: [resultText append: ( + (topicToResult, String cr) asText + addAttribute: (TextColor color: (Color gray: 0.7)); + yourself)] + ifFalse: [ + resultText append: ( + ('\----- Matches found in ''', topicToResult key title, ''' -----\\') withCRs asText + addAttribute: (TextColor color: (Color gray: 0.7))). + topicToResult value do: [:entry | + resultText append: (self printResultEntry: entry)] + ]]]. + + ^ resultText!
More information about the Squeak-dev mailing list |