Smalltalk › Squeak › Squeak - Dev

Squeak 4.6: ToolBuilder-MVC-mt.42.mcz

_‹ Previous Topic Next Topic _›

Classic

List

Threaded

1 message

commits-2

Squeak 4.6: ToolBuilder-MVC-mt.42.mcz

Chris Muller uploaded a new version of ToolBuilder-MVC to project Squeak 4.6:
http://source.squeak.org/squeak46/ToolBuilder-MVC-mt.42.mcz

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

Name: ToolBuilder-MVC-mt.42
Author: mt
Time: 3 May 2015, 3:14:38.18 pm
UUID: f1b2eb4e-2140-c445-a31f-c4c95ad44334
Ancestors: ToolBuilder-MVC-mt.41

A simple implementation for spacers.

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

SystemOrganization addCategory: #'ToolBuilder-MVC'!

ToolBuilder subclass: #MVCToolBuilder
instanceVariableNames: 'panes topSize widgets parentMenu'
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>>buildPluggableAlternateMultiSelectionList: (in category 'widgets optional') -----
buildPluggableAlternateMultiSelectionList: aSpec

"Trim selector to one argument to match list expectations."
aSpec setIndex: (aSpec setIndex first: (aSpec setIndex findString: ':')) asSymbol.
^ self buildPluggableList: aSpec.!

----- Method: MVCToolBuilder>>buildPluggableButton: (in category 'widgets required') -----
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 'widgets required') -----
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>>buildPluggableMenu: (in category 'widgets required') -----
buildPluggableMenu: menuSpec
"Just a very simple mapping to selection menu. It assumes that all item specs have the same receiver."

| menu |
menu := CustomMenu new.
menuSpec items do: [:ea |
menu
add: ea label
target: ea action receiver
selector: ea action selector
argumentList: ea action arguments.
ea separator ifTrue: [menu addLine]].
^ menu!

----- Method: MVCToolBuilder>>buildPluggableMenuItem: (in category 'widgets required') -----
buildPluggableMenuItem: itemSpec

^ itemSpec label!

----- Method: MVCToolBuilder>>buildPluggablePanel: (in category 'widgets required') -----
buildPluggablePanel: aSpec
| widget children |
widget := View new model: aSpec model.
widget borderWidth: 1.
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>>buildPluggableSpacer: (in category 'widgets required') -----
buildPluggableSpacer: aSpec

| widget |
widget := View new.
self register: widget id: aSpec name.

widget borderWidth: 0.
widget backgroundColor: aSpec color.
widget window: (widget window topLeft extent: aSpec extent).

self setFrame: aSpec frame in: widget.

parent ifNotNil:[parent addSubView: widget].
^widget!

----- Method: MVCToolBuilder>>buildPluggableText: (in category 'widgets required') -----
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>>buildPluggableTree: (in category 'widgets required') -----
buildPluggableTree: aSpec

self shouldBeImplemented.!

----- Method: MVCToolBuilder>>buildPluggableWindow: (in category 'widgets required') -----
buildPluggableWindow: aSpec
| widget children label |
topSize := 0@0 corner: 640@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@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 := (anObject isKindOf: View)
ifTrue: [anObject]
ifFalse: [self build: anObject].
(window isKindOf: PopUpMenu)
ifTrue: [window invokeOn: nil].
(window isKindOf: View)
ifTrue: [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>>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."

!

----- 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>>confirm:orCancel:title: (in category 'ui requests') -----
confirm: aString orCancel: cancelBlock title: titleString
"Put up a yes/no/cancel menu with caption aString, and titleString to label the dialog.
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: (self dialogStringFromQuery: aString withTitle: titleString)
orCancel: cancelBlock!

----- Method: MVCUIManager>>confirm:title: (in category 'ui requests') -----
confirm: queryString title: titleString
"Put up a yes/no menu with caption queryString, and titleString to label the dialog.
Answer true if the response is yes, false if no. This is a modal question--the user
must respond yes or no."
^PopUpMenu confirm: (self dialogStringFromQuery: queryString withTitle: titleString)
!

----- Method: MVCUIManager>>confirm:title:trueChoice:falseChoice: (in category 'ui requests') -----
confirm: queryString title: titleString trueChoice: trueChoice falseChoice: falseChoice
"Put up a yes/no menu with caption queryString, and titleString to label the dialog.
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
is the false-choice. This is a modal question -- the user must respond one way or
the other."
^ PopUpMenu
confirm: (self dialogStringFromQuery: queryString withTitle: titleString)
trueChoice: trueChoice
falseChoice: falseChoice!

----- Method: MVCUIManager>>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."
^PopUpMenu confirm: queryString trueChoice: trueChoice falseChoice: falseChoice!

----- Method: MVCUIManager>>dialogStringFromQuery:withTitle: (in category 'private') -----
dialogStringFromQuery: queryString withTitle: titleString
"In Morphic, it is common to display a simple dialog that has a title bar. In MVC, simple
dialogs are simple. If the UIManager requests a dialog with title, add the title as a simply
decorated line at the top of the dialog text."
^String streamContents: [ :strm |
strm nextPutAll: '- ';
nextPutAll: titleString;
nextPutAll: ' -';
nextPut: Character cr;
nextPutAll: queryString ]
!

----- 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@10) corner: aPoint + (75@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@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@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@2) extent: w@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>>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!