src/core/derivable.slate

   1 d@(Root traits) traitsTally
   2 [
   3   d traitsWindow _delegates size
   4 ].
   5
   6 d@(Derivable traits) traitsReverseDo: block
   7 "Least important to most important traits"
   8 [| index tally |
   9   index := 0.
  10   tally := d traitsTally.
  11   [index = tally]
  12     whileFalse:
  13       [block apply*, (d traitsWindow _delegates at: index).
  14        index += 1]
  15 ].
  16
  17 d@(Derivable traits) traitsDo: block
  18 "Most important to least important traits"
  19 [| index |
  20   index := d traitsTally.
  21   [index = 0]
  22     whileFalse:
  23       [index -= 1.
  24        block apply*, (d traitsWindow _delegates at: index)]
  25 ].
  26
  27 d@(Derivable traits) orderTraits &mixins: mixins
  28 "Answers an array of the traits objects in order..."
  29 [| tally order index fixedOrder |
  30   mixins `defaultsTo: #{}.
  31   "TODO: Bootstrap-replace these two lines with the third (commented):"
  32   tally := d traitsTally.
  33   mixins do: [| :mixin | tally += mixin traitsTally].
  34   "tally := mixins gather: [| :mixin :tally | tally + mixin traitsTally] &initial: d traitsTally."
  35   order := mixins newSize: tally.
  36
  37   index := mixins size + 1.
  38
  39   order at: 0 put: d traits.
  40   mixins doWithIndex: [| :each :i | order at: i + 1 put: each traits].
  41
  42   d traitsDo:
  43     [| :traits |
  44      (order identityIncludes: traits)
  45        ifFalse:
  46          [order at: index put: traits. index += 1]].
  47
  48   mixins do:
  49     [| :mixin |
  50      mixin traitsDo:
  51        [| :traits |
  52         (order identityIncludes: traits)
  53           ifFalse:
  54             [order at: index put: traits. index += 1]]].
  55
  56   (order first: index) reversed
  57
  58 ].
  59
  60 "this one ignores the d object"
  61 d@(Derivable traits) orderTraits: mixins
  62 [| tally order index fixedOrder |
  63   tally := mixins size.
  64   mixins do: [| :mixin | tally += mixin traitsTally].
  65   order := Array newSize: tally.
  66
  67   mixins doWithIndex: [| :each :i | order at: i put: each traits].
  68
  69   index := mixins size.
  70
  71   mixins do:
  72     [| :mixin |
  73      mixin traitsDo:
  74        [| :traits |
  75         (order identityIncludes: traits)
  76           ifFalse:
  77             [order at: index put: traits. index += 1]]].
  78
  79   (order first: index) reversed
  80
  81 ].
  82
  83 d@(Derivable traits) derive &mixins: mixins &rejects: rejectSlots
  84 "Constructs and returns a new prototype based on the argument with a new
  85 Traits object that delegates to the old one. If mixins are specified,
  86 the Traits object inherits from each extra object's Traits in right-to-left
  87 order. Also, the new prototype gains slots from the other objects involved,
  88 except for those named rejects."
  89 [| newWindow newObj |
  90   mixins `defaultsTo: #{}.
  91   rejectSlots `defaultsTo: #{}.
  92   newWindow := Cloneable clone.
  93   newWindow restrictDelegation.
  94   "newWindow _delegates: (d orderTraits &mixins: mixins)."
  95   newWindow _delegates: (d orderTraits: mixins).
  96   newWindow addDelegate: Cloneable clone. "the traits for this object"
  97   newObj := d clone.
  98   newObj _delegates: {newWindow}.
  99   mixins do: #(newObj addSlotsFrom: _) `er.
 100   rejectSlots do: #(newObj removeSlot: _) `er.
 101   newObj
 102 ].
 103
 104 x@(Root traits) addPrototype: protoName &parents: parents &immutable: immutable &basedOn: basedOn
 105 "Creates a new prototype with the given name, handles derive calls
 106 transparently, and sets the traits name slot to the name for convenience."
 107 [| newProto |
 108   immutable `defaultsTo: False.
 109   basedOn `defaultsTo: Cloneable.
 110   parents `defaultsTo: {Cloneable}.
 111   parents size = 0 ifTrue: [error: 'Parent objects must be supplied.'].
 112   "newProto := (parents at: 0) derive &mixins: (parents allButFirst: 1)."
 113   newProto := basedOn derive &mixins: parents.
 114   immutable ifTrue: [newProto := newProto immutably].
 115   "ensureSlot:is: may return the old value if =, but always returns what
 116   is installed after the method is done."
 117   (x hasSlotNamed: protoName)
 118     ifTrue: [| oldProto |
 119              oldProto := x atSlotNamed: protoName.
 120              newProto := x ensureSlot: protoName is: newProto
 121                unlessSatisfies:
 122                  [| :old oldParents newParents |
 123                   "Modified equality using == over each delegate pair."
 124                   oldParents := old traitsWindow _delegates.
 125                   newParents := newProto traitsWindow _delegates.
 126                   oldParents size = newParents size
 127                     /\ [oldParents keySet allSatisfy:
 128                           [| :index | (oldParents at: index) == (newParents at: index)]]].
 129              newProto traitsWindow _delegates at: newProto traitsWindow _delegates size - 1 put: oldProto traits.
 130              newProto]
 131     ifFalse: [x addImmutableSlot: protoName valued: newProto].
 132   (x atSlotNamed: protoName) `>> [printName := protoName name. ]
 133 ].
 134
 135 x@(Root traits) printName: name
 136 "Add a printName slot on the object's traitsWindow and its traits.
 137 Override as necessary."
 138 [
 139   x traitsWindow addImmutableSlot: #printNameWindow valued: name.
 140   x traits addImmutableSlot: #printNameTraits valued: name.
 141 ].
 142
 143 x@(Root traits) printName
 144 [
 145   `conditions: (
 146     [x hasSlotNamed: #printNameWindow] -> [x printNameWindow ; ' traitsWindow'].
 147     [x hasSlotNamed: #printNameTraits] -> [x printNameTraits ; ' traits']
 148   ) otherwise: [x traitsWindow printNameWindow]
 149 ].
 150
 151 x@(Root traits) printDelegates
 152 [
 153   x traitsWindow _delegates do: [| :d | inform: d printName].
 154 ].
 155
 156 x@(Root traits) addPrototype: protoName derivedFrom: parents &basedOn: basedOn
 157 "Answer addPrototype:derivedFrom: with a default single parent of Cloneable."
 158 [x addPrototype: protoName &parents: parents &basedOn: basedOn].
 159
 160 x@(Root traits) define: slotName recursivelyFrom: builder
 161 "Creates a conservative new immutable slot holding the results of the block.
 162 If such a slot already exists, recursively add slots from the built object
 163 with their values in cases where the slots do not already exist in the
 164 existing object. This is essentially a conservative object-slot tree builder."
 165 [| new |
 166   new := builder do.
 167   (x hasSlotNamed: slotName)
 168     ifTrue:
 169       [(x atSlotNamed: slotName)
 170         ifNil: [x atSlotNamed: slotName put: new]
 171         ifNotNilDo: #(addSlotsFromRecursively: new) `er]
 172     ifFalse: [x addImmutableSlot: slotName valued: new].
 173   x atSlotNamed: slotName
 174 ].
 175
 176 x@(Root traits) define: slotName using: builder
 177 "Defines a new slot based on the result of running a block of code."
 178 [| result |
 179   result := builder do.
 180   x addImmutableSlot: slotName valued: result.
 181   result
 182 ].
 183
 184 x@(Root traits) define: protoName &parents: parents &slots: slotSpecs
 185   &builder: builder &namespace: ns &owner: obj &immutable: immutable
 186   &basedOn: basedOn
 187 "Answer addPrototype:derivedFrom: with a default single parent of Cloneable."
 188 [| proto |
 189   immutable `defaultsTo: False.
 190   slotSpecs `defaultsTo: #{}.
 191   proto := builder ifNil: [x addPrototype: protoName &parents: parents &immutable: immutable &basedOn: basedOn]
 192                    ifNotNil: [x define: protoName using: builder].
 193   slotSpecs do:
 194     [| :each |
 195      each ifNotNil: [(each is: Association)
 196          ifTrue: [(immutable ifTrue: [#addImmutableSlot:valued:] ifFalse: [#addSlot:valued:]) sendTo: {proto. each key. each value}]
 197          ifFalse: [(immutable ifTrue: [#addImmutableSlot:] ifFalse: [#addSlot:]) sendTo: {proto. each}]]].
 198   builder ifNil:
 199     [ns
 200       ifNil: [(x isSameAs: Namespace) /\
 201                 [(#surroundings findOn: {x}) ifNil: [True] ifNotNilDo: [| :m | (m apply*, proto) == x]]
 202                 ifTrue: [[| :_ | x] asMethod: #surroundings on: {proto traits}]]
 203       ifNotNil: [[| :_ | ns] asMethod: #surroundings on: {proto traits}].
 204      obj ifNotNil: [[| :_ | obj] asMethod: #owner on: {proto traits}]].
 205   proto
 206 ].
 207
 208 x@(Root traits) defineOddball: name &parents: parents
 209 "Makes a new Oddball."
 210 "TODO: handle the &parents: option."
 211 [x define: name &builder: [Oddball clone]].
 212
 213 x@(Root traits) undefine: name
 214 "Removes a previous slot definition."
 215 [
 216   x removeSlot: name
 217 ].
 218
 219 x@(Cloneable traits) instancesSetting: slotNames to: values
 220 [
 221   values collect: [| :columnValues newX |
 222     newX := x new.
 223     slotNames with: columnValues do:
 224       [| :slotName :slotValue | newX atSlotNamed: slotName put: slotValue].
 225     newX]
 226 ].
 227
 228 x@(Root traits) commentTemplate
 229 "Answers a basic comment as a String for the object based on its definition."
 230 [| slotNames delegateNames |
 231   slotNames := x slotNames.
 232   [| :result |
 233    result ; x printName asAn capitalize ; ' is ' ; x traits printName asAn ; '.\n'.
 234    x traitsTally > 1
 235      ifTrue:
 236        [result ; 'Mixins: '.
 237         x traitsDo: [| :trait | result ; trait printName ; ', '].
 238         result ; '\n'].
 239    (#size findsSameMethodOn: {x} asOn: {Array})
 240      ifTrue: [result ; 'It has indexable slots.\n'].
 241    slotNames isEmpty
 242      ifTrue: [result ; 'It has no named slots.']
 243      ifFalse:
 244        [result ; 'It has named slots: '.
 245         slotNames do:
 246           [| :name val |
 247            result ; name name.
 248            (val := x atSlotNamed: name)
 249              ifNotNil: [result ; ' -> ' ; val printString].
 250            result ; '. ']].
 251    result ; '\n'
 252    ] writingAs: ''
 253 ].