'From Squeak3.1alpha of 28 February 2001 [latest update: #4320] on 6 September 2001 at 9:10:44 am'! "Change Set: UniTile7-tk Date: 6 September 2001 Author: Ted Kaehler UniTile menu item to add a new temporary variable, or get a tile for an instance variable. Converted the 'center dot' in compound names to replace character ascii 0 instead of space. This allows the mixing in of spaces (args in menus, etc). Adjusted spacing. Converted many 'column' SyntaxMorphs to 'row' so that the popUp will appear beside it. (A layout bug fix caused these to be displayed as a true column). Selector menu now tells what class it is trying to show."! !LiteralNode methodsFor: 'tiles' stamp: 'tk 8/24/2001 15:43'! asMorphicSyntaxIn: parent | row | row _ parent addRow: #literal on: self. (key isVariableBinding) ifFalse: [ row layoutInset: 1. ^ row addMorphBack: (row addString: key storeString special: false)]. key key isNil ifTrue: [ ^ row addTextRow: ('###',key value soleInstance name) ] ifFalse: [ ^ row addTextRow: ('##', key key) ]. ! ! !Morph methodsFor: 'change reporting' stamp: 'tk 8/24/2001 22:07'! userSelectedColor: aColor "The user, via the UI, chose aColor to be the color for the receiver; set it, and tell my owner in case he wishes to react" self color: aColor. self world ifNotNil: [owner colorChangedForSubmorph: self]! ! !Player methodsFor: 'costume' stamp: 'tk 8/24/2001 09:09'! hasCostumeThatIsAWorld costume ifNil: [^ false]. (costume renderedMorph isWorldMorph) ifTrue: [^ true]. costumes ifNotNil: [costumes do: [:aCostume | (aCostume isWorldMorph) ifTrue: [^ true]]]. ^ false! ! !SyntaxMorph methodsFor: 'node types' stamp: 'tk 8/24/2001 15:41'! isAVariable "There are three kinds of variable nodes" ((parseNode class == TempVariableNode) or: [ (parseNode class == LiteralVariableNode) or: [ parseNode class == VariableNode]]) ifFalse: [^ false]. ^ (ClassBuilder new reservedNames includes: self decompile string withoutTrailingBlanks) not! ! !SyntaxMorph methodsFor: 'node types' stamp: 'tk 8/24/2001 13:16'! isDeclaration "Return true if I am a TempVarNode inside a declaration of some kind, including a method arg" | opc | opc _ owner parseNode class. opc == BlockArgsNode ifTrue: [^ true]. opc == MethodTempsNode ifTrue: [^ true]. opc == SelectorNode ifTrue: [^ true]. ^ false! ! !SyntaxMorph methodsFor: 'node types' stamp: 'tk 8/24/2001 15:49'! isNoun "Consider these to be nouns: TempVariableNode, LiteralNode, VariableNode, (MessageNode or CascadeNode with receiver), AssignmentNode" (#(TempVariableNode LiteralNode VariableNode AssignmentNode LiteralVariableNode) includes: (parseNode class name)) ifTrue: [^ true]. (self nodeClassIs: MessageNode) ifTrue: [^ parseNode receiver notNil]. (self nodeClassIs: CascadeNode) ifTrue: [^ parseNode receiver notNil]. ^ false! ! !SyntaxMorph methodsFor: 'insertion drop zones' stamp: 'tk 8/29/2001 20:21'! trackDropZones | hand i localPt insertion insHt ii prevBot nxtHt d c1 c2 ht2 spacer1 spacer2 wid ht1 dc each | hand _ self primaryHand. ("hand lastEvent redButtonPressed &" hand hasSubmorphs and: [(self hasOwner: hand) not]) ifFalse: [^ self]. insertion _ hand firstSubmorph renderedMorph. insertion isSyntaxMorph ifFalse: [^ self]. insertion isNoun ifFalse: [^ self]. localPt _ self globalPointToLocal: hand position. insHt _ insertion height. "**just use standard line height here" self removeDropZones. "Maybe first check if in right place, then just tweak heights." i _ (ii _ self indexOfMorphAbove: localPt) min: submorphs size-1. prevBot _ i <= 0 ifTrue: [(self innerBounds) top] ifFalse: [(self submorphs at: i) bottom]. nxtHt _ (submorphs isEmpty ifTrue: [insertion] ifFalse: [self submorphs at: i+1]) height. d _ ii > i ifTrue: [nxtHt "for consistent behavior at bottom"] ifFalse: [0 max: (localPt y - prevBot min: nxtHt)]. "Top and bottom spacer heights cause continuous motion..." c1 _ Color transparent. c2 _ Color transparent. ht2 _ d*insHt//nxtHt. ht1 _ insHt - ht2. wid _ self width - (2*borderWidth) - (2*self layoutInset). wid isPoint ifTrue: [wid _ wid x]. (spacer1 _ BorderedMorph newBounds: (0@0 extent: wid@ht1) color: (ht1 > (insHt//2) ifTrue: [c1] ifFalse: [c2])) borderWidth: 1; borderColor: spacer1 color. self privateAddMorph: spacer1 atIndex: (i+1 max: 1). (spacer2 _ BorderedMorph newBounds: (0@0 extent: wid@ht2) color: (ht2 > (insHt//2+1) ifTrue: [c1] ifFalse: [c2])) borderWidth: 1; borderColor: spacer2 color. spacer1 setProperty: #dropZone toValue: true. spacer2 setProperty: #dropZone toValue: true. self privateAddMorph: spacer2 atIndex: (i+3 min: submorphs size+1). self fullBounds. "Force layout prior to testing for cursor containment" "Maintain the drop target highlight -- highlight spacer if hand is in it." {spacer1. spacer2} do: [:spacer | (spacer containsPoint: localPt) ifTrue: [spacer color: self dropColor. "Ignore border color. Maybe do it later. self borderColor = self dropColor ifTrue: [self borderColor: self stdBorderColor]"]]. "If no submorph (incl spacers) highlighted, then re-highlight the block." "Ignore border color. Maybe do it later. ((self wantsDroppedMorph: insertion event: hand lastEvent) and: [(self submorphs anySatisfy: [:m | m containsPoint: localPt]) not]) ifTrue: [self borderColor: self dropColor]. " "Dragging a tile within a Block, if beside a tile, color it a dropzone" "Transcript show: localPt y printString; space; show: submorphs first top printString; space; show: submorphs last top printString; cr." dc _ self dropColor. 1 to: ((ii+4 min: submorphs size) max: 1) do: [:ind | each _ submorphs at: ind. each isSyntaxMorph ifTrue: [ localPt y >= each top ifTrue: ["in this one or beyond" (localPt y < each bottom) ifTrue: [(each submorphs anySatisfy: [:m | m containsPoint: localPt]) ifTrue: [each setDeselectedColor] ifFalse: [each color: dc]] ifFalse: [each color = dc ifTrue: [each setDeselectedColor]]] ifFalse: [each color = dc ifTrue: [each setDeselectedColor]]]]. ! ! !SyntaxMorph methodsFor: 'layout' stamp: 'tk 8/24/2001 09:14'! addBlockArg: aMorph "Add a temporary to a block or the method. Return true if succeed" "(aMorph nodeClassIs: TempVariableNode) is known to be true." "***NOTE: This method should be combined with addTempVar:" | tempHolder tt var nn | owner isMethodNode ifTrue: [ ^ (self addTempVar: aMorph)]. "Node for them is not inside the block" "If exists, drop the temp in this block and let user extend it." nn _ aMorph decompile string. "name" (self isKnownVarName: nn) ifTrue: [^ false]. "already defined" tt _ self firstSubmorph. tempHolder _ tt firstSubmorph isSyntaxMorph ifTrue: [(tt nodeClassIs: BlockArgsNode) ifTrue: [tt] ifFalse: [nil]] ifFalse: [nil]. tempHolder ifNil: ["make new row" tempHolder _ self addRow: #blockarg1 on: (BlockArgsNode new). tempHolder addNoiseString: self noiseBeforeBlockArg. tempHolder submorphs last firstSubmorph emphasis: 1. tempHolder useRoundedCorners. self addMorphFront: tempHolder. aMorph parseNode name: nn key: nn code: nil. aMorph parseNode asMorphicSyntaxIn: tempHolder. tempHolder cleanupAfterItDroppedOnMe. ^ true]. "Know this variable is not present, so add it" aMorph parseNode name: nn key: nn code: nil. tempHolder addMorphBack: (tempHolder transparentSpacerOfSize: 4@4). var _ tempHolder addRow: #tempVariable on: aMorph parseNode. var layoutInset: 1. var addMorphBack: (self aSimpleStringMorphWith: nn). var cleanupAfterItDroppedOnMe. ^ true ! ! !SyntaxMorph methodsFor: 'layout' stamp: 'tk 8/24/2001 15:15'! addSingleKeywordRow: aStringLikeItem | row sMorph modifiedString | (row _ self class row: #text on: nil) borderWidth: 1. modifiedString _ self substituteKeywordFor: aStringLikeItem. sMorph _ self addString: modifiedString special: true. sMorph font: (self fontToUseForSpecialWord: modifiedString). modifiedString = aStringLikeItem ifFalse: [ sMorph setProperty: #syntacticallyCorrectContents toValue: aStringLikeItem]. row addMorph: sMorph. self addMorphBack: row. ^row! ! !SyntaxMorph methodsFor: 'layout' stamp: 'tk 8/24/2001 09:13'! addTempVar: aMorph "know we are a block inside a MethodNode" "(aMorph nodeClassIs: TempVariableNode) is known to be true." | tempHolder ii tt var nn | nn _ aMorph decompile string. "name" (self isKnownVarName: nn) ifTrue: [^ false]. "already defined" tempHolder _ nil. (ii _ owner submorphIndexOf: self) = 1 ifFalse: [ tt _ owner submorphs at: ii - 1. tt isSyntaxMorph ifTrue: [ (tt nodeClassIs: MethodTempsNode) ifTrue: [tempHolder _ tt]. (tt nodeClassIs: UndefinedObject) ifTrue: [tempHolder _ tt findA: MethodTempsNode]]]. tempHolder ifNil: [ tempHolder _ owner addRow: #tempVariable on: MethodTempsNode new. tempHolder addNoiseString: self noiseBeforeBlockArg. tempHolder submorphs last firstSubmorph emphasis: 1. tempHolder useRoundedCorners. owner addMorph: tempHolder inFrontOf: self. aMorph parseNode name: nn key: nn code: nil. aMorph parseNode asMorphicSyntaxIn: tempHolder. tempHolder cleanupAfterItDroppedOnMe. ^ true]. aMorph parseNode name: nn key: nn code: nil. tempHolder addMorphBack: (tempHolder transparentSpacerOfSize: 4@4). var _ tempHolder addRow: #tempVariable on: aMorph parseNode. var layoutInset: 1. var addMorphBack: (self addString: nn special: false). var cleanupAfterItDroppedOnMe. ^ true! ! !SyntaxMorph methodsFor: 'layout' stamp: 'tk 8/24/2001 15:21'! addUnaryRow: aStringLikeItem style: aSymbol | row sMorph modifiedString fontToUse | (row _ self class row: #text on: nil) borderWidth: 1. modifiedString _ self substituteKeywordFor: aStringLikeItem. sMorph _ self addString: modifiedString special: true. fontToUse _ self fontToUseForSpecialWord: modifiedString. sMorph font: fontToUse emphasis: 1; setProperty: #syntacticReformatting toValue: #unary. modifiedString = aStringLikeItem ifFalse: [ sMorph setProperty: #syntacticallyCorrectContents toValue: aStringLikeItem]. row addMorph: sMorph. self addMorphBack: row. ^row! ! !SyntaxMorph methodsFor: 'layout' stamp: 'tk 8/22/2001 16:30'! isKnownVarName: newVarName "Return true if this variable is already known, as an argument, temp var, block temp, or instance variable." | syntLevel | (self parsedInClass allInstVarNames includes: newVarName) ifTrue: [^ true]. syntLevel _ self. [syntLevel tempVarNodesDo: [:node | node decompile string = newVarName ifTrue: [^ true]]. (syntLevel _ syntLevel owner) isSyntaxMorph] whileTrue. ^ false! ! !SyntaxMorph methodsFor: 'layout' stamp: 'tk 8/22/2001 16:35'! tempVarNodesDo: aBlock "Execute the block for any block temporary variables, method temps, or method args we have" | tempHolder argsHolder | ((self parseNode class == MethodNode) or: [self parseNode class == BlockNode]) ifTrue: [ self submorphsDoIfSyntax: [:sub | (sub nodeClassIs: MethodTempsNode) ifTrue: [tempHolder _ sub]. ((sub nodeClassIs: UndefinedObject) and: [tempHolder isNil]) ifTrue: [ tempHolder _ sub findA: MethodTempsNode]. (sub nodeClassIs: BlockArgsNode) ifTrue: [tempHolder _ sub]. (sub nodeClassIs: SelectorNode) ifTrue: [argsHolder _ sub]. ] ifString: [:sub | ]. tempHolder ifNotNil: ["Temp variables" tempHolder submorphsDoIfSyntax: [:sm | (sm nodeClassIs: TempVariableNode) ifTrue: [aBlock value: sm]] ifString: [:sm | ]]. argsHolder ifNotNil: ["arguments" argsHolder submorphsDoIfSyntax: [:sm | (sm nodeClassIs: TempVariableNode) ifTrue: [aBlock value: sm]] ifString: [:sm | ]]. ]. "otherwise do nothing"! ! !SyntaxMorph methodsFor: 'pop ups' stamp: 'tk 8/29/2001 21:03'! addArgs: howMany "Install new arguments in the MessageNode." ! ! !SyntaxMorph methodsFor: 'pop ups' stamp: 'tk 8/24/2001 13:24'! assignmentArrow "Offer to embed this variable in a new assignment statement. (Don't confuse this with upDownAssignment:, which runs the up and down arrows that rotate among assignment types.)" | rr | self isAVariable ifFalse: [^ nil]. self isDeclaration ifTrue: [^ nil]. ^ (rr _ RectangleMorph new) extent: 11@13; borderWidth: 1; color: Color lightGreen; borderColor: Color gray; addMorph: ((self noiseStringMorph: '_') topLeft: rr topLeft + (3@0)); on: #mouseUp send: #newAssignment to: self ! ! !SyntaxMorph methodsFor: 'pop ups' stamp: 'tk 8/26/2001 14:31'! colorPatch "Return a color patch button that lets the user choose a color and modifies the code" | cc patch sel completeMsg | ((self nodeClassIs: MessageNode) "or: [self nodeClassIs: SelectorNode]") ifFalse: [^ nil]. (sel _ self selector) ifNil: [^ nil]. (Color colorNames includes: sel) | (sel == #r:g:b:) ifFalse: [^ nil]. "a standard color name" completeMsg _ self isNoun ifTrue: [self] ifFalse: [owner isNoun ifTrue: [owner] ifFalse: [owner owner]]. (cc _ completeMsg try) class == Color ifFalse: [^ nil]. patch _ ColorTileMorph new colorSwatchColor: cc. "sends colorChangedForSubmorph: to the messageNode" patch color: Color transparent; borderWidth: 0. patch submorphs last delete. ^ patch! ! !SyntaxMorph methodsFor: 'pop ups' stamp: 'tk 8/28/2001 06:43'! extend | messageNodeMorph first arg | "replace this noun with a new message like (arg + 1). If type is not known, ask the user to type in a selector. Use nil as arg. Let user drag something to it afterwards." "Later do evaluation of self to see what type and offer right selector" self deselect. messageNodeMorph _ (MessageSend receiver: 1 selector: #+ arguments: #(1)) asTilesIn: Player. owner replaceSubmorph: self by: messageNodeMorph. first _ messageNodeMorph submorphs detect: [:mm | mm isSyntaxMorph]. messageNodeMorph replaceSubmorph: first by: self. " arg _ (messageNodeMorph findA: MessageNode) findA: LiteralNode. arg ifNotNil: [arg isSyntaxMorph ifTrue: [ arg listDirection: #leftToRight]." "not a column. For its popup" self acceptIfInScriptor.! ! !SyntaxMorph methodsFor: 'pop ups' stamp: 'tk 8/24/2001 13:14'! extendArrow "Return the extend arrow button. It replaces the argument with a new message. I am a number or getter messageNode." | patch | self isNoun ifFalse: [^ nil]. self isDeclaration ifTrue: [^ nil]. patch _ (ImageMorph new image: (TileMorph classPool at: #SuffixPicture)). patch on: #mouseDown send: #extend to: self. ^ patch! ! !SyntaxMorph methodsFor: 'pop ups' stamp: 'tk 8/24/2001 13:04'! newAssignment "I am a variableNode. Place me inside an assignment statement." | new old | new _ owner assignmentNode: AssignmentNode new variable: parseNode value: parseNode copy. self deselect. (old _ owner) replaceSubmorph: self by: new. "do the normal replacement" (old isSyntaxMorph) ifTrue: [old cleanupAfterItDroppedOnMe]. "now owned by no one" ! ! !SyntaxMorph methodsFor: 'pop ups' stamp: 'tk 8/24/2001 13:15'! offerPopUp "Put up a halo to allow user to change Literals (Integer, true), Selector (beep: sound, +,-,*,//,\\, r:g:b:, setX: incX: decX: for any X,), Variable (Color), not AssignmentNode (_ inc dec), Extend arrows on each literal, variable, and message, (block that is by itself). Retract arrows on each literal or variable, or message or block that is an argument. Any literal can be changed by Shift-clicking and typing." | panel any upDown retract extend colorPatch edge dismiss rr assign | (self hasProperty: #myPopup) ifTrue: [^ self]. "already has one" any _ false. (upDown _ self upDownArrows) ifNotNil: [any _ true]. (retract _ self retractArrow) ifNotNil: [any _ true]. (extend _ self extendArrow) ifNotNil: [any _ true]. (dismiss _ self dismisser) ifNotNil: [any _ true]. (assign _ self assignmentArrow) ifNotNil: [any _ true]. submorphs last class == ColorTileMorph ifFalse: [ (colorPatch _ self colorPatch) ifNotNil: [any _ true]]. any ifFalse: [^ self]. "Transcript cr; print: parseNode class; space; print: (self hasProperty: #myPopup); endEntry." panel _ RectangleMorph new color: Color transparent; borderWidth: 0. upDown ifNotNil: [ panel addMorphBack: upDown first. upDown first align: upDown first topLeft with: panel topLeft + (0@0). panel addMorphBack: upDown second. upDown second align: upDown second topLeft with: upDown first bottomLeft + (0@1). upDown size > 2 ifTrue: [ panel addMorphBack: upDown third. upDown third align: upDown third topLeft with: upDown first topRight + (2@3). ]]. rr _ self right. colorPatch ifNotNil: [ rr _ rr + colorPatch submorphs first width + 1. self addMorphBack: colorPatch. "always in tile" "colorPatch align: colorPatch topLeft with: panel topLeft + (1@1)"]. retract ifNotNil: [ edge _ panel submorphs size = 0 ifTrue: [panel left] ifFalse: [panel submorphs last right]. panel addMorphBack: retract. retract align: retract topLeft with: (edge+2) @ (panel top + 3)]. extend ifNotNil: [ edge _ panel submorphs size = 0 ifTrue: [panel left] ifFalse: [panel submorphs last right]. panel addMorphBack: extend. extend align: extend topLeft with: (edge+2) @ (panel top + 3)]. dismiss ifNotNil: [ edge _ panel submorphs size = 0 ifTrue: [panel left] ifFalse: [panel submorphs last right]. panel addMorphBack: dismiss. dismiss align: dismiss topLeft with: (edge+2) @ (panel top + 1)]. assign ifNotNil: [ edge _ panel submorphs size = 0 ifTrue: [panel left] ifFalse: [panel submorphs last right]. panel addMorphBack: assign. assign align: assign topLeft with: (edge+2) @ (panel top + 2)]. panel align: panel topLeft with: rr @ (self top -2). panel extent: panel submorphs last bottomRight - panel topLeft. self setProperty: #myPopup toValue: panel. self addMorphBack: panel. "Any reason ever to have panel below?" "(owner listDirection = #topToBottom and: [self listDirection = #leftToRight]) ifTrue: [self addMorphBack: panel] ifFalse: [owner addMorph: panel after: self]." ! ! !SyntaxMorph methodsFor: 'pop ups' stamp: 'tk 8/29/2001 21:01'! replaceSel: evt menuItem: stringMorph "I rep a SelectorNode. Replace my selector with new one that was just chosen from a menu" | menu new old newSel ms oa na case | (menu _ stringMorph owner owner) class == RectangleMorph ifTrue: [ menu delete]. new _ stringMorph contents. new first = $( ifTrue: [^ self]. "Cancel" new first = $ ifTrue: [^ self]. "nothing" new _ String streamContents: [:strm | "remove fake args" (new findBetweenSubStrs: #(' 5' $ )) do: [:part | strm nextPutAll: part]]. newSel _ stringMorph valueOfProperty: #syntacticallyCorrectContents. newSel ifNil: [newSel _ new]. old _ (ms _ self findA: StringMorph) valueOfProperty: #syntacticallyCorrectContents. old ifNil: [old _ (self findA: StringMorph) contents]. oa _ old numArgs. na _ newSel numArgs. case _ 5. (oa = 1) & (na = 1) ifTrue: [case _ 1]. (oa = 0) & (na = 0) ifTrue: [case _ 2]. (oa = 1) & (na = 0) ifTrue: [case _ 3]. (oa = 0) & (na = 1) ifTrue: [case _ 4]. case <= 4 ifTrue: [ ms contents: new. ms setProperty: #syntacticallyCorrectContents toValue: newSel. self acceptIfInScriptor]. case = 3 ifTrue: [^ owner tossOutArgs: 1]. case = 4 ifTrue: [^ owner addArgs: 1]. "more cases here"! ! !SyntaxMorph methodsFor: 'pop ups' stamp: 'tk 8/26/2001 15:26'! selectorMenu "Put up a menu of all selectors that my receiver could be sent. Replace me with the one chosen. (If fewer args, put the tiles for the extra arg to the side, in script's owner (world?).) Go ahead and eval receiver to find out its type. Later, mark selectors for side effects, and don't eval those. Put up a table. Each column is a viewer category." | rec cats value catNames interfaces list setter wording all words ind aVocabulary limitClass | rec _ owner receiverNode. rec ifNil: [rec _ owner owner receiverNode]. rec ifNil: [rec _ owner owner owner receiverNode]. cats _ #(). all _ Set new. value _ rec ifNotNil: [rec try]. value class == Error ifTrue: [value _ Vocabulary instanceWhoRespondsTo: self selector]. value class == Error ifTrue: [^ nil]. aVocabulary _ self vocabularyToUseWith: value. limitClass _ self limitClassToUseWith: value vocabulary: aVocabulary. catNames _ value categoriesForVocabulary: aVocabulary limitClass: limitClass. cats _ catNames collect: [:nn | list _ OrderedCollection new. interfaces _ value methodInterfacesForCategory: nn inVocabulary: aVocabulary limitClass: limitClass. interfaces do: [:mi | (all includes: mi selector) ifFalse: [ "list add: (self aSimpleStringMorphWith: mi elementWording). Expensive" words _ mi selector. (words beginsWith: 'get ') ifTrue: [words _ words allButFirst: 4]. mi selector last == $: ifTrue: [ words _ String streamContents: [:strm | "add fake args" (words findTokens: $:) do: [:part | strm nextPutAll: part; nextPutAll: ' 5 ']]. words _ words allButLast]. mi selector isInfix ifTrue: [words _ words, ' 5']. words _ self splitAtCapsAndDownshifted: words. list add: (self anUpdatingStringMorphWith: words special: true). words = mi selector ifFalse: [ list last setProperty: #syntacticallyCorrectContents toValue: mi selector]. all add: mi selector]. setter _ mi companionSetterSelector asString. (setter = 'nil') | (all includes: setter) ifFalse: ["need setters also" wording _ (self translateToWordySetter: setter). list add: (self aSimpleStringMorphWith: wording, ' 5'). wording = setter ifFalse: [ list last setProperty: #syntacticallyCorrectContents toValue: setter]. all add: setter]]. list]. (ind _ catNames indexOf: 'scripts') > 0 ifTrue: [ (cats at: ind) first contents = 'empty script' ifTrue: [(cats at: ind) removeFirst]]. cats first addFirst: (self aSimpleStringMorphWith: ' '). "spacer" cats first addFirst: (self aSimpleStringMorphWith: '( from ', value class name, ' )'). cats first first color: (Color green mixed: 0.25 with: Color black). self selectorMenuAsk: cats. "The method replaceSel:menuItem: does the work. and replaces the selector." ! ! !SyntaxMorph methodsFor: 'pop ups' stamp: 'tk 8/26/2001 15:24'! selectorMenuAsk: listOfLists "I represent a SelectorNode to be replaced by one of the selectors in one of the category lists. Each list has pre-built StringMorphs in it." | menu col | listOfLists isEmpty ifTrue: [^ nil]. listOfLists first addFirst: (self aSimpleStringMorphWith: '( Cancel )'). listOfLists first first color: Color red. menu _ RectangleMorph new. menu listDirection: #leftToRight; layoutInset: 3; cellInset: 1@0. menu layoutPolicy: TableLayout new; hResizing: #shrinkWrap; vResizing: #shrinkWrap; color: (Color r: 0.767 g: 1.0 b: 0.767); useRoundedCorners; cellPositioning: #topLeft. listOfLists do: [:ll | col _ Morph new. col listDirection: #topToBottom; layoutInset: 0; cellInset: 0@0. col layoutPolicy: TableLayout new; hResizing: #shrinkWrap. col color: Color transparent; vResizing: #shrinkWrap. menu addMorphBack: col. ll do: [:ss | col addMorphBack: ss. ss on: #mouseUp send: #replaceSel:menuItem: to: self] ]. self world addMorph: menu. menu setConstrainedPosition: (owner localPointToGlobal: self topRight) + (10@-30) hangOut: false. ! ! !SyntaxMorph methodsFor: 'pop ups' stamp: 'tk 8/24/2001 15:34'! setSelector: stringLike in: stringMorph | aSymbol myType str | "store the new selector and accept method" aSymbol _ stringLike asSymbol. self setBalloonText: (ScriptingSystem helpStringForOperator: aSymbol). myType _ stringMorph valueOfProperty: #syntacticReformatting ifAbsent: [#none]. str _ aSymbol. (self isStandardSetterKeyword: str) ifTrue: [str _ self translateToWordySetter: str]. (self isStandardGetterSelector: str) ifTrue: [str _ self translateToWordyGetter: str]. (self shouldBeBrokenIntoWords: myType) ifTrue: [str _ self substituteKeywordFor: str]. stringMorph contents: str. "parseNode key: aSymbol code: nil." str = stringLike ifFalse: [ stringMorph setProperty: #syntacticallyCorrectContents toValue: aSymbol]. self acceptSilently. ! ! !SyntaxMorph methodsFor: 'pop ups' stamp: 'tk 8/29/2001 21:02'! tossOutArgs: howMany "remove those args from the MessageNode and put them in the world." submorphs reverseDo: [:sub | ].! ! !SyntaxMorph methodsFor: 'pop ups' stamp: 'tk 8/24/2001 13:35'! upDown: delta event: evt arrow: arrowMorph | st | st _ submorphs detect: [:mm | mm isKindOf: StringMorph] ifNone: [^ self]. (self nodeClassIs: LiteralNode) ifTrue: [ "+/- 1" st contents: (self decompile asNumber + delta) printString. ^ self acceptUnlogged]. (self nodeClassIs: VariableNode) ifTrue: [ "true/false" st contents: (self decompile string = 'true') not printString. ^ self acceptSilently ifFalse: [self changed]. "maybe set parseNode's key"]. (self upDownArithOp: delta) ifTrue: [^ self]. "+ - // * < > <= = beep:" (self upDownAssignment: delta) ifTrue: [^ self]. "Handle assignment -- increaseBy: <- multiplyBy:" ! ! !SyntaxMorph methodsFor: 'pop ups' stamp: 'tk 8/24/2001 13:43'! upDownArrows "Return an array of two up/down arrow buttons. It replaces the selector or arg with a new one. I am a number or boolean or a selector (beep:, +,-,*,//,\\, or setX: incX: decX: for any X." | patch any noMenu | any _ (self nodeClassIs: LiteralNode) and: [parseNode key isNumber]. any _ any or: [(self nodeClassIs: VariableNode) and: [(#('true' 'false') includes: self decompile asString)]]. noMenu _ any. any _ any or: [self nodeClassIs: SelectorNode]. "all of them" any ifFalse: [^ nil]. patch _ {(ImageMorph new image: TileMorph upPicture) on: #mouseDown send: #upDown:event:arrow: to: self withValue: 1; on: #mouseStillDown send: #upDownMore:event:arrow: to: self withValue: 1; on: #mouseUp send: #upDownDone to: self. (ImageMorph new image: TileMorph downPicture) on: #mouseDown send: #upDown:event:arrow: to: self withValue: -1; on: #mouseStillDown send: #upDownMore:event:arrow: to: self withValue: -1; on: #mouseUp send: #upDownDone to: self}. noMenu ifFalse: [patch _ patch, {(RectangleMorph new) extent: 6@10; borderWidth: 1; color: Color lightGreen; borderColor: Color gray; on: #mouseUp send: #selectorMenu to: self}]. ^ patch! ! !SyntaxMorph methodsFor: 'pop ups' stamp: 'tk 8/24/2001 12:33'! upDownAssignment: delta "Rotate between increaseBy: decreaseBy: _ multiplyBy:" | st now want instVar | st _ submorphs detect: [:mm | mm isKindOf: StringMorph] ifNone: [^ self]. (self nodeClassIs: SelectorNode) ifTrue: ["kinds of assignment" ((now _ self decompile asString) beginsWith: 'set') ifTrue: ["a setX: 3" want _ 1+delta. instVar _ (now allButFirst: 3) allButLast]. (now endsWith: 'IncreaseBy:') ifTrue: ["a xIncreaseBy: 3 a setX: (a getX +3)." want _ 2+delta. instVar _ now allButLast: 11]. (now endsWith: 'DecreaseBy:') ifTrue: ["a xDecreaseBy: 3 a setX: (a getX -3)." want _ 3+delta. instVar _ now allButLast: 11]. (now endsWith: 'MultiplyBy:') ifTrue: ["a xMultiplyBy: 3 a setX: (a getX *3)." want _ 4+delta. instVar _ now allButLast: 11]. want ifNil: [^ false]. instVar _ instVar asLowercase. want _ #(1 2 3 4) atWrap: want. want = 1 ifTrue: ["setter method is present" self setSelector: ('set', instVar capitalized, ':') in: st. ^ true]. want = 2 ifTrue: ["notUnderstood will create the method if needed" self setSelector: instVar, 'IncreaseBy:' in: st. ^ true]. want = 3 ifTrue: ["notUnderstood will create the method if needed" self setSelector: instVar, 'DecreaseBy:' in: st. ^ true]. want = 4 ifTrue: ["notUnderstood will create the method if needed" self setSelector: instVar, 'MultiplyBy:' in: st. ^ true]. ]. ^ false ! ! !SyntaxMorph methodsFor: 'menus' stamp: 'tk 8/24/2001 13:34'! acceptSilently "Turn my current state into the text of a method. Compile it in my class. Don't rebuild the tiles." | cls | self isMethodNode ifFalse: [ self rootTile == self ifTrue: [^ false]. "not in a script" ^ self rootTile acceptSilently "always accept at the root"]. (self ownerThatIsA: ScriptEditorMorph) ifNil: [^ false]. (cls _ self parsedInClass) ifNil: [^ false]. cls compile: self decompile notifying: nil. ^ true! ! !SyntaxMorph methodsFor: 'menus' stamp: 'tk 8/24/2001 15:19'! addToken: aString type: aColorOrSymbol on: aNode | sMorph modifiedString noiseWord row | row _ (self addRow: aColorOrSymbol on: aNode) layoutInset: 1. self alansTest1 ifFalse: [ sMorph _ self addString: aString special: false. row addMorphBack: sMorph. ^row ]. noiseWord _ [ :w | w ifNotNil: [ row addMorphBack: (self noiseStringMorph: w); addMorphBack: (self tokenVerticalSeparator) ]. ]. (self shouldBeBrokenIntoWords: aColorOrSymbol) ifTrue: [ modifiedString _ self substituteKeywordFor: aString. sMorph _ self addString: modifiedString special: (aColorOrSymbol ~= #assignmentArrow). "(#(unary keywordGetz keywordSetter unaryGetter) includes: aColorOrSymbol)" modifiedString = aString ifFalse: [ sMorph setProperty: #syntacticallyCorrectContents toValue: aString]. sMorph setProperty: #syntacticReformatting toValue: aColorOrSymbol; contents: modifiedString. ] ifFalse: [ sMorph _ self addString: (modifiedString _ aString) special: false. ]. (#(keyword2 upArrow) includes: aColorOrSymbol) ifTrue: [ sMorph font: (self fontToUseForSpecialWord: modifiedString). ]. (#(keyword2 unary assignmentArrow methodHeader1 methodHeader2) includes: aColorOrSymbol) ifTrue: [ sMorph emphasis: 1. ]. aColorOrSymbol == #blockarg1 ifTrue: [ ]. (aColorOrSymbol == #variable or: [aColorOrSymbol == #tempVariable]) ifTrue: [ aString = 'self' ifTrue: [ sMorph setProperty: #wordyVariantOfSelf toValue: true. ]. noiseWord value: (self noiseWordBeforeVariableNode: aNode string: aString). ]. row addMorphBack: sMorph. ^row! ! !SyntaxMorph methodsFor: 'menus' stamp: 'tk 8/30/2001 06:22'! instVarTile: aName "Make and put into hand a tile for an instance variable" | sm | sm _ ((VariableNode new name: aName index: 1 type: 1 "LdInstType") asMorphicSyntaxIn: SyntaxMorph new). sm roundedCorners. ActiveHand attachMorph: sm. Preferences tileTranslucentDrag ifTrue: [sm lookTranslucent. sm align: sm center with: ActiveHand position "+ self cursorBaseOffset"] ifFalse: [sm align: sm topLeft with: ActiveHand position + self cursorBaseOffset] ! ! !SyntaxMorph methodsFor: 'menus' stamp: 'tk 8/28/2001 09:06'! showMenu: evt | menu | menu _ MenuMorph new. menu add: 'new temp variable tile' target: self selector: #tempVarTile. self rootTile isMethodNode ifTrue: [menu add: 'accept method' target: self selector: #accept]. menu addLine. self parsedInClass allInstVarNames do: [:nn | menu add: nn,' tile' target: self selector: #instVarTile: argument: nn]. menu addLine. menu add: 'show code' target: self selector: #showCode. menu add: 'try out' target: self selector: #try. menu popUpAt: evt hand position forHand: evt hand in: World. ! ! !SyntaxMorph methodsFor: 'menus' stamp: 'tk 8/28/2001 09:51'! tempVarTile "Make and put into hand a tile for a new temp variable" | enc sm | enc _ self rootTile parseNode encoder ifNil: [Encoder new]. sm _ ((enc newTemp: 'temp') asMorphicSyntaxIn: SyntaxMorph new). sm roundedCorners. ActiveHand attachMorph: sm. Preferences tileTranslucentDrag ifTrue: [sm lookTranslucent. sm align: sm center with: ActiveHand position "+ self cursorBaseOffset"] ifFalse: [sm align: sm topLeft with: ActiveHand position + self cursorBaseOffset] ! ! !SyntaxMorph methodsFor: 'node to morph' stamp: 'tk 8/24/2001 15:27'! alanKwdSetter2: aNode isAConditional: template key: key args: args "translates foo setHeading: 0 to foo's heading _ 0 " | kwdHolder wordy | kwdHolder _ self addToken: key type: #keywordSetter on: (SelectorNode new key: key code: nil "fill this in?"). wordy _ self translateToWordySetter: key. kwdHolder firstSubmorph setProperty: #syntacticReformatting toValue: #keywordSetter; contents: wordy; emphasis: 1. wordy = key asString ifFalse: [ kwdHolder firstSubmorph setProperty: #syntacticallyCorrectContents toValue: key asString]. (args first asMorphicSyntaxIn: self) setConditionalPartStyle ! ! !SyntaxMorph methodsFor: 'node to morph' stamp: 'tk 8/24/2001 15:28'! alanUnaryGetter: aNode key: key "I am a MessageNode. Fill me with a SelectorNode {getX} whose string is {'s x}. All on one level." | selSyn usm wordy | selSyn _ self addToken: key type: #unaryGetter on: (SelectorNode new key: key code: nil "fill this in?"). usm _ selSyn firstSubmorph. usm setProperty: #syntacticReformatting toValue: #unaryGetter. wordy _ self translateToWordyGetter: key. wordy = key asString ifFalse: [ usm setProperty: #syntacticallyCorrectContents toValue: key asString]. usm contents: wordy; emphasis: 1. ! ! !SyntaxMorph methodsFor: 'alans styles' stamp: 'tk 9/2/2001 20:21'! splitAtCapsAndDownshifted: aString ^String streamContents: [ :strm | aString do: [ :each | each = $: ifFalse: [ each isUppercase ifTrue: [strm nextPut: (Character value: 0); nextPut: (Character value: 0); nextPut: (Character value: 0); nextPut: each asLowercase] ifFalse: [strm nextPut: each] ]. ] ].! ! !SyntaxUpdatingStringMorph methodsFor: 'as yet unclassified' stamp: 'tk 9/2/2001 20:07'! drawOn: aCanvas | tempForm scanner strm where chars wid spaceWidth putLigature topOfLigature sizeOfLigature colorOfLigature dots charZero | tempForm _ Form extent: self extent depth: aCanvas depth. scanner _ DisplayScanner quickPrintOn: tempForm box: tempForm boundingBox font: self fontToUse. spaceWidth _ scanner stringWidth: ' '. strm _ ReadStream on: contents. charZero _ Character value: 0. "a marker for center dot ¥" where _ 0@0. topOfLigature _ self height // 2 - 1. sizeOfLigature _ (spaceWidth-2)@(spaceWidth-2). colorOfLigature _ Color black alpha: 0.45 "veryLightGray". dots _ OrderedCollection new. putLigature _ [ dots add: ((where x + 1) @ topOfLigature extent: sizeOfLigature). where _ where + (spaceWidth@0)]. strm peek = charZero ifTrue: [ strm next. putLigature value]. [strm peek = charZero] whileTrue: [strm next]. [strm atEnd] whileFalse: [ chars _ strm upTo: charZero. wid _ scanner stringWidth: chars. scanner drawString: chars at: where. where _ where + (wid@0). strm atEnd ifFalse: [putLigature value. [strm peek = charZero] whileTrue: [strm next]]. ]. aCanvas paintImage: tempForm at: self topLeft. dots do: [ :each | aCanvas fillRectangle: (each translateBy: self topLeft) fillStyle: colorOfLigature. ]. ! ! !Vocabulary class methodsFor: 'access' stamp: 'tk 8/24/2001 09:24'! instanceWhoRespondsTo: aSelector "Find the most likely class that responds to aSelector. Return an instance of it. Look in vocabularies to match the selector." "Most eToy selectors are for Players" | mthRefs | ((self vocabularyNamed: #eToy) includesSelector: aSelector) ifTrue: [ aSelector == #+ ifFalse: [^ Player new costume: Morph new]]. "Numbers are a problem" ((self vocabularyNamed: #Number) includesSelector: aSelector) ifTrue: [ ^ 1]. "Is a Float any different?" #("String Point Time Date") do: [:nn | ((self vocabularyNamed: nn) includesSelector: aSelector) ifTrue: [ "Ask Scott how to get a prototypical instance" ^ (Smalltalk at: nn) new]]. mthRefs _ Smalltalk allImplementorsOf: aSelector. "every one who implements the selector" mthRefs sortBlock: [:a :b | (Smalltalk at: a classSymbol) allSuperclasses size < (Smalltalk at: b classSymbol) allSuperclasses size]. mthRefs size > 0 ifTrue: [^ (Smalltalk at: mthRefs first classSymbol) new]. ^ Error new! ! SyntaxMorph removeSelector: #assignmentArrows! !SyntaxMorph reorganize! ('initialization' inAPluggableScrollPane inAScrollPane openInWindow returnNode:expression: sample:) ('accessing' actualObject cleanUpString: color: editor externalName fillStyle: getCurrentValue immediatelyBelowTheMethodNode isLeafTile parseNode parseNode: parsedInClass parsedInClass: receiverNode rename: unSpaceAndUpShift:appending: userScriptSelector userScriptSelector:) ('node types' findA: isAVariable isBlockNode isCascadePart isDeclaration isMethodNode isNoun isSyntaxMorph nodeClassIs: rootTile) ('event handling' cursorBaseOffset handlesKeyboard: handlesMouseDown: handlesMouseOver: handlesMouseOverDragging: keyStroke: mouseDown: mouseEnter: mouseEnterDragging: mouseLeave: mouseLeaveDragging: mouseMove: mouseUp: step stepTime wantsSteps) ('dropping/grabbing' acceptDroppingMorph:event: cleanupAfterItDroppedOnMe justDroppedInto:event: morphToDropInPasteUp: structureMatchWith: wantsDroppedMorph:event:) ('drawing' drawOn: lookTranslucent) ('highlighting' borderColor: compoundBorderColor dropColor grabColor highlightForDrop: highlightForGrab: stdBorderColor unhighlight unhighlightBorder unhighlightOwner unhighlightOwnerBorder) ('selection' currentSelectionDo: deselect isSelectable scaleColorByUserPref: select setDeselectedColor setSelection: wantsKeyboardFocusFor:) ('insertion drop zones' removeDropZones trackDropZones) ('layout' addBlockArg: addNoiseString: addNoiseString:emphasis: addRow:on: addSingleKeywordRow: addString:special: addTempVar: addTextRow: addToBlock:event: addUnaryRow:style: foldMessage foldMessageOneArg isKnownVarName: removeReturnNode tempVarNodesDo: try unfoldMessage) ('printing' getHeader: printBlockArgsNodeOn:indent: printBlockNodeOn:indent: printCascadeNodeOn:indent: printMessageNodeOn:indent: printMethodNodeOn:indent: printMethodTempsNodeOn:indent: printOn: printOn:indent: printSimpleStringMorph:on: printStatementsOn:indent: printVariableNodeOn:indent: structure submorphsDoIfSyntax:ifString: submorphsDoIfSyntax:ifString:otherwise:) ('pop ups' addArgs: assignmentArrow changeSound: colorChangedForSubmorph: colorPatch deleteLine deletePopup dismisser event:arrow:upDown: extend extendArrow newAssignment offerPopUp replaceSel:menuItem: retract retractArrow selectorMenu selectorMenuAsk: setSelector:in: tossOutArgs: upDown:event:arrow: upDownArithOp: upDownArrows upDownAssignment: upDownDone upDownMore:event:arrow:) ('menus' accept acceptIfInScriptor acceptIgnoring: acceptSilently acceptUnlogged addColumn:on: addMorphBack: addToken:type:on: addTokenSpecialCase:type:on: decompile finalAppearanceTweaks getMenuBlock instVarTile: showCode showMenu: tempVarTile) ('debugging' balloonText debugger debugger: hostContext update:) ('tests' changed test testForNode:andDo: toDo) ('type checking' allSpecs argTypeFor: currentVocabulary okToBeReplacedBy: receiverOrArgType receiverOrArgTypeAbove receiverTypeFor: resultType resultTypeFor: selector) ('node to morph' addTemporaries: addTemporaryControls alanBinaryPostRcvr:key:args: alanKeywordMessage:isAConditional:key:args: alanKwdCollect:isAConditional:key:args: alanKwdIfDo:isAConditional:key:args: alanKwdRepeatForDoing:isAConditional:key:args: alanKwdSetter2:isAConditional:key:args: alanKwdSetter:isAConditional:key:args: alanUnaryGetter:key: alanUnaryPostRcvr:key:selector: alansMessageNode:receiver:selector:keywords:arguments: assignmentNode:variable:value: blockNode:arguments:statements: blockNodeCollect:arguments:statements: cascadeNode:receiver:messages: changeBasicStyle isStandardGetterSelector: isStandardSetterKeyword: messageNode:receiver:selector:keywords:arguments: messageOneArg:receiver:selector:args: methodNodeInner:selectorOrFalse:precedence:arguments:temporaries:primitive:block: methodNodeOuter: vanillaMessageNode:receiver:selector:arguments:) ('formatting options' alansTest1 controlContrast2: controlContrast: controlSpacing2: controlSpacing: lookClassic usingClassicTiles) ('alans styles' aSimpleStringMorphWith: alansCurrentFontPreference alansTemplateStyleFor: anUpdatingStringMorphWith:special: constructSelfVariant:and: darkerColor fontToUseForSpecialWord: lighterColor noiseBeforeBlockArg noiseStringMorph: noiseWordBeforeVariableNode:string: setConditionalPartStyle setSpecialOuterTestFormat setSpecialTempDeclarationFormat1 setSpecialTempDeclarationFormat2 shouldBeBrokenIntoWords: specialColor:andBorder: splitAtCapsAndDownshifted: standardCellPositioning standardInset substituteKeywordFor: tokenVerticalSeparator translateFromWordySelfVariant: translateToWordyGetter: translateToWordySelfVariant: translateToWordySetter:) ('vocabulary' limitClassToUseWith:vocabulary: vocabularyToUseWith:) !