VBA - JsonIO.bas

Attribute VB_Name = "JsonIO"
'
' Version: 2019/09/10
'
' Module to read and write the JSON format (https://www.json.org)
' By default `{ }` is parsed as a `Dictionary` and `[ ]` as a base 1 Array.
'
' Usage:
'
'  ' Parse a JSON string '
'
'  Dim obj
'
'  For Each obj In JsonIO.Parse("[{a:1, b:'v1'}, {a:2, b:'v2'}]")
'    Debug.Print obj!a, obj!b
'  Next
'
'  ' Stringify to a JSON string '
'
'  Dim obj As New Dictionary
'  obj.Add "a", 1
'  obj.Add "b", Array("v1", 786.99, Now)
'
'  Debug.Print JsonIO.Stringify(obj, Indent:=2)
'  Debug.Print JsonIO.Stringify(obj, Indent:=vbTab)
'  Debug.Print JsonIO.Stringify(obj, Indent:="  ")
'

Option Explicit
Option Base 1

Private Type TReader
  Text As String
  Chars() As Byte
  Length As Long
  Index As Long
End Type

Private Type TWriter
  Text As String
  Index As Long
  Indent As Long
  Padding As Long
  DateFormat As String
  Escape(0 To 255) As Byte
End Type


Public Function Parse(Text) As Variant
  Dim self As TReader
  self.Text = Text
  self.Length = Len(self.Text)

    ' to array, 1 byte per character, capped to 255 '
  x_to_chars (Text), self.Chars

    ' parse recursively '
  x_peek_next self
  x_parse_item self, Parse

    ' check no more characters '
  For self.Index = self.Index + 1 To self.Length
    If self.Chars(self.Index) >= 33 Then Err.Raise x_err("unexpected character", self.Index)
  Next
End Function

Public Function Stringify(Item, Optional ByVal Indent = "", Optional DateFormat As String) As String
  Dim self As TWriter, i&
  If VarType(Indent) <> vbString Then Indent = String$(Indent, " ")
  self.Indent = Len(Indent)
  self.Text = String$(1024, Indent & " ")
  self.DateFormat = IIf(Len(DateFormat), DateFormat, "yyyy-mm-ddTHH:mm:ss")
  self.Index = 1

    ' build the lookup table for the escaped characters '
  For i = 0 To 31:    self.Escape(i) = 117: Next ' controls -> \u.... '
  For i = 127 To 159: self.Escape(i) = 117: Next ' controls -> \u.... '
  self.Escape(8) = 98   ' BS  -> \b '
  self.Escape(9) = 116  ' TAB -> \t '
  self.Escape(10) = 110 ' LF  -> \n '
  self.Escape(12) = 102 ' FF  -> \f '
  self.Escape(13) = 114 ' CR  -> \r '
  self.Escape(34) = 34  ' "   -> \" '
  self.Escape(92) = 92  ' \   -> \\ '

    ' write  recusively '
  x_write_item self, Item, Nothing
  Stringify = Left$(self.Text, self.Index - 1)

End Function


Private Sub x_parse_item(self As TReader, out)

  Select Case self.Chars(self.Index)
    Case 34, 39:            x_parse_text self, out                   ' quote '
    Case 43, 45, 48 To 57:  x_parse_number self, out                 ' +-0123456789 '
    Case 91:                x_parse_array self, out                  ' [ '
    Case 123:               x_parse_object self, out                 ' { '
    Case 102:               x_parse_value self, "false", False, out  ' f '
    Case 110:               x_parse_value self, "null", Empty, out   ' n '
    Case 116:               x_parse_value self, "true", True, out    ' t '
    Case Else:              Err.Raise x_err("unexpected character", self.Index)
  End Select

End Sub

Private Sub x_parse_text(self As TReader, out)
  Dim Quote As Byte, i&, n&, buffer$
  Quote = self.Chars(self.Index)
  i = self.Index + 1

  For self.Index = i To self.Length
    Select Case self.Chars(self.Index)
      Case Quote  ' if end quoting '
        out = Left$(buffer, n) & Mid$(self.Text, i, self.Index - i)
        Exit Sub

      Case 92  ' if escape '
        n = n + self.Index - i
        If n >= Len(buffer) Then buffer = buffer & String$(64 + n, 0)
        Mid$(buffer, 1 + n - self.Index + i) = Mid$(self.Text, i, self.Index - i)

        self.Index = self.Index + 1  ' next char '
        If self.Index > self.Length Then Exit For

        Select Case self.Chars(self.Index)
          Case 98:   Mid$(self.Text, self.Index) = vbBack       ' \b -> BS  '
          Case 102:  Mid$(self.Text, self.Index) = vbFormFeed   ' \f -> FF  '
          Case 110:  Mid$(self.Text, self.Index) = vbLf         ' \n -> LF  '
          Case 114:  Mid$(self.Text, self.Index) = vbCr         ' \r -> CR  '
          Case 116:  Mid$(self.Text, self.Index) = vbTab        ' \t -> TAB '
          Case 117:
            self.Index = self.Index + 4
            Mid$(self.Text, self.Index) = x_parse_unicode(self.Text, self.Index - 3)  ' \u.... '
        End Select

        i = self.Index
    End Select
  Next

  Err.Raise x_err("unexpected termination", self.Index)
End Sub

Private Function x_parse_unicode(Text As String, ByVal Index As Long) As String
On Error GoTo Catch
  x_parse_unicode = ChrW$(CInt("&h" & Mid$(Text, Index, 4)))
  Exit Function
Catch:
  Err.Raise x_err("invalid unicode", Index)
End Function

Private Sub x_parse_object(self As TReader, out)
  Dim Key$, Item
  Set out = New Dictionary

  Do
      ' parse key or `}` and exit '
    Select Case x_peek_next(self)
      Case 39, 34: x_parse_text self, Key  ' continue if `'` or `"` '
      Case 125:    Exit Sub                ' return if `}` '
      Case Else:   x_parse_key self, Key   ' else key without quoting '
    End Select

      ' parse `:` '
    If x_peek_next(self) <> 58 Then Err.Raise x_err("unexpected char", self.Index)  ' if not : '

      ' parse item '
    x_peek_next self
    x_parse_item self, Item
    out.Add Key:=Key, Item:=Item

      ' parse either `,` or `}` '
    Select Case x_peek_next(self)
      Case 44:              ' continue if , '
      Case 125:   Exit Sub  ' return if `}` '
      Case Else:  Err.Raise x_err("unexpected char", self.Index)
    End Select
  Loop
End Sub

Private Sub x_parse_array(self As TReader, out)
  Dim Item, n&
  out = Array()
  n = UBound(out)

  Do While x_peek_next(self) - 93  ' while not `]` '
    n = n + 1
    If n > UBound(out) Then ReDim Preserve out(5 + n * 2)
    x_parse_item self, out(n)

    Select Case x_peek_next(self)
      Case 44:             ' continue if `,` '
      Case 93:    Exit Do  ' break if `]` '
      Case Else:  Err.Raise x_err("unexpected char", self.Index)
    End Select
  Loop

  If n - UBound(out) Then ReDim Preserve out(n)
End Sub

Private Sub x_parse_key(self As TReader, out$)
  Dim i&

  For i = self.Index To self.Length
    Select Case self.Chars(i)
      Case 0 To 33, 58:  ' if control, space or colon '
        out = Mid$(self.Text, self.Index, i - self.Index)
        self.Index = i - 1
        Exit Sub
    End Select
  Next

  Err.Raise x_err("unexpected termination", self.Index)
End Sub

Private Sub x_parse_number(self As TReader, out)
  Dim i&, n&

  For i = self.Index To self.Length
    Select Case self.Chars(i)
      Case 48 To 57:   n = n + 1    ' [0-9] '
      Case 43, 45, 46:              ' [+-.] '
      Case 69, 101:    n = 0        ' [eE]  '
      Case Else:       Exit For     ' other '
    End Select
  Next

  out = Mid$(self.Text, self.Index, i - self.Index)
  If n < 16 Then out = Conversion.Val(out)

  self.Index = i - 1
End Sub

Private Sub x_parse_value(self As TReader, txt$, Val, out)
  If InStr(self.Index, self.Text, txt) - self.Index Then Err.Raise x_err("invalid value", self.Index)
  self.Index = self.Index + Len(txt) - 1
  If IsObject(Val) Then Set out = Val Else out = Val
End Sub

Private Function x_peek_next(self As TReader) As Long

  For self.Index = self.Index + 1 To self.Length
    If self.Chars(self.Index) >= 33 Then  ' if not basic latin control or space '
      x_peek_next = self.Chars(self.Index)
      Exit Function
    End If
  Next

  Err.Raise x_err("unexpected termination", self.Index)
End Function

Private Sub x_to_chars(Vector() As Byte, Chars() As Byte)
  Dim i&
  ReDim Chars(1 To (UBound(Vector) + 1) \ 2)

  For i = 1 To UBound(Vector) Step 2
    If Vector(i) Then Chars(i \ 2 + 1) = 255 Else Chars(i \ 2 + 1) = Vector(i - 1)
  Next
End Sub

Private Sub x_write_item(self As TWriter, Item, ByVal Ref As Object)

  If VBA.IsObject(Item) Then
    If Item Is Nothing Then
      x_write self, "null"
    ElseIf TypeOf Item Is Collection Then
      x_write_array self, Item, Ref
    Else
      If Item Is Ref Then Err.Raise x_err("recursive reference")
      Set Ref = Item
      On Error GoTo CatchWriteObject
      x_write_object self, Item.Keys, Item.Items, Ref
    End If
  Else
    Select Case VBA.VarType(Item)
      Case vbString:        x_write_text self, CStr(Item)
      Case 2 To 6, 17, 20:  x_write self, Trim$(Conversion.str$(Item))  ' number '
      Case vbDate:          x_write_date self, CDate(Item)
      Case vbBoolean:       x_write self, LCase(Item)
      Case Is >= vbArray:   x_write_array self, Item, Ref
      Case vbNull, vbEmpty: x_write self, "null"
      Case Else:            Err.Raise x_err("unsupported type " & VBA.typeName(Item))
    End Select
  End If

  Exit Sub

CatchWriteObject:
  If Err.Number = 438 Then Err.Raise x_err("unsupported object " & VBA.typeName(Item))
  On Error GoTo 0
  Resume
End Sub

Private Sub x_write_date(self As TWriter, Item As Date)
  x_write self, """" & VBA.Format$(Item, self.DateFormat, 1, 1) & """"
End Sub

Private Sub x_write_text(self As TWriter, Item As String)
  Dim Bytes() As Byte, i&, j&
  x_write self, """"
  Bytes = Item

  For j = 0 To UBound(Bytes) Step 2
    If Bytes(j + 1) Then      ' skips upper byte is set '
    ElseIf self.Escape(Bytes(j)) Then  ' if char needs escaping '
      x_write self, MidB$(Item, i + 1, j - i)
      i = j + 2

      If self.Escape(Bytes(j)) - 117 Then  ' if simple escape (not `u`) '
        x_write self, "\" & ChrW$(self.Escape(Bytes(j)))
      Else  ' unicode escaping '
        x_write self, VBA.Hex$(&HFF0000 + Bytes(j))
        Mid$(self.Text, self.Index - 6) = "\u"
      End If
    End If
  Next

  x_write self, MidB$(Item, i + 1, j - i)
  x_write self, """"
End Sub

Private Sub x_write_object(self As TWriter, Keys, Items, ByVal Ref As Object)
  Dim i&, some%
  x_write self, "{"
  self.Padding = self.Padding + self.Indent

  For i = LBound(Keys) To UBound(Keys)
    If some Then x_write self, ","
    If self.Indent Then x_write_indent self
    x_write_text self, CStr(Keys(i))
    If self.Indent Then x_write self, ": " Else x_write self, ":"
    x_write_item self, Items(i), Ref
    some = True
  Next

  self.Padding = self.Padding - self.Indent
  If some And self.Indent Then x_write_indent self
  x_write self, "}"
End Sub

Private Sub x_write_array(self As TWriter, Items, ByVal Ref As Object)
  Dim Item, some%
  x_write self, "["
  self.Padding = self.Padding + self.Indent

  For Each Item In Items
    If some Then x_write self, ","
    If self.Indent Then x_write_indent self
    x_write_item self, Item, Ref
    some = True
  Next

  self.Padding = self.Padding - self.Indent
  If some And self.Indent Then x_write_indent self
  x_write self, "]"
End Sub

Private Sub x_write_indent(self As TWriter)
  self.Index = self.Index + self.Padding + 1
  If self.Index >= Len(self.Text) Then x_increase_buffer self
  Mid$(self.Text, self.Index - self.Padding - 1) = vbLf
End Sub

Private Sub x_write(self As TWriter, str As String)
  self.Index = self.Index + Len(str)
  If self.Index >= Len(self.Text) Then x_increase_buffer self
  Mid$(self.Text, self.Index - Len(str)) = str
End Sub

Private Sub x_increase_buffer(self As TWriter)
  self.Text = self.Text & VBA.String$(self.Index, VBA.Right$(self.Text, 1))
End Sub

Private Function x_err(Message$, Optional i As Long) As Long
  x_err = 5
  Err.Source = "Json"
  Err.Number = x_err
  Err.Description = "Json, " & Message & IIf(i, " at " & i, "")
End Function