Packages May 2013

packages@lists.squeakfoundation.org

1 participants
357 discussions

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: ST80-fbs.145.mcz
by commits＠source.squeak.org 31 May '13

31 May '13

1 0

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

31 May '13

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

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

31 May '13

1 0

The Trunk: ToolBuilder-MVC-fbs.33.mcz
by commits＠source.squeak.org 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

The Trunk: CollectionsTests-nice.205.mcz
by commits＠source.squeak.org 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

1 0

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

Packages May 2013