[squeak-dev] Squeak 4.5: ToolBuilder-Morphic-fbs.91.mcz

commits at source.squeak.org commits at source.squeak.org
Fri Jan 24 20:17:03 UTC 2014


Chris Muller uploaded a new version of ToolBuilder-Morphic to project Squeak 4.5:
http://source.squeak.org/squeak45/ToolBuilder-Morphic-fbs.91.mcz

==================== Summary ====================

Name: ToolBuilder-Morphic-fbs.91
Author: fbs
Time: 9 January 2014, 2:56:27.235 pm
UUID: abaa076b-af43-af42-8c98-7a71482c6a30
Ancestors: ToolBuilder-Morphic-fbs.90

Move the ToolBuilder classes back to ToolBuilder-Morphic: this way you can have Morphic with or without ToolBuilder.

==================== Snapshot ====================

SystemOrganization addCategory: #'ToolBuilder-Morphic'!

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>>alternateMultiSelectListClass (in category 'widget classes') -----
alternateMultiSelectListClass
	^ AlternatePluggableListMorphOfMany !

----- 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>>buildHelpFor:spec: (in category 'pluggable widgets') -----
buildHelpFor: widget spec: aSpec
	aSpec help
		ifNotNil: [widget setBalloonText: aSpec help]!

----- Method: MorphicToolBuilder>>buildPluggableActionButton: (in category 'pluggable widgets') -----
buildPluggableActionButton: aSpec
	| button |
	button := self buildPluggableButton: aSpec.
	button color: Color white.
	^button!

----- 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: SystemBrowser 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!

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

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

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

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

----- 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 := 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!

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

----- Method: MorphicToolBuilder>>buildPluggableMenuItem: (in category 'building') -----
buildPluggableMenuItem: itemSpec
	| item action label menu |
	item := self menuItemClass new.
	label := (itemSpec isCheckable
		ifTrue: [	itemSpec checked ifTrue: ['<on>'] ifFalse: ['<off>']]
		ifFalse: ['']), itemSpec 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!

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

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

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

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

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

----- Method: MorphicToolBuilder>>buttonClass (in category 'widget classes') -----
buttonClass
	^ PluggableButtonMorphPlus!

----- Method: MorphicToolBuilder>>checkBoxClass (in category 'widget classes') -----
checkBoxClass
	^ PluggableCheckBoxMorph!

----- Method: MorphicToolBuilder>>close: (in category 'opening') -----
close: aWidget
	"Close a previously opened widget"
	aWidget delete!

----- Method: MorphicToolBuilder>>codePaneClass (in category 'widget classes') -----
codePaneClass
	^ PluggableTextMorphPlus!

----- Method: MorphicToolBuilder>>dropDownListClass (in category 'widget classes') -----
dropDownListClass
	^ PluggableDropDownListMorph!

----- Method: MorphicToolBuilder>>listByItemClass (in category 'widget classes') -----
listByItemClass
	^ PluggableListMorphByItemPlus!

----- Method: MorphicToolBuilder>>listClass (in category 'widget classes') -----
listClass
	^ PluggableListMorphPlus!

----- Method: MorphicToolBuilder>>menuClass (in category 'widget classes') -----
menuClass
	^ MenuMorph!

----- Method: MorphicToolBuilder>>menuItemClass (in category 'widget classes') -----
menuItemClass
	^ MenuItemMorph!

----- Method: MorphicToolBuilder>>multiSelectListClass (in category 'widget classes') -----
multiSelectListClass
	^ PluggableListMorphOfMany!

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

----- 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>>panelClass (in category 'widget classes') -----
panelClass
	^ PluggablePanelMorph!

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

----- 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 := 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.
	].!

----- 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 at 1.
		widget layoutInset: 1 at 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 at 1.
		widget layoutInset: 1 at 1.
		widget color: Color transparent.
		"and then some..."
		^self].
	^self error: 'Unknown layout: ', layout.!

----- Method: MorphicToolBuilder>>textPaneClass (in category 'widget classes') -----
textPaneClass
	^ PluggableTextMorphPlus!

----- Method: MorphicToolBuilder>>treeClass (in category 'widget classes') -----
treeClass
	^ PluggableTreeMorph!

----- Method: MorphicToolBuilder>>widgetAt:ifAbsent: (in category 'private') -----
widgetAt: id ifAbsent: aBlock
	widgets ifNil:[^aBlock value].
	^widgets at: id ifAbsent: aBlock!

----- Method: MorphicToolBuilder>>windowClass (in category 'widget classes') -----
windowClass
	^ PluggableSystemWindow!

----- Method: MorphicToolBuilder>>windowClassFor: (in category 'widget classes') -----
windowClassFor: aSpec
	aSpec isDialog ifTrue: [^ PluggableDialogWindow].
	^aSpec multiWindowStyle
		caseOf:
		{	[nil]				->	[PluggableSystemWindow].
			[#labelButton]	->	[PluggableSystemWindowWithLabelButton] }
		otherwise:				[PluggableSystemWindowWithLabelButton]!

AlignmentMorph subclass: #PluggableCheckBoxMorph
	instanceVariableNames: 'model actionSelector valueSelector label'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ToolBuilder-Morphic'!

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

----- Method: PluggableCheckBoxMorph>>actionSelector (in category 'accessing') -----
actionSelector
	"Answer the value of actionSelector"

	^ actionSelector!

----- Method: PluggableCheckBoxMorph>>actionSelector: (in category 'accessing') -----
actionSelector: anObject
	"Set the value of actionSelector"

	actionSelector := anObject!

----- Method: PluggableCheckBoxMorph>>basicPanel (in category 'installing') -----
basicPanel
	^BorderedMorph new
		beTransparent;
		extent: 0 at 0;
		borderWidth: 0;
		layoutInset: 0;
		cellInset: 0;
		layoutPolicy: TableLayout new;
		listCentering: #topLeft;
		cellPositioning: #center;
		hResizing: #spaceFill;
		vResizing: #shrinkWrap;
		yourself!

----- Method: PluggableCheckBoxMorph>>horizontalPanel (in category 'installing') -----
horizontalPanel
	^self basicPanel
		cellPositioning: #center;
		listDirection: #leftToRight;
		yourself.!

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

----- Method: PluggableCheckBoxMorph>>label (in category 'accessing') -----
label
	"Answer the value of label"

	^ label!

----- Method: PluggableCheckBoxMorph>>label: (in category 'accessing') -----
label: anObject
	"Set the value of label"

	label := anObject!

----- Method: PluggableCheckBoxMorph>>model (in category 'accessing') -----
model
	"Answer the value of model"

	^ model.
!

----- Method: PluggableCheckBoxMorph>>model: (in category 'accessing') -----
model: anObject
	"Set the value of model"

	model := anObject!

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

----- Method: PluggableCheckBoxMorph>>valueSelector (in category 'accessing') -----
valueSelector
	"Answer the value of valueSelector"

	^ valueSelector!

----- Method: PluggableCheckBoxMorph>>valueSelector: (in category 'accessing') -----
valueSelector: anObject
	"Set the value of valueSelector"

	valueSelector := anObject!

AlignmentMorph subclass: #PluggableDropDownListMorph
	instanceVariableNames: 'model listSelector selectionSelector selectionSetter'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ToolBuilder-Morphic'!

----- Method: PluggableDropDownListMorph>>basicPanel (in category 'drawing') -----
basicPanel
	^BorderedMorph new
		beTransparent;
		extent: 0 at 0;
		borderWidth: 0;
		layoutInset: 0;
		cellInset: 0;
		layoutPolicy: TableLayout new;
		listCentering: #topLeft;
		cellPositioning: #center;
		hResizing: #spaceFill;
		vResizing: #shrinkWrap;
		yourself!

----- Method: PluggableDropDownListMorph>>currentSelection (in category 'accessing') -----
currentSelection

	^ self model perform: selectionSelector!

----- Method: PluggableDropDownListMorph>>currentSelection: (in category 'accessing') -----
currentSelection: obj

	^ self model perform: selectionSetter with: obj!

----- Method: PluggableDropDownListMorph>>horizontalPanel (in category 'drawing') -----
horizontalPanel
	^self basicPanel
		cellPositioning: #center;
		listDirection: #leftToRight;
		yourself.!

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

----- Method: PluggableDropDownListMorph>>list (in category 'accessing') -----
list
	"Answer the value of list"

	^ self model perform: self listSelector.
	!

----- Method: PluggableDropDownListMorph>>listSelector (in category 'accessing') -----
listSelector
	"Answer the value of listSelector"

	^ listSelector!

----- Method: PluggableDropDownListMorph>>listSelector: (in category 'accessing') -----
listSelector: anObject
	"Set the value of listSelector"

	listSelector := anObject!

----- Method: PluggableDropDownListMorph>>model (in category 'accessing') -----
model
	^ model!

----- Method: PluggableDropDownListMorph>>model: (in category 'accessing') -----
model: anObject
	"Set the value of model"

	model := anObject!

----- Method: PluggableDropDownListMorph>>selectionSelector (in category 'accessing') -----
selectionSelector
	"Answer the value of selectionSelector"

	^ selectionSelector!

----- Method: PluggableDropDownListMorph>>selectionSelector: (in category 'accessing') -----
selectionSelector: anObject
	"Set the value of selectionSelector"

	selectionSelector := anObject!

----- Method: PluggableDropDownListMorph>>selectionSetter (in category 'accessing') -----
selectionSetter
	"Answer the value of selectionSetter"

	^ selectionSetter!

----- Method: PluggableDropDownListMorph>>selectionSetter: (in category 'accessing') -----
selectionSetter: anObject
	"Set the value of selectionSetter"

	selectionSetter := anObject!

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>>canBeEncroached (in category 'private') -----
canBeEncroached
	^ submorphs allSatisfy:
		[ : each | each canBeEncroached ]!

----- Method: PluggablePanelMorph>>children (in category 'accessing') -----
children
	^ model perform: getChildrenSelector!

----- 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: selectorSymbolOrNil 
	selectorSymbolOrNil ifNil: [ ^ self ].
	selectorSymbolOrNil = getChildrenSelector ifTrue:
		[ self
			 removeAllMorphs ;
			 addAllMorphs: self children ;
			 submorphsDo:
				[ : m | m
					 hResizing: #spaceFill ;
					 vResizing: #spaceFill ] ]!

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.
	^ itemList 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 isNil | potentialDropRow isNil ifTrue: [^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 
	
	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]!

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

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!

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

----- Method: MorphicUIManager class>>isActiveManager (in category 'accessing') -----
isActiveManager
	"Answer whether I should act as the active ui manager"
	^Smalltalk isMorphic!

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

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

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

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

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

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

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

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

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

----- Method: MorphicUIManager>>inform: (in category 'ui requests') -----
inform: aString
	"Display a message for the user to read and then dismiss"
	^UserDialogBoxMorph 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]]"
	SystemProgressMorph
		informUserAt: nil during: aBlock.!

----- Method: MorphicUIManager>>initialize (in category 'initialize-release') -----
initialize
	toolBuilder := MorphicToolBuilder new!

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

----- Method: MorphicUIManager>>newDisplayDepthNoRestore: (in category 'display') -----
newDisplayDepthNoRestore: pixelSize
	"Change depths.  Check if there is enough space!!  , di"
	| area need |
	pixelSize = Display depth ifTrue: [^ self  "no change"].
	pixelSize abs < Display depth ifFalse:
		["Make sure there is enough space"
		area := Display boundingBox area. "pixels"

		need := (area * (pixelSize abs - Display depth) // 8)  "new bytes needed"
				+ Smalltalk lowSpaceThreshold.
		(Smalltalk garbageCollectMost <= need
			and: [Smalltalk garbageCollect <= need])
			ifTrue: [self error: 'Insufficient free space']].
	Display setExtent: Display extent depth: pixelSize.

	DisplayScreen startUp!

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

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

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

----- Method: MorphicUIManager>>restoreDisplay (in category 'display') -----
restoreDisplay
	"Restore the bits on Display"
	Project current ifNotNil:[:p| p invalidate; restore].!

----- Method: MorphicUIManager>>restoreDisplayAfter: (in category 'display') -----
restoreDisplayAfter: aBlock
	"Evaluate the block, wait for a mouse click, and then restore the screen."

	aBlock value.
	Sensor waitButton.
	self restoreDisplay!

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

PluggableSystemWindow subclass: #PluggableDialogWindow
	instanceVariableNames: 'statusValue'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ToolBuilder-Morphic'!

----- Method: PluggableDialogWindow>>statusValue (in category 'as yet unclassified') -----
statusValue
	^statusValue!

----- Method: PluggableDialogWindow>>statusValue: (in category 'as yet unclassified') -----
statusValue: val
	statusValue := val!

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

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

----- Method: ListChooser class>>chooseFrom: (in category 'ChooserTool compatibility') -----
chooseFrom: aList
	^ self 
		chooseFrom: aList 
		title: self defaultTitle!

----- Method: ListChooser class>>chooseFrom:title: (in category 'ChooserTool compatibility') -----
chooseFrom: aList title: aString
	^ self
		chooseIndexFrom: aList 
		title: aString
		addAllowed: false!

----- Method: ListChooser class>>chooseIndexFrom: (in category 'instance creation') -----
chooseIndexFrom: aList
	^ self 
		chooseIndexFrom: aList 
		title: self defaultTitle!

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

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

----- Method: ListChooser class>>chooseItemFrom: (in category 'instance creation') -----
chooseItemFrom: aList
	^ self 
		chooseItemFrom: aList 
		title: self defaultTitle!

----- Method: ListChooser class>>chooseItemFrom:title: (in category 'instance creation') -----
chooseItemFrom: aList title: aString
	^ self
		chooseItemFrom: aList 
		title: aString
		addAllowed: false!

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

----- Method: ListChooser class>>defaultTitle (in category 'instance creation') -----
defaultTitle
	^ 'Please choose:'!

----- Method: ListChooser class>>testDictionary (in category 'examples') -----
testDictionary
	^ self 
		chooseItemFrom: (Dictionary newFrom: {#a->1. 2->#b.})
		title: 'Pick from Dictionary' "gives values, not keys"!

----- Method: ListChooser class>>testIndex (in category 'examples') -----
testIndex
	^ self 
		chooseIndexFrom: (Smalltalk classNames , Smalltalk traitNames) asOrderedCollection
		title: 'Pick a class'!

----- Method: ListChooser class>>testItem (in category 'examples') -----
testItem
	^ self 
		chooseItemFrom: (Smalltalk classNames , Smalltalk traitNames) asOrderedCollection
		title: 'Pick a class'!

----- Method: ListChooser class>>testItemAdd (in category 'examples') -----
testItemAdd
	^ self 
		chooseItemFrom: (Smalltalk classNames , Smalltalk traitNames) asOrderedCollection
		title: 'Pick or Add:'
		addAllowed: true!

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

----- Method: ListChooser class>>testSet (in category 'examples') -----
testSet
	^ self 
		chooseItemFrom: #(a list of values as a Set) asSet
		title: 'Pick from Set'!

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

----- Method: ListChooser>>acceptColor (in category 'drawing') -----
acceptColor
	^ self canAccept 
		ifTrue: [ ColorTheme current okColor ]
		ifFalse: [ Color lightGray "ColorTheme current disabledColor <- you don't have this!!" ]!

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

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

----- 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 at 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 at 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 at 1).
	panel children add: button.
	
	^ panel!

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

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

----- Method: ListChooser>>buildWindowWith: (in category 'building') -----
buildWindowWith: builder
	| windowSpec |
	windowSpec := builder pluggableWindowSpec new.
	windowSpec model: self.
	windowSpec label: #title.
	windowSpec children: OrderedCollection new.
	^windowSpec!

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

----- Method: ListChooser>>buildWith: (in category 'building') -----
buildWith: aBuilder
	| windowSpec |
	builder := aBuilder.
	windowSpec := self buildWindowWith: builder specs: {
		(0 at 0 corner: 1 at 0.05) -> [self buildSearchMorphWith: builder].
		(0 at 0.05 corner: 1 at 0.9) -> [self buildListMorphWith: builder].
		(0 at 0.9 corner: 1 at 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!

----- Method: ListChooser>>canAccept (in category 'testing') -----
canAccept
	^ self selectedIndex > 0!

----- Method: ListChooser>>canAdd (in category 'testing') -----
canAdd
	^ addAllowed and: [ self canAccept not ]!

----- Method: ListChooser>>cancel (in category 'event handling') -----
cancel
	"Cancel the dialog and move on"
	index := 0.
	builder ifNotNil: [ builder close: window ]!

----- Method: ListChooser>>cancelColor (in category 'drawing') -----
cancelColor
	^ ColorTheme current cancelColor!

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

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

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

----- Method: ListChooser>>closed (in category 'event handling') -----
closed
	"Cancel the dialog and move on"
	builder ifNotNil: [ index := 0 ]!

----- Method: ListChooser>>handlesKeyboard: (in category 'event handling') -----
handlesKeyboard: evt
	^ true!

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

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

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

----- Method: ListChooser>>list (in category 'accessing') -----
list
	^ selectedItems!

----- Method: ListChooser>>list: (in category 'accessing') -----
list: items
	fullList := items.
	selectedItems := items.
	self changed: #itemList.!

----- Method: ListChooser>>list:title: (in category 'accessing') -----
list: aList title: aString
	self list: aList.
	self title: aString!

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

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

----- Method: ListChooser>>realIndex (in category 'accessing') -----
realIndex
	^ realIndex ifNil: [ 0 ]!

----- Method: ListChooser>>searchText (in category 'accessing') -----
searchText
	^ searchText ifNil: [ searchText := '' ]!

----- Method: ListChooser>>searchText: (in category 'accessing') -----
searchText: aString
	searchText := aString!

----- Method: ListChooser>>selectedIndex (in category 'accessing') -----
selectedIndex
	^ index ifNil: [ index := 1 ]!

----- Method: ListChooser>>selectedIndex: (in category 'accessing') -----
selectedIndex: anInt
	index := (anInt min: selectedItems size).
	self changed: #selectedIndex.
	self changed: #canAccept.!

----- Method: ListChooser>>title (in category 'accessing') -----
title
	^ title ifNil: [ title := 'Please choose' ]!

----- Method: ListChooser>>title: (in category 'accessing') -----
title: aString
	title := aString.!

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

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

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

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

----- Method: PluggableTextMorphPlus>>getColorSelector (in category 'accessing') -----
getColorSelector
	^getColorSelector!

----- Method: PluggableTextMorphPlus>>getColorSelector: (in category 'accessing') -----
getColorSelector: aSymbol
	getColorSelector := aSymbol.
	self update: getColorSelector.!

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

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

----- Method: PluggableTextMorphPlus>>okToStyle (in category 'testing') -----
okToStyle
	styler ifNil:[^false].
	(model respondsTo: #aboutToStyle: ) ifFalse:[^true].
	^model aboutToStyle: styler
!

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

----- Method: PluggableTextMorphPlus>>styler (in category 'accessing') -----
styler
	"The styler responsible for highlighting text in the receiver"
	^styler!

----- Method: PluggableTextMorphPlus>>styler: (in category 'accessing') -----
styler: anObject
	"The styler responsible for highlighting text in the receiver"
	styler := anObject!

----- 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 paragraph composeAll.
	textMorph updateFromParagraph.
	selectionInterval 
		ifNotNil:[
			textMorph editor
				selectInvisiblyFrom: selectionInterval first to: selectionInterval last;
				storeSelectionInParagraph;
				setEmphasisHere].
	textMorph editor blinkParen.
	self scrollSelectionIntoView!

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

----- Method: PluggableTextMorphPlus>>update: (in category 'updating') -----
update: what
	what ifNil:[^self].
	what == getColorSelector ifTrue:[self color: (model perform: getColorSelector)].
	^super update: what!

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

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

----- 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>>enabled (in category 'accessing') -----
enabled
	^ enabled ifNil: [enabled := true]!

----- 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.
	onColor := Color veryLightGray.
	offColor := Color white!

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

----- Method: PluggableButtonMorphPlus>>updateMap (in category 'updating') -----
updateMap
	^ updateMap ifNil: [updateMap := Dictionary new]
!

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

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

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

----- 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>>dragItemSelector (in category 'accessing') -----
dragItemSelector
	^dragItemSelector!

----- Method: PluggableTreeMorph>>dragItemSelector: (in category 'accessing') -----
dragItemSelector: aSymbol
	dragItemSelector := aSymbol.
	aSymbol ifNotNil:[self dragEnabled: true].!

----- Method: PluggableTreeMorph>>dropItemSelector (in category 'accessing') -----
dropItemSelector
	^dropItemSelector!

----- Method: PluggableTreeMorph>>dropItemSelector: (in category 'accessing') -----
dropItemSelector: aSymbol
	dropItemSelector := aSymbol.
	aSymbol ifNotNil:[self dropEnabled: true].!

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

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

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



More information about the Squeak-dev mailing list