Smalltalk › Squeak › Squeak - Dev

Squeak 4.6: Traits-ul.305.mcz

_‹ Previous Topic Next Topic _›

Classic

List

Threaded

1 message

commits-2

Squeak 4.6: Traits-ul.305.mcz

Chris Muller uploaded a new version of Traits to project Squeak 4.6:
http://source.squeak.org/squeak46/Traits-ul.305.mcz

==================== Summary ====================

Name: Traits-ul.305
Author: ul
Time: 26 April 2015, 5:11:03.366 pm
UUID: 34df02d0-c86a-4038-a909-e1d332374322
Ancestors: Traits-mt.304

- cache the source files during recompilation

==================== Snapshot ====================

SystemOrganization addCategory: #'Traits-Composition'!
SystemOrganization addCategory: #'Traits-Kernel'!

----- Method: CompiledMethod class>>conflictMarker (in category '*Traits-constants') -----
conflictMarker
^ #traitConflict!

----- Method: CompiledMethod class>>explicitRequirementMarker (in category '*Traits-constants') -----
explicitRequirementMarker
^ #explicitRequirement!

----- Method: CompiledMethod class>>implicitRequirementMarker (in category '*Traits-constants') -----
implicitRequirementMarker
^ #requirement!

----- Method: CompiledMethod>>isConflict (in category '*Traits-testing') -----
isConflict
^ self markerOrNil == self class conflictMarker!

----- Method: CompiledMethod>>isExplicitlyRequired (in category '*Traits-testing') -----
isExplicitlyRequired
^ self isExplicitlyRequired: self markerOrNil!

----- Method: CompiledMethod>>isExplicitlyRequired: (in category '*Traits-testing') -----
isExplicitlyRequired: marker
^ marker == self class explicitRequirementMarker!

----- Method: CompiledMethod>>isImplicitlyRequired: (in category '*Traits-testing') -----
isImplicitlyRequired: marker
^ marker == self class implicitRequirementMarker!

----- Method: CompiledMethod>>isProvided (in category '*Traits-testing') -----
isProvided
^ self isProvided: self markerOrNil!

----- Method: CompiledMethod>>isProvided: (in category '*Traits-testing') -----
isProvided: marker
marker ifNil: [^ true].
^ (self isRequired: marker) not and: [(self isDisabled: marker) not]!

----- Method: CompiledMethod>>isRequired (in category '*Traits-testing') -----
isRequired
^ self isRequired: self markerOrNil!

----- Method: CompiledMethod>>isRequired: (in category '*Traits-testing') -----
isRequired: marker
marker ifNil: [^ false].
(self isImplicitlyRequired: marker) ifTrue: [^ true].
(self isExplicitlyRequired: marker) ifTrue: [^ true].
(self isSubclassResponsibility: marker) ifTrue: [^ true].
^ false!

----- Method: CompiledMethod>>isTraitMethod (in category '*Traits-testing') -----
isTraitMethod

^ self originalTraitMethod notNil!

----- Method: CompiledMethod>>originalTraitMethod (in category '*Traits-NanoKernel') -----
originalTraitMethod
"Remember the original trait method for the receiver."
^self properties originalTraitMethod!

----- Method: CompiledMethod>>originalTraitMethod: (in category '*Traits-NanoKernel') -----
originalTraitMethod: aCompiledMethod
"Remember the original trait method for the receiver."
| methodState |
methodState := TraitMethodState newFrom: self properties.
methodState originalTraitMethod: aCompiledMethod.
self penultimateLiteral: methodState.!

----- Method: CompiledMethod>>originalTraitOrClass (in category '*Traits-NanoKernel') -----
originalTraitOrClass
"The original trait for this method"
^self properties originalTraitOrClass!

----- Method: CompiledMethod>>sameTraitCodeAs: (in category '*Traits-NanoKernel') -----
sameTraitCodeAs: method
"Answer whether the receiver implements the same code as the
argument, method. Does not look at properties/pragmas since they
do not affect the resulting code."
| numLits |
(method isKindOf: CompiledMethod) ifFalse: [^false].
self methodHome == method methodHome ifFalse:[^false].
(self properties analogousCodeTo: method properties) ifFalse:[^false].
self size = method size ifFalse: [^false].
self header = method header ifFalse: [^false].
self initialPC to: self endPC do:[:i | (self at: i) = (method at: i) ifFalse: [^false]].
(numLits := self numLiterals) ~= method numLiterals ifTrue: [^false].
1 to: numLits-2 do:[:i| | lit1 lit2 |
lit1 := self literalAt: i.
lit2 := method literalAt: i.
(lit1 == lit2 or: [lit1 literalEqual: lit2]) ifFalse: [
(i = 1 and: [#(117 120) includes: self primitive]) ifTrue: [
lit1 isArray ifTrue:[
(lit2 isArray and: [lit1 allButLast = lit2 allButLast]) ifFalse:[^false]
] ifFalse: "ExternalLibraryFunction"
[(lit1 analogousCodeTo: lit2) ifFalse:[^false]].
] ifFalse:[
"any other discrepancy is a failure"^ false]]].
^true!

----- Method: AdditionalMethodState>>originalTraitMethod (in category '*Traits-NanoKernel') -----
originalTraitMethod
"The original method from the trait.
Only available in TraitMethodState."
^nil!

----- Method: AdditionalMethodState>>originalTraitOrClass (in category '*Traits-NanoKernel') -----
originalTraitOrClass
"The original trait for this method"
^method methodClass!

AdditionalMethodState variableSubclass: #TraitMethodState
instanceVariableNames: 'originalTraitMethod'
classVariableNames: ''
poolDictionaries: ''
category: 'Traits-Kernel'!

!TraitMethodState commentStamp: 'ar 12/29/2009 18:13' prior: 0!
Additional method state for trait provided methods.!

----- Method: TraitMethodState>>methodHome (in category 'accessing') -----
methodHome
"The behavior (trait/class) this method was originally defined in.
Derived from the originalTraitMethod if any."
^originalTraitMethod ifNil:[super methodHome] ifNotNil:[:m| m methodHome]!

----- Method: TraitMethodState>>originalTraitMethod (in category 'accessing') -----
originalTraitMethod
"The original method from the trait"
^originalTraitMethod!

----- Method: TraitMethodState>>originalTraitMethod: (in category 'accessing') -----
originalTraitMethod: aCompiledMethod
"The original method from the trait"
originalTraitMethod := aCompiledMethod!

----- Method: TraitMethodState>>originalTraitOrClass (in category 'accessing') -----
originalTraitOrClass
"The original trait for this method"
^originalTraitMethod originalTraitOrClass!

----- Method: MethodReference>>isTraitMethod (in category '*Traits-testing') -----
isTraitMethod

^ self compiledMethod isTraitMethod!

----- Method: ClassDescription class>>allTraitsDo: (in category '*Traits') -----
allTraitsDo: aBlock
"Evaluate aBlock with all the instance and class traits present in the system"
TraitImpl ifNotNil:[TraitImpl allTraitsDo: aBlock].!

----- Method: ClassDescription class>>newTraitComposition (in category '*Traits') -----
newTraitComposition
"Answer a new trait composition. If no current trait implementation
is installed, return an empty array"
^TraitImpl ifNil:[#()] ifNotNil:[TraitImpl newTraitComposition].!

----- Method: ClassDescription class>>newTraitNamed:uses:category: (in category '*Traits') -----
newTraitNamed: aSymbol uses: aTraitCompositionOrCollection category: aString
"Creates a new trait. If no current trait implementation
is installed, raise an error."
^TraitImpl
ifNil:[self error: 'Traits are not installed']
ifNotNil:[TraitImpl newTraitNamed: aSymbol uses: aTraitCompositionOrCollection category: aString]!

----- Method: ClassDescription class>>newTraitTemplateIn: (in category '*Traits') -----
newTraitTemplateIn: categoryString
^TraitImpl ifNil:[''] ifNotNil:[TraitImpl newTemplateIn: categoryString].!

----- Method: ClassDescription class>>traitImpl (in category '*Traits') -----
traitImpl
"Answer the default implementor of traits"
^TraitImpl!

----- Method: ClassDescription class>>traitImpl: (in category '*Traits') -----
traitImpl: aTraitClass
"Make the given trait class the default implementor of traits"
TraitImpl := aTraitClass.!

----- Method: ClassDescription>>allTraits (in category '*Traits-NanoKernel') -----
allTraits
"Answer all the traits that are used by myself without their transformations"
^self traitComposition isEmpty
ifTrue:[#()]
ifFalse:[self traitComposition allTraits].!

----- Method: ClassDescription>>assembleTraitMethodsFrom: (in category '*Traits-NanoKernel') -----
assembleTraitMethodsFrom: aTraitComposition
"Assemble the resulting methods for installing the given trait composition.
Returns a Dictionary instead of a MethodDictionary for speed (MDs grow by #become:)"
| methods |
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 |
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)]]]].
^methods!

----- Method: ClassDescription>>basicRemoveSelector: (in category '*Traits-NanoKernel') -----
basicRemoveSelector: aSelector
"Remove the message whose selector is given from the method
dictionary of the receiver, if it is there. Update the trait composition."
| oldMethod |
oldMethod := super basicRemoveSelector: aSelector.
oldMethod ifNotNil:[self updateTraits].
^oldMethod!

----- Method: ClassDescription>>classify:under:from:trait: (in category '*Traits-NanoKernel') -----
classify: selector under: heading from: category trait: aTrait
"Update the organization for a trait. the dumb, unoptimized version"
self updateTraits.!

----- Method: ClassDescription>>hasTraitComposition (in category '*Traits-NanoKernel') -----
hasTraitComposition
^self traitComposition notEmpty!

----- Method: ClassDescription>>includesLocalSelector: (in category '*Traits-NanoKernel') -----
includesLocalSelector: selector
^(self compiledMethodAt: selector ifAbsent:[^false]) methodHome == self!

----- Method: ClassDescription>>includesTrait: (in category '*Traits-NanoKernel') -----
includesTrait: aTrait
^self traitComposition anySatisfy:[:each| each includesTrait: aTrait]!

----- Method: ClassDescription>>installTraitMethodDict: (in category '*Traits-NanoKernel') -----
installTraitMethodDict: methods
"After having assembled the trait composition, install its methods."
| oldCategories removals |
"Apply the changes. We first add the new or changed methods."
oldCategories := Set new.
methods keysAndValuesDo:[:sel :newMethod| | oldMethod |
oldMethod := self compiledMethodAt: sel ifAbsent:[nil].
oldMethod == newMethod ifFalse:[
self traitAddSelector: sel withMethod: newMethod.
(self organization categoryOfElement: sel) ifNotNil:[:cat| oldCategories add: cat].
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 traitRemoveSelector: sel].

"Clean out empty categories"
oldCategories do:[:cat|
(self organization isEmptyCategoryNamed: cat)
ifTrue:[self organization removeCategory: cat]].

!

----- Method: ClassDescription>>installTraitsFrom: (in category '*Traits-NanoKernel') -----
installTraitsFrom: aTraitComposition
"Install the traits from the given composition. This method implements
the core composition method - all others are just optimizations for
particular cases. Consequently, the optimized versions can always fall
back to this method when things get too hairy."
| allTraits methods |

(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'].

self traitComposition: aTraitComposition.
methods := self assembleTraitMethodsFrom: aTraitComposition.
self installTraitMethodDict: methods.
self isMeta ifFalse:[self classSide updateTraitsFrom: aTraitComposition].
!

----- Method: ClassDescription>>isAliasSelector: (in category '*Traits-NanoKernel') -----
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]]!

----- Method: ClassDescription>>isLocalAliasSelector: (in category '*Traits-NanoKernel') -----
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]]!

----- Method: ClassDescription>>isLocalMethod: (in category '*Traits-NanoKernel') -----
isLocalMethod: aCompiledMethod
"Answer true if the method is a local method, e.g., defined in the receiver instead of a trait."
^aCompiledMethod methodHome == self!

----- Method: ClassDescription>>localSelectors (in category '*Traits-NanoKernel') -----
localSelectors
^self selectors select:[:sel| self includesLocalSelector: sel]!

----- Method: ClassDescription>>recompile:from: (in category '*Traits-NanoKernel') -----
recompile: selector from: oldClass
"Preserve the originalTraitMethod (if any) after recompiling a selector"
| oldMethod |
oldMethod := oldClass compiledMethodAt: selector.
super recompile: selector from: oldClass.
oldMethod originalTraitMethod ifNotNil:[:traitMethod|
(self compiledMethodAt: selector) originalTraitMethod: traitMethod.
].
!

----- Method: ClassDescription>>replaceSelector:withAlias:in: (in category '*Traits-NanoKernel') -----
replaceSelector: originalSelector withAlias: aliasSelector in: source
"replaces originalSelector with aliasSelector in in given source code"
| oldKeywords newKeywords args selectorWithArgs s |
oldKeywords := originalSelector keywords.
newKeywords := aliasSelector keywords.
oldKeywords size = newKeywords size ifFalse:[self error: 'Keyword mismatch'].
args := self newParser parseParameterNames: source asString.
selectorWithArgs := String streamContents: [:stream |
newKeywords keysAndValuesDo: [:index :keyword |
stream nextPutAll: keyword.
stream space.
args size >= index ifTrue: [
stream nextPutAll: (args at: index); space]]].
s := source asString readStream.
oldKeywords do: [ :each | s match: each ].
args isEmpty ifFalse: [ s match: args last ].
^selectorWithArgs withBlanksTrimmed asText , s upToEnd
!

----- Method: ClassDescription>>resolveTraitsConflict:from:to: (in category '*Traits-NanoKernel') -----
resolveTraitsConflict: aSelector from: oldMethod to: newMethod
"Resolve a traits conflict. Rules:
- If one method is required the other one wins
- Otherwise we compile a traits conflict
"
| marker selector |
oldMethod methodHome == newMethod methodHome ifTrue:[^oldMethod].
marker := oldMethod markerOrNil.
(#(requirement explicitRequirement subclassResponsibility shouldNotImplement) includes: marker)
ifTrue:[^newMethod].
marker := newMethod markerOrNil.
(#(requirement explicitRequirement subclassResponsibility shouldNotImplement) includes: marker)
ifTrue:[^oldMethod].
"Create a conflict marker"
selector := #(conflict conflict: conflict:with: conflict:with:with: conflict:with:with:with:
conflict:with:with:with:with: conflict:with:with:with:with:with: conflict:with:with:with:with:with:with:
conflict:with:with:with:with:with:with:with:) at: oldMethod numArgs+1.
^TraitDescription class compiledMethodAt: selector.!

----- Method: ClassDescription>>setTraitComposition: (in category '*Traits-NanoKernel') -----
setTraitComposition: aTraitComposition
"OBSOLETE. Use Class uses: aTraitComposition instead."
^self uses: aTraitComposition
!

----- Method: ClassDescription>>setTraitCompositionFrom: (in category '*Traits-NanoKernel') -----
setTraitCompositionFrom: aTraitComposition
"OBSOLETE. Use Class uses: aTraitComposition instead."
^self uses: aTraitComposition
!

----- Method: ClassDescription>>traitAddSelector:withMethod: (in category '*Traits-NanoKernel') -----
traitAddSelector: selector withMethod: traitMethod
"Add a method inherited from a trait.
Recompiles to avoid sharing and implement aliasing."
| oldMethod source methodNode newMethod originalSelector |
oldMethod := self compiledMethodAt: selector ifAbsent:[nil].
oldMethod ifNotNil:[
"The following is an important optimization as it prevents exponential
growth in recompilation. If T1 is used by T2 and T2 by T3 then (without
this optimization) any change in T1 would cause all methods in T2 to be
recompiled and each recompilation of a method in T2 would cause T3
to be fully recompiled. The test eliminates all such situations."
(oldMethod sameTraitCodeAs: traitMethod) ifTrue:[^oldMethod].
].
originalSelector := traitMethod selector.
source := traitMethod methodClass sourceCodeAt: originalSelector.
originalSelector == selector ifFalse:[
"Replace source selectors for aliases"
source := self replaceSelector: originalSelector withAlias: selector in: source.
].
methodNode := self newCompiler
compile: source in: self notifying: nil ifFail:[^nil].
newMethod := methodNode generate: (self defaultMethodTrailerIfLogSource: true).
newMethod putSource: source fromParseNode: methodNode inFile: 2
withPreamble: [:f | f cr; nextPut: $!!; nextChunkPut: 'Trait method'; cr].
newMethod originalTraitMethod: traitMethod.
^super addSelectorSilently: selector withMethod: newMethod.!

----- Method: ClassDescription>>traitComposition (in category '*Traits-NanoKernel') -----
traitComposition
"Answer my trait composition"
^self organization traitComposition!

----- Method: ClassDescription>>traitComposition: (in category '*Traits-NanoKernel') -----
traitComposition: aTraitComposition
"Install my trait composition"
self traitComposition do:[:tc| tc removeTraitUser: self].
aTraitComposition isEmptyOrNil ifTrue:[
self organization isTraitOrganizer
ifTrue:[self organization: (ClassOrganizer newFrom: self organization)].
] ifFalse:[
self organization isTraitOrganizer
ifFalse:[self organization: (TraitOrganizer newFrom: self organization)].
self organization traitComposition: aTraitComposition.
aTraitComposition do:[:tc| tc addTraitUser: self].
].
!

----- Method: ClassDescription>>traitCompositionString (in category '*Traits-NanoKernel') -----
traitCompositionString
"Answer the trait composition string for the receiver"
^self traitComposition isEmpty
ifTrue:['{}']
ifFalse:[self traitComposition asString].!

----- Method: ClassDescription>>traitRemoveSelector: (in category '*Traits-NanoKernel') -----
traitRemoveSelector: selector
"Remove the message whose selector is given from the method
dictionary of the receiver, if it is there. Answer nil otherwise."
| priorMethod priorProtocol |
priorMethod := self compiledMethodAt: selector ifAbsent: [^ nil].
priorProtocol := self whichCategoryIncludesSelector: selector.
SystemChangeNotifier uniqueInstance doSilently: [
self organization removeElement: selector].
super basicRemoveSelector: selector.
SystemChangeNotifier uniqueInstance
methodRemoved: priorMethod selector: selector inProtocol: priorProtocol class: self.
(self organization isEmptyCategoryNamed: priorProtocol)
ifTrue:[self organization removeCategory: priorProtocol].
!

----- Method: ClassDescription>>traits (in category '*Traits-NanoKernel') -----
traits
"Answer an array of my traits"
^self traitComposition asArray collect:[:composed| composed trait]!

----- Method: ClassDescription>>updateTraits (in category '*Traits-NanoKernel') -----
updateTraits
"Recompute my local traits composition"
self installTraitsFrom: self traitComposition.
!

----- Method: ClassDescription>>updateTraitsFrom: (in category '*Traits-NanoKernel') -----
updateTraitsFrom: instanceTraits
"ClassTrait/Metaclass only. Update me from the given instance traits"
| map newTraits |
self isMeta ifFalse:[self error: 'This is a metaclass operation'].
map := Dictionary new.
self traitComposition do:[:composed| map at: composed trait put: composed].
newTraits := (instanceTraits collect:[:composed| | trait |
trait := composed trait classTrait.
map at: trait ifAbsent:[trait]]
), (self traitComposition select:[:comp| comp trait isBaseTrait]).

self installTraitsFrom: newTraits!

----- Method: ClassDescription>>users (in category '*Traits-NanoKernel') -----
users
^#()!

----- Method: ClassDescription>>uses: (in category '*Traits-NanoKernel') -----
uses: aTraitComposition

self installTraitsFrom: aTraitComposition asTraitComposition.
!

ClassDescription subclass: #TraitBehavior
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Traits-Kernel'!

!TraitBehavior commentStamp: 'ar 12/29/2009 18:15' prior: 0!
Stub class for backward compatibility. Allows past extension methods in TraitBehavior to continue to work.!

TraitBehavior subclass: #TraitDescription
instanceVariableNames: 'users'
classVariableNames: ''
poolDictionaries: ''
category: 'Traits-Kernel'!

!TraitDescription commentStamp: 'ar 12/29/2009 18:15' prior: 0!
TraitDescription combines common behavior for both (instance) traits and (meta) class traits.!

TraitDescription subclass: #ClassTrait
instanceVariableNames: 'baseTrait'
classVariableNames: ''
poolDictionaries: ''
category: 'Traits-Kernel'!

!ClassTrait commentStamp: 'ar 12/29/2009 18:16' prior: 0!
The class of some trait. Just like the Class - Metaclass relationship.!

----- Method: ClassTrait class>>for: (in category 'instance creation') -----
for: baseTrait
^self new baseTrait: baseTrait!

----- Method: ClassTrait>>asMCDefinition (in category 'monticello') -----
asMCDefinition
^Smalltalk at: #MCClassTraitDefinition ifPresent:[:aClass|
aClass
baseTraitName: self baseTrait name
classTraitComposition: self traitCompositionString
].!

----- Method: ClassTrait>>baseTrait (in category 'accessing') -----
baseTrait
^baseTrait!

----- Method: ClassTrait>>baseTrait: (in category 'accessing') -----
baseTrait: aTrait
baseTrait ifNotNil:[self error: 'Already initialized'].
baseTrait := aTrait.!

----- Method: ClassTrait>>bindingOf: (in category 'compiling') -----
bindingOf: varName
"Answer the binding of some variable resolved in the scope of the receiver"
^baseTrait bindingOf: varName!

----- Method: ClassTrait>>category (in category 'accessing') -----
category
"Answer the category used for classifying this ClassTrait.
The category is shared between a Trait and its associated ClassTrait."

^baseTrait category!

----- Method: ClassTrait>>definition (in category 'accessing') -----
definition
^String streamContents: [:stream |
stream nextPutAll: self name.
stream cr; tab; nextPutAll: 'uses: ';
nextPutAll: self traitComposition asString.
].!

----- Method: ClassTrait>>instanceSide (in category 'accessing') -----
instanceSide
^self baseTrait!

----- Method: ClassTrait>>isClassTrait (in category 'testing') -----
isClassTrait
^true!

----- Method: ClassTrait>>isMeta (in category 'testing') -----
isMeta
^true!

----- Method: ClassTrait>>isObsolete (in category 'testing') -----
isObsolete
^baseTrait == nil or:[baseTrait isObsolete]!

----- Method: ClassTrait>>name (in category 'accessing') -----
name
^baseTrait name, ' classTrait'!

----- Method: ClassTrait>>soleInstance (in category 'accessing') -----
soleInstance
^baseTrait!

----- Method: ClassTrait>>theMetaClass (in category 'accessing') -----
theMetaClass
^self!

----- Method: ClassTrait>>theNonMetaClass (in category 'accessing') -----
theNonMetaClass
"Sent to a class or metaclass, always return the class"
^baseTrait!

----- Method: ClassTrait>>uses: (in category 'initialize') -----
uses: aTraitComposition
| newTraits copyOfOldTrait |
copyOfOldTrait := self shallowCopy.
newTraits := aTraitComposition asTraitComposition.
newTraits traitsDo:[:t|
(t isBaseTrait and:[t classSide hasMethods])
ifTrue:[self error: 'Cannot add: ', t].
(t isClassTrait and:[(baseTrait includesTrait: t baseTrait) not])
ifTrue:[self error: 'Cannot add: ', t].
].
self installTraitsFrom: newTraits.
SystemChangeNotifier uniqueInstance
traitDefinitionChangedFrom: copyOfOldTrait to: self.!

TraitDescription subclass: #Trait
instanceVariableNames: 'name environment classTrait category'
classVariableNames: ''
poolDictionaries: ''
category: 'Traits-Kernel'!

!Trait commentStamp: 'ar 12/29/2009 18:16' prior: 0!
Defines a trait in the system. Like Class, I concretize my superclass by providing instance variables for the name and the environment.!

----- Method: Trait class>>allTraitsDo: (in category 'public') -----
allTraitsDo: aBlock
"Evaluate aBlock with all the instance and class traits present in the system"

Smalltalk allTraitsDo: [ :aTrait |
aBlock
value: aTrait instanceSide;
value: aTrait classSide ]!

----- Method: Trait class>>convertClassToTrait: (in category 'load-unload') -----
convertClassToTrait: aClass
"Convert the given class to a trait"
| aTrait |
"Move the class out of the way"
aClass environment removeKey: aClass name.

"Create the trait in its place"
aTrait := Trait named: aClass name
uses: {}
category: aClass category.

aClass organization commentRemoteStr ifNotNil:[
aTrait classComment: aClass organization classComment
stamp: aClass organization commentStamp].

aClass selectorsAndMethodsDo:[:sel :meth|
aTrait compile: (aClass sourceCodeAt: sel)
classified: (aClass organization categoryOfElement: sel)
withStamp: (aClass compiledMethodAt: sel) timeStamp
notifying: nil].

aClass classSide selectorsAndMethodsDo:[:sel :meth|
aTrait classSide compile: (aClass classSide sourceCodeAt: sel)
classified: (aClass classSide organization categoryOfElement: sel)
withStamp: (aClass classSide compiledMethodAt: sel) timeStamp
notifying: nil].

aClass obsolete.
^aTrait
!

----- Method: Trait class>>convertTraitToClass: (in category 'load-unload') -----
convertTraitToClass: aTrait
"Convert the given trait to a class"
| aClass |
"Move the trait out of the way"
aTrait environment removeKey: aTrait name.
"Create the class in its place"
aClass := Object subclass: aTrait name
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: aTrait category.

aTrait organization commentRemoteStr ifNotNil:[
aClass classComment: aTrait organization classComment
stamp: aTrait organization commentStamp].

aTrait selectorsAndMethodsDo:[:sel :meth|
aClass compile: (aTrait sourceCodeAt: sel)
classified: (aTrait organization categoryOfElement: sel)
withStamp: (aTrait compiledMethodAt: sel) timeStamp
notifying: nil].

aTrait classSide selectorsAndMethodsDo:[:sel :meth|
aClass classSide compile: (aTrait classSide sourceCodeAt: sel)
classified: (aTrait classSide organization categoryOfElement: sel)
withStamp: (aTrait classSide compiledMethodAt: sel) timeStamp
notifying: nil].

aTrait obsolete.
^aClass
!

----- Method: Trait class>>flattenTraitMethodsInClass: (in category 'load-unload') -----
flattenTraitMethodsInClass: aClass
"Flatten all the trait methods in the given class"

(aClass isTrait or:[aClass hasTraitComposition]) ifFalse:[^self].
self storeTraitInfoInClass: aClass.
aClass selectorsAndMethodsDo:[:sel :meth| | oldClass |
(aClass includesLocalSelector: sel) ifFalse:[
oldClass := meth methodHome.
aClass compile: (aClass sourceCodeAt: sel)
classified: (aClass organization categoryOfElement: sel)
withStamp: (oldClass compiledMethodAt: sel ifAbsent:[meth]) timeStamp
notifying: nil]].
aClass traitComposition: #().!

----- Method: Trait class>>initialize (in category 'load-unload') -----
initialize
"Install after loading"
self install.!

----- Method: Trait class>>install (in category 'load-unload') -----
install
"Make me the default Trait implementation"
ClassDescription traitImpl: self.
"And restore any previously flattened traits"
self restoreAllTraits.
!

----- Method: Trait class>>named:uses:category: (in category 'public') -----
named: aSymbol uses: aTraitCompositionOrCollection category: aString
"Dispatch through ClassDescription for alternative implementations"
^ClassDescription newTraitNamed: aSymbol uses: aTraitCompositionOrCollection category: aString!

----- Method: Trait class>>named:uses:category:env: (in category 'instance creation') -----
named: aSymbol uses: aTraitComposition category: aString env: anEnvironment
| trait oldTrait systemCategory |
systemCategory := aString asSymbol.
trait := anEnvironment at: aSymbol ifAbsent: [nil].
(trait == nil or:[trait isMemberOf: Trait]) ifFalse: [
^self error: trait name , ' is not a Trait'].

oldTrait := trait shallowCopy.
trait ifNil:[trait := Trait new].

trait
setName: aSymbol
andRegisterInCategory: systemCategory
environment: anEnvironment.

trait uses: aTraitComposition.

"... notify interested clients ..."
oldTrait ifNil:[
SystemChangeNotifier uniqueInstance classAdded: trait inCategory: systemCategory.
] ifNotNil:[
SystemChangeNotifier uniqueInstance traitDefinitionChangedFrom: oldTrait to: trait.
systemCategory = oldTrait category ifFalse:[
SystemChangeNotifier uniqueInstance class: trait
recategorizedFrom: oldTrait category to: systemCategory].
].
^ trait!

----- Method: Trait class>>newTemplateIn: (in category 'public') -----
newTemplateIn: categoryString
^String streamContents: [:stream |
stream
nextPutAll: 'Trait named: #NameOfTrait';
cr; tab;
nextPutAll: 'uses: {}';
cr; tab;
nextPutAll: 'category: ';
nextPut: $';
nextPutAll: categoryString;
nextPut: $' ]!

----- Method: Trait class>>newTraitComposition (in category 'public') -----
newTraitComposition
"Creates a new TraitComposition"
^TraitComposition new!

----- Method: Trait class>>newTraitNamed:uses:category: (in category 'public') -----
newTraitNamed: aSymbol uses: aTraitCompositionOrCollection category: aString
"Creates a new trait."
| env |
env := self environment.
^self
named: aSymbol
uses: aTraitCompositionOrCollection
category: aString
env: env!

----- Method: Trait class>>removeAllTraits (in category 'load-unload') -----
removeAllTraits "Trait removeAllTraits"
"Removes all traits currently in use.
Preserves enough information so that traits can be recovered."
| converted remain |
converted := Set new.
Smalltalk allClasses do:[:aClass|
self flattenTraitMethodsInClass: aClass classSide.
self flattenTraitMethodsInClass: aClass.
converted add: aClass.
] displayingProgress: 'Flattening classes'.

remain := Smalltalk allTraits asSet.
(1 to: remain size) do:[:i| | trait |
trait := remain
detect:[:any| any users allSatisfy:[:aClass| converted includes: aClass]]
ifNone:[self error: 'Cyclic traits detected'].
remain remove: trait.
self flattenTraitMethodsInClass: trait classSide.
self flattenTraitMethodsInClass: trait.
converted add: trait.
] displayingProgress: 'Flattening traits'.

"Convert all traits to classes"
Smalltalk allTraits
do:[:trait| self convertTraitToClass: trait]
displayingProgress:[:trait| 'Converting ', trait name].
!

----- Method: Trait class>>restoreAllTraits (in category 'load-unload') -----
restoreAllTraits "Trait restoreAllTraits"
"Restores traits that had been previously removed.
This is the inverse operation to removeAllTraits."
| classes |
classes := Smalltalk allClasses select:[:aClass| aClass includesSelector: #traitInfo].
classes do:[:aClass| | method |
method := aClass compiledMethodAt: #traitInfo.
(method pragmaAt: #traitDefinition:) ifNotNil:[:pragma|
pragma arguments first
ifTrue:[self convertClassToTrait: aClass]].
] displayingProgress:[:aClass| 'Creating trait ', aClass name].
classes := Smalltalk allClassesAndTraits select:[:aClass|
(aClass includesSelector: #traitInfo)
or:[aClass classSide includesSelector: #traitInfo]].
classes do:[:aClass|
self restoreCompositionOf: aClass.
self restoreCompositionOf: aClass classSide.
] displayingProgress:[:aClass| 'Updating ', aClass name].
!

----- Method: Trait class>>restoreCompositionOf: (in category 'load-unload') -----
restoreCompositionOf: aClass
"Restore the trait composition for the given class"
| method requires composition |
method := aClass compiledMethodAt: #traitInfo ifAbsent:[^self].
aClass removeSelector: #traitInfo.
requires := (method pragmaAt: #traitRequires:)
ifNil:[#()]
ifNotNil:[:pragma| pragma arguments first].
(requires allSatisfy:[:tn| (Smalltalk at: tn ifAbsent:[nil]) isKindOf: Trait])
ifFalse:[^self inform: 'Cannot restore composition of ', aClass name].
composition := (method pragmaAt: #traitComposition:)
ifNil:[^self]
ifNotNil:[:pragma| Compiler evaluate: pragma arguments first].
aClass uses: composition.
aClass traitComposition selectorsAndMethodsDo:[:sel :meth|
| oldMethod newMethod |
newMethod := meth methodHome compiledMethodAt: sel.
oldMethod := aClass compiledMethodAt: sel ifAbsent:[newMethod].
oldMethod timeStamp = newMethod timeStamp
ifTrue:[aClass removeSelector: sel]].!

----- Method: Trait class>>storeTraitInfoInClass: (in category 'load-unload') -----
storeTraitInfoInClass: aClass
"Store trait information in the given class"
| code |
code := WriteStream on: (String new: 100).
code nextPutAll: 'traitInfo
"This method contains information to restore the trait structure
for the receiver when traits are loaded or unloaded"'.
aClass isTrait ifTrue:[
code crtab; nextPutAll: '"This class was originally a trait"'.
code crtab; nextPutAll: '<traitDefinition: true>'.
].
aClass hasTraitComposition ifTrue:[
code crtab; nextPutAll: '"The trait composition for the receiver"'.
code crtab; nextPutAll: '<traitComposition: ', aClass traitCompositionString storeString,'>'.
code crtab; nextPutAll: '"The required traits for this trait"'.
code crtab; nextPutAll: '<traitRequires: ', (aClass traits collect:[:t| t baseTrait name]),'>'.
].
aClass compile: code contents.
!

----- Method: Trait class>>unloadTraits (in category 'load-unload') -----
unloadTraits
"Trait unloadTraits"
Trait traitImpl == self ifTrue:[Trait traitImpl: nil].
self removeAllTraits.
Behavior compileSilently: 'updateTraits' classified: 'accessing'.
ClassDescription removeSelectorSilently: #updateTraits.
ClassOrganizer organization classify: #traitComposition under: 'accessing'.
(MCPackage named: 'Traits') unload.
ClassOrganizer removeSelectorSilently: #traitComposition.
Behavior removeSelectorSilently: #updateTraits.
CurrentReadOnlySourceFiles cacheDuring: [
Compiler recompileAll ]!

----- Method: Trait>>asTraitComposition (in category 'converting') -----
asTraitComposition
"Convert me into a trait composition"
^TraitComposition with: self!

----- Method: Trait>>baseTrait (in category 'accessing') -----
baseTrait
^self!

----- Method: Trait>>bindingOf: (in category 'compiling') -----
bindingOf: varName
"Answer the binding of some variable resolved in the scope of the receiver"
^self environment bindingOf: varName asSymbol.!

----- Method: Trait>>category (in category 'accessing') -----
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!

----- Method: Trait>>category: (in category 'accessing') -----
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!

----- Method: Trait>>classTrait (in category 'accessing') -----
classTrait
^classTrait!

----- Method: Trait>>definition (in category 'initialize') -----
definition
^String streamContents: [:stream |
stream nextPutAll: 'Trait named: ';
store: self name.
stream cr; tab; nextPutAll: 'uses: ';
nextPutAll: self traitComposition asString.
stream cr; tab; nextPutAll: 'category: ';
store: self category asString].!

----- Method: Trait>>environment (in category 'accessing') -----
environment
^environment!

----- Method: Trait>>environment: (in category 'accessing') -----
environment: anObject
environment := anObject!

----- Method: Trait>>fileOutOn:moveSource:toFile: (in category 'fileIn/Out') -----
fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex
super fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex.
self classSide hasMethods ifTrue:[
aFileStream cr; nextPutAll: '"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!!'; cr; cr.
self classSide
fileOutOn: aFileStream
moveSource: moveSource
toFile: fileIndex].!

----- Method: Trait>>hasClassTrait (in category 'testing') -----
hasClassTrait
^true!

----- Method: Trait>>initialize (in category 'initialize') -----
initialize
super initialize.
classTrait := ClassTrait for: self.!

----- Method: Trait>>isBaseTrait (in category 'testing') -----
isBaseTrait
^true!

----- Method: Trait>>isObsolete (in category 'testing') -----
isObsolete
"Return true if the receiver is obsolete."
^(self environment at: name ifAbsent: [nil]) ~~ self!

----- Method: Trait>>isValidTraitName: (in category 'initialize') -----
isValidTraitName: aSymbol
^(aSymbol isEmptyOrNil
or: [aSymbol first isLetter not
or: [aSymbol anySatisfy: [:character | character isAlphaNumeric not]]]) not!

----- Method: Trait>>name (in category 'accessing') -----
name
^name!

----- Method: Trait>>name: (in category 'accessing') -----
name: aSymbol
name := aSymbol!

----- Method: Trait>>obsolete (in category 'initialize') -----
obsolete
self name: ('AnObsolete' , self name) asSymbol.
self classTrait obsolete.
super obsolete!

----- Method: Trait>>removeFromSystem (in category 'initialize') -----
removeFromSystem
self removeFromSystem: true!

----- Method: Trait>>removeFromSystem: (in category 'initialize') -----
removeFromSystem: logged
self environment forgetClass: self logged: logged.
self obsolete!

----- Method: Trait>>rename: (in category 'initialize') -----
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'].
((self environment undeclared includesKey: newName)
and: [(self environment undeclared unreferencedKeys includes: newName) not])
ifTrue: [self inform: 'There are references to, ' , aString printString , '
from Undeclared. Check them after this change.'].
self environment renameClass: self as: newName.
name := newName!

----- Method: Trait>>setName:andRegisterInCategory:environment: (in category 'initialize') -----
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 includesKey: 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]
on: AttemptToWriteReadOnlyGlobal
do: [:n | n resume: true].
self environment organization classify: self name under: categorySymbol.
^ true!

----- Method: Trait>>theMetaClass (in category 'accessing') -----
theMetaClass
^self classTrait!

----- Method: Trait>>unload (in category 'initialize') -----
unload
"For polymorphism with classes. Do nothing"!

----- Method: TraitDescription class>>conflict (in category 'conflict methods') -----
conflict
"This method has a trait conflict"
^self traitConflict!

----- Method: TraitDescription class>>conflict: (in category 'conflict methods') -----
conflict: arg1
"This method has a trait conflict"
^self traitConflict!

----- Method: TraitDescription class>>conflict:with: (in category 'conflict methods') -----
conflict: arg1 with: arg2
"This method has a trait conflict"
^self traitConflict!

----- Method: TraitDescription class>>conflict:with:with: (in category 'conflict methods') -----
conflict: arg1 with: arg2 with: arg3
"This method has a trait conflict"
^self traitConflict!

----- Method: TraitDescription class>>conflict:with:with:with: (in category 'conflict methods') -----
conflict: arg1 with: arg2 with: arg3 with: arg4
"This method has a trait conflict"
^self traitConflict!

----- Method: TraitDescription class>>conflict:with:with:with:with: (in category 'conflict methods') -----
conflict: arg1 with: arg2 with: arg3 with: arg4 with: arg5
"This method has a trait conflict"
^self traitConflict!

----- Method: TraitDescription class>>conflict:with:with:with:with:with: (in category 'conflict methods') -----
conflict: arg1 with: arg2 with: arg3 with: arg4 with: arg5 with: arg6
"This method has a trait conflict"
^self traitConflict!

----- Method: TraitDescription class>>conflict:with:with:with:with:with:with: (in category 'conflict methods') -----
conflict: arg1 with: arg2 with: arg3 with: arg4 with: arg5 with: arg6 with: arg7
"This method has a trait conflict"
^self traitConflict!

----- Method: TraitDescription class>>conflict:with:with:with:with:with:with:with: (in category 'conflict methods') -----
conflict: arg1 with: arg2 with: arg3 with: arg4 with: arg5 with: arg6 with: arg7 with: arg8
"This method has a trait conflict"
^self traitConflict!

----- Method: TraitDescription>>+ (in category 'operations') -----
+ aTrait
"Creates a composition with the receiver and aTrait"
aTrait traitsDo:[:t| self == t ifTrue:[TraitCompositionException
signal: 'Trait ' , self asString, ' already in composition']].
^TraitComposition withAll: {self}, aTrait asTraitComposition!

----- Method: TraitDescription>>- (in category 'operations') -----
- anArrayOfSelectors
"Creates an exclusion"
^TraitExclusion
with: self
exclusions: anArrayOfSelectors!

----- Method: TraitDescription>>@ (in category 'operations') -----
@ anArrayOfAssociations
"Creates an alias"
^TraitAlias with: self aliases: anArrayOfAssociations!

----- Method: TraitDescription>>addSelectorSilently:withMethod: (in category 'operations') -----
addSelectorSilently: selector withMethod: compiledMethod
"Overridden to update the users of this trait"
super addSelectorSilently: selector withMethod: compiledMethod.
self users do:[:each| each updateTraits].!

----- Method: TraitDescription>>addTraitUser: (in category 'accessing') -----
addTraitUser: aTrait
users := self users copyWith: aTrait.
!

----- Method: TraitDescription>>allClassVarNames (in category 'accessing') -----
allClassVarNames
"Traits have no class var names"
^#()!

----- Method: TraitDescription>>asTraitComposition (in category 'converting') -----
asTraitComposition
^TraitComposition with: self!

----- Method: TraitDescription>>classPool (in category 'accessing') -----
classPool
"Traits have no class pool"
^ Dictionary new!

----- Method: TraitDescription>>copy (in category 'copying') -----
copy
self error: 'Traits cannot be trivially copied'!

----- Method: TraitDescription>>copyTraitExpression (in category 'copying') -----
copyTraitExpression
"Copy all except the actual traits"
^self!

----- Method: TraitDescription>>fileOut (in category 'fileIn/Out') -----
fileOut
"Create a file whose name is the name of the receiver with '.st' as the
extension, and file a description of the receiver onto it."
^ self fileOutAsHtml: false!

----- Method: TraitDescription>>fileOutAsHtml: (in category 'fileIn/Out') -----
fileOutAsHtml: useHtml
"File a description of the receiver onto a new file whose base name is the name of the receiver."

| internalStream |
internalStream := WriteStream on: (String new: 100).
internalStream header; timeStamp.

self fileOutOn: internalStream moveSource: false toFile: 0.
internalStream trailer.

FileStream writeSourceCodeFrom: internalStream baseName: self name isSt: true useHtml: useHtml.
!

----- Method: TraitDescription>>includesTrait: (in category 'testing') -----
includesTrait: aTrait
^self == aTrait or:[super includesTrait: aTrait]!

----- Method: TraitDescription>>installTraitsFrom: (in category 'operations') -----
installTraitsFrom: aTraitComposition
super installTraitsFrom: aTraitComposition.
self users do:[:each| each updateTraits].!

----- Method: TraitDescription>>isBaseTrait (in category 'testing') -----
isBaseTrait
^false!

----- Method: TraitDescription>>isClassTrait (in category 'testing') -----
isClassTrait
^false!

----- Method: TraitDescription>>isTrait (in category 'testing') -----
isTrait
^true!

----- Method: TraitDescription>>isTraitTransformation (in category 'testing') -----
isTraitTransformation
"Polymorphic with TraitTransformation"
^false!

----- Method: TraitDescription>>notifyOfRecategorizedSelector:from:to: (in category 'operations') -----
notifyOfRecategorizedSelector: element from: oldCategory to: newCategory
super notifyOfRecategorizedSelector: element from: oldCategory to: newCategory.
self users do:[:each| each classify: element under: newCategory from: oldCategory trait: self].!

----- Method: TraitDescription>>printHierarchy (in category 'printing') -----
printHierarchy
"For hierarchy view in the browser; print the users of a trait"
^String streamContents:[:s| self printUsersOf: self on: s level: 0].!

----- Method: TraitDescription>>printUsersOf:on:level: (in category 'printing') -----
printUsersOf: aClass on: aStream level: indent
aStream crtab: indent.
aStream nextPutAll: aClass name.
aClass isTrait ifTrue:[
aClass users do:[:each| self printUsersOf: aClass on: aStream level: indent+1].
].
!

----- Method: TraitDescription>>removeTraitUser: (in category 'accessing') -----
removeTraitUser: aTrait
users := self users copyWithout: aTrait.
!

----- Method: TraitDescription>>sharedPools (in category 'accessing') -----
sharedPools
"Traits have no shared pools"
^ Dictionary new!

----- Method: TraitDescription>>trait (in category 'accessing') -----
trait
^self!

----- Method: TraitDescription>>traitsDo: (in category 'operations') -----
traitsDo: aBlock
aBlock value: self.!

----- Method: TraitDescription>>users (in category 'accessing') -----
users
^users ifNil:[#()]!

----- Method: TraitDescription>>users: (in category 'accessing') -----
users: aCollection
users := aCollection!

----- Method: ClassOrganizer>>isTraitOrganizer (in category '*Traits-Kernel') -----
isTraitOrganizer
"Answer true if this is a TraitOrganizer"
^false!

----- Method: ClassOrganizer>>traitComposition (in category '*Traits-Kernel') -----
traitComposition
"Answer the receiver's trait composition"
^#()!

ClassOrganizer subclass: #TraitOrganizer
instanceVariableNames: 'traitComposition'
classVariableNames: ''
poolDictionaries: ''
category: 'Traits-Kernel'!

!TraitOrganizer commentStamp: 'ar 1/9/2010 17:56' prior: 0!
A class organizer containing state for traits.!

----- Method: TraitOrganizer>>isTraitOrganizer (in category 'testing') -----
isTraitOrganizer
"Answer true if this is a TraitOrganizer"
^true!

----- Method: TraitOrganizer>>traitComposition (in category 'accessing') -----
traitComposition
"Answer the receiver's trait composition"
^traitComposition ifNil:[traitComposition := TraitComposition new]!

----- Method: TraitOrganizer>>traitComposition: (in category 'accessing') -----
traitComposition: aTraitComposition
"Install the receiver's trait composition"
traitComposition := aTraitComposition.!

----- Method: SequenceableCollection>>asTraitComposition (in category '*Traits') -----
asTraitComposition
"For convenience the composition {T1. T2 ...} is the same as T1 + T2 + ..."
^self isEmpty
ifFalse: [
self size = 1
ifTrue: [self first asTraitComposition]
ifFalse: [
self copyWithoutFirst
inject: self first
into: [:left :right | left + right]]]
ifTrue: [ClassDescription newTraitComposition]!

Error subclass: #TraitCompositionException
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Traits-Composition'!

!TraitCompositionException commentStamp: 'ar 12/29/2009 18:13' prior: 0!
Signals invalid trait compositions.!

----- Method: Object>>explicitRequirement (in category '*Traits') -----
explicitRequirement
self error: 'Explicitly required method'!

----- Method: Object>>requirement (in category '*Traits') -----
requirement
| sender |
sender := thisContext sender.
^ NotImplemented signal: ('{1} or a superclass should implement {2} from trait {3}' format: {self className. sender selector. sender method originalTraitMethod methodClass})!

Object subclass: #TraitTransformation
instanceVariableNames: 'subject users'
classVariableNames: ''
poolDictionaries: ''
category: 'Traits-Composition'!

!TraitTransformation commentStamp: 'ar 12/29/2009 18:14' prior: 0!
A trait transformation is an instance of one of my concrete subclasses, TraitAlias or TraitExclusion. These represent a transformation of a trait, specified by the alias and exclusion operators.

I define an instance variable named subject which holds the object that is transformed. Thus, an alias transformation has as its subject a trait, and a trait exclusion has as its subject either a trait alias or a trait. Each of the concrete transformation classes implement the method allSelectors according to the transformation it represents.
!

TraitTransformation subclass: #TraitAlias
instanceVariableNames: 'aliases'
classVariableNames: ''
poolDictionaries: ''
category: 'Traits-Composition'!

!TraitAlias commentStamp: 'ar 12/29/2009 18:14' prior: 0!
A trait transformation representing the alias (->) operator.!

----- Method: TraitAlias class>>assertValidAliasDefinition: (in category 'instance creation') -----
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.']!

----- Method: TraitAlias class>>with:aliases: (in category 'instance creation') -----
with: aTraitComposition aliases: anArrayOfAssociations
self assertValidAliasDefinition: anArrayOfAssociations.
^self new
subject: aTraitComposition;
initializeFrom: anArrayOfAssociations;
yourself!

----- Method: TraitAlias>>- (in category 'converting') -----
- anArrayOfSelectors
^TraitExclusion
with: self
exclusions: anArrayOfSelectors!

----- Method: TraitAlias>>@ (in category 'converting') -----
@ anArrayOfAssociations
^TraitAlias
with: subject
aliases: (anArrayOfAssociations, self aliases)!

----- Method: TraitAlias>>aliases (in category 'accessing') -----
aliases
"Collection of associations where key is the
alias and value the original selector."
^aliases!

----- Method: TraitAlias>>aliases: (in category 'accessing') -----
aliases: aCollection
"Collection of associations where key is the
alias and value the original selector."
aliases := aCollection!

----- Method: TraitAlias>>copyTraitExpression (in category 'operations') -----
copyTraitExpression
"Copy all except the actual traits"
^TraitAlias
with: subject
aliases: aliases!

----- Method: TraitAlias>>includesSelector: (in category 'operations') -----
includesSelector: selector
"Answers true if the receiver provides the selector"
^(subject includesSelector: selector) or:[aliases anySatisfy:[:assoc| assoc key == selector]]!

----- Method: TraitAlias>>initialize (in category 'initialize-release') -----
initialize
super initialize.
aliases := #().!

----- Method: TraitAlias>>initializeFrom: (in category 'initialize-release') -----
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 := anArrayOfAssociations.
!

----- Method: TraitAlias>>isAliasSelector: (in category 'testing') -----
isAliasSelector: selector
^(self isLocalAliasSelector: selector) or:[super isAliasSelector: selector]!

----- Method: TraitAlias>>isLocalAliasSelector: (in category 'testing') -----
isLocalAliasSelector: selector
^(aliases anySatisfy:[:assoc| assoc key == selector])!

----- Method: TraitAlias>>printOn: (in category 'operations') -----
printOn: s
"Answer the trait composition string (used for class definitions)"
s nextPutAll: subject asString.
s nextPutAll: ' @ {'.
aliases do:[:assoc| s print: assoc] separatedBy:[s nextPutAll:'. '].
s nextPutAll: '}'.
!

----- Method: TraitAlias>>selectorsAndMethodsDo: (in category 'operations') -----
selectorsAndMethodsDo: aBlock
"enumerates all selectors and methods in a trait composition"

subject selectorsAndMethodsDo: aBlock.
aliases do:[:assoc| | method |
"Method can be nil during removals"
method := subject compiledMethodAt: assoc value ifAbsent:[nil].
method ifNotNil:[aBlock value: assoc key value: method].
].!

TraitTransformation subclass: #TraitExclusion
instanceVariableNames: 'exclusions'
classVariableNames: ''
poolDictionaries: ''
category: 'Traits-Composition'!

!TraitExclusion commentStamp: 'ar 12/29/2009 18:13' prior: 0!
A trait transformation representing the exclusion (-) operator.!

----- Method: TraitExclusion class>>with:exclusions: (in category 'instance creation') -----
with: aTraitComposition exclusions: anArrayOfSelectors
^self new
subject: aTraitComposition;
exclusions: anArrayOfSelectors;
yourself
!

----- Method: TraitExclusion>>- (in category 'converting') -----
- anArrayOfSelectors
^TraitExclusion
with: subject
exclusions: (anArrayOfSelectors, exclusions asArray)!

----- Method: TraitExclusion>>@ (in category 'converting') -----
@ anArrayOfAssociations

TraitCompositionException signal: 'Invalid trait exclusion. Aliases have to be specified before exclusions.'
!

----- Method: TraitExclusion>>copyTraitExpression (in category 'composition') -----
copyTraitExpression
"Copy all except the actual traits"
^TraitExclusion
with: subject
exclusions: exclusions asArray!

----- Method: TraitExclusion>>exclusions (in category 'accessing') -----
exclusions
^exclusions!

----- Method: TraitExclusion>>exclusions: (in category 'accessing') -----
exclusions: aCollection
exclusions := Set withAll: aCollection!

----- Method: TraitExclusion>>includesSelector: (in category 'composition') -----
includesSelector: selector
"Answers true if the receiver provides the selector"
^(subject includesSelector: selector) and:[(exclusions includes: selector) not]!

----- Method: TraitExclusion>>initialize (in category 'initialize') -----
initialize
super initialize.
exclusions := Set new.
!

----- Method: TraitExclusion>>printOn: (in category 'composition') -----
printOn: aStream
"Answer the trait composition string (used for class definitions)"
aStream nextPutAll: subject asString.
aStream nextPutAll: ' - {'.
exclusions asArray sort do:[:exc| aStream store: exc] separatedBy:[aStream nextPutAll: '. '].
aStream nextPutAll: '}'.!

----- Method: TraitExclusion>>selectorsAndMethodsDo: (in category 'composition') -----
selectorsAndMethodsDo: aBlock
"enumerates all selectors and methods in a trait composition"
^subject selectorsAndMethodsDo:[:sel :meth|
(exclusions includes: sel) ifFalse:[aBlock value: sel value: meth].
].!

----- Method: TraitTransformation>>+ (in category 'converting') -----
+ aTrait
"Just like ordered collection"
^TraitComposition withAll: {self. aTrait}!

----- Method: TraitTransformation>>- (in category 'converting') -----
- anArrayOfSelectors
^self subclassResponsibility!

----- Method: TraitTransformation>>@ (in category 'converting') -----
@ anArrayOfAssociations
^self subclassResponsibility!

----- Method: TraitTransformation>>addTraitUser: (in category 'accessing') -----
addTraitUser: aTrait
users := users copyWith: aTrait.
subject addTraitUser: aTrait.
!

----- Method: TraitTransformation>>allTraits (in category 'accessing') -----
allTraits
^subject allTraits!

----- Method: TraitTransformation>>asTraitComposition (in category 'converting') -----
asTraitComposition
^TraitComposition with: self!

----- Method: TraitTransformation>>asTraitTransform (in category 'converting') -----
asTraitTransform
^self!

----- Method: TraitTransformation>>copyTraitExpression (in category 'operations') -----
copyTraitExpression
"Copy all except the actual traits"
^self subclassResponsibility!

----- Method: TraitTransformation>>includesTrait: (in category 'testing') -----
includesTrait: aTrait
^subject includesTrait: aTrait!

----- Method: TraitTransformation>>initialize (in category 'initialize') -----
initialize
super initialize.
users := #().!

----- Method: TraitTransformation>>isAliasSelector: (in category 'testing') -----
isAliasSelector: selector
^subject isAliasSelector: selector!

----- Method: TraitTransformation>>isLocalAliasSelector: (in category 'testing') -----
isLocalAliasSelector: selector
^false!

----- Method: TraitTransformation>>isTraitTransformation (in category 'testing') -----
isTraitTransformation
"Polymorphic with Trait"
^true!

----- Method: TraitTransformation>>removeTraitUser: (in category 'accessing') -----
removeTraitUser: aTrait
users := users copyWithout: aTrait.
subject removeTraitUser: aTrait.!

----- Method: TraitTransformation>>selectorsAndMethodsDo: (in category 'operations') -----
selectorsAndMethodsDo: aBlock
"enumerates all selectors and methods in a trait composition"
^self subclassResponsibility!

----- Method: TraitTransformation>>subject: (in category 'accessing') -----
subject: aSubject
subject := aSubject.!

----- Method: TraitTransformation>>trait (in category 'accessing') -----
trait
^subject trait!

----- Method: TraitTransformation>>traitsDo: (in category 'accessing') -----
traitsDo: aBlock
^subject traitsDo: aBlock!

----- Method: TraitTransformation>>updateSelector:withTraitMethod:from: (in category 'operations') -----
updateSelector: aSelector withTraitMethod: compiledMethod from: aTrait
"broadcasts the change of a selector to all users of a trait"
^self subclassResponsibility!

----- Method: TraitTransformation>>updateTraits (in category 'operations') -----
updateTraits
"Recompute my users traits composition"
users do:[:each| each updateTraits].!

OrderedCollection subclass: #TraitComposition
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Traits-Composition'!

!TraitComposition commentStamp: 'ar 12/29/2009 18:13' prior: 0!
A trait composition is a collection of Traits or TraitTransformations.!

----- Method: TraitComposition>>+ (in category 'converting') -----
+ aTrait
self traitsDo:[:t| (t == aTrait trait) ifTrue:[^TraitCompositionException
signal: 'Trait ' , aTrait trait asString, ' already in composition']].
self addLast: aTrait.
^self!

----- Method: TraitComposition>>- (in category 'converting') -----
- 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)!

----- Method: TraitComposition>>@ (in category 'converting') -----
@ 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)!

----- Method: TraitComposition>>allTraits (in category 'accessing') -----
allTraits
^self gather:[:each| each allTraits copyWith: each trait]!

----- Method: TraitComposition>>asTraitComposition (in category 'converting') -----
asTraitComposition
^self!

----- Method: TraitComposition>>copyTraitExpression (in category 'operations') -----
copyTraitExpression
"Copy all except the actual traits"
^self collect:[:each| each copyTraitExpression].!

----- Method: TraitComposition>>isAliasSelector: (in category 'operations') -----
isAliasSelector: selector
"enumerates all selectors and methods in a trait composition"
^self anySatisfy:[:any| any isAliasSelector: selector]!

----- Method: TraitComposition>>isLocalAliasSelector: (in category 'operations') -----
isLocalAliasSelector: selector
"Return true if the selector aSymbol is an alias defined in the receiver."
^self anySatisfy:[:any| any isTraitTransformation and:[any isLocalAliasSelector: selector]]!

----- Method: TraitComposition>>isTraitTransformation (in category 'testing') -----
isTraitTransformation
"Polymorphic with TraitTransformation"
^false!

----- Method: TraitComposition>>printOn: (in category 'converting') -----
printOn: aStream
"Answer the trait composition string (used for class definitions)"
aStream nextPutAll: self traitCompositionString.
!

----- Method: TraitComposition>>selectorsAndMethodsDo: (in category 'operations') -----
selectorsAndMethodsDo: aBlock
"enumerates all selectors and methods in a trait composition"
self do:[:each| each selectorsAndMethodsDo: aBlock].!

----- Method: TraitComposition>>traitCompositionString (in category 'operations') -----
traitCompositionString
"Answer the trait composition string (used for class definitions)"
self size = 0 ifTrue:[^'{}'].
self size = 1 ifTrue:[^self first asString].
^String streamContents:[:s|
self do:[:each| s nextPutAll: each asString] separatedBy:[s nextPutAll: ' + '].
].!

----- Method: TraitComposition>>traits (in category 'accessing') -----
traits
^Array streamContents:[:s| self traitsDo:[:t| s nextPut: t]]!

----- Method: TraitComposition>>traitsDo: (in category 'accessing') -----
traitsDo: aBlock
^self do:[:each| each traitsDo: aBlock]!