123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251 |
- Smalltalk createPackage: 'Trapped-Backend'!
- (Smalltalk packageAt: 'Trapped-Backend') imports: {'lyst/Lyst'}!
- 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.' ].
- ! !
- AxonInterest subclass: #InterestedInTrapPath
- instanceVariableNames: ''
- package: 'Trapped-Backend'!
- !InterestedInTrapPath methodsFor: 'testing'!
- accepts: anAspect
- ^anAspect size <= aspect size and: [anAspect = (aspect copyFrom: 1 to: anAspect size)]
- ! !
- AxonInterest 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: #TrappedPosition
- instanceVariableNames: 'path model'
- package: 'Trapped-Backend'!
- !TrappedPosition methodsFor: 'accessing'!
- model
- ^model
- !
- path
- ^path
- !
- path: anArray model: aTrappedMW
- path := anArray.
- model := aTrappedMW
- ! !
- !TrappedPosition methodsFor: 'action'!
- modify: aBlock
- self model modify: self path do: aBlock
- !
- read: aBlock
- self model read: self path do: aBlock
- !
- watch: aBlock
- self model axon addInterest: (self
- interestOn: self path
- block: [ self read: aBlock ])
- ! !
- !TrappedPosition methodsFor: 'private'!
- interestOn: anAspect block: aBlock
- (anAspect notEmpty and: [ anAspect last isNil ])
- ifTrue: [ ^ InterestedInTrapPathSubtree new aspect: anAspect allButLast block: aBlock ]
- ifFalse: [ ^ InterestedInTrapPath new aspect: anAspect block: aBlock ]
- ! !
- AxonizedObject subclass: #Trapper
- instanceVariableNames: 'payload'
- package: 'Trapped-Backend'!
- !Trapper commentStamp!
- A portmanteau of 'Trapped wrapper', I am base class for model objects wrapped by Trapped.
- Wrapped object is indexed by #('string-at-index' #selector numeric-at-index) array paths. Operations using this indexing are:
- - `read:do:` to get the indexed content
- - `modify:do:` to get and modify the indexed content, and
- - (not any more) `watch:do:` to subscribe to changes of the indexed content.
- 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:
- - axon: (with a subclass of `Axon`)
- - model: (with a wrapped object, after `axon:`)!
- !Trapper methodsFor: 'accessing'!
- model: anObject
- payload := anObject.
- self axon changedAll
- ! !
- !Trapper methodsFor: 'action'!
- modify: path do: aBlock
- self subclassResponsibility
- !
- read: path do: aBlock
- self subclassResponsibility
- ! !
- Trapper subclass: #DirectTrapper
- instanceVariableNames: ''
- package: 'Trapped-Backend'!
- !DirectTrapper commentStamp!
- I am Trapper that directly manipulate
- the wrapped model object.!
- !DirectTrapper 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)
- ! !
- Trapper subclass: #IsolatingTrapper
- instanceVariableNames: ''
- package: 'Trapped-Backend'!
- !IsolatingTrapper commentStamp!
- I am Trapper that guards access
- to the wrapped model object via Isolator.
- IOW, read:do: gets always its own deep copy,
- modify:do: is not reentrant
- and upon writing the written part is deep-copied as well
- (so modifier does not hold the source of truth
- and can change it later).
- This also means, a wrapped object and all its parts
- must understand `#deepCopy`.!
- !IsolatingTrapper methodsFor: 'accessing'!
- model: anObject
- super model: (Isolator on: anObject)
- ! !
- !IsolatingTrapper 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
- ! !
- !SequenceableCollection methodsFor: '*Trapped-Backend'!
- asEavModel
- | model |
- model := EavModel new.
- model getBlock: [ :anObject | anObject atLyst: self ifAbsent: [ nil ] ].
- self isEmpty ifFalse: [
- model putBlock: [ :anObject :value | anObject atLyst: self ifAbsent: [ nil ] put: value ]].
- ^model
- ! !
|