Attribute VB_Name = "ZoteroNarrative"
Option Explicit

' Zotero Narrative Citation macro for Microsoft Word
'
' Turns a Zotero citation like (Bakker & Demerouti, 2017)
' into Bakker and Demerouti (2017), with no Refresh needed.
'
' How to use:
'   1. Insert a normal Zotero citation with one source.
'   2. Leave your cursor inside it or right after it.
'   3. Run MakeNarrative.
'
' Author names follow APA 7 narrative rules:
'   one author:          Bakker
'   two authors:         Bakker and Demerouti
'   three or more:       Bakker et al.
'   group author:        World Health Organization
'
' The macro types the names as plain text in front of the citation,
' turns on Omit Author inside Zotero's citation data, and updates the
' citation text to (2017) so Zotero sees it as unchanged.
' Works with Zotero's delayed citation updates turned on.
' If it can't safely update the text, it asks you to click Refresh.
' Test it on a copy of a document first.

Public Sub MakeNarrative()
    Dim fld As Field
    Dim codeText As String
    Dim names As String
    Dim itemsPos As Long
    Dim objStart As Long
    Dim newCode As String
    Dim insertPos As Long
    Dim plainText As String
    Dim newText As String
    Dim prefixText As String
    Dim r As Range

    On Error GoTo Failed

    Set fld = FindZoteroFieldAtCursor()
    If fld Is Nothing Then
        MsgBox "Put your cursor inside or right after a Zotero citation, then run this again.", _
            vbExclamation, "Zotero Narrative"
        Exit Sub
    End If

    codeText = fld.Code.Text

    If InStr(1, codeText, "CSL_CITATION", vbBinaryCompare) = 0 Then
        MsgBox "This citation is in an older Zotero format the macro can't read.", _
            vbExclamation, "Zotero Narrative"
        Exit Sub
    End If

    If CountOf(codeText, """itemData""") <> 1 Then
        MsgBox "This only works on citations with one source.", _
            vbExclamation, "Zotero Narrative"
        Exit Sub
    End If

    If InStr(1, codeText, """suppress-author""", vbBinaryCompare) > 0 Then
        MsgBox "This citation already has Omit Author turned on.", _
            vbExclamation, "Zotero Narrative"
        Exit Sub
    End If

    names = BuildNarrativeNames(codeText)
    If Len(names) = 0 Then
        MsgBox "Couldn't find author or editor names for this source.", _
            vbExclamation, "Zotero Narrative"
        Exit Sub
    End If

    itemsPos = InStr(1, codeText, """citationItems""", vbBinaryCompare)
    If itemsPos > 0 Then objStart = InStr(itemsPos, codeText, "{", vbBinaryCompare)
    If objStart = 0 Then
        MsgBox "Couldn't read this citation's Zotero data.", _
            vbExclamation, "Zotero Narrative"
        Exit Sub
    End If

    ' Work out the year-only text, e.g. (2017) or (2017, p. 5),
    ' from the citation text showing on the page.
    plainText = Trim$(Replace(fld.Result.Text, ChrW(160), " "))
    newText = YearOnlyText(plainText)

    ' Keep a prefix like "e.g.," if the citation has one: (e.g., 2016)
    prefixText = GetStringValue(codeText, "prefix")
    If Len(newText) > 0 And Len(prefixText) > 0 Then
        newText = "(" & prefixText & " " & Mid$(newText, 2)
    End If

    ' Turn on Omit Author by adding "suppress-author":true to the citation item.
    newCode = Left$(codeText, objStart) & """suppress-author"":true," & Mid$(codeText, objStart + 1)

    ' Update Zotero's record of the citation text so it matches what we show.
    If Len(newText) > 0 Then
        newCode = ReplaceStringValue(newCode, "plainCitation", newText)
        newCode = ReplaceStringValue(newCode, "formattedCitation", newText)
    End If

    ' Position of the field's opening marker. Names go right before it.
    insertPos = fld.Code.Start - 1

    StartUndo
    fld.Code.Text = newCode
    If Len(newText) > 0 Then
        fld.Result.Text = newText
        ' Clear the dashed underline Zotero uses for citations waiting on Refresh.
        fld.Result.Font.Underline = 0
    End If
    Set r = fld.Code.Duplicate
    r.SetRange insertPos, insertPos
    r.InsertAfter names & " "
    EndUndo

    If Len(newText) > 0 Then
        ShowStatus "Added " & names & "."
    Else
        MsgBox "Names added. Click Refresh in the Zotero tab to finish this one.", _
            vbInformation, "Zotero Narrative"
    End If
    Exit Sub

Failed:
    EndUndo
    MsgBox "Something went wrong: " & Err.Description, vbCritical, "Zotero Narrative"
End Sub

' Finds the Zotero citation the cursor is inside or right after.
Private Function FindZoteroFieldAtCursor() As Field
    Dim fld As Field
    Dim selPos As Long
    Dim fStart As Long
    Dim fEnd As Long

    selPos = Selection.Start
    For Each fld In ActiveDocument.StoryRanges(Selection.StoryType).Fields
        fStart = fld.Code.Start - 1
        fEnd = fld.Result.End + 1
        If selPos >= fStart And selPos <= fEnd Then
            If InStr(1, fld.Code.Text, "ZOTERO_ITEM", vbBinaryCompare) > 0 Then
                Set FindZoteroFieldAtCursor = fld
                Exit Function
            End If
        End If
    Next fld
End Function

' Turns "(Bakker & Demerouti, 2017, p. 5)" into "(2017, p. 5)".
' Returns "" if it can't find the year safely.
Private Function YearOnlyText(ByVal plain As String) As String
    Dim p As Long
    Dim rest As String

    If Left$(plain, 1) <> "(" Or Right$(plain, 1) <> ")" Then Exit Function

    p = InStr(1, plain, ", ", vbBinaryCompare)
    Do While p > 0
        rest = Mid$(plain, p + 2)
        If LooksLikeYear(rest) Then
            YearOnlyText = "(" & rest
            Exit Function
        End If
        p = InStr(p + 2, plain, ", ", vbBinaryCompare)
    Loop
End Function

Private Function LooksLikeYear(ByVal s As String) As Boolean
    Dim ls As String
    If Len(s) = 0 Then Exit Function
    ls = LCase$(s)
    If Left$(s, 1) Like "#" Then
        LooksLikeYear = True
    ElseIf Left$(ls, 4) = "n.d." Or Left$(ls, 8) = "in press" Or Left$(ls, 11) = "forthcoming" Then
        LooksLikeYear = True
    End If
End Function

' Reads the author (or editor) list from Zotero's data and builds the names.
Private Function BuildNarrativeNames(ByVal codeText As String) As String
    Dim itemPos As Long
    Dim arrStart As Long
    Dim arr As String
    Dim people As Collection
    Dim nameList As New Collection
    Dim obj As Variant
    Dim nm As String

    itemPos = InStr(1, codeText, """itemData""", vbBinaryCompare)
    If itemPos = 0 Then Exit Function

    arrStart = FindValueStart(codeText, "author", itemPos)
    If arrStart = 0 Then arrStart = FindValueStart(codeText, "editor", itemPos)
    If arrStart = 0 Then Exit Function
    If Mid$(codeText, arrStart, 1) <> "[" Then Exit Function

    arr = BalancedSegment(codeText, arrStart)
    If Len(arr) = 0 Then Exit Function

    Set people = GetObjects(arr)
    For Each obj In people
        nm = PersonName(CStr(obj))
        If Len(nm) > 0 Then nameList.Add nm
    Next obj

    Select Case nameList.Count
        Case 0
            BuildNarrativeNames = ""
        Case 1
            BuildNarrativeNames = nameList(1)
        Case 2
            BuildNarrativeNames = nameList(1) & " and " & nameList(2)
        Case Else
            BuildNarrativeNames = nameList(1) & " et al."
    End Select
End Function

' Gets the last name (with "van", "de", etc.) or a group author name.
Private Function PersonName(ByVal obj As String) As String
    Dim lit As String
    Dim fam As String
    Dim part As String

    lit = GetStringValue(obj, "literal")
    If Len(lit) > 0 Then
        PersonName = lit
        Exit Function
    End If

    fam = GetStringValue(obj, "family")
    If Len(fam) = 0 Then Exit Function

    part = GetStringValue(obj, "non-dropping-particle")
    If Len(part) > 0 Then fam = part & " " & fam

    PersonName = fam
End Function

' ---------- Small JSON helpers (Word for Mac has no built-in JSON reader) ----------

' Returns the position where the value for "key" starts, or 0 if not found.
Private Function FindValueStart(ByVal s As String, ByVal key As String, ByVal startAt As Long) As Long
    Dim p As Long
    Dim q As Long

    If startAt < 1 Then startAt = 1
    p = startAt
    Do
        p = InStr(p, s, """" & key & """", vbBinaryCompare)
        If p = 0 Then Exit Function
        If p = 1 Or Mid$(s, IIf(p > 1, p - 1, 1), 1) <> "\" Then
            q = SkipSpace(s, p + Len(key) + 2)
            If Mid$(s, q, 1) = ":" Then
                FindValueStart = SkipSpace(s, q + 1)
                Exit Function
            End If
        End If
        p = p + 1
    Loop
End Function

Private Function SkipSpace(ByVal s As String, ByVal p As Long) As Long
    Do While p <= Len(s)
        Select Case Mid$(s, p, 1)
            Case " ", vbTab, vbCr, vbLf
                p = p + 1
            Case Else
                Exit Do
        End Select
    Loop
    SkipSpace = p
End Function

' Returns the string value for "key" in a JSON object, or "".
Private Function GetStringValue(ByVal s As String, ByVal key As String) As String
    Dim v As Long
    v = FindValueStart(s, key, 1)
    If v = 0 Then Exit Function
    If Mid$(s, v, 1) <> """" Then Exit Function
    GetStringValue = ReadJsonString(s, v)
End Function

' Replaces the string value for "key" (first match). Returns s unchanged if not found.
Private Function ReplaceStringValue(ByVal s As String, ByVal key As String, ByVal newVal As String) As String
    Dim v As Long
    Dim endQ As Long

    ReplaceStringValue = s
    v = FindValueStart(s, key, 1)
    If v = 0 Then Exit Function
    If Mid$(s, v, 1) <> """" Then Exit Function
    endQ = JsonStringEnd(s, v)
    If endQ = 0 Then Exit Function

    ReplaceStringValue = Left$(s, v) & JsonEscape(newVal) & Mid$(s, endQ)
End Function

' Returns the position of the closing quote of a JSON string, or 0.
Private Function JsonStringEnd(ByVal s As String, ByVal quotePos As Long) As Long
    Dim i As Long
    Dim ch As String

    i = quotePos + 1
    Do While i <= Len(s)
        ch = Mid$(s, i, 1)
        If ch = "\" Then
            i = i + 2
        ElseIf ch = """" Then
            JsonStringEnd = i
            Exit Function
        Else
            i = i + 1
        End If
    Loop
End Function

Private Function JsonEscape(ByVal s As String) As String
    s = Replace(s, "\", "\\")
    s = Replace(s, """", "\""")
    JsonEscape = s
End Function

' Reads a JSON string that starts at the given quote mark.
Private Function ReadJsonString(ByVal s As String, ByVal quotePos As Long) As String
    Dim i As Long
    Dim ch As String
    Dim nx As String
    Dim out As String

    i = quotePos + 1
    Do While i <= Len(s)
        ch = Mid$(s, i, 1)
        If ch = "\" Then
            nx = Mid$(s, i + 1, 1)
            Select Case nx
                Case "u"
                    out = out & ChrW(CLng("&H" & Mid$(s, i + 2, 4)))
                    i = i + 6
                Case "n", "r", "t", "b", "f"
                    out = out & " "
                    i = i + 2
                Case Else
                    out = out & nx
                    i = i + 2
            End Select
        ElseIf ch = """" Then
            Exit Do
        Else
            out = out & ch
            i = i + 1
        End If
    Loop
    ReadJsonString = out
End Function

' Returns the full [ ... ] or { ... } block that opens at openPos.
Private Function BalancedSegment(ByVal s As String, ByVal openPos As Long) As String
    Dim i As Long
    Dim ch As String
    Dim depth As Long
    Dim inQuote As Boolean
    Dim esc As Boolean

    For i = openPos To Len(s)
        ch = Mid$(s, i, 1)
        If inQuote Then
            If esc Then
                esc = False
            ElseIf ch = "\" Then
                esc = True
            ElseIf ch = """" Then
                inQuote = False
            End If
        Else
            Select Case ch
                Case """"
                    inQuote = True
                Case "[", "{"
                    depth = depth + 1
                Case "]", "}"
                    depth = depth - 1
                    If depth = 0 Then
                        BalancedSegment = Mid$(s, openPos, i - openPos + 1)
                        Exit Function
                    End If
            End Select
        End If
    Next i
End Function

' Splits a JSON array of objects into a list of { ... } strings.
Private Function GetObjects(ByVal arr As String) As Collection
    Dim c As New Collection
    Dim i As Long
    Dim ch As String
    Dim depth As Long
    Dim startPos As Long
    Dim inQuote As Boolean
    Dim esc As Boolean

    For i = 1 To Len(arr)
        ch = Mid$(arr, i, 1)
        If inQuote Then
            If esc Then
                esc = False
            ElseIf ch = "\" Then
                esc = True
            ElseIf ch = """" Then
                inQuote = False
            End If
        Else
            Select Case ch
                Case """"
                    inQuote = True
                Case "{"
                    depth = depth + 1
                    If depth = 1 Then startPos = i
                Case "}"
                    If depth = 1 Then c.Add Mid$(arr, startPos, i - startPos + 1)
                    depth = depth - 1
            End Select
        End If
    Next i
    Set GetObjects = c
End Function

Private Function CountOf(ByVal s As String, ByVal findText As String) As Long
    Dim p As Long
    Dim n As Long
    p = InStr(1, s, findText, vbBinaryCompare)
    Do While p > 0
        n = n + 1
        p = InStr(p + Len(findText), s, findText, vbBinaryCompare)
    Loop
    CountOf = n
End Function

' ---------- Undo and status bar (late bound so Word for Mac won't fail if missing) ----------

Private Sub StartUndo()
    Dim app As Object
    On Error Resume Next
    Set app = Application
    app.UndoRecord.StartCustomRecord "Zotero Narrative"
End Sub

Private Sub EndUndo()
    Dim app As Object
    On Error Resume Next
    Set app = Application
    app.UndoRecord.EndCustomRecord
End Sub

Private Sub ShowStatus(ByVal msg As String)
    Dim app As Object
    On Error Resume Next
    Set app = Application
    app.StatusBar = msg
End Sub