src/lib/trait.slate

   1 prototypes define: #Trait &parents: {Cloneable}
   2   &slots: {#users -> IdentitySet new "The Trait or Traits object that use this one."
   3            }.
   4 "A Trait object is an individual protocol that exists for compile-time
   5 composition into Traits objects. In this way we can divide up protocols as many
   6 ways as conceptually appropriate without run-time overhead, and compile-time
   7 checks can verify completeness of the compositions.
   8
   9 The methods defined for traits are arbitrary multi-methods and can dispatch
  10 on anything. However, use of the traits object itself in such a method
  11 definition does not add a role to that object but just creates a place in the
  12 signature where it is indicated that the future composition result will have
  13 a role."
  14
  15 t@(Trait traits) new
  16 [t clone `setting: #{#users} to: {t users new}].
  17
  18 t@(Trait traits) noteUseBy: user@(Trait traits)
  19 [t users include: user].
  20
  21 t@(Trait traits) noteUseEndedBy: user@(Trait traits)
  22 [
  23   t users exclude: user.
  24   t users isEmpty ifTrue: [t finalize].
  25 ].
  26
  27 t@(Trait traits) notifyUsersOfChange
  28 [t users do: #handleChangedComponent `er].
  29
  30 t@(Trait traits) handleChangedComponent
  31 [
  32   t users do:
  33     [| :user | (user is: Trait) ifTrue: [user notifyUsersOfChange]
  34                                 ifFalse: [error: 'Recompilating concrete Trait users is not yet implemented.']]
  35 ].
  36
  37 t@(Trait traits) addMutatorForTraitSlot: name
  38 "Allow changes for slots whose type will always be Trait to automatically
  39 update the usage Set for that Trait and the old Trait, if any."
  40 [
  41   t addMutator:
  42     [| :user :trait |
  43      user trait ifNotNilDo: #(noteUseEndedBy: user) `er.
  44      user atSlotNamed: name put: trait.
  45      trait ifNotNil: [trait noteUseBy: user].
  46      trait] for: name
  47 ].
  48
  49 x@(Root traits) finalize [].
  50
  51 t@(Trait traits) services [overrideThis].
  52 "Answer the methods that are held for installation on composed results."
  53
  54 t@(Trait traits) flattened
  55 "Take the services that this Trait has, and turn them into a single concrete
  56 component Trait, thus flattening any compositions."
  57 [TraitComponent newFrom: t services].
  58
  59 t@(Trait traits) signatures [t services keySet].
  60 "The keys of the services are the relevant Signature objects."
  61 t@(Trait traits) methods [t services valueSet].
  62 "The values of the services are the actual methods to install."
  63
  64 t@(Trait traits) hasValidSignatures
  65 "Answers whether all of the signatures in the provided services actually
  66 dispatch at least in some way on the Trait(?)."
  67 "TODO: evaluate/improve the query for the role test"
  68 [
  69   t signatures allSatisfy:
  70     [| :sig | sig roles anySatisfy: #(t is: _) `er]
  71 ].
  72
  73 t@(Trait traits) hasValidServices
  74 [
  75   t hasValidSignatures /\
  76     [| check | check := True.
  77      t services keysAndValuesDo:
  78        [| :sig :m | check := check /\ [sig arity = m arity]].
  79      check]
  80 ].
  81
  82 t@(Trait traits) conflicts [overrideThis].
  83 "Answers those service associations which are inconsistent /and/ are not
  84 resolved here in an unambiguous way (say, by an override)."
  85 t@(Trait traits) hasConflicts [t conficts isEmpty not].
  86 "Answer whether there are any service definition conflicts."
  87
  88 t@(Trait traits) providedSelectors
  89 "Answers a set of all the selectors used in the service signatures."
  90 [t signatures collect: #selector `er].
  91
  92 t@(Trait traits) requiredSelectors
  93 "Answer all the selectors sent which should be defined on users of the Trait,
  94 but is not in the services selector set."
  95 [| requirements |
  96   requirements := Set new.
  97   t providedSelectors `cacheAs: #provisions.
  98   t services valuesDo:
  99     [| :m |
 100      (0 below: m arity) do:
 101        [| :index | requirements addAll:
 102          ((m allSelectorsSentToInputAt: index) difference: provisions)]].
 103   requirements
 104 ].
 105
 106 t@(Trait traits) isConcrete [t requiredSelectors isEmpty].
 107 t@(Trait traits) isAbstract [t isConcrete not].
 108
 109 t1@(Trait traits) conflictsWith: t2@(Trait traits)
 110 "Detects those Signatures which are bound to different Method objects in
 111 the two Trait objects."
 112 [| allServices |
 113   allServices := Dictionary new.
 114   {t1. t2} do:
 115     [| :base | base services keysAndValuesDo:
 116       [| :sig :m | (allServices at: sig ifAbsentPut: [Set new]) include: m]].
 117   allServices mapSelect: [| :sig :methods | methods size > 1]
 118 ].
 119
 120 t1@(Trait traits) = t2@(Trait traits)
 121 "Compare Trait objects by their services Mappings."
 122 [t1 services = t2 services].
 123
 124 t@(Trait traits) translate: sig for: target
 125 "This translates the convention of using the Trait object as place holder for
 126 the target installation object into the actual target intended Signature."
 127 [sig clone `setting: #{#roles} to: {sig roles copyReplace: t with: target}].
 128
 129 t@(Trait traits) installServicesOn: target
 130 [
 131   t services keysAndValuesDo:
 132     [| :sig :m | (t translate: sig for: target) defineAs: m]
 133 ].
 134
 135 x@(Root traits) speaks: t@(Trait traits)
 136 "Answer whether the given object has all of the services defined by the
 137 Trait object."
 138 [
 139   t services keysAndValuesDo:
 140     [| :sig :m targetSig | targetSig := (t translate: sig for: target).
 141      targetSig isDefined /\ [targetSig nearestMethod = m] ifFalse: [^ False]].
 142   True
 143 ].
 144
 145 t@(Trait traits) hasSubTrait: sub@(Trait traits)
 146 [overrideThis].
 147
 148 "TODO: this extension of is: to consider Trait composition is too conflating.
 149 x@(Root traits) is: t@(Trait traits)
 150 [x traits hasSubTrait: t].
 151 "
 152
 153 def@(Syntax MethodDefinition traits) asServiceOf: tr
 154 "A macro to transform a method definition into a service entry on the Trait
 155 object that the second argument should evaluate to (or be, if not a piece
 156 of syntax). It expands into a literal of the method object that became a
 157 service of the Trait."
 158 [| roles service |
 159   (tr is: Syntax Node) ifTrue: [tr := tr evaluate].
 160   (tr is: Trait) ifFalse: [error: 'The target for installation was not a Trait.'].
 161   roles := (def roles collect: #evaluate `er).
 162   (roles includes: tr) ifFalse: [error: 'The Trait is not dispatched upon.'].
 163   service := (tr services at: (Method Signature newNamed: def selector over: roles)
 164                         put: (def deepCopy as: Syntax Block) compile) unquoted.
 165   tr notifyUsersOfChange.
 166   service
 167 ].
 168
 169 prototypes define: #TraitComponent &parents: {Trait}
 170   &slots: {#services -> Dictionary new "Maps Signatures to Method objects."
 171            }.
 172
 173 t@(TraitComponent traits) newFrom: map@(Mapping traits)
 174 "Create a TraitComponent from valid signature->method associations."
 175 "TODO: check roles in the signatures?"
 176 [
 177   map := map mapSelect:
 178     [| :key :value | (key is: Method Signature) /\ [value is: Method]].
 179   t new `>> [services := map as: t services. ]
 180 ].
 181
 182 TraitComponent traits compareAndHashUsingSlots: #{#services}.
 183
 184 t@(TraitComponent traits) conflicts
 185 "A component cannot conflict with itself because of the Dictionary basis."
 186 [Set new &capacity: 0].
 187
 188 t@(TraitComponent traits) hasSubTrait: sub@(Trait traits)
 189 [False].
 190
 191 t@(TraitComponent traits) flattened [t].
 192
 193 prototypes define: #TraitSum &parents: {Trait} &slots: {#bases -> Set new}.
 194 "A symmetric sum, where no precedence is given to any of the bases."
 195
 196 t@(TraitSum traits) newFor: bases
 197 [
 198   t new `>>
 199     [| :newT |
 200      bases := bases as: t bases.
 201      bases do: #(noteUseBy: t) `er. ]
 202 ].
 203
 204 TraitSum traits compareAndHashUsingSlots: #{#bases}.
 205
 206 t1@(Trait traits) + t2@(Trait traits)
 207 [TraitSum newFor: {t1. t2}].
 208
 209 ts@(TraitSum traits) + t@(Trait traits)
 210 [ts newFor: (ts bases copyWith: t)].
 211
 212 t@(Trait traits) + ts@(TraitSum traits)
 213 [ts newFor: (ts bases copyWith: t)].
 214
 215 ts@(TraitSum traits) conflicts
 216 "Detects those Signatures which are bound to different Method objects in
 217 different bases."
 218 [| allServices |
 219   allServices := Dictionary new.
 220   ts bases do:
 221     [| :base | base services keysAndValuesDo:
 222       [| :sig :m | (allServices at: sig ifAbsentPut: [Set new]) include: m]].
 223   allServices mapSelect: [| :sig :methods | methods size > 1]
 224 ].
 225
 226 ts@(TraitSum traits) services
 227 [ts bases reduce: [| :b1 :b2 | b1 services union: b2 services]].
 228
 229 ts@(TraitSum traits) hasSubTrait: t@(Trait traits)
 230 [(ts bases includes: t) \/ [ts bases anySatisfy: #(hasSubTrait: t) `er]].
 231
 232 prototypes define: #TraitModifier &parents: {Trait} &slots: {#base -> Trait}.
 233 TraitModifier addMutatorForTraitSlot: #base.
 234
 235 tm@(TraitModifier traits) finalize
 236 [tm base := Nil. ].
 237
 238 TraitModifier traits compareAndHashUsingSlots: #{#base}.
 239
 240 tm@(TraitModifier traits) hasSubTrait: t@(Trait traits)
 241 [tm base = t \/ [tm base hasSubTrait: t]].
 242
 243 prototypes define: #TraitOverride &parents: {TraitModifier}
 244   &slots: {#layer -> Trait}.
 245 "A linear overlay composition of other Trait objects."
 246
 247 TraitOverride addMutatorForTraitSlot: #overlay.
 248
 249 TraitOverride traits compareAndHashUsingSlots: #{#base. #overlay}.
 250
 251 to@(TraitOverride traits) newBasedOn: base layering: overlay
 252 [to new `>> [base := base. overlay := overlay. ]].
 253
 254 t@(Trait traits) as: to@(TraitOverride traits)
 255 [to new `>> [overlay := overlay. ]].
 256
 257 to@(TraitOverride traits) newFrom: map@(Mapping traits)
 258 [(TraitComponent newFrom: map) as: to].
 259
 260 base@(Trait traits) ** layer@(Trait traits)
 261 [TraitOverride newBasedOn: base layering: layer].
 262
 263 to@(TraitOverride traits) finalize
 264 [
 265   resend.
 266   to overlay := Nil.
 267 ].
 268
 269 to@(TraitOverride traits) services
 270 "Apply the overlay to the underlying Trait."
 271 [to overlay services over: to base services].
 272
 273 to@(TraitOverride traits) conflicts
 274 "Count the conflicts remaining after applying the overlay."
 275 [(to services as: TraitComponent) conflicts].
 276
 277 to@(TraitOverride traits) hasSubTrait: t@(Trait traits)
 278 [to overlay = t \/ [to overlay hasSubTrait: t] \/ [resend]].
 279
 280 prototypes define: #TraitExclusion &parents: {TraitModifier}
 281   &slots: {#exclusion -> Trait}.
 282 TraitExclusion addMutatorForTraitSlot: #exclusion.
 283
 284 te@(TraitExclusion traits) newBasedOn: base excluding: exclusion
 285 [te new `>> [base := base. exclusion := exclusion. ]].
 286
 287 TraitExclusion traits compareAndHashUsingSlots: #{#base. #exclusion}.
 288
 289 t@(Trait traits) as: te@(TraitExclusion traits)
 290 [te new `>> [exclusion := exclusion. ]].
 291
 292 te@(TraitExclusion traits) newFrom: map@(Mapping traits)
 293 [(TraitComponent newFrom: map) as: te].
 294
 295 base@(Trait traits) - exclusion@(Trait traits)
 296 [TraitExclusion newBasedOn: base excluding: exclusion].
 297
 298 te@(TraitExclusion traits) services
 299 [
 300   te base services mapReject:
 301     [| :sig :m | (te exclusion services) includesKey: sig]
 302 ].
 303
 304 te@(TraitExclusion traits) finalize
 305 [
 306   resend.
 307   te exclusion := Nil.
 308 ].
 309
 310 te@(TraitExclusion traits) hasSubTrait: t@(Trait traits)
 311 [te exclusion = t \/ [te exclusion hasSubTrait: t] \/ [resend]].
 312
 313 prototypes define: #TraitWithAlias &parents: {TraitModifier}
 314   &slots: {#aliases -> Dictionary new "Map from alias Signatures to original."}.
 315
 316 TraitWithAlias traits compareAndHashUsingSlots: #{#base. #aliases}.
 317
 318 ta@(TraitWithAlias traits) newBasedOn: base aliasing: map
 319 [ta new `>> [base := base. aliases := map as: ta aliases. ]].
 320
 321 base@(Trait traits) aliasing: map
 322 [TraitWithAlias newBasedOn: base aliasing: map].
 323
 324 prototypes define: #TraitWrapper &parents: {Trait}
 325   &slots: {#basis. #cachedServices}.
 326 "A TraitWrapper allows non-Trait objects to participate in Trait compositions."
 327
 328 tw@(TraitWrapper traits) newFor: obj
 329 [tw new `>> [basis := obj. cachedServices := Nil. ]].
 330
 331 obj as: tw@(TraitWrapper traits)
 332 [tw newFor: obj].
 333
 334 tw@(TraitWrapper traits) services
 335 "TODO: speed this up by not looking up signatures for methods stored in
 336 other trait objects that the basis object uses."
 337 [
 338   tw cachedServices ifNil:
 339     [tw cachedServices := tw basis methods reverseProject: #signature `er ]
 340 ].
 341
 342 tw@(TraitWrapper traits) hasSubTrait: t@(Trait traits)
 343 [tw basis is: t].