The Trunk: ToolBuilder-MVC-fbs.34.mcz

Frank Shearar uploaded a new version of ToolBuilder-MVC to project The Trunk:
http://source.squeak.org/trunk/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.

=============== Diff against ToolBuilder-MVC-fbs.33 ===============

Item was added:
+ SystemOrganization addCategory: #'ToolBuilder-MVC'!

Item was added:
+ 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.!

Item was added:
+ ----- 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!

Item was added:
+ ----- 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!

Item was added:
+ ----- 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!

Item was added:
+ ----- 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!

Item was added:
+ ----- 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!

Item was added:
+ ----- 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!

Item was added:
+ ----- Method: MVCToolBuilder>>buildPluggableWindow: (in category 'pluggable widgets') -----
+ 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!

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

Item was added:
+ ----- 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!

Item was added:
+ ----- 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!

Item was added:
+ ----- 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!

Item was added:
+ ----- 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!

Item was added:
+ ----- 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!

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

Item was added:
+ ----- 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)]]].
+ !

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

Item was added:
+ ----- Method: 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'.!

Item was added:
+ ----- 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.!

Item was added:
+ ----- 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.!

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

Item was added:
+ 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.!

Item was added:
+ ----- 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!

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

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

Item was added:
+ ----- 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!

Item was added:
+ ----- 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]!

Item was added:
+ ----- 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]!

Item was added:
+ ----- 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!

Item was added:
+ ----- 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!

Item was added:
+ ----- 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!

Item was added:
+ ----- 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
+ !

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

Item was added:
+ ----- 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!

Item was added:
+ ----- 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].!

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

Item was added:
+ ----- 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!

Item was added:
+ ----- 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!

Item was added:
+ ----- 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 !

Item was added:
+ ----- 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 !

Item was added:
+ ----- 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!

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

Item was added:
+ ----- 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!