" DCI program: BB1IDE "

" Exported from Squeak 7179-basic.76.image on: 18 December 2011 by: Trygve "

" Browsers perspective "

" Class BB1ClassBrowser "

AlignmentMorph subclass: #BB1ClassBrowser
    instanceVariableNames: 'model perspName classPane classList classIndex selectedClass superclassPane superclassCollection superclassSelections superclassRefSelection categoryPane categoryNames categorySelections methodsPane methodRefSelection methods sourcePane editSelection metaClassIndicated classCommentIndicated isShowingDecompiled'
    classVariableNames: ''
    poolDictionaries: ''
    category: 'BB1IDE-Browsers'

" BB1ClassBrowser instance methods in category: access "

packageName
    ^ model packageNameForSubApp: perspName

perspName
    ^perspName

perspName: aString
    perspName := aString.

visibleVariables
    | cl vars |
    (cl := self selectedClassOrMetaClass) ifNil: [^Array new].
    vars := cl instVarNames.
    self selectedSuperclasses do:
        [:supRef | vars := vars , supRef refClass instVarNames].
    ^vars asSortedCollection

" BB1ClassBrowser instance methods in category: categoryPane "

buildCategoryPane
    categoryPane := PluggableListMorphOfMany
                        on: self
                        list: #categoryNames
                        primarySelection: nil
                        changePrimarySelection: nil
                        listSelection: #categorySelectionAt:
                        changeListSelection: #categorySelectionAt:put:
                        menu: #categoryPaneMenu:.
    categoryPane font: self listFont.
    ^categoryPane

categoryIndex
    ^0

categoryNames
    ^categoryNames asSortedCollection: [:x :y | x asString < y asString]

categorySelectionAt: index
    ^ self categorySelections at: index

categorySelectionAt: index put: aBool
    (categorySelections at: index) = aBool ifTrue: [^self]. " Nothing new. "
    self okToChange ifFalse: [^self].
    categorySelections at: index put: aBool.
    self refreshMethods.
    self changed: #allSelections.

categorySelections
    categorySelections ifNil: [categorySelections := (Array new: self categoryNames size) atAllPut: true].
    ^ categorySelections

currentCategory
    | ref |
    ^self selectedCategories size = 1
        ifTrue: [self selectedCategories first asString]
        ifFalse:
            [(ref := self methodRefSelection)
                ifNil: ['as yet unclassified']
                ifNotNil: [ref refCategory]].

refreshCategories
    | cl catSels catSet sups txt |
    catSels := self selectedCategories asSet.
    " Find all message categories. "
    catSet := Set new.
    self selectedClass ifNotNil:
        [(cl := self selectedClassOrMetaClass) organization categories do:
            [:cat |
            "catSet remove: cat ifAbsent: []."
            txt := cat asText.
            ((self selectedClassOrMetaClass organization listAtCategoryNamed: cat asString)
                    detect: [:sel | (cl includesLocalSelector: sel)] ifNone: [nil])
                ifNil: [txt allItalics]
                ifNotNil: [txt allBold].
            catSet add: txt]].
    (sups := self selectedSuperclasses) size to: 1 by: -1 do:
        [:ind || ref |
        ref := sups at: ind.
        cl := ref refClass.
        metaClassIndicated ifTrue: [cl := cl class].
        cl organization categories do:
            [:cat |
            catSet remove: cat ifAbsent: [].
            ref isOwn
                ifTrue: [catSet add: cat asText]
                ifFalse: [catSet add: cat asText allItalics]]].
    categoryNames := catSet asSortedCollection: [:x :y | x asString < y asString].
    " Set category selections. "
    categorySelections := (Array new: categoryNames size) atAllPut: false.
    self methodRefSelection
    ifNotNil:
        [catSels add: self methodRefSelection refCategory asString].
    "catSelection := self categoryIndex = 0 ifTrue: [nil] ifFalse: [self categoryNames at: self categoryIndex]."
    1 to: categoryNames size do:
        [:ind | (catSels includes: (categoryNames at: ind) asString) ifTrue: [categorySelections at: ind put: true]].
    "categoryIndex := catSelection ifNil: [0] ifNotNil: [categoryNames indexOf: catSelection]."
    self changed: #categoryNames; changed: #allSelections.
    self refreshMethods.

selectedCategories
    | res |
    res := WriteStream on: (Array new: categoryNames size).
    1 to: categoryNames size do:
        [:ind | (categorySelections at: ind) ifTrue: [res nextPut: (categoryNames at: ind)]].
    ^res contents

" BB1ClassBrowser instance methods in category: categoryPane-menu "

addCategory
    | newName |
    self okToChange ifFalse: [^ self].
    self selectedClass ifNil: [^ self].
    newName := FillInTheBlank request: 'Please type new category name' initialAnswer: self currentCategory.
    newName isEmpty
        ifTrue: [^ self]
        ifFalse: [newName := newName asSymbol].
    self selectedClassOrMetaClass organization addCategory: newName.
    self refreshCategories.

buildMessageCategoryBrowser
    self inform: 'This menu command has not been implemented.'

categorizeAllUncategorizedMethods
    | organizer organizers |
    organizer := self selectedClassOrMetaClass organization.
    organizers := self selectedClassOrMetaClass withAllSuperclasses collect: [:ea | ea organization].
    (organizer listAtCategoryNamed: ClassOrganizer default)
    do: [:sel | | found |
        found := (organizers collect: [ :org | org categoryOfElement: sel])
            detect: [:ea | ea ~= ClassOrganizer default and: [ ea ~= nil]]
            ifNone: [].
        found ifNotNil: [organizer classify: sel under: found]].
    self changed: #categoryNames

categoryPaneMenu: aMenu
    aMenu addList: #(
        -
"        (browse buildMessageCategoryBrowser)
        (printOut printOutMessageCategories)
        (fileOut fileOutMessageCategories)
        - "

        ('select all categories' selectAllCategories)
        ('deselect all categories' deselectAllCategories)
        -
        ('remove empty categories' removeEmptyCategories)
"        ('categorize all uncategorized' categorizeAllUncategorizedMethods)"
        ('new category...' addCategory)
        ('rename category...' renameCategory)
        ('remove category' removeCategory)
    ).
    ^aMenu

deselectAllCategories
    categorySelections := (Array new: categoryNames size) atAllPut: false.
    self refreshMethods.
    self changed: #allSelections.

fileOutMessageCategories
    self inform: 'This menu command has not been implemented.'

printOutMessageCategories
    self inform: 'This menu command has not been implemented.'

removeCategory
    "If a message category is selected, create a Confirmer so the user can
    verify that the currently selected message category should be removed
    from the system. If so, remove it."

    self selectedCategories size = 1
        ifFalse: [self inform: 'Select a single category for this method'. ^nil].
    (self selectedClassOrMetaClass organization listAtCategoryNamed: self currentCategory)
        ifNotEmpty: [^self inform: 'Please remove the methods before you remove the category.
Command ignored.'].
    self okToChange ifFalse: [^ self].
    self selectedClassOrMetaClass organization removeCategory: self currentCategory.
    self refreshCategories.

removeEmptyCategories
    self okToChange ifFalse: [^ self].
    self selectedClassOrMetaClass organization removeEmptyCategories.
    self refreshCategories.

renameCategory
    | cl oldName newName oldSelector |
    (cl := self selectedClass) ifNil: [^self].
    metaClassIndicated ifTrue: [cl := cl class].
    self selectedCategories size = 1 ifFalse: [^self inform: 'I rename one category at the time. Command aborted.'].
    self okToChange ifFalse: [^ self].
    oldName := self selectedCategories first asString asSymbol.
    oldSelector := self selectedMethod.
    newName := FillInTheBlank
        request: 'Please type new category name'
        initialAnswer: oldName.
    newName isEmpty
        ifTrue: [^ self]
        ifFalse: [newName := newName asSymbol].
    newName = oldName ifTrue: [^ self].
    cl organization
        renameCategory: oldName
        toBe: newName.
    self refreshCategories.
    self
        categorySelectionAt: (self categoryNames indexOf: newName)
        put: true.
    oldSelector
    ifNotNil:
        [self methodsIndex: (self methods findFirst: [:ref | ref refSelector = oldSelector])].

selectAllCategories
    categorySelections := (Array new: categoryNames size) atAllPut: true.
    self refreshMethods.
    self changed: #allSelections.

" BB1ClassBrowser instance methods in category: classPane "

buildClassPane
    | morph |
    morph := PluggableListMorph
        on: self
        list: #classList
        selected: #classIndex
        changeSelected: #classIndex:
        menu: #classMenu:shifted:
        keystroke: #classListKey:from:.
    morph font: self listFont.
    classPane ifNotNil: [classPane delete].
    classPane := morph.
    ^classPane.

classIndex
    ^classIndex

classIndex: indx
    classIndex := indx.
    selectedClass := indx = 0
        ifTrue: [nil]
        ifFalse: [Smalltalk at: (classList at: indx) asSymbol ifAbsent: [nil]].
    superclassCollection := nil.
    metaClassIndicated := false.
    categoryNames := Array new.
    categorySelections := Array new.
    methods := Array new.
    methodRefSelection := nil.
    self refreshCategories.
    self
        changed: #classList;
        changed: #superclassCollection;
        changed: #categoryNames;
        changed: #methods;
        changed: #sourceText.

classList
    | classNames |
    classNames := Set new.
    (SystemOrganization categoriesMatching: self packageName , '*') do:
        [:catNam |
        classNames addAll: (SystemOrganization listAtCategoryNamed: catNam asSymbol)].
    ^classList := classNames asSortedCollection

selectedClass
    ^selectedClass

selectedClass: aClass
    | indx |
    (indx := classList indexOf: aClass name) > 0
        ifTrue: [self classIndex: indx].

selectedClassOrMetaClass
    | cl |
    ^self metaClassIndicated
        ifTrue: [(cl := self selectedClass) ifNil: [nil] ifNotNil: [cl classSide]]
        ifFalse: [self selectedClass]

" BB1ClassBrowser instance methods in category: classPane-menu "

arrowKey: aChar from: view
    "backstop; all the PluggableList* classes actually handle arrow keys, and the models handle other keys."
    ^false

browseClassRefs
    | cls |
    cls := self selectedClass.
    (cls notNil and: [cls isTrait not])
        ifTrue: [self systemNavigation browseAllCallsOnClass: cls theNonMetaClass]

browseClassVarRefs
    "1/17/96 sw: devolve responsibility to the class, so that the code that does the real work can be shared"
    | cls |
    cls := self selectedClass.
    (cls notNil and: [cls isTrait not])
        ifTrue: [self systemNavigation browseClassVarRefs: cls]

browseClassVariables
    "Browse the class variables of the selected class. 2/5/96 sw"
    | cls |
    cls := self selectedClass.
    (cls notNil and: [cls isTrait not])
        ifTrue: [self systemNavigation browseClassVariables: cls]

browseInstVarDefs
    | cls |
    cls := self selectedClassOrMetaClass.
    (cls notNil and: [cls isTrait not])
        ifTrue: [self systemNavigation browseInstVarDefs: cls]

browseInstVarRefs
    | cls |
    cls := self selectedClassOrMetaClass.
    (cls notNil and: [cls isTrait not])
        ifTrue: [self systemNavigation browseInstVarRefs: cls]

classListKey: aChar from: view
    "Respond to a Command key. I am a model with a list of classes and a
    code pane, and I also have a listView that has a list of methods. The
    view knows how to get the list and selection."

    | cl |
    (cl := self selectedClassOrMetaClass) ifNil: [^ false].
"    $f == aChar ifTrue: [^ self findMethod].
    $r == aChar ifTrue: [^ self recent].
    $h == aChar ifTrue: [^ self spawnHierarchy]. "

    $x == aChar ifTrue: [^ self removeClass].
    $N == aChar ifTrue: [^ self browseClassRefs].
"    ^self methodsListKey: aChar from: view "
    ^false

classMenu: aMenu shifted: shifted
    ^BB1ClassBrowser classMenu: aMenu shifted: shifted

createInstVarAccessors
    "Create getters and setters for all inst vars defined at the level of the current class selection, except do NOT clobber or override any selectors already understood by the instances of the selected class"
    | aClass newMessage setter |
    (aClass := self selectedClassOrMetaClass) ifNotNil:
        [aClass instVarNames do:
            [:aName |
                (aClass canUnderstand: aName asSymbol)
                    ifFalse:
                        [newMessage := aName, '
    "Answer the value of ', aName, '"

    ^ ', aName.
                        aClass compile: newMessage classified: 'accessing' notifying: nil].
                (aClass canUnderstand: (setter := aName, ':') asSymbol)
                    ifFalse:
                        [newMessage := setter, ' anObject
    "Set the value of ', aName, '"

    ', aName, ' := anObject'.
                        aClass compile: newMessage classified: 'accessing' notifying: nil]]].
    self refreshCategories.
    self
        changed: #classList;
        changed: #superclassCollection;
        changed: #categoryNames;
        changed: #methods;
        changed: #sourceText.

fileOutClass
    | cl |
    (cl := self selectedClass)
        ifNotNil: [Cursor write showWhile: [cl fileOut]]

printOutClass
    "Print a description of the selected class onto a file whose name is the
    category name followed by .html."

    | cl |
    (cl := self selectedClass)
        ifNotNil: [Cursor write showWhile: [cl fileOutAsHtml: true]].

removeClass
    "Remove the selected class from the system, at interactive user request. Make certain the user really wants to do this, since it is not reversible. Answer true if removal actually happened."
    | message className classToRemove result callers |
    self okToChange ifFalse: [^ false].
    classToRemove := self selectedClassOrMetaClass ifNil: [Beeper beep. ^ false].
    classToRemove := classToRemove theNonMetaClass.
    className := classToRemove name.
    (callers := classToRemove allCallsOn)
    ifNotEmpty:
        [self inform: className , ' is in use. Remove references before removing class.'.
        self systemNavigation browseAllCallsOnClass: classToRemove.
        ^false].
    message := 'Are you certain that you
want to REMOVE the class ', className, '
from the system?'.
    (result := self confirm: message)
        ifTrue:
            [classToRemove subclasses size > 0
                ifTrue: [(self confirm: 'class has subclasses: ' , message)
                    ifFalse: [^ false]].
            classToRemove removeFromSystem.
            model changed: #classList.
            self classIndex: 0.
            true].
    ^ result

renameClass
    | oldName newName obs |
    self selectedClassOrMetaClass ifNil: [^ self].
    self okToChange ifFalse: [^ self].
    (self selectedClassOrMetaClass inheritsFrom: BB1Context)
    ifTrue:
        [self notify: 'Renaming contect classes does not work properly because\RoleTraits have the context class name as an attribute. \This rename method should be extended to cater for Context classes.' withCRs].
    oldName := self selectedClassOrMetaClass name.
    " Find local methods referencing old class, ignore users of Traits. "
    obs := (self systemNavigation allCallsOn: (Smalltalk associationAt: oldName))
            select: [:ref | (Smalltalk at: ref classSymbol) includesLocalSelector: ref methodSymbol].
    newName := (FillInTheBlank request: 'Please type new class name' initialAnswer: oldName) asSymbol.
    newName ifEmpty: [^ self].
    newName = oldName
        ifTrue: [^ self].
    (Smalltalk includesKey: newName)
        ifTrue: [^ self error: newName , ' already exists'].
    self selectedClassOrMetaClass rename: newName.
    model changed: #classList.
    self classIndex: (self classList indexOf: newName).
    obs ifNotEmpty:
         [Clipboard clipboardText: newName asString.
        self systemNavigation
                browseMessageList: obs
                name: 'Obsolete References to ' , oldName
                autoSelect: oldName]

" BB1ClassBrowser instance methods in category: methodsPane "

buildMethodsPane
    | morph |
    morph := PluggableListMorph
        on: self
        list: #methods
        selected: #methodsIndex
        changeSelected: #methodsIndex:
        menu: #methodsMenu:shifted:
        keystroke: #methodsListKey:from: .
    morph font: self listFont.
    methodsPane ifNotNil: [methodsPane delete].
    methodsPane := morph.
    ^methodsPane.

methodRefSelection
    ^methodRefSelection

methods
    ^methods

methodsIndex
    ^self methods findFirst: [:ref | ref = methodRefSelection]

methodsIndex: indx
    self okToChange ifFalse: [^self].
    self classCommentIndicated ifTrue: [^self].
    methodRefSelection := indx = 0 ifTrue: [nil] ifFalse: [self methods at: indx].
    self
        changed: #methodsIndex;
        changed: #sourceText.

refreshMethods
    | selOpr res cl selClass selSuperclasses |
    selOpr := self methodRefSelection.
    res := WriteStream
                on: (Array new: superclassCollection size).
    selClass := self metaClassIndicated ifFalse: [self selectedClass] ifTrue: [self selectedClass class].
    selSuperclasses := self metaClassIndicated
            ifFalse: [self selectedSuperclasses]
            ifTrue: [self selectedSuperclasses collect: [:clRef | (BB1ReferenceClass new refClass: clRef refClass class)isEditable: false; isOwn: true; yourself]].
    selClass
    ifNotNil:
        [(Array
                with: ((BB1ReferenceClass new refClass: selClass) isEditable: true; isOwn: true; yourself))
                        , selSuperclasses
                do:
                    [:clRef |
                    cl := clRef refClass.
                    self selectedCategories
                    do:
                        [:cat |
                        (cl organization listAtCategoryNamed: cat asString)
                        do:
                            [:sel |
                            res nextPut: (BB1ReferenceSelector new refClass: cl;
                                             refSelector: sel;
                                             refCategory: cat asString;
                                            isEditable:
                                                (clRef isEditable
                                                and: [cl = (self metaClassIndicated ifTrue: [selectedClass class] ifFalse: [selectedClass])
                                                and: [cl includesLocalSelector: sel]]);
                                             isOwn: (cl includesLocalSelector: sel);
                                             yourself)]]]].
    methods := res contents asSortedCollection:
                        [:x :y |
                        x refSelector = y refSelector
                        ifTrue: [x refClass allSuperclasses size < y refClass allSuperclasses size ]
                        ifFalse: [x refSelector < y refSelector]].
    methodRefSelection := self methods
                detect: [:ref | ref = selOpr]
                ifNone: [].
    self changed: #methods;
         changed: #sourceText.

selectedMethod
    ^methodRefSelection ifNil: [nil] ifNotNil: [methodRefSelection refSelector]

" BB1ClassBrowser instance methods in category: methodsPane-keyboard "

methodsListKey: aChar from: view
    | sel |
    (sel := self selectedMethod) ifNil: [^self].
    $m == aChar ifTrue:
        [^ self systemNavigation browseAllImplementorsOf: sel].
    $n == aChar ifTrue:
        [^ self systemNavigation browseAllCallsOn: sel].
    "The following require a class selection"
    " ---"
    "The following require a method selection"
    sel ifNotNil:
        [$o == aChar ifTrue: [^ self fileOutMessage].
        $c == aChar ifTrue: [^ self copySelector].
        $v == aChar ifTrue: [^ self browseVersions].
        $O == aChar ifTrue: [^ self openSingleMessageBrowser].
        $x == aChar ifTrue: [^ self removeMethod].
        $d == aChar ifTrue: [^ self removeMessageFromBrowser].

        ($C == aChar and: [self canShowMultipleMessageCategories])
            ifTrue: [^ self showHomeCategory]].
    ^ self arrowKey: aChar from: view

" BB1ClassBrowser instance methods in category: methodsPane-menu "

browseClassHierarchy
    self methodRefSelection ifNotNil: [
        self systemNavigation
            spawnHierarchyForClass: self selectedClassOrMetaClass "OK if nil"
            selector: self methodRefSelection refSelector]

browseHierarchy
    self systemNavigation browseHierarchy: self class

browseImplementors
    | refSel compiledMethod |
    (refSel := self methodRefSelection)
        ifNil:
            [self inform: 'Please select a method.\Command ignored.' withCRs.
            ^nil].
    compiledMethod := refSel refClass compiledMethodAt: refSel refSelector.
    self systemNavigation
        showMenuOf: compiledMethod messages
        withFirstItem: refSel refSelector
        ifChosenDo: [:sel | self systemNavigation browseAllImplementorsOf: sel].

browseMessages
    " Present a menu of all messages sent by the currently selected message. "
    " Open a message set browser of all implementors of the message chosen."
    self getSelectorAndSendQuery: #browseAllImplementorsOf: to: self systemNavigation

browseMethodFull
    self methodRefSelection ifNotNil: [
        Browser
            fullOnClass: self selectedClassOrMetaClass
            selector: self methodRefSelection refSelector]

browseSenders
    | compiledMethod refSel |
    (refSel := self methodRefSelection)
        ifNil:
            [self inform: 'Please select a method.\Command ignored.' withCRs.
            ^nil].
    
    compiledMethod := refSel refClass compiledMethodAt: refSel refSelector.
    self systemNavigation
        showMenuOf: compiledMethod messages
        withFirstItem: refSel refSelector
        ifChosenDo: [:sel | self systemNavigation browseAllCallsOn: sel].

browseVersions
    | selector class |
    (selector := self selectedMethod)
    ifNil:
        [self inform: 'Sorry, only actual methods have retrievable versions.'. ^nil ]
    ifNotNil:
        [class := self selectedClassOrMetaClass.
        ^VersionsBrowser
                browseVersionsOf: (class compiledMethodAt: selector)
                class: self selectedClass
                meta: class isMeta
                category: (class organization categoryOfElement: selector)
                selector: selector]

changeCategory
    "Present a menu of the categories of messages for the current class,
    and let the user choose a new category for the current message"

    | aClass aSelector |
    (aClass := self selectedClassOrMetaClass)
    ifNotNil:
        [(aSelector := self selectedMethod)
        ifNotNil:
            [(self letUserReclassify: aSelector in: aClass)
            ifTrue:
                [self refreshMethods]]]

fileOutMethod
    self selectedMethod
    ifNil:
        [self inform: 'Please select a method.
Command ignored.'.
        ^nil]
    ifNotNil:
        [Cursor write showWhile:
            [self selectedClassOrMetaClass fileOutMethod: self selectedMethod]]

methodHierarchy
    self systemNavigation
            methodHierarchyBrowserForClass: self selectedClassOrMetaClass
            selector: self selectedMethod

methodsMenu: aMenu shifted: shifted
    aMenu addList: #(
        -
        ('fileOut'                fileOutMethod)
        ('printOut'                printOutMethod)
        -
        ('senders of... (n)'            browseSenders)
        ('implementors of... (m)'        browseImplementors)
        ('versions (v)'                browseVersions)
        -
        ('change method category' changeCategory)
        ('remove method (x)'            removeMethod)
        -
        ).
    ^ aMenu

printOutMethod
    | textToPrint printer |
    self methodRefSelection ifNil: [^self inform: 'No method selected. Command ignored.'].
    textToPrint := self sourceMethodText.
    textToPrint := (self selectedClassOrMetaClass name asString , '>>') asText allBold , textToPrint.
    textToPrint size == 0 ifTrue: [^self inform: 'nothing to print.'].
    printer := TextPrinter defaultTextPrinter.
    printer documentTitle: self packageName.
    printer printText: textToPrint.

removeMethod
    | method confirmation |
    self selectedClassOrMetaClass isBehavior ifFalse: [^self error: 'No selected class'].
    (method := self selectedMethod) ifNil: [^self].
    self okToChange ifFalse: [^ self].
    confirmation := self systemNavigation confirmRemovalOf: method on: self selectedClassOrMetaClass.
    confirmation = 3 ifTrue: [^ self].
    (self selectedClassOrMetaClass includesLocalSelector: method)
        ifTrue: [self selectedClassOrMetaClass removeSelector: method]
        ifFalse: [self notify: 'Neither role nor superclass methods can be remocved here.'].
    methodRefSelection := nil.
    self refreshCategories.
    self
        changed: #methods;
        changed: #sourceText..
    confirmation = 2
        ifTrue: [self systemNavigation browseAllCallsOn: method].

selectMessageAndEvaluate: aBlock
    " Allow the user to choose one selector, chosen from the currently selected message's selector, "
    " as well as those of all messages sent by it, and evaluate aBlock on behalf of chosen selector. "
    " If there is only one possible choice, simply make it; "
    " if there are multiple choices, put up a menu, and evaluate aBlock on behalf of the the chosen selector, "
    " doing nothing if the user declines to choose any"
    | selector method messages |
    (selector := self selectedMethod) ifNil: [^ self].
    method := (self selectedClassOrMetaClass ifNil: [^ self])
        compiledMethodAt: selector
        ifAbsent: [].
    (method isNil or: [(messages := method messages) size == 0])
         ifTrue: [^ aBlock value: selector].
    (messages size == 1 and: [messages includes: selector])
        ifTrue:
            [^ aBlock value: selector]. "If only one item, there is no choice"
    self systemNavigation
        showMenuOf: messages
        withFirstItem: selector
        ifChosenDo: [:sel | aBlock value: sel]

selectorsMenu: aMenu shifted: shifted
"    ServiceGui browser: self messageListMenu: aMenu.
    ServiceGui onlyServices ifTrue: [^ aMenu].
    shifted
        ifTrue: [^ self shiftedMessageListMenu: aMenu]."

    aMenu addList: #(
"            ('what to show...'            offerWhatToShowMenu)
            ('toggle break on entry'        toggleBreakOnEntry)"

            -
"            ('browse full (b)'             browseMethodFull)
            ('browse hierarchy (h)'            classHierarchy)
            ('browse method (O)'            openSingleMessageBrowser)
            ('browse protocol (p)'            browseFullProtocol)"

            -
            ('fileOut'                fileOutMethod)
            ('printOut'                printOutMethod)
            -
            ('senders of... (n)'            browseSenders)
            ('implementors of... (m)'        browseImplementors)
"            ('inheritance (i)'            methodHierarchy) "
"            ('tile scriptor'            openSyntaxView) "
"            ('versions (v)'                browseVersions) "
            -
"            ('inst var refs...'            browseInstVarRefs)
            ('inst var defs...'            browseInstVarDefs)
            ('class var refs...'            browseClassVarRefs)
            ('class variables'            browseClassVariables)
            ('class refs (N)'            browseClassRefs)"

            -
            ('remove method (x)'            removeMethod)
            -
"            ('more...'                shiftedYellowButtonActivity) "
            ('change category...'                    changeCategory)
        ).
    ^ aMenu

" BB1ClassBrowser instance methods in category: private "

addClassBrowserPanes
    | switchHeight x1Frac x2Frac y1Frac x3Frac |
    x1Frac := 0.25. x2Frac := 0.50. x3Frac := 0.75.
    y1Frac := 0.4.
    switchHeight := 25.
    self
        addMorph: self buildClassPane
        fullFrame: (LayoutFrame
            fractions: (0@0 corner: x1Frac@y1Frac)
            offsets: (0@0 corner: 0@0)).
    self
        addMorph: self buildSuperclassPane
        fullFrame: (LayoutFrame
            fractions: (x1Frac@0 corner: x2Frac@y1Frac)
            offsets: (0@0 corner: 0@switchHeight negated)).
    self
        addMorph: self buildMorphicSwitches
        fullFrame: (LayoutFrame
            fractions: (x1Frac@y1Frac corner: x2Frac@y1Frac)
            offsets: (0@switchHeight negated corner: 0@0)).
    self
        addMorph: self buildCategoryPane
        fullFrame: (LayoutFrame
            fractions: (x2Frac@0 corner: x3Frac@y1Frac)).
    self
        addMorph: self buildMethodsPane
        fullFrame: (LayoutFrame
            fractions: (x3Frac@0 corner: 1@y1Frac)).
    self
        addMorph: self buildSourcePane
        fullFrame: (LayoutFrame
            fractions: (0@y1Frac corner: 1@1)).
    self addPaneSplitters.
    self allChanged.
    ^self

addMorph: aMorph frame: relFrame
    | frame |
    frame _ LayoutFrame new.
    frame
        leftFraction: relFrame left;
        rightFraction: relFrame right;
        topFraction: relFrame top;
        bottomFraction: relFrame bottom.
    self addMorph: aMorph fullFrame: frame.

allChanged
    self
        changed: #classList;
        changed: #superclassCollection;
        changed: #categoryNames;
        changed: #methods;
        changed: #sourceText.

categoryFromUserWithPrompt: aPrompt for: aClass
    "self new categoryFromUserWithPrompt: 'testing' for: SystemDictionary"
    | labels myCategories reject lines cats newName menuIndex |
    labels := OrderedCollection with: 'new...'.
    labels addAll: (myCategories := aClass organization categories asSortedCollection:
        [:a :b | a asLowercase < b asLowercase]).
    reject := myCategories asSet.
    reject
        add: ClassOrganizer nullCategory;
        add: ClassOrganizer default.
    lines := OrderedCollection with: 1 with: (myCategories size + 1).

    aClass allSuperclasses do:
        [:cls |
            cats := cls organization categories reject:
                 [:cat | reject includes: cat].
            cats isEmpty ifFalse:
                [lines add: labels size.
                labels addAll: (cats asSortedCollection:
                    [:a :b | a asLowercase < b asLowercase]).
                reject addAll: cats]].

    newName := (labels size = 1 or:
        [menuIndex := (UIManager default chooseFrom: labels lines: lines title: aPrompt).
        menuIndex = 0 ifTrue: [^ nil].
        menuIndex = 1])
            ifTrue:
                [UIManager default request: 'Please type new category name'
                    initialAnswer: 'category name']
            ifFalse:
                [labels at: menuIndex].
    ^ newName ifNotNil: [newName asSymbol]

codeFont
    "^((TextStyle named: 'BitstreamVeraSans') fontAt: 2). "
    ^BB1IDE textFont

codeFontSmall
    ^((TextStyle named: 'BitstreamVeraSans') fontAt: 2).

compileMethod: aText notifying: sourceEditor
    | method cls selector |
    (cls := self selectedClassOrMetaClass) isBehavior ifFalse: [^self error: 'No selected class'].    
    selector := Compiler parserClass new parseSelector: aText asString.
    ((cls includesSelector: selector) and: [(cls includesLocalSelector: selector) not])
    ifTrue:
        [^self inform: selector asString , ' is a RoleTrait method and can only be changed in the Interaction perspective.
Command ignored.'].
    method := self selectedClassOrMetaClass
                compile: aText
                classified: self currentCategory
                notifying: sourceEditor.
    method
    ifNotNil:
        [methodRefSelection := BB1ReferenceSelector new
                refClass: self selectedClassOrMetaClass ;
                refSelector: method;
                refCategory:
                    (self selectedClassOrMetaClass organization categoryOfElement: method) asString;
                isEditable: true;
                isOwn: true;
                yourself.
        self refreshCategories]
    ifNil:
        [" self error: 'Compilation failure: reselect the original category & method'"]

defaultColor
    "answer the default color/fill style for the receiver"
    ^ Color white

defineClass: defString notifying: sourceEditor
    "The receiver's textual content is a request to define a new class. The
    source code is defString. If any errors occur in compilation, notify
    sourceEditor."

    | oldClass class defTokens keywdIx envt newClassName |
    oldClass := self selectedClassOrMetaClass.
    defTokens := defString findTokens: Character separators.
    keywdIx := defTokens findFirst: [:x | x beginsWith: 'category'].
    envt := Smalltalk.
    keywdIx := defTokens findFirst: [:x | '*subclass*' match: x].
    newClassName := ((defTokens at: keywdIx+1) copyWithoutAll: '#()') asSymbol.
    ((oldClass isNil or: [oldClass theNonMetaClass name ~= newClassName])
        and: [envt includesKey: newClassName])
    ifTrue: ["Attempting to define new class over existing one when
                not looking at the original one in this browser..."

        (self confirm: ((newClassName asString , ' is an existing class in this system.
Redefining it might cause serious problems.
Is this really what you want to do?') asText makeBoldFrom: 1 to: newClassName size))
                ifFalse: [^ false]].
    "ar 8/29/1999: Use oldClass superclass for defining oldClass
    since oldClass superclass knows the definerClass of oldClass."

    oldClass ifNotNil: [oldClass := oldClass superclass].
    class := oldClass subclassDefinerClass
                evaluate: defString
                for: self
                notifying: sourceEditor
                logged: true.
    ^(class isKindOf: Behavior)
    ifTrue: [model changed: #classList.
            self changed: #clearUserEdits.
            self classIndex: (self classList indexOf: class name).
            self refreshCategories.
            true]
    ifFalse: [
            false]

getSelectorAndSendQuery: querySelector to: queryPerformer
    "Obtain a selector relevant to the current context, and then send the querySelector to the queryPerformer with the selector obtained as its argument. If no message is currently selected, then obtain a method name from a user type-in"
    self getSelectorAndSendQuery: querySelector to: queryPerformer with: { }.

getSelectorAndSendQuery: querySelector to: queryPerformer with: queryArgs
    "Obtain a selector relevant to the current context,"
    "and then send the querySelector to the queryPerformer with the
    selector obtained and queryArgs as its arguments."

    "If no message is currently selected, then obtain a method name from a
    user type-in."

    | strm array |
    strm := WriteStream on: (array := Array new: queryArgs size + 1).
    strm nextPut: nil.
    strm nextPutAll: queryArgs.
    self selectedMethod
        ifNil: [| selector |
            selector := UIManager default request: 'Type selector:' initialAnswer: 'flag:'.
            selector := selector copyWithout: Character space.
            ^ selector isEmptyOrNil
                ifFalse: [(Symbol
                            hasInterned: selector
                            ifTrue: [:aSymbol |
                                array at: 1 put: aSymbol.
                                queryPerformer perform: querySelector withArguments: array])
                        ifFalse: [self inform: 'no such selector']]].
    self
        selectMessageAndEvaluate: [:selector |
            array at: 1 put: selector.
            queryPerformer perform: querySelector withArguments: array]

initialize
    super initialize.
    self
        hResizing: #spaceFill;
        vResizing: #spaceFill;
        layoutInset: 1;
        borderWidth: 1;
        layoutPolicy: ProportionalLayout new.
    classList := nil.
    classIndex := 0.
    selectedClass := nil.
    superclassCollection := nil.
    metaClassIndicated := false.
    classCommentIndicated := false.
    categoryNames := Array new.
    categorySelections := Array new.
    methods := Array new.
    methodRefSelection := nil.

isDefiningExistingClass
    ^self isDefiningMethod not
    & self selectedClass notNil

isDefiningMethod
    ^self selectedCategories notEmpty

isDefiningNewClass
    ^self selectedClass isNil

letUserReclassify: anElement in: aClass
    "Put up a list of categories and solicit one from the user.
    Answer true if user indeed made a change, else false"

    | currentCat newCat |
    currentCat := aClass organization categoryOfElement: anElement.
    newCat := self
                categoryFromUserWithPrompt: 'choose category (currently "', currentCat, '")'
                for: aClass.
    (newCat ~~ nil and: [newCat ~= currentCat])
        ifTrue:
            [aClass organization classify: anElement under: newCat suppressIfDefault: false.
            ^ true]
        ifFalse:
            [^ false]

listFont
    "^((TextStyle named: 'BitstreamVeraSans') fontAt: 2). "
    ^BB1IDE listFont

okToChange
    self canDiscardEdits ifTrue: [^ true].
    self changed: #wantToChange. "Solicit cancel from view"
    ^ self canDiscardEdits

printOn: strm
    super printOn: strm.
    strm nextPutAll: ' on <' , perspName , '>'

refresh
    self addClassBrowserPanes.

setModel: browser
    model := browser

symbolTables
    "Symbol tables used for the completion system.
    You might want to subclass it for special StringHolders,
    but it works well most of the time (ie in Browsers, Workspaces and
    Debuggers). Note that returning nothing here is not a problem,
    as the global symbol table will always be used"

    | c |
    c := self selectedClassOrMetaClass.
    ^ c ifNil: [#() ] ifNotNil: [c symbolTables]

" BB1ClassBrowser instance methods in category: private/switches "

buildMorphicSwitches
    | instanceSwitch commentSwitch classSwitch row aColor |
    instanceSwitch := PluggableButtonMorph
        on: self
        getState: #instanceMethodsIndicated
        action: #instanceButtonHit.
    instanceSwitch
        label: 'instance';
        askBeforeChanging: true;
        borderWidth: 1;
        borderColor: Color gray.
        
    commentSwitch := PluggableButtonMorph
        on: self
        getState: #classCommentIndicated
        action: #classCommentButtonHit.
    commentSwitch
        label: '?' asText allBold;
        askBeforeChanging: true;
        setBalloonText: 'class comment';
        borderWidth: 1;
        borderColor: Color gray.
        
    classSwitch := PluggableButtonMorph
        on: self
        getState: #classMethodsIndicated
        action: #classButtonHit.
    classSwitch
        label: 'class';
        askBeforeChanging: true;
        borderWidth: 1;
        borderColor: Color gray.
        
    row := AlignmentMorph newRow
        hResizing: #spaceFill;
        vResizing: #spaceFill;
        cellInset: 1;
        borderWidth: 0;
        addMorphBack: instanceSwitch;
        addMorphBack: commentSwitch;
        addMorphBack: classSwitch.

    aColor := self color.
    row color: aColor muchLighter.
    {instanceSwitch. commentSwitch. classSwitch} do: [:m |
        m
            color: aColor;
            onColor: aColor darker darker offColor: aColor;
            hResizing: #spaceFill;
            vResizing: #spaceFill.].
    ^ row

classButtonHit
    "Indicate that the message selection should come from the metaclass
    messages."

    self metaClassIndicated: true.
    classCommentIndicated := false.
    self refreshCategories.    
    self refreshMethods.
    self changed: #superclassIndex.
    self changed.
"]"
    self
        changed: #superclassCollection;
        changed: #categoryNames;
        changed: #methods;
        changed: #methodSourceText.

classCommentButtonHit
    self okToChange ifFalse: [^self].
    classCommentIndicated := true.
    metaClassIndicated := false.
    categorySelections := (Array new: self categoryNames size) atAllPut: false.
    methodRefSelection := nil.
    self refreshMethods.
    self changed: #allSelections.
    self refreshCategories.    
    self refreshMethods.
    self changed: #superclassIndex.
    self changed.
"]"
    self
        changed: #superclassCollection;
        changed: #categoryNames;
        changed: #methods;
        changed: #methodSourceText.

classCommentIndicated
     ^classCommentIndicated == true

classMethodsIndicated
    "Answer whether the messages to be presented should come from the
    metaclass."

    ^ self metaClassIndicated and: [self classCommentIndicated not]

instanceButtonHit
    "Indicate that the message selection should come from the class (instance) messages."
    self metaClassIndicated: false.
    classCommentIndicated := false.
    self refreshCategories.    
    self refreshMethods.
    self changed: #superclassIndex.
    self changed.
"]"
    self
        changed: #superclassCollection;
        changed: #categoryNames;
        changed: #methods;
        changed: #methodSourceText.

instanceMethodsIndicated
    ^metaClassIndicated not and: [self classCommentIndicated ~= true]

metaClassIndicated
    ^metaClassIndicated == true

metaClassIndicated: trueOrFalse
    "Indicate whether browsing instance or class messages."
    metaClassIndicated := trueOrFalse.
    classCommentIndicated := false.
    methodRefSelection := nil.
    self changed: #classSelectionChanged.
    self changed: #methodCategoryList.
    self changed: #methodList.
    self changed: #contents.
    self changed: #annotation.

" BB1ClassBrowser instance methods in category: sourcePane "

buildSourcePane
    sourcePane := BB1PluggableTextMorph
        on: self
        text: #sourceText
        accept: #sourceText:notifying:
        readSelection: #nullSelection
        menu: #sourceMenu:shifted:.
    sourcePane font: self codeFont.
    sourcePane editString: 'no source'; hasUnacceptedEdits: false.
    "sourcePane borderColor: self borderColor."
    ^sourcePane

methodTemplate
    | source |
    source := ('message selector and argument names'
            , String cr , '" comment stating purpose of message. "'
            , String cr , '    | temporary variable names |'
            , String cr , '    statements' )
                    asText.
    source addAttribute: (TextFontChange fontNumber: 3).
    ^source

nullSelection
    ^ 1 to: 0.

sourceForClassDefinition
    | strm thisClass selSuper clDefString |
    thisClass := self selectedClassOrMetaClass.
    selSuper := self selectedSuperclasses collect: [:ref | ref refClass].
    strm := WriteStream on: String new.
    thisClass allSuperclasses reverseDo:
        [:cl |
        (selSuper includes: cl)
        ifTrue:
            [strm nextPut: $"; tab;
                nextPutAll: cl name;
                space;
                nextPutAll: cl allInstVarNames printString;
                nextPut: $"
; cr]].
    clDefString := thisClass definitionST80
        copyReplaceAll: thisClass name asString
        with: thisClass name.
    ^(Text
        string: strm contents
        attributes: {TextEmphasis italic. TextFontReference toFont: self codeFontSmall. TextColor blue. })
        , clDefString

sourceForNewClassDefinition: superclass
    ^superclass name , ' subclass: #NameOfSubclass
    instanceVariableNames: ''''
    classVariableNames: ''''
    poolDictionaries: ''''
    category: ''' , self packageName , ''''

sourceMethodText
    | cl source |
    self methodRefSelection ifNil: [^self methodTemplate].
    cl := self methodRefSelection refClass.
    source := isShowingDecompiled == true
    ifTrue:
        [(cl compiledMethodAt: self selectedMethod)
                decompile asString asText]
    ifFalse:
        [(cl sourceCodeAt: self methodRefSelection refSelector ifAbsent: ['no source'])
            asString asText makeSelectorBoldSREIn: cl].
    self methodRefSelection isOwn
        ifTrue: [source addAttribute: (TextFontChange fontNumber: 3)]
        ifFalse: [source addAttribute: (TextFontChange fontNumber: 2)].
    self methodRefSelection isEditable ifFalse: [source := source allItalics].
    ^source

sourceText
    | cl |
    self classCommentIndicated
    ifTrue:
        [^(cl := self selectedClass)
            ifNil: ['Class not selected.' asText]
            ifNotNil: [cl hasComment ifTrue: [cl comment] ifFalse: ['No comment']]].
    self isDefiningMethod ifTrue: [^self sourceMethodText].
    self isDefiningExistingClass ifTrue: [^self sourceForClassDefinition].
    self isDefiningNewClass
    ifTrue:
        [^self sourceForNewClassDefinition:
                ((self perspName = #Context)
                    ifTrue: [BB1Context]
                    ifFalse: [Object])].
    self error: 'Shouldn''t be here'.

sourceText: aText notifying: sourceEditor
    | cl |
    self classCommentIndicated
        ifTrue:
            [(cl := self selectedClass)
                ifNotNil: [cl comment: aText].
            ^true].
    self isDefiningMethod
    ifTrue:
        [self compileMethod: aText notifying: sourceEditor]
    ifFalse:
        [self isDefiningNewClass | self isDefiningExistingClass
            ifTrue: [self defineClass: aText asString notifying: sourceEditor]].

" BB1ClassBrowser instance methods in category: sourcePane-menu "

sourceMenu: aMenu shifted: shifted
    | donorMenu |
    donorMenu := shifted
                ifTrue: [ParagraphEditor shiftedYellowButtonMenu]
                ifFalse: [ParagraphEditor yellowButtonMenu].
    aMenu addAllFrom: donorMenu.
    aMenu
        addLine;
        add: 'toggle decompiled code'
                help: 'See how BabyIDE handles role binding at runtime.'
                action: #toggleDecompiledCode.
    ^aMenu

toggleDecompiledCode    
    self okToChange ifFalse: [^self].
    isShowingDecompiled := isShowingDecompiled
        ifNil: [true]
        ifNotNil: [isShowingDecompiled not].
    sourcePane color: (isShowingDecompiled ifTrue: [Color lightRed] ifFalse: [Color transparent]).
    self changed: #sourceText.

" BB1ClassBrowser instance methods in category: superclassPane "

buildSuperclassPane
    superclassPane := PluggableListMorphOfMany
                        on: self
                        list: #superclassCollection
                        primarySelection: #superclassIndex
                        changePrimarySelection: nil
                        listSelection: #superclassSelectionAt:
                        changeListSelection: #superclassSelectionAt:put:
                        menu: #superclassListMenu:.
    superclassPane font: self listFont.
    "superclassPane borderColor: self borderColor."
    ^superclassPane

selectedSuperclasses
    | res |
    res := WriteStream on: (Array new: self superclassCollection size).
    1 to: self superclassCollection size do:
        [:ind | (self superclassSelections at: ind) ifTrue: [res nextPut: (superclassCollection at: ind)]].
    ^res contents

superclassCollection
    | thisClass ref |
    superclassCollection ifNotNil: [ ^ superclassCollection].
    superclassCollection := OrderedCollection new.
    selectedClass ifNil: [
            superclassRefSelection := nil.
            self    changed: #superclassCollection.
            ^ superclassCollection].    
    ref := BB1ReferenceClass new refClass: selectedClass superclass.
    "ref comment: ' #(' , thisClass instanceVariablesString , ') '."
    ref isOwn: true.
    ref isEditable: true.
    superclassCollection addFirst: ref.
    (thisClass := selectedClass superclass)
    ifNotNil:
        [[(thisClass := thisClass superclass) notNil]
        whileTrue:
            [ref := BB1ReferenceClass new refClass: thisClass.
            ref isOwn: false.
            ref isEditable: false.
            superclassCollection addFirst: ref]].
    superclassSelections := (Array new: superclassCollection size) atAllPut: false.
    superclassRefSelection := nil.
    self refreshCategories.
    self    changed: #superclassCollection.
    ^superclassCollection

superclassIndex
    ^self superclassCollection findFirst: [:ref | ref = superclassRefSelection]

superclassSelectionAt: index
    ^ self superclassSelections at: index

superclassSelectionAt: index put: aBool
    " Row at given index shall be multiselected if aBool = true. "
    self okToChange ifFalse: [^self].
    (self superclassSelections at: index) = aBool ifTrue: [^self]. " Noting new, ignore. "
    self superclassSelections at: index put: aBool.
    superclassRefSelection := aBool ifTrue: [superclassCollection at: index] ifFalse: [nil].
    self refreshCategories.
    self
        changed: #superclassIndex;
        changed;
        changed: superclassCollection;
        changed: #categoryNames;
        changed: #operations;
        changed: #sourceText.

superclassSelections
    superclassSelections ifNil: [superclassSelections := (Array new: self superclassCollection size) atAllPut: false].
    ^ superclassSelections

" BB1ClassBrowser instance methods in category: superclassPane-menu "

deselectAllSuperclasses
    self superclassSelections atAllPut: false.
    self refreshCategories.
    self
        changed: #superclassIndex;
        changed;
        changed: superclassCollection;
        changed: #categoryNames;
        changed: #allSelections;
        changed: #methods;
        changed: #methodSourceText.

openSuperclassIde
    | sups |
    (sups := self selectedSuperclasses) size = 1
        ifFalse: [self inform: 'Select a single superclass for this method. Command canceled.'.
            ^ nil].
    model openSuperclassIdeOnClass: sups first refClass.

selectAllSuperclasses
    self superclassSelections atAllPut: true.
    self refreshCategories.
    self
        changed: #superclassIndex;
        changed;
        changed: superclassCollection;
        changed: #categoryNames;
        changed: #methods;
        changed: #methodSourceText.

superclassListMenu: aMenu
    aMenu addList: #(    
        -
"        ('select all superclasses' selectAllSuperclasses)
        ('deselect all superclasses' deselectAllSuperclasses)    
        -
        ('SRE browse class object'
                inspectClassBaby
                        'Open an SRE object browser on the selected class object')
        -
        ('Squeak browse class'        browseClassSqueak
                            'Open a Squeak Browser on the selected class.')
        ('Squeak inspect class'        inspectClassSqueak
                            'Inspect the selected class object in a Squeak Inspector.')
        -    "

        -
        ('spawn IDE on superclass package' openSuperclassIde 'Open a BabyIDE on the package of the selected superclass')
        -
        ('select all'
                selectAllSuperclasses
                        'Select all superclasses.')
        ('deselect all'
                deselectAllSuperclasses
                        'Deselect all superclasses.')
    ).
    ^aMenu
    

"        ('Baby new class instance ...'    classDefineClassInstance
                            'Define a (new) subclass of the selected class and browse some instance of it')"

" BB1ClassBrowser instance methods in category: updating "

clearUserEditFlag
    "Clear the hasUnacceptedEdits flag in all my dependent views."
    self changed: #clearUserEdits

update: aParameter
    super update: aParameter.
    self changed: aParameter.
    aParameter = #classList
    ifTrue:
        [super update: #classList.
        self changed: #classList].

" BB1ClassBrowser class class methods in category: instance creation "

inAColumn: aCollectionOfMorphs
    "Answer a columnar AlignmentMorph holding the given collection"

    | col |
    col _ self newColumn
        color: Color transparent;
        vResizing: #shrinkWrap;
        hResizing: #shrinkWrap;
        layoutInset: 1;
        borderColor: Color black;
        borderWidth: 1;
        wrapCentering: #center;
        cellPositioning: #topCenter.
    aCollectionOfMorphs do: [:each | col addMorphBack: each].
    ^ col

" BB1ClassBrowser class class methods in category: private "

classMenu: aMenu shifted: shifted
    shifted ifTrue: [^ self shiftedClassListMenu: aMenu].
    aMenu addList: #(
        -
        ('printOutClass'                    printOutClass)
        ('fileOutClass'                    fileOutClass)
        -
        ('inst var refs...'            browseInstVarRefs)
        ('inst var defs...'            browseInstVarDefs)
        -
        ('class var refs...'            browseClassVarRefs)
        ('class vars'                    browseClassVariables)
        ('class refs (N)'                browseClassRefs)
        -
        ('rename class ...'            renameClass)
"        ('copy class'                copyClass) "
        ('remove class (x)'            removeClass)
        -
        ('create inst var accessors' createInstVarAccessors)
        
"        ('find method...'                findMethod) "
"        ('find method wildcard...'    findMethodWithWildcard) "
        -
"        ('more...'                    offerShiftedClassListMenu) "
    ).
    ^ aMenu

shiftedClassListMenu: aMenu
    "Set up the menu to apply to the receiver's class list when the shift key is down"
self error: 'Unused menu; needs installation.'.
    ^ aMenu addList: #(
            -
            ('unsent methods'            browseUnusedMethods    'browse all methods defined by this class that have no senders')
            ('unreferenced inst vars'    showUnreferencedInstVars    'show a list of all instance variables that are not referenced in methods')
            ('unreferenced class vars'    showUnreferencedClassVars    'show a list of all class variables that are not referenced in methods')
            ('subclass template'            makeNewSubclass        'put a template into the code pane for defining of a subclass of this class')
            -
            ('sample instance'            makeSampleInstance        'give me a sample instance of this class, if possible')
            ('inspect instances'            inspectInstances            'open an inspector on all the extant instances of this class')
            ('inspect subinstances'        inspectSubInstances        'open an inspector on all the extant instances of this class and of all of its subclasses')
            -
            ('add all meths to current chgs'        addAllMethodsToCurrentChangeSet
                                                                'place all the methods defined by this class into the current change set')
            ('create inst var accessors'    createInstVarAccessors    'compile instance-variable access methods for any instance variables that do not yet have them')
            -
            ('more...'                    offerUnshiftedClassListMenu    'return to the standard class-list menu'))

" Class BB1IDE "

SystemWindow subclass: #BB1IDE
    instanceVariableNames: 'appName classBrowserDict buttonDict flapStrip flapsScrollPane currentBrowser envBrowser dataBrowser contextBrowser scrollBar'
    classVariableNames: 'LastAppName'
    poolDictionaries: ''
    category: 'BB1IDE-Browsers'

" BB1IDE instance methods in category: access "

contextPackageName
    ^self appName , '-Context'

dataPackageName
    ^self appName , '-Data'

interactionPackageName
    ^self appName , '-Roles'

" BB1IDE instance methods in category: printHtml "

htmlCodeListingHeader
    ^
'<html>
<head>
<link rel="stylesheet" type="text/css" TITLE="Tabs" href="/CSS/tabs.css" />
<LINK REL="StyleSheet" HREF="/CSS/fonts.css" TYPE="text/css" MEDIA=screen>
<style>
body { font-family: sans-serif }
p { font-size: 13px; }
H1, H2, H3, H4, H5 {font-family: serif; font-style: italic; color: green; font-weight: bold; line-height: 1.33em; margin: 15px 0 8px}
H1 {font-size: xx-large }
H2 {font-size: x-large }
H3 {font-size: large }
H4 {font-size: medium }
H5 {font-size: small }
ul { font-weight: bolder; }
</style>
</head>
<body>
'

printAppHtml
    | strm appDir appDirName fd initStrm imName |
    appName ifNil: [^self error: 'no application'].
    appDirName := appName.
    fd := FileDirectory default.
    "fd := FileDirectory on: 'C:\webhusetPrivate\Examples\SqueakExamples'."
    (initStrm := WriteStream on: String new)
            nextPutAll: self htmlCodeListingHeader; cr; "nextPutAll: '<br>';" cr;cr.
            "nextPutAll: self htmlMainTabs; cr; nextPutAll: '<br>'; cr;cr. "
    FileDirectory default class splitName: SmalltalkImage current imageName to: [:p :n | imName := n].
    "(headerStrm := WriteStream on: String new)
        nextPutAll: 'DCI program: ' , appName;
        cr; nextPutAll: 'Exported from ' , imName ;
        space ; nextPutAll: 'on: ' , Date dateAndTimeNow first printString , ' by: ' , Utilities authorName. "

    (fd directoryNames includes: appDirName) ifFalse:[fd createDirectory: appDirName].
    appDir := fd directoryNamed: appDirName.
    [strm := appDir fileNamed: appName , '.html'.
    strm cr;
        nextPutAll: initStrm contents; cr;
        nextPutAll: '<H1>';
        nextPutAll: '" DCI program: ' , appName , ' "';
        nextPutAll: '</H1>'; cr;
        nextPutAll: '<H5>';
        nextPutAll: '" Exported from Squeak ' , imName , ' on: ' , Date dateAndTimeNow first printString , ' by: ' , Utilities authorName , ' "';
        nextPutAll: '</H5>'; cr.
    self printAppHtmlOn: strm.
    ] ensure: [strm close].

printAppHtmlOn: strm
    | perspNameSet classNames perspColl classSet |
    perspNameSet := Set new.
    (SystemOrganization categoriesMatching: appName , '-' , '*') do:
        [:cat | perspNameSet add: ((cat copyFrom: self appName size + 2 to: cat size) copyUpTo: $-)].
    perspNameSet remove: 'Roles' ifAbsent: [nil].
    (perspNameSet remove: 'Data'
            ifAbsent: [nil])
            ifNotNil: [self printClassPerspective: 'Data' htmlOn: strm].
    (perspNameSet remove: 'Context'
            ifAbsent: [nil])
            ifNotNil: [self printContextPerspectiveHtmlOn: strm].
    perspColl := OrderedCollection new.
    classSet := Set new.
    perspColl addAll: perspNameSet asSortedCollection.
    perspColl do:
        [:persp |
        (SystemOrganization categoriesMatching: (self packageNameForSubApp: persp) , '*') do:
            [:catNam |
            strm cr;
                nextPutAll: '<H2>';
                nextPutAll: '" ' , persp , ' perspective " ';
                nextPutAll: '</H2>'; cr.
            classNames := Set new.
            classNames addAll: (SystemOrganization listAtCategoryNamed: catNam asSymbol).
            classNames asSortedCollection do:
                [:clNam | (Smalltalk at: clNam) printHtmlOn: strm].
            ]
        ].

printClassPerspective: persp htmlOn: strm
        | classNames |
    (SystemOrganization categoriesMatching: (self packageNameForSubApp: persp) , '*') do:
        [:catNam |
        strm cr;
            nextPutAll: '<H2>';
            nextPutAll: '" ' , persp , ' perspective " ';
            nextPutAll: '</H2>'; cr.
        classNames := Set new.
        classNames addAll: (SystemOrganization listAtCategoryNamed: catNam asSymbol).
        classNames asSortedCollection do:
            [:clNam | (Smalltalk at: clNam) printHtmlOn: strm].    
        ].

printContextClass: ctxClassName htmlOn: strm
    strm cr;
        nextPutAll: '<H3>';
        nextPutAll: '" Context: ' , ctxClassName , ' "';
        nextPutAll: '</H3>'; cr.
    (Smalltalk at: ctxClassName) printHtmlOn: strm.
    self printInteractionDiagramHtmlFor: ctxClassName On: strm.
    self printRoleMethodsHtmlFor: ctxClassName On: strm.
    strm nextPutAll: '<br> ' .

printContextPerspectiveHtmlOn: strm
    | classNames catNames |
    catNames := (SystemOrganization categoriesMatching: (self packageNameForSubApp: 'Context') , '*').
    classNames := (SystemOrganization listAtCategoryNamed: catNames first) select: [:clNam | (Smalltalk at: clNam ifAbsent: [nil]) inheritsFrom: BB1Context].
    classNames ifEmpty:
        [('" No Contexts in this program. " ') asText allBlueItalic printHtmlTextOn: strm.
        ^self
        ].
    strm cr;
        nextPutAll: '<H2>';
        nextPutAll: '" Context perspective " ';
        nextPutAll: '</H2>'.
    classNames do: [:clNam | self printContextClass: clNam htmlOn: strm ].

printInteractionDiagramHtmlFor: ctxName On: strm
    | interactionBrowser diagramFileName localName |
    (Smalltalk at: ctxName) roleNames
    ifEmpty:
        [strm cr;
            nextPutAll: '<H4>';
            nextPutAll: '" This Context has no roles and no role diagram. "';
            nextPutAll: '</H4>'; cr.
        ^self].
    interactionBrowser := classBrowserDict at: #Interaction
                ifAbsent: [self error: 'no interaction browser'].
    interactionBrowser classIndex: (interactionBrowser classList indexOf: ctxName).
    interactionBrowser diagramPane selectRole: nil.
    localName := ctxName , ' diagram.GIF'.
    diagramFileName := strm directory fullNameFor: localName.
    strm directory deleteFileNamed: diagramFileName.
    interactionBrowser diagramPane exportAsGIFToFileNamed: diagramFileName.
    strm nextPutAll: '<img src="' , localName , '" alt="No diagram"/>'.

printRoleMethodsHtmlFor: ctxClassName On: strm
    | runRole roleNames runRoleCl |
    roleNames := (Smalltalk at: ctxClassName) roleNames.
    roleNames asSortedCollection do:
        [:roleName |
        ((runRoleCl := Smalltalk at: (ctxClassName asString , roleName asString) asSymbol ifAbsent: [nil])
            notNil and: [runRoleCl SoleInstance methodDict notEmpty])
        ifTrue:
            [runRole := runRoleCl SoleInstance.
            strm cr;
                nextPutAll: '<H4>';
                nextPutAll: '" Methodful Role ' , roleName , ' "';
                nextPutAll: '</H4>'; cr.
            runRole printMethodsHtmlOn: strm
            ]
        ifFalse:
            [strm cr;
                nextPutAll: '<H4>';
                nextPutAll: '" Methodless Role ' , roleName , ' "';        
                nextPutAll: '</H4>'; cr.
            ]
        ].

" BB1IDE instance methods in category: private "

addMorph: aMorph fullFrame: aLayoutFrame
    | mCol |
    mCol := aMorph color.
    super addMorph: aMorph fullFrame: aLayoutFrame.
    aMorph color: mCol.

appName
    ^appName

appName: aName
    | offsetPoint interactionBrowser |
    appName := aName.
    LastAppName := aName.
    classBrowserDict
        do: [:browser | browser delete].
    classBrowserDict := IdentityDictionary new.
    self subAppNames asSet , #(#Data #Context ) asSet
        do: [:subApp |
            | classBrowser |
            (classBrowser := BB1ClassBrowser new)
                setModel: self;
                perspName: subApp asSymbol.
            self addDependent: classBrowser.
            classBrowser refresh.
            classBrowserDict at: subApp asSymbol put: classBrowser].
    (interactionBrowser := BB1InteractionBrowser new)
        model: self.
    self addDependent: interactionBrowser.
    classBrowserDict at: #Interaction put: interactionBrowser.
    self buildFlapsScrollPane.
    offsetPoint := 0 @ 40.
    self
        addMorph: flapsScrollPane
        fullFrame: (LayoutFrame
                fractions: (0 @ 0 corner: 1 @ 0)
                offsets: (0 @ 0 corner: offsetPoint)).
    classBrowserDict
        do: [:browser | self
                addMorph: browser
                fullFrame: (LayoutFrame
                        fractions: (0 @ 0 corner: 1 @ 1)
                        offsets: (offsetPoint corner: 0 @ 0))].
    interactionBrowser refresh.
    appName
        ifNotEmpty:
            [self setLabel: self appName , ' (babyIDE)'.
            self buttonHit: (buttonDict at: #Interaction)]

documentHeader
    ^
'<html>
<head>
<link rel="stylesheet" type="text/css" TITLE="Tabs" href="/CSS/tabs.css" />
<LINK REL="StyleSheet" HREF="/CSS/fonts.css" TYPE="text/css" MEDIA=screen>
</head>
<body>'

fileOutApp: category on: aFileStream initializing: aBool
    | first poolSet tempClass classes traits |
    traits := self orderedTraitsIn: category.
    classes := self superclassOrder: category.
    poolSet := Set new.
    classes do: [:class | class sharedPools do: [:eachPool | poolSet add: eachPool]].
    poolSet size > 0 ifTrue: [
        tempClass := Class new.
        tempClass shouldFileOutPools ifTrue: [
            poolSet := poolSet select: [:aPool |
                tempClass shouldFileOutPool: (Smalltalk keyAtIdentityValue: aPool)].
            poolSet do: [:aPool | tempClass fileOutPool: aPool onFileStream: aFileStream]]].
    first := true.
    traits , classes , traits do: [:each |
        first
            ifTrue: [first := false]
            ifFalse: [aFileStream cr; nextPut: Character newPage; cr].
        each
            fileOutOn: aFileStream
            moveSource: false
            toFile: 0
            initializing: false].
    aBool ifTrue: [classes do: [:cls | cls fileOutInitializerOn: aFileStream]].

initialize
    super initialize.
    appName := ''.
    classBrowserDict := Dictionary new.
    buttonDict := Dictionary new.
    self color: Color lightGreen. " SystemWindow sets color to white when adding morph!"
    self paneColor: Color lightGreen. " SystemWindow plays havoc with colors if this is not set. "

openSuperclassIdeOnClass: aClass
    | cat app rest persp newIDE |
    cat := (SystemOrganization categoryOfElement: aClass name) asString.
    app := cat copyUpTo: $-.
    rest := cat copyFrom: app size + 2 to: cat size.
    persp := rest copyUpTo: $-.
    newIDE := self class newIDE.
    newIDE appName: app.
    newIDE perspective: persp class: aClass.
    newIDE openSimply.

orderedTraitsIn: packName
    "Answer an OrderedCollection containing references to the traits in the
    categories whose app name is the argument, category (a string). The traits
    are ordered so they can be filed in."

    | titles behaviors traits |
    titles := Set new.
    (SystemOrganization categoriesMatching: self appName , '*')
    do:
        [:cat |
        titles addAll: (SystemOrganization listAtCategoryNamed: cat asSymbol)].
    behaviors := titles collect: [:title | Smalltalk at: title asSymbol].
    traits := behaviors reject: [:each | each isBehavior].
    traits := traits asSortedCollection: [:t1 :t2 |
        (t2 traitComposition allTraits includes: t1)
            or: [(t1 traitComposition allTraits includes: t2) not]].
    ^traits asOrderedCollection

packageNameForSubApp: subApp
    ^subApp = self appName
        ifTrue: [self appName asString]
        ifFalse: [self appName asString , '-' , subApp asString]

perspectiveNames
    | dciArr restSet |
    dciArr := #(Data Context Interaction).
    restSet := classBrowserDict keys asSet.
    dciArr do: [:nam | restSet remove: nam ifAbsent: []].
    ^dciArr , restSet asSortedCollection

refreshPerspectives
    | offsetPoint |
    self subAppNames asSortedCollection
    do:
        [:persp || classBrowser |
        (classBrowserDict includesKey: persp asSymbol)
        ifFalse:
            [(classBrowser := BB1ClassBrowser new) setModel: self;
                 perspName: persp asSymbol.
            self addDependent: classBrowser.
            classBrowser refresh.
            classBrowserDict at: persp asSymbol put: classBrowser.
            self addFlapButton: persp.
            offsetPoint := 0 @ 40.
            self
                addMorph: classBrowser
                fullFrame: (LayoutFrame
                        fractions: (0 @ 0 corner: 1 @ 1)
                        offsets: (offsetPoint corner: 0 @ 0))
            ]
        ].

subAppNames
    | nameSet |
    self appName ifNil: [^Array new].
    nameSet := Set new.
    (SystemOrganization categoriesMatching: self appName , '-' , '*') do:
        [:cat |
        cat size > (self appName size + 1)
            ifTrue: [nameSet add: ((cat copyFrom: self appName size + 2 to: cat size) copyUpTo: $-)]
            ifFalse: [nameSet add: cat]].
    ^nameSet

superclassOrder: packName
    | behaviors classes |
    behaviors := Set new.
    (SystemOrganization categoriesMatching: packName , '*')
    do:
        [:cat |
        behaviors addAll: (SystemOrganization listAtCategoryNamed: cat asSymbol)].
    behaviors := behaviors collect: [:title | Smalltalk at: title asSymbol].
    classes := behaviors select: [:each | each isBehavior].
    ^ChangeSet superclassOrder: classes asArray

" BB1IDE instance methods in category: private-flapsStrip "

addFlapButton: subApp
    | fontset1 button |
    "fontset1 := ((TextStyle named: 'BitstreamVeraSans') fonts
                        detect: [:any | any pointSize = 13] ifNone: [nil])
                    emphasis: 1."

    fontset1 := BB1IDE textFont.
    (button := SimpleButtonMorph new)
        label: subApp asString font: fontset1 emphasis: 1;
        borderWidth: 2;
        borderColor: Color gray;
        color: Color lightGreen;
        target: self;
        actionSelector: #buttonHit: ;
        arguments: (Array with: button).
    buttonDict at: subApp asSymbol put: button.
    flapStrip addMorphBack: button.

buildFlapsScrollPane
    flapStrip notNil ifTrue: [flapStrip delete].
    flapsScrollPane notNil ifTrue: [flapsScrollPane delete].
    buttonDict := IdentityDictionary new.
    flapStrip := AlignmentMorph newRow
        hResizing: #shrinkWrap;
        vResizing: #shrinkWrap;
        cellInset: 1;
        color: Color transparent;
        borderWidth: 0.
    self perspectiveNames do:
        [:subApp | self addFlapButton: subApp].
    (flapsScrollPane := ScrollPane new)
        bounds: (flapStrip bounds expandBy: 10);
        color: Color lightGreen;
        model: self;
        getMenuSelector: #yellowMenu: ;
        hideVScrollBarIndefinitely: true;
        alwaysShowHScrollBar: true.
    flapsScrollPane scroller addMorph: flapStrip.

buttonHit: selButton
    | selBrowser |
    buttonDict values do:
        [:butt |
        butt = selButton
            ifTrue: [butt color: Color green]
            ifFalse: [butt color: Color lightGreen]].
    (selBrowser := classBrowserDict at: selButton label asSymbol ifAbsent: [nil])
    ifNotNil:
        [currentBrowser := selBrowser.
        self addMorphFront: currentBrowser.
        paneMorphs := (submorphs select: [ :pane | paneMorphs includes: pane]) asArray.
        self changed: #selection].

yellowMenu: aMenu
    aMenu addList:
    #(
        -
        ('set application...'    setApp                'Change the app that is handeled in this IDE')
        ('new perspective...'    newPerspective    'Add a new perspective to this app.')
        -
        ('printHtml for this App'        printAppHtml        'Print out HTML all classes and traits for this App')
        ('fileOut this App'        fileOutApp        'File out all classes and traits for this App')                    
    ).
    ^aMenu

" BB1IDE instance methods in category: triggers "

fileOutApp
    | internalStream |
    self appName
        ifEmpty: [^ self].
    internalStream _ WriteStream on: (String new: 1000).
    self fileOutApp: appName on: internalStream initializing: true.
    FileStream writeSourceCodeFrom: internalStream baseName: self appName isSt: true useHtml: false.

newPerspective
    | newName newCategory |
    newName := FillInTheBlank
        request: 'Please type name of the perspective'
        initialAnswer: ''.
    newName size = 0 ifTrue: [^self].
    newCategory := self appName , '-' , newName.
    (SystemOrganization categoriesMatching: newCategory , '*')
        ifNotEmpty: [^self inform: newCategory , ' exists. Command ignored.'].
    SystemOrganization addCategory: newCategory.
    self setLabel: 'BabyIDE1: ' , newCategory.
    self refreshPerspectives.

open
    | projNams |
    projNams := self perspectiveNames.
    appName ifNotEmpty: [self buttonHit: (buttonDict at: projNams first)].
    self openInWorld.

openSimply
    self setLabel: 'BabyIDE1: ' , self appName.
    self openInWorld.

perspective: persp class: aClass
    | perspButton clBrowser |
    (perspButton := buttonDict at: persp asSymbol ifAbsent: [nil])
    ifNotNil:
        [perspButton performAction.
        clBrowser := classBrowserDict at: persp asSymbol.
        clBrowser selectedClass: aClass.
        ].

setApp
    | allDCIApps appMenu appIndx newName |
    allDCIApps :=
        (BB1Context allSubclasses collect:[:ctxCl | (SystemOrganization categoryOfElement: ctxCl name) asString copyUpTo: $-.])
            asSet asSortedCollection.
    appMenu := PopUpMenu labelArray: allDCIApps , (Array with: 'other...').
    appIndx := appMenu startUpCenteredWithCaption: 'Select Application'.
    appIndx = 0 ifTrue: [^nil].
    appIndx > allDCIApps size
    ifTrue:
        [newName := FillInTheBlank
            request: 'Please type name of the application'
            initialAnswer: LastAppName.
            newName size = 0 ifTrue: [^nil]]
    ifFalse:
        [newName := allDCIApps at: appIndx].
    self appName: newName.
    ^self

" BB1IDE class class methods in category: class initialization "

initialize
    " BB1IDE initialize "
    TheWorldMenu unregisterOpenCommand: 'BabyIDE1'.
    TheWorldMenu
        registerOpenCommand:
            {'BabyIDE1...'. {BB1IDE. #open}. 'An IDE supporting the DCI paradigm.'}.
    LastAppName := 'BB2Shapes'.

" BB1IDE class class methods in category: constants "

listFont
    ^((TextStyle named: 'BitstreamVeraSans') fontAt: 4)

smallFont
    ^((TextStyle named: 'BitstreamVeraSans') fontAt: 4)

textFont
    ^((TextStyle named: 'BitstreamVeraSans') fontAt: 4)

" BB1IDE class class methods in category: instance creation "

newIDE
    ^self basicNew initialize

open
    " BB1IDE open. "
    | ide |
    (ide := self basicNew initialize setApp)
        ifNil: [^self]
        ifNotNil: [ide open]

openEmpty
    ^ self basicNew initialize open

openOn: appName
    " BB1IDE openOn: 'BabyShapes4'. "
    ^(self basicNew initialize appName: appName) open

" Class BB1InteractionBrowser "

AlignmentMorph subclass: #BB1InteractionBrowser
    instanceVariableNames: 'model nameSpace contextsPane contextClassNames selectedContextClass diagramPane diagramScroller selectedRole baseContextsPane baseContextsList selectedBaseContextClass methodsPane methods selectedMethod isShowingDecompiled sourcePane'
    classVariableNames: ''
    poolDictionaries: ''
    category: 'BB1IDE-Browsers'

" BB1InteractionBrowser instance methods in category: access "

diagramPane
    ^diagramPane

isEnvironmentRole: aRoleName
    " Return true iff any of its role methods are called from its Context. "
    | runRole |
    runRole := self runtimeRoleForRoleName: aRoleName.
    runRole ifNil: [^false].
    ^runRole methodDict includesKey: #run

model
    ^model

roleTraitForRoleName: roleName
    | thisContextClass traitName trt |
    (thisContextClass := self selectedContextClass) ifNil: [^nil].
    traitName := (thisContextClass name asString , roleName asString) asSymbol.
    trt := Smalltalk
                at: traitName
                ifAbsent: [nil].
    ^trt isTrait
        ifTrue: [trt]
        ifFalse: [nil]

runtimeRoleForRoleName: roleName
    | thisContextClass runtimeRoleName cl |
    (thisContextClass := self selectedContextClass) ifNil: [^nil].
    runtimeRoleName := (thisContextClass name asString , roleName asString) asSymbol.
    cl := Smalltalk at: runtimeRoleName ifAbsent: [nil].
    ^(cl isNil or: [cl isTrait]) ifTrue: [nil] ifFalse: [cl SoleInstance]

setModel: mod
    model := mod.
    self addBrowserPanes.

title
    ^self selectedContextClass name

visibleVariables
    self selectedRoleName ifNil: [Array new].
    ^(self selectedContextClass collaboratorsFor: self selectedRoleName) asSortedCollection

" BB1InteractionBrowser instance methods in category: classPane "

buildClassPane
    | morph |
    morph := PluggableListMorph
        on: self
        list: #classList
        selected: #classIndex
        changeSelected: #classIndex:
        menu: #classMenu:shifted:
        keystroke: #classListKey:from:.
    morph font: self listFont.
    contextsPane ifNotNil: [contextsPane delete].
    contextsPane := morph.
    ^contextsPane.

classIndex
    ^selectedContextClass ifNil: [0] ifNotNil: [contextClassNames indexOf: selectedContextClass name]

classIndex: indx
    selectedContextClass := indx = 0
        ifTrue: [nil]
        ifFalse: [Smalltalk at: (contextClassNames at: indx) asSymbol ifAbsent: [nil]].
    self refreshMethods.
    self
        changed: #contextClass;
        changed: #classIndex;
        changed: #methods;
        changed: #selection.

classList
    | contextNames |
    contextNames := Set new.
    (SystemOrganization categoriesMatching: (model contextPackageName)) do:
        [:catNam |
        contextNames
            addAll:
                ((SystemOrganization listAtCategoryNamed: catNam)
                    select: [:nam | (Smalltalk at: nam) respondsTo: #isDefiningInteraction])].
    ^(contextClassNames := contextNames asSortedCollection)

selectedContextClass
    ^selectedContextClass

" BB1InteractionBrowser instance methods in category: classPane-menu "

arrowKey: aChar from: view
    "backstop; all the PluggableList* classes actually handle arrow keys, and the models handle other keys."
    ^false

browseClassRefs
    | cls |
    cls := self selectedContextClass.
    (cls notNil and: [cls isTrait not])
        ifTrue: [self systemNavigation browseAllCallsOnClass: cls theNonMetaClass]

browseClassVarRefs
    "1/17/96 sw: devolve responsibility to the class, so that the code that does the real work can be shared"
    | cls |
    cls := self selectedContextClass.
    (cls notNil and: [cls isTrait not])
        ifTrue: [self systemNavigation browseClassVarRefs: cls]

browseClassVariables
    "Browse the class variables of the selected class. 2/5/96 sw"
    | cls |
    cls := self selectedContextClass.
    (cls notNil and: [cls isTrait not])
        ifTrue: [self systemNavigation browseClassVariables: cls]

browseInstVarDefs
    | cls |
    cls := self selectedContextClass.
    (cls notNil and: [cls isTrait not])
        ifTrue: [self systemNavigation browseInstVarDefs: cls]

browseInstVarRefs
    "1/26/96 sw: real work moved to class, so it can be shared"
    | cls |
    cls := self selectedContextClass.
    (cls notNil and: [cls isTrait not])
        ifTrue: [self systemNavigation browseInstVarRefs: cls]

classListKey: aChar from: view
    "Respond to a Command key. I am a model with a list of classes and a
    code pane, and I also have a listView that has a list of methods. The
    view knows how to get the list and selection."

    | cl |
    (cl := self selectedContextClass) ifNil: [^ false].
"    $f == aChar ifTrue: [^ self findMethod].
    $r == aChar ifTrue: [^ self recent].
    $h == aChar ifTrue: [^ self spawnHierarchy]. "

    $x == aChar ifTrue: [^ self removeClass].
    $N == aChar ifTrue: [^ self browseClassRefs].
"    ^self methodsListKey: aChar from: view "
    ^false

classMenu: aMenu
    aMenu addList: #(
        -
"        ('fileOut'                    fileOutClass)
        -
        ('inst var refs...'            browseInstVarRefs)
        ('inst var defs...'            browseInstVarDefs)
        -
        ('class var refs...'            browseClassVarRefs)
        ('class vars'                    browseClassVariables)
        ('class refs (N)'                browseClassRefs) "

        -
        ('rename class ...'            renameClass)
"        ('remove class (x)'        removeClass) "
    ).
    self selectedContextClass ifNil: [(aMenu itemWithWording: 'rename class ...') isEnabled: false].
    ^ aMenu

classMenu: aMenu shifted: shifted
    ^BB1ClassBrowser classMenu: aMenu shifted: shifted

fileOutClass
    | cl |
    (cl := self selectedContextClass)
        ifNotNil: [Cursor write showWhile: [cl fileOut]]

removeClass
    "Remove the selected class from the system, at interactive user request. Make certain the user really wants to do this, since it is not reversible. Answer true if removal actually happened."
    | message className classToRemove result callers |
    self okToChange ifFalse: [^ false].
    classToRemove := self selectedContextClass ifNil: [Beeper beep. ^ false].
    className := classToRemove name.
    (callers := classToRemove allCallsOn)
    ifNotEmpty:
        [self inform: className , ' is in use. Remove references before removing class.'.
        self systemNavigation browseAllCallsOnClass: classToRemove.
        ^false].
    message := 'Are you certain that you
want to REMOVE the class ', className, '
from the system?'.
    (result := self confirm: message)
        ifTrue:
            [classToRemove subclasses size > 0
                ifTrue: [(self confirm: 'class has subclasses: ' , message)
                    ifFalse: [^ false]].
            classToRemove removeFromSystem.
            model changed: #classList.
            self classIndex: 0.
            true].
    ^ result

renameClass
    | oldName newName obs |
    self selectedContextClass ifNil: [^ self].
    self okToChange ifFalse: [^ self].
    oldName := self selectedContextClass name.
    " Find local methods referencing old class, ignore users of Traits. "
    obs := (self systemNavigation allCallsOn: (Smalltalk associationAt: oldName))
            select: [:ref | (Smalltalk at: ref classSymbol) includesLocalSelector: ref methodSymbol].
    newName := FillInTheBlank request: 'Please type new class name' initialAnswer: oldName.
    newName = ''
        ifTrue: [^ self].
    newName = oldName
        ifTrue: [^ self].
    (Smalltalk includesKey: newName)
        ifTrue: [^ self error: newName , ' already exists'].
    self selectedContextClass rename: newName.
    model changed: #classList.
    self classIndex: (self classList indexOf: newName).
    obs ifNotEmpty:
         [Clipboard clipboardText: newName asString.
        self systemNavigation
                browseMessageList: obs
                name: 'Obsolete References to ' , oldName
                autoSelect: oldName]

" BB1InteractionBrowser instance methods in category: diagramPane "

addedRole: newRoleName
    | ctx |
    (ctx := self selectedContextClass) ifNil: [^self error: 'context should have been selected here'].
    (ctx respondsTo: newRoleName asSymbol)
    ifFalse:
        [(ctx
            compile:
                (newRoleName
                , '\' , String tab , "'self error: ''binding method undefined.''." '^nil')
                withCRs
            classified: 'role binding'
            notifying: nil)
        ifNil: [^self error: 'Compilation failure'.]].

buildDiagramPane
    (diagramPane := BB1InteractionDiagram new) setModel: self.
    diagramPane extent: 1000@1000.
    self addDependent: diagramPane.
    diagramScroller := ScrollPane new.
    diagramScroller scroller addMorph: diagramPane.
    ^diagramScroller

removedRole: roleName
    | runRole |
    (self selectedContextClass includesLocalSelector: roleName)
        ifTrue: [self selectedContextClass removeSelector: roleName].
    (runRole := self selectedRuntimeRole)
        ifNotNil: [runRole removeFromSystem].
    self refreshMethods.

roleTraitForRole: role
    | cl ctx |
    role ifNil: [^nil].
    (ctx := role contextClass) ifNil: [^nil].
    cl := Smalltalk
        at: (ctx name asString , role name asString) asSymbol
        ifAbsent: [nil].
    cl isTrait ifFalse: [^nil].
    ^cl

selectRole: aRole
    selectedRole := aRole.
    self refreshMethods.

selectedRole
    ^selectedRole

selectedRoleName
    ^selectedRole ifNil: [nil] ifNotNil: [selectedRole name]

selectedRoleTrait
    | role |
    (role := self selectedRole) ifNil: [^nil].
    ^self roleTraitForRoleName: role name

selectedRuntimeRole
    | role |
    (role := self selectedRole) ifNil: [^nil].
    ^self runtimeRoleForRoleName: role name

" BB1InteractionBrowser instance methods in category: methodsPane "

buildMethodsPane
    | morph |
    morph := PluggableListMorph
        on: self
        list: #methods
        selected: #methodsIndex
        changeSelected: #methodsIndex:
        menu: #methodsMenu:shifted:.
    morph
        font: self listFont ;
        color: Color lightBlue..
    methodsPane ifNotNil: [methodsPane delete].
    methodsPane := morph.
    ^methodsPane

methods
    ^methods

methodsIndex
    ^self methods findFirst: [:ref | ref = selectedMethod]

methodsIndex: indx
    self okToChange ifFalse: [^self].
    selectedMethod := indx = 0 ifTrue: [nil] ifFalse: [self methods at: indx].
    self changed: #methodsIndex; changed: #sourceText.

refreshMethods
    | selOpr runRole |
    selOpr := selectedMethod.
    methods := (runRole := self selectedRuntimeRole)
        ifNotNil: [runRole methodDict keys asSortedCollection]
        ifNil: [Array new].
    selectedMethod := methods
        detect: [:sel | sel = selOpr]
        ifNone: [methods ifEmpty: [nil] ifNotEmpty: [methods first]].
    self
        changed: #methods;
        changed: #sourceText.

selectedMethod
    ^selectedMethod

" BB1InteractionBrowser instance methods in category: methodsPane-menu "

browseImplementors
    | selector compiledMethod |
    (selector := self selectedMethod)
        ifNil:
            [self inform: 'Please select a method.\Command ignored.' withCRs.
            ^nil].
    compiledMethod := self selectedRuntimeRole compiledMethodAt: selector.
    self systemNavigation
        showMenuOf: compiledMethod messages
        withFirstItem: selector
        ifChosenDo: [:sel | self systemNavigation browseAllImplementorsOf: sel].

browseSenders
    | selector compiledMethod |
    (selector := self selectedMethod)
        ifNil:
            [self inform: 'Please select a method.\Command ignored.' withCRs.
            ^nil].
    compiledMethod := self selectedRuntimeRole compiledMethodAt: selector.
    self systemNavigation
        showMenuOf: compiledMethod messages
        withFirstItem: selector
        ifChosenDo: [:sel | self systemNavigation browseAllCallsOn: sel].

browseVersions
    | selector class |
    (selector := self selectedMethod)
    ifNil:
        [self inform: 'Sorry, only actual methods have retrievable versions.'. ^nil ]
    ifNotNil:
        [class := self selectedRuntimeRole .
        ^VersionsBrowser
                browseVersionsOf: (class compiledMethodAt: selector)
                class: self selectedRuntimeRole
                meta: false
                category: (class organization categoryOfElement: selector)
                selector: selector]

fileOutMethod
    self selectedMethod
        ifNil:
            [self inform: 'Please select a method.\Command ignored.' withCRs.
            ^nil].
    Cursor write showWhile:
        [self selectedRuntimeRole fileOutMethod: self selectedMethod]

methodsMenu: aMenu shifted: shifted
    aMenu addList: #(
        -
        ('fileOut'                fileOutMethod)
        ('printOut'                printOutMethod)
        -
        ('senders of... (n)'            browseSenders)
        ('implementors of... (m)'        browseImplementors)
        ('versions (v)'                browseVersions)
        -
        ('remove method (x)'            removeMethod)
        -
        ).
    ^ aMenu

printOutMethod
    | textToPrint printer |
    self selectedRuntimeRole ifNil: [^self inform: 'No method selected. Command ignored.'].
    textToPrint := self sourceText.
    textToPrint := (self selectedRuntimeRole name asString , '>>') asText allBold , textToPrint.
    textToPrint size == 0 ifTrue: [^self inform: 'nothing to print.'].
    printer := TextPrinter defaultTextPrinter.
    printer documentTitle: self selectedRuntimeRole basicCategory.
    printer printText: textToPrint.

removeMethod
    "If a message is selected, create a Confirmer so the user can verify that
    the currently selected message should be removed from the system. If
    so,
    remove it. If the Preference 'confirmMethodRemoves' is set to false, the
    confirmer is bypassed."

    | selector trait confirmation |
    self okToChange ifFalse: [^ self].
    (selector := self selectedMethod) ifNil: [^self].
    (trait := self selectedRuntimeRole) ifNil: [^self].
    confirmation := self systemNavigation confirmRemovalOf: selector on: trait.
    confirmation == 3 ifTrue: [^ self].
    (trait includesLocalSelector: selector)
        ifTrue: [trait removeSelector: selector].
    selectedMethod := nil.
    self refreshMethods.
    "In case organization not cached"
    confirmation == 2
        ifTrue: [SystemNavigation default browseAllCallsOn: selector].
    trait allSelectors ifEmpty: [trait removeFromSystem].

" BB1InteractionBrowser instance methods in category: private "

addBrowserPanes
    self
        addMorph: self buildClassPane
        fullFrame: (LayoutFrame fractions: (0@0 corner: 0.2@0.4)).
    self
        addMorph: self buildMethodsPane
        fullFrame: (LayoutFrame fractions: (0@0.4 corner: 0.2@1)).         
    self
        addMorph: self buildDiagramPane
        fullFrame: (LayoutFrame fractions: (0.2@0 corner: 1@0.5)).
    self
        addMorph: self buildSourcePane
        fullFrame: (LayoutFrame fractions: (0.2@0.5 corner: 1@1)).
    self addPaneSplitters.
    ^self

clearUserEditFlag
    "Clear the hasUnacceptedEdits flag in all my dependent views."
    self changed: #clearUserEdits

codeFont
    ^((TextStyle named: 'BitstreamVeraSans') fontAt: 4).

contextPackageName
    ^model contextPackageName

dataPackageName
    ^model dataPackageName

initialize
    super initialize.
    self
        hResizing: #spaceFill;
        vResizing: #spaceFill;
        layoutInset: 1;
        borderWidth: 1;
        layoutPolicy: ProportionalLayout new;
        borderWidth: 1;
        color: Color lightBlue.
    methods := Array new.
    selectedMethod := nil.
    baseContextsList := nil.

listFont
    "^((TextStyle named: 'BitstreamVeraSans') fontAt: 2). "
    ^BB1IDE listFont

model: mod
    model := mod.
    self addBrowserPanes.
    ^self

nullSelection
    ^ 1 to: 0.

okToChange
    self canDiscardEdits ifTrue: [^ true].
    self changed: #wantToChange. "Solicit cancel from view"
    ^ self canDiscardEdits

packageNameForSubApp: subApp
    ^model packageNameForSubApp: subApp

refresh
    self changed: #classList.

update: aParameter
    super update: aParameter.
    self changed: aParameter.
    aParameter == #methods ifTrue: [self refreshMethods]

" BB1InteractionBrowser instance methods in category: sourcePane "

buildSourcePane
    sourcePane := BB1PluggableTextMorph
        on: self
        text: #sourceText
        accept: #sourceText:notifying:
        readSelection: #nullSelection
        menu: #sourceMenu:shifted: .
    sourcePane
        font: self codeFont;
        color: Color lightBlue;
        editString: 'no source'; hasUnacceptedEdits: false.
    "sourcePane borderColor: self borderColor."
    ^sourcePane

ensureRoleClassFromRoleName: roleName notifying: sourceEditor
    | className roleClass strm source |
    className := (self selectedContextClass name asString , roleName asString) asSymbol.
    roleClass := Smalltalk at: className ifAbsent: [nil].
    roleClass isTrait ifTrue: [roleClass removeFromSystem. roleClass := nil].
    roleClass ifNil: [
        strm := WriteStream on: String new.
        strm
            nextPutAll: 'BB1RuntimeRole subclass: #';
            nextPutAll: className;
            cr; tab; nextPutAll: 'instanceVariableNames: '''' ';
            cr; tab; nextPutAll: 'classVariableNames: '''' ';
            cr; tab; nextPutAll: 'poolDictionaries: '''' ';
            cr; tab; nextPutAll: 'category: ''', model interactionPackageName asString , ''' '.
        source := strm contents.
        roleClass := BB1RuntimeRole subclassDefinerClass
                evaluate: source
                for: self
                notifying: sourceEditor
                logged: true.
        roleClass SoleInstance:
            (roleClass basicNew roleContextClassName: self selectedContextClass name asSymbol).
        ].
    ^roleClass

methodTemplate
    | source |
    source := ('message selector and argument names'
            , String cr , '" comment stating purpose of message. "'
            , String cr , '    | temporary variable names |'
            , String cr , '    statements' )
                    asText.
    source addAttribute: (TextFontChange fontNumber: 3).
    ^source

sourceText
    | contxt selector source runRole |
    (contxt := self selectedContextClass)
        ifNil: [^ 'No context selected. Select or define context class before roles.'].
    contxt roleNames ifEmpty: [^'No roles defined.'].
    self selectedRole ifNil: [^'No role selected.'].
    (selector := self selectedMethod)
        ifNil: [^ self methodTemplate].
    runRole := self selectedRuntimeRole ifNil: [^ 'No runtime role.'].
    source := isShowingDecompiled == true
        ifTrue:
            [(runRole compiledMethodAt: self selectedMethod)
                decompile]
        ifFalse:
            [runRole
                ultimateSourceCodeAt: selector
                ifAbsent: [self error.
                    ^ 'error']].
    ^ source asString asText makeSelectorBoldSREIn: runRole class

sourceText: aText notifying: sourceEditor
    | roleClass newSelector |
    self selectedRole
        ifNil: [self notify: 'Select a role (old or new) in the diagram' , String cr , 'before attempting to compile a mehod.'.
            ^ self].
    roleClass := self ensureRoleClassFromRoleName: self selectedRole name notifying: sourceEditor.
    newSelector := roleClass compile: aText classified: 'role methods' notifying: sourceEditor.
    newSelector
        ifNil: [^ self].
    newSelector ~= self selectedMethod
        ifTrue: [selectedMethod := newSelector.
            self refreshMethods].
    self changed: #sourceText.

symbolTables
    "Symbol tables used for the completion system.
    You might want to subclass it for special StringHolders,
    but it works well most of the time (ie in Browsers, Workspaces and
    Debuggers). Note that returning nothing here is not a problem,
    as the global symbol table will always be used"

    | rR |
    rR := self selectedRuntimeRole.
    ^ rR ifNil: [#() ] ifNotNil: [rR class symbolTables]

" BB1InteractionBrowser instance methods in category: sourcePane-menu "

sourceMenu: aMenu shifted: shifted
    aMenu addList: #(
                #-
                #('find...(f)' #find)
                #('find again (g)' #findAgain)
                #('set search string (h)' #setSearchString)
                #-
                #('do again (j)' #again)
                #('undo (z)' #undo)
                #- #('copy (c)' #copySelection)
                #('cut (x)' #cut)
                #('paste (v)' #paste)
                #('paste...' #pasteRecent)
                #-
                #('do it (d)' #doIt)
                #('print it (p)' #printIt)
                #('inspect it (i)' #inspectIt)
                #('explore it (I)' #exploreIt)
                #- #('accept (s)' #accept)
                #('cancel (l)' #cancel)
                #-
                #('toggle decompiled code' #toggleDecompiledCode 'See how BabyIDE handles role binding at runtime.')
                #-
                #- ).
    ^ aMenu

toggleDecompiledCode    
    self okToChange ifFalse: [^self].
    isShowingDecompiled := isShowingDecompiled
        ifNil: [true]
        ifNotNil: [isShowingDecompiled not].
    sourcePane color: (isShowingDecompiled ifTrue: [Color lightRed] ifFalse: [Color lightBlue]).
    self changed: #sourceText.

" Class BB1InteractionDiagram "

PasteUpMorph subclass: #BB1InteractionDiagram
    instanceVariableNames: 'nameMorph contextClass roles links'
    classVariableNames: ''
    poolDictionaries: ''
    category: 'BB1IDE-Browsers'

" BB1InteractionDiagram instance methods in category: access "

contextClass
    ^contextClass

diagramExists
    ^(self submorphs select: [:ea | ea visible]) notEmpty

exportAsGIFToFileNamed: aFileName
    " 2011.10.18-PrintBabyIDE diagram -TRee "
    | printBounds canvasForm imName |
    self hasSubmorphs ifFalse: [^self].
    FileDirectory default class
        splitName: SmalltalkImage current imageName
        to: [:p :n | imName := n].
    printBounds := self printBounds.
    canvasForm := FormCanvas extent: printBounds extent depth: 8.
    canvasForm
        setOrigin: printBounds origin negated "+ (25@25)"
        clipRect: (0@0 extent: printBounds extent).
    canvasForm fillColor: Color white.
    self printableShapes reverseDo: [:ea | ea fullDrawOn: canvasForm].
    GIFReadWriter putForm: canvasForm form onFileNamed: aFileName.

roleAtGlobal: globalPt
    | localPt roleColl |
    localPt := self globalPointToLocal: globalPt.
    roleColl := roles select: [:r | r bounds containsPoint: localPt].
    roleColl size = 0 ifTrue: [^nil].
    roleColl size > 1 ifTrue: [self error: 'Overlapping target roles?'].
    ^roleColl anyOne name

" BB1InteractionDiagram instance methods in category: links "

addLinkFrom: role1
    | newLink pt role2 w |
    newLink := BB1InteractionLink new
                diagram: self;
                fromRole: role1 toRole: role1;
                yourself.
    self addMorphFront: newLink.
    [Sensor noButtonPressed]
    whileTrue: [
        pt := self globalPointToLocal: Sensor mousePoint.
        (role2 := roles detect: [:r | r bounds containsPoint: pt] ifNone: [nil]).
        role2 ifNotNil: [
            newLink fromRole: role1 toRole: role2.
            self addMorphFront: newLink.
            (w := self world) ifNotNil: [w doOneCycle]]].
    role2
    ifNotNil: [
        links add: newLink.
        self storeStructure ]
    ifNil: [newLink delete].

handlesMouseDown: evt
    ^true

handlesMouseStillDown: evt
    ^true

refreshLinks
    | struct fromRoles toRoles newLink role1 role2 breakpoints attachPoint1 attachPoint2 points |
    struct := self selectedContextClass ifNil: [Dictionary new] ifNotNil: [self selectedContextClass roleStructure].
    breakpoints := self selectedContextClass ifNil: [Dictionary new] ifNotNil: [self selectedContextClass linkBreakPoints].
    links copy do: [:link | link delete].
    links := Set new.
    struct keysDo:
        [:fromName |
        (fromRoles := roles select: [:role | role name = fromName]) size = 1 ifFalse: [self error].
        role1 := fromRoles asArray first.
        (struct at: fromName) do:
            [:toName |
            (toRoles := roles select: [:role | role name = toName]) size = 1 ifFalse: [self error].
            role2 := toRoles asArray first.
            (links select: [:link | link isFromRole: role1 toRole: role2]) isEmpty
            ifTrue:
                [newLink := BB1InteractionLink new
                    diagram: self;
                    fromRole: role1 toRole: role2;
                    yourself.
                points := OrderedCollection with: role1 center.
                (breakpoints at: (role1 name , '_' , role2 name) asSymbol ifAbsent: [#()])
                    do: [:pt | points addLast: pt].
                points addLast: (role2 center).
                attachPoint1 := role1 attachPointFrom: (points at: 2).
                attachPoint2 := role2 attachPointFrom: (points at: points size - 1).
                points at: 1 put: attachPoint1.
                points at: points size put: attachPoint2.
                newLink setVertices: (points collect: [:pt | pt roundTo: 5@5]).
                links add: newLink.
                self addMorphFront: newLink]]]

removeLinkFromView: aLink
    links remove: aLink ifAbsent: [].
    aLink delete.

role: aRole isMovingThrough: aPoint
    links do:
        [:link |
            (link fromRole = aRole or: [link toRole = aRole])
            ifTrue:
                [link refresh]].

" BB1InteractionDiagram instance methods in category: private "

contextPackageName
    ^model contextPackageName

dataPackageName
    ^model dataPackageName

exportAsGIF
    | fileName |
    fileName _ FileDirectory default
        nextNameFor: self title extension: 'GIF'.
    fileName _ FillInTheBlank request: 'GIF file name?' initialAnswer: fileName.
    fileName isEmpty ifTrue: [^self].
    self exportAsGIFToFileNamed: fileName

exportAsGIFToFile: aFileName
    | printBounds canvasForm innerBounds |
    
    innerBounds := self printBounds.
    printBounds := innerBounds outsetBy: (25@50).
    canvasForm := FormCanvas extent: printBounds extent depth: 8.
    canvasForm
        setOrigin: printBounds origin negated "+ (25@25)"
        clipRect: (0@0 extent: printBounds extent).
    canvasForm fillColor: Color white.
    self printableShapes reverseDo: [:ea | ea fullDrawOn: canvasForm].
    GIFReadWriter putForm: canvasForm form onFileNamed: aFileName.

initialize
    super initialize.
    self
        borderWidth: 0;
        color: Color lightBlue;
        borderColor: Color black;
        gridSpecPut: (0@0 corner: 5@5).
    roles := Set new.
    links := Set new.
    griddingOn := true.

packageNameForSubApp: subApp
    ^model packageNameForSubApp: subApp

printBounds
    | printBounds printableShapes |
    printableShapes := self submorphs select: [:ea | ea visible].
    printBounds := printableShapes first bounds.
    printableShapes do: [:ea | printBounds := printBounds merge: ea bounds].
    ^printBounds "outsetBy: 50".

printableShapes
    ^self submorphs select: [:ea | ea visible].

selectedContextClass
    ^model selectedContextClass

storeAll
    self storeRolePositions.
    self storeStructure.
    self storeLinkBreakpoints.

storeLinkBreakpoints
    "Store link intermediate points as a method in the contect metaclass."
    | strm cl |
    (cl := model selectedContextClass)
        ifNil: [^ self].
    strm := WriteStream on: String new.
    strm nextPutAll: 'linkBreakPoints';
         cr;
         tab;
         nextPutAll: '| dict |';
         cr;
         tab;
         nextPutAll: '(dict := Dictionary new)'.
    links
        do: [:link | link storeBreakpointsOn: strm].
    strm cr; tab; tab; nextPutAll: 'yourself.'; cr; tab; nextPutAll: '^dict.'.
    cl class
        compile: strm contents
        classified: 'context diagram'
        notifying: nil.

storeRolePositions
    "Store role positions as a method in the contect metaclass."
    | methStrm cl |
    (cl := model selectedContextClass)
        ifNil: [^ self].
    methStrm := WriteStream on: String new.
    methStrm nextPutAll: 'rolePositions';
         cr;
         tab;
         nextPutAll: '| dict |';
         cr;
         tab;
         nextPutAll: '(dict := Dictionary new)'.
    roles
        do: [:role | methStrm cr; tab; tab; nextPutAll: 'at: #' , role name , ' put: ' , role position printString , ';'].
    methStrm cr; tab; tab; nextPutAll: 'yourself.'; cr; tab; nextPutAll: '^dict.'.
    cl class compile: methStrm contents
        classified: 'context diagram'
        notifying: nil.

storeStructure
    | strm cl |
    (cl := model selectedContextClass)
        ifNil: [^ self].
    strm := WriteStream on: String new.
    strm nextPutAll: 'roleStructure';
         cr;
         tab;
         nextPutAll: '^super roleStructure'.
    roles
        do: [:r |
            strm cr; tab; nextPutAll: 'at: '; nextPutAll: r name asSymbol storeString; nextPutAll: ' put: #('.
            links
                do: [:link | link fromRole = r
                        ifTrue: [strm nextPutAll: link toRole name asSymbol storeString;
                                 space]].
            strm nextPutAll: ');'].
    strm cr; tab; tab; nextPutAll: 'yourself.'.
    cl class
        compile: strm contents
        classified: 'role structure'
        notifying: nil

title
    ^model title

" BB1InteractionDiagram instance methods in category: roles "

addRole
    | newName newRole |
    newName := FillInTheBlank request: 'Please type name of new role' initialAnswer: ''.
    newName size = 0 ifTrue: [^self].
    (roles detect: [:r | r name = newName] ifNone: [nil])
        ifNotNil: [self notify: 'Role named ' , newName , ' is already in this context..
Command ignored.'.
            ^self].
     newName first isLowercase
    ifTrue: [
        self notify: 'Role names should start with capital letter.
I will fix it if you proceed.'.
        newName at: 1 put: newName first asUppercase].
    newRole := BB1InteractionRole new.
    newRole diagram: self; name: newName.
    newRole openInHand.
    [ newRole owner isKindOf: self class ] whileFalse: [ World doOneCycle ].
    roles add: newRole.    
    self addDependent: newRole.
    self storeAll.
    model addedRole: newName.
    self selectRole: self.
    ^newRole

addRoleNamed: rNam atGlobal: globalPt
    | newRole |
    (newRole := BB1InteractionRole new)
        diagram: self;
        name: rNam;
        basicPosition: (self globalPointToLocal: globalPt).
    self addMorphFront: newRole.
    roles add: newRole.    
    self addDependent: newRole.
    self storeAll.
    model addedRole: rNam.
    self selectRole: self.
    ^newRole

deleteRoleFromView: aRole
    roles remove: aRole ifAbsent: [].    
    links copy do:
        [:link |
            (link fromRole = aRole or: [link toRole = aRole])
            ifTrue:
                [links remove: link.
                link delete]].

refreshRoles
    | position newRole positionDict existingRoles |
    position := self bounds origin + (50@50).
    roles copy do: [:role | role delete].
    roles := Set new.
    self selectedContextClass
    ifNotNil:
        [positionDict := self selectedContextClass rolePositions.
        model selectedContextClass roleNames asSortedCollection do:
            [:rNam |
            existingRoles := roles select: [:role | role name = rNam].
            existingRoles isEmpty
            ifTrue:
                [newRole := BB1InteractionRole new.
                newRole diagram: self; name: rNam.
                roles add: newRole.
                newRole basicPosition: (positionDict at: rNam ifAbsent: [position := position + (50@50)])]
            ifFalse:
                [newRole := existingRoles first.
                newRole update].    
            self addMorphFront: newRole]].

selectRole: aRole
    model okToChange ifFalse: [^false].
    model selectedRole = aRole name ifTrue: [^self].
    model selectRole: aRole.
    self changed: #selection.

selectedRoleName
    ^model selectedRoleName

" BB1InteractionDiagram instance methods in category: triggers "

browseRoleBindingMethods
    | ctxClass newBrowser catInd |
    (ctxClass := self selectedContextClass) ifNil: [^self].
    newBrowser := Browser new.
    newBrowser systemCategoryListIndex: (catInd := SystemOrganization categories indexOf: ctxClass category).
    newBrowser classListIndex: ((SystemOrganization listAtCategoryNumber: catInd) indexOf: ctxClass name).
    newBrowser metaClassIndicated: false.
    newBrowser messageCategoryListIndex: (newBrowser messageCategoryList indexOf: 'role binding').
    newBrowser messageListIndex: 0.
    Browser openBrowserView: (newBrowser openMessageCatEditString: nil)
                label: 'Message Category Browser (' ,
                        newBrowser selectedClassOrMetaClassName , ')'

mouseDown: evt
    super mouseDown: evt.
    model ifNil: [^#rejected].
    evt yellowButtonPressed
    ifTrue:
        [^self yellowButtonActivity: evt].
    (evt redButtonPressed and: [self bounds containsPoint: evt cursorPoint])
    ifTrue:
        ["model annotations: (object class comment copyUpTo: Character cr)."
        evt hand waitForClicksOrDrag: self event: evt].

refresh
    submorphs copy
        do: [:sub | sub delete].
    contextClass := model selectedContextClass.
    self refreshRoles.
    self refreshLinks.

update: aParameter
    super update: aParameter.
    aParameter == #contextClass
        ifTrue: [self refresh].
    aParameter == #selection
        ifTrue: [self changed: #selection]

yellowButtonActivity: shiftKeyState
    | aMenu |
    aMenu := MenuMorph new defaultTarget: self.
    aMenu addTitle: self printString.
    aMenu addList: #(
        ('add role' #addRole 'Add a new role in this context')
        -
        ('role binding methods' #browseRoleBindingMethods 'Sortcut to the role binding methods in the current context.')
"        -
        ( 'refresh' #refresh)
        ('save positions' #storeAll)"

"        -
        ('explore diagram' #explore) "

        ('export diagram as GIF' #exportAsGIF 'Store this diagram as a GIF picture.' )
        ).
    (aMenu itemWithWording: 'add role') isEnabled: (model selectedContextClass notNil).
"    (aMenu itemWithWording: 'refresh') isEnabled: (model selectedContextClass notNil).
    (aMenu itemWithWording: 'save positions') isEnabled: (model selectedContextClass notNil). "

    (aMenu itemWithWording: 'export diagram as GIF') isEnabled: (model selectedContextClass notNil).
"    (Smalltalk includesKey: #CInspectorSRE)
    ifTrue:
        [aMenu addList: #(- ('Baby inspect' #objectInspectSRE))]."

"    (Smalltalk includesKey: #ACollaboratorToolSRE)
    ifTrue:
        [aMenu addList: #(('Baby collaboration' #openSREcollaboration))]."

    aMenu popUpInWorld.

" Class BB1InteractionLink "

PolygonMorph subclass: #BB1InteractionLink
    instanceVariableNames: 'diagram fromRole toRole'
    classVariableNames: ''
    poolDictionaries: ''
    category: 'BB1IDE-Browsers'

" BB1InteractionLink instance methods in category: access "

fromRole
    ^fromRole

fromRole: role1 toRole: role2
    fromRole := role1.
    toRole := role2.
    self refresh.

isFromRole: role1 toRole: role2
    ^fromRole == role1 and: [toRole == role2]

removeFromProgram
    diagram removeLinkFromView: self.
    diagram storeStructure

storeBreakpointsOn: strm
    " Store breakpoints as dictionary entry. "
    self vertices size > 2
    ifTrue:
        [strm cr; tab; tab; nextPutAll:
            'at: #''' , fromRole name , '_' , toRole name , ''' put: {' .
                self vertices from: 2 to: vertices size - 1 do:    
                        [:pt | strm nextPutAll: pt storeString , '. ' ].
                strm nextPutAll: ' };'].

straighten
    super straighten.
    diagram storeLinkBreakpoints.

toRole
    ^toRole

" BB1InteractionLink instance methods in category: private "

diagram
    ^diagram

diagram: diag
    diagram := diag

dropVertex: ix event: evt fromHandle: handle
    super dropVertex: ix event: evt fromHandle: handle.
    diagram storeAll; refreshLinks.

initialize
    super initialize.
    closed := false.
    smoothCurve := false.
    self
        color: Color black;
        borderColor: Color black;
        makeForwardArrow;    
        sticky: true.

printOn: strm
    super printOn: strm.
    strm nextPutAll: ' (' , fromRole printString , '->' , toRole printString ,')'.

refresh    
    (fromRole notNil and: [toRole notNil])
         ifTrue:
            [self setVertices:
                (Array
                    with: (fromRole attachPointFrom: (toRole center roundTo: 5@5))
                    with: (toRole attachPointFrom: (fromRole center roundTo: 5@5)))].

" BB1InteractionLink instance methods in category: triggers "

handlesMouseDown: evt
    ^true

mouseDown: evt
    (evt redButtonPressed and: [self bounds containsPoint: evt cursorPoint])
        ifTrue: [diagram addMorphFront: self.].
    (evt yellowButtonPressed and: [self bounds containsPoint: evt cursorPoint])
    ifTrue:
        [^self yellowButtonActivity: evt].
    super mouseDown: evt.

yellowButtonActivity: shiftKeyState
    | aMenu |
    aMenu := (MenuMorph new defaultTarget: self)
        addTitle: self printString;
        add: 'remove link' action: #removeFromProgram;
        add: 'straighten' action: #straighten.
    aMenu popUpInWorld.

" Class BB1InteractionRole "

EllipseMorph subclass: #BB1InteractionRole
    instanceVariableNames: 'diagram name nameMorph'
    classVariableNames: ''
    poolDictionaries: ''
    category: 'BB1IDE-Browsers'

" BB1InteractionRole instance methods in category: access "

<= anInteractionRole
    ^self name <= anInteractionRole name

= anInteractionRole
    ^self name = anInteractionRole name

addLink
    diagram addLinkFrom: self.

attachPointFrom: aPoint
    " Answer a point on my bounds suitable as an arrow end point. "
    ^self griddedPoint: (self bounds intersectionWithLineSegmentFromCenterTo: aPoint)

basicPosition: aPoint
    super position: (self griddedPoint: aPoint).

contextClass
    | cl |
    ^(cl := diagram model selectedContextClass) ifNil: [nil] ifNotNil: [cl]

contextClassName
    | cl |
    ^(cl := diagram model selectedContextClass) ifNil: [nil] ifNotNil: [cl name]

diagram
    ^diagram

diagram: aContextDiagram
    diagram := aContextDiagram.
    diagram addDependent: self.

displayName
    ^name asString asText allBold

name
    ^name asString asSymbol

name: aSymbol
    name := aSymbol.
    nameMorph
        newContents: '' asText;     " To block any TextMorph optimization if name unchanged. "
        newContents: self displayName;
        updateFromParagraph.
    self invalidRect: self bounds.

roleTrait
    ^self diagram model roleTraitForRoleName: self name

" BB1InteractionRole instance methods in category: private "

borderColor
    ^self isSelected
        ifTrue: [Color red]
        ifFalse: [Color black]

borderWidth
    ^(self diagram model runtimeRoleForRoleName: self name) ifNil: [1] ifNotNil: [4].

color
    ^self isSelected
        ifTrue: [Color lightMagenta]
        ifFalse: [Color white]

hasDropShadow
    ^self isEnvironment

initialize
    super initialize.
    self
        borderWidth: 2;
        borderColor: Color black;
        layoutPolicy: TableLayout new;
        hResizing: #shrinkWrap;
        vResizing: #shrinkWrap;
        color: Color lightGreen;
        extent: 75@50;
        shadowOffset: 5@5;
        shadowColor: Color green.
    nameMorph := TextMorph new
            hResizing: #shrinkWrap;
            contents: '';
            beAllFont: BB1IDE textFont;
                "((TextStyle named: 'BitstreamVeraSans') fontAt: 4);"
            wrapFlag: false;
            centered;
            margins: 10;
            yourself.
    self addMorphBack: nameMorph.

isEnvironment
    ^(self diagram notNil and: [self diagram model notNil])
        ifTrue: [self diagram model isEnvironmentRole: self name]
        ifFalse: [false]

isSelected
    ^diagram model selectedRole = self

position: aPoint
    super position: (self griddedPoint: aPoint).
    diagram refreshLinks; storeAll.

printOn: strm
    super printOn: strm.
    strm nextPutAll: ' (' , nameMorph text asString , ')'.

update: aParameter
    aParameter = #selection
    ifTrue:
        [self borderWidth: self borderWidth.
        self color: self color.
        self borderColor: self borderColor.
        self name: self name].

" BB1InteractionRole instance methods in category: private-mouse "

balloonText
    | cl strg |
    cl := diagram selectedContextClass.
    strg := (cl sourceCodeAt: self name asString asSymbol ifAbsent: ['Binding method missing.']) asString
                withNoLineLongerThan: Preferences maxBalloonHelpLineLength* 2.
    ^(TextMorph new contents: (strg asText makeSelectorBoldSREIn: cl))
        "beAllFont: ((TextStyle named: 'BitstreamVeraSans') fontAt: 4);"
        beAllFont: BB1IDE smallFont;
        leftFlush

click: evt
    self isSelected
        ifTrue: [diagram selectRole: nil]
        ifFalse: [diagram selectRole: self].

handlesMouseDown: evt
    ^true

mouseDown: evt
    evt yellowButtonPressed
        ifTrue: [^self yellowButtonActivity: evt].
    (evt redButtonPressed and: [self bounds containsPoint: evt cursorPoint])
        ifTrue: [evt hand waitForClicksOrDrag: self event: evt].

mouseDownPriority
    ^nameMorph mouseDownPriority + 1.

startDrag: evt
    | point w |
    point := self position.
    diagram selectRole: self.
    [Sensor redButtonPressed]
    whileTrue:
        [point := (self globalPointToLocal: Sensor cursorPoint) - (self extent // 2).
        self basicPosition: point.
        diagram role: self isMovingThrough: point.
        (w := self world) ifNotNil: [w doOneCycle]].
    self position: point.

" BB1InteractionRole instance methods in category: triggers "

delete
    diagram deleteRoleFromView: self.
    super delete.

removeRoleFromProgram
    self delete.
    diagram storeAll.
    diagram model removedRole: name.

renameRole
    | newName oldName |
    oldName := self name.
    newName := FillInTheBlank
        request: 'Please type new role name'
        initialAnswer: self name.
    (newName size = 0 or: [newName = self name]) ifTrue: [^self].
    self name: newName.
    diagram storeAll.
    diagram selectedContextClass
        renameRoleNamed: oldName to: newName.
    self invalidRect: self bounds.

yellowButtonActivity: shiftKeyState
    | aMenu |
    aMenu := (MenuMorph new defaultTarget: self) addTitle: self printString; yourself.
    aMenu addList: #(
        -
        ('addLink' #addLink)
        -
        ( 'remove role' #removeRoleFromProgram)
        ( 'rename role' #renameRole)
    ).
    aMenu popUpInWorld.

" Class BB1MergeConnector "

LineMorph subclass: #BB1MergeConnector
    instanceVariableNames: 'startEllipse endEllipse'
    classVariableNames: ''
    poolDictionaries: ''
    category: 'BB1IDE-Browsers'

" BB1MergeConnector instance methods in category: private "

initialize
    super initialize.
    color := Color black.
    borderWidth := 2.
    borderColor := Color black.
    closed := false.

refresh
    self setVertices: {startEllipse center. endEllipse center.}.
    ^self

startEllipse: first endEllipse: last
    startEllipse := first.
    endEllipse := last.
    ^self

" BB1MergeConnector class class methods in category: instance creation "

startEllipse: first endEllipse: last
    ^(BB1MergeConnector basicNew initialize)
        startEllipse: first endEllipse: last;
        refresh;
        yourself

" Class BB1MergeMorph "

PasteUpMorph subclass: #BB1MergeMorph
    instanceVariableNames: 'interactionBrowser selectedBaseContext baseContextsList currentContextClass baseContextClass baseEllipseDict baseRolePositions offset'
    classVariableNames: ''
    poolDictionaries: ''
    category: 'BB1IDE-Browsers'

" BB1MergeMorph instance methods in category: access "

baseContextClass: ctx
    baseContextClass := ctx.

baseContextsIndex
    ^selectedBaseContext ifNil: [0] ifNotNil: [baseContextsList indexOf: selectedBaseContext]

currentContextClass: ctx
    currentContextClass := ctx.

interactionBrowser: ip
    interactionBrowser := ip.

" BB1MergeMorph instance methods in category: private "

createMorphForRoleNamed: nam at: pos
    | rMorph nameMorph |
    rMorph := EllipseMorph new
            layoutPolicy: TableLayout new;
            hResizing: #shrinkWrap;
            vResizing: #shrinkWrap;
            position: pos;
            yourself.
    nameMorph := TextMorph new
            contents: nam;
            wrapFlag: false;
            centered;
            margins: 10;
            yourself.
    rMorph addMorphBack: nameMorph.
    ^rMorph

initialize
    super initialize.
    "self color: Color transparent".
    self color: ((TranslucentColor yellow) alpha: 0.5).
    bounds := 106@139 corner: 1045@969.

" BB1MergeMorph instance methods in category: triggers "

attachBaseContext
    | lockedNameDict pt0 targetRoleName mergeDict line lines |
    baseRolePositions := baseContextClass rolePositions.
    baseEllipseDict := Dictionary new.
    lines := Set new.
    baseRolePositions associationsDo:
        [:ass || rMorph |
        rMorph := self createMorphForRoleNamed: ass key asString asText at: ass value.
        self submorphs isEmpty
        ifTrue:
            [self privateBounds: rMorph fullBounds]
        ifFalse:
            [self privateBounds: (self bounds merge: rMorph fullBounds)].
        baseEllipseDict at: ass key put: rMorph.
        self addMorphFront: rMorph].
    " + line morphs "
        baseContextClass roleStructure
        associationsDo:
            [:ass || fromName toSet |
            fromName := ass key.
            toSet := ass value.
            toSet do:
                [:toName |
                line := BB1MergeConnector
                    startEllipse: (baseEllipseDict at: fromName)
                    endEllipse: (baseEllipseDict at: toName).
                self addMorphBack: line.
                lines add: line]].
        "--"
    self clipSubmorphs: false.
    "cnt := self center. self extent: interactionBrowser bounds extent. self center: cnt."
    offset := self position.
    interactionBrowser addMorphFront: self.
    
    lockedNameDict := Dictionary new.
    mergeDict := Dictionary new.
    baseRolePositions keysDo:
        [:rName |
        pt0 := self bindRole: rName locked: lockedNameDict lines: lines.
        targetRoleName := interactionBrowser diagramPane roleAtGlobal: pt0.
        targetRoleName
            ifNil:
                [targetRoleName := rName.
                interactionBrowser diagramPane addRoleNamed: targetRoleName atGlobal: pt0].
        mergeDict at: targetRoleName put: rName.
        lockedNameDict at: rName put: pt0].    
    self delete.
    ^mergeDict

bindRole: rName locked: lockedNameDict lines: linesSet
    | focusEllipse pt0 w pt1 |
    focusEllipse := baseEllipseDict at: rName.
    pt1 := (baseRolePositions at: rName) + (focusEllipse extent // 2) - offset.
    [Sensor anyButtonPressed] whileTrue: [].
    [Sensor anyButtonPressed]
    whileFalse:
        [self position: ((pt0 := Sensor cursorPoint) - pt1).
        lockedNameDict associationsDo: "rName -> ellipsePosition "
            [:ass | (baseEllipseDict at: ass key) position: (ass value - ((baseEllipseDict at: ass key) extent // 2))].
        linesSet do: [:line | line refresh].
        (w := self world) ifNotNil: [w doOneCycle]].
    ^pt0

" Support perspective "

" Class BB1Context "

" This is the superclass for all DCI Context classes.

At runtime, Contexts are kept i a stack; only the one that was entered most recently is the currently active one.
The Context stack is kept in ContextStack, a BB1Context class variable.
The currently active Context should be the global (Smalltalk) vaiable CurrentContext.
But trouble with the compiler made it necessary to make it a derived variable: BB1Context>>currentContext.

Example trouble: The CompiledMethod BB3Greed>>zzplay has two CurrentContext literals,
one is == the association in Smalltalk and one a different object that does not always have the same value.
BB3Player>>zzyourTurn has had the same problem, but not always.
The problem seems to dissapear if Role names are replaced by the long form, e.g. (CurrentContext at: #CurrentPlayer)
Faulty optimization for blocks caused by my BabyIDE hacks?

Revert to CurrentContext is top value on Context stack in BB1Context class var

Bug in BB1RoleNode possibly fixed (from ...\WORK\14-Squeak7175-experiments\36..45-ContextSingleton-globalContext\Squeak3.10.1-7175-basic.46.image) "

Object subclass: #BB1Context
    instanceVariableNames: 'roleMap mergedContext'
    classVariableNames: ''
    poolDictionaries: ''
    category: 'BB1IDE-Support'

" BB1Context instance methods in category: data manipulation "

at: roleName
    ^ self
        at: roleName
        ifAbsent:
            [self error: roleName , ' is not defined as a role in this Context.'].

at: roleName ifAbsent: absentBlock
    | value |
    value := roleMap
                at: roleName
                ifAbsent: [absentBlock].
    value == self symbolForLazyBinding
        ifTrue: [value := self perform: roleName.
            roleMap at: roleName put: value].
    (value isBlock
            and: [value numArgs = 0])
        ifTrue: [^ value value].
    ^ value

at: roleName put: value
self error: 'at:put: illegal in all Context classes'.
    (roleMap includesKey: roleName)
        ifFalse: [self error: roleName , ' is an undeclared role name'].
    roleMap at: roleName put: value.
    ^value

clearRoleMap
    roleMap := IdentityDictionary new.
    roleMap at: #cc put: self.
    ^roleMap

includesKey: aKey
    ^roleMap includesKey: aKey

remap
    | messName |
    self clearRoleMap.
    self class roleNames
        do: [:rNam |
            messName := rNam asString asSymbol.
            roleMap
                at: messName
                put: (self
                        perform: messName
                        ifNotUnderstood: [nil])].

roleForObject: aRolePlayer
    ^roleMap keyAtValue: aRolePlayer ifAbsent: [nil].

" BB1Context instance methods in category: execution "

runInteractionFromRoleNamed: triggerRoleName
    self executeInContext:
        [self remap.
        (roleMap at: triggerRoleName ifAbsent: [nil])
            ifNil:
                [self error: 'role named ' , triggerRoleName , ' is undefined. Interaction not run.'.
                ^self]
            ifNotNil:
            [^self to: triggerRoleName send: #run withArgs: #()]
        ].

to: roleName send: selector withArgs: argArray
    | receiver runRole compiledMethod |
    receiver := roleMap at: roleName.
    runRole := self class roleClassForRoleName: roleName.
    runRole ifNotNil: [compiledMethod := runRole methodDict at: selector ifAbsent: [nil]].
    compiledMethod
        ifNil: [^receiver perform: selector withArguments: argArray]
        ifNotNil: [^receiver withArgs: argArray executeMethod: compiledMethod]

" BB1Context instance methods in category: private "

executeInContext: aBlock
    BB1ContextStack pushContextStack: self.
    aBlock ensure: [BB1ContextStack popContextStack].

initialize
    super initialize.
    roleMap := IdentityDictionary new.
    roleMap at: #cc put: self.

perform: aSelector ifNotUnderstood: aBlock
    ^(self respondsTo: aSelector asSymbol)
        ifTrue: [self perform: aSelector]
        ifFalse: [aBlock value]

symbolForLazyBinding
    ^#'____LazyBinding'

" BB1Context class class methods in category: context diagram "

isDefiningInteraction
    ^true

linkBreakPoints
    ^IdentityDictionary new

rolePositions
    ^ IdentityDictionary new

" BB1Context class class methods in category: role structure "

collaboratorsFor: roleName
    ^ (self roleStructure at: roleName ifAbsent: [OrderedCollection new]) , (Array with: roleName)

roleNames
    ^ self roleStructure keys

roleStructure
    ^ IdentityDictionary new

" BB1Context class class methods in category: runtime services "

playerForRole: roleName
    ^BB1ContextStack currentContext at: roleName

" BB1Context class class methods in category: traits services "

removeFromSystem
    | trait |
    self roleNames do:
        [:rNam |
        (trait := Smalltalk
            at: (self name asString , rNam asString) asSymbol
            ifAbsent: [nil])
        ifNotNil:
            [trait removeFromSystem]].
    super removeFromSystem.

rename: aString
    | trait |
    self roleNames do:
        [:rNam |
        (trait := Smalltalk
            at: (self name asString , rNam asString) asSymbol
            ifAbsent: [nil])
        ifNotNil:
            [trait rename: (aString , rNam asString) asSymbol]].
    super rename: aString.

renameRoleNamed: oldName to: newName
    | obs trait source oldCat roleTrait |
    obs := OrderedCollection new.
    self roleNames do:
        [:rNam |
        (trait := self roleTraitForRoleName: rNam)
        ifNotNil:
            [trait methodDict associationsDo:
                [:ass |
                (ass value hasLiteralSuchThat:
                    [:lit |
                    lit isString and: [lit includesSubstring: oldName asString caseSensitive: true]])
                ifTrue:
                    [obs add: (MethodReference new setStandardClass: trait methodSymbol: ass key)]
                ]]].
    " Rename role binding method. "
    (source := self sourceMethodAt: oldName ifAbsent: [nil])
    ifNotNil:
        [oldCat := self organization categoryOfElement: oldName.
        source replaceFrom: 1 to: oldName size with: newName asText allBold.
        self
                compile: source
                classified: oldCat
                notifying: nil.
        self removeSelector: oldName].
    " Rename trait. "
    (roleTrait := self roleTraitForRoleName: oldName)
    ifNotNil:
        [roleTrait rename: (self traitNameFromRoleName: newName).
        Clipboard clipboardText: newName.
        self systemNavigation
            browseMessageList: obs
            name: 'Obsolete References to ' , oldName
            autoSelect: oldName].

roleClassForRoleName: roleName
    ^Smalltalk
            at: (self name asString , roleName asString) asSymbol
            ifAbsent: [nil]

roleNameFromRTRoleName: rtNam
    " BB2ShapesCtx roleNameFromRTRoleName: #BB2ShapesCtxArrows "
    rtNam size > self name size ifFalse: [^self error: 'Trait name trouble: ' , rtNam].
    ^(rtNam asString copyFrom: self name size +1 to: rtNam size) asSymbol

roleNameFromTraitName: tNam
    " BB1ShapesCtxArrows roleNameFromTraitName:
        (BB1ShapesCtxArrows traitNameFromRoleName: 'Shape1' asSymbol ) "

    tNam size > self name size ifFalse: [^self error: 'Trait name trouble.'].
    ^(tNam asString copyFrom: self name size +1 to: tNam size) asSymbol

roleTraitForRoleName: roleName
    | cl traitName |
    traitName := (self name asString , roleName asString) asSymbol.
    cl := Smalltalk
                at: traitName
                ifAbsent: [nil].
    ^ cl isTrait
        ifTrue: [cl]
        ifFalse: [nil]

runtimeRoleNameFromRoleName: rNam
    " BB5aMoneyTransferContextTransferMoneySource runtimeRoleNameFromRoleName: 'TransferMoneySource' asSymbol "
    ^(self name asString , rNam asString) asSymbol

traitNameFromRoleName: rNam
    " BB1ShapesCtxArrows traitNameFromRoleName: 'Shape1' asSymbol "
    ^(self name asString , rNam asString) asSymbol

" Class BB1ContextStack "

Object subclass: #BB1ContextStack
    instanceVariableNames: ''
    classVariableNames: ''
    poolDictionaries: ''
    category: 'BB1IDE-Support'

" BB1ContextStack class class methods in category: access "

ContextStack
    ContextStack ifNil: [ContextStack := OrderedCollection new].
    ^ContextStack

cc
    ^currentContext

currentContext
    ^currentContext

popContextStack
    self ContextStack removeLast.
    currentContext := ContextStack ifEmpty: [nil] ifNotEmpty: [ContextStack last].
    ^currentContext

pushContextStack: aContext
    currentContext := aContext.
    self ContextStack addLast: currentContext.
    ^currentContext

" BB1ContextStack class class methods in category: class initialization "

initialize
    " BB1ContextStack initialize "
    ContextStack := nil.

" BB1ContextStack class class methods in category: runtime services "

playerForRole: roleName
    ^self currentContext at: roleName

" Class BB1ContextVariablesInspector "

ContextVariablesInspector subclass: #BB1ContextVariablesInspector
    instanceVariableNames: 'roleNames roleValues'
    classVariableNames: ''
    poolDictionaries: ''
    category: 'BB1IDE-Support'

" BB1ContextVariablesInspector instance methods in category: access "

currentRolePlayers
    | squeakCtx babyContext rolePlayerMap thisRoleName |
    squeakCtx := object.
    squeakCtx ifNil: [^Dictionary new].
    (babyContext := BB1ContextStack currentContext) ifNil: [^Dictionary new].
    thisRoleName := babyContext
                ifNil: [#UNKNOWN]
                ifNotNil: [babyContext class roleNameFromRTRoleName: squeakCtx methodClass name asSymbol].
    "self doOnlyOnce: [self traceRM: squeakCtx receiver class. self halt]." "self rearmOneShot"
    rolePlayerMap := Dictionary new.
    rolePlayerMap
        at: 'THIS ROLE>>' , thisRoleName asString
        put: (babyContext at: thisRoleName ifAbsent: [nil]).
    (babyContext class roleNames "collaboratorsFor: thisRoleName")
        do:
            [:collaboratorName |
            rolePlayerMap at: collaboratorName put: (babyContext at: collaboratorName ifAbsent: [nil])].
    ^rolePlayerMap

fieldList
    "Refer to the comment in Inspector|fieldList."

    | fields |
    object == nil ifTrue: [^Array with: 'thisContext'].
    fields _ (Array with: 'thisContext' with: 'all temp vars') , object tempNames.
    object myEnv ifNotNil: [fields := fields, object capturedTempNames].
    fields := fields , roleNames.
    ^ fields

selection
    "Refer to the comment in Inspector|selection."
    | idx numTemps numEnv |
    selectionIndex = 0 ifTrue:[^''].
    selectionIndex = 1 ifTrue: [^object].
    selectionIndex = 2 ifTrue: [^ object tempsAndValues].
    idx := 2.
    numTemps := object method numTemps.
    selectionIndex - idx <= numTemps ifTrue: [^ object tempAt: selectionIndex - 2].
    idx := idx + numTemps.
    numEnv := object myEnv ifNil: [0] ifNotNil: [object myEnv size].
    selectionIndex - idx <= numEnv ifTrue: [^object myEnv at: selectionIndex - idx].
    idx := idx + numEnv.
    ^ roleValues at: selectionIndex - idx

zzcurrentRolePlayers
    " Search stack for all baby contexts with their current role mappings. "
    " Select the roles that are reachable from the current role. "
    " Note that the baby context is different from the Squeak stack context (here: ctx). "
    | ctx currentTraits thisTrait thisRoleName rolePlayerMap babyContext |
    ctx := object.
    ctx ifNil: [^Dictionary new].
    
    currentTraits := ctx receiver class traitComposition allTraits select:
            [:t | t allSelectors includes: ctx method selector].
    currentTraits ifEmpty: [^Dictionary new].
    thisTrait := currentTraits first.
    thisRoleName := (thisTrait roleContextClass roleNameFromTraitName: thisTrait name asSymbol).
    rolePlayerMap := Dictionary new.
    [    ctx := ctx findNextHandlerContextStarting.
        ((ctx notNil
            and: [(babyContext := ctx tempAt: 1) isKindOf: BB1Context])
                and: [babyContext includesKey: thisRoleName])
        ifTrue:
            [rolePlayerMap
                    at: 'THIS ROLE>>' , thisRoleName
                    put: (babyContext at: thisRoleName ifAbsent: [nil]).
            (babyContext class collaboratorsFor: thisRoleName)
            do:
                [:partnerName |
                rolePlayerMap
                    at: partnerName put: (babyContext at: partnerName ifAbsent: [nil])]].
        ctx notNil
    ] whileTrue: [ctx := ctx sender].
        
    ^rolePlayerMap

" BB1ContextVariablesInspector instance methods in category: private "

initialize
    super initialize.
    roleNames := OrderedCollection new.
    roleValues := OrderedCollection new.

" BB1ContextVariablesInspector instance methods in category: triggers "

inspect: anObject
    "Initialize the receiver so that it is inspecting anObject. There is no
    current selection.
    
    Because no object's inspectorClass method answers this class, it is OK for this method to
    override Inspector >> inspect: "


    | map |
    object := anObject.
    self initialize.
    map := self currentRolePlayers.
    roleNames := map keys asSortedCollection..
    roleValues := roleNames collect: [:nam | map at: nam].

" Class BB1Iterator "

Object subclass: #BB1Iterator
    instanceVariableNames: 'collection'
    classVariableNames: ''
    poolDictionaries: ''
    category: 'BB1IDE-Support'

" BB1Iterator instance methods in category: error handling "

do: aBlock
    collection do: aBlock

doesNotUnderstand: aMessage
    collection do: [:element | aMessage sendTo: element]

inject: thisValue into: binaryBlock
    | nextValue |
    nextValue := thisValue.
    collection do: [:each | nextValue := binaryBlock value: nextValue value: each].
    ^nextValue

" BB1Iterator instance methods in category: private "

on: aCollection
    collection := aCollection

" BB1Iterator class class methods in category: instance creation "

on: aCollection
    ^self new on: aCollection

" Class BB1MessageNode "

MessageNode subclass: #BB1MessageNode
    instanceVariableNames: ''
    classVariableNames: ''
    poolDictionaries: ''
    category: 'BB1IDE-Support'

" BB1MessageNode instance methods in category: code generation "

zzemitForValue: stack on: strm
    "For #ifTrue:ifFalse: and #whileTrue: / #whileFalse: style messages, the pc is set to the jump instruction, so that mustBeBoolean exceptions can be shown correctly."
    special > 0
        ifTrue:
            [pc _ 0.
            self perform: (MacroEmitters at: special) with: stack with: strm with: true]
        ifFalse:
            [
            
            receiver ~~ nil ifTrue: [receiver emitForValue: stack on: strm].
            arguments do: [:argument | argument emitForValue: stack on: strm].
            selector
                emit: stack
                args: arguments size
                on: strm
                super: receiver == NodeSuper.
            pc _ strm position]

zzsizeForValue: encoder
    | total argSize |
    special > 0
        ifTrue: [^self perform: (MacroSizers at: special) with: encoder with: true].
    receiver == NodeSuper
        ifTrue: [selector _ selector copy "only necess for splOops"].
    total _ selector size: encoder args: arguments size super: receiver == NodeSuper.
    receiver == nil
        ifFalse: [total _ total + (receiver sizeForValue: encoder)].
    sizes _ arguments collect:
                    [:arg |
                    argSize _ arg sizeForValue: encoder.
                    total _ total + argSize.
                    argSize].
    ^total

" BB1MessageNode instance methods in category: initialize-release "

receiver: rcvr selector: selName arguments: args precedence: p from: encoder sourceRange: range
    "Compile."
    encoder noteSourceRange: range forNode: self.
    ^self
        receiver: (encoder scopeTableAt: #cc)
        selector: #to:send:withArgs:
        arguments: (OrderedCollection
            with: (encoder encodeLiteral: rcvr roleName)
            with: (encoder encodeLiteral: selName)
            with: (BraceNode new elements: args))
        precedence: p
        from: encoder.

" Class BB1PluggableButtonMorph "

PluggableButtonMorph subclass: #BB1PluggableButtonMorph
    instanceVariableNames: ''
    classVariableNames: ''
    poolDictionaries: ''
    category: 'BB1IDE-Support'

" BB1PluggableButtonMorph instance methods in category: access "

getModelState
    "TRee: I did find a way to identify the button when it asks for state."
    ^ getStateSelector isNil
        ifTrue: [false]
        ifFalse: [getStateSelector numArgs = 0
                ifTrue: [model perform: getStateSelector]
                ifFalse: [model
                        perform: getStateSelector
                        withArguments: (Array with: self)]]

printOn: strm
    super printOn: strm.
    strm nextPutAll: '<' , label , '>'.

update: aParameter
    getLabelSelector
        ifNotNil: [aParameter == getLabelSelector
                ifTrue: [self
                        label: (model perform: getLabelSelector)]].
    self getModelState
        ifTrue: [self color: onColor. self borderColor: Color red. self borderWidth: 4]
        ifFalse: [self color: offColor. self borderColor: Color blue. self borderWidth: 1]

" Class BB1PluggableTextMorph "

PluggableTextMorph subclass: #BB1PluggableTextMorph
    instanceVariableNames: ''
    classVariableNames: ''
    poolDictionaries: ''
    category: 'BB1IDE-Support'

" BB1PluggableTextMorph instance methods in category: model access "

beAllFont: aFont
    ^textMorph beAllFont: aFont

fontName: family size: sz
    textMorph fontName: family size: sz

textMorph
    ^textMorph

textStyle
    ^textMorph textStyle

textStyle: aTextStyle
    ^textMorph setTextStyle: aTextStyle

" BB1PluggableTextMorph instance methods in category: private "

makeProjectLink
    "We don't know how to do this"
    ^ self flash

showBytecodes
    "We don't know how to do this"
    ^ self flash

" Class BB1ReferenceClass "

Object subclass: #BB1ReferenceClass
    instanceVariableNames: 'refClass isEditable isOwn comment text'
    classVariableNames: ''
    poolDictionaries: ''
    category: 'BB1IDE-Support'

" BB1ReferenceClass instance methods in category: access "

<= other
    ^self asStringOrText asString <= other asStringOrText asString

= other
    ^other class = self class
    and: [self asStringOrText asString = other asStringOrText asString]

asStringOrText
    " Note: kern and font change are ignored by ListMorph! "
    refClass isNil ifTrue: [^'UNDEFINED' asText].
    text := refClass name asString asText , self comment asText.
    isEditable = true ifFalse: [text allItalics].
    "isOwn
        ifTrue: [text size > 0 ifTrue: [text addAttribute: (TextFontChange fontNumber: 3) from: 1 to: text size]]
        ifFalse: [text := text allItalics]."

    ^text

comment
    ^comment ifNil: [''] ifNotNil: [comment]

comment: aStringOrText
    comment := aStringOrText

isEditable
    ^isEditable == true

isEditable: aBool
    isEditable := aBool.
    text := nil.

isOwn
    ^isOwn

isOwn: aBool
    isOwn := aBool.
    text := nil.

printOn: strm
    super printOn: strm.
    strm nextPut: ${; nextPutAll: refClass name; nextPut: $}

refClass
    ^refClass

refClass: aCl
    refClass := aCl.
    text := nil.
    comment := ''.

" Class BB1ReferenceSelector "

Object subclass: #BB1ReferenceSelector
    instanceVariableNames: 'refClass refCategory refSelector isEditable isOwn comment text'
    classVariableNames: ''
    poolDictionaries: ''
    category: 'BB1IDE-Support'

" BB1ReferenceSelector instance methods in category: access "

<= other
    ^self asStringOrText asString <= other asStringOrText asString

= other
    ^other class = self class
    and: [self asStringOrText asString = other asStringOrText asString]

asStringOrText
    text ifNil:
        [" Note: kern is ignored by ListMorph! "
        (refClass notNil and: [refSelector notNil]) ifFalse: [^'UNDEFINED' asText allBold].
        text := refSelector asString asText , (' (' , refClass name , ')') asText , comment asText.
        isEditable = true ifTrue: [text allBold]. " ifFalse: [text allItalics]."
        isOwn = false ifTrue: [text allItalics].
"        ifFalse:
            [text size > 0 ifTrue: [text addAttribute: (TextFontChange fontNumber: 2) from: 1 to: text size]]"
].
    ^text

comment
    ^comment

comment: aStringOrText
    comment := aStringOrText

isEditable
    ^isEditable

isEditable: aBool
    isEditable := aBool.
    text := nil.

isOwn
    ^isOwn

isOwn: aBool
    isOwn := aBool.
    text := nil.

printOn: strm
    super printOn: strm.
    strm nextPut: ${; nextPutAll: refClass name; nextPutAll: '>>'; nextPutAll: refSelector; nextPut: $}

refCategory
    ^refCategory

refCategory: cat
    refCategory := cat.

refClass
    ^refClass

refClass: aClass
    refClass := aClass.
    text := nil.
    comment := ''.

refSelector
    ^refSelector

refSelector: aSymbol
    refSelector := aSymbol.
    text := nil.

" Class BB1RoleNode "

VariableNode subclass: #BB1RoleNode
    instanceVariableNames: 'receiver arguments selector'
    classVariableNames: ''
    poolDictionaries: ''
    category: 'BB1IDE-Support'

" BB1RoleNode instance methods in category: accessing "

asVariable: roleName contextName: ctxNam
    | arg1 |
    comment := nil.
    receiver := VariableNode new
                name: 'self'
                key: #BB1ContextStack -> BB1ContextStack
                code: -4.
    selector := SelectorNode new comment: nil;
                 key: #playerForRole: code: -5.
    arg1 := LiteralVariableNode new.
    arg1 key: roleName asSymbol code: LdLitType negated.
    arg1 name: roleName.
    arguments := OrderedCollection with: arg1.

contextClass
    ^key value

receiver
    ^receiver

roleName
    ^arguments first key

zzasVariable: roleName contextName: ctxNam
    | arg1 |
    comment := nil.
    receiver := VariableNode new
                name: 'self'
                key: ctxNam -> (Smalltalk at: ctxNam)
                code: -4.
    selector := SelectorNode new comment: nil;
                 key: #playerForRole: code: -5.
    arg1 := LiteralVariableNode new.
    arg1 key: roleName asSymbol code: LdLitType negated.
    arg1 name: roleName.
    arguments := OrderedCollection with: arg1.

" BB1RoleNode instance methods in category: code generation "

emitForValue: stack on: strm
    pc := 0.
    receiver ~~ nil ifTrue: [receiver emitForValue: stack on: strm].
    arguments do: [:argument | argument emitForValue: stack on: strm].
    selector
        emit: stack
        args: arguments size
        on: strm
        super: receiver == NodeSuper.
    pc _ strm position.

sizeForValue: encoder
    | total argSize |
    receiver == NodeSuper
        ifTrue: [selector _ selector copy "only necess for splOops"].
    total _ selector size: encoder args: arguments size super: receiver == NodeSuper.
    receiver == nil
        ifFalse: [total _ total + (receiver sizeForValue: encoder)].
    arguments do:
                    [:arg |
                    argSize _ arg sizeForValue: encoder.
                    total _ total + argSize.
                    argSize].
    ^total

" BB1RoleNode instance methods in category: printing "

printOn: aStream indent: level
    aStream
        nextPutAll: arguments first key.

" Class BB1RuntimeRole "

Object subclass: #BB1RuntimeRole
    instanceVariableNames: 'roleContextClassName'
    classVariableNames: ''
    poolDictionaries: ''
    category: 'BB1IDE-Support'

" BB1RuntimeRole instance methods in category: accessing "

compiledMethodAt: selector
    ^self class compiledMethodAt: selector

methodDict
    ^self class methodDict

printMethodsHtmlOn: strm
    | selectors roleMethods source |
    selectors := self methodDict keys.
    roleMethods := self methodDict values.
    selectors ifEmpty: [self error: 'No role methods.'].
    selectors do:
        [:sel |
        source := self class sourceMethodAt: sel.
        [source last isSeparator]
            whileTrue:
                [source := source copyFrom: 1 to: source size - 1].        
        source printHtmlParagraphOn: strm].

roleContextClass
    ^Smalltalk at: roleContextClassName ifAbsent: [nil]

roleContextClassName
    ^roleContextClassName

roleContextClassName: ctxNam
    roleContextClassName := ctxNam

roleName
    ^(self class name asString copyFrom: roleContextClassName size + 1 to: self class name size) asSymbol

ultimateSourceCodeAt: selector ifAbsent: aBlock
    ^self class ultimateSourceCodeAt: selector ifAbsent: aBlock

" BB1RuntimeRole class class methods in category: sole instance "

SoleInstance
    ^SoleInstance

SoleInstance: aRuntimeRole
    SoleInstance := aRuntimeRole