[squeak-dev] Squeak 4.5: Traits-cwp.301.mcz

commits at source.squeak.org commits at source.squeak.org
Fri Jan 24 20:17:34 UTC 2014


Chris Muller uploaded a new version of Traits to project Squeak 4.5:
http://source.squeak.org/squeak45/Traits-cwp.301.mcz

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

Name: Traits-cwp.301
Author: cwp
Time: 10 January 2014, 10:21:42.335 am
UUID: 4d29a1a0-5d8b-4439-a082-e42b5e69efc9
Ancestors: Traits-nice.300

Implement Trait>>unload, for better polymorphism with classes.

==================== 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>>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: 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 defaultMethodTrailer.
	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.
	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: Behavior>>allTraits (in category '*Traits-Kernel') -----
allTraits
	"Backstop. When traits are unloaded there are no traits hiding here."
	^#()!

----- Method: Behavior>>hasTraitComposition (in category '*Traits-Kernel') -----
hasTraitComposition
	"Backstop. When traits are unloaded we never have a trait composition"
	^false!

----- Method: Behavior>>traitComposition (in category '*Traits-Kernel') -----
traitComposition
	"Backstop. When traits are unloaded we never have a trait composition"
	^#()!

----- Method: Behavior>>traitCompositionString (in category '*Traits-Kernel') -----
traitCompositionString
	"Backstop. Monticello needs a traitCompositionString even with traits unloaded"
	^'{}'!

----- 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]!



More information about the Squeak-dev mailing list