Squeak-dev May 2013

squeak-dev@lists.squeakfoundation.org

59 participants
334 discussions

The Trunk: Morphic-fbs.653.mcz
by commits＠source.squeak.org 31 May '13

31 May '13

Frank Shearar uploaded a new version of Morphic to project The Trunk: http://source.squeak.org/trunk/Morphic-fbs.653.mcz ==================== Summary ==================== Name: Morphic-fbs.653 Author: fbs Time: 31 May 2013, 4:00:33.132 pm UUID: f85ab481-1220-47b1-998e-0dea9c443203 Ancestors: Morphic-kb.652 Move ToolBuilder-Morphic to Morphic-ToolBuilder. =============== Diff against Morphic-kb.652 =============== Item was changed: SystemOrganization addCategory: #'Morphic-Balloon'! SystemOrganization addCategory: #'Morphic-Basic'! SystemOrganization addCategory: #'Morphic-Basic-NewCurve'! SystemOrganization addCategory: #'Morphic-Borders'! SystemOrganization addCategory: #'Morphic-Collections-Arrayed'! SystemOrganization addCategory: #'Morphic-Demo'! SystemOrganization addCategory: #'Morphic-Events'! SystemOrganization addCategory: #'Morphic-Explorer'! SystemOrganization addCategory: #'Morphic-Kernel'! SystemOrganization addCategory: #'Morphic-Layouts'! SystemOrganization addCategory: #'Morphic-Menus'! SystemOrganization addCategory: #'Morphic-Menus-DockingBar'! SystemOrganization addCategory: #'Morphic-Models'! SystemOrganization addCategory: #'Morphic-Pluggable Widgets'! SystemOrganization addCategory: #'Morphic-Support'! SystemOrganization addCategory: #'Morphic-Text Support'! SystemOrganization addCategory: #'Morphic-TrueType'! SystemOrganization addCategory: #'Morphic-Widgets'! SystemOrganization addCategory: #'Morphic-Windows'! SystemOrganization addCategory: #'Morphic-Worlds'! + SystemOrganization addCategory: #'Morphic-ToolBuilder'! Item was added: + Object subclass: #ListChooser + instanceVariableNames: 'window fullList selectedItems searchText searchMorph title listMorph index realIndex buttonBar builder addAllowed result' + classVariableNames: '' + poolDictionaries: '' + category: 'Morphic-ToolBuilder'! + + !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.! Item was added: + ----- Method: ListChooser class>>chooseFrom: (in category 'ChooserTool compatibility') ----- + chooseFrom: aList + ^ self + chooseFrom: aList + title: self defaultTitle! Item was added: + ----- Method: ListChooser class>>chooseFrom:title: (in category 'ChooserTool compatibility') ----- + chooseFrom: aList title: aString + ^ self + chooseIndexFrom: aList + title: aString + addAllowed: false! Item was added: + ----- Method: ListChooser class>>chooseIndexFrom: (in category 'instance creation') ----- + chooseIndexFrom: aList + ^ self + chooseIndexFrom: aList + title: self defaultTitle! Item was added: + ----- 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! Item was added: + ----- 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! Item was added: + ----- Method: ListChooser class>>chooseItemFrom: (in category 'instance creation') ----- + chooseItemFrom: aList + ^ self + chooseItemFrom: aList + title: self defaultTitle! Item was added: + ----- Method: ListChooser class>>chooseItemFrom:title: (in category 'instance creation') ----- + chooseItemFrom: aList title: aString + ^ self + chooseItemFrom: aList + title: aString + addAllowed: false! Item was added: + ----- 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! Item was added: + ----- Method: ListChooser class>>defaultTitle (in category 'instance creation') ----- + defaultTitle + ^ 'Please choose:'! Item was added: + ----- Method: ListChooser class>>testDictionary (in category 'examples') ----- + testDictionary + ^ self + chooseItemFrom: (Dictionary newFrom: {#a->1. 2->#b.}) + title: 'Pick from Dictionary' "gives values, not keys"! Item was added: + ----- Method: ListChooser class>>testIndex (in category 'examples') ----- + testIndex + ^ self + chooseIndexFrom: (Smalltalk classNames , Smalltalk traitNames) asOrderedCollection + title: 'Pick a class'! Item was added: + ----- Method: ListChooser class>>testItem (in category 'examples') ----- + testItem + ^ self + chooseItemFrom: (Smalltalk classNames , Smalltalk traitNames) asOrderedCollection + title: 'Pick a class'! Item was added: + ----- Method: ListChooser class>>testItemAdd (in category 'examples') ----- + testItemAdd + ^ self + chooseItemFrom: (Smalltalk classNames , Smalltalk traitNames) asOrderedCollection + title: 'Pick or Add:' + addAllowed: true! Item was added: + ----- 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'! Item was added: + ----- Method: ListChooser class>>testSet (in category 'examples') ----- + testSet + ^ self + chooseItemFrom: #(a list of values as a Set) asSet + title: 'Pick from Set'! Item was added: + ----- 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 ]! Item was added: + ----- Method: ListChooser>>acceptColor (in category 'drawing') ----- + acceptColor + ^ self canAccept + ifTrue: [ ColorTheme current okColor ] + ifFalse: [ Color lightGray "ColorTheme current disabledColor <- you don't have this!!" ]! Item was added: + ----- 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! Item was added: + ----- 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 ]! Item was added: + ----- 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@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@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@1). + panel children add: button. + + ^ panel! Item was added: + ----- 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! Item was added: + ----- 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! Item was added: + ----- Method: ListChooser>>buildWindowWith: (in category 'building') ----- + buildWindowWith: builder + | windowSpec | + windowSpec := builder pluggableWindowSpec new. + windowSpec model: self. + windowSpec label: #title. + windowSpec children: OrderedCollection new. + ^windowSpec! Item was added: + ----- 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! Item was added: + ----- Method: ListChooser>>buildWith: (in category 'building') ----- + buildWith: aBuilder + | windowSpec | + builder := aBuilder. + windowSpec := self buildWindowWith: builder specs: { + (0@0 corner: 1(a)0.05) -> [self buildSearchMorphWith: builder]. + (0(a)0.05 corner: 1(a)0.9) -> [self buildListMorphWith: builder]. + (0(a)0.9 corner: 1@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! Item was added: + ----- Method: ListChooser>>canAccept (in category 'testing') ----- + canAccept + ^ self selectedIndex > 0! Item was added: + ----- Method: ListChooser>>canAdd (in category 'testing') ----- + canAdd + ^ addAllowed and: [ self canAccept not ]! Item was added: + ----- Method: ListChooser>>cancel (in category 'event handling') ----- + cancel + "Cancel the dialog and move on" + index := 0. + builder ifNotNil: [ builder close: window ]! Item was added: + ----- Method: ListChooser>>cancelColor (in category 'drawing') ----- + cancelColor + ^ ColorTheme current cancelColor! Item was added: + ----- 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! Item was added: + ----- 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! Item was added: + ----- 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! Item was added: + ----- Method: ListChooser>>closed (in category 'event handling') ----- + closed + "Cancel the dialog and move on" + builder ifNotNil: [ index := 0 ]! Item was added: + ----- Method: ListChooser>>handlesKeyboard: (in category 'event handling') ----- + handlesKeyboard: evt + ^ true! Item was added: + ----- 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))! Item was added: + ----- 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 ]. + ! Item was added: + ----- 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. + ! Item was added: + ----- Method: ListChooser>>list (in category 'accessing') ----- + list + ^ selectedItems! Item was added: + ----- Method: ListChooser>>list: (in category 'accessing') ----- + list: items + fullList := items. + selectedItems := items. + self changed: #itemList.! Item was added: + ----- Method: ListChooser>>list:title: (in category 'accessing') ----- + list: aList title: aString + self list: aList. + self title: aString! Item was added: + ----- 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. + ! Item was added: + ----- 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.! Item was added: + ----- Method: ListChooser>>realIndex (in category 'accessing') ----- + realIndex + ^ realIndex ifNil: [ 0 ]! Item was added: + ----- Method: ListChooser>>searchText (in category 'accessing') ----- + searchText + ^ searchText ifNil: [ searchText := '' ]! Item was added: + ----- Method: ListChooser>>searchText: (in category 'accessing') ----- + searchText: aString + searchText := aString! Item was added: + ----- Method: ListChooser>>selectedIndex (in category 'accessing') ----- + selectedIndex + ^ index ifNil: [ index := 1 ]! Item was added: + ----- Method: ListChooser>>selectedIndex: (in category 'accessing') ----- + selectedIndex: anInt + index := (anInt min: selectedItems size). + self changed: #selectedIndex. + self changed: #canAccept.! Item was added: + ----- Method: ListChooser>>title (in category 'accessing') ----- + title + ^ title ifNil: [ title := 'Please choose' ]! Item was added: + ----- Method: ListChooser>>title: (in category 'accessing') ----- + title: aString + title := aString.! Item was added: + ----- 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.! Item was added: + ToolBuilder subclass: #MorphicToolBuilder + instanceVariableNames: 'widgets panes parentMenu' + classVariableNames: '' + poolDictionaries: '' + category: 'Morphic-ToolBuilder'! + + !MorphicToolBuilder commentStamp: 'ar 2/11/2005 15:02' prior: 0! + The Morphic tool builder.! Item was added: + ----- Method: MorphicToolBuilder class>>isActiveBuilder (in category 'accessing') ----- + isActiveBuilder + "Answer whether I am the currently active builder" + ^Smalltalk isMorphic! Item was added: + ----- Method: MorphicToolBuilder>>add:to: (in category 'private') ----- + add: aMorph to: aParent + aParent addMorphBack: aMorph. + aParent isSystemWindow ifTrue:[ + aParent addPaneMorph: aMorph. + ].! Item was added: + ----- Method: MorphicToolBuilder>>alternateMultiSelectListClass (in category 'widget classes') ----- + alternateMultiSelectListClass + ^ AlternatePluggableListMorphOfMany ! Item was added: + ----- 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! Item was added: + ----- Method: MorphicToolBuilder>>buildHelpFor:spec: (in category 'pluggable widgets') ----- + buildHelpFor: widget spec: aSpec + aSpec help + ifNotNil: [widget setBalloonText: aSpec help]! Item was added: + ----- Method: MorphicToolBuilder>>buildPluggableActionButton: (in category 'pluggable widgets') ----- + buildPluggableActionButton: aSpec + | button | + button := self buildPluggableButton: aSpec. + button color: Color white. + ^button! Item was added: + ----- 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: Preferences 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! Item was added: + ----- 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! Item was added: + ----- 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! Item was added: + ----- 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! Item was added: + ----- 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! Item was added: + ----- Method: MorphicToolBuilder>>buildPluggableInputField: (in category 'pluggable widgets') ----- + buildPluggableInputField: aSpec + | widget | + widget := self buildPluggableText: aSpec. + widget acceptOnCR: true. + widget hideScrollBarsIndefinitely. + ^widget! Item was added: + ----- 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! Item was added: + ----- 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! Item was added: + ----- Method: MorphicToolBuilder>>buildPluggableMenuItem: (in category 'building') ----- + buildPluggableMenuItem: itemSpec + | item action label menu | + item := self menuItemClass new. + label := itemSpec label. + itemSpec checked ifTrue:[label := '<on>', label] ifFalse:[label := '<off>', label]. + item contents: label. + item isEnabled: itemSpec enabled. + (action := itemSpec action) ifNotNil:[ + item + target: action receiver; + selector: action selector; + arguments: action arguments. + ]. + (menu := itemSpec subMenu) ifNotNil:[ + item subMenu: (menu buildWith: self). + ]. + parentMenu ifNotNil:[parentMenu addMorphBack: item]. + itemSpec separator ifTrue:[parentMenu addLine]. + ^item! Item was added: + ----- 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! Item was added: + ----- 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! Item was added: + ----- 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! Item was added: + ----- 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! Item was added: + ----- 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! Item was added: + ----- Method: MorphicToolBuilder>>buttonClass (in category 'widget classes') ----- + buttonClass + ^ PluggableButtonMorphPlus! Item was added: + ----- Method: MorphicToolBuilder>>checkBoxClass (in category 'widget classes') ----- + checkBoxClass + ^ PluggableCheckBoxMorph! Item was added: + ----- Method: MorphicToolBuilder>>close: (in category 'opening') ----- + close: aWidget + "Close a previously opened widget" + aWidget delete! Item was added: + ----- Method: MorphicToolBuilder>>codePaneClass (in category 'widget classes') ----- + codePaneClass + ^ PluggableTextMorphPlus! Item was added: + ----- Method: MorphicToolBuilder>>dropDownListClass (in category 'widget classes') ----- + dropDownListClass + ^ PluggableDropDownListMorph! Item was added: + ----- Method: MorphicToolBuilder>>listByItemClass (in category 'widget classes') ----- + listByItemClass + ^ PluggableListMorphByItemPlus! Item was added: + ----- Method: MorphicToolBuilder>>listClass (in category 'widget classes') ----- + listClass + ^ PluggableListMorphPlus! Item was added: + ----- Method: MorphicToolBuilder>>menuClass (in category 'widget classes') ----- + menuClass + ^ MenuMorph! Item was added: + ----- Method: MorphicToolBuilder>>menuItemClass (in category 'widget classes') ----- + menuItemClass + ^ MenuItemMorph! Item was added: + ----- Method: MorphicToolBuilder>>multiSelectListClass (in category 'widget classes') ----- + multiSelectListClass + ^ PluggableListMorphOfMany! Item was added: + ----- 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! Item was added: + ----- 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! Item was added: + ----- Method: MorphicToolBuilder>>panelClass (in category 'widget classes') ----- + panelClass + ^ PluggablePanelMorph! Item was added: + ----- 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.! Item was added: + ----- 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. + ]. + ! Item was added: + ----- 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. + ].! Item was added: + ----- 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@1. + widget layoutInset: 1@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@1. + widget layoutInset: 1@1. + widget color: Color transparent. + "and then some..." + ^self]. + ^self error: 'Unknown layout: ', layout.! Item was added: + ----- Method: MorphicToolBuilder>>textPaneClass (in category 'widget classes') ----- + textPaneClass + ^ PluggableTextMorphPlus! Item was added: + ----- Method: MorphicToolBuilder>>treeClass (in category 'widget classes') ----- + treeClass + ^ PluggableTreeMorph! Item was added: + ----- Method: MorphicToolBuilder>>widgetAt:ifAbsent: (in category 'private') ----- + widgetAt: id ifAbsent: aBlock + widgets ifNil:[^aBlock value]. + ^widgets at: id ifAbsent: aBlock! Item was added: + ----- Method: MorphicToolBuilder>>windowClass (in category 'widget classes') ----- + windowClass + ^ PluggableSystemWindow! Item was added: + ----- Method: MorphicToolBuilder>>windowClassFor: (in category 'widget classes') ----- + windowClassFor: aSpec + aSpec isDialog ifTrue: [^ PluggableDialogWindow]. + ^aSpec multiWindowStyle + caseOf: + { [nil] -> [PluggableSystemWindow]. + [#labelButton] -> [PluggableSystemWindowWithLabelButton] } + otherwise: [PluggableSystemWindowWithLabelButton]! Item was added: + ToolBuilderTests subclass: #MorphicToolBuilderTests + instanceVariableNames: '' + classVariableNames: '' + poolDictionaries: '' + category: 'Morphic-ToolBuilder'! + + !MorphicToolBuilderTests commentStamp: 'ar 2/11/2005 15:02' prior: 0! + Tests for the Morphic tool builder.! Item was added: + ----- Method: MorphicToolBuilderTests>>acceptWidgetText (in category 'support') ----- + acceptWidgetText + widget hasUnacceptedEdits: true. + widget accept.! Item was added: + ----- Method: MorphicToolBuilderTests>>buttonWidgetEnabled (in category 'support') ----- + buttonWidgetEnabled + "Answer whether the current widget (a button) is currently enabled" + ^widget enabled! Item was added: + ----- Method: MorphicToolBuilderTests>>changeListWidget (in category 'support') ----- + changeListWidget + widget changeModelSelection: widget getCurrentSelectionIndex + 1.! Item was added: + ----- Method: MorphicToolBuilderTests>>expectedButtonSideEffects (in category 'support') ----- + expectedButtonSideEffects + ^#(getColor getState getEnabled)! Item was added: + ----- Method: MorphicToolBuilderTests>>fireButtonWidget (in category 'support') ----- + fireButtonWidget + widget performAction.! Item was added: + ----- Method: MorphicToolBuilderTests>>fireMenuItemWidget (in category 'support') ----- + fireMenuItemWidget + (widget itemWithWording: 'Menu Item') + ifNotNil: [:item | item doButtonAction]! Item was added: + ----- Method: MorphicToolBuilderTests>>setUp (in category 'support') ----- + setUp + super setUp. + builder := MorphicToolBuilder new.! Item was added: + ----- Method: MorphicToolBuilderTests>>testWindowDynamicLabel (in category 'tests-window') ----- + testWindowDynamicLabel + self makeWindow. + self assert: (widget label = 'TestLabel').! Item was added: + ----- Method: MorphicToolBuilderTests>>testWindowStaticLabel (in category 'tests-window') ----- + testWindowStaticLabel + | spec | + spec := builder pluggableWindowSpec new. + spec model: self. + spec children: #(). + spec label: 'TestLabel'. + widget := builder build: spec. + self assert: (widget label = 'TestLabel').! Item was added: + ----- Method: MorphicToolBuilderTests>>widgetColor (in category 'support') ----- + widgetColor + "Answer color from widget" + ^widget color! Item was added: + UIManager subclass: #MorphicUIManager + instanceVariableNames: '' + classVariableNames: '' + poolDictionaries: '' + category: 'Morphic-ToolBuilder'! + + !MorphicUIManager commentStamp: 'dtl 5/2/2010 16:07' prior: 0! + MorphicUIManager is a UIManager that implements user interface requests for a Morphic user interface.! Item was added: + ----- Method: MorphicUIManager class>>isActiveManager (in category 'accessing') ----- + isActiveManager + "Answer whether I should act as the active ui manager" + ^Smalltalk isMorphic! Item was added: + ----- 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 ]! Item was added: + ----- Method: MorphicUIManager>>chooseDirectory:from: (in category 'ui requests') ----- + chooseDirectory: label from: dir + "Let the user choose a directory" + ^FileList2 modalFolderSelector: dir! Item was added: + ----- 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]! Item was added: + ----- 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! Item was added: + ----- 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 ]! Item was added: + ----- 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 ]! Item was added: + ----- 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! Item was added: + ----- 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! Item was added: + ----- 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 ! Item was added: + ----- 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! Item was added: + ----- 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.! Item was added: + ----- Method: MorphicUIManager>>inform: (in category 'ui requests') ----- + inform: aString + "Display a message for the user to read and then dismiss" + ^UserDialogBoxMorph inform: aString! Item was added: + ----- 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.! Item was added: + ----- Method: MorphicUIManager>>initialize (in category 'initialize-release') ----- + initialize + toolBuilder := MorphicToolBuilder new! Item was added: + ----- 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! Item was added: + ----- 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 ! Item was added: + ----- 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! Item was added: + ----- 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! Item was added: + PluggableButtonMorph subclass: #PluggableButtonMorphPlus + instanceVariableNames: 'enabled action getColorSelector getEnabledSelector updateMap' + classVariableNames: '' + poolDictionaries: '' + category: 'Morphic-ToolBuilder'! + + !PluggableButtonMorphPlus commentStamp: 'ar 2/11/2005 21:53' prior: 0! + An extended version of PluggableButtonMorph supporting enablement, color and block/message actions.! Item was added: + ----- Method: PluggableButtonMorphPlus>>action (in category 'accessing') ----- + action + ^action! Item was added: + ----- Method: PluggableButtonMorphPlus>>action: (in category 'accessing') ----- + action: anAction + action := nil. + anAction isSymbol ifTrue:[^super action: anAction]. + action := anAction.! Item was added: + ----- Method: PluggableButtonMorphPlus>>enabled (in category 'accessing') ----- + enabled + ^ enabled ifNil: [enabled := true]! Item was added: + ----- 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]]! Item was added: + ----- Method: PluggableButtonMorphPlus>>getColorSelector (in category 'accessing') ----- + getColorSelector + ^getColorSelector! Item was added: + ----- Method: PluggableButtonMorphPlus>>getColorSelector: (in category 'accessing') ----- + getColorSelector: aSymbol + getColorSelector := aSymbol. + self update: getColorSelector.! Item was added: + ----- Method: PluggableButtonMorphPlus>>getEnabledSelector (in category 'accessing') ----- + getEnabledSelector + ^getEnabledSelector! Item was added: + ----- Method: PluggableButtonMorphPlus>>getEnabledSelector: (in category 'accessing') ----- + getEnabledSelector: aSymbol + getEnabledSelector := aSymbol. + self update: aSymbol.! Item was added: + ----- Method: PluggableButtonMorphPlus>>initialize (in category 'initialize-release') ----- + initialize + super initialize. + enabled := true. + onColor := Color veryLightGray. + offColor := Color white! Item was added: + ----- Method: PluggableButtonMorphPlus>>mouseDown: (in category 'action') ----- + mouseDown: evt + enabled ifFalse:[^self]. + ^super mouseDown: evt! Item was added: + ----- Method: PluggableButtonMorphPlus>>mouseMove: (in category 'action') ----- + mouseMove: evt + enabled ifFalse:[^self]. + ^super mouseMove: evt! Item was added: + ----- Method: PluggableButtonMorphPlus>>mouseUp: (in category 'action') ----- + mouseUp: evt + enabled ifFalse:[^self]. + ^super mouseUp: evt! Item was added: + ----- 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.! Item was added: + ----- Method: PluggableButtonMorphPlus>>performAction (in category 'action') ----- + performAction + enabled ifFalse:[^self]. + action ifNotNil:[^action value]. + ^super performAction! Item was added: + ----- 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]]. + ! Item was added: + ----- Method: PluggableButtonMorphPlus>>updateMap (in category 'updating') ----- + updateMap + ^ updateMap ifNil: [updateMap := Dictionary new] + ! Item was added: + ----- 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! Item was added: + AlignmentMorph subclass: #PluggableCheckBoxMorph + instanceVariableNames: 'model actionSelector valueSelector label' + classVariableNames: '' + poolDictionaries: '' + category: 'Morphic-ToolBuilder'! Item was added: + ----- 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 + ! Item was added: + ----- Method: PluggableCheckBoxMorph>>actionSelector (in category 'accessing') ----- + actionSelector + "Answer the value of actionSelector" + + ^ actionSelector! Item was added: + ----- Method: PluggableCheckBoxMorph>>actionSelector: (in category 'accessing') ----- + actionSelector: anObject + "Set the value of actionSelector" + + actionSelector := anObject! Item was added: + ----- Method: PluggableCheckBoxMorph>>basicPanel (in category 'installing') ----- + basicPanel + ^BorderedMorph new + beTransparent; + extent: 0@0; + borderWidth: 0; + layoutInset: 0; + cellInset: 0; + layoutPolicy: TableLayout new; + listCentering: #topLeft; + cellPositioning: #center; + hResizing: #spaceFill; + vResizing: #shrinkWrap; + yourself! Item was added: + ----- Method: PluggableCheckBoxMorph>>horizontalPanel (in category 'installing') ----- + horizontalPanel + ^self basicPanel + cellPositioning: #center; + listDirection: #leftToRight; + yourself.! Item was added: + ----- 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).! Item was added: + ----- Method: PluggableCheckBoxMorph>>label (in category 'accessing') ----- + label + "Answer the value of label" + + ^ label! Item was added: + ----- Method: PluggableCheckBoxMorph>>label: (in category 'accessing') ----- + label: anObject + "Set the value of label" + + label := anObject! Item was added: + ----- Method: PluggableCheckBoxMorph>>model (in category 'accessing') ----- + model + "Answer the value of model" + + ^ model. + ! Item was added: + ----- Method: PluggableCheckBoxMorph>>model: (in category 'accessing') ----- + model: anObject + "Set the value of model" + + model := anObject! Item was added: + ----- 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). + ! Item was added: + ----- Method: PluggableCheckBoxMorph>>valueSelector (in category 'accessing') ----- + valueSelector + "Answer the value of valueSelector" + + ^ valueSelector! Item was added: + ----- Method: PluggableCheckBoxMorph>>valueSelector: (in category 'accessing') ----- + valueSelector: anObject + "Set the value of valueSelector" + + valueSelector := anObject! Item was added: + PluggableSystemWindow subclass: #PluggableDialogWindow + instanceVariableNames: 'statusValue' + classVariableNames: '' + poolDictionaries: '' + category: 'Morphic-ToolBuilder'! Item was added: + ----- Method: PluggableDialogWindow>>statusValue (in category 'as yet unclassified') ----- + statusValue + ^statusValue! Item was added: + ----- Method: PluggableDialogWindow>>statusValue: (in category 'as yet unclassified') ----- + statusValue: val + statusValue := val! Item was added: + AlignmentMorph subclass: #PluggableDropDownListMorph + instanceVariableNames: 'model listSelector selectionSelector selectionSetter' + classVariableNames: '' + poolDictionaries: '' + category: 'Morphic-ToolBuilder'! Item was added: + ----- Method: PluggableDropDownListMorph>>basicPanel (in category 'drawing') ----- + basicPanel + ^BorderedMorph new + beTransparent; + extent: 0@0; + borderWidth: 0; + layoutInset: 0; + cellInset: 0; + layoutPolicy: TableLayout new; + listCentering: #topLeft; + cellPositioning: #center; + hResizing: #spaceFill; + vResizing: #shrinkWrap; + yourself! Item was added: + ----- Method: PluggableDropDownListMorph>>currentSelection (in category 'accessing') ----- + currentSelection + + ^ self model perform: selectionSelector! Item was added: + ----- Method: PluggableDropDownListMorph>>currentSelection: (in category 'accessing') ----- + currentSelection: obj + + ^ self model perform: selectionSetter with: obj! Item was added: + ----- Method: PluggableDropDownListMorph>>horizontalPanel (in category 'drawing') ----- + horizontalPanel + ^self basicPanel + cellPositioning: #center; + listDirection: #leftToRight; + yourself.! Item was added: + ----- 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).! Item was added: + ----- Method: PluggableDropDownListMorph>>list (in category 'accessing') ----- + list + "Answer the value of list" + + ^ self model perform: self listSelector. + ! Item was added: + ----- Method: PluggableDropDownListMorph>>listSelector (in category 'accessing') ----- + listSelector + "Answer the value of listSelector" + + ^ listSelector! Item was added: + ----- Method: PluggableDropDownListMorph>>listSelector: (in category 'accessing') ----- + listSelector: anObject + "Set the value of listSelector" + + listSelector := anObject! Item was added: + ----- Method: PluggableDropDownListMorph>>model (in category 'accessing') ----- + model + ^ model! Item was added: + ----- Method: PluggableDropDownListMorph>>model: (in category 'accessing') ----- + model: anObject + "Set the value of model" + + model := anObject! Item was added: + ----- Method: PluggableDropDownListMorph>>selectionSelector (in category 'accessing') ----- + selectionSelector + "Answer the value of selectionSelector" + + ^ selectionSelector! Item was added: + ----- Method: PluggableDropDownListMorph>>selectionSelector: (in category 'accessing') ----- + selectionSelector: anObject + "Set the value of selectionSelector" + + selectionSelector := anObject! Item was added: + ----- Method: PluggableDropDownListMorph>>selectionSetter (in category 'accessing') ----- + selectionSetter + "Answer the value of selectionSetter" + + ^ selectionSetter! Item was added: + ----- Method: PluggableDropDownListMorph>>selectionSetter: (in category 'accessing') ----- + selectionSetter: anObject + "Set the value of selectionSetter" + + selectionSetter := anObject! Item was added: + PluggableListMorphPlus subclass: #PluggableListMorphByItemPlus + instanceVariableNames: 'itemList' + classVariableNames: '' + poolDictionaries: '' + category: 'Morphic-ToolBuilder'! + + !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.! Item was added: + ----- 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. + ! Item was added: + ----- 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] + ! Item was added: + ----- Method: PluggableListMorphByItemPlus>>getList (in category 'as yet unclassified') ----- + getList + "cache the raw items in itemList" + itemList := getListSelector ifNil: [ #() ] ifNotNil: [ model perform: getListSelector ]. + ^super getList! Item was added: + ----- 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! Item was added: + PluggableListMorph subclass: #PluggableListMorphPlus + instanceVariableNames: 'dragItemSelector dropItemSelector wantsDropSelector' + classVariableNames: '' + poolDictionaries: '' + category: 'Morphic-ToolBuilder'! + + !PluggableListMorphPlus commentStamp: 'ar 7/15/2005 11:10' prior: 0! + Extensions for PluggableListMorph needed by ToolBuilder! Item was added: + ----- 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. + ! Item was added: + ----- Method: PluggableListMorphPlus>>dragItemSelector (in category 'accessing') ----- + dragItemSelector + ^dragItemSelector! Item was added: + ----- Method: PluggableListMorphPlus>>dragItemSelector: (in category 'accessing') ----- + dragItemSelector: aSymbol + dragItemSelector := aSymbol. + aSymbol ifNotNil:[self dragEnabled: true].! Item was added: + ----- Method: PluggableListMorphPlus>>dropItemSelector (in category 'accessing') ----- + dropItemSelector + ^dropItemSelector! Item was added: + ----- Method: PluggableListMorphPlus>>dropItemSelector: (in category 'accessing') ----- + dropItemSelector: aSymbol + dropItemSelector := aSymbol. + aSymbol ifNotNil:[self dropEnabled: true].! Item was added: + ----- 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]! Item was added: + ----- Method: PluggableListMorphPlus>>wantsDropSelector (in category 'accessing') ----- + wantsDropSelector + ^wantsDropSelector! Item was added: + ----- Method: PluggableListMorphPlus>>wantsDropSelector: (in category 'accessing') ----- + wantsDropSelector: aSymbol + wantsDropSelector := aSymbol! Item was added: + ----- 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! Item was added: + AlignmentMorph subclass: #PluggablePanelMorph + instanceVariableNames: 'model getChildrenSelector' + classVariableNames: '' + poolDictionaries: '' + category: 'Morphic-ToolBuilder'! + + !PluggablePanelMorph commentStamp: 'ar 2/11/2005 20:13' prior: 0! + A pluggable panel morph which deals with changing children.! Item was added: + ----- Method: PluggablePanelMorph>>getChildrenSelector (in category 'accessing') ----- + getChildrenSelector + ^getChildrenSelector! Item was added: + ----- Method: PluggablePanelMorph>>getChildrenSelector: (in category 'accessing') ----- + getChildrenSelector: aSymbol + getChildrenSelector := aSymbol.! Item was added: + ----- Method: PluggablePanelMorph>>model (in category 'accessing') ----- + model + ^model! Item was added: + ----- Method: PluggablePanelMorph>>model: (in category 'accessing') ----- + model: aModel + model ifNotNil:[model removeDependent: self]. + model := aModel. + model ifNotNil:[model addDependent: self].! Item was added: + ----- Method: PluggablePanelMorph>>update: (in category 'update') ----- + update: what + what == nil ifTrue:[^self]. + what == getChildrenSelector ifTrue:[ + self removeAllMorphs. + self addAllMorphs: (model perform: getChildrenSelector). + self submorphsDo:[:m| m hResizing: #spaceFill; vResizing: #spaceFill]. + ].! Item was added: + SystemWindow subclass: #PluggableSystemWindow + instanceVariableNames: 'getLabelSelector getChildrenSelector children closeWindowSelector' + classVariableNames: '' + poolDictionaries: '' + category: 'Morphic-ToolBuilder'! + + !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.! Item was added: + ----- Method: PluggableSystemWindow>>addPaneMorph: (in category 'accessing') ----- + addPaneMorph: aMorph + self addMorph: aMorph fullFrame: aMorph layoutFrame! Item was added: + ----- Method: PluggableSystemWindow>>closeWindowSelector (in category 'accessing') ----- + closeWindowSelector + ^closeWindowSelector! Item was added: + ----- Method: PluggableSystemWindow>>closeWindowSelector: (in category 'accessing') ----- + closeWindowSelector: aSymbol + closeWindowSelector := aSymbol! Item was added: + ----- Method: PluggableSystemWindow>>delete (in category 'initialization') ----- + delete + closeWindowSelector ifNotNil:[model perform: closeWindowSelector]. + super delete. + ! Item was added: + ----- Method: PluggableSystemWindow>>getChildrenSelector (in category 'accessing') ----- + getChildrenSelector + ^getChildrenSelector! Item was added: + ----- Method: PluggableSystemWindow>>getChildrenSelector: (in category 'accessing') ----- + getChildrenSelector: aSymbol + getChildrenSelector := aSymbol! Item was added: + ----- Method: PluggableSystemWindow>>getLabelSelector (in category 'accessing') ----- + getLabelSelector + ^getLabelSelector! Item was added: + ----- Method: PluggableSystemWindow>>getLabelSelector: (in category 'accessing') ----- + getLabelSelector: aSymbol + getLabelSelector := aSymbol. + self update: aSymbol.! Item was added: + ----- Method: PluggableSystemWindow>>label (in category 'accessing') ----- + label + ^label contents! Item was added: + ----- Method: PluggableSystemWindow>>label: (in category 'accessing') ----- + label: aString + self setLabel: aString.! Item was added: + ----- 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! Item was added: + PluggableTextMorph subclass: #PluggableTextMorphPlus + instanceVariableNames: 'getColorSelector acceptAction unstyledAcceptText styler' + classVariableNames: '' + poolDictionaries: '' + category: 'Morphic-ToolBuilder'! + + !PluggableTextMorphPlus commentStamp: 'ar 2/11/2005 21:53' prior: 0! + A pluggable text morph with support for color.! Item was added: + ----- Method: PluggableTextMorphPlus>>accept (in category 'updating') ----- + accept + super accept. + acceptAction ifNotNil:[acceptAction value: textMorph asText].! Item was added: + ----- Method: PluggableTextMorphPlus>>acceptAction (in category 'accessing') ----- + acceptAction + ^acceptAction! Item was added: + ----- Method: PluggableTextMorphPlus>>acceptAction: (in category 'accessing') ----- + acceptAction: anAction + acceptAction := anAction! Item was added: + ----- 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]! Item was added: + ----- 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! Item was added: + ----- Method: PluggableTextMorphPlus>>getColorSelector (in category 'accessing') ----- + getColorSelector + ^getColorSelector! Item was added: + ----- Method: PluggableTextMorphPlus>>getColorSelector: (in category 'accessing') ----- + getColorSelector: aSymbol + getColorSelector := aSymbol. + self update: getColorSelector.! Item was added: + ----- 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'! Item was added: + ----- 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]! Item was added: + ----- Method: PluggableTextMorphPlus>>okToStyle (in category 'testing') ----- + okToStyle + styler ifNil:[^false]. + (model respondsTo: #aboutToStyle: ) ifFalse:[^true]. + ^model aboutToStyle: styler + ! Item was added: + ----- 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]! Item was added: + ----- Method: PluggableTextMorphPlus>>styler (in category 'accessing') ----- + styler + "The styler responsible for highlighting text in the receiver" + ^styler! Item was added: + ----- Method: PluggableTextMorphPlus>>styler: (in category 'accessing') ----- + styler: anObject + "The styler responsible for highlighting text in the receiver" + styler := anObject! Item was added: + ----- 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 updateFromParagraph. + selectionInterval + ifNotNil:[ + textMorph editor + selectInvisiblyFrom: selectionInterval first to: selectionInterval last; + storeSelectionInParagraph; + setEmphasisHere]. + textMorph editor blinkParen. + self scrollSelectionIntoView! Item was added: + ----- 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]! Item was added: + ----- Method: PluggableTextMorphPlus>>update: (in category 'updating') ----- + update: what + what ifNil:[^self]. + what == getColorSelector ifTrue:[self color: (model perform: getColorSelector)]. + ^super update: what! Item was added: + ----- 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). + ].! Item was added: + ListItemWrapper subclass: #PluggableTreeItemNode + instanceVariableNames: '' + classVariableNames: '' + poolDictionaries: '' + category: 'Morphic-ToolBuilder'! + + !PluggableTreeItemNode commentStamp: 'ar 2/12/2005 04:37' prior: 0! + Tree item for PluggableTreeMorph.! Item was added: + ----- Method: PluggableTreeItemNode>>acceptDroppingObject: (in category 'accessing') ----- + acceptDroppingObject: anotherItem + ^model dropNode: anotherItem on: self! Item was added: + ----- Method: PluggableTreeItemNode>>asString (in category 'accessing') ----- + asString + ^model printNode: self! Item was added: + ----- Method: PluggableTreeItemNode>>balloonText (in category 'accessing') ----- + balloonText + ^model balloonTextForNode: self! Item was added: + ----- Method: PluggableTreeItemNode>>canBeDragged (in category 'accessing') ----- + canBeDragged + ^model isDraggableNode: self! Item was added: + ----- Method: PluggableTreeItemNode>>contents (in category 'accessing') ----- + contents + ^model contentsOfNode: self! Item was added: + ----- Method: PluggableTreeItemNode>>hasContents (in category 'accessing') ----- + hasContents + ^model hasNodeContents: self! Item was added: + ----- Method: PluggableTreeItemNode>>icon (in category 'accessing') ----- + icon + ^model iconOfNode: self! Item was added: + ----- Method: PluggableTreeItemNode>>item (in category 'accessing') ----- + item + ^item! Item was added: + ----- Method: PluggableTreeItemNode>>wantsDroppedObject: (in category 'accessing') ----- + wantsDroppedObject: anotherItem + ^model wantsDroppedNode: anotherItem on: self! Item was added: + SimpleHierarchicalListMorph subclass: #PluggableTreeMorph + instanceVariableNames: 'roots selectedWrapper getRootsSelector getChildrenSelector hasChildrenSelector getLabelSelector getIconSelector getSelectedPathSelector setSelectedSelector getHelpSelector dropItemSelector wantsDropSelector dragItemSelector' + classVariableNames: '' + poolDictionaries: '' + category: 'Morphic-ToolBuilder'! + + !PluggableTreeMorph commentStamp: 'ar 2/12/2005 04:38' prior: 0! + A pluggable tree morph.! Item was added: + ----- 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! Item was added: + ----- Method: PluggableTreeMorph>>balloonTextForNode: (in category 'node access') ----- + balloonTextForNode: node + getHelpSelector ifNil:[^nil]. + ^model perform: getHelpSelector with: node item! Item was added: + ----- 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]! Item was added: + ----- Method: PluggableTreeMorph>>dragItemSelector (in category 'accessing') ----- + dragItemSelector + ^dragItemSelector! Item was added: + ----- Method: PluggableTreeMorph>>dragItemSelector: (in category 'accessing') ----- + dragItemSelector: aSymbol + dragItemSelector := aSymbol. + aSymbol ifNotNil:[self dragEnabled: true].! Item was added: + ----- Method: PluggableTreeMorph>>dropItemSelector (in category 'accessing') ----- + dropItemSelector + ^dropItemSelector! Item was added: + ----- Method: PluggableTreeMorph>>dropItemSelector: (in category 'accessing') ----- + dropItemSelector: aSymbol + dropItemSelector := aSymbol. + aSymbol ifNotNil:[self dropEnabled: true].! Item was added: + ----- Method: PluggableTreeMorph>>dropNode:on: (in category 'node access') ----- + dropNode: srcNode on: dstNode + dropItemSelector ifNil:[^nil]. + model perform: dropItemSelector with: srcNode item with: dstNode item! Item was added: + ----- Method: PluggableTreeMorph>>getChildrenSelector (in category 'accessing') ----- + getChildrenSelector + ^getChildrenSelector! Item was added: + ----- Method: PluggableTreeMorph>>getChildrenSelector: (in category 'accessing') ----- + getChildrenSelector: aSymbol + getChildrenSelector := aSymbol.! Item was added: + ----- Method: PluggableTreeMorph>>getHelpSelector (in category 'accessing') ----- + getHelpSelector + ^getHelpSelector! Item was added: + ----- Method: PluggableTreeMorph>>getHelpSelector: (in category 'accessing') ----- + getHelpSelector: aSymbol + getHelpSelector := aSymbol! Item was added: + ----- Method: PluggableTreeMorph>>getIconSelector (in category 'accessing') ----- + getIconSelector + ^getIconSelector! Item was added: + ----- Method: PluggableTreeMorph>>getIconSelector: (in category 'accessing') ----- + getIconSelector: aSymbol + getIconSelector := aSymbol! Item was added: + ----- Method: PluggableTreeMorph>>getLabelSelector (in category 'accessing') ----- + getLabelSelector + ^getLabelSelector! Item was added: + ----- Method: PluggableTreeMorph>>getLabelSelector: (in category 'accessing') ----- + getLabelSelector: aSymbol + getLabelSelector := aSymbol! Item was added: + ----- Method: PluggableTreeMorph>>getMenuSelector (in category 'accessing') ----- + getMenuSelector + ^getMenuSelector! Item was added: + ----- Method: PluggableTreeMorph>>getMenuSelector: (in category 'accessing') ----- + getMenuSelector: aSymbol + getMenuSelector := aSymbol! Item was added: + ----- Method: PluggableTreeMorph>>getRootsSelector (in category 'accessing') ----- + getRootsSelector + ^getRootsSelector! Item was added: + ----- Method: PluggableTreeMorph>>getRootsSelector: (in category 'accessing') ----- + getRootsSelector: aSelector + getRootsSelector := aSelector. + self update: getRootsSelector.! Item was added: + ----- Method: PluggableTreeMorph>>getSelectedPathSelector (in category 'accessing') ----- + getSelectedPathSelector + ^getSelectedPathSelector! Item was added: + ----- Method: PluggableTreeMorph>>getSelectedPathSelector: (in category 'accessing') ----- + getSelectedPathSelector: aSymbol + getSelectedPathSelector := aSymbol.! Item was added: + ----- Method: PluggableTreeMorph>>hasChildrenSelector (in category 'accessing') ----- + hasChildrenSelector + ^hasChildrenSelector! Item was added: + ----- Method: PluggableTreeMorph>>hasChildrenSelector: (in category 'accessing') ----- + hasChildrenSelector: aSymbol + hasChildrenSelector := aSymbol! Item was added: + ----- Method: PluggableTreeMorph>>hasNodeContents: (in category 'node access') ----- + hasNodeContents: node + hasChildrenSelector ifNil:[^node contents isEmpty not]. + ^model perform: hasChildrenSelector with: node item! Item was added: + ----- Method: PluggableTreeMorph>>iconOfNode: (in category 'node access') ----- + iconOfNode: node + getIconSelector ifNil:[^nil]. + ^model perform: getIconSelector with: node item! Item was added: + ----- Method: PluggableTreeMorph>>isDraggableNode: (in category 'node access') ----- + isDraggableNode: node + ^true! Item was added: + ----- Method: PluggableTreeMorph>>keystrokeActionSelector (in category 'accessing') ----- + keystrokeActionSelector + ^keystrokeActionSelector! Item was added: + ----- Method: PluggableTreeMorph>>keystrokeActionSelector: (in category 'accessing') ----- + keystrokeActionSelector: aSymbol + keystrokeActionSelector := aSymbol! Item was added: + ----- Method: PluggableTreeMorph>>printNode: (in category 'node access') ----- + printNode: node + getLabelSelector ifNil:[^node item printString]. + ^model perform: getLabelSelector with: node item! Item was added: + ----- Method: PluggableTreeMorph>>roots (in category 'accessing') ----- + roots + ^roots! Item was added: + ----- Method: PluggableTreeMorph>>roots: (in category 'accessing') ----- + roots: anArray + roots := anArray collect:[:item| PluggableTreeItemNode with: item model: self]. + self list: roots.! Item was added: + ----- 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 + + ! Item was added: + ----- Method: PluggableTreeMorph>>setSelectedMorph: (in category 'selection') ----- + setSelectedMorph: aMorph + selectedWrapper := aMorph complexContents. + self selection: selectedWrapper. + setSelectedSelector ifNotNil:[ + model + perform: setSelectedSelector + with: (selectedWrapper ifNotNil:[selectedWrapper item]). + ].! Item was added: + ----- Method: PluggableTreeMorph>>setSelectedSelector (in category 'accessing') ----- + setSelectedSelector + ^setSelectedSelector! Item was added: + ----- Method: PluggableTreeMorph>>setSelectedSelector: (in category 'accessing') ----- + setSelectedSelector: aSymbol + setSelectedSelector := aSymbol! Item was added: + ----- 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! Item was added: + ----- 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! Item was added: + ----- Method: PluggableTreeMorph>>wantsDropSelector (in category 'accessing') ----- + wantsDropSelector + ^wantsDropSelector! Item was added: + ----- Method: PluggableTreeMorph>>wantsDropSelector: (in category 'accessing') ----- + wantsDropSelector: aSymbol + wantsDropSelector := aSymbol! Item was added: + ----- 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.! Item was added: + ----- 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!

1 0

The Trunk: ToolBuilder-Morphic-fbs.90.mcz
by commits＠source.squeak.org 31 May '13

31 May '13

Frank Shearar uploaded a new version of ToolBuilder-Morphic to project The Trunk: http://source.squeak.org/trunk/ToolBuilder-Morphic-fbs.90.mcz ==================== Summary ==================== Name: ToolBuilder-Morphic-fbs.90 Author: fbs Time: 31 May 2013, 4:00:00.398 pm UUID: b06416ef-714b-41ee-b6a1-90ddf0c305be Ancestors: ToolBuilder-Morphic-ul.89 Move ToolBuilder-Morphic to Morphic-ToolBuilder. =============== Diff against ToolBuilder-Morphic-ul.89 =============== Item was removed: - SystemOrganization addCategory: #'ToolBuilder-Morphic'! Item was removed: - 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.! Item was removed: - ----- Method: ListChooser class>>chooseFrom: (in category 'ChooserTool compatibility') ----- - chooseFrom: aList - ^ self - chooseFrom: aList - title: self defaultTitle! Item was removed: - ----- Method: ListChooser class>>chooseFrom:title: (in category 'ChooserTool compatibility') ----- - chooseFrom: aList title: aString - ^ self - chooseIndexFrom: aList - title: aString - addAllowed: false! Item was removed: - ----- Method: ListChooser class>>chooseIndexFrom: (in category 'instance creation') ----- - chooseIndexFrom: aList - ^ self - chooseIndexFrom: aList - title: self defaultTitle! Item was removed: - ----- 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! Item was removed: - ----- 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! Item was removed: - ----- Method: ListChooser class>>chooseItemFrom: (in category 'instance creation') ----- - chooseItemFrom: aList - ^ self - chooseItemFrom: aList - title: self defaultTitle! Item was removed: - ----- Method: ListChooser class>>chooseItemFrom:title: (in category 'instance creation') ----- - chooseItemFrom: aList title: aString - ^ self - chooseItemFrom: aList - title: aString - addAllowed: false! Item was removed: - ----- 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! Item was removed: - ----- Method: ListChooser class>>defaultTitle (in category 'instance creation') ----- - defaultTitle - ^ 'Please choose:'! Item was removed: - ----- Method: ListChooser class>>testDictionary (in category 'examples') ----- - testDictionary - ^ self - chooseItemFrom: (Dictionary newFrom: {#a->1. 2->#b.}) - title: 'Pick from Dictionary' "gives values, not keys"! Item was removed: - ----- Method: ListChooser class>>testIndex (in category 'examples') ----- - testIndex - ^ self - chooseIndexFrom: (Smalltalk classNames , Smalltalk traitNames) asOrderedCollection - title: 'Pick a class'! Item was removed: - ----- Method: ListChooser class>>testItem (in category 'examples') ----- - testItem - ^ self - chooseItemFrom: (Smalltalk classNames , Smalltalk traitNames) asOrderedCollection - title: 'Pick a class'! Item was removed: - ----- Method: ListChooser class>>testItemAdd (in category 'examples') ----- - testItemAdd - ^ self - chooseItemFrom: (Smalltalk classNames , Smalltalk traitNames) asOrderedCollection - title: 'Pick or Add:' - addAllowed: true! Item was removed: - ----- 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'! Item was removed: - ----- Method: ListChooser class>>testSet (in category 'examples') ----- - testSet - ^ self - chooseItemFrom: #(a list of values as a Set) asSet - title: 'Pick from Set'! Item was removed: - ----- 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 ]! Item was removed: - ----- Method: ListChooser>>acceptColor (in category 'drawing') ----- - acceptColor - ^ self canAccept - ifTrue: [ ColorTheme current okColor ] - ifFalse: [ Color lightGray "ColorTheme current disabledColor <- you don't have this!!" ]! Item was removed: - ----- 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! Item was removed: - ----- 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 ]! Item was removed: - ----- 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@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@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@1). - panel children add: button. - - ^ panel! Item was removed: - ----- 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! Item was removed: - ----- 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! Item was removed: - ----- Method: ListChooser>>buildWindowWith: (in category 'building') ----- - buildWindowWith: builder - | windowSpec | - windowSpec := builder pluggableWindowSpec new. - windowSpec model: self. - windowSpec label: #title. - windowSpec children: OrderedCollection new. - ^windowSpec! Item was removed: - ----- 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! Item was removed: - ----- Method: ListChooser>>buildWith: (in category 'building') ----- - buildWith: aBuilder - | windowSpec | - builder := aBuilder. - windowSpec := self buildWindowWith: builder specs: { - (0@0 corner: 1(a)0.05) -> [self buildSearchMorphWith: builder]. - (0(a)0.05 corner: 1(a)0.9) -> [self buildListMorphWith: builder]. - (0(a)0.9 corner: 1@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! Item was removed: - ----- Method: ListChooser>>canAccept (in category 'testing') ----- - canAccept - ^ self selectedIndex > 0! Item was removed: - ----- Method: ListChooser>>canAdd (in category 'testing') ----- - canAdd - ^ addAllowed and: [ self canAccept not ]! Item was removed: - ----- Method: ListChooser>>cancel (in category 'event handling') ----- - cancel - "Cancel the dialog and move on" - index := 0. - builder ifNotNil: [ builder close: window ]! Item was removed: - ----- Method: ListChooser>>cancelColor (in category 'drawing') ----- - cancelColor - ^ ColorTheme current cancelColor! Item was removed: - ----- 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! Item was removed: - ----- 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! Item was removed: - ----- 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! Item was removed: - ----- Method: ListChooser>>closed (in category 'event handling') ----- - closed - "Cancel the dialog and move on" - builder ifNotNil: [ index := 0 ]! Item was removed: - ----- Method: ListChooser>>handlesKeyboard: (in category 'event handling') ----- - handlesKeyboard: evt - ^ true! Item was removed: - ----- 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))! Item was removed: - ----- 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 ]. - ! Item was removed: - ----- 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. - ! Item was removed: - ----- Method: ListChooser>>list (in category 'accessing') ----- - list - ^ selectedItems! Item was removed: - ----- Method: ListChooser>>list: (in category 'accessing') ----- - list: items - fullList := items. - selectedItems := items. - self changed: #itemList.! Item was removed: - ----- Method: ListChooser>>list:title: (in category 'accessing') ----- - list: aList title: aString - self list: aList. - self title: aString! Item was removed: - ----- 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. - ! Item was removed: - ----- 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.! Item was removed: - ----- Method: ListChooser>>realIndex (in category 'accessing') ----- - realIndex - ^ realIndex ifNil: [ 0 ]! Item was removed: - ----- Method: ListChooser>>searchText (in category 'accessing') ----- - searchText - ^ searchText ifNil: [ searchText := '' ]! Item was removed: - ----- Method: ListChooser>>searchText: (in category 'accessing') ----- - searchText: aString - searchText := aString! Item was removed: - ----- Method: ListChooser>>selectedIndex (in category 'accessing') ----- - selectedIndex - ^ index ifNil: [ index := 1 ]! Item was removed: - ----- Method: ListChooser>>selectedIndex: (in category 'accessing') ----- - selectedIndex: anInt - index := (anInt min: selectedItems size). - self changed: #selectedIndex. - self changed: #canAccept.! Item was removed: - ----- Method: ListChooser>>title (in category 'accessing') ----- - title - ^ title ifNil: [ title := 'Please choose' ]! Item was removed: - ----- Method: ListChooser>>title: (in category 'accessing') ----- - title: aString - title := aString.! Item was removed: - ----- 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.! Item was removed: - 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.! Item was removed: - ----- Method: MorphicToolBuilder class>>isActiveBuilder (in category 'accessing') ----- - isActiveBuilder - "Answer whether I am the currently active builder" - ^Smalltalk isMorphic! Item was removed: - ----- Method: MorphicToolBuilder>>add:to: (in category 'private') ----- - add: aMorph to: aParent - aParent addMorphBack: aMorph. - aParent isSystemWindow ifTrue:[ - aParent addPaneMorph: aMorph. - ].! Item was removed: - ----- Method: MorphicToolBuilder>>alternateMultiSelectListClass (in category 'widget classes') ----- - alternateMultiSelectListClass - ^ AlternatePluggableListMorphOfMany ! Item was removed: - ----- 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! Item was removed: - ----- Method: MorphicToolBuilder>>buildHelpFor:spec: (in category 'pluggable widgets') ----- - buildHelpFor: widget spec: aSpec - aSpec help - ifNotNil: [widget setBalloonText: aSpec help]! Item was removed: - ----- Method: MorphicToolBuilder>>buildPluggableActionButton: (in category 'pluggable widgets') ----- - buildPluggableActionButton: aSpec - | button | - button := self buildPluggableButton: aSpec. - button color: Color white. - ^button! Item was removed: - ----- 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: Preferences 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! Item was removed: - ----- 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! Item was removed: - ----- 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! Item was removed: - ----- 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! Item was removed: - ----- 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! Item was removed: - ----- Method: MorphicToolBuilder>>buildPluggableInputField: (in category 'pluggable widgets') ----- - buildPluggableInputField: aSpec - | widget | - widget := self buildPluggableText: aSpec. - widget acceptOnCR: true. - widget hideScrollBarsIndefinitely. - ^widget! Item was removed: - ----- 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! Item was removed: - ----- 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! Item was removed: - ----- Method: MorphicToolBuilder>>buildPluggableMenuItem: (in category 'building') ----- - buildPluggableMenuItem: itemSpec - | item action label menu | - item := self menuItemClass new. - label := itemSpec label. - itemSpec checked ifTrue:[label := '<on>', label] ifFalse:[label := '<off>', label]. - item contents: label. - item isEnabled: itemSpec enabled. - (action := itemSpec action) ifNotNil:[ - item - target: action receiver; - selector: action selector; - arguments: action arguments. - ]. - (menu := itemSpec subMenu) ifNotNil:[ - item subMenu: (menu buildWith: self). - ]. - parentMenu ifNotNil:[parentMenu addMorphBack: item]. - itemSpec separator ifTrue:[parentMenu addLine]. - ^item! Item was removed: - ----- 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! Item was removed: - ----- 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! Item was removed: - ----- 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! Item was removed: - ----- 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! Item was removed: - ----- 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! Item was removed: - ----- Method: MorphicToolBuilder>>buttonClass (in category 'widget classes') ----- - buttonClass - ^ PluggableButtonMorphPlus! Item was removed: - ----- Method: MorphicToolBuilder>>checkBoxClass (in category 'widget classes') ----- - checkBoxClass - ^ PluggableCheckBoxMorph! Item was removed: - ----- Method: MorphicToolBuilder>>close: (in category 'opening') ----- - close: aWidget - "Close a previously opened widget" - aWidget delete! Item was removed: - ----- Method: MorphicToolBuilder>>codePaneClass (in category 'widget classes') ----- - codePaneClass - ^ PluggableTextMorphPlus! Item was removed: - ----- Method: MorphicToolBuilder>>dropDownListClass (in category 'widget classes') ----- - dropDownListClass - ^ PluggableDropDownListMorph! Item was removed: - ----- Method: MorphicToolBuilder>>listByItemClass (in category 'widget classes') ----- - listByItemClass - ^ PluggableListMorphByItemPlus! Item was removed: - ----- Method: MorphicToolBuilder>>listClass (in category 'widget classes') ----- - listClass - ^ PluggableListMorphPlus! Item was removed: - ----- Method: MorphicToolBuilder>>menuClass (in category 'widget classes') ----- - menuClass - ^ MenuMorph! Item was removed: - ----- Method: MorphicToolBuilder>>menuItemClass (in category 'widget classes') ----- - menuItemClass - ^ MenuItemMorph! Item was removed: - ----- Method: MorphicToolBuilder>>multiSelectListClass (in category 'widget classes') ----- - multiSelectListClass - ^ PluggableListMorphOfMany! Item was removed: - ----- 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! Item was removed: - ----- 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! Item was removed: - ----- Method: MorphicToolBuilder>>panelClass (in category 'widget classes') ----- - panelClass - ^ PluggablePanelMorph! Item was removed: - ----- 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.! Item was removed: - ----- 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. - ]. - ! Item was removed: - ----- 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. - ].! Item was removed: - ----- 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@1. - widget layoutInset: 1@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@1. - widget layoutInset: 1@1. - widget color: Color transparent. - "and then some..." - ^self]. - ^self error: 'Unknown layout: ', layout.! Item was removed: - ----- Method: MorphicToolBuilder>>textPaneClass (in category 'widget classes') ----- - textPaneClass - ^ PluggableTextMorphPlus! Item was removed: - ----- Method: MorphicToolBuilder>>treeClass (in category 'widget classes') ----- - treeClass - ^ PluggableTreeMorph! Item was removed: - ----- Method: MorphicToolBuilder>>widgetAt:ifAbsent: (in category 'private') ----- - widgetAt: id ifAbsent: aBlock - widgets ifNil:[^aBlock value]. - ^widgets at: id ifAbsent: aBlock! Item was removed: - ----- Method: MorphicToolBuilder>>windowClass (in category 'widget classes') ----- - windowClass - ^ PluggableSystemWindow! Item was removed: - ----- Method: MorphicToolBuilder>>windowClassFor: (in category 'widget classes') ----- - windowClassFor: aSpec - aSpec isDialog ifTrue: [^ PluggableDialogWindow]. - ^aSpec multiWindowStyle - caseOf: - { [nil] -> [PluggableSystemWindow]. - [#labelButton] -> [PluggableSystemWindowWithLabelButton] } - otherwise: [PluggableSystemWindowWithLabelButton]! Item was removed: - ToolBuilderTests subclass: #MorphicToolBuilderTests - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'ToolBuilder-Morphic'! - - !MorphicToolBuilderTests commentStamp: 'ar 2/11/2005 15:02' prior: 0! - Tests for the Morphic tool builder.! Item was removed: - ----- Method: MorphicToolBuilderTests>>acceptWidgetText (in category 'support') ----- - acceptWidgetText - widget hasUnacceptedEdits: true. - widget accept.! Item was removed: - ----- Method: MorphicToolBuilderTests>>buttonWidgetEnabled (in category 'support') ----- - buttonWidgetEnabled - "Answer whether the current widget (a button) is currently enabled" - ^widget enabled! Item was removed: - ----- Method: MorphicToolBuilderTests>>changeListWidget (in category 'support') ----- - changeListWidget - widget changeModelSelection: widget getCurrentSelectionIndex + 1.! Item was removed: - ----- Method: MorphicToolBuilderTests>>expectedButtonSideEffects (in category 'support') ----- - expectedButtonSideEffects - ^#(getColor getState getEnabled)! Item was removed: - ----- Method: MorphicToolBuilderTests>>fireButtonWidget (in category 'support') ----- - fireButtonWidget - widget performAction.! Item was removed: - ----- Method: MorphicToolBuilderTests>>fireMenuItemWidget (in category 'support') ----- - fireMenuItemWidget - (widget itemWithWording: 'Menu Item') - ifNotNil: [:item | item doButtonAction]! Item was removed: - ----- Method: MorphicToolBuilderTests>>setUp (in category 'support') ----- - setUp - super setUp. - builder := MorphicToolBuilder new.! Item was removed: - ----- Method: MorphicToolBuilderTests>>testWindowDynamicLabel (in category 'tests-window') ----- - testWindowDynamicLabel - self makeWindow. - self assert: (widget label = 'TestLabel').! Item was removed: - ----- Method: MorphicToolBuilderTests>>testWindowStaticLabel (in category 'tests-window') ----- - testWindowStaticLabel - | spec | - spec := builder pluggableWindowSpec new. - spec model: self. - spec children: #(). - spec label: 'TestLabel'. - widget := builder build: spec. - self assert: (widget label = 'TestLabel').! Item was removed: - ----- Method: MorphicToolBuilderTests>>widgetColor (in category 'support') ----- - widgetColor - "Answer color from widget" - ^widget color! Item was removed: - 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.! Item was removed: - ----- Method: MorphicUIManager class>>isActiveManager (in category 'accessing') ----- - isActiveManager - "Answer whether I should act as the active ui manager" - ^Smalltalk isMorphic! Item was removed: - ----- 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 ]! Item was removed: - ----- Method: MorphicUIManager>>chooseDirectory:from: (in category 'ui requests') ----- - chooseDirectory: label from: dir - "Let the user choose a directory" - ^FileList2 modalFolderSelector: dir! Item was removed: - ----- 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]! Item was removed: - ----- 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! Item was removed: - ----- 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 ]! Item was removed: - ----- 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 ]! Item was removed: - ----- 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! Item was removed: - ----- 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! Item was removed: - ----- 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 ! Item was removed: - ----- 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! Item was removed: - ----- 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.! Item was removed: - ----- Method: MorphicUIManager>>inform: (in category 'ui requests') ----- - inform: aString - "Display a message for the user to read and then dismiss" - ^UserDialogBoxMorph inform: aString! Item was removed: - ----- 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.! Item was removed: - ----- Method: MorphicUIManager>>initialize (in category 'initialize-release') ----- - initialize - toolBuilder := MorphicToolBuilder new! Item was removed: - ----- 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! Item was removed: - ----- 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 ! Item was removed: - ----- 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! Item was removed: - ----- 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! Item was removed: - 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.! Item was removed: - ----- Method: PluggableButtonMorphPlus>>action (in category 'accessing') ----- - action - ^action! Item was removed: - ----- Method: PluggableButtonMorphPlus>>action: (in category 'accessing') ----- - action: anAction - action := nil. - anAction isSymbol ifTrue:[^super action: anAction]. - action := anAction.! Item was removed: - ----- Method: PluggableButtonMorphPlus>>enabled (in category 'accessing') ----- - enabled - ^ enabled ifNil: [enabled := true]! Item was removed: - ----- 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]]! Item was removed: - ----- Method: PluggableButtonMorphPlus>>getColorSelector (in category 'accessing') ----- - getColorSelector - ^getColorSelector! Item was removed: - ----- Method: PluggableButtonMorphPlus>>getColorSelector: (in category 'accessing') ----- - getColorSelector: aSymbol - getColorSelector := aSymbol. - self update: getColorSelector.! Item was removed: - ----- Method: PluggableButtonMorphPlus>>getEnabledSelector (in category 'accessing') ----- - getEnabledSelector - ^getEnabledSelector! Item was removed: - ----- Method: PluggableButtonMorphPlus>>getEnabledSelector: (in category 'accessing') ----- - getEnabledSelector: aSymbol - getEnabledSelector := aSymbol. - self update: aSymbol.! Item was removed: - ----- Method: PluggableButtonMorphPlus>>initialize (in category 'initialize-release') ----- - initialize - super initialize. - enabled := true. - onColor := Color veryLightGray. - offColor := Color white! Item was removed: - ----- Method: PluggableButtonMorphPlus>>mouseDown: (in category 'action') ----- - mouseDown: evt - enabled ifFalse:[^self]. - ^super mouseDown: evt! Item was removed: - ----- Method: PluggableButtonMorphPlus>>mouseMove: (in category 'action') ----- - mouseMove: evt - enabled ifFalse:[^self]. - ^super mouseMove: evt! Item was removed: - ----- Method: PluggableButtonMorphPlus>>mouseUp: (in category 'action') ----- - mouseUp: evt - enabled ifFalse:[^self]. - ^super mouseUp: evt! Item was removed: - ----- 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.! Item was removed: - ----- Method: PluggableButtonMorphPlus>>performAction (in category 'action') ----- - performAction - enabled ifFalse:[^self]. - action ifNotNil:[^action value]. - ^super performAction! Item was removed: - ----- 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]]. - ! Item was removed: - ----- Method: PluggableButtonMorphPlus>>updateMap (in category 'updating') ----- - updateMap - ^ updateMap ifNil: [updateMap := Dictionary new] - ! Item was removed: - ----- 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! Item was removed: - AlignmentMorph subclass: #PluggableCheckBoxMorph - instanceVariableNames: 'model actionSelector valueSelector label' - classVariableNames: '' - poolDictionaries: '' - category: 'ToolBuilder-Morphic'! Item was removed: - ----- 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 - ! Item was removed: - ----- Method: PluggableCheckBoxMorph>>actionSelector (in category 'accessing') ----- - actionSelector - "Answer the value of actionSelector" - - ^ actionSelector! Item was removed: - ----- Method: PluggableCheckBoxMorph>>actionSelector: (in category 'accessing') ----- - actionSelector: anObject - "Set the value of actionSelector" - - actionSelector := anObject! Item was removed: - ----- Method: PluggableCheckBoxMorph>>basicPanel (in category 'installing') ----- - basicPanel - ^BorderedMorph new - beTransparent; - extent: 0@0; - borderWidth: 0; - layoutInset: 0; - cellInset: 0; - layoutPolicy: TableLayout new; - listCentering: #topLeft; - cellPositioning: #center; - hResizing: #spaceFill; - vResizing: #shrinkWrap; - yourself! Item was removed: - ----- Method: PluggableCheckBoxMorph>>horizontalPanel (in category 'installing') ----- - horizontalPanel - ^self basicPanel - cellPositioning: #center; - listDirection: #leftToRight; - yourself.! Item was removed: - ----- 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).! Item was removed: - ----- Method: PluggableCheckBoxMorph>>label (in category 'accessing') ----- - label - "Answer the value of label" - - ^ label! Item was removed: - ----- Method: PluggableCheckBoxMorph>>label: (in category 'accessing') ----- - label: anObject - "Set the value of label" - - label := anObject! Item was removed: - ----- Method: PluggableCheckBoxMorph>>model (in category 'accessing') ----- - model - "Answer the value of model" - - ^ model. - ! Item was removed: - ----- Method: PluggableCheckBoxMorph>>model: (in category 'accessing') ----- - model: anObject - "Set the value of model" - - model := anObject! Item was removed: - ----- 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). - ! Item was removed: - ----- Method: PluggableCheckBoxMorph>>valueSelector (in category 'accessing') ----- - valueSelector - "Answer the value of valueSelector" - - ^ valueSelector! Item was removed: - ----- Method: PluggableCheckBoxMorph>>valueSelector: (in category 'accessing') ----- - valueSelector: anObject - "Set the value of valueSelector" - - valueSelector := anObject! Item was removed: - PluggableSystemWindow subclass: #PluggableDialogWindow - instanceVariableNames: 'statusValue' - classVariableNames: '' - poolDictionaries: '' - category: 'ToolBuilder-Morphic'! Item was removed: - ----- Method: PluggableDialogWindow>>statusValue (in category 'as yet unclassified') ----- - statusValue - ^statusValue! Item was removed: - ----- Method: PluggableDialogWindow>>statusValue: (in category 'as yet unclassified') ----- - statusValue: val - statusValue := val! Item was removed: - AlignmentMorph subclass: #PluggableDropDownListMorph - instanceVariableNames: 'model listSelector selectionSelector selectionSetter' - classVariableNames: '' - poolDictionaries: '' - category: 'ToolBuilder-Morphic'! Item was removed: - ----- Method: PluggableDropDownListMorph>>basicPanel (in category 'drawing') ----- - basicPanel - ^BorderedMorph new - beTransparent; - extent: 0@0; - borderWidth: 0; - layoutInset: 0; - cellInset: 0; - layoutPolicy: TableLayout new; - listCentering: #topLeft; - cellPositioning: #center; - hResizing: #spaceFill; - vResizing: #shrinkWrap; - yourself! Item was removed: - ----- Method: PluggableDropDownListMorph>>currentSelection (in category 'accessing') ----- - currentSelection - - ^ self model perform: selectionSelector! Item was removed: - ----- Method: PluggableDropDownListMorph>>currentSelection: (in category 'accessing') ----- - currentSelection: obj - - ^ self model perform: selectionSetter with: obj! Item was removed: - ----- Method: PluggableDropDownListMorph>>horizontalPanel (in category 'drawing') ----- - horizontalPanel - ^self basicPanel - cellPositioning: #center; - listDirection: #leftToRight; - yourself.! Item was removed: - ----- 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).! Item was removed: - ----- Method: PluggableDropDownListMorph>>list (in category 'accessing') ----- - list - "Answer the value of list" - - ^ self model perform: self listSelector. - ! Item was removed: - ----- Method: PluggableDropDownListMorph>>listSelector (in category 'accessing') ----- - listSelector - "Answer the value of listSelector" - - ^ listSelector! Item was removed: - ----- Method: PluggableDropDownListMorph>>listSelector: (in category 'accessing') ----- - listSelector: anObject - "Set the value of listSelector" - - listSelector := anObject! Item was removed: - ----- Method: PluggableDropDownListMorph>>model (in category 'accessing') ----- - model - ^ model! Item was removed: - ----- Method: PluggableDropDownListMorph>>model: (in category 'accessing') ----- - model: anObject - "Set the value of model" - - model := anObject! Item was removed: - ----- Method: PluggableDropDownListMorph>>selectionSelector (in category 'accessing') ----- - selectionSelector - "Answer the value of selectionSelector" - - ^ selectionSelector! Item was removed: - ----- Method: PluggableDropDownListMorph>>selectionSelector: (in category 'accessing') ----- - selectionSelector: anObject - "Set the value of selectionSelector" - - selectionSelector := anObject! Item was removed: - ----- Method: PluggableDropDownListMorph>>selectionSetter (in category 'accessing') ----- - selectionSetter - "Answer the value of selectionSetter" - - ^ selectionSetter! Item was removed: - ----- Method: PluggableDropDownListMorph>>selectionSetter: (in category 'accessing') ----- - selectionSetter: anObject - "Set the value of selectionSetter" - - selectionSetter := anObject! Item was removed: - 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.! Item was removed: - ----- 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. - ! Item was removed: - ----- 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] - ! Item was removed: - ----- Method: PluggableListMorphByItemPlus>>getList (in category 'as yet unclassified') ----- - getList - "cache the raw items in itemList" - itemList := getListSelector ifNil: [ #() ] ifNotNil: [ model perform: getListSelector ]. - ^super getList! Item was removed: - ----- 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! Item was removed: - 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! Item was removed: - ----- 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. - ! Item was removed: - ----- Method: PluggableListMorphPlus>>dragItemSelector (in category 'accessing') ----- - dragItemSelector - ^dragItemSelector! Item was removed: - ----- Method: PluggableListMorphPlus>>dragItemSelector: (in category 'accessing') ----- - dragItemSelector: aSymbol - dragItemSelector := aSymbol. - aSymbol ifNotNil:[self dragEnabled: true].! Item was removed: - ----- Method: PluggableListMorphPlus>>dropItemSelector (in category 'accessing') ----- - dropItemSelector - ^dropItemSelector! Item was removed: - ----- Method: PluggableListMorphPlus>>dropItemSelector: (in category 'accessing') ----- - dropItemSelector: aSymbol - dropItemSelector := aSymbol. - aSymbol ifNotNil:[self dropEnabled: true].! Item was removed: - ----- 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]! Item was removed: - ----- Method: PluggableListMorphPlus>>wantsDropSelector (in category 'accessing') ----- - wantsDropSelector - ^wantsDropSelector! Item was removed: - ----- Method: PluggableListMorphPlus>>wantsDropSelector: (in category 'accessing') ----- - wantsDropSelector: aSymbol - wantsDropSelector := aSymbol! Item was removed: - ----- 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! Item was removed: - 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.! Item was removed: - ----- Method: PluggablePanelMorph>>getChildrenSelector (in category 'accessing') ----- - getChildrenSelector - ^getChildrenSelector! Item was removed: - ----- Method: PluggablePanelMorph>>getChildrenSelector: (in category 'accessing') ----- - getChildrenSelector: aSymbol - getChildrenSelector := aSymbol.! Item was removed: - ----- Method: PluggablePanelMorph>>model (in category 'accessing') ----- - model - ^model! Item was removed: - ----- Method: PluggablePanelMorph>>model: (in category 'accessing') ----- - model: aModel - model ifNotNil:[model removeDependent: self]. - model := aModel. - model ifNotNil:[model addDependent: self].! Item was removed: - ----- Method: PluggablePanelMorph>>update: (in category 'update') ----- - update: what - what == nil ifTrue:[^self]. - what == getChildrenSelector ifTrue:[ - self removeAllMorphs. - self addAllMorphs: (model perform: getChildrenSelector). - self submorphsDo:[:m| m hResizing: #spaceFill; vResizing: #spaceFill]. - ].! Item was removed: - 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.! Item was removed: - ----- Method: PluggableSystemWindow>>addPaneMorph: (in category 'accessing') ----- - addPaneMorph: aMorph - self addMorph: aMorph fullFrame: aMorph layoutFrame! Item was removed: - ----- Method: PluggableSystemWindow>>closeWindowSelector (in category 'accessing') ----- - closeWindowSelector - ^closeWindowSelector! Item was removed: - ----- Method: PluggableSystemWindow>>closeWindowSelector: (in category 'accessing') ----- - closeWindowSelector: aSymbol - closeWindowSelector := aSymbol! Item was removed: - ----- Method: PluggableSystemWindow>>delete (in category 'initialization') ----- - delete - closeWindowSelector ifNotNil:[model perform: closeWindowSelector]. - super delete. - ! Item was removed: - ----- Method: PluggableSystemWindow>>getChildrenSelector (in category 'accessing') ----- - getChildrenSelector - ^getChildrenSelector! Item was removed: - ----- Method: PluggableSystemWindow>>getChildrenSelector: (in category 'accessing') ----- - getChildrenSelector: aSymbol - getChildrenSelector := aSymbol! Item was removed: - ----- Method: PluggableSystemWindow>>getLabelSelector (in category 'accessing') ----- - getLabelSelector - ^getLabelSelector! Item was removed: - ----- Method: PluggableSystemWindow>>getLabelSelector: (in category 'accessing') ----- - getLabelSelector: aSymbol - getLabelSelector := aSymbol. - self update: aSymbol.! Item was removed: - ----- Method: PluggableSystemWindow>>label (in category 'accessing') ----- - label - ^label contents! Item was removed: - ----- Method: PluggableSystemWindow>>label: (in category 'accessing') ----- - label: aString - self setLabel: aString.! Item was removed: - ----- 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! Item was removed: - 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.! Item was removed: - ----- Method: PluggableTextMorphPlus>>accept (in category 'updating') ----- - accept - super accept. - acceptAction ifNotNil:[acceptAction value: textMorph asText].! Item was removed: - ----- Method: PluggableTextMorphPlus>>acceptAction (in category 'accessing') ----- - acceptAction - ^acceptAction! Item was removed: - ----- Method: PluggableTextMorphPlus>>acceptAction: (in category 'accessing') ----- - acceptAction: anAction - acceptAction := anAction! Item was removed: - ----- 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]! Item was removed: - ----- 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! Item was removed: - ----- Method: PluggableTextMorphPlus>>getColorSelector (in category 'accessing') ----- - getColorSelector - ^getColorSelector! Item was removed: - ----- Method: PluggableTextMorphPlus>>getColorSelector: (in category 'accessing') ----- - getColorSelector: aSymbol - getColorSelector := aSymbol. - self update: getColorSelector.! Item was removed: - ----- 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'! Item was removed: - ----- 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]! Item was removed: - ----- Method: PluggableTextMorphPlus>>okToStyle (in category 'testing') ----- - okToStyle - styler ifNil:[^false]. - (model respondsTo: #aboutToStyle: ) ifFalse:[^true]. - ^model aboutToStyle: styler - ! Item was removed: - ----- 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]! Item was removed: - ----- Method: PluggableTextMorphPlus>>styler (in category 'accessing') ----- - styler - "The styler responsible for highlighting text in the receiver" - ^styler! Item was removed: - ----- Method: PluggableTextMorphPlus>>styler: (in category 'accessing') ----- - styler: anObject - "The styler responsible for highlighting text in the receiver" - styler := anObject! Item was removed: - ----- 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 updateFromParagraph. - selectionInterval - ifNotNil:[ - textMorph editor - selectInvisiblyFrom: selectionInterval first to: selectionInterval last; - storeSelectionInParagraph; - setEmphasisHere]. - textMorph editor blinkParen. - self scrollSelectionIntoView! Item was removed: - ----- 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]! Item was removed: - ----- Method: PluggableTextMorphPlus>>update: (in category 'updating') ----- - update: what - what ifNil:[^self]. - what == getColorSelector ifTrue:[self color: (model perform: getColorSelector)]. - ^super update: what! Item was removed: - ----- 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). - ].! Item was removed: - ListItemWrapper subclass: #PluggableTreeItemNode - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'ToolBuilder-Morphic'! - - !PluggableTreeItemNode commentStamp: 'ar 2/12/2005 04:37' prior: 0! - Tree item for PluggableTreeMorph.! Item was removed: - ----- Method: PluggableTreeItemNode>>acceptDroppingObject: (in category 'accessing') ----- - acceptDroppingObject: anotherItem - ^model dropNode: anotherItem on: self! Item was removed: - ----- Method: PluggableTreeItemNode>>asString (in category 'accessing') ----- - asString - ^model printNode: self! Item was removed: - ----- Method: PluggableTreeItemNode>>balloonText (in category 'accessing') ----- - balloonText - ^model balloonTextForNode: self! Item was removed: - ----- Method: PluggableTreeItemNode>>canBeDragged (in category 'accessing') ----- - canBeDragged - ^model isDraggableNode: self! Item was removed: - ----- Method: PluggableTreeItemNode>>contents (in category 'accessing') ----- - contents - ^model contentsOfNode: self! Item was removed: - ----- Method: PluggableTreeItemNode>>hasContents (in category 'accessing') ----- - hasContents - ^model hasNodeContents: self! Item was removed: - ----- Method: PluggableTreeItemNode>>icon (in category 'accessing') ----- - icon - ^model iconOfNode: self! Item was removed: - ----- Method: PluggableTreeItemNode>>item (in category 'accessing') ----- - item - ^item! Item was removed: - ----- Method: PluggableTreeItemNode>>wantsDroppedObject: (in category 'accessing') ----- - wantsDroppedObject: anotherItem - ^model wantsDroppedNode: anotherItem on: self! Item was removed: - 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.! Item was removed: - ----- 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! Item was removed: - ----- Method: PluggableTreeMorph>>balloonTextForNode: (in category 'node access') ----- - balloonTextForNode: node - getHelpSelector ifNil:[^nil]. - ^model perform: getHelpSelector with: node item! Item was removed: - ----- 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]! Item was removed: - ----- Method: PluggableTreeMorph>>dragItemSelector (in category 'accessing') ----- - dragItemSelector - ^dragItemSelector! Item was removed: - ----- Method: PluggableTreeMorph>>dragItemSelector: (in category 'accessing') ----- - dragItemSelector: aSymbol - dragItemSelector := aSymbol. - aSymbol ifNotNil:[self dragEnabled: true].! Item was removed: - ----- Method: PluggableTreeMorph>>dropItemSelector (in category 'accessing') ----- - dropItemSelector - ^dropItemSelector! Item was removed: - ----- Method: PluggableTreeMorph>>dropItemSelector: (in category 'accessing') ----- - dropItemSelector: aSymbol - dropItemSelector := aSymbol. - aSymbol ifNotNil:[self dropEnabled: true].! Item was removed: - ----- Method: PluggableTreeMorph>>dropNode:on: (in category 'node access') ----- - dropNode: srcNode on: dstNode - dropItemSelector ifNil:[^nil]. - model perform: dropItemSelector with: srcNode item with: dstNode item! Item was removed: - ----- Method: PluggableTreeMorph>>getChildrenSelector (in category 'accessing') ----- - getChildrenSelector - ^getChildrenSelector! Item was removed: - ----- Method: PluggableTreeMorph>>getChildrenSelector: (in category 'accessing') ----- - getChildrenSelector: aSymbol - getChildrenSelector := aSymbol.! Item was removed: - ----- Method: PluggableTreeMorph>>getHelpSelector (in category 'accessing') ----- - getHelpSelector - ^getHelpSelector! Item was removed: - ----- Method: PluggableTreeMorph>>getHelpSelector: (in category 'accessing') ----- - getHelpSelector: aSymbol - getHelpSelector := aSymbol! Item was removed: - ----- Method: PluggableTreeMorph>>getIconSelector (in category 'accessing') ----- - getIconSelector - ^getIconSelector! Item was removed: - ----- Method: PluggableTreeMorph>>getIconSelector: (in category 'accessing') ----- - getIconSelector: aSymbol - getIconSelector := aSymbol! Item was removed: - ----- Method: PluggableTreeMorph>>getLabelSelector (in category 'accessing') ----- - getLabelSelector - ^getLabelSelector! Item was removed: - ----- Method: PluggableTreeMorph>>getLabelSelector: (in category 'accessing') ----- - getLabelSelector: aSymbol - getLabelSelector := aSymbol! Item was removed: - ----- Method: PluggableTreeMorph>>getMenuSelector (in category 'accessing') ----- - getMenuSelector - ^getMenuSelector! Item was removed: - ----- Method: PluggableTreeMorph>>getMenuSelector: (in category 'accessing') ----- - getMenuSelector: aSymbol - getMenuSelector := aSymbol! Item was removed: - ----- Method: PluggableTreeMorph>>getRootsSelector (in category 'accessing') ----- - getRootsSelector - ^getRootsSelector! Item was removed: - ----- Method: PluggableTreeMorph>>getRootsSelector: (in category 'accessing') ----- - getRootsSelector: aSelector - getRootsSelector := aSelector. - self update: getRootsSelector.! Item was removed: - ----- Method: PluggableTreeMorph>>getSelectedPathSelector (in category 'accessing') ----- - getSelectedPathSelector - ^getSelectedPathSelector! Item was removed: - ----- Method: PluggableTreeMorph>>getSelectedPathSelector: (in category 'accessing') ----- - getSelectedPathSelector: aSymbol - getSelectedPathSelector := aSymbol.! Item was removed: - ----- Method: PluggableTreeMorph>>hasChildrenSelector (in category 'accessing') ----- - hasChildrenSelector - ^hasChildrenSelector! Item was removed: - ----- Method: PluggableTreeMorph>>hasChildrenSelector: (in category 'accessing') ----- - hasChildrenSelector: aSymbol - hasChildrenSelector := aSymbol! Item was removed: - ----- Method: PluggableTreeMorph>>hasNodeContents: (in category 'node access') ----- - hasNodeContents: node - hasChildrenSelector ifNil:[^node contents isEmpty not]. - ^model perform: hasChildrenSelector with: node item! Item was removed: - ----- Method: PluggableTreeMorph>>iconOfNode: (in category 'node access') ----- - iconOfNode: node - getIconSelector ifNil:[^nil]. - ^model perform: getIconSelector with: node item! Item was removed: - ----- Method: PluggableTreeMorph>>isDraggableNode: (in category 'node access') ----- - isDraggableNode: node - ^true! Item was removed: - ----- Method: PluggableTreeMorph>>keystrokeActionSelector (in category 'accessing') ----- - keystrokeActionSelector - ^keystrokeActionSelector! Item was removed: - ----- Method: PluggableTreeMorph>>keystrokeActionSelector: (in category 'accessing') ----- - keystrokeActionSelector: aSymbol - keystrokeActionSelector := aSymbol! Item was removed: - ----- Method: PluggableTreeMorph>>printNode: (in category 'node access') ----- - printNode: node - getLabelSelector ifNil:[^node item printString]. - ^model perform: getLabelSelector with: node item! Item was removed: - ----- Method: PluggableTreeMorph>>roots (in category 'accessing') ----- - roots - ^roots! Item was removed: - ----- Method: PluggableTreeMorph>>roots: (in category 'accessing') ----- - roots: anArray - roots := anArray collect:[:item| PluggableTreeItemNode with: item model: self]. - self list: roots.! Item was removed: - ----- 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 - - ! Item was removed: - ----- Method: PluggableTreeMorph>>setSelectedMorph: (in category 'selection') ----- - setSelectedMorph: aMorph - selectedWrapper := aMorph complexContents. - self selection: selectedWrapper. - setSelectedSelector ifNotNil:[ - model - perform: setSelectedSelector - with: (selectedWrapper ifNotNil:[selectedWrapper item]). - ].! Item was removed: - ----- Method: PluggableTreeMorph>>setSelectedSelector (in category 'accessing') ----- - setSelectedSelector - ^setSelectedSelector! Item was removed: - ----- Method: PluggableTreeMorph>>setSelectedSelector: (in category 'accessing') ----- - setSelectedSelector: aSymbol - setSelectedSelector := aSymbol! Item was removed: - ----- 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! Item was removed: - ----- 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! Item was removed: - ----- Method: PluggableTreeMorph>>wantsDropSelector (in category 'accessing') ----- - wantsDropSelector - ^wantsDropSelector! Item was removed: - ----- Method: PluggableTreeMorph>>wantsDropSelector: (in category 'accessing') ----- - wantsDropSelector: aSymbol - wantsDropSelector := aSymbol! Item was removed: - ----- 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.! Item was removed: - ----- 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!

1 0

The Trunk: ST80-fbs.145.mcz
by commits＠source.squeak.org 31 May '13

31 May '13

Frank Shearar uploaded a new version of ST80 to project The Trunk: http://source.squeak.org/trunk/ST80-fbs.145.mcz ==================== Summary ==================== Name: ST80-fbs.145 Author: fbs Time: 31 May 2013, 3:58:33.3 pm UUID: 391f44a6-e960-42f2-83b4-7c9700212c0e Ancestors: ST80-fbs.144 Move ToolBuilder-MVC to ST80-ToolBuilder. =============== Diff against ST80-fbs.144 =============== Item was changed: SystemOrganization addCategory: #'ST80-Controllers'! SystemOrganization addCategory: #'ST80-Editors'! SystemOrganization addCategory: #'ST80-Framework'! SystemOrganization addCategory: #'ST80-Menus'! SystemOrganization addCategory: #'ST80-Menus-Tests'! SystemOrganization addCategory: #'ST80-Paths'! SystemOrganization addCategory: #'ST80-Pluggable Views'! SystemOrganization addCategory: #'ST80-Support'! SystemOrganization addCategory: #'ST80-Support-Tests'! SystemOrganization addCategory: #'ST80-Symbols'! SystemOrganization addCategory: #'ST80-Views'! + SystemOrganization addCategory: #'ST80-ToolBuilder'! Item was added: + ToolBuilder subclass: #MVCToolBuilder + instanceVariableNames: 'panes topSize widgets' + classVariableNames: '' + poolDictionaries: '' + category: 'ST80-ToolBuilder'! + + !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>>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: + ToolBuilderTests subclass: #MVCToolBuilderTests + instanceVariableNames: '' + classVariableNames: '' + poolDictionaries: '' + category: 'ST80-ToolBuilder'! + + !MVCToolBuilderTests commentStamp: 'ar 2/11/2005 15:02' prior: 0! + Tests for the MVC tool builder.! Item was added: + ----- Method: MVCToolBuilderTests>>acceptWidgetText (in category 'support') ----- + acceptWidgetText + widget hasUnacceptedEdits: true. + widget controller accept.! Item was added: + ----- Method: MVCToolBuilderTests>>changeListWidget (in category 'support') ----- + changeListWidget + widget changeModelSelection: widget getCurrentSelectionIndex + 1.! Item was added: + ----- Method: MVCToolBuilderTests>>expectedButtonSideEffects (in category 'support') ----- + expectedButtonSideEffects + ^#(getState)! Item was added: + ----- Method: MVCToolBuilderTests>>fireButtonWidget (in category 'support') ----- + fireButtonWidget + widget performAction.! Item was added: + ----- Method: MVCToolBuilderTests>>setUp (in category 'support') ----- + setUp + super setUp. + builder := MVCToolBuilder new.! Item was added: + ----- Method: MVCToolBuilderTests>>tearDown (in category 'support') ----- + tearDown + ScreenController new restoreDisplay. + super tearDown! Item was added: + ----- Method: MVCToolBuilderTests>>testAddAction (in category 'tests-not applicable') ----- + testAddAction + "MVCToolBuilder does not implement #buildPluggableMenu:"! Item was added: + ----- Method: MVCToolBuilderTests>>testAddTargetSelectorArgumentList (in category 'tests-not applicable') ----- + testAddTargetSelectorArgumentList + "MVCToolBuilder does not implement #buildPluggableMenu:"! Item was added: + ----- Method: MVCToolBuilderTests>>testButtonFiresBlock (in category 'tests-not applicable') ----- + testButtonFiresBlock + "MVC buttons only support action Symbols"! Item was added: + ----- Method: MVCToolBuilderTests>>testButtonFiresMessage (in category 'tests-not applicable') ----- + testButtonFiresMessage + "MVC buttons only support action Symbols, not MessageSends"! Item was added: + ----- Method: MVCToolBuilderTests>>testButtonInitiallyDisabled (in category 'tests-not applicable') ----- + testButtonInitiallyDisabled + "MVC does not have button enablement"! Item was added: + ----- Method: MVCToolBuilderTests>>testButtonInitiallyDisabledSelector (in category 'tests-not applicable') ----- + testButtonInitiallyDisabledSelector + "MVC does not have button enablement"! Item was added: + ----- Method: MVCToolBuilderTests>>testGetButtonColor (in category 'tests-not applicable') ----- + testGetButtonColor + "MVC buttons do not have color"! Item was added: + ----- Method: MVCToolBuilderTests>>testGetButtonEnabled (in category 'tests-not applicable') ----- + testGetButtonEnabled + "MVC does not have button enablement"! Item was added: + ----- Method: MVCToolBuilderTests>>testGetInputFieldColor (in category 'tests-not applicable') ----- + testGetInputFieldColor + "MVC input fields do not have color"! Item was added: + ----- Method: MVCToolBuilderTests>>testGetPanelChildren (in category 'tests-not applicable') ----- + testGetPanelChildren + "MVC panels do not allow changing children"! Item was added: + ----- Method: MVCToolBuilderTests>>testGetTextColor (in category 'tests-not applicable') ----- + testGetTextColor + "not supported in MVC"! Item was added: + ----- Method: MVCToolBuilderTests>>testGetWindowChildren (in category 'tests-not applicable') ----- + testGetWindowChildren + "not supported in MVC"! Item was added: + ----- Method: MVCToolBuilderTests>>testGetWindowLabel (in category 'tests-not applicable') ----- + testGetWindowLabel + "not supported in MVC"! Item was added: + ----- Method: MVCToolBuilderTests>>testTreeExpandPath (in category 'tests-not applicable') ----- + testTreeExpandPath + "MVCToollBuilder does not implement trees"! Item was added: + ----- Method: MVCToolBuilderTests>>testTreeExpandPathFirst (in category 'tests-not applicable') ----- + testTreeExpandPathFirst + "MVCToollBuilder does not implement trees"! Item was added: + ----- Method: MVCToolBuilderTests>>testTreeGetSelectionPath (in category 'tests-not applicable') ----- + testTreeGetSelectionPath + "MVCToollBuilder does not implement trees"! Item was added: + ----- Method: MVCToolBuilderTests>>testTreeRoots (in category 'tests-not applicable') ----- + testTreeRoots + "MVCToollBuilder does not implement trees"! Item was added: + ----- Method: MVCToolBuilderTests>>testTreeWidgetID (in category 'tests-not applicable') ----- + testTreeWidgetID + "MVCToollBuilder does not implement trees"! Item was added: + ----- Method: MVCToolBuilderTests>>testWindowCloseAction (in category 'tests-not applicable') ----- + testWindowCloseAction + "This can only work if we're actually run in MVC" + World isNil ifTrue: [super testWindowCloseAction]! Item was added: + UIManager subclass: #MVCUIManager + instanceVariableNames: '' + classVariableNames: '' + poolDictionaries: '' + category: 'ST80-ToolBuilder'! + + !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>>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!

1 0

The Trunk: ToolBuilder-MVC-fbs.33.mcz
by commits＠source.squeak.org 31 May '13

31 May '13

Frank Shearar uploaded a new version of ToolBuilder-MVC to project The Trunk: http://source.squeak.org/trunk/ToolBuilder-MVC-fbs.33.mcz ==================== Summary ==================== Name: ToolBuilder-MVC-fbs.33 Author: fbs Time: 31 May 2013, 3:57:44.48 pm UUID: a8fd7d64-d153-4a7e-b0c8-ce8fc219a2e4 Ancestors: ToolBuilder-MVC-nice.32 Move ToolBuilder-MVC to ST80-ToolBuilder. =============== Diff against ToolBuilder-MVC-nice.32 =============== Item was removed: - SystemOrganization addCategory: #'ToolBuilder-MVC'! Item was removed: - 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 removed: - ----- 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 removed: - ----- 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 removed: - ----- 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 removed: - ----- 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 removed: - ----- 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 removed: - ----- 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 removed: - ----- 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 removed: - ----- Method: MVCToolBuilder>>close: (in category 'opening') ----- - close: aWidget - "Close a previously opened widget" - aWidget controller closeAndUnschedule.! Item was removed: - ----- 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 removed: - ----- 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 removed: - ----- 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 removed: - ----- 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 removed: - ----- Method: MVCToolBuilder>>pluggableTreeSpec (in category 'defaults') ----- - pluggableTreeSpec - "We have no tree widget in MVC right now" - ^nil! Item was removed: - ----- 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 removed: - ----- 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 removed: - ----- 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 removed: - ----- 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 removed: - ----- 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 removed: - ----- Method: MVCToolBuilder>>widgetAt:ifAbsent: (in category 'private') ----- - widgetAt: id ifAbsent: aBlock - widgets ifNil:[^aBlock value]. - ^widgets at: id ifAbsent: aBlock! Item was removed: - ToolBuilderTests subclass: #MVCToolBuilderTests - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'ToolBuilder-MVC'! - - !MVCToolBuilderTests commentStamp: 'ar 2/11/2005 15:02' prior: 0! - Tests for the MVC tool builder.! Item was removed: - ----- Method: MVCToolBuilderTests>>acceptWidgetText (in category 'support') ----- - acceptWidgetText - widget hasUnacceptedEdits: true. - widget controller accept.! Item was removed: - ----- Method: MVCToolBuilderTests>>changeListWidget (in category 'support') ----- - changeListWidget - widget changeModelSelection: widget getCurrentSelectionIndex + 1.! Item was removed: - ----- Method: MVCToolBuilderTests>>expectedButtonSideEffects (in category 'support') ----- - expectedButtonSideEffects - ^#(getState)! Item was removed: - ----- Method: MVCToolBuilderTests>>fireButtonWidget (in category 'support') ----- - fireButtonWidget - widget performAction.! Item was removed: - ----- Method: MVCToolBuilderTests>>setUp (in category 'support') ----- - setUp - super setUp. - builder := MVCToolBuilder new.! Item was removed: - ----- Method: MVCToolBuilderTests>>tearDown (in category 'support') ----- - tearDown - ScreenController new restoreDisplay. - super tearDown! Item was removed: - ----- Method: MVCToolBuilderTests>>testAddAction (in category 'tests-not applicable') ----- - testAddAction - "MVCToolBuilder does not implement #buildPluggableMenu:"! Item was removed: - ----- Method: MVCToolBuilderTests>>testAddTargetSelectorArgumentList (in category 'tests-not applicable') ----- - testAddTargetSelectorArgumentList - "MVCToolBuilder does not implement #buildPluggableMenu:"! Item was removed: - ----- Method: MVCToolBuilderTests>>testButtonFiresBlock (in category 'tests-not applicable') ----- - testButtonFiresBlock - "MVC buttons only support action Symbols"! Item was removed: - ----- Method: MVCToolBuilderTests>>testButtonFiresMessage (in category 'tests-not applicable') ----- - testButtonFiresMessage - "MVC buttons only support action Symbols, not MessageSends"! Item was removed: - ----- Method: MVCToolBuilderTests>>testButtonInitiallyDisabled (in category 'tests-not applicable') ----- - testButtonInitiallyDisabled - "MVC does not have button enablement"! Item was removed: - ----- Method: MVCToolBuilderTests>>testButtonInitiallyDisabledSelector (in category 'tests-not applicable') ----- - testButtonInitiallyDisabledSelector - "MVC does not have button enablement"! Item was removed: - ----- Method: MVCToolBuilderTests>>testGetButtonColor (in category 'tests-not applicable') ----- - testGetButtonColor - "MVC buttons do not have color"! Item was removed: - ----- Method: MVCToolBuilderTests>>testGetButtonEnabled (in category 'tests-not applicable') ----- - testGetButtonEnabled - "MVC does not have button enablement"! Item was removed: - ----- Method: MVCToolBuilderTests>>testGetInputFieldColor (in category 'tests-not applicable') ----- - testGetInputFieldColor - "MVC input fields do not have color"! Item was removed: - ----- Method: MVCToolBuilderTests>>testGetPanelChildren (in category 'tests-not applicable') ----- - testGetPanelChildren - "MVC panels do not allow changing children"! Item was removed: - ----- Method: MVCToolBuilderTests>>testGetTextColor (in category 'tests-not applicable') ----- - testGetTextColor - "not supported in MVC"! Item was removed: - ----- Method: MVCToolBuilderTests>>testGetWindowChildren (in category 'tests-not applicable') ----- - testGetWindowChildren - "not supported in MVC"! Item was removed: - ----- Method: MVCToolBuilderTests>>testGetWindowLabel (in category 'tests-not applicable') ----- - testGetWindowLabel - "not supported in MVC"! Item was removed: - ----- Method: MVCToolBuilderTests>>testTreeExpandPath (in category 'tests-not applicable') ----- - testTreeExpandPath - "MVCToollBuilder does not implement trees"! Item was removed: - ----- Method: MVCToolBuilderTests>>testTreeExpandPathFirst (in category 'tests-not applicable') ----- - testTreeExpandPathFirst - "MVCToollBuilder does not implement trees"! Item was removed: - ----- Method: MVCToolBuilderTests>>testTreeGetSelectionPath (in category 'tests-not applicable') ----- - testTreeGetSelectionPath - "MVCToollBuilder does not implement trees"! Item was removed: - ----- Method: MVCToolBuilderTests>>testTreeRoots (in category 'tests-not applicable') ----- - testTreeRoots - "MVCToollBuilder does not implement trees"! Item was removed: - ----- Method: MVCToolBuilderTests>>testTreeWidgetID (in category 'tests-not applicable') ----- - testTreeWidgetID - "MVCToollBuilder does not implement trees"! Item was removed: - ----- Method: MVCToolBuilderTests>>testWindowCloseAction (in category 'tests-not applicable') ----- - testWindowCloseAction - "This can only work if we're actually run in MVC" - World isNil ifTrue: [super testWindowCloseAction]! Item was removed: - 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 removed: - ----- 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 removed: - ----- Method: MVCUIManager>>chooseDirectory:from: (in category 'ui requests') ----- - chooseDirectory: label from: dir - "Let the user choose a directory" - ^self notYetImplemented! Item was removed: - ----- 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 removed: - ----- 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 removed: - ----- 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 removed: - ----- 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 removed: - ----- 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 removed: - ----- 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 removed: - ----- 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 removed: - ----- 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 removed: - ----- 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 removed: - ----- 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 removed: - ----- 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 removed: - ----- Method: MVCUIManager>>initialize (in category 'initialize-release') ----- - initialize - toolBuilder := MVCToolBuilder new! Item was removed: - ----- 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 removed: - ----- 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 removed: - ----- 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 removed: - ----- 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!

1 0

minutes, servers, restarts, and websites
by Chris Cunnington 31 May '13

31 May '13

> If you can move that prototype to one of the new servers sponsored by the Free Software Foundation, > than that is very fine for me as far as I am concerned. Ken created a scheme for box3 and box4 that suits their relative size. It's easy to put the squeak.org Altitude prototype back on box3, but I don't think it's a good idea, as box3 is mainly about Jenkins. Ideally, I'd like to see box4 preparation move ahead. Ken wanted to do something different than before, perhaps using nginx instead of Apache. I think it would probably be best for me to wait for that. Because we're talking about it now, it seems urgent. I imagine the situation will shift over the summer. My role now is specific. I'm happy to say that anything beyond it is not my bailiwick (Vogtei). It'll all come around. Chris

1 0

minutes, servers, restarts, and websites
by Chris Cunnington 31 May '13

31 May '13

>Anyway, after not hearing from you in a while, it's good to know >you're still around. Nice of you to say. As usual, I've probably come a bit strong. Sorry about that. As mundane as Board minutes can sometimes be, it seems to be worse without them. Cheers, Chris

2 2

how to attachMorph: at the corner?
by Chris Muller 31 May '13

31 May '13

I'm using #openInHand, which opens my morph, centered under the hand. I want to open it in the hand, but attached near the upper left corner rather than the center. To do this, I factored the temp var "delta" calculation out of HandMorph>>#attachMorph:, so it would take an argument instead, attachMorph: aMorph at: delta. Regular attachMorph now calls it passing in the center point. Now I have an attach API that accepts an offset, guess I just need to support openInHand: offset to call the new #attachMorph:at:. (Sigh) It works but is there a better way to do this?

2 4

Daily Commit Log
by commits＠source.squeak.org 31 May '13

31 May '13

Changes to Trunk (http://source.squeak.org/trunk.html) in the last 24 hours: http://lists.squeakfoundation.org/pipermail/packages/2013-May/005994.html Name: Kernel-fbs.762 Ancestors: Kernel-fbs.761 Turn Promise into a fully chainable object with decent error handling. (This implements the Smalltalk equivalent of JavaScript's Promises/A+ specification.) ============================================= http://lists.squeakfoundation.org/pipermail/packages/2013-May/005995.html Name: KernelTests-fbs.252 Ancestors: KernelTests-fbs.251 Turn Promise into a fully chainable object with decent error handling. (This implements the Smalltalk equivalent of JavaScript's Promises/A+ specification.) ============================================= http://lists.squeakfoundation.org/pipermail/packages/2013-May/005996.html Name: Collections-nice.520 Ancestors: Collections-fbs.519 Introduce Character null ============================================= http://lists.squeakfoundation.org/pipermail/packages/2013-May/005997.html Name: CollectionsTests-nice.204 Ancestors: CollectionsTests-fbs.203 Don't let Character null fail ============================================= http://lists.squeakfoundation.org/pipermail/packages/2013-May/005998.html Name: Monticello-nice.546 Ancestors: Monticello-kb.545 Let's encode .mcz/snapshot/source.st in UTF8 Let's decode UTF8 in MCStReader. Previously, it was encoded in latin-1 (iso-8859-L1) for ByteString and UTF-32BE for WideString. And would always be decoded in latin-1 by MCStReader. Note that compatibility with legacy code is handled by catching InvalidUTF8 exception. An alternative would be to use a BOM in new snapshot. However, since the snapshot/source.st is not used by Squeak tools, it's not really worth. ============================================= http://lists.squeakfoundation.org/pipermail/packages/2013-May/005999.html Name: System-nice.539 Ancestors: System-fbs.538 Now that .mcz/snapshot/source.st are encoded in UTF8, Let MczInstaller decode UTF8. Previously, snapshot/source.st was encoded in latin-1 (iso-8859-L1) for ByteString and UTF-32BE for WideString. And would always be decoded in MacRoman by MczInstaller (or UTF-8 if there were a BOM, but there weren't) Note that .mcz do not use a BOM for compatibility with legacy code. Thus compatibility is handled by catching InvalidUTF8 exception. The rationale is that previous interpretation of snapshot/source.st was completely broken and presumably not used. So adding a bit of complexity with a BOM compatibility is not really worth. ============================================= http://lists.squeakfoundation.org/pipermail/packages/2013-May/006000.html Name: CollectionsTests-nice.205 Ancestors: CollectionsTests-nice.204 Better use allByteCharacters than allCharacters. They do the same, but second one is misleading, not all Characters are byte now. =============================================

1 0

Fw: Re: [squeak-dev] minutes, servers, restarts, and websites
by Rudolf Rednose 31 May '13

31 May '13

1 0

The Trunk: CollectionsTests-nice.205.mcz
by commits＠source.squeak.org 31 May '13

31 May '13

Nicolas Cellier uploaded a new version of CollectionsTests to project The Trunk: http://source.squeak.org/trunk/CollectionsTests-nice.205.mcz ==================== Summary ==================== Name: CollectionsTests-nice.205 Author: nice Time: 31 May 2013, 1:05:58.534 am UUID: 9eb181ab-8e91-473a-8662-d59c355f3cfb Ancestors: CollectionsTests-nice.204 Better use allByteCharacters than allCharacters. They do the same, but second one is misleading, not all Characters are byte now. =============== Diff against CollectionsTests-nice.204 =============== Item was changed: ----- Method: CharacterTest>>testPrintStringAll (in category 'testing-printing') ----- testPrintStringAll + Character allByteCharacters do: [ :each | - Character allCharacters do: [ :each | self assert: (self class newCompiler evaluate: each printString) = each ].! Item was changed: ----- Method: CharacterTest>>testStoreStringAll (in category 'testing-printing') ----- testStoreStringAll + Character allByteCharacters do: [ :each | - Character allCharacters do: [ :each | self assert: (self class newCompiler evaluate: each storeString) = each ].!

1 0

← Newer
1
2
3
4
5
6
7
...
34
Older →

Jump to page: