Ducts.ns

Newspeak3
'Root'
class Ducts usingPlatform: p <Platform> = (
(* Ducts is Newspeak's change notification framework, a minimalist alternative to Announcements.

Copyright 2008 Cadence Design Systems, Inc.
Copyright 2009, 2012 Ryan Macnak and other contributors.
Copyright 2024-2025 Gilad Bracha.

Licensed under the Apache License, Version 2.0 (the ''License''); you may not use this file except in compliance with the License.  You may obtain a copy of the License at  http://www.apache.org/licenses/LICENSE-2.0 *)
|
	private List = p collections List.
|) (
public class Duct = (
(* A Duct is one of the core classes implementing the simplest possible dependency update mechanism. The other class is Outlet.

A dependency structure is implemented by a Duct as the source of the dependency and a number of Outlets attached to it as the interested parties (observers). A Duct understands the message #send:. Upon receipt of this message, the Duct forwards the argument object to all Outlets connected to it as the #receive: message. To process the #receive: message, each outlet invokes the receiver block associated with the outlet. Neither the Duct nor the Outlets interpret the argument object in any way.

The relationship between Ducts and Outlets is many-to-many. A Duct can have any number of Outlets attached to it. An Outlet can be attached to any number of Ducts. Both a Duct and an Outlet can be configured with an ''owner'' object. That object serves no purpose other than easing the debugging of complex dependency structures.

A Duct can be marked as ''exclusive'' by sending to it the #beExclusive message. An exclusive Duct acts as a recursion lock by ignoring nested #send: requests. By default ducts are not exclusive.

The normal behavior of a Duct can be overridden in a number of ways. A Duct can be blocked for the duration of evaluating a block (#blockWhile:), so that any #send: messages are ignored while the block is being evaluated. An override block can be installed on a Duct (#overrideWith:while:). This arranges for the override block to run to process any #send: messages received by a Duct, instead of forwarding the received objects to the attached Outlets. *)
|
	public owner <Object>
	outlets <List[Outlet]> ::= List new.
	isExclusive <Boolean> ::= false.
	override <Block | nil>
	|) (
public => block <Block> = (
	(* Create an outlet with 'block' as the response and attach it to the receiver. *)

	| outlet |
	outlet:: Outlet response: block.
	self attach: outlet.
	^outlet
)
public attach: anOutlet <Outlet> = (
	(* Attach 'anOutlet' to the receiver. *)

	outlets add: anOutlet.
	anOutlet addedToDuct: self
)
public attachOutletsOf: anotherDuct = (
	(* Attach to the receiver the outlets currently attached to 'anotherDuct'.
	The outlets end up attached to both ducts. *)

	anotherDuct outlets do: [:each | attach: each]
)
public beExclusive = (
	(* Make the receiver exclusive. An exclusive duct blocks itself for the duration of delivering a sent packet. *)

	isExclusive: true
)
public beWeak = (
	outlets:: WeakStorage new
)
public block = (
	setOverride: [:x |]
)
public blockWhile: aBlock <Block> = (
	(* Evaluate aBlock. While the block is being evaluated, do not deliver anything sent to the duct. Answer the result of evaluating aBlock. *)

	^self overrideWith: [:ignored | ] while: aBlock
)
public detach: anOutlet <Outlet> = (
	(* Detach 'anOutlet' from the receiver. Signal an error if the outlet is not attached to the receiver. *)

	outlets remove: anOutlet.
	anOutlet removedFromDuct: self
)
public detachAll = (
	(* Detach all outlets currently attached to the receiver. *)

	outlets (*copy*) do: [:each | detach: each]
)
public gatherInto: summaryBlock while: aBlock = (
	(* Evaluate aBlock. For the duration of evaluation, do not deliver anything sent through the receiver to the connected outlets. After aBlock finishes, invoke summaryBlock with the collection of everything that was sent to the receiver and not delivered. Answer the result of evaluating aBlock. *)

	| things blockResult |
	things:: List new.
	blockResult:: overrideWith: [:a | things add: a] while: aBlock.
	summaryBlock value: things.
	^blockResult
)
public isOverridden = (
	^override notNil
)
public on: expected <Object> do: aBlock <Block> = (
	 (* July 18, 2007: 	DEPRECATED, will be removed.
	Clients should provide equivalent functionality as part of their API instead.
	See Visual>>on:do: for an example. *)

	#BOGUS yourself (* see above *).
	^self => [:event | event = expected ifTrue: [aBlock value]]
)
public overrideWith: overrideBlock while: aBlock = (
	(* Evaluate aBlock. While it is being evaluated, direct anything sent through the receiver into the overrideBlock instead of the connected outlets. Answer the result of evaluating aBlock. *)

	| oldOverride |
	oldOverride:: override.
	override: overrideBlock.
	^aBlock ensure: [override: oldOverride]
)
public printOn: aStream = (
	super printOn: aStream.
	owner isNil ifFalse: [
        aStream nextPutAll: ' of: '; print: owner
    ]
)
privateSendBlocked: packet <Object> = (
	(* The actual workhorse that gets the objects delivered, blocking the receiver for the duration of the delivery and thus breaking any dependency cycles. *)

	override == nil
		ifTrue: [blockWhile: [outlets (*copy*) do: [:each | each receive: packet]]]
		ifFalse:
			[ | originalOverride |
			originalOverride: override.
			(* Should be preserved because blockWhile establishes its own override. *)
			blockWhile: [originalOverride value: packet]]
)
privateSendUnblocked: packet <Object> = (
	(* The actual workhorse that gets the objects delivered without blocking the receiver for the duration of delivery. *)

	override == nil
		ifTrue: [outlets (*copy*) do: [:each | each receive: packet]]
		ifFalse: [override value: packet]
)
public send: packet <Object> = (
	(* Send the object to all outlets currently attached to the receiver, unless the receiver is marked as exclusive and already is in the process of sending another packet. *)

	isExclusive
		ifTrue: [privateSendBlocked: packet]
		ifFalse: [privateSendUnblocked: packet]
)
setOverride: aBlock <Block> ^<Block | UndefinedObject> = (
	(* Set a new override block and return the override that was in effect before the call. This is a restricted message to be used by senders who know exactly what they are doing. The preferred protocol is #overrideWith:while:. *)

	| original |
	original:: override.
	override: aBlock.
	^original
)
public takeOverOutletsOf: anotherDuct = (
	(* Attach to the receiver the outlets currently attached to anotherDuct
	and detach them from anotherDuct. *)

	anotherDuct outlets do: [:each | attach: each].
	anotherDuct detachAll
)
public transformedUsing: transformerBlock <Block> ^<Duct> = (
	(* Answer a new Duct that retransmits everything sent through the receiver, but passes the sent objects through the transformerBlock. *)

	| duct |
	duct:: Duct new.
	duct owner: self =>
		[:sentValue | duct send: (transformerBlock value: sentValue)].
	^duct
)
public unblock = (
	setOverride: nil
)
) : (
public owner: anObject = (
	(* Create a new duct with 'anObject' saved by the duct as its owner. The owner is stored in the duct to ease debugging. It is not used by the duct itself in any way. *)

	^self new owner: anObject
)
)
public class Holder with: obj = (
(* A Holder is an object that holds onto a value and notifies any interested parties about the changes of the value using two Ducts.

The value of a Holder can be set by sending the Holder the #value: message and retrieved using the #value message.

The two Ducts used to notify the interested parties of value changes are accessible by sending the messages #changing and #changed. Notification happens as part of processing the #value: message and proceeds as follows:

	- The new value is sent into the #changing duct. The Holder still holds the old value.
	- The value of the Holder is changed.
	- The new value is sent into the #changed duct. The Holder holds the new value.

The Holder makes no attempt to check the equality of values. The #changing and #changed ducts are triggered regardless of whether the new value is #= to the old one or not.

Two alternative methods of changing the value of a Holder are available.

#quietlySetValue: sets the value without triggering any ducts.

#value:beforeChanged: accepts a Block which is evaluated after the new value is stored in the Holder but before the #changed duct is triggered (between steps 2 and 3 of the list above). *)
|
	valueS <Object> ::= obj. (* The current value of the receiver. *)
	changingS <Duct | nil> (* The duct triggered before the value of the receiver changes. Created lazily on an attempt to use it. *)
	changedS <Duct | nil> (* The duct triggered after the value of the receiver changes. Created lazily on an attempt to use it. *)
	|) (
public printOn: aStream = (
	super printOn: aStream.
	aStream space; print: value
)
quietlySetValue: newValue <Object> = (
	(* Set the receiver value without triggering any broadcasts. *)

	valueS:: newValue
)
public value = (
	(* Answer the current value held by the receiver. *)

	^valueS
)
public value: anObject = (
	(* Set the argument to be the receiver's new value. *)

	(* Note that the changing and changed ducts are accessed directly and checked for existence, to avoid instantiating them when nobody has expressed any interest in their services by retrieving them. *)
	changingS isNil ifFalse: [
        changingS send: anObject
    ].
	valueS:: anObject.
	changedS isNil ifFalse: [
        changedS send: anObject
    ]
)
value: anObject beforeChanged: aBlock = (
	(* Set the receiver's new value and evaluate the argument block BEFORE announcing the 'changed' event. *)

	(* Note that the changing and changed ducts are accessed directly and checked for existence, to avoid instantiating them when nobody has expressed any interest in their services by retrieving them. *)
	changingS isNil ifFalse: [
        changingS send: anObject
    ].
	valueS:: anObject.
	aBlock value.
	changedS isNil ifFalse: [
        changedS send: anObject
    ]
)
public isKindOfHolder = (
	^true
)
public changed ^<Duct> = (
	(* Answer the duct broadcasting the new value of the receiver right after the value is set. *)

	changedS isNil ifTrue: [changedS:: Duct owner: self].
	^changedS
)
public changing ^<Duct> = (
	(* Answer the duct broadcasting the new value of the receiver just before it is set. At the time of the broadcast the receiver is still holding the old value. *)

	changingS isNil ifTrue: [changingS:: Duct owner: self].
	^changingS
)
) : (
public new = (
	^with: nil
)
)
public class Outlet response: aBlock owner: anObject = (
(* An Outlet is one of the core classes implementing the simplest possible dependency update mechanism. The other class is Duct.

See the Duct class comment for an overview.

An Outlet represents a reception point of dependency updates. An Outlet is configured with a response block which processes the received objects. The response block always expects one argument.

An Outlet is in some sense symmetrical to a Duct and supports some of the same processing control messages, such as #beExclusive, #blockWhile:, #overrideWith:while: and #gatherInto:while:. *)
|
	owner <Object> ::= anObject.
	ducts <Collection[Duct]> ::= WeakStorage new.
	response <Block> ::= aBlock.
	isExclusive <Boolean> ::= false.
	override <Block | nil>
	|) (
public addedToDuct: aDuct = (
	ducts add: aDuct
)
public attachTo: aDuct <Duct> = (
	aDuct attach: self
)
beExclusive = (
	(* Make the receiver exclusive. An exclusive outlet blocks itself for the duration of processing a received packet, so the receiving code is never reentered. *)

	isExclusive: true
)
block = (
	setOverride: [:x | ]
)
blockWhile: aBlock = (
	(* Suspend object delivery for the duration of evaluating aBlock. Return the result of aBlock. *)

	^self overrideWith: [:ignored | ] while: aBlock
)
detachFrom: aDuct <Duct> = (
	aDuct detach: self
)
detachFromAll = (
	ducts copy do: [:each | self detachFrom: each]
)
gatherInto: gatherBlock while: aBlock = (
	(* Suspend object delivery for the duration of evaluating aBlock. Then evaluate gatherBlock passing to it the collection of all undelivered objects (empty if no objects were received). Return the result of aBlock. *)

	| received result |
	received:: List new.
	result:: self
		overrideWith: [:a | received add: a]
		while: aBlock.
	gatherBlock value: received.
	^result
)
overrideWith: anOutlet <Outlet> while: aBlock <Block> = (
	| oldOverride |
	oldOverride:: override.
	override:: anOutlet.
	^aBlock ensure: [override:: oldOverride]
)
public printOn: aStream = (
	super printOn: aStream.
	owner isNil ifFalse: [
        aStream nextPutAll: ' of: '; print: owner
    ]
)
public receive: packet <Object> = (
	| originalOverride |
	isExclusive
		ifTrue:
			[override == nil
				ifTrue: [blockWhile: [response value: packet]]
				ifFalse:
					[originalOverride: override.
					(* blockWhile sets its own override so we need to preserve it *)
					blockWhile: [originalOverride value: packet]]]
		ifFalse:
			[override == nil
				ifTrue: [response value: packet]
				ifFalse: [override value: packet]]
)
removedFromDuct: aDuct = (
	ducts remove: aDuct
)
setOverride: another <Outlet> = (
	(* Set the override and return the old one. It is the sender's responsibility to save the old override (which is nil if there was no override) and restore it later if appropriate. *)

	| old |
	old:: override.
	override:: another.
	^old
)
unblock = (
	setOverride: nil
)
) : (
public owner: obj = (
	^response: [:ignored| ] owner: obj
)
public response: block = (
	^response: block owner: nil
)
)
public class WeakStorage = (
(* A WeakStorage is a simple weak OrderedCollection-like collection class, for the use by Ducts and Outlets when needed. *)
|
	storage <Array> ::= Array new: 5. (* The actual weak collection holding onto the receiver's content. *)
	lastUsedIndex <Integer> ::= 0. (* Used internally to remember the last index at which an object has been stored. *)
	|) (
public add: anObject = (
	findAvailableIndex.
	^storage at: lastUsedIndex put: anObject
)
public copy = (
	| theCopy = WeakStorage new. |
	self do: [:each | theCopy add: each].
	^theCopy
)
public do: aBlock = (
	storage do: [:each | each isNil ifFalse: [
        aBlock value: each
        ]
    ]
)
findAvailableIndex = (
	| limit newStorage |
	lastUsedIndex:: lastUsedIndex + 1.
	(lastUsedIndex <= storage size and: [(storage at: lastUsedIndex) isNil]) ifTrue:
		[^lastUsedIndex].
	lastUsedIndex:: 1.
	limit:: storage size.
	[lastUsedIndex <= limit] whileTrue:
		[(storage at: lastUsedIndex) isNil ifTrue: [^lastUsedIndex].
		lastUsedIndex:: lastUsedIndex + 1].
	newStorage:: Array new: storage size + (storage size min: 100).
	newStorage replaceFrom: 1 to: storage size with: storage startingAt: 1.
	storage:: newStorage.
	(* lastUsedIndex is set properly after the loop above *)
	^lastUsedIndex
)
public includes: anObject = (
	^(storage indexOf: anObject) > 0
)
public isEmpty = (
	^size = 0
)
public remove: anObject = (
	| index |
	index:: storage indexOf: anObject.
	index > 0 ifTrue:
		[storage at: index put: nil]
)
public removeAll = (
	storage:: Array new: 5.
	lastUsedIndex:: 0
)
public size = (
	^storage inject: 0 into:
		[:size :each |
		size + (each isNil ifTrue: [0] ifFalse: [1])]
)
) : (
)
) : (
)