trapped/st/Trapped-Backend.st

Smalltalk current createPackage: 'Trapped-Backend' properties: #{}!
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.' ].
! !

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: #KeyedPubSubBase
	instanceVariableNames: ''
	package: 'Trapped-Backend'!
!KeyedPubSubBase commentStamp!
I represent a pub-sub based on a key.
I manage key-block subscriptions as well as running blocks that are dirty.
The subscription objects are reponsible of decision if the change is relevant for them.
Subscription object must be subclasses of KeyedSubscriptionBase.

My subclasses must provide implementation for:
	subscriptionKey:block: (factory method for creating appropriate subscription object)

as well as bookkeeping of subscriptions:
	add:
    do:
    clean
    (optionally) run!

!KeyedPubSubBase methodsFor: 'action'!

changed: key
	| needsToRun |
    needsToRun := false.
	self do: [ :each |
		(each accepts: key) ifTrue: [
			each flag.
            needsToRun := true.
		]
	].
	self dirty: needsToRun
!

dirty: aBoolean
	aBoolean ifTrue: [[ self run ] fork]
!

on: key hook: aBlock
	self add: (self subscriptionKey: key block: aBlock) flag.
   	self dirty: true
!

run
	| needsClean |
    needsClean := false.
	self do: [ :each |
		each isFlagged ifTrue: [
            each run.
            each isEnabled ifFalse: [ needsClean := true ]
        ]
	].
    needsClean ifTrue: [ self clean ]
!

subscriptionKey: key block: aBlock
    "Should return subclass of KeyedSubscriptionBase"
    self subclassReponsibility
! !

KeyedPubSubBase subclass: #ListKeyedPubSubBase
	instanceVariableNames: ''
	package: 'Trapped-Backend'!
!ListKeyedPubSubBase commentStamp!
I am base class list-keyed pub-sub.

My subclasses need to provide implementation for:
	add:
    do:
    clean
    (optionally) run!

!ListKeyedPubSubBase methodsFor: 'action'!

subscriptionKey: key block: aBlock
	^ListKeyedSubscription new key: key block: aBlock; yourself
! !

ListKeyedPubSubBase subclass: #SimpleListKeyedPubSub
	instanceVariableNames: 'queue'
	package: 'Trapped-Backend'!

!SimpleListKeyedPubSub methodsFor: 'accessing'!

add: aSubscription
	queue add: aSubscription.
! !

!SimpleListKeyedPubSub methodsFor: 'bookkeeping'!

clean
	queue := queue select: [ :each | each isEnabled ]
! !

!SimpleListKeyedPubSub methodsFor: 'enumeration'!

do: aBlock
	queue do: aBlock
! !

!SimpleListKeyedPubSub methodsFor: 'initialization'!

initialize
    super initialize.
	queue := OrderedCollection new
! !

Error subclass: #KeyedPubSubUnsubscribe
	instanceVariableNames: ''
	package: 'Trapped-Backend'!
!KeyedPubSubUnsubscribe commentStamp!
SIgnal me from the subscription block to unsubscribe it.!

Object subclass: #KeyedSubscriptionBase
	instanceVariableNames: 'key actionBlock flagged'
	package: 'Trapped-Backend'!

!KeyedSubscriptionBase methodsFor: 'accessing'!

flag
	flagged := true
!

key: anObject block: aBlock
	key := anObject.
    actionBlock := aBlock
! !

!KeyedSubscriptionBase methodsFor: 'action'!

run
	[[ actionBlock value ] ensure: [ flagged := false ]]
    on: KeyedPubSubUnsubscribe do: [ actionBlock := nil ]
! !

!KeyedSubscriptionBase methodsFor: 'initialization'!

initialize
	super initialize.
    key := nil.
    actionBlock := nil.
    flagged := false.
! !

!KeyedSubscriptionBase methodsFor: 'testing'!

accepts: aKey
    "Should return true if change for aKey is relevant for this subscription"
    self subclassResponsibility
!

isEnabled
	^actionBlock notNil
!

isFlagged
	^flagged
! !

KeyedSubscriptionBase subclass: #ListKeyedSubscription
	instanceVariableNames: ''
	package: 'Trapped-Backend'!

!ListKeyedSubscription methodsFor: 'testing'!

accepts: aKey
    ^aKey size <= key size and: [aKey = (key copyFrom: 1 to: aKey size)]
! !

Object subclass: #ListKeyedEntity
	instanceVariableNames: 'dispatcher 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:.
This 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)
	dispatcher: (with a subclass of ListKeyedPubSubBase)!

!ListKeyedEntity methodsFor: 'accessing'!

dispatcher
	^dispatcher
!

dispatcher: aDispatcher
	dispatcher := aDispatcher
!

model: anObject
	payload := anObject.
    self dispatcher changed: #()
! !

!ListKeyedEntity methodsFor: 'action'!

watch: path do: aBlock
	self dispatcher 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 dispatcher 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 dispatcher changed: path ]
!

read: path do: aBlock
    | eavModel |
    eavModel := ({#root},path) asEavModel.
    payload model: eavModel read: aBlock
! !

!Object methodsFor: '*Trapped-Backend'!

reverseTrapAt: anObject
	^nil
!

reverseTrapAt: anObject put: value
	self error: 'Trapped cannot put at ', self class name, ' type key.'
! !

!SequenceableCollection methodsFor: '*Trapped-Backend'!

asEavModel
    | model |
    model := EavModel new.
    model getBlock: [ :anObject |
        self inject: anObject into: [ :soFar :segment |
            soFar ifNotNil: [ segment reverseTrapAt: soFar ]]].
    self isEmpty ifFalse: [
        model putBlock: [ :anObject :value | | penultimate |
            penultimate :=  self allButLast inject: anObject into: [ :soFar :segment |
                soFar ifNotNil: [ segment reverseTrapAt: soFar ]].
            self last reverseTrapAt: penultimate put: value ]].
    ^model
! !

!String methodsFor: '*Trapped-Backend'!

reverseTrapAt: anObject
	^anObject at: self ifAbsent: [nil]
!

reverseTrapAt: anObject put: value
	^anObject at: self put: value
! !

!Symbol methodsFor: '*Trapped-Backend'!

reverseTrapAt: anObject
	^[anObject perform: self] on: MessageNotUnderstood do: [^nil]
!

reverseTrapAt: anObject put: value
    ^anObject perform: (self, ':') asSymbol withArguments: { value }
! !

!Number methodsFor: '*Trapped-Backend'!

reverseTrapAt: anObject
	^anObject at: self ifAbsent: [nil]
!

reverseTrapAt: anObject put: value
	^anObject at: self put: value
! !