1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171 |
- Smalltalk createPackage: 'Kernel-Classes'!
- Object subclass: #Behavior
- slots: {#organization. #slots. #fn. #superclass}
- package: 'Kernel-Classes'!
- !Behavior commentStamp!
- I am the superclass of all class objects.
- In addition to BehaviorBody, I define superclass/subclass relationships and instantiation.
- I define the protocol for creating instances of a class with `#basicNew` and `#new` (see `boot.js` for class constructors details).
- My instances know about the subclass/superclass relationships between classes and contain the description that instances are created from.
- I also provide iterating over the class hierarchy.!
- !Behavior methodsFor: 'accessing'!
- allSelectors
- ^ self allSuperclasses
- inject: self selectors
- into: [ :acc :each | acc addAll: each selectors; yourself ]
- !
- allSubclasses
- "Answer an collection of the receiver's and the receiver's descendent's subclasses. "
- ^ Array streamContents: [ :str | self allSubclassesDo: [ :each | str nextPut: each ] ]
- !
- allSuperclasses
-
- self superclass ifNil: [ ^ #() ].
-
- ^ self superclass allSuperclasses copyWithFirst: self superclass
- !
- applySuperConstructorOn: anObject withArguments: anArray
- <inlineJS: '
- Object.getPrototypeOf($self.fn.prototype).constructor
- .apply(anObject, anArray)
- '>
- !
- basicOrganization
- ^ organization
- !
- basicOrganization: aClassOrganizer
- organization := aClassOrganizer
- !
- beJavaScriptSubclassOf: aJavaScriptFunction
- "Reparent the JS constructor's prototype to aJavaScriptFunction's one,
- plus bookkeeping. That way I stay part of (simulated) Smalltalk hierarchy,
- but my instances will physically be instanceof aJavaScriptFunction."
- self makeJavaScriptConstructorSubclassOf: aJavaScriptFunction.
- Smalltalk core detachClass: self
- !
- javaScriptConstructor
- "Answer the JS constructor used to instantiate. See kernel-language.js"
-
- ^ fn
- !
- javaScriptConstructor: aJavaScriptFunction
- "Set the JS constructor used to instantiate.
- See the JS counter-part in boot.js `$core.setClassConstructor'"
-
- Smalltalk core setClassConstructor: self to: aJavaScriptFunction
- !
- javascriptConstructor
- self deprecatedAPI: 'Use #javaScriptConstructor instead.'.
- ^ self javaScriptConstructor
- !
- javascriptConstructor: aJavaScriptFunction
- self deprecatedAPI: 'Use #javaScriptConstructor: instead.'.
- ^ self javaScriptConstructor: aJavaScriptFunction
- !
- lookupSelector: selector
- "Look up the given selector in my methodDictionary.
- Return the corresponding method if found.
- Otherwise chase the superclass chain and try again.
- Return nil if no method is found."
-
- <inlineJS: 'return $self.methods[selector]'>
- !
- prototype
- ^ self javaScriptConstructor prototype
- !
- slots
- ^ slots
- !
- subclasses
- self subclassResponsibility
- !
- superPrototype
- <inlineJS: 'return Object.getPrototypeOf($self.fn.prototype)'>
- !
- superclass
- ^ superclass
- !
- theMetaClass
- self subclassResponsibility
- !
- theNonMetaClass
- self subclassResponsibility
- !
- withAllSubclasses
- ^ self allSubclasses copyWithFirst: self
- ! !
- !Behavior methodsFor: 'enumerating'!
- allSubclassesDo: aBlock
- "Evaluate the argument, aBlock, for each of the receiver's subclasses."
- <inlineJS: '$core.traverseClassTree(self, function(subclass) {
- if (subclass !!== self) aBlock._value_(subclass);
- })'>
- ! !
- !Behavior methodsFor: 'instance creation'!
- alternateConstructorViaSelector: aSelector
- ^ BlockClosure
- javaScriptConstructorFor: self prototype
- initializingVia: (self >> aSelector) fn
- !
- basicNew
- <inlineJS: 'return new self.fn()'>
- !
- new
- ^ self basicNew initialize
- ! !
- !Behavior methodsFor: 'private'!
- makeJavaScriptConstructorSubclassOf: javaScriptClass
- <inlineJS: '
- Object.setPrototypeOf($self.fn.prototype, javaScriptClass.prototype);
- '>
- ! !
- !Behavior methodsFor: 'testing'!
- canUnderstand: aSelector
- ^ (self lookupSelector: aSelector) notNil
- !
- includesBehavior: aClass
- ^ self == aClass or: [
- self inheritsFrom: aClass ]
- !
- inheritsFrom: aClass
- ^ self superclass
- ifNil: [ false ]
- ifNotNil: [ :superClass | superClass includesBehavior: aClass ]
- !
- isBehavior
- ^ true
- ! !
- Behavior subclass: #Class
- slots: {#package. #subclasses}
- package: 'Kernel-Classes'!
- !Class commentStamp!
- I am __the__ class object.
- My instances are the classes of the system.
- Class creation is done throught a `ClassBuilder` instance.!
- !Class methodsFor: 'accessing'!
- basicPackage: aPackage
- package := aPackage
- !
- classTag
- "Returns a tag or general category for this class.
- Typically used to help tools do some reflection.
- Helios, for example, uses this to decide what icon the class should display."
-
- ^ 'class'
- !
- definition
- ^ String streamContents: [ :stream | stream
- print: self superclass; write: ' subclass: '; printSymbol: self name; lf;
- write: (self traitCompositionDefinition ifNotEmpty: [ :tcd | { String tab. 'uses: '. tcd. String lf }]);
- tab; write: {'slots: {'. ('. ' join: (self instanceVariableNames collect: #symbolPrintString)). '}'}; lf;
- tab; write: 'package: '; print: self category ]
- !
- package
- ^ package
- !
- rename: aString
- ClassBuilder new renameClass: self to: aString
- !
- subclasses
- ^ subclasses copy
- !
- theMetaClass
- ^ self class
- ! !
- !Class methodsFor: 'converting'!
- provided
- "Returns JS proxy that allows to access 'static API', as in
- Number provided EPSILON
- that forwards to (wrapped JS) constructor function."
-
- ^ self javaScriptConstructor provided
- ! !
- !Class methodsFor: 'enumerating'!
- includingPossibleMetaDo: aBlock
- aBlock value: self.
- aBlock value: self theMetaClass
- ! !
- !Class methodsFor: 'testing'!
- isClass
- ^ true
- ! !
- Behavior subclass: #Metaclass
- slots: {#instanceClass}
- package: 'Kernel-Classes'!
- !Metaclass commentStamp!
- I am the root of the class hierarchy.
- My instances are metaclasses, one for each real class, and have a single instance, which they hold onto: the class that they are the metaclass of.!
- !Metaclass methodsFor: 'accessing'!
- definition
- ^ String streamContents: [ :stream | stream
- print: self;
- write: (self traitCompositionDefinition
- ifEmpty: [' ']
- ifNotEmpty: [ :tcd | { String lf. String tab. 'uses: '. tcd. String lf. String tab }]);
- write: {'slots: {'. ('. ' join: (self instanceVariableNames collect: #symbolPrintString)). '}'} ]
- !
- instanceClass
- ^ instanceClass
- !
- instanceVariableNames: aString
- "Kept for file-in compatibility."
- ^ self slots: aString instanceVariablesStringAsSlotList
- !
- name
- ^ self instanceClass name, ' class'
- !
- package
- ^ self instanceClass package
- !
- slots: aCollection
- ClassBuilder new
- class: self slots: aCollection.
- ^ self
- !
- subclasses
- ^ Smalltalk core metaSubclasses: self
- !
- theMetaClass
- ^ self
- !
- theNonMetaClass
- ^ self instanceClass
- !
- uses: aTraitCompositionDescription instanceVariableNames: aString
- "Kept for file-in compatibility."
- ^ self uses: aTraitCompositionDescription slots: aString instanceVariablesStringAsSlotList
- !
- uses: aTraitCompositionDescription slots: aCollection
- self
- slots: aCollection;
- setTraitComposition: aTraitCompositionDescription asTraitComposition.
- ^ self
- ! !
- !Metaclass methodsFor: 'converting'!
- asJavaScriptSource
- ^ '$globals.', self instanceClass name, '.a$cls'
- ! !
- !Metaclass methodsFor: 'testing'!
- isMetaclass
- ^ true
- ! !
- Object subclass: #ClassBuilder
- slots: {}
- package: 'Kernel-Classes'!
- !ClassBuilder commentStamp!
- I am responsible for compiling new classes or modifying existing classes in the system.
- Rather than using me directly to compile a class, use `Class >> subclass:instanceVariableNames:package:`.!
- !ClassBuilder methodsFor: 'class definition'!
- addSubclassOf: aClass named: className instanceVariableNames: aCollection package: packageName
- self deprecatedAPI: 'Use #addSubclass:named:slots:package: instead.'.
- ^ self
- addSubclassOf: aClass
- named: className
- slots: aCollection
- package: packageName
- !
- addSubclassOf: aClass named: className slots: aCollection package: packageName
- | theClass thePackage |
-
- theClass := Smalltalk globals at: className.
- thePackage := Package named: packageName.
-
- theClass ifNotNil: [
- theClass package: thePackage.
- theClass superclass == aClass
- ifFalse: [ ^ self
- migrateClassNamed: className
- superclass: aClass
- slots: aCollection
- package: packageName ] ].
-
- ^ (self
- basicAddSubclassOf: aClass
- named: className
- slots: aCollection
- package: packageName) recompile; yourself
- !
- addTraitNamed: traitName package: packageName
- | theTrait thePackage |
-
- theTrait := Smalltalk globals at: traitName.
- thePackage := Package named: packageName.
-
- theTrait ifNotNil: [ ^ theTrait package: thePackage; recompile; yourself ].
-
- theTrait := self
- basicAddTraitNamed: traitName
- package: packageName.
-
- SystemAnnouncer current
- announce: (ClassAdded new
- theClass: theTrait;
- yourself).
-
- ^ theTrait
- !
- class: aClass slots: aCollection
- self basicClass: aClass slots: aCollection.
-
- SystemAnnouncer current
- announce: (ClassDefinitionChanged new
- theClass: aClass;
- yourself)
- !
- superclass: aClass subclass: className
- ^ self superclass: aClass subclass: className slots: #() package: nil
- !
- superclass: aClass subclass: className slots: aCollection package: packageName
- | newClass |
-
- newClass := self addSubclassOf: aClass
- named: className slots: aCollection
- package: (packageName ifNil: [ 'unclassified' ]).
-
- SystemAnnouncer current
- announce: (ClassAdded new
- theClass: newClass;
- yourself).
-
- ^ newClass
- ! !
- !ClassBuilder methodsFor: 'class migration'!
- migrateClass: aClass superclass: anotherClass
- ^ self
- migrateClassNamed: aClass name
- superclass: anotherClass
- slots: aClass slots
- package: aClass package name
- !
- migrateClassNamed: className superclass: aClass instanceVariableNames: aCollection package: packageName
- self deprecatedAPI: 'Use #migrateClassNamed:superclass:slots:package: instead.'.
- ^ self
- migrateClassNamed: className
- superclass: aClass
- slots: aCollection
- package: packageName
- !
- migrateClassNamed: className superclass: aClass slots: aCollection package: packageName
- | oldClass newClass tmp |
-
- tmp := 'new*', className.
- oldClass := Smalltalk globals at: className.
-
- newClass := self
- addSubclassOf: aClass
- named: tmp
- slots: aCollection
- package: packageName.
- self basicSwapClassNames: oldClass with: newClass.
- [ self copyClass: oldClass to: newClass ]
- on: Error
- do: [ :exception |
- self
- basicSwapClassNames: oldClass with: newClass;
- basicRemoveClass: newClass.
- SystemAnnouncer current announce: (ClassRenamed new
- theClass: oldClass;
- yourself).
- exception pass ].
- self
- rawRenameClass: oldClass to: tmp;
- rawRenameClass: newClass to: className.
- oldClass subclasses
- do: [ :each | self migrateClass: each superclass: newClass ].
- self basicRemoveClass: oldClass.
-
- SystemAnnouncer current announce: (ClassMigrated new
- theClass: newClass;
- oldClass: oldClass;
- yourself).
-
- ^ newClass
- !
- renameClass: aClass to: className
- self basicRenameClass: aClass to: className.
-
- "Recompile the class to fix potential issues with super sends"
- aClass recompile.
-
- SystemAnnouncer current
- announce: (ClassRenamed new
- theClass: aClass;
- yourself)
- ! !
- !ClassBuilder methodsFor: 'copying'!
- copyClass: aClass named: className
- | newClass |
- newClass := self
- addSubclassOf: aClass superclass
- named: className
- slots: aClass slots copy
- package: aClass package name.
- self copyClass: aClass to: newClass.
-
- SystemAnnouncer current
- announce: (ClassAdded new
- theClass: newClass;
- yourself).
-
- ^ newClass
- !
- copyClass: aClass to: anotherClass
- anotherClass comment: aClass comment.
- aClass methodDictionary valuesDo: [ :each |
- each origin = aClass ifTrue: [
- Compiler new install: each source forClass: anotherClass protocol: each protocol ] ].
- anotherClass setTraitComposition: aClass traitComposition.
- self basicClass: anotherClass class slots: aClass class slots copy.
- aClass class methodDictionary valuesDo: [ :each |
- each origin = aClass class ifTrue: [
- Compiler new install: each source forClass: anotherClass class protocol: each protocol ] ].
- anotherClass class setTraitComposition: aClass class traitComposition
- ! !
- !ClassBuilder methodsFor: 'private'!
- basicAddSubclassOf: aClass named: aString slots: aCollection package: packageName
- <inlineJS: '
- var klass = $core.addClass(aString, aClass, packageName);
- $core.setSlots(klass, aCollection);
- return klass;
- '>
- !
- basicAddTraitNamed: aString package: anotherString
- <inlineJS: 'return $core.addTrait(aString, anotherString)'>
- !
- basicClass: aClass slots: aCollection
- aClass isMetaclass ifFalse: [ self error: aClass name, ' is not a metaclass' ].
- Smalltalk core setSlots: aClass to: aCollection
- !
- basicRemoveClass: aClass
- <inlineJS: '$core.removeClass(aClass)'>
- !
- basicRenameClass: aClass to: aString
- <inlineJS: '
- $globals[aString] = aClass;
- delete $globals[aClass.name];
- aClass.name = aString;
- '>
- !
- basicSwapClassNames: aClass with: anotherClass
- <inlineJS: '
- var tmp = aClass.name;
- aClass.name = anotherClass.name;
- anotherClass.name = tmp;
- '>
- !
- rawRenameClass: aClass to: aString
- <inlineJS: '
- $globals[aString] = aClass;
- '>
- ! !
- !ClassBuilder class methodsFor: 'as yet unclassified'!
- sortClasses: aCollection
- | root members |
- root := {nil. {}}.
- members := HashedCollection new.
- aCollection do: [ :each | members at: each name put: {each. {}} ].
- (aCollection asArray sorted: [ :a :b | a name <= b name ]) do: [ :each |
- | target |
- target := members
- at: (each superclass ifNotNil: [ :superklass | superklass name ])
- ifAbsent: [ root ].
- target second add: (members at: each name) ].
- ^ root second
- ! !
- Trait named: #TBehaviorDefaults
- package: 'Kernel-Classes'!
- !TBehaviorDefaults methodsFor: 'accessing'!
- name
- ^ nil
- !
- slots
- "Default for non-classes; to be able to send #slots to any class / trait."
- ^ #()
- !
- superclass
- "Default for non-classes; to be able to send #superclass to any class / trait."
- ^ nil
- !
- traitUsers
- "Default for non-traits; to be able to send #traitUsers to any class / trait"
- ^ #()
- ! !
- !TBehaviorDefaults methodsFor: 'enumerating'!
- allSubclassesDo: aBlock
- "Default for non-classes; to be able to send #allSubclassesDo: to any class / trait."
- !
- includingPossibleMetaDo: aBlock
- "Default for non-classes."
- aBlock value: self
- ! !
- !TBehaviorDefaults methodsFor: 'printing'!
- printOn: aStream
- self name
- ifNil: [ super printOn: aStream ]
- ifNotNil: [ :name | aStream nextPutAll: name ]
- ! !
- Trait named: #TBehaviorProvider
- package: 'Kernel-Classes'!
- !TBehaviorProvider commentStamp!
- I have method dictionary, slots and organization.!
- !TBehaviorProvider methodsFor: 'accessing'!
- >> aString
- ^ self methodAt: aString
- !
- allInstanceVariableNames
- ^ self allSlots select: #isString
- !
- allSlotNames
- ^ self allSlots
- !
- allSlots
- | result |
- result := self slots copy.
- self superclass ifNotNil: [ :s | result addAll: s allSlots ].
- ^ result
- !
- instanceVariableNames
- ^ self slots select: #isString
- !
- methodAt: aString
- ^ self methodDictionary at: aString
- !
- methodDictionary
- <inlineJS: 'var dict = $globals.HashedCollection._new();
- var methods = self.methods;
- Object.keys(methods).forEach(function(i) {
- if(methods[i].selector) {
- dict._at_put_(methods[i].selector, methods[i]);
- }
- });
- return dict'>
- !
- methodOrganizationEnter: aMethod andLeave: oldMethod
- aMethod ifNotNil: [
- self organization addElement: aMethod protocol ].
-
- oldMethod ifNotNil: [
- self removeProtocolIfEmpty: oldMethod protocol ]
- !
- methodTemplate
- ^ String streamContents: [ :stream | stream
- write: 'messageSelectorAndArgumentNames'; lf;
- tab; write: '"comment stating purpose of message"'; lf;
- lf;
- tab; write: '| temporary variable names |'; lf;
- tab; write: 'statements' ]
- !
- methods
- ^ self methodDictionary values
- !
- methodsInProtocol: aString
- ^ self methods select: [ :each | each protocol = aString ]
- !
- organization
- ^ self basicOrganization ifNil: [
- self basicOrganization: (ClassOrganizer on: self).
- self basicOrganization ]
- !
- ownMethods
- "Answer the methods of the receiver that are not package extensions
- nor obtained via trait composition"
- ^ (self ownProtocols
- inject: OrderedCollection new
- into: [ :acc :each | acc, (self ownMethodsInProtocol: each) ])
- sorted: [ :a :b | a selector <= b selector ]
- !
- ownMethodsInProtocol: aString
- ^ (self methodsInProtocol: aString) select: [ :each | each origin = self ]
- !
- ownProtocols
- "Answer the protocols of the receiver that are not package extensions"
- ^ self protocols reject: [ :each |
- each match: '^\*' ]
- !
- packageOfProtocol: aString
- "Answer the package the method of receiver belongs to:
- - if it is an extension method, answer the corresponding package
- - else answer the receiver's package"
-
- (aString beginsWith: '*') ifFalse: [
- ^ self package ].
-
- ^ Package
- named: aString allButFirst
- ifAbsent: [ nil ]
- !
- protocols
- ^ self organization elements asArray sorted
- !
- removeProtocolIfEmpty: aString
- self methods
- detect: [ :each | each protocol = aString ]
- ifNone: [ self organization removeElement: aString ]
- !
- selectors
- ^ self methodDictionary keys
- !
- slotNames
- ^ self slots
- !
- traitComposition
- ^ (self basicAt: 'traitComposition')
- ifNil: [ #() ]
- ifNotNil: [ :aCollection | aCollection collect: [ :each | TraitTransformation fromJSON: each ] ]
- !
- traitCompositionDefinition
- ^ self traitComposition ifNotEmpty: [ :traitComposition |
- String streamContents: [ :str |
- str write: '{'.
- traitComposition
- do: [ :each | str write: each definition ]
- separatedBy: [ str write: '. ' ].
- str write: '}' ] ]
- ! !
- !TBehaviorProvider methodsFor: 'compiling'!
- addCompiledMethod: aMethod
- | oldMethod announcement |
-
- oldMethod := self methodDictionary
- at: aMethod selector
- ifAbsent: [ nil ].
-
- self basicAddCompiledMethod: aMethod.
-
- announcement := oldMethod
- ifNil: [
- MethodAdded new
- method: aMethod;
- yourself ]
- ifNotNil: [
- MethodModified new
- oldMethod: oldMethod;
- method: aMethod;
- yourself ].
-
-
- SystemAnnouncer current
- announce: announcement
- !
- compile: aString protocol: anotherString
- ^ Compiler new
- install: aString
- forClass: self
- protocol: anotherString
- !
- recompile
- ^ Compiler new recompile: self
- !
- removeCompiledMethod: aMethod
- self basicRemoveCompiledMethod: aMethod.
-
- SystemAnnouncer current
- announce: (MethodRemoved new
- method: aMethod;
- yourself)
- !
- setTraitComposition: aTraitComposition
- <inlineJS: '$core.setTraitComposition(aTraitComposition._asJavaScriptObject(), self)'>
- ! !
- !TBehaviorProvider methodsFor: 'enumerating'!
- protocolsDo: aBlock
- "Execute aBlock for each method protocol with
- its collection of methods in the sort order of protocol name."
- | methodsByProtocol |
- methodsByProtocol := HashedCollection new.
- self methodDictionary valuesDo: [ :m |
- (methodsByProtocol at: m protocol ifAbsentPut: [ Array new ])
- add: m ].
- self protocols do: [ :protocol |
- aBlock value: protocol value: (methodsByProtocol at: protocol) ]
- ! !
- !TBehaviorProvider methodsFor: 'private'!
- basicAddCompiledMethod: aMethod
- <inlineJS: '$core.addMethod(aMethod, self)'>
- !
- basicRemoveCompiledMethod: aMethod
- <inlineJS: '$core.removeMethod(aMethod,self)'>
- ! !
- !TBehaviorProvider methodsFor: 'testing'!
- includesSelector: aString
- ^ self methodDictionary includesKey: aString
- ! !
- Trait named: #TMasterBehavior
- package: 'Kernel-Classes'!
- !TMasterBehavior commentStamp!
- I am the behavior on the instance-side of the browser.
- I define things like package, category, name, comment etc.
- as opposed to derived behaviors (metaclass, class trait, ...)
- that relate to me.!
- !TMasterBehavior methodsFor: 'accessing'!
- category
- ^ self package ifNil: [ 'Unclassified' ] ifNotNil: [ self package name ]
- !
- classTag
- "Every master behavior should define a class tag."
- ^ self subclassResponsibility
- !
- comment
- ^ (self basicAt: 'comment') ifNil: [ '' ]
- !
- comment: aString
- self basicAt: 'comment' put: aString.
- SystemAnnouncer current
- announce: (ClassCommentChanged new
- theClass: self;
- yourself)
- !
- definedMethods
- "Answers methods of me and derived 'meta' part if present"
- | methods |
- methods := self methods.
- self theMetaClass
- ifNil: [ ^ methods ]
- ifNotNil: [ :meta | ^ methods, meta methods ]
- !
- enterOrganization
- Smalltalk ifNotNil: [
- (self basicAt: 'category')
- ifNil: [ self basicPackage: nil ]
- ifNotNil: [ :category |
- "Amber has 1-1 correspondence between cat and pkg, atm"
- self basicPackage: (Package named: category).
- self package organization addElement: self ] ]
- !
- leaveOrganization
- Smalltalk ifNotNil: [
- self package organization removeElement: self ]
- !
- name
- <inlineJS: 'return self.name'>
- !
- package: aPackage
- | oldPackage |
-
- self package = aPackage ifTrue: [ ^ self ].
-
- oldPackage := self package.
-
- self
- leaveOrganization;
- basicAt: 'category' put: aPackage name;
- enterOrganization.
- SystemAnnouncer current announce: (ClassMoved new
- theClass: self;
- oldPackage: oldPackage;
- yourself)
- !
- theNonMetaClass
- ^ self
- ! !
- !TMasterBehavior methodsFor: 'browsing'!
- browse
- Finder findClass: self
- ! !
- !TMasterBehavior methodsFor: 'converting'!
- asJavaScriptSource
- ^ '$globals.', self name
- ! !
- Object subclass: #Trait
- slots: {#organization. #package. #traitUsers}
- package: 'Kernel-Classes'!
- !Trait methodsFor: 'accessing'!
- basicOrganization
- ^ organization
- !
- basicOrganization: aClassOrganizer
- organization := aClassOrganizer
- !
- basicPackage: aPackage
- package := aPackage
- !
- classTag
- ^ 'trait'
- !
- definition
- ^ String streamContents: [ :stream | stream
- write: 'Trait named: '; printSymbol: self name; lf;
- write: (self traitCompositionDefinition ifNotEmpty: [ :tcd | { String tab. 'uses: '. tcd. String lf }]);
- tab; write: 'package: '; print: self category ]
- !
- package
- ^ package
- !
- theMetaClass
- ^ nil
- !
- traitUsers
- ^ traitUsers copy
- ! !
- !Trait methodsFor: 'composition'!
- - anArray
- ^ self asTraitTransformation - anArray
- !
- @ anArrayOfAssociations
- ^ self asTraitTransformation @ anArrayOfAssociations
- ! !
- !Trait methodsFor: 'converting'!
- asTraitComposition
- ^ self asTraitTransformation asTraitComposition
- !
- asTraitTransformation
- ^ TraitTransformation on: self
- ! !
- !Trait class methodsFor: 'instance creation'!
- named: aString package: anotherString
- ^ ClassBuilder new addTraitNamed: aString package: anotherString
- !
- named: aString uses: aTraitCompositionDescription package: anotherString
- | trait |
- trait := self named: aString package: anotherString.
- trait setTraitComposition: aTraitCompositionDescription asTraitComposition.
- ^ trait
- ! !
- Object subclass: #TraitTransformation
- slots: {#trait. #aliases. #exclusions}
- package: 'Kernel-Classes'!
- !TraitTransformation commentStamp!
- I am a single step in trait composition.
- I represent one trait including its aliases and exclusions.!
- !TraitTransformation methodsFor: 'accessing'!
- addAliases: anArrayOfAssociations
- anArrayOfAssociations do: [ :each |
- | key |
- key := each key.
- aliases at: key
- ifPresent: [ self error: 'Cannot use same alias name twice.' ]
- ifAbsent: [ aliases at: key put: each value ] ].
- ^ anArrayOfAssociations
- !
- addExclusions: anArray
- exclusions addAll: anArray.
- ^ anArray
- !
- aliases
- ^ aliases
- !
- definition
- ^ String streamContents: [ :str |
- str print: self trait.
- self aliases ifNotEmpty: [ :al |
- str write: ' @ {'.
- al associations
- do: [ :each | str printSymbol: each key; write: ' -> '; printSymbol: each value ]
- separatedBy: [ str write: '. ' ].
- str write: '}' ].
- self exclusions ifNotEmpty: [ :ex |
- str write: ' - #('.
- ex asArray sorted
- do: [ :each | str write: each symbolPrintString allButFirst ]
- separatedBy: [ str space ].
- str write: ')' ] ]
- !
- exclusions
- ^ exclusions
- !
- trait
- ^ trait
- !
- trait: anObject
- trait := anObject
- ! !
- !TraitTransformation methodsFor: 'composition'!
- - anArray
- ^ self copy addExclusions: anArray; yourself
- !
- @ anArrayOfAssociations
- ^ self copy addAliases: anArrayOfAssociations; yourself
- ! !
- !TraitTransformation methodsFor: 'converting'!
- asJavaScriptObject
- ^ #{
- 'trait' -> self trait.
- 'aliases' -> self aliases.
- 'exclusions' -> self exclusions asArray sorted }
- !
- asJavaScriptSource
- ^ String streamContents: [ :str | str write: {
- '{trait: '. self trait asJavaScriptSource.
- self aliases ifNotEmpty: [ :al |
- {', aliases: '. al asJSONString} ].
- self exclusions ifNotEmpty: [ :ex |
- {', exclusions: '. ex asArray sorted asJavaScriptSource} ].
- '}' } ]
- !
- asTraitComposition
- ^ { self }
- !
- asTraitTransformation
- ^ self
- ! !
- !TraitTransformation methodsFor: 'copying'!
- postCopy
- aliases := aliases copy.
- exclusions := exclusions copy
- ! !
- !TraitTransformation methodsFor: 'initialization'!
- initialize
- super initialize.
- aliases := #{}.
- exclusions := Set new.
- trait := nil
- ! !
- !TraitTransformation class methodsFor: 'instance creation'!
- fromJSON: aJSObject
- ^ super new
- trait: (aJSObject at: #trait);
- addAliases: (Smalltalk readJSObject: (aJSObject at: #aliases ifAbsent: [#{}])) associations;
- addExclusions: (aJSObject at: #exclusions ifAbsent: [#()]);
- yourself
- !
- on: aTrait
- ^ super new trait: aTrait; yourself
- ! !
- Behavior setTraitComposition: {TBehaviorDefaults. TBehaviorProvider} asTraitComposition!
- Class setTraitComposition: {TMasterBehavior. TSubclassable} asTraitComposition!
- Trait setTraitComposition: {TBehaviorDefaults. TBehaviorProvider. TMasterBehavior} asTraitComposition!
- ! !
- !Array methodsFor: '*Kernel-Classes'!
- asTraitComposition
- "not implemented yet, noop atm"
- ^ self collect: [ :each | each asTraitTransformation ]
- ! !
- !String methodsFor: '*Kernel-Classes'!
- instanceVariablesStringAsSlotList
- ^ (self tokenize: ' ') reject: [ :each | each isEmpty ]
- ! !
|