Trapped-Backend.st 8.3 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383
  1. Smalltalk current createPackage: 'Trapped-Backend'!
  2. Object subclass: #EavModel
  3. instanceVariableNames: 'getBlock putBlock'
  4. package: 'Trapped-Backend'!
  5. !EavModel commentStamp!
  6. External actor value model.!
  7. !EavModel methodsFor: 'accessing'!
  8. getBlock: aBlock
  9. getBlock := aBlock
  10. !
  11. on: anObject
  12. "Returns value of model applied on object"
  13. ^getBlock value: anObject
  14. !
  15. on: anObject put: anObject2
  16. "Puts a value via model applied on object"
  17. ^putBlock value: anObject value: anObject2
  18. !
  19. putBlock: aBlock
  20. putBlock := aBlock
  21. ! !
  22. !EavModel methodsFor: 'initialization'!
  23. initialize
  24. super initialize.
  25. getBlock := [ self error: 'No getter block.' ].
  26. putBlock := [ self error: 'No putter block.' ].
  27. ! !
  28. Object subclass: #Isolator
  29. instanceVariableNames: 'root'
  30. package: 'Trapped-Backend'!
  31. !Isolator methodsFor: 'accessing'!
  32. root
  33. ^root
  34. !
  35. root: anObject
  36. root := anObject
  37. ! !
  38. !Isolator methodsFor: 'action'!
  39. model: anEavModel modify: aBlock
  40. | newValue |
  41. newValue := aBlock value: (anEavModel on: self).
  42. anEavModel on: self put: newValue deepCopy
  43. !
  44. model: anEavModel read: aBlock
  45. aBlock value: (anEavModel on: self) deepCopy
  46. ! !
  47. !Isolator class methodsFor: 'instance creation'!
  48. on: anObject
  49. ^self new root: anObject
  50. ! !
  51. Object subclass: #KeyedPubSubBase
  52. instanceVariableNames: 'factory'
  53. package: 'Trapped-Backend'!
  54. !KeyedPubSubBase commentStamp!
  55. I represent a pub-sub based on a key.
  56. I manage key-block subscriptions as well as running blocks that are dirty.
  57. The subscription objects are reponsible of decision if the change is relevant for them.
  58. Subscription object must be subclasses of KeyedSubscriptionBase.
  59. My subclasses must provide implementation for:
  60. add:
  61. do:
  62. clean
  63. (optionally) run
  64. and issue this call before actual use:
  65. subscritionFactory: (setting [:key:block|...] factory that creates appropriate subscription)!
  66. !KeyedPubSubBase methodsFor: 'action'!
  67. changed: key
  68. | needsToRun |
  69. needsToRun := false.
  70. self do: [ :each |
  71. (each accepts: key) ifTrue: [
  72. each flag.
  73. needsToRun := true.
  74. ]
  75. ].
  76. self dirty: needsToRun
  77. !
  78. dirty: aBoolean
  79. aBoolean ifTrue: [[ self run ] fork]
  80. !
  81. on: key hook: aBlock
  82. self add: (factory value: key value: aBlock) flag.
  83. self dirty: true
  84. !
  85. run
  86. [
  87. | needsClean |
  88. needsClean := false.
  89. self do: [ :each |
  90. each isFlagged ifTrue: [ each run ].
  91. each isEnabled ifFalse: [ needsClean := true ]
  92. ].
  93. needsClean ifTrue: [ self clean ]
  94. ] on: Error do: [ self dirty: true ]
  95. !
  96. subscriptionFactory: aBlock
  97. factory := aBlock
  98. ! !
  99. KeyedPubSubBase subclass: #SimpleKeyedPubSub
  100. instanceVariableNames: 'queue'
  101. package: 'Trapped-Backend'!
  102. !SimpleKeyedPubSub methodsFor: 'accessing'!
  103. add: aSubscription
  104. queue add: aSubscription.
  105. ! !
  106. !SimpleKeyedPubSub methodsFor: 'bookkeeping'!
  107. clean
  108. queue := queue select: [ :each | each isEnabled ]
  109. ! !
  110. !SimpleKeyedPubSub methodsFor: 'enumeration'!
  111. do: aBlock
  112. queue do: aBlock
  113. ! !
  114. !SimpleKeyedPubSub methodsFor: 'initialization'!
  115. initialize
  116. super initialize.
  117. queue := OrderedCollection new
  118. ! !
  119. Error subclass: #KeyedPubSubUnsubscribe
  120. instanceVariableNames: ''
  121. package: 'Trapped-Backend'!
  122. !KeyedPubSubUnsubscribe commentStamp!
  123. SIgnal me from the subscription block to unsubscribe it.!
  124. Object subclass: #KeyedSubscriptionBase
  125. instanceVariableNames: 'key actionBlock flagged'
  126. package: 'Trapped-Backend'!
  127. !KeyedSubscriptionBase methodsFor: 'accessing'!
  128. flag
  129. flagged := true
  130. !
  131. key: anObject block: aBlock
  132. key := anObject.
  133. actionBlock := aBlock
  134. ! !
  135. !KeyedSubscriptionBase methodsFor: 'action'!
  136. run
  137. [ flagged := false. actionBlock value ]
  138. on: KeyedPubSubUnsubscribe do: [ actionBlock := nil ]
  139. ! !
  140. !KeyedSubscriptionBase methodsFor: 'initialization'!
  141. initialize
  142. super initialize.
  143. key := nil.
  144. actionBlock := nil.
  145. flagged := false.
  146. ! !
  147. !KeyedSubscriptionBase methodsFor: 'testing'!
  148. accepts: aKey
  149. "Should return true if change for aKey is relevant for this subscription"
  150. self subclassResponsibility
  151. !
  152. isEnabled
  153. ^actionBlock notNil
  154. !
  155. isFlagged
  156. ^flagged
  157. ! !
  158. KeyedSubscriptionBase subclass: #ListKeyedSubscription
  159. instanceVariableNames: ''
  160. package: 'Trapped-Backend'!
  161. !ListKeyedSubscription methodsFor: 'testing'!
  162. accepts: aKey
  163. ^aKey size <= key size and: [aKey = (key copyFrom: 1 to: aKey size)]
  164. ! !
  165. KeyedSubscriptionBase subclass: #TwoWayListKeyedSubscription
  166. instanceVariableNames: ''
  167. package: 'Trapped-Backend'!
  168. !TwoWayListKeyedSubscription methodsFor: 'testing'!
  169. accepts: aKey
  170. ^aKey size <= key size
  171. ifTrue: [aKey = (key copyFrom: 1 to: aKey size)]
  172. ifFalse: [key = (aKey copyFrom: 1 to: key size)]
  173. ! !
  174. Object subclass: #ListKeyedEntity
  175. instanceVariableNames: 'dispatcher payload'
  176. package: 'Trapped-Backend'!
  177. !ListKeyedEntity commentStamp!
  178. I am base class for #('string-at-index' #selector numeric-at-index)-array-path-keyed entities,
  179. that moderate access to the wrapped model object via read;do and modify:do:
  180. and allow pub-sub via watch:do:.
  181. This wrapped model can be any smalltalk object.
  182. My subclasses need to provide implementation for:
  183. read:do:
  184. modify:do:
  185. and must issue these calls when initializing:
  186. model: (with a wrapped object)
  187. dispatcher: (with a subclass of KeyedPubSubBase)!
  188. !ListKeyedEntity methodsFor: 'accessing'!
  189. dispatcher
  190. ^dispatcher
  191. !
  192. dispatcher: aDispatcher
  193. dispatcher := aDispatcher
  194. subscriptionFactory: [ :key :block |
  195. (key notEmpty and: [ key last isNil ])
  196. ifTrue: [ TwoWayListKeyedSubscription new key: key allButLast block: block; yourself ]
  197. ifFalse: [ ListKeyedSubscription new key: key block: block; yourself ]];
  198. yourself
  199. !
  200. model: anObject
  201. payload := anObject.
  202. self dispatcher changed: #()
  203. ! !
  204. !ListKeyedEntity methodsFor: 'action'!
  205. watch: path do: aBlock
  206. self dispatcher on: path hook: [ self read: path do: aBlock ]
  207. ! !
  208. ListKeyedEntity subclass: #ListKeyedDirectEntity
  209. instanceVariableNames: ''
  210. package: 'Trapped-Backend'!
  211. !ListKeyedDirectEntity commentStamp!
  212. I am ListKeyedEntity that directly manipulate
  213. the wrapped model object.!
  214. !ListKeyedDirectEntity methodsFor: 'action'!
  215. modify: path do: aBlock
  216. | newValue eavModel |
  217. eavModel := path asEavModel.
  218. newValue := aBlock value: (eavModel on: payload).
  219. [ eavModel on: payload put: newValue ] ensure: [ self dispatcher changed: path ]
  220. !
  221. read: path do: aBlock
  222. | eavModel |
  223. eavModel := path asEavModel.
  224. aBlock value: (eavModel on: payload)
  225. ! !
  226. ListKeyedEntity subclass: #ListKeyedIsolatedEntity
  227. instanceVariableNames: ''
  228. package: 'Trapped-Backend'!
  229. !ListKeyedIsolatedEntity commentStamp!
  230. I am ListKeyedEntity that guards access
  231. to the wrapped model object via Isolator.!
  232. !ListKeyedIsolatedEntity methodsFor: 'accessing'!
  233. model: anObject
  234. super model: (Isolator on: anObject)
  235. ! !
  236. !ListKeyedIsolatedEntity methodsFor: 'action'!
  237. modify: path do: aBlock
  238. | eavModel |
  239. eavModel := ({{#root}},path) asEavModel.
  240. [ payload model: eavModel modify: aBlock ] ensure: [ self dispatcher changed: path ]
  241. !
  242. read: path do: aBlock
  243. | eavModel |
  244. eavModel := ({{#root}},path) asEavModel.
  245. payload model: eavModel read: aBlock
  246. ! !
  247. !Object methodsFor: '*Trapped-Backend'!
  248. reverseTrapAt: anObject
  249. ^nil
  250. !
  251. reverseTrapAt: anObject put: value
  252. self error: 'Trapped cannot put at ', self class name, ' type key.'
  253. ! !
  254. !Number methodsFor: '*Trapped-Backend'!
  255. reverseTrapAt: anObject
  256. ^anObject ifNotNil: [ anObject at: self ifAbsent: [nil] ]
  257. !
  258. reverseTrapAt: anObject put: value
  259. ^anObject at: self put: value
  260. ! !
  261. !SequenceableCollection methodsFor: '*Trapped-Backend'!
  262. asEavModel
  263. | model |
  264. model := EavModel new.
  265. model getBlock: [ :anObject |
  266. self inject: anObject into: [ :soFar :segment |
  267. segment reverseTrapAt: soFar ]].
  268. self isEmpty ifFalse: [
  269. model putBlock: [ :anObject :value | | penultimate |
  270. penultimate := self allButLast inject: anObject into: [ :soFar :segment |
  271. soFar ifNotNil: [ segment reverseTrapAt: soFar ]].
  272. self last reverseTrapAt: penultimate put: value ]].
  273. ^model
  274. ! !
  275. !String methodsFor: '*Trapped-Backend'!
  276. reverseTrapAt: anObject
  277. ^anObject ifNotNil: [ anObject at: self ifAbsent: [nil] ]
  278. !
  279. reverseTrapAt: anObject put: value
  280. ^anObject at: self put: value
  281. ! !
  282. !Array methodsFor: '*Trapped-Backend'!
  283. reverseTrapAt: anObject
  284. ^[anObject perform: self first] on: MessageNotUnderstood do: [^nil]
  285. !
  286. reverseTrapAt: anObject put: value
  287. ^anObject perform: (self first, ':') asSymbol withArguments: { value }
  288. ! !