Kernel-Classes.st 24 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080
  1. Smalltalk createPackage: 'Kernel-Classes'!
  2. Object subclass: #Behavior
  3. instanceVariableNames: ''
  4. package: 'Kernel-Classes'!
  5. !Behavior commentStamp!
  6. I am the superclass of all class objects.
  7. In addition to BehaviorBody, I define superclass/subclass relationships and instantiation.
  8. I define the protocol for creating instances of a class with `#basicNew` and `#new` (see `boot.js` for class constructors details).
  9. My instances know about the subclass/superclass relationships between classes and contain the description that instances are created from.
  10. I also provide iterating over the class hierarchy.!
  11. !Behavior methodsFor: 'accessing'!
  12. allInstanceVariableNames
  13. | result |
  14. result := self instanceVariableNames copy.
  15. self superclass ifNotNil: [
  16. result addAll: self superclass allInstanceVariableNames ].
  17. ^ result
  18. !
  19. allSelectors
  20. ^ self allSuperclasses
  21. inject: self selectors
  22. into: [ :acc :each | acc addAll: each selectors; yourself ]
  23. !
  24. allSubclasses
  25. "Answer an collection of the receiver's and the receiver's descendent's subclasses. "
  26. ^ Array streamContents: [ :str | self allSubclassesDo: [ :each | str nextPut: each ] ]
  27. !
  28. allSuperclasses
  29. self superclass ifNil: [ ^ #() ].
  30. ^ (OrderedCollection with: self superclass)
  31. addAll: self superclass allSuperclasses;
  32. yourself
  33. !
  34. instanceVariableNames
  35. <inlineJS: 'return self.iVarNames'>
  36. !
  37. javascriptConstructor
  38. "Answer the JS constructor used to instantiate. See boot.js"
  39. <inlineJS: 'return self.fn'>
  40. !
  41. javascriptConstructor: aJavaScriptFunction
  42. "Set the JS constructor used to instantiate.
  43. See the JS counter-part in boot.js `$core.setClassConstructor'"
  44. <inlineJS: '$core.setClassConstructor(self, aJavaScriptFunction);'>
  45. !
  46. lookupSelector: selector
  47. "Look up the given selector in my methodDictionary.
  48. Return the corresponding method if found.
  49. Otherwise chase the superclass chain and try again.
  50. Return nil if no method is found."
  51. | lookupClass |
  52. lookupClass := self.
  53. [ lookupClass = nil ] whileFalse: [
  54. (lookupClass includesSelector: selector)
  55. ifTrue: [ ^ lookupClass methodAt: selector ].
  56. lookupClass := lookupClass superclass ].
  57. ^ nil
  58. !
  59. prototype
  60. <inlineJS: 'return self.fn.prototype'>
  61. !
  62. subclasses
  63. self subclassResponsibility
  64. !
  65. superclass
  66. <inlineJS: 'return self.superclass'>
  67. !
  68. theMetaClass
  69. self subclassResponsibility
  70. !
  71. theNonMetaClass
  72. self subclassResponsibility
  73. !
  74. withAllSubclasses
  75. ^ (Array with: self) addAll: self allSubclasses; yourself
  76. ! !
  77. !Behavior methodsFor: 'enumerating'!
  78. allSubclassesDo: aBlock
  79. "Evaluate the argument, aBlock, for each of the receiver's subclasses."
  80. <inlineJS: '$core.traverseClassTree(self, function(subclass) {
  81. if (subclass !!== self) aBlock._value_(subclass);
  82. })'>
  83. ! !
  84. !Behavior methodsFor: 'instance creation'!
  85. basicNew
  86. <inlineJS: 'return new self.fn()'>
  87. !
  88. new
  89. ^ self basicNew initialize
  90. ! !
  91. !Behavior methodsFor: 'testing'!
  92. canUnderstand: aSelector
  93. ^ (self includesSelector: aSelector asString) or: [
  94. self superclass notNil and: [ self superclass canUnderstand: aSelector ]]
  95. !
  96. includesBehavior: aClass
  97. ^ self == aClass or: [
  98. self inheritsFrom: aClass ]
  99. !
  100. inheritsFrom: aClass
  101. self superclass ifNil: [ ^ false ].
  102. ^ aClass == self superclass or: [
  103. self superclass inheritsFrom: aClass ]
  104. !
  105. isBehavior
  106. ^ true
  107. ! !
  108. Behavior subclass: #Class
  109. instanceVariableNames: ''
  110. package: 'Kernel-Classes'!
  111. !Class commentStamp!
  112. I am __the__ class object.
  113. My instances are the classes of the system.
  114. Class creation is done throught a `ClassBuilder` instance.!
  115. !Class methodsFor: 'accessing'!
  116. classTag
  117. "Returns a tag or general category for this class.
  118. Typically used to help tools do some reflection.
  119. Helios, for example, uses this to decide what icon the class should display."
  120. ^ 'class'
  121. !
  122. definition
  123. ^ String streamContents: [ :stream | stream
  124. print: self superclass; write: ' subclass: '; printSymbol: self name; lf;
  125. write: (self traitCompositionDefinition ifNotEmpty: [ :tcd | { String tab. 'uses: '. tcd. String lf }]);
  126. tab; write: 'instanceVariableNames: '; print: (' ' join: self instanceVariableNames); lf;
  127. tab; write: 'package: '; print: self category ]
  128. !
  129. rename: aString
  130. ClassBuilder new renameClass: self to: aString
  131. !
  132. subclasses
  133. <inlineJS: 'return self.subclasses._copy()'>
  134. !
  135. theMetaClass
  136. ^ self class
  137. ! !
  138. !Class methodsFor: 'testing'!
  139. isClass
  140. ^ true
  141. ! !
  142. Behavior subclass: #Metaclass
  143. instanceVariableNames: ''
  144. package: 'Kernel-Classes'!
  145. !Metaclass commentStamp!
  146. I am the root of the class hierarchy.
  147. 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.!
  148. !Metaclass methodsFor: 'accessing'!
  149. definition
  150. ^ String streamContents: [ :stream | stream
  151. print: self;
  152. write: (self traitCompositionDefinition
  153. ifEmpty: [' ']
  154. ifNotEmpty: [ :tcd | { String lf. String tab. 'uses: '. tcd. String lf. String tab }]);
  155. write: 'instanceVariableNames: ';
  156. print: (' ' join: self instanceVariableNames) ]
  157. !
  158. instanceClass
  159. <inlineJS: 'return self.instanceClass'>
  160. !
  161. instanceVariableNames: aCollection
  162. ClassBuilder new
  163. class: self instanceVariableNames: aCollection.
  164. ^ self
  165. !
  166. name
  167. ^ self instanceClass name, ' class'
  168. !
  169. package
  170. ^ self instanceClass package
  171. !
  172. subclasses
  173. <inlineJS: 'return $core.metaSubclasses(self)'>
  174. !
  175. theMetaClass
  176. ^ self
  177. !
  178. theNonMetaClass
  179. ^ self instanceClass
  180. !
  181. uses: aTraitCompositionDescription instanceVariableNames: aCollection
  182. | metaclass |
  183. metaclass := self instanceVariableNames: aCollection.
  184. metaclass setTraitComposition: aTraitCompositionDescription asTraitComposition.
  185. ^ metaclass
  186. ! !
  187. !Metaclass methodsFor: 'converting'!
  188. asJavaScriptSource
  189. ^ '$globals.', self instanceClass name, '.a$cls'
  190. ! !
  191. !Metaclass methodsFor: 'testing'!
  192. isMetaclass
  193. ^ true
  194. ! !
  195. Object subclass: #ClassBuilder
  196. instanceVariableNames: ''
  197. package: 'Kernel-Classes'!
  198. !ClassBuilder commentStamp!
  199. I am responsible for compiling new classes or modifying existing classes in the system.
  200. Rather than using me directly to compile a class, use `Class >> subclass:instanceVariableNames:package:`.!
  201. !ClassBuilder methodsFor: 'accessing'!
  202. instanceVariableNamesFor: aString
  203. ^ (aString tokenize: ' ') reject: [ :each | each isEmpty ]
  204. ! !
  205. !ClassBuilder methodsFor: 'class definition'!
  206. addSubclassOf: aClass named: className instanceVariableNames: aCollection package: packageName
  207. | theClass thePackage |
  208. theClass := Smalltalk globals at: className.
  209. thePackage := Package named: packageName.
  210. theClass ifNotNil: [
  211. theClass package: thePackage.
  212. theClass superclass == aClass
  213. ifFalse: [ ^ self
  214. migrateClassNamed: className
  215. superclass: aClass
  216. instanceVariableNames: aCollection
  217. package: packageName ] ].
  218. ^ (self
  219. basicAddSubclassOf: aClass
  220. named: className
  221. instanceVariableNames: aCollection
  222. package: packageName) recompile; yourself
  223. !
  224. addTraitNamed: traitName package: packageName
  225. | theTrait thePackage |
  226. theTrait := Smalltalk globals at: traitName.
  227. thePackage := Package named: packageName.
  228. theTrait ifNotNil: [ ^ theTrait package: thePackage; recompile; yourself ].
  229. ^ self
  230. basicAddTraitNamed: traitName
  231. package: packageName
  232. !
  233. class: aClass instanceVariableNames: ivarNames
  234. self basicClass: aClass instanceVariableNames: ivarNames.
  235. SystemAnnouncer current
  236. announce: (ClassDefinitionChanged new
  237. theClass: aClass;
  238. yourself)
  239. !
  240. superclass: aClass subclass: className
  241. ^ self superclass: aClass subclass: className instanceVariableNames: '' package: nil
  242. !
  243. superclass: aClass subclass: className instanceVariableNames: ivarNames package: packageName
  244. | newClass |
  245. newClass := self addSubclassOf: aClass
  246. named: className instanceVariableNames: (self instanceVariableNamesFor: ivarNames)
  247. package: (packageName ifNil: [ 'unclassified' ]).
  248. SystemAnnouncer current
  249. announce: (ClassAdded new
  250. theClass: newClass;
  251. yourself).
  252. ^ newClass
  253. ! !
  254. !ClassBuilder methodsFor: 'class migration'!
  255. migrateClass: aClass superclass: anotherClass
  256. ^ self
  257. migrateClassNamed: aClass name
  258. superclass: anotherClass
  259. instanceVariableNames: aClass instanceVariableNames
  260. package: aClass package name
  261. !
  262. migrateClassNamed: className superclass: aClass instanceVariableNames: aCollection package: packageName
  263. | oldClass newClass tmp |
  264. tmp := 'new*', className.
  265. oldClass := Smalltalk globals at: className.
  266. newClass := self
  267. addSubclassOf: aClass
  268. named: tmp
  269. instanceVariableNames: aCollection
  270. package: packageName.
  271. self basicSwapClassNames: oldClass with: newClass.
  272. [ self copyClass: oldClass to: newClass ]
  273. on: Error
  274. do: [ :exception |
  275. self
  276. basicSwapClassNames: oldClass with: newClass;
  277. basicRemoveClass: newClass.
  278. exception resignal ].
  279. self
  280. rawRenameClass: oldClass to: tmp;
  281. rawRenameClass: newClass to: className.
  282. oldClass subclasses
  283. do: [ :each | self migrateClass: each superclass: newClass ].
  284. self basicRemoveClass: oldClass.
  285. SystemAnnouncer current announce: (ClassMigrated new
  286. theClass: newClass;
  287. oldClass: oldClass;
  288. yourself).
  289. ^ newClass
  290. !
  291. renameClass: aClass to: className
  292. self basicRenameClass: aClass to: className.
  293. "Recompile the class to fix potential issues with super sends"
  294. aClass recompile.
  295. SystemAnnouncer current
  296. announce: (ClassRenamed new
  297. theClass: aClass;
  298. yourself)
  299. ! !
  300. !ClassBuilder methodsFor: 'copying'!
  301. copyClass: aClass named: className
  302. | newClass |
  303. newClass := self
  304. addSubclassOf: aClass superclass
  305. named: className
  306. instanceVariableNames: aClass instanceVariableNames
  307. package: aClass package name.
  308. self copyClass: aClass to: newClass.
  309. SystemAnnouncer current
  310. announce: (ClassAdded new
  311. theClass: newClass;
  312. yourself).
  313. ^ newClass
  314. !
  315. copyClass: aClass to: anotherClass
  316. anotherClass comment: aClass comment.
  317. aClass methodDictionary valuesDo: [ :each |
  318. each methodClass = aClass ifTrue: [
  319. Compiler new install: each source forClass: anotherClass protocol: each protocol ] ].
  320. anotherClass setTraitComposition: aClass traitComposition.
  321. self basicClass: anotherClass class instanceVariables: aClass class instanceVariableNames.
  322. aClass class methodDictionary valuesDo: [ :each |
  323. each methodClass = aClass class ifTrue: [
  324. Compiler new install: each source forClass: anotherClass class protocol: each protocol ] ].
  325. anotherClass class setTraitComposition: aClass class traitComposition
  326. ! !
  327. !ClassBuilder methodsFor: 'method definition'!
  328. installMethod: aCompiledMethod forClass: aBehavior protocol: aString
  329. aCompiledMethod protocol: aString.
  330. aBehavior addCompiledMethod: aCompiledMethod.
  331. ^ aCompiledMethod
  332. ! !
  333. !ClassBuilder methodsFor: 'private'!
  334. basicAddSubclassOf: aClass named: aString instanceVariableNames: aCollection package: packageName
  335. <inlineJS: '
  336. return $core.addClass(aString, aClass, aCollection, packageName);
  337. '>
  338. !
  339. basicAddTraitNamed: aString package: anotherString
  340. <inlineJS: 'return $core.addTrait(aString, anotherString)'>
  341. !
  342. basicClass: aClass instanceVariableNames: aString
  343. self basicClass: aClass instanceVariables: (self instanceVariableNamesFor: aString)
  344. !
  345. basicClass: aClass instanceVariables: aCollection
  346. aClass isMetaclass ifFalse: [ self error: aClass name, ' is not a metaclass' ].
  347. aClass basicAt: 'iVarNames' put: aCollection
  348. !
  349. basicRemoveClass: aClass
  350. <inlineJS: '$core.removeClass(aClass)'>
  351. !
  352. basicRenameClass: aClass to: aString
  353. <inlineJS: '
  354. $globals[aString] = aClass;
  355. delete $globals[aClass.className];
  356. aClass.className = aString;
  357. '>
  358. !
  359. basicSwapClassNames: aClass with: anotherClass
  360. <inlineJS: '
  361. var tmp = aClass.className;
  362. aClass.className = anotherClass.className;
  363. anotherClass.className = tmp;
  364. '>
  365. !
  366. rawRenameClass: aClass to: aString
  367. <inlineJS: '
  368. $globals[aString] = aClass;
  369. '>
  370. ! !
  371. !ClassBuilder methodsFor: 'public'!
  372. setupClass: aClass
  373. self deprecatedAPI: 'Classes are now auto-inited.'
  374. ! !
  375. Object subclass: #ClassSorterNode
  376. instanceVariableNames: 'theClass level nodes'
  377. package: 'Kernel-Classes'!
  378. !ClassSorterNode commentStamp!
  379. I provide an algorithm for sorting classes alphabetically.
  380. See [Issue #143](https://lolg.it/amber/amber/issues/143).!
  381. !ClassSorterNode methodsFor: 'accessing'!
  382. getNodesFrom: aCollection
  383. | children others |
  384. children := #().
  385. others := #().
  386. aCollection do: [ :each |
  387. (each superclass = self theClass)
  388. ifTrue: [ children add: each ]
  389. ifFalse: [ others add: each ]].
  390. nodes:= children collect: [ :each |
  391. ClassSorterNode on: each classes: others level: self level + 1 ]
  392. !
  393. level
  394. ^ level
  395. !
  396. level: anInteger
  397. level := anInteger
  398. !
  399. nodes
  400. ^ nodes
  401. !
  402. theClass
  403. ^ theClass
  404. !
  405. theClass: aClass
  406. theClass := aClass
  407. ! !
  408. !ClassSorterNode methodsFor: 'visiting'!
  409. traverseClassesWith: aCollection
  410. "sort classes alphabetically Issue #143"
  411. aCollection add: self theClass.
  412. (self nodes sorted: [ :a :b | a theClass name <= b theClass name ]) do: [ :aNode |
  413. aNode traverseClassesWith: aCollection ].
  414. ! !
  415. !ClassSorterNode class methodsFor: 'instance creation'!
  416. on: aClass classes: aCollection level: anInteger
  417. ^ self new
  418. theClass: aClass;
  419. level: anInteger;
  420. getNodesFrom: aCollection;
  421. yourself
  422. ! !
  423. Trait named: #TBehaviorDefaults
  424. package: 'Kernel-Classes'!
  425. !TBehaviorDefaults methodsFor: 'accessing'!
  426. allInstanceVariableNames
  427. "Default for non-classes; to be able to send #allInstanceVariableNames to any class / trait."
  428. ^ #()
  429. !
  430. name
  431. ^ nil
  432. !
  433. superclass
  434. "Default for non-classes; to be able to send #superclass to any class / trait."
  435. ^ nil
  436. !
  437. traitUsers
  438. "Default for non-traits; to be able to send #traitUsers to any class / trait"
  439. ^ #()
  440. ! !
  441. !TBehaviorDefaults methodsFor: 'enumerating'!
  442. allSubclassesDo: aBlock
  443. "Default for non-classes; to be able to send #allSubclassesDo: to any class / trait."
  444. ! !
  445. !TBehaviorDefaults methodsFor: 'printing'!
  446. printOn: aStream
  447. self name
  448. ifNil: [ super printOn: aStream ]
  449. ifNotNil: [ :name | aStream nextPutAll: name ]
  450. ! !
  451. Trait named: #TBehaviorProvider
  452. package: 'Kernel-Classes'!
  453. !TBehaviorProvider commentStamp!
  454. I have method dictionary and organization.!
  455. !TBehaviorProvider methodsFor: 'accessing'!
  456. >> aString
  457. ^ self methodAt: aString
  458. !
  459. methodAt: aString
  460. ^ self methodDictionary at: aString
  461. !
  462. methodDictionary
  463. <inlineJS: 'var dict = $globals.HashedCollection._new();
  464. var methods = self.methods;
  465. Object.keys(methods).forEach(function(i) {
  466. if(methods[i].selector) {
  467. dict._at_put_(methods[i].selector, methods[i]);
  468. }
  469. });
  470. return dict'>
  471. !
  472. methodTemplate
  473. ^ String streamContents: [ :stream | stream
  474. write: 'messageSelectorAndArgumentNames'; lf;
  475. tab; write: '"comment stating purpose of message"'; lf;
  476. lf;
  477. tab; write: '| temporary variable names |'; lf;
  478. tab; write: 'statements' ]
  479. !
  480. methods
  481. ^ self methodDictionary values
  482. !
  483. methodsInProtocol: aString
  484. ^ self methods select: [ :each | each protocol = aString ]
  485. !
  486. organization
  487. ^ self basicAt: 'organization'
  488. !
  489. ownMethods
  490. "Answer the methods of the receiver that are not package extensions
  491. nor obtained via trait composition"
  492. ^ (self ownProtocols
  493. inject: OrderedCollection new
  494. into: [ :acc :each | acc, (self ownMethodsInProtocol: each) ])
  495. sorted: [ :a :b | a selector <= b selector ]
  496. !
  497. ownMethodsInProtocol: aString
  498. ^ (self methodsInProtocol: aString) select: [ :each | each methodClass = self ]
  499. !
  500. ownProtocols
  501. "Answer the protocols of the receiver that are not package extensions"
  502. ^ self protocols reject: [ :each |
  503. each match: '^\*' ]
  504. !
  505. packageOfProtocol: aString
  506. "Answer the package the method of receiver belongs to:
  507. - if it is an extension method, answer the corresponding package
  508. - else answer the receiver's package"
  509. (aString beginsWith: '*') ifFalse: [
  510. ^ self package ].
  511. ^ Package
  512. named: aString allButFirst
  513. ifAbsent: [ nil ]
  514. !
  515. protocols
  516. ^ self organization elements sorted
  517. !
  518. removeProtocolIfEmpty: aString
  519. self methods
  520. detect: [ :each | each protocol = aString ]
  521. ifNone: [ self organization removeElement: aString ]
  522. !
  523. selectors
  524. ^ self methodDictionary keys
  525. !
  526. traitComposition
  527. ^ (self basicAt: 'traitComposition') collect: [ :each | TraitTransformation fromJSON: each ]
  528. !
  529. traitCompositionDefinition
  530. ^ self traitComposition ifNotEmpty: [ :traitComposition |
  531. String streamContents: [ :str |
  532. str write: '{'.
  533. traitComposition
  534. do: [ :each | str write: each definition ]
  535. separatedBy: [ str write: '. ' ].
  536. str write: '}' ] ]
  537. ! !
  538. !TBehaviorProvider methodsFor: 'compiling'!
  539. addCompiledMethod: aMethod
  540. | oldMethod announcement |
  541. oldMethod := self methodDictionary
  542. at: aMethod selector
  543. ifAbsent: [ nil ].
  544. (self protocols includes: aMethod protocol)
  545. ifFalse: [ self organization addElement: aMethod protocol ].
  546. self basicAddCompiledMethod: aMethod.
  547. oldMethod ifNotNil: [
  548. self removeProtocolIfEmpty: oldMethod protocol ].
  549. announcement := oldMethod
  550. ifNil: [
  551. MethodAdded new
  552. method: aMethod;
  553. yourself ]
  554. ifNotNil: [
  555. MethodModified new
  556. oldMethod: oldMethod;
  557. method: aMethod;
  558. yourself ].
  559. SystemAnnouncer current
  560. announce: announcement
  561. !
  562. compile: aString protocol: anotherString
  563. ^ Compiler new
  564. install: aString
  565. forClass: self
  566. protocol: anotherString
  567. !
  568. recompile
  569. ^ Compiler new recompile: self
  570. !
  571. removeCompiledMethod: aMethod
  572. self basicRemoveCompiledMethod: aMethod.
  573. self removeProtocolIfEmpty: aMethod protocol.
  574. SystemAnnouncer current
  575. announce: (MethodRemoved new
  576. method: aMethod;
  577. yourself)
  578. !
  579. setTraitComposition: aTraitComposition
  580. <inlineJS: '$core.setTraitComposition(aTraitComposition._asJavaScriptObject(), self)'>
  581. ! !
  582. !TBehaviorProvider methodsFor: 'enumerating'!
  583. protocolsDo: aBlock
  584. "Execute aBlock for each method protocol with
  585. its collection of methods in the sort order of protocol name."
  586. | methodsByProtocol |
  587. methodsByProtocol := HashedCollection new.
  588. self methodDictionary valuesDo: [ :m |
  589. (methodsByProtocol at: m protocol ifAbsentPut: [ Array new ])
  590. add: m ].
  591. self protocols do: [ :protocol |
  592. aBlock value: protocol value: (methodsByProtocol at: protocol) ]
  593. ! !
  594. !TBehaviorProvider methodsFor: 'private'!
  595. basicAddCompiledMethod: aMethod
  596. <inlineJS: '$core.addMethod(aMethod, self)'>
  597. !
  598. basicRemoveCompiledMethod: aMethod
  599. <inlineJS: '$core.removeMethod(aMethod,self)'>
  600. ! !
  601. !TBehaviorProvider methodsFor: 'testing'!
  602. includesSelector: aString
  603. ^ self methodDictionary includesKey: aString
  604. ! !
  605. Trait named: #TMasterBehavior
  606. package: 'Kernel-Classes'!
  607. !TMasterBehavior commentStamp!
  608. I am the behavior on the instance-side of the browser.
  609. I define things like package, category, name, comment etc.
  610. as opposed to derived behaviors (metaclass, class trait, ...)
  611. that relate to me.!
  612. !TMasterBehavior methodsFor: 'accessing'!
  613. category
  614. ^ self package ifNil: [ 'Unclassified' ] ifNotNil: [ self package name ]
  615. !
  616. classTag
  617. "Every master behavior should define a class tag."
  618. ^ self subclassResponsibility
  619. !
  620. comment
  621. ^ (self basicAt: 'comment') ifNil: [ '' ]
  622. !
  623. comment: aString
  624. self basicAt: 'comment' put: aString.
  625. SystemAnnouncer current
  626. announce: (ClassCommentChanged new
  627. theClass: self;
  628. yourself)
  629. !
  630. enterOrganization
  631. Smalltalk ifNotNil: [
  632. self package isString ifTrue: [ self basicAt: 'pkg' put: (Package named: self package) ].
  633. self package organization addElement: self ]
  634. !
  635. leaveOrganization
  636. Smalltalk ifNotNil: [
  637. self package organization removeElement: self ]
  638. !
  639. name
  640. <inlineJS: 'return self.className'>
  641. !
  642. package
  643. ^ self basicAt: 'pkg'
  644. !
  645. package: aPackage
  646. | oldPackage |
  647. self package = aPackage ifTrue: [ ^ self ].
  648. oldPackage := self package.
  649. self
  650. leaveOrganization;
  651. basicAt: 'pkg' put: aPackage;
  652. enterOrganization.
  653. SystemAnnouncer current announce: (ClassMoved new
  654. theClass: self;
  655. oldPackage: oldPackage;
  656. yourself)
  657. !
  658. theNonMetaClass
  659. ^ self
  660. ! !
  661. !TMasterBehavior methodsFor: 'browsing'!
  662. browse
  663. Finder findClass: self
  664. ! !
  665. !TMasterBehavior methodsFor: 'converting'!
  666. asJavaScriptSource
  667. ^ '$globals.', self name
  668. ! !
  669. Object subclass: #Trait
  670. instanceVariableNames: ''
  671. package: 'Kernel-Classes'!
  672. !Trait methodsFor: 'accessing'!
  673. classTag
  674. ^ 'trait'
  675. !
  676. definition
  677. ^ String streamContents: [ :stream | stream
  678. write: 'Trait named: '; printSymbol: self name; lf;
  679. write: (self traitCompositionDefinition ifNotEmpty: [ :tcd | { String tab. 'uses: '. tcd. String lf }]);
  680. tab; write: 'package: '; print: self category ]
  681. !
  682. theMetaClass
  683. ^ nil
  684. !
  685. traitUsers
  686. ^ (self basicAt: 'traitUsers') copy
  687. ! !
  688. !Trait methodsFor: 'composition'!
  689. - anArray
  690. ^ self asTraitTransformation - anArray
  691. !
  692. @ anArrayOfAssociations
  693. ^ self asTraitTransformation @ anArrayOfAssociations
  694. ! !
  695. !Trait methodsFor: 'converting'!
  696. asTraitComposition
  697. ^ self asTraitTransformation asTraitComposition
  698. !
  699. asTraitTransformation
  700. ^ TraitTransformation on: self
  701. ! !
  702. !Trait class methodsFor: 'instance creation'!
  703. named: aString package: anotherString
  704. ^ ClassBuilder new addTraitNamed: aString package: anotherString
  705. !
  706. named: aString uses: aTraitCompositionDescription package: anotherString
  707. | trait |
  708. trait := self named: aString package: anotherString.
  709. trait setTraitComposition: aTraitCompositionDescription asTraitComposition.
  710. ^ trait
  711. ! !
  712. Object subclass: #TraitTransformation
  713. instanceVariableNames: 'trait aliases exclusions'
  714. package: 'Kernel-Classes'!
  715. !TraitTransformation commentStamp!
  716. I am a single step in trait composition.
  717. I represent one trait including its aliases and exclusions.!
  718. !TraitTransformation methodsFor: 'accessing'!
  719. addAliases: anArrayOfAssociations
  720. anArrayOfAssociations do: [ :each |
  721. | key |
  722. key := each key.
  723. aliases at: key
  724. ifPresent: [ self error: 'Cannot use same alias name twice.' ]
  725. ifAbsent: [ aliases at: key put: each value ] ].
  726. ^ anArrayOfAssociations
  727. !
  728. addExclusions: anArray
  729. exclusions addAll: anArray.
  730. ^ anArray
  731. !
  732. aliases
  733. ^ aliases
  734. !
  735. definition
  736. ^ String streamContents: [ :str |
  737. str print: self trait.
  738. self aliases ifNotEmpty: [ :al |
  739. str write: ' @ {'.
  740. al associations
  741. do: [ :each | str printSymbol: each key; write: ' -> '; printSymbol: each value ]
  742. separatedBy: [ str write: '. ' ].
  743. str write: '}' ].
  744. self exclusions ifNotEmpty: [ :ex |
  745. str write: ' - #('.
  746. ex asArray sorted
  747. do: [ :each | str write: each symbolPrintString allButFirst ]
  748. separatedBy: [ str space ].
  749. str write: ')' ] ]
  750. !
  751. exclusions
  752. ^ exclusions
  753. !
  754. trait
  755. ^ trait
  756. !
  757. trait: anObject
  758. trait := anObject
  759. ! !
  760. !TraitTransformation methodsFor: 'composition'!
  761. - anArray
  762. ^ self copy addExclusions: anArray; yourself
  763. !
  764. @ anArrayOfAssociations
  765. ^ self copy addAliases: anArrayOfAssociations; yourself
  766. ! !
  767. !TraitTransformation methodsFor: 'converting'!
  768. asJavaScriptObject
  769. ^ #{
  770. 'trait' -> self trait.
  771. 'aliases' -> self aliases.
  772. 'exclusions' -> self exclusions asArray sorted }
  773. !
  774. asJavaScriptSource
  775. ^ String streamContents: [ :str | str write: {
  776. '{trait: '. self trait asJavaScriptSource.
  777. self aliases ifNotEmpty: [ :al |
  778. {', aliases: '. al asJSONString} ].
  779. self exclusions ifNotEmpty: [ :ex |
  780. {', exclusions: '. ex asArray sorted asJavaScriptSource} ].
  781. '}' } ]
  782. !
  783. asTraitComposition
  784. ^ { self }
  785. !
  786. asTraitTransformation
  787. ^ self
  788. ! !
  789. !TraitTransformation methodsFor: 'copying'!
  790. postCopy
  791. aliases := aliases copy.
  792. exclusions := exclusions copy
  793. ! !
  794. !TraitTransformation methodsFor: 'initialization'!
  795. initialize
  796. super initialize.
  797. aliases := #{}.
  798. exclusions := Set new.
  799. trait := nil
  800. ! !
  801. !TraitTransformation class methodsFor: 'instance creation'!
  802. fromJSON: aJSObject
  803. ^ super new
  804. trait: (aJSObject at: #trait);
  805. addAliases: (Smalltalk readJSObject: (aJSObject at: #aliases ifAbsent: [#{}])) associations;
  806. addExclusions: (aJSObject at: #exclusions ifAbsent: [#()]);
  807. yourself
  808. !
  809. on: aTrait
  810. ^ super new trait: aTrait; yourself
  811. ! !
  812. Behavior setTraitComposition: {TBehaviorDefaults. TBehaviorProvider} asTraitComposition!
  813. Class setTraitComposition: {TMasterBehavior. TSubclassable} asTraitComposition!
  814. Trait setTraitComposition: {TBehaviorDefaults. TBehaviorProvider. TMasterBehavior} asTraitComposition!
  815. ! !
  816. !Array methodsFor: '*Kernel-Classes'!
  817. asTraitComposition
  818. "not implemented yet, noop atm"
  819. ^ self collect: [ :each | each asTraitTransformation ]
  820. ! !