Attribute VB_Name = "modTokens"
'---------------------------
' Tokeniser

'------------------------------
Option Explicit
'------------------------------------------------
' Strings can be quoted with double quotation marks.
'-----------------------------------------------------
Public Function GetToken(ByRef s As String) As String

  xEatWhiteSpace s

  Select Case Left$(s, 1)
    Case """"
      Dim lX As String
      lX = InStr(2, s, """")
      If lX = 0 Then
        Err.Raise enumErrorCodes.MissingClosingQuotationMark, "modTokens.GetToken", "Expected closing quotation mark"
      Else
        GetToken = Mid$(s, 2, lX - 2)
        s = Mid$(s, lX + 1)
      End If
    Case "{", "}", "[", "]", ":", ","
      GetToken = Left$(s, 1)
      s = Mid$(s, 2)
    Case Else
      Do While (Left$(s, 1) > " ") And (InStr("{}[],", Left$(s, 1)) = 0) And (LenB(s) > 0)
        GetToken = GetToken & Left$(s, 1)
        s = Mid$(s, 2)
      Loop
  End Select

End Function




Private Sub xEatWhiteSpace(ByRef s As String)

  Do
    Do While (Left$(s, 1) <= " ") And (LenB(s) > 0)
      s = Mid$(s, 2)
    Loop
    If (Left$(s, 1) = "#") Then
      xEatComment s
    Else
      Exit Sub
    End If
  Loop

End Sub




Private Sub xEatComment(ByRef s As String)
  Do While (Left$(s, 1) <> vbCr) And (LenB(s) > 0)
    s = Mid$(s, 2)
  Loop
End Sub




'---------------------------------------------------------
' Read a JSON like structure from the string and return it as a dictionary.
'
' see http://www.crockford.com/JSON/index.html

'A JSON object is an unordered set of name/value pairs.
'The object begins with '{' and ends with '}'.
'Each name is followed by ':' and the name/value pairs are separated by ','.
'A JSON array is an ordered collection of values.
'The collection begins with '[' and ends with ']'. Values are separated by ','.
'A value can be a string in double quotes, or a number, or true or false or null,
'or a JSON object or a JSON array. These structures can be nested.
'A string is a collection of zero or more Unicode characters, wrapped
'in double quotes, using backslash escapes.
'A character is represented as a single character string.
'Whitespace can be inserted between any pair of tokens.
'Annotations can be included using the /* ... */ and // commenting conventions.


' The syntax is:

'JSON -object:
'  { property-list }
'  {}

'property-list :
'  string-literal : value
'  property-list , string-literal : value

'value:
'  string-literal
'  Numeric -literal
'  JSON -object
'  JSON-array
'  true
'  false
'  null

'JSON-array :
'  [ element-list ]
'  []

'element -List:
'  value
'  element -List, value
'
'look at the code for certainty.

' This version does not deal with
'  - character escapes so don't try embedding quotation marks.
'  - comments

'---------------------------
Public Function ReadJSON(sStream As String) As Dictionary

  Dim sToken As String
  sToken = GetToken(sStream)
  If (sToken = "{") Then
    Set ReadJSON = xReadPropertyList(sStream)
  Else
    Err.Raise enumErrorCodes.ExpectedOpeningCurlyBracket, "ReadDefinitions", "Expected opening curly bracket but got <" & sToken & ">"
  End If

End Function



'----------------------------------------------------------
' Leading { has already been eaten here.
'-----------------------------------------------
Public Function xReadPropertyList(sStream As String) As Dictionary

  Set xReadPropertyList = New Dictionary
  Dim sToken As String
  Dim sKey As String
  Do
    sToken = GetToken(sStream)
    Select Case sToken
      Case "}" ' finished
        Exit Do
      Case ","
        ' simply ignore the comma, personally I think that commas are onions (See 'The Periodic Table')
      Case Else ' must be the key
        sKey = sToken
        sToken = GetToken(sStream) ' must be a colon, ignore it
        xReadPropertyList.Add sKey, xReadValue(sStream)
    End Select
  Loop

End Function



'----------------------------------------------------------
' Leading [ has already been eaten here.
'-----------------------------------------------
Public Function xReadArray(sStream As String) As Collection

  Set xReadArray = New Collection
  Dim sToken As String
  Dim sKey As String
  Do
    sToken = GetToken(sStream)
    Select Case sToken
      Case "]" ' finished
        Exit Do
      Case ","
        ' simply ignore the comma, personally I think that commas are onions (See 'The Periodic Table')
      Case Else ' must be the item
        xReadArray.Add sToken   ' TODO: convert numbers, trues, false, etc.
    End Select
  Loop

End Function



'-------------------------------------------------
' Read a value.
' The return type here is variant so that we can return a string or a dictionary
'------------------------------------------------------
Private Function xReadValue(sStream As String) As Variant

  Dim sToken As String

  sToken = GetToken(sStream)
  Select Case sToken
    Case "{"
      Set xReadValue = xReadPropertyList(sStream)
    Case "["
      Set xReadValue = xReadArray(sStream)
    Case Else    ' literal
      xReadValue = sToken 'TODO: should convert trues and falses etc.
  End Select

End Function




Public Function PropertyListToString(PropertyList As Dictionary) As String

  Dim oPropertyList As Dictionary
  Dim oArray As Collection
  Dim sKey As String
  Dim lX As Long
  Dim sValue As String

  PropertyListToString = "{"
  With PropertyList
    For lX = 0 To .Count - 1
      sKey = .Keys(lX)
      If TypeOf .Item(sKey) Is Dictionary Then
        sValue = PropertyListToString(.Item(sKey)) & vbCrLf
      ElseIf TypeOf .Item(sKey) Is Collection Then
        sValue = xArrayToString(.Item(sKey)) & vbCrLf
      ElseIf VarType(.Item(sKey)) = vbString Then
        sValue = """" & .Item(sKey) & """"
      Else
        sValue = .Item(sKey)
      End If
      PropertyListToString = PropertyListToString & """" & sKey & """ : " & sValue
      If lX < .Count - 1 Then
        PropertyListToString = PropertyListToString & ", "
      End If
    Next lX
    PropertyListToString = PropertyListToString & "}"

  End With


End Function



Public Function xArrayToString(ArrayList As Collection) As String

  Dim lX As Long
  Dim sValue As String

  xArrayToString = "["
  With ArrayList
    For lX = 1 To .Count
      If TypeOf .Item(lX) Is Dictionary Then
        sValue = PropertyListToString(.Item(lX)) & vbCrLf
      ElseIf TypeOf .Item(lX) Is Collection Then
        sValue = xArrayToString(.Item(lX)) & vbCrLf
      Else
        sValue = .Item(lX)
      End If
      xArrayToString = xArrayToString & sValue
      If lX < .Count Then
        xArrayToString = xArrayToString & ", "
      End If
    Next lX
    xArrayToString = xArrayToString & "]"

  End With


End Function