Chris Muller uploaded a new version of ToolBuilder-Morphic to project Squeak 4.5:
http://source.squeak.org/squeak45/ToolBuilder-Morphic-fbs.91.mcz ==================== Summary ==================== Name: ToolBuilder-Morphic-fbs.91 Author: fbs Time: 9 January 2014, 2:56:27.235 pm UUID: abaa076b-af43-af42-8c98-7a71482c6a30 Ancestors: ToolBuilder-Morphic-fbs.90 Move the ToolBuilder classes back to ToolBuilder-Morphic: this way you can have Morphic with or without ToolBuilder. ==================== Snapshot ==================== SystemOrganization addCategory: #'ToolBuilder-Morphic'! 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.! ----- Method: MorphicToolBuilder class>>isActiveBuilder (in category 'accessing') ----- isActiveBuilder "Answer whether I am the currently active builder" ^Smalltalk isMorphic! ----- Method: MorphicToolBuilder>>add:to: (in category 'private') ----- add: aMorph to: aParent aParent addMorphBack: aMorph. aParent isSystemWindow ifTrue:[ aParent addPaneMorph: aMorph. ].! ----- Method: MorphicToolBuilder>>alternateMultiSelectListClass (in category 'widget classes') ----- alternateMultiSelectListClass ^ AlternatePluggableListMorphOfMany ! ----- 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! ----- Method: MorphicToolBuilder>>buildHelpFor:spec: (in category 'pluggable widgets') ----- buildHelpFor: widget spec: aSpec aSpec help ifNotNil: [widget setBalloonText: aSpec help]! ----- Method: MorphicToolBuilder>>buildPluggableActionButton: (in category 'pluggable widgets') ----- buildPluggableActionButton: aSpec | button | button := self buildPluggableButton: aSpec. button color: Color white. ^button! ----- 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: SystemBrowser 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! ----- 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! ----- 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! ----- 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! ----- 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! ----- Method: MorphicToolBuilder>>buildPluggableInputField: (in category 'pluggable widgets') ----- buildPluggableInputField: aSpec | widget | widget := self buildPluggableText: aSpec. widget acceptOnCR: true. widget hideScrollBarsIndefinitely. ^widget! ----- 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! ----- 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! ----- Method: MorphicToolBuilder>>buildPluggableMenuItem: (in category 'building') ----- buildPluggableMenuItem: itemSpec | item action label menu | item := self menuItemClass new. label := (itemSpec isCheckable ifTrue: [ itemSpec checked ifTrue: ['<on>'] ifFalse: ['<off>']] ifFalse: ['']), itemSpec 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! ----- 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! ----- 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! ----- 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! ----- 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! ----- 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! ----- Method: MorphicToolBuilder>>buttonClass (in category 'widget classes') ----- buttonClass ^ PluggableButtonMorphPlus! ----- Method: MorphicToolBuilder>>checkBoxClass (in category 'widget classes') ----- checkBoxClass ^ PluggableCheckBoxMorph! ----- Method: MorphicToolBuilder>>close: (in category 'opening') ----- close: aWidget "Close a previously opened widget" aWidget delete! ----- Method: MorphicToolBuilder>>codePaneClass (in category 'widget classes') ----- codePaneClass ^ PluggableTextMorphPlus! ----- Method: MorphicToolBuilder>>dropDownListClass (in category 'widget classes') ----- dropDownListClass ^ PluggableDropDownListMorph! ----- Method: MorphicToolBuilder>>listByItemClass (in category 'widget classes') ----- listByItemClass ^ PluggableListMorphByItemPlus! ----- Method: MorphicToolBuilder>>listClass (in category 'widget classes') ----- listClass ^ PluggableListMorphPlus! ----- Method: MorphicToolBuilder>>menuClass (in category 'widget classes') ----- menuClass ^ MenuMorph! ----- Method: MorphicToolBuilder>>menuItemClass (in category 'widget classes') ----- menuItemClass ^ MenuItemMorph! ----- Method: MorphicToolBuilder>>multiSelectListClass (in category 'widget classes') ----- multiSelectListClass ^ PluggableListMorphOfMany! ----- 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! ----- 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! ----- Method: MorphicToolBuilder>>panelClass (in category 'widget classes') ----- panelClass ^ PluggablePanelMorph! ----- 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.! ----- 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. ]. ! ----- 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. ].! ----- 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.! ----- Method: MorphicToolBuilder>>textPaneClass (in category 'widget classes') ----- textPaneClass ^ PluggableTextMorphPlus! ----- Method: MorphicToolBuilder>>treeClass (in category 'widget classes') ----- treeClass ^ PluggableTreeMorph! ----- Method: MorphicToolBuilder>>widgetAt:ifAbsent: (in category 'private') ----- widgetAt: id ifAbsent: aBlock widgets ifNil:[^aBlock value]. ^widgets at: id ifAbsent: aBlock! ----- Method: MorphicToolBuilder>>windowClass (in category 'widget classes') ----- windowClass ^ PluggableSystemWindow! ----- Method: MorphicToolBuilder>>windowClassFor: (in category 'widget classes') ----- windowClassFor: aSpec aSpec isDialog ifTrue: [^ PluggableDialogWindow]. ^aSpec multiWindowStyle caseOf: { [nil] -> [PluggableSystemWindow]. [#labelButton] -> [PluggableSystemWindowWithLabelButton] } otherwise: [PluggableSystemWindowWithLabelButton]! AlignmentMorph subclass: #PluggableCheckBoxMorph instanceVariableNames: 'model actionSelector valueSelector label' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-Morphic'! ----- 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 ! ----- Method: PluggableCheckBoxMorph>>actionSelector (in category 'accessing') ----- actionSelector "Answer the value of actionSelector" ^ actionSelector! ----- Method: PluggableCheckBoxMorph>>actionSelector: (in category 'accessing') ----- actionSelector: anObject "Set the value of actionSelector" actionSelector := anObject! ----- 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! ----- Method: PluggableCheckBoxMorph>>horizontalPanel (in category 'installing') ----- horizontalPanel ^self basicPanel cellPositioning: #center; listDirection: #leftToRight; yourself.! ----- 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).! ----- Method: PluggableCheckBoxMorph>>label (in category 'accessing') ----- label "Answer the value of label" ^ label! ----- Method: PluggableCheckBoxMorph>>label: (in category 'accessing') ----- label: anObject "Set the value of label" label := anObject! ----- Method: PluggableCheckBoxMorph>>model (in category 'accessing') ----- model "Answer the value of model" ^ model. ! ----- Method: PluggableCheckBoxMorph>>model: (in category 'accessing') ----- model: anObject "Set the value of model" model := anObject! ----- 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). ! ----- Method: PluggableCheckBoxMorph>>valueSelector (in category 'accessing') ----- valueSelector "Answer the value of valueSelector" ^ valueSelector! ----- Method: PluggableCheckBoxMorph>>valueSelector: (in category 'accessing') ----- valueSelector: anObject "Set the value of valueSelector" valueSelector := anObject! AlignmentMorph subclass: #PluggableDropDownListMorph instanceVariableNames: 'model listSelector selectionSelector selectionSetter' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-Morphic'! ----- 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! ----- Method: PluggableDropDownListMorph>>currentSelection (in category 'accessing') ----- currentSelection ^ self model perform: selectionSelector! ----- Method: PluggableDropDownListMorph>>currentSelection: (in category 'accessing') ----- currentSelection: obj ^ self model perform: selectionSetter with: obj! ----- Method: PluggableDropDownListMorph>>horizontalPanel (in category 'drawing') ----- horizontalPanel ^self basicPanel cellPositioning: #center; listDirection: #leftToRight; yourself.! ----- 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).! ----- Method: PluggableDropDownListMorph>>list (in category 'accessing') ----- list "Answer the value of list" ^ self model perform: self listSelector. ! ----- Method: PluggableDropDownListMorph>>listSelector (in category 'accessing') ----- listSelector "Answer the value of listSelector" ^ listSelector! ----- Method: PluggableDropDownListMorph>>listSelector: (in category 'accessing') ----- listSelector: anObject "Set the value of listSelector" listSelector := anObject! ----- Method: PluggableDropDownListMorph>>model (in category 'accessing') ----- model ^ model! ----- Method: PluggableDropDownListMorph>>model: (in category 'accessing') ----- model: anObject "Set the value of model" model := anObject! ----- Method: PluggableDropDownListMorph>>selectionSelector (in category 'accessing') ----- selectionSelector "Answer the value of selectionSelector" ^ selectionSelector! ----- Method: PluggableDropDownListMorph>>selectionSelector: (in category 'accessing') ----- selectionSelector: anObject "Set the value of selectionSelector" selectionSelector := anObject! ----- Method: PluggableDropDownListMorph>>selectionSetter (in category 'accessing') ----- selectionSetter "Answer the value of selectionSetter" ^ selectionSetter! ----- Method: PluggableDropDownListMorph>>selectionSetter: (in category 'accessing') ----- selectionSetter: anObject "Set the value of selectionSetter" selectionSetter := anObject! 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.! ----- Method: PluggablePanelMorph>>canBeEncroached (in category 'private') ----- canBeEncroached ^ submorphs allSatisfy: [ : each | each canBeEncroached ]! ----- Method: PluggablePanelMorph>>children (in category 'accessing') ----- children ^ model perform: getChildrenSelector! ----- Method: PluggablePanelMorph>>getChildrenSelector (in category 'accessing') ----- getChildrenSelector ^getChildrenSelector! ----- Method: PluggablePanelMorph>>getChildrenSelector: (in category 'accessing') ----- getChildrenSelector: aSymbol getChildrenSelector := aSymbol.! ----- Method: PluggablePanelMorph>>model (in category 'accessing') ----- model ^model! ----- Method: PluggablePanelMorph>>model: (in category 'accessing') ----- model: aModel model ifNotNil:[model removeDependent: self]. model := aModel. model ifNotNil:[model addDependent: self].! ----- Method: PluggablePanelMorph>>update: (in category 'update') ----- update: selectorSymbolOrNil selectorSymbolOrNil ifNil: [ ^ self ]. selectorSymbolOrNil = getChildrenSelector ifTrue: [ self removeAllMorphs ; addAllMorphs: self children ; submorphsDo: [ : m | m hResizing: #spaceFill ; vResizing: #spaceFill ] ]! 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! 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.! ----- 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. ! ----- 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] ! ----- Method: PluggableListMorphByItemPlus>>getList (in category 'as yet unclassified') ----- getList "cache the raw items in itemList" itemList := getListSelector ifNil: [ #() ] ifNotNil: [ model perform: getListSelector ]. ^super getList! ----- 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! ----- 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. ! ----- Method: PluggableListMorphPlus>>dragItemSelector (in category 'accessing') ----- dragItemSelector ^dragItemSelector! ----- Method: PluggableListMorphPlus>>dragItemSelector: (in category 'accessing') ----- dragItemSelector: aSymbol dragItemSelector := aSymbol. aSymbol ifNotNil:[self dragEnabled: true].! ----- Method: PluggableListMorphPlus>>dropItemSelector (in category 'accessing') ----- dropItemSelector ^dropItemSelector! ----- Method: PluggableListMorphPlus>>dropItemSelector: (in category 'accessing') ----- dropItemSelector: aSymbol dropItemSelector := aSymbol. aSymbol ifNotNil:[self dropEnabled: true].! ----- 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]! ----- Method: PluggableListMorphPlus>>wantsDropSelector (in category 'accessing') ----- wantsDropSelector ^wantsDropSelector! ----- Method: PluggableListMorphPlus>>wantsDropSelector: (in category 'accessing') ----- wantsDropSelector: aSymbol wantsDropSelector := aSymbol! ----- 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! ListItemWrapper subclass: #PluggableTreeItemNode instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-Morphic'! !PluggableTreeItemNode commentStamp: 'ar 2/12/2005 04:37' prior: 0! Tree item for PluggableTreeMorph.! ----- Method: PluggableTreeItemNode>>acceptDroppingObject: (in category 'accessing') ----- acceptDroppingObject: anotherItem ^model dropNode: anotherItem on: self! ----- Method: PluggableTreeItemNode>>asString (in category 'accessing') ----- asString ^model printNode: self! ----- Method: PluggableTreeItemNode>>balloonText (in category 'accessing') ----- balloonText ^model balloonTextForNode: self! ----- Method: PluggableTreeItemNode>>canBeDragged (in category 'accessing') ----- canBeDragged ^model isDraggableNode: self! ----- Method: PluggableTreeItemNode>>contents (in category 'accessing') ----- contents ^model contentsOfNode: self! ----- Method: PluggableTreeItemNode>>hasContents (in category 'accessing') ----- hasContents ^model hasNodeContents: self! ----- Method: PluggableTreeItemNode>>icon (in category 'accessing') ----- icon ^model iconOfNode: self! ----- Method: PluggableTreeItemNode>>item (in category 'accessing') ----- item ^item! ----- Method: PluggableTreeItemNode>>wantsDroppedObject: (in category 'accessing') ----- wantsDroppedObject: anotherItem ^model wantsDroppedNode: anotherItem on: self! 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.! ----- Method: MorphicUIManager class>>isActiveManager (in category 'accessing') ----- isActiveManager "Answer whether I should act as the active ui manager" ^Smalltalk isMorphic! ----- 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 ]! ----- Method: MorphicUIManager>>chooseDirectory:from: (in category 'ui requests') ----- chooseDirectory: label from: dir "Let the user choose a directory" ^FileList2 modalFolderSelector: dir! ----- 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]! ----- 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! ----- 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 ]! ----- 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 ]! ----- 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! ----- 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! ----- 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 ! ----- 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! ----- 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.! ----- Method: MorphicUIManager>>inform: (in category 'ui requests') ----- inform: aString "Display a message for the user to read and then dismiss" ^UserDialogBoxMorph inform: aString! ----- 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.! ----- Method: MorphicUIManager>>initialize (in category 'initialize-release') ----- initialize toolBuilder := MorphicToolBuilder new! ----- 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! ----- Method: MorphicUIManager>>newDisplayDepthNoRestore: (in category 'display') ----- newDisplayDepthNoRestore: pixelSize "Change depths. Check if there is enough space!! , di" | area need | pixelSize = Display depth ifTrue: [^ self "no change"]. pixelSize abs < Display depth ifFalse: ["Make sure there is enough space" area := Display boundingBox area. "pixels" need := (area * (pixelSize abs - Display depth) // 8) "new bytes needed" + Smalltalk lowSpaceThreshold. (Smalltalk garbageCollectMost <= need and: [Smalltalk garbageCollect <= need]) ifTrue: [self error: 'Insufficient free space']]. Display setExtent: Display extent depth: pixelSize. DisplayScreen startUp! ----- 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 ! ----- 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! ----- 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! ----- Method: MorphicUIManager>>restoreDisplay (in category 'display') ----- restoreDisplay "Restore the bits on Display" Project current ifNotNil:[:p| p invalidate; restore].! ----- Method: MorphicUIManager>>restoreDisplayAfter: (in category 'display') ----- restoreDisplayAfter: aBlock "Evaluate the block, wait for a mouse click, and then restore the screen." aBlock value. Sensor waitButton. self restoreDisplay! 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.! PluggableSystemWindow subclass: #PluggableDialogWindow instanceVariableNames: 'statusValue' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-Morphic'! ----- Method: PluggableDialogWindow>>statusValue (in category 'as yet unclassified') ----- statusValue ^statusValue! ----- Method: PluggableDialogWindow>>statusValue: (in category 'as yet unclassified') ----- statusValue: val statusValue := val! ----- Method: PluggableSystemWindow>>addPaneMorph: (in category 'accessing') ----- addPaneMorph: aMorph self addMorph: aMorph fullFrame: aMorph layoutFrame! ----- Method: PluggableSystemWindow>>closeWindowSelector (in category 'accessing') ----- closeWindowSelector ^closeWindowSelector! ----- Method: PluggableSystemWindow>>closeWindowSelector: (in category 'accessing') ----- closeWindowSelector: aSymbol closeWindowSelector := aSymbol! ----- Method: PluggableSystemWindow>>delete (in category 'initialization') ----- delete closeWindowSelector ifNotNil:[model perform: closeWindowSelector]. super delete. ! ----- Method: PluggableSystemWindow>>getChildrenSelector (in category 'accessing') ----- getChildrenSelector ^getChildrenSelector! ----- Method: PluggableSystemWindow>>getChildrenSelector: (in category 'accessing') ----- getChildrenSelector: aSymbol getChildrenSelector := aSymbol! ----- Method: PluggableSystemWindow>>getLabelSelector (in category 'accessing') ----- getLabelSelector ^getLabelSelector! ----- Method: PluggableSystemWindow>>getLabelSelector: (in category 'accessing') ----- getLabelSelector: aSymbol getLabelSelector := aSymbol. self update: aSymbol.! ----- Method: PluggableSystemWindow>>label (in category 'accessing') ----- label ^label contents! ----- Method: PluggableSystemWindow>>label: (in category 'accessing') ----- label: aString self setLabel: aString.! ----- 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! 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.! ----- Method: ListChooser class>>chooseFrom: (in category 'ChooserTool compatibility') ----- chooseFrom: aList ^ self chooseFrom: aList title: self defaultTitle! ----- Method: ListChooser class>>chooseFrom:title: (in category 'ChooserTool compatibility') ----- chooseFrom: aList title: aString ^ self chooseIndexFrom: aList title: aString addAllowed: false! ----- Method: ListChooser class>>chooseIndexFrom: (in category 'instance creation') ----- chooseIndexFrom: aList ^ self chooseIndexFrom: aList title: self defaultTitle! ----- 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! ----- 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! ----- Method: ListChooser class>>chooseItemFrom: (in category 'instance creation') ----- chooseItemFrom: aList ^ self chooseItemFrom: aList title: self defaultTitle! ----- Method: ListChooser class>>chooseItemFrom:title: (in category 'instance creation') ----- chooseItemFrom: aList title: aString ^ self chooseItemFrom: aList title: aString addAllowed: false! ----- 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! ----- Method: ListChooser class>>defaultTitle (in category 'instance creation') ----- defaultTitle ^ 'Please choose:'! ----- Method: ListChooser class>>testDictionary (in category 'examples') ----- testDictionary ^ self chooseItemFrom: (Dictionary newFrom: {#a->1. 2->#b.}) title: 'Pick from Dictionary' "gives values, not keys"! ----- Method: ListChooser class>>testIndex (in category 'examples') ----- testIndex ^ self chooseIndexFrom: (Smalltalk classNames , Smalltalk traitNames) asOrderedCollection title: 'Pick a class'! ----- Method: ListChooser class>>testItem (in category 'examples') ----- testItem ^ self chooseItemFrom: (Smalltalk classNames , Smalltalk traitNames) asOrderedCollection title: 'Pick a class'! ----- Method: ListChooser class>>testItemAdd (in category 'examples') ----- testItemAdd ^ self chooseItemFrom: (Smalltalk classNames , Smalltalk traitNames) asOrderedCollection title: 'Pick or Add:' addAllowed: true! ----- 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'! ----- Method: ListChooser class>>testSet (in category 'examples') ----- testSet ^ self chooseItemFrom: #(a list of values as a Set) asSet title: 'Pick from Set'! ----- 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 ]! ----- Method: ListChooser>>acceptColor (in category 'drawing') ----- acceptColor ^ self canAccept ifTrue: [ ColorTheme current okColor ] ifFalse: [ Color lightGray "ColorTheme current disabledColor <- you don't have this!!" ]! ----- 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! ----- 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 ]! ----- 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! ----- 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! ----- 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! ----- Method: ListChooser>>buildWindowWith: (in category 'building') ----- buildWindowWith: builder | windowSpec | windowSpec := builder pluggableWindowSpec new. windowSpec model: self. windowSpec label: #title. windowSpec children: OrderedCollection new. ^windowSpec! ----- 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! ----- Method: ListChooser>>buildWith: (in category 'building') ----- buildWith: aBuilder | windowSpec | builder := aBuilder. windowSpec := self buildWindowWith: builder specs: { (0@0 corner: 1@0.05) -> [self buildSearchMorphWith: builder]. (0@0.05 corner: 1@0.9) -> [self buildListMorphWith: builder]. (0@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! ----- Method: ListChooser>>canAccept (in category 'testing') ----- canAccept ^ self selectedIndex > 0! ----- Method: ListChooser>>canAdd (in category 'testing') ----- canAdd ^ addAllowed and: [ self canAccept not ]! ----- Method: ListChooser>>cancel (in category 'event handling') ----- cancel "Cancel the dialog and move on" index := 0. builder ifNotNil: [ builder close: window ]! ----- Method: ListChooser>>cancelColor (in category 'drawing') ----- cancelColor ^ ColorTheme current cancelColor! ----- 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! ----- 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! ----- 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! ----- Method: ListChooser>>closed (in category 'event handling') ----- closed "Cancel the dialog and move on" builder ifNotNil: [ index := 0 ]! ----- Method: ListChooser>>handlesKeyboard: (in category 'event handling') ----- handlesKeyboard: evt ^ true! ----- 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))! ----- 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 ]. ! ----- 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. ! ----- Method: ListChooser>>list (in category 'accessing') ----- list ^ selectedItems! ----- Method: ListChooser>>list: (in category 'accessing') ----- list: items fullList := items. selectedItems := items. self changed: #itemList.! ----- Method: ListChooser>>list:title: (in category 'accessing') ----- list: aList title: aString self list: aList. self title: aString! ----- 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. ! ----- 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.! ----- Method: ListChooser>>realIndex (in category 'accessing') ----- realIndex ^ realIndex ifNil: [ 0 ]! ----- Method: ListChooser>>searchText (in category 'accessing') ----- searchText ^ searchText ifNil: [ searchText := '' ]! ----- Method: ListChooser>>searchText: (in category 'accessing') ----- searchText: aString searchText := aString! ----- Method: ListChooser>>selectedIndex (in category 'accessing') ----- selectedIndex ^ index ifNil: [ index := 1 ]! ----- Method: ListChooser>>selectedIndex: (in category 'accessing') ----- selectedIndex: anInt index := (anInt min: selectedItems size). self changed: #selectedIndex. self changed: #canAccept.! ----- Method: ListChooser>>title (in category 'accessing') ----- title ^ title ifNil: [ title := 'Please choose' ]! ----- Method: ListChooser>>title: (in category 'accessing') ----- title: aString title := aString.! ----- 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.! 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.! ----- Method: PluggableTextMorphPlus>>accept (in category 'updating') ----- accept super accept. acceptAction ifNotNil:[acceptAction value: textMorph asText].! ----- Method: PluggableTextMorphPlus>>acceptAction (in category 'accessing') ----- acceptAction ^acceptAction! ----- Method: PluggableTextMorphPlus>>acceptAction: (in category 'accessing') ----- acceptAction: anAction acceptAction := anAction! ----- 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]! ----- 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! ----- Method: PluggableTextMorphPlus>>getColorSelector (in category 'accessing') ----- getColorSelector ^getColorSelector! ----- Method: PluggableTextMorphPlus>>getColorSelector: (in category 'accessing') ----- getColorSelector: aSymbol getColorSelector := aSymbol. self update: getColorSelector.! ----- 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'! ----- 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]! ----- Method: PluggableTextMorphPlus>>okToStyle (in category 'testing') ----- okToStyle styler ifNil:[^false]. (model respondsTo: #aboutToStyle: ) ifFalse:[^true]. ^model aboutToStyle: styler ! ----- 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]! ----- Method: PluggableTextMorphPlus>>styler (in category 'accessing') ----- styler "The styler responsible for highlighting text in the receiver" ^styler! ----- Method: PluggableTextMorphPlus>>styler: (in category 'accessing') ----- styler: anObject "The styler responsible for highlighting text in the receiver" styler := anObject! ----- 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 paragraph composeAll. textMorph updateFromParagraph. selectionInterval ifNotNil:[ textMorph editor selectInvisiblyFrom: selectionInterval first to: selectionInterval last; storeSelectionInParagraph; setEmphasisHere]. textMorph editor blinkParen. self scrollSelectionIntoView! ----- 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]! ----- Method: PluggableTextMorphPlus>>update: (in category 'updating') ----- update: what what ifNil:[^self]. what == getColorSelector ifTrue:[self color: (model perform: getColorSelector)]. ^super update: what! ----- 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). ].! 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.! ----- Method: PluggableButtonMorphPlus>>action (in category 'accessing') ----- action ^action! ----- Method: PluggableButtonMorphPlus>>action: (in category 'accessing') ----- action: anAction action := nil. anAction isSymbol ifTrue:[^super action: anAction]. action := anAction.! ----- Method: PluggableButtonMorphPlus>>enabled (in category 'accessing') ----- enabled ^ enabled ifNil: [enabled := true]! ----- 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]]! ----- Method: PluggableButtonMorphPlus>>getColorSelector (in category 'accessing') ----- getColorSelector ^getColorSelector! ----- Method: PluggableButtonMorphPlus>>getColorSelector: (in category 'accessing') ----- getColorSelector: aSymbol getColorSelector := aSymbol. self update: getColorSelector.! ----- Method: PluggableButtonMorphPlus>>getEnabledSelector (in category 'accessing') ----- getEnabledSelector ^getEnabledSelector! ----- Method: PluggableButtonMorphPlus>>getEnabledSelector: (in category 'accessing') ----- getEnabledSelector: aSymbol getEnabledSelector := aSymbol. self update: aSymbol.! ----- Method: PluggableButtonMorphPlus>>initialize (in category 'initialize-release') ----- initialize super initialize. enabled := true. onColor := Color veryLightGray. offColor := Color white! ----- Method: PluggableButtonMorphPlus>>mouseDown: (in category 'action') ----- mouseDown: evt enabled ifFalse:[^self]. ^super mouseDown: evt! ----- Method: PluggableButtonMorphPlus>>mouseMove: (in category 'action') ----- mouseMove: evt enabled ifFalse:[^self]. ^super mouseMove: evt! ----- Method: PluggableButtonMorphPlus>>mouseUp: (in category 'action') ----- mouseUp: evt enabled ifFalse:[^self]. ^super mouseUp: evt! ----- 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.! ----- Method: PluggableButtonMorphPlus>>performAction (in category 'action') ----- performAction enabled ifFalse:[^self]. action ifNotNil:[^action value]. ^super performAction! ----- 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]]. ! ----- Method: PluggableButtonMorphPlus>>updateMap (in category 'updating') ----- updateMap ^ updateMap ifNil: [updateMap := Dictionary new] ! ----- 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! 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.! ----- 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! ----- Method: PluggableTreeMorph>>balloonTextForNode: (in category 'node access') ----- balloonTextForNode: node getHelpSelector ifNil:[^nil]. ^model perform: getHelpSelector with: node item! ----- 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]! ----- Method: PluggableTreeMorph>>dragItemSelector (in category 'accessing') ----- dragItemSelector ^dragItemSelector! ----- Method: PluggableTreeMorph>>dragItemSelector: (in category 'accessing') ----- dragItemSelector: aSymbol dragItemSelector := aSymbol. aSymbol ifNotNil:[self dragEnabled: true].! ----- Method: PluggableTreeMorph>>dropItemSelector (in category 'accessing') ----- dropItemSelector ^dropItemSelector! ----- Method: PluggableTreeMorph>>dropItemSelector: (in category 'accessing') ----- dropItemSelector: aSymbol dropItemSelector := aSymbol. aSymbol ifNotNil:[self dropEnabled: true].! ----- Method: PluggableTreeMorph>>dropNode:on: (in category 'node access') ----- dropNode: srcNode on: dstNode dropItemSelector ifNil:[^nil]. model perform: dropItemSelector with: srcNode item with: dstNode item! ----- Method: PluggableTreeMorph>>getChildrenSelector (in category 'accessing') ----- getChildrenSelector ^getChildrenSelector! ----- Method: PluggableTreeMorph>>getChildrenSelector: (in category 'accessing') ----- getChildrenSelector: aSymbol getChildrenSelector := aSymbol.! ----- Method: PluggableTreeMorph>>getHelpSelector (in category 'accessing') ----- getHelpSelector ^getHelpSelector! ----- Method: PluggableTreeMorph>>getHelpSelector: (in category 'accessing') ----- getHelpSelector: aSymbol getHelpSelector := aSymbol! ----- Method: PluggableTreeMorph>>getIconSelector (in category 'accessing') ----- getIconSelector ^getIconSelector! ----- Method: PluggableTreeMorph>>getIconSelector: (in category 'accessing') ----- getIconSelector: aSymbol getIconSelector := aSymbol! ----- Method: PluggableTreeMorph>>getLabelSelector (in category 'accessing') ----- getLabelSelector ^getLabelSelector! ----- Method: PluggableTreeMorph>>getLabelSelector: (in category 'accessing') ----- getLabelSelector: aSymbol getLabelSelector := aSymbol! ----- Method: PluggableTreeMorph>>getMenuSelector (in category 'accessing') ----- getMenuSelector ^getMenuSelector! ----- Method: PluggableTreeMorph>>getMenuSelector: (in category 'accessing') ----- getMenuSelector: aSymbol getMenuSelector := aSymbol! ----- Method: PluggableTreeMorph>>getRootsSelector (in category 'accessing') ----- getRootsSelector ^getRootsSelector! ----- Method: PluggableTreeMorph>>getRootsSelector: (in category 'accessing') ----- getRootsSelector: aSelector getRootsSelector := aSelector. self update: getRootsSelector.! ----- Method: PluggableTreeMorph>>getSelectedPathSelector (in category 'accessing') ----- getSelectedPathSelector ^getSelectedPathSelector! ----- Method: PluggableTreeMorph>>getSelectedPathSelector: (in category 'accessing') ----- getSelectedPathSelector: aSymbol getSelectedPathSelector := aSymbol.! ----- Method: PluggableTreeMorph>>hasChildrenSelector (in category 'accessing') ----- hasChildrenSelector ^hasChildrenSelector! ----- Method: PluggableTreeMorph>>hasChildrenSelector: (in category 'accessing') ----- hasChildrenSelector: aSymbol hasChildrenSelector := aSymbol! ----- Method: PluggableTreeMorph>>hasNodeContents: (in category 'node access') ----- hasNodeContents: node hasChildrenSelector ifNil:[^node contents isEmpty not]. ^model perform: hasChildrenSelector with: node item! ----- Method: PluggableTreeMorph>>iconOfNode: (in category 'node access') ----- iconOfNode: node getIconSelector ifNil:[^nil]. ^model perform: getIconSelector with: node item! ----- Method: PluggableTreeMorph>>isDraggableNode: (in category 'node access') ----- isDraggableNode: node ^true! ----- Method: PluggableTreeMorph>>keystrokeActionSelector (in category 'accessing') ----- keystrokeActionSelector ^keystrokeActionSelector! ----- Method: PluggableTreeMorph>>keystrokeActionSelector: (in category 'accessing') ----- keystrokeActionSelector: aSymbol keystrokeActionSelector := aSymbol! ----- Method: PluggableTreeMorph>>printNode: (in category 'node access') ----- printNode: node getLabelSelector ifNil:[^node item printString]. ^model perform: getLabelSelector with: node item! ----- Method: PluggableTreeMorph>>roots (in category 'accessing') ----- roots ^roots! ----- Method: PluggableTreeMorph>>roots: (in category 'accessing') ----- roots: anArray roots := anArray collect:[:item| PluggableTreeItemNode with: item model: self]. self list: roots.! ----- 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 ! ----- Method: PluggableTreeMorph>>setSelectedMorph: (in category 'selection') ----- setSelectedMorph: aMorph selectedWrapper := aMorph complexContents. self selection: selectedWrapper. setSelectedSelector ifNotNil:[ model perform: setSelectedSelector with: (selectedWrapper ifNotNil:[selectedWrapper item]). ].! ----- Method: PluggableTreeMorph>>setSelectedSelector (in category 'accessing') ----- setSelectedSelector ^setSelectedSelector! ----- Method: PluggableTreeMorph>>setSelectedSelector: (in category 'accessing') ----- setSelectedSelector: aSymbol setSelectedSelector := aSymbol! ----- 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! ----- 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! ----- Method: PluggableTreeMorph>>wantsDropSelector (in category 'accessing') ----- wantsDropSelector ^wantsDropSelector! ----- Method: PluggableTreeMorph>>wantsDropSelector: (in category 'accessing') ----- wantsDropSelector: aSymbol wantsDropSelector := aSymbol! ----- 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.! ----- 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! |
Free forum by Nabble | Edit this page |