Squeak 4.5: ToolBuilder-Morphic-fbs.91.mcz

Previous Topic Next Topic
 
classic Classic list List threaded Threaded
1 message Options
Reply | Threaded
Open this post in threaded view
|

Squeak 4.5: ToolBuilder-Morphic-fbs.91.mcz

commits-2
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!