Wednesday 14 February 2018

VBA - Lambda Expressions - C# feature implemented with JScript

Summary: Use JScript in ScriptControl to replicate the C# feature of lambda expressions leveraging the FunctionDelegate pattern found previously here on this blog.

So in a I showed how we can implement a FunctionDelegate to abstract away Application.Run and CallByName. The pattern is a useful one and we can add a third and fourth implementation. The third implementation is a Javascript function delegate and the fourth is a lambda expression based on Javascript.

The JavaScript Function Delegate

So we needed to update the factory class FnFactory (and that is given below) to create accept the source of a Javascript function as a parameter. We create an instance of the ScriptControl for the purposes of compilation only, we can harvest the name of the javascript function from the ScriptControl's own parsing of the function which is useful for when we want to call Run.

At execution time we created another instance of the ScriptControl, add the source and call the Run method. This is the simplest pattern. We could have been cleverer and shared ScriptControl instances. We could also feed in some global objects such as Application, ActiveWorkbook and ActiveSheet the existence of which VBA code can rely upon. For the time being we'll keep it simple.

If your Javascript has a compilation error you will get an error message of the pattern...

#Failed to create javascript function delegate because compilation failed with code (1004) and message 'Expected ';''

If you blink and you missed it then you can always call FnFactory.LastError which caches the last error.

Test examples are given in the test module (given module) here is a snippet. They demonstrate that you need to write in javascript (and not VBA!). So comparisons in Javascript use triple equals.

Private Sub TestFNJavascript0()

    Dim oFnDelegate As FunctionDelegate
    Set oFnDelegate = FnFactory.FnJavascript("function foo(bar) { return bar===1; }")

    Debug.Assert oFnDelegate.Run(0) = False
    Debug.Assert oFnDelegate.Run(1) = True

    Dim oFnDelegate2 As FunctionDelegate
    Set oFnDelegate2 = FnFactory.FnJavascript("function foo2(x) { return Math.pow(x,2)-4*x-5; }")
    
    Debug.Assert oFnDelegate2.Run(5) = 0 'root
    Debug.Assert oFnDelegate2.Run(-1) = 0 'root

    Debug.Assert oFnDelegate2.Run(1) = -8

End Sub

The Lambda Function Delegate

So the Lambda Function Delegate is based on the JavaScript Function, we simply look for the arrow operator => and see that as the dividing line between arguments to be passed (found on the left of the arrow) and implementation code (found to the right of the arrow). To convert to a javascript function is easy, we make up a function name using a random number, we place brackets around the arguments, we scrap the arrow and wrap the implementation code in curly brackets; finally, we add a return keyword to the final statement.

This means we can write lambda expression of the following form which respectively (i) test for equality to one, (2) adds two number...

    bar => bar===1
    x,y => x+y

We can even handle multi-statements and split on semi-colons (so please do not pass semi-colons inside strings or the code will break). So both the following do some Fibonacci logic, the first expression is hard coded to find the 6th Fibonacci term (given first two terms), the second expression calculates the n'th Fibonacci term.

    a,b =>  c=a+b; d=c+b; e=c+d; d+e 
    n => var fib = [0, 1]; for(var i=fib.length; i<=n; i++) {  fib.push( fib[i-2] + fib[i-1]);} ; fib[n]

So just to be clear the above expressions get compiled to the following javascript functions under the hood

function f96195316(bar) { return bar===1;}
function f87144583(x,y) { return x+y;}
function f56236861(a,b) { c=a+b; d=c+b; e=c+d; return  d+e ;}
function f36401868(n)   { var fib = [0, 1]; for(var i=fib.length; i<=n; i++) {  fib.push( fib[i-2] + fib[i-1]);} ; return  fib[n];}

And so here is the code, two classes and a standard module. Requires a Tools->Reference to Microsoft Script Control 1.0

The FnFactory class (global instancing)


Option Explicit

'* Tools References
'*   MSScriptControl    Microsoft Script Control 1.0    C:\Windows\SysWOW64\msscript.ocx


'---------------------------------------------------------------------------------------
' Module    : FnFactory
' DateTime  : 06/02/2018 15:57
' Author    : Simon
' Purpose   : Contains factory methods to frees us from the syntactical constraints
'             around the New keyword
' Deployment: Open a text editor and ensure the line reads "Attribute VB_PredeclaredId = True"
'             so that one will not need to New this module!
'---------------------------------------------------------------------------------------

Private msLastError As String

'---------------------------------------------------------------------------------------
' Procedure : LastError
' DateTime  : 14/02/2018 17:54
' Author    : Simon
' Purpose   : returns a copy of last error
'---------------------------------------------------------------------------------------
' Arguments :
'    [out,retval]   : returns a copy of last error
'
Public Function LastError() As String
    LastError = msLastError
End Function



'---------------------------------------------------------------------------------------
' Procedure : FnJavascript
' DateTime  : 14/02/2018 17:50
' Author    : Simon
' Purpose   :
'---------------------------------------------------------------------------------------
' Arguments :
'    [in] sJavaScriptFunction    : the JavaScript function source
'    [in] bReturnTypeIsObject    : whether or not we need to say 'Set foo=Run(...' for returning an object
'    [out,retval]                : returns a create instance of FunctionDelegate containing the passed details
'
Public Function FnJavascript(ByVal sJavaScriptFunction As String, _
                            Optional ByVal bReturnTypeIsObject As Boolean) As FunctionDelegate
    
    Dim oNewFD As FunctionDelegate
    Set oNewFD = New FunctionDelegate
    
    oNewFD.JavaScriptFunction = sJavaScriptFunction
    
    '* Tools References
    '*   MSScriptControl    Microsoft Script Control 1.0    C:\Windows\SysWOW64\msscript.ocx
    Dim oSCForCompilationOnly As MSScriptControl.ScriptControl
    Set oSCForCompilationOnly = New MSScriptControl.ScriptControl
    oSCForCompilationOnly.Language = "JScript"
    
    Dim lSavedErrNum  As Long
    Dim sSavedErrDesc As String
    On Error Resume Next
    oSCForCompilationOnly.AddCode sJavaScriptFunction
    lSavedErrNum = Err.Number
    sSavedErrDesc = Err.Description
    On Error GoTo 0
    
    If lSavedErrNum <> 0 Then
    
        Dim sMsg As String
        msLastError = "#Failed to create javascript function delegate because compilation failed " & _
                    "with code (" & lSavedErrNum & ") and message '" & sSavedErrDesc & "'"
        Err.Raise vbObjectError, , msLastError
    Else
        '* so it compiled and not we can tease out details
        Dim oNewestProc As MSScriptControl.Procedure
        Set oNewestProc = oSCForCompilationOnly.Procedures.Item(oSCForCompilationOnly.Procedures.Count)
            
        oNewFD.HasReturnValue = oNewestProc.HasReturnValue
        oNewFD.JavaScriptName = oNewestProc.Name
        oNewFD.NumArgs = oNewestProc.NumArgs
        
        oNewFD.ReturnTypeIsObject = bReturnTypeIsObject
        'Stop
        
        
    End If
    
    Set FnJavascript = oNewFD

End Function


'---------------------------------------------------------------------------------------
' Procedure : FnJsLamda
' DateTime  : 14/02/2018 17:56
' Author    : Simon
' Purpose   : Takes a lambda expression and rewrites it as a javascript function and passes
'             it to create a javascript function delegate
'---------------------------------------------------------------------------------------
' Arguments :
'    [in] sJavaScriptFunction    : the Lambda expression (uses JavaScript syntax underlying)
'    [in] bReturnTypeIsObject    : whether or not we need to say 'Set foo=Run(...' for returning an object
'    [out,retval]                : returns a create instance of FunctionDelegate containing the passed details
'
Public Function FnJsLamda(ByVal sJsLamda As String, Optional ByVal bReturnTypeIsObject As Boolean) As FunctionDelegate

    If Len(sJsLamda) = 0 Then Err.Raise vbObjectError, "", "#Error null sJsLamda!"
    
    Dim lArrowAt As Long
    lArrowAt = VBA.InStr(1, sJsLamda, "=>", vbTextCompare)
    If lArrowAt = 0 Then Err.Raise vbObjectError, "", "#Could not find arrow operator '=>' in sJsLamda '" & sJsLamda & "'!"
    If VBA.InStr(lArrowAt + 1, sJsLamda, "=>", vbTextCompare) > 0 Then Err.Raise vbObjectError, "", _
                               "#Found more than one arrow operator '=>' in sJsLamda '" & sJsLamda & "'!"
    
    Dim vSplit As Variant
    vSplit = VBA.Split(sJsLamda, "=>")
    
    
    
    Dim lSemiColonsAfterArrow As Long
    lSemiColonsAfterArrow = CountOccurrences(vSplit(1), ";")
    
    If lSemiColonsAfterArrow <> CountOccurrences(sJsLamda, ";") Then Err.Raise vbObjectError, , _
                               "#Semicolons should only appear after arrow in sJsLamda '" & sJsLamda & "'!"
    
    
    If lSemiColonsAfterArrow = 0 Then
        Dim sDummyFunction As String
        sDummyFunction = "function f" & CLng((Rnd(1)) * 10 ^ 8) & "(" & Trim(vSplit(0)) & ") { return " & Trim(vSplit(1)) & ";}"
    
    Else
        '* we have a multi statement function so we have to splice in the return keyword
    
        Dim vSplitOnSemiColons As Variant
        vSplitOnSemiColons = VBA.Split(vSplit(1), ";")
        
        vSplitOnSemiColons(UBound(vSplitOnSemiColons)) = " return " & vSplitOnSemiColons(UBound(vSplitOnSemiColons)) & ";"
        
        Dim sRejoined As String
        sRejoined = VBA.Join(vSplitOnSemiColons, ";")
    
        sDummyFunction = "function f" & CLng((Rnd(1)) * 10 ^ 8) & "(" & Trim(vSplit(0)) & ") { " & Trim(sRejoined) & "}"
    
    End If
    
    Set FnJsLamda = FnJavascript(sDummyFunction, bReturnTypeIsObject)


End Function

'---------------------------------------------------------------------------------------
' Procedure : CountOccurrences
' DateTime  : 14/02/2018 17:55
' Author    : Simon
' Purpose   :
'---------------------------------------------------------------------------------------
' Arguments :
'    [in] sText     : the string in which to search
'    [in] sChar     : the character(s) for which to search
'    [out,retval]   : the number of occurences of the character(s)
'
Private Function CountOccurrences(ByVal sText As String, ByVal sChar As String) As Long
    
    Dim lCount As Long: lCount = 0
    
    Dim lCharAt As Long
    lCharAt = VBA.InStr(1, sText, sChar, vbTextCompare)
    While lCharAt > 0
        DoEvents
        lCount = lCount + 1
        lCharAt = VBA.InStr(lCharAt + 1, sText, sChar, vbTextCompare)
    Wend

    CountOccurrences = lCount
End Function




'---------------------------------------------------------------------------------------
' Procedure : FnAppRun
' DateTime  : 05/02/2018 14:05
' Author    : Simon
' Purpose   : A factory method to create a FunctionDelegate containing enough info
'             to pass to Application.Run(.. , .. , .. , ...)
'             Using a factory method frees us from the syntactical constraints
'             around the New keyword
'---------------------------------------------------------------------------------------
' Arguments :
'    [in] sMacro                 : the name of macro passed to Application.Run
'    [in] bReturnTypeIsObject    : whether or not we need to say 'Set foo=Application.Run(...' for returning an object
'    [out,retval]                : returns a create instance of FunctionDelegate containing the passed details
'
Public Function FnAppRun(ByVal sMacro As String, Optional ByVal bReturnTypeIsObject As Boolean) As FunctionDelegate
    
    
    Dim oNewFD As FunctionDelegate
    Set oNewFD = New FunctionDelegate
    
    oNewFD.IsAppRun = True
    oNewFD.AppRunMacro = sMacro
    oNewFD.ReturnTypeIsObject = bReturnTypeIsObject
    'oNewFD.mvArgs = vargs
    
    Set FnAppRun = oNewFD

End Function


'---------------------------------------------------------------------------------------
' Procedure : FnCallByName
' DateTime  : 06/02/2018 15:50
' Author    : Simon
' Purpose   : A factory method to create a FunctionDelegate containing enough info
'             to pass to VBA.CallByName(.. , .. , .. , ...)
'             Using a factory method frees us from the syntactical constraints
'             around the New keyword
'---------------------------------------------------------------------------------------
' Arguments :
'    [in] oCallByNameTarget      : the object (class instance) on whom we want to call the method
'    [in] sMacro                 : the name of method we want to call
'    [in] eCallByNameType        : necessary to specify one of {VbSet, VbMethod, VbLet, VbGet}
'    [in] bReturnTypeIsObject    : whether or not we need to say 'Set foo=VBA.CallByName(...' for returning an object
'    [out,retval]                : returns a create instance of FunctionDelegate containing the passed details
'
Public Function FnCallByName(ByVal oCallByNameTarget As Object, ByVal sMacro As String, _
                        ByVal eCallByNameType As VbCallType, Optional bReturnTypeIsObject As Boolean) As FunctionDelegate
    
    
    Dim oNewFD As FunctionDelegate
    Set oNewFD = New FunctionDelegate
    
    oNewFD.IsAppRun = False
    Set oNewFD.CallByNameTarget = oCallByNameTarget
    oNewFD.ReturnTypeIsObject = bReturnTypeIsObject
    oNewFD.CallByNameType = eCallByNameType
    
    oNewFD.AppRunMacro = sMacro
    'oNewFD.mvArgs = vargs
    
    Set FnCallByName = oNewFD

End Function

The FunctionDelegate class

Option Explicit

'* Tools References
'*   MSScriptControl    Microsoft Script Control 1.0    C:\Windows\SysWOW64\msscript.ocx

'---------------------------------------------------------------------------------------
' Module    : FunctionDelegate
' DateTime  : 06/02/2018 16:04
' Author    : Simon
' Purpose   : Contains enough information to call a function either using
'             (a) Application.Run() if function lives in a standard module or
'             (b) VBA.CallByName() if function lives in a class instance (object)
'             (c) MSScriptControl.ScriptControl.Run() is given a javascript function
'             (d) MSScriptControl.ScriptControl.Run() is given a lambda function
'
'             Uses the FnFactory class for instantiation of this class.
'---------------------------------------------------------------------------------------


Private msAppRunMacro As String
Private mobjCallByNameTarget As Object
Private meCallByNameType As VbCallType
Private mbIsAppRun As Boolean

Private mbReturnTypeIsObject As Boolean

'* Added 14th Feb 2018
Private msJavaScriptFunction As String
Private msJavaScriptName As String
Private mbHasReturnValue As Boolean
Private mlNumArgs As Long

Public Property Get NumArgs() As Long
    NumArgs = mlNumArgs
End Property
Public Property Let NumArgs(ByVal lNumArgs As Long)
    mlNumArgs = lNumArgs
End Property

Public Property Get HasReturnValue() As Boolean
    HasReturnValue = mbHasReturnValue
End Property
Public Property Let HasReturnValue(ByVal bHasReturnValue As Boolean)
    mbHasReturnValue = bHasReturnValue
End Property

Public Property Get JavaScriptFunction() As String
    JavaScriptFunction = msJavaScriptFunction
End Property
Public Property Let JavaScriptFunction(ByVal sJavaScriptFunction As String)
    msJavaScriptFunction = sJavaScriptFunction
End Property

Public Property Get JavaScriptName() As String
    JavaScriptName = msJavaScriptName
End Property
Public Property Let JavaScriptName(ByVal sJavaScriptName As String)
    msJavaScriptName = sJavaScriptName
End Property

Public Property Get ReturnTypeIsObject() As Boolean
    ReturnTypeIsObject = mbReturnTypeIsObject
End Property
Public Property Let ReturnTypeIsObject(ByVal bReturnTypeIsObject As Boolean)
    mbReturnTypeIsObject = bReturnTypeIsObject
End Property

Public Property Get IsAppRun() As Boolean
    IsAppRun = mbIsAppRun
End Property
Public Property Let IsAppRun(ByVal bIsAppRun As Boolean)
    mbIsAppRun = bIsAppRun
End Property




Public Property Get CallByNameType() As VbCallType
    CallByNameType = meCallByNameType
End Property

Public Property Let CallByNameType(ByVal eCallByNameType As VbCallType)
    meCallByNameType = eCallByNameType
End Property

Public Property Get CallByNameTarget() As Object
    Set CallByNameTarget = mobjCallByNameTarget
End Property
Public Property Set CallByNameTarget(ByVal objCallByNameTarget As Object)
    Set mobjCallByNameTarget = objCallByNameTarget
End Property

Public Property Get AppRunMacro() As String
    AppRunMacro = msAppRunMacro
End Property
Public Property Let AppRunMacro(ByVal sAppRunMacro As String)
    msAppRunMacro = sAppRunMacro
End Property


'---------------------------------------------------------------------------------------
' Procedure : Run
' DateTime  : 06/02/2018 16:01
' Author    : Simon
' Purpose   : This runs/executes/calls the function.  Deployed correctly one can omit
'             .Run in the calling line see unit tests for example
'
' Deployment: *** need to ensure that this has the line "Attribute Item.VB_UserMemId = 0"
'                 to make it default ***
'---------------------------------------------------------------------------------------
' Arguments :
'    vargs()    : a variable list of arguments which we'll pass on to Application.Run()
'                 or VBA.CallByName()
'
Public Function Run(ParamArray vargs() As Variant)
    Dim lArgCount As Long
    lArgCount = UBound(vargs) - LBound(vargs) + 1
    
    If mbIsAppRun Then
    
        If lArgCount = 0 Then
            If mbReturnTypeIsObject Then
                Set Run = Application.Run(msAppRunMacro)
            Else
                Run = Application.Run(msAppRunMacro)
            End If
        ElseIf lArgCount = 1 Then
            If mbReturnTypeIsObject Then
                Set Run = Application.Run(msAppRunMacro, vargs(0))
            Else
                Run = Application.Run(msAppRunMacro, vargs(0))
            End If
        ElseIf lArgCount = 2 Then
            If mbReturnTypeIsObject Then
                Set Run = Application.Run(msAppRunMacro, vargs(0), vargs(1))
            Else
                Run = Application.Run(msAppRunMacro, vargs(0), vargs(1))
            End If
        Else
            'requires more lines to handle multiple arguments,
            'a bit ugly so will do later
        End If
    ElseIf Not mobjCallByNameTarget Is Nothing Then
                
        If lArgCount = 0 Then
            
            If mbReturnTypeIsObject Then
                Set Run = CallByName(mobjCallByNameTarget, msAppRunMacro, meCallByNameType)
            Else
                Run = CallByName(mobjCallByNameTarget, msAppRunMacro, meCallByNameType)
            End If
        
        ElseIf lArgCount = 1 Then
            
            If mbReturnTypeIsObject Then
                Set Run = CallByName(mobjCallByNameTarget, msAppRunMacro, meCallByNameType, vargs(0))
            Else
                Run = CallByName(mobjCallByNameTarget, msAppRunMacro, meCallByNameType, vargs(0))
            End If
        
        ElseIf lArgCount = 2 Then
            
            If mbReturnTypeIsObject Then
                Set Run = CallByName(mobjCallByNameTarget, msAppRunMacro, meCallByNameType, vargs(0), vargs(1))
            Else
                Run = CallByName(mobjCallByNameTarget, msAppRunMacro, meCallByNameType, vargs(0), vargs(1))
            End If
        
        Else
            'requires more lines to handle multiple arguments,
            'a bit ugly so will do later
        End If
    ElseIf LenB(msJavaScriptFunction) > 0 Then
            
        '* Tools References
        '*   MSScriptControl    Microsoft Script Control 1.0    C:\Windows\SysWOW64\msscript.ocx
        Dim oSCForExecution As MSScriptControl.ScriptControl
        Set oSCForExecution = New MSScriptControl.ScriptControl
        oSCForExecution.Language = "JScript"
        
        Dim lSavedErrNum  As Long
        Dim sSavedErrDesc As String
        oSCForExecution.AddCode Me.JavaScriptFunction
        
        If lArgCount = 0 Then
            
            If mbReturnTypeIsObject Then
                Set Run = oSCForExecution.Run(Me.JavaScriptName, msAppRunMacro)
            Else
                Run = oSCForExecution.Run(Me.JavaScriptName, msAppRunMacro)
            End If
        
        ElseIf lArgCount = 1 Then
            
            If mbReturnTypeIsObject Then
                Set Run = oSCForExecution.Run(Me.JavaScriptName, vargs(0))
            Else
                Run = oSCForExecution.Run(Me.JavaScriptName, vargs(0))
            End If
        
        ElseIf lArgCount = 2 Then
            
            If mbReturnTypeIsObject Then
                Set Run = oSCForExecution.Run(Me.JavaScriptName, vargs(0), vargs(1))
            Else
                Run = oSCForExecution.Run(Me.JavaScriptName, vargs(0), vargs(1))
            End If
        
        Else
            'requires more lines to handle multiple arguments,
            'a bit ugly so will do later
        End If
        
    End If

End Function

The tstTestFnJavascript standard module

Option Explicit
Option Private Module

Private Sub TestAllFNJavascript()
    TestFNJavascript0
    TestFnJsLamda
End Sub


Private Sub TestFNJavascript0()

    Dim oFnDelegate As FunctionDelegate
    Set oFnDelegate = FnFactory.FnJavascript("function foo(bar) { return bar===1; }")
    

    
    Debug.Assert oFnDelegate.Run(0) = False
    Debug.Assert oFnDelegate.Run(1) = True

    Dim oFnDelegate2 As FunctionDelegate
    Set oFnDelegate2 = FnFactory.FnJavascript("function foo2(x) { return Math.pow(x,2)-4*x-5; }")
    
    Debug.Assert oFnDelegate2.Run(5) = 0 'root
    Debug.Assert oFnDelegate2.Run(-1) = 0 'root

    Debug.Assert oFnDelegate2.Run(1) = -8

End Sub

Private Sub TestFnJsLamda()


    'Set oFnDelegate = FnFactory.FnJsLamda("bar => bar===1")
    
    Dim fnLamda As FunctionDelegate
    Set fnLamda = FnFactory.FnJsLamda("bar => bar===1")
    
    Debug.Print fnLamda.JavaScriptFunction
    
    Debug.Assert fnLamda.Run(0) = False
    Debug.Assert fnLamda.Run(1) = True
    
    
    Dim fnLamda2 As FunctionDelegate
    Set fnLamda2 = FnFactory.FnJsLamda("x,y => x+y")
    
    Debug.Print fnLamda2.JavaScriptFunction
    
    Debug.Assert fnLamda2.Run(2, 2) = 4
    Debug.Assert fnLamda2.Run(3, -1) = 2
    
    Dim fnLamdaMultiStatement As FunctionDelegate
    Set fnLamdaMultiStatement = FnFactory.FnJsLamda("a,b => var c=a+b;var d=c+b;var e=c+d; d+e ")
    
    Debug.Assert fnLamdaMultiStatement.Run(1, 1) = 8
    
    Set fnLamdaMultiStatement = FnFactory.FnJsLamda("a,b =>  c=a+b; d=c+b; e=c+d; d+e ")
    Debug.Print fnLamdaMultiStatement.JavaScriptFunction
    Debug.Assert fnLamdaMultiStatement.Run(1, 1) = 8
    
    'https://stackoverflow.com/questions/7944239/generating-fibonacci-sequence
    Dim sFib As String
    sFib = "n => var fib = [0, 1]; for(var i=fib.length; i<=n; i++) {  fib.push( fib[i-2] + fib[i-1]);} ; fib[n]"
    
    Dim fnFibonacci As FunctionDelegate
    Set fnFibonacci = FnFactory.FnJsLamda(sFib)
    Debug.Print fnFibonacci.JavaScriptFunction
    Debug.Assert fnFibonacci.Run(0) = 0
    Debug.Assert fnFibonacci.Run(1) = 1
    Debug.Assert fnFibonacci.Run(2) = 1
    Debug.Assert fnFibonacci.Run(3) = 2
    Debug.Assert fnFibonacci.Run(4) = 3
    Debug.Assert fnFibonacci.Run(5) = 5
    Debug.Assert fnFibonacci.Run(6) = 8
    

End Sub


1 comment:

  1. Hey @exceldevelopmentplatform, FYI we have made a native Lambda expression here: https://github.com/sancarn/VBA-STD-Library/. Lambda expressions are in a vba-like syntax, compile to byte code and are executed from there. Recent tests show it's near to speed of formula, which isn't great, but isn't awful either.

    I would expect it to be faster than JScript, though im not willing to bet on it :P

    ReplyDelete