Packages May 2013

packages@lists.squeakfoundation.org

1 participants
357 discussions

The Trunk: SUnitGUI-fbs.57.mcz
by commits＠source.squeak.org 31 May '13

31 May '13

Frank Shearar uploaded a new version of SUnitGUI to project The Trunk: http://source.squeak.org/trunk/SUnitGUI-fbs.57.mcz ==================== Summary ==================== Name: SUnitGUI-fbs.57 Author: fbs Time: 31 May 2013, 4:03:07.92 pm UUID: b836135e-01ed-4f6e-b671-36c56a5fa89a Ancestors: SUnitGUI-eem.56 Move ToolBuilder-SUnit to SUnitGUI-ToolBuilder. =============== Diff against SUnitGUI-eem.56 =============== Item was changed: + SystemOrganization addCategory: #'SUnitGUI-ToolBuilder'! SystemOrganization addCategory: #SUnitGUI! Item was added: + WidgetStub subclass: #ButtonStub + instanceVariableNames: '' + classVariableNames: '' + poolDictionaries: '' + category: 'SUnitGUI-ToolBuilder'! Item was added: + ----- Method: ButtonStub>>click (in category 'simulating') ----- + click + | action | + action := spec action. + action isSymbol + ifTrue: [self model perform: action] + ifFalse: [action value]! Item was added: + ----- Method: ButtonStub>>color (in category 'simulating') ----- + color + ^ state at: #color! Item was added: + ----- Method: ButtonStub>>isEnabled (in category 'simulating') ----- + isEnabled + ^ state at: #enabled! Item was added: + ----- Method: ButtonStub>>isPressed (in category 'simulating') ----- + isPressed + ^ state at: #state! Item was added: + ----- Method: ButtonStub>>label (in category 'simulating') ----- + label + ^ state at: #label! Item was added: + ----- Method: ButtonStub>>stateVariables (in category 'events') ----- + stateVariables + ^ #(label color state enabled)! Item was added: + WidgetStub subclass: #CompositeStub + instanceVariableNames: '' + classVariableNames: '' + poolDictionaries: '' + category: 'SUnitGUI-ToolBuilder'! Item was added: + ----- Method: CompositeStub>>children (in category 'accessing') ----- + children + ^ state at: #children ifAbsent: [#()]! Item was added: + ----- Method: CompositeStub>>children: (in category 'accessing') ----- + children: anObject + state at: #children put: anObject! Item was added: + ----- Method: CompositeStub>>stateVariables (in category 'accessing') ----- + stateVariables + ^ #(children)! Item was added: + ----- Method: CompositeStub>>widgetNamed: (in category 'accessing') ----- + widgetNamed: aString + self name = aString + ifTrue: [^ self] + ifFalse: [self children do: [:ea | (ea widgetNamed: aString) ifNotNil: [:w | ^ w]]]. + ^ nil! Item was added: + WidgetStub subclass: #ListStub + instanceVariableNames: 'list index' + classVariableNames: '' + poolDictionaries: '' + category: 'SUnitGUI-ToolBuilder'! Item was added: + ----- Method: ListStub>>click: (in category 'simulating') ----- + click: aString + self clickItemAt: (self list indexOf: aString)! Item was added: + ----- Method: ListStub>>clickItemAt: (in category 'simulating') ----- + clickItemAt: anInteger + | selector | + selector := spec setIndex. + selector + ifNil: [self model perform: spec setSelected with: (self list at: anInteger)] + ifNotNil: [self model perform: selector with: anInteger] + ! Item was added: + ----- Method: ListStub>>list (in category 'simulating') ----- + list + ^ list ifNil: [Array new]! Item was added: + ----- Method: ListStub>>menu (in category 'simulating') ----- + menu + ^ MenuStub fromSpec: + (self model + perform: spec menu + with: (PluggableMenuSpec withModel: self model))! Item was added: + ----- Method: ListStub>>refresh (in category 'events') ----- + refresh + self refreshList. + self refreshIndex! Item was added: + ----- Method: ListStub>>refreshIndex (in category 'events') ----- + refreshIndex + | selector | + selector := spec getIndex. + index := selector + ifNil: [self list indexOf: (self model perform: spec getSelected)] + ifNotNil: [spec model perform: selector] + ! Item was added: + ----- Method: ListStub>>refreshList (in category 'events') ----- + refreshList + list := self model perform: spec list! Item was added: + ----- Method: ListStub>>selectedIndex (in category 'simulating') ----- + selectedIndex + ^ index ifNil: [0]! Item was added: + ----- Method: ListStub>>selectedItem (in category 'simulating') ----- + selectedItem + | items idx | + (items := self list) isEmpty ifTrue: [^ nil]. + (idx := self selectedIndex) = 0 ifTrue: [^ nil]. + ^ items at: idx + ! Item was added: + ----- Method: ListStub>>update: (in category 'events') ----- + update: aSelector + aSelector = spec list ifTrue: [^ self refreshList]. + aSelector = spec getSelected ifTrue: [^ self refreshIndex]. + aSelector = spec getIndex ifTrue: [^ self refreshIndex]. + ^ super update: aSelector! Item was added: + WidgetStub subclass: #MenuStub + instanceVariableNames: '' + classVariableNames: '' + poolDictionaries: '' + category: 'SUnitGUI-ToolBuilder'! Item was added: + ----- Method: MenuStub>>click: (in category 'as yet unclassified') ----- + click: aString + | item | + item := self items detect: [:ea | ea label = aString] ifNone: [^ self]. + item action isSymbol + ifTrue: [self model perform: item action] + ifFalse: [item action value]! Item was added: + ----- Method: MenuStub>>items (in category 'as yet unclassified') ----- + items + ^ spec items! Item was added: + ----- Method: MenuStub>>labels (in category 'as yet unclassified') ----- + labels + ^ self items keys! Item was added: + CompositeStub subclass: #PanelStub + instanceVariableNames: '' + classVariableNames: '' + poolDictionaries: '' + category: 'SUnitGUI-ToolBuilder'! Item was added: + ToolBuilder subclass: #SUnitToolBuilder + instanceVariableNames: 'widgets' + classVariableNames: '' + poolDictionaries: '' + category: 'SUnitGUI-ToolBuilder'! + + !SUnitToolBuilder commentStamp: 'cwp 6/7/2005 00:53' prior: 0! + I create a set of "stub" widgets that are useful for testing. Instead of drawing themselves in some GUI, they simulate graphical widgets for testing purposes. Through my widgets, unit tests can simulate user actions and make assertions about the state of the display. + + See TestRunnerPlusTest for examples.! Item was added: + ----- Method: SUnitToolBuilder>>buildPluggableButton: (in category 'building') ----- + buildPluggableButton: aSpec + | w | + w := ButtonStub fromSpec: aSpec. + self register: w id: aSpec name. + ^w! Item was added: + ----- Method: SUnitToolBuilder>>buildPluggableList: (in category 'building') ----- + buildPluggableList: aSpec + | w | + w := ListStub fromSpec: aSpec. + self register: w id: aSpec name. + ^w! Item was added: + ----- Method: SUnitToolBuilder>>buildPluggableMenu: (in category 'building') ----- + buildPluggableMenu: aSpec + ^ MenuStub fromSpec: aSpec! Item was added: + ----- Method: SUnitToolBuilder>>buildPluggablePanel: (in category 'building') ----- + buildPluggablePanel: aSpec + | w | + w := PanelStub fromSpec: aSpec. + self register: w id: aSpec name. + ^w! Item was added: + ----- Method: SUnitToolBuilder>>buildPluggableText: (in category 'building') ----- + buildPluggableText: aSpec + | w | + w := TextStub fromSpec: aSpec. + self register: w id: aSpec name. + ^w! Item was added: + ----- Method: SUnitToolBuilder>>buildPluggableTree: (in category 'building') ----- + buildPluggableTree: aSpec + | w | + w := TreeStub fromSpec: aSpec. + self register: w id: aSpec name. + ^w! Item was added: + ----- Method: SUnitToolBuilder>>buildPluggableWindow: (in category 'building') ----- + buildPluggableWindow: aSpec + | window children | + window := WindowStub fromSpec: aSpec. + children := aSpec children. + children isSymbol + ifFalse: [window children: (children collect: [:ea | ea buildWith: self])]. + self register: window id: aSpec name. + ^ window! Item was added: + ----- Method: SUnitToolBuilder>>close: (in category 'opening') ----- + close: aWidget + aWidget close! Item was added: + ----- Method: SUnitToolBuilder>>open: (in category 'opening') ----- + open: anObject + ^ self build: anObject! Item was added: + ----- Method: SUnitToolBuilder>>register:id: (in category 'private') ----- + register: widget id: id + id ifNil:[^self]. + widgets ifNil:[widgets := Dictionary new]. + widgets at: id put: widget.! Item was added: + ----- Method: SUnitToolBuilder>>widgetAt:ifAbsent: (in category 'private') ----- + widgetAt: id ifAbsent: aBlock + widgets ifNil:[^aBlock value]. + ^widgets at: id ifAbsent: aBlock! Item was added: + ToolBuilderTests subclass: #SUnitToolBuilderTests + instanceVariableNames: '' + classVariableNames: '' + poolDictionaries: '' + category: 'SUnitGUI-ToolBuilder'! Item was added: + ----- Method: SUnitToolBuilderTests>>acceptWidgetText (in category 'support') ----- + acceptWidgetText + widget accept: 'Some text'! Item was added: + ----- Method: SUnitToolBuilderTests>>buttonWidgetEnabled (in category 'support') ----- + buttonWidgetEnabled + ^ widget isEnabled! Item was added: + ----- Method: SUnitToolBuilderTests>>changeListWidget (in category 'support') ----- + changeListWidget + widget clickItemAt: widget selectedIndex + 1! Item was added: + ----- Method: SUnitToolBuilderTests>>fireButtonWidget (in category 'support') ----- + fireButtonWidget + widget click! Item was added: + ----- Method: SUnitToolBuilderTests>>fireMenuItemWidget (in category 'support') ----- + fireMenuItemWidget + widget click: 'Menu Item'! Item was added: + ----- Method: SUnitToolBuilderTests>>setUp (in category 'running') ----- + setUp + super setUp. + builder := SUnitToolBuilder new.! Item was added: + ----- Method: SUnitToolBuilderTests>>testHandlingNotification (in category 'tests') ----- + testHandlingNotification + | receivedSignal resumed | + receivedSignal := resumed := false. + [ | count | + "client-code puts up progress, and signals some notications" + count := 0. + 'doing something' + displayProgressFrom: 0 + to: 10 + during: + [ : bar | 10 timesRepeat: + [ bar value: (count := count + 1). + (Delay forMilliseconds: 200) wait. + Notification signal: 'message'. + resumed := true ] ] ] + on: Notification + do: + [ : noti | receivedSignal := true. + noti resume ]. + self + assert: receivedSignal ; + assert: resumed! Item was added: + ----- Method: SUnitToolBuilderTests>>testListCached (in category 'tests') ----- + testListCached + + self makeItemList. + queries := Bag new. + self changed: #getList. + widget list. + widget list. + self assert: queries size = 1! Item was added: + ----- Method: SUnitToolBuilderTests>>testListSelectionCached (in category 'tests') ----- + testListSelectionCached + + self makeItemList. + queries := Bag new. + self changed: #getListSelection. + widget selectedIndex. + widget selectedIndex. + self assert: queries size = 1! Item was added: + ----- Method: SUnitToolBuilderTests>>testTextCached (in category 'tests') ----- + testTextCached + + self makeText. + queries := Bag new. + self changed: #getText. + widget text. + widget text. + self assert: queries size = 1! Item was added: + ----- Method: SUnitToolBuilderTests>>widgetColor (in category 'support') ----- + widgetColor + ^ widget color! Item was added: + WidgetStub subclass: #TextStub + instanceVariableNames: '' + classVariableNames: '' + poolDictionaries: '' + category: 'SUnitGUI-ToolBuilder'! Item was added: + ----- Method: TextStub>>accept: (in category 'simulating') ----- + accept: aString + state at: #getText put: aString. + ^ self model perform: spec setText with: aString asText! Item was added: + ----- Method: TextStub>>color (in category 'simulating') ----- + color + ^ state at: #color! Item was added: + ----- Method: TextStub>>stateVariables (in category 'events') ----- + stateVariables + ^ #(color selection getText)! Item was added: + ----- Method: TextStub>>text (in category 'simulating') ----- + text + ^ state at: #getText! Item was added: + WidgetStub subclass: #TreeNodeStub + instanceVariableNames: 'item' + classVariableNames: '' + poolDictionaries: '' + category: 'SUnitGUI-ToolBuilder'! Item was added: + ----- Method: TreeNodeStub class>>fromSpec:item: (in category 'instance creation') ----- + fromSpec: aSpec item: anObject + ^ self new setSpec: aSpec item: anObject! Item was added: + ----- Method: TreeNodeStub>>children (in category 'simulating') ----- + children + ^ (self model perform: spec getChildren with: item) + collect: [:ea | TreeNodeStub fromSpec: spec item: ea]! Item was added: + ----- Method: TreeNodeStub>>item (in category 'simulating') ----- + item + ^ item! Item was added: + ----- Method: TreeNodeStub>>label (in category 'simulating') ----- + label + ^ self model perform: spec label with: item! Item was added: + ----- Method: TreeNodeStub>>matches: (in category 'private') ----- + matches: aString + ^ self label = aString! Item was added: + ----- Method: TreeNodeStub>>openPath: (in category 'events') ----- + openPath: anArray + | child | + anArray isEmpty + ifTrue: [self select] + ifFalse: [child := self children + detect: [:ea | ea matches: anArray first] + ifNone: [^ self select]. + child openPath: anArray allButFirst] + ! Item was added: + ----- Method: TreeNodeStub>>printOn: (in category 'printing') ----- + printOn: aStream + aStream + print: self class; + nextPut: $<; + print: item; + nextPut: $>! Item was added: + ----- Method: TreeNodeStub>>select (in category 'simulating') ----- + select + self model perform: spec setSelected with: item! Item was added: + ----- Method: TreeNodeStub>>selectPath: (in category 'private') ----- + selectPath: anArray + | child | + anArray isEmpty ifTrue: [^ self select]. + child := self children detect: [:ea | ea matches: anArray first] ifNone: [^ self select]. + child selectPath: anArray allButFirst.! Item was added: + ----- Method: TreeNodeStub>>setSpec:item: (in category 'initialize-release') ----- + setSpec: aSpec item: anObject + super setSpec: aSpec. + item := anObject! Item was added: + WidgetStub subclass: #TreeStub + instanceVariableNames: 'roots' + classVariableNames: '' + poolDictionaries: '' + category: 'SUnitGUI-ToolBuilder'! Item was added: + ----- Method: TreeStub>>openPath: (in category 'private') ----- + openPath: anArray + | first | + first := roots detect: [:ea | ea matches: anArray first] ifNone: [^ self]. + first openPath: anArray allButFirst! Item was added: + ----- Method: TreeStub>>roots: (in category 'private') ----- + roots: anArray + roots := anArray collect: [:ea | TreeNodeStub fromSpec: spec item: ea]. + ! Item was added: + ----- Method: TreeStub>>select: (in category 'simulating') ----- + select: anArray + self openPath: anArray! Item was added: + ----- Method: TreeStub>>setSpec: (in category 'initialize-release') ----- + setSpec: aSpec + super setSpec: aSpec. + self update: spec roots! Item was added: + ----- Method: TreeStub>>update: (in category 'events') ----- + update: anObject + anObject == spec roots ifTrue: [^ self updateRoots]. + anObject == spec getSelectedPath ifTrue: [^ self updateSelectedPath]. + (anObject isKindOf: Array) ifTrue: [^ self openPath: anObject allButFirst]. + super update: anObject + ! Item was added: + ----- Method: TreeStub>>updateRoots (in category 'events') ----- + updateRoots + ^ self roots: (self model perform: spec roots) + ! Item was added: + ----- Method: TreeStub>>updateSelectedPath (in category 'events') ----- + updateSelectedPath + | path first | + path := self model perform: spec getSelectedPath. + first := roots detect: [:ea | ea item = path first] ifNone: [^ self]. + first selectPath: path allButFirst.! Item was added: + Object subclass: #WidgetStub + instanceVariableNames: 'spec state' + classVariableNames: '' + poolDictionaries: '' + category: 'SUnitGUI-ToolBuilder'! Item was added: + ----- Method: WidgetStub class>>fromSpec: (in category 'instance creation') ----- + fromSpec: aSpec + ^ self new setSpec: aSpec! Item was added: + ----- Method: WidgetStub>>model (in category 'simulating') ----- + model + ^ spec model! Item was added: + ----- Method: WidgetStub>>name (in category 'accessing') ----- + name + ^ spec name ifNil: [' ']! Item was added: + ----- Method: WidgetStub>>printOn: (in category 'printing') ----- + printOn: aStream + aStream + print: self class; + nextPut: $<; + nextPutAll: self name; + nextPut: $>! Item was added: + ----- Method: WidgetStub>>refresh (in category 'events') ----- + refresh + self stateVariables do: [:var | self refresh: var]! Item was added: + ----- Method: WidgetStub>>refresh: (in category 'events') ----- + refresh: var + | value | + value := spec perform: var. + self refresh: var with: value! Item was added: + ----- Method: WidgetStub>>refresh:with: (in category 'events') ----- + refresh: var with: value + state + at: var + put: (value isSymbol + ifTrue: [spec model perform: value] + ifFalse: [value])! Item was added: + ----- Method: WidgetStub>>setSpec: (in category 'initialize-release') ----- + setSpec: aSpec + state := IdentityDictionary new. + spec := aSpec. + spec model addDependent: self. + self refresh.! Item was added: + ----- Method: WidgetStub>>spec (in category 'accessing') ----- + spec + ^ spec! Item was added: + ----- Method: WidgetStub>>stateVariables (in category 'events') ----- + stateVariables + ^ #()! Item was added: + ----- Method: WidgetStub>>update: (in category 'events') ----- + update: aSymbol + + self stateVariables do: + [:var | + (spec perform: var) == aSymbol ifTrue: + [self refresh: var with: aSymbol. + ^ self]]! Item was added: + ----- Method: WidgetStub>>widgetNamed: (in category 'accessing') ----- + widgetNamed: aString + ^ self name = aString + ifTrue: [self] + ifFalse: [nil]! Item was added: + CompositeStub subclass: #WindowStub + instanceVariableNames: '' + classVariableNames: '' + poolDictionaries: '' + category: 'SUnitGUI-ToolBuilder'! Item was added: + ----- Method: WindowStub>>close (in category 'simulating') ----- + close + spec model perform: spec closeAction! Item was added: + ----- Method: WindowStub>>stateVariables (in category 'events') ----- + stateVariables + ^ super stateVariables, #(label)!

1 0

The Trunk: SUnitGUI-fbs.57.mcz
by commits＠source.squeak.org 31 May '13

31 May '13

1 0

The Trunk: ToolBuilder-SUnit-fbs.18.mcz
by commits＠source.squeak.org 31 May '13

31 May '13

Frank Shearar uploaded a new version of ToolBuilder-SUnit to project The Trunk: http://source.squeak.org/trunk/ToolBuilder-SUnit-fbs.18.mcz ==================== Summary ==================== Name: ToolBuilder-SUnit-fbs.18 Author: fbs Time: 31 May 2013, 4:02:23.33 pm UUID: 64c28b7a-b3fd-4bdd-9188-0c615b680b5b Ancestors: ToolBuilder-SUnit-cwp.17 Move ToolBuilder-SUnit to SUnitGUI-ToolBuilder. =============== Diff against ToolBuilder-SUnit-cwp.17 =============== Item was removed: - SystemOrganization addCategory: #'ToolBuilder-SUnit'! Item was removed: - WidgetStub subclass: #ButtonStub - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'ToolBuilder-SUnit'! Item was removed: - ----- Method: ButtonStub>>click (in category 'simulating') ----- - click - | action | - action := spec action. - action isSymbol - ifTrue: [self model perform: action] - ifFalse: [action value]! Item was removed: - ----- Method: ButtonStub>>color (in category 'simulating') ----- - color - ^ state at: #color! Item was removed: - ----- Method: ButtonStub>>isEnabled (in category 'simulating') ----- - isEnabled - ^ state at: #enabled! Item was removed: - ----- Method: ButtonStub>>isPressed (in category 'simulating') ----- - isPressed - ^ state at: #state! Item was removed: - ----- Method: ButtonStub>>label (in category 'simulating') ----- - label - ^ state at: #label! Item was removed: - ----- Method: ButtonStub>>stateVariables (in category 'events') ----- - stateVariables - ^ #(label color state enabled)! Item was removed: - WidgetStub subclass: #CompositeStub - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'ToolBuilder-SUnit'! Item was removed: - ----- Method: CompositeStub>>children (in category 'accessing') ----- - children - ^ state at: #children ifAbsent: [#()]! Item was removed: - ----- Method: CompositeStub>>children: (in category 'accessing') ----- - children: anObject - state at: #children put: anObject! Item was removed: - ----- Method: CompositeStub>>stateVariables (in category 'accessing') ----- - stateVariables - ^ #(children)! Item was removed: - ----- Method: CompositeStub>>widgetNamed: (in category 'accessing') ----- - widgetNamed: aString - self name = aString - ifTrue: [^ self] - ifFalse: [self children do: [:ea | (ea widgetNamed: aString) ifNotNil: [:w | ^ w]]]. - ^ nil! Item was removed: - WidgetStub subclass: #ListStub - instanceVariableNames: 'list index' - classVariableNames: '' - poolDictionaries: '' - category: 'ToolBuilder-SUnit'! Item was removed: - ----- Method: ListStub>>click: (in category 'simulating') ----- - click: aString - self clickItemAt: (self list indexOf: aString)! Item was removed: - ----- Method: ListStub>>clickItemAt: (in category 'simulating') ----- - clickItemAt: anInteger - | selector | - selector := spec setIndex. - selector - ifNil: [self model perform: spec setSelected with: (self list at: anInteger)] - ifNotNil: [self model perform: selector with: anInteger] - ! Item was removed: - ----- Method: ListStub>>list (in category 'simulating') ----- - list - ^ list ifNil: [Array new]! Item was removed: - ----- Method: ListStub>>menu (in category 'simulating') ----- - menu - ^ MenuStub fromSpec: - (self model - perform: spec menu - with: (PluggableMenuSpec withModel: self model))! Item was removed: - ----- Method: ListStub>>refresh (in category 'events') ----- - refresh - self refreshList. - self refreshIndex! Item was removed: - ----- Method: ListStub>>refreshIndex (in category 'events') ----- - refreshIndex - | selector | - selector := spec getIndex. - index := selector - ifNil: [self list indexOf: (self model perform: spec getSelected)] - ifNotNil: [spec model perform: selector] - ! Item was removed: - ----- Method: ListStub>>refreshList (in category 'events') ----- - refreshList - list := self model perform: spec list! Item was removed: - ----- Method: ListStub>>selectedIndex (in category 'simulating') ----- - selectedIndex - ^ index ifNil: [0]! Item was removed: - ----- Method: ListStub>>selectedItem (in category 'simulating') ----- - selectedItem - | items idx | - (items := self list) isEmpty ifTrue: [^ nil]. - (idx := self selectedIndex) = 0 ifTrue: [^ nil]. - ^ items at: idx - ! Item was removed: - ----- Method: ListStub>>update: (in category 'events') ----- - update: aSelector - aSelector = spec list ifTrue: [^ self refreshList]. - aSelector = spec getSelected ifTrue: [^ self refreshIndex]. - aSelector = spec getIndex ifTrue: [^ self refreshIndex]. - ^ super update: aSelector! Item was removed: - WidgetStub subclass: #MenuStub - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'ToolBuilder-SUnit'! Item was removed: - ----- Method: MenuStub>>click: (in category 'as yet unclassified') ----- - click: aString - | item | - item := self items detect: [:ea | ea label = aString] ifNone: [^ self]. - item action isSymbol - ifTrue: [self model perform: item action] - ifFalse: [item action value]! Item was removed: - ----- Method: MenuStub>>items (in category 'as yet unclassified') ----- - items - ^ spec items! Item was removed: - ----- Method: MenuStub>>labels (in category 'as yet unclassified') ----- - labels - ^ self items keys! Item was removed: - CompositeStub subclass: #PanelStub - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'ToolBuilder-SUnit'! Item was removed: - ToolBuilder subclass: #SUnitToolBuilder - instanceVariableNames: 'widgets' - classVariableNames: '' - poolDictionaries: '' - category: 'ToolBuilder-SUnit'! - - !SUnitToolBuilder commentStamp: 'cwp 6/7/2005 00:53' prior: 0! - I create a set of "stub" widgets that are useful for testing. Instead of drawing themselves in some GUI, they simulate graphical widgets for testing purposes. Through my widgets, unit tests can simulate user actions and make assertions about the state of the display. - - See TestRunnerPlusTest for examples.! Item was removed: - ----- Method: SUnitToolBuilder>>buildPluggableButton: (in category 'building') ----- - buildPluggableButton: aSpec - | w | - w := ButtonStub fromSpec: aSpec. - self register: w id: aSpec name. - ^w! Item was removed: - ----- Method: SUnitToolBuilder>>buildPluggableList: (in category 'building') ----- - buildPluggableList: aSpec - | w | - w := ListStub fromSpec: aSpec. - self register: w id: aSpec name. - ^w! Item was removed: - ----- Method: SUnitToolBuilder>>buildPluggableMenu: (in category 'building') ----- - buildPluggableMenu: aSpec - ^ MenuStub fromSpec: aSpec! Item was removed: - ----- Method: SUnitToolBuilder>>buildPluggablePanel: (in category 'building') ----- - buildPluggablePanel: aSpec - | w | - w := PanelStub fromSpec: aSpec. - self register: w id: aSpec name. - ^w! Item was removed: - ----- Method: SUnitToolBuilder>>buildPluggableText: (in category 'building') ----- - buildPluggableText: aSpec - | w | - w := TextStub fromSpec: aSpec. - self register: w id: aSpec name. - ^w! Item was removed: - ----- Method: SUnitToolBuilder>>buildPluggableTree: (in category 'building') ----- - buildPluggableTree: aSpec - | w | - w := TreeStub fromSpec: aSpec. - self register: w id: aSpec name. - ^w! Item was removed: - ----- Method: SUnitToolBuilder>>buildPluggableWindow: (in category 'building') ----- - buildPluggableWindow: aSpec - | window children | - window := WindowStub fromSpec: aSpec. - children := aSpec children. - children isSymbol - ifFalse: [window children: (children collect: [:ea | ea buildWith: self])]. - self register: window id: aSpec name. - ^ window! Item was removed: - ----- Method: SUnitToolBuilder>>close: (in category 'opening') ----- - close: aWidget - aWidget close! Item was removed: - ----- Method: SUnitToolBuilder>>open: (in category 'opening') ----- - open: anObject - ^ self build: anObject! Item was removed: - ----- Method: SUnitToolBuilder>>register:id: (in category 'private') ----- - register: widget id: id - id ifNil:[^self]. - widgets ifNil:[widgets := Dictionary new]. - widgets at: id put: widget.! Item was removed: - ----- Method: SUnitToolBuilder>>widgetAt:ifAbsent: (in category 'private') ----- - widgetAt: id ifAbsent: aBlock - widgets ifNil:[^aBlock value]. - ^widgets at: id ifAbsent: aBlock! Item was removed: - ToolBuilderTests subclass: #SUnitToolBuilderTests - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'ToolBuilder-SUnit'! Item was removed: - ----- Method: SUnitToolBuilderTests>>acceptWidgetText (in category 'support') ----- - acceptWidgetText - widget accept: 'Some text'! Item was removed: - ----- Method: SUnitToolBuilderTests>>buttonWidgetEnabled (in category 'support') ----- - buttonWidgetEnabled - ^ widget isEnabled! Item was removed: - ----- Method: SUnitToolBuilderTests>>changeListWidget (in category 'support') ----- - changeListWidget - widget clickItemAt: widget selectedIndex + 1! Item was removed: - ----- Method: SUnitToolBuilderTests>>fireButtonWidget (in category 'support') ----- - fireButtonWidget - widget click! Item was removed: - ----- Method: SUnitToolBuilderTests>>fireMenuItemWidget (in category 'support') ----- - fireMenuItemWidget - widget click: 'Menu Item'! Item was removed: - ----- Method: SUnitToolBuilderTests>>setUp (in category 'running') ----- - setUp - super setUp. - builder := SUnitToolBuilder new.! Item was removed: - ----- Method: SUnitToolBuilderTests>>testHandlingNotification (in category 'tests') ----- - testHandlingNotification - | receivedSignal resumed | - receivedSignal := resumed := false. - [ | count | - "client-code puts up progress, and signals some notications" - count := 0. - 'doing something' - displayProgressFrom: 0 - to: 10 - during: - [ : bar | 10 timesRepeat: - [ bar value: (count := count + 1). - (Delay forMilliseconds: 200) wait. - Notification signal: 'message'. - resumed := true ] ] ] - on: Notification - do: - [ : noti | receivedSignal := true. - noti resume ]. - self - assert: receivedSignal ; - assert: resumed! Item was removed: - ----- Method: SUnitToolBuilderTests>>testListCached (in category 'tests') ----- - testListCached - - self makeItemList. - queries := Bag new. - self changed: #getList. - widget list. - widget list. - self assert: queries size = 1! Item was removed: - ----- Method: SUnitToolBuilderTests>>testListSelectionCached (in category 'tests') ----- - testListSelectionCached - - self makeItemList. - queries := Bag new. - self changed: #getListSelection. - widget selectedIndex. - widget selectedIndex. - self assert: queries size = 1! Item was removed: - ----- Method: SUnitToolBuilderTests>>testTextCached (in category 'tests') ----- - testTextCached - - self makeText. - queries := Bag new. - self changed: #getText. - widget text. - widget text. - self assert: queries size = 1! Item was removed: - ----- Method: SUnitToolBuilderTests>>widgetColor (in category 'support') ----- - widgetColor - ^ widget color! Item was removed: - WidgetStub subclass: #TextStub - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'ToolBuilder-SUnit'! Item was removed: - ----- Method: TextStub>>accept: (in category 'simulating') ----- - accept: aString - state at: #getText put: aString. - ^ self model perform: spec setText with: aString asText! Item was removed: - ----- Method: TextStub>>color (in category 'simulating') ----- - color - ^ state at: #color! Item was removed: - ----- Method: TextStub>>stateVariables (in category 'events') ----- - stateVariables - ^ #(color selection getText)! Item was removed: - ----- Method: TextStub>>text (in category 'simulating') ----- - text - ^ state at: #getText! Item was removed: - WidgetStub subclass: #TreeNodeStub - instanceVariableNames: 'item' - classVariableNames: '' - poolDictionaries: '' - category: 'ToolBuilder-SUnit'! Item was removed: - ----- Method: TreeNodeStub class>>fromSpec:item: (in category 'instance creation') ----- - fromSpec: aSpec item: anObject - ^ self new setSpec: aSpec item: anObject! Item was removed: - ----- Method: TreeNodeStub>>children (in category 'simulating') ----- - children - ^ (self model perform: spec getChildren with: item) - collect: [:ea | TreeNodeStub fromSpec: spec item: ea]! Item was removed: - ----- Method: TreeNodeStub>>item (in category 'simulating') ----- - item - ^ item! Item was removed: - ----- Method: TreeNodeStub>>label (in category 'simulating') ----- - label - ^ self model perform: spec label with: item! Item was removed: - ----- Method: TreeNodeStub>>matches: (in category 'private') ----- - matches: aString - ^ self label = aString! Item was removed: - ----- Method: TreeNodeStub>>openPath: (in category 'events') ----- - openPath: anArray - | child | - anArray isEmpty - ifTrue: [self select] - ifFalse: [child := self children - detect: [:ea | ea matches: anArray first] - ifNone: [^ self select]. - child openPath: anArray allButFirst] - ! Item was removed: - ----- Method: TreeNodeStub>>printOn: (in category 'printing') ----- - printOn: aStream - aStream - print: self class; - nextPut: $<; - print: item; - nextPut: $>! Item was removed: - ----- Method: TreeNodeStub>>select (in category 'simulating') ----- - select - self model perform: spec setSelected with: item! Item was removed: - ----- Method: TreeNodeStub>>selectPath: (in category 'private') ----- - selectPath: anArray - | child | - anArray isEmpty ifTrue: [^ self select]. - child := self children detect: [:ea | ea matches: anArray first] ifNone: [^ self select]. - child selectPath: anArray allButFirst.! Item was removed: - ----- Method: TreeNodeStub>>setSpec:item: (in category 'initialize-release') ----- - setSpec: aSpec item: anObject - super setSpec: aSpec. - item := anObject! Item was removed: - WidgetStub subclass: #TreeStub - instanceVariableNames: 'roots' - classVariableNames: '' - poolDictionaries: '' - category: 'ToolBuilder-SUnit'! Item was removed: - ----- Method: TreeStub>>openPath: (in category 'private') ----- - openPath: anArray - | first | - first := roots detect: [:ea | ea matches: anArray first] ifNone: [^ self]. - first openPath: anArray allButFirst! Item was removed: - ----- Method: TreeStub>>roots: (in category 'private') ----- - roots: anArray - roots := anArray collect: [:ea | TreeNodeStub fromSpec: spec item: ea]. - ! Item was removed: - ----- Method: TreeStub>>select: (in category 'simulating') ----- - select: anArray - self openPath: anArray! Item was removed: - ----- Method: TreeStub>>setSpec: (in category 'initialize-release') ----- - setSpec: aSpec - super setSpec: aSpec. - self update: spec roots! Item was removed: - ----- Method: TreeStub>>update: (in category 'events') ----- - update: anObject - anObject == spec roots ifTrue: [^ self updateRoots]. - anObject == spec getSelectedPath ifTrue: [^ self updateSelectedPath]. - (anObject isKindOf: Array) ifTrue: [^ self openPath: anObject allButFirst]. - super update: anObject - ! Item was removed: - ----- Method: TreeStub>>updateRoots (in category 'events') ----- - updateRoots - ^ self roots: (self model perform: spec roots) - ! Item was removed: - ----- Method: TreeStub>>updateSelectedPath (in category 'events') ----- - updateSelectedPath - | path first | - path := self model perform: spec getSelectedPath. - first := roots detect: [:ea | ea item = path first] ifNone: [^ self]. - first selectPath: path allButFirst.! Item was removed: - Object subclass: #WidgetStub - instanceVariableNames: 'spec state' - classVariableNames: '' - poolDictionaries: '' - category: 'ToolBuilder-SUnit'! Item was removed: - ----- Method: WidgetStub class>>fromSpec: (in category 'instance creation') ----- - fromSpec: aSpec - ^ self new setSpec: aSpec! Item was removed: - ----- Method: WidgetStub>>model (in category 'simulating') ----- - model - ^ spec model! Item was removed: - ----- Method: WidgetStub>>name (in category 'accessing') ----- - name - ^ spec name ifNil: [' ']! Item was removed: - ----- Method: WidgetStub>>printOn: (in category 'printing') ----- - printOn: aStream - aStream - print: self class; - nextPut: $<; - nextPutAll: self name; - nextPut: $>! Item was removed: - ----- Method: WidgetStub>>refresh (in category 'events') ----- - refresh - self stateVariables do: [:var | self refresh: var]! Item was removed: - ----- Method: WidgetStub>>refresh: (in category 'events') ----- - refresh: var - | value | - value := spec perform: var. - self refresh: var with: value! Item was removed: - ----- Method: WidgetStub>>refresh:with: (in category 'events') ----- - refresh: var with: value - state - at: var - put: (value isSymbol - ifTrue: [spec model perform: value] - ifFalse: [value])! Item was removed: - ----- Method: WidgetStub>>setSpec: (in category 'initialize-release') ----- - setSpec: aSpec - state := IdentityDictionary new. - spec := aSpec. - spec model addDependent: self. - self refresh.! Item was removed: - ----- Method: WidgetStub>>spec (in category 'accessing') ----- - spec - ^ spec! Item was removed: - ----- Method: WidgetStub>>stateVariables (in category 'events') ----- - stateVariables - ^ #()! Item was removed: - ----- Method: WidgetStub>>update: (in category 'events') ----- - update: aSymbol - - self stateVariables do: - [:var | - (spec perform: var) == aSymbol ifTrue: - [self refresh: var with: aSymbol. - ^ self]]! Item was removed: - ----- Method: WidgetStub>>widgetNamed: (in category 'accessing') ----- - widgetNamed: aString - ^ self name = aString - ifTrue: [self] - ifFalse: [nil]! Item was removed: - CompositeStub subclass: #WindowStub - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'ToolBuilder-SUnit'! Item was removed: - ----- Method: WindowStub>>close (in category 'simulating') ----- - close - spec model perform: spec closeAction! Item was removed: - ----- Method: WindowStub>>stateVariables (in category 'events') ----- - stateVariables - ^ super stateVariables, #(label)!

1 0

The Trunk: ToolBuilder-SUnit-fbs.18.mcz
by commits＠source.squeak.org 31 May '13

31 May '13

1 0

The Trunk: ToolBuilder-SUnit-fbs.18.mcz
by commits＠source.squeak.org 31 May '13

31 May '13

1 0

The Trunk: Morphic-fbs.653.mcz
by commits＠source.squeak.org 31 May '13

31 May '13

Frank Shearar uploaded a new version of Morphic to project The Trunk: http://source.squeak.org/trunk/Morphic-fbs.653.mcz ==================== Summary ==================== Name: Morphic-fbs.653 Author: fbs Time: 31 May 2013, 4:00:33.132 pm UUID: f85ab481-1220-47b1-998e-0dea9c443203 Ancestors: Morphic-kb.652 Move ToolBuilder-Morphic to Morphic-ToolBuilder. =============== Diff against Morphic-kb.652 =============== Item was changed: SystemOrganization addCategory: #'Morphic-Balloon'! SystemOrganization addCategory: #'Morphic-Basic'! SystemOrganization addCategory: #'Morphic-Basic-NewCurve'! SystemOrganization addCategory: #'Morphic-Borders'! SystemOrganization addCategory: #'Morphic-Collections-Arrayed'! SystemOrganization addCategory: #'Morphic-Demo'! SystemOrganization addCategory: #'Morphic-Events'! SystemOrganization addCategory: #'Morphic-Explorer'! SystemOrganization addCategory: #'Morphic-Kernel'! SystemOrganization addCategory: #'Morphic-Layouts'! SystemOrganization addCategory: #'Morphic-Menus'! SystemOrganization addCategory: #'Morphic-Menus-DockingBar'! SystemOrganization addCategory: #'Morphic-Models'! SystemOrganization addCategory: #'Morphic-Pluggable Widgets'! SystemOrganization addCategory: #'Morphic-Support'! SystemOrganization addCategory: #'Morphic-Text Support'! SystemOrganization addCategory: #'Morphic-TrueType'! SystemOrganization addCategory: #'Morphic-Widgets'! SystemOrganization addCategory: #'Morphic-Windows'! SystemOrganization addCategory: #'Morphic-Worlds'! + SystemOrganization addCategory: #'Morphic-ToolBuilder'! Item was added: + Object subclass: #ListChooser + instanceVariableNames: 'window fullList selectedItems searchText searchMorph title listMorph index realIndex buttonBar builder addAllowed result' + classVariableNames: '' + poolDictionaries: '' + category: 'Morphic-ToolBuilder'! + + !ListChooser commentStamp: 'MAD 3/14/2010 16:20' prior: 0! + I am a simple dialog to allow the user to pick from a list of strings or symbols. + I support keyboard and mouse navigation, and interactive filtering of the displayed items. + + You can specify whether you want the index, or the value of the selected item. If you're interested in the value, you can also allow users to Add a new value not in the list. + + cmd-s or <enter> or double-click answers the currently selected item's value/index; + cmd-l or <escape> or closing the window answers nil/zero. + + Now using ToolBuilder, so needs Morphic-MAD.381. + + Released under the MIT Licence.! Item was added: + ----- Method: ListChooser class>>chooseFrom: (in category 'ChooserTool compatibility') ----- + chooseFrom: aList + ^ self + chooseFrom: aList + title: self defaultTitle! Item was added: + ----- Method: ListChooser class>>chooseFrom:title: (in category 'ChooserTool compatibility') ----- + chooseFrom: aList title: aString + ^ self + chooseIndexFrom: aList + title: aString + addAllowed: false! Item was added: + ----- Method: ListChooser class>>chooseIndexFrom: (in category 'instance creation') ----- + chooseIndexFrom: aList + ^ self + chooseIndexFrom: aList + title: self defaultTitle! Item was added: + ----- Method: ListChooser class>>chooseIndexFrom:title: (in category 'instance creation') ----- + chooseIndexFrom: aList title: aString + ^ self + chooseIndexFrom: aList + title: (aString isEmptyOrNil ifTrue: [ self defaultTitle ] ifFalse: [ aString ]) + addAllowed: false! Item was added: + ----- Method: ListChooser class>>chooseIndexFrom:title:addAllowed: (in category 'instance creation') ----- + chooseIndexFrom: aList title: aString addAllowed: aBoolean + ^ self new + chooseIndexFrom: aList + title: (aString isEmptyOrNil ifTrue: [ self defaultTitle ] ifFalse: [ aString ]) + addAllowed: aBoolean! Item was added: + ----- Method: ListChooser class>>chooseItemFrom: (in category 'instance creation') ----- + chooseItemFrom: aList + ^ self + chooseItemFrom: aList + title: self defaultTitle! Item was added: + ----- Method: ListChooser class>>chooseItemFrom:title: (in category 'instance creation') ----- + chooseItemFrom: aList title: aString + ^ self + chooseItemFrom: aList + title: aString + addAllowed: false! Item was added: + ----- Method: ListChooser class>>chooseItemFrom:title:addAllowed: (in category 'instance creation') ----- + chooseItemFrom: aList title: aString addAllowed: aBoolean + ^ self new + chooseItemFrom: aList + title: (aString isEmptyOrNil ifTrue: [ self defaultTitle ] ifFalse: [ aString ]) + addAllowed: aBoolean! Item was added: + ----- Method: ListChooser class>>defaultTitle (in category 'instance creation') ----- + defaultTitle + ^ 'Please choose:'! Item was added: + ----- Method: ListChooser class>>testDictionary (in category 'examples') ----- + testDictionary + ^ self + chooseItemFrom: (Dictionary newFrom: {#a->1. 2->#b.}) + title: 'Pick from Dictionary' "gives values, not keys"! Item was added: + ----- Method: ListChooser class>>testIndex (in category 'examples') ----- + testIndex + ^ self + chooseIndexFrom: (Smalltalk classNames , Smalltalk traitNames) asOrderedCollection + title: 'Pick a class'! Item was added: + ----- Method: ListChooser class>>testItem (in category 'examples') ----- + testItem + ^ self + chooseItemFrom: (Smalltalk classNames , Smalltalk traitNames) asOrderedCollection + title: 'Pick a class'! Item was added: + ----- Method: ListChooser class>>testItemAdd (in category 'examples') ----- + testItemAdd + ^ self + chooseItemFrom: (Smalltalk classNames , Smalltalk traitNames) asOrderedCollection + title: 'Pick or Add:' + addAllowed: true! Item was added: + ----- Method: ListChooser class>>testLongTitle (in category 'examples') ----- + testLongTitle + ^ self + chooseItemFrom: #(this is a list of values that aren/t the point here) + title: 'Pick from some values from this list'! Item was added: + ----- Method: ListChooser class>>testSet (in category 'examples') ----- + testSet + ^ self + chooseItemFrom: #(a list of values as a Set) asSet + title: 'Pick from Set'! Item was added: + ----- Method: ListChooser>>accept (in category 'event handling') ----- + accept + "if the user submits with no valid entry, make them start over" + self canAccept ifFalse: [ + searchMorph selectAll. + ^ self ]. + + "find the selected item in the original list, and return it" + result := selectedItems at: index. + + builder ifNotNil: [ :bldr | + builder := nil. + bldr close: window ]! Item was added: + ----- Method: ListChooser>>acceptColor (in category 'drawing') ----- + acceptColor + ^ self canAccept + ifTrue: [ ColorTheme current okColor ] + ifFalse: [ Color lightGray "ColorTheme current disabledColor <- you don't have this!!" ]! Item was added: + ----- Method: ListChooser>>acceptText: (in category 'event handling') ----- + acceptText: someText + "the text morph wants to tell us about its contents but I don't care, I'm only interested in the list" + self accept! Item was added: + ----- Method: ListChooser>>add (in category 'event handling') ----- + add + "if the user submits with no valid entry, make them start over" + self canAdd ifFalse: [ + searchMorph selectAll. + ^ self ]. + + "find the string to return" + result := searchMorph getText. + + builder ifNotNil: [ :bldr | + builder := nil. + bldr close: window ]! Item was added: + ----- Method: ListChooser>>buildButtonBarWith: (in category 'building') ----- + buildButtonBarWith: builder + | panel button | + panel := builder pluggablePanelSpec new + model: self; + layout: #proportional; + children: OrderedCollection new. + button := builder pluggableButtonSpec new. + button + model: self; + label: 'Accept (s)'; + action: #accept; + enabled: #canAccept; + state: #canAccept; + color: #acceptColor; + frame: (0.0 @ 0.0 corner: 0.34@1). + panel children add: button. + + button := builder pluggableButtonSpec new. + button + model: self; + label: 'Add (a)'; + action: #add; + enabled: #canAdd; + frame: (0.36 @ 0.0 corner: 0.63@1). + panel children add: button. + + button := builder pluggableButtonSpec new. + button + model: self; + label: 'Cancel (l)'; + action: #cancel; + color: #cancelColor; + frame: (0.65 @ 0.0 corner: 1@1). + panel children add: button. + + ^ panel! Item was added: + ----- Method: ListChooser>>buildListMorphWith: (in category 'building') ----- + buildListMorphWith: builder + | listSpec | + listSpec := builder pluggableListSpec new. + listSpec + model: self; + list: #list; + getIndex: #selectedIndex; + setIndex: #selectedIndex:; + doubleClick: #accept; + "handleBasicKeys: false;" + keystrokePreview: #keyStrokeFromList:; + "doubleClickSelector: #accept;" + autoDeselect: false. + ^ listSpec! Item was added: + ----- Method: ListChooser>>buildSearchMorphWith: (in category 'building') ----- + buildSearchMorphWith: builder + | fieldSpec | + fieldSpec := builder pluggableInputFieldSpec new. + fieldSpec + model: self; + getText: #searchText; + setText: #acceptText:; + menu: nil. + "hideScrollBarsIndefinitely;" + "acceptOnCR: true;" + "setBalloonText: 'Type a string to filter down the listed items'." + "onKeyStrokeSend: #keyStroke: to: self." + ^ fieldSpec! Item was added: + ----- Method: ListChooser>>buildWindowWith: (in category 'building') ----- + buildWindowWith: builder + | windowSpec | + windowSpec := builder pluggableWindowSpec new. + windowSpec model: self. + windowSpec label: #title. + windowSpec children: OrderedCollection new. + ^windowSpec! Item was added: + ----- Method: ListChooser>>buildWindowWith:specs: (in category 'building') ----- + buildWindowWith: builder specs: specs + | windowSpec | + windowSpec := self buildWindowWith: builder. + specs do: [ :assoc | + | rect action widgetSpec | + rect := assoc key. + action := assoc value. + widgetSpec := action value. + widgetSpec ifNotNil:[ + widgetSpec frame: rect. + windowSpec children add: widgetSpec ] ]. + ^ windowSpec! Item was added: + ----- Method: ListChooser>>buildWith: (in category 'building') ----- + buildWith: aBuilder + | windowSpec | + builder := aBuilder. + windowSpec := self buildWindowWith: builder specs: { + (0@0 corner: 1(a)0.05) -> [self buildSearchMorphWith: builder]. + (0(a)0.05 corner: 1(a)0.9) -> [self buildListMorphWith: builder]. + (0(a)0.9 corner: 1@1) -> [self buildButtonBarWith: builder]. + }. + windowSpec closeAction: #closed. + windowSpec extent: self initialExtent. + window := builder build: windowSpec. + + + searchMorph := window submorphs detect: + [ :each | each isKindOf: PluggableTextMorph ]. + searchMorph + hideScrollBarsIndefinitely; + acceptOnCR: true; + setBalloonText: 'Type a string to filter down the listed items'; + onKeyStrokeSend: #keyStroke: to: self; + hasUnacceptedEdits: true "force acceptOnCR to work even with no text entered". + listMorph := window submorphs detect: + [ :each | each isKindOf: PluggableListMorph ]. + ^ window! Item was added: + ----- Method: ListChooser>>canAccept (in category 'testing') ----- + canAccept + ^ self selectedIndex > 0! Item was added: + ----- Method: ListChooser>>canAdd (in category 'testing') ----- + canAdd + ^ addAllowed and: [ self canAccept not ]! Item was added: + ----- Method: ListChooser>>cancel (in category 'event handling') ----- + cancel + "Cancel the dialog and move on" + index := 0. + builder ifNotNil: [ builder close: window ]! Item was added: + ----- Method: ListChooser>>cancelColor (in category 'drawing') ----- + cancelColor + ^ ColorTheme current cancelColor! Item was added: + ----- Method: ListChooser>>chooseIndexFrom:title: (in category 'initialize-release') ----- + chooseIndexFrom: labelList title: aString + | choice | + choice := self chooseItemFrom: labelList title: aString addAllowed: false. + ^ fullList indexOf: choice ifAbsent: 0! Item was added: + ----- Method: ListChooser>>chooseIndexFrom:title:addAllowed: (in category 'initialize-release') ----- + chooseIndexFrom: labelList title: aString addAllowed: aBoolean + | choice | + choice := self chooseItemFrom: labelList title: aString addAllowed: false. + addAllowed := aBoolean. + ^ fullList indexOf: choice ifAbsent: 0! Item was added: + ----- Method: ListChooser>>chooseItemFrom:title:addAllowed: (in category 'initialize-release') ----- + chooseItemFrom: labelList title: aString addAllowed: aBoolean + fullList := labelList asOrderedCollection. "coerce everything into an OC" + builder := ToolBuilder default. + self list: fullList. + self title: aString. + addAllowed := aBoolean. + window := ToolBuilder default open: self. + window center: Sensor cursorPoint. + window setConstrainedPosition: (Sensor cursorPoint - (window fullBounds extent // 2)) hangOut: false. + builder runModal: window. + ^ result! Item was added: + ----- Method: ListChooser>>closed (in category 'event handling') ----- + closed + "Cancel the dialog and move on" + builder ifNotNil: [ index := 0 ]! Item was added: + ----- Method: ListChooser>>handlesKeyboard: (in category 'event handling') ----- + handlesKeyboard: evt + ^ true! Item was added: + ----- Method: ListChooser>>initialExtent (in category 'building') ----- + initialExtent + | listFont titleFont buttonFont listWidth titleWidth buttonWidth | + listFont := Preferences standardListFont. + titleFont := Preferences windowTitleFont. + buttonFont := Preferences standardButtonFont. + listWidth := 20 * (listFont widthOf: $m). + titleWidth := titleFont widthOfString: self title, '__________'. "add some space for titlebar icons" + buttonWidth := buttonFont widthOfString: '_Accept_(s)___Add (a)___Cancel_(l)_'. + ^ (listWidth max: (titleWidth max: buttonWidth))@(30 * (listFont height))! Item was added: + ----- Method: ListChooser>>keyStroke: (in category 'event handling') ----- + keyStroke: event + | newText key | + "handle updates to the search box interactively" + key := event keyString. + (key = '<up>') ifTrue: [ + self move: -1. + ^ self ]. + (key = '<down>') ifTrue: [ + self move: 1. + ^ self ]. + + (key = '<Cmd-s>') ifTrue: [ self accept. ^ self ]. + (key = '<cr>') ifTrue: [ self accept. ^ self ]. + + (key = '<escape>') ifTrue: [ self cancel. ^ self ]. + (key = '<Cmd-l>') ifTrue: [ self cancel. ^ self ]. + + (key = '<Cmd-a>') ifTrue: [ self add. ^ self ]. + + "pull out what's been typed, and update the list as required" + newText := searchMorph textMorph asText asString. + (newText = searchText) ifFalse: [ + searchText := newText. + self updateFilter ]. + ! Item was added: + ----- Method: ListChooser>>keyStrokeFromList: (in category 'event handling') ----- + keyStrokeFromList: event + "we don't want the list to be picking up events, excepting scroll events" + + "Don't sent ctrl-up/ctrl-down events to the searchMorph: they're scrolling events." + (#(30 31) contains: [:each | each = event keyValue]) not + ifTrue: + ["window world primaryHand keyboardFocus: searchMorph." + searchMorph keyStroke: event. + "let the list know we've dealt with it" + ^true]. + ^false. + ! Item was added: + ----- Method: ListChooser>>list (in category 'accessing') ----- + list + ^ selectedItems! Item was added: + ----- Method: ListChooser>>list: (in category 'accessing') ----- + list: items + fullList := items. + selectedItems := items. + self changed: #itemList.! Item was added: + ----- Method: ListChooser>>list:title: (in category 'accessing') ----- + list: aList title: aString + self list: aList. + self title: aString! Item was added: + ----- Method: ListChooser>>move: (in category 'event handling') ----- + move: offset + | newindex | + "The up arrow key moves the cursor, and it seems impossible to restore. + So, for consistency, on either arrow, select everything, so a new letter-press starts over. yuk." + searchMorph selectAll. + + newindex := self selectedIndex + offset. + newindex > selectedItems size ifTrue: [ ^ nil ]. + newindex < 1 ifTrue: [ ^ nil ]. + self selectedIndex: newindex. + ! Item was added: + ----- Method: ListChooser>>moveWindowNear: (in category 'drawing') ----- + moveWindowNear: aPoint + | trialRect delta | + trialRect := Rectangle center: aPoint extent: window fullBounds extent. + delta := trialRect amountToTranslateWithin: World bounds. + window position: trialRect origin + delta.! Item was added: + ----- Method: ListChooser>>realIndex (in category 'accessing') ----- + realIndex + ^ realIndex ifNil: [ 0 ]! Item was added: + ----- Method: ListChooser>>searchText (in category 'accessing') ----- + searchText + ^ searchText ifNil: [ searchText := '' ]! Item was added: + ----- Method: ListChooser>>searchText: (in category 'accessing') ----- + searchText: aString + searchText := aString! Item was added: + ----- Method: ListChooser>>selectedIndex (in category 'accessing') ----- + selectedIndex + ^ index ifNil: [ index := 1 ]! Item was added: + ----- Method: ListChooser>>selectedIndex: (in category 'accessing') ----- + selectedIndex: anInt + index := (anInt min: selectedItems size). + self changed: #selectedIndex. + self changed: #canAccept.! Item was added: + ----- Method: ListChooser>>title (in category 'accessing') ----- + title + ^ title ifNil: [ title := 'Please choose' ]! Item was added: + ----- Method: ListChooser>>title: (in category 'accessing') ----- + title: aString + title := aString.! Item was added: + ----- Method: ListChooser>>updateFilter (in category 'event handling') ----- + updateFilter + + selectedItems := + searchText isEmptyOrNil + ifTrue: [ fullList ] + ifFalse: [ | pattern patternMatches prefixMatches | + pattern := (searchText includes: $*) + ifTrue: [ searchText ] + ifFalse: [ '*', searchText, '*' ]. + patternMatches := fullList select: [:s | pattern match: s ]. + prefixMatches := OrderedCollection new: patternMatches size. + patternMatches removeAllSuchThat: [ :each | + (each findString: searchText startingAt: 1 caseSensitive: false) = 1 + and: [ + prefixMatches add: each. + true ] ]. + prefixMatches addAllLast: patternMatches; yourself]. + self changed: #list. + self selectedIndex: 1. + self changed: #selectedIndex.! Item was added: + ToolBuilder subclass: #MorphicToolBuilder + instanceVariableNames: 'widgets panes parentMenu' + classVariableNames: '' + poolDictionaries: '' + category: 'Morphic-ToolBuilder'! + + !MorphicToolBuilder commentStamp: 'ar 2/11/2005 15:02' prior: 0! + The Morphic tool builder.! Item was added: + ----- Method: MorphicToolBuilder class>>isActiveBuilder (in category 'accessing') ----- + isActiveBuilder + "Answer whether I am the currently active builder" + ^Smalltalk isMorphic! Item was added: + ----- Method: MorphicToolBuilder>>add:to: (in category 'private') ----- + add: aMorph to: aParent + aParent addMorphBack: aMorph. + aParent isSystemWindow ifTrue:[ + aParent addPaneMorph: aMorph. + ].! Item was added: + ----- Method: MorphicToolBuilder>>alternateMultiSelectListClass (in category 'widget classes') ----- + alternateMultiSelectListClass + ^ AlternatePluggableListMorphOfMany ! Item was added: + ----- Method: MorphicToolBuilder>>asFrame: (in category 'private') ----- + asFrame: aRectangle + | frame | + aRectangle ifNil:[^nil]. + frame := LayoutFrame new. + frame + leftFraction: aRectangle left; + rightFraction: aRectangle right; + topFraction: aRectangle top; + bottomFraction: aRectangle bottom. + ^frame! Item was added: + ----- Method: MorphicToolBuilder>>buildHelpFor:spec: (in category 'pluggable widgets') ----- + buildHelpFor: widget spec: aSpec + aSpec help + ifNotNil: [widget setBalloonText: aSpec help]! Item was added: + ----- Method: MorphicToolBuilder>>buildPluggableActionButton: (in category 'pluggable widgets') ----- + buildPluggableActionButton: aSpec + | button | + button := self buildPluggableButton: aSpec. + button color: Color white. + ^button! Item was added: + ----- Method: MorphicToolBuilder>>buildPluggableAlternateMultiSelectionList: (in category 'pluggable widgets') ----- + buildPluggableAlternateMultiSelectionList: aSpec + | listMorph listClass | + aSpec getSelected ifNotNil: [ ^ self error: 'There is no PluggableAlternateListMorphOfManyByItem' ]. + listClass := self alternateMultiSelectListClass. + listMorph := listClass + on: aSpec model + list: aSpec list + primarySelection: aSpec getIndex + changePrimarySelection: aSpec setIndex + listSelection: aSpec getSelectionList + changeListSelection: aSpec setSelectionList + menu: aSpec menu. + listMorph + setProperty: #highlightSelector toValue: #highlightMessageList:with: ; + setProperty: #itemConversionMethod toValue: #asStringOrText ; + setProperty: #balloonTextSelectorForSubMorphs toValue: #balloonTextForClassAndMethodString ; + enableDragNDrop: Preferences browseWithDragNDrop ; + menuTitleSelector: #messageListSelectorTitle. + self + register: listMorph + id: aSpec name. + listMorph + keystrokeActionSelector: aSpec keyPress ; + getListElementSelector: aSpec listItem ; + getListSizeSelector: aSpec listSize. + self + buildHelpFor: listMorph + spec: aSpec. + self + setFrame: aSpec frame + in: listMorph. + parent ifNotNil: [ self add: listMorph to: parent ]. + panes ifNotNil: [ aSpec list ifNotNil:[panes add: aSpec list ] ]. + ^ listMorph! Item was added: + ----- Method: MorphicToolBuilder>>buildPluggableButton: (in category 'pluggable widgets') ----- + buildPluggableButton: aSpec + | widget label state action enabled | + label := aSpec label. + state := aSpec state. + action := aSpec action. + widget := self buttonClass on: aSpec model + getState: (state isSymbol ifTrue:[state]) + action: nil + label: (label isSymbol ifTrue:[label]). + widget style: aSpec style. + aSpec changeLabelWhen + ifNotNilDo: [ :event | widget whenChanged: event update: aSpec label]. + self register: widget id: aSpec name. + enabled := aSpec enabled. + enabled isSymbol + ifTrue:[widget getEnabledSelector: enabled] + ifFalse:[widget enabled:enabled]. + widget action: action. + widget getColorSelector: aSpec color. + widget offColor: Color white.. + self buildHelpFor: widget spec: aSpec. + (label isSymbol or:[label == nil]) ifFalse:[widget label: label]. + self setFrame: aSpec frame in: widget. + parent ifNotNil:[self add: widget to: parent]. + ^widget! Item was added: + ----- Method: MorphicToolBuilder>>buildPluggableCheckBox: (in category 'pluggable widgets') ----- + buildPluggableCheckBox: spec + + | widget label state action | + label := spec label. + state := spec state. + action := spec action. + widget := self checkBoxClass on: spec model + getState: (state isSymbol ifTrue:[state]) + action: (action isSymbol ifTrue:[action]) + label: (label isSymbol ifTrue:[label]). + self register: widget id: spec name. + + widget installButton. + " widget getColorSelector: spec color. + widget offColor: Color white.. + self buildHelpFor: widget spec: spec. + (label isSymbol or:[label == nil]) ifFalse:[widget label: label]. + " self setFrame: spec frame in: widget. + parent ifNotNil:[self add: widget to: parent]. + ^widget! Item was added: + ----- Method: MorphicToolBuilder>>buildPluggableCodePane: (in category 'pluggable widgets') ----- + buildPluggableCodePane: aSpec + "Install the default styler for code panes. + Implementation note: We should just be doing something like, e.g., + ^(self buildPluggableText: aSpec) useDefaultStyler + Unfortunately, this will retrieve and layout the initial text twice which + can make for a noticable performance difference when looking at some + larger piece of code. So instead we copy the implementation from + buildPlugggableText: here and insert #useDefaultStyler at the right point" + | widget | + widget := self codePaneClass new. + widget useDefaultStyler. + widget on: aSpec model + text: aSpec getText + accept: aSpec setText + readSelection: aSpec selection + menu: aSpec menu. + widget font: Preferences standardCodeFont. + self register: widget id: aSpec name. + widget getColorSelector: aSpec color. + self setFrame: aSpec frame in: widget. + parent ifNotNil:[self add: widget to: parent]. + widget borderColor: Color lightGray. + widget color: Color white. + ^widget! Item was added: + ----- Method: MorphicToolBuilder>>buildPluggableDropDownList: (in category 'pluggable widgets') ----- + buildPluggableDropDownList: spec + + | widget model listSelector selectionSelector selectionSetter | + model := spec model. + listSelector := spec listSelector. + selectionSelector := spec selectionSelector. + selectionSetter := spec selectionSetter. + widget := self dropDownListClass new + model: model; + listSelector: listSelector; + selectionSelector: selectionSelector; + selectionSetter: selectionSetter; + yourself. + self register: widget id: spec name. + + widget installDropDownList. + self setFrame: spec frame in: widget. + parent ifNotNil:[self add: widget to: parent]. + ^widget! Item was added: + ----- Method: MorphicToolBuilder>>buildPluggableInputField: (in category 'pluggable widgets') ----- + buildPluggableInputField: aSpec + | widget | + widget := self buildPluggableText: aSpec. + widget acceptOnCR: true. + widget hideScrollBarsIndefinitely. + ^widget! Item was added: + ----- Method: MorphicToolBuilder>>buildPluggableList: (in category 'pluggable widgets') ----- + buildPluggableList: aSpec + | widget listClass getIndex setIndex | + aSpec getSelected ifNil:[ + listClass := self listClass. + getIndex := aSpec getIndex. + setIndex := aSpec setIndex. + ] ifNotNil:[ + listClass := self listByItemClass. + getIndex := aSpec getSelected. + setIndex := aSpec setSelected. + ]. + widget := listClass on: aSpec model + list: aSpec list + selected: getIndex + changeSelected: setIndex + menu: aSpec menu + keystroke: aSpec keyPress. + self register: widget id: aSpec name. + widget getListElementSelector: aSpec listItem. + widget getListSizeSelector: aSpec listSize. + widget getIconSelector: aSpec icon. + widget doubleClickSelector: aSpec doubleClick. + widget dragItemSelector: aSpec dragItem. + widget dropItemSelector: aSpec dropItem. + widget wantsDropSelector: aSpec dropAccept. + widget autoDeselect: aSpec autoDeselect. + widget keystrokePreviewSelector: aSpec keystrokePreview. + aSpec color isNil + ifTrue: [widget + borderWidth: 1; + borderColor: Color lightGray; + color: Color white] + ifFalse: [widget color: aSpec color]. + self buildHelpFor: widget spec: aSpec. + self setFrame: aSpec frame in: widget. + parent ifNotNil:[self add: widget to: parent]. + panes ifNotNil:[ + aSpec list ifNotNil:[panes add: aSpec list]. + ]. + ^widget! Item was added: + ----- Method: MorphicToolBuilder>>buildPluggableMenu: (in category 'building') ----- + buildPluggableMenu: menuSpec + | prior menu | + prior := parentMenu. + parentMenu := menu := self menuClass new. + menuSpec label ifNotNil:[parentMenu addTitle: menuSpec label]. + menuSpec items do:[:each| each buildWith: self]. + parentMenu := prior. + ^menu! Item was added: + ----- Method: MorphicToolBuilder>>buildPluggableMenuItem: (in category 'building') ----- + buildPluggableMenuItem: itemSpec + | item action label menu | + item := self menuItemClass new. + label := itemSpec label. + itemSpec checked ifTrue:[label := '<on>', label] ifFalse:[label := '<off>', label]. + item contents: label. + item isEnabled: itemSpec enabled. + (action := itemSpec action) ifNotNil:[ + item + target: action receiver; + selector: action selector; + arguments: action arguments. + ]. + (menu := itemSpec subMenu) ifNotNil:[ + item subMenu: (menu buildWith: self). + ]. + parentMenu ifNotNil:[parentMenu addMorphBack: item]. + itemSpec separator ifTrue:[parentMenu addLine]. + ^item! Item was added: + ----- Method: MorphicToolBuilder>>buildPluggableMultiSelectionList: (in category 'pluggable widgets') ----- + buildPluggableMultiSelectionList: aSpec + | widget listClass | + aSpec getSelected ifNotNil:[^self error:'There is no PluggableListMorphOfManyByItem']. + listClass := self multiSelectListClass. + widget := listClass on: aSpec model + list: aSpec list + primarySelection: aSpec getIndex + changePrimarySelection: aSpec setIndex + listSelection: aSpec getSelectionList + changeListSelection: aSpec setSelectionList + menu: aSpec menu. + self register: widget id: aSpec name. + widget keystrokeActionSelector: aSpec keyPress. + widget getListElementSelector: aSpec listItem. + widget getListSizeSelector: aSpec listSize. + self buildHelpFor: widget spec: aSpec. + self setFrame: aSpec frame in: widget. + parent ifNotNil:[self add: widget to: parent]. + panes ifNotNil:[ + aSpec list ifNotNil:[panes add: aSpec list]. + ]. + ^widget! Item was added: + ----- Method: MorphicToolBuilder>>buildPluggablePanel: (in category 'pluggable widgets') ----- + buildPluggablePanel: aSpec + | widget children frame | + widget := self panelClass new. + self register: widget id: aSpec name. + widget model: aSpec model. + widget color: Color transparent. + widget clipSubmorphs: true. + children := aSpec children. + children isSymbol ifTrue:[ + widget getChildrenSelector: children. + widget update: children. + children := #(). + ]. + self buildAll: children in: widget. + self buildHelpFor: widget spec: aSpec. + self setFrame: aSpec frame in: widget. + parent ifNotNil:[self add: widget to: parent]. + self setLayout: aSpec layout in: widget. + widget layoutInset: 0. + widget borderWidth: 0. + widget submorphsDo:[:sm| + (frame := sm layoutFrame) ifNotNil:[ + (frame rightFraction = 0 or:[frame rightFraction = 1]) + ifFalse:[frame rightOffset:1]. + (frame bottomFraction = 0 or:[frame bottomFraction = 1]) + ifFalse:[frame bottomOffset: 1]]]. + widget color: Color transparent. + ^widget! Item was added: + ----- Method: MorphicToolBuilder>>buildPluggableText: (in category 'pluggable widgets') ----- + buildPluggableText: aSpec + | widget | + widget := self textPaneClass on: aSpec model + text: aSpec getText + accept: aSpec setText + readSelection: aSpec selection + menu: aSpec menu. + widget askBeforeDiscardingEdits: aSpec askBeforeDiscardingEdits. + widget font: Preferences standardCodeFont. + self register: widget id: aSpec name. + widget getColorSelector: aSpec color. + self buildHelpFor: widget spec: aSpec. + self setFrame: aSpec frame in: widget. + parent ifNotNil:[self add: widget to: parent]. + widget borderColor: Color lightGray. + widget color: Color white. + ^widget! Item was added: + ----- Method: MorphicToolBuilder>>buildPluggableTree: (in category 'pluggable widgets') ----- + buildPluggableTree: aSpec + | widget | + widget := self treeClass new. + self register: widget id: aSpec name. + widget model: aSpec model. + widget getSelectedPathSelector: aSpec getSelectedPath. + widget setSelectedSelector: aSpec setSelected. + widget getChildrenSelector: aSpec getChildren. + widget hasChildrenSelector: aSpec hasChildren. + widget getLabelSelector: aSpec label. + widget getIconSelector: aSpec icon. + widget getHelpSelector: aSpec help. + widget getMenuSelector: aSpec menu. + widget keystrokeActionSelector: aSpec keyPress. + widget getRootsSelector: aSpec roots. + widget autoDeselect: aSpec autoDeselect. + widget dropItemSelector: aSpec dropItem. + widget wantsDropSelector: aSpec dropAccept. + widget dragItemSelector: aSpec dragItem. + self setFrame: aSpec frame in: widget. + parent ifNotNil:[self add: widget to: parent]. + " panes ifNotNil:[ + aSpec roots ifNotNil:[panes add: aSpec roots]. + ]. " + ^widget! Item was added: + ----- Method: MorphicToolBuilder>>buildPluggableWindow: (in category 'pluggable widgets') ----- + buildPluggableWindow: aSpec + | widget children | + aSpec layout == #proportional ifFalse:[ + "This needs to be implemented - probably by adding a single pane and then the rest" + ^self error: 'Not implemented'. + ]. + widget := (self windowClassFor: aSpec) new. + self register: widget id: aSpec name. + widget model: aSpec model. + aSpec label ifNotNil: + [:label| + label isSymbol + ifTrue:[widget getLabelSelector: label] + ifFalse:[widget setLabel: label]]. + aSpec multiWindowStyle notNil ifTrue: + [widget savedMultiWindowState: (SavedMultiWindowState on: aSpec model)]. + children := aSpec children. + children isSymbol ifTrue:[ + widget getChildrenSelector: children. + widget update: children. + children := #(). + ]. + widget closeWindowSelector: aSpec closeAction. + panes := OrderedCollection new. + self buildAll: children in: widget. + self buildHelpFor: widget spec: aSpec. + widget bounds: (RealEstateAgent + initialFrameFor: widget + initialExtent: (aSpec extent ifNil:[widget initialExtent]) + world: self currentWorld). + widget setUpdatablePanesFrom: panes. + ^widget! Item was added: + ----- Method: MorphicToolBuilder>>buttonClass (in category 'widget classes') ----- + buttonClass + ^ PluggableButtonMorphPlus! Item was added: + ----- Method: MorphicToolBuilder>>checkBoxClass (in category 'widget classes') ----- + checkBoxClass + ^ PluggableCheckBoxMorph! Item was added: + ----- Method: MorphicToolBuilder>>close: (in category 'opening') ----- + close: aWidget + "Close a previously opened widget" + aWidget delete! Item was added: + ----- Method: MorphicToolBuilder>>codePaneClass (in category 'widget classes') ----- + codePaneClass + ^ PluggableTextMorphPlus! Item was added: + ----- Method: MorphicToolBuilder>>dropDownListClass (in category 'widget classes') ----- + dropDownListClass + ^ PluggableDropDownListMorph! Item was added: + ----- Method: MorphicToolBuilder>>listByItemClass (in category 'widget classes') ----- + listByItemClass + ^ PluggableListMorphByItemPlus! Item was added: + ----- Method: MorphicToolBuilder>>listClass (in category 'widget classes') ----- + listClass + ^ PluggableListMorphPlus! Item was added: + ----- Method: MorphicToolBuilder>>menuClass (in category 'widget classes') ----- + menuClass + ^ MenuMorph! Item was added: + ----- Method: MorphicToolBuilder>>menuItemClass (in category 'widget classes') ----- + menuItemClass + ^ MenuItemMorph! Item was added: + ----- Method: MorphicToolBuilder>>multiSelectListClass (in category 'widget classes') ----- + multiSelectListClass + ^ PluggableListMorphOfMany! Item was added: + ----- Method: MorphicToolBuilder>>open: (in category 'opening') ----- + open: anObject + "Build and open the object. Answer the widget opened." + | morph | + anObject isMorph + ifTrue:[morph := anObject] + ifFalse:[morph := self build: anObject]. + (morph isKindOf: MenuMorph) + ifTrue:[morph popUpInWorld: World]. + (morph isKindOf: SystemWindow) + ifTrue:[morph openInWorldExtent: morph extent] + ifFalse:[morph openInWorld]. + ^morph! Item was added: + ----- Method: MorphicToolBuilder>>open:label: (in category 'opening') ----- + open: anObject label: aString + "Build an open the object, labeling it appropriately. Answer the widget opened." + | window | + window := self open: anObject. + window setLabel: aString. + ^window! Item was added: + ----- Method: MorphicToolBuilder>>panelClass (in category 'widget classes') ----- + panelClass + ^ PluggablePanelMorph! Item was added: + ----- Method: MorphicToolBuilder>>register:id: (in category 'private') ----- + register: widget id: id + id ifNil:[^self]. + widgets ifNil:[widgets := Dictionary new]. + widgets at: id put: widget. + widget setNameTo: id.! Item was added: + ----- Method: MorphicToolBuilder>>runModal: (in category 'opening') ----- + runModal: aWidget + "Run the (previously opened) widget modally, e.g., + do not return control to the sender before the user has responded." + [aWidget world notNil] whileTrue: [ + aWidget outermostWorldMorph doOneCycle. + ]. + ! Item was added: + ----- Method: MorphicToolBuilder>>setFrame:in: (in category 'private') ----- + setFrame: aRectangle in: widget + | frame | + aRectangle ifNil:[^nil]. + frame := aRectangle isRectangle + ifTrue: [self asFrame: aRectangle] + ifFalse: [aRectangle]. "assume LayoutFrame" + widget layoutFrame: frame. + widget hResizing: #spaceFill; vResizing: #spaceFill. + (parent isSystemWindow) ifTrue:[ + widget borderWidth: 2; borderColor: #inset. + ].! Item was added: + ----- Method: MorphicToolBuilder>>setLayout:in: (in category 'private') ----- + setLayout: layout in: widget + layout == #proportional ifTrue:[ + widget layoutPolicy: ProportionalLayout new. + ^self]. + layout == #horizontal ifTrue:[ + widget layoutPolicy: TableLayout new. + widget listDirection: #leftToRight. + widget submorphsDo:[:m| m hResizing: #spaceFill; vResizing: #spaceFill]. + widget cellInset: 1@1. + widget layoutInset: 1@1. + widget color: Color transparent. + "and then some..." + ^self]. + layout == #vertical ifTrue:[ + widget layoutPolicy: TableLayout new. + widget listDirection: #topToBottom. + widget submorphsDo:[:m| m hResizing: #spaceFill; vResizing: #spaceFill]. + widget cellInset: 1@1. + widget layoutInset: 1@1. + widget color: Color transparent. + "and then some..." + ^self]. + ^self error: 'Unknown layout: ', layout.! Item was added: + ----- Method: MorphicToolBuilder>>textPaneClass (in category 'widget classes') ----- + textPaneClass + ^ PluggableTextMorphPlus! Item was added: + ----- Method: MorphicToolBuilder>>treeClass (in category 'widget classes') ----- + treeClass + ^ PluggableTreeMorph! Item was added: + ----- Method: MorphicToolBuilder>>widgetAt:ifAbsent: (in category 'private') ----- + widgetAt: id ifAbsent: aBlock + widgets ifNil:[^aBlock value]. + ^widgets at: id ifAbsent: aBlock! Item was added: + ----- Method: MorphicToolBuilder>>windowClass (in category 'widget classes') ----- + windowClass + ^ PluggableSystemWindow! Item was added: + ----- Method: MorphicToolBuilder>>windowClassFor: (in category 'widget classes') ----- + windowClassFor: aSpec + aSpec isDialog ifTrue: [^ PluggableDialogWindow]. + ^aSpec multiWindowStyle + caseOf: + { [nil] -> [PluggableSystemWindow]. + [#labelButton] -> [PluggableSystemWindowWithLabelButton] } + otherwise: [PluggableSystemWindowWithLabelButton]! Item was added: + ToolBuilderTests subclass: #MorphicToolBuilderTests + instanceVariableNames: '' + classVariableNames: '' + poolDictionaries: '' + category: 'Morphic-ToolBuilder'! + + !MorphicToolBuilderTests commentStamp: 'ar 2/11/2005 15:02' prior: 0! + Tests for the Morphic tool builder.! Item was added: + ----- Method: MorphicToolBuilderTests>>acceptWidgetText (in category 'support') ----- + acceptWidgetText + widget hasUnacceptedEdits: true. + widget accept.! Item was added: + ----- Method: MorphicToolBuilderTests>>buttonWidgetEnabled (in category 'support') ----- + buttonWidgetEnabled + "Answer whether the current widget (a button) is currently enabled" + ^widget enabled! Item was added: + ----- Method: MorphicToolBuilderTests>>changeListWidget (in category 'support') ----- + changeListWidget + widget changeModelSelection: widget getCurrentSelectionIndex + 1.! Item was added: + ----- Method: MorphicToolBuilderTests>>expectedButtonSideEffects (in category 'support') ----- + expectedButtonSideEffects + ^#(getColor getState getEnabled)! Item was added: + ----- Method: MorphicToolBuilderTests>>fireButtonWidget (in category 'support') ----- + fireButtonWidget + widget performAction.! Item was added: + ----- Method: MorphicToolBuilderTests>>fireMenuItemWidget (in category 'support') ----- + fireMenuItemWidget + (widget itemWithWording: 'Menu Item') + ifNotNil: [:item | item doButtonAction]! Item was added: + ----- Method: MorphicToolBuilderTests>>setUp (in category 'support') ----- + setUp + super setUp. + builder := MorphicToolBuilder new.! Item was added: + ----- Method: MorphicToolBuilderTests>>testWindowDynamicLabel (in category 'tests-window') ----- + testWindowDynamicLabel + self makeWindow. + self assert: (widget label = 'TestLabel').! Item was added: + ----- Method: MorphicToolBuilderTests>>testWindowStaticLabel (in category 'tests-window') ----- + testWindowStaticLabel + | spec | + spec := builder pluggableWindowSpec new. + spec model: self. + spec children: #(). + spec label: 'TestLabel'. + widget := builder build: spec. + self assert: (widget label = 'TestLabel').! Item was added: + ----- Method: MorphicToolBuilderTests>>widgetColor (in category 'support') ----- + widgetColor + "Answer color from widget" + ^widget color! Item was added: + UIManager subclass: #MorphicUIManager + instanceVariableNames: '' + classVariableNames: '' + poolDictionaries: '' + category: 'Morphic-ToolBuilder'! + + !MorphicUIManager commentStamp: 'dtl 5/2/2010 16:07' prior: 0! + MorphicUIManager is a UIManager that implements user interface requests for a Morphic user interface.! Item was added: + ----- Method: MorphicUIManager class>>isActiveManager (in category 'accessing') ----- + isActiveManager + "Answer whether I should act as the active ui manager" + ^Smalltalk isMorphic! Item was added: + ----- Method: MorphicUIManager>>chooseClassOrTrait:from: (in category 'ui requests') ----- + chooseClassOrTrait: label from: environment + "Let the user choose a Class or Trait. Use ListChooser in Morphic." + + | names index | + names := environment classAndTraitNames. + index := self + chooseFrom: names + lines: #() + title: label. + index = 0 ifTrue: [ ^nil ]. + ^environment + at: (names at: index) + ifAbsent: [ nil ]! Item was added: + ----- Method: MorphicUIManager>>chooseDirectory:from: (in category 'ui requests') ----- + chooseDirectory: label from: dir + "Let the user choose a directory" + ^FileList2 modalFolderSelector: dir! Item was added: + ----- Method: MorphicUIManager>>chooseFileMatching:label: (in category 'ui requests') ----- + chooseFileMatching: patterns label: aString + "Let the user choose a file matching the given patterns" + | result | + result := FileList2 modalFileSelectorForSuffixes: patterns. + ^result ifNotNil:[result fullName]! Item was added: + ----- Method: MorphicUIManager>>chooseFont:for:setSelector:getSelector: (in category 'ui requests') ----- + chooseFont: titleString for: aModel setSelector: setSelector getSelector: getSelector + "Open a font-chooser for the given model" + ^FontChooserTool default + openWithWindowTitle: titleString + for: aModel + setSelector: setSelector + getSelector: getSelector! Item was added: + ----- Method: MorphicUIManager>>chooseFrom:lines:title: (in category 'ui requests') ----- + chooseFrom: aList lines: linesArray title: aString + "Choose an item from the given list. Answer the index of the selected item." + ^ aList size > 30 + ifTrue: + [ "Don't put more than 30 items in a menu. Use ListChooser insted" + ListChooser + chooseFrom: aList + title: aString ] + ifFalse: + [ MenuMorph + chooseFrom: aList + lines: linesArray + title: aString ]! Item was added: + ----- Method: MorphicUIManager>>chooseFrom:values:lines:title: (in category 'ui requests') ----- + chooseFrom: labelList values: valueList lines: linesArray title: aString + "Choose an item from the given list. Answer the selected item." + | index | + ^ labelList size > 30 + ifTrue: + [ "No point in displaying more than 30 items in a menu. Use ListChooser insted" + index := ListChooser + chooseFrom: labelList + title: aString. + index = 0 ifFalse: [ valueList at: index ] ] + ifFalse: + [ MenuMorph + chooseFrom: labelList + values: valueList + lines: linesArray + title: aString ]! Item was added: + ----- Method: MorphicUIManager>>confirm: (in category 'ui requests') ----- + confirm: queryString + "Put up a yes/no menu with caption queryString. Answer true if the + response is yes, false if no. This is a modal question--the user must + respond yes or no." + ^UserDialogBoxMorph confirm: queryString! Item was added: + ----- Method: MorphicUIManager>>confirm:orCancel: (in category 'ui requests') ----- + confirm: aString orCancel: cancelBlock + "Put up a yes/no/cancel menu with caption aString. Answer true if + the response is yes, false if no. If cancel is chosen, evaluate + cancelBlock. This is a modal question--the user must respond yes or no." + ^UserDialogBoxMorph confirm: aString orCancel: cancelBlock! Item was added: + ----- Method: MorphicUIManager>>confirm:trueChoice:falseChoice: (in category 'ui requests') ----- + confirm: queryString trueChoice: trueChoice falseChoice: falseChoice + "Put up a yes/no menu with caption queryString. The actual wording for the two choices will be as provided in the trueChoice and falseChoice parameters. Answer true if the response is the true-choice, false if it's the false-choice. + This is a modal question -- the user must respond one way or the other." + ^ UserDialogBoxMorph confirm: queryString trueChoice: trueChoice falseChoice: falseChoice ! Item was added: + ----- Method: MorphicUIManager>>displayProgress:at:from:to:during: (in category 'ui requests') ----- + displayProgress: titleString at: aPoint from: minVal to: maxVal during: workBlock + "Display titleString as a caption over a progress bar while workBlock is evaluated." + | result progress | + progress := SystemProgressMorph + position: aPoint + label: titleString + min: minVal + max: maxVal. + [ [ result := workBlock value: progress ] + on: ProgressNotification + do: + [ : ex | ex extraParam isString ifTrue: + [ SystemProgressMorph uniqueInstance + labelAt: progress + put: ex extraParam ]. + ex resume ] ] ensure: [ SystemProgressMorph close: progress ]. + ^ result! Item was added: + ----- Method: MorphicUIManager>>edit:label:accept: (in category 'ui requests') ----- + edit: aText label: labelString accept: anAction + "Open an editor on the given string/text" + | window | + window := Workspace open. + labelString ifNotNil: [ window setLabel: labelString ]. + "By default, don't style in UIManager edit: requests" + window model + shouldStyle: false; + acceptContents: aText; + acceptAction: anAction. + ^window.! Item was added: + ----- Method: MorphicUIManager>>inform: (in category 'ui requests') ----- + inform: aString + "Display a message for the user to read and then dismiss" + ^UserDialogBoxMorph inform: aString! Item was added: + ----- Method: MorphicUIManager>>informUserDuring: (in category 'ui requests') ----- + informUserDuring: aBlock + "Display a message above (or below if insufficient room) the cursor + during execution of the given block. + UIManager default informUserDuring:[:bar| + #(one two three) do:[:info| + bar value: info. + (Delay forSeconds: 1) wait]]" + SystemProgressMorph + informUserAt: nil during: aBlock.! Item was added: + ----- Method: MorphicUIManager>>initialize (in category 'initialize-release') ----- + initialize + toolBuilder := MorphicToolBuilder new! Item was added: + ----- Method: MorphicUIManager>>multiLineRequest:centerAt:initialAnswer:answerHeight: (in category 'ui requests') ----- + multiLineRequest: queryString centerAt: aPoint initialAnswer: defaultAnswer answerHeight: answerHeight + "Create a multi-line instance of me whose question is queryString with + the given initial answer. Invoke it centered at the given point, and + answer the string the user accepts. Answer nil if the user cancels. An + empty string returned means that the ussr cleared the editing area and + then hit 'accept'. Because multiple lines are invited, we ask that the user + use the ENTER key, or (in morphic anyway) hit the 'accept' button, to + submit; that way, the return key can be typed to move to the next line." + ^FillInTheBlankMorph + request: queryString + initialAnswer: defaultAnswer + centerAt: aPoint + inWorld: self currentWorld + onCancelReturn: nil + acceptOnCR: false! Item was added: + ----- Method: MorphicUIManager>>request:initialAnswer: (in category 'ui requests') ----- + request: queryString initialAnswer: defaultAnswer + "Create an instance of me whose question is queryString with the given + initial answer. Invoke it centered at the given point, and answer the + string the user accepts. Answer the empty string if the user cancels." + ^FillInTheBlankMorph request: queryString initialAnswer: defaultAnswer ! Item was added: + ----- Method: MorphicUIManager>>request:initialAnswer:centerAt: (in category 'ui requests') ----- + request: queryString initialAnswer: defaultAnswer centerAt: aPoint + "Create an instance of me whose question is queryString with the given + initial answer. Invoke it centered at the given point, and answer the + string the user accepts. Answer the empty string if the user cancels." + ^FillInTheBlankMorph request: queryString initialAnswer: defaultAnswer centerAt: aPoint! Item was added: + ----- Method: MorphicUIManager>>requestPassword: (in category 'ui requests') ----- + requestPassword: queryString + "Create an instance of me whose question is queryString. Invoke it centered + at the cursor, and answer the string the user accepts. Answer the empty + string if the user cancels." + ^FillInTheBlankMorph requestPassword: queryString! Item was added: + PluggableButtonMorph subclass: #PluggableButtonMorphPlus + instanceVariableNames: 'enabled action getColorSelector getEnabledSelector updateMap' + classVariableNames: '' + poolDictionaries: '' + category: 'Morphic-ToolBuilder'! + + !PluggableButtonMorphPlus commentStamp: 'ar 2/11/2005 21:53' prior: 0! + An extended version of PluggableButtonMorph supporting enablement, color and block/message actions.! Item was added: + ----- Method: PluggableButtonMorphPlus>>action (in category 'accessing') ----- + action + ^action! Item was added: + ----- Method: PluggableButtonMorphPlus>>action: (in category 'accessing') ----- + action: anAction + action := nil. + anAction isSymbol ifTrue:[^super action: anAction]. + action := anAction.! Item was added: + ----- Method: PluggableButtonMorphPlus>>enabled (in category 'accessing') ----- + enabled + ^ enabled ifNil: [enabled := true]! Item was added: + ----- Method: PluggableButtonMorphPlus>>enabled: (in category 'accessing') ----- + enabled: aBool + enabled := aBool. + enabled + ifFalse:[self color: Color gray] + ifTrue:[self getModelState + ifTrue: [self color: onColor] + ifFalse: [self color: offColor]]! Item was added: + ----- Method: PluggableButtonMorphPlus>>getColorSelector (in category 'accessing') ----- + getColorSelector + ^getColorSelector! Item was added: + ----- Method: PluggableButtonMorphPlus>>getColorSelector: (in category 'accessing') ----- + getColorSelector: aSymbol + getColorSelector := aSymbol. + self update: getColorSelector.! Item was added: + ----- Method: PluggableButtonMorphPlus>>getEnabledSelector (in category 'accessing') ----- + getEnabledSelector + ^getEnabledSelector! Item was added: + ----- Method: PluggableButtonMorphPlus>>getEnabledSelector: (in category 'accessing') ----- + getEnabledSelector: aSymbol + getEnabledSelector := aSymbol. + self update: aSymbol.! Item was added: + ----- Method: PluggableButtonMorphPlus>>initialize (in category 'initialize-release') ----- + initialize + super initialize. + enabled := true. + onColor := Color veryLightGray. + offColor := Color white! Item was added: + ----- Method: PluggableButtonMorphPlus>>mouseDown: (in category 'action') ----- + mouseDown: evt + enabled ifFalse:[^self]. + ^super mouseDown: evt! Item was added: + ----- Method: PluggableButtonMorphPlus>>mouseMove: (in category 'action') ----- + mouseMove: evt + enabled ifFalse:[^self]. + ^super mouseMove: evt! Item was added: + ----- Method: PluggableButtonMorphPlus>>mouseUp: (in category 'action') ----- + mouseUp: evt + enabled ifFalse:[^self]. + ^super mouseUp: evt! Item was added: + ----- Method: PluggableButtonMorphPlus>>onColor:offColor: (in category 'accessing') ----- + onColor: colorWhenOn offColor: colorWhenOff + "Set the fill colors to be used when this button is on/off." + + onColor := colorWhenOn. + offColor := colorWhenOff. + self update: getStateSelector.! Item was added: + ----- Method: PluggableButtonMorphPlus>>performAction (in category 'action') ----- + performAction + enabled ifFalse:[^self]. + action ifNotNil:[^action value]. + ^super performAction! Item was added: + ----- Method: PluggableButtonMorphPlus>>update: (in category 'updating') ----- + update: what + what ifNil:[^self]. + what == getLabelSelector ifTrue: [ + self label: (model perform: getLabelSelector)]. + what == getEnabledSelector ifTrue:[^self enabled: (model perform: getEnabledSelector)]. + + getColorSelector ifNotNil: [ | cc | + color = (cc := model perform: getColorSelector) ifFalse:[ + color := cc. + self onColor: color offColor: color. + self changed. + ]. + ]. + self getModelState + ifTrue: [self color: onColor] + ifFalse: [self color: offColor]. + getEnabledSelector ifNotNil:[ + self enabled: (model perform: getEnabledSelector). + ]. + updateMap ifNotNil: + [(updateMap at: what ifAbsent: []) + ifNotNilDo: [ :newTarget | ^self update: newTarget]]. + ! Item was added: + ----- Method: PluggableButtonMorphPlus>>updateMap (in category 'updating') ----- + updateMap + ^ updateMap ifNil: [updateMap := Dictionary new] + ! Item was added: + ----- Method: PluggableButtonMorphPlus>>whenChanged:update: (in category 'updating') ----- + whenChanged: notification update: target + "On receipt of a notification, such as #contents notification from a CodeHolder, + invoke an update as if target had been the original notification." + + self updateMap at: notification put: target! Item was added: + AlignmentMorph subclass: #PluggableCheckBoxMorph + instanceVariableNames: 'model actionSelector valueSelector label' + classVariableNames: '' + poolDictionaries: '' + category: 'Morphic-ToolBuilder'! Item was added: + ----- Method: PluggableCheckBoxMorph class>>on:getState:action:label: (in category 'as yet unclassified') ----- + on: anObject getState: getStateSel action: actionSel label: labelSel + + ^ self new + on: anObject + getState: getStateSel + action: actionSel + label: labelSel + menu: nil + ! Item was added: + ----- Method: PluggableCheckBoxMorph>>actionSelector (in category 'accessing') ----- + actionSelector + "Answer the value of actionSelector" + + ^ actionSelector! Item was added: + ----- Method: PluggableCheckBoxMorph>>actionSelector: (in category 'accessing') ----- + actionSelector: anObject + "Set the value of actionSelector" + + actionSelector := anObject! Item was added: + ----- Method: PluggableCheckBoxMorph>>basicPanel (in category 'installing') ----- + basicPanel + ^BorderedMorph new + beTransparent; + extent: 0@0; + borderWidth: 0; + layoutInset: 0; + cellInset: 0; + layoutPolicy: TableLayout new; + listCentering: #topLeft; + cellPositioning: #center; + hResizing: #spaceFill; + vResizing: #shrinkWrap; + yourself! Item was added: + ----- Method: PluggableCheckBoxMorph>>horizontalPanel (in category 'installing') ----- + horizontalPanel + ^self basicPanel + cellPositioning: #center; + listDirection: #leftToRight; + yourself.! Item was added: + ----- Method: PluggableCheckBoxMorph>>installButton (in category 'installing') ----- + installButton + + | aButton aLabel | + aButton := UpdatingThreePhaseButtonMorph checkBox + target: self model; + actionSelector: self actionSelector; + getSelector: self valueSelector; + yourself. + aLabel := (StringMorph contents: self label translated + font: (StrikeFont familyName: TextStyle defaultFont familyName + size: TextStyle defaultFont pointSize - 1)). + self addMorph: (self horizontalPanel + addMorphBack: aButton; + addMorphBack: aLabel; + yourself).! Item was added: + ----- Method: PluggableCheckBoxMorph>>label (in category 'accessing') ----- + label + "Answer the value of label" + + ^ label! Item was added: + ----- Method: PluggableCheckBoxMorph>>label: (in category 'accessing') ----- + label: anObject + "Set the value of label" + + label := anObject! Item was added: + ----- Method: PluggableCheckBoxMorph>>model (in category 'accessing') ----- + model + "Answer the value of model" + + ^ model. + ! Item was added: + ----- Method: PluggableCheckBoxMorph>>model: (in category 'accessing') ----- + model: anObject + "Set the value of model" + + model := anObject! Item was added: + ----- Method: PluggableCheckBoxMorph>>on:getState:action:label:menu: (in category 'initialization') ----- + on: anObject getState: getStateSel action: actionSel label: labelSel menu: menuSel + + self model: anObject. + self valueSelector: getStateSel. + self actionSelector: actionSel. + self label: (self model perform: labelSel). + ! Item was added: + ----- Method: PluggableCheckBoxMorph>>valueSelector (in category 'accessing') ----- + valueSelector + "Answer the value of valueSelector" + + ^ valueSelector! Item was added: + ----- Method: PluggableCheckBoxMorph>>valueSelector: (in category 'accessing') ----- + valueSelector: anObject + "Set the value of valueSelector" + + valueSelector := anObject! Item was added: + PluggableSystemWindow subclass: #PluggableDialogWindow + instanceVariableNames: 'statusValue' + classVariableNames: '' + poolDictionaries: '' + category: 'Morphic-ToolBuilder'! Item was added: + ----- Method: PluggableDialogWindow>>statusValue (in category 'as yet unclassified') ----- + statusValue + ^statusValue! Item was added: + ----- Method: PluggableDialogWindow>>statusValue: (in category 'as yet unclassified') ----- + statusValue: val + statusValue := val! Item was added: + AlignmentMorph subclass: #PluggableDropDownListMorph + instanceVariableNames: 'model listSelector selectionSelector selectionSetter' + classVariableNames: '' + poolDictionaries: '' + category: 'Morphic-ToolBuilder'! Item was added: + ----- Method: PluggableDropDownListMorph>>basicPanel (in category 'drawing') ----- + basicPanel + ^BorderedMorph new + beTransparent; + extent: 0@0; + borderWidth: 0; + layoutInset: 0; + cellInset: 0; + layoutPolicy: TableLayout new; + listCentering: #topLeft; + cellPositioning: #center; + hResizing: #spaceFill; + vResizing: #shrinkWrap; + yourself! Item was added: + ----- Method: PluggableDropDownListMorph>>currentSelection (in category 'accessing') ----- + currentSelection + + ^ self model perform: selectionSelector! Item was added: + ----- Method: PluggableDropDownListMorph>>currentSelection: (in category 'accessing') ----- + currentSelection: obj + + ^ self model perform: selectionSetter with: obj! Item was added: + ----- Method: PluggableDropDownListMorph>>horizontalPanel (in category 'drawing') ----- + horizontalPanel + ^self basicPanel + cellPositioning: #center; + listDirection: #leftToRight; + yourself.! Item was added: + ----- Method: PluggableDropDownListMorph>>installDropDownList (in category 'drawing') ----- + installDropDownList + + | aButton aLabel | + aButton := PluggableButtonMorph on: self model getState: nil action: nil. + aLabel := (StringMorph contents: self model currentRemoteVatId translated + font: (StrikeFont familyName: TextStyle defaultFont familyName + size: TextStyle defaultFont pointSize - 1)). + self addMorph: (self horizontalPanel + addMorphBack: aLabel; + addMorphBack: aButton; + yourself).! Item was added: + ----- Method: PluggableDropDownListMorph>>list (in category 'accessing') ----- + list + "Answer the value of list" + + ^ self model perform: self listSelector. + ! Item was added: + ----- Method: PluggableDropDownListMorph>>listSelector (in category 'accessing') ----- + listSelector + "Answer the value of listSelector" + + ^ listSelector! Item was added: + ----- Method: PluggableDropDownListMorph>>listSelector: (in category 'accessing') ----- + listSelector: anObject + "Set the value of listSelector" + + listSelector := anObject! Item was added: + ----- Method: PluggableDropDownListMorph>>model (in category 'accessing') ----- + model + ^ model! Item was added: + ----- Method: PluggableDropDownListMorph>>model: (in category 'accessing') ----- + model: anObject + "Set the value of model" + + model := anObject! Item was added: + ----- Method: PluggableDropDownListMorph>>selectionSelector (in category 'accessing') ----- + selectionSelector + "Answer the value of selectionSelector" + + ^ selectionSelector! Item was added: + ----- Method: PluggableDropDownListMorph>>selectionSelector: (in category 'accessing') ----- + selectionSelector: anObject + "Set the value of selectionSelector" + + selectionSelector := anObject! Item was added: + ----- Method: PluggableDropDownListMorph>>selectionSetter (in category 'accessing') ----- + selectionSetter + "Answer the value of selectionSetter" + + ^ selectionSetter! Item was added: + ----- Method: PluggableDropDownListMorph>>selectionSetter: (in category 'accessing') ----- + selectionSetter: anObject + "Set the value of selectionSetter" + + selectionSetter := anObject! Item was added: + PluggableListMorphPlus subclass: #PluggableListMorphByItemPlus + instanceVariableNames: 'itemList' + classVariableNames: '' + poolDictionaries: '' + category: 'Morphic-ToolBuilder'! + + !PluggableListMorphByItemPlus commentStamp: '<historical>' prior: 0! + Main comment stating the purpose of this class and relevant relationship to other classes. + + Possible useful expressions for doIt or printIt. + + Structure: + instVar1 type -- comment about the purpose of instVar1 + instVar2 type -- comment about the purpose of instVar2 + + Any further useful comments about the general approach of this implementation.! Item was added: + ----- Method: PluggableListMorphByItemPlus>>changeModelSelection: (in category 'model access') ----- + changeModelSelection: anInteger + "Change the model's selected item to be the one at the given index." + + | item | + setIndexSelector ifNotNil: [ + item := (anInteger = 0 ifTrue: [nil] ifFalse: [itemList at: anInteger]). + model perform: setIndexSelector with: item]. + self update: getIndexSelector. + ! Item was added: + ----- Method: PluggableListMorphByItemPlus>>getCurrentSelectionIndex (in category 'model access') ----- + getCurrentSelectionIndex + "Answer the index of the current selection." + | item | + getIndexSelector == nil ifTrue: [^ 0]. + item := model perform: getIndexSelector. + ^ itemList findFirst: [ :x | x = item] + ! Item was added: + ----- Method: PluggableListMorphByItemPlus>>getList (in category 'as yet unclassified') ----- + getList + "cache the raw items in itemList" + itemList := getListSelector ifNil: [ #() ] ifNotNil: [ model perform: getListSelector ]. + ^super getList! Item was added: + ----- Method: PluggableListMorphByItemPlus>>list: (in category 'initialization') ----- + list: arrayOfStrings + "Set the receivers items to be the given list of strings." + "Note: the instance variable 'items' holds the original list. + The instance variable 'list' is a paragraph constructed from + this list." + "NOTE: this is no longer true; list is a real list, and itemList is no longer used. And this method shouldn't be called, incidentally." + self isThisEverCalled . + itemList := arrayOfStrings. + ^ super list: arrayOfStrings! Item was added: + PluggableListMorph subclass: #PluggableListMorphPlus + instanceVariableNames: 'dragItemSelector dropItemSelector wantsDropSelector' + classVariableNames: '' + poolDictionaries: '' + category: 'Morphic-ToolBuilder'! + + !PluggableListMorphPlus commentStamp: 'ar 7/15/2005 11:10' prior: 0! + Extensions for PluggableListMorph needed by ToolBuilder! Item was added: + ----- Method: PluggableListMorphPlus>>acceptDroppingMorph:event: (in category 'drag and drop') ----- + acceptDroppingMorph: aMorph event: evt + | item | + dropItemSelector isNil | potentialDropRow isNil ifTrue: [^self]. + item := aMorph passenger. + model perform: dropItemSelector with: item with: potentialDropRow. + self resetPotentialDropRow. + evt hand releaseMouseFocus: self. + Cursor normal show. + ! Item was added: + ----- Method: PluggableListMorphPlus>>dragItemSelector (in category 'accessing') ----- + dragItemSelector + ^dragItemSelector! Item was added: + ----- Method: PluggableListMorphPlus>>dragItemSelector: (in category 'accessing') ----- + dragItemSelector: aSymbol + dragItemSelector := aSymbol. + aSymbol ifNotNil:[self dragEnabled: true].! Item was added: + ----- Method: PluggableListMorphPlus>>dropItemSelector (in category 'accessing') ----- + dropItemSelector + ^dropItemSelector! Item was added: + ----- Method: PluggableListMorphPlus>>dropItemSelector: (in category 'accessing') ----- + dropItemSelector: aSymbol + dropItemSelector := aSymbol. + aSymbol ifNotNil:[self dropEnabled: true].! Item was added: + ----- Method: PluggableListMorphPlus>>startDrag: (in category 'drag and drop') ----- + startDrag: evt + + dragItemSelector ifNil:[^self]. + evt hand hasSubmorphs ifTrue: [^ self]. + [ | dragIndex draggedItem ddm | + (self dragEnabled and: [model okToChange]) ifFalse: [^ self]. + dragIndex := self rowAtLocation: evt position. + dragIndex = 0 ifTrue:[^self]. + draggedItem := model perform: dragItemSelector with: (self modelIndexFor: dragIndex). + draggedItem ifNil:[^self]. + ddm := TransferMorph withPassenger: draggedItem from: self. + ddm dragTransferType: #dragTransferPlus. + evt hand grabMorph: ddm] + ensure: [Cursor normal show. + evt hand releaseMouseFocus: self]! Item was added: + ----- Method: PluggableListMorphPlus>>wantsDropSelector (in category 'accessing') ----- + wantsDropSelector + ^wantsDropSelector! Item was added: + ----- Method: PluggableListMorphPlus>>wantsDropSelector: (in category 'accessing') ----- + wantsDropSelector: aSymbol + wantsDropSelector := aSymbol! Item was added: + ----- Method: PluggableListMorphPlus>>wantsDroppedMorph:event: (in category 'drag and drop') ----- + wantsDroppedMorph: aMorph event: anEvent + aMorph dragTransferType == #dragTransferPlus ifFalse:[^false]. + dropItemSelector ifNil:[^false]. + wantsDropSelector ifNil:[^true]. + ^(model perform: wantsDropSelector with: aMorph passenger) == true! Item was added: + AlignmentMorph subclass: #PluggablePanelMorph + instanceVariableNames: 'model getChildrenSelector' + classVariableNames: '' + poolDictionaries: '' + category: 'Morphic-ToolBuilder'! + + !PluggablePanelMorph commentStamp: 'ar 2/11/2005 20:13' prior: 0! + A pluggable panel morph which deals with changing children.! Item was added: + ----- Method: PluggablePanelMorph>>getChildrenSelector (in category 'accessing') ----- + getChildrenSelector + ^getChildrenSelector! Item was added: + ----- Method: PluggablePanelMorph>>getChildrenSelector: (in category 'accessing') ----- + getChildrenSelector: aSymbol + getChildrenSelector := aSymbol.! Item was added: + ----- Method: PluggablePanelMorph>>model (in category 'accessing') ----- + model + ^model! Item was added: + ----- Method: PluggablePanelMorph>>model: (in category 'accessing') ----- + model: aModel + model ifNotNil:[model removeDependent: self]. + model := aModel. + model ifNotNil:[model addDependent: self].! Item was added: + ----- Method: PluggablePanelMorph>>update: (in category 'update') ----- + update: what + what == nil ifTrue:[^self]. + what == getChildrenSelector ifTrue:[ + self removeAllMorphs. + self addAllMorphs: (model perform: getChildrenSelector). + self submorphsDo:[:m| m hResizing: #spaceFill; vResizing: #spaceFill]. + ].! Item was added: + SystemWindow subclass: #PluggableSystemWindow + instanceVariableNames: 'getLabelSelector getChildrenSelector children closeWindowSelector' + classVariableNames: '' + poolDictionaries: '' + category: 'Morphic-ToolBuilder'! + + !PluggableSystemWindow commentStamp: 'ar 2/11/2005 20:14' prior: 0! + A pluggable system window. Fixes the issues with label retrieval and adds support for changing children.! Item was added: + ----- Method: PluggableSystemWindow>>addPaneMorph: (in category 'accessing') ----- + addPaneMorph: aMorph + self addMorph: aMorph fullFrame: aMorph layoutFrame! Item was added: + ----- Method: PluggableSystemWindow>>closeWindowSelector (in category 'accessing') ----- + closeWindowSelector + ^closeWindowSelector! Item was added: + ----- Method: PluggableSystemWindow>>closeWindowSelector: (in category 'accessing') ----- + closeWindowSelector: aSymbol + closeWindowSelector := aSymbol! Item was added: + ----- Method: PluggableSystemWindow>>delete (in category 'initialization') ----- + delete + closeWindowSelector ifNotNil:[model perform: closeWindowSelector]. + super delete. + ! Item was added: + ----- Method: PluggableSystemWindow>>getChildrenSelector (in category 'accessing') ----- + getChildrenSelector + ^getChildrenSelector! Item was added: + ----- Method: PluggableSystemWindow>>getChildrenSelector: (in category 'accessing') ----- + getChildrenSelector: aSymbol + getChildrenSelector := aSymbol! Item was added: + ----- Method: PluggableSystemWindow>>getLabelSelector (in category 'accessing') ----- + getLabelSelector + ^getLabelSelector! Item was added: + ----- Method: PluggableSystemWindow>>getLabelSelector: (in category 'accessing') ----- + getLabelSelector: aSymbol + getLabelSelector := aSymbol. + self update: aSymbol.! Item was added: + ----- Method: PluggableSystemWindow>>label (in category 'accessing') ----- + label + ^label contents! Item was added: + ----- Method: PluggableSystemWindow>>label: (in category 'accessing') ----- + label: aString + self setLabel: aString.! Item was added: + ----- Method: PluggableSystemWindow>>update: (in category 'updating') ----- + update: what + what ifNil:[^self]. + what == getLabelSelector ifTrue:[self setLabel: (model perform: getLabelSelector)]. + what == getChildrenSelector ifTrue:[ + children ifNil:[children := #()]. + self removeAllMorphsIn: children. + children := model perform: getChildrenSelector. + self addAllMorphs: children. + children do:[:m| m hResizing: #spaceFill; vResizing: #spaceFill]. + ]. + ^super update: what! Item was added: + PluggableTextMorph subclass: #PluggableTextMorphPlus + instanceVariableNames: 'getColorSelector acceptAction unstyledAcceptText styler' + classVariableNames: '' + poolDictionaries: '' + category: 'Morphic-ToolBuilder'! + + !PluggableTextMorphPlus commentStamp: 'ar 2/11/2005 21:53' prior: 0! + A pluggable text morph with support for color.! Item was added: + ----- Method: PluggableTextMorphPlus>>accept (in category 'updating') ----- + accept + super accept. + acceptAction ifNotNil:[acceptAction value: textMorph asText].! Item was added: + ----- Method: PluggableTextMorphPlus>>acceptAction (in category 'accessing') ----- + acceptAction + ^acceptAction! Item was added: + ----- Method: PluggableTextMorphPlus>>acceptAction: (in category 'accessing') ----- + acceptAction: anAction + acceptAction := anAction! Item was added: + ----- Method: PluggableTextMorphPlus>>acceptTextInModel (in category 'styling') ----- + acceptTextInModel + + self okToStyle ifFalse:[^super acceptTextInModel]. + "#correctFrom:to:with: is sent when the method source is + manipulated during compilation (removing unused temps, + changing selectors etc). But #correctFrom:to:with: operates + on the textMorph's text, and we may be saving an unstyled + copy of the text. This means that these corrections will be lost + unless we also apply the corrections to the unstyled copy that we are saving. + So remember the unstyled copy in unstyledAcceptText, so + that when #correctFrom:to:with: is received we can also apply + the correction to it" + unstyledAcceptText := styler unstyledTextFrom: textMorph asText. + [^setTextSelector isNil or: + [setTextSelector numArgs = 2 + ifTrue: [model perform: setTextSelector with: unstyledAcceptText with: self] + ifFalse: [model perform: setTextSelector with: unstyledAcceptText]] + ] ensure:[unstyledAcceptText := nil]! Item was added: + ----- Method: PluggableTextMorphPlus>>correctFrom:to:with: (in category 'styling') ----- + correctFrom: start to: stop with: aString + "see the comment in #acceptTextInModel " + unstyledAcceptText ifNotNil:[unstyledAcceptText replaceFrom: start to: stop with: aString ]. + ^ super correctFrom: start to: stop with: aString! Item was added: + ----- Method: PluggableTextMorphPlus>>getColorSelector (in category 'accessing') ----- + getColorSelector + ^getColorSelector! Item was added: + ----- Method: PluggableTextMorphPlus>>getColorSelector: (in category 'accessing') ----- + getColorSelector: aSymbol + getColorSelector := aSymbol. + self update: getColorSelector.! Item was added: + ----- Method: PluggableTextMorphPlus>>getMenu: (in category 'menu') ----- + getMenu: shiftKeyState + "Answer the menu for this text view. We override the superclass implementation to + so we can give the selection interval to the model." + + | menu aMenu | + getMenuSelector == nil ifTrue: [^ nil]. + getMenuSelector numArgs < 3 ifTrue: [^ super getMenu: shiftKeyState]. + menu := MenuMorph new defaultTarget: model. + getMenuSelector numArgs = 3 ifTrue: + [aMenu := model + perform: getMenuSelector + with: menu + with: shiftKeyState + with: self selectionInterval. + getMenuTitleSelector ifNotNil: + [aMenu addTitle: (model perform: getMenuTitleSelector)]. + ^ aMenu]. + ^ self error: 'The getMenuSelector must be a 1- or 2 or 3-keyword symbol'! Item was added: + ----- Method: PluggableTextMorphPlus>>hasUnacceptedEdits: (in category 'styling') ----- + hasUnacceptedEdits: aBoolean + "re-implemented to re-style the text iff aBoolean is true" + + super hasUnacceptedEdits: aBoolean. + (aBoolean and: [self okToStyle]) + ifTrue: [ styler styleInBackgroundProcess: textMorph contents]! Item was added: + ----- Method: PluggableTextMorphPlus>>okToStyle (in category 'testing') ----- + okToStyle + styler ifNil:[^false]. + (model respondsTo: #aboutToStyle: ) ifFalse:[^true]. + ^model aboutToStyle: styler + ! Item was added: + ----- Method: PluggableTextMorphPlus>>setText: (in category 'styling') ----- + setText: aText + + self okToStyle ifFalse:[^super setText: aText]. + super setText: (styler format: aText asText). + aText size < 4096 + ifTrue:[styler style: textMorph contents] + ifFalse:[styler styleInBackgroundProcess: textMorph contents]! Item was added: + ----- Method: PluggableTextMorphPlus>>styler (in category 'accessing') ----- + styler + "The styler responsible for highlighting text in the receiver" + ^styler! Item was added: + ----- Method: PluggableTextMorphPlus>>styler: (in category 'accessing') ----- + styler: anObject + "The styler responsible for highlighting text in the receiver" + styler := anObject! Item was added: + ----- Method: PluggableTextMorphPlus>>stylerStyled: (in category 'styling') ----- + stylerStyled: styledCopyOfText + "Sent after the styler completed styling the underlying text" + textMorph contents runs: styledCopyOfText runs . + "textMorph paragraph recomposeFrom: 1 to: textMorph contents size delta: 0." "caused chars to appear in wrong order esp. in demo mode. remove this line when sure it is fixed" + textMorph updateFromParagraph. + selectionInterval + ifNotNil:[ + textMorph editor + selectInvisiblyFrom: selectionInterval first to: selectionInterval last; + storeSelectionInParagraph; + setEmphasisHere]. + textMorph editor blinkParen. + self scrollSelectionIntoView! Item was added: + ----- Method: PluggableTextMorphPlus>>stylerStyledInBackground: (in category 'styling') ----- + stylerStyledInBackground: styledCopyOfText + "Sent after the styler completed styling of the text" + + "It is possible that the text string has changed since the styling began. Disregard the styles if styledCopyOfText's string differs with the current textMorph contents string" + textMorph contents string = styledCopyOfText string + ifTrue: [self stylerStyled: styledCopyOfText]! Item was added: + ----- Method: PluggableTextMorphPlus>>update: (in category 'updating') ----- + update: what + what ifNil:[^self]. + what == getColorSelector ifTrue:[self color: (model perform: getColorSelector)]. + ^super update: what! Item was added: + ----- Method: PluggableTextMorphPlus>>useDefaultStyler (in category 'initialize') ----- + useDefaultStyler + "This should be changed to a proper registry but as long as there is only shout this will do" + Smalltalk at: #SHTextStylerST80 ifPresent:[:stylerClass| + self styler: (stylerClass new view: self). + ].! Item was added: + ListItemWrapper subclass: #PluggableTreeItemNode + instanceVariableNames: '' + classVariableNames: '' + poolDictionaries: '' + category: 'Morphic-ToolBuilder'! + + !PluggableTreeItemNode commentStamp: 'ar 2/12/2005 04:37' prior: 0! + Tree item for PluggableTreeMorph.! Item was added: + ----- Method: PluggableTreeItemNode>>acceptDroppingObject: (in category 'accessing') ----- + acceptDroppingObject: anotherItem + ^model dropNode: anotherItem on: self! Item was added: + ----- Method: PluggableTreeItemNode>>asString (in category 'accessing') ----- + asString + ^model printNode: self! Item was added: + ----- Method: PluggableTreeItemNode>>balloonText (in category 'accessing') ----- + balloonText + ^model balloonTextForNode: self! Item was added: + ----- Method: PluggableTreeItemNode>>canBeDragged (in category 'accessing') ----- + canBeDragged + ^model isDraggableNode: self! Item was added: + ----- Method: PluggableTreeItemNode>>contents (in category 'accessing') ----- + contents + ^model contentsOfNode: self! Item was added: + ----- Method: PluggableTreeItemNode>>hasContents (in category 'accessing') ----- + hasContents + ^model hasNodeContents: self! Item was added: + ----- Method: PluggableTreeItemNode>>icon (in category 'accessing') ----- + icon + ^model iconOfNode: self! Item was added: + ----- Method: PluggableTreeItemNode>>item (in category 'accessing') ----- + item + ^item! Item was added: + ----- Method: PluggableTreeItemNode>>wantsDroppedObject: (in category 'accessing') ----- + wantsDroppedObject: anotherItem + ^model wantsDroppedNode: anotherItem on: self! Item was added: + SimpleHierarchicalListMorph subclass: #PluggableTreeMorph + instanceVariableNames: 'roots selectedWrapper getRootsSelector getChildrenSelector hasChildrenSelector getLabelSelector getIconSelector getSelectedPathSelector setSelectedSelector getHelpSelector dropItemSelector wantsDropSelector dragItemSelector' + classVariableNames: '' + poolDictionaries: '' + category: 'Morphic-ToolBuilder'! + + !PluggableTreeMorph commentStamp: 'ar 2/12/2005 04:38' prior: 0! + A pluggable tree morph.! Item was added: + ----- Method: PluggableTreeMorph>>acceptDroppingMorph:event: (in category 'morphic') ----- + acceptDroppingMorph: aTransferMorph event: evt + dropItemSelector ifNil: [ ^ self ]. + model + perform: dropItemSelector + withEnoughArguments: {aTransferMorph passenger. + (self itemFromPoint: evt position) withoutListWrapper. + aTransferMorph shouldCopy}. + evt hand releaseMouseFocus: self. + potentialDropMorph ifNotNil: [ potentialDropMorph highlightForDrop: false ]. + Cursor normal show! Item was added: + ----- Method: PluggableTreeMorph>>balloonTextForNode: (in category 'node access') ----- + balloonTextForNode: node + getHelpSelector ifNil:[^nil]. + ^model perform: getHelpSelector with: node item! Item was added: + ----- Method: PluggableTreeMorph>>contentsOfNode: (in category 'node access') ----- + contentsOfNode: node + | children | + getChildrenSelector ifNil:[^#()]. + children := model perform: getChildrenSelector with: node item. + ^children collect:[:item| PluggableTreeItemNode with: item model: self]! Item was added: + ----- Method: PluggableTreeMorph>>dragItemSelector (in category 'accessing') ----- + dragItemSelector + ^dragItemSelector! Item was added: + ----- Method: PluggableTreeMorph>>dragItemSelector: (in category 'accessing') ----- + dragItemSelector: aSymbol + dragItemSelector := aSymbol. + aSymbol ifNotNil:[self dragEnabled: true].! Item was added: + ----- Method: PluggableTreeMorph>>dropItemSelector (in category 'accessing') ----- + dropItemSelector + ^dropItemSelector! Item was added: + ----- Method: PluggableTreeMorph>>dropItemSelector: (in category 'accessing') ----- + dropItemSelector: aSymbol + dropItemSelector := aSymbol. + aSymbol ifNotNil:[self dropEnabled: true].! Item was added: + ----- Method: PluggableTreeMorph>>dropNode:on: (in category 'node access') ----- + dropNode: srcNode on: dstNode + dropItemSelector ifNil:[^nil]. + model perform: dropItemSelector with: srcNode item with: dstNode item! Item was added: + ----- Method: PluggableTreeMorph>>getChildrenSelector (in category 'accessing') ----- + getChildrenSelector + ^getChildrenSelector! Item was added: + ----- Method: PluggableTreeMorph>>getChildrenSelector: (in category 'accessing') ----- + getChildrenSelector: aSymbol + getChildrenSelector := aSymbol.! Item was added: + ----- Method: PluggableTreeMorph>>getHelpSelector (in category 'accessing') ----- + getHelpSelector + ^getHelpSelector! Item was added: + ----- Method: PluggableTreeMorph>>getHelpSelector: (in category 'accessing') ----- + getHelpSelector: aSymbol + getHelpSelector := aSymbol! Item was added: + ----- Method: PluggableTreeMorph>>getIconSelector (in category 'accessing') ----- + getIconSelector + ^getIconSelector! Item was added: + ----- Method: PluggableTreeMorph>>getIconSelector: (in category 'accessing') ----- + getIconSelector: aSymbol + getIconSelector := aSymbol! Item was added: + ----- Method: PluggableTreeMorph>>getLabelSelector (in category 'accessing') ----- + getLabelSelector + ^getLabelSelector! Item was added: + ----- Method: PluggableTreeMorph>>getLabelSelector: (in category 'accessing') ----- + getLabelSelector: aSymbol + getLabelSelector := aSymbol! Item was added: + ----- Method: PluggableTreeMorph>>getMenuSelector (in category 'accessing') ----- + getMenuSelector + ^getMenuSelector! Item was added: + ----- Method: PluggableTreeMorph>>getMenuSelector: (in category 'accessing') ----- + getMenuSelector: aSymbol + getMenuSelector := aSymbol! Item was added: + ----- Method: PluggableTreeMorph>>getRootsSelector (in category 'accessing') ----- + getRootsSelector + ^getRootsSelector! Item was added: + ----- Method: PluggableTreeMorph>>getRootsSelector: (in category 'accessing') ----- + getRootsSelector: aSelector + getRootsSelector := aSelector. + self update: getRootsSelector.! Item was added: + ----- Method: PluggableTreeMorph>>getSelectedPathSelector (in category 'accessing') ----- + getSelectedPathSelector + ^getSelectedPathSelector! Item was added: + ----- Method: PluggableTreeMorph>>getSelectedPathSelector: (in category 'accessing') ----- + getSelectedPathSelector: aSymbol + getSelectedPathSelector := aSymbol.! Item was added: + ----- Method: PluggableTreeMorph>>hasChildrenSelector (in category 'accessing') ----- + hasChildrenSelector + ^hasChildrenSelector! Item was added: + ----- Method: PluggableTreeMorph>>hasChildrenSelector: (in category 'accessing') ----- + hasChildrenSelector: aSymbol + hasChildrenSelector := aSymbol! Item was added: + ----- Method: PluggableTreeMorph>>hasNodeContents: (in category 'node access') ----- + hasNodeContents: node + hasChildrenSelector ifNil:[^node contents isEmpty not]. + ^model perform: hasChildrenSelector with: node item! Item was added: + ----- Method: PluggableTreeMorph>>iconOfNode: (in category 'node access') ----- + iconOfNode: node + getIconSelector ifNil:[^nil]. + ^model perform: getIconSelector with: node item! Item was added: + ----- Method: PluggableTreeMorph>>isDraggableNode: (in category 'node access') ----- + isDraggableNode: node + ^true! Item was added: + ----- Method: PluggableTreeMorph>>keystrokeActionSelector (in category 'accessing') ----- + keystrokeActionSelector + ^keystrokeActionSelector! Item was added: + ----- Method: PluggableTreeMorph>>keystrokeActionSelector: (in category 'accessing') ----- + keystrokeActionSelector: aSymbol + keystrokeActionSelector := aSymbol! Item was added: + ----- Method: PluggableTreeMorph>>printNode: (in category 'node access') ----- + printNode: node + getLabelSelector ifNil:[^node item printString]. + ^model perform: getLabelSelector with: node item! Item was added: + ----- Method: PluggableTreeMorph>>roots (in category 'accessing') ----- + roots + ^roots! Item was added: + ----- Method: PluggableTreeMorph>>roots: (in category 'accessing') ----- + roots: anArray + roots := anArray collect:[:item| PluggableTreeItemNode with: item model: self]. + self list: roots.! Item was added: + ----- Method: PluggableTreeMorph>>selectPath:in: (in category 'updating') ----- + selectPath: path in: listItem + path isEmpty ifTrue: [^self setSelectedMorph: nil]. + listItem withSiblingsDo: [:each | + (each complexContents item = path first) ifTrue: [ + each isExpanded ifFalse: [ + each toggleExpandedState. + self adjustSubmorphPositions. + ]. + each changed. + path size = 1 ifTrue: [ + ^self setSelectedMorph: each + ]. + each firstChild ifNil: [^self setSelectedMorph: nil]. + ^self selectPath: path allButFirst in: each firstChild + ]. + ]. + ^self setSelectedMorph: nil + + ! Item was added: + ----- Method: PluggableTreeMorph>>setSelectedMorph: (in category 'selection') ----- + setSelectedMorph: aMorph + selectedWrapper := aMorph complexContents. + self selection: selectedWrapper. + setSelectedSelector ifNotNil:[ + model + perform: setSelectedSelector + with: (selectedWrapper ifNotNil:[selectedWrapper item]). + ].! Item was added: + ----- Method: PluggableTreeMorph>>setSelectedSelector (in category 'accessing') ----- + setSelectedSelector + ^setSelectedSelector! Item was added: + ----- Method: PluggableTreeMorph>>setSelectedSelector: (in category 'accessing') ----- + setSelectedSelector: aSymbol + setSelectedSelector := aSymbol! Item was added: + ----- Method: PluggableTreeMorph>>startDrag: (in category 'morphic') ----- + startDrag: evt + | ddm itemMorph passenger | + self dragEnabled + ifTrue: [itemMorph := scroller submorphs + detect: [:any | any highlightedForMouseDown] + ifNone: []]. + (itemMorph isNil + or: [evt hand hasSubmorphs]) + ifTrue: [^ self]. + itemMorph highlightForMouseDown: false. + itemMorph ~= self selectedMorph + ifTrue: [self setSelectedMorph: itemMorph]. + passenger := self model perform: dragItemSelector with: itemMorph withoutListWrapper. + passenger + ifNotNil: [ddm := TransferMorph withPassenger: passenger from: self. + ddm dragTransferType: #dragTransferPlus. + Preferences dragNDropWithAnimation + ifTrue: [self model dragAnimationFor: itemMorph transferMorph: ddm]. + evt hand grabMorph: ddm]. + evt hand releaseMouseFocus: self! Item was added: + ----- Method: PluggableTreeMorph>>update: (in category 'updating') ----- + update: what + what ifNil:[^self]. + what == getRootsSelector ifTrue:[ + self roots: (model perform: getRootsSelector) + ]. + what == getSelectedPathSelector ifTrue:[ + ^self selectPath: (model perform: getSelectedPathSelector) + in: (scroller submorphs at: 1 ifAbsent: [^self]) + ]. + ^super update: what! Item was added: + ----- Method: PluggableTreeMorph>>wantsDropSelector (in category 'accessing') ----- + wantsDropSelector + ^wantsDropSelector! Item was added: + ----- Method: PluggableTreeMorph>>wantsDropSelector: (in category 'accessing') ----- + wantsDropSelector: aSymbol + wantsDropSelector := aSymbol! Item was added: + ----- Method: PluggableTreeMorph>>wantsDroppedMorph:event: (in category 'morphic') ----- + wantsDroppedMorph: aMorph event: anEvent + aMorph dragTransferType == #dragTransferPlus ifFalse:[^false]. + dropItemSelector ifNil:[^false]. + wantsDropSelector ifNil:[^true]. + ^ (model perform: wantsDropSelector with: aMorph passenger) == true.! Item was added: + ----- Method: PluggableTreeMorph>>wantsDroppedNode:on: (in category 'node access') ----- + wantsDroppedNode: srcNode on: dstNode + dropItemSelector ifNil:[^false]. + wantsDropSelector ifNil:[^true]. + ^(model perform: wantsDropSelector with: srcNode with: dstNode) == true!

1 0

The Trunk: Morphic-fbs.653.mcz
by commits＠source.squeak.org 31 May '13

31 May '13

1 0

The Trunk: Morphic-fbs.653.mcz
by commits＠source.squeak.org 31 May '13

31 May '13

1 0

The Trunk: ToolBuilder-Morphic-fbs.90.mcz
by commits＠source.squeak.org 31 May '13

31 May '13

Frank Shearar uploaded a new version of ToolBuilder-Morphic to project The Trunk: http://source.squeak.org/trunk/ToolBuilder-Morphic-fbs.90.mcz ==================== Summary ==================== Name: ToolBuilder-Morphic-fbs.90 Author: fbs Time: 31 May 2013, 4:00:00.398 pm UUID: b06416ef-714b-41ee-b6a1-90ddf0c305be Ancestors: ToolBuilder-Morphic-ul.89 Move ToolBuilder-Morphic to Morphic-ToolBuilder. =============== Diff against ToolBuilder-Morphic-ul.89 =============== Item was removed: - SystemOrganization addCategory: #'ToolBuilder-Morphic'! Item was removed: - Object subclass: #ListChooser - instanceVariableNames: 'window fullList selectedItems searchText searchMorph title listMorph index realIndex buttonBar builder addAllowed result' - classVariableNames: '' - poolDictionaries: '' - category: 'ToolBuilder-Morphic'! - - !ListChooser commentStamp: 'MAD 3/14/2010 16:20' prior: 0! - I am a simple dialog to allow the user to pick from a list of strings or symbols. - I support keyboard and mouse navigation, and interactive filtering of the displayed items. - - You can specify whether you want the index, or the value of the selected item. If you're interested in the value, you can also allow users to Add a new value not in the list. - - cmd-s or <enter> or double-click answers the currently selected item's value/index; - cmd-l or <escape> or closing the window answers nil/zero. - - Now using ToolBuilder, so needs Morphic-MAD.381. - - Released under the MIT Licence.! Item was removed: - ----- Method: ListChooser class>>chooseFrom: (in category 'ChooserTool compatibility') ----- - chooseFrom: aList - ^ self - chooseFrom: aList - title: self defaultTitle! Item was removed: - ----- Method: ListChooser class>>chooseFrom:title: (in category 'ChooserTool compatibility') ----- - chooseFrom: aList title: aString - ^ self - chooseIndexFrom: aList - title: aString - addAllowed: false! Item was removed: - ----- Method: ListChooser class>>chooseIndexFrom: (in category 'instance creation') ----- - chooseIndexFrom: aList - ^ self - chooseIndexFrom: aList - title: self defaultTitle! Item was removed: - ----- Method: ListChooser class>>chooseIndexFrom:title: (in category 'instance creation') ----- - chooseIndexFrom: aList title: aString - ^ self - chooseIndexFrom: aList - title: (aString isEmptyOrNil ifTrue: [ self defaultTitle ] ifFalse: [ aString ]) - addAllowed: false! Item was removed: - ----- Method: ListChooser class>>chooseIndexFrom:title:addAllowed: (in category 'instance creation') ----- - chooseIndexFrom: aList title: aString addAllowed: aBoolean - ^ self new - chooseIndexFrom: aList - title: (aString isEmptyOrNil ifTrue: [ self defaultTitle ] ifFalse: [ aString ]) - addAllowed: aBoolean! Item was removed: - ----- Method: ListChooser class>>chooseItemFrom: (in category 'instance creation') ----- - chooseItemFrom: aList - ^ self - chooseItemFrom: aList - title: self defaultTitle! Item was removed: - ----- Method: ListChooser class>>chooseItemFrom:title: (in category 'instance creation') ----- - chooseItemFrom: aList title: aString - ^ self - chooseItemFrom: aList - title: aString - addAllowed: false! Item was removed: - ----- Method: ListChooser class>>chooseItemFrom:title:addAllowed: (in category 'instance creation') ----- - chooseItemFrom: aList title: aString addAllowed: aBoolean - ^ self new - chooseItemFrom: aList - title: (aString isEmptyOrNil ifTrue: [ self defaultTitle ] ifFalse: [ aString ]) - addAllowed: aBoolean! Item was removed: - ----- Method: ListChooser class>>defaultTitle (in category 'instance creation') ----- - defaultTitle - ^ 'Please choose:'! Item was removed: - ----- Method: ListChooser class>>testDictionary (in category 'examples') ----- - testDictionary - ^ self - chooseItemFrom: (Dictionary newFrom: {#a->1. 2->#b.}) - title: 'Pick from Dictionary' "gives values, not keys"! Item was removed: - ----- Method: ListChooser class>>testIndex (in category 'examples') ----- - testIndex - ^ self - chooseIndexFrom: (Smalltalk classNames , Smalltalk traitNames) asOrderedCollection - title: 'Pick a class'! Item was removed: - ----- Method: ListChooser class>>testItem (in category 'examples') ----- - testItem - ^ self - chooseItemFrom: (Smalltalk classNames , Smalltalk traitNames) asOrderedCollection - title: 'Pick a class'! Item was removed: - ----- Method: ListChooser class>>testItemAdd (in category 'examples') ----- - testItemAdd - ^ self - chooseItemFrom: (Smalltalk classNames , Smalltalk traitNames) asOrderedCollection - title: 'Pick or Add:' - addAllowed: true! Item was removed: - ----- Method: ListChooser class>>testLongTitle (in category 'examples') ----- - testLongTitle - ^ self - chooseItemFrom: #(this is a list of values that aren/t the point here) - title: 'Pick from some values from this list'! Item was removed: - ----- Method: ListChooser class>>testSet (in category 'examples') ----- - testSet - ^ self - chooseItemFrom: #(a list of values as a Set) asSet - title: 'Pick from Set'! Item was removed: - ----- Method: ListChooser>>accept (in category 'event handling') ----- - accept - "if the user submits with no valid entry, make them start over" - self canAccept ifFalse: [ - searchMorph selectAll. - ^ self ]. - - "find the selected item in the original list, and return it" - result := selectedItems at: index. - - builder ifNotNil: [ :bldr | - builder := nil. - bldr close: window ]! Item was removed: - ----- Method: ListChooser>>acceptColor (in category 'drawing') ----- - acceptColor - ^ self canAccept - ifTrue: [ ColorTheme current okColor ] - ifFalse: [ Color lightGray "ColorTheme current disabledColor <- you don't have this!!" ]! Item was removed: - ----- Method: ListChooser>>acceptText: (in category 'event handling') ----- - acceptText: someText - "the text morph wants to tell us about its contents but I don't care, I'm only interested in the list" - self accept! Item was removed: - ----- Method: ListChooser>>add (in category 'event handling') ----- - add - "if the user submits with no valid entry, make them start over" - self canAdd ifFalse: [ - searchMorph selectAll. - ^ self ]. - - "find the string to return" - result := searchMorph getText. - - builder ifNotNil: [ :bldr | - builder := nil. - bldr close: window ]! Item was removed: - ----- Method: ListChooser>>buildButtonBarWith: (in category 'building') ----- - buildButtonBarWith: builder - | panel button | - panel := builder pluggablePanelSpec new - model: self; - layout: #proportional; - children: OrderedCollection new. - button := builder pluggableButtonSpec new. - button - model: self; - label: 'Accept (s)'; - action: #accept; - enabled: #canAccept; - state: #canAccept; - color: #acceptColor; - frame: (0.0 @ 0.0 corner: 0.34@1). - panel children add: button. - - button := builder pluggableButtonSpec new. - button - model: self; - label: 'Add (a)'; - action: #add; - enabled: #canAdd; - frame: (0.36 @ 0.0 corner: 0.63@1). - panel children add: button. - - button := builder pluggableButtonSpec new. - button - model: self; - label: 'Cancel (l)'; - action: #cancel; - color: #cancelColor; - frame: (0.65 @ 0.0 corner: 1@1). - panel children add: button. - - ^ panel! Item was removed: - ----- Method: ListChooser>>buildListMorphWith: (in category 'building') ----- - buildListMorphWith: builder - | listSpec | - listSpec := builder pluggableListSpec new. - listSpec - model: self; - list: #list; - getIndex: #selectedIndex; - setIndex: #selectedIndex:; - doubleClick: #accept; - "handleBasicKeys: false;" - keystrokePreview: #keyStrokeFromList:; - "doubleClickSelector: #accept;" - autoDeselect: false. - ^ listSpec! Item was removed: - ----- Method: ListChooser>>buildSearchMorphWith: (in category 'building') ----- - buildSearchMorphWith: builder - | fieldSpec | - fieldSpec := builder pluggableInputFieldSpec new. - fieldSpec - model: self; - getText: #searchText; - setText: #acceptText:; - menu: nil. - "hideScrollBarsIndefinitely;" - "acceptOnCR: true;" - "setBalloonText: 'Type a string to filter down the listed items'." - "onKeyStrokeSend: #keyStroke: to: self." - ^ fieldSpec! Item was removed: - ----- Method: ListChooser>>buildWindowWith: (in category 'building') ----- - buildWindowWith: builder - | windowSpec | - windowSpec := builder pluggableWindowSpec new. - windowSpec model: self. - windowSpec label: #title. - windowSpec children: OrderedCollection new. - ^windowSpec! Item was removed: - ----- Method: ListChooser>>buildWindowWith:specs: (in category 'building') ----- - buildWindowWith: builder specs: specs - | windowSpec | - windowSpec := self buildWindowWith: builder. - specs do: [ :assoc | - | rect action widgetSpec | - rect := assoc key. - action := assoc value. - widgetSpec := action value. - widgetSpec ifNotNil:[ - widgetSpec frame: rect. - windowSpec children add: widgetSpec ] ]. - ^ windowSpec! Item was removed: - ----- Method: ListChooser>>buildWith: (in category 'building') ----- - buildWith: aBuilder - | windowSpec | - builder := aBuilder. - windowSpec := self buildWindowWith: builder specs: { - (0@0 corner: 1(a)0.05) -> [self buildSearchMorphWith: builder]. - (0(a)0.05 corner: 1(a)0.9) -> [self buildListMorphWith: builder]. - (0(a)0.9 corner: 1@1) -> [self buildButtonBarWith: builder]. - }. - windowSpec closeAction: #closed. - windowSpec extent: self initialExtent. - window := builder build: windowSpec. - - - searchMorph := window submorphs detect: - [ :each | each isKindOf: PluggableTextMorph ]. - searchMorph - hideScrollBarsIndefinitely; - acceptOnCR: true; - setBalloonText: 'Type a string to filter down the listed items'; - onKeyStrokeSend: #keyStroke: to: self; - hasUnacceptedEdits: true "force acceptOnCR to work even with no text entered". - listMorph := window submorphs detect: - [ :each | each isKindOf: PluggableListMorph ]. - ^ window! Item was removed: - ----- Method: ListChooser>>canAccept (in category 'testing') ----- - canAccept - ^ self selectedIndex > 0! Item was removed: - ----- Method: ListChooser>>canAdd (in category 'testing') ----- - canAdd - ^ addAllowed and: [ self canAccept not ]! Item was removed: - ----- Method: ListChooser>>cancel (in category 'event handling') ----- - cancel - "Cancel the dialog and move on" - index := 0. - builder ifNotNil: [ builder close: window ]! Item was removed: - ----- Method: ListChooser>>cancelColor (in category 'drawing') ----- - cancelColor - ^ ColorTheme current cancelColor! Item was removed: - ----- Method: ListChooser>>chooseIndexFrom:title: (in category 'initialize-release') ----- - chooseIndexFrom: labelList title: aString - | choice | - choice := self chooseItemFrom: labelList title: aString addAllowed: false. - ^ fullList indexOf: choice ifAbsent: 0! Item was removed: - ----- Method: ListChooser>>chooseIndexFrom:title:addAllowed: (in category 'initialize-release') ----- - chooseIndexFrom: labelList title: aString addAllowed: aBoolean - | choice | - choice := self chooseItemFrom: labelList title: aString addAllowed: false. - addAllowed := aBoolean. - ^ fullList indexOf: choice ifAbsent: 0! Item was removed: - ----- Method: ListChooser>>chooseItemFrom:title:addAllowed: (in category 'initialize-release') ----- - chooseItemFrom: labelList title: aString addAllowed: aBoolean - fullList := labelList asOrderedCollection. "coerce everything into an OC" - builder := ToolBuilder default. - self list: fullList. - self title: aString. - addAllowed := aBoolean. - window := ToolBuilder default open: self. - window center: Sensor cursorPoint. - window setConstrainedPosition: (Sensor cursorPoint - (window fullBounds extent // 2)) hangOut: false. - builder runModal: window. - ^ result! Item was removed: - ----- Method: ListChooser>>closed (in category 'event handling') ----- - closed - "Cancel the dialog and move on" - builder ifNotNil: [ index := 0 ]! Item was removed: - ----- Method: ListChooser>>handlesKeyboard: (in category 'event handling') ----- - handlesKeyboard: evt - ^ true! Item was removed: - ----- Method: ListChooser>>initialExtent (in category 'building') ----- - initialExtent - | listFont titleFont buttonFont listWidth titleWidth buttonWidth | - listFont := Preferences standardListFont. - titleFont := Preferences windowTitleFont. - buttonFont := Preferences standardButtonFont. - listWidth := 20 * (listFont widthOf: $m). - titleWidth := titleFont widthOfString: self title, '__________'. "add some space for titlebar icons" - buttonWidth := buttonFont widthOfString: '_Accept_(s)___Add (a)___Cancel_(l)_'. - ^ (listWidth max: (titleWidth max: buttonWidth))@(30 * (listFont height))! Item was removed: - ----- Method: ListChooser>>keyStroke: (in category 'event handling') ----- - keyStroke: event - | newText key | - "handle updates to the search box interactively" - key := event keyString. - (key = '<up>') ifTrue: [ - self move: -1. - ^ self ]. - (key = '<down>') ifTrue: [ - self move: 1. - ^ self ]. - - (key = '<Cmd-s>') ifTrue: [ self accept. ^ self ]. - (key = '<cr>') ifTrue: [ self accept. ^ self ]. - - (key = '<escape>') ifTrue: [ self cancel. ^ self ]. - (key = '<Cmd-l>') ifTrue: [ self cancel. ^ self ]. - - (key = '<Cmd-a>') ifTrue: [ self add. ^ self ]. - - "pull out what's been typed, and update the list as required" - newText := searchMorph textMorph asText asString. - (newText = searchText) ifFalse: [ - searchText := newText. - self updateFilter ]. - ! Item was removed: - ----- Method: ListChooser>>keyStrokeFromList: (in category 'event handling') ----- - keyStrokeFromList: event - "we don't want the list to be picking up events, excepting scroll events" - - "Don't sent ctrl-up/ctrl-down events to the searchMorph: they're scrolling events." - (#(30 31) contains: [:each | each = event keyValue]) not - ifTrue: - ["window world primaryHand keyboardFocus: searchMorph." - searchMorph keyStroke: event. - "let the list know we've dealt with it" - ^true]. - ^false. - ! Item was removed: - ----- Method: ListChooser>>list (in category 'accessing') ----- - list - ^ selectedItems! Item was removed: - ----- Method: ListChooser>>list: (in category 'accessing') ----- - list: items - fullList := items. - selectedItems := items. - self changed: #itemList.! Item was removed: - ----- Method: ListChooser>>list:title: (in category 'accessing') ----- - list: aList title: aString - self list: aList. - self title: aString! Item was removed: - ----- Method: ListChooser>>move: (in category 'event handling') ----- - move: offset - | newindex | - "The up arrow key moves the cursor, and it seems impossible to restore. - So, for consistency, on either arrow, select everything, so a new letter-press starts over. yuk." - searchMorph selectAll. - - newindex := self selectedIndex + offset. - newindex > selectedItems size ifTrue: [ ^ nil ]. - newindex < 1 ifTrue: [ ^ nil ]. - self selectedIndex: newindex. - ! Item was removed: - ----- Method: ListChooser>>moveWindowNear: (in category 'drawing') ----- - moveWindowNear: aPoint - | trialRect delta | - trialRect := Rectangle center: aPoint extent: window fullBounds extent. - delta := trialRect amountToTranslateWithin: World bounds. - window position: trialRect origin + delta.! Item was removed: - ----- Method: ListChooser>>realIndex (in category 'accessing') ----- - realIndex - ^ realIndex ifNil: [ 0 ]! Item was removed: - ----- Method: ListChooser>>searchText (in category 'accessing') ----- - searchText - ^ searchText ifNil: [ searchText := '' ]! Item was removed: - ----- Method: ListChooser>>searchText: (in category 'accessing') ----- - searchText: aString - searchText := aString! Item was removed: - ----- Method: ListChooser>>selectedIndex (in category 'accessing') ----- - selectedIndex - ^ index ifNil: [ index := 1 ]! Item was removed: - ----- Method: ListChooser>>selectedIndex: (in category 'accessing') ----- - selectedIndex: anInt - index := (anInt min: selectedItems size). - self changed: #selectedIndex. - self changed: #canAccept.! Item was removed: - ----- Method: ListChooser>>title (in category 'accessing') ----- - title - ^ title ifNil: [ title := 'Please choose' ]! Item was removed: - ----- Method: ListChooser>>title: (in category 'accessing') ----- - title: aString - title := aString.! Item was removed: - ----- Method: ListChooser>>updateFilter (in category 'event handling') ----- - updateFilter - - selectedItems := - searchText isEmptyOrNil - ifTrue: [ fullList ] - ifFalse: [ | pattern patternMatches prefixMatches | - pattern := (searchText includes: $*) - ifTrue: [ searchText ] - ifFalse: [ '*', searchText, '*' ]. - patternMatches := fullList select: [:s | pattern match: s ]. - prefixMatches := OrderedCollection new: patternMatches size. - patternMatches removeAllSuchThat: [ :each | - (each findString: searchText startingAt: 1 caseSensitive: false) = 1 - and: [ - prefixMatches add: each. - true ] ]. - prefixMatches addAllLast: patternMatches; yourself]. - self changed: #list. - self selectedIndex: 1. - self changed: #selectedIndex.! Item was removed: - ToolBuilder subclass: #MorphicToolBuilder - instanceVariableNames: 'widgets panes parentMenu' - classVariableNames: '' - poolDictionaries: '' - category: 'ToolBuilder-Morphic'! - - !MorphicToolBuilder commentStamp: 'ar 2/11/2005 15:02' prior: 0! - The Morphic tool builder.! Item was removed: - ----- Method: MorphicToolBuilder class>>isActiveBuilder (in category 'accessing') ----- - isActiveBuilder - "Answer whether I am the currently active builder" - ^Smalltalk isMorphic! Item was removed: - ----- Method: MorphicToolBuilder>>add:to: (in category 'private') ----- - add: aMorph to: aParent - aParent addMorphBack: aMorph. - aParent isSystemWindow ifTrue:[ - aParent addPaneMorph: aMorph. - ].! Item was removed: - ----- Method: MorphicToolBuilder>>alternateMultiSelectListClass (in category 'widget classes') ----- - alternateMultiSelectListClass - ^ AlternatePluggableListMorphOfMany ! Item was removed: - ----- Method: MorphicToolBuilder>>asFrame: (in category 'private') ----- - asFrame: aRectangle - | frame | - aRectangle ifNil:[^nil]. - frame := LayoutFrame new. - frame - leftFraction: aRectangle left; - rightFraction: aRectangle right; - topFraction: aRectangle top; - bottomFraction: aRectangle bottom. - ^frame! Item was removed: - ----- Method: MorphicToolBuilder>>buildHelpFor:spec: (in category 'pluggable widgets') ----- - buildHelpFor: widget spec: aSpec - aSpec help - ifNotNil: [widget setBalloonText: aSpec help]! Item was removed: - ----- Method: MorphicToolBuilder>>buildPluggableActionButton: (in category 'pluggable widgets') ----- - buildPluggableActionButton: aSpec - | button | - button := self buildPluggableButton: aSpec. - button color: Color white. - ^button! Item was removed: - ----- Method: MorphicToolBuilder>>buildPluggableAlternateMultiSelectionList: (in category 'pluggable widgets') ----- - buildPluggableAlternateMultiSelectionList: aSpec - | listMorph listClass | - aSpec getSelected ifNotNil: [ ^ self error: 'There is no PluggableAlternateListMorphOfManyByItem' ]. - listClass := self alternateMultiSelectListClass. - listMorph := listClass - on: aSpec model - list: aSpec list - primarySelection: aSpec getIndex - changePrimarySelection: aSpec setIndex - listSelection: aSpec getSelectionList - changeListSelection: aSpec setSelectionList - menu: aSpec menu. - listMorph - setProperty: #highlightSelector toValue: #highlightMessageList:with: ; - setProperty: #itemConversionMethod toValue: #asStringOrText ; - setProperty: #balloonTextSelectorForSubMorphs toValue: #balloonTextForClassAndMethodString ; - enableDragNDrop: Preferences browseWithDragNDrop ; - menuTitleSelector: #messageListSelectorTitle. - self - register: listMorph - id: aSpec name. - listMorph - keystrokeActionSelector: aSpec keyPress ; - getListElementSelector: aSpec listItem ; - getListSizeSelector: aSpec listSize. - self - buildHelpFor: listMorph - spec: aSpec. - self - setFrame: aSpec frame - in: listMorph. - parent ifNotNil: [ self add: listMorph to: parent ]. - panes ifNotNil: [ aSpec list ifNotNil:[panes add: aSpec list ] ]. - ^ listMorph! Item was removed: - ----- Method: MorphicToolBuilder>>buildPluggableButton: (in category 'pluggable widgets') ----- - buildPluggableButton: aSpec - | widget label state action enabled | - label := aSpec label. - state := aSpec state. - action := aSpec action. - widget := self buttonClass on: aSpec model - getState: (state isSymbol ifTrue:[state]) - action: nil - label: (label isSymbol ifTrue:[label]). - widget style: aSpec style. - aSpec changeLabelWhen - ifNotNilDo: [ :event | widget whenChanged: event update: aSpec label]. - self register: widget id: aSpec name. - enabled := aSpec enabled. - enabled isSymbol - ifTrue:[widget getEnabledSelector: enabled] - ifFalse:[widget enabled:enabled]. - widget action: action. - widget getColorSelector: aSpec color. - widget offColor: Color white.. - self buildHelpFor: widget spec: aSpec. - (label isSymbol or:[label == nil]) ifFalse:[widget label: label]. - self setFrame: aSpec frame in: widget. - parent ifNotNil:[self add: widget to: parent]. - ^widget! Item was removed: - ----- Method: MorphicToolBuilder>>buildPluggableCheckBox: (in category 'pluggable widgets') ----- - buildPluggableCheckBox: spec - - | widget label state action | - label := spec label. - state := spec state. - action := spec action. - widget := self checkBoxClass on: spec model - getState: (state isSymbol ifTrue:[state]) - action: (action isSymbol ifTrue:[action]) - label: (label isSymbol ifTrue:[label]). - self register: widget id: spec name. - - widget installButton. - " widget getColorSelector: spec color. - widget offColor: Color white.. - self buildHelpFor: widget spec: spec. - (label isSymbol or:[label == nil]) ifFalse:[widget label: label]. - " self setFrame: spec frame in: widget. - parent ifNotNil:[self add: widget to: parent]. - ^widget! Item was removed: - ----- Method: MorphicToolBuilder>>buildPluggableCodePane: (in category 'pluggable widgets') ----- - buildPluggableCodePane: aSpec - "Install the default styler for code panes. - Implementation note: We should just be doing something like, e.g., - ^(self buildPluggableText: aSpec) useDefaultStyler - Unfortunately, this will retrieve and layout the initial text twice which - can make for a noticable performance difference when looking at some - larger piece of code. So instead we copy the implementation from - buildPlugggableText: here and insert #useDefaultStyler at the right point" - | widget | - widget := self codePaneClass new. - widget useDefaultStyler. - widget on: aSpec model - text: aSpec getText - accept: aSpec setText - readSelection: aSpec selection - menu: aSpec menu. - widget font: Preferences standardCodeFont. - self register: widget id: aSpec name. - widget getColorSelector: aSpec color. - self setFrame: aSpec frame in: widget. - parent ifNotNil:[self add: widget to: parent]. - widget borderColor: Color lightGray. - widget color: Color white. - ^widget! Item was removed: - ----- Method: MorphicToolBuilder>>buildPluggableDropDownList: (in category 'pluggable widgets') ----- - buildPluggableDropDownList: spec - - | widget model listSelector selectionSelector selectionSetter | - model := spec model. - listSelector := spec listSelector. - selectionSelector := spec selectionSelector. - selectionSetter := spec selectionSetter. - widget := self dropDownListClass new - model: model; - listSelector: listSelector; - selectionSelector: selectionSelector; - selectionSetter: selectionSetter; - yourself. - self register: widget id: spec name. - - widget installDropDownList. - self setFrame: spec frame in: widget. - parent ifNotNil:[self add: widget to: parent]. - ^widget! Item was removed: - ----- Method: MorphicToolBuilder>>buildPluggableInputField: (in category 'pluggable widgets') ----- - buildPluggableInputField: aSpec - | widget | - widget := self buildPluggableText: aSpec. - widget acceptOnCR: true. - widget hideScrollBarsIndefinitely. - ^widget! Item was removed: - ----- Method: MorphicToolBuilder>>buildPluggableList: (in category 'pluggable widgets') ----- - buildPluggableList: aSpec - | widget listClass getIndex setIndex | - aSpec getSelected ifNil:[ - listClass := self listClass. - getIndex := aSpec getIndex. - setIndex := aSpec setIndex. - ] ifNotNil:[ - listClass := self listByItemClass. - getIndex := aSpec getSelected. - setIndex := aSpec setSelected. - ]. - widget := listClass on: aSpec model - list: aSpec list - selected: getIndex - changeSelected: setIndex - menu: aSpec menu - keystroke: aSpec keyPress. - self register: widget id: aSpec name. - widget getListElementSelector: aSpec listItem. - widget getListSizeSelector: aSpec listSize. - widget getIconSelector: aSpec icon. - widget doubleClickSelector: aSpec doubleClick. - widget dragItemSelector: aSpec dragItem. - widget dropItemSelector: aSpec dropItem. - widget wantsDropSelector: aSpec dropAccept. - widget autoDeselect: aSpec autoDeselect. - widget keystrokePreviewSelector: aSpec keystrokePreview. - aSpec color isNil - ifTrue: [widget - borderWidth: 1; - borderColor: Color lightGray; - color: Color white] - ifFalse: [widget color: aSpec color]. - self buildHelpFor: widget spec: aSpec. - self setFrame: aSpec frame in: widget. - parent ifNotNil:[self add: widget to: parent]. - panes ifNotNil:[ - aSpec list ifNotNil:[panes add: aSpec list]. - ]. - ^widget! Item was removed: - ----- Method: MorphicToolBuilder>>buildPluggableMenu: (in category 'building') ----- - buildPluggableMenu: menuSpec - | prior menu | - prior := parentMenu. - parentMenu := menu := self menuClass new. - menuSpec label ifNotNil:[parentMenu addTitle: menuSpec label]. - menuSpec items do:[:each| each buildWith: self]. - parentMenu := prior. - ^menu! Item was removed: - ----- Method: MorphicToolBuilder>>buildPluggableMenuItem: (in category 'building') ----- - buildPluggableMenuItem: itemSpec - | item action label menu | - item := self menuItemClass new. - label := itemSpec label. - itemSpec checked ifTrue:[label := '<on>', label] ifFalse:[label := '<off>', label]. - item contents: label. - item isEnabled: itemSpec enabled. - (action := itemSpec action) ifNotNil:[ - item - target: action receiver; - selector: action selector; - arguments: action arguments. - ]. - (menu := itemSpec subMenu) ifNotNil:[ - item subMenu: (menu buildWith: self). - ]. - parentMenu ifNotNil:[parentMenu addMorphBack: item]. - itemSpec separator ifTrue:[parentMenu addLine]. - ^item! Item was removed: - ----- Method: MorphicToolBuilder>>buildPluggableMultiSelectionList: (in category 'pluggable widgets') ----- - buildPluggableMultiSelectionList: aSpec - | widget listClass | - aSpec getSelected ifNotNil:[^self error:'There is no PluggableListMorphOfManyByItem']. - listClass := self multiSelectListClass. - widget := listClass on: aSpec model - list: aSpec list - primarySelection: aSpec getIndex - changePrimarySelection: aSpec setIndex - listSelection: aSpec getSelectionList - changeListSelection: aSpec setSelectionList - menu: aSpec menu. - self register: widget id: aSpec name. - widget keystrokeActionSelector: aSpec keyPress. - widget getListElementSelector: aSpec listItem. - widget getListSizeSelector: aSpec listSize. - self buildHelpFor: widget spec: aSpec. - self setFrame: aSpec frame in: widget. - parent ifNotNil:[self add: widget to: parent]. - panes ifNotNil:[ - aSpec list ifNotNil:[panes add: aSpec list]. - ]. - ^widget! Item was removed: - ----- Method: MorphicToolBuilder>>buildPluggablePanel: (in category 'pluggable widgets') ----- - buildPluggablePanel: aSpec - | widget children frame | - widget := self panelClass new. - self register: widget id: aSpec name. - widget model: aSpec model. - widget color: Color transparent. - widget clipSubmorphs: true. - children := aSpec children. - children isSymbol ifTrue:[ - widget getChildrenSelector: children. - widget update: children. - children := #(). - ]. - self buildAll: children in: widget. - self buildHelpFor: widget spec: aSpec. - self setFrame: aSpec frame in: widget. - parent ifNotNil:[self add: widget to: parent]. - self setLayout: aSpec layout in: widget. - widget layoutInset: 0. - widget borderWidth: 0. - widget submorphsDo:[:sm| - (frame := sm layoutFrame) ifNotNil:[ - (frame rightFraction = 0 or:[frame rightFraction = 1]) - ifFalse:[frame rightOffset:1]. - (frame bottomFraction = 0 or:[frame bottomFraction = 1]) - ifFalse:[frame bottomOffset: 1]]]. - widget color: Color transparent. - ^widget! Item was removed: - ----- Method: MorphicToolBuilder>>buildPluggableText: (in category 'pluggable widgets') ----- - buildPluggableText: aSpec - | widget | - widget := self textPaneClass on: aSpec model - text: aSpec getText - accept: aSpec setText - readSelection: aSpec selection - menu: aSpec menu. - widget askBeforeDiscardingEdits: aSpec askBeforeDiscardingEdits. - widget font: Preferences standardCodeFont. - self register: widget id: aSpec name. - widget getColorSelector: aSpec color. - self buildHelpFor: widget spec: aSpec. - self setFrame: aSpec frame in: widget. - parent ifNotNil:[self add: widget to: parent]. - widget borderColor: Color lightGray. - widget color: Color white. - ^widget! Item was removed: - ----- Method: MorphicToolBuilder>>buildPluggableTree: (in category 'pluggable widgets') ----- - buildPluggableTree: aSpec - | widget | - widget := self treeClass new. - self register: widget id: aSpec name. - widget model: aSpec model. - widget getSelectedPathSelector: aSpec getSelectedPath. - widget setSelectedSelector: aSpec setSelected. - widget getChildrenSelector: aSpec getChildren. - widget hasChildrenSelector: aSpec hasChildren. - widget getLabelSelector: aSpec label. - widget getIconSelector: aSpec icon. - widget getHelpSelector: aSpec help. - widget getMenuSelector: aSpec menu. - widget keystrokeActionSelector: aSpec keyPress. - widget getRootsSelector: aSpec roots. - widget autoDeselect: aSpec autoDeselect. - widget dropItemSelector: aSpec dropItem. - widget wantsDropSelector: aSpec dropAccept. - widget dragItemSelector: aSpec dragItem. - self setFrame: aSpec frame in: widget. - parent ifNotNil:[self add: widget to: parent]. - " panes ifNotNil:[ - aSpec roots ifNotNil:[panes add: aSpec roots]. - ]. " - ^widget! Item was removed: - ----- Method: MorphicToolBuilder>>buildPluggableWindow: (in category 'pluggable widgets') ----- - buildPluggableWindow: aSpec - | widget children | - aSpec layout == #proportional ifFalse:[ - "This needs to be implemented - probably by adding a single pane and then the rest" - ^self error: 'Not implemented'. - ]. - widget := (self windowClassFor: aSpec) new. - self register: widget id: aSpec name. - widget model: aSpec model. - aSpec label ifNotNil: - [:label| - label isSymbol - ifTrue:[widget getLabelSelector: label] - ifFalse:[widget setLabel: label]]. - aSpec multiWindowStyle notNil ifTrue: - [widget savedMultiWindowState: (SavedMultiWindowState on: aSpec model)]. - children := aSpec children. - children isSymbol ifTrue:[ - widget getChildrenSelector: children. - widget update: children. - children := #(). - ]. - widget closeWindowSelector: aSpec closeAction. - panes := OrderedCollection new. - self buildAll: children in: widget. - self buildHelpFor: widget spec: aSpec. - widget bounds: (RealEstateAgent - initialFrameFor: widget - initialExtent: (aSpec extent ifNil:[widget initialExtent]) - world: self currentWorld). - widget setUpdatablePanesFrom: panes. - ^widget! Item was removed: - ----- Method: MorphicToolBuilder>>buttonClass (in category 'widget classes') ----- - buttonClass - ^ PluggableButtonMorphPlus! Item was removed: - ----- Method: MorphicToolBuilder>>checkBoxClass (in category 'widget classes') ----- - checkBoxClass - ^ PluggableCheckBoxMorph! Item was removed: - ----- Method: MorphicToolBuilder>>close: (in category 'opening') ----- - close: aWidget - "Close a previously opened widget" - aWidget delete! Item was removed: - ----- Method: MorphicToolBuilder>>codePaneClass (in category 'widget classes') ----- - codePaneClass - ^ PluggableTextMorphPlus! Item was removed: - ----- Method: MorphicToolBuilder>>dropDownListClass (in category 'widget classes') ----- - dropDownListClass - ^ PluggableDropDownListMorph! Item was removed: - ----- Method: MorphicToolBuilder>>listByItemClass (in category 'widget classes') ----- - listByItemClass - ^ PluggableListMorphByItemPlus! Item was removed: - ----- Method: MorphicToolBuilder>>listClass (in category 'widget classes') ----- - listClass - ^ PluggableListMorphPlus! Item was removed: - ----- Method: MorphicToolBuilder>>menuClass (in category 'widget classes') ----- - menuClass - ^ MenuMorph! Item was removed: - ----- Method: MorphicToolBuilder>>menuItemClass (in category 'widget classes') ----- - menuItemClass - ^ MenuItemMorph! Item was removed: - ----- Method: MorphicToolBuilder>>multiSelectListClass (in category 'widget classes') ----- - multiSelectListClass - ^ PluggableListMorphOfMany! Item was removed: - ----- Method: MorphicToolBuilder>>open: (in category 'opening') ----- - open: anObject - "Build and open the object. Answer the widget opened." - | morph | - anObject isMorph - ifTrue:[morph := anObject] - ifFalse:[morph := self build: anObject]. - (morph isKindOf: MenuMorph) - ifTrue:[morph popUpInWorld: World]. - (morph isKindOf: SystemWindow) - ifTrue:[morph openInWorldExtent: morph extent] - ifFalse:[morph openInWorld]. - ^morph! Item was removed: - ----- Method: MorphicToolBuilder>>open:label: (in category 'opening') ----- - open: anObject label: aString - "Build an open the object, labeling it appropriately. Answer the widget opened." - | window | - window := self open: anObject. - window setLabel: aString. - ^window! Item was removed: - ----- Method: MorphicToolBuilder>>panelClass (in category 'widget classes') ----- - panelClass - ^ PluggablePanelMorph! Item was removed: - ----- Method: MorphicToolBuilder>>register:id: (in category 'private') ----- - register: widget id: id - id ifNil:[^self]. - widgets ifNil:[widgets := Dictionary new]. - widgets at: id put: widget. - widget setNameTo: id.! Item was removed: - ----- Method: MorphicToolBuilder>>runModal: (in category 'opening') ----- - runModal: aWidget - "Run the (previously opened) widget modally, e.g., - do not return control to the sender before the user has responded." - [aWidget world notNil] whileTrue: [ - aWidget outermostWorldMorph doOneCycle. - ]. - ! Item was removed: - ----- Method: MorphicToolBuilder>>setFrame:in: (in category 'private') ----- - setFrame: aRectangle in: widget - | frame | - aRectangle ifNil:[^nil]. - frame := aRectangle isRectangle - ifTrue: [self asFrame: aRectangle] - ifFalse: [aRectangle]. "assume LayoutFrame" - widget layoutFrame: frame. - widget hResizing: #spaceFill; vResizing: #spaceFill. - (parent isSystemWindow) ifTrue:[ - widget borderWidth: 2; borderColor: #inset. - ].! Item was removed: - ----- Method: MorphicToolBuilder>>setLayout:in: (in category 'private') ----- - setLayout: layout in: widget - layout == #proportional ifTrue:[ - widget layoutPolicy: ProportionalLayout new. - ^self]. - layout == #horizontal ifTrue:[ - widget layoutPolicy: TableLayout new. - widget listDirection: #leftToRight. - widget submorphsDo:[:m| m hResizing: #spaceFill; vResizing: #spaceFill]. - widget cellInset: 1@1. - widget layoutInset: 1@1. - widget color: Color transparent. - "and then some..." - ^self]. - layout == #vertical ifTrue:[ - widget layoutPolicy: TableLayout new. - widget listDirection: #topToBottom. - widget submorphsDo:[:m| m hResizing: #spaceFill; vResizing: #spaceFill]. - widget cellInset: 1@1. - widget layoutInset: 1@1. - widget color: Color transparent. - "and then some..." - ^self]. - ^self error: 'Unknown layout: ', layout.! Item was removed: - ----- Method: MorphicToolBuilder>>textPaneClass (in category 'widget classes') ----- - textPaneClass - ^ PluggableTextMorphPlus! Item was removed: - ----- Method: MorphicToolBuilder>>treeClass (in category 'widget classes') ----- - treeClass - ^ PluggableTreeMorph! Item was removed: - ----- Method: MorphicToolBuilder>>widgetAt:ifAbsent: (in category 'private') ----- - widgetAt: id ifAbsent: aBlock - widgets ifNil:[^aBlock value]. - ^widgets at: id ifAbsent: aBlock! Item was removed: - ----- Method: MorphicToolBuilder>>windowClass (in category 'widget classes') ----- - windowClass - ^ PluggableSystemWindow! Item was removed: - ----- Method: MorphicToolBuilder>>windowClassFor: (in category 'widget classes') ----- - windowClassFor: aSpec - aSpec isDialog ifTrue: [^ PluggableDialogWindow]. - ^aSpec multiWindowStyle - caseOf: - { [nil] -> [PluggableSystemWindow]. - [#labelButton] -> [PluggableSystemWindowWithLabelButton] } - otherwise: [PluggableSystemWindowWithLabelButton]! Item was removed: - ToolBuilderTests subclass: #MorphicToolBuilderTests - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'ToolBuilder-Morphic'! - - !MorphicToolBuilderTests commentStamp: 'ar 2/11/2005 15:02' prior: 0! - Tests for the Morphic tool builder.! Item was removed: - ----- Method: MorphicToolBuilderTests>>acceptWidgetText (in category 'support') ----- - acceptWidgetText - widget hasUnacceptedEdits: true. - widget accept.! Item was removed: - ----- Method: MorphicToolBuilderTests>>buttonWidgetEnabled (in category 'support') ----- - buttonWidgetEnabled - "Answer whether the current widget (a button) is currently enabled" - ^widget enabled! Item was removed: - ----- Method: MorphicToolBuilderTests>>changeListWidget (in category 'support') ----- - changeListWidget - widget changeModelSelection: widget getCurrentSelectionIndex + 1.! Item was removed: - ----- Method: MorphicToolBuilderTests>>expectedButtonSideEffects (in category 'support') ----- - expectedButtonSideEffects - ^#(getColor getState getEnabled)! Item was removed: - ----- Method: MorphicToolBuilderTests>>fireButtonWidget (in category 'support') ----- - fireButtonWidget - widget performAction.! Item was removed: - ----- Method: MorphicToolBuilderTests>>fireMenuItemWidget (in category 'support') ----- - fireMenuItemWidget - (widget itemWithWording: 'Menu Item') - ifNotNil: [:item | item doButtonAction]! Item was removed: - ----- Method: MorphicToolBuilderTests>>setUp (in category 'support') ----- - setUp - super setUp. - builder := MorphicToolBuilder new.! Item was removed: - ----- Method: MorphicToolBuilderTests>>testWindowDynamicLabel (in category 'tests-window') ----- - testWindowDynamicLabel - self makeWindow. - self assert: (widget label = 'TestLabel').! Item was removed: - ----- Method: MorphicToolBuilderTests>>testWindowStaticLabel (in category 'tests-window') ----- - testWindowStaticLabel - | spec | - spec := builder pluggableWindowSpec new. - spec model: self. - spec children: #(). - spec label: 'TestLabel'. - widget := builder build: spec. - self assert: (widget label = 'TestLabel').! Item was removed: - ----- Method: MorphicToolBuilderTests>>widgetColor (in category 'support') ----- - widgetColor - "Answer color from widget" - ^widget color! Item was removed: - UIManager subclass: #MorphicUIManager - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'ToolBuilder-Morphic'! - - !MorphicUIManager commentStamp: 'dtl 5/2/2010 16:07' prior: 0! - MorphicUIManager is a UIManager that implements user interface requests for a Morphic user interface.! Item was removed: - ----- Method: MorphicUIManager class>>isActiveManager (in category 'accessing') ----- - isActiveManager - "Answer whether I should act as the active ui manager" - ^Smalltalk isMorphic! Item was removed: - ----- Method: MorphicUIManager>>chooseClassOrTrait:from: (in category 'ui requests') ----- - chooseClassOrTrait: label from: environment - "Let the user choose a Class or Trait. Use ListChooser in Morphic." - - | names index | - names := environment classAndTraitNames. - index := self - chooseFrom: names - lines: #() - title: label. - index = 0 ifTrue: [ ^nil ]. - ^environment - at: (names at: index) - ifAbsent: [ nil ]! Item was removed: - ----- Method: MorphicUIManager>>chooseDirectory:from: (in category 'ui requests') ----- - chooseDirectory: label from: dir - "Let the user choose a directory" - ^FileList2 modalFolderSelector: dir! Item was removed: - ----- Method: MorphicUIManager>>chooseFileMatching:label: (in category 'ui requests') ----- - chooseFileMatching: patterns label: aString - "Let the user choose a file matching the given patterns" - | result | - result := FileList2 modalFileSelectorForSuffixes: patterns. - ^result ifNotNil:[result fullName]! Item was removed: - ----- Method: MorphicUIManager>>chooseFont:for:setSelector:getSelector: (in category 'ui requests') ----- - chooseFont: titleString for: aModel setSelector: setSelector getSelector: getSelector - "Open a font-chooser for the given model" - ^FontChooserTool default - openWithWindowTitle: titleString - for: aModel - setSelector: setSelector - getSelector: getSelector! Item was removed: - ----- Method: MorphicUIManager>>chooseFrom:lines:title: (in category 'ui requests') ----- - chooseFrom: aList lines: linesArray title: aString - "Choose an item from the given list. Answer the index of the selected item." - ^ aList size > 30 - ifTrue: - [ "Don't put more than 30 items in a menu. Use ListChooser insted" - ListChooser - chooseFrom: aList - title: aString ] - ifFalse: - [ MenuMorph - chooseFrom: aList - lines: linesArray - title: aString ]! Item was removed: - ----- Method: MorphicUIManager>>chooseFrom:values:lines:title: (in category 'ui requests') ----- - chooseFrom: labelList values: valueList lines: linesArray title: aString - "Choose an item from the given list. Answer the selected item." - | index | - ^ labelList size > 30 - ifTrue: - [ "No point in displaying more than 30 items in a menu. Use ListChooser insted" - index := ListChooser - chooseFrom: labelList - title: aString. - index = 0 ifFalse: [ valueList at: index ] ] - ifFalse: - [ MenuMorph - chooseFrom: labelList - values: valueList - lines: linesArray - title: aString ]! Item was removed: - ----- Method: MorphicUIManager>>confirm: (in category 'ui requests') ----- - confirm: queryString - "Put up a yes/no menu with caption queryString. Answer true if the - response is yes, false if no. This is a modal question--the user must - respond yes or no." - ^UserDialogBoxMorph confirm: queryString! Item was removed: - ----- Method: MorphicUIManager>>confirm:orCancel: (in category 'ui requests') ----- - confirm: aString orCancel: cancelBlock - "Put up a yes/no/cancel menu with caption aString. Answer true if - the response is yes, false if no. If cancel is chosen, evaluate - cancelBlock. This is a modal question--the user must respond yes or no." - ^UserDialogBoxMorph confirm: aString orCancel: cancelBlock! Item was removed: - ----- Method: MorphicUIManager>>confirm:trueChoice:falseChoice: (in category 'ui requests') ----- - confirm: queryString trueChoice: trueChoice falseChoice: falseChoice - "Put up a yes/no menu with caption queryString. The actual wording for the two choices will be as provided in the trueChoice and falseChoice parameters. Answer true if the response is the true-choice, false if it's the false-choice. - This is a modal question -- the user must respond one way or the other." - ^ UserDialogBoxMorph confirm: queryString trueChoice: trueChoice falseChoice: falseChoice ! Item was removed: - ----- Method: MorphicUIManager>>displayProgress:at:from:to:during: (in category 'ui requests') ----- - displayProgress: titleString at: aPoint from: minVal to: maxVal during: workBlock - "Display titleString as a caption over a progress bar while workBlock is evaluated." - | result progress | - progress := SystemProgressMorph - position: aPoint - label: titleString - min: minVal - max: maxVal. - [ [ result := workBlock value: progress ] - on: ProgressNotification - do: - [ : ex | ex extraParam isString ifTrue: - [ SystemProgressMorph uniqueInstance - labelAt: progress - put: ex extraParam ]. - ex resume ] ] ensure: [ SystemProgressMorph close: progress ]. - ^ result! Item was removed: - ----- Method: MorphicUIManager>>edit:label:accept: (in category 'ui requests') ----- - edit: aText label: labelString accept: anAction - "Open an editor on the given string/text" - | window | - window := Workspace open. - labelString ifNotNil: [ window setLabel: labelString ]. - "By default, don't style in UIManager edit: requests" - window model - shouldStyle: false; - acceptContents: aText; - acceptAction: anAction. - ^window.! Item was removed: - ----- Method: MorphicUIManager>>inform: (in category 'ui requests') ----- - inform: aString - "Display a message for the user to read and then dismiss" - ^UserDialogBoxMorph inform: aString! Item was removed: - ----- Method: MorphicUIManager>>informUserDuring: (in category 'ui requests') ----- - informUserDuring: aBlock - "Display a message above (or below if insufficient room) the cursor - during execution of the given block. - UIManager default informUserDuring:[:bar| - #(one two three) do:[:info| - bar value: info. - (Delay forSeconds: 1) wait]]" - SystemProgressMorph - informUserAt: nil during: aBlock.! Item was removed: - ----- Method: MorphicUIManager>>initialize (in category 'initialize-release') ----- - initialize - toolBuilder := MorphicToolBuilder new! Item was removed: - ----- Method: MorphicUIManager>>multiLineRequest:centerAt:initialAnswer:answerHeight: (in category 'ui requests') ----- - multiLineRequest: queryString centerAt: aPoint initialAnswer: defaultAnswer answerHeight: answerHeight - "Create a multi-line instance of me whose question is queryString with - the given initial answer. Invoke it centered at the given point, and - answer the string the user accepts. Answer nil if the user cancels. An - empty string returned means that the ussr cleared the editing area and - then hit 'accept'. Because multiple lines are invited, we ask that the user - use the ENTER key, or (in morphic anyway) hit the 'accept' button, to - submit; that way, the return key can be typed to move to the next line." - ^FillInTheBlankMorph - request: queryString - initialAnswer: defaultAnswer - centerAt: aPoint - inWorld: self currentWorld - onCancelReturn: nil - acceptOnCR: false! Item was removed: - ----- Method: MorphicUIManager>>request:initialAnswer: (in category 'ui requests') ----- - request: queryString initialAnswer: defaultAnswer - "Create an instance of me whose question is queryString with the given - initial answer. Invoke it centered at the given point, and answer the - string the user accepts. Answer the empty string if the user cancels." - ^FillInTheBlankMorph request: queryString initialAnswer: defaultAnswer ! Item was removed: - ----- Method: MorphicUIManager>>request:initialAnswer:centerAt: (in category 'ui requests') ----- - request: queryString initialAnswer: defaultAnswer centerAt: aPoint - "Create an instance of me whose question is queryString with the given - initial answer. Invoke it centered at the given point, and answer the - string the user accepts. Answer the empty string if the user cancels." - ^FillInTheBlankMorph request: queryString initialAnswer: defaultAnswer centerAt: aPoint! Item was removed: - ----- Method: MorphicUIManager>>requestPassword: (in category 'ui requests') ----- - requestPassword: queryString - "Create an instance of me whose question is queryString. Invoke it centered - at the cursor, and answer the string the user accepts. Answer the empty - string if the user cancels." - ^FillInTheBlankMorph requestPassword: queryString! Item was removed: - PluggableButtonMorph subclass: #PluggableButtonMorphPlus - instanceVariableNames: 'enabled action getColorSelector getEnabledSelector updateMap' - classVariableNames: '' - poolDictionaries: '' - category: 'ToolBuilder-Morphic'! - - !PluggableButtonMorphPlus commentStamp: 'ar 2/11/2005 21:53' prior: 0! - An extended version of PluggableButtonMorph supporting enablement, color and block/message actions.! Item was removed: - ----- Method: PluggableButtonMorphPlus>>action (in category 'accessing') ----- - action - ^action! Item was removed: - ----- Method: PluggableButtonMorphPlus>>action: (in category 'accessing') ----- - action: anAction - action := nil. - anAction isSymbol ifTrue:[^super action: anAction]. - action := anAction.! Item was removed: - ----- Method: PluggableButtonMorphPlus>>enabled (in category 'accessing') ----- - enabled - ^ enabled ifNil: [enabled := true]! Item was removed: - ----- Method: PluggableButtonMorphPlus>>enabled: (in category 'accessing') ----- - enabled: aBool - enabled := aBool. - enabled - ifFalse:[self color: Color gray] - ifTrue:[self getModelState - ifTrue: [self color: onColor] - ifFalse: [self color: offColor]]! Item was removed: - ----- Method: PluggableButtonMorphPlus>>getColorSelector (in category 'accessing') ----- - getColorSelector - ^getColorSelector! Item was removed: - ----- Method: PluggableButtonMorphPlus>>getColorSelector: (in category 'accessing') ----- - getColorSelector: aSymbol - getColorSelector := aSymbol. - self update: getColorSelector.! Item was removed: - ----- Method: PluggableButtonMorphPlus>>getEnabledSelector (in category 'accessing') ----- - getEnabledSelector - ^getEnabledSelector! Item was removed: - ----- Method: PluggableButtonMorphPlus>>getEnabledSelector: (in category 'accessing') ----- - getEnabledSelector: aSymbol - getEnabledSelector := aSymbol. - self update: aSymbol.! Item was removed: - ----- Method: PluggableButtonMorphPlus>>initialize (in category 'initialize-release') ----- - initialize - super initialize. - enabled := true. - onColor := Color veryLightGray. - offColor := Color white! Item was removed: - ----- Method: PluggableButtonMorphPlus>>mouseDown: (in category 'action') ----- - mouseDown: evt - enabled ifFalse:[^self]. - ^super mouseDown: evt! Item was removed: - ----- Method: PluggableButtonMorphPlus>>mouseMove: (in category 'action') ----- - mouseMove: evt - enabled ifFalse:[^self]. - ^super mouseMove: evt! Item was removed: - ----- Method: PluggableButtonMorphPlus>>mouseUp: (in category 'action') ----- - mouseUp: evt - enabled ifFalse:[^self]. - ^super mouseUp: evt! Item was removed: - ----- Method: PluggableButtonMorphPlus>>onColor:offColor: (in category 'accessing') ----- - onColor: colorWhenOn offColor: colorWhenOff - "Set the fill colors to be used when this button is on/off." - - onColor := colorWhenOn. - offColor := colorWhenOff. - self update: getStateSelector.! Item was removed: - ----- Method: PluggableButtonMorphPlus>>performAction (in category 'action') ----- - performAction - enabled ifFalse:[^self]. - action ifNotNil:[^action value]. - ^super performAction! Item was removed: - ----- Method: PluggableButtonMorphPlus>>update: (in category 'updating') ----- - update: what - what ifNil:[^self]. - what == getLabelSelector ifTrue: [ - self label: (model perform: getLabelSelector)]. - what == getEnabledSelector ifTrue:[^self enabled: (model perform: getEnabledSelector)]. - - getColorSelector ifNotNil: [ | cc | - color = (cc := model perform: getColorSelector) ifFalse:[ - color := cc. - self onColor: color offColor: color. - self changed. - ]. - ]. - self getModelState - ifTrue: [self color: onColor] - ifFalse: [self color: offColor]. - getEnabledSelector ifNotNil:[ - self enabled: (model perform: getEnabledSelector). - ]. - updateMap ifNotNil: - [(updateMap at: what ifAbsent: []) - ifNotNilDo: [ :newTarget | ^self update: newTarget]]. - ! Item was removed: - ----- Method: PluggableButtonMorphPlus>>updateMap (in category 'updating') ----- - updateMap - ^ updateMap ifNil: [updateMap := Dictionary new] - ! Item was removed: - ----- Method: PluggableButtonMorphPlus>>whenChanged:update: (in category 'updating') ----- - whenChanged: notification update: target - "On receipt of a notification, such as #contents notification from a CodeHolder, - invoke an update as if target had been the original notification." - - self updateMap at: notification put: target! Item was removed: - AlignmentMorph subclass: #PluggableCheckBoxMorph - instanceVariableNames: 'model actionSelector valueSelector label' - classVariableNames: '' - poolDictionaries: '' - category: 'ToolBuilder-Morphic'! Item was removed: - ----- Method: PluggableCheckBoxMorph class>>on:getState:action:label: (in category 'as yet unclassified') ----- - on: anObject getState: getStateSel action: actionSel label: labelSel - - ^ self new - on: anObject - getState: getStateSel - action: actionSel - label: labelSel - menu: nil - ! Item was removed: - ----- Method: PluggableCheckBoxMorph>>actionSelector (in category 'accessing') ----- - actionSelector - "Answer the value of actionSelector" - - ^ actionSelector! Item was removed: - ----- Method: PluggableCheckBoxMorph>>actionSelector: (in category 'accessing') ----- - actionSelector: anObject - "Set the value of actionSelector" - - actionSelector := anObject! Item was removed: - ----- Method: PluggableCheckBoxMorph>>basicPanel (in category 'installing') ----- - basicPanel - ^BorderedMorph new - beTransparent; - extent: 0@0; - borderWidth: 0; - layoutInset: 0; - cellInset: 0; - layoutPolicy: TableLayout new; - listCentering: #topLeft; - cellPositioning: #center; - hResizing: #spaceFill; - vResizing: #shrinkWrap; - yourself! Item was removed: - ----- Method: PluggableCheckBoxMorph>>horizontalPanel (in category 'installing') ----- - horizontalPanel - ^self basicPanel - cellPositioning: #center; - listDirection: #leftToRight; - yourself.! Item was removed: - ----- Method: PluggableCheckBoxMorph>>installButton (in category 'installing') ----- - installButton - - | aButton aLabel | - aButton := UpdatingThreePhaseButtonMorph checkBox - target: self model; - actionSelector: self actionSelector; - getSelector: self valueSelector; - yourself. - aLabel := (StringMorph contents: self label translated - font: (StrikeFont familyName: TextStyle defaultFont familyName - size: TextStyle defaultFont pointSize - 1)). - self addMorph: (self horizontalPanel - addMorphBack: aButton; - addMorphBack: aLabel; - yourself).! Item was removed: - ----- Method: PluggableCheckBoxMorph>>label (in category 'accessing') ----- - label - "Answer the value of label" - - ^ label! Item was removed: - ----- Method: PluggableCheckBoxMorph>>label: (in category 'accessing') ----- - label: anObject - "Set the value of label" - - label := anObject! Item was removed: - ----- Method: PluggableCheckBoxMorph>>model (in category 'accessing') ----- - model - "Answer the value of model" - - ^ model. - ! Item was removed: - ----- Method: PluggableCheckBoxMorph>>model: (in category 'accessing') ----- - model: anObject - "Set the value of model" - - model := anObject! Item was removed: - ----- Method: PluggableCheckBoxMorph>>on:getState:action:label:menu: (in category 'initialization') ----- - on: anObject getState: getStateSel action: actionSel label: labelSel menu: menuSel - - self model: anObject. - self valueSelector: getStateSel. - self actionSelector: actionSel. - self label: (self model perform: labelSel). - ! Item was removed: - ----- Method: PluggableCheckBoxMorph>>valueSelector (in category 'accessing') ----- - valueSelector - "Answer the value of valueSelector" - - ^ valueSelector! Item was removed: - ----- Method: PluggableCheckBoxMorph>>valueSelector: (in category 'accessing') ----- - valueSelector: anObject - "Set the value of valueSelector" - - valueSelector := anObject! Item was removed: - PluggableSystemWindow subclass: #PluggableDialogWindow - instanceVariableNames: 'statusValue' - classVariableNames: '' - poolDictionaries: '' - category: 'ToolBuilder-Morphic'! Item was removed: - ----- Method: PluggableDialogWindow>>statusValue (in category 'as yet unclassified') ----- - statusValue - ^statusValue! Item was removed: - ----- Method: PluggableDialogWindow>>statusValue: (in category 'as yet unclassified') ----- - statusValue: val - statusValue := val! Item was removed: - AlignmentMorph subclass: #PluggableDropDownListMorph - instanceVariableNames: 'model listSelector selectionSelector selectionSetter' - classVariableNames: '' - poolDictionaries: '' - category: 'ToolBuilder-Morphic'! Item was removed: - ----- Method: PluggableDropDownListMorph>>basicPanel (in category 'drawing') ----- - basicPanel - ^BorderedMorph new - beTransparent; - extent: 0@0; - borderWidth: 0; - layoutInset: 0; - cellInset: 0; - layoutPolicy: TableLayout new; - listCentering: #topLeft; - cellPositioning: #center; - hResizing: #spaceFill; - vResizing: #shrinkWrap; - yourself! Item was removed: - ----- Method: PluggableDropDownListMorph>>currentSelection (in category 'accessing') ----- - currentSelection - - ^ self model perform: selectionSelector! Item was removed: - ----- Method: PluggableDropDownListMorph>>currentSelection: (in category 'accessing') ----- - currentSelection: obj - - ^ self model perform: selectionSetter with: obj! Item was removed: - ----- Method: PluggableDropDownListMorph>>horizontalPanel (in category 'drawing') ----- - horizontalPanel - ^self basicPanel - cellPositioning: #center; - listDirection: #leftToRight; - yourself.! Item was removed: - ----- Method: PluggableDropDownListMorph>>installDropDownList (in category 'drawing') ----- - installDropDownList - - | aButton aLabel | - aButton := PluggableButtonMorph on: self model getState: nil action: nil. - aLabel := (StringMorph contents: self model currentRemoteVatId translated - font: (StrikeFont familyName: TextStyle defaultFont familyName - size: TextStyle defaultFont pointSize - 1)). - self addMorph: (self horizontalPanel - addMorphBack: aLabel; - addMorphBack: aButton; - yourself).! Item was removed: - ----- Method: PluggableDropDownListMorph>>list (in category 'accessing') ----- - list - "Answer the value of list" - - ^ self model perform: self listSelector. - ! Item was removed: - ----- Method: PluggableDropDownListMorph>>listSelector (in category 'accessing') ----- - listSelector - "Answer the value of listSelector" - - ^ listSelector! Item was removed: - ----- Method: PluggableDropDownListMorph>>listSelector: (in category 'accessing') ----- - listSelector: anObject - "Set the value of listSelector" - - listSelector := anObject! Item was removed: - ----- Method: PluggableDropDownListMorph>>model (in category 'accessing') ----- - model - ^ model! Item was removed: - ----- Method: PluggableDropDownListMorph>>model: (in category 'accessing') ----- - model: anObject - "Set the value of model" - - model := anObject! Item was removed: - ----- Method: PluggableDropDownListMorph>>selectionSelector (in category 'accessing') ----- - selectionSelector - "Answer the value of selectionSelector" - - ^ selectionSelector! Item was removed: - ----- Method: PluggableDropDownListMorph>>selectionSelector: (in category 'accessing') ----- - selectionSelector: anObject - "Set the value of selectionSelector" - - selectionSelector := anObject! Item was removed: - ----- Method: PluggableDropDownListMorph>>selectionSetter (in category 'accessing') ----- - selectionSetter - "Answer the value of selectionSetter" - - ^ selectionSetter! Item was removed: - ----- Method: PluggableDropDownListMorph>>selectionSetter: (in category 'accessing') ----- - selectionSetter: anObject - "Set the value of selectionSetter" - - selectionSetter := anObject! Item was removed: - PluggableListMorphPlus subclass: #PluggableListMorphByItemPlus - instanceVariableNames: 'itemList' - classVariableNames: '' - poolDictionaries: '' - category: 'ToolBuilder-Morphic'! - - !PluggableListMorphByItemPlus commentStamp: '<historical>' prior: 0! - Main comment stating the purpose of this class and relevant relationship to other classes. - - Possible useful expressions for doIt or printIt. - - Structure: - instVar1 type -- comment about the purpose of instVar1 - instVar2 type -- comment about the purpose of instVar2 - - Any further useful comments about the general approach of this implementation.! Item was removed: - ----- Method: PluggableListMorphByItemPlus>>changeModelSelection: (in category 'model access') ----- - changeModelSelection: anInteger - "Change the model's selected item to be the one at the given index." - - | item | - setIndexSelector ifNotNil: [ - item := (anInteger = 0 ifTrue: [nil] ifFalse: [itemList at: anInteger]). - model perform: setIndexSelector with: item]. - self update: getIndexSelector. - ! Item was removed: - ----- Method: PluggableListMorphByItemPlus>>getCurrentSelectionIndex (in category 'model access') ----- - getCurrentSelectionIndex - "Answer the index of the current selection." - | item | - getIndexSelector == nil ifTrue: [^ 0]. - item := model perform: getIndexSelector. - ^ itemList findFirst: [ :x | x = item] - ! Item was removed: - ----- Method: PluggableListMorphByItemPlus>>getList (in category 'as yet unclassified') ----- - getList - "cache the raw items in itemList" - itemList := getListSelector ifNil: [ #() ] ifNotNil: [ model perform: getListSelector ]. - ^super getList! Item was removed: - ----- Method: PluggableListMorphByItemPlus>>list: (in category 'initialization') ----- - list: arrayOfStrings - "Set the receivers items to be the given list of strings." - "Note: the instance variable 'items' holds the original list. - The instance variable 'list' is a paragraph constructed from - this list." - "NOTE: this is no longer true; list is a real list, and itemList is no longer used. And this method shouldn't be called, incidentally." - self isThisEverCalled . - itemList := arrayOfStrings. - ^ super list: arrayOfStrings! Item was removed: - PluggableListMorph subclass: #PluggableListMorphPlus - instanceVariableNames: 'dragItemSelector dropItemSelector wantsDropSelector' - classVariableNames: '' - poolDictionaries: '' - category: 'ToolBuilder-Morphic'! - - !PluggableListMorphPlus commentStamp: 'ar 7/15/2005 11:10' prior: 0! - Extensions for PluggableListMorph needed by ToolBuilder! Item was removed: - ----- Method: PluggableListMorphPlus>>acceptDroppingMorph:event: (in category 'drag and drop') ----- - acceptDroppingMorph: aMorph event: evt - | item | - dropItemSelector isNil | potentialDropRow isNil ifTrue: [^self]. - item := aMorph passenger. - model perform: dropItemSelector with: item with: potentialDropRow. - self resetPotentialDropRow. - evt hand releaseMouseFocus: self. - Cursor normal show. - ! Item was removed: - ----- Method: PluggableListMorphPlus>>dragItemSelector (in category 'accessing') ----- - dragItemSelector - ^dragItemSelector! Item was removed: - ----- Method: PluggableListMorphPlus>>dragItemSelector: (in category 'accessing') ----- - dragItemSelector: aSymbol - dragItemSelector := aSymbol. - aSymbol ifNotNil:[self dragEnabled: true].! Item was removed: - ----- Method: PluggableListMorphPlus>>dropItemSelector (in category 'accessing') ----- - dropItemSelector - ^dropItemSelector! Item was removed: - ----- Method: PluggableListMorphPlus>>dropItemSelector: (in category 'accessing') ----- - dropItemSelector: aSymbol - dropItemSelector := aSymbol. - aSymbol ifNotNil:[self dropEnabled: true].! Item was removed: - ----- Method: PluggableListMorphPlus>>startDrag: (in category 'drag and drop') ----- - startDrag: evt - - dragItemSelector ifNil:[^self]. - evt hand hasSubmorphs ifTrue: [^ self]. - [ | dragIndex draggedItem ddm | - (self dragEnabled and: [model okToChange]) ifFalse: [^ self]. - dragIndex := self rowAtLocation: evt position. - dragIndex = 0 ifTrue:[^self]. - draggedItem := model perform: dragItemSelector with: (self modelIndexFor: dragIndex). - draggedItem ifNil:[^self]. - ddm := TransferMorph withPassenger: draggedItem from: self. - ddm dragTransferType: #dragTransferPlus. - evt hand grabMorph: ddm] - ensure: [Cursor normal show. - evt hand releaseMouseFocus: self]! Item was removed: - ----- Method: PluggableListMorphPlus>>wantsDropSelector (in category 'accessing') ----- - wantsDropSelector - ^wantsDropSelector! Item was removed: - ----- Method: PluggableListMorphPlus>>wantsDropSelector: (in category 'accessing') ----- - wantsDropSelector: aSymbol - wantsDropSelector := aSymbol! Item was removed: - ----- Method: PluggableListMorphPlus>>wantsDroppedMorph:event: (in category 'drag and drop') ----- - wantsDroppedMorph: aMorph event: anEvent - aMorph dragTransferType == #dragTransferPlus ifFalse:[^false]. - dropItemSelector ifNil:[^false]. - wantsDropSelector ifNil:[^true]. - ^(model perform: wantsDropSelector with: aMorph passenger) == true! Item was removed: - AlignmentMorph subclass: #PluggablePanelMorph - instanceVariableNames: 'model getChildrenSelector' - classVariableNames: '' - poolDictionaries: '' - category: 'ToolBuilder-Morphic'! - - !PluggablePanelMorph commentStamp: 'ar 2/11/2005 20:13' prior: 0! - A pluggable panel morph which deals with changing children.! Item was removed: - ----- Method: PluggablePanelMorph>>getChildrenSelector (in category 'accessing') ----- - getChildrenSelector - ^getChildrenSelector! Item was removed: - ----- Method: PluggablePanelMorph>>getChildrenSelector: (in category 'accessing') ----- - getChildrenSelector: aSymbol - getChildrenSelector := aSymbol.! Item was removed: - ----- Method: PluggablePanelMorph>>model (in category 'accessing') ----- - model - ^model! Item was removed: - ----- Method: PluggablePanelMorph>>model: (in category 'accessing') ----- - model: aModel - model ifNotNil:[model removeDependent: self]. - model := aModel. - model ifNotNil:[model addDependent: self].! Item was removed: - ----- Method: PluggablePanelMorph>>update: (in category 'update') ----- - update: what - what == nil ifTrue:[^self]. - what == getChildrenSelector ifTrue:[ - self removeAllMorphs. - self addAllMorphs: (model perform: getChildrenSelector). - self submorphsDo:[:m| m hResizing: #spaceFill; vResizing: #spaceFill]. - ].! Item was removed: - SystemWindow subclass: #PluggableSystemWindow - instanceVariableNames: 'getLabelSelector getChildrenSelector children closeWindowSelector' - classVariableNames: '' - poolDictionaries: '' - category: 'ToolBuilder-Morphic'! - - !PluggableSystemWindow commentStamp: 'ar 2/11/2005 20:14' prior: 0! - A pluggable system window. Fixes the issues with label retrieval and adds support for changing children.! Item was removed: - ----- Method: PluggableSystemWindow>>addPaneMorph: (in category 'accessing') ----- - addPaneMorph: aMorph - self addMorph: aMorph fullFrame: aMorph layoutFrame! Item was removed: - ----- Method: PluggableSystemWindow>>closeWindowSelector (in category 'accessing') ----- - closeWindowSelector - ^closeWindowSelector! Item was removed: - ----- Method: PluggableSystemWindow>>closeWindowSelector: (in category 'accessing') ----- - closeWindowSelector: aSymbol - closeWindowSelector := aSymbol! Item was removed: - ----- Method: PluggableSystemWindow>>delete (in category 'initialization') ----- - delete - closeWindowSelector ifNotNil:[model perform: closeWindowSelector]. - super delete. - ! Item was removed: - ----- Method: PluggableSystemWindow>>getChildrenSelector (in category 'accessing') ----- - getChildrenSelector - ^getChildrenSelector! Item was removed: - ----- Method: PluggableSystemWindow>>getChildrenSelector: (in category 'accessing') ----- - getChildrenSelector: aSymbol - getChildrenSelector := aSymbol! Item was removed: - ----- Method: PluggableSystemWindow>>getLabelSelector (in category 'accessing') ----- - getLabelSelector - ^getLabelSelector! Item was removed: - ----- Method: PluggableSystemWindow>>getLabelSelector: (in category 'accessing') ----- - getLabelSelector: aSymbol - getLabelSelector := aSymbol. - self update: aSymbol.! Item was removed: - ----- Method: PluggableSystemWindow>>label (in category 'accessing') ----- - label - ^label contents! Item was removed: - ----- Method: PluggableSystemWindow>>label: (in category 'accessing') ----- - label: aString - self setLabel: aString.! Item was removed: - ----- Method: PluggableSystemWindow>>update: (in category 'updating') ----- - update: what - what ifNil:[^self]. - what == getLabelSelector ifTrue:[self setLabel: (model perform: getLabelSelector)]. - what == getChildrenSelector ifTrue:[ - children ifNil:[children := #()]. - self removeAllMorphsIn: children. - children := model perform: getChildrenSelector. - self addAllMorphs: children. - children do:[:m| m hResizing: #spaceFill; vResizing: #spaceFill]. - ]. - ^super update: what! Item was removed: - PluggableTextMorph subclass: #PluggableTextMorphPlus - instanceVariableNames: 'getColorSelector acceptAction unstyledAcceptText styler' - classVariableNames: '' - poolDictionaries: '' - category: 'ToolBuilder-Morphic'! - - !PluggableTextMorphPlus commentStamp: 'ar 2/11/2005 21:53' prior: 0! - A pluggable text morph with support for color.! Item was removed: - ----- Method: PluggableTextMorphPlus>>accept (in category 'updating') ----- - accept - super accept. - acceptAction ifNotNil:[acceptAction value: textMorph asText].! Item was removed: - ----- Method: PluggableTextMorphPlus>>acceptAction (in category 'accessing') ----- - acceptAction - ^acceptAction! Item was removed: - ----- Method: PluggableTextMorphPlus>>acceptAction: (in category 'accessing') ----- - acceptAction: anAction - acceptAction := anAction! Item was removed: - ----- Method: PluggableTextMorphPlus>>acceptTextInModel (in category 'styling') ----- - acceptTextInModel - - self okToStyle ifFalse:[^super acceptTextInModel]. - "#correctFrom:to:with: is sent when the method source is - manipulated during compilation (removing unused temps, - changing selectors etc). But #correctFrom:to:with: operates - on the textMorph's text, and we may be saving an unstyled - copy of the text. This means that these corrections will be lost - unless we also apply the corrections to the unstyled copy that we are saving. - So remember the unstyled copy in unstyledAcceptText, so - that when #correctFrom:to:with: is received we can also apply - the correction to it" - unstyledAcceptText := styler unstyledTextFrom: textMorph asText. - [^setTextSelector isNil or: - [setTextSelector numArgs = 2 - ifTrue: [model perform: setTextSelector with: unstyledAcceptText with: self] - ifFalse: [model perform: setTextSelector with: unstyledAcceptText]] - ] ensure:[unstyledAcceptText := nil]! Item was removed: - ----- Method: PluggableTextMorphPlus>>correctFrom:to:with: (in category 'styling') ----- - correctFrom: start to: stop with: aString - "see the comment in #acceptTextInModel " - unstyledAcceptText ifNotNil:[unstyledAcceptText replaceFrom: start to: stop with: aString ]. - ^ super correctFrom: start to: stop with: aString! Item was removed: - ----- Method: PluggableTextMorphPlus>>getColorSelector (in category 'accessing') ----- - getColorSelector - ^getColorSelector! Item was removed: - ----- Method: PluggableTextMorphPlus>>getColorSelector: (in category 'accessing') ----- - getColorSelector: aSymbol - getColorSelector := aSymbol. - self update: getColorSelector.! Item was removed: - ----- Method: PluggableTextMorphPlus>>getMenu: (in category 'menu') ----- - getMenu: shiftKeyState - "Answer the menu for this text view. We override the superclass implementation to - so we can give the selection interval to the model." - - | menu aMenu | - getMenuSelector == nil ifTrue: [^ nil]. - getMenuSelector numArgs < 3 ifTrue: [^ super getMenu: shiftKeyState]. - menu := MenuMorph new defaultTarget: model. - getMenuSelector numArgs = 3 ifTrue: - [aMenu := model - perform: getMenuSelector - with: menu - with: shiftKeyState - with: self selectionInterval. - getMenuTitleSelector ifNotNil: - [aMenu addTitle: (model perform: getMenuTitleSelector)]. - ^ aMenu]. - ^ self error: 'The getMenuSelector must be a 1- or 2 or 3-keyword symbol'! Item was removed: - ----- Method: PluggableTextMorphPlus>>hasUnacceptedEdits: (in category 'styling') ----- - hasUnacceptedEdits: aBoolean - "re-implemented to re-style the text iff aBoolean is true" - - super hasUnacceptedEdits: aBoolean. - (aBoolean and: [self okToStyle]) - ifTrue: [ styler styleInBackgroundProcess: textMorph contents]! Item was removed: - ----- Method: PluggableTextMorphPlus>>okToStyle (in category 'testing') ----- - okToStyle - styler ifNil:[^false]. - (model respondsTo: #aboutToStyle: ) ifFalse:[^true]. - ^model aboutToStyle: styler - ! Item was removed: - ----- Method: PluggableTextMorphPlus>>setText: (in category 'styling') ----- - setText: aText - - self okToStyle ifFalse:[^super setText: aText]. - super setText: (styler format: aText asText). - aText size < 4096 - ifTrue:[styler style: textMorph contents] - ifFalse:[styler styleInBackgroundProcess: textMorph contents]! Item was removed: - ----- Method: PluggableTextMorphPlus>>styler (in category 'accessing') ----- - styler - "The styler responsible for highlighting text in the receiver" - ^styler! Item was removed: - ----- Method: PluggableTextMorphPlus>>styler: (in category 'accessing') ----- - styler: anObject - "The styler responsible for highlighting text in the receiver" - styler := anObject! Item was removed: - ----- Method: PluggableTextMorphPlus>>stylerStyled: (in category 'styling') ----- - stylerStyled: styledCopyOfText - "Sent after the styler completed styling the underlying text" - textMorph contents runs: styledCopyOfText runs . - "textMorph paragraph recomposeFrom: 1 to: textMorph contents size delta: 0." "caused chars to appear in wrong order esp. in demo mode. remove this line when sure it is fixed" - textMorph updateFromParagraph. - selectionInterval - ifNotNil:[ - textMorph editor - selectInvisiblyFrom: selectionInterval first to: selectionInterval last; - storeSelectionInParagraph; - setEmphasisHere]. - textMorph editor blinkParen. - self scrollSelectionIntoView! Item was removed: - ----- Method: PluggableTextMorphPlus>>stylerStyledInBackground: (in category 'styling') ----- - stylerStyledInBackground: styledCopyOfText - "Sent after the styler completed styling of the text" - - "It is possible that the text string has changed since the styling began. Disregard the styles if styledCopyOfText's string differs with the current textMorph contents string" - textMorph contents string = styledCopyOfText string - ifTrue: [self stylerStyled: styledCopyOfText]! Item was removed: - ----- Method: PluggableTextMorphPlus>>update: (in category 'updating') ----- - update: what - what ifNil:[^self]. - what == getColorSelector ifTrue:[self color: (model perform: getColorSelector)]. - ^super update: what! Item was removed: - ----- Method: PluggableTextMorphPlus>>useDefaultStyler (in category 'initialize') ----- - useDefaultStyler - "This should be changed to a proper registry but as long as there is only shout this will do" - Smalltalk at: #SHTextStylerST80 ifPresent:[:stylerClass| - self styler: (stylerClass new view: self). - ].! Item was removed: - ListItemWrapper subclass: #PluggableTreeItemNode - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'ToolBuilder-Morphic'! - - !PluggableTreeItemNode commentStamp: 'ar 2/12/2005 04:37' prior: 0! - Tree item for PluggableTreeMorph.! Item was removed: - ----- Method: PluggableTreeItemNode>>acceptDroppingObject: (in category 'accessing') ----- - acceptDroppingObject: anotherItem - ^model dropNode: anotherItem on: self! Item was removed: - ----- Method: PluggableTreeItemNode>>asString (in category 'accessing') ----- - asString - ^model printNode: self! Item was removed: - ----- Method: PluggableTreeItemNode>>balloonText (in category 'accessing') ----- - balloonText - ^model balloonTextForNode: self! Item was removed: - ----- Method: PluggableTreeItemNode>>canBeDragged (in category 'accessing') ----- - canBeDragged - ^model isDraggableNode: self! Item was removed: - ----- Method: PluggableTreeItemNode>>contents (in category 'accessing') ----- - contents - ^model contentsOfNode: self! Item was removed: - ----- Method: PluggableTreeItemNode>>hasContents (in category 'accessing') ----- - hasContents - ^model hasNodeContents: self! Item was removed: - ----- Method: PluggableTreeItemNode>>icon (in category 'accessing') ----- - icon - ^model iconOfNode: self! Item was removed: - ----- Method: PluggableTreeItemNode>>item (in category 'accessing') ----- - item - ^item! Item was removed: - ----- Method: PluggableTreeItemNode>>wantsDroppedObject: (in category 'accessing') ----- - wantsDroppedObject: anotherItem - ^model wantsDroppedNode: anotherItem on: self! Item was removed: - SimpleHierarchicalListMorph subclass: #PluggableTreeMorph - instanceVariableNames: 'roots selectedWrapper getRootsSelector getChildrenSelector hasChildrenSelector getLabelSelector getIconSelector getSelectedPathSelector setSelectedSelector getHelpSelector dropItemSelector wantsDropSelector dragItemSelector' - classVariableNames: '' - poolDictionaries: '' - category: 'ToolBuilder-Morphic'! - - !PluggableTreeMorph commentStamp: 'ar 2/12/2005 04:38' prior: 0! - A pluggable tree morph.! Item was removed: - ----- Method: PluggableTreeMorph>>acceptDroppingMorph:event: (in category 'morphic') ----- - acceptDroppingMorph: aTransferMorph event: evt - dropItemSelector ifNil: [ ^ self ]. - model - perform: dropItemSelector - withEnoughArguments: {aTransferMorph passenger. - (self itemFromPoint: evt position) withoutListWrapper. - aTransferMorph shouldCopy}. - evt hand releaseMouseFocus: self. - potentialDropMorph ifNotNil: [ potentialDropMorph highlightForDrop: false ]. - Cursor normal show! Item was removed: - ----- Method: PluggableTreeMorph>>balloonTextForNode: (in category 'node access') ----- - balloonTextForNode: node - getHelpSelector ifNil:[^nil]. - ^model perform: getHelpSelector with: node item! Item was removed: - ----- Method: PluggableTreeMorph>>contentsOfNode: (in category 'node access') ----- - contentsOfNode: node - | children | - getChildrenSelector ifNil:[^#()]. - children := model perform: getChildrenSelector with: node item. - ^children collect:[:item| PluggableTreeItemNode with: item model: self]! Item was removed: - ----- Method: PluggableTreeMorph>>dragItemSelector (in category 'accessing') ----- - dragItemSelector - ^dragItemSelector! Item was removed: - ----- Method: PluggableTreeMorph>>dragItemSelector: (in category 'accessing') ----- - dragItemSelector: aSymbol - dragItemSelector := aSymbol. - aSymbol ifNotNil:[self dragEnabled: true].! Item was removed: - ----- Method: PluggableTreeMorph>>dropItemSelector (in category 'accessing') ----- - dropItemSelector - ^dropItemSelector! Item was removed: - ----- Method: PluggableTreeMorph>>dropItemSelector: (in category 'accessing') ----- - dropItemSelector: aSymbol - dropItemSelector := aSymbol. - aSymbol ifNotNil:[self dropEnabled: true].! Item was removed: - ----- Method: PluggableTreeMorph>>dropNode:on: (in category 'node access') ----- - dropNode: srcNode on: dstNode - dropItemSelector ifNil:[^nil]. - model perform: dropItemSelector with: srcNode item with: dstNode item! Item was removed: - ----- Method: PluggableTreeMorph>>getChildrenSelector (in category 'accessing') ----- - getChildrenSelector - ^getChildrenSelector! Item was removed: - ----- Method: PluggableTreeMorph>>getChildrenSelector: (in category 'accessing') ----- - getChildrenSelector: aSymbol - getChildrenSelector := aSymbol.! Item was removed: - ----- Method: PluggableTreeMorph>>getHelpSelector (in category 'accessing') ----- - getHelpSelector - ^getHelpSelector! Item was removed: - ----- Method: PluggableTreeMorph>>getHelpSelector: (in category 'accessing') ----- - getHelpSelector: aSymbol - getHelpSelector := aSymbol! Item was removed: - ----- Method: PluggableTreeMorph>>getIconSelector (in category 'accessing') ----- - getIconSelector - ^getIconSelector! Item was removed: - ----- Method: PluggableTreeMorph>>getIconSelector: (in category 'accessing') ----- - getIconSelector: aSymbol - getIconSelector := aSymbol! Item was removed: - ----- Method: PluggableTreeMorph>>getLabelSelector (in category 'accessing') ----- - getLabelSelector - ^getLabelSelector! Item was removed: - ----- Method: PluggableTreeMorph>>getLabelSelector: (in category 'accessing') ----- - getLabelSelector: aSymbol - getLabelSelector := aSymbol! Item was removed: - ----- Method: PluggableTreeMorph>>getMenuSelector (in category 'accessing') ----- - getMenuSelector - ^getMenuSelector! Item was removed: - ----- Method: PluggableTreeMorph>>getMenuSelector: (in category 'accessing') ----- - getMenuSelector: aSymbol - getMenuSelector := aSymbol! Item was removed: - ----- Method: PluggableTreeMorph>>getRootsSelector (in category 'accessing') ----- - getRootsSelector - ^getRootsSelector! Item was removed: - ----- Method: PluggableTreeMorph>>getRootsSelector: (in category 'accessing') ----- - getRootsSelector: aSelector - getRootsSelector := aSelector. - self update: getRootsSelector.! Item was removed: - ----- Method: PluggableTreeMorph>>getSelectedPathSelector (in category 'accessing') ----- - getSelectedPathSelector - ^getSelectedPathSelector! Item was removed: - ----- Method: PluggableTreeMorph>>getSelectedPathSelector: (in category 'accessing') ----- - getSelectedPathSelector: aSymbol - getSelectedPathSelector := aSymbol.! Item was removed: - ----- Method: PluggableTreeMorph>>hasChildrenSelector (in category 'accessing') ----- - hasChildrenSelector - ^hasChildrenSelector! Item was removed: - ----- Method: PluggableTreeMorph>>hasChildrenSelector: (in category 'accessing') ----- - hasChildrenSelector: aSymbol - hasChildrenSelector := aSymbol! Item was removed: - ----- Method: PluggableTreeMorph>>hasNodeContents: (in category 'node access') ----- - hasNodeContents: node - hasChildrenSelector ifNil:[^node contents isEmpty not]. - ^model perform: hasChildrenSelector with: node item! Item was removed: - ----- Method: PluggableTreeMorph>>iconOfNode: (in category 'node access') ----- - iconOfNode: node - getIconSelector ifNil:[^nil]. - ^model perform: getIconSelector with: node item! Item was removed: - ----- Method: PluggableTreeMorph>>isDraggableNode: (in category 'node access') ----- - isDraggableNode: node - ^true! Item was removed: - ----- Method: PluggableTreeMorph>>keystrokeActionSelector (in category 'accessing') ----- - keystrokeActionSelector - ^keystrokeActionSelector! Item was removed: - ----- Method: PluggableTreeMorph>>keystrokeActionSelector: (in category 'accessing') ----- - keystrokeActionSelector: aSymbol - keystrokeActionSelector := aSymbol! Item was removed: - ----- Method: PluggableTreeMorph>>printNode: (in category 'node access') ----- - printNode: node - getLabelSelector ifNil:[^node item printString]. - ^model perform: getLabelSelector with: node item! Item was removed: - ----- Method: PluggableTreeMorph>>roots (in category 'accessing') ----- - roots - ^roots! Item was removed: - ----- Method: PluggableTreeMorph>>roots: (in category 'accessing') ----- - roots: anArray - roots := anArray collect:[:item| PluggableTreeItemNode with: item model: self]. - self list: roots.! Item was removed: - ----- Method: PluggableTreeMorph>>selectPath:in: (in category 'updating') ----- - selectPath: path in: listItem - path isEmpty ifTrue: [^self setSelectedMorph: nil]. - listItem withSiblingsDo: [:each | - (each complexContents item = path first) ifTrue: [ - each isExpanded ifFalse: [ - each toggleExpandedState. - self adjustSubmorphPositions. - ]. - each changed. - path size = 1 ifTrue: [ - ^self setSelectedMorph: each - ]. - each firstChild ifNil: [^self setSelectedMorph: nil]. - ^self selectPath: path allButFirst in: each firstChild - ]. - ]. - ^self setSelectedMorph: nil - - ! Item was removed: - ----- Method: PluggableTreeMorph>>setSelectedMorph: (in category 'selection') ----- - setSelectedMorph: aMorph - selectedWrapper := aMorph complexContents. - self selection: selectedWrapper. - setSelectedSelector ifNotNil:[ - model - perform: setSelectedSelector - with: (selectedWrapper ifNotNil:[selectedWrapper item]). - ].! Item was removed: - ----- Method: PluggableTreeMorph>>setSelectedSelector (in category 'accessing') ----- - setSelectedSelector - ^setSelectedSelector! Item was removed: - ----- Method: PluggableTreeMorph>>setSelectedSelector: (in category 'accessing') ----- - setSelectedSelector: aSymbol - setSelectedSelector := aSymbol! Item was removed: - ----- Method: PluggableTreeMorph>>startDrag: (in category 'morphic') ----- - startDrag: evt - | ddm itemMorph passenger | - self dragEnabled - ifTrue: [itemMorph := scroller submorphs - detect: [:any | any highlightedForMouseDown] - ifNone: []]. - (itemMorph isNil - or: [evt hand hasSubmorphs]) - ifTrue: [^ self]. - itemMorph highlightForMouseDown: false. - itemMorph ~= self selectedMorph - ifTrue: [self setSelectedMorph: itemMorph]. - passenger := self model perform: dragItemSelector with: itemMorph withoutListWrapper. - passenger - ifNotNil: [ddm := TransferMorph withPassenger: passenger from: self. - ddm dragTransferType: #dragTransferPlus. - Preferences dragNDropWithAnimation - ifTrue: [self model dragAnimationFor: itemMorph transferMorph: ddm]. - evt hand grabMorph: ddm]. - evt hand releaseMouseFocus: self! Item was removed: - ----- Method: PluggableTreeMorph>>update: (in category 'updating') ----- - update: what - what ifNil:[^self]. - what == getRootsSelector ifTrue:[ - self roots: (model perform: getRootsSelector) - ]. - what == getSelectedPathSelector ifTrue:[ - ^self selectPath: (model perform: getSelectedPathSelector) - in: (scroller submorphs at: 1 ifAbsent: [^self]) - ]. - ^super update: what! Item was removed: - ----- Method: PluggableTreeMorph>>wantsDropSelector (in category 'accessing') ----- - wantsDropSelector - ^wantsDropSelector! Item was removed: - ----- Method: PluggableTreeMorph>>wantsDropSelector: (in category 'accessing') ----- - wantsDropSelector: aSymbol - wantsDropSelector := aSymbol! Item was removed: - ----- Method: PluggableTreeMorph>>wantsDroppedMorph:event: (in category 'morphic') ----- - wantsDroppedMorph: aMorph event: anEvent - aMorph dragTransferType == #dragTransferPlus ifFalse:[^false]. - dropItemSelector ifNil:[^false]. - wantsDropSelector ifNil:[^true]. - ^ (model perform: wantsDropSelector with: aMorph passenger) == true.! Item was removed: - ----- Method: PluggableTreeMorph>>wantsDroppedNode:on: (in category 'node access') ----- - wantsDroppedNode: srcNode on: dstNode - dropItemSelector ifNil:[^false]. - wantsDropSelector ifNil:[^true]. - ^(model perform: wantsDropSelector with: srcNode with: dstNode) == true!

1 0

The Trunk: ToolBuilder-Morphic-fbs.90.mcz
by commits＠source.squeak.org 31 May '13

31 May '13

1 0

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

Packages May 2013