1"====================================================================== 2| 3| Smalltalk GUI wrapper for method source code widgets 4| 5| 6 ======================================================================" 7 8"====================================================================== 9| 10| Copyright 1992,94,95,99,2000,2001,2002,2003,2007 11| Free Software Foundation, Inc. 12| Written by Paolo Bonzini. 13| 14| This file is part of GNU Smalltalk. 15| 16| GNU Smalltalk is free software; you can redistribute it and/or modify it 17| under the terms of the GNU General Public License as published by the Free 18| Software Foundation; either version 2, or (at your option) any later version. 19| 20| GNU Smalltalk is distributed in the hope that it will be useful, but WITHOUT 21| ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS 22| FOR A PARTICULAR PURPOSE. See the GNU General Public License for more 23| details. 24| 25| You should have received a copy of the GNU General Public License along with 26| GNU Smalltalk; see the file COPYING. If not, write to the Free Software 27| Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. 28| 29 ====================================================================== 30" 31 32 33 34BLOX.BText subclass: BCode [ 35 | class line highlighted source variables pools temps isMethod highlightBlock | 36 37 <comment: nil> 38 <category: 'Graphics-Browser'> 39 40 Colors := nil. 41 Highlight := nil. 42 43 BCode class >> highlight [ 44 <category: 'choosing behavior'> 45 ^Highlight 46 ] 47 48 BCode class >> highlight: aBoolean [ 49 <category: 'choosing behavior'> 50 Highlight := aBoolean 51 ] 52 53 BCode class >> colorAt: aSymbol [ 54 <category: 'event handlers'> 55 ^Colors at: aSymbol ifAbsent: [nil] 56 ] 57 58 BCode class >> colorAt: aSymbol put: aColor [ 59 <category: 'event handlers'> 60 ^Colors at: aSymbol put: (BTextAttributes foregroundColor: aColor) 61 ] 62 63 BCode class >> initializeColors [ 64 <category: 'event handlers'> 65 Colors := IdentityDictionary new: 32. 66 self highlight: true. 67 self 68 colorAt: #classVar put: 'cyan4'; 69 colorAt: #globalVar put: 'cyan4'; 70 colorAt: #poolVar put: 'cyan4'; 71 colorAt: #undeclaredVar put: 'red'; 72 colorAt: #instanceVar put: 'black'; 73 colorAt: #argument put: 'black'; 74 colorAt: #temporary put: 'black'; 75 colorAt: #specialId put: 'grey50'; 76 colorAt: #literal put: 'grey50'; 77 colorAt: #temporaries put: 'magenta'; 78 colorAt: #methodHeader put: 'magenta'; 79 colorAt: #primitive put: 'magenta'; 80 colorAt: #arguments put: 'magenta'; 81 colorAt: #special put: 'magenta'; 82 colorAt: #unaryMsg put: 'magenta4'; 83 colorAt: #binaryMsg put: 'chocolate4'; 84 colorAt: #keywordMsg put: 'NavyBlue'; 85 colorAt: #comment put: 'SpringGreen4' 86 ] 87 88 checkLine: unused [ 89 <category: 'event handlers'> 90 | oldLine | 91 oldLine := line. 92 line := self currentLine. 93 line ~= oldLine & highlighted not ifTrue: [self rehighlight] 94 ] 95 96 create [ 97 <category: 'event handlers'> 98 super create. 99 self inClass: UndefinedObject. 100 highlighted := false. 101 self onKeyUpEventSend: #checkLine: to: self. 102 self 103 onMouseUpEvent: 1 104 send: #checkLine: 105 to: self 106 ] 107 108 invokeCallback [ 109 <category: 'event handlers'> 110 highlighted ifTrue: [self blackLine]. 111 super invokeCallback 112 ] 113 114 highlightAs: kind from: start to: end [ 115 <category: 'mediating protocol'> 116 highlightBlock 117 value: (BCode colorAt: kind) 118 value: start 119 value: end 120 ] 121 122 highlightAs: kind pos: pos [ 123 <category: 'mediating protocol'> 124 pos isNil ifTrue: [^self]. 125 self 126 highlightAs: kind 127 from: pos 128 to: pos 129 ] 130 131 highlightNewVariable: name from: start to: end as: kind [ 132 <category: 'mediating protocol'> 133 temps at: name put: kind. 134 self 135 highlightAs: kind 136 from: start 137 to: end 138 ] 139 140 highlightVariable: name from: start to: end [ 141 <category: 'mediating protocol'> 142 self 143 highlightAs: (self variableKind: name) 144 from: start 145 to: end 146 ] 147 148 blackLine [ 149 <category: 'syntax highlighting'> 150 highlighted := false. 151 self removeAttributesFrom: 1 @ line to: 1 @ (line + 1) 152 ] 153 154 classifyNewVariable: var [ 155 <category: 'syntax highlighting'> 156 pools 157 keysAndValuesDo: [:pool :kind | (pool includesKey: var) ifTrue: [^kind]]. 158 ^(var at: 1) isUppercase ifTrue: [#globalVar] ifFalse: [#undeclaredVar] 159 ] 160 161 declareVariables: aCollection in: dictionary as: kind [ 162 <category: 'syntax highlighting'> 163 aCollection do: [:each | dictionary at: each asString put: kind] 164 ] 165 166 rehighlight [ 167 <category: 'syntax highlighting'> 168 self class highlight ifFalse: [^self]. 169 self 170 removeAttributes; 171 highlight 172 ] 173 174 highlight [ 175 <category: 'syntax highlighting'> 176 self class highlight ifFalse: [^self]. 177 self highlightSyntax. 178 highlighted := true 179 ] 180 181 highlightBlockClosure [ 182 <category: 'syntax highlighting'> 183 | sourceStream nlPos lineNumber | 184 lineNumber := 0. 185 sourceStream := ReadStream on: source. 186 ^ 187 [:color :start :end | 188 | startPos endPos | 189 [start > sourceStream position] whileTrue: 190 [lineNumber := lineNumber + 1. 191 nlPos := sourceStream position. 192 sourceStream skipTo: Character nl]. 193 startPos := (start - nlPos) @ lineNumber. 194 [end > sourceStream position] whileTrue: 195 [lineNumber := lineNumber + 1. 196 nlPos := sourceStream position. 197 sourceStream skipTo: Character nl]. 198 endPos := (end - nlPos + 1) @ lineNumber. 199 self 200 setAttributes: color 201 from: startPos 202 to: endPos] 203 ] 204 205 parserClass [ 206 <category: 'syntax highlighting'> 207 ^STInST.RBBracketedMethodParser 208 ] 209 210 highlightSyntax [ 211 <category: 'syntax highlighting'> 212 | parser | 213 source = self contents 214 ifFalse: 215 ["FIXME: this is wrong, something is being dropped 216 elsewhere with respect to content updates" 217 source := self contents]. 218 parser := (self parserClass new) 219 errorBlock: [:string :pos | ^self]; 220 initializeParserWith: source type: #on:errorBlock:; 221 yourself. 222 isMethod 223 ifTrue: [self highlight: parser parseMethod] 224 ifFalse: 225 [[parser atEnd] whileFalse: 226 [self highlight: (parser parseStatements: false). 227 parser step "gobble doit terminating bang"]] 228 ] 229 230 highlight: node [ 231 <category: 'syntax highlighting'> 232 233 [| color commentsNode | 234 temps := LookupTable new. 235 highlightBlock := self highlightBlockClosure. 236 SyntaxHighlighter highlight: node in: self. 237 commentsNode := STInST.RBProgramNode new copyCommentsFrom: node. 238 commentsNode comments isNil ifTrue: [^self]. 239 color := BCode colorAt: #comment. 240 highlightBlock := self highlightBlockClosure. 241 commentsNode comments do: 242 [:each | 243 highlightBlock 244 value: color 245 value: each first 246 value: each last]] 247 ensure: [temps := highlightBlock := nil] 248 ] 249 250 inClass: aClass [ 251 <category: 'syntax highlighting'> 252 class == aClass ifTrue: [^self]. 253 class := aClass. 254 self initVariableClassification. 255 self 256 declareVariables: class allClassVarNames 257 in: variables 258 as: #classVar. 259 self 260 declareVariables: class allInstVarNames 261 in: variables 262 as: #instanceVar. 263 class withAllSuperclassesDo: 264 [:each | 265 pools at: class environment put: #globalVar. 266 class sharedPools 267 do: [:pool | pools at: (class environment at: pool) put: #poolVar]] 268 ] 269 270 initVariableClassification [ 271 <category: 'syntax highlighting'> 272 variables := LookupTable new. "variable String -> its kind" 273 pools := IdentityDictionary new. "Dictionary -> kind of variables in it" 274 variables 275 at: 'self' put: #specialId; 276 at: 'super' put: #specialId; 277 at: 'thisContext' put: #specialId 278 ] 279 280 variableKind: var [ 281 <category: 'syntax highlighting'> 282 ^temps at: var 283 ifAbsentPut: [variables at: var ifAbsent: [self classifyNewVariable: var]] 284 ] 285 286 contents: textOrAssociation [ 287 <category: 'widget protocol'> 288 | newClass | 289 line := 1. 290 highlighted := false. 291 (textOrAssociation isKindOf: Association) 292 ifTrue: 293 [source := textOrAssociation value. 294 newClass := textOrAssociation key. 295 isMethod := true] 296 ifFalse: 297 [source := textOrAssociation. 298 newClass := UndefinedObject. 299 isMethod := false]. 300 super contents: source. 301 self 302 inClass: newClass; 303 highlight 304 ] 305] 306 307 308 309STInST.STInST.RBProgramNodeVisitor subclass: SyntaxHighlighter [ 310 | widget | 311 312 <category: 'Graphics-Browser'> 313 <comment: nil> 314 315 SyntaxHighlighter class >> highlight: node in: aBCodeWidget [ 316 <category: 'instance creation'> 317 (self new) 318 widget: aBCodeWidget; 319 visitNode: node 320 ] 321 322 widget: aBCodeWidget [ 323 <category: 'initialize-release'> 324 widget := aBCodeWidget 325 ] 326 327 acceptArrayNode: anArrayNode [ 328 "widget highlightAs: #special at: anArrayNode left." 329 330 <category: 'visitor-double dispatching'> 331 self visitNode: anArrayNode body 332 "widget highlightAs: #special at: anArrayNode right" 333 ] 334 335 acceptAssignmentNode: anAssignmentNode [ 336 <category: 'visitor-double dispatching'> 337 self acceptVariableNode: anAssignmentNode variable. 338 "widget highlightAs: #special 339 from: anAssignment assignment 340 to: anAssignmentNode assignment + 1." 341 self visitNode: anAssignmentNode value 342 ] 343 344 acceptBlockNode: aBlockNode [ 345 "widget highlightAs: #special at: aBlockNode left." 346 347 <category: 'visitor-double dispatching'> 348 aBlockNode colons with: aBlockNode arguments 349 do: 350 [:colonPos :argument | 351 "widget highlightAs: #special at: colonPos." 352 353 self highlightNewVariable: argument as: #argument]. 354 355 "aBlockNode bar isNil ifFalse: [ 356 widget highlightAs: #special at: aBlockNode bar. 357 ]." 358 self visitNode: aBlockNode body 359 "widget highlightAs: #special at: aBlockNode right" 360 ] 361 362 acceptCascadeNode: aCascadeNode [ 363 <category: 'visitor-double dispatching'> 364 | n | 365 n := 0. 366 self visitNode: aCascadeNode messages first receiver. 367 aCascadeNode messages do: 368 [:each | 369 self highlightMessageSend: each 370 "separatedBy: [ | semi | 371 semi := aCascadeNode semicolons at: (n := n + 1) 372 widget highlightAs: #special at: semi ]"] 373 ] 374 375 acceptLiteralNode: aLiteralNode [ 376 <category: 'visitor-double dispatching'> 377 widget 378 highlightAs: #literal 379 from: aLiteralNode start 380 to: aLiteralNode stop 381 ] 382 383 acceptMessageNode: aMessageNode [ 384 <category: 'visitor-double dispatching'> 385 self visitNode: aMessageNode receiver. 386 self highlightMessageSend: aMessageNode 387 ] 388 389 acceptMethodNode: aMethodNode [ 390 "A pity we cannot share this code with highlightMessageSend: ..." 391 392 <category: 'visitor-double dispatching'> 393 aMethodNode isUnary 394 ifTrue: 395 [widget 396 highlightAs: #unaryMsg 397 from: aMethodNode selectorParts first start 398 to: aMethodNode selectorParts first stop]. 399 aMethodNode isBinary 400 ifTrue: 401 [widget 402 highlightAs: #binaryMsg 403 from: aMethodNode selectorParts first start 404 to: aMethodNode selectorParts first stop. 405 self highlightNewVariable: aMethodNode arguments first as: #argument]. 406 aMethodNode isKeyword 407 ifTrue: 408 [aMethodNode selectorParts with: aMethodNode arguments 409 do: 410 [:sel :arg | 411 widget 412 highlightAs: #binaryMsg 413 from: sel start 414 to: sel stop. 415 self highlightNewVariable: arg as: #argument]]. 416 self visitNode: aMethodNode body 417 ] 418 419 acceptOptimizedNode: aBlockNode [ 420 "widget highlightAs: #special from: aBlockNode left to: aBlockNode + 2." 421 422 <category: 'visitor-double dispatching'> 423 self visitNode: aBlockNode body 424 "widget highlightAs: #special at: aBlockNode right" 425 ] 426 427 acceptReturnNode: aReturnNode [ 428 "widget highlightAs: #special at: anArrayNode start." 429 430 <category: 'visitor-double dispatching'> 431 self visitNode: aReturnNode value 432 ] 433 434 acceptSequenceNode: aSequenceNode [ 435 <category: 'visitor-double dispatching'> 436 | n | 437 n := 0. 438 "widget highlightAs: #special at: aSequenceNode leftBar." 439 aSequenceNode temporaries do: 440 [:temporary | 441 "widget highlightAs: #special at: colonPos." 442 443 self highlightNewVariable: temporary as: #temporary]. 444 "widget highlightAs: #special at: aSequenceNode rightBar." 445 aSequenceNode statements do: 446 [:each | 447 self visitNode: each 448 "separatedBy: [ | period | 449 period := aSequenceNode periods at: (n := n + 1) 450 widget highlightAs: #special at: period ]" 451 452 "n < aSequenceNode periods size ifTrue: [ 453 widget highlightAs: #special at: aSequenceNode periods last ]."] 454 ] 455 456 acceptVariableNode: aVariableNode [ 457 <category: 'visitor-double dispatching'> 458 widget 459 highlightVariable: aVariableNode name 460 from: aVariableNode start 461 to: aVariableNode stop 462 ] 463 464 highlightMessageSend: aMessageNode [ 465 <category: 'visitor-double dispatching'> 466 aMessageNode isUnary 467 ifTrue: 468 [widget 469 highlightAs: #unaryMsg 470 from: aMessageNode selectorParts first start 471 to: aMessageNode selectorParts first stop. 472 ^self]. 473 aMessageNode isBinary 474 ifTrue: 475 [widget 476 highlightAs: #binaryMsg 477 from: aMessageNode selectorParts first start 478 to: aMessageNode selectorParts first stop. 479 self visitNode: aMessageNode arguments first. 480 ^self]. 481 aMessageNode selectorParts with: aMessageNode arguments 482 do: 483 [:sel :arg | 484 widget 485 highlightAs: #binaryMsg 486 from: sel start 487 to: sel stop. 488 self visitNode: arg] 489 ] 490 491 highlightNewVariable: node as: kind [ 492 <category: 'visitor-double dispatching'> 493 widget 494 highlightNewVariable: node name 495 from: node start 496 to: node stop 497 as: kind 498 ] 499] 500 501 502 503PText subclass: PCode [ 504 505 <import: STInST> 506 <comment: nil> 507 <category: 'Graphics-Browser'> 508 509 PCode class >> bloxClass [ 510 <category: 'instance creation'> 511 ^BCode 512 ] 513 514 implementorsFrom: position [ 515 <category: 'limited parsing'> 516 | symbol | 517 symbol := self getMessageAt: position. 518 symbol isNil 519 ifTrue: 520 [Blox beep. 521 ^self]. 522 MethodSetBrowser implementorsOf: symbol parent: self 523 ] 524 525 sendersFrom: position [ 526 <category: 'limited parsing'> 527 | symbol | 528 symbol := self getMessageAt: position. 529 symbol isNil 530 ifTrue: 531 [Blox beep. 532 ^self]. 533 MethodSetBrowser sendersOf: symbol parent: self 534 ] 535 536 getMessageAt: position [ 537 "This is so easy to do with the Refactoring Browser's 538 parse nodes!!!" 539 540 <category: 'limited parsing'> 541 "First, we must map line/row to the actual index in 542 the source code." 543 544 | stream pos parser node | 545 stream := ReadStream on: blox contents. 546 position y - 1 timesRepeat: [stream nextLine]. 547 stream skip: position x - 1. 548 pos := stream position. 549 stream reset. 550 parser := RBParser new. 551 parser errorBlock: [:message :position | ^nil]. 552 parser 553 scanner: (parser scannerClass on: stream errorBlock: parser errorBlock). 554 node := parser parseMethod body. 555 node := node bestNodeFor: (pos to: pos + 1). 556 [node isMessage] whileFalse: 557 [node := node parent. 558 node isNil ifTrue: [^nil]]. 559 ^node selector 560 ] 561 562 implementors [ 563 <category: 'blue button menu'> 564 ^self implementorsFrom: blox currentPosition 565 ] 566 567 senders [ 568 <category: 'blue button menu'> 569 ^self sendersFrom: blox currentPosition 570 ] 571 572 compileIt [ 573 <category: 'blue button menu'> 574 super compileIt. 575 self blox rehighlight 576 ] 577] 578 579 580 581Eval [ 582 BCode initializeColors 583] 584 585