VBA promise implementation

Here's how the promise framework  is implemented. This is kind of extreme VBA and Excel is very unforgiving. If you are playing around with this, I advise saving often.

cDeferred versus cPromise

These two classes tend to be used interchangeably in some of my descriptions, but they are quite different. In my VBA implementation, a promise is a property of a deferred. A deferred is used to signal status and record the data to be passed following some action, whereas a promise is the messenger of that status. Generally speaking deferreds are accessed by the performer of the action just once, and are about sending a signal.  Promises are used to react to the resolution of an action and are about receiving a signal.

A typical app might look like this in pseudo code, where the 'process' class would take care of doing something with data retrieved asynchronously.

sub asyncdata
    asyncdata.done(process,"store").fail(process,"error")    
end sub
   
function asyncdata
    set defer = new cDeferred
    getsomedata(defer)
    asyncdata = defer.promise()
end function

sub getsomedata(defer)
    data = getthedata
    if (somerror) then
         defer.reject(someerror)
   else
         defer.resolve(data)
   endif
 end sub   

cDeferred class

The deferred object is the parent of the cPromise class. The main interface members of the cDeferred class are
  • .resolve ( array(data) ) 
this is called to signal the promise that it can execute its .done() method. It is recommended that data is encapsulated in an array so that extra items can be added later, and to protect the messenger classes from needing to worry about data typing. Self reference is returned for chaining.
  • .reject( array(errorData) ) 
this is called to signal the promise that it can execute its .fail() method. It is recommended that data is encapsulated in an array so that extra items can be added later, and to protect the messenger classes from needing to worry about data typing. Self reference is returned for chaining.

Each of these signal their .promise by raising a .completed( array(data) ) event, which .promise is listening for. 

Option Explicit
' this is vba hack of a jquery $.Deferred()
Private pPromise As cPromise
Private pStatus As Long
' this will be raised when resolved/rejected to coerce promise execution
Public Event completed(data As Variant)
Public Property Get isResolved() As Boolean
    isResolved = (pStatus = 1)
End Property
Public Property Get isRejected() As Boolean
    isRejected = (pStatus = 2)
End Property
Public Property Get isCompleted() As Boolean
    isCompleted = isRejected Or isResolved
End Property
Public Property Get promise() As cPromise
    Set promise = pPromise
End Property
Private Function complete(data As Variant) As cDeferred
    ' the data can be a series of arguments
    promise.setData (data)
    Set complete = Me
    ' alert promise we've been completed
    RaiseEvent completed(data)
End Function
Public Function resolve(data As Variant) As cDeferred
    ' all is good - will execite promise.done()
    pStatus = 1
    Set resolve = complete(data)
End Function
Public Function reject(data As Variant) As cDeferred
    ' all is bad - will execute promise.fail()
    pStatus = 2
    Set reject = complete(data)
End Function
Public Sub tearDown(Optional a As Variant)
    promise.tearDown
    Set pPromise = Nothing
End Sub
Private Sub class_initialize()
    Set pPromise = New cPromise
    promise.init Me
    pStatus = 0
End Sub

cPromise class

The cPromise object is the child of the cDeferred class. A completed event in its parent cDeferred class will provoke an execute of either the queue of actions in the .done() queue or in the .fail() queue. The main interface members of the cPromise class are
  • .done (callback As Object, method As String,  Optional defer As cDeferred = Nothing,  Optional args As Variant)
This adds execution of callback.method(data, defer, args) to the .done() queue, waiting for a .resolve() signal from its parent cDeferred. If .done() is called after the promise is resolved, it will execute calback.method(data,defer,args) immediately. Items are removed from the queue immediately on execution, so will only be executed once and strictly in sequence. Self reference is returned for chaining.
  • .fail (callback As Object, method As String,  Optional defer As cDeferred = Nothing,  Optional args As Variant)
This adds execution of callback.method(errorData, defer, args) to the .fail() queue, waiting for a .reject() signal from its parent cDeferred. If .fail() is called after the promise is resolved, it will execute calback.method(data,defer,args) immediately. Items are removed from the queue immediately on execution, so will only be executed once and strictly in sequence.Self reference is returned for chaining.

Option Explicit
' we are going to be alerted by events going on in the parent object
Private WithEvents pDeferred As cDeferred
' these are things to do when completed
Private pSucceeds As Collection
Private pFails As Collection
Private pWhens As Collection
' this is the data that arrives when resolved/rejected
Private pData As Variant
Public Function init(parent As cDeferred) As cPromise
    Set pDeferred = parent
    Set init = Me
End Function
' data arguments are unknown in quantity/type
Public Function setData(arr As Variant) As cPromise
    pData = arr
    Set setData = Me
End Function
Public Property Get deferred() As cDeferred
    Set deferred = pDeferred
End Property
' retrieve the arguments
Public Function getData() As Variant
    getData = pData
End Function
' we are being asked to record an action to take on either success or failure
Private Function queueUp(coll As Collection, _
            callback As Object, method As String, _
            Optional defer As cDeferred = Nothing, _
            Optional args As Variant) As cPromise
    Dim cb As cCallback
    Set cb = New cCallback
    ' add to the list of things that need to be done when resolved
    
    coll.add cb.init(callback, method, defer, args)
    ' do them all in case already resolved
    execute
    Set queueUp = Me
End Function
' queueUp a failure action
Public Function fail(callback As Object, method As String, _
        Optional defer As cDeferred = Nothing, _
        Optional args As Variant) As cPromise
    Set fail = queueUp(pFails, callback, method, defer, args)
End Function
' queueUp a success action
Public Function done(callback As Object, method As String, _
        Optional defer As cDeferred = Nothing, _
        Optional args As Variant) As cPromise
    Set done = queueUp(pSucceeds, callback, method, defer, args)
End Function
' do anything in the queue
Private Sub execute()
    ' do the successes
    If pDeferred.isResolved Then flush pSucceeds
    ' and the failures
    If pDeferred.isRejected Then flush pFails
    ' resolve any completed whens
    dealWithWhens
    
End Sub
Private Sub flush(coll As Collection)
    Dim cb As cCallback, n As Long, i As Long
    ' destroy the callback after execution so it only happens once
    '
    n = coll.Count
    For i = 1 To n
        Set cb = coll(1)
        CallByName cb.callback, cb.method, VbMethod, getData, cb.defer, cb.args
        coll.remove (1)
        cb.tearDown
    Next i

End Sub
Public Property Get whens() As Collection
    Set whens = pWhens
End Property
Private Sub class_initialize()
    Set pSucceeds = New Collection
    Set pFails = New Collection
    Set pWhens = New Collection
End Sub
Public Sub tearDown(Optional a As Variant)
    Dim act As cCallback
    For Each act In pSucceeds
        act.tearDown
    Next act
    Set pSucceeds = Nothing
    For Each act In pFails
        act.tearDown
    Next act
    Set pFails = Nothing
    Set pDeferred = Nothing
End Sub
Private Sub pDeferred_completed(a As Variant)
    ' do anything queued
    ' this event is called when deferred is resolved/rejected
    execute
    '
End Sub
Private Sub dealWithWhens()
    ' may be part of some whens
    Dim w As cWhen
    For Each w In pWhens
        w.completed
    Next w
End Sub



cWhen class

The cWhen class is not normally called directly, but rather through the when() function. The interface to when is
  • when( array(promises,...) ,array(promises,..),...) 
All promises is in all arrays need to be resolved or rejected for the promise that is returned by when to get either resolved or rejected. If any promise fails, the promise returned will be rejected. All promises need to be resolved successfully for the when.promise to be resolved. As a convenience, the data associated with the last promise in all arrays is passed to the .done() or .fail() method of when.promise

when returns a cPromise, which means that you can chain .done() or .fail() to a when() function.
Public Function when(ParamArray arr() As Variant) As cPromise
' kind of like jquery $.when()
    Dim i As Long, n As Long, combinedPromises As Variant, j As Long
    n = 0
' the paramarray is an array of arrays of promises. combining then into one list
    For i = LBound(arr) To UBound(arr)
        n = n - LBound(arr(i)) + UBound(arr(i)) + 1
    Next i
    ReDim combinedPromises(0 To n - 1)
    n = LBound(combinedPromises)
    
    For i = LBound(arr) To UBound(arr)
        For j = LBound(arr(i)) To UBound(arr(i))
            Set combinedPromises(n) = arr(i)(j)
            n = n + 1
        Next j
    Next i
    
 ' now process a long list of whens
    Dim w As cWhen
    Set w = New cWhen
    Set when = w.when(combinedPromises)
End Function

cWhen
Option Explicit
Private pDeferred As cDeferred
Private pPromises As Collection
Public Function when(arrayOfPromises As Variant) As cPromise
    ' we need to listen to each of the promises mention in array
    ' when all are done we can resolve
    Dim i As Long, p As cPromise, d As cDeferred
    Set pDeferred = New cDeferred
    For i = LBound(arrayOfPromises) To UBound(arrayOfPromises)
        ' each promise can belong to a collection of whens
        Set p = arrayOfPromises(i)
        p.whens.add Me
        pPromises.add p
    Next i
    Set when = pDeferred.promise()
End Function
Public Sub completed()
    ' this will be called as a promise is executed.
    ' when all in the collection are done. we can resolve this
    Dim p As cPromise, f As Long, lp As cPromise
    f = 0
    For Each p In pPromises
        ' they all have to be completed
        Set lp = p
        If (Not p.deferred.isCompleted) Then Exit Sub
        If (p.deferred.isRejected) Then f = f + 1
    Next p
    ' all have been done, so resolve or reject it
    ' what gets passed is the data belongnig to the last promise
    If f = 0 Then
        pDeferred.resolve (lp.getData)
    Else
        pDeferred.reject (Array("when rejected with " & f & " failures"))
    End If
End Sub
Private Sub class_initialize()
    Set pDeferred = New cDeferred
    Set pPromises = New Collection
End Sub
Public Function tearDown()
    Dim i As Long, p As cPromise, n As Long
    pDeferred.tearDown
    Set pDeferred = Nothing
    n = pPromises.Count
    For i = 1 To n
        Set p = pPromises(i)
        Set p = Nothing
        pPromises.remove (1)
    Next i
    Set pPromises = Nothing
End Function


cDeferredRegister class

In order to avoid dropping out of memory, out of scope variable are referenced in a public register. This class is normally accessed through these functions.
  • keepInRegister(o As Object, Optional oName As String = vbNullString, Optional oType As String = vbNullString) As Object
This adds an object reference with the given name and type. The name and type are only used for later listing and debugging. Self reference is returned for chaining.
  • clearRegister()
Removes all register items and attempts to execute a tearDown class if they have one. Should be called when all aync activity is ended, and as very first call in a fresh session.

  • register.list
Can be useful for debugging. It will produce a list like this.

register.list
these items are being kept in memory
248811352     cProcessData
266750400     cEventTimer
266749920     cBackoff
264238376     cHttpDeferredHelper
358537424     cHttpDeferred
schema        cJobject
266750592     cEventTimer
266750496     cBackoff
264239816     cHttpDeferredHelper
269075400     cHttpDeferred

   One of the trickiest things is to get the arguments right for reject,resolve,done and fail. If you get that wrong, the error will show here in the cPromise() class

        CallByName cb.callback, cb.method, VbMethod, getData, cb.defer, cb.args

 To identify which object is being called, inspect ObjPtr(cb.callback) which will be one of the addresses returned by register.list , and cb.Method which will be a string with the name of the method within the class.

Option Explicit
Public register As cDeferredRegister
Public Function keepInRegister(o As Object, Optional oName As String = vbNullString, _
        Optional oType As String = vbNullString) As Object
    Set keepInRegister = keepSafe(register, o, oName, oType)
End Function

Public Function keepSafe(reg As cDeferredRegister, _
        o As Variant, Optional oName As String = vbNullString, _
        Optional oType As String = vbNullString) As Object
    
    If register Is Nothing Then Set register = New cDeferredRegister
    Set keepSafe = reg.register(o, oName, oType)
End Function
Public Function clearRegister() As cDeferredRegister
    If register Is Nothing Then Set register = New cDeferredRegister
    register.tearDown
End Function

cDeferredRegister
Option Explicit
' when doing asynchronous things, local variables can go out of scope and be garbage collected
' the purpose of this class is to register an interest in local variables so they dont
' and instance of this class should be declared at module level so it stays in scope when your proc exits
' doing it this way avoids lots of global variables
Private pInterests As Collection
Public Sub list(Optional data As Variant, _
        Optional defer As cDeferred, Optional args As Variant)
    Dim x As cRegisterItem, i As Long
    Debug.Print "these items are being kept in memory"
    For i = 1 To pInterests.Count
        Set x = pInterests(i)
        Debug.Print x.oName, x.oType
    Next i
End Sub
Public Sub tearDown(Optional data As Variant, _
        Optional defer As cDeferred, Optional args As Variant)
    Dim c As Variant, n As Long, i As Long, x As cRegisterItem
    n = pInterests.Count
    For i = 1 To n
        Set x = pInterests(1)
        Set c = x.ob
        tryToTearDown c
        Set c = Nothing
        pInterests.remove (1)
        Set x = Nothing
    Next i
End Sub
Public Function register(o As Variant, Optional oName As String = vbNullString, _
        Optional oType As String = "unknown type") As Variant
    Dim x As cRegisterItem
    Set x = New cRegisterItem
    If oName = vbNullString Then
        If IsObject(o) Then
            oName = CStr(ObjPtr(o))
        Else
            oName = CStr(ObjPtr(x))
        End If
    End If

    x.init o, oName, oType
    pInterests.add x, oName
    Set register = x
End Function
Private Function tryToTearDown(c As Variant) As Boolean
    ' this will try to execute a teardown if it has one
    On Error GoTo failed
    c.tearDown
    tryToTearDown = True
    Exit Function
    
failed:
    tryToTearDown = False
    
End Function
Private Sub class_initialize()
    Set pInterests = New Collection
End Sub
Since this is in the early stages of development the code is in a separate workbook (promises.xlsm) and can be downloaded here

For help and more information join our forum,follow the blog or follow me on twitter .

Comments