[squeak-dev] Squeak 4.5: ToolBuilder-MVC-fbs.34.mcz

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


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

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

Name: ToolBuilder-MVC-fbs.34
Author: fbs
Time: 9 January 2014, 2:59:06.329 pm
UUID: aded987d-5cd5-6f41-9635-1d38da947ddf
Ancestors: ToolBuilder-MVC-fbs.33

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

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

SystemOrganization addCategory: #'ToolBuilder-MVC'!

ToolBuilder subclass: #MVCToolBuilder
	instanceVariableNames: 'panes topSize widgets'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ToolBuilder-MVC'!

!MVCToolBuilder commentStamp: 'ar 2/11/2005 15:02' prior: 0!
The MVC tool builder.!

----- Method: MVCToolBuilder class>>isActiveBuilder (in category 'accessing') -----
isActiveBuilder
	"Answer whether I am the currently active builder"
	"This is really a way of answering whether 'Smalltalk isMVC'"
	ScheduledControllers ifNil:[^false].
	^(ScheduledControllers activeControllerProcess ifNil:[^false]) isTerminated not!

----- Method: MVCToolBuilder>>asWindow: (in category 'private') -----
asWindow: aRectangle

	| outer |
	outer := parent window ifNil: [topSize].
	^(aRectangle origin * outer extent) truncated
		corner: (aRectangle corner * outer extent) truncated!

----- Method: MVCToolBuilder>>buildPluggableButton: (in category 'pluggable widgets') -----
buildPluggableButton: aSpec
	| widget label state |
	label := aSpec label.
	state := aSpec state.
	widget := PluggableButtonView on: aSpec model
				getState: (state isSymbol ifTrue:[state])
				action: aSpec action
				label: (label isSymbol ifTrue:[label]).
	self register: widget id: aSpec name.
	label ifNotNil: [label isSymbol
		ifTrue: [widget label: (aSpec model perform: label)]
		ifFalse: [widget label: label]].
	self setFrame: aSpec frame in: widget.
	parent ifNotNil: [parent addSubView: widget].
	^widget!

----- Method: MVCToolBuilder>>buildPluggableList: (in category 'pluggable widgets') -----
buildPluggableList: aSpec
	| widget listClass getIndex setIndex |
	aSpec getSelected ifNil:[
		listClass := PluggableListView.
		getIndex := aSpec getIndex.
		setIndex := aSpec setIndex.
	] ifNotNil:[
		listClass := PluggableListViewByItem.
		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.
	self setFrame: aSpec frame in: widget.
	parent ifNotNil:[parent addSubView: widget].
	panes ifNotNil:[
		aSpec list ifNotNil:[panes add: aSpec list].
	].
	^widget!

----- Method: MVCToolBuilder>>buildPluggablePanel: (in category 'pluggable widgets') -----
buildPluggablePanel: aSpec
	| widget children |
	widget := View new model: aSpec model.
	self register: widget id: aSpec name.
	children := aSpec children.
	children isSymbol ifTrue:[
		"@@@@ FIXME: PluggablePanes need to remember their getChildrenSelector"
		"widget getChildrenSelector: children.
		widget update: children."
		children := #().
	].
	self setFrame: aSpec frame in: widget.
	self buildAll: children in: widget.
	parent ifNotNil:[parent addSubView: widget].
	self setLayout: aSpec layout in: widget.
	^widget!

----- Method: MVCToolBuilder>>buildPluggableText: (in category 'pluggable widgets') -----
buildPluggableText: aSpec
	| widget |
	widget := PluggableTextView on: aSpec model
				text: aSpec getText 
				accept: aSpec setText
				readSelection: aSpec selection 
				menu: aSpec menu.
	self register: widget id: aSpec name.
	self setFrame: aSpec frame in: widget.
	parent ifNotNil:[parent addSubView: widget].
	panes ifNotNil:[
		aSpec getText ifNotNil:[panes add: aSpec getText].
	].
	^widget!

----- Method: MVCToolBuilder>>buildPluggableWindow: (in category 'pluggable widgets') -----
buildPluggableWindow: aSpec
	| widget children label |
	topSize := 0 at 0 corner: 640 at 480.
	aSpec layout == #proportional ifFalse:[
		"This needs to be implemented - probably by adding a single pane and then the rest"
		^self error: 'Not implemented'.
	].
	widget := StandardSystemView new.
	self register: widget id: aSpec name.
	widget model: aSpec model.
	label := aSpec label.
	label isSymbol ifTrue: [label := aSpec model perform: label].
	label isNil ifFalse: [widget setLabel: label].
	children := aSpec children.
	children isSymbol ifTrue:[
		"This isn't implemented by StandardSystemView, so we fake it"
		children := widget model perform: children.
	].
	aSpec extent ifNotNil:[topSize :=  0 at 0 extent: aSpec extent].
	widget window: topSize.
	panes := OrderedCollection new.
	self buildAll: children in: widget.
	widget setUpdatablePanesFrom: panes.
	^widget!

----- Method: MVCToolBuilder>>close: (in category 'opening') -----
close: aWidget
	"Close a previously opened widget"
	aWidget controller closeAndUnschedule.!

----- Method: MVCToolBuilder>>open: (in category 'opening') -----
open: anObject
	"Build and open the object. Answer the widget opened."
	| window |
	window := self build: anObject.
	window controller open.
	^window!

----- Method: MVCToolBuilder>>open:label: (in category 'opening') -----
open: anObject label: aString
	"Build an open the object, labeling it appropriately.  Answer the widget opened."
	| window |
	window := self build: anObject.
	window label: aString.
	window controller open.
	^window!

----- Method: MVCToolBuilder>>openDebugger: (in category 'opening') -----
openDebugger: anObject
	"Build and open the object. Answer the widget opened."
	| window |
	window := self build: anObject.
	window controller openNoTerminate.
	^window!

----- Method: MVCToolBuilder>>openDebugger:label: (in category 'opening') -----
openDebugger: anObject label: aString
	"Build an open the object, labeling it appropriately.  Answer the widget opened."
	| window |
	window := self build: anObject.
	window label: aString.
	window controller openNoTerminate.
	^window!

----- Method: MVCToolBuilder>>openDebugger:label:closing: (in category 'opening') -----
openDebugger: anObject label: aString closing: topView
	"Build an open the object, labeling it appropriately.  Answer the widget opened."
	| window |
	topView controller controlTerminate.
	topView deEmphasize; erase.

	"a few hacks to get the scroll selection artifacts out when we got here by clicking in the list"
"	topView subViewWantingControl ifNotNil: [
		topView subViewWantingControl controller controlTerminate
	]."
	topView controller status: #closed.
	window := self build: anObject.
	window label: aString.
	window controller openNoTerminate.
	topView controller closeAndUnscheduleNoErase.
	Processor terminateActive.
	^window!

----- Method: MVCToolBuilder>>pluggableTreeSpec (in category 'defaults') -----
pluggableTreeSpec
	"We have no tree widget in MVC right now"
	^nil!

----- Method: MVCToolBuilder>>positionSubviewsWithin: (in category 'private') -----
positionSubviewsWithin: widget
	"Translate subviews to position the viewport of each subView relative to
	the widget window origin. If subviews are repositioned, as in a row of button
	views arranged within a view, then the transformations will later be rescaled
	to fit the subviews within the widget window."

	widget subViews ifNotNilDo: [:subViews |
		subViews isEmpty ifFalse: [ | translation |
			translation := widget window origin - subViews first window origin.
			subViews do: [:v | 
				v setTransformation: (v transformation translateBy: translation)]]].
!

----- Method: MVCToolBuilder>>register:id: (in category 'private') -----
register: widget id: id
	id ifNil:[^self].
	widgets ifNil:[widgets := Dictionary new].
	widgets at: id put: widget.!

----- Method: MVCToolBuilder>>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."

	self error: 'Please implement me'.!

----- Method: MVCToolBuilder>>setFrame:in: (in category 'private') -----
setFrame: fractionsRectangleOrLayoutFrame in: widget
	| win |
	fractionsRectangleOrLayoutFrame ifNil: [^nil].
	win := fractionsRectangleOrLayoutFrame isRectangle
		ifTrue: [self asWindow: fractionsRectangleOrLayoutFrame]
		ifFalse: [fractionsRectangleOrLayoutFrame layout: nil in: topSize]. "assume LayoutFrame"
	widget window: win.!

----- Method: MVCToolBuilder>>setLayout:in: (in category 'private') -----
setLayout: layout in: widget
	"Arrange subview horizontally or vertically according to layout directive.
	If the subview dimensions were specified with layout frames rather than explicit
	rectangle sizes, then their window horizontal or vertical dimensions will be resized
	as needed to fit within the widget extent."

	self positionSubviewsWithin: widget.
	layout == #proportional ifTrue:[^self].
	layout == #horizontal ifTrue:[
		| prev subViewWidth widgetWidth xScale |
		subViewWidth := (widget subViews collect: [:e | e window extent x]) sum.
		widgetWidth := widget window extent x.
		xScale := widgetWidth / subViewWidth. "to adjust corner of prev prior to align:"
		prev := nil.
		widget subViews do:[:next| | newWindowWidth newCorner |
			prev ifNotNil:[ "resize prev window prior to aligning next"
				xScale < 1 ifTrue: [ "proportional placement spec requires resizing"
					newWindowWidth := (prev window extent x * xScale) truncated.
					newCorner := (prev window origin x + newWindowWidth)@(prev window corner y).
					prev setWindow: (prev window origin corner: newCorner)].
				next align: next viewport topLeft with: prev viewport topRight.
			].
			prev := next.
		].
		^self].
	layout == #vertical ifTrue:[
		| prev subViewHeight widgetHeight yScale |
		subViewHeight := (widget subViews collect: [:e | e window extent y]) sum.
		widgetHeight := widget window extent y.
		yScale := widgetHeight / subViewHeight. "to adjust corner of prev prior to align:"
		prev := nil.
		widget subViews do:[:next| | newWindowHeight newCorner |
			prev ifNotNil:[ "resize prev window prior to aligning next"
				yScale < 1 ifTrue: [ "proportional placement spec requires resizing"
					newWindowHeight := (prev window extent y * yScale) truncated.
					newCorner := (prev window corner x)@(prev window origin y + newWindowHeight).
					prev setWindow: (prev window origin corner: newCorner)].
				next align: next viewport topLeft with: prev viewport bottomLeft.
			].
			prev := next.
		].
		^self].
	^self error: 'Unknown layout: ', layout.!

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

UIManager subclass: #MVCUIManager
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ToolBuilder-MVC'!

!MVCUIManager commentStamp: 'dtl 5/2/2010 16:06' prior: 0!
MVCUIManager is a UIManager that implements user interface requests for an MVC user interface.!

----- Method: MVCUIManager class>>isActiveManager (in category 'accessing') -----
isActiveManager
	"Answer whether I should act as the active ui manager"
	"This is really a way of answering whether 'Smalltalk isMVC'"
	ScheduledControllers ifNil:[^false].
	^ScheduledControllers activeControllerProcess == Processor activeProcess!

----- Method: MVCUIManager>>chooseDirectory:from: (in category 'ui requests') -----
chooseDirectory: label from: dir
	"Let the user choose a directory"
	^self notYetImplemented!

----- Method: MVCUIManager>>chooseFileMatching:label: (in category 'ui requests') -----
chooseFileMatching: patterns label: labelString
	"Let the user choose a file matching the given patterns"
	^self notYetImplemented!

----- Method: MVCUIManager>>chooseFont:for:setSelector:getSelector: (in category 'ui requests') -----
chooseFont: aPrompt for: aTarget setSelector: setSelector getSelector: getSelector
	"MVC Only!! prompt for a font and if one is provided, send it to aTarget using a message with selector aSelector."
	| aMenu aChoice aStyle namesAndSizes aFont |
	aMenu := CustomMenu new.
	TextStyle actualTextStyles keysSortedSafely do:
		[:styleName |
			aMenu add: styleName action: styleName].
	aChoice := aMenu startUpWithCaption: aPrompt.
	aChoice ifNil: [^ self].
	aMenu := CustomMenu new.
	aStyle := TextStyle named: aChoice.
	(namesAndSizes := aStyle fontNamesWithPointSizes) do:
		[:aString | aMenu add: aString action: aString].
	aChoice := aMenu startUpWithCaption: nil.
	aChoice ifNil: [^ self].
	aFont := aStyle fontAt: (namesAndSizes indexOf: aChoice).
	aTarget perform: setSelector with: aFont!

----- Method: MVCUIManager>>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: MVCUIManager>>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: MVCUIManager>>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: MVCUIManager>>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: MVCUIManager>>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."
	| delta savedArea captionText textFrame barFrame outerFrame result range lastW |
	barFrame := aPoint - (75 at 10) corner: aPoint + (75 at 10).
	captionText := DisplayText text: titleString asText allBold.
	captionText
		foregroundColor: Color black
		backgroundColor: Color white.
	textFrame := captionText boundingBox insetBy: -4.
	textFrame := textFrame align: textFrame bottomCenter
					with: barFrame topCenter + (0 at 2).
	outerFrame := barFrame merge: textFrame.
	delta := outerFrame amountToTranslateWithin: Display boundingBox.
	barFrame := barFrame translateBy: delta.
	textFrame := textFrame translateBy: delta.
	outerFrame := outerFrame translateBy: delta.
	savedArea := Form fromDisplay: outerFrame.
	Display fillBlack: barFrame; fillWhite: (barFrame insetBy: 2).
	Display fillBlack: textFrame; fillWhite: (textFrame insetBy: 2).
	captionText displayOn: Display at: textFrame topLeft + (4 at 4).
	range := maxVal = minVal ifTrue: [1] ifFalse: [maxVal - minVal].  "Avoid div by 0"
	lastW := 0.
	[result := workBlock value:  "Supply the bar-update block for evaluation in the work block"
		[:barVal |
		| w |
		w := ((barFrame width-4) asFloat * ((barVal-minVal) asFloat / range min: 1.0)) asInteger.
		w ~= lastW ifTrue: [
			Display fillGray: (barFrame topLeft + (2 at 2) extent: w at 16).
			lastW := w]]]
		ensure: [savedArea displayOn: Display at: outerFrame topLeft].
	^result!

----- Method: MVCUIManager>>edit:label:accept: (in category 'ui requests') -----
edit: aText label: labelString accept: anAction
	"Open an editor on the given string/text"

	Workspace new
		acceptContents: aText;
		acceptAction: anAction;
		openLabel: labelString
!

----- Method: MVCUIManager>>inform: (in category 'ui requests') -----
inform: aString
	"Display a message for the user to read and then dismiss"
	^PopUpMenu inform: aString!

----- Method: MVCUIManager>>informUser:during: (in category 'ui requests') -----
informUser: aString during: aBlock
	"Display a message above (or below if insufficient room) the cursor 
	during execution of the given block.
		UIManager default informUser: 'Just a sec!!' during: [(Delay forSeconds: 1) wait].
	"
	(SelectionMenu labels: '')
		displayAt: Sensor cursorPoint
		withCaption: aString
		during: aBlock!

----- Method: MVCUIManager>>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]]"
	aBlock value:[:string| Transcript cr; show: string].!

----- Method: MVCUIManager>>initialize (in category 'initialize-release') -----
initialize
	toolBuilder := MVCToolBuilder new!

----- Method: MVCUIManager>>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: MVCUIManager>>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"
		ScheduledControllers scheduledWindowControllers do:
			[:aController | "This should be refined..."
			aController view cacheBitsAsTwoTone ifFalse:
				[area := area + aController view windowBox area]].
		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.
	ScheduledControllers updateGray.
	DisplayScreen startUp!

----- Method: MVCUIManager>>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: MVCUIManager>>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."
	^ FillInTheBlank request: queryString initialAnswer: defaultAnswer centerAt: aPoint !

----- Method: MVCUIManager>>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!

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

----- Method: MVCUIManager>>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!



More information about the Squeak-dev mailing list