'From Squeak3.1alpha of 4 February 2001 [latest update: #3585] on 13 February 2001 at 9:21:06 pm'! "Change Set: ProjStore16-tk Date: 13 February 2001 Author: Ted Kaehler Type checking for universal tiles when the EToyFriendly preference is set. Attempts to duplicate the rules that prevent errors from happening in EToys when a tile is dropped on the wrong kind of thing."! AlignmentMorph subclass: #SyntaxMorph instanceVariableNames: 'parseNode markerMorph ' classVariableNames: 'AllSpecs ' poolDictionaries: '' category: 'Morphic-Tile Scriptors'! !SyntaxMorph commentStamp: 'tk 2/9/2001 15:13' prior: 0! A single class of morph that holds any piece of Smalltalk, and allows it to be a tile. Tiles can be dragged in or out of a method. In the message list pane of a Browser, choose 'tile scriptor'. Bring up a second one to steal parts from. Clicking multiple times selects enclosing phrases of code. Dragging lets you take away a copy. Any tile may be replaced by dropping on it. Shift-click to edit the text of any tile. Change variable and message names, but do not change the part-of-speech (objects to selector). Each SyntaxMorph holds a ParseNode. After editing, the parseNode is only good as a part-of-speech indicator. Only the classes of the parseNodes are important. It's state is not kept up to date with the tile edits (but maybe it should be). The correspondence between SyntaxMorphs and parseNodes in the real parse tree is not one-to-one. Several extra levels of SyntaxMorph were added as aligners to make the horizontal and vertical layout right. These sometimes have nil for the parseNode. When accept the method, we pass over the tree of SyntaxMorphs, gathering their printStrings and inserting punctuation. See (SyntaxMorph>>printOn:indent:). We send the result to the compiler. (We do not use the parse tree we already have.) To turn on type checking: Preferences enable: #eToyFriendly or for testing: World project projectParameters at: #fullCheck put: true.! !Presenter methodsFor: 'viewer' stamp: 'tk 2/12/2001 16:37'! cacheSpecs: aMorph "For SyntaxMorph's type checking, cache the list of all viewer command specifications." aMorph world ifNil: [^ true]. (aMorph world valueOfProperty: #universalTiles ifAbsent: [false]) ifFalse: [^ true]. Preferences eToyFriendly ifFalse: [^ true]. "not checking" (Project current projectParameters at: #fullCheck ifAbsent: [false]) ifFalse: [^ true]. "not checking" SyntaxMorph initialize.! ! !Presenter methodsFor: 'viewer' stamp: 'tk 2/12/2001 16:38'! viewMorph: aMorph | aPlayer aViewer aPalette aRect aPoint nominalHeight aFlapTab topItem flapLoc | Sensor leftShiftDown ifFalse: [((aPalette _ aMorph standardPalette) ~~ nil and: [aPalette isInWorld]) ifTrue: [^ aPalette viewMorph: aMorph]]. aPlayer _ (topItem _ aMorph topRendererOrSelf) assuredPlayer. aViewer _ self nascentPartsViewer. self cacheSpecs: topItem. "redo the spec cache once in a while" "19 sept 2000 - allow flaps in any paste up" flapLoc _ associatedMorph "world". Preferences viewersInFlaps ifTrue: [aViewer setProperty: #noInteriorThumbnail toValue: true. aViewer initializeFor: aPlayer barHeight: 0. aViewer enforceTileColorPolicy. aViewer fullBounds. "force layout" "associatedMorph addMorph: aViewer." "why???" flapLoc hideViewerFlapsOtherThanFor: aPlayer. aFlapTab _ flapLoc viewerFlapTabFor: topItem. aFlapTab referent submorphs do: [:m | (m isKindOf: Viewer) ifTrue: [m delete]]. aViewer visible: true. aFlapTab applyThickness: aViewer width + 25. aFlapTab spanWorld. aFlapTab showFlap. aViewer position: aFlapTab referent position. aFlapTab referent addMorph: aViewer beSticky. "moved" flapLoc startSteppingSubmorphsOf: aFlapTab. flapLoc startSteppingSubmorphsOf: aViewer. ^ aFlapTab]. aViewer initializeFor: aPlayer barHeight: 6. aViewer enforceTileColorPolicy. aViewer fullBounds. "force layout" Preferences automaticViewerPlacement ifTrue: [aPoint _ aMorph bounds right @ (aMorph center y - ((nominalHeight _ aViewer initialHeightToAllow) // 2)). aRect _ (aPoint extent: (aViewer width @ nominalHeight)) translatedToBeWithin: flapLoc bounds. aViewer position: aRect topLeft. aViewer visible: true. associatedMorph addMorph: aViewer. flapLoc startSteppingSubmorphsOf: aViewer. "it's already in the world, somewhat coincidentally" ^ aViewer]. aMorph primaryHand attachMorph: (aViewer visible: true). ^ aViewer! ! !ScriptEditorMorph methodsFor: 'other' stamp: 'tk 2/13/2001 20:24'! unhibernate | ww | "Recreate my tiles from my method. If I have new universal tiles." (ww _ self world) ifNil: [playerScripted ifNil: [^ self]. playerScripted isUniversalTiles ifFalse: [^ self]] ifNotNil: [ (ww valueOfProperty: #universalTiles ifAbsent: [false]) ifFalse: [^ self]]. self showSourceInScriptor. self hResizing: #shrinkWrap; vResizing: #shrinkWrap; cellPositioning: #topLeft.! ! !SyntaxMorph methodsFor: 'type checking' stamp: 'tk 2/9/2001 10:07'! allSpecs | all pairs clsName | "Return all specs that the Viewer knows about. Maybe cache it." "SyntaxMorph new allSpecs" all _ OrderedCollection new. pairs _ Smalltalk allImplementorsOf: #additionsToViewerCategories. pairs do: [:pp | clsName _ (pp findTokens: ' ') first. all addAll: (Smalltalk at: clsName asSymbol) additionsToViewerCategories]. ^ all! ! !SyntaxMorph methodsFor: 'type checking' stamp: 'tk 2/12/2001 16:26'! argTypeFor: aSelector | where | "Search for the type of the argument of this selector. Return #unknown if not found." where _ aSelector numArgs = 0 ifTrue: [self inform: aSelector, ' does not take an argument'. ^ #error "7"] ifFalse: [9]. self class allSpecs do: [:catPair | catPair second do: [:spec | spec first == #command ifTrue: [ spec second == aSelector ifTrue: ["ours" spec size < 4 ifTrue: [^ #unknown] ifFalse: [^ spec fourth]]]. spec first == #slot ifTrue: [ spec size >= where ifTrue: [ (spec at: where) == aSelector ifTrue: ["ours" ^ spec fourth]]]. ]]. ^ #unknown "What if the same selector appears more than one time?"! ! !SyntaxMorph methodsFor: 'type checking' stamp: 'tk 2/13/2001 20:25'! okToBeReplacedBy: aSyntaxMorph | itsType myType | "Return true if it is OK to replace me with aSyntaxMorph. Enforce the type rules in the old EToy green tiles. World project projectParameters at: #fullCheck put: true. " ((Preferences eToyFriendly) or: [self world project projectParameters at: #fullCheck ifAbsent: [false]]) ifFalse: [^ true]. "not checking" (parseNode class == BlockNode and: [aSyntaxMorph parseNode class == BlockNode]) ifTrue: [^ true]. (parseNode class == ReturnNode and: [aSyntaxMorph parseNode class == ReturnNode]) ifTrue: [^ true]. parseNode class == KeyWordNode ifTrue: [^ false]. aSyntaxMorph parseNode class == KeyWordNode ifTrue: [^ false]. parseNode class == SelectorNode ifTrue: [^ false]. aSyntaxMorph parseNode class == SelectorNode ifTrue: [^ false]. owner isSyntaxMorph ifFalse: [^ true]. "only within a script" "Transcript show: aSyntaxMorph resultType printString, ' dropped on ', self receiverOrArgType printString; cr. " (itsType _ aSyntaxMorph resultType) == #unknown ifTrue: [^ true]. (myType _ self receiverOrArgType) == #unknown ifTrue: [^ true]. "my type in enclosing message" ^ myType = itsType ! ! !SyntaxMorph methodsFor: 'type checking' stamp: 'tk 2/9/2001 15:56'! receiverOrArgType | ty | "Return my type in my role as a receiver or as an argument. Ask my enclosing message first, then ask myself. (If owner accepts any #object, and I am a #point, do return #object.)" ^ (ty _ self receiverOrArgTypeAbove) == #unknown ifTrue: [self resultType] ifFalse: [ty]! ! !SyntaxMorph methodsFor: 'type checking' stamp: 'tk 2/13/2001 15:33'! receiverOrArgTypeAbove | enclosing sub list | "Return the type for me according to the message that encloses me." (self nodeClassIs: BlockNode) ifTrue: [^ #command]. enclosing _ owner. sub _ self. [enclosing isSyntaxMorph ifFalse: [^ #unknown]. (enclosing nodeClassIs: MessageNode) ifTrue: [ list _ enclosing submorphs select: [:ss | ss isSyntaxMorph and: [ss parseNode ~~ nil]]. list size = 1 ifFalse: [ ^ (list indexOf: sub) = 1 ifTrue: [enclosing receiverTypeFor: enclosing selector] ifFalse: [enclosing argTypeFor: enclosing selector]]]. (enclosing nodeClassIs: BlockNode) ifTrue: [^ #command]. sub _ enclosing. enclosing _ enclosing owner. true] whileTrue.! ! !SyntaxMorph methodsFor: 'type checking' stamp: 'tk 2/12/2001 16:26'! receiverTypeFor: aSelector | where | "Search for the type of the receiver of this selector. Return #unknown if not found." where _ aSelector numArgs = 0 ifTrue: [7] ifFalse: [9]. self class allSpecs do: [:catPair | catPair second do: [:spec | spec first == #command ifTrue: [ spec second == aSelector ifTrue: ["ours" ^ #player]]. spec first == #slot ifTrue: [ spec size >= where ifTrue: [ (spec at: where) == aSelector ifTrue: ["ours" ^ spec at: where-1]]]. ]]. ^ #unknown "What if the same selector appears more than one time?"! ! !SyntaxMorph methodsFor: 'type checking' stamp: 'tk 2/12/2001 14:40'! resultType | list value soundChoices | "Look up my result type. If I am a constant, use that class. If I am a message, look up the selector." parseNode class == BlockNode ifTrue: [^ #blockContext]. list _ submorphs select: [:ss | ss isSyntaxMorph and: [ss parseNode ~~ nil]]. list size > 1 ifTrue: [^ self resultTypeFor: self selector]. list size = 1 ifTrue: ["test for levels that are just for spacing in layout" (list first isSyntaxMorph and: [list first nodeClassIs: MessageNode]) ifTrue: [ ^ list first resultType]]. "go down one level" value _ self try. value class == Error ifTrue: [^ #unknown]. (value isKindOf: Number) ifTrue: [^ #number]. (value isKindOf: Boolean) ifTrue: [^ #boolean]. value class == String ifTrue: [ soundChoices _ #('silence'). "default, if no SampledSound class" Smalltalk at: #SampledSound ifPresent: [:sampledSound | soundChoices _ sampledSound soundNames]. (soundChoices includes: value) ifTrue: [^ #sound]]. (value isKindOf: Player) ifTrue: [^ #player]. ^ value class name asLowercase "asSymbol (not needed)"! ! !SyntaxMorph methodsFor: 'type checking' stamp: 'tk 2/13/2001 21:20'! resultTypeFor: aSelector | where | "Search for the type of the argument of this selector. Return #unknown if not found." aSelector ifNil: [self inform: 'Please tell Ted how you caused this'. ^ #abs "a bogus type"]. where _ aSelector numArgs = 0 ifTrue: [7] ifFalse: [9]. self class allSpecs do: [:catPair | catPair second do: [:spec | spec first == #command ifTrue: [ spec second == aSelector ifTrue: ["ours" ^ #command]]. spec first == #slot ifTrue: [ spec size >= where ifTrue: [ (spec at: where) == aSelector ifTrue: ["ours" where = 9 ifTrue: [^ #command] "Not supposed to use a setter for its result" ifFalse: [^ spec fourth]]]]. ]]. ^ #unknown "What if the same selector appears more than one time?"! ! !SyntaxMorph methodsFor: 'type checking' stamp: 'tk 2/13/2001 15:59'! selector | sel cnt | "Find the selector I represent, or have inside of me. My parseNode is a SelectorNode or a MessageNode." parseNode class == SelectorNode ifTrue: [ ^ (self findA: StringMorph) contents asSymbol]. parseNode class == KeyWordNode ifTrue: [ ^ (self findA: StringMorph) contents asSymbol]. sel _ ''. cnt _ 0. submorphs do: [:mm | mm isSyntaxMorph ifTrue: [ cnt _ cnt + 1. (mm nodeClassIs: SelectorNode) ifTrue: [^ mm selector]. (mm nodeClassIs: MessagePartNode) ifTrue: [ sel _ sel, mm selector]. (mm nodeClassIs: KeyWordNode) ifTrue: [ sel _ sel, (mm findA: StringMorph) contents]. cnt = 2 ifTrue: ["not the receiver. Selector and arg" (mm nodeClassIs: MessageNode) ifTrue: [ sel _ mm selector]]]]. sel size > 0 ifTrue: [^ sel asSymbol]. ^ nil! ! !SyntaxMorph methodsFor: 'dropping/grabbing' stamp: 'tk 2/13/2001 16:40'! acceptDroppingMorph: aMorph event: evt | itNoun old | "For the moment, you have to drop it the right place. We do not look at enclosing morphs" "Two ways to do this: Must always destroy old node, then drag in new one. Or, drop replaces what you drop on. Nasty with blocks. see wantsDroppedMorph:event:" "We know it is acceptable. Just a matter of which case" itNoun _ aMorph isNoun. self withAllOwnersDo: [:m | (m isSyntaxMorph and: [m isBlockNode]) ifTrue: [m stopStepping; removeDropZones]]. self isBlockNode & itNoun ifTrue: [(aMorph nodeClassIs: TempVariableNode) ifTrue: ["If I am a BlockNode, and it is a TempVariableNode, add it into list" ^ (self addBlockArg: aMorph) ifFalse: ["if already declared, start new line of code with it" self addToBlock: aMorph event: evt]] ifFalse: [^ self addToBlock: aMorph event: evt]]. "If I am a BlockNode and it is a noun add it as a new line" self isBlockNode ifTrue: [ (aMorph nodeClassIs: ReturnNode) ifTrue: [^ self addToBlock: aMorph event: evt]]. "Later add args and keywords. later allow comments to be dropped" "Can't put statement, literal, assignment, or cascade into left side of assignment" (owner isSyntaxMorph) ifTrue: [(owner nodeClassIs: AssignmentNode) ifTrue: [(owner submorphIndexOf: self) = 1 ifTrue: [((aMorph nodeClassIs: TempVariableNode) or: [aMorph nodeClassIs: VariableNode]) ifFalse: [ ^ self]]]]. aMorph deselect. (old _ owner) replaceSubmorph: self by: aMorph. "do the normal replacement" (old isSyntaxMorph) ifTrue: [old cleanupAfterItDroppedOnMe]. "now owned by no one" ! ! !SyntaxMorph methodsFor: 'dropping/grabbing' stamp: 'tk 2/13/2001 16:45'! morphToDropInPasteUp: aPasteUp "If property #beScript is true, create a scriptor around me." | actualObject itsSelector aScriptor adjustment handy tw blk | self flag: #noteToTed. "I changed PhraseTileMorph's version of this method to eliminate the flagshipInstance annoyance, and the below needs to be changed accordingly -- look at my method and notice diffs. Besides eliminating the flagshipInstance test, one needs to be sure that the thing dropped is adjusted to reflect which instance of the uniclass is at hand. sw 1/19/2001 02:30" (self valueOfProperty: #beScript ifAbsent: [false]) ifFalse: [^ self]. self removeProperty: #beScript. (actualObject _ self actualObject) ifNil: [^ self]. actualObject assureUniClass. itsSelector _ self userScriptSelector. aScriptor _ itsSelector isEmptyOrNil ifFalse: [adjustment _ 0@0. actualObject scriptEditorFor: itsSelector] ifTrue: ["It's a system-defined selector; construct an anonymous scriptor around it" adjustment _ 60 @ 20. actualObject newScriptorAround: self]. handy _ aPasteUp primaryHand. aScriptor ifNotNil: [ aScriptor position: handy position - adjustment. aPasteUp addMorphFront: aScriptor. "do this early so can find World" (tw _ aScriptor findA: TwoWayScrollPane) ifNil: [ aScriptor useNewTiles. itsSelector ifNil: ["blank script" tw _ aScriptor findA: TwoWayScrollPane. blk _ tw scroller firstSubmorph "MethodNode" lastSubmorph "BlockNode". blk addMorphFront: self. "self position: self topLeft + (7@14)"]]]. aScriptor showSourceInScriptor. "**This destroys most of the work done before**" aScriptor hResizing: #shrinkWrap; vResizing: #shrinkWrap; cellPositioning: #topLeft. (aScriptor isKindOf: ScriptEditorMorph) ifTrue: [aScriptor playerScripted expungeEmptyUnRenamedScripts]. ^ aScriptor ifNil: [self] ! ! !SyntaxMorph methodsFor: 'dropping/grabbing' stamp: 'tk 2/12/2001 15:22'! structureMatchWith: aMorph | meNoun itNoun | "Return true if the node types would allow aMorph to replace me. This tests the gross structure of the method only." "If nodes are of equal class, replace me with new one." (self nodeClassIs: MessageNode) ifFalse: [ (self nodeClassIs: aMorph parseNode class) ifTrue: [^ true]]. meNoun _ self isNoun. itNoun _ aMorph isNoun. "Consider these nouns to be equal: TempVariableNode, LiteralNode, VariableNode, (MessageNode with receiver), CascadeNode, AssignmentNode" meNoun & itNoun ifTrue: [^ true]. meNoun & aMorph isBlockNode ifTrue: [^ true]. "If I am a BlockNode, and it is a TempVariableNode, add it into list" "If I am a BlockNode, and it is a noun, add it as a new line" self isBlockNode ifTrue: [itNoun ifTrue: [^ true]. (aMorph nodeClassIs: ReturnNode) ifTrue: [^ (self submorphs detect: [:mm | ((mm isSyntaxMorph) and: [mm nodeClassIs: ReturnNode])] ifNone: [nil]) isNil]]. "none already in this block" "If I am a BlockNode, and it is a ReturnNode, add to end" (self isMethodNode) ifTrue: [^ false]. "Later add args and keywords" "Later allow comments to be dropped in" "Add MethodTemps by dropping into the main block" ^ false "otherwise reject" ! ! !SyntaxMorph methodsFor: 'dropping/grabbing' stamp: 'tk 2/12/2001 15:57'! wantsDroppedMorph: aMorph event: evt "For the moment, you have to drop it the right place. We do not look at enclosing morphs" "Two ways to do this: Must always destroy old node, then drag in new one. Or, drop replaces what you drop on. Nasty with blocks." (aMorph isKindOf: SyntaxMorph) ifFalse: [^ false]. (self structureMatchWith: aMorph) ifFalse: [^ false]. "gross structure" "Only look at types if NoviceMode -- building EToys" ^ self okToBeReplacedBy: aMorph. "test the types" "^ true"! ! !SyntaxMorph methodsFor: 'insertion drop zones' stamp: 'tk 2/13/2001 15:00'! trackDropZones | hand i localPt insertion insHt ii prevBot nxtHt d c1 c2 ht2 spacer1 spacer2 wid ht1 | 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 yellow lighter. c2 _ Color transparent. ht2 _ d*insHt//nxtHt. ht1 _ insHt - ht2. wid _ 100 min: owner width - 10. (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 borderColor: self dropColor. self borderColor = self dropColor ifTrue: [self borderColor: self stdBorderColor]]]. "If no submorph (incl spacers) highlighted, then re-highlight the block." ((self wantsDroppedMorph: insertion event: hand lastEvent) and: [(self submorphs anySatisfy: [:m | m containsPoint: localPt]) not]) ifTrue: [self borderColor: self dropColor] ! ! !SyntaxMorph methodsFor: 'layout' stamp: 'tk 2/12/2001 14:39'! try "Evaluate me once" (#(MessageNode LiteralNode VariableNode) includes: parseNode class name) ifFalse: [^ Error new]. ^ [Compiler evaluate: self decompile for: self actualObject logged: false. "should do something to the player" ] ifError: [ :a :b | Error new].! ! !SyntaxMorph methodsFor: 'menus' stamp: 'tk 2/13/2001 20:23'! accept "Turn my current state into the text of a method. Compile it in my class." | cls sc | self isMethodNode ifFalse: [ self rootTile == self ifTrue: [^ self]. "not in a script" ^ self rootTile accept "always accept at the root"]. (cls _ self parsedInClass) ifNil: [^ self]. cls compile: self decompile notifying: nil. (sc _ self firstOwnerSuchThat: [:mm | mm class == ScriptEditorMorph]) ifNotNil: [sc hibernate; unhibernate]. "rebuild the tiles" ! ! !SyntaxMorph class methodsFor: 'as yet unclassified' stamp: 'tk 2/12/2001 16:25'! allSpecs AllSpecs ifNil: [self initialize]. ^ AllSpecs! ! !SyntaxMorph class methodsFor: 'as yet unclassified' stamp: 'tk 2/12/2001 16:10'! initialize "gather all the specs of all the kinds of EToy tiles." AllSpecs _ self new allSpecs.! ! SyntaxMorph initialize!