NewspeakColorization.ns

Newspeak3
'Root'
class NewspeakColorization usingPlatform: p grammar: grammar = (
(*
Newspeak code colorizer.

Copyright Google Inc. 2016 - 2017.
*)
	|
	private Color = p graphics Color.
	private Map = p collections Map.
	private List = p collections List.
	private ClassMirror = p mirrors ClassMirror.
	private TypedNS3Grammar = grammar TypedNS3Grammar.
	private StringBuilder = p kernel StringBuilder.
	private TextProperties = p text TextProperties.
	private TextString = p text TextString.
	private TextBlock = p text TextBlock.
	|
) (
public class NS3BrowserColorizer = NS3Colorizer (
(* The colorizer maps different kinds of language constructs to different text properties via the mapping defined
by computePropertiesMap, which it stores in propertiesMap. The parsing process defined by the superclass produces an
a list of ranges in the source, where each range identifies the kind of construct in that range (see class Range in the surrounding module).  Not every section of text has a range computed for it; only sections that define constructs with special textual properties are computed. Later we will compute a set of text objects which covers the entire source, filling in the parts that lack an entry in the range list with text objects with default properties.

We convert the list to an array (incidental), rangeArray and sort it in ascending order of start indices.
The ranges in the range list may overlap.  In consolidateRanges,  overlaps are eliminated by iterating over the sorted range list and comparing adjacent ranges pairwise. If they overlap, they may or may not have the same kind. If the kinds are the same, we merge the ranges into one. If they differ, we truncate the first range to eliminate the overlap.

We then traverse the range array and, using propertiesMap, compute a corresponding set of text objects that have the appropriate properties, and filling in the gaps with text objects that have default properties, as described above.
*)|
	propertiesMap <Map[Symbol, TextProperties]> = computePropertiesMap.
	textSegments <List[TextString]>
	inputString <String>
	priorSegmentEnd <Integer>
	rangeArray <Array>
|) (
class Range kind: k start: s end: e = (
(*
Instances of this class describe a range of text in the source. The start and end of the range are given as indices into the source.
The kind is a descriptor for what sort of element the code describes - a type, an error, a literal etc. The kind will serve as a key for the colorizer to decide what color to use for the text described by the range.
*)|
	public kind <Symbol> = k.
	public start <Integer> = s.
	public end <Integer> = e.
|) (
) : (
)
coloredText ^ <Text> = (
  ^TextBlock units: textSegments
)
public colorizeClassDeclaration: s <String> fromClass: c <Class> via: cf <[:Range]> = (
      setString: s class: c.
      colorizeString: s withProduction: classDeclaration via: cf
)
public colorizeDoIt: s <String> fromClass: c <Class> via: cf <[:Range]> = (
      setString: s class: c.
      colorizeString: s withProduction: doItExpression via: cf
)
public colorizeHeader: s <String> fromClass: c <Class> via: cf <[:Range]> = (
      setString: s class: c.
      colorizeString: s withProduction: classHeader via: cf
)
public colorizeMethod: s <String> fromClass: c <Class> via: cf <[:Range]> = (
      setString: s class: c.
      colorizeString: s withProduction: methodDecl via: cf
)
colorizeString: s <String> withProduction: parser <CombinatorialParser> via: cf <[:Range]> = (
	parser, eoi parseString: s ifError: [:msg :pos |
		noteRange: #error from: pos to: inputSize.
		^feedRangesTo: cf
      ].
      feedRangesTo: cf
)
computePropertiesMap ^ <Map[Symbol, TextProperties]> = (
(* compute a mapping from 'kinds', which are symbols denoting logical categories of code, to textual properties used to colorize them*)
  |
  redBoldUnderlined <TextProperties> = TextProperties new color: Color red; weight: #bold; underline: true; yourself.
  redUnderlined <TextProperties> = TextProperties new color: Color red; underline: true; yourself.
  orangeBoldUnderlined <TextProperties> = TextProperties new color: Color orange;  weight: #bold; underline: true; yourself.
  underlined <TextProperties> = TextProperties new  underline: true; yourself.
  gray <TextProperties> = TextProperties new color: Color gray; yourself.
  blue <TextProperties> = TextProperties new color: Color blue; yourself.
  grayBold <TextProperties> = TextProperties new color: Color gray; weight: #bold; yourself.
  blackBold <TextProperties> = TextProperties new color: Color black;  weight: #bold; yourself.
  blueBold <TextProperties> = TextProperties new color: Color blue;  weight: #bold; yourself.
  magentaBold <TextProperties> = TextProperties new color: Color magenta;  weight: #bold; yourself.
  bold <TextProperties> = TextProperties new  weight: #bold; yourself.
 |

      ^Map new
		 at: #error put: redBoldUnderlined;
             at: #undefinedUnary put: redUnderlined;
             at: #undefinedBinary put: redUnderlined;
             at: #undefinedKeyword put: redUnderlined;
             at: #shadowingTempVar put: orangeBoldUnderlined;
             at: #obsoleteMessage put: orangeBoldUnderlined;
             at: #whitespaceWarning put: orangeBoldUnderlined;
             at: #incompleteUnary put: underlined;
             at: #incompleteBinary put: underlined;
             at: #incompleteKeyword put: underlined;
             at: #self put: gray;
             at: #super put: gray;
             at: #outer put: gray;
             at: #true put: gray;
             at: #false put: gray;
             at: #nil put: gray;
             at: #string put: gray;
             at: #symbol put: gray;
             at: #number put: gray;
             at: #character put: gray;
             at: #public put: gray;
             at: #protected put: gray;
             at: #private put: gray;
             at: #tempVar put: grayBold;
             at: #blockTempVar put: grayBold;
             at: #blockPatternArg put: grayBold;
             at: #patternArg put: grayBold;
             at: #slotDecl put: grayBold;
             at: #patternTempVar put: grayBold;
             at: #methodTempBar put: blackBold;
             at: #leftParenthesis put: blackBold;
             at: #rightParenthesis put: blackBold;
             at: #leftParenthesis3 put: blackBold;
             at: #rightParenthesis3 put: blackBold;
             at: #leftParenthesis6 put: blackBold;
             at: #rightParenthesis6 put: blackBold;
             at: #blockStart put: blackBold;
             at: #blockEnd put: blackBold;
             at: #blockStart3 put: blackBold;
             at: #blockEnd3 put: blackBold;
             at: #blockStart6 put: blackBold;
             at: #blockEnd6 put: blackBold;
             at: #leftBrace put: blackBold;
             at: #rightBrace put: blackBold;
             at: #leftBrace3 put: blackBold;
             at: #rightBrace3 put: blackBold;
             at: #leftBrace6 put: blackBold;
             at: #rightBrace6 put: blackBold;
             at: #messagePatternDecl put: bold;
             at: #class put: gray;
             at: #className put: bold;
             at: #comment put: blue;
             at: #type put: blueBold;
             at: #return put: blueBold;
             at: #leftParenthesis1 put: blueBold;
             at: #rightParenthesis1 put: blueBold;
             at: #leftParenthesis4 put: blueBold;
             at: #rightParenthesis4 put: blueBold;
             at: #leftParenthesis7 put: blueBold;
             at: #rightParenthesis7 put: blueBold;
             at: #blockStart1 put: blueBold;
             at: #blockEnd1 put: blueBold;
             at: #blockStart4 put: blueBold;
             at: #blockEnd4 put: blueBold;
             at: #blockStart7 put: blueBold;
             at: #blockEnd7 put: blueBold;
             at: #leftBrace1 put: blueBold;
             at: #rightBrace1 put: blueBold;
             at: #leftBrace4 put: blueBold;
             at: #rightBrace4 put: blueBold;
             at: #leftBrace7 put: blueBold;
             at: #rightBrace7 put: blueBold;
             at: #leftParenthesis2 put: magentaBold;
             at: #rightParenthesis2 put: magentaBold;
             at: #leftParenthesis5 put: magentaBold;
             at: #rightParenthesis5 put: magentaBold;
             at: #blockStart2 put: magentaBold;
             at: #blockEnd2 put: magentaBold;
             at: #blockStart5 put: magentaBold;
             at: #blockEnd5 put: magentaBold;
             at: #leftBrace2 put: magentaBold;
             at: #rightBrace2 put: magentaBold;
             at: #leftBrace5 put: magentaBold;
             at: #rightBrace5 put: magentaBold;
             yourself
)
computeTextSegments = (
      | textString <TextString> |
  consolidateRanges.
  rangeArray do: [:r <Range> |
	nil = r ifFalse: [
      	r start > priorSegmentEnd ifTrue: [ (* add a segment for unmarked text between identified ranges *)
			textString:: TextString forString: (inputString copyFrom: priorSegmentEnd to: r start - 1).
			textSegments add: textString.
		].
	(* The range 0..size is degenerate and leads to errors in Squeak 5.0 Morphic layout of paragraphs. *)
		textString:: TextString
			forString: (inputString copyFrom: (r start max: 1) to: r end)
			properties: (propertiesMap at: r kind ifAbsent: [TextProperties new color: Color black; yourself]).
		textSegments add: textString.
		priorSegmentEnd:: r end + 1.	(* remember last marked range *)
		]
	].
      priorSegmentEnd < inputSize ifTrue: [ (* create a segment for the tail end of the source *)
			textString:: TextString forString: (inputString copyFrom: priorSegmentEnd to: inputSize).
			textSegments add: textString.
	]
)
consolidateRanges = (
   | index <Integer> ::= 1.  |
	rangeArray:: rangeMap asArray. (*BOGUS - work around broken List>>sort on web*)
	rangeArray sort: [:r1 <Range> :r2 <Range> | r1 start = r2 start ifTrue: [r1 end < r2 end] ifFalse: [r1 start < r2 start]].
	[index < rangeArray size] whileTrue: [
		consolidateRangesAt: index.
		index:: index + 1.
	]
)
consolidateRangesAt: index <Integer> = (
| e1 <Range> e2 <Range>  |
	e1:: rangeArray at: index.
	e2:: rangeArray at: index + 1.
      e2 start > e1 end
		ifFalse: [ (* e1 and e2 overlap *)
			e1 kind = e2 kind ifTrue: [ (* merge e1 & e2 *)
			rangeArray at: index put: nil.
			rangeArray at: index + 1 put: (Range kind: e1 kind start: e1 start end: e2 end).
			] ifFalse: [ (* shorten e1 to eliminate overlap *)
				rangeArray at: index put: (Range kind: e1 kind start: e1 start end: e2 start - 1).]
			]
)
feedRangesTo: cf <[:Range]> = (
  	consolidateRanges.
	rangeArray do: [:r | nil = r ifFalse: [cf value: r]].
)
noteRange: kind <Symbol> from: start <Integer> to: end <Integer> = (
   rangeMap add: (Range kind: kind start: (start max: 1) end: end).
)
public parseClassDecl: s <String> fromClass: c <Class> ^<Text> = (
(* Questionable*)
	| parser |

      setString: s class: c.
	^parseString: s withProduction: classDecl
)
public parseClassDeclaration: s <String> fromClass: c <Class> ^<Text> = (
	| parser |

      setString: s class: c.
	^parseString: s withProduction: classDeclaration
)
public parseClassHeader: s <String> fromClass: c <Class> ^<Text> = (
	| parser |

      setString: s class: c.
	^parseString: s withProduction: classHeader
)
public parseCodeBody: s <String> fromClass: c <Class> ^<Text> = (
	| parser |

      setString: s class: c.
	^parseString: s withProduction: codeBody
)
public parseDoIt: s <String> fromClass: c <Class> ^<Text> = (
	| parser |

      setString: s class: c.
	^parseString: s withProduction: doItExpression
)
public parseMethod: s <String> fromClass: c <Class> ^ <Text> = (
	| parser |

      setString: s class: c.
	^parseString: s withProduction: methodDecl
)
public parseSlotDeclaration: s <String> fromClass: c <Class> ^<Text> = (
	| parser |

      setString: s class: c.
	^parseString: s withProduction: slotDef, eoi
)
parseString: s <String> withProduction: parser <CombinatorialParser> ^ <Text> = (
	parser, eoi parseString: s ifError: [:msg :pos |
		noteRange: #error from: pos to: inputSize.
		computeTextSegments.
		^coloredText ].
	computeTextSegments.
	^coloredText
)
setString: s <String> class: c <ClassDeclarationMirror | Mixin> = (	
	inputSize:: s size.	
	inputString:: s.	
	klass:: c.	
	bracketDepth:: 0.	
	braceDepth:: 0.	
	parenDepth:: 0.	
	rangeMap:: List new.
	textSegments:: List new.	
	priorSegmentEnd:: 1.	
	cachedScopeStack: nil.)
) : (
)
class NS3Colorizer = TypedNS3Grammar (
(*
This class subclasses the grammar so that it can parse Newspeak source with specialized semantic actions that determine how to colorize the code. This is done by calling the noteRange:from:to: method.

Because colorization is used to identify shadowing and undefined names, a notion of scoping is needed. Therefore a stack of scopes, cachedScopeStack, is maintained. Scopes are represented by maps from symbols to symbols. The keys are names of declarations, and the values are kinds.

It might be better to produce an actual AST (or a subset thereof) and visit it in order to colorize. In the existing scheme, subexpressions may induce colorizations that are subsumed by their enclosing expressions or statements, and we are forced to explicitly account for these situations and withdraw colorizations. See for example the blockType method, or worse, binaryMsgPattern.
*)|
	cachedScopeStack
	klass
	rangeMap <List[Range]>
	inputSize <Integer>
	startComment
	braceDepth <Integer>
	bracketDepth <Integer>
	parenDepth <Integer>
	isFirst ::= true.
	mixinMirrorForObject <MixinMirror> = (ClassMirror reflecting: Object) mixin.
|) (
accessModifier = (
	^super accessModifier wrapper: [ :mod :ws |
		noteRange: mod value asSymbol from: mod start to: mod end.
		mod]
)
beginComment = (
	^(TokenizingParser withSubparser: super beginComment) wrap:
		[:t | self noteRange: #unfinishedComment from: t start to: self inputSize. t].
)
binaryMsgPattern = (
	^super binaryMsgPattern wrapper:
		[:sel <Token> :p <Tuple[Token, Token]> | | typeRange <Range> |
		self pushScope.
		self currentScope at: p first value put: #parameter.
		(* The machinations around the ranges are especially nasty here.
		The formal parameter is initially colored as a slot, but we may want to
		treat formals specially, so we retract its colorization. If the slot had a type,
		we retract that too (because it is last) and later reinstate it.
		*)
		p last isNil ifFalse: [typeRange:: rangeMap removeLast].
		rangeMap removeLast.
		noteRange: #messagePatternDecl from: sel start to: sel end.
		noteRange: #patternArg from: p first start to: p first end.
		p last isNil ifFalse: [rangeMap add: typeRange].
		].
)
binarySelector = (
	^super binarySelector wrap:
		[:t | | kind |
		kind:: selector: t value
			ifDefined: [#binary]
			ifIncomplete: [#incompleteBinary]
			ifUndefined: [#undefinedBinary]
			ifObsolete: [#obsoleteMessage].
		self noteRange: kind from: t start to: t end.
		t].
)
block = (
	^super block wrapper:
		[:lb :params :cb :rb |
		params isNil ifFalse: [params isEmpty ifFalse: [self popScope]].
		{lb. params. cb. rb}]
)
blockParameter = (
	^super blockParameter wrapper:
		[:cn :sd | (* blockParameter ::= colon, slotDecl *)
		| kind |
		checkBlockParameter: sd first.
		kind:: (symbolInScope: sd first value) ifTrue: [#shadowingTempVar] ifFalse: [#blockPatternArg].
		noteRange: kind from: sd first start to: sd first end.
		sd]
)
blockParameters = (
	^super blockParameters wrapper:
		[:ps :vb  | self pushScope.
		ps do: [:p | self currentScope at: p first value put: #parameter].
		{ps. vb}]
)
blockType = (
(* The brackets around the block type will colorize themselves, but their
colorization is superceded by the surrounding type. Therefore we remove the last
two elements from the rangeMap. *)
	^super blockType wrapper:
		[:lb :t :rb | rangeMap removeLast; removeLast. t ]
)
braceLevelString = (
	^self braceDepth = 1 ifTrue: [''] ifFalse: [self braceDepth printString]
)
bracketLevelString = (
	^self bracketDepth = 1 ifTrue: [''] ifFalse: [self bracketDepth printString]
)
characterConstant = (
	^super characterConstant wrap:
		[:t | self noteRange: #'$' from: t start to: t end. t].
)
checkBlockParameter: sd <Token> = (
	(inputString runeAt: sd start - 1) = 58 ifTrue: [^self].
	self noteRange: #whitespaceWarning from: sd start - 1 to: sd start -1
)
checkKeyword: kwd <Token> = (
	kwd end >= inputSize ifTrue: [^self].
	(inputString runeAt: kwd end + 1) <= 32 ifTrue: [^self].
	self noteRange: #whitespaceWarning from: kwd start to: kwd end
)
classDeclaration: classDecl canUnderstand: selector = (
	(classDecl instanceSide methods includesMirrorNamed: selector)
		ifTrue: [^true].
	(classDecl instanceSide nestedClasses includesMirrorNamed: selector)
		ifTrue: [^true].
	(classDecl instanceSide slots includesMirrorNamed: selector)
		ifTrue: [^true].
	^false	
)
public classHeader = (
	^super classHeader
		wrap:
			[ :tokens |
			(tokens at: 9) = nil ifFalse: (* we have slot declarations *)
				[ | decs |
					decs:: (tokens at: 9) size = 3 ifTrue: [ (* Non-simultaneous case:  | slots | *)
						((tokens at: 9) at: 2) ] ifFalse: [ (* Simultaneous case:  || slots || *)
						(tokens at: 9) at: 3
						].
					decs
					do: [ :each | noteRange: #slotDecl from: (each at: 2) first start to: (each at: 2) first end ] ].
			tokens ]
)
classId = (
  ^super classId wrap: [:cn | 	
	  noteRange: #className from: cn start to: cn end.
	  cn
	]
)
classReservedWord = (
  ^super classReservedWord wrap: [:c | 
	  noteRange: #class from: c start to: c end.
	  c
	]
)
public codeBody = (
	^super codeBody wrapper:
		[:litMsg :tmps :stmts |
		tmps isNil ifFalse: [tmps isEmpty ifFalse: [self popScope]].
		{tmps. stmts}]
)
comment = (
	^super comment wrap:
		[:token | self noteRange: #comment from: token start to: token end].
)
currentScope = (
	self assert: [self scopeStack isEmpty not] message: 'Scope underflow'.
	^self scopeStack last
)
decreaseBraceLevel = (
	self braceDepth: (self braceDepth - 1) \\ 7.
)
decreaseBracketLevel = (
	self bracketDepth: (self bracketDepth - 1) \\ 7.
)
decreaseParenLevel = (
	self parenDepth: (self parenDepth - 1) \\ 7.
)
endComment = (
	^(TokenizingParser withSubparser: super endComment) wrap:
		[:t |  rangeMap removeLast. t].
)
extendedCanUnderstand: sel <Symbol> = (
	| k <ClassDeclarationMirror> |
	k: klass.
	[nil = k] whileFalse:
		[(classDeclaration: k canUnderstand: sel) ifTrue: [^true].	
		 k: k enclosingClass].

	(* klass mixin applications do: [:any | ^any canUnderstand: sel].*)
	^classDeclaration: mixinMirrorForObject declaration canUnderstand: sel
)
increaseBraceLevel = (
	self braceDepth: (self braceDepth + 1) \\ 7.
)
increaseBracketLevel = (
	self bracketDepth: (self bracketDepth + 1) \\ 7.
)
increaseParenLevel = (
	self parenDepth: (self parenDepth + 1) \\ 7.
)
keywordHereSend = (
	^super keywordHereSend wrap:
		[:kws | | sel kind sb |
		sb:: StringBuilder new.
		kws do: [:kwd |
			rangeMap removeLast.
			sb add: kwd first value].
		sel:: sb asString.
		kind:: symbol: sel
			ifInScope: [#instVar]
			ifNotInScope: [#undefinedKeyword]
			ifObsolete: [#obsoleteMessage].
		kws do:
			[:kwp | noteRange: kind from: kwp first start to: kwp first end]]
)
keywordMsg = (
	^super keywordMsg wrapper:
		[:esend :kws |
		| sel kind |
		kws do: [:kwp | checkKeyword: (kwp at: 1)].

		sel:: (kws inject: '' into: [:s :kwp | s, (kwp at: 1) value]) asString.
		kind:: selector: sel
			ifDefined: [#keyword]
			ifIncomplete: [#incompleteKeyword]
			ifUndefined: [#undefinedKeyword]
			ifObsolete: [#obsoleteMessage].
		kws do: [:kwp | self noteRange: kind from: kwp first start to: kwp first end]].
)
keywordMsgPattern = (
	^super keywordMsgPattern wrap:
		[:kws |
		pushScope.
		kws do: [:kwp | | kind |
			kind:: (symbolInScope: kwp last first value)
				ifTrue: [#shadowingTempVar]
				ifFalse: [#patternArg].
			currentScope at: kwp last first value put: #parameter.
			noteRange: #messagePatternDecl from: kwp first start to: kwp first end.
			noteRange: kind from: kwp last first start to: kwp last first end]]
)
lbracket = (
	^super lbracket wrap:
		[:t |
		| range |
		self increaseBracketLevel.
		range:: ('blockStart', self bracketLevelString) asSymbol.
		self noteRange: range from: t start to: t end.
		t]
)
lcurly = (
	^super lcurly wrap:
		[:t | | range |
		self increaseBraceLevel.
		range:: ('leftBrace', self braceLevelString) asSymbol.
		self noteRange: range from: t start to: t end.
		t]
)
lparen = (
	^super lparen wrap:
		[:t | | range |
		self increaseParenLevel.
		range:: ('leftParenthesis', self parenLevelString) asSymbol.
		self noteRange: range from: t start to: t end.
		t]
)
method = (
	| res |
	self pushScope.
	res:: super method.
	self popScope.
	^res
)
nestedClassDecl = (
	^super nestedClassDecl wrap:
		[:tokens | (* accessModifier opt, classDeclaration*)
		noteRange: #className from: ((tokens last) at: 2) start to: ((tokens last) at: 2) end.
		tokens]
)
noteRange: kind from: start to: end  = (
	subclassResponsibility
)
number = (
	^super number wrap:
		[:t | self noteRange: #number from: t start to: t end. t].
)
parenLevelString = (
	^self parenDepth = 1 ifTrue: [''] ifFalse: [self parenDepth printString]
)
pattern = (
	^super pattern wrap:
		[:tpl |
		self noteRange: #string from: (tpl at: 1) start to: (tpl at: 3) end.
		tpl at: 2]
)
popScope = (
	self scopeStack removeLast
)
pushScope = (
	self scopeStack addLast: Map new
)
rbracket = (
	^super rbracket wrap:
		[:t |
		| range |
		range:: ('blockEnd', self bracketLevelString) asSymbol.
		self decreaseBracketLevel.
		self noteRange: range from: t start to: t end.
		t]
)
rcurly = (
	^super rcurly wrap:
		[:t | | range |
		range:: ('rightBrace', self braceLevelString) asSymbol.
		self decreaseBraceLevel.
		self noteRange: range from: t start to: t end.
		t]
)
returnStatement = (
	^super returnStatement wrapper:
		[:h <Token> :expr :od <Token> |
		self noteRange: #return from: h start to: h end.
		expr].
)
returnType = (
	^super returnType wrapper:
		[:h <Token> :t | self noteRange: #type from: h start to: h end. t]
)
rparen = (
	^super rparen wrap:
		[:t |  | range |
		range:: ('rightParenthesis', self parenLevelString) asSymbol.
		self decreaseParenLevel.
		self noteRange: range from: t start to: t end.
		t]
)
scopeStack = (
	(* TODO: get rid of this, rename slot and initialize it*)
	(* deal with forwarding reference *)
	cachedScopeStack isKindOfCollection ifFalse:
		[cachedScopeStack:: List new].
	^cachedScopeStack
)
selector: sel ifDefined: definedAction ifIncomplete: incompleteAction ifUndefined: undefinedAction ifObsolete: obsoleteAction = (
	({#isKindOf:. #out. #halt. #inspect. #flag:. #instVarAt:. #isMemberOf:. #~. #!=} includes: sel) ifTrue: [^obsoleteAction value].
      ^definedAction value
)
semicolon = (
	^super semicolon wrap:
		[:t | self noteRange: #cascadeSeparator from: t start to: t end. t].
)
setterKeyword = (
	^super setterKeyword wrap: [:skw <Token> | | kind |
		checkKeyword: skw.
		kind:: (self symbolInScope: (skw value copyFrom: 1 to: (skw end - skw start )))
			ifTrue: [#instVar]
			ifFalse: [#undefinedKeyword].
		self noteRange: kind from: skw  start to: skw end.
		skw]
)
slotDef = (
	^super slotDef wrap:
		[:tokens | | sd kind |
		sd:: (tokens at: 2) first.
		noteRange: #slotDecl from: sd start to: sd end.
		(* isFirst ifTrue: [pushScope. isFirst: false]. *)
		tokens]
)
slotName = (
	^super slotName wrap:
		[:n <Token> | | kind |
		kind:: ({'self'. 'super'. 'outer'. 'true'. 'false'. 'nil'} includes: n value)
			ifTrue: [n value asSymbol]
                  ifFalse: [symbol: n value
				ifInScope: [#instVar]
				ifNotInScope: [#undefinedUnary]
				ifObsolete: [#obsoleteMessage]].
		noteRange: kind from: n start to: n end.
		n]
)
string = (
	^super string wrap:
		[:t | self noteRange: #string from: t start to: t end. t]
)
symbol: aString <String> ifInScope: inScopeAction ifNotInScope: notInScopeAction ifObsolete: obsoleteAction = (
	scopeStack do: [:s | (s includesKey: aString) ifTrue: [^inScopeAction value]].
	^inScopeAction value (* BOGUS *)
)
symbolConstant = (
	^super symbolConstant wrapper:
		[:p <Token> :s |
		self noteRange: #symbol from: p start to: s end.
		s].
)
symbolInScope: aString <String> ^ <Boolean> = (
	scopeStack do: [:s | (s includesKey: aString) ifTrue: [^true]].

		(extendedCanUnderstand: aString) ifTrue: [^true].
		^false
)
temporaries = (
	|
	tempSlotDefs = tempSlotDef star.
 	tempSeqSlotDecls = vbar, tempSlotDefs, vbar.
 	tempSimSlotDecls = vbar, vbar, tempSlotDefs, vbar, vbar.
 	tempSlotDecls = tempSimSlotDecls | tempSeqSlotDecls.
	|

	^tempSlotDecls wrap:
		[:parts | | vb1 vb2 vds vb3 vb4 |
		parts size = 3
			ifTrue:
				[vb1:: parts at: 1.
				vb2:: vb1.
				vds:: parts at: 2.
				vb3:: parts at: 3.
				vb4:: vb3]
			ifFalse:
				[vb1:: parts at: 1.
			vb2:: parts at: 2.
			vds:: parts at: 3.
			vb3:: parts at: 4.
			vb4:: parts at: 5].

		isFirst: true.
		noteRange: #methodTempBar from: vb1 start to: vb2 end.
		noteRange: #methodTempBar from: vb3 start to: vb4 end.
		vds]
)
tupleType = (
(* The braces around the tuple type will colorize themselves, but their
colorization is superceded by the surrounding type. Therefore we remove the last
two elements from the rangeMap. *)
	^super tupleType wrapper:
		[:lc :t :rc | rangeMap removeLast; removeLast. t ]
)
type = (
	^super type wrapper:
		[:lb :te :rb | self noteRange: #type from: lb start to: rb end. te]
)
typeArguments = (
(* The brackets around the type arguments will colorize themselves, but their
colorization is superceded by the surrounding type. Therefore we remove the last
two elements from the rangeMap. *)
	^super typeArguments wrapper:
		[:lb :t :rb | rangeMap removeLast; removeLast. t ]
)
unaryMsgPattern = (
	^super unaryMsgPattern wrap:
		[:sel <Symbol> |
		rangeMap removeLast.
		self noteRange: #messagePatternDecl from: sel start to: sel end.
		sel].
)
unarySelector = (
	^super unarySelector wrap:
		[:t | | kind |
		kind:: selector: t value
			ifDefined: [#unary]
			ifIncomplete: [#incompleteUnary]
			ifUndefined: [#undefinedUnary]
			ifObsolete: [#obsoleteMessage].
		self noteRange: kind from: t start to: t end.
		t].
)
variableName = (
	^super variableName wrap:
		[:n <Token> |
		n value = 'self' ifTrue: [self noteRange: #self from: n start to: n end]
		ifFalse: [n value = 'super' ifTrue: [self noteRange: #super from: n start to: n end]
		ifFalse: [n value = 'true' ifTrue: [self noteRange: #true from: n start to: n end]
		ifFalse: [n value = 'false' ifTrue: [self noteRange: #false from: n start to: n end]
		ifFalse: [n value = 'nil' ifTrue: [self noteRange: #nil from: n start to: n end]
		ifFalse: []]]]].
		n]
)
tempSlotDef = (
	^super slotDef wrap: [ :tokens | | sd kind |
		sd:: (tokens at: 2) first.
		noteRange: #slotDecl from: sd start to: sd end.

		isFirst ifTrue: [pushScope. isFirst: false].
       scopeStack isEmpty ifTrue: [pushScope]. 
       (* Illegal input can cause the scope stack to be empty when it should not.
           This is a brute force hack to prevent crashes in these cases.
       *)

		kind:: (symbolInScope: sd value) ifTrue: [#shadowingTempVar] ifFalse: [#tempVar].
		currentScope at: sd value put: #temporary.
		currentScope at: sd value, ':' put: #temporary.
		noteRange: kind from: sd start to: sd end.

		tokens]
)
) : (
)
) : (
)