[squeak-dev] Squeak 4.5: ShoutCore-cwp.40.mcz
commits at source.squeak.org
commits at source.squeak.org
Fri Jan 24 20:18:07 UTC 2014
Chris Muller uploaded a new version of ShoutCore to project Squeak 4.5:
http://source.squeak.org/squeak45/ShoutCore-cwp.40.mcz
==================== Summary ====================
Name: ShoutCore-cwp.40
Author: cwp
Time: 1 January 2014, 1:11:46.449 pm
UUID: 81b3e230-2e8a-42c5-9521-e54338fadb6f
Ancestors: ShoutCore-fbs.39
Rewrite environment import/export to be eager, rather than lazy. (step 2 of 3)
==================== Snapshot ====================
SystemOrganization addCategory: #'ShoutCore-Monticello'!
SystemOrganization addCategory: #'ShoutCore-Parsing'!
SystemOrganization addCategory: #'ShoutCore-Styling'!
(PackageInfo named: 'ShoutCore') postscript: 'SHTextStylerST80 syntaxHighlightingAsYouType: Preferences syntaxHighlightingAsYouType.
SHTextStylerST80 syntaxHighlightingAsYouTypeLeftArrowAssignment: Preferences syntaxHighlightingAsYouTypeLeftArrowAssignment.
SHTextStylerST80 syntaxHighlightingAsYouTypeAnsiAssignment: Preferences syntaxHighlightingAsYouTypeAnsiAssignment.'!
----- Method: MCPatchBrowser>>aboutToStyle: (in category '*ShoutCore') -----
aboutToStyle: aStyler
selection ifNotNil: [
selection isConflict ifTrue: [ ^false ].
(selection isAddition or: [ selection isRemoval ]) ifTrue: [
selection definition isOrganizationDefinition ifTrue: [ ^false ].
aStyler classOrMetaClass: self selectedClassOrMetaClass.
^true ] ].
^false!
----- Method: MCSnapshotBrowser>>aboutToStyle: (in category '*ShoutCore') -----
aboutToStyle: aStyler
| classDefinition shouldStyle |
classSelection ifNil: [ ^false ].
self switchIsComment ifTrue: [ ^false ].
methodSelection
ifNotNil: [
classDefinition := items
detect: [:ea |
ea isClassDefinition and: [ ea className = classSelection ] ]
ifNone: [
(Smalltalk at: classSelection ifAbsent: [ Object ]) asClassDefinition ].
shouldStyle := true ]
ifNil: [
classDefinition := nil.
shouldStyle := categorySelection ~= self extensionsCategory ].
aStyler
environment: self;
classOrMetaClass: (classDefinition ifNotNil: [
SHMCClassDefinition
classDefinition: classDefinition
items: items
meta: switch = #class ]).
^shouldStyle!
----- Method: MCSnapshotBrowser>>bindingOf: (in category '*ShoutCore') -----
bindingOf: aSymbol
(Smalltalk bindingOf: aSymbol) ifNotNil: [ :binding | ^binding ].
items do: [ :each |
(each isClassDefinition and: [
each className = aSymbol ]) ifTrue: [ ^aSymbol -> each ] ].
^nil!
----- Method: MCSnapshotBrowser>>hasBindingThatBeginsWith: (in category '*ShoutCore') -----
hasBindingThatBeginsWith: aString
^false!
Object subclass: #SHMCClassDefinition
instanceVariableNames: 'classDefinition items meta'
classVariableNames: ''
poolDictionaries: ''
category: 'ShoutCore-Monticello'!
----- Method: SHMCClassDefinition class>>classDefinition:items:meta: (in category 'as yet unclassified') -----
classDefinition: aMCClassDefinition items: anObject meta: aBoolean
^self new
classDefinition: aMCClassDefinition;
items: anObject;
meta: aBoolean;
yourself!
----- Method: SHMCClassDefinition>>allInstVarNames (in category 'accessing') -----
allInstVarNames
| superclassOrDef answer classOrDef instVars|
answer := meta
ifTrue:[classDefinition classInstVarNames asArray]
ifFalse:[ classDefinition instVarNames asArray].
classOrDef := classDefinition.
[superclassOrDef := (classOrDef isKindOf: MCClassDefinition)
ifTrue:[ |s|
s := classOrDef superclassName.
items
detect: [:ea | ea isClassDefinition and: [ea className = s]]
ifNone: [Smalltalk at: s asSymbol ifAbsent:[nil]]]
ifFalse:[ | sc |
sc := classOrDef superclass.
sc ifNotNil:[
items
detect: [:ea | ea isClassDefinition and: [ea className = sc name asString]]
ifNone: [sc] ]].
superclassOrDef isNil
] whileFalse:[
instVars := (superclassOrDef isKindOf: MCClassDefinition)
ifTrue:[
meta
ifTrue:[superclassOrDef classInstVarNames]
ifFalse:[superclassOrDef instVarNames]]
ifFalse:["real"
meta
ifTrue:[superclassOrDef theNonMetaClass class instVarNames]
ifFalse:[superclassOrDef theNonMetaClass instVarNames]].
answer := answer, instVars.
classOrDef := superclassOrDef].
^answer!
----- Method: SHMCClassDefinition>>allowUnderscoreAssignments (in category 'act like a class') -----
allowUnderscoreAssignments
^nil!
----- Method: SHMCClassDefinition>>bindingOf: (in category 'act like environment') -----
bindingOf: aSymbol
| binding |
(binding := Smalltalk bindingOf: aSymbol)
ifNotNil: [^binding].
items do:[:each |
(each isClassDefinition and: [each className = aSymbol])
ifTrue:[^aSymbol -> each]].
^nil!
----- Method: SHMCClassDefinition>>classDefinition: (in category 'accessing') -----
classDefinition: aMCClassDefinition
classDefinition := aMCClassDefinition!
----- Method: SHMCClassDefinition>>classPool (in category 'act like a class') -----
classPool
| d |
d := Dictionary new.
classDefinition classVarNames do:[:each |
d at: each put: nil].
^d!
----- Method: SHMCClassDefinition>>environment (in category 'act like a class') -----
environment
^self!
----- Method: SHMCClassDefinition>>hasBindingThatBeginsWith: (in category 'act like environment') -----
hasBindingThatBeginsWith: aString
(Smalltalk globals hasBindingThatBeginsWith: aString) ifTrue: [^true].
items do:[:each |
(each isClassDefinition and: [each className beginsWith: aString])
ifTrue:[^true]].
^false!
----- Method: SHMCClassDefinition>>items: (in category 'accessing') -----
items: anObject
items := anObject!
----- Method: SHMCClassDefinition>>meta: (in category 'accessing') -----
meta: aBoolean
meta := aBoolean!
----- Method: SHMCClassDefinition>>sharedPools (in category 'act like a class') -----
sharedPools
| d |
d := Set new.
classDefinition poolDictionaries do:[:each |
d add: [Smalltalk at: each asSymbol ifAbsent:[nil]] ].
^d!
----- Method: SHMCClassDefinition>>shoutParserClass (in category 'accessing') -----
shoutParserClass
"Answer the parser class"
^SHParserST80!
----- Method: SHMCClassDefinition>>theNonMetaClass (in category 'act like a class') -----
theNonMetaClass
^self copy meta: false; yourself!
----- Method: SHMCClassDefinition>>withAllSuperclasses (in category 'accessing') -----
withAllSuperclasses
| superclassOrDef answer classOrDef |
answer := Array with: self.
classOrDef := classDefinition.
[superclassOrDef := (classOrDef isKindOf: MCClassDefinition)
ifTrue:[ |s|
s := classOrDef superclassName.
items
detect: [:ea | ea isClassDefinition and: [ea className = s]]
ifNone: [Smalltalk at: s asSymbol ifAbsent:[nil]]]
ifFalse:[ | sc |
sc := classOrDef superclass.
sc ifNotNil:[
items
detect: [:ea | ea isClassDefinition and: [ea className = sc name asString]]
ifNone: [sc] ]].
superclassOrDef isNil
] whileFalse:[
answer := answer, (Array with: superclassOrDef).
classOrDef := superclassOrDef].
^answer!
Object subclass: #SHParserST80
instanceVariableNames: 'classOrMetaClass source workspace arguments sourcePosition currentToken currentTokenFirst temporaries instanceVariables errorBlock currentTokenSourcePosition blockDepth bracketDepth ranges environment'
classVariableNames: ''
poolDictionaries: ''
category: 'ShoutCore-Parsing'!
!SHParserST80 commentStamp: 'tween 8/16/2004 15:44' prior: 0!
I am a Smalltalk method / expression parser.
Rather than creating an Abstract Syntax Tree, I create a sequence of SHRanges (in my 'ranges' instance variable), which represent the tokens within the String I am parsing.
I am used by a SHTextStylerST80 to parse method source strings.
I am able to parse incomplete / incorrect methods, and so can be used to parse methods that are being edited.
My 'source' instance variable should be set to the string to be parsed.
My 'classOrMetaClass' instance var must be set to the class or metaClass for the method source so that I can correctly resolve identifiers within the source. If this is nil , I parse the source as an expression (i.e. a doIt expression).
My 'workspace' instance variable can be set to a Workspace, so that I can resolve workspace variables.
My 'environment' instance variable is the global namespace (this is initialized to Smalltalk, but can be set to a different environment).
Example 1.
ranges := SHParserST80 new
classOrMetaClass: Object;
source: 'testMethod ^self';
parse;
ranges
!
----- Method: SHParserST80 class>>new (in category 'instance creation') -----
new
^super new
initialize;
yourself!
----- Method: SHParserST80>>allowUnderscoreAssignments (in category 'private') -----
allowUnderscoreAssignments
"Query class + preference"
^(classOrMetaClass ifNotNil: [:c | c allowUnderscoreAssignments])
ifNil: [Scanner allowUnderscoreAsAssignment ]!
----- Method: SHParserST80>>allowUnderscoreSelectors (in category 'private') -----
allowUnderscoreSelectors
^ Scanner prefAllowUnderscoreSelectors!
----- Method: SHParserST80>>classOrMetaClass: (in category 'accessing') -----
classOrMetaClass: aClass
classOrMetaClass := aClass!
----- Method: SHParserST80>>currentChar (in category 'scan') -----
currentChar
^source at: sourcePosition ifAbsent: [nil]!
----- Method: SHParserST80>>enterBlock (in category 'parse support') -----
enterBlock
blockDepth := blockDepth + 1.
bracketDepth := bracketDepth + 1!
----- Method: SHParserST80>>environment: (in category 'accessing') -----
environment: anObject
environment := anObject!
----- Method: SHParserST80>>error (in category 'error handling') -----
error
self
rangeType: #excessCode
start: (ranges isEmpty ifTrue: [1] ifFalse: [ranges last end + 1])
end: source size.
errorBlock value!
----- Method: SHParserST80>>failUnless: (in category 'error handling') -----
failUnless: aBoolean
aBoolean ifFalse:[self error]
!
----- Method: SHParserST80>>failWhen: (in category 'error handling') -----
failWhen: aBoolean
aBoolean ifTrue:[self error]!
----- Method: SHParserST80>>initialize (in category 'accessing') -----
initialize
environment := Smalltalk globals.!
----- Method: SHParserST80>>initializeInstanceVariables (in category 'parse support') -----
initializeInstanceVariables
instanceVariables := classOrMetaClass notNil
ifTrue: [classOrMetaClass allInstVarNames asArray]
ifFalse: [Set new]!
----- Method: SHParserST80>>isAnsiAssignment (in category 'token testing') -----
isAnsiAssignment
^currentToken = ':='!
----- Method: SHParserST80>>isAssignment (in category 'token testing') -----
isAssignment
^self isAnsiAssignment or: [self allowUnderscoreAssignments and: [currentToken = '_']]!
----- Method: SHParserST80>>isBigDigit:base: (in category 'character testing') -----
isBigDigit: aCharacter base: anInteger
"Answer true if aCharacter is a digit or a capital
letter appropriate for base anInteger"
| digitValue |
digitValue := aCharacter digitValue.
^digitValue >= 0 and:[digitValue < anInteger]!
----- Method: SHParserST80>>isBinary (in category 'token testing') -----
isBinary
(currentToken isNil or: [self isName or: [self isKeyword]])
ifTrue: [^false].
1 to: currentToken size do: [:i | | c |
c := currentToken at: i.
(self isSelectorCharacter: c)
ifFalse: [^false]].
^true!
----- Method: SHParserST80>>isBlockArgName: (in category 'identifier testing') -----
isBlockArgName: aString
"Answer true if aString is the name of a block argument, false otherwise"
| temp arg |
blockDepth to: 1 by: -1 do: [:level |
arg := (arguments at: level ifAbsent: [#()]) includes: aString.
arg ifTrue: [^true].
temp := (temporaries at: level ifAbsent: [#()]) includes: aString.
temp ifTrue: [^false]].
^false!
----- Method: SHParserST80>>isBlockTempName: (in category 'identifier testing') -----
isBlockTempName: aString
"Answer true if aString is the name of a block temporary. false otherwise"
| temp arg |
blockDepth to: 1 by: -1 do: [:level |
arg := (arguments at: level ifAbsent: [#()]) includes: aString.
arg ifTrue: [^false].
temp := (temporaries at: level ifAbsent: [#()]) includes: aString.
temp ifTrue: [^true]].
^false!
----- Method: SHParserST80>>isIncompleteBlockArgName: (in category 'identifier testing') -----
isIncompleteBlockArgName: aString
"Answer true if aString is the start of the name of a block argument, false otherwise"
| arg |
blockDepth to: 1 by: -1 do: [:level |
arg := (arguments at: level ifAbsent: [#()]) anySatisfy: [:each | each beginsWith: aString].
arg ifTrue: [^true]].
^false!
----- Method: SHParserST80>>isIncompleteBlockTempName: (in category 'identifier testing') -----
isIncompleteBlockTempName: aString
"Answer true if aString is the start of the name of a block temporary. false otherwise"
| temp |
blockDepth to: 1 by: -1 do: [:level |
temp := (temporaries at: level ifAbsent: [#()]) anySatisfy: [:each | each beginsWith: aString].
temp ifTrue: [^true]].
^false!
----- Method: SHParserST80>>isIncompleteMethodArgName: (in category 'identifier testing') -----
isIncompleteMethodArgName: aString
"Answer true if aString is the start of the name of a method argument, false otherwise.
Does not check whether aString is also a blockArgName"
^(arguments at: 0 ifAbsent: [#()]) anySatisfy: [:each | each beginsWith: aString]!
----- Method: SHParserST80>>isIncompleteMethodTempName: (in category 'identifier testing') -----
isIncompleteMethodTempName: aString
"Answer true if aString is the start of then name of a method temporary, false otherwise."
^(temporaries at: 0 ifAbsent: [#()]) anySatisfy: [:each | each beginsWith: aString]!
----- Method: SHParserST80>>isKeyword (in category 'token testing') -----
isKeyword
"This method assumes that currentTokenFirst is a non-letter character when currentToken is nil."
^(currentTokenFirst isLetter or: [
currentTokenFirst == $_ and: [
currentToken notNil and: [
currentToken size > 1 and: [
self allowUnderscoreSelectors ] ] ] ]) and: [
currentToken last == $: ]!
----- Method: SHParserST80>>isMethodArgName: (in category 'identifier testing') -----
isMethodArgName: aString
"Answer true if aString is the name of a method argument, false otherwise.
Does not check whether aString is also a blockArgName"
^(arguments at: 0 ifAbsent: [#()]) includes: aString!
----- Method: SHParserST80>>isMethodTempName: (in category 'identifier testing') -----
isMethodTempName: aString
"Answer true if aString is the name of a method temporary, false otherwise.
Does not check whether aString is also a block temporary
or argument"
((arguments at: 0 ifAbsent: [#()]) includes: aString) ifTrue: [^false].
^(temporaries at: 0 ifAbsent: [#()]) includes: aString!
----- Method: SHParserST80>>isName (in category 'token testing') -----
isName
"This method assumes that currentTokenFirst is a non-letter character when currentToken is nil."
^(currentTokenFirst isLetter or: [
currentTokenFirst == $_ and: [
currentToken notNil and: [
currentToken size > 1 and: [
self allowUnderscoreSelectors ] ] ] ]) and: [
currentToken last isAlphaNumeric or: [
currentToken last == $_ and: [
self allowUnderscoreSelectors ] ] ] !
----- Method: SHParserST80>>isSelectorCharacter: (in category 'character testing') -----
isSelectorCharacter: aCharacter
aCharacter isAlphaNumeric ifTrue: [^false].
aCharacter isSeparator ifTrue:[^false].
('"#$'':().;[]{}^_' includes: aCharacter)
ifTrue:[^false].
aCharacter asciiValue = 30 ifTrue: [^false "the doIt char"].
aCharacter asciiValue = 0 ifTrue: [^false].
"Any other char is ok as a binary selector char."
^true
!
----- Method: SHParserST80>>isTokenExternalFunctionCallingConvention (in category 'token testing') -----
isTokenExternalFunctionCallingConvention
| descriptorClass |
descriptorClass := Smalltalk at: #ExternalFunction ifAbsent: [nil].
descriptorClass == nil ifTrue: [^false].
^(descriptorClass callingConventionFor: currentToken) notNil!
----- Method: SHParserST80>>leaveBlock (in category 'parse support') -----
leaveBlock
arguments removeKey: blockDepth ifAbsent: [].
temporaries removeKey: blockDepth ifAbsent: [].
blockDepth := blockDepth - 1.
bracketDepth := bracketDepth - 1!
----- Method: SHParserST80>>nextChar (in category 'scan') -----
nextChar
sourcePosition := sourcePosition + 1.
^source at: sourcePosition ifAbsent: $ !
----- Method: SHParserST80>>parse (in category 'parse') -----
parse
"Parse the receiver's text as a Smalltalk method"
^self parse: (classOrMetaClass notNil) !
----- Method: SHParserST80>>parse: (in category 'parse') -----
parse: isAMethod
"Parse the receiver's text. If isAMethod is true
then treat text as a method, if false as an
expression with no message pattern"
self initializeInstanceVariables.
sourcePosition := 1.
arguments := Dictionary new.
temporaries := Dictionary new.
blockDepth := bracketDepth := 0.
ranges
ifNil: [ranges := OrderedCollection new: 100]
ifNotNil: [ranges reset].
errorBlock := [^false].
[self scanNext.
isAMethod
ifTrue: [
self parseMessagePattern.
self parsePragmaSequence].
self parseMethodTemporaries.
isAMethod ifTrue: [self parsePragmaSequence].
self parseStatementList.
currentToken ifNotNil: [self error]]
ensure:[errorBlock := nil].
^true!
----- Method: SHParserST80>>parseArray (in category 'parse') -----
parseArray
[currentTokenFirst == $)] whileFalse: [self parseLiteralArrayElement].
self scanPast: #arrayEnd!
----- Method: SHParserST80>>parseBinary (in category 'parse') -----
parseBinary
| binary type |
self parseUnary.
[self isBinary]
whileTrue: [
binary := currentToken.
type := #binary.
(binary isEmpty or:[(Symbol lookup: binary) notNil])
ifFalse:[
type := (Symbol thatStartsCaseSensitive: binary skipping: nil)
ifNil: [#undefinedBinary]
ifNotNil:[#incompleteBinary]].
self scanPast: type.
self parseTerm.
self parseUnary]
!
----- Method: SHParserST80>>parseBinaryMessagePattern (in category 'parse') -----
parseBinaryMessagePattern
self scanPast: #patternBinary.
self failUnless: self isName.
self scanPast: #patternArg.
!
----- Method: SHParserST80>>parseBlock (in category 'parse') -----
parseBlock
self enterBlock.
self scanPast: #blockStart level: bracketDepth.
currentTokenFirst == $: ifTrue: [self parseBlockArguments].
currentTokenFirst == $| ifTrue: [self parseBlockTemporaries].
self parseStatementList.
self failUnless: currentTokenFirst == $].
self scanPast: #blockEnd level: bracketDepth.
self leaveBlock!
----- Method: SHParserST80>>parseBlockArguments (in category 'parse') -----
parseBlockArguments
[currentTokenFirst == $:]
whileTrue: [
self scanPast: #blockArgColon.
self failUnless: self isName.
self scanPast: #blockPatternArg].
currentTokenFirst == $|
ifTrue: [^self scanPast: #blockArgsBar]!
----- Method: SHParserST80>>parseBlockTemporaries (in category 'parse') -----
parseBlockTemporaries
currentTokenFirst == $|
ifTrue: [
self scanPast: #blockTempBar.
[self isName]
whileTrue: [self scanPast: #blockPatternTempVar].
self failUnless: currentToken = '|'.
self scanPast: #blockTempBar]!
----- Method: SHParserST80>>parseBraceArray (in category 'parse') -----
parseBraceArray
self parseStatementListForBraceArray.
self failUnless: currentTokenFirst == $}.
self scanPast: #rightBrace!
----- Method: SHParserST80>>parseByteArray (in category 'parse') -----
parseByteArray
[currentTokenFirst == $]] whileFalse: [
currentTokenFirst isDigit
ifTrue: [
"do not parse the number, can be time consuming"
self scanPast: #number]
ifFalse: [
self failWhen: currentTokenFirst == $. .
self error]].
self scanPast: #byteArrayEnd!
----- Method: SHParserST80>>parseCascade (in category 'parse') -----
parseCascade
self parseKeyword.
[currentTokenFirst == $;]
whileTrue: [
self scanPast: #cascadeSeparator.
self parseKeyword]!
----- Method: SHParserST80>>parseCharSymbol (in category 'parse') -----
parseCharSymbol
| s e |
s := sourcePosition - 1.
e := sourcePosition.
self nextChar.
self scanPast: #symbol start: s end: e!
----- Method: SHParserST80>>parseExpression (in category 'parse') -----
parseExpression
| assignType |
self isName
ifTrue: [
self scanPast: (self resolve: currentToken).
self isAssignment
ifTrue: [
assignType := self isAnsiAssignment
ifTrue: [#ansiAssignment]
ifFalse: [#assignment].
self scanPast: assignType.
self parseExpression]
ifFalse: [self parseCascade]]
ifFalse: [
self parseTerm.
self parseCascade]!
----- Method: SHParserST80>>parseExternalCall (in category 'parse') -----
parseExternalCall
[self scanNext.
((Smalltalk at: #ExternalFunction) callingConventionModifierFor: currentToken) notNil]
whileTrue.
self failUnless: currentToken notNil.
self scanPast: #externalCallType.
currentToken = '*'
ifTrue: [self scanPast: #externalCallTypePointerIndicator].
currentTokenFirst isDigit
ifTrue: [self scanPast: #integer]
ifFalse: [
self failUnless: currentTokenFirst == $'.
self parseString].
self failUnless: currentTokenFirst == $(.
self scanPast: #leftParenthesis.
[currentTokenFirst ~= $)]
whileTrue: [
self failUnless: currentToken notNil.
self scanPast: #externalCallType.
currentToken = '*'
ifTrue: [self scanPast: #externalCallTypePointerIndicator]].
self scanPast: #rightParenthesis.
currentToken = 'module:'
ifTrue: [
self scanPast: #module.
self parseStringOrSymbol ].
currentToken = 'error:' ifTrue: [
self scanPast: #primitive. "there's no rangeType for error"
self isName
ifTrue: [ self scanPast: #patternTempVar ]
ifFalse: [ self parseStringOrSymbol ] ].
self failUnless: currentToken = '>'.
self scanPast: #primitiveOrExternalCallEnd!
----- Method: SHParserST80>>parseKeyword (in category 'parse') -----
parseKeyword
| keyword rangeIndices |
self parseBinary.
keyword := ''.
rangeIndices := #().
[
[self isKeyword]
whileTrue: [
keyword := keyword, currentToken.
self rangeType: #keyword.
"remember where this keyword token is in ranges"
rangeIndices := rangeIndices copyWith: ranges size.
self scanNext.
self parseTerm.
self parseBinary ]
] ensure: [ | type |
"do this in an ensure so that it happens even if the errorBlock evaluates before getting here"
"patch up the keyword tokens, so that incomplete and undefined ones look different"
(keyword isEmpty or:[(Symbol lookup: keyword) notNil])
ifFalse:[
type := (Symbol thatStartsCaseSensitive: keyword skipping: nil)
ifNil: [#undefinedKeyword]
ifNotNil:[#incompleteKeyword].
rangeIndices do: [:i | (ranges at: i) type: type]]]!
----- Method: SHParserST80>>parseKeywordMessagePattern (in category 'parse') -----
parseKeywordMessagePattern
[self isKeyword]
whileTrue: [
self scanPast: #patternKeyword.
self failUnless: self isName.
self scanPast: #patternArg]
!
----- Method: SHParserST80>>parseLiteral: (in category 'parse') -----
parseLiteral: inArray
currentTokenFirst == $$
ifTrue: [
| pos |
self failWhen: self currentChar isNil.
self rangeType: #'$'.
pos := currentTokenSourcePosition + 1.
self nextChar.
^self scanPast: #character start: pos end: pos].
currentTokenFirst isDigit
ifTrue: [
"do not parse the number, can be time consuming"
^self scanPast: #number].
currentToken = '-'
ifTrue: [
| c |
c := self currentChar.
(inArray and: [c isNil or: [c isDigit not]])
ifTrue: [
"single - can be a symbol in an Array"
^self scanPast: #symbol].
self scanPast: #-.
self failWhen: currentToken isNil.
"token isNil ifTrue: [self error: 'Unexpected End Of Input']."
"do not parse the number, can be time consuming"
^self scanPast: #number].
currentTokenFirst == $' ifTrue: [^self parseString].
currentTokenFirst == $# ifTrue: [^self parseSymbol].
(inArray and: [currentToken notNil]) ifTrue: [^self scanPast: #symbol].
self failWhen: currentTokenFirst == $. .
self error ": 'argument missing'"!
----- Method: SHParserST80>>parseLiteralArrayElement (in category 'parse') -----
parseLiteralArrayElement
currentTokenFirst isLetter
ifTrue: [
| type |
type := (#('true' 'false' 'nil') includes: currentToken)
ifTrue: [currentToken asSymbol]
ifFalse: [#symbol].
^self scanPast: type].
currentTokenFirst == $(
ifTrue: [
self scanPast: #arrayStart.
^self parseArray].
^self parseLiteral: true!
----- Method: SHParserST80>>parseMessagePattern (in category 'parse') -----
parseMessagePattern
self isName
ifTrue: [self parseUnaryMessagePattern]
ifFalse: [
self isBinary
ifTrue:[self parseBinaryMessagePattern]
ifFalse:[
self failUnless: self isKeyword.
self parseKeywordMessagePattern]]!
----- Method: SHParserST80>>parseMethodTemporaries (in category 'parse') -----
parseMethodTemporaries
currentTokenFirst == $|
ifTrue: [
self scanPast: #methodTempBar.
[self isName]
whileTrue: [self scanPast: #patternTempVar].
self failUnless: currentToken = '|'.
self scanPast: #methodTempBar]!
----- Method: SHParserST80>>parsePragmaBinary (in category 'parse') -----
parsePragmaBinary
self scanPast: #pragmaBinary.
self isName
ifTrue:[self scanPast: (self resolvePragmaArgument: currentToken)]
ifFalse:[ self parseLiteral: false].
self failUnless: currentToken = '>'.
self scanPast: #primitiveOrExternalCallEnd!
----- Method: SHParserST80>>parsePragmaKeyword (in category 'parse') -----
parsePragmaKeyword
[self isKeyword]
whileTrue:[
self scanPast: #pragmaKeyword.
self isName
ifTrue:[self scanPast: (self resolvePragmaArgument: currentToken)]
ifFalse:[ self parseLiteral: false]].
self failUnless: currentToken = '>'.
self scanPast: #primitiveOrExternalCallEnd!
----- Method: SHParserST80>>parsePragmaSequence (in category 'parse') -----
parsePragmaSequence
[currentToken = '<' ]
whileTrue:[
self scanPast: #primitiveOrExternalCallStart.
currentToken = 'primitive:'
ifTrue: [
self rangeType: #primitive.
self parsePrimitive]
ifFalse:[
self isTokenExternalFunctionCallingConvention
ifTrue: [
self rangeType: #externalFunctionCallingConvention.
self parseExternalCall]
ifFalse:[
self isName
ifTrue:[
self scanPast: #pragmaUnary.
self failUnless: currentToken = '>'.
self scanPast: #primitiveOrExternalCallEnd]
ifFalse:[
self isKeyword
ifTrue:[
self parsePragmaKeyword]
ifFalse:[
self isBinary
ifTrue:[self parsePragmaBinary]
ifFalse:[ self error ": 'Invalid External Function Calling convention'" ]]]]]]!
----- Method: SHParserST80>>parsePrimitive (in category 'parse') -----
parsePrimitive
self scanNext.
currentTokenFirst isDigit
ifTrue: [ self scanPast: #integer ]
ifFalse: [
self parseStringOrSymbol.
currentToken = 'module:' ifTrue: [
self scanPast: #module.
self parseStringOrSymbol ] ].
currentToken = 'error:' ifTrue: [
self scanPast: #primitive. "there's no rangeType for error"
self isName
ifTrue: [ self scanPast: #patternTempVar ]
ifFalse: [ self parseStringOrSymbol ] ].
self failUnless: currentToken = '>'.
self scanPast: #primitiveOrExternalCallEnd!
----- Method: SHParserST80>>parseStatement (in category 'parse') -----
parseStatement
currentTokenFirst == $^ ifTrue: [self scanPast: #return].
self parseExpression!
----- Method: SHParserST80>>parseStatementList (in category 'parse') -----
parseStatementList
[[currentTokenFirst == $.] whileTrue: [self scanPast: #statementSeparator].
(currentToken notNil and: [currentTokenFirst ~~ $]])
ifTrue: [self parseStatement].
currentTokenFirst == $.]
whileTrue: [self scanPast: #statementSeparator]!
----- Method: SHParserST80>>parseStatementListForBraceArray (in category 'parse') -----
parseStatementListForBraceArray
"same as parseStatementList, but does not allow empty statements e.g {...$a...}.
A single terminating . IS allowed e.g. {$a.} "
[currentTokenFirst ~~ $} ifTrue: [self parseStatement].
currentTokenFirst == $.]
whileTrue: [self scanPast: #statementSeparator]!
----- Method: SHParserST80>>parseString (in category 'parse') -----
parseString
| first c answer last |
first := sourcePosition.
answer := ''.
[(c := self currentChar)
ifNil: [
self rangeType: #unfinishedString start: first - 1 end: source size.
self error ": 'unfinished string'"].
(c == $'
ifFalse: [answer := answer copyWith: c. true]
ifTrue: [false]
) or: [
self peekChar == $'
ifTrue: [
sourcePosition := sourcePosition + 1.
answer := answer copyWith: $'.
true]
ifFalse: [false]]
] whileTrue: [sourcePosition := sourcePosition + 1].
last := sourcePosition.
self nextChar.
self scanPast: #string start: first - 1 end: last.
^answer!
----- Method: SHParserST80>>parseStringOrSymbol (in category 'parse') -----
parseStringOrSymbol
currentTokenFirst == $' ifTrue: [ ^self parseString ].
currentTokenFirst == $# ifTrue: [ ^self parseSymbol ].
self error!
----- Method: SHParserST80>>parseSymbol (in category 'parse') -----
parseSymbol
| c |
currentToken = '#'
ifTrue: [
"if token is just the #, then scan whitespace and comments
and then process the next character.
Squeak allows space between the # and the start of the symbol
e.g. # (), # a, # 'sym' "
self rangeType: #symbol.
self scanWhitespace].
c := self currentChar.
self failWhen: (c isNil or: [c isSeparator]).
c == $(
ifTrue: [
self nextChar.
self scanPast: #arrayStart start: currentTokenSourcePosition end: currentTokenSourcePosition + 1.
^self parseArray].
c == $' ifTrue: [^self parseSymbolString].
c == $[ ifTrue: [
self nextChar.
self scanPast: #byteArrayStart start: currentTokenSourcePosition end: currentTokenSourcePosition + 1.
^self parseByteArray].
((self isSelectorCharacter: c) or: [c == $-])
ifTrue: [^self parseSymbolSelector].
(c isLetter or: [
c == $: or: [
c == $_ and: [self allowUnderscoreSelectors] ] ])
ifTrue: [^self parseSymbolIdentifier].
^self parseCharSymbol!
----- Method: SHParserST80>>parseSymbolIdentifier (in category 'parse') -----
parseSymbolIdentifier
| c start end |
c := self currentChar.
self failUnless: (c isLetter or: [c == $: or: [c == $_ and: [self allowUnderscoreSelectors]]]).
start := sourcePosition.
[c := self nextChar.
c isAlphaNumeric or: [c == $: or: [c == $_ and: [self allowUnderscoreSelectors]]]] whileTrue.
end := sourcePosition - 1.
c := source copyFrom: start - 1 to: end.
self scanPast: #symbol start: start - 1 end: end.
^c!
----- Method: SHParserST80>>parseSymbolSelector (in category 'parse') -----
parseSymbolSelector
| start end |
start := sourcePosition - 1.
end := sourcePosition.
[self isSelectorCharacter: self nextChar]
whileTrue: [end := sourcePosition].
self scanPast: #symbol start: start end: end!
----- Method: SHParserST80>>parseSymbolString (in category 'parse') -----
parseSymbolString
| first c last |
first := sourcePosition.
self nextChar.
[(c := self currentChar)
ifNil: [
self rangeType: #unfinishedString start: first end: source size.
self error ": 'unfinished string'"].
c ~~ $' or: [
self peekChar == $'
ifTrue: [sourcePosition := sourcePosition + 1.true]
ifFalse: [false]]
] whileTrue: [sourcePosition := sourcePosition + 1].
last := sourcePosition.
self nextChar.
self scanPast: #stringSymbol start: first - 1 end: last!
----- Method: SHParserST80>>parseTerm (in category 'parse') -----
parseTerm
self failWhen: currentToken isNil.
currentTokenFirst == $(
ifTrue: [
bracketDepth := bracketDepth + 1.
self scanPast: #leftParenthesis level: bracketDepth.
self parseExpression.
self failUnless: currentTokenFirst == $).
self scanPast: #rightParenthesis level: bracketDepth.
^bracketDepth := bracketDepth - 1].
currentTokenFirst == $[ ifTrue: [^self parseBlock].
currentTokenFirst == ${
ifTrue: [
self scanPast: #leftBrace.
^self parseBraceArray].
self isName ifTrue: [^self scanPast: (self resolve: currentToken)].
self parseLiteral: false!
----- Method: SHParserST80>>parseUnary (in category 'parse') -----
parseUnary
| unary type |
[self isName]
whileTrue: [
unary := currentToken.
type := #unary.
(unary isEmpty or:[(Symbol lookup: unary) notNil])
ifFalse:[
type := (Symbol thatStartsCaseSensitive: unary skipping: nil)
ifNil: [#undefinedUnary]
ifNotNil:[#incompleteUnary]].
self scanPast: type]
!
----- Method: SHParserST80>>parseUnaryMessagePattern (in category 'parse') -----
parseUnaryMessagePattern
self scanPast: #patternUnary
!
----- Method: SHParserST80>>peekChar (in category 'scan') -----
peekChar
^source at: sourcePosition + 1 ifAbsent: [$ ]!
----- Method: SHParserST80>>pushArgument: (in category 'parse support') -----
pushArgument: aString
(arguments at: blockDepth ifAbsentPut: [OrderedCollection new: 10])
add: aString!
----- Method: SHParserST80>>pushTemporary: (in category 'parse support') -----
pushTemporary: aString
(temporaries at: blockDepth ifAbsentPut: [OrderedCollection new: 10])
add: aString!
----- Method: SHParserST80>>rangeType: (in category 'recording ranges') -----
rangeType: aSymbol
^self
rangeType: aSymbol
start: currentTokenSourcePosition
end: currentTokenSourcePosition + currentToken size - 1!
----- Method: SHParserST80>>rangeType:start:end: (in category 'recording ranges') -----
rangeType: aSymbol start: s end: e
^ranges add: (SHRange start: s end: e type: aSymbol)!
----- Method: SHParserST80>>ranges (in category 'accessing') -----
ranges
^ranges!
----- Method: SHParserST80>>rangesIn:classOrMetaClass:workspace:environment: (in category 'parse') -----
rangesIn: sourceString classOrMetaClass: aBehaviour workspace: aWorkspace environment: anEnvironmentOrNil
anEnvironmentOrNil ifNotNil: [environment := anEnvironmentOrNil].
self
workspace: aWorkspace;
classOrMetaClass: aBehaviour;
source: sourceString.
self parse.
^ranges!
----- Method: SHParserST80>>resolve: (in category 'identifier testing') -----
resolve: aString
(#('self' 'super' 'true' 'false' 'nil' 'thisContext') includes: aString)
ifTrue: [^aString asSymbol].
(self isBlockTempName: aString) ifTrue: [^#blockTempVar].
(self isBlockArgName: aString) ifTrue: [^#blockArg].
(self isMethodTempName: aString) ifTrue: [^#tempVar].
(self isMethodArgName: aString) ifTrue: [^#methodArg].
(instanceVariables includes: aString) ifTrue: [^#instVar].
workspace
ifNotNil: [(workspace hasBindingOf: aString) ifTrue: [^#workspaceVar]].
Symbol hasInterned: aString ifTrue: [:sym |
classOrMetaClass isBehavior
ifTrue: [
classOrMetaClass theNonMetaClass withAllSuperclasses do: [:c |
(c classPool bindingOf: sym) ifNotNil: [^#classVar].
c sharedPools do: [:p | (p bindingOf: sym) ifNotNil: [^#poolConstant]].
(c environment bindingOf: sym) ifNotNil: [^#globalVar]]]
ifFalse: [(environment bindingOf: sym) ifNotNil: [^#globalVar]]].
^self resolvePartial: aString!
----- Method: SHParserST80>>resolvePartial: (in category 'identifier testing') -----
resolvePartial: aString
"check if any identifier begins with aString"
(#('self' 'super' 'true' 'false' 'nil' 'thisContext') anySatisfy: [:each | each beginsWith: aString])
ifTrue: [^#incompleteIdentifier].
(self isIncompleteBlockTempName: aString) ifTrue: [^#incompleteIdentifier].
(self isIncompleteBlockArgName: aString) ifTrue: [^#incompleteIdentifier].
(self isIncompleteMethodTempName: aString) ifTrue: [^#incompleteIdentifier].
(self isIncompleteMethodArgName: aString) ifTrue: [^#incompleteIdentifier].
(instanceVariables anySatisfy: [:each | each beginsWith: aString]) ifTrue: [^#incompleteIdentifier].
workspace
ifNotNil: [(workspace hasBindingThatBeginsWith: aString) ifTrue: [^#incompleteIdentifier]].
classOrMetaClass isBehavior
ifTrue: [
classOrMetaClass theNonMetaClass withAllSuperclasses do: [:c |
(c classPool hasBindingThatBeginsWith: aString) ifTrue: [^#incompleteIdentifier].
c sharedPools do: [:p | (p hasBindingThatBeginsWith: aString) ifTrue: [^#incompleteIdentifier]].
(c environment hasBindingThatBeginsWith: aString) ifTrue: [^#incompleteIdentifier]]]
ifFalse: [(environment hasBindingThatBeginsWith: aString) ifTrue: [^#incompleteIdentifier]].
^#undefinedIdentifier!
----- Method: SHParserST80>>resolvePartialPragmaArgument: (in category 'identifier testing') -----
resolvePartialPragmaArgument: aString
"check if any valid pragma argument begins with aString"
(#('true' 'false' 'nil') anySatisfy: [:each | each beginsWith: aString])
ifTrue: [^#incompleteIdentifier].
"should really check that a matching binding is for a Class?"
classOrMetaClass isBehavior
ifTrue: [
classOrMetaClass theNonMetaClass withAllSuperclasses do: [:c |
(c environment hasBindingThatBeginsWith: aString) ifTrue: [^#incompleteIdentifier]]]
ifFalse: [(environment hasBindingThatBeginsWith: aString) ifTrue: [^#incompleteIdentifier]].
^#undefinedIdentifier!
----- Method: SHParserST80>>resolvePragmaArgument: (in category 'identifier testing') -----
resolvePragmaArgument: aString
(#('true' 'false' 'nil') includes: aString) ifTrue: [^aString asSymbol].
"should really check that global is a class?"
Symbol hasInterned: aString ifTrue: [:sym |
classOrMetaClass isBehavior
ifTrue: [
classOrMetaClass theNonMetaClass withAllSuperclasses do: [:c |
(c environment bindingOf: sym) ifNotNil: [^#globalVar]]]
ifFalse: [(environment bindingOf: sym) ifNotNil: [^#globalVar]]].
^self resolvePartialPragmaArgument: aString!
----- Method: SHParserST80>>scanBinary (in category 'scan') -----
scanBinary
| c d |
c := self currentChar.
currentTokenSourcePosition := sourcePosition.
currentToken := c asString.
d := self nextChar.
((self isSelectorCharacter: c) or: [c == $:]) ifFalse: [^currentToken].
(c == $: and: [d == $=])
ifTrue: [" := assignment"
currentToken := currentToken , d asString.
self nextChar.
^currentToken].
c == $| ifTrue:["| cannot precede a longer token" ^currentToken].
[self isSelectorCharacter: d]
whileTrue: [
currentToken := currentToken , d asString.
d := self nextChar].
^currentToken!
----- Method: SHParserST80>>scanComment (in category 'scan') -----
scanComment
| c s e |
s := sourcePosition.
[sourcePosition := sourcePosition + 1.
(c := self currentChar)
ifNil: [
self rangeType: #unfinishedComment start: s end: source size.
^self error ": 'unfinished comment'"].
c == $"]
whileFalse: [].
e := sourcePosition.
s < e ifTrue: [self rangeType: #comment start: s end: e].
self nextChar.
self scanWhitespace!
----- Method: SHParserST80>>scanIdentifier (in category 'scan') -----
scanIdentifier
| c start |
start := sourcePosition.
[(c := self nextChar) isAlphaNumeric or: [c == $_ and: [self allowUnderscoreSelectors]]] whileTrue.
(c == $: and: [(self isSelectorCharacter: self peekChar) not])
ifTrue: [self nextChar].
currentToken := source copyFrom: start to: sourcePosition - 1.
currentTokenSourcePosition := start!
----- Method: SHParserST80>>scanNext (in category 'scan') -----
scanNext
self scanWhitespace.
currentTokenFirst := self currentChar.
currentTokenFirst
ifNil: [" end of input "
currentTokenFirst := $ .
currentTokenSourcePosition := nil.
currentToken := nil.
^nil].
currentTokenFirst isDigit ifTrue: [^self scanNumber].
(currentTokenFirst isLetter or: [
currentTokenFirst == $_ and: [ self allowUnderscoreSelectors ] ])
ifTrue: [^self scanIdentifier].
^self scanBinary!
----- Method: SHParserST80>>scanNumber (in category 'scan') -----
scanNumber
| start c nc base |
start := sourcePosition.
self skipDigits.
c := self currentChar.
c == $r
ifTrue: [
base := Integer readFrom: (ReadStream on: (source copyFrom: start to: sourcePosition - 1)).
self peekChar == $- ifTrue:[self nextChar].
self skipBigDigits: base.
c := self currentChar.
c == $.
ifTrue: [
(self isBigDigit: self nextChar base: base)
ifFalse: [sourcePosition := sourcePosition - 1]
ifTrue: [self skipBigDigits: base]].
c := self currentChar.
('deq'includes: c)
ifTrue: [
((nc := self nextChar) isDigit or: [nc == $- and:[self peekChar isDigit]])
ifFalse: [sourcePosition := sourcePosition - 1]
ifTrue: [self skipDigits]].
c == $s
ifTrue: [
self nextChar isDigit
ifFalse: [sourcePosition := sourcePosition - 1]
ifTrue: [self skipDigits]].
currentToken := source copyFrom: start to: sourcePosition - 1.
^currentTokenSourcePosition := start].
c == $s
ifTrue: [
self nextChar isDigit
ifFalse: [sourcePosition := sourcePosition - 1]
ifTrue: [self skipDigits.].
currentToken := source copyFrom: start to: sourcePosition - 1.
^currentTokenSourcePosition := start].
c == $.
ifTrue: [
self nextChar isDigit
ifFalse: [
sourcePosition := sourcePosition - 1.
currentToken := source copyFrom: start to: sourcePosition - 1.
^currentTokenSourcePosition := start]
ifTrue: [self skipDigits]].
c := self currentChar.
('deq' includes: c)
ifTrue: [
((nc := self nextChar) isDigit or: [nc == $- and:[self peekChar isDigit]])
ifFalse: [sourcePosition := sourcePosition - 1]
ifTrue: [self skipDigits]].
c == $s
ifTrue: [
self nextChar isDigit
ifFalse: [sourcePosition := sourcePosition - 1]
ifTrue: [self skipDigits]].
currentToken := source copyFrom: start to: sourcePosition - 1.
^currentTokenSourcePosition := start!
----- Method: SHParserST80>>scanPast: (in category 'scan') -----
scanPast: rangeType
"record rangeType for current token .
record argument and temp declarations.
scan and answer the next token"
rangeType = #blockPatternArg ifTrue: [self pushArgument: currentToken].
rangeType = #blockPatternTempVar ifTrue: [self pushTemporary: currentToken].
rangeType = #patternArg ifTrue: [self pushArgument: currentToken].
rangeType = #patternTempVar ifTrue: [self pushTemporary: currentToken].
^self
rangeType: rangeType;
scanNext!
----- Method: SHParserST80>>scanPast:level: (in category 'scan') -----
scanPast: rangeType level: level
"first level adds no suffix to the rangeType.
Suffix from 1 to 7 added in cycles , ((level-2) mod(7) + 1)"
| cycle typePlusCycle |
cycle := level <= 1
ifTrue: [0]
ifFalse:[ ((level - 2) \\ 7) + 1].
typePlusCycle := cycle = 0
ifTrue:[rangeType]
ifFalse:[(rangeType, cycle asString) asSymbol].
^self scanPast: typePlusCycle
!
----- Method: SHParserST80>>scanPast:start:end: (in category 'scan') -----
scanPast: rangeType start: startInteger end: endInteger
"record rangeType for current token from startInteger to endInteger,
and scanNext token"
^self
rangeType: rangeType start: startInteger end: endInteger;
scanNext
!
----- Method: SHParserST80>>scanWhitespace (in category 'scan') -----
scanWhitespace
| c |
[c := self currentChar.
c notNil and: [c isSeparator]]
whileTrue: [sourcePosition := sourcePosition + 1].
c == $" ifTrue: [self scanComment]!
----- Method: SHParserST80>>skipBigDigits: (in category 'scan') -----
skipBigDigits: baseInteger
[self isBigDigit: self nextChar base: baseInteger]
whileTrue: []
!
----- Method: SHParserST80>>skipDigits (in category 'scan') -----
skipDigits
[self nextChar isDigit]
whileTrue: []!
----- Method: SHParserST80>>source (in category 'accessing') -----
source
^source!
----- Method: SHParserST80>>source: (in category 'accessing') -----
source: aString
source := aString!
----- Method: SHParserST80>>workspace: (in category 'accessing') -----
workspace: aWorkspace
workspace := aWorkspace!
Object subclass: #SHRange
instanceVariableNames: 'start end type'
classVariableNames: ''
poolDictionaries: ''
category: 'ShoutCore-Parsing'!
!SHRange commentStamp: 'tween 8/16/2004 15:16' prior: 0!
I associate a type with a range of characters in a String
I have these instance variables...
start - the one based index of the first character of the range within the String.
end - the one based index of the last character of the range within the String.
type - a Symbol describing the type of the range
A sequence of instances of me are created by an instance of SHParserST80 which can then used by an instance of SHTextStyler to style Text. !
----- Method: SHRange class>>start:end:type: (in category 'instance creation') -----
start: s end: e type: aSymbol
^self new
start: s end: e type: aSymbol;
yourself!
----- Method: SHRange>>end (in category 'accessing') -----
end
^end!
----- Method: SHRange>>end: (in category 'accessing') -----
end: anInteger
end := anInteger!
----- Method: SHRange>>length (in category 'accessing') -----
length
^end - start + 1!
----- Method: SHRange>>start (in category 'accessing') -----
start
^start!
----- Method: SHRange>>start: (in category 'accessing') -----
start: anInteger
start := anInteger!
----- Method: SHRange>>start:end:type: (in category 'accessing') -----
start: startInteger end: endInteger type: typeSymbol
start := startInteger.
end := endInteger.
type := typeSymbol!
----- Method: SHRange>>type (in category 'accessing') -----
type
^type!
----- Method: SHRange>>type: (in category 'accessing') -----
type: aSymbol
type := aSymbol!
Object subclass: #SHTextStyler
instanceVariableNames: 'sem backgroundProcess text monitor view stylingEnabled'
classVariableNames: ''
poolDictionaries: ''
category: 'ShoutCore-Styling'!
!SHTextStyler commentStamp: 'tween 8/27/2004 10:54' prior: 0!
I am an Abstract class.
Subclasses of me can create formatted, coloured, and styled copies of Text that is given to them.
They may perform their styling asynchronously, in a background process which I create and manage.
My public interface is...
view: aViewOrMorph - set the view that will receive notifications when styling has completed.
format: aText - modifies aText's string
style: aText - modifies the TextAttributes of aText, but does not change the string, then sends #stylerStyled: to the view.
styleInBackgroundProcess: aText - performs style: in a background process, then sends #stylerStylednBackground: to the view.
styledTextFor: aText - answers a formatted and styled copy of aText
unstyledTextFrom: aText - answers a copy of aText with all TextAttributes removed
Subclasses of me should re-implement...
privateFormat: aText - answer a formatted version of aText; the String may be changed
privateStyle: aText - modify the TextAttributes of aText; but do not change the String
!
----- Method: SHTextStyler>>evaluateWithoutStyling: (in category 'styling') -----
evaluateWithoutStyling: aBlock
| t |
t := stylingEnabled.
stylingEnabled := false.
^ aBlock ensure: [stylingEnabled := t]!
----- Method: SHTextStyler>>format: (in category 'formatting') -----
format: aText
"Answer a copy of <aText> which has been reformatted,
or <aText> if no formatting is to be applied"
self terminateBackgroundStylingProcess.
^self privateFormat: aText!
----- Method: SHTextStyler>>initialize (in category 'styling') -----
initialize
stylingEnabled := true
!
----- Method: SHTextStyler>>monitor (in category 'private') -----
monitor
^monitor ifNil: [monitor := Monitor new]!
----- Method: SHTextStyler>>privateFormat: (in category 'private') -----
privateFormat: aText
self shouldBeImplemented!
----- Method: SHTextStyler>>privateStyle: (in category 'private') -----
privateStyle: aText
self shouldBeImplemented!
----- Method: SHTextStyler>>style: (in category 'styling') -----
style: aText
self terminateBackgroundStylingProcess.
stylingEnabled ifTrue:[
text := aText copy.
self privateStyle: text.
view ifNotNil:[view stylerStyled: text] ]!
----- Method: SHTextStyler>>styleInBackgroundProcess: (in category 'styling') -----
styleInBackgroundProcess: aText
self terminateBackgroundStylingProcess.
stylingEnabled ifTrue:[
text := aText copy.
self monitor critical: [
sem := Semaphore new.
[sem notNil
ifTrue: [
sem wait.
view ifNotNil:[view stylerStyledInBackground: text]]
] forkAt: Processor activePriority.
backgroundProcess :=
[self privateStyle: text.
sem signal]
forkAt: Processor userBackgroundPriority] ]
!
----- Method: SHTextStyler>>styledTextFor: (in category 'styling') -----
styledTextFor: aText
"Answer a copy of aText that is both formatted and styled"
| formattedText |
formattedText := self privateFormat: aText.
self privateStyle: formattedText.
^formattedText!
----- Method: SHTextStyler>>terminateBackgroundStylingProcess (in category 'private') -----
terminateBackgroundStylingProcess
self monitor critical: [
backgroundProcess
ifNotNil: [
backgroundProcess terminate.
backgroundProcess := nil].
sem
ifNotNil:[
sem terminateProcess.
sem := nil].
] !
----- Method: SHTextStyler>>unstyledTextFrom: (in category 'styling') -----
unstyledTextFrom: aText
^Text fromString: aText string!
----- Method: SHTextStyler>>veryDeepInner: (in category 'copying') -----
veryDeepInner: aDeepCopier
super veryDeepInner: aDeepCopier.
sem := backgroundProcess := monitor := nil.
text := text veryDeepCopyWith: aDeepCopier.
view := view veryDeepCopyWith: aDeepCopier!
----- Method: SHTextStyler>>view: (in category 'accessing') -----
view: aViewOrMorph
view := aViewOrMorph!
SHTextStyler subclass: #SHTextStylerST80
instanceVariableNames: 'classOrMetaClass workspace font parser formatAssignments environment sourceMap processedSourceMap pixelHeight'
classVariableNames: 'SubduedSyntaxHighlights SyntaxHighlightingAsYouType SyntaxHighlightingAsYouTypeAnsiAssignment SyntaxHighlightingAsYouTypeLeftArrowAssignment'
poolDictionaries: ''
category: 'ShoutCore-Styling'!
SHTextStylerST80 class
instanceVariableNames: 'styleTable textAttributesByPixelHeight'!
!SHTextStylerST80 commentStamp: 'tween 8/27/2004 10:55' prior: 0!
I style Smalltalk methods and expressions.
My 'styleTable' class instance var holds an array ofArrays which control how each token is styled/coloured. See my defaultStyleTable class method for its structure.
My styleTable can be changed by either modifying the defaultStyleTable class method and then executing SHTextStylerST80 initialize ; or by giving me a new styleTable through my #styleTable: class method.
My 'textAttributesByPixelSize' class instance var contains a dictionary of dictionaries.
The key is a pixelSize and the value a Dictionary from token type Symbol to TextAttribute array.
It is created/maintained automatically.
I also install these 3 preferences when my class initialize method is executed....
#syntaxHighlightingAsYouType - controls whether methods are styled in browsers
#syntaxHighlightingAsYouTypeAnsiAssignment - controls whether assignments are formatted to be :=
#syntaxHighlightingAsYouTypeLeftArrowAssignment - controls whether assignments are formatted to be _
I reimplement #unstyledTextFrom: so that TextActions are preserved in the unstyled text
!
SHTextStylerST80 class
instanceVariableNames: 'styleTable textAttributesByPixelHeight'!
----- Method: SHTextStylerST80 class>>ansiAssignmentPreferenceChanged (in category 'preferences') -----
ansiAssignmentPreferenceChanged
"the user has changed the syntaxHighlightingAsYouTypeAnsiAssignment setting.
If they have turned it on then force syntaxHighlightingAsYouTypeLeftArrowAssignment
to be turned off"
self syntaxHighlightingAsYouTypeAnsiAssignment
ifTrue: [self syntaxHighlightingAsYouTypeLeftArrowAssignment: false]!
----- Method: SHTextStylerST80 class>>attributeArrayForColor:emphasis:font: (in category 'style table') -----
attributeArrayForColor: aColorOrNil emphasis: anEmphasisSymbolOrArrayorNil font: aTextStyleOrFontOrNil
"Answer a new Array containing any non nil TextAttributes specified"
| answer emphArray |
answer := Array new.
aColorOrNil ifNotNil: [answer := answer, {TextColor color: aColorOrNil}].
anEmphasisSymbolOrArrayorNil ifNotNil: [
emphArray := anEmphasisSymbolOrArrayorNil isSymbol
ifTrue: [{anEmphasisSymbolOrArrayorNil}]
ifFalse: [anEmphasisSymbolOrArrayorNil].
emphArray do: [:each |
each ~= #normal
ifTrue:[
answer := answer, {TextEmphasis perform: each}]]].
aTextStyleOrFontOrNil ifNotNil: [
answer := answer, {TextFontReference toFont: aTextStyleOrFontOrNil}].
^answer!
----- Method: SHTextStylerST80 class>>attributesFor:pixelHeight: (in category 'style table') -----
attributesFor: aSymbol pixelHeight: aNumber
^(self textAttributesByPixelHeight
at: aNumber
ifAbsentPut:[self initialTextAttributesForPixelHeight: aNumber])
at: aSymbol ifAbsent:[nil]!
----- Method: SHTextStylerST80 class>>chooseDefaultStyleTable (in category 'style table') -----
chooseDefaultStyleTable
"Choose the default style table"
^self subduedSyntaxHighlights
ifTrue:[self subduedStyleTable]
ifFalse:[self defaultStyleTable]!
----- Method: SHTextStylerST80 class>>defaultStyleTable (in category 'style table') -----
defaultStyleTable
"color can be a valid argument to Color class>>colorFrom: , or nil to
use the editor text color.
Multiple emphases can be specified using an array e.g. #(bold italic).
If emphasis is not specified, #normal will be used.
if pixel height is not specified , then the editor font size will be used.
"
^#(
"(symbol color [emphasisSymbolOrArray [textStyleName [pixelHeight]]])"
(default black )
(invalid red )
(excessCode red )
(comment (green muchDarker) italic)
(unfinishedComment (red muchDarker) italic)
(#'$' (red muchDarker) )
(character (red muchDarker) )
(integer (red muchDarker) )
(number (red muchDarker) )
(#- (red muchDarker) )
(symbol (blue muchDarker) bold)
(stringSymbol (blue muchDarker) bold)
(literalArray (blue muchDarker) bold)
(string (magenta muchDarker) normal)
(unfinishedString red normal )
(assignment nil bold )
(ansiAssignment nil bold)
(literal nil italic)
(keyword (blue muchDarker) )
(binary (blue muchDarker) )
(unary (blue muchDarker) )
(incompleteKeyword (gray muchDarker) underlined)
(incompleteBinary (gray muchDarker) underlined)
(incompleteUnary (gray muchDarker) underlined)
(undefinedKeyword red )
(undefinedBinary red )
(undefinedUnary red )
(patternKeyword nil bold)
(patternBinary nil bold)
(patternUnary nil bold)
(#self (red muchDarker) bold)
(#super (red muchDarker) bold)
(#true (red muchDarker) bold)
(#false (red muchDarker) bold)
(#nil (red muchDarker) bold)
(#thisContext (red muchDarker) bold)
(#return (red muchDarker) bold)
(patternArg (blue muchDarker) italic)
(methodArg (blue muchDarker) italic)
(blockPatternArg (blue muchDarker) italic)
(blockArg (blue muchDarker) italic)
(argument (blue muchDarker) italic)
(blockArgColon black )
(leftParenthesis black )
(rightParenthesis black )
(leftParenthesis1 (green muchDarker) )
(rightParenthesis1 (green muchDarker) )
(leftParenthesis2 (magenta muchDarker) )
(rightParenthesis2 (magenta muchDarker) )
(leftParenthesis3 (red muchDarker) )
(rightParenthesis3 (red muchDarker) )
(leftParenthesis4 (green darker) )
(rightParenthesis4 (green darker) )
(leftParenthesis5 (orange darker) )
(rightParenthesis5 (orange darker) )
(leftParenthesis6 (magenta darker) )
(rightParenthesis6 (magenta darker) )
(leftParenthesis7 blue )
(rightParenthesis7 blue )
(blockStart black )
(blockEnd black )
(blockStart1 (green muchDarker) )
(blockEnd1 (green muchDarker) )
(blockStart2 (magenta muchDarker) )
(blockEnd2 (magenta muchDarker) )
(blockStart3 (red muchDarker) )
(blockEnd3 (red muchDarker) )
(blockStart4 (green darker) )
(blockEnd4 (green darker) )
(blockStart5 (orange darker) )
(blockEnd5 (orange darker) )
(blockStart6 (magenta darker) )
(blockEnd6 (magenta darker) )
(blockStart7 blue )
(blockEnd7 blue )
(arrayStart black )
(arrayEnd black )
(arrayStart1 black )
(arrayEnd1 black )
(byteArrayStart black )
(byteArrayEnd black )
(byteArrayStart1 black )
(byteArrayEnd1 black )
(leftBrace black )
(rightBrace black )
(cascadeSeparator black )
(statementSeparator black )
(externalCallType black )
(externalCallTypePointerIndicator black )
(primitiveOrExternalCallStart black bold )
(primitiveOrExternalCallEnd black bold )
(methodTempBar gray )
(blockTempBar gray )
(blockArgsBar gray )
(primitive (green muchDarker) bold)
(pragmaKeyword (green muchDarker) bold)
(pragmaUnary (green muchDarker) bold)
(pragmaBinary (green muchDarker) bold)
(externalFunctionCallingConvention (green muchDarker) bold)
(module (green muchDarker) bold)
(blockTempVar gray italic)
(blockPatternTempVar gray italic)
(instVar black bold)
(workspaceVar black bold)
(undefinedIdentifier red bold)
(incompleteIdentifier (gray darker) (italic underlined))
(tempVar (gray darker) italic)
(patternTempVar (gray darker) italic)
(poolConstant (gray darker) italic)
(classVar (gray darker) bold)
(globalVar black bold) )
!
----- Method: SHTextStylerST80 class>>initialTextAttributesForPixelHeight: (in category 'style table') -----
initialTextAttributesForPixelHeight: aNumber
| d |
d := IdentityDictionary new.
self styleTable do: [:each | | textStyle element emphasis font pixelHeight attrArray color textStyleName |
element := each first.
color := each at: 2 ifAbsent:[nil].
color:=color ifNotNil: [Color colorFrom: color].
emphasis := each at: 3 ifAbsent:[nil].
textStyleName := each at: 4 ifAbsent: [nil].
pixelHeight := each at: 5 ifAbsent: [aNumber].
textStyleName ifNil:[pixelHeight := nil].
textStyle := TextStyle named: textStyleName.
font := textStyle ifNotNil:[pixelHeight ifNotNil:[textStyle fontOfSize: pixelHeight]].
attrArray := self attributeArrayForColor: color emphasis: emphasis font: font.
attrArray notEmpty
ifTrue:[
d at: element put: attrArray]].
^d
!
----- Method: SHTextStylerST80 class>>initialize (in category 'class initialization') -----
initialize
"Clear styleTable and textAttributesByPixelSize cache so that they will
reinitialize.
SHTextStylerST80 initialize
"
styleTable := nil.
textAttributesByPixelHeight := nil. !
----- Method: SHTextStylerST80 class>>leftArrowAssignmentPreferenceChanged (in category 'preferences') -----
leftArrowAssignmentPreferenceChanged
"the user has changed the syntaxHighlightingAsYouTypeLeftArrowAssignment setting.
If they have turned it on then force syntaxHighlightingAsYouTypeAnsiAssignment
to be turned off"
self syntaxHighlightingAsYouTypeLeftArrowAssignment
ifTrue: [self syntaxHighlightingAsYouTypeAnsiAssignment: false]!
----- Method: SHTextStylerST80 class>>styleTable (in category 'style table') -----
styleTable
^styleTable ifNil: [ styleTable := self chooseDefaultStyleTable ]!
----- Method: SHTextStylerST80 class>>styleTable: (in category 'style table') -----
styleTable: anArray
"Set the receiver's styleTable to anArray.
Clear textAttributesByPixelSize cache so that it will reinitialize.
"
styleTable := anArray.
textAttributesByPixelHeight := nil!
----- Method: SHTextStylerST80 class>>subduedStyleTable (in category 'style table') -----
subduedStyleTable
"color can be a valid argument to Color class>>colorFrom: , or nil to
use the editor text color.
Multiple emphases can be specified using an array e.g. #(bold italic).
If emphasis is not specified, #normal will be used.
if pixel height is not specified , then the editor font size will be used.
"
^#(
"(symbol color [emphasisSymbolOrArray [textStyleName [pixelHeight]]])"
(default black )
(invalid red )
(excessCode red )
(comment (cyan muchDarker) )
(unfinishedComment (red muchDarker) italic)
(#'$' (red muchDarker) )
(character (red muchDarker) )
(integer (red muchDarker) )
(number (red muchDarker) )
(#- (red muchDarker) )
(symbol (blue muchDarker) )
(stringSymbol (blue muchDarker) )
(literalArray (blue muchDarker) )
(string (magenta muchDarker) normal )
(unfinishedString red normal )
(assignment nil bold )
(ansiAssignment nil bold)
(literal nil italic)
(keyword (blue muchDarker) )
(binary (blue muchDarker) )
(unary (blue muchDarker) )
(incompleteKeyword (gray muchDarker) underlined)
(incompleteBinary (gray muchDarker) underlined)
(incompleteUnary (gray muchDarker) underlined)
(undefinedKeyword red )
(undefinedBinary red )
(undefinedUnary red )
(patternKeyword nil bold)
(patternBinary nil bold)
(patternUnary nil bold)
(#self (red muchDarker) )
(#super (red muchDarker) )
(#true (red muchDarker) )
(#false (red muchDarker) )
(#nil (red muchDarker) )
(#thisContext (red muchDarker) )
(#return (red muchDarker) )
(patternArg (blue muchDarker) )
(methodArg (blue muchDarker) )
(blockPatternArg (blue muchDarker) )
(blockArg (blue muchDarker) )
(argument (blue muchDarker) )
(blockArgColon black )
(leftParenthesis black )
(rightParenthesis black )
(leftParenthesis1 (green muchDarker) )
(rightParenthesis1 (green muchDarker) )
(leftParenthesis2 (magenta muchDarker) )
(rightParenthesis2 (magenta muchDarker) )
(leftParenthesis3 (red muchDarker) )
(rightParenthesis3 (red muchDarker) )
(leftParenthesis4 (green darker) )
(rightParenthesis4 (green darker) )
(leftParenthesis5 (orange darker) )
(rightParenthesis5 (orange darker) )
(leftParenthesis6 (magenta darker) )
(rightParenthesis6 (magenta darker) )
(leftParenthesis7 blue )
(rightParenthesis7 blue )
(blockStart black )
(blockEnd black )
(blockStart1 (green muchDarker) )
(blockEnd1 (green muchDarker) )
(blockStart2 (magenta muchDarker) )
(blockEnd2 (magenta muchDarker) )
(blockStart3 (red muchDarker) )
(blockEnd3 (red muchDarker) )
(blockStart4 (green darker) )
(blockEnd4 (green darker) )
(blockStart5 (orange darker) )
(blockEnd5 (orange darker) )
(blockStart6 (magenta darker) )
(blockEnd6 (magenta darker) )
(blockStart7 blue )
(blockEnd7 blue )
(arrayStart black )
(arrayEnd black )
(arrayStart1 black )
(arrayEnd1 black )
(byteArrayStart black )
(byteArrayEnd black )
(byteArrayStart1 black )
(byteArrayEnd1 black )
(leftBrace black )
(rightBrace black )
(cascadeSeparator black )
(statementSeparator black )
(externalCallType black )
(externalCallTypePointerIndicator black )
(primitiveOrExternalCallStart black )
(primitiveOrExternalCallEnd black )
(methodTempBar gray )
(blockTempBar gray )
(blockArgsBar gray )
(primitive (green muchDarker) bold)
(pragmaKeyword (green muchDarker) bold)
(pragmaUnary (green muchDarker) bold)
(pragmaBinary (green muchDarker) bold)
(externalFunctionCallingConvention (green muchDarker) bold)
(module (green muchDarker) bold)
(blockTempVar gray )
(blockPatternTempVar gray )
(instVar black )
(workspaceVar black )
(undefinedIdentifier red )
(incompleteIdentifier (gray darker) (italic underlined))
(tempVar (gray darker) )
(patternTempVar (gray darker) )
(poolConstant (gray muchDarker) )
(classVar (gray muchDarker) )
(globalVar black ) )!
----- Method: SHTextStylerST80 class>>subduedSyntaxHighlights (in category 'preferences') -----
subduedSyntaxHighlights
<preference: 'Subdued Syntax Highlighting'
category: 'browsing'
description: 'When enabled, use a more subdued syntax highlighting approach that is not as aggressive in the face newbies. Intended to introduce people gracefully to the shiny colorful world of Squeak syntax'
type: #Boolean>
^SubduedSyntaxHighlights ifNil:[true]!
----- Method: SHTextStylerST80 class>>subduedSyntaxHighlights: (in category 'preferences') -----
subduedSyntaxHighlights: aBool
"Change the subdued syntax highlighting preference"
SubduedSyntaxHighlights := aBool.
"Force reload"
styleTable := nil.
textAttributesByPixelHeight := nil.!
----- Method: SHTextStylerST80 class>>syntaxHighlightingAsYouType (in category 'preferences') -----
syntaxHighlightingAsYouType
<preference: 'syntaxHighlightingAsYouType'
category: 'browsing'
description: 'Enable, or disable, Shout - Syntax Highlighting As You Type. When enabled, code in Browsers and Workspaces is styled to reveal its syntactic structure. When the code is changed (by typing some characters, for example), the styling is changed so that it remains in sync with the modified code.'
type: #Boolean>
^SyntaxHighlightingAsYouType ifNil: [true]!
----- Method: SHTextStylerST80 class>>syntaxHighlightingAsYouType: (in category 'preferences') -----
syntaxHighlightingAsYouType: aBoolean
SyntaxHighlightingAsYouType := aBoolean.!
----- Method: SHTextStylerST80 class>>syntaxHighlightingAsYouTypeAnsiAssignment (in category 'preferences') -----
syntaxHighlightingAsYouTypeAnsiAssignment
<preference: 'syntaxHighlightingAsYouTypeAnsiAssignment'
category: 'browsing'
description: 'If true, and syntaxHighlightingAsYouType is enabled, all left arrow assignments ( _ ) will be converted to the ANSI format ( := ) when a method is selected in a Browser. Whilst editing a method, this setting has no effect - both the left arrow and the ansi format may be used.'
type: #Boolean>
^SyntaxHighlightingAsYouTypeLeftArrowAssignment ifNil: [true]!
----- Method: SHTextStylerST80 class>>syntaxHighlightingAsYouTypeAnsiAssignment: (in category 'preferences') -----
syntaxHighlightingAsYouTypeAnsiAssignment: aBoolean
SyntaxHighlightingAsYouTypeAnsiAssignment := aBoolean.!
----- Method: SHTextStylerST80 class>>syntaxHighlightingAsYouTypeLeftArrowAssignment (in category 'preferences') -----
syntaxHighlightingAsYouTypeLeftArrowAssignment
<preference: 'syntaxHighlightingAsYouTypeLeftArrowAssignment'
category: 'browsing'
description: 'If true, and syntaxHighlightingAsYouType is enabled, all ANSI format assignments ( := ) will be converted to left arrows ( _ ) when a method is selected in a Browser. Whilst editing a method, this setting has no effect - both the left arrow and the ansi format may be used.'
type: #Boolean>
^SyntaxHighlightingAsYouTypeLeftArrowAssignment ifNil: [true]!
----- Method: SHTextStylerST80 class>>syntaxHighlightingAsYouTypeLeftArrowAssignment: (in category 'preferences') -----
syntaxHighlightingAsYouTypeLeftArrowAssignment: aBoolean
SyntaxHighlightingAsYouTypeLeftArrowAssignment := aBoolean.!
----- Method: SHTextStylerST80 class>>textAttributesByPixelHeight (in category 'style table') -----
textAttributesByPixelHeight
^ textAttributesByPixelHeight ifNil: [ textAttributesByPixelHeight := Dictionary new ]!
----- Method: SHTextStylerST80>>attributesFor: (in category 'private') -----
attributesFor: aSymbol
^self class attributesFor: aSymbol pixelHeight: self pixelHeight
!
----- Method: SHTextStylerST80>>classOrMetaClass: (in category 'accessing') -----
classOrMetaClass: aBehavior
classOrMetaClass := aBehavior!
----- Method: SHTextStylerST80>>convertAssignmentsToAnsi: (in category 'private') -----
convertAssignmentsToAnsi: aText
"If the Preference is to show ansiAssignments then answer a copy of <aText> where each left arrow assignment is replaced with a ':=' ansi assignment. A parser is used so that each left arrow is only replaced if it occurs within an assigment statement"
^self replaceStringForRangesWithType: #assignment with: ':=' in: aText!
----- Method: SHTextStylerST80>>convertAssignmentsToLeftArrow: (in category 'private') -----
convertAssignmentsToLeftArrow: aText
"If the Preference is to show leftArrowAssignments then answer a copy of <aText> where each ansi assignment (:=) is replaced with a left arrow. A parser is used so that each ':=' is only replaced if it actually occurs within an assigment statement"
^self replaceStringForRangesWithType: #ansiAssignment with: '_' in: aText!
----- Method: SHTextStylerST80>>environment: (in category 'accessing') -----
environment: anObject
environment := anObject!
----- Method: SHTextStylerST80>>font: (in category 'accessing') -----
font: aFont
font := aFont!
----- Method: SHTextStylerST80>>formatAssignments: (in category 'accessing') -----
formatAssignments: aBoolean
"determines whether assignments are reformatted according to the Preferences,
or left as they are"
formatAssignments := aBoolean!
----- Method: SHTextStylerST80>>initialize (in category 'initialize-release') -----
initialize
super initialize.
formatAssignments := true!
----- Method: SHTextStylerST80>>parseableSourceCodeTemplate (in category 'private') -----
parseableSourceCodeTemplate
^'messageSelectorAndArgumentNames
"comment stating purpose of message"
| temporary variable names |
statements'!
----- Method: SHTextStylerST80>>pixelHeight (in category 'private') -----
pixelHeight
"In Morphic the receiver will have been given a code font, in MVC the font will be nil. So when the font is nil, answer the pixelHeight of the MVC Browsers' code font, i.e. TextStyle defaultFont pixelHeight"
^pixelHeight
ifNil:[pixelHeight := (font
ifNil:[TextStyle defaultFont]) pixelSize]!
----- Method: SHTextStylerST80>>privateFormat: (in category 'private') -----
privateFormat: aText
"Perform any formatting of aText necessary and answer either aText, or a formatted copy of aText"
aText asString = Object sourceCodeTemplate
ifTrue:[
"the original source code template does not parse,
replace it with one that does"
^self parseableSourceCodeTemplate asText].
formatAssignments
ifTrue:[
self class syntaxHighlightingAsYouTypeAnsiAssignment
ifTrue:[^self convertAssignmentsToAnsi: aText].
self class syntaxHighlightingAsYouTypeLeftArrowAssignment
ifTrue:[^self convertAssignmentsToLeftArrow: aText]].
^aText!
----- Method: SHTextStylerST80>>privateStyle: (in category 'private') -----
privateStyle: aText
| ranges |
ranges := self rangesIn: aText setWorkspace: true.
ranges ifNotNil: [self setAttributesIn: aText fromRanges: ranges]!
----- Method: SHTextStylerST80>>rangesIn:setWorkspace: (in category 'private') -----
rangesIn: aText setWorkspace: aBoolean
"Answer a collection of SHRanges by parsing aText.
When formatting it is not necessary to set the workspace, and this can make the parse take less time, so aBoolean specifies whether the parser should be given the workspace"
| shoutParserClass |
"Switch parsers if we have to"
shoutParserClass := (classOrMetaClass ifNil:[Object]) shoutParserClass.
parser class = shoutParserClass ifFalse:[parser := shoutParserClass new].
^parser
rangesIn: aText asString
classOrMetaClass: classOrMetaClass
workspace: (aBoolean ifTrue:[workspace])
environment: environment
!
----- Method: SHTextStylerST80>>replaceStringForRangesWithType:with:in: (in category 'private') -----
replaceStringForRangesWithType: aSymbol with: aString in: aText
"Answer aText if no replacements, or a copy of aText with
each range with a type of aSymbol replaced by aString"
| answer toReplace adjustSourceMap increaseInLength |
toReplace := (self rangesIn: aText setWorkspace: false)
select: [:each | each type = aSymbol].
toReplace isEmpty ifTrue: [^aText].
answer := aText copy.
increaseInLength := 0.
adjustSourceMap := sourceMap notNil and:[sourceMap ~~ processedSourceMap].
(toReplace asSortedCollection: [:a :b | a start <= b start])
do: [:each | | end start thisIncrease |
start := each start + increaseInLength.
end := each end + increaseInLength.
answer replaceFrom: start to: end with: aString.
thisIncrease := aString size - each length.
increaseInLength := increaseInLength + thisIncrease.
adjustSourceMap ifTrue:[
sourceMap do:[:assoc | | first newFirst last newLast |
first := newFirst := assoc value first.
last := newLast := assoc value last.
first > start ifTrue:[newFirst := first + thisIncrease].
last > start ifTrue:[newLast := last + thisIncrease].
(first ~= newFirst or:[last ~= newLast])
ifTrue:[assoc value: (newFirst to: newLast)]]]].
adjustSourceMap ifTrue:[processedSourceMap := sourceMap].
^answer!
----- Method: SHTextStylerST80>>setAttributesIn:fromRanges: (in category 'private') -----
setAttributesIn: aText fromRanges: ranges
| charAttr defaultAttr attr newRuns newValues lastAttr oldRuns lastCount |
oldRuns := aText runs.
defaultAttr := self attributesFor: #default.
charAttr := Array new: aText size.
1 to: charAttr size do: [:i | charAttr at: i put: defaultAttr].
ranges do: [:range |
(attr := self attributesFor: range type) == nil
ifFalse:[ range start to: range end do: [:i | charAttr at: i put: attr]]].
newRuns := OrderedCollection new: charAttr size // 10.
newValues := OrderedCollection new: charAttr size // 10.
1 to: charAttr size do: [:i |
attr := charAttr at: i.
i = 1
ifTrue: [
newRuns add: 1.
lastCount := 1.
lastAttr := newValues add: attr]
ifFalse:[
attr == lastAttr
ifTrue: [
lastCount := lastCount + 1.
newRuns at: newRuns size put: lastCount]
ifFalse: [
newRuns add: 1.
lastCount := 1.
lastAttr := newValues add: attr]]].
aText runs: (RunArray runs: newRuns values: newValues).
oldRuns withStartStopAndValueDo:[:start :stop :attribs|
(attribs anySatisfy: [:each | self shouldPreserveAttribute: each])
ifTrue: [
attribs do: [:eachAttrib | aText addAttribute: eachAttrib from: start to: stop]]].
!
----- Method: SHTextStylerST80>>shouldPreserveAttribute: (in category 'private') -----
shouldPreserveAttribute: aTextAttribute
"Answer true if Shout should preserve ALL the attributes in the same run as the argument,
false otherwise"
(aTextAttribute respondsTo: #shoutShouldPreserve)
ifTrue:[^ aTextAttribute shoutShouldPreserve].
^aTextAttribute isMemberOf: TextAction!
----- Method: SHTextStylerST80>>sourceMap: (in category 'accessing') -----
sourceMap: aSortedCollection
"set the receiver's sourceMap to aSortedCollection.
The sourceMap is used by a Debugger to select the appropriate
ranges within its text. These ranges need to be adjusted if, and when, the receiver
reformats the text that is displayed"
sourceMap := aSortedCollection!
----- Method: SHTextStylerST80>>unstyledTextFrom: (in category 'converting') -----
unstyledTextFrom: aText
"Re-implemented so that TextActions are not removed from aText"
| answer |
answer := super unstyledTextFrom: aText.
aText runs withStartStopAndValueDo: [:start :stop :attribs |
(attribs anySatisfy: [:each | each isKindOf: TextAction])
ifTrue: [
attribs do: [:eachAttrib | answer addAttribute: eachAttrib from: start to: stop]]].
^answer!
----- Method: SHTextStylerST80>>veryDeepInner: (in category 'copying') -----
veryDeepInner: aDeepCopier
super veryDeepInner: aDeepCopier.
classOrMetaClass := classOrMetaClass veryDeepCopyWith: aDeepCopier.
workspace := workspace veryDeepCopyWith: aDeepCopier.
"share the font?"
parser := parser veryDeepCopyWith: aDeepCopier.
sourceMap := sourceMap veryDeepCopyWith: aDeepCopier.
processedSourceMap := processedSourceMap veryDeepCopyWith: aDeepCopier!
----- Method: SHTextStylerST80>>workspace: (in category 'accessing') -----
workspace: aWorkspace
workspace := aWorkspace!
----- Method: Dictionary>>hasBindingThatBeginsWith: (in category '*ShoutCore') -----
hasBindingThatBeginsWith: aString
"Answer true if the receiver has a key that begins with aString, false otherwise"
self keysDo:[:each |
(each beginsWith: aString)
ifTrue:[^true]].
^false!
----- Method: SharedPool class>>hasBindingThatBeginsWith: (in category '*ShoutCore') -----
hasBindingThatBeginsWith: aString
"Answer true if the receiver has a binding that begins with aString, false otherwise"
"First look in classVar dictionary."
(self classPool hasBindingThatBeginsWith: aString) ifTrue:[^true].
"Next look in shared pools."
self sharedPools do:[:pool |
(pool hasBindingThatBeginsWith: aString) ifTrue: [^true]].
^false!
----- Method: SystemDictionary>>hasBindingThatBeginsWith: (in category '*ShoutCore') -----
hasBindingThatBeginsWith: aString
"Use the cached class and non-class names for better performance."
| name searchBlock |
searchBlock := [ :element |
(element beginsWith: aString)
ifTrue: [ 0 ]
ifFalse: [
aString < element
ifTrue: [ -1 ]
ifFalse: [ 1 ] ] ].
name := self classNames
findBinary: searchBlock
ifNone: [ nil ].
name ifNotNil: [ ^true ].
name := self nonClassNames
findBinary: searchBlock
ifNone: [ nil ].
^name notNil!
----- Method: SmalltalkImage>>hasBindingThatBeginsWith: (in category '*ShoutCore') -----
hasBindingThatBeginsWith: aString
"Answer true if the receiver has a key that begins with aString, false otherwise"
^globals hasBindingThatBeginsWith: aString!
----- Method: Behavior>>shoutParserClass (in category '*ShoutCore-Parsing') -----
shoutParserClass
"Answer the parser class"
^SHParserST80!
----- Method: Environment>>hasBindingThatBeginsWith: (in category '*ShoutCore') -----
hasBindingThatBeginsWith: aString
bindings associationsDo:
[:ea | (ea key beginsWith: aString) ifTrue: [^ true]].
^ false
!
----- Method: Workspace>>hasBindingThatBeginsWith: (in category '*ShoutCore') -----
hasBindingThatBeginsWith: aString
bindings ifNil: [ ^false ].
bindings keysDo: [ :each |
(each beginsWith: aString) ifTrue: [ ^true ] ].
^false!
More information about the Squeak-dev
mailing list
|