« Return to Thread: [squeak-dev] Unload Traits script
[squeak-dev] Re: Unload Traits script
by Andreas Raab
::
Rate this Message:
Philippe Marschall wrote:
>> It gives you an image, a) without traits, and b) with the old class format.
>>
>> The aim being to 1) enable folks with code that relies on the old format to
>> move up to 3.10 should they so desire 2) Satisfy those who dont like the
>> existing traits based traits implementation and would like to have something
>> simpler and 3) Provide a starting point for a future simpler traits
>> implementation if anyone wants to write it.
>
> What about people who need traits?
There is no reason why a traits implementation needs to be as intrusive
as this one. Earlier this year I had been playing with a traits
implementation for Croquet just to understand some of the implementation
aspects a little better and it was pretty clear that an alternative
implementation which is much less invasive is not only trivial to do but
fits much better into the rest of the existing system. I'm attaching a
draft version of this experiment (which is not fully functional since I
lost interest but it will load into Croquet and is enough to play with
it) and you can check it out to see how it hooks into the system -
basically traits inherit from ClassDescription which avoids most of the
code duplication and leaves the option for perhaps having stateful
traits at some point. The extension points to the existing kernel are
few (and could be made fewer) and loading and unloading would be trivial
with just a tiny bit more work.
In any case, this is not a complete implementation but rather an
illustration that the current implementation isn't the only way traits
can be implemented in Squeak and that an alternative can be small,
loadable, and easy to understand.
Cheers,
- Andreas
[Traits-Kernel.2.cs]
'From Croquet1.0beta of 11 April 2006 [latest update: #2] on 12 May 2008 at 5:48:20 am'!
OrderedCollection subclass: #TraitComposition
instanceVariableNames: ''
classVariableNames: 'TraitsCache'
poolDictionaries: ''
category: 'Traits-Kernel'!
!TraitComposition commentStamp: '<historical>' prior: 0!
A trait composition is a collection of Traits or TraitTransformations.!
TraitComposition class
instanceVariableNames: ''!
Error subclass: #TraitCompositionException
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Traits-Kernel'!
TraitCompositionException class
instanceVariableNames: ''!
ClassDescription subclass: #TraitDescription
instanceVariableNames: 'users'
classVariableNames: ''
poolDictionaries: ''
category: 'Traits-Kernel'!
TraitDescription subclass: #Metatrait
instanceVariableNames: 'baseTrait'
classVariableNames: ''
poolDictionaries: ''
category: 'Traits-Kernel'!
!Metatrait commentStamp: '<historical>' prior: 0!
Metatrait is the metaclass used for traits.!
TraitDescription subclass: #Trait
instanceVariableNames: 'name environment category'
classVariableNames: ''
poolDictionaries: ''
category: 'Traits-Kernel'!
TraitDescription class
instanceVariableNames: ''!
Metatrait class
instanceVariableNames: ''!
Trait class
instanceVariableNames: ''!
Object subclass: #TraitTransformation
instanceVariableNames: 'subject users'
classVariableNames: ''
poolDictionaries: ''
category: 'Traits-Kernel'!
TraitTransformation subclass: #TraitAlias
instanceVariableNames: 'aliases'
classVariableNames: ''
poolDictionaries: ''
category: 'Traits-Kernel'!
TraitTransformation subclass: #TraitExclusion
instanceVariableNames: 'exclusions'
classVariableNames: ''
poolDictionaries: ''
category: 'Traits-Kernel'!
TraitTransformation class
instanceVariableNames: ''!
TraitAlias class
instanceVariableNames: ''!
TraitExclusion class
instanceVariableNames: ''!
!Object methodsFor: '*Traits-Kernel' stamp: 'ar 11/22/2007 04:25'!
isTrait
^false! !
!Behavior methodsFor: '*Traits-Kernel' stamp: 'ar 5/11/2008 02:09'!
hasTraitComposition
^self traitComposition notEmpty! !
!Behavior methodsFor: '*Traits-Kernel' stamp: 'ar 5/11/2008 01:55'!
includesLocalSelector: selector
^(self compiledMethodAt: selector ifAbsent:[^false]) methodHome == self! !
!Behavior methodsFor: '*Traits-Kernel' stamp: 'ar 5/11/2008 02:11'!
isAliasSelector: aSymbol
"Return true if the selector aSymbol is an alias defined
in my or in another composition somewhere deeper in
the tree of traits compositions."
^(self includesLocalSelector: aSymbol) not
and: [self hasTraitComposition]
and: [self traitComposition isAliasSelector: aSymbol]! !
!Behavior methodsFor: '*Traits-Kernel' stamp: 'ar 5/11/2008 02:17'!
isLocalAliasSelector: aSymbol
"Return true if the selector aSymbol is an alias defined
in my or in another composition somewhere deeper in
the tree of traits compositions."
^(self includesLocalSelector: aSymbol) not
and: [self hasTraitComposition]
and: [self traitComposition isLocalAliasSelector: aSymbol]! !
!Behavior methodsFor: '*Traits-Kernel' stamp: 'ar 5/11/2008 02:07'!
localSelectors
^self selectors select:[:sel| self includesLocalSelector: sel]! !
!ClassDescription methodsFor: '*Traits-Kernel' stamp: 'ar 11/28/2007 20:53'!
addSelector: selector withTraitMethod: compiledMethod
"Add a method from a trait. Recompiles if the method includes super sends."
| newMethod |
self addSelectorSilently: selector withMethod: compiledMethod.
(compiledMethod sendsToSuper) ifTrue:[
self recompile: selector.
newMethod := self compiledMethodAt: selector.
newMethod == compiledMethod ifTrue:[self error: 'Recompilation failure'].
"Set the original home of the recompiled method"
newMethod methodHome: compiledMethod methodHome.
].! !
!ClassDescription methodsFor: '*Traits-Kernel' stamp: 'ar 11/22/2007 04:21'!
allTraits
"Answer all the traits that are used by myself without their transformations"
^self traits gather:[:t| t allTraits copyWith: t].! !
!ClassDescription methodsFor: '*Traits-Kernel' stamp: 'ar 11/28/2007 20:49'!
basicRemoveSelector: selector
"Assuming that the argument, selector (a Symbol), is a message selector
in my method dictionary, remove it and its method. For traits, we need to check
whether the selector originated in a different trait and if so, exclude it from the trait
in addition to removing it."
| oldMethod oldHome tc updated |
oldMethod := self compiledMethodAt: selector ifAbsent:[^nil].
oldHome := oldMethod methodHome.
"Make sure this is neither my trait nor that the method was removed from oldHome"
(oldHome isTrait and:[oldHome includesSelector: selector]) ifTrue:[
"Find any trait transformation providing the selector"
tc := self traitComposition.
oldHome := tc detect:[:t| t includesSelector: selector] ifNone:[nil].
oldHome ifNotNil:["Exclude the selector and store the transform back"
oldHome removeUser: self.
updated := oldHome - {selector}.
updated addUser: self.
updated = oldHome ifFalse:[tc at: (tc indexOf: oldHome) put: updated]
].
].
super basicRemoveSelector: selector.
"The following is slow, but effective to propagate a selector from a trait after removing it."
self installTraitsFrom: self traitComposition.! !
!ClassDescription methodsFor: '*Traits-Kernel' stamp: 'ar 11/28/2007 20:50'!
classify: selector under: heading fromTrait: aTrait
"Update the organization for a trait"
| compiledMethod |
compiledMethod := self compiledMethodAt: selector.
compiledMethod methodHome == aTrait ifTrue:[
self organization classify: selector under: heading.
].! !
!ClassDescription methodsFor: '*Traits-Kernel' stamp: 'ar 11/18/2007 19:02'!
classSide
^self theMetaClass! !
!ClassDescription methodsFor: '*Traits-Kernel' stamp: 'ar 5/11/2008 02:38'!
fileOutInitializerOn: aStream
"-- ignored --"! !
!ClassDescription methodsFor: '*Traits-Kernel' stamp: 'ar 5/11/2008 02:37'!
fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex initializing: aBool
^self fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex! !
!ClassDescription methodsFor: '*Traits-Kernel' stamp: 'ar 11/28/2007 21:22'!
installTraitsFrom: aTraitComposition
"Install the traits from the given composition"
| allTraits methods oldMethod removals |
(self traitComposition isEmpty and: [aTraitComposition isEmpty]) ifTrue: [^self].
"Check for cycles"
allTraits := aTraitComposition gather: [:t | t allTraits copyWith: t].
(allTraits includes: self) ifTrue:[^self error: 'Cyclic trait definition detected'].
"Assemble the methods in a new dictionary first.
Uses a Dictionary instead of a MethodDictionary for speed (MDs grow by #become:)"
methods := Dictionary new.
"Stick in the local methods first, since this avoids generating conflict methods unnecessarily"
self selectorsAndMethodsDo:[:sel :newMethod|
(self isLocalMethod: newMethod)
ifTrue:[methods at: sel put:newMethod]].
"Now assemble the traits methods"
aTraitComposition do:[:trait|
trait selectorsAndMethodsDo:[:sel :newMethod|
oldMethod := methods at: sel ifAbsentPut:[newMethod].
newMethod == oldMethod ifFalse:["a conflict"
(self isLocalMethod: oldMethod) ifFalse:[
methods at: sel put: (self resolveTraitsConflict: sel from: oldMethod to: newMethod).
].
].
].
].
"Apply the changes. We first add the new or changed methods."
methods keysAndValuesDo:[:sel :newMethod|
oldMethod := self compiledMethodAt: sel ifAbsent:[nil].
oldMethod == newMethod ifFalse:[
self addSelector: sel withTraitMethod: newMethod.
self organization classify: sel under: (newMethod methodHome organization categoryOfElement: newMethod selector).
]].
"Now remove the old or obsoleted ones"
removals := OrderedCollection new.
self selectorsDo:[:sel| (methods includesKey: sel) ifFalse:[removals add: sel]].
removals do:[:sel| self removeSelector: sel].
self traitComposition: aTraitComposition.
self isMeta ifFalse:[self class updateTraitsFrom: aTraitComposition].! !
!ClassDescription methodsFor: '*Traits-Kernel' stamp: 'ar 5/11/2008 01:53'!
instanceSide
^self theNonMetaClass! !
!ClassDescription methodsFor: '*Traits-Kernel' stamp: 'ar 11/28/2007 20:51'!
isLocalMethod: aCompiledMethod
"Answer true if the method is a local method, e.g., defined in the receiver instead of a trait."
^aCompiledMethod methodHome == self! !
!ClassDescription methodsFor: '*Traits-Kernel' stamp: 'ar 11/18/2007 18:16'!
removeTraitSelector: selector
self removeSelectorSilently: selector! !
!ClassDescription methodsFor: '*Traits-Kernel' stamp: 'ar 5/1/2008 21:25'!
replaceTraitSelector: original with: aSelector in: source for: aMethod
| oldKeywords newKeywords args newSelectorWithArgs startOfSource lastSelectorToken |
oldKeywords := original keywords.
newKeywords := aSelector keywords.
self assert: oldKeywords size = newKeywords size.
args := (self parserClass new
parseArgsAndTemps: source string notifying: nil) copyFrom: 1 to: aMethod numArgs.
newSelectorWithArgs := String streamContents: [:stream |
newKeywords withIndexDo: [:keyword :index |
stream nextPutAll: keyword.
stream space.
args size >= index ifTrue: [
stream nextPutAll: (args at: index); space]]].
lastSelectorToken := args isEmpty
ifFalse: [args last]
ifTrue: [oldKeywords last].
startOfSource := (source string
indexOfSubCollection: lastSelectorToken startingAt: 1) + lastSelectorToken size.
^newSelectorWithArgs withBlanksTrimmed asText , (source copyFrom: startOfSource to: source size)! !
!ClassDescription methodsFor: '*Traits-Kernel' stamp: 'ar 11/18/2007 15:22'!
resolveTraitsConflict: selector from: oldMethod to: newMethod
"Resolve a traits conflict. Last one wins (for now)"
^newMethod
! !
!ClassDescription methodsFor: '*Traits-Kernel' stamp: 'ar 11/22/2007 04:12'!
traitComposition
"Answer an array of my traits"
^TraitComposition for: self! !
!ClassDescription methodsFor: '*Traits-Kernel' stamp: 'ar 11/22/2007 06:32'!
traitCompositionString
"Print a description of the traits composition"
^self name asString! !
!ClassDescription methodsFor: '*Traits-Kernel' stamp: 'ar 11/22/2007 06:29'!
traitComposition: aTraitComposition
"Install my traits"
(aTraitComposition isKindOf: TraitComposition) ifFalse:[self error: 'Not a trait composition'].
self traitComposition do:[:t| t removeUser: self].
TraitComposition for: self put: aTraitComposition.
aTraitComposition do:[:t| t addUser: self].
! !
!ClassDescription methodsFor: '*Traits-Kernel' stamp: 'ar 11/22/2007 04:36'!
traits
"Answer an array of my traits"
^self traitComposition asArray collect:[:composed| composed theTrait]! !
!ClassDescription methodsFor: '*Traits-Kernel' stamp: 'ar 11/28/2007 21:22'!
updateSelector: selector withTraitMethod: compiledMethod from: aTrait
"A selector in the given trait has changed. Update my usage of it."
| oldMethod |
oldMethod := self compiledMethodAt: selector ifAbsent:[nil].
(oldMethod == nil and:[compiledMethod == nil]) ifTrue:[^nil].
oldMethod ifNil:["No previous method, add and classify the new method"
self addSelector: selector withTraitMethod: compiledMethod.
self organization classify: selector under: (aTrait organization categoryOfElement: selector).
^self].
(self isLocalMethod: oldMethod) ifTrue:[^nil]. "local version trumps override"
oldMethod methodHome == aTrait ifTrue:["same trait, just update"
compiledMethod ifNil:[^self removeTraitSelector: selector].
^self addSelector: selector withTraitMethod: compiledMethod].
compiledMethod ifNil:[^self]. "removed a method from a different trait"
"Resolve conflict"
^self addSelector: selector withTraitMethod:
(self resolveTraitsConflict: selector from: oldMethod to: compiledMethod)! !
!ClassDescription methodsFor: '*Traits-Kernel' stamp: 'ar 11/18/2007 22:27'!
usesTrait: aTrait
^self traits anySatisfy:[:t| t usesTrait: aTrait].! !
!ClassDescription methodsFor: '*Traits-Kernel' stamp: 'ar 5/11/2008 02:34'!
uses: aTraitComposition
| newTraits |
newTraits := (aTraitComposition isKindOf: Trait orOf: TraitTransformation)
ifTrue:[TraitComposition with: aTraitComposition]
ifFalse:[(aTraitComposition isKindOf: SequenceableCollection)
ifTrue:[TraitComposition withAll: aTraitComposition asArray]
ifFalse:[self error: 'Invalid traits specification']].
self installTraitsFrom: newTraits.
! !
!Class methodsFor: '*Traits-Kernel' stamp: 'ar 11/22/2007 06:34'!
definitionST80
"Answer a String that defines the receiver."
| aStream path |
aStream := WriteStream on: (String new: 300).
superclass == nil
ifTrue: [aStream nextPutAll: 'ProtoObject']
ifFalse: [path := ''.
self environment scopeFor: superclass name from: nil
envtAndPathIfFound: [:envt :remotePath | path := remotePath].
aStream nextPutAll: path , superclass name].
aStream nextPutAll: self kindOfSubclass;
store: self name.
self traitComposition ifNotEmpty:[
aStream cr; tab; nextPutAll: 'uses: ';
nextPutAll: self traitComposition traitCompositionString.
].
aStream cr; tab; nextPutAll: 'instanceVariableNames: ';
store: self instanceVariablesString.
aStream cr; tab; nextPutAll: 'classVariableNames: ';
store: self classVariablesString.
aStream cr; tab; nextPutAll: 'poolDictionaries: ';
store: self sharedPoolsString.
aStream cr; tab; nextPutAll: 'category: ';
store: (SystemOrganization categoryOfElement: self name) asString.
superclass ifNil: [
aStream nextPutAll: '.'; cr.
aStream nextPutAll: self name.
aStream space; nextPutAll: 'superclass: nil'. ].
^ aStream contents! !
!Class methodsFor: '*Traits-Kernel' stamp: 'ar 5/11/2008 02:34'!
subclass: t uses: aTraitComposition instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat
| newClass copyOfOldClass |
copyOfOldClass := self copy.
newClass := self
subclass: t
instanceVariableNames: f
classVariableNames: d
poolDictionaries: s
category: cat.
newClass uses: aTraitComposition.
SystemChangeNotifier uniqueInstance
classDefinitionChangedFrom: copyOfOldClass to: newClass.
^newClass! !
!CompiledMethod methodsFor: '*Traits-Kernel' stamp: 'ar 11/28/2007 20:48'!
methodHome
"The behavior (trait/class) this method was originally defined in.
Can be different from methodClass if the method was recompiled due to super sends."
^self properties at: #methodHome ifAbsent:[self methodClass]! !
!CompiledMethod methodsFor: '*Traits-Kernel' stamp: 'ar 11/28/2007 20:48'!
methodHome: aBehavior
"The behavior (trait/class) this method was originally defined in.
Can be different from methodClass if the method was recompiled due to super sends."
aBehavior
ifNil:[self properties removeKey: #methodHome]
ifNotNil:[self properties at: #methodHome put: aBehavior].! !
!Metaclass methodsFor: '*Traits-Kernel' stamp: 'ar 11/22/2007 06:34'!
definitionST80
"Refer to the comment in ClassDescription|definition."
^ String streamContents:
[:strm |
strm print: self.
self traitComposition ifNotEmpty:[
strm crtab; nextPutAll: 'uses: '; nextPutAll: self traitComposition traitCompositionString.
].
strm
crtab;
nextPutAll: 'instanceVariableNames: ';
store: self instanceVariablesString]! !
!Metaclass methodsFor: '*Traits-Kernel' stamp: 'ar 11/22/2007 04:20'!
updateTraitsFrom: instanceTraits
"Update me from the given instance traits"
| map newTraits trait |
map := Dictionary new.
self traitComposition do:[:composed| map at: composed theTrait put: composed].
newTraits := (instanceTraits collect:[:composed|
trait := composed theTrait classTrait.
map at: trait ifAbsent:[trait]]
), (self traitComposition select:[:comp| comp theTrait isBaseTrait]).
self installTraitsFrom: newTraits! !
!Metaclass methodsFor: '*Traits-Kernel' stamp: 'ar 5/11/2008 02:34'!
uses: aTraitComposition instanceVariableNames: instVarString
| newMetaClass copyOfOldMetaClass |
copyOfOldMetaClass := self copy.
newMetaClass := self instanceVariableNames: instVarString.
self uses: aTraitComposition.
SystemChangeNotifier uniqueInstance
classDefinitionChangedFrom: copyOfOldMetaClass to: newMetaClass! !
!TraitComposition methodsFor: 'accessing' stamp: 'ar 11/18/2007 19:20'!
addUser: aUser
self do:[:each| each addUser: aUser]! !
!TraitComposition methodsFor: 'accessing' stamp: 'ar 11/22/2007 04:37'!
allTraits
^self gather:[:each| each allTraits copyWith: each theTrait]! !
!TraitComposition methodsFor: 'accessing' stamp: 'ar 11/18/2007 19:20'!
removeUser: aUser
self do:[:each| each removeUser: aUser]! !
!TraitComposition methodsFor: 'accessing' stamp: 'ar 5/11/2008 02:30'!
traits
^Array streamContents:[:s| self traitsDo:[:t| s nextPut: t]]! !
!TraitComposition methodsFor: 'accessing' stamp: 'ar 11/22/2007 06:21'!
traitsDo: aBlock
^self do:[:each| each traitsDo: aBlock]! !
!TraitComposition methodsFor: 'accessing' stamp: 'ar 11/18/2007 21:02'!
traitUsers
"Answer this traits users, without the transforms in the middle"
^self gather:[:each|
(each isBehavior)
ifTrue:[Array with: each]
ifFalse:[each traitUsers]].! !
!TraitComposition methodsFor: 'testing' stamp: 'ar 11/28/2007 21:09'!
isTraitTransformation
"Polymorphic with TraitTransformation"
^false! !
!TraitComposition methodsFor: 'testing' stamp: 'ar 11/22/2007 06:21'!
usesTrait: aTrait
^self anySatisfy:[:each| each usesTrait: aTrait]! !
!TraitComposition methodsFor: 'converting' stamp: 'ar 11/18/2007 19:13'!
+ aTrait
self addLast: aTrait.
^self! !
!TraitComposition methodsFor: 'converting' stamp: 'ar 11/18/2007 23:13'!
- anArray
"the modifier operators #@ and #- bind stronger than +.
Thus, #@ or #- sent to a sum will only affect the most right summand"
self addLast: (self removeLast - anArray)! !
!TraitComposition methodsFor: 'converting' stamp: 'ar 11/18/2007 23:12'!
@ anArrayOfAssociations
"the modifier operators #@ and #- bind stronger than +.
Thus, #@ or #- sent to a sum will only affect the most right summand"
self addLast: (self removeLast @ anArrayOfAssociations)! !
!TraitComposition methodsFor: 'composition' stamp: 'ar 11/22/2007 06:21'!
classify: selector under: category fromTrait: aTrait
"broadcasts a reclassification of some selector to all users of a trait"
self do:[:each| each classify: selector under: category fromTrait: aTrait].! !
!TraitComposition methodsFor: 'composition' stamp: 'ar 11/22/2007 06:20'!
copyTraitExpression
"Copy all except the actual traits"
^self collect:[:each| each copyTraitExpression].! !
!TraitComposition methodsFor: 'composition' stamp: 'ar 5/11/2008 02:13'!
isAliasSelector: selector
"enumerates all selectors and methods in a trait composition"
^self anySatisfy:[:any| any isAliasSelector: selector]! !
!TraitComposition methodsFor: 'composition' stamp: 'ar 5/11/2008 02:17'!
isLocalAliasSelector: selector
"enumerates all selectors and methods in a trait composition"
^self anySatisfy:[:any| any isLocalAliasSelector: selector]! !
!TraitComposition methodsFor: 'composition' stamp: 'ar 11/22/2007 06:12'!
selectorsAndMethodsDo: aBlock
"enumerates all selectors and methods in a trait composition"
self do:[:each| each selectorsAndMethodsDo: aBlock].! !
!TraitComposition methodsFor: 'composition' stamp: 'ar 11/22/2007 06:23'!
traitCompositionString
"Answer the trait composition string (used for class definitions)"
self size = 0 ifTrue:[^'{}'].
self size = 1 ifTrue:[^self first traitCompositionString].
^String streamContents:[:s|
self do:[:each| s nextPutAll: each traitCompositionString] separatedBy:[s nextPutAll: ' + '].
].! !
!TraitComposition methodsFor: 'composition' stamp: 'ar 11/22/2007 06:11'!
updateSelector: aSelector withTraitMethod: compiledMethod from: aTrait
"broadcasts the change of a selector to all users of a trait"
^self do:[:each| each updateSelector: aSelector withTraitMethod: compiledMethod from: aTrait]! !
!TraitComposition class methodsFor: 'class initialization' stamp: 'ar 11/22/2007 04:11'!
initialize
"TraitComposition initialize"
TraitsCache := Dictionary new.! !
!TraitComposition class methodsFor: 'accessing' stamp: 'ar 11/22/2007 04:10'!
for: aUser
"Answer the traits composition for the given user.
This method provides a storage area for traits in classes."
^TraitsCache at: aUser ifAbsent:[self new]! !
!TraitComposition class methodsFor: 'accessing' stamp: 'ar 11/22/2007 04:11'!
for: aUser put: aComposition
"Answer the traits composition for the given user.
This method provides a storage area for traits in classes."
^TraitsCache at: aUser put: aComposition! !
!TraitDescription methodsFor: 'accessing' stamp: 'ar 11/28/2007 20:54'!
addUser: aTrait
users := self users copyWith: aTrait.
! !
!TraitDescription methodsFor: 'accessing' stamp: 'ar 11/28/2007 20:57'!
allClassVarNames
"Traits have no class var names"
^#()! !
!TraitDescription methodsFor: 'accessing' stamp: 'ar 11/28/2007 20:58'!
classPool
"Traits have no class pool"
^ Dictionary new! !
!TraitDescription methodsFor: 'accessing' stamp: 'ar 11/28/2007 20:55'!
removeUser: aTrait
users := self users copyWithout: aTrait.
! !
!TraitDescription methodsFor: 'accessing' stamp: 'ar 11/28/2007 20:58'!
sharedPools
"Traits have no shared pools"
^ Dictionary new! !
!TraitDescription methodsFor: 'accessing' stamp: 'ar 11/28/2007 20:59'!
theTrait
^self! !
!TraitDescription methodsFor: 'accessing' stamp: 'ar 11/28/2007 20:55'!
traitUsers
"Answer this traits users, without the transforms in the middle"
^self users gather:[:each|
(each isBehavior)
ifTrue:[Array with: each]
ifFalse:[each traitUsers]].! !
!TraitDescription methodsFor: 'accessing' stamp: 'ar 11/28/2007 20:55'!
users
^users ifNil:[#()]! !
!TraitDescription methodsFor: 'accessing' stamp: 'ar 11/28/2007 20:55'!
users: aCollection
users := aCollection! !
!TraitDescription methodsFor: 'copying' stamp: 'ar 11/28/2007 20:55'!
copy
self error: 'Traits cannot be trivially copied'! !
!TraitDescription methodsFor: 'copying' stamp: 'ar 11/28/2007 20:55'!
copyTraitExpression
"Copy all except the actual traits"
^self! !
!TraitDescription methodsFor: 'testing' stamp: 'ar 11/28/2007 21:01'!
isBaseTrait
^false! !
!TraitDescription methodsFor: 'testing' stamp: 'ar 11/28/2007 21:01'!
isClassTrait
^false! !
!TraitDescription methodsFor: 'testing' stamp: 'ar 11/28/2007 20:56'!
isTrait
^true! !
!TraitDescription methodsFor: 'testing' stamp: 'ar 11/28/2007 20:56'!
isTraitTransformation
"Polymorphic with TraitTransformation"
^false! !
!TraitDescription methodsFor: 'testing' stamp: 'ar 11/28/2007 20:56'!
usesTrait: aTrait
^self == aTrait or:[super usesTrait: aTrait]! !
!TraitDescription methodsFor: 'operations' stamp: 'ar 11/28/2007 20:57'!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: category notifying: requestor
"Overridden to update the users of this trait"
super addAndClassifySelector: selector withMethod: compiledMethod inProtocol: category notifying: requestor.
"Update category"
self users do:[:each| each classify: selector under: category fromTrait: self].! !
!TraitDescription methodsFor: 'operations' stamp: 'ar 11/28/2007 20:57'!
addSelectorSilently: selector withMethod: compiledMethod
"Overridden to update the users of this trait"
super addSelectorSilently: selector withMethod: compiledMethod.
self users do:[:each| each updateSelector: selector withTraitMethod: compiledMethod from: self].! !
!TraitDescription methodsFor: 'operations' stamp: 'ar 11/28/2007 20:57'!
basicRemoveSelector: aSelector
"Overridden to update the users of this trait"
| priorMethod |
priorMethod := self compiledMethodAt: aSelector ifAbsent:[^nil].
super basicRemoveSelector: aSelector.
self users do:[:each|
each updateSelector: aSelector withTraitMethod: nil from: priorMethod methodHome].! !
!TraitDescription methodsFor: 'operations' stamp: 'ar 11/28/2007 20:57'!
classify: selector under: heading fromTrait: aTrait
"Update the organization for a trait"
super classify: selector under: heading fromTrait: aTrait.
self users do:[:each| each classify: selector under: heading fromTrait: aTrait].! !
!TraitDescription methodsFor: 'operations' stamp: 'ar 11/28/2007 20:58'!
recompile: selector from: oldClass
"Duplicated to avoid calling our version of addSelectorSilently:"
| method trailer methodNode |
method := oldClass compiledMethodAt: selector.
trailer := method trailer.
methodNode := self compilerClass new
compile: (oldClass sourceCodeAt: selector)
in: self
notifying: nil
ifFail: [^ self]. "Assume OK after proceed from SyntaxError"
selector == methodNode selector ifFalse: [self error: 'selector changed!!'].
super addSelectorSilently: selector withMethod: (methodNode generate: trailer).
! !
!TraitDescription methodsFor: 'operations' stamp: 'ar 11/28/2007 20:59'!
traitsDo: aBlock
aBlock value: self.! !
!TraitDescription methodsFor: 'operations' stamp: 'ar 11/28/2007 21:02'!
+ aTrait
"Creates a composition with the receiver and aTrait"
^TraitComposition withAll: {self. aTrait}! !
!TraitDescription methodsFor: 'operations' stamp: 'ar 11/28/2007 21:03'!
- anArrayOfSelectors
"Creates an exclusion"
^TraitExclusion
with: self
exclusions: anArrayOfSelectors! !
!TraitDescription methodsFor: 'operations' stamp: 'ar 11/28/2007 21:03'!
@ anArrayOfAssociations
"Creates an alias"
^ TraitAlias with: self aliases: anArrayOfAssociations! !
!Metatrait methodsFor: 'initialize' stamp: 'ar 11/22/2007 04:20'!
updateTraitsFrom: instanceTraits
"Update me from the given instance traits"
| map newTraits trait |
map := Dictionary new.
self traitComposition do:[:composed| map at: composed theTrait put: composed].
newTraits := (instanceTraits collect:[:composed|
trait := composed theTrait classTrait.
map at: trait ifAbsent:[trait]]
), (self traitComposition select:[:comp| comp theTrait isBaseTrait]).
self installTraitsFrom: newTraits! !
!Metatrait methodsFor: 'initialize' stamp: 'ar 11/22/2007 04:26'!
uses: aTraitComposition
| newTraits |
newTraits := (aTraitComposition isTrait or:[aTraitComposition isTraitTransformation])
ifTrue:[TraitComposition with: aTraitComposition]
ifFalse:[(aTraitComposition isKindOf: SequenceableCollection)
ifTrue:[TraitComposition withAll: aTraitComposition asArray]
ifFalse:[self error: 'Invalid traits specification']].
newTraits traitsDo:[:t|
(t isBaseTrait and:[t classSide hasMethods])
ifTrue:[self error: 'Cannot add: ', t].
(t isClassTrait and:[(baseTrait usesTrait: t baseTrait) not])
ifTrue:[self error: 'Cannot add: ', t].
].
self installTraitsFrom: newTraits.! !
!Metatrait methodsFor: 'accessing' stamp: 'ar 11/18/2007 23:00'!
baseTrait
^baseTrait! !
!Metatrait methodsFor: 'accessing' stamp: 'ar 11/22/2007 06:34'!
definitionST80
^String streamContents: [:stream |
stream nextPutAll: self name.
stream cr; tab; nextPutAll: 'uses: ';
nextPutAll: self traitComposition traitCompositionString.
].! !
!Metatrait methodsFor: 'accessing' stamp: 'ar 5/11/2008 01:51'!
instanceSide
^self baseTrait! !
!Metatrait methodsFor: 'accessing' stamp: 'ar 11/18/2007 21:44'!
name
^baseTrait name, ' classTrait'! !
!Metatrait methodsFor: 'accessing' stamp: 'ar 11/18/2007 21:45'!
new
baseTrait ifNotNil:[self error: 'Already initialized'].
baseTrait := self basicNew initialize.
baseTrait
superclass: nil
methodDictionary: MethodDictionary new
format: Object format.
^baseTrait! !
!Metatrait methodsFor: 'testing' stamp: 'ar 11/18/2007 22:59'!
isClassTrait
^true! !
!Metatrait methodsFor: 'testing' stamp: 'ar 11/18/2007 22:21'!
isMeta
^true! !
!Trait methodsFor: 'initialize' stamp: 'ar 11/28/2007 21:02'!
definitionST80
^String streamContents: [:stream |
stream nextPutAll: 'Trait named: ';
store: self name.
stream cr; tab; nextPutAll: 'uses: ';
nextPutAll: self traitComposition traitCompositionString.
stream cr; tab; nextPutAll: 'category: ';
store: self category asString].! !
!Trait methodsFor: 'initialize' stamp: 'ar 11/18/2007 15:33'!
isValidTraitName: aSymbol
^(aSymbol isEmptyOrNil
or: [aSymbol first isLetter not]
or: [aSymbol anySatisfy: [:character | character isAlphaNumeric not]]) not! !
!Trait methodsFor: 'initialize' stamp: 'ar 11/28/2007 21:00'!
obsolete
self name: ('AnObsolete' , self name) asSymbol.
super obsolete! !
!Trait methodsFor: 'initialize' stamp: 'ar 11/28/2007 21:00'!
removeFromSystem
self removeFromSystem: true! !
!Trait methodsFor: 'initialize' stamp: 'ar 11/28/2007 21:00'!
removeFromSystem: logged
self environment forgetClass: self logged: logged.
self obsolete! !
!Trait methodsFor: 'initialize' stamp: 'ar 11/18/2007 15:41'!
rename: aString
"The new name of the receiver is the argument, aString."
| newName |
(newName := aString asSymbol) ~= self name
ifFalse: [^ self].
(self environment includesKey: newName)
ifTrue: [^ self error: newName , ' already exists'].
(Undeclared includesKey: newName)
ifTrue: [self inform: 'There are references to, ' , aString printString , '
from Undeclared. Check them after this change.'].
self environment renameClass: self as: newName.
name := newName! !
!Trait methodsFor: 'initialize' stamp: 'ar 11/18/2007 15:33'!
setName: aSymbol andRegisterInCategory: categorySymbol environment: aSystemDictionary
(self isValidTraitName: aSymbol) ifFalse: [self error:'Invalid trait name'].
(self environment == aSystemDictionary
and: [self name = aSymbol
and: [self category = categorySymbol]]) ifTrue: [^self].
((aSystemDictionary includes: aSymbol) and: [(aSystemDictionary at: aSymbol) ~~ self])
ifTrue: [self error: 'The name ''' , aSymbol , ''' is already used'].
(self environment notNil and: [self name notNil and: [self name ~= aSymbol]]) ifTrue: [
self environment renameClass: self as: aSymbol].
self name: aSymbol.
self environment: aSystemDictionary.
self environment at: self name put: self.
self environment organization classify: self name under: categorySymbol.
^ true! !
!Trait methodsFor: 'accessing' stamp: 'ar 11/18/2007 15:37'!
category
"Answer the system organization category for the receiver. First check whether the
category name stored in the ivar is still correct and only if this fails look it up
(latter is much more expensive)"
| result |
category ifNotNilDo: [ :symbol |
((SystemOrganization listAtCategoryNamed: symbol) includes: self name)
ifTrue: [ ^symbol ] ].
category := (result := SystemOrganization categoryOfElement: self name).
^result! !
!Trait methodsFor: 'accessing' stamp: 'ar 11/18/2007 15:38'!
category: aString
"Categorize the receiver under the system category, aString, removing it from
any previous categorization."
| oldCategory |
oldCategory := category.
aString isString
ifTrue: [
category := aString asSymbol.
SystemOrganization classify: self name under: category ]
ifFalse: [self errorCategoryName].
SystemChangeNotifier uniqueInstance
class: self recategorizedFrom: oldCategory to: category! !
!Trait methodsFor: 'accessing' stamp: 'ar 11/18/2007 21:48'!
classTrait
^self class! !
!Trait methodsFor: 'accessing' stamp: 'ar 11/18/2007 15:37'!
environment
^environment! !
!Trait methodsFor: 'accessing' stamp: 'ar 11/18/2007 15:37'!
environment: anObject
environment := anObject! !
!Trait methodsFor: 'accessing' stamp: 'ar 11/18/2007 15:37'!
name
^name! !
!Trait methodsFor: 'accessing' stamp: 'ar 11/18/2007 15:37'!
name: aSymbol
name := aSymbol! !
!Trait methodsFor: 'testing' stamp: 'ar 5/11/2008 01:57'!
hasClassTrait
^true! !
!Trait methodsFor: 'testing' stamp: 'ar 11/18/2007 22:59'!
isBaseTrait
^true! !
!Trait methodsFor: 'testing' stamp: 'ar 11/18/2007 15:41'!
isObsolete
"Return true if the receiver is obsolete."
^(self environment at: name ifAbsent: [nil]) ~~ self! !
!Metatrait class methodsFor: 'instance creation' stamp: 'ar 11/18/2007 21:25'!
new
| newMeta |
newMeta := super new.
newMeta
superclass: Trait
methodDictionary: MethodDictionary new
format: Trait format.
^newMeta! !
!Trait class methodsFor: 'instance creation' stamp: 'ar 5/1/2008 21:16'!
named: aSymbol uses: aTraitCompositionOrCollection category: aString
| env |
env := self environment.
^self
named: aSymbol
uses: aTraitCompositionOrCollection
category: aString
env: env! !
!Trait class methodsFor: 'instance creation' stamp: 'ar 5/11/2008 02:34'!
named: aSymbol uses: aTraitComposition category: aString env: anEnvironment
| trait oldTrait systemCategory oldCategory |
systemCategory := aString asSymbol.
oldTrait := anEnvironment at: aSymbol ifAbsent: [nil].
oldTrait ifNil:[
trait := Metatrait new new.
] ifNotNil:[
oldCategory := oldTrait category.
trait := oldTrait.
].
(trait isKindOf: Trait) ifFalse: [
^self error: trait name , ' is not a Trait'].
trait
setName: aSymbol
andRegisterInCategory: systemCategory
environment: anEnvironment.
trait uses: aTraitComposition.
"... notify interested clients ..."
oldTrait ifNil:[
SystemChangeNotifier uniqueInstance classAdded: trait inCategory: systemCategory.
] ifNotNil:[
systemCategory = oldCategory ifFalse:[
SystemChangeNotifier uniqueInstance class: trait
recategorizedFrom: oldTrait category to: systemCategory].
].
^ trait! !
!TraitTransformation methodsFor: 'initialize' stamp: 'ar 11/18/2007 17:32'!
initialize
super initialize.
users := #().! !
!TraitTransformation methodsFor: 'accessing' stamp: 'ar 11/18/2007 19:12'!
addUser: aTrait
users ifEmpty:[subject addUser: self].
users := users copyWith: aTrait.! !
!TraitTransformation methodsFor: 'accessing' stamp: 'ar 11/18/2007 19:12'!
allTraits
^subject allTraits! !
!TraitTransformation methodsFor: 'accessing' stamp: 'ar 11/18/2007 19:11'!
removeUser: aTrait
users := users copyWithout: aTrait.
users ifEmpty:[subject removeUser: self].
! !
!TraitTransformation methodsFor: 'accessing' stamp: 'ar 11/18/2007 19:12'!
subject: aSubject
subject := aSubject.! !
!TraitTransformation methodsFor: 'accessing' stamp: 'ar 11/22/2007 06:08'!
theTrait
^subject theTrait! !
!TraitTransformation methodsFor: 'accessing' stamp: 'ar 11/22/2007 06:08'!
traitsDo: aBlock
^subject traitsDo: aBlock! !
!TraitTransformation methodsFor: 'accessing' stamp: 'ar 11/18/2007 21:02'!
traitUsers
"Answer this traits users, without the transforms in the middle"
^users gather:[:each|
(each isBehavior)
ifTrue:[Array with: each]
ifFalse:[each traitUsers]].! !
!TraitTransformation methodsFor: 'testing' stamp: 'ar 5/11/2008 02:13'!
isAliasSelector: selector
^subject isAliasSelector: selector! !
!TraitTransformation methodsFor: 'testing' stamp: 'ar 5/11/2008 02:17'!
isLocalAliasSelector: selector
^false! !
!TraitTransformation methodsFor: 'testing' stamp: 'ar 11/22/2007 04:24'!
isTraitTransformation
"Polymorphic with Trait"
^true! !
!TraitTransformation methodsFor: 'testing' stamp: 'ar 11/22/2007 06:08'!
usesTrait: aTrait
^subject usesTrait: aTrait! !
!TraitTransformation methodsFor: 'composition' stamp: 'ar 11/22/2007 06:14'!
classify: selector under: category fromTrait: aTrait
"broadcasts a reclassification of some selector to all users of a trait"
^self subclassResponsibility! !
!TraitTransformation methodsFor: 'composition' stamp: 'ar 11/22/2007 06:18'!
copyTraitExpression
"Copy all except the actual traits"
^self subclassResponsibility! !
!TraitTransformation methodsFor: 'composition' stamp: 'ar 11/22/2007 06:12'!
selectorsAndMethodsDo: aBlock
"enumerates all selectors and methods in a trait composition"
^self subclassResponsibility! !
!TraitTransformation methodsFor: 'composition' stamp: 'ar 11/22/2007 06:15'!
traitCompositionString
"Answer the trait composition string (used for class definitions)"
^self subclassResponsibility! !
!TraitTransformation methodsFor: 'composition' stamp: 'ar 11/22/2007 06:12'!
updateSelector: aSelector withTraitMethod: compiledMethod from: aTrait
"broadcasts the change of a selector to all users of a trait"
^self subclassResponsibility! !
!TraitTransformation methodsFor: 'printing' stamp: 'ar 11/22/2007 06:19'!
asString
^self traitCompositionString! !
!TraitTransformation methodsFor: 'printing' stamp: 'ar 11/22/2007 06:19'!
printOn: aStream
super printOn: aStream.
aStream nextPut: $(; print: users; nextPutAll: ': '; nextPutAll: self traitCompositionString; nextPut: $).! !
!TraitTransformation methodsFor: 'converting' stamp: 'ar 11/18/2007 17:44'!
asTraitTransform
^self! !
!TraitTransformation methodsFor: 'converting' stamp: 'ar 11/22/2007 04:07'!
+ aTrait
"Just like ordered collection"
^TraitComposition withAll: {self. aTrait}! !
!TraitTransformation methodsFor: 'converting' stamp: 'ar 11/18/2007 23:13'!
- anArrayOfSelectors
^TraitExclusion
with: self
exclusions: anArrayOfSelectors! !
!TraitTransformation methodsFor: 'converting' stamp: 'ar 11/18/2007 23:14'!
@ anArrayOfAssociations
self error: 'Invalid trait exclusion. Aliases have to be specified before exclusions.'! !
!TraitAlias methodsFor: 'initialize-release' stamp: 'ar 11/18/2007 17:14'!
initialize
super initialize.
aliases := Dictionary new.! !
!TraitAlias methodsFor: 'initialize-release' stamp: 'ar 5/11/2008 02:28'!
initializeFrom: anArrayOfAssociations
| newNames |
newNames := (anArrayOfAssociations collect: [:each | each key]) asIdentitySet.
newNames size < anArrayOfAssociations size ifTrue: [
TraitCompositionException signal: 'Cannot use the same alias name twice'].
anArrayOfAssociations do: [:each |
(newNames includes: each value) ifTrue: [
TraitCompositionException signal: 'Cannot define an alias for an alias']].
aliases := Dictionary new.
anArrayOfAssociations do:[:assoc|
aliases at: assoc value put: assoc key.
].! !
!TraitAlias methodsFor: 'accessing' stamp: 'ar 11/18/2007 17:07'!
aliases
"Collection of associations where key is the
alias and value the original selector."
^aliases! !
!TraitAlias methodsFor: 'accessing' stamp: 'ar 11/18/2007 17:45'!
aliases: aDictionary
aliases := aDictionary! !
!TraitAlias methodsFor: 'composition' stamp: 'ar 5/1/2008 21:14'!
classify: selector under: category fromTrait: aTrait
"broadcasts a reclassification of some selector to all users of a trait"
^users do:[:each|
each classify: selector under: category fromTrait: aTrait.
(aliases includesKey: selector) ifTrue:[
each classify: (aliases at: selector) under: category fromTrait: aTrait.
].
].! !
!TraitAlias methodsFor: 'composition' stamp: 'ar 11/22/2007 06:18'!
copyTraitExpression
"Copy all except the actual traits"
^TraitAlias
with: subject
aliases: (Array streamContents:[:s|
aliases associationsDo:[:a| s nextPut: a value -> a key]])
! !
!TraitAlias methodsFor: 'composition' stamp: 'ar 5/1/2008 21:14'!
includesSelector: selector
"Answers true if the receiver provides the selector"
^(subject includesSelector: selector) or:[aliases includesKey: selector]! !
!TraitAlias methodsFor: 'composition' stamp: 'ar 5/1/2008 21:15'!
selectorsAndMethodsDo: aBlock
"enumerates all selectors and methods in a trait composition"
^subject selectorsAndMethodsDo:[:sel :meth|
aBlock value: sel value: meth.
(aliases includesKey: sel)
ifTrue:[aBlock value: (aliases at: sel ifAbsent:[sel]) value: meth]
].! !
!TraitAlias methodsFor: 'composition' stamp: 'ar 11/22/2007 06:16'!
traitCompositionString
"Answer the trait composition string (used for class definitions)"
^String streamContents:[:s|
s nextPutAll: subject traitCompositionString.
s nextPutAll: ' @ {'.
aliases keys asArray sort do:[:original|
s print: (aliases at: original); nextPutAll: ' -> '; print: original.
] separatedBy:[s nextPutAll:'. '].
s nextPutAll: '}'.
].! !
!TraitAlias methodsFor: 'composition' stamp: 'ar 5/1/2008 21:15'!
updateSelector: aSelector withTraitMethod: compiledMethod from: aTrait
"broadcasts the change of a selector to all users of a trait"
users do:[:each|
each updateSelector: aSelector withTraitMethod: compiledMethod from: aTrait.
(aliases includesKey: aSelector) ifTrue:[
each updateSelector: (aliases at: aSelector ifAbsent:[aSelector])
withTraitMethod: compiledMethod from: aTrait
].
].! !
!TraitAlias methodsFor: 'converting' stamp: 'ar 11/18/2007 18:11'!
asArrayOfAssociations
"Awkward, compatible mapped -> original representation"
^Array streamContents:[:s|
aliases keysAndValuesDo:[:original :mapped|
s nextPut: mapped -> original.
].
].! !
!TraitAlias methodsFor: 'converting' stamp: 'ar 11/18/2007 19:13'!
@ anArrayOfAssociations
^TraitAlias
with: subject
aliases: (anArrayOfAssociations, self asArrayOfAssociations)! !
!TraitAlias methodsFor: 'testing' stamp: 'ar 5/11/2008 02:17'!
isAliasSelector: selector
^(aliases includes: selector) or:[super isAliasSelector: selector]! !
!TraitAlias methodsFor: 'testing' stamp: 'ar 5/11/2008 02:17'!
isLocalAliasSelector: selector
^(aliases includes: selector)! !
!TraitExclusion methodsFor: 'initialize' stamp: 'ar 11/18/2007 17:16'!
initialize
super initialize.
exclusions := Set new.
! !
!TraitExclusion methodsFor: 'accessing' stamp: 'ar 11/18/2007 18:04'!
exclusions
^exclusions! !
!TraitExclusion methodsFor: 'accessing' stamp: 'ar 11/18/2007 18:04'!
exclusions: aCollection
exclusions := Set withAll: aCollection! !
!TraitExclusion methodsFor: 'composition' stamp: 'ar 11/22/2007 06:13'!
classify: selector under: category fromTrait: aTrait
"broadcasts a reclassification of some selector to all users of a trait"
(exclusions includes: selector) ifFalse:[
users do:[:each| each classify: selector under: category fromTrait: aTrait]
].! !
!TraitExclusion methodsFor: 'composition' stamp: 'ar 11/22/2007 06:19'!
copyTraitExpression
"Copy all except the actual traits"
^TraitExclusion
with: subject
exclusions: exclusions asArray! !
!TraitExclusion methodsFor: 'composition' stamp: 'ar 11/27/2007 22:10'!
includesSelector: selector
"Answers true if the receiver provides the selector"
^(subject includesSelector: selector) and:[(exclusions includes: selector) not]! !
!TraitExclusion methodsFor: 'composition' stamp: 'ar 11/22/2007 06:12'!
selectorsAndMethodsDo: aBlock
"enumerates all selectors and methods in a trait composition"
^subject selectorsAndMethodsDo:[:sel :meth|
(exclusions includes: sel) ifFalse:[aBlock value: sel value: meth].
].! !
!TraitExclusion methodsFor: 'composition' stamp: 'ar 11/22/2007 06:17'!
traitCompositionString
"Answer the trait composition string (used for class definitions)"
^String streamContents:[:s|
s nextPutAll: subject traitCompositionString.
s nextPutAll: ' - {'.
exclusions asArray sort do:[:exc| s store: exc] separatedBy:[s nextPutAll: '. '].
s nextPutAll: '}'.
].! !
!TraitExclusion methodsFor: 'composition' stamp: 'ar 11/22/2007 06:11'!
updateSelector: aSelector withTraitMethod: compiledMethod from: aTrait
"broadcasts the change of a selector to all users of a trait"
(exclusions includes: aSelector) ifFalse:[
users do:[:each| each updateSelector: aSelector withTraitMethod: compiledMethod from: aTrait]
].! !
!TraitExclusion methodsFor: 'converting' stamp: 'ar 11/18/2007 18:09'!
- anArrayOfSelectors
^TraitExclusion
with: subject
exclusions: (anArrayOfSelectors, exclusions asArray)! !
!TraitAlias class methodsFor: 'instance creation' stamp: 'ar 5/11/2008 02:27'!
assertValidAliasDefinition: anArrayOfAssociations
"Throw an exceptions if the alias definition is not valid.
It is expected to be a collection of associations and
the number of arguments of the alias selector has to
be the same as the original selector."
((anArrayOfAssociations isKindOf: Collection) and: [
anArrayOfAssociations allSatisfy: [:each |
each isKindOf: Association]]) ifFalse: [
self error: 'Invalid alias definition: Not a collection of associations.'].
(anArrayOfAssociations allSatisfy: [:association |
(association key numArgs = association value numArgs and: [
(association key numArgs = -1) not])]) ifFalse: [
TraitCompositionException signal: 'Invalid alias definition: Alias and original selector have to have the same number of arguments.']! !
!TraitAlias class methodsFor: 'instance creation' stamp: 'ar 11/18/2007 17:45'!
with: aTraitComposition aliases: anArrayOfAssociations
self assertValidAliasDefinition: anArrayOfAssociations.
^self new
subject: aTraitComposition;
initializeFrom: anArrayOfAssociations;
yourself! !
!TraitExclusion class methodsFor: 'instance creation' stamp: 'ar 11/18/2007 18:04'!
with: aTraitComposition exclusions: anArrayOfSelectors
^self new
subject: aTraitComposition;
exclusions: anArrayOfSelectors;
yourself
! !
!TraitExclusion class reorganize!
('instance creation' with:exclusions:)
!
!TraitAlias class reorganize!
('instance creation' assertValidAliasDefinition: with:aliases:)
!
!TraitTransformation class reorganize!
('as yet unclassified')
!
!TraitExclusion reorganize!
('initialize' initialize)
('accessing' exclusions exclusions:)
('composition' classify:under:fromTrait: copyTraitExpression includesSelector: selectorsAndMethodsDo: traitCompositionString updateSelector:withTraitMethod:from:)
('converting' -)
!
!TraitAlias reorganize!
('initialize-release' initialize initializeFrom:)
('accessing' aliases aliases:)
('composition' classify:under:fromTrait: copyTraitExpression includesSelector: selectorsAndMethodsDo: traitCompositionString updateSelector:withTraitMethod:from:)
('converting' asArrayOfAssociations @)
('testing' isAliasSelector: isLocalAliasSelector:)
!
!TraitTransformation reorganize!
('initialize' initialize)
('accessing' addUser: allTraits removeUser: subject: theTrait traitsDo: traitUsers)
('testing' isAliasSelector: isLocalAliasSelector: isTraitTransformation usesTrait:)
('composition' classify:under:fromTrait: copyTraitExpression selectorsAndMethodsDo: traitCompositionString updateSelector:withTraitMethod:from:)
('printing' asString printOn:)
('converting' asTraitTransform + - @)
!
!Trait class reorganize!
('instance creation' named:uses:category: named:uses:category:env:)
('accessing')
!
!Metatrait class reorganize!
('instance creation' new)
!
!TraitDescription class reorganize!
('as yet unclassified')
!
!Trait reorganize!
('initialize' definitionST80 isValidTraitName: obsolete removeFromSystem removeFromSystem: rename: setName:andRegisterInCategory:environment:)
('accessing' category category: classTrait environment environment: name name:)
('testing' hasClassTrait isBaseTrait isObsolete)
!
!Metatrait reorganize!
('initialize' updateTraitsFrom: uses:)
('accessing' baseTrait definitionST80 instanceSide name new)
('testing' isClassTrait isMeta)
!
!TraitDescription reorganize!
('accessing' addUser: allClassVarNames classPool removeUser: sharedPools theTrait traitUsers users users:)
('copying' copy copyTraitExpression)
('testing' isBaseTrait isClassTrait isTrait isTraitTransformation usesTrait:)
('operations' addAndClassifySelector:withMethod:inProtocol:notifying: addSelectorSilently:withMethod: basicRemoveSelector: classify:under:fromTrait: recompile:from: traitsDo: + - @)
!
!TraitCompositionException class reorganize!
('as yet unclassified')
!
!TraitCompositionException reorganize!
('as yet unclassified')
!
TraitComposition initialize!
!TraitComposition class reorganize!
('class initialization' initialize)
('accessing' for: for:put:)
!
!TraitComposition reorganize!
('accessing' addUser: allTraits removeUser: traits traitsDo: traitUsers)
('testing' isTraitTransformation usesTrait:)
('converting' + - @)
('composition' classify:under:fromTrait: copyTraitExpression isAliasSelector: isLocalAliasSelector: selectorsAndMethodsDo: traitCompositionString updateSelector:withTraitMethod:from:)
!
>> It gives you an image, a) without traits, and b) with the old class format.
>>
>> The aim being to 1) enable folks with code that relies on the old format to
>> move up to 3.10 should they so desire 2) Satisfy those who dont like the
>> existing traits based traits implementation and would like to have something
>> simpler and 3) Provide a starting point for a future simpler traits
>> implementation if anyone wants to write it.
>
> What about people who need traits?
There is no reason why a traits implementation needs to be as intrusive
as this one. Earlier this year I had been playing with a traits
implementation for Croquet just to understand some of the implementation
aspects a little better and it was pretty clear that an alternative
implementation which is much less invasive is not only trivial to do but
fits much better into the rest of the existing system. I'm attaching a
draft version of this experiment (which is not fully functional since I
lost interest but it will load into Croquet and is enough to play with
it) and you can check it out to see how it hooks into the system -
basically traits inherit from ClassDescription which avoids most of the
code duplication and leaves the option for perhaps having stateful
traits at some point. The extension points to the existing kernel are
few (and could be made fewer) and loading and unloading would be trivial
with just a tiny bit more work.
In any case, this is not a complete implementation but rather an
illustration that the current implementation isn't the only way traits
can be implemented in Squeak and that an alternative can be small,
loadable, and easy to understand.
Cheers,
- Andreas
[Traits-Kernel.2.cs]
'From Croquet1.0beta of 11 April 2006 [latest update: #2] on 12 May 2008 at 5:48:20 am'!
OrderedCollection subclass: #TraitComposition
instanceVariableNames: ''
classVariableNames: 'TraitsCache'
poolDictionaries: ''
category: 'Traits-Kernel'!
!TraitComposition commentStamp: '<historical>' prior: 0!
A trait composition is a collection of Traits or TraitTransformations.!
TraitComposition class
instanceVariableNames: ''!
Error subclass: #TraitCompositionException
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Traits-Kernel'!
TraitCompositionException class
instanceVariableNames: ''!
ClassDescription subclass: #TraitDescription
instanceVariableNames: 'users'
classVariableNames: ''
poolDictionaries: ''
category: 'Traits-Kernel'!
TraitDescription subclass: #Metatrait
instanceVariableNames: 'baseTrait'
classVariableNames: ''
poolDictionaries: ''
category: 'Traits-Kernel'!
!Metatrait commentStamp: '<historical>' prior: 0!
Metatrait is the metaclass used for traits.!
TraitDescription subclass: #Trait
instanceVariableNames: 'name environment category'
classVariableNames: ''
poolDictionaries: ''
category: 'Traits-Kernel'!
TraitDescription class
instanceVariableNames: ''!
Metatrait class
instanceVariableNames: ''!
Trait class
instanceVariableNames: ''!
Object subclass: #TraitTransformation
instanceVariableNames: 'subject users'
classVariableNames: ''
poolDictionaries: ''
category: 'Traits-Kernel'!
TraitTransformation subclass: #TraitAlias
instanceVariableNames: 'aliases'
classVariableNames: ''
poolDictionaries: ''
category: 'Traits-Kernel'!
TraitTransformation subclass: #TraitExclusion
instanceVariableNames: 'exclusions'
classVariableNames: ''
poolDictionaries: ''
category: 'Traits-Kernel'!
TraitTransformation class
instanceVariableNames: ''!
TraitAlias class
instanceVariableNames: ''!
TraitExclusion class
instanceVariableNames: ''!
!Object methodsFor: '*Traits-Kernel' stamp: 'ar 11/22/2007 04:25'!
isTrait
^false! !
!Behavior methodsFor: '*Traits-Kernel' stamp: 'ar 5/11/2008 02:09'!
hasTraitComposition
^self traitComposition notEmpty! !
!Behavior methodsFor: '*Traits-Kernel' stamp: 'ar 5/11/2008 01:55'!
includesLocalSelector: selector
^(self compiledMethodAt: selector ifAbsent:[^false]) methodHome == self! !
!Behavior methodsFor: '*Traits-Kernel' stamp: 'ar 5/11/2008 02:11'!
isAliasSelector: aSymbol
"Return true if the selector aSymbol is an alias defined
in my or in another composition somewhere deeper in
the tree of traits compositions."
^(self includesLocalSelector: aSymbol) not
and: [self hasTraitComposition]
and: [self traitComposition isAliasSelector: aSymbol]! !
!Behavior methodsFor: '*Traits-Kernel' stamp: 'ar 5/11/2008 02:17'!
isLocalAliasSelector: aSymbol
"Return true if the selector aSymbol is an alias defined
in my or in another composition somewhere deeper in
the tree of traits compositions."
^(self includesLocalSelector: aSymbol) not
and: [self hasTraitComposition]
and: [self traitComposition isLocalAliasSelector: aSymbol]! !
!Behavior methodsFor: '*Traits-Kernel' stamp: 'ar 5/11/2008 02:07'!
localSelectors
^self selectors select:[:sel| self includesLocalSelector: sel]! !
!ClassDescription methodsFor: '*Traits-Kernel' stamp: 'ar 11/28/2007 20:53'!
addSelector: selector withTraitMethod: compiledMethod
"Add a method from a trait. Recompiles if the method includes super sends."
| newMethod |
self addSelectorSilently: selector withMethod: compiledMethod.
(compiledMethod sendsToSuper) ifTrue:[
self recompile: selector.
newMethod := self compiledMethodAt: selector.
newMethod == compiledMethod ifTrue:[self error: 'Recompilation failure'].
"Set the original home of the recompiled method"
newMethod methodHome: compiledMethod methodHome.
].! !
!ClassDescription methodsFor: '*Traits-Kernel' stamp: 'ar 11/22/2007 04:21'!
allTraits
"Answer all the traits that are used by myself without their transformations"
^self traits gather:[:t| t allTraits copyWith: t].! !
!ClassDescription methodsFor: '*Traits-Kernel' stamp: 'ar 11/28/2007 20:49'!
basicRemoveSelector: selector
"Assuming that the argument, selector (a Symbol), is a message selector
in my method dictionary, remove it and its method. For traits, we need to check
whether the selector originated in a different trait and if so, exclude it from the trait
in addition to removing it."
| oldMethod oldHome tc updated |
oldMethod := self compiledMethodAt: selector ifAbsent:[^nil].
oldHome := oldMethod methodHome.
"Make sure this is neither my trait nor that the method was removed from oldHome"
(oldHome isTrait and:[oldHome includesSelector: selector]) ifTrue:[
"Find any trait transformation providing the selector"
tc := self traitComposition.
oldHome := tc detect:[:t| t includesSelector: selector] ifNone:[nil].
oldHome ifNotNil:["Exclude the selector and store the transform back"
oldHome removeUser: self.
updated := oldHome - {selector}.
updated addUser: self.
updated = oldHome ifFalse:[tc at: (tc indexOf: oldHome) put: updated]
].
].
super basicRemoveSelector: selector.
"The following is slow, but effective to propagate a selector from a trait after removing it."
self installTraitsFrom: self traitComposition.! !
!ClassDescription methodsFor: '*Traits-Kernel' stamp: 'ar 11/28/2007 20:50'!
classify: selector under: heading fromTrait: aTrait
"Update the organization for a trait"
| compiledMethod |
compiledMethod := self compiledMethodAt: selector.
compiledMethod methodHome == aTrait ifTrue:[
self organization classify: selector under: heading.
].! !
!ClassDescription methodsFor: '*Traits-Kernel' stamp: 'ar 11/18/2007 19:02'!
classSide
^self theMetaClass! !
!ClassDescription methodsFor: '*Traits-Kernel' stamp: 'ar 5/11/2008 02:38'!
fileOutInitializerOn: aStream
"-- ignored --"! !
!ClassDescription methodsFor: '*Traits-Kernel' stamp: 'ar 5/11/2008 02:37'!
fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex initializing: aBool
^self fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex! !
!ClassDescription methodsFor: '*Traits-Kernel' stamp: 'ar 11/28/2007 21:22'!
installTraitsFrom: aTraitComposition
"Install the traits from the given composition"
| allTraits methods oldMethod removals |
(self traitComposition isEmpty and: [aTraitComposition isEmpty]) ifTrue: [^self].
"Check for cycles"
allTraits := aTraitComposition gather: [:t | t allTraits copyWith: t].
(allTraits includes: self) ifTrue:[^self error: 'Cyclic trait definition detected'].
"Assemble the methods in a new dictionary first.
Uses a Dictionary instead of a MethodDictionary for speed (MDs grow by #become:)"
methods := Dictionary new.
"Stick in the local methods first, since this avoids generating conflict methods unnecessarily"
self selectorsAndMethodsDo:[:sel :newMethod|
(self isLocalMethod: newMethod)
ifTrue:[methods at: sel put:newMethod]].
"Now assemble the traits methods"
aTraitComposition do:[:trait|
trait selectorsAndMethodsDo:[:sel :newMethod|
oldMethod := methods at: sel ifAbsentPut:[newMethod].
newMethod == oldMethod ifFalse:["a conflict"
(self isLocalMethod: oldMethod) ifFalse:[
methods at: sel put: (self resolveTraitsConflict: sel from: oldMethod to: newMethod).
].
].
].
].
"Apply the changes. We first add the new or changed methods."
methods keysAndValuesDo:[:sel :newMethod|
oldMethod := self compiledMethodAt: sel ifAbsent:[nil].
oldMethod == newMethod ifFalse:[
self addSelector: sel withTraitMethod: newMethod.
self organization classify: sel under: (newMethod methodHome organization categoryOfElement: newMethod selector).
]].
"Now remove the old or obsoleted ones"
removals := OrderedCollection new.
self selectorsDo:[:sel| (methods includesKey: sel) ifFalse:[removals add: sel]].
removals do:[:sel| self removeSelector: sel].
self traitComposition: aTraitComposition.
self isMeta ifFalse:[self class updateTraitsFrom: aTraitComposition].! !
!ClassDescription methodsFor: '*Traits-Kernel' stamp: 'ar 5/11/2008 01:53'!
instanceSide
^self theNonMetaClass! !
!ClassDescription methodsFor: '*Traits-Kernel' stamp: 'ar 11/28/2007 20:51'!
isLocalMethod: aCompiledMethod
"Answer true if the method is a local method, e.g., defined in the receiver instead of a trait."
^aCompiledMethod methodHome == self! !
!ClassDescription methodsFor: '*Traits-Kernel' stamp: 'ar 11/18/2007 18:16'!
removeTraitSelector: selector
self removeSelectorSilently: selector! !
!ClassDescription methodsFor: '*Traits-Kernel' stamp: 'ar 5/1/2008 21:25'!
replaceTraitSelector: original with: aSelector in: source for: aMethod
| oldKeywords newKeywords args newSelectorWithArgs startOfSource lastSelectorToken |
oldKeywords := original keywords.
newKeywords := aSelector keywords.
self assert: oldKeywords size = newKeywords size.
args := (self parserClass new
parseArgsAndTemps: source string notifying: nil) copyFrom: 1 to: aMethod numArgs.
newSelectorWithArgs := String streamContents: [:stream |
newKeywords withIndexDo: [:keyword :index |
stream nextPutAll: keyword.
stream space.
args size >= index ifTrue: [
stream nextPutAll: (args at: index); space]]].
lastSelectorToken := args isEmpty
ifFalse: [args last]
ifTrue: [oldKeywords last].
startOfSource := (source string
indexOfSubCollection: lastSelectorToken startingAt: 1) + lastSelectorToken size.
^newSelectorWithArgs withBlanksTrimmed asText , (source copyFrom: startOfSource to: source size)! !
!ClassDescription methodsFor: '*Traits-Kernel' stamp: 'ar 11/18/2007 15:22'!
resolveTraitsConflict: selector from: oldMethod to: newMethod
"Resolve a traits conflict. Last one wins (for now)"
^newMethod
! !
!ClassDescription methodsFor: '*Traits-Kernel' stamp: 'ar 11/22/2007 04:12'!
traitComposition
"Answer an array of my traits"
^TraitComposition for: self! !
!ClassDescription methodsFor: '*Traits-Kernel' stamp: 'ar 11/22/2007 06:32'!
traitCompositionString
"Print a description of the traits composition"
^self name asString! !
!ClassDescription methodsFor: '*Traits-Kernel' stamp: 'ar 11/22/2007 06:29'!
traitComposition: aTraitComposition
"Install my traits"
(aTraitComposition isKindOf: TraitComposition) ifFalse:[self error: 'Not a trait composition'].
self traitComposition do:[:t| t removeUser: self].
TraitComposition for: self put: aTraitComposition.
aTraitComposition do:[:t| t addUser: self].
! !
!ClassDescription methodsFor: '*Traits-Kernel' stamp: 'ar 11/22/2007 04:36'!
traits
"Answer an array of my traits"
^self traitComposition asArray collect:[:composed| composed theTrait]! !
!ClassDescription methodsFor: '*Traits-Kernel' stamp: 'ar 11/28/2007 21:22'!
updateSelector: selector withTraitMethod: compiledMethod from: aTrait
"A selector in the given trait has changed. Update my usage of it."
| oldMethod |
oldMethod := self compiledMethodAt: selector ifAbsent:[nil].
(oldMethod == nil and:[compiledMethod == nil]) ifTrue:[^nil].
oldMethod ifNil:["No previous method, add and classify the new method"
self addSelector: selector withTraitMethod: compiledMethod.
self organization classify: selector under: (aTrait organization categoryOfElement: selector).
^self].
(self isLocalMethod: oldMethod) ifTrue:[^nil]. "local version trumps override"
oldMethod methodHome == aTrait ifTrue:["same trait, just update"
compiledMethod ifNil:[^self removeTraitSelector: selector].
^self addSelector: selector withTraitMethod: compiledMethod].
compiledMethod ifNil:[^self]. "removed a method from a different trait"
"Resolve conflict"
^self addSelector: selector withTraitMethod:
(self resolveTraitsConflict: selector from: oldMethod to: compiledMethod)! !
!ClassDescription methodsFor: '*Traits-Kernel' stamp: 'ar 11/18/2007 22:27'!
usesTrait: aTrait
^self traits anySatisfy:[:t| t usesTrait: aTrait].! !
!ClassDescription methodsFor: '*Traits-Kernel' stamp: 'ar 5/11/2008 02:34'!
uses: aTraitComposition
| newTraits |
newTraits := (aTraitComposition isKindOf: Trait orOf: TraitTransformation)
ifTrue:[TraitComposition with: aTraitComposition]
ifFalse:[(aTraitComposition isKindOf: SequenceableCollection)
ifTrue:[TraitComposition withAll: aTraitComposition asArray]
ifFalse:[self error: 'Invalid traits specification']].
self installTraitsFrom: newTraits.
! !
!Class methodsFor: '*Traits-Kernel' stamp: 'ar 11/22/2007 06:34'!
definitionST80
"Answer a String that defines the receiver."
| aStream path |
aStream := WriteStream on: (String new: 300).
superclass == nil
ifTrue: [aStream nextPutAll: 'ProtoObject']
ifFalse: [path := ''.
self environment scopeFor: superclass name from: nil
envtAndPathIfFound: [:envt :remotePath | path := remotePath].
aStream nextPutAll: path , superclass name].
aStream nextPutAll: self kindOfSubclass;
store: self name.
self traitComposition ifNotEmpty:[
aStream cr; tab; nextPutAll: 'uses: ';
nextPutAll: self traitComposition traitCompositionString.
].
aStream cr; tab; nextPutAll: 'instanceVariableNames: ';
store: self instanceVariablesString.
aStream cr; tab; nextPutAll: 'classVariableNames: ';
store: self classVariablesString.
aStream cr; tab; nextPutAll: 'poolDictionaries: ';
store: self sharedPoolsString.
aStream cr; tab; nextPutAll: 'category: ';
store: (SystemOrganization categoryOfElement: self name) asString.
superclass ifNil: [
aStream nextPutAll: '.'; cr.
aStream nextPutAll: self name.
aStream space; nextPutAll: 'superclass: nil'. ].
^ aStream contents! !
!Class methodsFor: '*Traits-Kernel' stamp: 'ar 5/11/2008 02:34'!
subclass: t uses: aTraitComposition instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat
| newClass copyOfOldClass |
copyOfOldClass := self copy.
newClass := self
subclass: t
instanceVariableNames: f
classVariableNames: d
poolDictionaries: s
category: cat.
newClass uses: aTraitComposition.
SystemChangeNotifier uniqueInstance
classDefinitionChangedFrom: copyOfOldClass to: newClass.
^newClass! !
!CompiledMethod methodsFor: '*Traits-Kernel' stamp: 'ar 11/28/2007 20:48'!
methodHome
"The behavior (trait/class) this method was originally defined in.
Can be different from methodClass if the method was recompiled due to super sends."
^self properties at: #methodHome ifAbsent:[self methodClass]! !
!CompiledMethod methodsFor: '*Traits-Kernel' stamp: 'ar 11/28/2007 20:48'!
methodHome: aBehavior
"The behavior (trait/class) this method was originally defined in.
Can be different from methodClass if the method was recompiled due to super sends."
aBehavior
ifNil:[self properties removeKey: #methodHome]
ifNotNil:[self properties at: #methodHome put: aBehavior].! !
!Metaclass methodsFor: '*Traits-Kernel' stamp: 'ar 11/22/2007 06:34'!
definitionST80
"Refer to the comment in ClassDescription|definition."
^ String streamContents:
[:strm |
strm print: self.
self traitComposition ifNotEmpty:[
strm crtab; nextPutAll: 'uses: '; nextPutAll: self traitComposition traitCompositionString.
].
strm
crtab;
nextPutAll: 'instanceVariableNames: ';
store: self instanceVariablesString]! !
!Metaclass methodsFor: '*Traits-Kernel' stamp: 'ar 11/22/2007 04:20'!
updateTraitsFrom: instanceTraits
"Update me from the given instance traits"
| map newTraits trait |
map := Dictionary new.
self traitComposition do:[:composed| map at: composed theTrait put: composed].
newTraits := (instanceTraits collect:[:composed|
trait := composed theTrait classTrait.
map at: trait ifAbsent:[trait]]
), (self traitComposition select:[:comp| comp theTrait isBaseTrait]).
self installTraitsFrom: newTraits! !
!Metaclass methodsFor: '*Traits-Kernel' stamp: 'ar 5/11/2008 02:34'!
uses: aTraitComposition instanceVariableNames: instVarString
| newMetaClass copyOfOldMetaClass |
copyOfOldMetaClass := self copy.
newMetaClass := self instanceVariableNames: instVarString.
self uses: aTraitComposition.
SystemChangeNotifier uniqueInstance
classDefinitionChangedFrom: copyOfOldMetaClass to: newMetaClass! !
!TraitComposition methodsFor: 'accessing' stamp: 'ar 11/18/2007 19:20'!
addUser: aUser
self do:[:each| each addUser: aUser]! !
!TraitComposition methodsFor: 'accessing' stamp: 'ar 11/22/2007 04:37'!
allTraits
^self gather:[:each| each allTraits copyWith: each theTrait]! !
!TraitComposition methodsFor: 'accessing' stamp: 'ar 11/18/2007 19:20'!
removeUser: aUser
self do:[:each| each removeUser: aUser]! !
!TraitComposition methodsFor: 'accessing' stamp: 'ar 5/11/2008 02:30'!
traits
^Array streamContents:[:s| self traitsDo:[:t| s nextPut: t]]! !
!TraitComposition methodsFor: 'accessing' stamp: 'ar 11/22/2007 06:21'!
traitsDo: aBlock
^self do:[:each| each traitsDo: aBlock]! !
!TraitComposition methodsFor: 'accessing' stamp: 'ar 11/18/2007 21:02'!
traitUsers
"Answer this traits users, without the transforms in the middle"
^self gather:[:each|
(each isBehavior)
ifTrue:[Array with: each]
ifFalse:[each traitUsers]].! !
!TraitComposition methodsFor: 'testing' stamp: 'ar 11/28/2007 21:09'!
isTraitTransformation
"Polymorphic with TraitTransformation"
^false! !
!TraitComposition methodsFor: 'testing' stamp: 'ar 11/22/2007 06:21'!
usesTrait: aTrait
^self anySatisfy:[:each| each usesTrait: aTrait]! !
!TraitComposition methodsFor: 'converting' stamp: 'ar 11/18/2007 19:13'!
+ aTrait
self addLast: aTrait.
^self! !
!TraitComposition methodsFor: 'converting' stamp: 'ar 11/18/2007 23:13'!
- anArray
"the modifier operators #@ and #- bind stronger than +.
Thus, #@ or #- sent to a sum will only affect the most right summand"
self addLast: (self removeLast - anArray)! !
!TraitComposition methodsFor: 'converting' stamp: 'ar 11/18/2007 23:12'!
@ anArrayOfAssociations
"the modifier operators #@ and #- bind stronger than +.
Thus, #@ or #- sent to a sum will only affect the most right summand"
self addLast: (self removeLast @ anArrayOfAssociations)! !
!TraitComposition methodsFor: 'composition' stamp: 'ar 11/22/2007 06:21'!
classify: selector under: category fromTrait: aTrait
"broadcasts a reclassification of some selector to all users of a trait"
self do:[:each| each classify: selector under: category fromTrait: aTrait].! !
!TraitComposition methodsFor: 'composition' stamp: 'ar 11/22/2007 06:20'!
copyTraitExpression
"Copy all except the actual traits"
^self collect:[:each| each copyTraitExpression].! !
!TraitComposition methodsFor: 'composition' stamp: 'ar 5/11/2008 02:13'!
isAliasSelector: selector
"enumerates all selectors and methods in a trait composition"
^self anySatisfy:[:any| any isAliasSelector: selector]! !
!TraitComposition methodsFor: 'composition' stamp: 'ar 5/11/2008 02:17'!
isLocalAliasSelector: selector
"enumerates all selectors and methods in a trait composition"
^self anySatisfy:[:any| any isLocalAliasSelector: selector]! !
!TraitComposition methodsFor: 'composition' stamp: 'ar 11/22/2007 06:12'!
selectorsAndMethodsDo: aBlock
"enumerates all selectors and methods in a trait composition"
self do:[:each| each selectorsAndMethodsDo: aBlock].! !
!TraitComposition methodsFor: 'composition' stamp: 'ar 11/22/2007 06:23'!
traitCompositionString
"Answer the trait composition string (used for class definitions)"
self size = 0 ifTrue:[^'{}'].
self size = 1 ifTrue:[^self first traitCompositionString].
^String streamContents:[:s|
self do:[:each| s nextPutAll: each traitCompositionString] separatedBy:[s nextPutAll: ' + '].
].! !
!TraitComposition methodsFor: 'composition' stamp: 'ar 11/22/2007 06:11'!
updateSelector: aSelector withTraitMethod: compiledMethod from: aTrait
"broadcasts the change of a selector to all users of a trait"
^self do:[:each| each updateSelector: aSelector withTraitMethod: compiledMethod from: aTrait]! !
!TraitComposition class methodsFor: 'class initialization' stamp: 'ar 11/22/2007 04:11'!
initialize
"TraitComposition initialize"
TraitsCache := Dictionary new.! !
!TraitComposition class methodsFor: 'accessing' stamp: 'ar 11/22/2007 04:10'!
for: aUser
"Answer the traits composition for the given user.
This method provides a storage area for traits in classes."
^TraitsCache at: aUser ifAbsent:[self new]! !
!TraitComposition class methodsFor: 'accessing' stamp: 'ar 11/22/2007 04:11'!
for: aUser put: aComposition
"Answer the traits composition for the given user.
This method provides a storage area for traits in classes."
^TraitsCache at: aUser put: aComposition! !
!TraitDescription methodsFor: 'accessing' stamp: 'ar 11/28/2007 20:54'!
addUser: aTrait
users := self users copyWith: aTrait.
! !
!TraitDescription methodsFor: 'accessing' stamp: 'ar 11/28/2007 20:57'!
allClassVarNames
"Traits have no class var names"
^#()! !
!TraitDescription methodsFor: 'accessing' stamp: 'ar 11/28/2007 20:58'!
classPool
"Traits have no class pool"
^ Dictionary new! !
!TraitDescription methodsFor: 'accessing' stamp: 'ar 11/28/2007 20:55'!
removeUser: aTrait
users := self users copyWithout: aTrait.
! !
!TraitDescription methodsFor: 'accessing' stamp: 'ar 11/28/2007 20:58'!
sharedPools
"Traits have no shared pools"
^ Dictionary new! !
!TraitDescription methodsFor: 'accessing' stamp: 'ar 11/28/2007 20:59'!
theTrait
^self! !
!TraitDescription methodsFor: 'accessing' stamp: 'ar 11/28/2007 20:55'!
traitUsers
"Answer this traits users, without the transforms in the middle"
^self users gather:[:each|
(each isBehavior)
ifTrue:[Array with: each]
ifFalse:[each traitUsers]].! !
!TraitDescription methodsFor: 'accessing' stamp: 'ar 11/28/2007 20:55'!
users
^users ifNil:[#()]! !
!TraitDescription methodsFor: 'accessing' stamp: 'ar 11/28/2007 20:55'!
users: aCollection
users := aCollection! !
!TraitDescription methodsFor: 'copying' stamp: 'ar 11/28/2007 20:55'!
copy
self error: 'Traits cannot be trivially copied'! !
!TraitDescription methodsFor: 'copying' stamp: 'ar 11/28/2007 20:55'!
copyTraitExpression
"Copy all except the actual traits"
^self! !
!TraitDescription methodsFor: 'testing' stamp: 'ar 11/28/2007 21:01'!
isBaseTrait
^false! !
!TraitDescription methodsFor: 'testing' stamp: 'ar 11/28/2007 21:01'!
isClassTrait
^false! !
!TraitDescription methodsFor: 'testing' stamp: 'ar 11/28/2007 20:56'!
isTrait
^true! !
!TraitDescription methodsFor: 'testing' stamp: 'ar 11/28/2007 20:56'!
isTraitTransformation
"Polymorphic with TraitTransformation"
^false! !
!TraitDescription methodsFor: 'testing' stamp: 'ar 11/28/2007 20:56'!
usesTrait: aTrait
^self == aTrait or:[super usesTrait: aTrait]! !
!TraitDescription methodsFor: 'operations' stamp: 'ar 11/28/2007 20:57'!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: category notifying: requestor
"Overridden to update the users of this trait"
super addAndClassifySelector: selector withMethod: compiledMethod inProtocol: category notifying: requestor.
"Update category"
self users do:[:each| each classify: selector under: category fromTrait: self].! !
!TraitDescription methodsFor: 'operations' stamp: 'ar 11/28/2007 20:57'!
addSelectorSilently: selector withMethod: compiledMethod
"Overridden to update the users of this trait"
super addSelectorSilently: selector withMethod: compiledMethod.
self users do:[:each| each updateSelector: selector withTraitMethod: compiledMethod from: self].! !
!TraitDescription methodsFor: 'operations' stamp: 'ar 11/28/2007 20:57'!
basicRemoveSelector: aSelector
"Overridden to update the users of this trait"
| priorMethod |
priorMethod := self compiledMethodAt: aSelector ifAbsent:[^nil].
super basicRemoveSelector: aSelector.
self users do:[:each|
each updateSelector: aSelector withTraitMethod: nil from: priorMethod methodHome].! !
!TraitDescription methodsFor: 'operations' stamp: 'ar 11/28/2007 20:57'!
classify: selector under: heading fromTrait: aTrait
"Update the organization for a trait"
super classify: selector under: heading fromTrait: aTrait.
self users do:[:each| each classify: selector under: heading fromTrait: aTrait].! !
!TraitDescription methodsFor: 'operations' stamp: 'ar 11/28/2007 20:58'!
recompile: selector from: oldClass
"Duplicated to avoid calling our version of addSelectorSilently:"
| method trailer methodNode |
method := oldClass compiledMethodAt: selector.
trailer := method trailer.
methodNode := self compilerClass new
compile: (oldClass sourceCodeAt: selector)
in: self
notifying: nil
ifFail: [^ self]. "Assume OK after proceed from SyntaxError"
selector == methodNode selector ifFalse: [self error: 'selector changed!!'].
super addSelectorSilently: selector withMethod: (methodNode generate: trailer).
! !
!TraitDescription methodsFor: 'operations' stamp: 'ar 11/28/2007 20:59'!
traitsDo: aBlock
aBlock value: self.! !
!TraitDescription methodsFor: 'operations' stamp: 'ar 11/28/2007 21:02'!
+ aTrait
"Creates a composition with the receiver and aTrait"
^TraitComposition withAll: {self. aTrait}! !
!TraitDescription methodsFor: 'operations' stamp: 'ar 11/28/2007 21:03'!
- anArrayOfSelectors
"Creates an exclusion"
^TraitExclusion
with: self
exclusions: anArrayOfSelectors! !
!TraitDescription methodsFor: 'operations' stamp: 'ar 11/28/2007 21:03'!
@ anArrayOfAssociations
"Creates an alias"
^ TraitAlias with: self aliases: anArrayOfAssociations! !
!Metatrait methodsFor: 'initialize' stamp: 'ar 11/22/2007 04:20'!
updateTraitsFrom: instanceTraits
"Update me from the given instance traits"
| map newTraits trait |
map := Dictionary new.
self traitComposition do:[:composed| map at: composed theTrait put: composed].
newTraits := (instanceTraits collect:[:composed|
trait := composed theTrait classTrait.
map at: trait ifAbsent:[trait]]
), (self traitComposition select:[:comp| comp theTrait isBaseTrait]).
self installTraitsFrom: newTraits! !
!Metatrait methodsFor: 'initialize' stamp: 'ar 11/22/2007 04:26'!
uses: aTraitComposition
| newTraits |
newTraits := (aTraitComposition isTrait or:[aTraitComposition isTraitTransformation])
ifTrue:[TraitComposition with: aTraitComposition]
ifFalse:[(aTraitComposition isKindOf: SequenceableCollection)
ifTrue:[TraitComposition withAll: aTraitComposition asArray]
ifFalse:[self error: 'Invalid traits specification']].
newTraits traitsDo:[:t|
(t isBaseTrait and:[t classSide hasMethods])
ifTrue:[self error: 'Cannot add: ', t].
(t isClassTrait and:[(baseTrait usesTrait: t baseTrait) not])
ifTrue:[self error: 'Cannot add: ', t].
].
self installTraitsFrom: newTraits.! !
!Metatrait methodsFor: 'accessing' stamp: 'ar 11/18/2007 23:00'!
baseTrait
^baseTrait! !
!Metatrait methodsFor: 'accessing' stamp: 'ar 11/22/2007 06:34'!
definitionST80
^String streamContents: [:stream |
stream nextPutAll: self name.
stream cr; tab; nextPutAll: 'uses: ';
nextPutAll: self traitComposition traitCompositionString.
].! !
!Metatrait methodsFor: 'accessing' stamp: 'ar 5/11/2008 01:51'!
instanceSide
^self baseTrait! !
!Metatrait methodsFor: 'accessing' stamp: 'ar 11/18/2007 21:44'!
name
^baseTrait name, ' classTrait'! !
!Metatrait methodsFor: 'accessing' stamp: 'ar 11/18/2007 21:45'!
new
baseTrait ifNotNil:[self error: 'Already initialized'].
baseTrait := self basicNew initialize.
baseTrait
superclass: nil
methodDictionary: MethodDictionary new
format: Object format.
^baseTrait! !
!Metatrait methodsFor: 'testing' stamp: 'ar 11/18/2007 22:59'!
isClassTrait
^true! !
!Metatrait methodsFor: 'testing' stamp: 'ar 11/18/2007 22:21'!
isMeta
^true! !
!Trait methodsFor: 'initialize' stamp: 'ar 11/28/2007 21:02'!
definitionST80
^String streamContents: [:stream |
stream nextPutAll: 'Trait named: ';
store: self name.
stream cr; tab; nextPutAll: 'uses: ';
nextPutAll: self traitComposition traitCompositionString.
stream cr; tab; nextPutAll: 'category: ';
store: self category asString].! !
!Trait methodsFor: 'initialize' stamp: 'ar 11/18/2007 15:33'!
isValidTraitName: aSymbol
^(aSymbol isEmptyOrNil
or: [aSymbol first isLetter not]
or: [aSymbol anySatisfy: [:character | character isAlphaNumeric not]]) not! !
!Trait methodsFor: 'initialize' stamp: 'ar 11/28/2007 21:00'!
obsolete
self name: ('AnObsolete' , self name) asSymbol.
super obsolete! !
!Trait methodsFor: 'initialize' stamp: 'ar 11/28/2007 21:00'!
removeFromSystem
self removeFromSystem: true! !
!Trait methodsFor: 'initialize' stamp: 'ar 11/28/2007 21:00'!
removeFromSystem: logged
self environment forgetClass: self logged: logged.
self obsolete! !
!Trait methodsFor: 'initialize' stamp: 'ar 11/18/2007 15:41'!
rename: aString
"The new name of the receiver is the argument, aString."
| newName |
(newName := aString asSymbol) ~= self name
ifFalse: [^ self].
(self environment includesKey: newName)
ifTrue: [^ self error: newName , ' already exists'].
(Undeclared includesKey: newName)
ifTrue: [self inform: 'There are references to, ' , aString printString , '
from Undeclared. Check them after this change.'].
self environment renameClass: self as: newName.
name := newName! !
!Trait methodsFor: 'initialize' stamp: 'ar 11/18/2007 15:33'!
setName: aSymbol andRegisterInCategory: categorySymbol environment: aSystemDictionary
(self isValidTraitName: aSymbol) ifFalse: [self error:'Invalid trait name'].
(self environment == aSystemDictionary
and: [self name = aSymbol
and: [self category = categorySymbol]]) ifTrue: [^self].
((aSystemDictionary includes: aSymbol) and: [(aSystemDictionary at: aSymbol) ~~ self])
ifTrue: [self error: 'The name ''' , aSymbol , ''' is already used'].
(self environment notNil and: [self name notNil and: [self name ~= aSymbol]]) ifTrue: [
self environment renameClass: self as: aSymbol].
self name: aSymbol.
self environment: aSystemDictionary.
self environment at: self name put: self.
self environment organization classify: self name under: categorySymbol.
^ true! !
!Trait methodsFor: 'accessing' stamp: 'ar 11/18/2007 15:37'!
category
"Answer the system organization category for the receiver. First check whether the
category name stored in the ivar is still correct and only if this fails look it up
(latter is much more expensive)"
| result |
category ifNotNilDo: [ :symbol |
((SystemOrganization listAtCategoryNamed: symbol) includes: self name)
ifTrue: [ ^symbol ] ].
category := (result := SystemOrganization categoryOfElement: self name).
^result! !
!Trait methodsFor: 'accessing' stamp: 'ar 11/18/2007 15:38'!
category: aString
"Categorize the receiver under the system category, aString, removing it from
any previous categorization."
| oldCategory |
oldCategory := category.
aString isString
ifTrue: [
category := aString asSymbol.
SystemOrganization classify: self name under: category ]
ifFalse: [self errorCategoryName].
SystemChangeNotifier uniqueInstance
class: self recategorizedFrom: oldCategory to: category! !
!Trait methodsFor: 'accessing' stamp: 'ar 11/18/2007 21:48'!
classTrait
^self class! !
!Trait methodsFor: 'accessing' stamp: 'ar 11/18/2007 15:37'!
environment
^environment! !
!Trait methodsFor: 'accessing' stamp: 'ar 11/18/2007 15:37'!
environment: anObject
environment := anObject! !
!Trait methodsFor: 'accessing' stamp: 'ar 11/18/2007 15:37'!
name
^name! !
!Trait methodsFor: 'accessing' stamp: 'ar 11/18/2007 15:37'!
name: aSymbol
name := aSymbol! !
!Trait methodsFor: 'testing' stamp: 'ar 5/11/2008 01:57'!
hasClassTrait
^true! !
!Trait methodsFor: 'testing' stamp: 'ar 11/18/2007 22:59'!
isBaseTrait
^true! !
!Trait methodsFor: 'testing' stamp: 'ar 11/18/2007 15:41'!
isObsolete
"Return true if the receiver is obsolete."
^(self environment at: name ifAbsent: [nil]) ~~ self! !
!Metatrait class methodsFor: 'instance creation' stamp: 'ar 11/18/2007 21:25'!
new
| newMeta |
newMeta := super new.
newMeta
superclass: Trait
methodDictionary: MethodDictionary new
format: Trait format.
^newMeta! !
!Trait class methodsFor: 'instance creation' stamp: 'ar 5/1/2008 21:16'!
named: aSymbol uses: aTraitCompositionOrCollection category: aString
| env |
env := self environment.
^self
named: aSymbol
uses: aTraitCompositionOrCollection
category: aString
env: env! !
!Trait class methodsFor: 'instance creation' stamp: 'ar 5/11/2008 02:34'!
named: aSymbol uses: aTraitComposition category: aString env: anEnvironment
| trait oldTrait systemCategory oldCategory |
systemCategory := aString asSymbol.
oldTrait := anEnvironment at: aSymbol ifAbsent: [nil].
oldTrait ifNil:[
trait := Metatrait new new.
] ifNotNil:[
oldCategory := oldTrait category.
trait := oldTrait.
].
(trait isKindOf: Trait) ifFalse: [
^self error: trait name , ' is not a Trait'].
trait
setName: aSymbol
andRegisterInCategory: systemCategory
environment: anEnvironment.
trait uses: aTraitComposition.
"... notify interested clients ..."
oldTrait ifNil:[
SystemChangeNotifier uniqueInstance classAdded: trait inCategory: systemCategory.
] ifNotNil:[
systemCategory = oldCategory ifFalse:[
SystemChangeNotifier uniqueInstance class: trait
recategorizedFrom: oldTrait category to: systemCategory].
].
^ trait! !
!TraitTransformation methodsFor: 'initialize' stamp: 'ar 11/18/2007 17:32'!
initialize
super initialize.
users := #().! !
!TraitTransformation methodsFor: 'accessing' stamp: 'ar 11/18/2007 19:12'!
addUser: aTrait
users ifEmpty:[subject addUser: self].
users := users copyWith: aTrait.! !
!TraitTransformation methodsFor: 'accessing' stamp: 'ar 11/18/2007 19:12'!
allTraits
^subject allTraits! !
!TraitTransformation methodsFor: 'accessing' stamp: 'ar 11/18/2007 19:11'!
removeUser: aTrait
users := users copyWithout: aTrait.
users ifEmpty:[subject removeUser: self].
! !
!TraitTransformation methodsFor: 'accessing' stamp: 'ar 11/18/2007 19:12'!
subject: aSubject
subject := aSubject.! !
!TraitTransformation methodsFor: 'accessing' stamp: 'ar 11/22/2007 06:08'!
theTrait
^subject theTrait! !
!TraitTransformation methodsFor: 'accessing' stamp: 'ar 11/22/2007 06:08'!
traitsDo: aBlock
^subject traitsDo: aBlock! !
!TraitTransformation methodsFor: 'accessing' stamp: 'ar 11/18/2007 21:02'!
traitUsers
"Answer this traits users, without the transforms in the middle"
^users gather:[:each|
(each isBehavior)
ifTrue:[Array with: each]
ifFalse:[each traitUsers]].! !
!TraitTransformation methodsFor: 'testing' stamp: 'ar 5/11/2008 02:13'!
isAliasSelector: selector
^subject isAliasSelector: selector! !
!TraitTransformation methodsFor: 'testing' stamp: 'ar 5/11/2008 02:17'!
isLocalAliasSelector: selector
^false! !
!TraitTransformation methodsFor: 'testing' stamp: 'ar 11/22/2007 04:24'!
isTraitTransformation
"Polymorphic with Trait"
^true! !
!TraitTransformation methodsFor: 'testing' stamp: 'ar 11/22/2007 06:08'!
usesTrait: aTrait
^subject usesTrait: aTrait! !
!TraitTransformation methodsFor: 'composition' stamp: 'ar 11/22/2007 06:14'!
classify: selector under: category fromTrait: aTrait
"broadcasts a reclassification of some selector to all users of a trait"
^self subclassResponsibility! !
!TraitTransformation methodsFor: 'composition' stamp: 'ar 11/22/2007 06:18'!
copyTraitExpression
"Copy all except the actual traits"
^self subclassResponsibility! !
!TraitTransformation methodsFor: 'composition' stamp: 'ar 11/22/2007 06:12'!
selectorsAndMethodsDo: aBlock
"enumerates all selectors and methods in a trait composition"
^self subclassResponsibility! !
!TraitTransformation methodsFor: 'composition' stamp: 'ar 11/22/2007 06:15'!
traitCompositionString
"Answer the trait composition string (used for class definitions)"
^self subclassResponsibility! !
!TraitTransformation methodsFor: 'composition' stamp: 'ar 11/22/2007 06:12'!
updateSelector: aSelector withTraitMethod: compiledMethod from: aTrait
"broadcasts the change of a selector to all users of a trait"
^self subclassResponsibility! !
!TraitTransformation methodsFor: 'printing' stamp: 'ar 11/22/2007 06:19'!
asString
^self traitCompositionString! !
!TraitTransformation methodsFor: 'printing' stamp: 'ar 11/22/2007 06:19'!
printOn: aStream
super printOn: aStream.
aStream nextPut: $(; print: users; nextPutAll: ': '; nextPutAll: self traitCompositionString; nextPut: $).! !
!TraitTransformation methodsFor: 'converting' stamp: 'ar 11/18/2007 17:44'!
asTraitTransform
^self! !
!TraitTransformation methodsFor: 'converting' stamp: 'ar 11/22/2007 04:07'!
+ aTrait
"Just like ordered collection"
^TraitComposition withAll: {self. aTrait}! !
!TraitTransformation methodsFor: 'converting' stamp: 'ar 11/18/2007 23:13'!
- anArrayOfSelectors
^TraitExclusion
with: self
exclusions: anArrayOfSelectors! !
!TraitTransformation methodsFor: 'converting' stamp: 'ar 11/18/2007 23:14'!
@ anArrayOfAssociations
self error: 'Invalid trait exclusion. Aliases have to be specified before exclusions.'! !
!TraitAlias methodsFor: 'initialize-release' stamp: 'ar 11/18/2007 17:14'!
initialize
super initialize.
aliases := Dictionary new.! !
!TraitAlias methodsFor: 'initialize-release' stamp: 'ar 5/11/2008 02:28'!
initializeFrom: anArrayOfAssociations
| newNames |
newNames := (anArrayOfAssociations collect: [:each | each key]) asIdentitySet.
newNames size < anArrayOfAssociations size ifTrue: [
TraitCompositionException signal: 'Cannot use the same alias name twice'].
anArrayOfAssociations do: [:each |
(newNames includes: each value) ifTrue: [
TraitCompositionException signal: 'Cannot define an alias for an alias']].
aliases := Dictionary new.
anArrayOfAssociations do:[:assoc|
aliases at: assoc value put: assoc key.
].! !
!TraitAlias methodsFor: 'accessing' stamp: 'ar 11/18/2007 17:07'!
aliases
"Collection of associations where key is the
alias and value the original selector."
^aliases! !
!TraitAlias methodsFor: 'accessing' stamp: 'ar 11/18/2007 17:45'!
aliases: aDictionary
aliases := aDictionary! !
!TraitAlias methodsFor: 'composition' stamp: 'ar 5/1/2008 21:14'!
classify: selector under: category fromTrait: aTrait
"broadcasts a reclassification of some selector to all users of a trait"
^users do:[:each|
each classify: selector under: category fromTrait: aTrait.
(aliases includesKey: selector) ifTrue:[
each classify: (aliases at: selector) under: category fromTrait: aTrait.
].
].! !
!TraitAlias methodsFor: 'composition' stamp: 'ar 11/22/2007 06:18'!
copyTraitExpression
"Copy all except the actual traits"
^TraitAlias
with: subject
aliases: (Array streamContents:[:s|
aliases associationsDo:[:a| s nextPut: a value -> a key]])
! !
!TraitAlias methodsFor: 'composition' stamp: 'ar 5/1/2008 21:14'!
includesSelector: selector
"Answers true if the receiver provides the selector"
^(subject includesSelector: selector) or:[aliases includesKey: selector]! !
!TraitAlias methodsFor: 'composition' stamp: 'ar 5/1/2008 21:15'!
selectorsAndMethodsDo: aBlock
"enumerates all selectors and methods in a trait composition"
^subject selectorsAndMethodsDo:[:sel :meth|
aBlock value: sel value: meth.
(aliases includesKey: sel)
ifTrue:[aBlock value: (aliases at: sel ifAbsent:[sel]) value: meth]
].! !
!TraitAlias methodsFor: 'composition' stamp: 'ar 11/22/2007 06:16'!
traitCompositionString
"Answer the trait composition string (used for class definitions)"
^String streamContents:[:s|
s nextPutAll: subject traitCompositionString.
s nextPutAll: ' @ {'.
aliases keys asArray sort do:[:original|
s print: (aliases at: original); nextPutAll: ' -> '; print: original.
] separatedBy:[s nextPutAll:'. '].
s nextPutAll: '}'.
].! !
!TraitAlias methodsFor: 'composition' stamp: 'ar 5/1/2008 21:15'!
updateSelector: aSelector withTraitMethod: compiledMethod from: aTrait
"broadcasts the change of a selector to all users of a trait"
users do:[:each|
each updateSelector: aSelector withTraitMethod: compiledMethod from: aTrait.
(aliases includesKey: aSelector) ifTrue:[
each updateSelector: (aliases at: aSelector ifAbsent:[aSelector])
withTraitMethod: compiledMethod from: aTrait
].
].! !
!TraitAlias methodsFor: 'converting' stamp: 'ar 11/18/2007 18:11'!
asArrayOfAssociations
"Awkward, compatible mapped -> original representation"
^Array streamContents:[:s|
aliases keysAndValuesDo:[:original :mapped|
s nextPut: mapped -> original.
].
].! !
!TraitAlias methodsFor: 'converting' stamp: 'ar 11/18/2007 19:13'!
@ anArrayOfAssociations
^TraitAlias
with: subject
aliases: (anArrayOfAssociations, self asArrayOfAssociations)! !
!TraitAlias methodsFor: 'testing' stamp: 'ar 5/11/2008 02:17'!
isAliasSelector: selector
^(aliases includes: selector) or:[super isAliasSelector: selector]! !
!TraitAlias methodsFor: 'testing' stamp: 'ar 5/11/2008 02:17'!
isLocalAliasSelector: selector
^(aliases includes: selector)! !
!TraitExclusion methodsFor: 'initialize' stamp: 'ar 11/18/2007 17:16'!
initialize
super initialize.
exclusions := Set new.
! !
!TraitExclusion methodsFor: 'accessing' stamp: 'ar 11/18/2007 18:04'!
exclusions
^exclusions! !
!TraitExclusion methodsFor: 'accessing' stamp: 'ar 11/18/2007 18:04'!
exclusions: aCollection
exclusions := Set withAll: aCollection! !
!TraitExclusion methodsFor: 'composition' stamp: 'ar 11/22/2007 06:13'!
classify: selector under: category fromTrait: aTrait
"broadcasts a reclassification of some selector to all users of a trait"
(exclusions includes: selector) ifFalse:[
users do:[:each| each classify: selector under: category fromTrait: aTrait]
].! !
!TraitExclusion methodsFor: 'composition' stamp: 'ar 11/22/2007 06:19'!
copyTraitExpression
"Copy all except the actual traits"
^TraitExclusion
with: subject
exclusions: exclusions asArray! !
!TraitExclusion methodsFor: 'composition' stamp: 'ar 11/27/2007 22:10'!
includesSelector: selector
"Answers true if the receiver provides the selector"
^(subject includesSelector: selector) and:[(exclusions includes: selector) not]! !
!TraitExclusion methodsFor: 'composition' stamp: 'ar 11/22/2007 06:12'!
selectorsAndMethodsDo: aBlock
"enumerates all selectors and methods in a trait composition"
^subject selectorsAndMethodsDo:[:sel :meth|
(exclusions includes: sel) ifFalse:[aBlock value: sel value: meth].
].! !
!TraitExclusion methodsFor: 'composition' stamp: 'ar 11/22/2007 06:17'!
traitCompositionString
"Answer the trait composition string (used for class definitions)"
^String streamContents:[:s|
s nextPutAll: subject traitCompositionString.
s nextPutAll: ' - {'.
exclusions asArray sort do:[:exc| s store: exc] separatedBy:[s nextPutAll: '. '].
s nextPutAll: '}'.
].! !
!TraitExclusion methodsFor: 'composition' stamp: 'ar 11/22/2007 06:11'!
updateSelector: aSelector withTraitMethod: compiledMethod from: aTrait
"broadcasts the change of a selector to all users of a trait"
(exclusions includes: aSelector) ifFalse:[
users do:[:each| each updateSelector: aSelector withTraitMethod: compiledMethod from: aTrait]
].! !
!TraitExclusion methodsFor: 'converting' stamp: 'ar 11/18/2007 18:09'!
- anArrayOfSelectors
^TraitExclusion
with: subject
exclusions: (anArrayOfSelectors, exclusions asArray)! !
!TraitAlias class methodsFor: 'instance creation' stamp: 'ar 5/11/2008 02:27'!
assertValidAliasDefinition: anArrayOfAssociations
"Throw an exceptions if the alias definition is not valid.
It is expected to be a collection of associations and
the number of arguments of the alias selector has to
be the same as the original selector."
((anArrayOfAssociations isKindOf: Collection) and: [
anArrayOfAssociations allSatisfy: [:each |
each isKindOf: Association]]) ifFalse: [
self error: 'Invalid alias definition: Not a collection of associations.'].
(anArrayOfAssociations allSatisfy: [:association |
(association key numArgs = association value numArgs and: [
(association key numArgs = -1) not])]) ifFalse: [
TraitCompositionException signal: 'Invalid alias definition: Alias and original selector have to have the same number of arguments.']! !
!TraitAlias class methodsFor: 'instance creation' stamp: 'ar 11/18/2007 17:45'!
with: aTraitComposition aliases: anArrayOfAssociations
self assertValidAliasDefinition: anArrayOfAssociations.
^self new
subject: aTraitComposition;
initializeFrom: anArrayOfAssociations;
yourself! !
!TraitExclusion class methodsFor: 'instance creation' stamp: 'ar 11/18/2007 18:04'!
with: aTraitComposition exclusions: anArrayOfSelectors
^self new
subject: aTraitComposition;
exclusions: anArrayOfSelectors;
yourself
! !
!TraitExclusion class reorganize!
('instance creation' with:exclusions:)
!
!TraitAlias class reorganize!
('instance creation' assertValidAliasDefinition: with:aliases:)
!
!TraitTransformation class reorganize!
('as yet unclassified')
!
!TraitExclusion reorganize!
('initialize' initialize)
('accessing' exclusions exclusions:)
('composition' classify:under:fromTrait: copyTraitExpression includesSelector: selectorsAndMethodsDo: traitCompositionString updateSelector:withTraitMethod:from:)
('converting' -)
!
!TraitAlias reorganize!
('initialize-release' initialize initializeFrom:)
('accessing' aliases aliases:)
('composition' classify:under:fromTrait: copyTraitExpression includesSelector: selectorsAndMethodsDo: traitCompositionString updateSelector:withTraitMethod:from:)
('converting' asArrayOfAssociations @)
('testing' isAliasSelector: isLocalAliasSelector:)
!
!TraitTransformation reorganize!
('initialize' initialize)
('accessing' addUser: allTraits removeUser: subject: theTrait traitsDo: traitUsers)
('testing' isAliasSelector: isLocalAliasSelector: isTraitTransformation usesTrait:)
('composition' classify:under:fromTrait: copyTraitExpression selectorsAndMethodsDo: traitCompositionString updateSelector:withTraitMethod:from:)
('printing' asString printOn:)
('converting' asTraitTransform + - @)
!
!Trait class reorganize!
('instance creation' named:uses:category: named:uses:category:env:)
('accessing')
!
!Metatrait class reorganize!
('instance creation' new)
!
!TraitDescription class reorganize!
('as yet unclassified')
!
!Trait reorganize!
('initialize' definitionST80 isValidTraitName: obsolete removeFromSystem removeFromSystem: rename: setName:andRegisterInCategory:environment:)
('accessing' category category: classTrait environment environment: name name:)
('testing' hasClassTrait isBaseTrait isObsolete)
!
!Metatrait reorganize!
('initialize' updateTraitsFrom: uses:)
('accessing' baseTrait definitionST80 instanceSide name new)
('testing' isClassTrait isMeta)
!
!TraitDescription reorganize!
('accessing' addUser: allClassVarNames classPool removeUser: sharedPools theTrait traitUsers users users:)
('copying' copy copyTraitExpression)
('testing' isBaseTrait isClassTrait isTrait isTraitTransformation usesTrait:)
('operations' addAndClassifySelector:withMethod:inProtocol:notifying: addSelectorSilently:withMethod: basicRemoveSelector: classify:under:fromTrait: recompile:from: traitsDo: + - @)
!
!TraitCompositionException class reorganize!
('as yet unclassified')
!
!TraitCompositionException reorganize!
('as yet unclassified')
!
TraitComposition initialize!
!TraitComposition class reorganize!
('class initialization' initialize)
('accessing' for: for:put:)
!
!TraitComposition reorganize!
('accessing' addUser: allTraits removeUser: traits traitsDo: traitUsers)
('testing' isTraitTransformation usesTrait:)
('converting' + - @)
('composition' classify:under:fromTrait: copyTraitExpression isAliasSelector: isLocalAliasSelector: selectorsAndMethodsDo: traitCompositionString updateSelector:withTraitMethod:from:)
!
« Return to Thread: [squeak-dev] Unload Traits script
| Free Forum Powered by Nabble | Forum Help |