├── .gitignore ├── Build-Display.ps1 ├── Build.ps1 ├── Close-All-Of.ps1 ├── Commit.ps1 ├── Export.ps1 ├── LICENSE ├── Make.ps1 ├── README.md ├── src ├── Applicable.cls ├── Assoc.cls ├── Buildable.cls ├── ByName.cls ├── Comparable.cls ├── Composed.cls ├── Console.cls ├── Delayed.cls ├── Dict.cls ├── Enumerable.cls ├── Equatable.cls ├── Exceptions.bas ├── Frame.cls ├── HashSet.cls ├── InternalDelegate.cls ├── Lambda.cls ├── LambdaTable.cls ├── LambdasModule.bas ├── Lazy.cls ├── Linear.cls ├── List.cls ├── Maybe.cls ├── Monadic.cls ├── OnArgs.cls ├── OnObject.cls ├── Output.cls ├── Partial.cls ├── SetLike.cls ├── Showable.cls ├── SortedSet.cls ├── SqlCommand.cls ├── SqlConnection.cls ├── SqlResult.cls ├── Str.cls ├── Try.cls ├── Tuple.cls ├── Writer.cls ├── cast.bas ├── defAccum.bas ├── defApply.bas ├── defBuildable.bas ├── defCompare.bas ├── defEquals.bas ├── defFilter.bas ├── defMap.bas ├── defMonad.bas ├── defSetLike.bas ├── defShow.bas ├── fsview.bas ├── path.bas ├── shutilB.bas ├── shutilE.bas ├── sort.bas ├── srch.bas ├── vbeCodeModule.cls ├── vbeProcedure.cls └── vbeProcedures.cls └── test ├── BatteryApplicable.bas ├── BatteryIterable.bas ├── BatteryMonadic.bas ├── BatterySetLike.bas ├── TestByName.bas ├── TestComposed.bas ├── TestDict.bas ├── TestHashSet.bas ├── TestInternalDelegate.bas ├── TestLambda.bas ├── TestLazy.bas ├── TestList.bas ├── TestMaybe.bas ├── TestNameCall.bas ├── TestPartial.bas ├── TestShow.bas ├── TestSortedSet.bas ├── TestStr.bas ├── TestTuple.bas ├── TestZip.bas └── Testcast.bas /.gitignore: -------------------------------------------------------------------------------- 1 | ################### 2 | ## Microsoft Office 3 | ################### 4 | *.xlsm 5 | *.xlam 6 | *.accdb 7 | *.accde 8 | *.accdr 9 | *.laccdb 10 | -------------------------------------------------------------------------------- /Build-Display.ps1: -------------------------------------------------------------------------------- 1 | # 2 | 3 | <# 4 | #> 5 | Param ( 6 | [Int] $level, 7 | [String] $msg 8 | ) 9 | 10 | function Build-Display { 11 | Switch ($level) { 12 | 1 { 13 | Write-Host "=> " -ForeGround Blue -noNewLine 14 | break 15 | } 16 | 2 { 17 | Write-Host "==> " -ForeGround Green -noNewLine 18 | break 19 | } 20 | default { 21 | $icon = "> ".PadLeft($level + 2, "-") 22 | Write-Host $icon -ForeGround Yellow -noNewLine 23 | break 24 | } 25 | } 26 | Write-Host $msg 27 | } 28 | 29 | Build-Display 30 | -------------------------------------------------------------------------------- /Build.ps1: -------------------------------------------------------------------------------- 1 | # Build.ps1 2 | # 3 | # Collects VBEX files into an office add-in file 4 | # 5 | # Copywrite (C) 2015 Philip Wales 6 | # 7 | 8 | Param( 9 | [String]$buildPath, 10 | [System.Array]$sourceFiles, 11 | [System.Array]$references 12 | ) 13 | 14 | $scriptRoot = if ($PSVersionTable.PSVersion.Major -ge 3) { 15 | $PSScriptRoot 16 | } else { 17 | Split-Path $MyInvocation.MyCommand.Path -Parent 18 | } 19 | $display = (Join-Path $scriptRoot "Build-Display.ps1") 20 | 21 | function Build { 22 | 23 | $fileExt = [System.IO.Path]::GetExtension($buildPath) 24 | $officeCOM = switch -wildcard ($fileExt.ToLower()) { 25 | ".xl*" {New-Object -ComObject Excel.Application; break} 26 | #".ac*" {New-Object -ComObject Acces.Application; break} 27 | default {throw "$fileName is not a supported office file."} 28 | } 29 | Write-Host "Will Build $buildPath" 30 | dosEOLFolder $sourceFiles 31 | $srcAddin = (BuildExcelAddin $officeCOM $sourceFiles $references $buildPath) 32 | $officeCOM.Quit() 33 | } 34 | 35 | function BuildExcelAddin($officeCOM, 36 | [System.Array] $moduleFiles, 37 | [System.Array] $references, 38 | [String] $outputPath) { 39 | 40 | $newFile = $officeCOM.Workbooks.Add() 41 | $prj = $newFile.VBProject 42 | $projectName = [System.IO.Path]::GetFileNameWithoutExtension($outputPath) 43 | BuildVBProject $prj $projectName $moduleFiles $references 44 | 45 | Write-Host "Saving Addin as $outputPath" -ForeGround Green 46 | $newFile.SaveAs($outputPath, 55) 47 | return $newFile 48 | } 49 | 50 | function BuildAccessAddin($officeCOM, [System.Array] $moduleFiles, 51 | [System.Array] $references, [String] $outputPath) { 52 | 53 | $newDB = $officeCOM.DBEngine.CreateDatabase($outputPath) 54 | $prj = $officeCOM.VBE.VBProjects(1) 55 | $projectName = [System.IO.Path]::GetFileNameWithoutExtension($outputPath) 56 | BuildVBProject $prj $projectName $moduleFiles $references 57 | 58 | return $newDB 59 | } 60 | 61 | function BuildVBProject($prj, [String] $name, [System.Array] $moduleFiles, 62 | [System.Array] $references) { 63 | 64 | $prj.Name = $name 65 | & "$display" 1 "Building VBProject $name`:" 66 | $moduleCount = $moduleFiles.length 67 | & "$display" 2 "Importing $moduleCount Modules:" 68 | ForEach($moduleFile in $modulefiles) { 69 | & "$display" 3 "$moduleFile" 70 | $prj.VBComponents.Import($moduleFile) 71 | } 72 | $refCount = $references.length 73 | Write-Host "==> " -ForeGround Green -noNewLine 74 | Write-Host "Linking $refCount References:" 75 | ForEach($reference in $references) { 76 | & "$display" 3 "$reference" 77 | $prj.References.AddFromFile( $reference ) 78 | } 79 | } 80 | 81 | function dosEOLFolder([System.Array] $textFiles) { 82 | $count = $textFiles.length 83 | Write-Host "Converting $count files to CRLF" 84 | $textFiles | ForEach-Object { dosEOL $_ } 85 | } 86 | 87 | function dosEOL([String] $textFile) { 88 | $tempOut = "$textFile-CRLF" 89 | Get-Content $textFile | Set-Content $tempOut 90 | Remove-Item $textFile 91 | Move-Item $tempOut $textFile 92 | } 93 | 94 | Build #entry point 95 | 96 | -------------------------------------------------------------------------------- /Close-All-Of.ps1: -------------------------------------------------------------------------------- 1 | # 2 | <# 3 | .Synopsis 4 | Checks if the user wants to close all instances of a procss before doing so. 5 | 6 | .Description 7 | When using scripts that open processes in the background, it is often difficult to 8 | ensure that all created instances of those programs are closed. The simplest solution 9 | is to just close all processes of that name. This can close instance that were not 10 | opened by a script, so this function asks the user if it is ok if we do so. 11 | 12 | .Parameter processName 13 | Name of the process to close. 14 | 15 | .Example 16 | # Close all instances of EXCEL.exe 17 | Close-All-Of "EXCEL" 18 | I Cannot close the instances of EXCEL I opened. 19 | May I close all instances of EXCEL? [y/N] 20 | > Yes 21 | WARNING! All instances of EXCEL were closed! 22 | #> 23 | Param ( 24 | [String] $processName 25 | ) 26 | 27 | Function Close-All-Of { 28 | Write-Host "" 29 | Write-Host "I cannot close the instances of $processName I opened." 30 | $closeAll = Read-Host "May I close all instances of $processName" + "? [y/N]" 31 | $msg = if ($closeAll -like "y*") { 32 | Stop-Process -Name "$processName" 33 | "WARNING! All instances of $processName were closed!" 34 | } else { 35 | "WARNING! There are unused instances of $processName in the background!" 36 | } 37 | Write-Host $msg -ForeGround Red 38 | } 39 | 40 | Close-All-Of 41 | -------------------------------------------------------------------------------- /Commit.ps1: -------------------------------------------------------------------------------- 1 | # Commit.ps1 2 | # 3 | # Collects VBEX files into an office add-in file 4 | # 5 | # Copywrite (C) 2015 Philip Wales 6 | # 7 | Param() 8 | 9 | $scriptRoot = if ($PSVersionTable.PSVersion.Major -ge 3) { 10 | $PSScriptRoot 11 | } else { 12 | Split-Path $MyInvocation.MyCommand.Path -Parent 13 | } 14 | $export = (Join-Path $scriptRoot "Export.ps1") 15 | $closeAll = (Join-Path $scriptRoot "Close-All-Of.ps1") 16 | $builds = @("src", "test") 17 | 18 | ForEach($build in $builds) { 19 | $file = (Join-Path "$scriptRoot" "VBEX$build.xlam") 20 | $dest = (Join-Path "$scriptRoot" "$build") 21 | Get-ChildItem "$dest" | Remove-Item 22 | & $export "$file" "$dest" 23 | } 24 | 25 | & "$closeAll" "EXCEL" 26 | -------------------------------------------------------------------------------- /Export.ps1: -------------------------------------------------------------------------------- 1 | # Export.ps1 2 | # 3 | # Exports all VBE files from a office file to a path 4 | # 5 | # Copywrite (C) 2015 Philip Wales 6 | # 7 | Param( 8 | [String]$sourceFile, 9 | [String]$outDest 10 | ) 11 | 12 | $scriptRoot = if ($PSVersionTable.PSVersion.Major -ge 3) { 13 | $PSScriptRoot 14 | } else { 15 | Split-Path $MyInvocation.MyCommand.Path -Parent 16 | } 17 | $display = (Join-Path $scriptRoot "Build-Display.ps1") 18 | 19 | function Export { 20 | Write-Host "Will Export $sourceFile to $outDest`:" 21 | $officeCOM = (OfficeComFromFileName $sourceFile) 22 | $fileCOM = (OpenMSOfficeFile $officeCOM $sourceFile) 23 | $prjCOM = ($fileCOM.VBProject) 24 | ExportModules $prjCOM $outDest 25 | $officeCOM.Quit() 26 | Start-Sleep -seconds 1 27 | Write-Host "Removing $sourceFile" -ForeGround Red 28 | Remove-Item $sourceFile 29 | } 30 | 31 | function OfficeComFromFileName([String] $fileName) { 32 | $fileExt = [System.IO.Path]::GetExtension($fileName) 33 | $officeCOM = switch -wildcard ($fileExt.ToLower()) { 34 | ".xl*" {New-Object -ComObject Excel.Application; break} 35 | ".ac*" {throw "Access is not yet supported"; break} #{New-Object -ComObject Acces.Application; break} 36 | default {throw "$fileName is not a supported office file."} 37 | } 38 | return $officeCOM 39 | } 40 | 41 | function OpenMSOfficeFile($officeCOM, [String] $filePath) { 42 | Write-Host "Opening $filePath with Office Application." 43 | $fileCOM = ($officeCOM.Workbooks.Open($filePath)) 44 | return $fileCOM 45 | } 46 | 47 | function ExportModules($prjCOM, [String] $outDest) { 48 | 49 | $vbComps = ($prjCOM.VBComponents) 50 | $count = $vbComps.count 51 | & "$display" 1 "Exporting $count modules to $outDest`:" 52 | ForEach ($component in $vbComps) { 53 | $compFileExt = (GetComponentExt($component)) 54 | if ($compFileExt -ne "") { 55 | $compFileName = $component.name + $compFileExt 56 | $exportPath = (Join-Path $outDest $compFileName) 57 | & "$display" 3 "$compFileName" 58 | $component.Export($exportPath) 59 | } 60 | } 61 | } 62 | 63 | function GetComponentExt($component) { 64 | $compExt = switch ($component.Type) { 65 | 1 {".bas"} 66 | 2 {".cls"} 67 | # form 68 | default {""} 69 | } 70 | return $compExt 71 | } 72 | 73 | Export # entry 74 | -------------------------------------------------------------------------------- /Make.ps1: -------------------------------------------------------------------------------- 1 | # Build.ps1 2 | # 3 | # Collects VBEX files into an office add-in file 4 | # 5 | # Copywrite (C) 2015 Philip Wales 6 | # 7 | Param( 8 | [ValidateSet("Excel")] 9 | [String]$officeApp = "Excel" 10 | ) 11 | 12 | # locations of required libraries change according to OS arch. 13 | # Our libs are 32 bit. 14 | $programFiles = if ([Environment]::Is64BitOperatingSystem) { 15 | "Program Files (x86)" 16 | } else { 17 | "Program Files" 18 | } 19 | 20 | 21 | # Compatible with earlier powershell versions 22 | $scriptRoot = if ($PSVersionTable.PSVersion.Major -ge 3) { 23 | $PSScriptRoot 24 | } else { 25 | Split-Path $MyInvocation.MyCommand.Path -Parent 26 | } 27 | $buildScript = (Join-Path $scriptRoot "Build.ps1") 28 | 29 | $ext = switch ($officeApp) { 30 | "Excel" {"xlam"} 31 | # "Access" {"accde"} Wow is the Acces Object Model shit. 32 | default {throw "$officeApp is not a supported office application."} 33 | } 34 | 35 | $VBA_EXTENSIBILITY_LIB = "C:\$programFiles\Common Files\Microsoft Shared\VBA\VBA6\VBE6EXT.OLB" 36 | $VBA_SCRIPTING_LIB = "C:\Windows\system32\scrrun.dll" 37 | $ACTIVEX_DATA_OBJECTS_LIB = "C:\$programFiles\Common Files\System\ado\msado15.dll" 38 | 39 | $buildRefs = @{ 40 | "src" = @("$VBA_EXTENSIBILITY_LIB", "$VBA_SCRIPTING_LIB", "$ACTIVEX_DATA_OBJECTS_LIB"); 41 | "test" = @((Join-Path $scriptRoot "VBEXsrc.$ext")) 42 | } 43 | 44 | ForEach ($build In $buildRefs.Keys) { 45 | $path = (Join-Path $scriptRoot "VBEX$build.$ext") 46 | $files = (Get-ChildItem (Join-Path $scriptRoot $build)) | % { $_.FullName } # v3 and greater this would be just .FullName 47 | $refs = $buildRefs[$build] 48 | & "$buildScript" "$path" $files $refs 49 | } 50 | 51 | & (Join-Path "$scriptRoot" "Close-All-Of.ps1") "$officeApp" 52 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | VBEX 2 | ==== 3 | 4 | _VBA Extension Library_ 5 | 6 | 42 | 43 | Intro 44 | ----- 45 | 46 | Ease production of VBA code with the VBEX library of rich idiomatic containers and some functional programing capabilities to bring VBA into the new millenium. With VBEX you can: 47 | 48 | 1. Use Class Constructors for immutable classes. 49 | 1. Print meaningful debug methods that reveal a datastructures contents 50 | 51 | Console.PrintLine List.Create(1, 2, 3, 4) ' Note usage of class constructors 52 | List(1, 2, 3, 4) 53 | 54 | 1. Create functional objects to use with higher order functions. With those we have created some monadic classes _(List, Maybe, Try)_ that implement the traditonal `Map`, `FlatMap` or `Bind` methods. 55 | 1. Access a growing library of Containers. 56 | 1. Perform file-system operations. 57 | - These will later be replaced or enhanced with an object-oriented model 58 | 1. Later there will be APIs for ADODB (SQL) and Windows Scripting Host 59 | 2. ADODB/SQL implemented with `SqlConnection`, `SqlCommand`, and `SqlResult`! 60 | 61 | 62 | Install 63 | ------- 64 | 65 | Once you acquire the source by either cloning this repo or downloading zip and extracting 66 | 67 | 1. Run the _Make.ps1_ script to build _VBEXsrc.xlam_ and _VBEXtest.xlam_. 68 | - _VBEXtest.xlam_ contains unit-testing code and is only relevant to development. 69 | 1. Reference _VBEXsrc.xlam_ in projects to use VBEX 70 | - From the VBE from the menu _tools >> References >> Browse_. 71 | 1. Enable ["Programmatic access to Office VBA project"](https://support.microsoft.com/en-us/kb/282830) 72 | - This is required for the Lambda class as it auto-generates code in a blank module. 73 | 74 | Usage 75 | ----- 76 | 77 | VBEX is not a normal VBA library, before you start using you should understand the following aspects about VBEX. 78 | 79 | ### Predeclared Objects 80 | 81 | All public classes have a predeclared instance of that class called the "predeclared object". 82 | - The predeclared object has the same name as the class, _e.g._ 83 | 84 | ``` 85 | Dim xs As List ' word "List" as a type 86 | Set xs = List.Create(1, 2, 3) ' word "List" here is the predeclared object 87 | ``` 88 | 89 | - All creatable classes are created from the predeclared object. 90 | - Predeclared objects of mutable classes can be mutated, but there is no reason for one to ever do so. 91 | 92 | ### Inheritance 93 | 94 | Since VBA has only Interface Inheritance, 95 | code that would be put in parent or abstract classesis instead put into `def*` modules. 96 | While this reduces code duplication, it only reduces it to trivial code like, 97 | 98 | Public Function IsSubSetOf(ByVal other As SetLike) As Boolean 99 | 100 | IsSubSetOf = defSetLike.IsSubSetOf(Me, other) 101 | 102 | End Function 103 | Private Function SetLike_IsSubSetOf(ByVal other As SetLike) As Boolean 104 | 105 | SetLike_IsSubSetOf = IsSubSetOf(other) 106 | 107 | End Function 108 | 109 | This screams for some macro or preprocessing system, but that doesn't exist yet. 110 | 111 | ### Applicable 112 | 113 | Implementations of the _Applicable_ interface allow methods and functions to be treated as objects. 114 | - All Applicable objects are immutable. 115 | - The _Lambda_ class writes functions to a VBEX modules and allows you to execute that code. 116 | + Using the Lambda class will sometimes disable the debugger. 117 | + A lambda has no reference to environment in it was created. 118 | * `Lambda.FromShort("_ + x")` will always error even if `x` is in the current scope. 119 | - _OnArgs_ and _OnObject_ are complementary. 120 | + `OnArgs.Make(myObject, "method", vbMethod)` is `(x) => myObject.method(x)` 121 | + `OnObject.Make("method", vbMethod, myArgs)` is `(o) => o.method(myArgs)` 122 | + These are the _only_ applicable objects that have references to the current environment. 123 | -------------------------------------------------------------------------------- /src/Applicable.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "Applicable" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = True 10 | Option Explicit 11 | 12 | Public Function Apply(ParamArray args() As Variant) As Variant 13 | Attribute Apply.VB_UserMemId = 0 14 | 15 | End Function 16 | Public Function ApplyOnArray(ByRef args() As Variant) As Variant 17 | 18 | End Function 19 | Public Function Compose(ByVal f As Applicable) As Applicable 20 | 21 | End Function 22 | Public Function AndThen(ByVal g As Applicable) As Applicable 23 | 24 | End Function 25 | Public Function Partial(ParamArray args() As Variant) As Applicable 26 | 27 | End Function 28 | Public Function AsPartial(ByRef args() As Variant) As Applicable 29 | 30 | End Function 31 | Public Function delay(ParamArray args() As Variant) As Delayed 32 | 33 | End Function 34 | Public Function AsDelay(ByRef args() As Variant) As Delayed 35 | 36 | End Function 37 | 38 | -------------------------------------------------------------------------------- /src/Assoc.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "Assoc" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = True 9 | Attribute VB_Exposed = True 10 | Option Explicit 11 | ' 12 | ' Assoc Class 13 | ' =========== 14 | ' 15 | ' 16 | ' Copywrite (C) 2014 Philip Wales 17 | ' This file (Assoc.cls) is distributed under the GPL-3.0 license 18 | ' Obtain a copy of the GPL-3.0 license 19 | ' 20 | ' 21 | Implements Showable 22 | ' 23 | ' Private Members 24 | ' --------------- 25 | ' 26 | Private pPair As Tuple 27 | ' 28 | ' 29 | ' 30 | Public Function Make(ByVal k, ByVal v) As Assoc 31 | 32 | Dim result As New Assoc 33 | result.Inject k, v 34 | Set Make = result 35 | 36 | End Function 37 | Friend Sub Inject(ByVal k, ByVal v) 38 | 39 | Set pPair = Tuple.Pack(k, v) 40 | 41 | End Sub 42 | Public Property Get key() As Variant 43 | 44 | Assign key, pPair.Item(1) 45 | 46 | End Property 47 | Public Property Get Value() As Variant 48 | 49 | Assign Value, pPair.Item(2) 50 | 51 | End Property 52 | ' 53 | ' 54 | ' 55 | Public Function Show() As String 56 | 57 | Show = defShow.Show(key) & " -> " & defShow.Show(Value) 58 | 59 | End Function 60 | Private Function Showable_Show() As String 61 | 62 | Showable_Show = Show 63 | 64 | End Function 65 | -------------------------------------------------------------------------------- /src/Buildable.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "Buildable" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = True 9 | Attribute VB_Exposed = True 10 | Option Explicit 11 | ' 12 | ' Buildable 13 | ' ========== 14 | ' 15 | Public Function MakeEmpty() As Buildable 16 | Exceptions.NotImplementedError Me, "MakeEmpty" 17 | End Function 18 | Public Sub AddItem(ByVal x) 19 | Exceptions.NotImplementedError Me, "AddItem" 20 | End Sub 21 | Public Sub AddItems(ByVal x) 22 | Exceptions.NotImplementedError Me, "AddItems" 23 | End Sub 24 | -------------------------------------------------------------------------------- /src/ByName.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "ByName" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = True 9 | Attribute VB_Exposed = True 10 | Option Explicit 11 | ' 12 | ' ByName Class 13 | ' ============ 14 | ' 15 | ' 16 | ' Copywrite (C) 2014 Philip Wales 17 | ' This file (ByName.cls) is distributed under the GPL-3.0 license 18 | ' Obtain a copy of the GPL-3.0 license 19 | ' 20 | Implements Showable 21 | Implements Delayed 22 | ' 23 | ' Private Members 24 | ' --------------- 25 | ' 26 | Private pApplicable As Applicable 27 | Private pArgs() As Variant 28 | ' 29 | ' Constructors 30 | ' ------------ 31 | ' 32 | Public Function Create(ByVal op As Applicable, ParamArray args()) As ByName 33 | 34 | Set Create = Make(op, CArray(args)) 35 | 36 | End Function 37 | Public Function Make(ByVal op As Applicable, ByRef args()) As ByName 38 | 39 | Dim result As New ByName 40 | result.Inject op, args 41 | Set Make = result 42 | 43 | End Function 44 | Friend Sub Inject(ByVal op As Applicable, ByRef args()) 45 | 46 | Set pApplicable = op 47 | pArgs = args 48 | 49 | End Sub 50 | ' 51 | ' Delayed 52 | ' -------- 53 | ' 54 | Public Property Get Evaluate() As Variant 55 | Attribute Evaluate.VB_UserMemId = 0 56 | 57 | Assign Evaluate, pApplicable.ApplyOnArray(pArgs) 58 | 59 | End Property 60 | Private Property Get Delayed_Evaluate() As Variant 61 | 62 | Assign Delayed_Evaluate, Evaluate 63 | 64 | End Property 65 | Public Function Map(ByVal op As Applicable) As ByName 66 | 67 | Dim opResult As Applicable 68 | Set opResult = op.Compose(pApplicable) 69 | 70 | Dim result As ByName 71 | Set result = Make(opResult, pArgs) 72 | 73 | Set Map = result 74 | 75 | End Function 76 | Private Function Delayed_Map(ByVal op As Applicable) As Delayed 77 | 78 | Set Delayed_Map = Map(op) 79 | 80 | End Function 81 | ' 82 | ' Showable 83 | ' --------- 84 | ' 85 | Public Function Show() As String 86 | 87 | Show = defShow.ParamShowableObject(Me, pApplicable, pArgs) 88 | 89 | End Function 90 | Private Function Showable_Show() As String 91 | 92 | Showable_Show = Show 93 | 94 | End Function 95 | -------------------------------------------------------------------------------- /src/Comparable.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "Comparable" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = True 10 | ' 11 | ' Comparable 12 | ' ----------- 13 | ' 14 | Public Function Compare(ByVal x) As CompareResult 15 | 16 | End Function 17 | -------------------------------------------------------------------------------- /src/Composed.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "Composed" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = True 9 | Attribute VB_Exposed = True 10 | ' 11 | ' Composed Class 12 | ' ============== 13 | ' 14 | ' Copywrite (C) 2014 Philip Wales 15 | ' This file (Composed.cls) is distributed under the GPL-3.0 license 16 | ' Obtain a copy of the GPL-3.0 license 17 | ' 18 | Option Explicit 19 | Implements Showable 20 | Implements Applicable 21 | ' 22 | ' Private Members 23 | ' --------------- 24 | ' 25 | Private pInnerOp As Applicable 26 | Private pOuterOp As Applicable 27 | ' 28 | ' Constructors 29 | ' ------------ 30 | ' 31 | Public Function Make(ByVal outerOp As Applicable, _ 32 | ByVal innerOp As Applicable) As Composed 33 | 34 | Dim result As New Composed 35 | result.Inject innerOp, outerOp 36 | Set Make = result 37 | 38 | End Function 39 | Friend Sub Inject(ByVal innerOp As Applicable, ByVal outerOp As Applicable) 40 | 41 | Set pInnerOp = innerOp 42 | Set pOuterOp = outerOp 43 | 44 | End Sub 45 | ' 46 | ' Applicable 47 | ' ----------- 48 | ' 49 | ' ### Meaningful 50 | ' 51 | Public Function ApplyOnArray(ByRef args() As Variant) As Variant 52 | 53 | Assign ApplyOnArray, pOuterOp.Apply(pInnerOp.ApplyOnArray(args)) 54 | 55 | End Function 56 | ' 57 | ' ### Embedded 58 | ' 59 | Private Function Applicable_ApplyOnArray(ByRef args() As Variant) As Variant 60 | 61 | Assign Applicable_ApplyOnArray, ApplyOnArray(args) 62 | 63 | End Function 64 | '! default member 65 | Public Function Apply(ParamArray args() As Variant) As Variant 66 | Attribute Apply.VB_UserMemId = 0 67 | 68 | Assign Apply, ApplyOnArray(cast.CArray(args)) 69 | 70 | End Function 71 | Private Function Applicable_Apply(ParamArray args() As Variant) As Variant 72 | 73 | Assign Applicable_Apply, ApplyOnArray(CArray(args)) 74 | 75 | End Function 76 | Public Function Compose(ByVal f As Applicable) As Applicable 77 | 78 | Set Compose = defApply.Compose(Me, f) 79 | 80 | End Function 81 | Private Function Applicable_Compose(ByVal f As Applicable) As Applicable 82 | 83 | Set Applicable_Compose = Compose(f) 84 | 85 | End Function 86 | Public Function AndThen(ByVal g As Applicable) As Applicable 87 | 88 | Set AndThen = defApply.AndThen(Me, g) 89 | 90 | End Function 91 | Private Function Applicable_AndThen(ByVal g As Applicable) As Applicable 92 | 93 | Set Applicable_AndThen = AndThen(g) 94 | 95 | End Function 96 | Public Function Partial(ParamArray args() As Variant) As Applicable 97 | 98 | Set Partial = AsPartial(CArray(args)) 99 | 100 | End Function 101 | Private Function Applicable_Partial(ParamArray args() As Variant) As Applicable 102 | 103 | Set Applicable_Partial = AsPartial(CArray(args)) 104 | 105 | End Function 106 | Public Function AsPartial(ByRef args() As Variant) As Applicable 107 | 108 | Set AsPartial = defApply.AsPartial(Me, args) 109 | 110 | End Function 111 | Private Function Applicable_AsPartial(ByRef args() As Variant) As Applicable 112 | 113 | Set Applicable_AsPartial = AsPartial(args) 114 | 115 | End Function 116 | Public Function delay(ParamArray args() As Variant) As Delayed 117 | 118 | Set delay = AsDelay(CArray(args)) 119 | 120 | End Function 121 | Private Function Applicable_Delay(ParamArray args() As Variant) As Delayed 122 | 123 | Set Applicable_Delay = AsDelay(CArray(args)) 124 | 125 | End Function 126 | Public Function AsDelay(ByRef args() As Variant) As Delayed 127 | 128 | Set AsDelay = defApply.AsDelay(Me, args) 129 | 130 | End Function 131 | Private Function Applicable_AsDelay(ByRef args() As Variant) As Delayed 132 | 133 | Set Applicable_AsDelay = AsDelay(args) 134 | 135 | End Function 136 | ' 137 | ' Showable 138 | ' --------- 139 | ' 140 | Public Function Show() As String 141 | 142 | Show = defShow.ParamShowableObject(Me, pOuterOp, pInnerOp) 143 | 144 | End Function 145 | Private Function Showable_Show() As String 146 | 147 | Showable_Show = Show 148 | 149 | End Function 150 | -------------------------------------------------------------------------------- /src/Console.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "Console" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = True 9 | Attribute VB_Exposed = True 10 | Option Explicit 11 | ' 12 | ' Console 13 | ' ======= 14 | ' 15 | ' Representation of the VBE Immediate Pane 16 | ' 17 | Implements Output 18 | ' 19 | ' Interfaces 20 | ' ---------- 21 | ' 22 | ' ### Output 23 | ' 24 | ' #### Prints 25 | ' 26 | Public Sub Prints(ByVal x As Variant) 27 | 28 | Debug.Print defShow.Show(x); 29 | 30 | End Sub 31 | Private Sub Output_Prints(ByVal x As Variant) 32 | 33 | Prints x 34 | 35 | End Sub 36 | ' 37 | ' #### PrintLine 38 | ' 39 | Public Sub PrintLine(ByVal x As Variant) 40 | 41 | Prints x 42 | Debug.Print 43 | 44 | End Sub 45 | Private Sub Output_PrintLine(ByVal x As Variant) 46 | 47 | PrintLine x 48 | 49 | End Sub 50 | ' 51 | ' #### PrintLines 52 | ' 53 | Public Sub PrintLines(ByRef xs() As Variant) 54 | 55 | Dim x As Variant 56 | For Each x In xs 57 | PrintLine x 58 | Next x 59 | 60 | End Sub 61 | Private Sub Output_PrintLines(ByRef xs() As Variant) 62 | 63 | PrintLines xs 64 | 65 | End Sub 66 | 67 | -------------------------------------------------------------------------------- /src/Delayed.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "Delayed" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = True 10 | Option Explicit 11 | 12 | Public Property Get Evaluate() As Variant 13 | Attribute Evaluate.VB_UserMemId = 0 14 | 15 | End Property 16 | Public Function Map(ByVal op As Applicable) As Delayed 17 | 18 | End Function 19 | -------------------------------------------------------------------------------- /src/Dict.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "Dict" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = True 9 | Attribute VB_Exposed = True 10 | Option Explicit 11 | ' 12 | ' Dict 13 | ' ==== 14 | ' 15 | ' Mutelable Mapping class based on Python's `Dict` 16 | ' 17 | ' Copywrite (C) 2014 Philip Wales 18 | ' This file (Dict.cls) is distributed under the GPL-3.0 license 19 | ' Obtain a copy of the GPL-3.0 license 20 | ' 21 | Implements Showable 22 | ' Should implement more Interfaces but this is the only mapping type yet. 23 | ' 24 | ' Public Members 25 | ' -------------- 26 | ' None 27 | ' 28 | ' Should implement more Interfaces but this is the only mapping type yet. 29 | ' 30 | Private pDict As Scripting.Dictionary 31 | ' 32 | ' Constructors 33 | ' ------------ 34 | ' 35 | Private Sub Class_Initialize() 36 | 37 | Set pDict = New Scripting.Dictionary 38 | 39 | End Sub 40 | Public Function Create(ParamArray assocs()) As Dict 41 | 42 | Set Create = FromAssocs(List.Copy(assocs)) 43 | 44 | End Function 45 | Public Function FromLists(ByVal ks As Linear, ByVal vs As Linear) As Dict 46 | Debug.Assert (ks.UpperBound = vs.UpperBound And _ 47 | ks.LowerBound = vs.LowerBound) ' TODO: raise error 48 | 49 | Dim result As New Dict 50 | 51 | ' TODO: use Zip. then expect users to use `FromAssocs`? 52 | Dim i As Long 53 | For i = ks.LowerBound To ks.UpperBound 54 | result.Add ks.Item(i), vs.Item(i) 55 | Next i 56 | 57 | Set FromLists = result 58 | 59 | End Function 60 | ' TODO: use a defined type not a tuple but the type must be public.... 61 | Public Function FromAssocs(ByVal assocs) As Dict 62 | 63 | Dim result As New Dict 64 | 65 | Dim kv 66 | For Each kv In assocs 67 | result.Add kv.key, kv.Value 68 | Next 69 | 70 | Set FromAssocs = result 71 | 72 | End Function 73 | Public Function FromKeys(ByVal keySet as ISetLike, ByVal op As IApplicable) As Dict 74 | 75 | Dim result As New Dict 76 | 77 | Dim key As Variant 78 | For Each key In keySet.Elements 79 | result.Add key, op.Apply(key) 80 | Next 81 | 82 | Set FromKeys = result 83 | End Function 84 | Public Function Copy(ByVal thatD As Dict) As Dict 85 | 86 | Set Copy = FromAssocs(thatD.Pairs) 87 | 88 | End Function 89 | ' 90 | ' Public Properties 91 | ' ----------------- 92 | ' 93 | ' ### Single Item actions 94 | ' 95 | '' 96 | ' `Item`: same as usual 97 | ' TODO: how does pDict do this -> hashtables 98 | Public Property Get Item(ByVal k) As Variant 99 | Attribute Item.VB_UserMemId = 0 100 | 101 | If pDict.Exists(k) Then 102 | Assign Item, pDict(k) 103 | Else 104 | KeyError Me, "Item", defShow.Show(k) & " is not an entry" 105 | End If 106 | 107 | End Property 108 | Public Property Let Item(ByVal k, ByVal v) 109 | Attribute Item.VB_UserMemId = 0 110 | 111 | pDict(k) = v 112 | 113 | End Property 114 | Public Property Set Item(ByVal k, ByVal v) 115 | Attribute Item.VB_UserMemId = 0 116 | 117 | Set pDict(k) = v 118 | 119 | End Property 120 | '' 121 | ' GetItem: Return default value if `key` does not exist 122 | Public Function GetItem(ByVal k, Optional ByVal default = Empty) As Variant 123 | 124 | Console.PrintLine "WARNING: Method Dict.GetItem is deprecated." 125 | Assign GetItem, GetOrElse(k, default) 126 | 127 | End Function 128 | Public Function GetOrElse(ByVal k, Optional ByVal default = Empty) As Variant 129 | 130 | Assign GetOrElse, MaybeGet(k).GetOrElse(default) 131 | 132 | End Function 133 | Public Function MaybeGet(ByVal k) As Maybe 134 | 135 | Set MaybeGet = Maybe.Attempt(ByName.Create(OnArgs.Make("Item", VbGet, Me), k)) 136 | 137 | End Function 138 | '' 139 | ' Pair: return a `Tuple` of (key, value) 140 | Public Function Pair(ByVal k) As Assoc 141 | 142 | Set Pair = Assoc.Make(k, pDict(k)) 143 | 144 | End Function 145 | ' 146 | <<<<<<< HEAD 147 | ' ### Produce Dicts 148 | ' 149 | Public Function MapValues(ByVal op As IApplicable) As Dict 150 | 151 | Dim result As New Dict 152 | Dim key As Variant 153 | For Each key In pDict.keys 154 | result.Add key, op.Apply(pDict(key)) 155 | ======= 156 | ' Produce Dicts 157 | ' ------------- 158 | ' 159 | Public Function MapValues(ByVal op As Applicable) As Dict 160 | 161 | Dim result As New Dict 162 | Dim k 163 | For Each k In pDict.Keys 164 | result.Add k, op.Apply(pDict.Item(k)) 165 | >>>>>>> 657e6ad39542e8f79bc640baf67c60ca2cd876a7 166 | Next 167 | 168 | Set MapValues = result 169 | 170 | End Function 171 | ' 172 | <<<<<<< HEAD 173 | ' ### Produce Lists 174 | ======= 175 | ' FilterKeys 176 | ' FilterValues 177 | ' FilterNotKeys 178 | ' FilterNotValues 179 | ' 180 | ' TODO: is Dict SetLike? 181 | ' 182 | ' Produce Lists 183 | ' ------------- 184 | >>>>>>> 657e6ad39542e8f79bc640baf67c60ca2cd876a7 185 | ' 186 | Public Function Keys() As List 187 | 188 | Set Keys = List.Copy(pDict.Keys) 189 | 190 | End Function 191 | Public Function Values() As List 192 | 193 | Set Values = List.Copy(pDict.Items) 194 | 195 | End Function 196 | Public Function Pairs() As List 197 | 198 | Dim result As List 199 | Set result = List.Create 200 | 201 | Dim k 202 | For Each k In Keys 203 | result.Append Pair(k) 204 | Next 205 | 206 | Set Pairs = result 207 | 208 | End Function 209 | ' 210 | ' Public Methods 211 | ' -------------- 212 | ' 213 | Public Function Count() As Long 214 | 215 | Count = pDict.Count 216 | 217 | End Function 218 | Public Sub Add(ByVal k, ByVal v) 219 | 220 | pDict.Add k, v 221 | 222 | End Sub 223 | '' 224 | ' Remove: Remove entry 225 | Public Sub Remove(ByVal k) 226 | 227 | pDict.Remove k 228 | 229 | End Sub 230 | Public Function Exists(ByVal k) As Boolean 231 | 232 | Exists = pDict.Exists(k) 233 | 234 | End Function 235 | Public Sub Update(ByVal other As Dict) 236 | 237 | Dim k 238 | For Each k In other.Keys 239 | pDict(k) = other(k) 240 | Next 241 | 242 | End Sub 243 | Public Sub Clear() 244 | 245 | pDict.RemoveAll 246 | 247 | End Sub 248 | ' 249 | ' Showable 250 | ' --------- 251 | ' 252 | Public Function Show() As String 253 | 254 | Show = defShow.ShowableObject(Me, Pairs.ToArray) 255 | 256 | End Function 257 | Private Function Showable_Show() As String 258 | 259 | Showable_Show = Show 260 | 261 | End Function 262 | -------------------------------------------------------------------------------- /src/Equatable.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "Equatable" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = True 10 | Option Explicit 11 | 12 | Public Function Equals(ByVal other As Variant) As Boolean 13 | 14 | End Function 15 | -------------------------------------------------------------------------------- /src/Exceptions.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "Exceptions" 2 | Option Explicit 3 | 4 | Public Enum vbErrorNums 5 | TYPE_ERROR = 13 6 | OBJECT_REQUIRED = 424 7 | INDEX_ERROR = 9 8 | VALUE_ERROR = 380 9 | ' TODO: list more values 10 | End Enum 11 | 12 | Public Enum exErrorNums 13 | TYPE_ERROR = vbErrorNums.TYPE_ERROR 14 | OBJECT_REQUIRED = vbErrorNums.OBJECT_REQUIRED 15 | INDEX_ERROR = vbErrorNums.INDEX_ERROR 16 | VALUE_ERROR = vbErrorNums.VALUE_ERROR 17 | UNIMPLEMENTED = 1 ' TODO: use more non-conflicting values 18 | ILLEGAL_ARGUMENT = 666 19 | KEY_ERROR 20 | OS_ERROR 21 | End Enum 22 | ' 23 | ' Exceptions 24 | ' ========== 25 | ' 26 | Public Sub BubbleError(ByVal raiser, ByVal method As String, _ 27 | ByVal e As ErrObject) 28 | 29 | Dim trace As String 30 | trace = MakeDescription(raiser, method, e.description) 31 | 32 | Err.Raise e.Number, e.source, trace ', e.HelpFile, e.HelpContext 33 | 34 | End Sub 35 | Public Sub IllegalArgument(ByVal raiser, ByVal method As String, _ 36 | Optional ByVal msg As String) 37 | 38 | RaiseError exErrorNums.ILLEGAL_ARGUMENT, raiser, method, msg 39 | 40 | End Sub 41 | Public Sub IndexError(ByVal raiser, ByVal method As String, _ 42 | Optional ByVal msg As String) 43 | 44 | RaiseError exErrorNums.INDEX_ERROR, raiser, method, msg 45 | 46 | End Sub 47 | Public Sub KeyError(ByVal raiser, ByVal method As String, _ 48 | Optional ByVal msg As String) 49 | 50 | RaiseError exErrorNums.KEY_ERROR, raiser, method, msg 51 | 52 | End Sub 53 | Public Sub NotImplementedError(ByVal raiser, ByVal method As String) 54 | 55 | Dim source As String 56 | source = MakeSource(raiser, method) 57 | 58 | Dim msg As String 59 | msg = source & " Not implemented." 60 | 61 | RaiseError exErrorNums.UNIMPLEMENTED, raiser, method, msg 62 | 63 | End Sub 64 | Public Sub OSError(ByVal raiser, ByVal method As String, _ 65 | Optional ByVal msg As String) 66 | 67 | RaiseError exErrorNums.OS_ERROR, raiser, method, msg 68 | 69 | End Sub 70 | Public Sub TypeError(ByVal raiser, ByVal method As String, _ 71 | Optional ByVal msg As String) 72 | 73 | RaiseError exErrorNums.TYPE_ERROR, raiser, method, msg 74 | 75 | End Sub 76 | Public Sub ValueError(ByVal raiser, ByVal method As String, _ 77 | Optional ByVal msg As String) 78 | 79 | RaiseError exErrorNums.VALUE_ERROR, raiser, method, msg 80 | 81 | End Sub 82 | ' 83 | ' Private Methods 84 | ' --------------- 85 | ' 86 | Private Sub RaiseError(ByVal errNum As exErrorNums, ByVal raiser, _ 87 | ByVal method As String, ByVal msg As String) 88 | 89 | Err.Raise errNum, description:=MakeDescription(raiser, method, msg) 90 | 91 | End Sub 92 | Private Function MakeDescription(ByVal raiser, ByVal method As String, _ 93 | ByVal msg As String) As String 94 | 95 | MakeDescription = AddTrace(MakeSource(raiser, method), msg) 96 | 97 | End Function 98 | Private Function MakeSource(ByVal raiser, ByVal method As String) As String 99 | 100 | Dim result As String 101 | If IsObject(raiser) Then 102 | result = TypeName(raiser) & "." & method 103 | Else 104 | result = raiser & "." & method 105 | End If 106 | 107 | MakeSource = result 108 | 109 | End Function 110 | Private Function AddTrace(ByVal source As String, _ 111 | ByVal description As String) As String 112 | 113 | AddTrace = source & " >> " & description 114 | 115 | End Function 116 | -------------------------------------------------------------------------------- /src/Frame.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "Frame" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = True 9 | Attribute VB_Exposed = True 10 | Option Explicit 11 | ' 12 | ' Frame 13 | ' ===== 14 | ' 15 | ' Wrapper for a Linear with mutable bounds 16 | ' 17 | ' Copywrite (C) 2014 Philip Wales 18 | ' This file (Frame.cls) is distributed under the GPL-3.0 license 19 | ' Obtain a copy of the GPL-3.0 license 20 | ' 21 | Implements Showable 22 | Implements Linear 23 | ' 24 | ' Private Members 25 | ' --------------- 26 | ' 27 | Private pLinearSequence As Linear 28 | Private pLower As Long 29 | Private pUpper As Long 30 | ' 31 | ' Constructors 32 | ' ------------ 33 | ' 34 | Public Function Make(ByVal linSeq As Linear, _ 35 | ByVal lower As Long, ByVal upper As Long) As Frame 36 | 37 | Dim result As New Frame 38 | result.Inject linSeq, lower, upper 39 | Set Make = result 40 | 41 | End Function 42 | Public Function FromLeft(ByVal linSeq As Linear, _ 43 | ByVal upper As Long) As Frame 44 | 45 | Set FromLeft = Make(linSeq, linSeq.LowerBound, upper) 46 | 47 | End Function 48 | Public Function FromRight(ByVal linSeq As Linear, _ 49 | ByVal lower As Long) As Frame 50 | 51 | Set FromRight = Make(linSeq, lower, linSeq.UpperBound) 52 | 53 | End Function 54 | Friend Sub Inject(ByVal linSeq As Linear, ByVal lower As Long, ByVal upper As Long) 55 | 56 | CheckIndexRange linSeq, "Item", lower 57 | CheckIndexRange linSeq, "Item", upper 58 | Set pLinearSequence = linSeq 59 | pLower = lower 60 | pUpper = upper 61 | 62 | End Sub 63 | '' 64 | ' Public Methods 65 | ' -------------- 66 | ' 67 | Public Function ConvertTo(ByVal seed As Buildable) As Buildable 68 | 69 | Dim result As Buildable 70 | Set result = seed.MakeEmpty 71 | 72 | Dim i As Long 73 | For i = pLower To pUpper 74 | seed.AddItem Item(i) 75 | Next 76 | 77 | Set ConvertTo = result 78 | 79 | End Function 80 | Public Function MapTo(ByVal seed As Buildable, ByVal op As Applicable) As Buildable 81 | 82 | Set MapTo = defMap.IterableMap(seed, op, Me) 83 | 84 | End Function 85 | Public Function FlatMapTo(ByVal seed As Buildable, ByVal op As Applicable) As Buildable 86 | 87 | Set FlatMapTo = defMap.IterableBind(seed, op, Me) 88 | 89 | End Function 90 | ' FilterTo and all the others..... 91 | '' 92 | ' Transversable 93 | ' ------------- 94 | ' 95 | Public Property Get NewEnum() As IUnknown 96 | Attribute NewEnum.VB_UserMemId = -4 97 | 98 | Static copyCollec As Collection 99 | Set copyCollec = ToCollection 100 | Set NewEnum = copyCollec.[_NewEnum] 101 | 102 | End Property 103 | '' 104 | ' Linear 105 | ' --------- 106 | ' 107 | Public Property Get Item(ByVal index As Long) As Variant 108 | Attribute Item.VB_UserMemId = 0 109 | 110 | CheckIndexRange Me, "Item", index 111 | Assign Item, pLinearSequence.Item(index + pLower) 112 | 113 | End Property 114 | Public Function LowerBound() As Long 115 | 116 | LowerBound = 1 117 | 118 | End Function 119 | '' 120 | ' [ 0 | 1 | 2 | 3 | 4 ] 121 | ' [ 0 | 1 ] 122 | Public Function UpperBound() As Long 123 | 124 | UpperBound = pUpper - pLower 125 | 126 | End Function 127 | 128 | Private Function Linear_Item(ByVal index As Long) As Variant 129 | 130 | Assign Linear_Item, Item(index) 131 | 132 | End Function 133 | Private Function Linear_LowerBound() As Long 134 | 135 | Linear_LowerBound = LowerBound 136 | 137 | End Function 138 | Private Function Linear_UpperBound() As Long 139 | 140 | Linear_UpperBound = UpperBound 141 | 142 | End Function 143 | Public Function ToArray() As Variant() 144 | 145 | ToArray = defIterable.ToArray(Me) 146 | 147 | End Function 148 | Private Function Linear_ToArray() As Variant() 149 | 150 | Linear_ToArray = ToArray() 151 | 152 | End Function 153 | Public Function ToCollection() As Collection 154 | 155 | Set ToCollection = defIterable.ToCollection(Me) 156 | 157 | End Function 158 | Private Function Linear_ToCollection() As Collection 159 | 160 | Set Linear_ToCollection = ToCollection 161 | 162 | End Function 163 | Public Function ToBuildable(ByVal seed As Buildable) As Buildable 164 | 165 | Set ToBuildable = defIterable.ToBuildable(seed, Me) 166 | 167 | End Function 168 | Private Function Linear_ToBuildable(ByVal seed As Buildable) As Buildable 169 | 170 | Set Linear_ToBuildable = ToBuildable(seed) 171 | 172 | End Function 173 | ' 174 | ' Showable 175 | ' --------- 176 | ' 177 | Public Function Show() As String 178 | 179 | Show = defShow.ParamShowableObject(Me, pLinearSequence, pLower, pUpper) 180 | 181 | End Function 182 | Private Function Showable_Show() As String 183 | 184 | Showable_Show = Show 185 | 186 | End Function 187 | -------------------------------------------------------------------------------- /src/InternalDelegate.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "InternalDelegate" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = True 9 | Attribute VB_Exposed = True 10 | ' 11 | ' InternalDelegate 12 | ' ================ 13 | ' 14 | ' Copywrite (C) 2014 Philip Wales 15 | ' This file (InternalDelegate.cls) is distributed under the GPL-3.0 license 16 | ' Obtain a copy of the GPL-3.0 license 17 | ' 18 | ' 19 | Option Explicit 20 | Implements Showable 21 | Implements Applicable 22 | ' 23 | ' Constants 24 | ' --------- 25 | ' 26 | Private Const CANNOT_FIND_MACRO As Integer = 1004 27 | ' 28 | ' Private Members 29 | ' --------------- 30 | ' 31 | Private pFunctionName As String 32 | ' 33 | ' Constructors 34 | ' ------------ 35 | ' 36 | Public Function Make(ByVal funcName As String) As InternalDelegate 37 | 38 | Dim result As New InternalDelegate 39 | result.Inject funcName 40 | Set Make = result 41 | 42 | End Function 43 | ' 44 | ' Friend Methods 45 | ' -------------- 46 | ' 47 | Friend Sub Inject(ByVal funcName As String) 48 | 49 | pFunctionName = funcName 50 | 51 | End Sub 52 | ' 53 | ' Applicable 54 | ' ----------- 55 | ' 56 | ' ### Meaningful 57 | ' 58 | '! default member 59 | Public Function Apply(ParamArray args()) As Variant 60 | Attribute Apply.VB_UserMemId = 0 61 | On Error GoTo ErrHandler 62 | 63 | Assign Apply, ApplyOnArray(CArray(args)) 64 | 65 | Exit Function 66 | ErrHandler: 67 | Select Case Err.Number 68 | 69 | Case CANNOT_FIND_MACRO 70 | 71 | Dim msg As String 72 | msg = pFunctionName & ": is not a global Function or Sub in VBEX" 73 | Exceptions.ValueError Me, "Apply", msg 74 | 75 | Case Else 76 | Exceptions.BubbleError Me, "Apply", Err 77 | 78 | End Select 79 | End Function 80 | ' 81 | ' ### Embedded 82 | ' 83 | Public Function ApplyOnArray(ByRef args() As Variant) As Variant 84 | 85 | Assign ApplyOnArray, defApply.ApplicationRunOnArray(pFunctionName, args) 86 | 87 | End Function 88 | Private Function Applicable_Apply(ParamArray args()) As Variant 89 | 90 | Assign Applicable_Apply, Applicable_ApplyOnArray(CArray(args)) 91 | 92 | End Function 93 | Private Function Applicable_ApplyOnArray(ByRef args() As Variant) As Variant 94 | 95 | Assign Applicable_ApplyOnArray, ApplyOnArray(args) 96 | 97 | End Function 98 | Public Function Compose(ByVal f As Applicable) As Applicable 99 | 100 | Set Compose = defApply.Compose(Me, f) 101 | 102 | End Function 103 | Private Function Applicable_Compose(ByVal f As Applicable) As Applicable 104 | 105 | Set Applicable_Compose = Compose(f) 106 | 107 | End Function 108 | Public Function AndThen(ByVal g As Applicable) As Applicable 109 | 110 | Set AndThen = defApply.AndThen(Me, g) 111 | 112 | End Function 113 | Private Function Applicable_AndThen(ByVal g As Applicable) As Applicable 114 | 115 | Set Applicable_AndThen = AndThen(g) 116 | 117 | End Function 118 | Public Function Partial(ParamArray args() As Variant) As Applicable 119 | 120 | Set Partial = AsPartial(CArray(args)) 121 | 122 | End Function 123 | Private Function Applicable_Partial(ParamArray args() As Variant) As Applicable 124 | 125 | Set Applicable_Partial = AsPartial(CArray(args)) 126 | 127 | End Function 128 | Public Function AsPartial(ByRef args() As Variant) As Applicable 129 | 130 | Set AsPartial = defApply.AsPartial(Me, args) 131 | 132 | End Function 133 | Private Function Applicable_AsPartial(ByRef args() As Variant) As Applicable 134 | 135 | Set Applicable_AsPartial = AsPartial(args) 136 | 137 | End Function 138 | Public Function delay(ParamArray args() As Variant) As Delayed 139 | 140 | Set delay = AsDelay(CArray(args)) 141 | 142 | End Function 143 | Private Function Applicable_Delay(ParamArray args() As Variant) As Delayed 144 | 145 | Set Applicable_Delay = AsDelay(CArray(args)) 146 | 147 | End Function 148 | Public Function AsDelay(ByRef args() As Variant) As Delayed 149 | 150 | Set AsDelay = defApply.AsDelay(Me, args) 151 | 152 | End Function 153 | Private Function Applicable_AsDelay(ByRef args() As Variant) As Delayed 154 | 155 | Set Applicable_AsDelay = AsDelay(args) 156 | 157 | End Function 158 | ' 159 | ' Showable 160 | ' --------- 161 | ' 162 | Public Function Show() As String 163 | 164 | Show = defShow.ParamShowableObject(Me, pFunctionName) 165 | 166 | End Function 167 | Private Function Showable_Show() As String 168 | 169 | Showable_Show = Show 170 | 171 | End Function 172 | -------------------------------------------------------------------------------- /src/Lambda.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "Lambda" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = True 9 | Attribute VB_Exposed = True 10 | ' 11 | ' Lambda 12 | ' ====== 13 | ' 14 | ' Copywrite (C) 2014 Philip Wales 15 | ' Original idea from Mathieu Guindon. 16 | ' This file (Lambda.cls) is distributed under the GPL-3.0 license 17 | ' Obtain a copy of the GPL-3.0 license 18 | ' 19 | ' Create lambda expressions from strings using 20 | ' either C# notation 21 | ' 22 | ' "(x, y, z) => x * y + z" 23 | ' 24 | ' Or Scala-ish short hand 25 | ' 26 | ' "( _ * _ ) + _" 27 | ' 28 | ' both produce the same result 29 | ' 30 | ' RESTRICTIONS 31 | ' ------------ 32 | ' 33 | ' Lambdas currently must be completely independent of external definitions. 34 | ' One cannot reference external varaibles or functions from a lambda. This 35 | ' is because Lambda simple translates the strings to a proper function defintion 36 | ' that are written to an external blank module. That module is reference by the 37 | ' client code but not visa versa. 38 | ' 39 | ' _eg_ both of these are invalid: 40 | ' 41 | ' Public Function Intersect(ByVal other As SortedSet) As SortedSet 42 | ' Set Intersect = Filter(Lambda.FromString("(x) => other.Exists(x)") 43 | ' End Function 44 | ' 45 | ' `Other` is not decalared in the scope of the created lambda function. 46 | ' 47 | ' Public Function Foo() As Integer 48 | ' Foo = 12 49 | ' End Function 50 | ' Public Sub Bar() 51 | ' Debug.Print List.Create(1,2,3).Map(Lambda.FromShort("_ + Foo()")).Show 52 | ' End Sub 53 | ' 54 | ' `Foo` is not declared in the scope of the lambda. 55 | ' 56 | ' Currently, the external module is located inside of the VBEX project. 57 | ' So it should be able to reference VBEX methods. Ergo, this is valid. 58 | ' 59 | ' Private Function BaseNames(ByVal filepaths As List) As List 60 | ' Set BaseNames = filepaths.Map(Lambda.FromProper("(f) => path.BaseName(f)")) 61 | ' End Function 62 | ' 63 | ' 64 | ' TODO: 65 | ' ----- 66 | ' 67 | ' - pass local variables to the lambda. 68 | ' 69 | Option Explicit 70 | Implements Showable 71 | Implements Applicable 72 | ' 73 | ' Constants 74 | ' --------- 75 | ' 76 | Private Const CANNOT_FIND_MACRO As Integer = 1004 77 | Private Const INVALID_LAMBDA_EXPRESSION As Integer = 666 ' TODO: 78 | Private Const SHORT_HAND_CHAR As String = "_" ' TODO: it's acutal name 79 | ' 80 | ' Private Members 81 | ' --------------- 82 | ' 83 | Private pId As String ' name of the lamda in LambdaTable 84 | Private pExpression As String ' Only for the `Show` method 85 | ' 86 | ' Class 87 | ' ----- 88 | Private Sub Class_Terminate() 89 | 90 | LambdaTable.RemoveLambda pId 91 | 92 | End Sub 93 | ' 94 | ' Constructors 95 | ' ------------ 96 | ' 97 | '' 98 | ' Create an Lambda Function 99 | Public Function Make(ByRef args() As String, ByVal expr As String) As Lambda 100 | 101 | Dim result As New Lambda 102 | result.SendToLambdaTable args, expr 103 | Set Make = result 104 | 105 | End Function 106 | ' 107 | ' "(args) => expr" 108 | ' Public Function func(args) As Variant 109 | ' cast.Assign func, expr 110 | ' End Function 111 | Public Function FromProper(ByVal proper As String) As Lambda 112 | 113 | Dim splitExpr() As String 114 | splitExpr = Split(proper, ") => ") 115 | 116 | Dim params As String 117 | params = Mid$(splitExpr(0), 2) ' skip "(" 118 | 119 | Dim expr As String 120 | expr = splitExpr(1) 121 | 122 | Dim args() As String 123 | args = Split(Replace$(params, " ", ""), ",") 124 | 125 | Set FromProper = Make(args, expr) 126 | 127 | End Function 128 | Public Function FromShort(ByVal shorthand As String) As Lambda 129 | 130 | Const ASCaCODE As Integer = 97 ' Asc("a") 131 | 132 | Dim expr As String 133 | expr = shorthand 134 | 135 | Dim argsize As Integer 136 | argsize = UBound(Split(expr, SHORT_HAND_CHAR)) - 1 137 | 138 | Dim args() As String 139 | ReDim args(0 To argsize) 140 | 141 | Dim i As Integer 142 | For i = 0 To argsize 143 | 144 | Dim paramChar As String 145 | paramChar = Chr(ASCaCODE + i) 146 | 147 | expr = Replace(expr, SHORT_HAND_CHAR, paramChar, Count:=1) 148 | 149 | args(i) = paramChar 150 | 151 | Next i 152 | 153 | Set FromShort = Make(args, expr) 154 | 155 | End Function 156 | ' 157 | ' Friend Methods 158 | ' -------------- 159 | ' 160 | Friend Sub SendToLambdaTable(ByRef args() As String, ByVal expr As String) 161 | 162 | pExpression = expr 163 | pId = LambdaTable.AddLambda(args, expr) 164 | 165 | End Sub 166 | ' 167 | ' Applicable 168 | ' ----------- 169 | ' 170 | ' ### Meaningful 171 | ' 172 | Public Function ApplyOnArray(ByRef args() As Variant) As Variant 173 | 174 | Assign ApplyOnArray, defApply.ApplicationRunOnArray(pId, args) 175 | 176 | End Function 177 | ' 178 | ' ### Embeded 179 | ' 180 | '! default member 181 | Public Function Apply(ParamArray args()) As Variant 182 | Attribute Apply.VB_UserMemId = 0 183 | 184 | Assign Apply, ApplyOnArray(CArray(args)) 185 | 186 | End Function 187 | Private Function Applicable_Apply(ParamArray args()) As Variant 188 | 189 | Assign Applicable_Apply, ApplyOnArray(CArray(args)) 190 | 191 | End Function 192 | Private Function Applicable_ApplyOnArray(ByRef args() As Variant) As Variant 193 | 194 | Assign Applicable_ApplyOnArray, ApplyOnArray(args) 195 | 196 | End Function 197 | Public Function Compose(ByVal f As Applicable) As Applicable 198 | 199 | Set Compose = defApply.Compose(Me, f) 200 | 201 | End Function 202 | Private Function Applicable_Compose(ByVal f As Applicable) As Applicable 203 | 204 | Set Applicable_Compose = Compose(f) 205 | 206 | End Function 207 | Public Function AndThen(ByVal g As Applicable) As Applicable 208 | 209 | Set AndThen = defApply.AndThen(Me, g) 210 | 211 | End Function 212 | Private Function Applicable_AndThen(ByVal g As Applicable) As Applicable 213 | 214 | Set Applicable_AndThen = AndThen(g) 215 | 216 | End Function 217 | Public Function Partial(ParamArray args() As Variant) As Applicable 218 | 219 | Set Partial = AsPartial(CArray(args)) 220 | 221 | End Function 222 | Private Function Applicable_Partial(ParamArray args() As Variant) As Applicable 223 | 224 | Set Applicable_Partial = AsPartial(CArray(args)) 225 | 226 | End Function 227 | Public Function AsPartial(ByRef args() As Variant) As Applicable 228 | 229 | Set AsPartial = defApply.AsPartial(Me, args) 230 | 231 | End Function 232 | Private Function Applicable_AsPartial(ByRef args() As Variant) As Applicable 233 | 234 | Set Applicable_AsPartial = AsPartial(args) 235 | 236 | End Function 237 | Public Function delay(ParamArray args() As Variant) As Delayed 238 | 239 | Set delay = AsDelay(CArray(args)) 240 | 241 | End Function 242 | Private Function Applicable_Delay(ParamArray args() As Variant) As Delayed 243 | 244 | Set Applicable_Delay = AsDelay(CArray(args)) 245 | 246 | End Function 247 | Public Function AsDelay(ByRef args() As Variant) As Delayed 248 | 249 | Set AsDelay = defApply.AsDelay(Me, args) 250 | 251 | End Function 252 | Private Function Applicable_AsDelay(ByRef args() As Variant) As Delayed 253 | 254 | Set Applicable_AsDelay = AsDelay(args) 255 | 256 | End Function 257 | 258 | ' 259 | ' Showable 260 | ' --------- 261 | ' 262 | Public Function Show() As String 263 | 264 | Show = defShow.ParamShowableObject(Me, pId, pExpression) 265 | 266 | End Function 267 | Private Function Showable_Show() As String 268 | 269 | Showable_Show = Show 270 | 271 | End Function 272 | -------------------------------------------------------------------------------- /src/LambdaTable.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "LambdaTable" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = True 9 | Attribute VB_Exposed = True 10 | Option Explicit 11 | ' 12 | ' Constants 13 | ' --------- 14 | ' 15 | Private Const DEFAULT_LAMBDA_ID As String = "x___" 16 | Private Const CANNOT_FIND_MACRO As Integer = 1004 17 | Private Const LAMBDA_MODULE As String = "LambdasModule" '? 18 | ' 19 | ' Private Members 20 | ' --------------- 21 | ' 22 | Private pLambdaCount As Long 23 | ' 24 | ' Class 25 | ' ----- 26 | ' 27 | Private Sub Class_Initialize() 28 | pLambdaCount = 0 29 | ClearModule 30 | End Sub 31 | Private Sub Class_Terminate() 32 | ClearModule 33 | End Sub 34 | Private Sub ClearModule() 35 | 36 | With LambdaCodeModule 37 | .DeleteLines 1, .CountOfLines 38 | End With 39 | 40 | pLambdaCount = 0 41 | 42 | End Sub 43 | 44 | ' 45 | ' Add lambda to table return lambda name 46 | ' 47 | Public Function AddLambda(ByRef args() As String, _ 48 | ByVal expression As String) As String 49 | 50 | Dim id As String 51 | id = GenerateLambdaId 52 | 53 | Dim funCode As String 54 | funCode = BuildFunction(id, expression, args) 55 | 56 | LambdaCodeModule.AddFromString funCode 57 | 58 | AddLambda = id 59 | 60 | End Function 61 | Public Sub RemoveLambda(ByVal id As String) 62 | 63 | With LambdaCodeModule 64 | 65 | Dim lineStart As Long 66 | lineStart = .ProcStartLine(id, vbext_pk_Proc) 67 | 68 | Dim lineCount As Long 69 | lineCount = .ProcCountLines(id, vbext_pk_Proc) 70 | 71 | .DeleteLines lineStart, lineCount 72 | 73 | End With 74 | 75 | End Sub 76 | Private Function GenerateLambdaId() As String 77 | 78 | pLambdaCount = pLambdaCount + 1 79 | GenerateLambdaId = DEFAULT_LAMBDA_ID & Hex(pLambdaCount) 80 | 81 | End Function 82 | ' 83 | ' ### Code Building 84 | ' 85 | Private Function BuildFunction(ByVal id As String, ByVal exp As String, ByRef args() As String) As String 86 | 87 | Dim bod As String 88 | bod = Body(id, exp) 89 | 90 | Dim parms As String 91 | parms = Parameters(args) 92 | 93 | Dim sig As String 94 | sig = Signature(id, parms) 95 | 96 | BuildFunction = Content(sig, bod) 97 | 98 | End Function 99 | Private Function Content(ByVal sig As String, ByVal bod As String) As String 100 | 101 | Content = Join(Array(sig, bod, "End Function"), vbNewLine) 102 | 103 | End Function 104 | Private Function Signature(ByVal id As String, ByVal parms As String) As String 105 | 106 | Signature = "Public Function " & id & "(" & parms & ") As Variant" 107 | 108 | End Function 109 | Private Function Body(ByVal id As String, ByVal exp As String) As String 110 | 111 | Body = "cast.Assign " & id & ", " & exp 112 | 113 | End Function 114 | Private Function Parameters(ByRef args() As String) As String 115 | 116 | Parameters = Join(args, ", ") 117 | 118 | End Function 119 | ' 120 | ' ### VBE access 121 | ' 122 | Private Property Get LambdaCodeModule() As CodeModule 123 | 124 | Set LambdaCodeModule = ThisWorkbook.VBProject.VBComponents(LAMBDA_MODULE).CodeModule 125 | 126 | End Property 127 | -------------------------------------------------------------------------------- /src/LambdasModule.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "LambdasModule" 2 | -------------------------------------------------------------------------------- /src/Lazy.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "Lazy" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = True 9 | Attribute VB_Exposed = True 10 | Option Explicit 11 | ' 12 | ' Lazy Class 13 | ' ============ 14 | ' 15 | ' 16 | ' Copywrite (C) 2014 Philip Wales 17 | ' This file (Lazy.cls) is distributed under the GPL-3.0 license 18 | ' Obtain a copy of the GPL-3.0 license 19 | ' 20 | Implements Showable 21 | Implements Delayed 22 | ' 23 | ' Private Members 24 | ' --------------- 25 | ' 26 | Private pDelayed As Delayed 27 | Private pValue As Variant 28 | ' 29 | ' Constructors 30 | ' ------------ 31 | ' 32 | Public Function Create(ByVal op As Applicable, ParamArray args()) As Lazy 33 | 34 | Set Create = Make(op, CArray(args)) 35 | 36 | End Function 37 | Public Function Make(ByVal op As Applicable, ByRef args()) As Lazy 38 | 39 | Dim delay As ByName 40 | Set delay = ByName.Make(op, args) 41 | 42 | Set Make = FromDelayed(delay) 43 | 44 | End Function 45 | Public Function FromDelayed(ByVal delay As Delayed) As Lazy 46 | 47 | Dim result As New Lazy 48 | result.Inject delay 49 | Set FromDelayed = result 50 | 51 | End Function 52 | Friend Sub Inject(ByVal delay As Delayed) 53 | 54 | Set pDelayed = delay 55 | 56 | End Sub 57 | ' 58 | ' Public Methods 59 | ' -------------- 60 | ' 61 | Public Function IsDelayed() As Boolean 62 | 63 | IsDelayed = IsEmpty(pValue) 64 | 65 | End Function 66 | Public Function IsEvaluated() As Boolean 67 | 68 | IsEvaluated = (Not IsDelayed) 69 | 70 | End Function 71 | ' 72 | ' Delayed 73 | ' -------- 74 | ' 75 | Public Property Get Evaluate() As Variant 76 | Attribute Evaluate.VB_UserMemId = 0 77 | 78 | If IsDelayed Then 79 | Assign pValue, pDelayed.Evaluate 80 | End If 81 | 82 | Assign Evaluate, pValue 83 | 84 | End Property 85 | Private Property Get Delayed_Evaluate() As Variant 86 | 87 | Assign Delayed_Evaluate, Evaluate 88 | 89 | End Property 90 | Public Function Map(ByVal op As Applicable) As Lazy 91 | 92 | Dim result As Delayed 93 | If IsDelayed Then 94 | ' `Me` in a parameter array evauluates the default property... 95 | Dim args(0 To 0) As Variant 96 | Assign args(0), Me 97 | Set result = ByName.Make(op, args) ' Evaluating result does not evaluate `Me` when using a CallByName Applicable. 98 | Debug.Assert IsDelayed 99 | Else 100 | Set result = ByName.Create(op, pValue) 101 | End If 102 | 103 | Set Map = Lazy.FromDelayed(result) 104 | 105 | End Function 106 | Private Function Delayed_Map(ByVal op As Applicable) As Delayed 107 | 108 | Set Delayed_Map = Map(op) 109 | 110 | End Function 111 | ' 112 | ' Showable 113 | ' --------- 114 | ' 115 | Public Function Show() As String 116 | 117 | Dim repr As String 118 | If IsDelayed Then 119 | repr = defShow.Show(pDelayed) 120 | Else 121 | repr = defShow.Show(pValue) 122 | End If 123 | Show = defShow.ParamShowableObject(Me, repr) 124 | 125 | End Function 126 | Private Function Showable_Show() As String 127 | 128 | Showable_Show = Show 129 | 130 | End Function 131 | -------------------------------------------------------------------------------- /src/Linear.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "Linear" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = True 10 | Option Explicit 11 | ' 12 | ' Linear 13 | ' ====== 14 | ' 15 | ' Has Indexed _read_ access 16 | ' 17 | Public Function Item(ByVal index As Long) As Variant 18 | Attribute Item.VB_UserMemId = 0 19 | 20 | End Function 21 | Public Function LowerBound() As Long 22 | 23 | End Function 24 | Public Function UpperBound() As Long 25 | 26 | End Function 27 | Public Function ToArray() As Variant() 28 | 29 | End Function 30 | Public Function ToCollection() As Collection 31 | 32 | End Function 33 | Public Function ToBuildable(ByVal seed As Buildable) As Buildable 34 | 35 | End Function 36 | 'Public Function IndexWhere(ByVal pred As Applicable) As Maybe 37 | ' 38 | 'End Function 39 | 'Public Function IndexOf(ByVal val As Variant) As Maybe 40 | ' 41 | 'End Function 42 | 'Public Function LastIndexWhere(ByVal pred As Applicable) As Maybe 43 | ' 44 | 'End Function 45 | 'Public Function LastIndexOf(ByVal val As Variant) As Maybe 46 | ' 47 | 'End Function 48 | 'Public Function Find(ByVal pred As Applicable) As Maybe 49 | ' 50 | 'End Function 51 | 'Public Function FindLast(ByVal pred As Applicable) As Maybe 52 | ' 53 | 'End Function 54 | 'Public Function CountWhere(ByVal pred As Applicable) As Long 55 | ' 56 | 'End Function 57 | -------------------------------------------------------------------------------- /src/Maybe.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "Maybe" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = True 9 | Attribute VB_Exposed = True 10 | Option Explicit 11 | ' 12 | ' Maybe Class 13 | ' =========== 14 | ' 15 | ' 16 | ' Copywrite (C) 2014 Philip Wales 17 | ' This file (Maybe.cls) is distributed under the GPL-3.0 license 18 | ' Obtain a copy of the GPL-3.0 license 19 | ' 20 | ' An object that optionally contains an item. It's use is an abstraction from 21 | ' checking if a method returned a value or not. 22 | ' 23 | ' 24 | Implements Equatable 25 | Implements Showable 26 | Implements Monadic 27 | ' 28 | ' Private Members 29 | ' --------------- 30 | ' 31 | Private pVar As Variant 32 | ' 33 | ' Constructor 34 | ' ----------- 35 | ' 36 | Public Function Some(ByVal x) As Maybe 37 | 38 | Dim result As New Maybe 39 | result.Inject x 40 | Set Some = result 41 | 42 | End Function 43 | Public Function None() As Maybe 44 | 45 | Dim result As New Maybe 46 | Set None = result 47 | 48 | End Function 49 | Public Function MakeIf(ByVal pred As Boolean, ByVal x) As Maybe 50 | 51 | If pred Then 52 | Set MakeIf = Some(x) 53 | Else 54 | Set MakeIf = None 55 | End If 56 | 57 | End Function 58 | Public Function Attempt(ByVal delay As Delayed) As Maybe 59 | 60 | Dim result As Maybe 61 | On Error GoTo Fail 62 | Set result = Some(delay.Evaluate()) 63 | On Error GoTo 0 64 | 65 | CleanExit: 66 | Set Attempt = result 67 | 68 | Exit Function 69 | 70 | Fail: 71 | Set result = None() 72 | Resume CleanExit 73 | 74 | End Function 75 | ' 76 | ' ### Friend Methods 77 | ' 78 | Friend Sub Inject(ByVal x) 79 | 80 | Assign pVar, x 81 | 82 | End Sub 83 | ' 84 | ' Public Methods 85 | ' -------------- 86 | ' 87 | Public Function IsNone() As Boolean 88 | 89 | IsNone = IsEmpty(pVar) 90 | 91 | End Function 92 | Public Function IsSome() As Boolean 93 | 94 | IsSome = (Not IsNone) 95 | 96 | End Function 97 | Public Property Get GetItem() As Variant 98 | Attribute GetItem.VB_UserMemId = 0 99 | 100 | If IsSome Then 101 | Assign GetItem, pVar 102 | Else 103 | ValueError Me, "GetItem", "Cannot get None" 104 | End If 105 | 106 | End Property 107 | Public Function GetOrElse(ByVal other) As Variant 108 | 109 | If IsSome Then 110 | Assign GetOrElse, pVar 111 | Else 112 | Assign GetOrElse, other 113 | End If 114 | 115 | End Function 116 | ' 117 | ' Equatable 118 | ' ---------- 119 | ' 120 | Public Function Equals(ByVal x) As Boolean 121 | 122 | Equals = False 123 | 124 | If TypeName(x) <> TypeName(Me) Then 125 | Exit Function 126 | End If 127 | 128 | Dim mx As Maybe 129 | Set mx = x 130 | 131 | If IsSome And mx.IsSome Then 132 | Equals = (defEquals.Equals(pVar, mx.GetItem)) 133 | Else 134 | Equals = (IsNone And mx.IsNone) 135 | End If 136 | 137 | End Function 138 | Private Function Equatable_Equals(ByVal x) As Boolean 139 | 140 | Equatable_Equals = Equals(x) 141 | 142 | End Function 143 | ' 144 | ' Monadic 145 | ' -------- 146 | ' 147 | Public Function Bind(ByVal op As Applicable) As Maybe 148 | 149 | Dim result As Maybe 150 | If IsSome Then 151 | 152 | On Error GoTo ErrHandler 153 | Dim opResult 154 | Assign opResult, op.Apply(pVar) 155 | Set result = opResult 156 | On Error GoTo 0 157 | 158 | Else 159 | Set result = None 160 | End If 161 | 162 | Set Bind = result 163 | Exit Function 164 | ErrHandler: 165 | Dim msg As String 166 | Select Case Err.Number 167 | Case vbErrorNums.TYPE_ERROR, vbErrorNums.OBJECT_REQUIRED 168 | msg = defShow.Show(op) & " did not return a Maybe object" 169 | Exceptions.TypeError Me, "Bind", msg 170 | Case Else 171 | Exceptions.BubbleError Me, "Bind", Err 172 | End Select 173 | End Function 174 | Public Function Map(ByVal op As Applicable) As Maybe 175 | 176 | Dim result As Maybe 177 | If IsSome Then 178 | Set result = Some(op.Apply(pVar)) 179 | Else 180 | Set result = None 181 | End If 182 | Set Map = result 183 | 184 | End Function 185 | Private Function Monadic_Bind(ByVal op As Applicable) As Monadic 186 | 187 | Set Monadic_Bind = Bind(op) 188 | 189 | End Function 190 | Private Function Monadic_Map(ByVal op As Applicable) As Monadic 191 | 192 | Set Monadic_Map = Map(op) 193 | 194 | End Function 195 | Private Function Monadic_Unit(ByVal x) As Monadic 196 | 197 | Set Monadic_Unit = Some(x) 198 | 199 | End Function 200 | ' 201 | ' Showable 202 | ' --------- 203 | ' 204 | Public Function Show() As String 205 | 206 | Dim result As String 207 | If IsNone Then 208 | result = ParamShowableObject(Me) 209 | Else 210 | result = ParamShowableObject(Me, pVar) 211 | End If 212 | 213 | Show = result 214 | 215 | End Function 216 | Private Function Showable_Show() As String 217 | 218 | Showable_Show = Show 219 | 220 | End Function 221 | -------------------------------------------------------------------------------- /src/Monadic.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "Monadic" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = True 10 | Option Explicit 11 | 12 | Public Function Bind(ByVal op As Applicable) As Monadic 13 | 14 | End Function 15 | Public Function Map(ByVal op As Applicable) As Monadic 16 | 17 | End Function 18 | Public Function Unit(ByVal x) As Monadic 19 | Attribute Unit.VB_UserMemId = 0 20 | 21 | End Function 22 | -------------------------------------------------------------------------------- /src/OnArgs.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "OnArgs" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = True 9 | Attribute VB_Exposed = True 10 | ' 11 | ' OnArgs 12 | ' ====== 13 | ' 14 | ' Copywrite (C) 2014 Philip Wales 15 | ' This file (OnArgs.cls) is distributed under the GPL-3.0 license 16 | ' Obtain a copy of the GPL-3.0 license 17 | ' 18 | ' obj.method(_) 19 | ' 20 | Option Explicit 21 | Implements Applicable 22 | Implements Showable 23 | ' 24 | ' Private Members 25 | ' --------------- 26 | ' 27 | Private pObj As Object 28 | Private pMethod As String 29 | Private pCallType As VbCallType 30 | ' 31 | ' Constructors 32 | ' ------------ 33 | ' 34 | Public Function Make(ByVal method As String, ByVal callT As VbCallType, _ 35 | ByVal obj As Object) As OnArgs 36 | 37 | Dim result As New OnArgs 38 | result.Inject obj, method, callT 39 | Set Make = result 40 | 41 | End Function 42 | ' 43 | ' ### Friend Methods 44 | ' 45 | Friend Sub Inject(ByVal obj As Object, ByVal method As String, ByVal callT As String) 46 | 47 | Set pObj = obj 48 | pMethod = method 49 | pCallType = callT 50 | 51 | End Sub 52 | ' 53 | ' Applicable 54 | ' ----------- 55 | ' 56 | Public Function ApplyOnArray(ByRef args() As Variant) As Variant 57 | 58 | Assign ApplyOnArray, defApply.CallByNameOnArray(pObj, pMethod, pCallType, args) 59 | 60 | End Function 61 | ' 62 | ' ### Embedded 63 | ' 64 | Private Function Applicable_ApplyOnArray(ByRef args() As Variant) As Variant 65 | 66 | Assign Applicable_ApplyOnArray, ApplyOnArray(args) 67 | 68 | End Function 69 | '! default member 70 | Public Function Apply(ParamArray args() As Variant) As Variant 71 | Attribute Apply.VB_UserMemId = 0 72 | 73 | Assign Apply, ApplyOnArray(cast.CArray(args)) 74 | 75 | End Function 76 | Private Function Applicable_Apply(ParamArray args() As Variant) As Variant 77 | 78 | Assign Applicable_Apply, ApplyOnArray(CArray(args)) 79 | 80 | End Function 81 | Public Function Compose(ByVal f As Applicable) As Applicable 82 | 83 | Set Compose = defApply.Compose(Me, f) 84 | 85 | End Function 86 | Private Function Applicable_Compose(ByVal f As Applicable) As Applicable 87 | 88 | Set Applicable_Compose = Compose(f) 89 | 90 | End Function 91 | Public Function AndThen(ByVal g As Applicable) As Applicable 92 | 93 | Set AndThen = defApply.AndThen(Me, g) 94 | 95 | End Function 96 | Private Function Applicable_AndThen(ByVal g As Applicable) As Applicable 97 | 98 | Set Applicable_AndThen = AndThen(g) 99 | 100 | End Function 101 | Public Function Partial(ParamArray args() As Variant) As Applicable 102 | 103 | Set Partial = AsPartial(CArray(args)) 104 | 105 | End Function 106 | Private Function Applicable_Partial(ParamArray args() As Variant) As Applicable 107 | 108 | Set Applicable_Partial = AsPartial(CArray(args)) 109 | 110 | End Function 111 | Public Function AsPartial(ByRef args() As Variant) As Applicable 112 | 113 | Set AsPartial = defApply.AsPartial(Me, args) 114 | 115 | End Function 116 | Private Function Applicable_AsPartial(ByRef args() As Variant) As Applicable 117 | 118 | Set Applicable_AsPartial = AsPartial(args) 119 | 120 | End Function 121 | Public Function delay(ParamArray args() As Variant) As Delayed 122 | 123 | Set delay = AsDelay(CArray(args)) 124 | 125 | End Function 126 | Private Function Applicable_Delay(ParamArray args() As Variant) As Delayed 127 | 128 | Set Applicable_Delay = AsDelay(CArray(args)) 129 | 130 | End Function 131 | Public Function AsDelay(ByRef args() As Variant) As Delayed 132 | 133 | Set AsDelay = defApply.AsDelay(Me, args) 134 | 135 | End Function 136 | Private Function Applicable_AsDelay(ByRef args() As Variant) As Delayed 137 | 138 | Set Applicable_AsDelay = AsDelay(args) 139 | 140 | End Function 141 | ' 142 | ' Showable 143 | ' --------- 144 | ' 145 | Public Function Show() As String 146 | 147 | Dim sObj As String 148 | sObj = defShow.Show(pObj) 149 | 150 | Dim repr As String 151 | repr = sObj & "." & pMethod 152 | 153 | Show = defShow.ParamShowableObject(Me, repr) 154 | 155 | End Function 156 | Private Function Showable_Show() As String 157 | 158 | Showable_Show = Show 159 | 160 | End Function 161 | 162 | 163 | -------------------------------------------------------------------------------- /src/OnObject.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "OnObject" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = True 9 | Attribute VB_Exposed = True 10 | ' 11 | ' OnObject 12 | ' ======== 13 | ' 14 | ' Copywrite (C) 2014 Philip Wales 15 | ' This file (OnObject.cls) is distributed under the GPL-3.0 license 16 | ' Obtain a copy of the GPL-3.0 license 17 | ' 18 | ' _.method(args) 19 | ' 20 | Option Explicit 21 | Implements Applicable 22 | Implements Showable 23 | ' 24 | ' Private Members 25 | ' --------------- 26 | ' 27 | Private pMethod As String 28 | Private pCallType As VbCallType 29 | Private pArgs() As Variant 30 | ' 31 | ' Constructors 32 | ' ------------ 33 | ' 34 | Public Function Create(ByVal method As String, ByVal callT As VbCallType, _ 35 | ParamArray args() As Variant) As OnObject 36 | 37 | Set Create = Make(method, callT, CArray(args)) 38 | 39 | End Function 40 | Public Function Make(ByVal method As String, ByVal callT As VbCallType, _ 41 | ByRef args() As Variant) As OnObject 42 | 43 | Dim result As New OnObject 44 | result.Inject method, callT, args 45 | Set Make = result 46 | 47 | End Function 48 | ' 49 | ' ### Friend Methods 50 | ' 51 | Friend Sub Inject(ByVal method As String, ByVal callT As String, _ 52 | ByRef args() As Variant) 53 | 54 | pMethod = method 55 | pCallType = callT 56 | pArgs = args 57 | 58 | End Sub 59 | ' 60 | ' Errors 61 | ' ------ 62 | ' 63 | Private Sub InvalidArguementsError(ByRef params() As Variant) 64 | 65 | Dim failArray As String 66 | failArray = defShow.Show(params) 67 | 68 | Dim msg As String 69 | msg = "Invalid Arguements, Expecting one object " & failArray 70 | 71 | Exceptions.ValueError Me, "Applicable_ApplyOnArray", msg 72 | 73 | End Sub 74 | ' 75 | ' Applicable 76 | ' ----------- 77 | ' 78 | Public Function ApplyOnArray(ByRef params() As Variant) As Variant 79 | 80 | Dim Callee As Object 81 | If UBound(params) = LBound(params) Then 82 | Set Callee = params(UBound(params)) 83 | Else 84 | InvalidArguementsError params 85 | End If 86 | 87 | Assign ApplyOnArray, defApply.CallByNameOnArray(Callee, pMethod, pCallType, pArgs) 88 | 89 | End Function 90 | ' 91 | ' ### Embedded 92 | ' 93 | Private Function Applicable_ApplyOnArray(ByRef args() As Variant) As Variant 94 | 95 | Assign Applicable_ApplyOnArray, ApplyOnArray(args) 96 | 97 | End Function 98 | '! default member 99 | Public Function Apply(ParamArray args() As Variant) As Variant 100 | Attribute Apply.VB_UserMemId = 0 101 | 102 | Assign Apply, ApplyOnArray(cast.CArray(args)) 103 | 104 | End Function 105 | Private Function Applicable_Apply(ParamArray args() As Variant) As Variant 106 | 107 | Assign Applicable_Apply, ApplyOnArray(CArray(args)) 108 | 109 | End Function 110 | Public Function Compose(ByVal f As Applicable) As Applicable 111 | 112 | Set Compose = defApply.Compose(Me, f) 113 | 114 | End Function 115 | Private Function Applicable_Compose(ByVal f As Applicable) As Applicable 116 | 117 | Set Applicable_Compose = Compose(f) 118 | 119 | End Function 120 | Public Function AndThen(ByVal g As Applicable) As Applicable 121 | 122 | Set AndThen = defApply.AndThen(Me, g) 123 | 124 | End Function 125 | Private Function Applicable_AndThen(ByVal g As Applicable) As Applicable 126 | 127 | Set Applicable_AndThen = AndThen(g) 128 | 129 | End Function 130 | Public Function Partial(ParamArray args() As Variant) As Applicable 131 | 132 | Set Partial = AsPartial(CArray(args)) 133 | 134 | End Function 135 | Private Function Applicable_Partial(ParamArray args() As Variant) As Applicable 136 | 137 | Set Applicable_Partial = AsPartial(CArray(args)) 138 | 139 | End Function 140 | Public Function AsPartial(ByRef args() As Variant) As Applicable 141 | 142 | Set AsPartial = defApply.AsPartial(Me, args) 143 | 144 | End Function 145 | Private Function Applicable_AsPartial(ByRef args() As Variant) As Applicable 146 | 147 | Set Applicable_AsPartial = AsPartial(args) 148 | 149 | End Function 150 | Public Function delay(ParamArray args() As Variant) As Delayed 151 | 152 | Set delay = AsDelay(CArray(args)) 153 | 154 | End Function 155 | Private Function Applicable_Delay(ParamArray args() As Variant) As Delayed 156 | 157 | Set Applicable_Delay = AsDelay(CArray(args)) 158 | 159 | End Function 160 | Public Function AsDelay(ByRef args() As Variant) As Delayed 161 | 162 | Set AsDelay = defApply.AsDelay(Me, args) 163 | 164 | End Function 165 | Private Function Applicable_AsDelay(ByRef args() As Variant) As Delayed 166 | 167 | Set Applicable_AsDelay = AsDelay(args) 168 | 169 | End Function 170 | ' 171 | ' Showable 172 | ' --------- 173 | ' 174 | Public Function Show() As String 175 | 176 | Dim sArgs As String 177 | sArgs = defShow.Show(pArgs) 178 | 179 | Dim repr As String 180 | repr = "." & pMethod & "(" & sArgs & ")" 181 | 182 | Show = defShow.ParamShowableObject(Me, repr) 183 | 184 | End Function 185 | Private Function Showable_Show() As String 186 | 187 | Showable_Show = Show 188 | 189 | End Function 190 | -------------------------------------------------------------------------------- /src/Output.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "Output" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = True 10 | Option Explicit 11 | 12 | ' print with no new line 13 | Public Sub Prints(ByVal x As Variant) 14 | 15 | End Sub 16 | ' print and end with new line 17 | Public Sub PrintLine(ByVal x As Variant) 18 | 19 | End Sub 20 | Public Sub PrintLines(ByRef xs() As Variant) 21 | 22 | End Sub 23 | 24 | 25 | 26 | -------------------------------------------------------------------------------- /src/Partial.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "Partial" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = True 9 | Attribute VB_Exposed = True 10 | ' 11 | ' Partial 12 | ' ======= 13 | ' 14 | ' Applicable with some args preset 15 | ' 16 | Option Explicit 17 | Implements Showable 18 | Implements Applicable 19 | ' 20 | ' Constants 21 | ' --------- 22 | ' 23 | ' 24 | ' Private Members 25 | ' --------------- 26 | ' 27 | Private pApplicable As Applicable 28 | Private pStoredArgs() As Variant 29 | Private pArgLower As Long 30 | Private pArgUpper As Long 31 | ' 32 | ' Constructors 33 | ' ------------ 34 | ' 35 | Public Function Make(ByVal app As Applicable, ByRef storedArgs()) As Partial 36 | 37 | Dim result As New Partial 38 | result.Inject app, storedArgs 39 | Set Make = result 40 | 41 | End Function 42 | Public Function Create(ByVal app As Applicable, ParamArray storedArgs()) 43 | 44 | Set Create = Make(app, CArray(storedArgs)) 45 | 46 | End Function 47 | ' 48 | ' Friend Methods 49 | ' -------------- 50 | ' 51 | Friend Sub Inject(ByVal app As Applicable, ByRef args()) 52 | 53 | Set pApplicable = app 54 | pStoredArgs = args 55 | pArgLower = LBound(pStoredArgs) 56 | pArgUpper = UBound(pStoredArgs) 57 | 58 | End Sub 59 | ' 60 | ' Applicable 61 | ' ----------- 62 | ' 63 | Public Function Apply(ParamArray args()) As Variant 64 | Attribute Apply.VB_UserMemId = 0 65 | On Error GoTo SimpleBubble 66 | 67 | Assign Apply, ApplyOnArray(CArray(args)) 68 | 69 | Exit Function 70 | SimpleBubble: 71 | Exceptions.BubbleError Me, "Apply", Err 72 | 73 | End Function 74 | Public Function ApplyOnArray(ByRef args()) As Variant 75 | 76 | On Error GoTo ErrHandler 77 | 78 | Dim sentArgs() As Variant 79 | ReDim sentArgs(pArgLower To pArgUpper) 80 | 81 | Dim passedArgsLower As Long 82 | passedArgsLower = LBound(args) 83 | 84 | Dim passedArgsUpper As Long 85 | passedArgsUpper = UBound(args) 86 | 87 | ' Weave args into pStoredArgs as sentArgs 88 | Dim a As Long 89 | a = passedArgsLower 90 | 91 | Dim s As Long 92 | For s = pArgLower To pArgUpper 93 | 94 | If IsEmpty(pStoredArgs(s)) Then 95 | Assign sentArgs(s), args(a) 96 | a = a + 1 97 | Else 98 | Assign sentArgs(s), pStoredArgs(s) 99 | End If 100 | 101 | Next 102 | 103 | If a < passedArgsUpper Then 104 | On Error GoTo 0 105 | Exceptions.IllegalArgument Me, "ApplyOnArray", _ 106 | "Called with too many arguments" 107 | On Error GoTo ErrHandler 108 | End If 109 | 110 | Assign ApplyOnArray, pApplicable.ApplyOnArray(sentArgs) 111 | 112 | Exit Function 113 | ErrHandler: 114 | Select Case Err.Number 115 | Case vbErrorNums.INDEX_ERROR 116 | Exceptions.IndexError Me, "ApplyOnArray", _ 117 | "Not called with enough arguments." 118 | Case Else 119 | Exceptions.BubbleError Me, "ApplyOnArray", Err 120 | End Select 121 | 122 | End Function 123 | Private Function Applicable_Apply(ParamArray args()) As Variant 124 | 125 | Assign Applicable_Apply, ApplyOnArray(CArray(args)) 126 | 127 | End Function 128 | Private Function Applicable_ApplyOnArray(ByRef args()) As Variant 129 | 130 | Assign Applicable_ApplyOnArray, ApplyOnArray(args) 131 | 132 | End Function 133 | Public Function Compose(ByVal f As Applicable) As Applicable 134 | 135 | Set Compose = defApply.Compose(Me, f) 136 | 137 | End Function 138 | Private Function Applicable_Compose(ByVal f As Applicable) As Applicable 139 | 140 | Set Applicable_Compose = Compose(f) 141 | 142 | End Function 143 | Public Function AndThen(ByVal g As Applicable) As Applicable 144 | 145 | Set AndThen = defApply.AndThen(Me, g) 146 | 147 | End Function 148 | Private Function Applicable_AndThen(ByVal g As Applicable) As Applicable 149 | 150 | Set Applicable_AndThen = AndThen(g) 151 | 152 | End Function 153 | Public Function Partial(ParamArray args() As Variant) As Applicable 154 | 155 | Set Partial = AsPartial(CArray(args)) 156 | 157 | End Function 158 | Private Function Applicable_Partial(ParamArray args() As Variant) As Applicable 159 | 160 | Set Applicable_Partial = AsPartial(CArray(args)) 161 | 162 | End Function 163 | Public Function AsPartial(ByRef args() As Variant) As Applicable 164 | 165 | Set AsPartial = defApply.AsPartial(Me, args) 166 | 167 | End Function 168 | Private Function Applicable_AsPartial(ByRef args() As Variant) As Applicable 169 | 170 | Set Applicable_AsPartial = AsPartial(args) 171 | 172 | End Function 173 | Public Function delay(ParamArray args() As Variant) As Delayed 174 | 175 | Set delay = AsDelay(CArray(args)) 176 | 177 | End Function 178 | Private Function Applicable_Delay(ParamArray args() As Variant) As Delayed 179 | 180 | Set Applicable_Delay = AsDelay(CArray(args)) 181 | 182 | End Function 183 | Public Function AsDelay(ByRef args() As Variant) As Delayed 184 | 185 | Set AsDelay = defApply.AsDelay(Me, args) 186 | 187 | End Function 188 | Private Function Applicable_AsDelay(ByRef args() As Variant) As Delayed 189 | 190 | Set Applicable_AsDelay = AsDelay(args) 191 | 192 | End Function 193 | ' 194 | ' Showable 195 | ' --------- 196 | ' 197 | Public Function Show() As String 198 | 199 | Show = defShow.ParamShowableObject(Me, pApplicable, pStoredArgs) 200 | 201 | End Function 202 | Private Function Showable_Show() As String 203 | 204 | Showable_Show = Show 205 | 206 | End Function 207 | 208 | -------------------------------------------------------------------------------- /src/SetLike.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "SetLike" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = True 10 | Option Explicit 11 | 12 | Public Function Contains(ByVal sought) As Boolean 13 | Attribute Contains.VB_UserMemId = 0 14 | 15 | End Function 16 | Public Property Get Elements() As IUnknown 17 | Attribute Elements.VB_UserMemId = -4 18 | 19 | End Property 20 | Public Function Count() As Long 21 | 22 | End Function 23 | Public Function IsDisJoint(ByVal other As SetLike) As Boolean 24 | 25 | End Function 26 | Public Function IsSubSetOf(ByVal other As SetLike) As Boolean 27 | 28 | End Function 29 | Public Function IsProperSubSetOf(ByVal other As SetLike) As Boolean 30 | 31 | End Function 32 | Public Function IsSuperSetOf(ByVal other As SetLike) As Boolean 33 | 34 | End Function 35 | Public Function IsProperSuperSetOf(ByVal other As SetLike) As Boolean 36 | 37 | End Function 38 | Public Function Union(ByVal other As SetLike) As SetLike 39 | 40 | End Function 41 | Public Function Intersect(ByVal other As SetLike) As SetLike 42 | 43 | End Function 44 | Public Function Difference(ByVal other As SetLike) As SetLike 45 | 46 | End Function 47 | Public Function SymmetricDifference(ByVal other As SetLike) As SetLike 48 | 49 | End Function 50 | -------------------------------------------------------------------------------- /src/Showable.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "Showable" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = True 10 | Option Explicit 11 | 12 | Public Function Show() As String 13 | End Function 14 | -------------------------------------------------------------------------------- /src/SqlCommand.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "SqlCommand" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = True 9 | Attribute VB_Exposed = True 10 | Option Explicit 11 | ' 12 | ' SqlCommand 13 | ' ========== 14 | 15 | ' Copywrite (C) 2014 Philip Wales 16 | ' This file (SqlCommand.cls) is distributed under the GPL-3.0 license 17 | ' Obtain a copy of the GPL-3.0 license 18 | ' 19 | ' Wrapper for `ADODB.Command`. It is only created by a SqlConnection. I don't 20 | ' know if it does anything more useful than `ADODB.Command` other than return 21 | ' an SqlResult, which will be more interesting. 22 | ' 23 | Implements Applicable 24 | Implements Showable 25 | ' 26 | ' Private Members 27 | ' --------------- 28 | Private pCommand As ADODB.Command 29 | ' 30 | ' Constructor 31 | ' ----------- 32 | Public Function Make(ByVal adoCommand As ADODB.Command) As SqlCommand 33 | 34 | Dim result As New SqlCommand 35 | Set result.Command = adoCommand 36 | Set Make = result 37 | 38 | End Function 39 | Friend Property Set Command(ByVal adoCommand As ADODB.Command) 40 | 41 | Set pCommand = adoCommand 42 | 43 | End Property 44 | ' 45 | ' Interfaces 46 | ' ---------- 47 | ' 48 | ' ### Applicable 49 | ' 50 | ' SQLCommands can return two values: a RecordSet if the command is a query ( 51 | ' which is only a SELECT command) or the number of rows affected if the command 52 | ' is an update command (which is an INSERT, UPDATE, or DELETE command.) 53 | ' 54 | Public Function ADOExecuteQueryOnArray(ByRef args() As Variant) As ADODB.RecordSet 55 | 56 | ResetArgs args 57 | Set ADOExecuteQueryOnArray = pCommand.Execute() 58 | 59 | End Function 60 | Public Function ADOExecuteQuery(ParamArray args() As Variant) As ADODB.RecordSet 61 | 62 | Set ADOExecuteQuery = ADOExecuteQueryOnArray(CArray(args)) 63 | 64 | End Function 65 | Public Function ExecuteQuery(ParamArray args() As Variant) As SqlResult 66 | 67 | Set ExecuteQuery = ExecuteQueryOnArray(CArray(args)) 68 | 69 | End Function 70 | Public Function ExecuteQueryOnArray(ByRef args() As Variant) As SqlResult 71 | 72 | Set ExecuteQueryOnArray = SqlResult.Make(ADOExecuteQueryOnArray(args)) 73 | 74 | End Function 75 | Public Function ExecuteUpdate(ParamArray args() As Variant) As Long 76 | 77 | ExecuteUpdate = ExecuteUpdateOnArray(CArray(args)) 78 | 79 | End Function 80 | Public Function ExecuteUpdateOnArray(ByRef args() As Variant) As Long 81 | 82 | ResetArgs args 83 | 84 | Dim checkRows As Long 85 | pCommand.Execute checkRows 86 | 87 | ExecuteUpdateOnArray = checkRows 88 | 89 | End Function 90 | Private Sub ResetArgs(ByRef args() As Variant) 91 | 92 | pCommand.Parameters.Refresh ' clear parameters 93 | 94 | Dim arg 95 | For Each arg In args 96 | 97 | Dim adoType As ADODB.DataTypeEnum 98 | adoType = GetADOTypeOf(arg) 99 | 100 | Dim parm As ADODB.Parameter 101 | Set parm = pCommand.CreateParameter(Type:=adoType, Value:=arg) 102 | pCommand.Parameters.Append parm 103 | 104 | Next 105 | 106 | End Sub 107 | '' 108 | ' I was using `adVariant` for everything becuase it was the simplest solution 109 | ' and it worked until I used a boolean as an arg and it broke. So maybe I 110 | ' should add more types cases. 111 | Private Function GetADOTypeOf(ByVal arg As Variant) As ADODB.DataTypeEnum 112 | 113 | Dim result As ADODB.DataTypeEnum 114 | Select Case TypeName(arg) 115 | Case "Boolean" 116 | result = adBoolean 117 | Case Else 118 | result = adVariant 119 | End Select 120 | 121 | GetADOTypeOf = result 122 | 123 | End Function 124 | ' 125 | ' On problem with this section is that SqlCommand is Applicable which means 126 | ' they implement the `Apply` method, but they have two candidates for what the 127 | ' `Apply` method should call: `ExecuteQuery` and `ExecuteUpdate`. Currently, 128 | ' it defaults to `ExecuteQuery`, but I would like it to smartly decide what 129 | ' type of command the SqlCommand is. Determining the type of a plain text 130 | ' command is simple enough with just string operations but with stored procs 131 | ' I am at a lost. 132 | ' 133 | ' Perhaps split this class into SqlQuery and SqlUpdate and let the user decide. 134 | ' Two reasons why I haven't split the class: 135 | ' 136 | ' 1. I have never seen another library split the command classes on result 137 | ' type. 138 | ' - Java splits the command Interfaces on custom text (PreparedStatement) and 139 | ' stored procs (CallableStatement) 140 | ' 2. Both would implement an ISqlCommand interface and would need a default 141 | ' implementation module. So now what was 1 file is now 4. 142 | ' 143 | Private Function Applicable_Apply(ParamArray args() As Variant) As Variant 144 | 145 | Set Applicable_Apply = ExecuteQueryOnArray(CArray(args)) 146 | 147 | End Function 148 | Private Function Applicable_ApplyOnArray(ByRef args() As Variant) As Variant 149 | 150 | Set Applicable_ApplyOnArray = ExecuteQueryOnArray(CArray(args)) 151 | 152 | End Function 153 | ' 154 | ' ### Embeded 155 | ' 156 | Public Function Compose(ByVal f As Applicable) As Applicable 157 | 158 | Set Compose = defApply.Compose(Me, f) 159 | 160 | End Function 161 | Private Function Applicable_Compose(ByVal f As Applicable) As Applicable 162 | 163 | Set Applicable_Compose = Compose(f) 164 | 165 | End Function 166 | Public Function AndThen(ByVal g As Applicable) As Applicable 167 | 168 | Set AndThen = defApply.AndThen(Me, g) 169 | 170 | End Function 171 | Private Function Applicable_AndThen(ByVal g As Applicable) As Applicable 172 | 173 | Set Applicable_AndThen = AndThen(g) 174 | 175 | End Function 176 | Public Function Partial(ParamArray args() As Variant) As Applicable 177 | 178 | Set Partial = AsPartial(CArray(args)) 179 | 180 | End Function 181 | Private Function Applicable_Partial(ParamArray args() As Variant) As Applicable 182 | 183 | Set Applicable_Partial = AsPartial(CArray(args)) 184 | 185 | End Function 186 | Public Function AsPartial(ByRef args() As Variant) As Applicable 187 | 188 | Set AsPartial = defApply.AsPartial(Me, args) 189 | 190 | End Function 191 | Private Function Applicable_AsPartial(ByRef args() As Variant) As Applicable 192 | 193 | Set Applicable_AsPartial = AsPartial(args) 194 | 195 | End Function 196 | Public Function delay(ParamArray args() As Variant) As Delayed 197 | 198 | Set delay = AsDelay(CArray(args)) 199 | 200 | End Function 201 | Private Function Applicable_Delay(ParamArray args() As Variant) As Delayed 202 | 203 | Set Applicable_Delay = AsDelay(CArray(args)) 204 | 205 | End Function 206 | Public Function AsDelay(ByRef args() As Variant) As Delayed 207 | 208 | Set AsDelay = defApply.AsDelay(Me, args) 209 | 210 | End Function 211 | Private Function Applicable_AsDelay(ByRef args() As Variant) As Delayed 212 | 213 | Set Applicable_AsDelay = AsDelay(args) 214 | 215 | End Function 216 | ' 217 | ' ### Showable 218 | ' 219 | Public Function Show() As String 220 | 221 | Show = defShow.ParamShowableObject(Me, pCommand.CommandText) 222 | 223 | End Function 224 | Private Function Showable_Show() As String 225 | 226 | Showable_Show = Show 227 | 228 | End Function 229 | -------------------------------------------------------------------------------- /src/SqlConnection.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "SqlConnection" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = True 9 | Attribute VB_Exposed = True 10 | Option Explicit 11 | ' 12 | ' SqlConnection 13 | ' ============= 14 | ' 15 | ' Establishes an ADODB connection to a source and provides a rich interface to 16 | ' that source. 17 | ' 18 | Implements Showable 19 | ' 20 | ' Private Member 21 | ' -------------- 22 | ' 23 | Private pConnection As ADODB.Connection 24 | ' 25 | ' Error Values 26 | ' ------------ 27 | ' 28 | Public Enum SqlConnectionErrors 29 | NO_RECORDS = 770 30 | TOO_MANY_RECORDS 31 | TOO_MANY_FIELDS 32 | End Enum 33 | ' 34 | ' Constructor 35 | ' ----------- 36 | ' 37 | ' ### Constructors 38 | ' 39 | Public Function Make(ByVal connectString As String) As SqlConnection 40 | 41 | Dim result As New SqlConnection 42 | result.OpenConnection connectString 43 | Set Make = result 44 | 45 | End Function 46 | Public Function ToAccess(ByVal filePath As String) As SqlConnection 47 | 48 | Dim connectString As String 49 | connectString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _ 50 | "Data Source=" & filePath & ";" & _ 51 | "Jet OLEDB:Engine Type=5;" & _ 52 | "Persist Security Info=False;" 53 | 54 | Set ToAccess = Make(connectString) 55 | 56 | End Function 57 | Public Function ToExcel(ByVal filePath As String) As SqlConnection 58 | 59 | Dim connectString As String 60 | connectString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _ 61 | "Data Source=" & filePath & ";" & _ 62 | "Extended Properties=Excel 8.0;" 63 | 64 | Set ToExcel = Make(connectString) 65 | 66 | End Function 67 | Public Function ToMySql(ByVal server As String, ByVal db As String, _ 68 | ByVal username As String, ByVal passwd As String, _ 69 | ByVal vers As String) As SqlConnection 70 | 71 | Dim connectTemplate As String 72 | connectTemplate = "DRIVER={MySQL ODBC {4} Driver}; SERVER={0}; DATABASE={1}; UID={2};PASSWORD={3}; OPTION=3" 73 | 74 | Dim connect As String 75 | connect = Str.Format(connectTemplate, server, db, username, passwd, vers) 76 | 77 | Set ToMySql = Make(connect) 78 | 79 | End Function 80 | ' 81 | ' ### Class Events 82 | ' 83 | Private Sub Class_Initialize() 84 | 85 | Set pConnection = New ADODB.Connection 86 | 87 | End Sub 88 | Private Sub Class_Terminate() 89 | 90 | If pConnection.State Then pConnection.Close 91 | 92 | End Sub 93 | ' 94 | ' ### Friend Properties 95 | ' 96 | Friend Sub OpenConnection(ByVal connectStr As String) 97 | 98 | pConnection.Open connectStr 99 | 100 | End Sub 101 | Friend Property Get DbConnection() As ADODB.Connection 102 | 103 | Set DbConnection = pConnection 104 | 105 | End Property 106 | ' 107 | ' Interfaces 108 | ' ---------- 109 | ' 110 | ' ### Showable 111 | ' 112 | Private Function Showable_Show() As String 113 | 114 | Showable_Show = defShow.ParamShowableObject(Me, pConnection.ConnectionString) 115 | 116 | End Function 117 | ' 118 | '####################################################################################### 119 | ' 120 | ' Returning SQLCommands 121 | ' 122 | ' Custom SQL 123 | Public Function MakeCommand(ByVal sql As String) As SqlCommand 124 | 125 | Set MakeCommand = SqlCommand.Make(MakeAdoCommand(sql)) 126 | 127 | End Function 128 | Public Function MakeAdoCommand(ByVal sql As String) As ADODB.Command 129 | 130 | Dim result As New ADODB.Command 131 | result.ActiveConnection = DbConnection 132 | result.CommandText = sql 133 | Set MakeAdoCommand = result 134 | 135 | End Function 136 | ' Stored SQL 137 | Public Function GetCommand(ByVal sqlName As String) As SqlCommand 138 | 139 | Set GetCommand = SqlCommand.Make(GetAdoCommand(sqlName)) 140 | 141 | End Function 142 | Public Function GetAdoCommand(ByVal sqlName As String) As ADODB.Command 143 | 144 | Dim result As ADODB.Command 145 | Set result = MakeAdoCommand(sqlName) 146 | result.CommandType = adCmdStoredProc 147 | Set GetAdoCommand = result 148 | 149 | End Function 150 | ' 151 | ' ### Append safely 152 | ' 153 | Public Function SafeAdd(ByVal getArgs As Dict, ByVal getQuerysName As String, _ 154 | ByVal addArgs As Dict, ByVal addQuerysName As String) As Long 155 | 156 | Dim finder As SqlCommand 157 | Set finder = GetCommand(getQuerysName) 158 | 159 | Dim autoId As Maybe 160 | Set autoId = finder.ExecuteQueryOnArray(getArgs.Values.ToArray).SingleResult 161 | 162 | If autoId.IsNone Then 163 | 164 | Dim checkRow As Long 165 | checkRow = GetCommand(addQuerysName).ExecuteUpdateOnArray(addArgs.Values.ToArray) 166 | Debug.Assert checkRow = 1 167 | Set autoId = finder.ExecuteQueryOnArray(getArgs.Values.ToArray).SingleResult 168 | 169 | End If 170 | 171 | On Error GoTo ErrHandler 172 | SafeAdd = autoId 173 | 174 | Exit Function 175 | ErrHandler: 176 | Dim showArgs As Dict 177 | Set showArgs = Dict.Create( _ 178 | Assoc.Make("getArgs", getArgs), _ 179 | Assoc.Make("getQuerysName", getQuerysName), _ 180 | Assoc.Make("addArgs", addArgs), _ 181 | Assoc.Make("addQuerysName", addQuerysName) _ 182 | ) 183 | 184 | Exceptions.ValueError Me, "SafeAdd", "Failed to get autoId with " & showArgs.Show 185 | 186 | End Function 187 | Public Function SimpleSafeAdd(ByVal arg As Assoc, ByVal getQuerysName As String, _ 188 | ByVal addQuerysName As String) As Long 189 | 190 | Dim unifiedArgs As Dict 191 | Set unifiedArgs = Dict.Create(arg) 192 | 193 | SimpleSafeAdd = SafeAdd(unifiedArgs, getQuerysName, unifiedArgs, addQuerysName) 194 | 195 | End Function 196 | 197 | -------------------------------------------------------------------------------- /src/SqlResult.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "SqlResult" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = True 9 | Attribute VB_Exposed = True 10 | Option Explicit 11 | ' 12 | ' SqlResult 13 | ' --------- 14 | ' 15 | Implements Showable 16 | Implements Linear 17 | 18 | Private pRecords As Maybe ' Maybe(Rows) 19 | Private pFieldNames As List ' [Fields] 20 | ' 21 | ' Constructors 22 | ' ------------ 23 | ' 24 | Public Function Make(ByVal rs As ADODB.RecordSet) As SqlResult 25 | 26 | Dim result As New SqlResult 27 | Set result.RecordSet = rs 28 | Set Make = result 29 | 30 | End Function 31 | Friend Property Set RecordSet(ByVal rs As ADODB.RecordSet) 32 | 33 | Set pFieldNames = TransversableMap(List, OnObject.Create("Name", VbGet), rs.Fields) 34 | 35 | If Not rs.EOF Then 36 | Set pRecords = Maybe.Some(rs.GetRows) 37 | Else 38 | Set pRecords = Maybe.None 39 | End If 40 | 41 | End Property 42 | Public Property Get Records() As Maybe 43 | 44 | Set Records = pRecords 45 | 46 | End Property 47 | Public Property Get FieldNames() As List 48 | 49 | Set FieldNames = pFieldNames 50 | 51 | End Property 52 | ' 53 | ' Result Handling 54 | ' --------------- 55 | ' 56 | ' ### Single Value 57 | ' 58 | Public Function SingleResult() As Maybe 59 | 60 | ' Could use (x) => x(0,0) 61 | ' but less lambdas the better 62 | Dim result As Maybe 63 | If pRecords.IsSome Then 64 | Set result = Maybe.Some(pRecords.GetItem(0, 0)) 65 | Else 66 | Set result = Maybe.None 67 | End If 68 | 69 | Set SingleResult = result 70 | 71 | End Function 72 | ' 73 | ' ### Lists 74 | ' 75 | Public Function GetColumn(ByVal colIndex As Long) As Variant() 76 | 77 | GetColumn = Application.index(pRecords, colIndex + 1, 0) 78 | 79 | End Function 80 | Public Function GetRow(ByVal rowIndex As Long) As Variant() 81 | 82 | GetRow = Application.index(pRecords, 0, rowIndex + 1) 83 | 84 | End Function 85 | ' 86 | ' ### Dicts 87 | ' 88 | '' 89 | ' [ [$1], [$2] ] => { $1 -> $2 } 90 | Public Function HDict() As Dict 91 | 92 | ' Check for only 2 fields 93 | Dim recs() As Variant 94 | recs = pRecords.GetItem 95 | 96 | If UBound(recs, 1) > 1 Then 97 | Err.Raise TOO_MANY_FIELDS, _ 98 | description:=TypeName(Me) & ".HDict: Query returned more than 2 fields." 99 | End If 100 | 101 | Dim Keys As List 102 | Set Keys = List.Copy(GetColumn(0)) 103 | 104 | Dim vals As List 105 | Set vals = List.Copy(GetColumn(1)) 106 | 107 | Dim result As Dict 108 | Set result = Dict.FromLists(Keys, vals) 109 | 110 | Set HDict = result 111 | 112 | End Function 113 | '' 114 | ' () => { HEADER -> [ column ] } 115 | Public Function VDict() As Dict 116 | 117 | Dim result As Dict 118 | Set result = Dict.Create 119 | 120 | Dim col As Integer 121 | For col = 1 To pFieldNames.Count 122 | result.Add pFieldNames(col), GetColumn(col - 1) 123 | Next 124 | 125 | Set VDict = result 126 | 127 | End Function 128 | '' 129 | ' rowIndex => { HEADER -> value } 130 | Public Function DictAt(ByVal rowIndex As Long) As Dict 131 | 132 | Set DictAt = Dict.FromLists(pFieldNames, List.Copy(GetRow(rowIndex))) 133 | 134 | End Function 135 | '' 136 | ' () => [ { HEADER -> value } ] 137 | Public Function AllDicts() As List 138 | 139 | ' TODO: Use a convert to instead of map with identity. 140 | Set AllDicts = ToBuildable(List) 141 | 142 | End Function 143 | ' 144 | ' Interfaces 145 | ' ---------- 146 | ' 147 | ' ### Showable 148 | ' 149 | Public Function Show() As String 150 | 151 | Show = defShow.ParamShowableObject(Me, pFieldNames, pRecords) 152 | 153 | End Function 154 | Private Function Showable_Show() As String 155 | 156 | Showable_Show = Show 157 | 158 | End Function 159 | ' 160 | ' ### Linear 161 | ' 162 | Private Function Linear_Item(ByVal index As Long) As Variant 163 | 164 | Set Linear_Item = DictAt(index) 165 | 166 | End Function 167 | Public Function LowerBound() As Long 168 | 169 | LowerBound = 0 170 | 171 | End Function 172 | Private Function Linear_LowerBound() As Long 173 | 174 | Linear_LowerBound = LowerBound 175 | 176 | End Function 177 | Public Function UpperBound() As Maybe 178 | 179 | Set UpperBound = pRecords.Map(Lambda.FromShort("UBound( _, 2 )")) 180 | 181 | End Function 182 | Private Function Linear_UpperBound() As Long 183 | 184 | Linear_UpperBound = UpperBound.GetOrElse(-1) 185 | 186 | End Function 187 | Public Function ToArray() As Variant() 188 | 189 | ToArray = defIterable.ToArray(Me) 190 | 191 | End Function 192 | Private Function Linear_ToArray() As Variant() 193 | 194 | Linear_ToArray = ToArray 195 | 196 | End Function 197 | Public Function ToCollection() As Collection 198 | 199 | Set ToCollection = defIterable.ToCollection(Me) 200 | 201 | End Function 202 | Private Function Linear_ToCollection() As Collection 203 | 204 | Set Linear_ToCollection = ToCollection 205 | 206 | End Function 207 | Public Function ToBuildable(ByVal seed As Buildable) As Buildable 208 | 209 | Set ToBuildable = defIterable.ToBuildable(seed, Me) 210 | 211 | End Function 212 | Private Function Linear_ToBuildable(ByVal seed As Buildable) As Buildable 213 | 214 | Set Linear_ToBuildable = ToBuildable(seed) 215 | 216 | End Function 217 | -------------------------------------------------------------------------------- /src/Try.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "Try" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = True 9 | Attribute VB_Exposed = True 10 | Option Explicit 11 | ' 12 | ' Try Class 13 | ' =========== 14 | ' 15 | ' 16 | ' Copywrite (C) 2014 Philip Wales 17 | ' This file (Try.cls) is distributed under the GPL-3.0 license 18 | ' Obtain a copy of the GPL-3.0 license 19 | ' 20 | ' An object that optionally contains an item. It's use is an abstraction from 21 | ' checking if a method returned a value or not. 22 | ' 23 | ' 24 | Implements Equatable 25 | Implements Showable 26 | Implements Monadic 27 | ' 28 | ' Private Members 29 | ' --------------- 30 | ' 31 | Private pResult As Variant 32 | Private pError As ErrObject 33 | Private pSuccess As Boolean 34 | ' 35 | ' Constructor 36 | ' ----------- 37 | ' 38 | Public Function Create(ByVal op As Applicable, ParamArray args()) As Try 39 | 40 | Set Create = Make(op, CArray(args)) 41 | 42 | End Function 43 | Public Function Make(ByVal op As Applicable, ByRef args() As Variant) As Try 44 | 45 | Dim delay As ByName 46 | Set delay = ByName.Make(op, args) 47 | Set Make = FromDelayed(delay) 48 | 49 | End Function 50 | Public Function FromDelayed(ByVal delay As Delayed) As Try 51 | 52 | Dim result As Try 53 | On Error GoTo Fail 54 | Set result = Success(delay.Evaluate()) 55 | On Error GoTo 0 56 | 57 | CleanExit: 58 | Set FromDelayed = result 59 | 60 | Exit Function 61 | 62 | Fail: 63 | Set result = Failure(Err) 64 | Resume CleanExit 65 | 66 | End Function 67 | Private Function Success(ByVal x) As Try 68 | 69 | Dim result As New Try 70 | result.AssignResult x 71 | Set Success = result 72 | 73 | End Function 74 | Private Function Failure(ByVal e As ErrObject) As Try 75 | 76 | Dim result As New Try 77 | result.AssignError e 78 | Set Failure = result 79 | 80 | End Function 81 | ' 82 | ' ### Friend Methods 83 | ' 84 | Friend Sub AssignResult(ByVal x) 85 | 86 | pSuccess = True 87 | Assign pResult, x 88 | 89 | End Sub 90 | Friend Sub AssignError(ByVal e As ErrObject) 91 | 92 | pSuccess = False 93 | Set pError = e 94 | 95 | End Sub 96 | ' 97 | ' Public Methods 98 | ' -------------- 99 | ' 100 | Public Function IsSuccess() As Boolean 101 | 102 | IsSuccess = pSuccess 103 | 104 | End Function 105 | Public Function IsFailure() As Boolean 106 | 107 | IsFailure = (Not IsSuccess) 108 | 109 | End Function 110 | Public Function GetItem() As Variant 111 | Attribute GetItem.VB_UserMemId = 0 112 | 113 | If IsSuccess Then 114 | Assign GetItem, pResult 115 | Else 116 | Exceptions.BubbleError Me, "GetItem", pError 117 | End If 118 | 119 | End Function 120 | Public Function GetOrElse(ByVal default) As Variant 121 | 122 | Dim result 123 | If IsSuccess Then 124 | Assign result, pResult 125 | Else 126 | Assign result, default 127 | End If 128 | Assign GetOrElse, result 129 | 130 | End Function 131 | ' 132 | ' Recover / RecoverWith? 133 | ' 134 | ' 135 | ' Equatable 136 | ' ---------- 137 | ' 138 | Public Function Equals(ByVal x As Try) As Boolean 139 | 140 | If x.IsSuccess And IsSuccess Then 141 | Equals = (x.GetItem = pResult) 142 | Else 143 | Equals = False 144 | End If 145 | 146 | End Function 147 | Private Function Equatable_Equals(ByVal x) As Boolean 148 | 149 | Equatable_Equals = Equals(x) 150 | 151 | End Function 152 | ' 153 | ' Monadic 154 | ' -------- 155 | ' 156 | Public Function Bind(ByVal op As Applicable) As Try 157 | 158 | Dim result As Try 159 | If IsSuccess Then 160 | 161 | On Error GoTo ErrHandler 162 | Dim opResult 163 | Assign opResult, op.Apply(pResult) 164 | Set result = opResult 165 | On Error GoTo 0 166 | 167 | Else 168 | Set result = Me 169 | End If 170 | 171 | Set Bind = result 172 | Exit Function 173 | ErrHandler: 174 | Dim msg As String 175 | Select Case Err.Number 176 | Case vbErrorNums.TYPE_ERROR, vbErrorNums.OBJECT_REQUIRED 177 | msg = defShow.Show(op) & " did not return a Try object" 178 | Exceptions.TypeError Me, "Bind", msg 179 | Case Else 180 | Exceptions.BubbleError Me, "Bind", Err 181 | End Select 182 | End Function 183 | Public Function Map(ByVal op As Applicable) As Try 184 | 185 | Dim result As Try 186 | If IsSuccess Then 187 | Set result = Create(op, pResult) 188 | Else 189 | Set result = Me 190 | End If 191 | Set Map = result 192 | 193 | End Function 194 | Private Function Monadic_Bind(ByVal op As Applicable) As Monadic 195 | 196 | Set Monadic_Bind = Bind(op) 197 | 198 | End Function 199 | Private Function Monadic_Map(ByVal op As Applicable) As Monadic 200 | 201 | Set Monadic_Map = Map(op) 202 | 203 | End Function 204 | Private Function Monadic_Unit(ByVal x) As Monadic 205 | 206 | Set Monadic_Unit = FromDelayed(x) 207 | 208 | End Function 209 | 210 | ' 211 | ' Showable 212 | ' --------- 213 | ' 214 | Public Function Show() As String 215 | 216 | Dim result As String 217 | If IsSuccess Then 218 | result = ParamShowableObject(Me, pResult) 219 | Else 220 | result = ParamShowableObject(Me, pError) 221 | End If 222 | 223 | Show = result 224 | 225 | End Function 226 | Private Function Showable_Show() As String 227 | 228 | Showable_Show = Show 229 | 230 | End Function 231 | -------------------------------------------------------------------------------- /src/Tuple.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "Tuple" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = True 9 | Attribute VB_Exposed = True 10 | 11 | Option Explicit 12 | ' 13 | ' Tuple 14 | ' ===== 15 | ' 16 | ' Implementation of Tuple in VB 17 | ' 18 | Implements Showable 19 | Implements Equatable 20 | ' 21 | ' Private Members 22 | ' --------------- 23 | ' 24 | '' 25 | ' All memebers are stored in an Array 26 | ' ...simple enough 27 | Private pArray() As Variant 28 | ' 29 | ' Private Methods 30 | ' --------------- 31 | ' 32 | Private Sub Class_Initialize() 33 | 34 | pArray = Array() 35 | 36 | End Sub 37 | Private Sub CopyArray(ByRef dest(), ByRef src()) 38 | 39 | Dim lower As Long 40 | lower = LBound(src) 41 | 42 | Dim upper As Long 43 | upper = UBound(src) 44 | 45 | Dim offset As Long 46 | offset = LBound(dest) - lower 47 | 48 | Dim i As Long 49 | For i = lower To upper 50 | cast.Assign dest(i + offset), src(i) 51 | Next i 52 | 53 | End Sub 54 | Private Sub TupleSizeError(ByVal method As String, ByRef offending()) 55 | 56 | Dim msg As String 57 | msg = "Offending sequence is of size: " & ArraySize(offending) + 1 & " not " & ArraySize(pArray) + 1 58 | 59 | IndexError Me, method, msg 60 | 61 | End Sub 62 | Private Function ArraySize(ByRef a()) As Long 63 | 64 | ArraySize = UBound(a) - LBound(a) 65 | 66 | End Function 67 | ' 68 | ' Friend Methods 69 | ' -------------- 70 | ' 71 | Friend Sub Contain(ByVal vs) 72 | 73 | pArray = vs 74 | 75 | End Sub 76 | ' 77 | ' Constructors 78 | ' ------------ 79 | ' 80 | Public Function SingleValue(ByVal val) As Tuple 81 | 82 | Set SingleValue = Pack(val) 83 | 84 | End Function 85 | '' 86 | ' Pack: create a tuple from a parameter array 87 | ' 88 | ' Tuple.Pack(1, 2, "A") ' (1, 2, A) 89 | Public Function Pack(ParamArray vals()) As Tuple 90 | 91 | Set Pack = Implode(cast.CArray(vals)) 92 | 93 | End Function 94 | '' 95 | ' Implode: Transform an Iterable into a Tuple 96 | ' offsetting required for indexes 97 | ' 98 | ' Tuple.Implode(Array(1, 2, "A")) ' (1, 2, A) 99 | Public Function Implode(ByRef arr) As Tuple 100 | 101 | Dim result As New Tuple 102 | 103 | Dim a() 104 | a = cast.CArray(arr) 105 | 106 | Dim size As Long 107 | size = ArraySize(a) 108 | 109 | If Not ((IsEmpty(arr)) Or (size = -1)) Then 110 | 111 | Dim newArray() 112 | ReDim newArray(0 To size) 113 | 114 | CopyArray newArray, a 115 | result.Contain newArray 116 | 117 | Else 118 | result.Contain Array() 119 | End If 120 | 121 | Set Implode = result 122 | 123 | End Function 124 | '' 125 | ' Zip, create a list of tuples... 126 | ' TODO: use param array instead of just 2 127 | Public Function Zip(ByVal seed As Buildable, ByVal xs As Linear, _ 128 | ByVal ys As Linear) As Buildable 129 | 130 | Dim result As Buildable 131 | Set result = seed.MakeEmpty 132 | 133 | Dim lower As Long 134 | lower = srch.Max(xs.LowerBound, ys.LowerBound) 135 | 136 | Dim upper As Long 137 | upper = srch.Min(xs.UpperBound, ys.UpperBound) 138 | 139 | Dim i As Long 140 | For i = 1 To upper 141 | result.AddItem Pack(xs.Item(i), ys.Item(i)) 142 | Next i 143 | 144 | Set Zip = result 145 | 146 | End Function 147 | ' 148 | ' Public Methods 149 | ' -------------- 150 | ' 151 | Public Property Get Item(ByVal index) 152 | Attribute Item.VB_UserMemId = 0 153 | 154 | cast.Assign Item, pArray(index - 1) 155 | 156 | End Property 157 | '' 158 | ' Load elements into a parameter array of varaibles 159 | ' 160 | ' Set t = Tuple.Pack(1, 2, "A") 161 | ' t.Unpack x, y, z ' x = 1, y = 2, z = "A" 162 | ' 163 | ' In other languages this is the same as 164 | ' 165 | ' x, y, z = t 166 | ' 167 | Public Sub Unpack(ParamArray Elements()) 168 | 169 | If ArraySize(pArray) = ArraySize(cast.CArray(Elements)) Then 170 | Dim i As Long 171 | For i = 0 To ArraySize(pArray) 172 | cast.Assign Elements(i), pArray(i) 173 | Next i 174 | Else 175 | TupleSizeError "Unpack", cast.CArray(Elements) 176 | End If 177 | 178 | End Sub 179 | '' 180 | ' Explode: Load elements into array `arr` 181 | ' arr must be an array 182 | ' 183 | Public Sub Explode(ByRef Elements()) 184 | 185 | If ArraySize(pArray) = ArraySize(Elements) Then 186 | CopyArray Elements, pArray 187 | Else 188 | TupleSizeError "Explode", Elements 189 | End If 190 | 191 | End Sub 192 | Public Property Get Count() As Long 193 | 194 | Count = ArraySize(pArray) + 1 195 | 196 | End Property 197 | ' 198 | ' ### Equatable 199 | ' 200 | Public Function Equals(ByVal other) As Boolean 201 | 202 | Equals = False 203 | 204 | If TypeName(other) <> TypeName(Me) Then 205 | Exit Function 206 | ElseIf Count <> other.Count Then 207 | Exit Function 208 | End If 209 | 210 | Dim i As Long 211 | For i = 0 To UBound(pArray) 212 | If Not defEquals.Equals(pArray(i), other.Item(i + 1)) Then 213 | Exit Function 214 | End If 215 | Next i 216 | 217 | Equals = True 218 | 219 | End Function 220 | Private Function Equatable_Equals(ByVal other) As Boolean 221 | 222 | Equatable_Equals = Equals(other) 223 | 224 | End Function 225 | ' 226 | ' 227 | ' ### Showable 228 | ' 229 | Public Function Show() As String 230 | 231 | Show = defShow.ShowableObject(Me, pArray) 232 | 233 | End Function 234 | Public Function Showable_Show() As String 235 | 236 | Showable_Show = Show 237 | 238 | End Function 239 | -------------------------------------------------------------------------------- /src/Writer.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "Writer" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = True 9 | Attribute VB_Exposed = True 10 | ' 11 | ' File Writer 12 | ' =========== 13 | ' 14 | ' author: Matt's Mug 15 | ' url: http://codereview.stackexchange.com/questions/52306/file-reader-writer-text 16 | ' 17 | ' 18 | Option Explicit 19 | Implements Output 20 | 21 | ' 22 | ' Private Members 23 | ' --------------- 24 | ' 25 | Private Const ERROR_BASE As Long = &HFADE 26 | Private pFilePath As String 27 | Private pFileNumber As Long 28 | ' 29 | ' Public Memebers 30 | ' --------------- 31 | ' 32 | 'expose raised errors to clients: 33 | ' TODO: not exposed yet Public? 34 | Public Enum FileWriterError 35 | FileNotOpened = vbObjectError + ERROR_BASE + 42 36 | FileAlreadyOpened 37 | FileDoesNotExist 38 | FileAlreadyExists 39 | End Enum 40 | ' 41 | ' Constructor 42 | ' ----------- 43 | ' 44 | Public Function OpenFile(ByVal filePath As String, _ 45 | Optional ByVal overwrite As Boolean = True) As Writer 46 | 47 | Dim result As New Writer 48 | result.SetFile filePath, False, overwrite 49 | Set OpenFile = result 50 | 51 | End Function 52 | Public Function NewFile(ByVal filePath As String) As Writer 53 | 54 | Dim result As New Writer 55 | result.SetFile filePath, True, False 56 | Set NewFile = result 57 | 58 | End Function 59 | ' 60 | ' ### Friend Methods 61 | ' 62 | Friend Sub SetFile(ByVal filePath As String, ByVal Create As Boolean, _ 63 | ByVal overwrite As Boolean) 64 | 65 | On Error GoTo ErrHandler 66 | 67 | If pFileNumber <> 0 Then 68 | OnFileAlreadyOpenedError "SetFile", filePath 69 | End If 70 | 71 | Dim filePathExists As Boolean 72 | filePathExists = fsview.FileExists(filePath) 73 | 74 | If Create And filePathExists Then 75 | OnFileAlreadyExistsError "SetFile", filePath 76 | ElseIf Not (Create Or filePathExists) Then 77 | OnFileDoesNotExistError "SetFile", filePath 78 | End If 79 | 80 | pFileNumber = FreeFile 81 | pFilePath = filePath 82 | 83 | If overwrite Or Create Then 84 | Open filePath For Output As #pFileNumber 85 | Else 86 | Open filePath For Append As #pFileNumber 87 | End If 88 | 89 | Exit Sub 90 | 91 | ErrHandler: 92 | OnUnHandledError "SetFile" 93 | 94 | End Sub 95 | ' 96 | ' Destructors 97 | ' ----------- 98 | ' 99 | Private Sub Class_Terminate() 100 | 101 | CloseFile 102 | 103 | End Sub 104 | ' 105 | ' Public Methods 106 | ' -------------- 107 | ' 108 | Public Sub CloseFile() 109 | On Error GoTo ErrHandler 110 | 111 | Close #pFileNumber 112 | pFileNumber = 0 113 | 114 | Exit Sub 115 | 116 | ErrHandler: 117 | OnUnHandledError "CloseFile" 118 | 119 | End Sub 120 | ' 121 | ' Private Methods 122 | ' --------------- 123 | ' 124 | ' ### Writing 125 | ' 126 | Private Sub AppendData(ByVal data As String, ByVal method As String) 127 | On Error GoTo ErrHandler 128 | 129 | If pFileNumber = 0 Then 130 | OnFileNotOpenedError method 131 | End If 132 | 133 | Print #pFileNumber, data; 134 | 135 | CleanExit: 136 | Exit Sub 137 | 138 | ErrHandler: 139 | 140 | 'handle "52: Bad file name or number" by raising a FileWriterError.FileNotOpened instead: 141 | If Err.Number = 52 Then OnFileNotOpenedError method 142 | 143 | 'close file it *any* error occurs writing to it: 144 | CloseFile 145 | 146 | OnUnHandledError "AppendData" 147 | 148 | End Sub 149 | ' 150 | ' ### Errors 151 | ' 152 | Private Function GetErrorSource(ByVal method As String) As String 153 | 154 | GetErrorSource = TypeName(Me) & "." & method 155 | 156 | End Function 157 | Private Sub OnUnHandledError(ByVal method As String) 158 | 159 | Err.Raise Err.Number, GetErrorSource(method), Err.description, _ 160 | Err.HelpFile, Err.HelpContext 161 | 162 | End Sub 163 | Private Sub OnFileNotOpenedError(ByVal method As String) 164 | 165 | Err.Raise FileWriterError.FileNotOpened, GetErrorSource(method), _ 166 | "File #" & pFileNumber & "(" & pFilePath & ") was unexpectedly closed." 167 | 168 | End Sub 169 | Private Sub OnFileAlreadyOpenedError(ByVal method As String, ByVal fileName As String) 170 | 171 | Err.Raise FileWriterError.FileAlreadyOpened, GetErrorSource(method), _ 172 | "File '" & fileName & _ 173 | "' cannot be opened with this instance at this point. A file is already opened." 174 | 175 | End Sub 176 | Private Sub OnFileDoesNotExistError(ByVal method As String, ByVal fileName As String) 177 | 178 | Err.Raise FileWriterError.FileDoesNotExist, GetErrorSource(method), _ 179 | "File '" & fileName & "' cannot be opened as it does not exist." 180 | 181 | End Sub 182 | Private Sub OnFileAlreadyExistsError(ByVal method As String, ByVal fileName As String) 183 | 184 | Err.Raise FileWriterError.FileAlreadyExists, GetErrorSource(method), _ 185 | "File '" & fileName & "' cannot be created as it already exists." 186 | 187 | End Sub 188 | ' 189 | ' Interfaces 190 | ' ---------- 191 | ' 192 | ' ### Output 193 | ' 194 | ' 195 | ' #### Prints 196 | ' 197 | Public Sub Prints(ByVal data As Variant) 198 | 199 | AppendData defShow.Show(data), method:="Prints" 200 | 201 | End Sub 202 | Public Sub Output_Prints(ByVal data As Variant) 203 | 204 | Prints data 205 | 206 | End Sub 207 | ' 208 | ' #### PrintLine 209 | ' 210 | Public Sub PrintLine(ByVal line As Variant) 211 | 212 | AppendData defShow.Show(line), method:="PrintLine" 213 | AppendData vbNewLine, method:="PrintLine" 214 | 215 | End Sub 216 | Public Sub Output_PrintLine(ByVal line As Variant) 217 | 218 | PrintLine line 219 | 220 | End Sub 221 | ' 222 | ' #### PrintLiness 223 | ' 224 | Public Sub PrintLines(ByRef lines() As Variant) 225 | 226 | Dim line As Variant 227 | For Each line In lines 228 | PrintLine line 229 | Next line 230 | 231 | End Sub 232 | Public Sub Output_PrintLines(ByRef lines() As Variant) 233 | 234 | PrintLine lines 235 | 236 | End Sub 237 | 238 | 239 | 240 | -------------------------------------------------------------------------------- /src/cast.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "cast" 2 | Option Explicit 3 | ' 4 | ' cast 5 | ' ==== 6 | ' 7 | '' 8 | ' Assign x to y regardless of object or primitive 9 | Public Sub Assign(ByRef x, ByVal y) 10 | 11 | If IsObject(y) Then 12 | Set x = y 13 | Else 14 | x = y 15 | End If 16 | 17 | End Sub 18 | '' 19 | ' Convert Variant To Varaint() 20 | ' TODO: Bubble Errors if xs is not an array 21 | Public Function CArray(ByVal xs) As Variant() 22 | 23 | On Error GoTo CheckIfNotArray 24 | CArray = xs 25 | 26 | Exit Function 27 | CheckIfNotArray: 28 | Debug.Assert Not IsArray(xs) 29 | NotImplementedError "cast", "CArray" 30 | 31 | End Function 32 | Public Function xArray(ParamArray xs() As Variant) As Variant() 33 | 34 | xArray = CArray(xs) 35 | 36 | End Function 37 | '' 38 | ' Is x An Array? 39 | Public Function IsArray(ByVal x) As Boolean 40 | 41 | IsArray = (TypeName(x) Like "*()") 42 | 43 | End Function 44 | 45 | -------------------------------------------------------------------------------- /src/defAccum.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "defAccum" 2 | Option Explicit 3 | 4 | Public Function Fold(ByVal op As Applicable, ByVal Init, ByVal sequence) 5 | 6 | Dim result 7 | Assign result, Init 8 | 9 | Dim element 10 | For Each element In sequence 11 | Assign result, op.Apply(result, element) 12 | Next 13 | 14 | Assign Fold, result 15 | 16 | End Function 17 | Public Function Scan(ByVal seed As Buildable, ByVal op As Applicable, ByVal Init, ByVal sequence) As Buildable 18 | 19 | Dim result As Buildable 20 | Set result = seed.MakeEmpty 21 | 22 | Dim temp 23 | Assign temp, Init 24 | 25 | Dim element 26 | For Each element In sequence 27 | 28 | Assign temp, op.Apply(temp, element) 29 | result.AddItem temp 30 | 31 | Next 32 | 33 | Set Scan = result 34 | 35 | End Function 36 | -------------------------------------------------------------------------------- /src/defApply.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "defApply" 2 | Option Explicit 3 | 4 | Public Function Compose(ByVal outer As Applicable, ByVal inner As Applicable) As Applicable 5 | 6 | Set Compose = Composed.Make(outer, inner) 7 | 8 | End Function 9 | Public Function AndThen(ByVal inner As Applicable, ByVal outer As Applicable) As Applicable 10 | 11 | Set AndThen = Composed.Make(outer, inner) 12 | 13 | End Function 14 | Public Function AsPartial(ByVal f As Applicable, ByRef args() As Variant) As Applicable 15 | 16 | Set AsPartial = Partial.Make(f, args) 17 | 18 | End Function 19 | Public Function AsDelay(ByVal f As Applicable, ByRef args() As Variant) As Delayed 20 | 21 | Set AsDelay = ByName.Make(f, args) 22 | 23 | End Function 24 | Public Function ApplicationRunOnArray(ByVal id As String, ByRef args() As Variant) As Variant 25 | 26 | Dim result 27 | Select Case UBound(args) + 1 28 | Case 0 29 | Assign result, Application.Run(id) 30 | Case 1 31 | Assign result, Application.Run(id, args(0)) 32 | Case 2 33 | Assign result, Application.Run(id, args(0), args(1)) 34 | Case 3 35 | Assign result, Application.Run(id, args(0), args(1), args(2)) 36 | Case 4 37 | Assign result, Application.Run(id, args(0), args(1), args(2), args(3)) 38 | Case 5 39 | Assign result, Application.Run(id, args(0), args(1), args(2), args(3), args(4)) 40 | Case 6 41 | Assign result, Application.Run(id, args(0), args(1), args(2), args(3), args(4), args(5)) 42 | Case 7 43 | Assign result, Application.Run(id, args(0), args(1), args(2), args(3), args(4), args(5), args(6)) 44 | Case 8 45 | Assign result, Application.Run(id, args(0), args(1), args(2), args(3), args(4), args(5), args(6), args(7)) 46 | Case 9 47 | Assign result, Application.Run(id, args(0), args(1), args(2), args(3), args(4), args(5), args(6), args(7), args(8)) 48 | Case 10 49 | Assign result, Application.Run(id, args(0), args(1), args(2), args(3), args(4), args(5), args(6), args(7), args(8), args(9)) 50 | Case Else 51 | NotImplementedError "defApply", "ApplicationRunOnArray" 52 | End Select 53 | 54 | Assign ApplicationRunOnArray, result 55 | 56 | End Function 57 | Public Function CallByNameOnArray(ByVal obj As Object, ByVal method As String, ByVal clltype As VbCallType, ByRef args() As Variant) As Variant 58 | 59 | Dim result 60 | Select Case UBound(args) + 1 61 | Case 0 62 | Assign result, CallByName(obj, method, clltype) 63 | Case 1 64 | Assign result, CallByName(obj, method, clltype, args(0)) 65 | Case 2 66 | Assign result, CallByName(obj, method, clltype, args(0), args(1)) 67 | Case 3 68 | Assign result, CallByName(obj, method, clltype, args(0), args(1), args(2)) 69 | Case 4 70 | Assign result, CallByName(obj, method, clltype, args(0), args(1), args(2), args(3)) 71 | Case 5 72 | Assign result, CallByName(obj, method, clltype, args(0), args(1), args(2), args(3), args(4)) 73 | Case 6 74 | Assign result, CallByName(obj, method, clltype, args(0), args(1), args(2), args(3), args(4), args(5)) 75 | Case 7 76 | Assign result, CallByName(obj, method, clltype, args(0), args(1), args(2), args(3), args(4), args(5), args(6)) 77 | Case 8 78 | Assign result, CallByName(obj, method, clltype, args(0), args(1), args(2), args(3), args(4), args(5), args(6), args(7)) 79 | Case 9 80 | Assign result, CallByName(obj, method, clltype, args(0), args(1), args(2), args(3), args(4), args(5), args(6), args(7), args(8)) 81 | Case 10 82 | Assign result, CallByName(obj, method, clltype, args(0), args(1), args(2), args(3), args(4), args(5), args(6), args(7), args(8), args(9)) 83 | Case Else 84 | NotImplementedError "defApply", "CallByNameOnArray" 85 | End Select 86 | 87 | Assign CallByNameOnArray, result 88 | 89 | End Function 90 | 91 | -------------------------------------------------------------------------------- /src/defBuildable.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "defBuildable" 2 | Option Explicit 3 | 4 | Public Function Repeat(ByVal seed As Buildable, ByVal val, ByVal n As Long) _ 5 | As Buildable 6 | 7 | Dim result As Buildable 8 | Set result = seed.MakeEmpty 9 | 10 | Dim i As Long 11 | For i = 1 To n 12 | result.AddItem val 13 | Next 14 | 15 | Set Repeat = result 16 | 17 | End Function 18 | Public Function Enumerate(ByVal seed As Buildable, ByVal from As Long, _ 19 | ByVal til As Long, Optional ByVal by As Long = 1) As Buildable 20 | 21 | If Not (0 < (til - from) * Sgn(by)) Then ' Does not converge 22 | Exceptions.ValueError seed, "Enumerate", "Sequence does not converge" 23 | End If 24 | 25 | Dim result As Buildable 26 | Set result = seed.MakeEmpty 27 | 28 | Dim i As Long 29 | For i = from To til Step by 30 | result.AddItem i 31 | Next 32 | 33 | Set Enumerate = result 34 | 35 | End Function 36 | '' 37 | ' Converts an Transversable to any Buildable 38 | Public Function ConvertTo(ByVal seed As Buildable, ByVal transversable) _ 39 | As Variant 40 | 41 | Dim result As Buildable 42 | Set result = seed.MakeEmpty 43 | result.AddItems (transversable) 44 | Set ConvertTo = result 45 | 46 | End Function 47 | -------------------------------------------------------------------------------- /src/defCompare.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "defCompare" 2 | ' 3 | ' Compare 4 | ' ------- 5 | ' 6 | Public Enum CompareResult 7 | 8 | lt = -1 9 | eq = 0 10 | gt = 1 11 | 12 | End Enum 13 | Private Sub CheckComparable(ByVal x) 14 | 15 | If Not IsComparable(x) Then 16 | Dim msg As String 17 | msg = defShow.Show(x) & " Is not a Comparable object" 18 | TypeError "defCompare", "CheckComparable", msg 19 | End If 20 | 21 | End Sub 22 | Private Function IsComparable(ByVal x) As Boolean 23 | 24 | IsComparable = (TypeOf x Is Comparable) 25 | 26 | End Function 27 | ' 28 | ' Public Functions 29 | ' ---------------- 30 | ' 31 | Public Function AsComparable(ByVal x) As Comparable 32 | 33 | CheckComparable x 34 | Set AsComparable = x 35 | 36 | End Function 37 | Public Function Compare(ByVal x, ByVal y) As CompareResult 38 | 39 | 40 | Dim result As CompareResult 41 | If Equals(x, y) Then 42 | result = eq 43 | ElseIf LessThan(x, y) Then 44 | result = lt 45 | ElseIf GreaterThan(x, y) Then 46 | result = gt 47 | End If 48 | 49 | Compare = result 50 | 51 | End Function 52 | Public Function LessThan(ByVal x, ByVal y) As Boolean 53 | 54 | Dim result As Boolean 55 | 56 | If IsComparable(x) Then 57 | result = (AsComparable(x).Compare(y) = lt) 58 | ElseIf IsComparable(y) Then 59 | result = (AsComparable(y).Compare(x) = gt) 60 | Else 61 | On Error GoTo ErrHandler 62 | result = (x < y) 63 | On Error GoTo 0 64 | End If 65 | 66 | LessThan = result 67 | Exit Function 68 | ErrHandler: 69 | Select Case Err.Number 70 | Case Else 71 | Exceptions.BubbleError "defCompare", "LessThan", Err 72 | End Select 73 | End Function 74 | Public Function GreaterThan(ByVal x, ByVal y) As Boolean 75 | 76 | GreaterThan = LessThan(y, x) 77 | 78 | End Function 79 | Public Function LessThanOrEqualTo(ByVal x, ByVal y) As Boolean 80 | 81 | LessThanOrEqualTo = Not GreaterThan(x, y) 82 | 83 | End Function 84 | Public Function GreaterThanOrEqualTo(ByVal x, ByVal y) As Boolean 85 | 86 | GreaterThanOrEqualTo = Not LessThan(x, y) 87 | 88 | End Function 89 | 90 | 91 | 92 | 93 | -------------------------------------------------------------------------------- /src/defEquals.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "defEquals" 2 | Option Explicit 3 | Private Sub CheckEquatable(ByVal x) 4 | 5 | If Not IsEquatable(x) Then 6 | TypeError "defEquals", "CheckEquatable" 7 | End If 8 | 9 | End Sub 10 | Private Function IsEquatable(ByVal x) As Boolean 11 | 12 | IsEquatable = (TypeOf x Is Equatable) 13 | 14 | End Function 15 | ' 16 | ' Public Functions 17 | ' ---------------- 18 | ' 19 | Public Function AsEquatable(ByVal x) As Equatable 20 | 21 | CheckEquatable x 22 | Set AsEquatable = x 23 | 24 | End Function 25 | Public Function Equals(ByVal x, ByVal y) As Boolean 26 | 27 | Dim result As Boolean 28 | 29 | If IsEquatable(x) Then 30 | result = AsEquatable(x).Equals(y) 31 | ElseIf IsEquatable(y) Then 32 | result = AsEquatable(y).Equals(x) 33 | Else 34 | On Error GoTo ErrHandler 35 | result = (x = y) 36 | On Error GoTo 0 37 | End If 38 | 39 | Equals = result 40 | 41 | Exit Function 42 | ErrHandler: 43 | Select Case Err.Number 44 | Case Else 45 | Exceptions.BubbleError "defEquals", "Equals", Err 46 | End Select 47 | 48 | End Function 49 | -------------------------------------------------------------------------------- /src/defFilter.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "defFilter" 2 | Option Explicit 3 | 4 | Public Function Filter(ByVal seed As Buildable, _ 5 | ByVal pred As Applicable, ByVal sequence) As Variant 6 | 7 | Set Filter = GenericFilter(True, seed, pred, sequence) 8 | 9 | End Function 10 | Public Function FilterNot(ByVal seed As Buildable, _ 11 | ByVal pred As Applicable, ByVal sequence) As Variant 12 | 13 | Set FilterNot = GenericFilter(False, seed, pred, sequence) 14 | 15 | End Function 16 | Private Function GenericFilter(ByVal keep As Boolean, _ 17 | ByVal seed As Buildable, ByVal pred As Applicable, _ 18 | ByVal sequence) As Variant 19 | 20 | Dim result As Buildable 21 | Set result = seed.MakeEmpty 22 | 23 | Dim element 24 | For Each element In sequence 25 | If pred.Apply(element) = keep Then 26 | result.AddItem element 27 | End If 28 | Next 29 | 30 | Set GenericFilter = result 31 | 32 | End Function 33 | 34 | 35 | -------------------------------------------------------------------------------- /src/defMap.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "defMap" 2 | Option Explicit 3 | ' 4 | ' defMap 5 | ' ====== 6 | ' 7 | ' Default implementations of Map and Bind for different structures. Classes 8 | ' that implement `Map`, or `Bind` (aka `FlatMap`), can avoid code duplication 9 | ' by using these functions with their predeclared object as `seed`. 10 | ' 11 | ' It may be more prudent to split these into the various default files like 12 | ' defIterable, defTransversable etc... 13 | ' 14 | ' TODO: Should these belong in Buildable? 15 | Private Const MAP_ADD As String = "AddItem" 16 | Private Const BIND_ADD As String = "AddItems" 17 | ' 18 | ' Transversable 19 | ' ------------- 20 | ' 21 | ' Transversable maps use `For Each` structures to loop over the sequence. Since 22 | ' mutliple data-types can use `For Each` the squence is a Variant. 23 | ' 24 | ' These will be the most commonly used. 25 | ' 26 | Public Function TransversableMap(ByVal seed As Buildable, _ 27 | ByVal op As Applicable, ByVal sequence) As Buildable 28 | 29 | On Error GoTo Bubble 30 | Set TransversableMap = GenericTransversableMap(MAP_ADD, seed, op, sequence) 31 | 32 | Exit Function 33 | Bubble: 34 | Exceptions.BubbleError "defMap", "TransversableMap", Err 35 | 36 | End Function 37 | Public Function TransversableBind(ByVal seed As Buildable, _ 38 | ByVal op As Applicable, ByVal sequence) As Buildable 39 | 40 | On Error GoTo Bubble 41 | Set TransversableBind = GenericTransversableMap(BIND_ADD, seed, op, sequence) 42 | 43 | Exit Function 44 | Bubble: 45 | Exceptions.BubbleError "defMap", "TransversableBind", Err 46 | 47 | End Function 48 | Private Function GenericTransversableMap(ByVal buildMethod As String, _ 49 | ByVal seed As Buildable, ByVal op As Applicable, ByVal sequence) As Buildable 50 | 51 | Dim result As Buildable 52 | Set result = seed.MakeEmpty 53 | 54 | Dim element 55 | For Each element In sequence 56 | CallByName result, buildMethod, VbMethod, op.Apply(element) 57 | Next 58 | 59 | Set GenericTransversableMap = result 60 | 61 | End Function 62 | ' 63 | ' Iterable 64 | ' -------- 65 | ' 66 | ' Use for any iterable classes that are not transversable. 67 | ' Result must still be buildable. 68 | ' 69 | Public Function IterableMap(ByVal seed As Buildable, ByVal op As Applicable, _ 70 | ByVal iterable As Linear) As Buildable 71 | 72 | On Error GoTo Bubble 73 | Set IterableMap = GenericIterableMap(MAP_ADD, seed, op, iterable) 74 | 75 | Exit Function 76 | Bubble: 77 | Exceptions.BubbleError "defMap", "IterableMap", Err 78 | 79 | End Function 80 | Public Function IterableBind(ByVal seed As Buildable, ByVal op As Applicable, _ 81 | ByVal iterable As Linear) As Buildable 82 | 83 | On Error GoTo Bubble 84 | Set IterableBind = GenericIterableMap(BIND_ADD, seed, op, iterable) 85 | 86 | Exit Function 87 | Bubble: 88 | Exceptions.BubbleError "defMap", "IterableBind", Err 89 | 90 | End Function 91 | Private Function GenericIterableMap(ByVal buildMethod As String, _ 92 | ByVal seed As Buildable, ByVal op As Applicable, _ 93 | ByVal iterable As Linear) As Buildable 94 | 95 | Dim result As Buildable 96 | Set result = seed.MakeEmpty 97 | 98 | Dim i As Long 99 | For i = iterable.LowerBound To iterable.UpperBound 100 | CallByName result, buildMethod, VbMethod, op.Apply(iterable.Item(i)) 101 | Next 102 | 103 | Set GenericIterableMap = result 104 | 105 | End Function 106 | 107 | -------------------------------------------------------------------------------- /src/defMonad.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "defMonad" 2 | Option Explicit 3 | 4 | Public Function ApplyUnit(ByVal m As Monadic) As OnArgs 5 | 6 | Set ApplyUnit = OnArgs.Make("Unit", VbMethod, m) 7 | 8 | End Function 9 | -------------------------------------------------------------------------------- /src/defSetLike.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "defSetLike" 2 | Option Explicit 3 | ' 4 | ' Comparison 5 | ' ---------- 6 | ' 7 | Public Function SetEquals(ByVal xs As SetLike, ByVal ys) As Boolean 8 | 9 | If TypeOf ys Is SetLike Then 10 | On Error GoTo Nope 11 | SetEquals = (xs.Difference(ys).Count = 0) 12 | On Error GoTo 0 13 | Else 14 | 15 | CleanExit: 16 | SetEquals = False 17 | End If 18 | Exit Function 19 | Nope: 20 | Resume CleanExit: 21 | 22 | End Function 23 | Public Function IsDisJoint(ByVal xs As SetLike, ByVal ys As SetLike) As Boolean 24 | 25 | IsDisJoint = (xs.Intersect(ys).Count = 0) 26 | 27 | End Function 28 | Public Function IsSubSetOf(ByVal xs As SetLike, ByVal ys As SetLike) As Boolean 29 | 30 | Dim x 31 | For Each x In xs 32 | 33 | If Not ys.Contains(x) Then 34 | 35 | IsSubSetOf = False 36 | Exit Function 37 | 38 | End If 39 | 40 | Next 41 | 42 | IsSubSetOf = True 43 | 44 | End Function 45 | Public Function IsProperSubSetOf(ByVal xs As SetLike, ByVal ys As SetLike) As Boolean 46 | 47 | IsProperSubSetOf = (xs.IsSubSetOf(ys) And (xs.Count < ys.Count)) 48 | 49 | End Function 50 | Public Function IsSuperSetOf(ByVal xs As SetLike, ByVal ys As SetLike) As Boolean 51 | 52 | IsSuperSetOf = ys.IsSubSetOf(xs) 53 | 54 | End Function 55 | Public Function IsProperSuperSetOf(ByVal xs As SetLike, ByVal ys As SetLike) As Boolean 56 | 57 | IsProperSuperSetOf = ys.IsProperSubSetOf(xs) 58 | 59 | End Function 60 | ' 61 | ' Constructors 62 | ' ------------ 63 | ' 64 | Public Function Union(ByVal seed As Buildable, ByVal xs, ByVal ys) As Variant 65 | 66 | Dim result As Buildable 67 | Set result = seed.MakeEmpty 68 | 69 | result.AddItems xs 70 | result.AddItems ys 71 | 72 | Set Union = result 73 | 74 | End Function 75 | Public Function Intersect(ByVal seed As Buildable, ByVal xs, _ 76 | ByVal ys As SetLike) As Variant 77 | 78 | Set Intersect = GenericJoin(True, seed, xs, ys) 79 | 80 | End Function 81 | Public Function Difference(ByVal seed As Buildable, ByVal xs, _ 82 | ByVal ys As SetLike) As Variant 83 | 84 | Set Difference = GenericJoin(False, seed, xs, ys) 85 | 86 | End Function 87 | Public Function SymmetricDifference(ByVal seed As Buildable, _ 88 | ByVal xs As SetLike, ByVal ys As SetLike) As Variant 89 | 90 | Dim leftOuter 91 | Set leftOuter = xs.Difference(ys) 92 | 93 | Dim rightOuter 94 | Set rightOuter = ys.Difference(xs) 95 | 96 | Set SymmetricDifference = Union(seed, leftOuter, rightOuter) 97 | 98 | End Function 99 | Private Function GenericJoin(ByVal contained As Boolean, _ 100 | ByVal seed As Buildable, ByVal xs, ByVal ys As SetLike) As Variant 101 | 102 | Dim result As Buildable 103 | Set result = seed.MakeEmpty 104 | 105 | Dim x 106 | For Each x In xs 107 | If ys.Contains(x) = contained Then 108 | result.AddItem x 109 | End If 110 | Next 111 | 112 | Set GenericJoin = result 113 | 114 | End Function 115 | -------------------------------------------------------------------------------- /src/defShow.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "defShow" 2 | Option Explicit 3 | ' 4 | ' Show 5 | ' ==== 6 | ' 7 | ' Default implementation of Show. 8 | ' 9 | Private Const ARRAY_DELIM As String = ", " 10 | Private Const SQUARE_ARRAY_DELIM As String = "; " 11 | Private Const OBJOPEN As String = "(" 12 | Private Const OBJCLOSE As String = ")" 13 | Private Const ARROPEN As String = "[" 14 | Private Const ARRCLOSE As String = "]" 15 | 16 | ' 17 | ' Public Methods 18 | ' -------------- 19 | ' 20 | Public Function Show(ByVal x) As String 21 | Dim result As String 22 | 23 | If TypeOf x Is Showable Then 24 | 25 | Dim s As Showable 26 | Set s = x 27 | result = s.Show 28 | 29 | ElseIf IsObject(x) Then 30 | result = UnShowableObject(x) 31 | ElseIf cast.IsArray(x) Then 32 | result = ShowArray(x) 33 | ElseIf IsNull(x) Then 34 | x = vbNullString 35 | Else 36 | result = x 37 | End If 38 | 39 | Show = result 40 | 41 | End Function 42 | Public Function ParamShowableObject(ByVal obj As Object, _ 43 | ParamArray members()) As String 44 | 45 | ParamShowableObject = ShowableObject(obj, cast.CArray(members)) 46 | 47 | End Function 48 | Public Function ShowableObject(ByVal obj As Object, ByRef members()) As String 49 | 50 | Dim shownMembers As String 51 | shownMembers = ShowArrayMembers(members) 52 | 53 | ShowableObject = TypeName(obj) & OBJOPEN & shownMembers & OBJCLOSE 54 | 55 | End Function 56 | ' 57 | ' Private Methods 58 | ' --------------- 59 | ' 60 | Private Function UnShowableObject(ByVal obj As Object) As String 61 | 62 | Dim repr As String 63 | repr = "&" & ObjPtr(obj) 64 | 65 | UnShowableObject = ShowableObject(obj, cast.xArray(repr)) 66 | 67 | End Function 68 | ' 69 | ' ### Showing Arrays 70 | ' 71 | Private Function ShowArray(ByRef xs As Variant) As String 72 | 73 | Dim shownMembers As String 74 | If IsSquareArray(xs) Then 75 | shownMembers = ShowSquareArrayMembers(xs) 76 | Else 77 | shownMembers = ShowArrayMembers(xs) 78 | End If 79 | 80 | Dim withParens As String 81 | withParens = TypeName(xs) 82 | 83 | Dim withoutParens As String 84 | withoutParens = Left(withParens, Len(withParens) - 2) 85 | 86 | ShowArray = withoutParens & ARROPEN & shownMembers & ARRCLOSE 87 | 88 | End Function 89 | Private Function IsSquareArray(ByRef xs As Variant) As Boolean 90 | 91 | Dim dummy As Long 92 | Dim result As Boolean 93 | 94 | On Error GoTo Nope 95 | dummy = UBound(xs, 2) 96 | 97 | On Error GoTo Yup 98 | dummy = UBound(xs, 3) 99 | 100 | On Error GoTo 0 101 | Exceptions.TypeError "defShow", "IsSquareArray", _ 102 | "Can not and will not show 3 or more dimensional array." & _ 103 | " Do not use cubic or greater arrays!" 104 | 105 | CleanExit: 106 | IsSquareArray = result 107 | Exit Function 108 | 109 | Nope: 110 | Err.Clear 111 | result = False 112 | Resume CleanExit 113 | 114 | Yup: 115 | Err.Clear 116 | result = True 117 | Resume CleanExit 118 | 119 | End Function 120 | Private Function ShowArrayMembers(ByRef xs As Variant) As String 121 | 122 | Dim lower As Long 123 | lower = LBound(xs) 124 | 125 | Dim upper As Long 126 | upper = UBound(xs) 127 | 128 | Dim results() As String 129 | If lower <= upper Then 130 | ReDim results(lower To upper) 131 | End If 132 | 133 | Dim i As Long 134 | For i = lower To upper 135 | results(i) = Show(xs(i)) 136 | Next i 137 | 138 | ShowArrayMembers = Join(results, ARRAY_DELIM) 139 | 140 | End Function 141 | Private Function ShowSquareArrayMembers(ByRef xs As Variant) As String 142 | 143 | Dim txs As Variant 144 | txs = Application.Transpose(xs) 145 | 146 | Dim lower As Long 147 | lower = LBound(txs) 148 | 149 | Dim upper As Long 150 | upper = UBound(txs) 151 | 152 | Dim size As Long 153 | size = upper - lower + 1 154 | 155 | Dim results() As String 156 | If lower <= upper Then 157 | ReDim results(1 To size) 158 | End If 159 | 160 | Dim i As Long 161 | For i = 1 To size 162 | results(i) = ShowArrayMembers(Application.index(txs, i, 0)) 163 | Next 164 | 165 | ShowSquareArrayMembers = Join(results, SQUARE_ARRAY_DELIM) 166 | 167 | End Function 168 | 169 | -------------------------------------------------------------------------------- /src/fsview.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "fsview" 2 | Option Explicit 3 | ' 4 | ' fsview 5 | ' ====== 6 | ' 7 | ' Introspect the file system. 8 | ' 1. Path exists 9 | ' 2. Sub Items of path 10 | ' 3. Recursive Find 11 | ' 4. Glob search (Only uses VB `?` and `*` wild cards) 12 | ' 13 | ' Copyright (c) 2014 Philip Wales 14 | ' This file (fsview.bas) is distributed under the GPL-3.0 license. 15 | ' Obtain a copy of the license here: http://opensource.org/licenses/GPL-3.0 16 | 17 | Private Const ALLPAT As String = "*" 18 | Public Const PARDIR As String = ".." 19 | Public Const CURDIR As String = "." 20 | ' 21 | ' Introspect FileSystem 22 | ' --------------------- 23 | '' 24 | ' returns whether file or folder exists or not. 25 | ' Use `vbType` argument to filter/include files. 26 | ' See 27 | ' for more types 28 | Public Function Exists(ByVal filePath As String, _ 29 | Optional ByVal vbType As VbFileAttribute = vbDirectory) As Boolean 30 | 31 | If Not filePath = vbNullString Then 32 | 33 | Exists = Not (Dir$(Path.RTrimSep(filePath), vbType) = vbNullString) 34 | 35 | End If 36 | 37 | End Function 38 | '' 39 | ' Will not return true if a folder exists of the same name 40 | Public Function FileExists(ByVal filePath As String) 41 | 42 | FileExists = Exists(filePath, vbNormal) 43 | 44 | End Function 45 | '' 46 | ' vbDirectory option still includes files. 47 | ' FML 48 | Public Function FolderExists(ByVal folderPath As String) 49 | 50 | FolderExists = Exists(folderPath, vbDirectory) _ 51 | And Not Exists(folderPath, vbNormal) 52 | 53 | End Function 54 | '' 55 | ' returns a List of strings that are paths of subitems in root which 56 | ' match pat. 57 | Public Function SubItems(ByVal Root As String, Optional ByVal pat As String = ALLPAT, _ 58 | Optional ByVal vbType As VbFileAttribute = vbDirectory) As List 59 | 60 | Set SubItems = List.Create 61 | 62 | Dim subItem As String 63 | subItem = Dir$(JoinPath(Root, pat), vbType) 64 | 65 | Do While subItem <> vbNullString 66 | 67 | SubItems.Append JoinPath(Root, subItem) 68 | subItem = Dir$() 69 | 70 | Loop 71 | 72 | End Function 73 | Public Function SubFiles(ByVal Root As String, _ 74 | Optional pat As String = ALLPAT) As List 75 | 76 | Set SubFiles = SubItems(Root, pat, vbNormal) 77 | 78 | End Function 79 | '' 80 | ' Why on earth would I want . and .. included in sub folders? 81 | ' When vbDirectory is passed to dir it still includes files. Why the would 82 | ' anyone want that? Now there is no direct way to actually list subfolders 83 | ' only get a list of both files and folders and filter out files 84 | Public Function SubFolders(ByVal Root As String, Optional ByVal pat As String = vbNullString, _ 85 | Optional ByVal skipDots As Boolean = True) As List 86 | 87 | Dim result As List 88 | Set result = SubItems(Root, pat, vbDirectory) 89 | 90 | If skipDots And result.Count > 0 Then 91 | 92 | If result(1) = JoinPath(Root, CURDIR) Then ' else root 93 | result.Remove 1 94 | If result(1) = JoinPath(Root, PARDIR) Then ' else mountpoint 95 | result.Remove 1 96 | End If 97 | End If 98 | 99 | End If 100 | 101 | ' Do not use FilterNot(FileExists) as an optimization 102 | ' it will crash on illegal file names 103 | Set SubFolders = result.Filter(InternalDelegate.Make("FolderExists")) 104 | 105 | End Function 106 | Public Function Find(ByVal Root As String, Optional ByVal pat As String = "*", _ 107 | Optional ByVal vbType As VbFileAttribute = vbNormal) As List 108 | 109 | Dim result As List 110 | Set result = List.Create 111 | 112 | FindRecurse Root, result, pat, vbType 113 | 114 | Set Find = result 115 | 116 | End Function 117 | Private Sub FindRecurse(ByVal Root As String, ByRef foundItems As List, _ 118 | Optional pat As String = "*", _ 119 | Optional ByVal vbType As VbFileAttribute = vbNormal) 120 | 121 | Dim folder As Variant 122 | For Each folder In SubFolders(Root) 123 | FindRecurse folder, foundItems, pat, vbType 124 | Next folder 125 | 126 | foundItems.Extend SubItems(Root, pat, vbType) 127 | 128 | End Sub 129 | Public Function Glob(ByVal pattern As String, _ 130 | Optional ByVal vbType As VbFileAttribute = vbNormal) As List 131 | 132 | Dim Root As String 133 | Root = Path.LongestRoot(pattern) 134 | 135 | Dim patterns() As String 136 | patterns = Split(right$(pattern, Len(pattern) - Len(Root) - 1), Path.SEP) 137 | 138 | Set Glob = GlobRecurse(Root, patterns, 0, vbType) 139 | 140 | End Function 141 | Private Function GlobRecurse(ByVal Root As String, ByRef patterns() As String, _ 142 | ByVal index As Integer, ByVal vbType As VbFileAttribute) As List 143 | 144 | Dim result As List 145 | 146 | If index = UBound(patterns) Then 147 | Set result = SubItems(Root, patterns(index), vbType) 148 | Else 149 | 150 | Set result = List.Create 151 | 152 | Dim folder As Variant 153 | For Each folder In SubFolders(Root, patterns(index)) 154 | result.Extend GlobRecurse(folder, patterns, index + 1, vbType) 155 | Next folder 156 | 157 | End If 158 | 159 | Set GlobRecurse = result 160 | 161 | End Function 162 | -------------------------------------------------------------------------------- /src/path.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "path" 2 | Option Explicit 3 | ' 4 | ' path 5 | ' ==== 6 | ' 7 | ' Common Path Manipulations for VBEX 8 | ' 9 | ' Copyright (c) 2014 Philip Wales 10 | ' This file (path.bas) is distributed under the GPL-3.0 license. 11 | ' 12 | 13 | 14 | ' 15 | ' Constants 16 | ' --------- 17 | ' 18 | Public Const EXTSEP As String = "." 19 | Public Const PARDIR As String = ".." 20 | Public Const CURDIR As String = "." 21 | Public Const SEP As String = "\" ' "/" for UNIX if you ever run VBA on UNIX... 22 | Public Const PATHSEP As String = ";" ' not used... 23 | ' 24 | ' Path Manipulations 25 | ' ------------------ 26 | ' 27 | '' 28 | ' Returns the base name of a path, either the lowest folder or file 29 | ' Note! that `suffix` will be removed from the end regardless if its an actual filename 30 | ' extension or not. 31 | Public Function BaseName(ByVal filePath As String, _ 32 | Optional ByVal suffix As String) As String 33 | 34 | Dim pathSplit As Variant 35 | pathSplit = Split(filePath, SEP) 36 | 37 | BaseName = pathSplit(UBound(pathSplit)) 38 | 39 | If suffix <> vbNullString Then 40 | 41 | Dim baseLength As Integer 42 | baseLength = Len(BaseName) - Len(suffix) 43 | 44 | ' replace suffix with nothing and only look for suffix the end of the string 45 | BaseName = Left$(BaseName, baseLength) & Replace$(BaseName, suffix, "", baseLength + 1) 46 | 47 | End If 48 | 49 | End Function 50 | '' 51 | ' Returns the path of the parent folder. This is the opposite of `BaseName`. 52 | Public Function RootName(ByVal Path As String) As String 53 | 54 | RootName = ParentDir(Path, 1) 55 | 56 | End Function 57 | '' 58 | ' 59 | Public Function ParentDir(ByVal somePath As String, _ 60 | ByVal parentHeight As Integer) As String 61 | 62 | Dim splitPath As Variant 63 | splitPath = Split(somePath, SEP) 64 | 65 | Dim parentCount As Integer 66 | parentCount = UBound(splitPath) - parentHeight 67 | 68 | If parentCount > 0 Then 69 | 70 | ReDim Preserve splitPath(LBound(splitPath) To parentCount) 71 | 72 | End If 73 | 74 | ParentDir = Join(splitPath, SEP) 75 | 76 | End Function 77 | '' 78 | ' Returns the file extension of the file. 79 | ' path.ext -> .ext 80 | ' path -> 81 | ' path.bad.ext -> .ext 82 | Public Function Ext(ByVal filePath As String) As String 83 | 84 | Dim base As String 85 | base = BaseName(filePath) 86 | 87 | If InStr(base, EXTSEP) Then 88 | 89 | Dim fsplit As Variant 90 | fsplit = Split(base, EXTSEP) 91 | 92 | Ext = EXTSEP & fsplit(UBound(fsplit)) 93 | 94 | End If 95 | 96 | End Function 97 | '' 98 | ' Removes trailing SEP from path 99 | Public Function RTrimSep(ByVal Path As String) As String 100 | 101 | If right$(Path, 1) = SEP Then 102 | ' ends with SEP return all but end 103 | RTrimSep = Left$(Path, Len(Path) - 1) 104 | Else 105 | RTrimSep = Path 106 | End If 107 | 108 | End Function 109 | '' 110 | ' safely join two strings to form a path, inserting `SEP` if needed. 111 | Public Function JoinPath(ByVal rootPath As String, ByVal filePath As String) As String 112 | 113 | JoinPath = RTrimSep(rootPath) & SEP & filePath 114 | 115 | End Function 116 | '' 117 | ' Inserts `toAppend` in behind of the base name of string `filePath` but in 118 | ' front of the extension 119 | Public Function Append(ByVal filePath As String, ByVal toAppend As String) As String 120 | 121 | Dim fileExt As String 122 | fileExt = Ext(filePath) 123 | 124 | Dim Root As String 125 | Root = RootName(filePath) 126 | 127 | Dim base As String 128 | base = BaseName(filePath, suffix:=fileExt) 129 | 130 | Dim newName As String 131 | newName = base & toAppend & fileExt 132 | 133 | Append = JoinPath(Root, newName) 134 | 135 | End Function 136 | '' 137 | ' Inserts `toPrepend` in front of the base name of string `filePath` 138 | ' root/name.ext -> prepended -> root/prependedname.ext 139 | Public Function Prepend(ByVal filePath As String, ByVal toPrepend As String) As String 140 | 141 | Prepend = JoinPath(RootName(filePath), toPrepend & BaseName(filePath)) 142 | 143 | End Function 144 | '' 145 | ' Replaces current extension of `filePath` with `newExt` 146 | Public Function ChangeExt(ByVal filePath As String, ByVal newExt As String) As String 147 | 148 | Dim currentExt As String 149 | currentExt = Ext(filePath) 150 | 151 | Dim baseLength As String 152 | baseLength = Len(filePath) - Len(currentExt) 153 | 154 | ' ".ext" or "ext" -> "ext" 155 | newExt = Replace$(newExt, EXTSEP, vbNullString, 1, 1) 156 | 157 | ChangeExt = Left$(filePath, baseLength) & EXTSEP & newExt 158 | 159 | End Function 160 | '' 161 | ' Returns if the filePath contains a "?" or a "*" 162 | Public Function IsPattern(ByVal filePath As String) As Boolean 163 | IsPattern = (InStr(1, filePath, "?") + InStr(1, filePath, "*") <> 0) 164 | End Function 165 | '' 166 | ' Finds the longest filePath in pattern that is not a pattern. 167 | Public Function LongestRoot(ByVal pattern As String) As String 168 | 169 | Dim charPos As Integer 170 | charPos = InStr(1, pattern, "?") - 1 171 | 172 | Dim wildPos As Integer 173 | wildPos = InStr(1, pattern, "*") - 1 174 | 175 | Dim firstPatternPos As Integer 176 | If wildPos < 0 And charPos < 0 Then ' not a pattern 177 | firstPatternPos = Len(pattern) 178 | ElseIf wildPos < 0 Then 179 | firstPatternPos = charPos 180 | ElseIf charPos < 0 Then 181 | firstPatternPos = wildPos 182 | Else 183 | firstPatternPos = srch.Min(wildPos, charPos) 184 | End If 185 | 186 | LongestRoot = RootName(Left$(pattern, firstPatternPos)) 187 | 188 | End Function 189 | -------------------------------------------------------------------------------- /src/shutilB.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "shutilB" 2 | Option Explicit 3 | ' 4 | ' shutilB 5 | ' ======= 6 | ' 7 | ' Advanced filesystem operations for VBA. Routines of this variant will return `true` if 8 | ' operation is successful or `false` if failed. 9 | ' 10 | ' Copyright (c) 2014 Philip Wales 11 | ' This file (shutilB.bas) is distributed under the GPL-3.0 license. 12 | ' Obtain a copy of the license here: http://opensource.org/licenses/GPL-3.0 13 | ' 14 | ' It simply calls the respective `shutilE` method and uses boiler plate 15 | ' code to evaluate succes. Until procedures can be treated as data types 16 | ' better this boiler-plate code will remain. 17 | ' 18 | Public Function Move(ByVal src As String, ByVal dest As String, _ 19 | Optional createParent As Boolean = False) As Boolean 20 | 21 | Dim noError As Boolean 22 | On Error GoTo ErrHandler 23 | 24 | shutilE.Move src, dest, createParent 25 | noError = True 26 | 27 | CleanExit: 28 | Move = noError 29 | Exit Function 30 | 31 | ErrHandler: 32 | Err.Clear 33 | noError = False 34 | Resume CleanExit 35 | 36 | End Function 37 | Public Function Rename(ByVal aPath As String, ByVal newName As String) As Boolean 38 | 39 | Dim noError As Boolean 40 | On Error GoTo ErrHandler 41 | 42 | shutilE.Rename aPath, newName 43 | noError = True 44 | 45 | CleanExit: 46 | Rename = noError 47 | Exit Function 48 | 49 | ErrHandler: 50 | Err.Clear 51 | noError = False 52 | Resume CleanExit 53 | 54 | End Function 55 | Public Function Remove(ByVal filePath As String) As Boolean 56 | 57 | Dim noError As Boolean 58 | On Error GoTo ErrHandler 59 | 60 | shutilE.Remove filePath 61 | noError = True 62 | 63 | CleanExit: 64 | Remove = noError 65 | Exit Function 66 | 67 | ErrHandler: 68 | Err.Clear 69 | noError = False 70 | Resume CleanExit 71 | 72 | End Function 73 | Public Function MakeDir(ByVal filePath As String, _ 74 | Optional createParent As Boolean = False) As Boolean 75 | 76 | Dim noError As Boolean 77 | On Error GoTo ErrHandler 78 | 79 | shutilE.MakeDir filePath, createParent 80 | noError = True 81 | 82 | CleanExit: 83 | MakeDir = noError 84 | Exit Function 85 | 86 | ErrHandler: 87 | Err.Clear 88 | noError = False 89 | Resume CleanExit 90 | 91 | End Function 92 | Public Function CopyFile(ByVal src As String, ByVal dest As String, _ 93 | Optional createParent As Boolean = False) As Boolean 94 | 95 | Dim noError As Boolean 96 | On Error GoTo ErrHandler 97 | 98 | shutilE.CopyFile src, dest, createParent 99 | noError = True 100 | 101 | CleanExit: 102 | CopyFile = noError 103 | Exit Function 104 | 105 | ErrHandler: 106 | Err.Clear 107 | noError = False 108 | Resume CleanExit 109 | 110 | End Function 111 | 112 | -------------------------------------------------------------------------------- /src/shutilE.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "shutilE" 2 | Option Explicit 3 | ' 4 | ' shutilE 5 | ' ======= 6 | ' 7 | ' Advanced filesystem operations for VBA. This variant raises errors if 8 | ' attempted operation fails. 9 | ' 10 | ' Copyright (c) 2014 Philip Wales 11 | ' This file (shutilE.bas) is distributed under the GPL-3.0 license. 12 | ' Obtain a copy of the license here: http://opensource.org/licenses/GPL-3.0 13 | ' 14 | ' Scripting.FileSystemObject is slow and unstable since it relies on sending 15 | ' signals to ActiveX objects across the system. This module only uses built-in 16 | ' functions of Visual Basic, such as `Dir`, `Kill`, `Name`, etc. 17 | Public Enum ShutilErrors 18 | overWRiteRefusal 19 | failedDestroy 20 | failedCreate 21 | End Enum 22 | ' 23 | ' 24 | ' File System Modifications 25 | ' ------------------------- 26 | ' 27 | ' 28 | Public Sub Move(ByVal src As String, ByVal dest As String, _ 29 | Optional createParent As Boolean = False) 30 | 31 | On Error GoTo ErrHandler 32 | 33 | DestIsFolderFeature dest, src 34 | 35 | If createParent Then CreateRootPath dest 36 | 37 | Name src As dest 38 | 39 | If Not fsview.Exists(dest) Then 40 | OnFailedCreateError "Move", "Name As" 41 | End If 42 | 43 | If fsview.Exists(src) Then 44 | OnFailedDestroyError "Move", "Name As" 45 | End If 46 | 47 | CleanExit: 48 | Exit Sub 49 | 50 | ErrHandler: 51 | Select Case Err.Number 52 | Case Else 53 | ReRaiseError Err 54 | End Select 55 | 56 | End Sub 57 | Public Sub Rename(ByVal src As String, ByVal newName As String) 58 | 59 | On Error GoTo ErrHandler 60 | 61 | Debug.Assert newName = Path.BaseName(newName) 62 | 63 | Dim Root As String 64 | Root = RootName(src) 65 | 66 | Dim dest As String 67 | dest = Path.JoinPath(Root, newName) 68 | 69 | Move src, dest 70 | 71 | CleanExit: 72 | Exit Sub 73 | 74 | ErrHandler: 75 | Select Case Err.Number 76 | Case Else 77 | ReRaiseError Err 78 | End Select 79 | 80 | End Sub 81 | Public Sub Remove(ByVal aPath As String) 82 | On Error GoTo ErrHandler 83 | 84 | Kill aPath 85 | 86 | If fsview.Exists(aPath) Then 87 | OnFailedDestroyError "Remove", "Kill" 88 | End If 89 | 90 | CleanExit: 91 | Exit Sub 92 | 93 | ErrHandler: 94 | Select Case Err.Number 95 | Case Else 96 | ReRaiseError Err 97 | End Select 98 | 99 | End Sub 100 | Public Sub MakeDir(ByVal folderPath As String, Optional ByVal createParent As Boolean = False) 101 | 102 | Dim check As Boolean 103 | On Error GoTo ErrHandler 104 | 105 | If createParent Then CreateRootPath folderPath 106 | MkDir folderPath 107 | 108 | If Not fsview.FolderExists(folderPath) Then 109 | OnFailedCreateError "MakeDir", "MkDir" 110 | End If 111 | 112 | CleanExit: 113 | Exit Sub 114 | 115 | ErrHandler: 116 | Select Case Err.Number 117 | Case Else 118 | ReRaiseError Err 119 | End Select 120 | 121 | End Sub 122 | Public Sub CopyFile(ByVal src As String, ByVal dest As String, _ 123 | Optional createParent As Boolean = False) 124 | 125 | On Error GoTo ErrHandler 126 | 127 | DestIsFolderFeature dest, src 128 | 129 | If fsview.FileExists(dest) Then 130 | OnNoOverwriteError "CopyFile" 131 | End If 132 | 133 | If createParent Then CreateRootPath dest 134 | FileCopy src, dest 135 | 136 | If Not fsview.FileExists(dest) Then 137 | OnFailedCreateError "CopyFile", "FileCopy" 138 | End If 139 | 140 | CleanExit: 141 | Exit Sub 142 | 143 | ErrHandler: 144 | Select Case Err.Number 145 | Case Else 146 | ReRaiseError Err 147 | End Select 148 | 149 | End Sub 150 | Private Sub CreateRootPath(ByVal aPath As String) 151 | 152 | Dim parentFolder As String 153 | parentFolder = Path.RootName(aPath) 154 | 155 | If Not fsview.FolderExists(parentFolder) Then 156 | MakeDir parentFolder, createParent:=True 157 | End If 158 | 159 | End Sub 160 | Private Sub DestIsFolderFeature(ByRef dest As String, _ 161 | ByVal src As String) 162 | 163 | If right$(dest, 1) = Path.SEP Or fsview.FolderExists(dest) Then 164 | dest = Path.JoinPath(dest, Path.BaseName(src)) 165 | End If 166 | 167 | End Sub 168 | ' 169 | ' ### Custom Error Messages 170 | ' 171 | Private Sub ReRaiseError(ByRef e As ErrObject) 172 | 173 | Err.Raise e.Number, e.source, e.description, e.HelpFile, e.HelpContext 174 | 175 | End Sub 176 | Private Sub OnFailedCreateError(ByVal method As String, ByVal operation As String) 177 | 178 | Err.Raise ShutilErrors.failedCreate, method, _ 179 | "Destination does not exist after errorless `" & operation & "`" 180 | 181 | End Sub 182 | Private Sub OnFailedDestroyError(ByVal method As String, ByVal operation As String) 183 | 184 | Err.Raise ShutilErrors.failedDestroy, method, _ 185 | "Destination still exists after errorless `" & operation & "`" 186 | 187 | End Sub 188 | Private Sub OnNoOverwriteError(ByVal method As String) 189 | 190 | Err.Raise ShutilErrors.overWRiteRefusal, method, _ 191 | "Will not overwrite file at destination. Remove it first if desired." 192 | 193 | End Sub 194 | -------------------------------------------------------------------------------- /src/sort.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "sort" 2 | Option Explicit 3 | 4 | ' sort 5 | ' ==== 6 | ' 7 | ' Contains in-place sorting algorithms for Arrays. 8 | ' ** ARRAYS ONLY ** 9 | ' 10 | ' Helper Methods 11 | ' -------------- 12 | ' 13 | '' 14 | ' Swap should work on an array or any two variables. It 15 | ' will not work on elements of sequence objects as the 16 | ' accessors of those return a value not a reference. 17 | ' 18 | ' x = "a": y = "b" 19 | ' Swap x, y ' x="b", y="a" 20 | ' 21 | ' a = Array("a", "b") 22 | ' Swap a(0), a(1) ' a = [b, a] 23 | ' 24 | Private Sub Swap(ByRef x As Variant, ByRef y As Variant) 25 | 26 | Dim t 27 | Assign t, x 28 | Assign x, y 29 | Assign y, t 30 | 31 | End Sub 32 | ' 33 | ' Reversal 34 | ' -------- 35 | ' 36 | Public Sub Reverse(ByRef sequence() As Variant, _ 37 | ByVal lower As Long, ByVal upper As Long) 38 | 39 | Do While lower < upper 40 | 41 | Swap sequence(lower), sequence(upper) 42 | 43 | lower = lower + 1 44 | upper = upper - 1 45 | 46 | Loop 47 | 48 | End Sub 49 | ' 50 | ' Sorting 51 | ' ------- 52 | ' 53 | ' ### Bubble Sort 54 | ' 55 | Public Sub BubbleSort(ByRef sequence() As Variant, _ 56 | ByVal lower As Long, ByVal upper As Long) 57 | 58 | Dim upperIt As Long 59 | For upperIt = upper To lower + 1 Step -1 60 | 61 | Dim hasSwapped As Boolean 62 | hasSwapped = False 63 | 64 | Dim Bubble As Long 65 | For Bubble = lower To upperIt - 1 66 | 67 | If sequence(Bubble) > sequence(Bubble + 1) Then 68 | 69 | Swap sequence(Bubble), sequence(Bubble + 1) 70 | hasSwapped = True 71 | 72 | End If 73 | 74 | Next Bubble 75 | 76 | If Not hasSwapped Then Exit Sub 77 | 78 | Next upperIt 79 | 80 | End Sub 81 | ' 82 | ' ### Quick Sort 83 | ' 84 | Public Sub QuickSort(ByRef sequence() As Variant, ByVal lower As Long, ByVal upper As Long) 85 | 86 | ' length <= 1; already sorted 87 | If lower >= upper Then Exit Sub 88 | 89 | ' no special pivot selection used 90 | Swap sequence((lower + upper) / 2), sequence(upper) 91 | 92 | ' pivot is at the end 93 | Dim pivot As Variant 94 | pivot = sequence(upper) 95 | 96 | Dim middle As Integer 97 | middle = Partition(sequence, lower, upper, pivot) 98 | 99 | ' don't swap if they are the same (pivot is single greatest) 100 | If middle <> upper Then Swap sequence(upper), sequence(middle) 101 | 102 | ' Omit the location of the pivot 103 | QuickSort sequence, lower, middle - 1 104 | 105 | ' it is exactly where it should be. 106 | QuickSort sequence, middle + 1, upper 107 | ' which is the magic of the quick sort 108 | 109 | End Sub 110 | Private Function Partition(ByRef sequence() As Variant, ByVal lower As Long, _ 111 | ByVal upper As Long, ByVal pivot As Variant) As Long 112 | 113 | Do While lower < upper 114 | 115 | Do While sequence(lower) < pivot And lower < upper 116 | lower = lower + 1 117 | Loop 118 | 119 | ' right claims pivot as it is at the end 120 | Do While sequence(upper) >= pivot And lower < upper 121 | upper = upper - 1 122 | Loop 123 | 124 | ' don't swap if they are the same 125 | If lower <> upper Then Swap sequence(lower), sequence(upper) 126 | 127 | Loop 128 | Partition = lower 129 | 130 | End Function 131 | ' 132 | ' ### Merge Sort? 133 | ' 134 | ' 135 | ' ### Insert Sort? 136 | ' 137 | ' 138 | -------------------------------------------------------------------------------- /src/srch.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "srch" 2 | Option Explicit 3 | 4 | ' srch 5 | ' ==== 6 | ' 7 | ' ### Max|Min 8 | ' 9 | Private Function GenericExtremum(ByVal lg As CompareResult, _ 10 | ByVal sequence As Linear) As Long 11 | 12 | Dim result As Long 13 | result = sequence.LowerBound 14 | 15 | Dim curVal 16 | Assign curVal, sequence.Item(result) 17 | 18 | Dim i As Long 19 | For i = sequence.LowerBound To sequence.UpperBound 20 | 21 | If Not (Compare(curVal, sequence.Item(i)) = lg) Then 22 | 23 | result = i 24 | Assign curVal, sequence.Item(result) 25 | 26 | End If 27 | 28 | Next 29 | 30 | GenericExtremum = result 31 | 32 | End Function 33 | '' 34 | ' MaxIndex: Returns the index of `sequence` that has the maximum value 35 | Public Function MaxIndex(ByVal sequence As Linear) As Long 36 | 37 | MaxIndex = GenericExtremum(gt, sequence) 38 | 39 | End Function 40 | '' 41 | ' MaxValue: Returns the value of `sequence` that is the Maximum 42 | ' Uses `MaxIndex` 43 | Public Function MaxValue(ByVal sequence As Linear) As Variant 44 | 45 | Assign MaxValue, sequence.Item(MaxIndex(sequence)) 46 | 47 | End Function 48 | Public Function Max(ParamArray vals() As Variant) As Variant 49 | 50 | Assign Max, MaxValue(List.Copy(vals)) 51 | 52 | End Function 53 | '' 54 | ' MinIndex 55 | Public Function MinIndex(ByVal sequence As Linear) As Long 56 | 57 | MinIndex = GenericExtremum(lt, sequence) 58 | 59 | End Function 60 | '' 61 | ' MinValue 62 | Public Function MinValue(ByVal sequence As Linear) As Variant 63 | 64 | Assign MinValue, sequence.Item(MinIndex(sequence)) 65 | 66 | End Function 67 | Public Function Min(ParamArray vals() As Variant) As Variant 68 | 69 | Assign Min, MinValue(List.Copy(vals)) 70 | 71 | End Function 72 | ' 73 | ' ### Value Specific 74 | ' 75 | '' 76 | ' LinearSearch: 77 | Public Function LinearSearch(ByVal sought, ByVal sequence As Linear) As Maybe 78 | 79 | Dim i As Long 80 | For i = sequence.LowerBound To sequence.UpperBound 81 | 82 | If Equals(sequence.Item(i), sought) Then 83 | Set LinearSearch = Maybe.Some(i) 84 | Exit Function 85 | End If 86 | 87 | Next i 88 | 89 | Set LinearSearch = Maybe.None 90 | 91 | End Function 92 | '' 93 | ' Binary Search: Sequence must be sorted. Has the option of returning where the 94 | ' value should be instead of not found. 95 | Public Function BinarySearch(ByVal sought, ByVal sortedSequence As Linear, _ 96 | Optional ByVal nearest As Boolean = False) As Maybe 97 | 98 | Dim lower As Long 99 | lower = sortedSequence.LowerBound 100 | 101 | Dim upper As Long 102 | upper = sortedSequence.UpperBound 103 | 104 | Do While lower < upper 105 | 106 | Dim middle As Long 107 | middle = (lower + upper) \ 2 108 | 109 | Dim curVal 110 | Assign curVal, sortedSequence.Item(middle) 111 | 112 | If GreaterThanOrEqualTo(curVal, sought) Then 113 | upper = middle 114 | Else 115 | lower = middle + 1 116 | End If 117 | 118 | Loop 119 | 120 | Dim found As Boolean 121 | found = Equals(sortedSequence.Item(upper), sought) 122 | 123 | Set BinarySearch = Maybe.MakeIf(found Or nearest, upper) 124 | 125 | End Function 126 | -------------------------------------------------------------------------------- /src/vbeCodeModule.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "vbeCodeModule" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = True 9 | Attribute VB_Exposed = True 10 | ' requires Microsoft Visual Basic for Applications Extensibility 5.3 library 11 | Option Explicit 12 | 13 | Private mCodeModule As CodeModule 14 | Private mVbeProcedures As vbeProcedures 15 | 16 | Public Property Get CodeModule() As CodeModule 17 | Set CodeModule = mCodeModule 18 | End Property 19 | 20 | Public Property Let CodeModule(ByRef codeMod As CodeModule) 21 | Me.Initialize codeMod 22 | End Property 23 | 24 | Public Property Get vbeProcedures() 25 | Set vbeProcedures = mVbeProcedures 26 | End Property 27 | 28 | Public Sub Insert(ComponentType As vbext_ComponentType) 29 | 'Dim project As VBProject 30 | 'Set project = VBIDE.VBE 31 | 'project.VBComponents.Add ComponentType 32 | End Sub 33 | 34 | Public Function Create(codeMod As CodeModule) As vbeCodeModule 35 | ' allows calls from other projects without breaking the exisiting API 36 | 37 | Set Create = New vbeCodeModule 38 | Create.Initialize codeMod 39 | End Function 40 | 41 | Public Sub Initialize(codeMod As CodeModule) 42 | Set mCodeModule = codeMod 43 | Set mVbeProcedures = GetProcedures(mCodeModule) 44 | End Sub 45 | 46 | Private Sub Class_Terminate() 47 | Set mVbeProcedures = Nothing 48 | Set mCodeModule = Nothing 49 | End Sub 50 | 51 | Private Function GetProcedures(codeMod As CodeModule) As vbeProcedures 52 | Dim procName As String 53 | Dim procs As New vbeProcedures 54 | Dim proc As vbeProcedure 55 | Dim line As String 56 | Dim procKind As vbext_ProcKind 57 | 58 | Dim lineNumber As Long 59 | For lineNumber = 1 To codeMod.CountOfLines 60 | line = codeMod.lines(lineNumber, 1) 61 | If IsSignature(line) Then 62 | procKind = GetProcedureType(line) 63 | procName = codeMod.ProcOfLine(lineNumber, procKind) 64 | 65 | Set proc = New vbeProcedure 66 | proc.Initialize procName, codeMod, procKind 67 | End If 68 | Next lineNumber 69 | 70 | Set GetProcedures = procs 71 | 72 | End Function 73 | 74 | Private Function GetProcedureType(signatureLine As String) As vbext_ProcKind 75 | If InStr(1, signatureLine, "Property Get") > 0 Then 76 | GetProcedureType = vbext_pk_Get 77 | ElseIf InStr(1, signatureLine, "Property Let") > 0 Then 78 | GetProcedureType = vbext_pk_Let 79 | ElseIf InStr(1, signatureLine, "Property Set") > 0 Then 80 | GetProcedureType = vbext_pk_Set 81 | ElseIf InStr(1, signatureLine, "Sub") > 0 Or InStr(1, signatureLine, "Function") > 0 Then 82 | GetProcedureType = vbext_pk_Proc 83 | Else 84 | Const InvalidProcedureCallOrArgument As Long = 5 85 | Err.Raise InvalidProcedureCallOrArgument 86 | End If 87 | End Function 88 | 89 | Private Function IsSignature(line As String) As Boolean 90 | 91 | If line = vbNullString Then Exit Function 92 | If IsDeclaration(line) Then Exit Function 93 | 94 | ' pattern: 95 | ' any number of characters; 96 | ' Doesn't start with a comment; 97 | ' any number of characters; 98 | ' space; 99 | ' word; 100 | ' space; 101 | ' any number of characters 102 | 103 | If line Like "[!']* Property *" Then 104 | IsSignature = True 105 | ElseIf line Like "[!']* Function *" Then 106 | IsSignature = True 107 | ElseIf line Like "[!']* Sub *" Then 108 | IsSignature = True 109 | End If 110 | 111 | End Function 112 | 113 | Private Function IsDeclaration(line As String) As Boolean 114 | IsDeclaration = InStr(1, line, "Const") > 0 Or InStr(1, line, "Dim") > 0 115 | End Function 116 | -------------------------------------------------------------------------------- /src/vbeProcedures.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "vbeProcedures" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = True 9 | Attribute VB_Exposed = True 10 | Option Explicit 11 | 12 | ' ******************************************************************* 13 | ' * Collection Class Wrapper for vbeProcedure objects 14 | ' * Author: Christopher J. McClellan 15 | ' * DateCreated: 5/30/2014 16 | ' ******************************************************************* 17 | 18 | Private mCollection As Collection 19 | 20 | Public Function Create() As vbeProcedures 21 | Set Create = New vbeProcedures 22 | End Function 23 | 24 | Public Sub Clear() 25 | Attribute Clear.VB_Description = "Clears the collection and removes any procedure in it from memory." 26 | killVbeProcs 27 | Set mCollection = New Collection 28 | End Sub 29 | 30 | Public Function Add(ByRef vbeProc As vbeProcedure, Optional ByVal key As Variant) 31 | If IsMissing(key) Then 32 | mCollection.Add vbeProc 33 | Else 34 | mCollection.Add vbeProc, key 35 | End If 36 | End Function 37 | 38 | Public Function Remove(ByVal index As Variant) 39 | mCollection.Remove (index) 40 | End Function 41 | 42 | Public Function Item(ByVal index As Variant) As vbeProcedure 43 | Attribute Item.VB_Description = "Gets the procedure at the specified index." 44 | Attribute Item.VB_UserMemId = 0 45 | Set Item = mCollection(index) 46 | End Function 47 | 48 | Public Function Count() As Long 49 | Count = mCollection.Count 50 | End Function 51 | 52 | Public Function NewEnum() As IUnknown 53 | Attribute NewEnum.VB_UserMemId = -4 54 | Set NewEnum = mCollection.[_NewEnum] 55 | End Function 56 | 57 | Private Sub Class_Initialize() 58 | Set mCollection = New Collection 59 | End Sub 60 | 61 | Private Sub Class_Terminate() 62 | killVbeProcs 63 | Set mCollection = Nothing 64 | End Sub 65 | 66 | Private Sub killVbeProcs() 67 | Dim proc As vbeProcedure 68 | If Not mCollection Is Nothing Then 69 | For Each proc In mCollection 70 | Set proc = Nothing 71 | Next proc 72 | End If 73 | End Sub 74 | 75 | -------------------------------------------------------------------------------- /test/BatteryApplicable.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "BatteryApplicable" 2 | '@TestModule 3 | Option Explicit 4 | Option Private Module 5 | Private Assert As New Rubberduck.AssertClass 6 | ' 7 | ' Applicable Battery 8 | ' ================== 9 | ' 10 | Public Sub Battery(ByVal f As Applicable, ByVal x, ByVal y) 11 | 12 | TestApply f, x, y 13 | 14 | End Sub 15 | ' 16 | ' Tests 17 | ' ----- 18 | ' 19 | Private Sub TestApply(ByVal f As Applicable, ByVal x, ByVal y) 20 | 21 | Assert.AreEqual y, f.Apply(x) 22 | 23 | End Sub 24 | Private Sub TestPartial(ByVal f As Applicable, ByVal x, ByVal y) 25 | 26 | Assert.AreEqual y, f.Partial(x).Apply() 27 | Assert.AreEqual y, f.Partial(Empty).Apply(x) 28 | Assert.AreEqual y, f.AsPartial(xArray(x)).Apply() 29 | Assert.AreEqual y, f.AsPartial(xArray(Empty)).Apply(x) 30 | 31 | End Sub 32 | Private Sub TestDelay(ByVal f As Applicable, ByVal x, ByVal y) 33 | 34 | Assert.AreEqual y, f.Delay(x).Evaluate() 35 | Assert.AreEqual y, f.AsDelay(xArray(x)).Evaluate() 36 | 37 | End Sub 38 | -------------------------------------------------------------------------------- /test/BatteryIterable.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "BatteryIterable" 2 | '@TestModule 3 | Option Explicit 4 | Option Private Module 5 | Private Assert As New Rubberduck.AssertClass 6 | ' 7 | ' Iterable Battery 8 | ' ================ 9 | ' 10 | Public Sub Battery(ByVal itbl As Linear) 11 | 12 | LowerLTEQUpper itbl 13 | ItemInRange itbl 14 | ItemLTLower itbl 15 | ItemGTUpper itbl 16 | 17 | End Sub 18 | ' 19 | ' Private Procedures 20 | ' ------------------ 21 | ' 22 | ' ### Tests 23 | ' 24 | Private Sub LowerLTEQUpper(ByVal itbl As Linear) 25 | 26 | Dim lower As Long 27 | lower = itbl.LowerBound 28 | 29 | Dim upper As Long 30 | upper = itbl.UpperBound 31 | 32 | Dim TestPass As Boolean 33 | TestPass = (lower <= upper) 34 | 35 | Dim msg As String 36 | msg = "Lower(" & lower & ") <= Upper(" & upper & ")" & _ 37 | " For iterable(" & defshow.Show(itbl) & ")" 38 | 39 | Assert.IsTrue TestPass, msg 40 | 41 | End Sub 42 | Private Sub ItemInRange(ByVal itbl As Linear) 43 | 44 | Dim lower As Long 45 | lower = itbl.LowerBound 46 | 47 | Dim upper As Long 48 | upper = itbl.UpperBound 49 | 50 | Dim msg As String 51 | msg = "ItemInRange" 52 | 53 | Dim x 54 | On Error GoTo Fail 55 | Assign x, GetRandomItem(itbl, lower, upper) 56 | On Error GoTo 0 57 | 58 | Assert.IsFalse IsEmpty(x), msg 59 | 60 | CleanExit: 61 | Exit Sub 62 | Fail: 63 | Assert.Fail msg 64 | Resume CleanExit 65 | 66 | End Sub 67 | Private Sub ItemLTLower(ByVal itbl As Linear) 68 | 69 | Dim lower As Long 70 | lower = itbl.LowerBound 71 | 72 | Dim msg As String 73 | msg = "ItemLTLower" 74 | 75 | Dim x 76 | On Error GoTo Pass 77 | Assign x, itbl.Item(lower - 1) 78 | On Error GoTo 0 79 | 80 | Assert.Fail msg 81 | 82 | CleanExit: 83 | Exit Sub 84 | Pass: 85 | Assert.AreEqual Err.Number, CLng(9), msg 86 | 87 | End Sub 88 | Private Sub ItemGTUpper(ByVal itbl As Linear) 89 | 90 | Dim upper As Long 91 | upper = itbl.UpperBound 92 | 93 | Dim msg As String 94 | msg = "ItemGTUpper" 95 | 96 | Dim x 97 | On Error GoTo Pass 98 | Assign x, itbl.Item(upper + 1) 99 | On Error GoTo 0 100 | 101 | Assert.Fail msg 102 | 103 | CleanExit: 104 | Exit Sub 105 | Pass: 106 | Assert.AreEqual Err.Number, CLng(9), msg 107 | 108 | End Sub 109 | ' 110 | ' ### Helper Functions 111 | ' 112 | Private Function GetRandomItem(ByVal itbl As Linear, ByVal lower As Long, _ 113 | ByVal upper As Long) As Variant 114 | 115 | Dim ri As Long 116 | ri = RandomIndex(lower, upper) 117 | Assign GetRandomItem, itbl.Item(ri) 118 | 119 | End Function 120 | Private Function RandomIndex(ByVal lower As Long, ByVal upper As Long) As Long 121 | 122 | RandomIndex = Math.Round((upper - lower + 1) * Math.Rnd()) + lower 123 | 124 | End Function 125 | -------------------------------------------------------------------------------- /test/BatteryMonadic.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "BatteryMonadic" 2 | '@TestModule 3 | Option Explicit 4 | Option Private Module 5 | Private Assert As New Rubberduck.AssertClass 6 | ' 7 | ' Monadic Battery 8 | ' =============== 9 | ' 10 | Public Sub Battery(ByVal monad As Monadic) 11 | 12 | Dim x 13 | x = 2 14 | 15 | Dim f As Applicable 16 | Set f = Lambda.FromShort("_ * 2") 17 | 18 | Dim g As Applicable 19 | Set g = Lambda.FromShort("_ + 13") 20 | 21 | Dim u As Applicable 22 | Set u = ApplyUnit(monad) 23 | 24 | Dim uf As Applicable 25 | Set uf = Composed.Make(u, f) 26 | 27 | Dim ug As Applicable 28 | Set ug = Composed.Make(u, g) 29 | 30 | Dim m As Monadic 31 | Set m = u.Apply(x) 32 | 33 | Associativity m, uf, ug 34 | LeftUnit m, x, uf 35 | RightUnit m 36 | 37 | End Sub 38 | ' 39 | ' Tests 40 | ' ----- 41 | ' 42 | ' TODO: Closure 43 | ' 44 | Private Sub Associativity(ByVal m As Monadic, ByVal f As Applicable, _ 45 | ByVal g As Applicable) 46 | 47 | ' monad.Bind(f).Bind(g) == monad.Bind(x => f(x).Bind(g)) 48 | Dim leftSide As Equatable 49 | Set leftSide = m.Bind(f).Bind(g) 50 | 51 | Dim nc As Applicable ' .Bind(g) 52 | Set nc = OnObject.Create("Bind", VbMethod, g) 53 | 54 | Dim h As Applicable ' nc.Apply(f(x)) == f(x).Bind(g) 55 | Set h = Composed.Make(nc, f) 56 | 57 | Dim rightSide As Equatable 58 | Set rightSide = m.Bind(h) 59 | 60 | Dim result As Boolean 61 | result = Equals(leftSide, rightSide) 62 | Assert.IsTrue result 63 | 64 | End Sub 65 | ' I don't think I have this correct 66 | Private Sub LeftUnit(ByVal m As Monadic, ByVal x, ByVal f As Applicable) 67 | ' unit(x).Bind(f) == f(x) 68 | 69 | Dim leftSide As Equatable 70 | Set leftSide = m.Unit(x).Bind(f) 71 | 72 | Dim rightSide As Equatable 73 | Set rightSide = f.Apply(x) 74 | 75 | Dim result As Boolean 76 | result = Equals(leftSide, rightSide) 77 | Assert.IsTrue result 78 | 79 | End Sub 80 | Private Sub RightUnit(ByVal m As Monadic) 81 | ' m.Bind(unit) = m 82 | 83 | Dim u As Applicable 84 | Set u = OnArgs.Make("Unit", VbMethod, m) 85 | 86 | Dim leftSide As Equatable 87 | Set leftSide = m.Bind(u) 88 | 89 | Dim result As Boolean 90 | result = Equals(leftSide, m) 91 | Assert.IsTrue result 92 | 93 | End Sub 94 | -------------------------------------------------------------------------------- /test/BatterySetLike.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "BatterySetLike" 2 | Option Explicit 3 | Private Assert As New Rubberduck.AssertClass 4 | 5 | Public Sub Battery(ByVal setA As SetLike, _ 6 | ByVal setB As SetLike, _ 7 | ByVal setC As SetLike, _ 8 | ByVal emptySet As SetLike, _ 9 | ByVal super As SetLike) 10 | 11 | IdentityLaw setA, super, emptySet 12 | DomainLaw setA, super, emptySet 13 | IdempotentLaw setA 14 | CommutativeLaw setA, setB 15 | AssociatveLaw setA, setB, setC 16 | DistributiveLaw setA, setB, setC 17 | 18 | End Sub 19 | 20 | Private Sub IdentityLaw(ByVal setA As SetLike, ByVal super As SetLike, ByVal emptySet As SetLike) 21 | 22 | ' A U 0 = A 23 | Assert.IsTrue Equals(setA.Union(emptySet), setA) 24 | 'A n U = A 25 | Assert.IsTrue Equals(setA.Intersect(super), setA) 26 | 27 | End Sub 28 | Private Sub DomainLaw(ByVal setA As SetLike, ByVal super As SetLike, ByVal emptySet As SetLike) 29 | 30 | ' A u U = U 31 | Assert.IsTrue Equals(setA.Union(super), super) 32 | ' A n 0 = 0 33 | Assert.IsTrue Equals(setA.Intersect(emptySet), emptySet) 34 | 35 | End Sub 36 | Private Sub IdempotentLaw(ByVal setA As SetLike) 37 | 38 | ' A u A = A 39 | Assert.IsTrue Equals(setA.Union(setA), setA) 40 | ' A n A = A 41 | Assert.IsTrue Equals(setA.Intersect(setA), setA) 42 | 43 | End Sub 44 | Private Sub CommutativeLaw(ByVal setA As SetLike, ByVal setB As SetLike) 45 | 46 | ' A u B = B u A 47 | Assert.IsTrue Equals(setA.Union(setB), setB.Union(setA)) 48 | ' A n B = B n A 49 | Assert.IsTrue Equals(setA.Intersect(setB), setB.Intersect(setA)) 50 | 51 | End Sub 52 | Private Sub AssociatveLaw(ByVal setA As SetLike, ByVal setB As SetLike, ByVal setC As SetLike) 53 | 54 | ' (A u B) u C = A u (B u C) 55 | Dim lhsLaw1 As Equatable 56 | Set lhsLaw1 = setA.Union(setB).Union(setC) 57 | 58 | Dim rhsLaw1 As Equatable 59 | Set rhsLaw1 = setA.Union(setB.Union(setC)) 60 | 61 | Assert.IsTrue Equals(lhsLaw1, rhsLaw1) 62 | 63 | ' (A n B) n C = A n (B n C) 64 | Dim lhsLaw2 As Equatable 65 | Set lhsLaw2 = setA.Intersect(setB).Intersect(setC) 66 | 67 | Dim rhsLaw2 As Equatable 68 | Set rhsLaw2 = setA.Intersect(setB.Intersect(setC)) 69 | 70 | Assert.IsTrue Equals(lhsLaw2, rhsLaw2) 71 | 72 | End Sub 73 | Private Sub DistributiveLaw(ByVal setA As SetLike, ByVal setB As SetLike, ByVal setC As SetLike) 74 | 75 | ' A u (B n C) = (A u B) n (A u C) 76 | Dim lhsLaw1 As Equatable 77 | Set lhsLaw1 = setA.Union(setB.Intersect(setC)) 78 | 79 | Dim rhsLaw1 As Equatable 80 | Set rhsLaw1 = setA.Union(setB).Intersect(setA.Union(setC)) 81 | 82 | Assert.IsTrue Equals(lhsLaw1, rhsLaw1) 83 | 84 | 85 | ' A n (B u C) = (A n B) u (A n C) 86 | Dim lhsLaw2 As Equatable 87 | Set lhsLaw2 = setA.Intersect(setB.Union(setC)) 88 | 89 | Dim rhsLaw2 As Equatable 90 | Set rhsLaw2 = setA.Intersect(setB).Union(setA.Intersect(setC)) 91 | 92 | Assert.IsTrue Equals(lhsLaw2, rhsLaw2) 93 | 94 | End Sub 95 | -------------------------------------------------------------------------------- /test/TestByName.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "TestByName" 2 | '@TestModule 3 | Option Explicit 4 | Option Private Module 5 | Private Assert As New Rubberduck.AssertClass 6 | 7 | 8 | '@TestMethod 9 | Public Sub ByNameCreateTest() 10 | 11 | Dim op As OnArgs 12 | Set op = OnArgs.Make("GetItem", VbMethod, Dict.Create(Assoc.Make("key", "value"))) 13 | 14 | Dim bn As ByName 15 | Set bn = ByName.Create(op, "key", "default") 16 | Assert.AreEqual bn.Evaluate, "value" 17 | 18 | End Sub 19 | '@TestMethod 20 | Public Sub ByNameMakeTest() 21 | 22 | Dim op As OnArgs 23 | Set op = OnArgs.Make("GetItem", VbMethod, Dict.Create(Assoc.Make("key", "value"))) 24 | 25 | Dim bn As ByName 26 | Set bn = ByName.Make(op, carray(Array("none", "default"))) 27 | Assert.AreEqual bn.Evaluate, "default" 28 | 29 | End Sub 30 | -------------------------------------------------------------------------------- /test/TestComposed.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "TestComposed" 2 | '@TestModule 3 | Option Explicit 4 | Option Private Module 5 | Private Assert As New Rubberduck.AssertClass 6 | 7 | '@TestMethod 8 | Public Sub ComposeTest() 9 | 10 | Dim innerOp As Lambda 11 | Set innerOp = Lambda.FromShort("_ + 12") 12 | 13 | Dim outerOp As Lambda 14 | Set outerOp = Lambda.FromShort("_ * 10") 15 | 16 | Dim comp As Composed 17 | Set comp = Composed.Make(outerOp, innerOp) 18 | 19 | BatteryApplicable.Battery comp, 5, 170 20 | 21 | End Sub 22 | '@TestMethod 23 | Public Sub ComposeRecurseTest() 24 | 25 | Dim firstOp As Lambda 26 | Set firstOp = Lambda.FromShort("_ + 12") 27 | 28 | Dim secondOp As Lambda 29 | Set secondOp = Lambda.FromShort("_ * 10") 30 | 31 | Dim comp As Composed 32 | Set comp = Composed.Make(secondOp, firstOp) 33 | 34 | Dim thirdOp As Lambda 35 | Set thirdOp = Lambda.FromShort("_ \ 2") 36 | 37 | BatteryApplicable.Battery Composed.Make(thirdOp, comp), 5, 85 38 | 39 | End Sub 40 | -------------------------------------------------------------------------------- /test/TestDict.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "TestDict" 2 | '@TestModule 3 | Option Explicit 4 | Option Private Module 5 | Private Assert As New Rubberduck.AssertClass 6 | 7 | ' 8 | ' Constructors 9 | ' ------------ 10 | ' 11 | Private Sub DictTestEmpty(ByVal d As Dict) 12 | Assert.IsNotNothing d, "Empty Dict is not nothing" 13 | Assert.AreEqual CLng(0), d.Count, "Empty Dict count = 3" 14 | Assert.AreEqual "Dict()", d.Show, "Empty Dict Show" 15 | End Sub 16 | 17 | Private Sub DictTestNonEmpty(ByVal d As Dict) 18 | Assert.IsNotNothing d, "NonEmpty Dict is not nothing" 19 | Assert.AreEqual CLng(3), d.Count, "NonEmpty Dict count = 3" 20 | Assert.AreEqual "Dict(1 -> 2, 3 -> 4, 5 -> 6)", d.Show, "NonEmpty Dict Show" 21 | End Sub 22 | 23 | '@TestMethod 24 | Public Sub DictEmptyFromAssocs() 25 | DictTestEmpty Dict.Create() 26 | End Sub 27 | 28 | '@TestMethod 29 | Public Sub DictNonEmptyFromAssocs() 30 | DictTestNonEmpty Dict.Create(Assoc.Make(1, 2), Assoc.Make(3, 4), Assoc.Make(5, 6)) 31 | End Sub 32 | 33 | '@TestMethod 34 | Public Sub DictCreateEmptyDict() 35 | DictTestEmpty Dict.Create 36 | End Sub 37 | 38 | '@TestMethod 39 | Public Sub DictCreateNonEmptyDict() 40 | DictTestNonEmpty Dict.Create(Assoc.Make(1, 2), Assoc.Make(3, 4), Assoc.Make(5, 6)) 41 | End Sub 42 | 43 | '@TestMethod 44 | Public Sub DictCopyEmptyDict() 45 | DictTestEmpty Dict.Copy(Dict.Create()) 46 | End Sub 47 | 48 | '@TestMethod 49 | Public Sub DictCopyNonEmptyDict() 50 | DictTestNonEmpty Dict.Copy(Dict.Create(Assoc.Make(1, 2), Assoc.Make(3, 4), Assoc.Make(5, 6))) 51 | End Sub 52 | 53 | '@TestMethod 54 | Public Sub DictCopyIsCopy() 55 | Dim orig As Dict, cpy As Dict 56 | Set orig = Dict.Create 57 | Set cpy = Dict.Copy(orig) 58 | Assert.AreNotEqual ObjPtr(orig), ObjPtr(cpy), "Copy is a new instance" 59 | End Sub 60 | 61 | '@TestMethod 62 | Public Sub DictEmptyFromLists() 63 | DictTestEmpty Dict.FromLists(List.Create(), List.Create()) 64 | End Sub 65 | 66 | '@TestMethod 67 | Public Sub DictNonEmptyFromLists() 68 | DictTestNonEmpty Dict.FromLists(List.Create(1, 3, 5), List.Create(2, 4, 6)) 69 | End Sub 70 | 71 | 72 | '@TestMethod 73 | Public Sub DictKeysAndValues() 74 | 75 | Dim ks As List 76 | Set ks = List.Create(1, 2, 3) 77 | 78 | Dim vs As List 79 | Set vs = List.Create("a", "b", "c") 80 | 81 | Dim d As Dict 82 | Set d = Dict.FromLists(ks, vs) 83 | 84 | Assert.IsTrue ks.Equals(d.Keys) 85 | Assert.IsTrue vs.Equals(d.Values) 86 | 87 | End Sub 88 | -------------------------------------------------------------------------------- /test/TestHashSet.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "TestHashSet" 2 | Option Explicit 3 | Option Private Module 4 | '@TestModule 5 | Private Assert As New Rubberduck.AssertClass 6 | 7 | 8 | '@TestMethod 9 | Public Sub TestHashSetGist() 10 | 11 | Dim x As List 12 | Set x = List.Create(1, 2, 3) 13 | 14 | Dim y As List 15 | Set y = List.Create(1, 2, 3) 16 | 17 | Dim z As List 18 | Set z = y 19 | 20 | Dim hs As HashSet 21 | Set hs = HashSet.Create(x, x, y, y, z, z) 22 | 23 | Assert.AreEqual CLng(2), hs.Count 24 | Assert.IsTrue hs.Contains(x) 25 | Assert.IsTrue hs.Contains(y) 26 | Assert.IsTrue hs.Contains(z) 27 | 28 | End Sub 29 | '@TestMethod 30 | Public Sub TestHashAndSortedEquals() 31 | 32 | Dim compatable As HashSet 33 | Set compatable = HashSet.Create(1, 2, 3) 34 | 35 | Dim incompatable As HashSet 36 | Set incompatable = HashSet.Create(List.Create(1, 2, 3)) 37 | 38 | Dim ss As SortedSet 39 | Set ss = SortedSet.Create(1, 2, 3) 40 | 41 | On Error GoTo TestFail 42 | Assert.IsTrue Equals(compatable, ss) 43 | Assert.IsFalse Equals(incompatable, ss) 44 | On Error GoTo 0 45 | 46 | Exit Sub 47 | TestFail: 48 | Assert.Fail 49 | Resume Next 50 | End Sub 51 | '@TestMethod 52 | Public Sub BatteryHashSet() 53 | 54 | Dim x As List 55 | Set x = List.Create(1, 2, 3) 56 | 57 | Dim y As List 58 | Set y = List.Create(1, 2, 3) 59 | 60 | Dim z As List 61 | Set z = y 62 | 63 | Dim otherSet As SortedSet 64 | Set otherSet = SortedSet.Create(1, 2, 3) 65 | 66 | Dim otherAssoc As Assoc 67 | Set otherAssoc = Assoc.Make(1, 2) 68 | 69 | Dim hsA As HashSet 70 | Set hsA = HashSet.Create(x, y, z) 71 | 72 | Dim hsB As HashSet 73 | Set hsB = HashSet.Create(x, otherSet) 74 | 75 | Dim hsC As HashSet 76 | Set hsC = HashSet.Create(otherAssoc, z) 77 | 78 | Dim super As HashSet 79 | Set super = HashSet.Create(x, y, z, otherAssoc, otherSet) 80 | 81 | Dim emptySet As HashSet 82 | Set emptySet = HashSet.Create() 83 | 84 | BatterySetLike.Battery hsA, hsB, hsC, emptySet, super 85 | 86 | End Sub 87 | -------------------------------------------------------------------------------- /test/TestInternalDelegate.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "TestInternalDelegate" 2 | '@TestModule 3 | Option Explicit 4 | Option Private Module 5 | Private Assert As New Rubberduck.AssertClass 6 | 7 | '@TestMethod 8 | Public Sub TestPass() 9 | 10 | Dim idg As InternalDelegate 11 | Set idg = InternalDelegate.Make("MaxValue") 12 | 13 | Dim arg As List 14 | Set arg = List.Create(1, 2, 4, 2, 100, 2, 3, 20, 3) 15 | 16 | Dim result As Integer 17 | result = 100 18 | 19 | BatteryApplicable.Battery idg, arg, result 20 | 21 | End Sub 22 | -------------------------------------------------------------------------------- /test/TestLambda.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "TestLambda" 2 | '@TestModule 3 | Option Explicit 4 | Option Private Module 5 | Private Assert As New Rubberduck.AssertClass 6 | 7 | '@TestMethod 8 | Public Sub LambdaFromProper() 9 | 10 | Dim f As Lambda 11 | Set f = Lambda.FromProper("(x) => x * x") 12 | 13 | BatteryApplicable.Battery f, 2, 4 14 | 15 | End Sub 16 | '@TestMethod 17 | Public Sub LambdaFromShort() 18 | 19 | Dim f As Lambda 20 | Set f = Lambda.FromShort("_ + 13") 21 | 22 | BatteryApplicable.Battery f, 11, 24 23 | 24 | End Sub 25 | 26 | -------------------------------------------------------------------------------- /test/TestLazy.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "TestLazy" 2 | '@TestModule 3 | Option Explicit 4 | Option Private Module 5 | Private Assert As New Rubberduck.AssertClass 6 | 7 | '@TestMethod 8 | Public Sub LazyMakeTest() 9 | 10 | Dim op As OnArgs 11 | Set op = OnArgs.Make("Contains", VbMethod, SortedSet.Create(2)) 12 | 13 | Dim lzy As Lazy 14 | Set lzy = Lazy.Create(op, 2) 15 | 16 | Assert.IsTrue lzy.IsDelayed 17 | Assert.IsTrue lzy 18 | Assert.IsFalse lzy.IsDelayed 19 | 20 | End Sub 21 | ' 22 | '@TestMethod 23 | Public Sub LazyTestWithHashSet() 24 | 25 | Dim lz As Lazy 26 | Set lz = Lazy.Create(InternalDelegate.Make("BaseName"), "Hello\World") 27 | 28 | Dim hs As HashSet 29 | Set hs = HashSet.Create("World") 30 | 31 | Assert.IsTrue hs.Contains(lz) ' WILL FAIL, but shouldn't 32 | Assert.IsTrue hs.Contains(lz.Evaluate) ' doesn't fail 33 | Assert.IsTrue hs.Contains(lz) ' still does... 34 | 35 | End Sub 36 | ' 37 | ' Various problems with Map... 38 | ' ---------------------------- 39 | ' 40 | '@TestMethod 41 | Public Sub LazyLambdaMapTest() 42 | 43 | Dim lazyFour As Lazy 44 | Set lazyFour = Lazy.Create(Lambda.FromShort("_ + _"), 2, 2) 45 | 46 | Dim multTen As Lambda 47 | Set multTen = Lambda.FromShort("10 * _ ") 48 | 49 | LazyMapTest lazyFour, multTen, 40 50 | 51 | End Sub 52 | '@TestMethod 53 | Public Sub LazyMapTestWithInternalDelegate() 54 | 55 | Dim root As Lazy 56 | Set root = Lazy.Create(InternalDelegate.Make("RootName"), "C:\Some\Path\Yo.txt") 57 | 58 | Dim baser As Applicable 59 | Set baser = InternalDelegate.Make("BaseName") 60 | 61 | LazyMapTest root, baser, "Path" 62 | 63 | End Sub 64 | Private Sub LazyMapTest(ByVal initialLazy As Lazy, ByVal toMapWith As Applicable, ByVal mappedResult) 65 | 66 | Debug.Assert initialLazy.IsDelayed 67 | 68 | Dim mapped As Lazy 69 | Set mapped = initialLazy.Map(toMapWith) 70 | 71 | Assert.IsTrue initialLazy.IsDelayed 72 | Assert.IsTrue mapped.IsDelayed 73 | 74 | Assert.IsTrue Equals(mapped.Evaluate, mappedResult) 75 | Assert.IsTrue initialLazy.IsEvaluated 76 | 77 | End Sub 78 | -------------------------------------------------------------------------------- /test/TestList.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "TestList" 2 | '@Module 3 | Option Explicit 4 | Option Private Module 5 | Private Assert As New Rubberduck.AssertClass 6 | ' 7 | ' 8 | ' Constructors 9 | ' ------------ 10 | ' 11 | '@TestMethod 12 | Public Sub ListCopy() 13 | 14 | Assert.AreEqual "List(1, 2, 3)", List.Copy(Array(1, 2, 3)).Show 15 | Assert.AreEqual "List()", List.Copy(Array()).Show 16 | 17 | End Sub 18 | '@TestMethod 19 | Public Sub ListCopyIsCopy() 20 | 21 | Dim xs As List 22 | Set xs = List.Create(1, 2, 3) 23 | 24 | Dim ys As List 25 | Set ys = List.Copy(xs) 26 | 27 | Assert.IsTrue xs.Equals(ys) 28 | Assert.AreNotEqual ObjPtr(xs), ObjPtr(ys) 29 | 30 | End Sub 31 | '@TestMethod 32 | Public Sub ListNested() 33 | 34 | Dim flat As List 35 | Set flat = List.Create(1, 2, 3) 36 | 37 | Dim nested As List 38 | Set nested = List.Create(flat) 39 | 40 | Dim nestedCopy As List 41 | Set nestedCopy = List.Create(List.Copy(flat)) 42 | 43 | flat.Append 4 44 | 45 | Dim newNested As List 46 | Set newNested = List.Create(flat) 47 | 48 | Assert.IsTrue newNested.Equals(nested) 49 | Assert.IsFalse nested.Equals(nestedCopy) 50 | 51 | End Sub 52 | '@TestMethod 53 | Public Sub ListRepeat() 54 | 55 | Dim xs As List 56 | Set xs = List.Repeat("x", 5) 57 | 58 | Assert.AreEqual CLng(5), xs.Count 59 | 60 | Dim x 61 | For Each x In xs 62 | Assert.AreEqual "x", x 63 | Next 64 | 65 | End Sub 66 | ' 67 | ' Interfaces 68 | ' ---------- 69 | ' 70 | ' ### Equatable 71 | ' 72 | '@TestMethod 73 | Public Sub ListEquals() 74 | 75 | Dim xs As List 76 | Set xs = List.Create(1, 2, 3) 77 | 78 | Assert.IsTrue xs.Equals(xs), "Self is equal to self" 79 | Assert.IsTrue xs.Equals(List.Create(1, 2, 3)), "equal to new instance" 80 | Assert.IsTrue List.Create(1, 2, 3).Equals(xs), "New Instance is equal to xs" 81 | 82 | End Sub 83 | '@TestMethod 84 | Public Sub ListNotEquals() 85 | 86 | Dim xs As List 87 | Set xs = List.Create(1, 2, 3) 88 | 89 | Assert.IsFalse xs.Equals(List.Create(4, 5, 6)), "same size, different elements" 90 | Assert.IsFalse xs.Equals(List.Create(1, 2, 3, 4)), "different size, same elements" 91 | Assert.IsFalse xs.Equals(List.Create("A", "B", "C")), "different element type" 92 | 93 | End Sub 94 | ' 95 | ' ### ICountable 96 | ' 97 | '@TestMethod 98 | Public Sub ListCount() 99 | Assert.AreEqual List.Create(1, 2, 3).Count, CLng(3), "NonEmpty" 100 | Assert.AreEqual List.Create().Count, CLng(0), "empty" 101 | End Sub 102 | ' 103 | ' ### ISequence 104 | ' 105 | '@TestMethod 106 | Public Sub ListToArray() 107 | Assert.AreEqual Join(Array(1, 2, 3)), Join(List.Create(1, 2, 3).ToArray), "multiple elements" 108 | Assert.IsNothing Join(List.Create().ToArray) 109 | End Sub 110 | ' 111 | ' ### IPrintable 112 | ' 113 | '@TestMethod 114 | Public Sub ListShow() 115 | 116 | Dim flatList As List 117 | Set flatList = List.Create(1, 2, 3) 118 | 119 | Dim nestList As List 120 | Set nestList = List.Create(flatList, flatList) 121 | 122 | With Assert 123 | .AreEqual "List()", List.Create().Show 124 | .AreEqual "List(1, 2, 3)", flatList.Show 125 | .AreEqual "List(List(1, 2, 3), List(1, 2, 3))", nestList.Show 126 | End With 127 | 128 | End Sub 129 | ' 130 | ' Methods 131 | ' ------- 132 | ' 133 | '@TestMethod 134 | Public Sub ListReduce() 135 | 136 | Assert.AreEqual "abc", List.Create("a", "b", "c") _ 137 | .Reduce(Lambda.FromProper("(a, b) => a & b")) 138 | 139 | End Sub 140 | '@TestMethod 141 | Public Sub ListFold() 142 | 143 | Assert.AreEqual "abc", List.Create("a", "b", "c") _ 144 | .Fold("", Lambda.FromProper("(a, b) => a & b")) 145 | 146 | End Sub 147 | '@TestMethod 148 | Public Sub ListScan() 149 | 150 | Assert.AreEqual "List(z, za, zab, zabc)", List.Create("a", "b", "c") _ 151 | .Scan("z", Lambda.FromShort("_ & _")).Show 152 | 153 | End Sub 154 | '@TestMethod 155 | Public Sub ListMap() 156 | End Sub 157 | '@TestMethod 158 | Public Sub ListFlatMap() 159 | End Sub 160 | '@TestMethod 161 | Public Sub ListFilter() 162 | End Sub 163 | '@TestMethod 164 | Public Sub ListFilterNot() 165 | End Sub 166 | '@TestMethod 167 | Public Sub ListFPSections() 168 | End Sub 169 | '@TestMethod 170 | Public Sub ListEmptyFPSections() 171 | End Sub 172 | '@TestMethod 173 | Public Sub ListGroupBy() 174 | End Sub 175 | -------------------------------------------------------------------------------- /test/TestMaybe.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "TestMaybe" 2 | '@TestModule 3 | Option Explicit 4 | Option Private Module 5 | Private Assert As New Rubberduck.AssertClass 6 | 7 | '@TestMethod 8 | Public Sub MaybeMonadicTest() 9 | 10 | Dim m As Maybe 11 | Set m = Maybe.Some(2) 12 | 13 | BatteryMonadic.Battery m 14 | 15 | End Sub 16 | '@TestMethod 17 | Public Sub MaybeCanDefaultWithApplicationRun() 18 | 19 | Dim m As Maybe 20 | Set m = Maybe.Some("C:\Some\Path\yo.txt") 21 | 22 | Dim baser As InternalDelegate 23 | Set baser = InternalDelegate.Make("path.BaseName") 24 | 25 | On Error GoTo typeFailed 26 | Assert.AreEqual "yo.txt", baser.Apply(m) 27 | 28 | Exit Sub 29 | typeFailed: 30 | Assert.AreEqual CLng(13), Err.Number, "Error Number is not 13" 31 | Assert.Fail "Maybe did not default when called by application run" 32 | End Sub 33 | -------------------------------------------------------------------------------- /test/TestNameCall.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "TestNameCall" 2 | '@TestModule 3 | Option Explicit 4 | Option Private Module 5 | Private Assert As New Rubberduck.AssertClass 6 | 7 | '@TestMethod 8 | Public Sub OnArgsGetTest() 9 | 10 | Dim xs As List 11 | Set xs = List.Create("a", "b") 12 | 13 | Dim nc As OnArgs 14 | Set nc = OnArgs.Make("Item", VbGet, xs) 15 | 16 | BatteryApplicable.Battery nc, 2, "b" 17 | 18 | End Sub 19 | '@TestMethod 20 | Public Sub OnArgsMethodTest() 21 | 22 | Dim xs As SortedSet 23 | Set xs = SortedSet.Create(1, 2, 3) 24 | 25 | Dim nc As OnArgs 26 | Set nc = OnArgs.Make("Contains", VbMethod, xs) 27 | 28 | BatteryApplicable.Battery nc, 2, True 29 | BatteryApplicable.Battery nc, 4, False 30 | 31 | End Sub 32 | '@TestMethod 33 | Public Sub OnObjectTest() 34 | 35 | Dim s1 As SortedSet 36 | Set s1 = SortedSet.Create(1, 2, 3) 37 | 38 | Dim s2 As SortedSet 39 | Set s2 = SortedSet.Create("a", "b", "c") 40 | 41 | Dim nc As OnObject 42 | Set nc = OnObject.Create("Contains", VbMethod, 2) 43 | 44 | BatteryApplicable.Battery nc, s1, True 45 | BatteryApplicable.Battery nc, s2, False 46 | 47 | End Sub 48 | ''@TestMethod 49 | 'Public Sub OnMethodTest() 50 | ' 51 | ' Dim s1 As SortedSet 52 | ' Set s1 = SortedSet.Create(1, 2, 3) 53 | ' 54 | ' Dim s2 As SortedSet 55 | ' Set s2 = SortedSet.Create("a", "b", "c") 56 | ' 57 | ' Dim nc As NameCall 58 | ' Set nc = NameCall.OnObject("Contains", VbMethod, 2) 59 | ' 60 | ' BatteryApplicable.Battery nc, s1, True 61 | ' BatteryApplicable.Battery nc, s2, False 62 | ' 63 | 'End Sub 64 | 65 | -------------------------------------------------------------------------------- /test/TestPartial.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "TestPartial" 2 | Option Explicit 3 | 4 | '@TestModule 5 | Option Private Module 6 | Private Assert As New Rubberduck.AssertClass 7 | 8 | '@TestMethod 9 | Public Sub PartialMakeTest() 10 | 11 | Dim myDict As Dict 12 | Set myDict = Dict.Create 13 | 14 | Dim itemGetter As OnArgs 15 | Set itemGetter = OnArgs.Make("GetItem", VbMethod, myDict) 16 | 17 | Dim keyPart As Partial 18 | Set keyPart = Partial.Make(itemGetter, xArray(Empty, "default value")) 19 | 20 | BatteryApplicable.Battery keyPart, "key", "default value" 21 | 22 | myDict.Add "key", "value" 23 | BatteryApplicable.Battery keyPart, "key", "value" 24 | 25 | End Sub 26 | -------------------------------------------------------------------------------- /test/TestShow.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "TestShow" 2 | '@TestModule 3 | Option Explicit 4 | Option Private Module 5 | Private Assert As New Rubberduck.AssertClass 6 | 7 | '@TestMethod 8 | Public Sub ShowPrimativeDataTest() 9 | 10 | With Assert 11 | .AreEqual "x", defshow.Show("x") 12 | .AreEqual "1", defshow.Show(CInt(1)) 13 | .AreEqual "1", defshow.Show(CDbl(1)) 14 | End With 15 | 16 | End Sub 17 | '@TestMethod 18 | Public Sub ShowableTest() 19 | 20 | Dim flatList As List 21 | Set flatList = List.Create(1, 2, 3) 22 | 23 | Dim nestList As List 24 | Set nestList = List.Create(flatList, flatList) 25 | 26 | With Assert 27 | .AreEqual flatList.Show, defshow.Show(flatList) 28 | .AreEqual nestList.Show, defshow.Show(nestList) 29 | End With 30 | 31 | End Sub 32 | '@TestMethod 33 | Public Sub ShowObjectTest() 34 | 35 | Dim c As New Collection 36 | Assert.IsTrue (defshow.Show(c) Like "Collection(&*)") 37 | 38 | End Sub 39 | -------------------------------------------------------------------------------- /test/TestSortedSet.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "TestSortedSet" 2 | '@TestModule 3 | Option Explicit 4 | Option Private Module 5 | Private Assert As New Rubberduck.AssertClass 6 | 7 | Private Sub SetEmptyConstructorTest(ByVal emptySet As SortedSet) 8 | 9 | Assert.IsNotNothing emptySet, "Empty set is not nothing" 10 | Assert.AreEqual "SortedSet()", emptySet.Show, "Emptyset repr SortedSet()" 11 | Assert.AreEqual CLng(0), emptySet.Count, "emptyset count = 0" 12 | 13 | End Sub 14 | Private Sub SetNonEmptyConstructorTest(ByVal nonempty As SortedSet) 15 | 16 | Assert.IsNotNothing nonempty, "nonempty set is not nothing" 17 | Assert.AreEqual "SortedSet(1, 2, 3)", nonempty.Show, "nonempty repr SortedSet(1, 2, 3)" 18 | Assert.AreEqual CLng(3), nonempty.Count, "nonempty count = 0" 19 | 20 | End Sub 21 | 22 | '@TestMethod 23 | Public Sub SetEmptyCreate() 24 | SetEmptyConstructorTest SortedSet.Create() 25 | End Sub 26 | 27 | '@TestMethod 28 | Public Sub SetEmptyCopy() 29 | SetEmptyConstructorTest SortedSet.Copy(Array()) 30 | End Sub 31 | 32 | '@TestMethod 33 | Public Sub SetNonEmptyCopy() 34 | 35 | SetNonEmptyConstructorTest SortedSet.Copy(Array(1, 2, 3)) 36 | SetNonEmptyConstructorTest SortedSet.Copy(Array(1, 2, 3, 1, 2, 3)) 37 | 38 | End Sub 39 | '@TestMethod 40 | Public Sub SetNonEmptyCreate() 41 | 42 | SetNonEmptyConstructorTest SortedSet.Create(1, 2, 3) 43 | SetNonEmptyConstructorTest SortedSet.Create(1, 2, 3, 1, 2, 3) 44 | 45 | End Sub 46 | 47 | '@TestMethod 48 | Public Sub SetDifference() 49 | 50 | Dim s1 As SortedSet 51 | Set s1 = SortedSet.Create(1, 3, 5) 52 | 53 | Dim s2 As SortedSet 54 | Set s2 = SortedSet.Create(2, 4, 6) 55 | 56 | Dim S3 As SortedSet 57 | Set S3 = SortedSet.Create(3, 5, 7) 58 | 59 | Assert.AreEqual "SortedSet()", s1.Difference(s1).Show 60 | Assert.AreEqual "SortedSet(1, 3, 5)", s1.Difference(s2).Show 61 | Assert.AreEqual "SortedSet(2, 4, 6)", s2.Difference(s1).Show 62 | 63 | Assert.AreEqual "SortedSet(7)", S3.Difference(s1).Show 64 | Assert.AreEqual "SortedSet(1)", s1.Difference(S3).Show 65 | 66 | End Sub 67 | 68 | Private Function Setup() As Tuple 69 | 70 | Dim s1 As SortedSet 71 | Set s1 = SortedSet.Create(1, 3, 5) 72 | 73 | Dim s2 As SortedSet 74 | Set s2 = SortedSet.Create(2, 4, 6) 75 | 76 | Dim S3 As SortedSet 77 | Set S3 = SortedSet.Create(3, 5, 7) 78 | 79 | Set Setup = Tuple.Pack(s1, s2, S3) 80 | 81 | End Function 82 | 83 | '@TestMethod 84 | Public Sub SetIntersect() 85 | 86 | Dim s1 As SortedSet, s2 As SortedSet, S3 As SortedSet 87 | Setup.unpack s1, s2, S3 88 | 89 | Assert.AreEqual "SortedSet(1, 3, 5)", s1.Intersect(s1).Show 90 | 91 | Assert.AreEqual "SortedSet()", s1.Intersect(s2).Show 92 | Assert.AreEqual "SortedSet()", s2.Intersect(s1).Show 93 | 94 | Assert.AreEqual "SortedSet(3, 5)", S3.Intersect(s1).Show 95 | Assert.AreEqual "SortedSet(3, 5)", s1.Intersect(S3).Show 96 | 97 | End Sub 98 | 99 | '@TestMethod 100 | Public Sub SetUnion() 101 | 102 | Dim s1 As SortedSet, s2 As SortedSet, S3 As SortedSet 103 | Setup.unpack s1, s2, S3 104 | 105 | Assert.AreEqual "SortedSet(1, 3, 5)", s1.Union(s1).Show 106 | 107 | Assert.AreEqual "SortedSet(1, 2, 3, 4, 5, 6)", s1.Union(s2).Show 108 | Assert.AreEqual "SortedSet(1, 2, 3, 4, 5, 6)", s2.Union(s1).Show 109 | 110 | Assert.AreEqual "SortedSet(1, 3, 5, 7)", S3.Union(s1).Show 111 | Assert.AreEqual "SortedSet(1, 3, 5, 7)", s1.Union(S3).Show 112 | 113 | End Sub 114 | 115 | '@TestMethod 116 | Public Sub SetSymmetricDifference() 117 | 118 | Dim s1 As SortedSet, s2 As SortedSet, S3 As SortedSet 119 | Setup.unpack s1, s2, S3 120 | 121 | Assert.AreEqual "SortedSet()", s1.SymmetricDifference(s1).Show 122 | 123 | Assert.AreEqual "SortedSet(1, 2, 3, 4, 5, 6)", s1.SymmetricDifference(s2).Show 124 | Assert.AreEqual "SortedSet(1, 2, 3, 4, 5, 6)", s2.SymmetricDifference(s1).Show 125 | 126 | Assert.AreEqual "SortedSet(1, 7)", S3.SymmetricDifference(s1).Show 127 | Assert.AreEqual "SortedSet(1, 7)", s1.SymmetricDifference(S3).Show 128 | 129 | End Sub 130 | 131 | '@TestMethod 132 | Public Sub SetIsDisJoint() 133 | 134 | Dim s1 As SortedSet, s2 As SortedSet, S3 As SortedSet 135 | Setup.unpack s1, s2, S3 136 | 137 | Assert.IsFalse s1.IsDisJoint(s1) 138 | 139 | Assert.IsTrue s1.IsDisJoint(s2) 140 | Assert.IsTrue s2.IsDisJoint(s1) 141 | 142 | Assert.IsFalse S3.IsDisJoint(s1) 143 | Assert.IsFalse s1.IsDisJoint(S3) 144 | 145 | End Sub 146 | Private Function SubSetSetup() As Tuple 147 | 148 | Dim s1 As SortedSet 149 | Set s1 = SortedSet.Create(1, 3, 5) 150 | 151 | Dim s2 As SortedSet 152 | Set s2 = SortedSet.Create(2, 4, 6) 153 | 154 | Dim S3 As SortedSet 155 | Set S3 = SortedSet.Create(3, 5) 156 | 157 | Set SubSetSetup = Tuple.Pack(s1, s2, S3) 158 | 159 | End Function 160 | '@TestMethod 161 | Public Sub SetIsSubSet() 162 | 163 | Dim s1 As SortedSet, s2 As SortedSet, S3 As SortedSet 164 | SubSetSetup.unpack s1, s2, S3 165 | 166 | Assert.IsTrue s1.IsSubSetOf(s1) 167 | 168 | Assert.IsFalse s1.IsSubSetOf(s2) 169 | Assert.IsFalse s2.IsSubSetOf(s1) 170 | 171 | Assert.IsTrue S3.IsSubSetOf(s1) 172 | Assert.IsFalse s1.IsSubSetOf(S3) 173 | 174 | End Sub 175 | 176 | '@TestMethod 177 | Public Sub SetIsProperSubSet() 178 | 179 | Dim s1 As SortedSet, s2 As SortedSet, S3 As SortedSet 180 | SubSetSetup.unpack s1, s2, S3 181 | 182 | Assert.IsFalse s1.IsProperSubSetOf(s1) 183 | 184 | Assert.IsFalse s1.IsProperSubSetOf(s2) 185 | Assert.IsFalse s2.IsProperSubSetOf(s1) 186 | 187 | Assert.IsTrue S3.IsProperSubSetOf(s1) 188 | Assert.IsFalse s1.IsProperSubSetOf(S3) 189 | 190 | End Sub 191 | -------------------------------------------------------------------------------- /test/TestStr.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "TestStr" 2 | '@TestModule 3 | Option Explicit 4 | Option Private Module 5 | Private Assert As New Rubberduck.AssertClass 6 | ' 7 | ' 8 | ' Constructors 9 | ' ------------ 10 | ' 11 | '@TestMethod 12 | Public Sub TestStrJoin() 13 | 14 | Dim s As Str 15 | Set s = Str.Join(List.Create("Hello", "World"), ", ") 16 | 17 | Assert.AreEqual "Hello, World", s.Show 18 | 19 | End Sub 20 | '@TestMethod 21 | Public Sub TestStrMake() 22 | 23 | Dim s As Str 24 | Set s = Str.Make("Hello, World") 25 | 26 | Assert.AreEqual "Hello, World", s.Show 27 | 28 | End Sub 29 | '@TestMethod 30 | Public Sub TestStrRepeat() 31 | 32 | Dim s As Str 33 | Set s = Str.Repeat("Spam", 3) 34 | 35 | Assert.AreEqual "SpamSpamSpam", s.Show 36 | 37 | End Sub 38 | '@TestMethod 39 | Public Sub TestStrFormat() 40 | 41 | Dim s As Str 42 | Set s = Str.Format("{0}, {2}, {1}", "a", 2, 4.5) 43 | 44 | Assert.AreEqual "a, 4.5, 2", s.Show 45 | 46 | End Sub 47 | '@TestMethod 48 | Public Sub TestStrEscape() 49 | 50 | Dim s As Str 51 | Set s = Str.Escape("&Phil's parrot said ""I'm not dead""") 52 | 53 | Assert.AreEqual "`&Phil`'s` parrot` said` `""I`'m` not` dead`""", s.Show 54 | 55 | End Sub 56 | '@TestMethod 57 | Public Sub StrIterable() 58 | 59 | BatteryIterable.Battery Str.Make("Hello, World") 60 | 61 | End Sub 62 | 63 | -------------------------------------------------------------------------------- /test/TestTuple.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "TestTuple" 2 | '@TestModule 3 | Option Explicit 4 | Option Private Module 5 | Private Assert As New Rubberduck.AssertClass 6 | 7 | Private Sub TupleTestEmpty(ByVal t As Tuple) 8 | Assert.IsNotNothing t, "Empty Tuple is not nothing" 9 | Assert.AreEqual CLng(0), t.Count, "Empty Tuple count" 10 | Assert.AreEqual "Tuple()", t.Show, "Empty Tuple Show" 11 | End Sub 12 | Private Sub TupleTestNonEmpty(ByVal t As Tuple) 13 | Assert.IsNotNothing t, "NonEmpty Tuple is not nothing" 14 | Assert.AreEqual CLng(3), t.Count, "NonEmpty Tuple count" 15 | Assert.AreEqual "Tuple(1, 2, 3)", t.Show, "NonEmpty Tuple Show" 16 | End Sub 17 | 18 | '@TestMethod 19 | Public Sub TuplePackEmpty() 20 | TupleTestEmpty Tuple.Pack() 21 | End Sub 22 | 23 | '@TestMethod 24 | Public Sub TuplePackNonEmpty() 25 | TupleTestNonEmpty Tuple.Pack(1, 2, 3) 26 | End Sub 27 | 28 | '@TestMethod 29 | Public Sub TupleImpodeEmpty() 30 | TupleTestEmpty Tuple.Implode(Array()) 31 | End Sub 32 | 33 | '@TestMethod 34 | Public Sub TupleImpodeNonEmpty() 35 | TupleTestNonEmpty Tuple.Implode(Array(1, 2, 3)) 36 | End Sub 37 | 38 | '@TestMethod 39 | Public Sub TupleImpodeNonEmptyOffset() 40 | 41 | 'TODO: Shouldn't need to be variant 42 | Dim a(1 To 3) As Variant 43 | a(1) = 1 44 | a(2) = 2 45 | a(3) = 3 46 | 47 | TupleTestNonEmpty Tuple.Implode(a) 48 | 49 | End Sub 50 | 51 | '@TestMethod 52 | Public Sub TupleUnpackEmpty() 53 | 'TODO: no error 54 | Dim t As Tuple 55 | Set t = Tuple.Pack() 56 | 57 | t.unpack 58 | 59 | End Sub 60 | Private Function Setup() As Tuple 61 | 62 | Set Setup = Tuple.Pack(1, 2, 3) 63 | 64 | End Function 65 | '@TestMethod 66 | Public Sub TupleUnpackNonEmpty() 67 | 68 | Dim x As Integer, y As Integer, z As Integer 69 | Setup.unpack x, y, z 70 | 71 | Assert.AreEqual "1 2 3", Join(Array(x, y, z)) 72 | 73 | End Sub 74 | 75 | '@TestMethod 76 | Public Sub TupleExplodeNonEmpty() 77 | 78 | Dim a(0 To 2) As Variant 79 | Setup.Explode a 80 | 81 | Assert.AreEqual "1 2 3", Join(a) 82 | 83 | End Sub 84 | 85 | '@TestMethod 86 | Public Sub TupleExplodeNonEmptyOffset() 87 | 88 | Dim a(1 To 3) As Variant 89 | Setup.Explode a 90 | 91 | Assert.AreEqual "1 2 3", Join(a) 92 | 93 | End Sub 94 | -------------------------------------------------------------------------------- /test/TestZip.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "TestZip" 2 | '@TestModule 3 | Option Explicit 4 | Option Private Module 5 | Private Assert As New Rubberduck.AssertClass 6 | 7 | '@TestMethod 8 | Public Sub EmptyZip() 9 | Dim z As List 10 | Set z = Tuple.Zip(List, List.Create(), List.Create()) 11 | Assert.AreEqual CLng(0), z.Count, "Empty ZipList is Empty" 12 | End Sub 13 | '@TestMethod 14 | Public Sub NonEmptyZip() 15 | 16 | Dim z As List 17 | Set z = Tuple.Zip(List, List.Create(1, 2, 3, 4, 5), _ 18 | List.Create("a", "b", "c", "d", "e")) 19 | Assert.AreEqual "Tuple", TypeName(z(1)) 20 | Assert.AreEqual CLng(2), z(1).Count 21 | 22 | Assert.AreEqual 5, z(z.Count).Item(1) 23 | Assert.AreEqual "e", z(z.Count).Item(2) 24 | 25 | End Sub 26 | '@TestMethod 27 | Public Sub UnEvenZip() 28 | 29 | Dim z As List 30 | Set z = Tuple.Zip(List, List.Create("a"), List.Create(1, 2, 3)) 31 | Assert.AreEqual CLng(1), z.Count, "uneven took size of list A" 32 | 33 | Assert.AreEqual "a", z(1).Item(1) 34 | Assert.AreEqual 1, z(1).Item(2) 35 | 36 | End Sub 37 | '@TestMethod 38 | Public Sub UnEvenZipTakesSmallest() 39 | 40 | Dim l1 As List 41 | Set l1 = Tuple.Zip(List, List.Create("a"), List.Create(1, 2, 3)) 42 | Assert.AreEqual CLng(1), l1.Count 43 | 44 | Dim l2 As List 45 | Set l2 = Tuple.Zip(List, List.Create(1, 2, 3), List.Create("a")) 46 | Assert.AreEqual CLng(1), l2.Count 47 | 48 | End Sub 49 | 50 | -------------------------------------------------------------------------------- /test/Testcast.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "Testcast" 2 | '@TestModule 3 | Option Explicit 4 | Option Private Module 5 | Private Assert As New Rubberduck.AssertClass 6 | 7 | ' 8 | ' cast Test 9 | ' ========= 10 | ' 11 | '@TestMethod 12 | Public Sub CastAssignPrimative() 13 | 14 | Dim x As Integer 15 | x = 1 16 | 17 | cast.Assign x, 2 18 | Assert.AreEqual 2, x 19 | 20 | End Sub 21 | '@TestMethod 22 | Public Sub CastAssignArray() 23 | 24 | Dim a() As Variant 25 | a = List.Create(1, 2, 3).ToArray 26 | Assert.AreEqual "1 2 3", Join(a), "proving givens" 27 | 28 | Dim lower As Integer 29 | lower = LBound(a) 30 | 31 | cast.Assign a(lower), "x" 32 | Assert.AreEqual "x", a(lower) 33 | 34 | End Sub 35 | '@TestMethod 36 | Public Sub CastAssignObject() 37 | 38 | Dim xs As List 39 | Set xs = List.Create(1, 2, 3) 40 | 41 | Dim ys As List 42 | Set ys = List.Create("A", "B", "C") 43 | 44 | ' Assign uses default "Set" 45 | cast.Assign xs, ys 46 | Assert.IsTrue xs.Equals(ys) 47 | Assert.AreEqual ObjPtr(ys), ObjPtr(xs) 48 | 49 | 'Double Check 50 | ys.Append "D" 51 | Assert.IsTrue xs.Equals(ys) 52 | 53 | End Sub 54 | ' 55 | ' CArray 56 | ' ------ 57 | ' 58 | '@TestMethod 59 | Public Sub CastCArray() 60 | 61 | End Sub 62 | 63 | 64 | --------------------------------------------------------------------------------