[Pkg] Squeak3.10bc: ToolBuilder-Morphic-kph.22.mcz
squeak-dev-noreply at lists.squeakfoundation.org
squeak-dev-noreply at lists.squeakfoundation.org
Sat Dec 13 04:52:50 UTC 2008
A new version of ToolBuilder-Morphic was added to project Squeak3.10bc:
http://www.squeaksource.com/310bc/ToolBuilder-Morphic-kph.22.mcz
==================== Summary ====================
Name: ToolBuilder-Morphic-kph.22
Author: kph
Time: 13 December 2008, 4:52:49 am
UUID: 3431a71a-7e6c-4bc8-b8f7-06f071b127e2
Ancestors: ToolBuilder-Morphic-edc.21
Saved from SystemVersion
==================== Snapshot ====================
SystemOrganization addCategory: #'ToolBuilder-Morphic'!
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!
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.!
----- 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.
!
----- Method: PluggableListMorphByItemPlus>>getCurrentSelectionIndex (in category 'model access') -----
getCurrentSelectionIndex
"Answer the index of the current selection."
| item |
getIndexSelector == nil ifTrue: [^ 0].
item := model perform: getIndexSelector.
^ list findFirst: [ :x | x = item]
!
----- Method: PluggableListMorphByItemPlus>>getList (in category 'as yet unclassified') -----
getList
"cache the raw items in itemList"
itemList := getListSelector ifNil: [ #() ] ifNotNil: [ model perform: getListSelector ].
^super getList!
----- 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!
----- Method: PluggableListMorphPlus>>acceptDroppingMorph:event: (in category 'drag and drop') -----
acceptDroppingMorph: aMorph event: evt
| item |
dropItemSelector ifNil:[^self].
item := aMorph passenger.
model perform: dropItemSelector with: item with: potentialDropRow.
self resetPotentialDropRow.
evt hand releaseMouseFocus: self.
Cursor normal show.
!
----- Method: PluggableListMorphPlus>>dragItemSelector (in category 'accessing') -----
dragItemSelector
^dragItemSelector!
----- Method: PluggableListMorphPlus>>dragItemSelector: (in category 'accessing') -----
dragItemSelector: aSymbol
dragItemSelector := aSymbol.
aSymbol ifNotNil:[self dragEnabled: true].!
----- Method: PluggableListMorphPlus>>dropItemSelector (in category 'accessing') -----
dropItemSelector
^dropItemSelector!
----- Method: PluggableListMorphPlus>>dropItemSelector: (in category 'accessing') -----
dropItemSelector: aSymbol
dropItemSelector := aSymbol.
aSymbol ifNotNil:[self dropEnabled: true].!
----- Method: PluggableListMorphPlus>>startDrag: (in category 'drag and drop') -----
startDrag: evt
| ddm draggedItem dragIndex |
dragItemSelector ifNil:[^self].
evt hand hasSubmorphs ifTrue: [^ self].
[(self dragEnabled and: [model okToChange]) ifFalse: [^ self].
dragIndex := self rowAtLocation: evt position.
dragIndex = 0 ifTrue:[^self].
draggedItem := model perform: dragItemSelector with: 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]!
----- Method: PluggableListMorphPlus>>wantsDropSelector (in category 'accessing') -----
wantsDropSelector
^wantsDropSelector!
----- Method: PluggableListMorphPlus>>wantsDropSelector: (in category 'accessing') -----
wantsDropSelector: aSymbol
wantsDropSelector := aSymbol!
----- 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!
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.!
----- Method: PluggableSystemWindow>>addPaneMorph: (in category 'accessing') -----
addPaneMorph: aMorph
self addMorph: aMorph fullFrame: aMorph layoutFrame!
----- Method: PluggableSystemWindow>>closeWindowSelector (in category 'accessing') -----
closeWindowSelector
^closeWindowSelector!
----- Method: PluggableSystemWindow>>closeWindowSelector: (in category 'accessing') -----
closeWindowSelector: aSymbol
closeWindowSelector := aSymbol!
----- Method: PluggableSystemWindow>>delete (in category 'initialization') -----
delete
closeWindowSelector ifNotNil:[model perform: closeWindowSelector].
super delete.
!
----- Method: PluggableSystemWindow>>getChildrenSelector (in category 'accessing') -----
getChildrenSelector
^getChildrenSelector!
----- Method: PluggableSystemWindow>>getChildrenSelector: (in category 'accessing') -----
getChildrenSelector: aSymbol
getChildrenSelector := aSymbol!
----- Method: PluggableSystemWindow>>getLabelSelector (in category 'accessing') -----
getLabelSelector
^getLabelSelector!
----- Method: PluggableSystemWindow>>getLabelSelector: (in category 'accessing') -----
getLabelSelector: aSymbol
getLabelSelector := aSymbol.
self update: aSymbol.!
----- Method: PluggableSystemWindow>>label (in category 'accessing') -----
label
^label contents!
----- Method: PluggableSystemWindow>>label: (in category 'accessing') -----
label: aString
self setLabel: aString.!
----- 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!
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.!
----- Method: MorphicToolBuilder class>>isActiveBuilder (in category 'accessing') -----
isActiveBuilder
"Answer whether I am the currently active builder"
^Smalltalk isMorphic!
----- Method: MorphicToolBuilder>>add:to: (in category 'private') -----
add: aMorph to: aParent
aParent addMorphBack: aMorph.
aParent isSystemWindow ifTrue:[
aParent addPaneMorph: aMorph.
].!
----- 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!
----- Method: MorphicToolBuilder>>buildPluggableActionButton: (in category 'pluggable widgets') -----
buildPluggableActionButton: aSpec
| button |
button := self buildPluggableButton: aSpec.
button beActionButton.
^button!
----- Method: MorphicToolBuilder>>buildPluggableButton: (in category 'pluggable widgets') -----
buildPluggableButton: aSpec
| widget label state action enabled |
label := aSpec label.
state := aSpec state.
action := aSpec action.
widget := PluggableButtonMorphPlus on: aSpec model
getState: (state isSymbol ifTrue:[state])
action: nil
label: (label isSymbol ifTrue:[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 transparent.
aSpec help ifNotNil:[widget setBalloonText: aSpec help].
(label isSymbol or:[label == nil]) ifFalse:[widget label: label].
self setFrame: aSpec frame in: widget.
parent ifNotNil:[self add: widget to: parent].
^widget!
----- Method: MorphicToolBuilder>>buildPluggableInputField: (in category 'pluggable widgets') -----
buildPluggableInputField: aSpec
| widget |
widget := self buildPluggableText: aSpec.
widget acceptOnCR: true.
widget hideScrollBarsIndefinitely.
^widget!
----- Method: MorphicToolBuilder>>buildPluggableList: (in category 'pluggable widgets') -----
buildPluggableList: aSpec
| widget listClass getIndex setIndex |
aSpec getSelected ifNil:[
listClass := PluggableListMorphPlus.
getIndex := aSpec getIndex.
setIndex := aSpec setIndex.
] ifNotNil:[
listClass := PluggableListMorphByItemPlus.
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 dragItemSelector: aSpec dragItem.
widget dropItemSelector: aSpec dropItem.
widget wantsDropSelector: aSpec dropAccept.
widget autoDeselect: aSpec autoDeselect.
self setFrame: aSpec frame in: widget.
parent ifNotNil:[self add: widget to: parent].
panes ifNotNil:[
aSpec list ifNotNil:[panes add: aSpec list].
].
^widget!
----- Method: MorphicToolBuilder>>buildPluggableMenu: (in category 'building') -----
buildPluggableMenu: menuSpec
| prior menu |
prior := parentMenu.
parentMenu := menu := MenuMorph new.
menuSpec label ifNotNil:[parentMenu addTitle: menuSpec label].
menuSpec items do:[:each| each buildWith: self].
parentMenu := prior.
^menu!
----- Method: MorphicToolBuilder>>buildPluggableMenuItem: (in category 'building') -----
buildPluggableMenuItem: itemSpec
| item action label menu |
item _ MenuItemMorph 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].
^item!
----- Method: MorphicToolBuilder>>buildPluggableMultiSelectionList: (in category 'pluggable widgets') -----
buildPluggableMultiSelectionList: aSpec
| widget listClass |
aSpec getSelected ifNotNil:[^self error:'There is no PluggableListMorphOfManyByItem'].
listClass := PluggableListMorphOfMany.
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.
self setFrame: aSpec frame in: widget.
parent ifNotNil:[self add: widget to: parent].
panes ifNotNil:[
aSpec list ifNotNil:[panes add: aSpec list].
].
^widget!
----- Method: MorphicToolBuilder>>buildPluggablePanel: (in category 'pluggable widgets') -----
buildPluggablePanel: aSpec
| widget children |
widget := PluggablePanelMorph 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 setFrame: aSpec frame in: widget.
parent ifNotNil:[self add: widget to: parent].
self setLayout: aSpec layout in: widget.
^widget!
----- Method: MorphicToolBuilder>>buildPluggableText: (in category 'pluggable widgets') -----
buildPluggableText: aSpec
| widget |
widget := PluggableTextMorphPlus on: aSpec model
text: aSpec getText
accept: aSpec setText
readSelection: aSpec selection
menu: aSpec menu.
self register: widget id: aSpec name.
widget getColorSelector: aSpec color.
self setFrame: aSpec frame in: widget.
parent ifNotNil:[self add: widget to: parent].
panes ifNotNil:[
aSpec getText ifNotNil:[panes add: aSpec getText].
].
^widget!
----- Method: MorphicToolBuilder>>buildPluggableTree: (in category 'pluggable widgets') -----
buildPluggableTree: aSpec
| widget |
widget := PluggableTreeMorph 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.
self setFrame: aSpec frame in: widget.
parent ifNotNil:[self add: widget to: parent].
panes ifNotNil:[
aSpec roots ifNotNil:[panes add: aSpec roots].
].
^widget!
----- Method: MorphicToolBuilder>>buildPluggableWindow: (in category 'pluggable widgets') -----
buildPluggableWindow: aSpec
| widget children label |
aSpec layout == #proportional ifFalse:[
"This needs to be implemented - probably by adding a single pane and then the rest"
^self error: 'Not implemented'.
].
widget := PluggableSystemWindow new.
self register: widget id: aSpec name.
widget model: aSpec model.
(label := aSpec label) ifNotNil:[
label isSymbol
ifTrue:[widget getLabelSelector: label]
ifFalse:[widget setLabel: label]].
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.
aSpec extent ifNotNil:[widget extent: aSpec extent].
widget setUpdatablePanesFrom: panes.
^widget!
----- Method: MorphicToolBuilder>>close: (in category 'opening') -----
close: aWidget
"Close a previously opened widget"
aWidget delete!
----- Method: MorphicToolBuilder>>open: (in category 'opening') -----
open: anObject
"Build and open the object. Answer the widget opened."
| morph |
morph := self build: anObject.
(morph isKindOf: MenuMorph)
ifTrue:[morph popUpInWorld: World].
(morph isKindOf: SystemWindow)
ifTrue:[morph openInWorldExtent: morph extent]
ifFalse:[morph openInWorld].
^morph!
----- 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!
----- Method: MorphicToolBuilder>>register:id: (in category 'private') -----
register: widget id: id
id ifNil:[^self].
widgets ifNil:[widgets := Dictionary new].
widgets at: id put: widget.!
----- 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.
].
!
----- Method: MorphicToolBuilder>>setFrame:in: (in category 'private') -----
setFrame: aRectangle in: widget
| frame |
aRectangle ifNil:[^nil].
frame := self asFrame: aRectangle.
widget layoutFrame: frame.
widget hResizing: #spaceFill; vResizing: #spaceFill.
(parent isSystemWindow) ifTrue:[
widget borderWidth: 2; borderColor: #inset.
].!
----- 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].
"and then some..."
^self].
layout == #vertical ifTrue:[
widget layoutPolicy: TableLayout new.
widget listDirection: #topToBottom.
widget submorphsDo:[:m| m hResizing: #spaceFill; vResizing: #spaceFill].
"and then some..."
^self].
^self error: 'Unknown layout: ', layout.!
----- Method: MorphicToolBuilder>>widgetAt:ifAbsent: (in category 'private') -----
widgetAt: id ifAbsent: aBlock
widgets ifNil:[^aBlock value].
^widgets at: id ifAbsent: aBlock!
PluggableTextMorph subclass: #PluggableTextMorphPlus
instanceVariableNames: 'getColorSelector acceptAction'
classVariableNames: ''
poolDictionaries: ''
category: 'ToolBuilder-Morphic'!
!PluggableTextMorphPlus commentStamp: 'ar 2/11/2005 21:53' prior: 0!
A pluggable text morph with support for color.!
----- Method: PluggableTextMorphPlus>>accept (in category 'updating') -----
accept
super accept.
acceptAction ifNotNil:[acceptAction value: textMorph asText].!
----- Method: PluggableTextMorphPlus>>acceptAction (in category 'accessing') -----
acceptAction
^acceptAction!
----- Method: PluggableTextMorphPlus>>acceptAction: (in category 'accessing') -----
acceptAction: anAction
acceptAction := anAction!
----- Method: PluggableTextMorphPlus>>getColorSelector (in category 'accessing') -----
getColorSelector
^getColorSelector!
----- Method: PluggableTextMorphPlus>>getColorSelector: (in category 'accessing') -----
getColorSelector: aSymbol
getColorSelector := aSymbol.
self update: getColorSelector.!
----- Method: PluggableTextMorphPlus>>update: (in category 'updating') -----
update: what
what ifNil:[^self].
what == getColorSelector ifTrue:[self color: (model perform: getColorSelector)].
^super update: what!
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.!
----- Method: PluggablePanelMorph>>getChildrenSelector (in category 'accessing') -----
getChildrenSelector
^getChildrenSelector!
----- Method: PluggablePanelMorph>>getChildrenSelector: (in category 'accessing') -----
getChildrenSelector: aSymbol
getChildrenSelector := aSymbol.!
----- Method: PluggablePanelMorph>>model (in category 'accessing') -----
model
^model!
----- Method: PluggablePanelMorph>>model: (in category 'accessing') -----
model: aModel
model ifNotNil:[model removeDependent: self].
model := aModel.
model ifNotNil:[model addDependent: self].!
----- 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].
].!
UIManager subclass: #MorphicUIManager
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'ToolBuilder-Morphic'!
!MorphicUIManager commentStamp: 'ar 2/11/2005 21:52' prior: 0!
The Morphic ui manager.!
----- Method: MorphicUIManager class>>isActiveManager (in category 'accessing') -----
isActiveManager
"Answer whether I should act as the active ui manager"
^Smalltalk isMorphic!
----- Method: MorphicUIManager>>chooseDirectory:from: (in category 'ui requests') -----
chooseDirectory: label from: dir
"Let the user choose a directory"
^FileList2 modalFolderSelector: dir!
----- 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]!
----- 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."
| menu |
menu := PopUpMenu labelArray: aList lines: linesArray.
^aString isEmpty ifTrue:[menu startUp] ifFalse:[menu startUpWithCaption: aString]!
----- 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."
| menu |
menu := SelectionMenu labels: labelList lines: linesArray selections: valueList.
^aString isEmpty ifTrue:[menu startUp] ifFalse:[menu startUpWithCaption: aString]!
----- 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."
^PopUpMenu confirm: queryString!
----- 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."
^PopUpMenu confirm: aString orCancel: cancelBlock!
----- 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."
^ProgressInitiationException
display: titleString
at: aPoint
from: minVal
to: maxVal
during: workBlock!
----- Method: MorphicUIManager>>edit:label:accept: (in category 'ui requests') -----
edit: aText label: labelString accept: anAction
"Open an editor on the given string/text"
| window holder text |
holder := Workspace new.
holder contents: aText.
text := PluggableTextMorphPlus
on: holder
text: #contents
accept: #acceptContents:
readSelection: nil
menu: nil.
text acceptAction: anAction.
window := SystemWindow new.
labelString ifNotNil:[window setLabel: labelString].
window model: holder .
window addMorph: text frame: (0 at 0 extent: 1 at 1).
window paneColor: Color gray.
window openInWorld.
^ window !
----- Method: MorphicUIManager>>inform: (in category 'ui requests') -----
inform: aString
"Display a message for the user to read and then dismiss"
^PopUpMenu inform: aString!
----- 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]]"
(MVCMenuMorph from: (SelectionMenu labels: '') title: ' ')
informUserAt: Sensor cursorPoint during: aBlock.!
----- 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."
^FillInTheBlank multiLineRequest: queryString centerAt: aPoint initialAnswer: defaultAnswer answerHeight: answerHeight!
----- 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."
^FillInTheBlank request: queryString initialAnswer: defaultAnswer !
----- 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."
^FillInTheBlank requestPassword: queryString!
SimpleHierarchicalListMorph subclass: #PluggableTreeMorph
instanceVariableNames: 'roots selectedWrapper getRootsSelector getChildrenSelector hasChildrenSelector getLabelSelector getIconSelector getSelectedPathSelector setSelectedSelector getHelpSelector dropItemSelector wantsDropSelector'
classVariableNames: ''
poolDictionaries: ''
category: 'ToolBuilder-Morphic'!
!PluggableTreeMorph commentStamp: 'ar 2/12/2005 04:38' prior: 0!
A pluggable tree morph.!
----- Method: PluggableTreeMorph>>balloonTextForNode: (in category 'node access') -----
balloonTextForNode: node
getHelpSelector ifNil:[^nil].
^model perform: getHelpSelector with: node item!
----- 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]!
----- Method: PluggableTreeMorph>>dropItemSelector (in category 'accessing') -----
dropItemSelector
^dropItemSelector!
----- Method: PluggableTreeMorph>>dropItemSelector: (in category 'accessing') -----
dropItemSelector: aSymbol
dropItemSelector := aSymbol!
----- Method: PluggableTreeMorph>>dropNode:on: (in category 'node access') -----
dropNode: srcNode on: dstNode
dropItemSelector ifNil:[^nil].
model perform: dropItemSelector with: srcNode item with: dstNode item!
----- Method: PluggableTreeMorph>>getChildrenSelector (in category 'accessing') -----
getChildrenSelector
^getChildrenSelector!
----- Method: PluggableTreeMorph>>getChildrenSelector: (in category 'accessing') -----
getChildrenSelector: aSymbol
getChildrenSelector := aSymbol.!
----- Method: PluggableTreeMorph>>getHelpSelector (in category 'accessing') -----
getHelpSelector
^getHelpSelector!
----- Method: PluggableTreeMorph>>getHelpSelector: (in category 'accessing') -----
getHelpSelector: aSymbol
getHelpSelector := aSymbol!
----- Method: PluggableTreeMorph>>getIconSelector (in category 'accessing') -----
getIconSelector
^getIconSelector!
----- Method: PluggableTreeMorph>>getIconSelector: (in category 'accessing') -----
getIconSelector: aSymbol
getIconSelector := aSymbol!
----- Method: PluggableTreeMorph>>getLabelSelector (in category 'accessing') -----
getLabelSelector
^getLabelSelector!
----- Method: PluggableTreeMorph>>getLabelSelector: (in category 'accessing') -----
getLabelSelector: aSymbol
getLabelSelector := aSymbol!
----- Method: PluggableTreeMorph>>getMenuSelector (in category 'accessing') -----
getMenuSelector
^getMenuSelector!
----- Method: PluggableTreeMorph>>getMenuSelector: (in category 'accessing') -----
getMenuSelector: aSymbol
getMenuSelector := aSymbol!
----- Method: PluggableTreeMorph>>getRootsSelector (in category 'accessing') -----
getRootsSelector
^getRootsSelector!
----- Method: PluggableTreeMorph>>getRootsSelector: (in category 'accessing') -----
getRootsSelector: aSelector
getRootsSelector := aSelector.
self update: getRootsSelector.!
----- Method: PluggableTreeMorph>>getSelectedPathSelector (in category 'accessing') -----
getSelectedPathSelector
^getSelectedPathSelector!
----- Method: PluggableTreeMorph>>getSelectedPathSelector: (in category 'accessing') -----
getSelectedPathSelector: aSymbol
getSelectedPathSelector := aSymbol.!
----- Method: PluggableTreeMorph>>hasChildrenSelector (in category 'accessing') -----
hasChildrenSelector
^hasChildrenSelector!
----- Method: PluggableTreeMorph>>hasChildrenSelector: (in category 'accessing') -----
hasChildrenSelector: aSymbol
hasChildrenSelector := aSymbol!
----- Method: PluggableTreeMorph>>hasNodeContents: (in category 'node access') -----
hasNodeContents: node
hasChildrenSelector ifNil:[^node contents isEmpty not].
^model perform: hasChildrenSelector with: node item!
----- Method: PluggableTreeMorph>>iconOfNode: (in category 'node access') -----
iconOfNode: node
getIconSelector ifNil:[^nil].
^model perform: getIconSelector with: node item!
----- Method: PluggableTreeMorph>>isDraggableNode: (in category 'node access') -----
isDraggableNode: node
^true!
----- Method: PluggableTreeMorph>>keystrokeActionSelector (in category 'accessing') -----
keystrokeActionSelector
^keystrokeActionSelector!
----- Method: PluggableTreeMorph>>keystrokeActionSelector: (in category 'accessing') -----
keystrokeActionSelector: aSymbol
keystrokeActionSelector := aSymbol!
----- Method: PluggableTreeMorph>>printNode: (in category 'node access') -----
printNode: node
getLabelSelector ifNil:[^node item printString].
^model perform: getLabelSelector with: node item!
----- Method: PluggableTreeMorph>>roots (in category 'accessing') -----
roots
^roots!
----- Method: PluggableTreeMorph>>roots: (in category 'accessing') -----
roots: anArray
roots := anArray collect:[:item| PluggableTreeItemNode with: item model: self].
self list: roots.!
----- 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
!
----- Method: PluggableTreeMorph>>setSelectedMorph: (in category 'selection') -----
setSelectedMorph: aMorph
selectedWrapper := aMorph complexContents.
self selection: selectedWrapper.
setSelectedSelector ifNotNil:[
model
perform: setSelectedSelector
with: (selectedWrapper ifNotNil:[selectedWrapper item]).
].!
----- Method: PluggableTreeMorph>>setSelectedSelector (in category 'accessing') -----
setSelectedSelector
^setSelectedSelector!
----- Method: PluggableTreeMorph>>setSelectedSelector: (in category 'accessing') -----
setSelectedSelector: aSymbol
setSelectedSelector := aSymbol!
----- 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!
----- Method: PluggableTreeMorph>>wantsDropSelector (in category 'accessing') -----
wantsDropSelector
^wantsDropSelector!
----- Method: PluggableTreeMorph>>wantsDropSelector: (in category 'accessing') -----
wantsDropSelector: aSymbol
wantsDropSelector := aSymbol!
----- 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!
ListItemWrapper subclass: #PluggableTreeItemNode
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'ToolBuilder-Morphic'!
!PluggableTreeItemNode commentStamp: 'ar 2/12/2005 04:37' prior: 0!
Tree item for PluggableTreeMorph.!
----- Method: PluggableTreeItemNode>>acceptDroppingObject: (in category 'accessing') -----
acceptDroppingObject: anotherItem
^model dropNode: anotherItem on: self!
----- Method: PluggableTreeItemNode>>asString (in category 'accessing') -----
asString
^model printNode: self!
----- Method: PluggableTreeItemNode>>balloonText (in category 'accessing') -----
balloonText
^model balloonTextForNode: self!
----- Method: PluggableTreeItemNode>>canBeDragged (in category 'accessing') -----
canBeDragged
^model isDraggableNode: self!
----- Method: PluggableTreeItemNode>>contents (in category 'accessing') -----
contents
^model contentsOfNode: self!
----- Method: PluggableTreeItemNode>>hasContents (in category 'accessing') -----
hasContents
^model hasNodeContents: self!
----- Method: PluggableTreeItemNode>>icon (in category 'accessing') -----
icon
^model iconOfNode: self!
----- Method: PluggableTreeItemNode>>item (in category 'accessing') -----
item
^item!
----- Method: PluggableTreeItemNode>>wantsDroppedObject: (in category 'accessing') -----
wantsDroppedObject: anotherItem
^model wantsDroppedNode: anotherItem on: self!
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.!
----- Method: MorphicToolBuilderTests>>acceptWidgetText (in category 'support') -----
acceptWidgetText
widget hasUnacceptedEdits: true.
widget accept.!
----- Method: MorphicToolBuilderTests>>buttonWidgetEnabled (in category 'support') -----
buttonWidgetEnabled
"Answer whether the current widget (a button) is currently enabled"
^widget enabled!
----- Method: MorphicToolBuilderTests>>changeListWidget (in category 'support') -----
changeListWidget
widget changeModelSelection: widget getCurrentSelectionIndex + 1.!
----- Method: MorphicToolBuilderTests>>fireButtonWidget (in category 'support') -----
fireButtonWidget
widget performAction.!
----- Method: MorphicToolBuilderTests>>fireMenuItemWidget (in category 'support') -----
fireMenuItemWidget
(widget itemWithWording: 'Menu Item')
ifNotNilDo: [:item | item doButtonAction]!
----- Method: MorphicToolBuilderTests>>setUp (in category 'support') -----
setUp
super setUp.
builder := MorphicToolBuilder new.!
----- Method: MorphicToolBuilderTests>>testWindowDynamicLabel (in category 'tests-window') -----
testWindowDynamicLabel
self makeWindow.
self assert: (widget label = 'TestLabel').!
----- 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').!
----- Method: MorphicToolBuilderTests>>widgetColor (in category 'support') -----
widgetColor
"Answer color from widget"
^widget color!
PluggableButtonMorph subclass: #PluggableButtonMorphPlus
instanceVariableNames: 'enabled action getColorSelector getEnabledSelector'
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.!
----- Method: PluggableButtonMorphPlus>>action (in category 'accessing') -----
action
^action!
----- Method: PluggableButtonMorphPlus>>action: (in category 'accessing') -----
action: anAction
action := nil.
anAction isSymbol ifTrue:[^super action: anAction].
action := anAction.!
----- Method: PluggableButtonMorphPlus>>beActionButton (in category 'initialize-release') -----
beActionButton
"Make me like an action button"
self borderWidth: 2.
self borderColor: #raised.
self onColor: Color transparent offColor: Color transparent.
self cornerStyle: #rounded.!
----- Method: PluggableButtonMorphPlus>>enabled (in category 'accessing') -----
enabled
^enabled!
----- 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]]!
----- Method: PluggableButtonMorphPlus>>getColorSelector (in category 'accessing') -----
getColorSelector
^getColorSelector!
----- Method: PluggableButtonMorphPlus>>getColorSelector: (in category 'accessing') -----
getColorSelector: aSymbol
getColorSelector := aSymbol.
self update: getColorSelector.!
----- Method: PluggableButtonMorphPlus>>getEnabledSelector (in category 'accessing') -----
getEnabledSelector
^getEnabledSelector!
----- Method: PluggableButtonMorphPlus>>getEnabledSelector: (in category 'accessing') -----
getEnabledSelector: aSymbol
getEnabledSelector := aSymbol.
self update: aSymbol.!
----- Method: PluggableButtonMorphPlus>>initialize (in category 'initialize-release') -----
initialize
super initialize.
enabled := true.
self color: Color transparent.!
----- Method: PluggableButtonMorphPlus>>mouseDown: (in category 'action') -----
mouseDown: evt
enabled ifFalse:[^self].
^super mouseDown: evt!
----- Method: PluggableButtonMorphPlus>>mouseMove: (in category 'action') -----
mouseMove: evt
enabled ifFalse:[^self].
^super mouseMove: evt!
----- Method: PluggableButtonMorphPlus>>mouseUp: (in category 'action') -----
mouseUp: evt
enabled ifFalse:[^self].
^super mouseUp: evt!
----- 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.!
----- Method: PluggableButtonMorphPlus>>performAction (in category 'action') -----
performAction
enabled ifFalse:[^self].
action ifNotNil:[^action value].
^super performAction!
----- Method: PluggableButtonMorphPlus>>update: (in category 'updating') -----
update: what
what ifNil:[^self].
what == getLabelSelector ifTrue: [
self label: (model perform: getLabelSelector)].
what == getColorSelector ifTrue: [
color := (model perform: getColorSelector).
self onColor: color offColor: color.
self changed.
].
what == getStateSelector ifTrue:[
self getModelState
ifTrue: [self color: onColor]
ifFalse: [self color: offColor].
].
what == getEnabledSelector ifTrue:[^self enabled: (model perform: getEnabledSelector)].!
More information about the Packages
mailing list