[squeak-dev] The Inbox: PromisesLocal-rww.20.mcz

commits at source.squeak.org commits at source.squeak.org
Sun Oct 4 16:24:06 UTC 2020


A new version of PromisesLocal was added to project The Inbox:
http://source.squeak.org/inbox/PromisesLocal-rww.20.mcz

==================== Summary ====================

Name: PromisesLocal-rww.20
Author: rww
Time: 4 October 2020, 10:43:29.453407 am
UUID: ff0cd0f9-170e-4cfb-b64a-47a1b0446903
Ancestors: PromisesLocal-rww.19

use eventual sending to handle nil blocks, both the #then: block and the #ifRejected: block

==================== Snapshot ====================

SystemOrganization addCategory: #PromisesLocal!
SystemOrganization addCategory: #'PromisesLocal-Testing'!

Object subclass: #AbstractEventual
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'PromisesLocal'!

----- Method: AbstractEventual class>>broken: (in category 'promises') -----
broken: error
	"self broken: Error new"

	^ BrokenEventual new
		exception: error;
		yourself!

----- Method: AbstractEventual class>>isReference: (in category 'resolution') -----
isReference: object

	^ object class includesBehavior: AbstractEventual
!

----- Method: AbstractEventual class>>promise (in category 'promises') -----
promise
	"self promise"

	^ self promiseInVat: self vat.
!

----- Method: AbstractEventual class>>promiseClass (in category 'promises') -----
promiseClass

	^ Promise !

----- Method: AbstractEventual class>>promiseInVat: (in category 'promises') -----
promiseInVat: aVat
	"self promise"

	| promise buf |
	buf := OrderedCollection new: 0.
	promise := self promiseClass newOnBuffer: buf vat: aVat.
	^ Association key: promise value: promise resolver

!

----- Method: AbstractEventual class>>refDescriptionString (in category 'accessing') -----
refDescriptionString

	^ 'eventual'!

----- Method: AbstractEventual class>>resolution: (in category 'immediate') -----
resolution: obj

	^ obj!

----- Method: AbstractEventual class>>resolverClass (in category 'promises') -----
resolverClass

	^ LocalResolver !

----- Method: AbstractEventual class>>toReferenceContext: (in category 'resolution') -----
toReferenceContext: value 

	^ self toReferenceContext: value vat: self vat.
!

----- Method: AbstractEventual class>>toReferenceContext:vat: (in category 'resolution') -----
toReferenceContext: value vat: vat

	(self isReference: value)
		ifTrue: [^ value].
	(value isKindOf: Exception)
			ifTrue: [^ AbstractEventual broken: value]
			ifFalse: [^ NearEventual newOn: value vat: vat.].
!

----- Method: AbstractEventual>>at: (in category 'overrides') -----
at: index 

	| pair |
	pair := AbstractEventual promiseInVat: self vat.
	self redirectEventualMessage: (EventualMessageSend
		message: (Message selector: #at: argument: index) 
		resolver: pair value).
	^ pair key
!

----- Method: AbstractEventual>>at:put: (in category 'overrides') -----
at: index put: value

	| pair |
	pair := AbstractEventual promiseInVat: self vat.
	self redirectEventualMessage: (EventualMessageSend
		message: (Message selector: #at:put: arguments: {index. value}) 
		resolver: pair value).
	^ pair key
!

----- Method: AbstractEventual>>becomeContext: (in category 'messaging') -----
becomeContext: context

	self becomeForward: context.
!

----- Method: AbstractEventual>>doesNotUnderstand: (in category 'messaging') -----
doesNotUnderstand: aMessage

	^ self redirectMessage: aMessage
!

----- Method: AbstractEventual>>eventual (in category 'accessing') -----
eventual

	^ self!

----- Method: AbstractEventual>>eventualInVat: (in category 'accessing') -----
eventualInVat: aVat

	^ self
!

----- Method: AbstractEventual>>isEventual (in category 'testing') -----
isEventual

	^ true!

----- Method: AbstractEventual>>isFulfilled (in category 'testing') -----
isFulfilled

	^ false!

----- Method: AbstractEventual>>isInteger (in category 'overrides') -----
isInteger

	| pair |
	pair := AbstractEventual promiseInVat: self vat.
	self redirectEventualMessage: (EventualMessageSend
		message: (Message selector: #isInteger) 
		resolver: pair value).
	^ pair key
!

----- Method: AbstractEventual>>isLocal (in category 'testing') -----
isLocal

	^ true!

----- Method: AbstractEventual>>isNear (in category 'testing') -----
isNear

	^ true!

----- Method: AbstractEventual>>isPassByConstruction (in category 'testing') -----
isPassByConstruction

	^ false!

----- Method: AbstractEventual>>isPassByProxy (in category 'testing') -----
isPassByProxy

	^ true!

----- Method: AbstractEventual>>isRejected (in category 'testing') -----
isRejected

	^ false!

----- Method: AbstractEventual>>isRemote (in category 'testing') -----
isRemote

	^ false!

----- Method: AbstractEventual>>isResolved (in category 'testing') -----
isResolved

	^ false!

----- Method: AbstractEventual>>mustBeBoolean (in category 'messaging') -----
mustBeBoolean

	| context |
	context := thisContext sender.
	self resolution.
	context  skipBackBeforeJump.
	^ true!

----- Method: AbstractEventual>>printOn: (in category 'printing') -----
printOn: stream

	stream 
		nextPutAll: self class name;
		nextPutAll:  '::';
		nextPutAll: self refDescriptionString;
		nextPutAll: '('.
	self vat printOn: stream.
	stream nextPutAll: ')'.

!

----- Method: AbstractEventual>>redirectMessage: (in category 'messaging') -----
redirectMessage: aMessage

	| pair |
	pair := AbstractEventual promiseInVat: self vat.
	self redirectEventualMessage: (EventualMessageSend message: aMessage resolver: pair value).
	^ pair key

!

----- Method: AbstractEventual>>redirectMessageOneWay: (in category 'messaging') -----
redirectMessageOneWay: aMessage

	self redirectEventualMessage: (EventualMessageSend message: aMessage).
	^ nil
!

----- Method: AbstractEventual>>refDescriptionString (in category 'printing') -----
refDescriptionString

	^ self class refDescriptionString
!

----- Method: AbstractEventual>>rejectWith: (in category 'Promise/A+ protocol') -----
rejectWith: reason

	self subclassResponsibility!

----- Method: AbstractEventual>>resolution (in category 'accessing') -----
resolution

	^ self!

----- Method: AbstractEventual>>resolveWith: (in category 'Promise/A+ protocol') -----
resolveWith: arg

	self subclassResponsibility!

----- Method: AbstractEventual>>send: (in category 'eventual sending') -----
send: selector

	| pair |
	pair := AbstractEventual promiseInVat: self vat.
	self redirectEventualMessage: (EventualMessageSend selector: selector resolver: pair value).
	^ pair key
!

----- Method: AbstractEventual>>send:args: (in category 'eventual sending') -----
send: selector args: args

	| pair |
	pair := AbstractEventual promiseInVat: self vat.
	self redirectEventualMessage: (EventualMessageSend selector: selector arguments: args resolver: pair value).
	^ pair key
!

----- Method: AbstractEventual>>sendOneWay: (in category 'eventual sending') -----
sendOneWay: selector

	self redirectEventualMessage: (EventualMessageSend selector: selector).
	^ nil
!

----- Method: AbstractEventual>>sendOneWay:args: (in category 'eventual sending') -----
sendOneWay: selector args: args

	self redirectEventualMessage: (EventualMessageSend selector: selector arguments: args).
	^ nil
!

----- Method: AbstractEventual>>wait (in category 'waiting') -----
wait
	"Wait unconditionally for this promise to become fulfilled or rejected."
	PromiseWaiter waitTimeoutMSecs: 1000 onPromise: self.
	^ self resolution.!

----- Method: AbstractEventual>>waitTimeoutMSecs: (in category 'waiting') -----
waitTimeoutMSecs: msecs
	"Wait for at most the given number of milliseconds for this promise to settle.
	Answer true if it is resolved, false otherwise. False can therefore mean EITHER 'timeout' OR 'rejected'."

	PromiseWaiter waitTimeoutMSecs: msecs onPromise: self.
	^ self resolution.!

----- Method: AbstractEventual>>waitTimeoutSeconds: (in category 'waiting') -----
waitTimeoutSeconds: secs
	"Wait for at most the given number of milliseconds for this promise to settle.
	Answer true if it is resolved, false otherwise. False can therefore mean EITHER 'timeout' OR 'rejected'."

	PromiseWaiter waitTimeoutSeconds: secs onPromise: self.
	^ self resolution.!

AbstractEventual subclass: #BrokenEventual
	instanceVariableNames: 'exception'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'PromisesLocal'!

----- Method: BrokenEventual class>>refDescriptionString (in category 'accessing') -----
refDescriptionString

	^ 'broken'
!

----- Method: BrokenEventual>>becomeContext: (in category 'messaging') -----
becomeContext: ref

	^ self error: 'not switchable'!

----- Method: BrokenEventual>>doesNotUnderstand: (in category 'messaging') -----
doesNotUnderstand: aMessage

	^ self exception signal!

----- Method: BrokenEventual>>error (in category 'accessing') -----
error

	^ self exception!

----- Method: BrokenEventual>>exception (in category 'accessing') -----
exception

	^exception!

----- Method: BrokenEventual>>exception: (in category 'accessing') -----
exception: anException

	exception := anException!

----- Method: BrokenEventual>>isBroken (in category 'testing') -----
isBroken

	^ true!

----- Method: BrokenEventual>>isRejected (in category 'testing') -----
isRejected

	^ true!

----- Method: BrokenEventual>>isResolved (in category 'testing') -----
isResolved

	^ true!

----- Method: BrokenEventual>>printOn: (in category 'printing') -----
printOn: stream

	super printOn: stream.
	stream 
		nextPutAll: '{';
		nextPutAll: self exception description;
		nextPutAll: '}'.
!

----- Method: BrokenEventual>>redirectEventualMessage: (in category 'messaging') -----
redirectEventualMessage: anEventualMessage

	anEventualMessage receiver: exception.
	self vat schedule: anEventualMessage.
!

----- Method: BrokenEventual>>rejectWith: (in category 'Promise/A+ protocol') -----
rejectWith: arg

	PromiseAlreadyResolved new signal.
!

----- Method: BrokenEventual>>resolution (in category 'Promise/A+ protocol') -----
resolution

	^ exception signal!

----- Method: BrokenEventual>>resolveWith: (in category 'Promise/A+ protocol') -----
resolveWith: arg

	PromiseAlreadyResolved new signal.
!

----- Method: BrokenEventual>>value (in category 'accessing') -----
value

	^ exception!

AbstractEventual subclass: #NearEventual
	instanceVariableNames: 'vat value'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'PromisesLocal'!

----- Method: NearEventual class>>newOn: (in category 'instance creation') -----
newOn: anObject

	^ self newOn: anObject vat: anObject vat.
!

----- Method: NearEventual class>>newOn:vat: (in category 'instance creation') -----
newOn: anObject vat: vat

	^ self new
		initializeOnTarget: anObject vat: vat;
		yourself.
!

----- Method: NearEventual class>>refDescriptionString (in category 'accessing') -----
refDescriptionString

	^ 'near'!

----- Method: NearEventual>>= (in category 'comparing') -----
= anObject 
	"Answer whether the receiver and the argument represent the same 
	object. If = is redefined in any subclass, consider also redefining the 
	message hash."

	^anObject = value!

----- Method: NearEventual>>basicEquality: (in category 'comparing') -----
basicEquality: anObject 
	"Answer whether the receiver and the argument represent the same 
	object. If = is redefined in any subclass, consider also redefining the 
	message hash."

	^value basicEquality: anObject!

----- Method: NearEventual>>becomeContext: (in category 'messaging') -----
becomeContext: context

!

----- Method: NearEventual>>hash (in category 'comparing') -----
hash

	^value hash!

----- Method: NearEventual>>initializeOnTarget:vat: (in category 'initialization') -----
initializeOnTarget: anObject vat: aVat

	value := anObject.
	vat := aVat.
!

----- Method: NearEventual>>isFulfilled (in category 'testing') -----
isFulfilled

	^ true!

----- Method: NearEventual>>isInteger (in category 'number protocol') -----
isInteger

	^ value isInteger!

----- Method: NearEventual>>isPassByConstruction (in category 'serializing') -----
isPassByConstruction

	^ value isPassByConstruction
!

----- Method: NearEventual>>isResolved (in category 'testing') -----
isResolved

	^ true!

----- Method: NearEventual>>passByConstruction (in category 'serializing') -----
passByConstruction

	self isPassByConstruction
		ifTrue: [^ value]
		ifFalse: [self error: 'not passByConstruction'].
!

----- Method: NearEventual>>printOn: (in category 'printing') -----
printOn: stream

	stream nextPutAll: '{ '.
	value printOn: stream.
	stream nextPutAll: ' } >> '.
	super printOn: stream.

!

----- Method: NearEventual>>redirectEventualMessage: (in category 'messaging') -----
redirectEventualMessage: anEventualMessage

	anEventualMessage receiver: value.
	self vat schedule: anEventualMessage.
!

----- Method: NearEventual>>rejectWith: (in category 'Promise/A+ protocol') -----
rejectWith: arg

	PromiseAlreadyResolved new signal.
!

----- Method: NearEventual>>resolution (in category 'accessing') -----
resolution

	^ value!

----- Method: NearEventual>>resolveWith: (in category 'Promise/A+ protocol') -----
resolveWith: arg

	PromiseAlreadyResolved new signal.
!

----- Method: NearEventual>>value (in category 'accessing') -----
value

	^ value!

----- Method: NearEventual>>vat (in category 'accessing') -----
vat

	^ vat!

----- Method: NearEventual>>wait (in category 'waiting') -----
wait

	super waitTimeoutMSecs: 3.
	super wait.
	^ self resolution.!

----- Method: NearEventual>>waitTimeoutMSecs: (in category 'waiting') -----
waitTimeoutMSecs: msecs

	super waitTimeoutMSecs: 3.
	super waitTimeoutMSecs: msecs.
	^ self resolution.!

----- Method: NearEventual>>waitTimeoutSeconds: (in category 'waiting') -----
waitTimeoutSeconds: secs

	super waitTimeoutMSecs: 3.
	super waitTimeoutSeconds: secs.
	^ self resolution.!

AbstractEventual subclass: #Promise
	instanceVariableNames: 'vat msgBuffer resolver'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'PromisesLocal'!

!Promise commentStamp: 'tonyg 1/31/2018 23:34' prior: 0!
I represent the result of an asynchronous message.  Once the message is processed, I will be resolved to a value.  I am typically instantiated by invocations of #futureSend:at:args: (and not by #futureDo:atArgs:).

See class-comment of FutureNode.

I also implement the Promises/A+ Javascript specification. This allows you to chain my instances to perform arbitrarily complex asynchronous tasks with error handling baked in.

A Promise may be in one of three possible states: #pending, #fulfilled or #rejected. A Promise may move from #pending -> #fulfilled (by way of the resolveWith: message), or from #pending -> #rejected (by way of rejectWith:). No other state changes may occur.

Once #fulfilled or #rejected, a Promise's value must not change. In keeping with the major Javascript Promise implementations' interpretations of this, calls to resolveWith: or rejectWith: when a Promise is in #fulfilled or #rejected state are simply ignored - an error is not signalled. (See test cases PromiseTest testFirstResolutionWins, testCannotRejectFulfilledPromise and testCannotResolveaRejectedPromise.)!

----- Method: Promise class>>ifRejected: (in category 'instance creation') -----
ifRejected: aBlock

	^ self new
		whenRejected: aBlock;
		yourself.
!

----- Method: Promise class>>new (in category 'instance creation') -----
new

	^ self newOnBuffer: (OrderedCollection new: 0) vat: self vat!

----- Method: Promise class>>newOnBuffer:vat: (in category 'instance creation') -----
newOnBuffer: buf vat: vat

	^ self basicNew
		initializeOnBuffer: buf vat: vat;
		yourself!

----- Method: Promise class>>refDescriptionString (in category 'accessing') -----
refDescriptionString

	^ 'promise'!

----- Method: Promise class>>unit: (in category 'instance creation') -----
unit: anObject

	"Return a resolved Promise. #new is the other half of Promise's unit function; #new returns an unresolved Promise."
	^ Promise new
		resolveWith: anObject.!

----- Method: Promise>>error (in category 'accessing') -----
error

	^ nil!

----- Method: Promise>>fulfillWith: (in category 'Promise/A+ protocol') -----
fulfillWith: aBlock

	self fulfillWith: aBlock passErrors: (msgBuffer collect: [:e | e isRejector]) isEmpty!

----- Method: Promise>>fulfillWith:passErrors: (in category 'Promise/A+ protocol') -----
fulfillWith: aBlock passErrors: aBoolean
	"Evaluate aBlock. If it signals an exception, reject this promise with the exception
	as the argument; if it returns a value [or another Promise], resolve this promise
	with the result.
	
	If aBoolean is true, and an exception is signaled, it is passed out to the caller.
	If aBoolean is false, signaled exceptions are considered handled after the promise
	has been rejected."
	[ self resolveWith: aBlock value ]
		on: Exception
		do: [ :ex |
			(ex isKindOf: Halt)
				ifTrue: [ex pass]
				ifFalse: [
					self rejectWith: ex.
					aBoolean ifTrue: [ ex pass ] ]]!

----- Method: Promise>>ifRejected: (in category 'Promise/A+ protocol') -----
ifRejected: errBlock

	^ errBlock
		ifNil: [^ self whenBroken: [:e | e]]
		ifNotNil: [:b | self whenBroken: errBlock].
!

----- Method: Promise>>initializeOnBuffer:vat: (in category 'initialization') -----
initializeOnBuffer: buf vat: aVat

	super initialize.
	msgBuffer := buf.
	vat := aVat.
	resolver := self resolverClass onRef: self buffer: buf.
!

----- Method: Promise>>isEventual (in category 'testing') -----
isEventual

	^ true!

----- Method: Promise>>isNear (in category 'testing') -----
isNear

	^ false!

----- Method: Promise>>isPromise (in category 'testing') -----
isPromise

	^ true!

----- Method: Promise>>isRejected (in category 'testing') -----
isRejected

	^ false!

----- Method: Promise>>printOn: (in category 'printing') -----
printOn: stream

	stream 
		nextPutAll: 'a Promise<';
		nextPutAll: self class name;
		nextPutAll:  '>::';
		nextPutAll: self refDescriptionString;
		nextPutAll: '('.
	self vat printOn: stream.
	stream nextPutAll: ')'.
!

----- Method: Promise>>redirectEventualMessage: (in category 'Promise/A+ protocol') -----
redirectEventualMessage: anEventualMessage

	[msgBuffer addLast: anEventualMessage]
		on: Exception
		do: [:error | self redirectEventualMessage: anEventualMessage].
!

----- Method: Promise>>reject (in category 'Promise/A+ protocol') -----
reject

	self rejectWith: nil!

----- Method: Promise>>rejectWith: (in category 'resolving') -----
rejectWith: reason

	self resolver smash: reason.!

----- Method: Promise>>resolve (in category 'Promise/A+ protocol') -----
resolve
	
	self resolveWith: nil!

----- Method: Promise>>resolveWith: (in category 'resolving') -----
resolveWith: arg
	"Resolve this promise. If arg is itself a Promise, make this promise depend upon it,
	as detailed in the Promises/A+ spec:
		https://promisesaplus.com/#the-promise-resolution-procedure"

	self resolver resolve: arg.
!

----- Method: Promise>>resolver (in category 'accessing') -----
resolver

	^ resolver!

----- Method: Promise>>resolverClass (in category 'accessing') -----
resolverClass

	^ self class resolverClass!

----- Method: Promise>>then: (in category 'Promise/A+ protocol') -----
then: resolvedBlock

	resolvedBlock
		ifNil: [^ self whenResolved: [:o | o]]
		ifNotNil: [:b | ^ self whenResolved: resolvedBlock].!

----- Method: Promise>>then:ifRejected: (in category 'Promise/A+ protocol') -----
then: resolvedBlock ifRejected: errBlock
	"Return a Promise that, if it resolves, runs the resolvedBlock. If resolution throws an Exception, it runs the errBlock."

	| p |
	p := self then: resolvedBlock.
	self ifRejected: errBlock.
	^ p.!

----- Method: Promise>>value (in category 'accessing') -----
value

	^ self!

----- Method: Promise>>vat (in category 'accessing') -----
vat

	vat isNil 
		ifTrue: [vat := super vat].
	^ vat!

----- Method: Promise>>vat: (in category 'accessing') -----
vat: aVat

	vat := aVat!

----- Method: Promise>>whenMoreResolved: (in category 'when clause') -----
whenMoreResolved: reactor

	"aBlock numArgs <= 1 ifFalse: [self error: 'Must be 0- or 1-argument block']."
	self redirectMessageOneWay: (Message selector: #whenMoreResolved: argument: reactor).
!

Object subclass: #ELib
	instanceVariableNames: ''
	classVariableNames: 'ForkDebugger'
	poolDictionaries: ''
	category: 'PromisesLocal'!

----- Method: ELib class>>debugEventualException: (in category 'debugging') -----
debugEventualException: anException
	"For convenience. Construct a helper process to debug an exception that occurred in the active process later on so that the active process can (try to) resume. Uses a temporary variable to access and copy the signaler context now before it gets GC'ed."

	self forkDebugger ifTrue: [
		| helperProcess |
		helperProcess := (EventualProcess
			forContext: anException signalerContext copyStack
			priority: Processor activeProcess priority
			onVat: Processor activeProcess vat)
				shouldResumeFromDebugger: true;
				yourself.

		Project current addDeferredUIMessage: [
			helperProcess
				debugWithTitle: anException description
				full: false] ].
!

----- Method: ELib class>>forkDebugger (in category 'preferences') -----
forkDebugger

	<preference: 'Fork Debugger on Exception'
		categoryList: #(promises)
		description: 'If enabled, any exception thrown inside the event loop will have its stack copied and a debugger will open outside of the event loop'
		type: #Boolean>
	^ ForkDebugger ifNil: [false]!

----- Method: ELib class>>forkDebugger: (in category 'preferences') -----
forkDebugger: bool

	ForkDebugger := bool.
!

----- Method: Object>>basicEquality: (in category '*promiseslocal') -----
basicEquality: anObject 
	"Answer whether the receiver and the argument represent the same 
	object. If = is redefined in any subclass, consider also redefining the 
	message hash."

	^self == anObject!

----- Method: Object>>basicEquivalence: (in category '*promiseslocal') -----
basicEquivalence: anObject 
	"Primitive. Answer whether the receiver and the argument are the same  
	object (have the same object pointer). Do not redefine the message == in  
	any other class!! Essential. No Lookup. Do not override in any subclass.  
	See Object documentation whatIsAPrimitive."


	<primitive: 110> "primitiveEquivalent" 
	self primitiveFailed!

----- Method: Object>>eventual (in category '*promiseslocal') -----
eventual

	^ NearEventual newOn: self
!

----- Method: Object>>eventualInVat: (in category '*promiseslocal') -----
eventualInVat: aVat

	^ NearEventual newOn: self vat: aVat
!

----- Method: Object>>whenBroken: (in category '*promiseslocal') -----
whenBroken: reactor

	| pair |
	pair := AbstractEventual promiseInVat: self vat.
	self whenMoreResolved: (WhenBrokenReactor
		onClosure: reactor 
		ref: self 
		resolver: pair value).
	^ pair key
!

----- Method: Object>>whenBrokenOnly: (in category '*promiseslocal') -----
whenBrokenOnly: reactor

	self whenMoreResolved: (WhenBrokenReactor
		onClosure: reactor 
		ref: self 
		resolver: nil).
	^ nil
!

----- Method: Object>>whenMoreResolved: (in category '*promiseslocal') -----
whenMoreResolved: reactor

	(reactor isEventual and: [reactor isRemote])
		ifTrue: [
			reactor redirectMessageOneWay: (Message 
				selector: #value: 
				argument: self value)]
		ifFalse: [reactor value: self value]
!

----- Method: Object>>whenRejected: (in category '*promiseslocal') -----
whenRejected: aBlock

	^ self whenBroken: aBlock
!

----- Method: Object>>whenResolved: (in category '*promiseslocal') -----
whenResolved: reactor

	| pair |
	pair := AbstractEventual promiseInVat: self vat.
	self whenMoreResolved: (WhenResolvedReactor
		onClosure: reactor 
		ref: self 
		resolver: pair value).
	^ pair key
!

----- Method: Object>>whenResolvedOnly: (in category '*promiseslocal') -----
whenResolvedOnly: reactor

	self whenMoreResolved: (WhenResolvedReactor
		onClosure: reactor 
		ref: self 
		resolver: nil).
	^ nil!

Object subclass: #PriorityVat
	instanceVariableNames: 'vatNick currentState normalQ immediateQ flashQ flashOverrideQ eventualProcess accessProtect readSynch'
	classVariableNames: 'LocalVat'
	poolDictionaries: ''
	category: 'PromisesLocal'!

----- Method: PriorityVat class>>clearLocalVat (in category 'accessing') -----
clearLocalVat
	"PriorityVat clearLocalVat"

	^ LocalVat ifNotNil: [LocalVat stop. LocalVat := nil]
!

----- Method: PriorityVat class>>localVat (in category 'accessing') -----
localVat
	"PriorityVat localVat"

	^ LocalVat ifNil: [LocalVat := self newWithNick: 'local']
!

----- Method: PriorityVat class>>newWithNick: (in category 'instance creation') -----
newWithNick: nick

	^ self new
		vatNick: nick;
		yourself!

----- Method: PriorityVat class>>stateMap (in category 'class initialization') -----
stateMap
	"(((PriorityVat stateMap compile)))"

	| desc |
	desc := ProtocolStateCompiler initialState: #running.
	(desc newState: #running -> (nil -> #stopped))
		add: #stopping -> (nil -> #stopping).
	(desc newState: #stopping -> (nil -> #stopped))
		add: #stopping -> (nil -> #stopping);
		addInteger: #stopped -> (nil -> #stopped).
	(desc newState: #stopped -> (nil -> #stopped)).
	^desc.
!

----- Method: PriorityVat>>initialize (in category 'private') -----
initialize

	self vatNick: '<new>'.
	self start.
	currentState := self class stateMap compile.!

----- Method: PriorityVat>>isRunning (in category 'action') -----
isRunning

	^ currentState 
		ifNil: [false]
		ifNotNil: [:state | state isStateNamed: #running].!

----- Method: PriorityVat>>nextPriorityMsg (in category 'private') -----
nextPriorityMsg

	readSynch wait.
	accessProtect
		critical: [
			flashOverrideQ isEmpty ifFalse: [ ^ flashOverrideQ next ].
			flashQ isEmpty ifFalse: [ ^ flashQ next ].
			immediateQ isEmpty ifFalse: [ ^ immediateQ next ].
			normalQ isEmpty ifFalse: [ ^ normalQ next ].
			^ nil].!

----- Method: PriorityVat>>postCopy (in category 'private') -----
postCopy

	super postCopy.
	self initialize.!

----- Method: PriorityVat>>printOn: (in category 'private') -----
printOn: stream

	stream nextPutAll: 'vat#'.
	stream nextPutAll: self vatNick.
!

----- Method: PriorityVat>>processSends (in category 'private') -----
processSends

	[[
		Processor yield.
		self nextPriorityMsg ifNotNil: [:msg | msg value].
		self isRunning ] whileTrue]
			ifCurtailed: [self isRunning ifTrue: [self restartEventLoop]].
	
!

----- Method: PriorityVat>>restartEventLoop (in category 'action') -----
restartEventLoop

	| currentEventLoop |
	eventualProcess ifNotNil: [:ea | currentEventLoop := ea].
	eventualProcess := nil.
	eventualProcess := EventualProcess newOnVat: self.
	eventualProcess resumeAsProcess.
	currentEventLoop ifNotNil: [:ea | ea terminate ].!

----- Method: PriorityVat>>schedule: (in category 'action') -----
schedule: msg

	self schedule: msg priority: #Normal.
!

----- Method: PriorityVat>>schedule:priority: (in category 'action') -----
schedule: msg priority: priority

	self isRunning ifFalse: [^ self].
	accessProtect critical: [
		(priority == 3 or: [priority == #FlashOverride]) ifTrue: [flashOverrideQ nextPut: msg].
		(priority == 2 or: [priority == #Flash]) ifTrue: [flashQ nextPut: msg].
		(priority == 1 or: [priority == #Immediate]) ifTrue: [immediateQ nextPut: msg].
		(priority == 0 or: [priority == #Normal]) ifTrue: [normalQ nextPut: msg]].
	readSynch signal.
!

----- Method: PriorityVat>>start (in category 'action') -----
start

	self isRunning ifTrue: [^ self].
	normalQ := SharedQueue new.
	immediateQ := SharedQueue new.
	flashQ := SharedQueue new.
	flashOverrideQ := SharedQueue new.
	accessProtect := Semaphore forMutualExclusion.
	readSynch := Semaphore new.
	eventualProcess := EventualProcess newOnVat: self.
	eventualProcess resumeAsProcess.
!

----- Method: PriorityVat>>stop (in category 'action') -----
stop

	self transitionEvent: #stopping.
	self schedule: [#cycle].
	(Delay forMilliseconds: 1) wait.
	eventualProcess ifNotNil: [:p | eventualProcess terminate].
	eventualProcess := nil.
	normalQ := nil.
	immediateQ := nil.
	flashQ := nil.
	flashOverrideQ := nil.
	accessProtect := nil.
	readSynch := nil.
!

----- Method: PriorityVat>>stopped (in category 'action') -----
stopped

	self transitionEvent: #stopped.
!

----- Method: PriorityVat>>transitionEvent: (in category 'events') -----
transitionEvent: event

	| newState |
	newState := currentState transitionEvent: event value: event client: self.
	(newState ~= currentState)
		ifTrue: [ currentState := newState. ^ true]
		ifFalse: [^ false]!

----- Method: PriorityVat>>vatNick (in category 'accessing') -----
vatNick

	^ vatNick!

----- Method: PriorityVat>>vatNick: (in category 'accessing') -----
vatNick: nick

	vatNick := nick.
!

Object subclass: #PromiseWaiter
	instanceVariableNames: 'promise value state'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'PromisesLocal'!

----- Method: PromiseWaiter class>>newOnPromise: (in category 'as yet unclassified') -----
newOnPromise: promise
	"Wait unconditionally for this promise to become fulfilled or rejected."

	^ self new
		initializeOnPromise: promise;
		yourself.
!

----- Method: PromiseWaiter class>>waitOnPromise: (in category 'as yet unclassified') -----
waitOnPromise: promise
	"Wait unconditionally for this promise to become fulfilled or rejected."

	| waiter |
	waiter := PromiseWaiter newOnPromise: promise.
	^ waiter wait.
!

----- Method: PromiseWaiter class>>waitTimeoutMSecs:onPromise: (in category 'as yet unclassified') -----
waitTimeoutMSecs: msecs onPromise: promise

	| waiter |
	waiter := PromiseWaiter newOnPromise: promise.
	^ waiter waitTimeoutMSecs: msecs.
!

----- Method: PromiseWaiter class>>waitTimeoutSeconds:onPromise: (in category 'as yet unclassified') -----
waitTimeoutSeconds: secs onPromise: promise

	^ self waitTimeoutMSecs: (secs * 1000) onPromise: promise!

----- Method: PromiseWaiter>>initializeOnPromise: (in category 'initialize-release') -----
initializeOnPromise: prom

	state := #pending.
	promise := prom.
	promise whenResolved: [:v | self result: v].
	promise whenRejected: [:v | self result: v].
	(promise isResolved or: [promise isRejected])
		ifTrue: [self result: promise].
!

----- Method: PromiseWaiter>>result: (in category 'accessing') -----
result: anObject
	"Set the value of result"

	(state == #fulfilled) ifTrue: [^self].
	state := #fulfilled.
!

----- Method: PromiseWaiter>>wait (in category 'control') -----
wait
	"Wait unconditionally for this promise to become fulfilled or rejected."

	| sema |
	(state == #fulfilled) ifTrue: [
		promise removeActionsWithReceiver: self.
		^ promise value].
	sema := Semaphore new.
	promise whenResolved: [sema signal].
	[[sema wait] on: TestFailure do: [:e | ]] ensure: [promise removeActionsWithReceiver: self].
	^ promise value.
!

----- Method: PromiseWaiter>>waitTimeoutMSecs: (in category 'control') -----
waitTimeoutMSecs: timeout

	| sema delay |
	(state == #fulfilled) ifTrue: [
		promise removeActionsWithReceiver: self.
		^ promise resolution].
	sema := Semaphore new.
	promise whenResolved: [sema signal].
	delay := Delay timeoutSemaphore: sema afterMSecs: timeout.
	[sema wait] ensure: [
		delay unschedule.
		promise removeActionsWithReceiver: self].
	^ promise resolution.
!

----- Method: PromiseWaiter>>waitTimeoutSeconds: (in category 'control') -----
waitTimeoutSeconds: seconds

	^self waitTimeoutMSecs: seconds * 1000
!

Object subclass: #Reactor
	instanceVariableNames: 'ref resolver closure'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'PromisesLocal'!

----- Method: Reactor class>>onClosure:ref:resolver: (in category 'instance creation') -----
onClosure: closure ref: ref resolver: resolver

	^ self new
		initOnClosure: closure ref: ref resolver: resolver;
		yourself.
!

----- Method: Reactor>>initOnClosure:ref:resolver: (in category 'initialize-release') -----
initOnClosure: aClosure ref: aRef resolver: aResolver

	closure := aClosure.
	ref := aRef.
	resolver := aResolver.
!

----- Method: Reactor>>isRejector (in category 'testing') -----
isRejector

	^ false!

----- Method: Reactor>>isResolver (in category 'testing') -----
isResolver

	^ false!

----- Method: Reactor>>reactToLostClient: (in category 'reacting') -----
reactToLostClient: anException

	self value: anException.
	^ nil!

----- Method: Reactor>>value: (in category 'reacting') -----
value: ignored

	closure isNil ifTrue:[^ nil].
	^ closure  cull: ref value.
!

Reactor subclass: #WhenBrokenReactor
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'PromisesLocal'!

----- Method: WhenBrokenReactor class>>isPassByConstruction (in category 'serialization') -----
isPassByConstruction

	^ true!

----- Method: WhenBrokenReactor>>isRejector (in category 'testing') -----
isRejector

	^ true!

----- Method: WhenBrokenReactor>>value: (in category 'as yet unclassified') -----
value: ignored

	| aRef aResolver aClosure result |
	closure isNil ifTrue:[^ nil].
	(ref isBroken)
		ifTrue: [
			aRef := ref.
			aResolver := resolver.
			aClosure := closure.
			ref := nil.
			resolver := nil.
			closure := nil.
			[result := aClosure cull: aRef value]
				on: Error
				do: [:ex | result := ex].
			aResolver notNil ifTrue: [
				aResolver resolve: result].
			^ nil].
	(ref isNear)
		ifTrue: [
			ref := nil.
			resolver := nil.
			closure := nil.
			^ nil].
	(ref isResolved)
		ifTrue: [^ nil]
		ifFalse: [ref whenMoreResolved: self.
			^ nil].
!

Reactor subclass: #WhenResolvedReactor
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'PromisesLocal'!

----- Method: WhenResolvedReactor class>>isPassByConstruction (in category 'serialization') -----
isPassByConstruction

	^ true!

----- Method: WhenResolvedReactor>>isResolver (in category 'testing') -----
isResolver

	^ true!

----- Method: WhenResolvedReactor>>value: (in category 'as yet unclassified') -----
value: ignored

	| aRef aResolver aClosure result |
	closure isNil ifTrue:[^ nil].
	(ref isResolved)
		ifTrue: [
			aRef := ref.
			aResolver := resolver.
			aClosure := closure.
			ref := nil.
			resolver := nil.
			closure := nil.
			[result := aClosure cull: aRef value]
				on: Error
				do: [:ex | result := ex].
			aResolver isNil 
				ifFalse: [aResolver resolve: result].
			^ nil]
		ifFalse: [
			ref whenMoreResolved: self.
			^ nil].
!

Object subclass: #Resolver
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'PromisesLocal'!

Resolver subclass: #LocalResolver
	instanceVariableNames: 'ref buf'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'PromisesLocal'!

----- Method: LocalResolver class>>onRef:buffer: (in category 'instance creation') -----
onRef: ref buffer: buf

	^ self new
		initializeOnRef: ref buffer: buf;
		yourself
!

----- Method: LocalResolver>>initializeOnRef:buffer: (in category 'initialize-release') -----
initializeOnRef: aRef buffer: aBuf

	ref := aRef.
	buf := aBuf.
!

----- Method: LocalResolver>>isDone (in category 'resolving') -----
isDone

	^ ref isNil
!

----- Method: LocalResolver>>resolve: (in category 'resolving') -----
resolve: resolutionValue

	| tmp1 |
	self isDone ifTrue: [ ^ PromiseAlreadyResolved new signal ].
	tmp1 := AbstractEventual toReferenceContext: resolutionValue.
	ref becomeContext: tmp1.
	self sendMsgsToNewRef: ref.
	ref := nil.
	^ nil
!

----- Method: LocalResolver>>sendMsgsToNewRef: (in category 'resolving') -----
sendMsgsToNewRef: newRef

	| pendingMessages msg |
	buf isNil ifTrue: [^nil].
	pendingMessages := buf readStream.
	buf := nil.
	[pendingMessages atEnd] 
		whileFalse: [
			msg := pendingMessages next.
			newRef redirectEventualMessage: msg].
!

----- Method: LocalResolver>>smash: (in category 'resolving') -----
smash: exception 

	self isDone ifTrue: [ ^ PromiseAlreadyResolved new signal ].
	^ (AbstractEventual isReference: exception)
		ifTrue: [self resolve: exception]
		ifFalse: [
			(exception class includesBehavior: Exception)
				ifTrue: [self resolve: exception]
				ifFalse: [self resolve: (BrokenEventual new 
					exception: (BrokenPromiseValue value: exception); 
					yourself)]].
!

----- Method: Resolver>>isDone (in category 'resolving') -----
isDone

	self subclassResponsibility !

----- Method: Resolver>>resolve: (in category 'resolving') -----
resolve: value

	self subclassResponsibility !

----- Method: Resolver>>smash: (in category 'resolving') -----
smash: exception

	self subclassResponsibility !

----- Method: Resolver>>smashString: (in category 'resolving') -----
smashString: exceptionTxt

	^ self smash: (Error new messageText: exceptionTxt)!

ServiceProvider subclass: #PromisesLocalServiceProvider
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'PromisesLocal'!

----- Method: PromisesLocalServiceProvider class>>initialize (in category 'initialization') -----
initialize 
	ServiceRegistry current buildProvider: self new!

MessageSend subclass: #EventualMessageSend
	instanceVariableNames: 'resolver'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'PromisesLocal'!

----- Method: EventualMessageSend class>>message: (in category 'instance creation') -----
message: aMessage

	^ self new
		selector: aMessage selector;
		arguments: aMessage arguments;
		resolver: nil;
		yourself!

----- Method: EventualMessageSend class>>message:resolver: (in category 'instance creation') -----
message: aMessage resolver: aResolver

	^ self new
		selector: aMessage selector;
		arguments: aMessage arguments;
		resolver: aResolver;
		yourself!

----- Method: EventualMessageSend class>>receiver:resolver:selector: (in category 'instance creation') -----
receiver: anObject resolver: aResolver selector: aSymbol
	^ (super receiver: anObject selector: aSymbol)
		resolver: aResolver;
		yourself!

----- Method: EventualMessageSend class>>receiver:resolver:selector:arguments: (in category 'instance creation') -----
receiver: anObject resolver: aResolver selector: aSymbol arguments: anArray
	^ (super receiver: anObject selector: aSymbol arguments: anArray)
		resolver: aResolver;
		yourself!

----- Method: EventualMessageSend class>>selector: (in category 'as yet unclassified') -----
selector: aSymbol
	^ (super receiver: nil selector: aSymbol)
		resolver: nil;
		yourself!

----- Method: EventualMessageSend class>>selector:arguments: (in category 'as yet unclassified') -----
selector: aSymbol arguments: anArray
	^ (super receiver: nil selector: aSymbol arguments: anArray)
		resolver: nil;
		yourself!

----- Method: EventualMessageSend class>>selector:arguments:resolver: (in category 'as yet unclassified') -----
selector: aSymbol arguments: anArray resolver: aResolver 
	^ (super receiver: nil selector: aSymbol arguments: anArray)
		resolver: aResolver;
		yourself!

----- Method: EventualMessageSend class>>selector:resolver: (in category 'as yet unclassified') -----
selector: aSymbol resolver: aResolver 
	^ (super receiver: nil selector: aSymbol)
		resolver: aResolver;
		yourself!

----- Method: EventualMessageSend>>isOneWay (in category 'testing') -----
isOneWay

	^ self resolver isNil!

----- Method: EventualMessageSend>>isRejector (in category 'testing') -----
isRejector

	^ (self selector == #whenMoreResolved:) 
		and: [self arguments first isRejector]!

----- Method: EventualMessageSend>>printOn: (in category 'private') -----
printOn: t1 
	| t2 |
	t1 nextPutAll: 'EventualSend ('.
	receiver printOn: t1.
	t1 nextPutAll: ' '.
	(selector isUnary
			or: [selector isInfix])
		ifTrue: [selector printOn: t1.
			t1 nextPutAll: ' '.
			self arguments
				do: [:t3 | t1 print: t3]
				separatedBy: [t1 nextPutAll: ' ']]
		ifFalse: [t2 := (self selector subStrings: ':')
						collect: [:t3 | t3 asSymbol asSimpleSetter asString].
			t2
				with: self arguments
				do: [:t3 :t4 | 
					t1 nextPutAll: ' ';
						 nextPutAll: t3;
						 nextPutAll: ' '.
					t4 printOn: t1]].
	t1 nextPutAll: ') -> ['.
	resolver printOn: t1.
	t1 nextPutAll: ']'!

----- Method: EventualMessageSend>>resolve: (in category 'api') -----
resolve: ref

	self resolver ifNotNil: [self resolver resolve: ref].!

----- Method: EventualMessageSend>>resolver (in category 'accessing') -----
resolver

	^ resolver!

----- Method: EventualMessageSend>>resolver: (in category 'accessing') -----
resolver: aResolver

	resolver := aResolver!

----- Method: EventualMessageSend>>smash: (in category 'api') -----
smash: exception

	self resolver ifNotNil: [self resolver smash: exception].!

----- Method: EventualMessageSend>>value (in category 'api') -----
value

	| value |
	[
		value := receiver
			perform: selector 
			withArguments: (self collectArguments: arguments)
			inSuperclass: receiver class.
		self resolver notNil ifTrue: [ self resolver resolve: value ]
	] 
		on: Exception
		do: [:ex |
			self resolver ifNotNil: [:r | r smash: ex].
			(ex isKindOf: Halt)
				ifTrue: [ex pass]
				ifFalse: [ELib debugEventualException: ex]].

!

Process subclass: #EventualProcess
	instanceVariableNames: 'eventualName vat'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'PromisesLocal'!

----- Method: EventualProcess class>>forContext:priority:onVat: (in category 'instance creation') -----
forContext: aContext priority: anInteger onVat: aVat
	"Answer an instance of me that has suspended aContext at priority 
	anInteger."

	| newProcess |
	newProcess := self newOnVat: aVat.
	newProcess suspendedContext: aContext.
	newProcess priority: anInteger.
	^newProcess!

----- Method: EventualProcess class>>newOnVat: (in category 'instance creation') -----
newOnVat: vat 
	^ super new
		priority: Processor userBackgroundPriority;
		eventualName: 'vat thread';
		vat: vat;
		setupContext;
		yourself!

----- Method: EventualProcess>>eventualName (in category 'accessing') -----
eventualName

	^ eventualName!

----- Method: EventualProcess>>eventualName: (in category 'accessing') -----
eventualName: aName

	eventualName := aName.
!

----- Method: EventualProcess>>printOn: (in category 'accessing') -----
printOn: aStream

	aStream nextPutAll: '{squeake'.
	self eventualName notNil
		ifTrue: [
			aStream nextPutAll: '-'.
			aStream nextPutAll: self eventualName asString].
	aStream nextPutAll: '} '.
	super printOn: aStream.
!

----- Method: EventualProcess>>resume (in category 'changing process state') -----
resume

	(Processor activeProcess == self)
		ifTrue: [self resumeAsProcess]
		ifFalse: [self resumeInVat].
!

----- Method: EventualProcess>>resumeAsProcess (in category 'changing process state') -----
resumeAsProcess

	super resume.!

----- Method: EventualProcess>>resumeInVat (in category 'changing process state') -----
resumeInVat

	self vat schedule: self suspendedContext.!

----- Method: EventualProcess>>setupContext (in category 'initialize-release') -----
setupContext

	self suspendedContext: [
		self vat processSends.
		Processor terminateActive] asContext.!

----- Method: EventualProcess>>vat (in category 'accessing') -----
vat

	^ vat!

----- Method: EventualProcess>>vat: (in category 'accessing') -----
vat: aVat

	vat := aVat!

----- Method: Process>>vat (in category '*promiseslocal') -----
vat

	^ PriorityVat localVat.!

----- Method: BlockClosure>>eventual (in category '*promiseslocal') -----
eventual

	| pair eMsg |
	pair := AbstractEventual promiseInVat: self vat.
	eMsg := EventualMessageSend receiver: self resolver: pair value selector: #value.
	self vat schedule: eMsg.
	^ pair key

!

----- Method: ProtoObject>>basicEquivalence: (in category '*promiseslocal') -----
basicEquivalence: anObject
	"Primitive. Answer whether the receiver and the argument are the same 
	object (have the same object pointer). Do not redefine the message == in 
	any other class!! Essential. No Lookup. Do not override in any subclass. 
	See Object documentation whatIsAPrimitive."

	<primitive: 110>
	self primitiveFailed!

----- Method: ProtoObject>>defaultLabelForInspector (in category '*promiseslocal') -----
defaultLabelForInspector
	"Answer the default label to be used for an Inspector window on the receiver."

	^ self class name!

----- Method: ProtoObject>>inspect (in category '*promiseslocal') -----
inspect
	"Create and schedule an Inspector in which the user can examine the receiver's variables."

	Inspector openOn: self withEvalPane: true!

----- Method: ProtoObject>>isBroken (in category '*promiseslocal') -----
isBroken

	^ false!

----- Method: ProtoObject>>isEventual (in category '*promiseslocal') -----
isEventual

	^ false
!

----- Method: ProtoObject>>isFulfilled (in category '*promiseslocal') -----
isFulfilled

	^ self isNear
!

----- Method: ProtoObject>>isNear (in category '*promiseslocal') -----
isNear

	^ true!

----- Method: ProtoObject>>isPromise (in category '*promiseslocal') -----
isPromise

	^ false
!

----- Method: ProtoObject>>isProxy (in category '*promiseslocal') -----
isProxy

	^ false
!

----- Method: ProtoObject>>isResolved (in category '*promiseslocal') -----
isResolved

	^ self isPromise not
!

----- Method: ProtoObject>>redirectEventualMessage: (in category '*promiseslocal') -----
redirectEventualMessage: anEventualMessage

	anEventualMessage receiver: self.
	self vat schedule: anEventualMessage.
!

----- Method: ProtoObject>>resolution (in category '*promiseslocal') -----
resolution

	^ self!

----- Method: ProtoObject>>vat (in category '*promiseslocal') -----
vat

	^ Processor activeProcess vat
!

TestCase subclass: #PriorityVatTest
	instanceVariableNames: 'eventReceived'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'PromisesLocal-Testing'!

----- Method: PriorityVatTest>>tearDown (in category 'initialize-release') -----
tearDown

	(PriorityVat clearLocalVat; localVat) restartEventLoop.
!

----- Method: PriorityVatTest>>testPriorityVat (in category 'testing') -----
testPriorityVat

	| vat |
	vat := PriorityVat newWithNick: 'testVat'.
	eventReceived := false.
	vat schedule: [eventReceived := true].
	(Delay forMilliseconds: 1) wait.
	self assert: eventReceived.
	vat stop.!

TestCase subclass: #RefsTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'PromisesLocal-Testing'!

----- Method: RefsTest>>tearDown (in category 'initialize-release') -----
tearDown

	(PriorityVat clearLocalVat; localVat) restartEventLoop.
!

----- Method: RefsTest>>testArithmeticPrimitivesWithPromiseReceiver (in category 'testing') -----
testArithmeticPrimitivesWithPromiseReceiver
	| t1 t2 |
	t1 := 42 eventual.
	t2 := 10.
	t1 * t2
		whenResolved: [:t3 | 
			self assert: t3 resolution == 420]!

----- Method: RefsTest>>testBasicPromiseResolution (in category 'testing') -----
testBasicPromiseResolution

	| pair |
	pair := AbstractEventual promise.
	self assert: pair key isEventual.
	pair value resolve: 'rob'.
	self assert: pair key isNear.
	self assert: pair key = 'rob'.
!

----- Method: RefsTest>>testBasicPromiseSmashing (in category 'testing') -----
testBasicPromiseSmashing
	| pair |
	pair := AbstractEventual promise.
	self assert: pair key isEventual.
	pair value smashString: 'test promise smashing'.
	self assert: pair key isBroken.
	self
		should: [pair key immediate]
		raise: Error!

----- Method: RefsTest>>testBasicPromiseToBooleanResolution (in category 'testing') -----
testBasicPromiseToBooleanResolution
	| tmp1 |
	tmp1 := AbstractEventual promise.
	self assert: tmp1 key isEventual.
	tmp1 value resolve: true.
	self
		assert: tmp1 key isNear;
		assert: tmp1 key = true!

----- Method: RefsTest>>testBlockClosure (in category 'testing') -----
testBlockClosure

	| result |
	[42 * 10] eventual whenResolved: [:r | result := r resolution].
	(Delay forMilliseconds: 100) wait.
	self assert: result = 420.!

----- Method: RefsTest>>testFailureArithmeticPrimitivesWithPromiseArgument (in category 'testing') -----
testFailureArithmeticPrimitivesWithPromiseArgument

	| num1 num2 |
	num1 := 10.
	num2 := 42 eventual.
	[num1 * num2 
		whenResolved: [:result | self assert: result == 420].
	self assert: false]
			on: Exception do: [:ex | ^ self assert: true].
	self assert: false!

----- Method: RefsTest>>testLocalResolve (in category 'testing') -----
testLocalResolve

	| pair |
	pair := AbstractEventual promise.
	pair value resolve: 'rob'.
	self assert: (pair key = 'rob').
	self should: [pair value smashString: 'test smash'] raise: Error.
!

----- Method: RefsTest>>testLocalSmash (in category 'testing') -----
testLocalSmash
	| pair |
	pair := AbstractEventual promise.
	pair value smashString: 'smash promise test'.
	self
		should: [pair key foobar]
		raise: Error.
	self
		should: [pair value smashString: 'smash promise test']
		raise: Error!

----- Method: RefsTest>>testNearRefs (in category 'testing') -----
testNearRefs
	| obj |
	obj := Object new.
	self assert: (obj eventual = obj eventual).
!

----- Method: RefsTest>>testUsedLocalResolver (in category 'testing') -----
testUsedLocalResolver

	| resolver |
	resolver := LocalResolver onRef: nil buffer: nil.
	self assert: resolver isDone.
	self should: [resolver resolve: 2] raise: Error.
	self should: [resolver smashString: 'test smash'] raise: Error.
!

----- Method: RefsTest>>testWhenBroken (in category 'testing') -----
testWhenBroken

	| result oldForkDebugger |
	oldForkDebugger := ELib forkDebugger.
	ELib forkDebugger: false.
	42 eventual / 0
		whenBroken: [:t3 | 
			result := t3 resolution.
			self assert: result isError].
	(Delay forMilliseconds: 100) wait.
	self assert: (result class == ZeroDivide).
	ELib forkDebugger: oldForkDebugger.
!

----- Method: RefsTest>>testWhenResolved (in category 'testing') -----
testWhenResolved

	| result  t1 t2 |
	t1 := 42 eventual.
	t2 := 10.
	t1 * t2
		whenResolved: [:t3 | 
			result := t3 resolution.
			self assert: result == 420].
	(Delay forMilliseconds: 100) wait.
	self assert: result == 420.!

Error subclass: #BrokenPromise
	instanceVariableNames: 'exception'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'PromisesLocal'!

!BrokenPromise commentStamp: 'tonyg 2/17/2017 13:53' prior: 0!
I am signalled when, during a Promise>>wait, the promise is rejected.
	promise:		the promise itself.
!

----- Method: BrokenPromise>>defaultAction (in category 'as yet unclassified') -----
defaultAction
	self messageText: 'Promise was rejected'.
	^super defaultAction!

----- Method: BrokenPromise>>exception (in category 'as yet unclassified') -----
exception
	^ exception!

----- Method: BrokenPromise>>exception: (in category 'as yet unclassified') -----
exception: aX
	exception := aX!

----- Method: BrokenPromise>>isResumable (in category 'as yet unclassified') -----
isResumable
	^ true!

----- Method: BrokenPromise>>promise (in category 'as yet unclassified') -----
promise
	^ self exception!

Error subclass: #BrokenPromiseValue
	instanceVariableNames: 'value'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'PromisesLocal'!

----- Method: BrokenPromiseValue class>>value: (in category 'instance creation') -----
value: obj

	^ self new
		value: obj;
		yourself!

----- Method: BrokenPromiseValue>>defaultAction (in category 'handling') -----
defaultAction

	self messageText: 'Promise was rejected with value: ', value.
	^super defaultAction!

----- Method: BrokenPromiseValue>>isResumable (in category 'handling') -----
isResumable

	^ true!

----- Method: BrokenPromiseValue>>value (in category 'accessing') -----
value

	^ value.!

----- Method: BrokenPromiseValue>>value: (in category 'accessing') -----
value: anObject

	value := anObject.!

Error subclass: #PromiseAlreadyResolved
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'PromisesLocal'!



More information about the Squeak-dev mailing list