123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251 |
- Smalltalk createPackage: 'Trapped-Backend'!
- Object subclass: #EavModel
- instanceVariableNames: 'getBlock putBlock'
- package: 'Trapped-Backend'!
- !EavModel commentStamp!
- External actor value model.!
- !EavModel methodsFor: 'accessing'!
- getBlock: aBlock
- getBlock := aBlock
- !
- on: anObject
- "Returns value of model applied on object"
- ^getBlock value: anObject
- !
- on: anObject put: anObject2
- "Puts a value via model applied on object"
- ^putBlock value: anObject value: anObject2
- !
- putBlock: aBlock
- putBlock := aBlock
- ! !
- !EavModel methodsFor: 'initialization'!
- initialize
- super initialize.
- getBlock := [ self error: 'No getter block.' ].
- putBlock := [ self error: 'No putter block.' ].
- ! !
- AxonInterestBase subclass: #InterestedInTrapPath
- instanceVariableNames: ''
- package: 'Trapped-Backend'!
- !InterestedInTrapPath methodsFor: 'testing'!
- accepts: anAspect
- ^anAspect size <= aspect size and: [anAspect = (aspect copyFrom: 1 to: anAspect size)]
- ! !
- AxonInterestBase subclass: #InterestedInTrapPathSubtree
- instanceVariableNames: ''
- package: 'Trapped-Backend'!
- !InterestedInTrapPathSubtree methodsFor: 'testing'!
- accepts: anAspect
- ^anAspect size <= aspect size
- ifTrue: [anAspect = (aspect copyFrom: 1 to: anAspect size)]
- ifFalse: [aspect = (anAspect copyFrom: 1 to: aspect size)]
- ! !
- Object subclass: #Isolator
- instanceVariableNames: 'root'
- package: 'Trapped-Backend'!
- !Isolator methodsFor: 'accessing'!
- root
- ^root
- !
- root: anObject
- root := anObject
- ! !
- !Isolator methodsFor: 'action'!
- model: anEavModel modify: aBlock
- | newValue |
- newValue := aBlock value: (anEavModel on: self).
- anEavModel on: self put: newValue deepCopy
- !
- model: anEavModel read: aBlock
- aBlock value: (anEavModel on: self) deepCopy
- ! !
- !Isolator class methodsFor: 'instance creation'!
- on: anObject
- ^self new root: anObject
- ! !
- Object subclass: #ListKeyedEntity
- instanceVariableNames: 'axon payload'
- package: 'Trapped-Backend'!
- !ListKeyedEntity commentStamp!
- I am base class for #('string-at-index' #selector numeric-at-index)-array-path-keyed entities,
- that moderate access to the wrapped model object via read;do and modify:do:
- and allow pub-sub via watch:do:.
- The wrapped model can be any smalltalk object.
- My subclasses need to provide implementation for:
- - read:do:
- - modify:do:
- and must issue these calls when initializing:
- - model: (with a wrapped object)
- - axon: (with a subclass of `AxonBase`)!
- !ListKeyedEntity methodsFor: 'accessing'!
- axon
- ^ axon
- !
- axon: anAxon
- axon := anAxon
- interestFactory: [ :description :block |
- (description notEmpty and: [ description last isNil ])
- ifTrue: [ InterestedInTrapPathSubtree new aspect: description allButLast block: block; yourself ]
- ifFalse: [ InterestedInTrapPath new aspect: description block: block; yourself ]];
- yourself
- !
- model: anObject
- payload := anObject.
- self changed: #()
- ! !
- !ListKeyedEntity methodsFor: 'action'!
- changed: anAspect
- self axon changed: anAspect
- !
- watch: path do: aBlock
- self axon on: path hook: [ self read: path do: aBlock ]
- ! !
- ListKeyedEntity subclass: #ListKeyedDirectEntity
- instanceVariableNames: ''
- package: 'Trapped-Backend'!
- !ListKeyedDirectEntity commentStamp!
- I am ListKeyedEntity that directly manipulate
- the wrapped model object.!
- !ListKeyedDirectEntity methodsFor: 'action'!
- modify: path do: aBlock
- | newValue eavModel |
- eavModel := path asEavModel.
- newValue := aBlock value: (eavModel on: payload).
- [ eavModel on: payload put: newValue ] ensure: [ self changed: path ]
- !
- read: path do: aBlock
- | eavModel |
- eavModel := path asEavModel.
- aBlock value: (eavModel on: payload)
- ! !
- ListKeyedEntity subclass: #ListKeyedIsolatedEntity
- instanceVariableNames: ''
- package: 'Trapped-Backend'!
- !ListKeyedIsolatedEntity commentStamp!
- I am ListKeyedEntity that guards access
- to the wrapped model object via Isolator.!
- !ListKeyedIsolatedEntity methodsFor: 'accessing'!
- model: anObject
- super model: (Isolator on: anObject)
- ! !
- !ListKeyedIsolatedEntity methodsFor: 'action'!
- modify: path do: aBlock
- | eavModel |
- eavModel := ({{#root}},path) asEavModel.
- [ payload model: eavModel modify: aBlock ] ensure: [ self changed: path ]
- !
- read: path do: aBlock
- | eavModel |
- eavModel := ({{#root}},path) asEavModel.
- payload model: eavModel read: aBlock
- ! !
- !Array methodsFor: '*Trapped-Backend'!
- asTrapAtPut: value sendTo: anObject
- ^anObject perform: (self first, ':') asSymbol withArguments: { value }
- !
- asTrapAtSendTo: anObject
- ^[anObject perform: self first] on: MessageNotUnderstood do: [^nil]
- ! !
- !Number methodsFor: '*Trapped-Backend'!
- asTrapAtPut: value sendTo: anObject
- ^anObject at: self put: value
- !
- asTrapAtSendTo: anObject
- ^anObject ifNotNil: [ anObject at: self ifAbsent: [nil] ]
- ! !
- !Object methodsFor: '*Trapped-Backend'!
- asTrapAtPut: value sendTo: anObject
- self error: 'Trapped cannot put at ', self class name, ' type key.'
- !
- asTrapAtSendTo: anObject
- ^nil
- ! !
- !SequenceableCollection methodsFor: '*Trapped-Backend'!
- asEavModel
- | model |
- model := EavModel new.
- model getBlock: [ :anObject |
- self inject: anObject into: [ :soFar :segment |
- segment asTrapAtSendTo: soFar ]].
- self isEmpty ifFalse: [
- model putBlock: [ :anObject :value | | penultimate |
- penultimate := self allButLast inject: anObject into: [ :soFar :segment |
- soFar ifNotNil: [ segment asTrapAtSendTo: soFar ]].
- self last asTrapAtPut:value sendTo: penultimate ]].
- ^model
- ! !
- !String methodsFor: '*Trapped-Backend'!
- asTrapAtPut: value sendTo: anObject
- ^anObject at: self put: value
- !
- asTrapAtSendTo: anObject
- ^anObject ifNotNil: [ anObject at: self ifAbsent: [nil] ]
- ! !
|