Example47: Lexer - Container (Advanced)

Category: Controls - Scintilla

Date: 03-28-2012

Return to Index


 
'This snippet builds on the "Lexer - Container(Simple)" snippet by
'adding a more complete lexing capability to the custom lexer function.
'In the previous snippet, the lexer styled an entire line at at time.
'The lexer discussed here breaks up the text and applies styling at
'a lower level (keywords, punctuation, operators, ...)
 
 
'Primary Code
 
 
'Compilable Example:
#Compiler PBWin 9, PBWin 10
#Compile EXE
#Dim All
#Include "Win32API.inc"
#Include "scintilla_gb.inc"
 
%ID_Sci = 1000
%SCE_Style_Numbers = 1  : %SCE_Style_Strings = 2  : %SCE_Style_Keywords = 3
%SCE_Style_Comments = 4 : %SCE_Style_Default = 5 : %SCE_Style_Operators = 6
 
Global hDlg, hSci, hLib As DWord
Global LWords() As String, UWords() As String, MWords() As String
Global CodeCase As Long
 
Function PBMain() As Long
   hLib = LoadLibrary("SCILEXER.DLL")
   Dialog New Pixels, 0, "Scintilla: Container Lexer",300,300,300,200, %WS_OverlappedWindow To hDlg
   Control Add "Scintilla", hDlg, %ID_Sci, "", 10,10,180,130, %WS_Child Or %WS_Visible
   Control Handle hDlg, %ID_Sci To hSci     'get handle to Scintilla window
   Dialog Show Modal hDlg Call DlgProc
End Function
 
CallBack Function DlgProc() As Long
   Local pNSC As SCNotification Ptr       ' // Scintilla notification messages
   Select Case CB.Msg
      Case %WM_InitDialog
         CodeCase = 3
         InitializeSci
         InitializeKeyWords
         PostMessage hSci, %SCI_SetSel, 0,0 'unselect initially
      Case %WM_Notify
         Select Case CB.NmID
            Case %ID_Sci
               pNSC = CB.lParam
               Select Case @pNSC.hdr.Code
                  Case %SCN_StyleNeeded
                     CustomPBLexer @pNSC.position
               End Select
         End Select
      Case %WM_Size
         Control Set Size hDlg, %ID_Sci, Lo(Word, CB.lParam)-20, Hi(Word, CB.lParam)-20
      Case %WM_Destroy
         If hLib Then FreeLibrary hLib             ' Free the Scintilla library
   End Select
End Function
 
Sub InitializeSci
   Local txt As String
   txt = "Select Case" + $CrLf
   txt = txt + "'   Case " + Chr$(34) + "cat" + Chr$(34) + $CrLf
   txt = txt + "'   Case " + Chr$(34) + "dog" + Chr$(34) + $CrLf
   txt = txt + "End Select" + Chr$(0)
   SendMessage(hSci, %SCI_SetText,         0, StrPTR(txt))       'set example text
   SendMessage hSci, %SCI_SetMarginWidthN, 0, 20                 'display line numbers
   SendMessage hSci, %SCI_SetLexer,  %SCLEX_Container, 0         'container does lexing
   SetLexerStyles
End Sub
 
Sub SetLexerstyles
   SendMessage hSci, %SCI_StyleSetFore, %SCE_Style_Comments,  %Green
   SendMessage hSci, %SCI_StyleSetFore, %SCE_Style_Keywords,  %Blue
   SendMessage hSci, %SCI_StyleSetFore, %SCE_Style_Strings,   %Red
   SendMessage hSci, %SCI_StyleSetFore, %SCE_Style_Numbers,   %Gray
   SendMessage hSci, %SCI_StyleSetFore, %SCE_Style_Default,   %Black
   SendMessage hSci, %SCI_StyleSetFore, %SCE_Style_Operators, %Green
End Sub
 
Sub InitializeKeyWords
   Local temp$, i As Long
   ReDim UWords(1000), LWords(1000), MWords(1000)
   Open Exe.Path$ + "keywords.txtFor Input As #1
   While IsFalse Eof(1)
      Line Input #1, temp$
      If Len(Trim$(temp$)) Then
         MWords(i) = temp$
         UWords(i) = UCase$(MWords(i))
         LWords(i) = LCase$(MWords(i))
         Incr i
      End If
   Wend
   Close #1
   ReDim Preserve UWords(i-1), LWords(i-1), MWords(i-1)
End Sub
 
Sub CustomPBLexer (ByVal iEndPos As Long)
   Local iLine, iStartPos, iStartLine, iEndLine As Long, c As String
   'lines from position returned by GetEndStyle to line containing SCNotification.position
   iStartPos = SendMessage(hSci, %SCI_GetEndStyled,0,0)
   iStartLine  = SendMessage(hSci, %SCI_LineFromPosition,iStartPos,0) 'start line
   iEndLine = SendMessage(hSci, %SCI_LineFromPosition,iEndPos,0)      'end line
   For iLine = iStartLine To iEndLine
      LexOneLine iLine
   Next iLine
End Sub
 
Sub LexOneLine(iLine As Long)
   Local I, iStart, iEnd, iLineLength, wFlag, StopPos, iResult As Long
   Local txt, xWord As String
   Local Letter As Byte Ptr
 
   iStart  = SendMessage( hSci, %SCI_PositionFromLine, iLine, 0)   'position of 1st char in line
   iEnd    = SendMessage( hSci, %SCI_GetLineEndPosition, iLine, 0) 'postion of last char in line
   iLineLength = SendMessage( hSci, %SCI_LineLength , iLine, 0)    'get line width
   txt = String$(iLineLength," ") + $Nul                           'set buffer length
   SendMessage hSci, %SCI_GetLine , iLine, StrPTR(txt)                 'get line text
   txt = UCase$(txt)   'CharUpperBuff(ByVal StrPTR(Buf), iLineLength)  'Make UCASE
 
   '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   ' Loop through each character in the line, using a pointer for better speed
   '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   Letter = StrPTR(txt) : wFlag = 0
   For I = 1 To Len(txt)
      Select Case @Letter 'The characters we need to inlude in a word
         Case 97 To 122, 65 To 90, 192 To 214, 216 To 246, 248 To 255, 35 To 38, 48 To 57, 63, 95
            If wFlag = 0 Then
               wFlag = 1 : stopPos = I
            End If
 
         Case 34 ' string quotes -> "
            stopPos = Instr(I + 1, txt, Chr$(34)) 'Find match
            If StopPos Then
               SendMessage(hSci, %SCI_StartStyling,iStart + I,31)
               SendMessage(hSci, %SCI_SetStyling, StopPos - 1 - I, %SCE_Style_Strings) 'style iLineLength characters
               StopPos = (StopPos - I + 1)
               I = I + StopPos
               Letter = Letter + StopPos
               wFlag = 0
            End If
 
         Case 39 ' comment character -> '
            SendMessage(hSci, %SCI_StartStyling,iStart + I - 1,31)
            SendMessage(hSci, %SCI_SetStyling, iLineLength - I + 1, %SCE_Style_Comments)
            wFlag = 0
            Exit For
 
         Case Else  'word is ready
            If wFlag = 1 Then
               xWord = Mid$(txt, stopPos, I - stopPos)  'Get word
               If xWord = "REMThen  'extra for the uncomment word, REM
                  SendMessage(hSci, %SCI_StartStyling,iStart + I - Len(xWord) - 1,31)
                  SendMessage(hSci, %SCI_SetStyling, iLineLength - I + Len(xWord) + 1, %SCE_Style_Comments)
                  wFlag = 0
                  Exit For
               End If
               Array Scan UWords(0), = xWord, To iResult  'Is it in the array?
               '---------------------------------upper/lower/mixed handled here-----------
               'If iResult AND CodeCase& Then
               '   xWord = Choose$(CodeCase&, UWords(iResult-1), LWords(iResult-1), MWords(iResult-1))
               '   SendMessage hSci, %SCI_SetTargetStart, iStart + I - Len(xWord) - 1, 0
               '   SendMessage hSci, %SCI_SetTargetEnd, iStart + I, 0
               '   SendMessage hSci, %SCI_ReplaceTarget, Len(xWord), StrPTR(xWord)
               '   SendMessage hSci, %SCI_GoToPos, iStart + I, 0
               'End If
               '----------------------------------------------------------------------
               SendMessage(hSci, %SCI_StartStyling,iStart + StopPos - 1,31)
               SendMessage(hSci, %SCI_SetStyling, I - StopPos, IIF(iResult, %SCE_Style_Keywords,%SCE_Style_Default))
               wFlag = 0
            End If
      End Select
      Incr Letter
   Next I
 
End Sub
 
'gbs_00665
'Date: 03-10-2012


created by gbSnippets
http://www.garybeene.com/sw/gbsnippets.htm