VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "CPretty"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Ext_KEY = "RVB_UniqueId" ,"379617B10166"
'----------------------
'Provides a filter through which lines can be pretty printed.
'Create one of these then pass text into the pretty method.
'Copy the output of pretty to a string.  After the last call to
'pretty call flush to get any pending text.  If the text passed to
'pretty was a complete block then flush should return nothing.
'----------------------
Option Explicit

'--Private Module Constants


'-- State variables
Private mlIndent As Long
Private msLastLine As String
Private moLines As Collection
Private moPoint As CPoint
Private msCurrentLine As String
Private msCurrentChar As String
Private mbALLOWSINGLELINEIF As Boolean
Private moExcursions As Collection
'-- End state variables

'-- Types
Private Type tExcursion
  lLineNumber As Long
  lColumnNumber As Long
End Type



';--------------------------
';Usage...: Set number of spaces to be added or subtracted for each indent level
';--------------------------
Public Property Get INDENT() As Long
  INDENT = mlIndent
End Property


Public Property Let INDENT(ByVal vlValue As Long)
  mlIndent = vlValue
End Property



';--------------------------
';Usage...: True if single line if statements are to be recognized
';--------------------------
Public Property Get ALLOWSINGLELINEIF() As Boolean
  ALLOWSINGLELINEIF = mbALLOWSINGLELINEIF
End Property


Public Property Let ALLOWSINGLELINEIF(ByVal vbValue As Boolean)
  mbALLOWSINGLELINEIF = vbValue
End Property



';----------------------
';Notes...: Feed lines into this and get indented lines back.  Modelled on
';          visual-basic-mode.el.
';----------------------
Public Function Prettify(ByVal vsLine As String) As String

  Dim sLine As String

  moLines.Add vsLine
  CURRENTLINENUMBER = moLines.Count
  CURRENTCOLUMNNUMBER = 1

  sLine = xIndentLine

  With moLines
    .Remove .Count
    .Add sLine
  End With

  msLastLine = sLine
  Prettify = sLine

End Function



';----------------------
';Usage...: Classify lines by regular expression
';----------------------
Private Function xLookingAt(ByRef roRegexp As RegExp) As Boolean
  xLookingAt = roRegexp.Test(msCurrentLine)
End Function



';----------------------
'Feed lines into this and get indented lines back.  Modelled on
';          visual-basic-mode.el.  Relies on the state of previous lines.
';----------------------
Private Function xIndentLine() As String
  xIndentLine = xIndentToColumn(xCalcIndent)
End Function



';----------------------
'Feed lines into this and get indented lines back.  Modelled on
';          visual-basic-mode.el.
'----------------------
Private Function xIndentToColumn(ByVal vlIndent As Long) As String
  xIndentToColumn = Space$(vlIndent) & Trim$(msCurrentLine)
End Function



';----------------------
'Calculate the indent for this line based on it and the previous
';          line (or lines).
';          VB does not short circuit so we split into separate if..then
';          clauses what is a big OR statement in the elisp on which this is
';          based.
'----------------------
Private Function xCalcIndent() As Long

  Dim lIndent As Long
  Dim oOriginalPoint As CPoint

  Set oOriginalPoint = moPoint.Copy

  xSaveExcursion

  If PDefunStartRE.Test(msCurrentLine) Or PLabelRE.Test(msCurrentLine) _
     Or PDefunEndRE.Test(msCurrentLine) Then
    xCalcIndent = 0
  ElseIf PElseRE.Test(msCurrentLine) Or PEndIfRE.Test(msCurrentLine) Then
    xCalcIndent = xIndentOf(xFindMatchingIf)
ElseIf PNextRE.Test(msCurrentLine) Then
  xCalcIndent = xIndentOf(xFindMatchingFor)
ElseIf PLoopRE.Test(msCurrentLine) Then
  xCalcIndent = xIndentOf(xFindMatchingDo)
ElseIf PWendRE.Test(msCurrentLine) Then
  xCalcIndent = xIndentOf(xFindMatchingWhile)
ElseIf PEndWithRE.Test(msCurrentLine) Then
  xCalcIndent = xIndentOf(xFindMatchingWith)
ElseIf PSelectEndRE.Test(msCurrentLine) Then
  xCalcIndent = xIndentOf(xFindMatchingSelect)
ElseIf PCaseRE.Test(msCurrentLine) Then
  xCalcIndent = INDENT + xIndentOf(xFindMatchingSelect)
ElseIf PEndBeginRE.Test(msCurrentLine) Then
  xCalcIndent = xIndentOf(xFindMatchingBegin)
Else
  xPreviousLineOfCode
  Do While xLookingAt(PLabelRE)
    xPreviousLineOfCode
  Loop
  If xLookingAt(PContinuationRE) Then
    'deal with continuation lines separately
    xFindOriginalStatement
    ' Indent continuation line under matching open paren,
    'or else one word in.
    Dim oOrigStmt As CPoint
    Set oOrigStmt = moPoint.Copy
    Dim lMatchingOpenParen As Long
    lMatchingOpenParen = -1
    xSaveExcursion
    xGotoChar oOriginalPoint
    xBackwardUpList
    ';; Only if point is now w/in cont. block.
    If (oOrigStmt.LE(moPoint)) Then
      lMatchingOpenParen = moPoint.COLUMN
    End If
    xRestoreExcursion

    If lMatchingOpenParen > 0 Then
      xCalcIndent = lMatchingOpenParen
    Else
      '      ;; Else, after first word on original line.
      xBackToIndentation
      xForwardWord
      '''Do While xLookingAt(PWhiteSpaceCharRE)
      Do While PWhiteSpaceCharRE.Test(msCurrentChar)
        If Not xForwardChar Then
          Exit Do
        End If
      Loop
      xCalcIndent = CURRENTCOLUMNNUMBER - 1 ' subtract one because we want to know how many spaces to add not the column number of the first-non-space
    End If
  Else
    xFindOriginalStatement
    lIndent = xIndentOf(msCurrentLine)
    If PDefunStartRE.Test(msCurrentLine) Then
      xCalcIndent = lIndent + INDENT
    ElseIf (PIfRE.Test(msCurrentLine) _
            Or PElseRE.Test(msCurrentLine)) _
           And (Not (ALLOWSINGLELINEIF _
                     And PIfThenRE.Test(msCurrentLine))) Then
      xCalcIndent = lIndent + INDENT
    ElseIf (PSelectRE.Test(msCurrentLine) _
            Or PCaseRE.Test(msCurrentLine)) Then
      xCalcIndent = lIndent + INDENT
    ElseIf (PSelectRE.Test(msCurrentLine) _
            Or PCaseRE.Test(msCurrentLine)) Then
      xCalcIndent = lIndent + INDENT
    ElseIf (PDoRE.Test(msCurrentLine)) Then
      xCalcIndent = lIndent + INDENT
    ElseIf (PForRE.Test(msCurrentLine)) Then
      xCalcIndent = lIndent + INDENT
    ElseIf (PWhileRE.Test(msCurrentLine)) Then
      xCalcIndent = lIndent + INDENT
    ElseIf (PWithRE.Test(msCurrentLine)) Then
      xCalcIndent = lIndent + INDENT
    ElseIf (PBeginRE.Test(msCurrentLine)) Then
      xCalcIndent = lIndent + INDENT
    Else
      xCalcIndent = lIndent
    End If
  End If
End If

xRestoreExcursion

End Function



'----------------------
'Clear the collection - release all objects
'----------------------
Public Sub Clear()

  Set moLines = New Collection
  msLastLine = ""
  Set moExcursions = New Collection
  Set moPoint = New CPoint

End Sub


'======= Class Events =======

Private Sub Class_Initialize()
  appCreateREs
  Clear
End Sub


'======= Private Methods =======




';----------------------
'Parms...: roOpenRE = Regular expression matching opening bracket
';          roCloseRE = Regular expression matching closing bracket
';Returns.: string  = line found
';Usage...: Use to find a matching indenting statement
';Notes...: Always returns a line even if that line is simply the first in
';          the list.
'----------------------
Private Function xFindMatchingStatement(ByRef roOpenRE As RegExp, _
                                        ByRef roCloseRE As RegExp) As String

  Dim lLevel As Long

  lLevel = 0

  Do While (CURRENTLINENUMBER > 1) And (lLevel >= 0)
    xPreviousLineOfCode
    xFindOriginalStatement
    If roCloseRE.Test(msCurrentLine) Then
      lLevel = lLevel + 1
    ElseIf roOpenRE.Test(msCurrentLine) Then
      lLevel = lLevel - 1
    End If
  Loop

  xFindMatchingStatement = msCurrentLine

End Function



Private Function xFindMatchingIf() As String
xFindMatchingIf = xFindMatchingStatement(PIfRE, PEndIfRE)
End Function



Private Function xFindMatchingSelect() As String
  xFindMatchingSelect = xFindMatchingStatement(PSelectRE, PSelectEndRE)
End Function



Private Function xFindMatchingFor() As String
  xFindMatchingFor = xFindMatchingStatement(PForRE, PNextRE)
End Function



Private Function xFindMatchingDo() As String
  xFindMatchingDo = xFindMatchingStatement(PDoRE, PLoopRE)
End Function



Private Function xFindMatchingWhile() As String
  xFindMatchingWhile = xFindMatchingStatement(PWhileRE, PWendRE)
End Function



Private Function xFindMatchingWith() As String
  xFindMatchingWith = xFindMatchingStatement(PWithRE, PEndWithRE)
End Function



Private Function xFindMatchingBegin() As String

  Dim lOriginalLine As Long

  lOriginalLine = CURRENTLINENUMBER

  xFindMatchingBegin = xFindMatchingStatement(PBeginRE, PEndBeginRE)
  If CURRENTLINENUMBER = 1 Then
    CURRENTLINENUMBER = lOriginalLine
    xFindMatchingBegin = xPreviousLineOfCode
  End If

End Function




';----------------------
'Parms...: vsLine = string to be examined
'Find the indent of this line.
'----------------------
Private Function xIndentOf(ByVal vsLine As String) As Long

  Dim lIndent As Long

  lIndent = 1
  Do While (Mid(vsLine, lIndent, 1) = " ")
    lIndent = lIndent + 1
    If (lIndent > Len(vsLine)) Then
      Exit Do
    End If
  Loop

  xIndentOf = lIndent - 1

End Function




';----------------------
'Move point to previous code line
'----------------------
Private Function xPreviousLineOfCode() As String

  If CURRENTLINENUMBER > 1 Then
    CURRENTLINENUMBER = CURRENTLINENUMBER - 1
    Do While (CURRENTLINENUMBER > 1) _
       And (xLookingAt(PBlankRE) Or (xLookingAt(PCommentRE)))
      CURRENTLINENUMBER = CURRENTLINENUMBER - 1
    Loop
  End If

  xPreviousLineOfCode = msCurrentLine

End Function



';----------------------
'Move point to start of multiline statement
'----------------------
Private Function xFindOriginalStatement() As String

  Dim lHere As Long
  lHere = CURRENTLINENUMBER
  xPreviousLineOfCode
  If ((CURRENTLINENUMBER > 1) Or Not xLookingAt(PContinuationRE)) Then
    Do While ((CURRENTLINENUMBER > 1) And xLookingAt(PContinuationRE))
      lHere = CURRENTLINENUMBER
      xPreviousLineOfCode
    Loop
    CURRENTLINENUMBER = lHere
  End If


End Function

Public Property Get CURRENTLINENUMBER() As Long
  CURRENTLINENUMBER = moPoint.LINE
End Property


Public Property Let CURRENTLINENUMBER(ByVal vlValue As Long)
  moPoint.LINE = vlValue
  If vlValue > 0 Then
    msCurrentLine = moLines(vlValue)
  End If

End Property



Public Property Get CURRENTCOLUMNNUMBER() As Long
  CURRENTCOLUMNNUMBER = moPoint.COLUMN
End Property


Public Property Let CURRENTCOLUMNNUMBER(ByVal vlValue As Long)

  moPoint.COLUMN = vlValue
  If vlValue < 1 Then
    msCurrentChar = ""
  Else
    msCurrentChar = Mid(msCurrentLine, vlValue, 1)
  End If

End Property



Private Function xSaveExcursion() As tExcursion

  moExcursions.Add moPoint.Copy

End Function



Private Function xRestoreExcursion() As Boolean

  With moExcursions
    With .Item(.Count)
      CURRENTLINENUMBER = .LINE
      CURRENTCOLUMNNUMBER = .COLUMN
    End With
    .Remove .Count
  End With

End Function



';----------------------
';Notes...: Do _not_ just copy the reference because this will make oPoint and moPoint the same thing.
';----------------------
Private Function xGotoChar(ByRef oPoint As CPoint) As Boolean

  CURRENTLINENUMBER = oPoint.LINE
  CURRENTCOLUMNNUMBER = oPoint.COLUMN

End Function




';----------------------
'Find beginning of bracketed expression
'Move backwards until an opening bracket is found.
'----------------------
Private Function xBackwardUpList() As Long

  Dim lLevel As Long
  Dim sBracket As String

  lLevel = 0

  Do
    If xBackwardChar Then
      sBracket = Mid(msCurrentLine, CURRENTCOLUMNNUMBER, 1)
      If sBracket = "(" Then
        lLevel = lLevel - 1
      ElseIf sBracket = ")" Then
        lLevel = lLevel + 1
      End If
      If lLevel < 0 Then
        Exit Do
      End If
    Else
      Exit Do
    End If
  Loop

End Function





';----------------------
'True if successful, false if reached start of buffer
'Find beginning of bracketed expression
'----------------------
Private Function xBackwardChar() As Boolean

  xBackwardChar = True
  If CURRENTCOLUMNNUMBER > 1 Then
    CURRENTCOLUMNNUMBER = CURRENTCOLUMNNUMBER - 1
  ElseIf CURRENTLINENUMBER > 1 Then
    CURRENTLINENUMBER = CURRENTLINENUMBER - 1
    If msCurrentLine = "" Then
      msCurrentLine = " " ' quick fix for problems caused by zero length lines
    End If
    CURRENTCOLUMNNUMBER = Len(msCurrentLine)
  Else
    xBackwardChar = False
  End If

End Function







';----------------------
'Move point to first non whitespace character on the line
'----------------------
Private Function xBackToIndentation() As Boolean

  xBackToIndentation = True
  CURRENTCOLUMNNUMBER = xIndentOf(msCurrentLine)

End Function



';----------------------
'Move point to next word
'Word is any alpha numeric
'----------------------
Private Function xForwardWord() As Boolean

  xForwardWord = True
  Do While Not PWordConstituentRE.Test(msCurrentChar)
    If Not xForwardChar Then
      Exit Do
    End If
  Loop

  Do While PWordConstituentRE.Test(msCurrentChar)
    If Not xForwardChar Then
      Exit Do
    End If
  Loop


End Function







';----------------------
'True if successful
'Move point to next character
'----------------------
Private Function xForwardChar() As Boolean

  xForwardChar = True
  If CURRENTCOLUMNNUMBER < Len(msCurrentLine) Then
    CURRENTCOLUMNNUMBER = CURRENTCOLUMNNUMBER + 1
  ElseIf CURRENTLINENUMBER < moLines.Count Then
    CURRENTLINENUMBER = CURRENTLINENUMBER + 1
    CURRENTCOLUMNNUMBER = 1
  Else
    xForwardChar = False
  End If

End Function