PC Plus SuperCD (UK) 2000 March/pcp161b.iso/handson/archive/Issue160/files/SyntaxEditor/main.pas

Pascal/Delphi Source File | 1999-10-18 | 9.8 KB | 308 lines

unit main;

(* PC PLUS Sample Delphi syntax-colouring application.

   Illustrates a simple way to read a plain text file containing program code,
   colour it according to its syntax, by adding RTF codes as necessary,
   then fill a RichEdit control with the coloured code.

   Syntax recognised:
   - Delphi keywords
   - Strings
   - Curly-brace comments
   - Starred comments
   - Single-line comments

   Deficiencies:

   The principal deficiency is that the editor does not do on-the-fly colour
   coding of strings and comments.

   It needs to be improved so that it automatically colours strings and
   un-colours them if the string delimiters are deleted.

   It should similarly colour and un-colour comments when their delimiters
   are deleted.

   Note that dealing with comments correctly is a tougher task than dealing
   with strings. The really big problem here is dealing with long multi-line
   comments. For example, it should be possible to enclose a large block
   of code between pairs of curly-brace or starred comments and have the entire
   block immediately recoloured as a comment. When the comment delimiters are
   deleted, the code should be recoloured as normal.

   - does not deal correctly with colour-coding after cut and paste operations
     or when two lines require recolouring (e.g. if you press the Enter key
     to divide the token beginend into begin on one line and end on the next,
     then only the end token will be colour-coded.

   - does not check if it's ok to load a new file (i.e. if the current
     file has been modified and needs to be saved first). This can be checked
     using the RichEdit1.Modified property.

   - Limited error-handling
     This can be improved by adding exception handling when attempting
     to read and write from streams and by testing the 'status'
     parameter after every read-write operation.

   - Could be optimised
     I have not gone to any lengths to fine-tune my code for efficiency. The
     speed of file loading is perfectly adequate with files up to 500K or so.
     With files in excess of a Megabyte, there is a noticable delay - but only
     of a few seconds (on a 333MHz PC), which seems quite reasonable. All the
     same, there are places in the code where the efficiency could certainly
     be improved.

   - Bugs?
     This is only a sample application and I haven't had the time (or the
     inclination!) to test this rigorously. No doubt there are bugs of varying
     degrees of unsubtlety lurking in here somewhere. Have fun find them and
     squashing them!

   Author: Huw Collingbourne.

*)

// The following comments have been added to test colour-coding when
// loading this source file.
{ This is a
  2-line comment}
interface
      { 'a string'  (*a starred
         comment *)  inside a standard one  }
(* This is a starred comment *)
(* {a standard comment} inside a starred one        *)
// { standard comment after line comment }
{ // line comment in standard comment }

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ComCtrls, ExtCtrls,
  Syntax, EditConsts, RichEditUtils, StrUtils, Menus;

type
  chararray = array[0..255] of char;
     // ReadStatus defines type of the status parameter
  ReadStatus = SUCCESS..READERROR;

  TForm1 = class(TForm)
    RichEdit1: TRichEdit;
    OpenDialog1: TOpenDialog;
    SaveDialog1: TSaveDialog;
    MainMenu1: TMainMenu;
    File1: TMenuItem;
    NewMenuItem: TMenuItem;
    SaveMenuItem: TMenuItem;
    SaveAsMenuItem: TMenuItem;
    N1: TMenuItem;
    ExitMenuItem: TMenuItem;
    Print1: TMenuItem;
    LoadMenuItem: TMenuItem;
    PrintDialog1: TPrintDialog;
    StatusBar1: TStatusBar;
    procedure FormCreate(Sender: TObject);
    procedure NewMenuItemClick(Sender: TObject);
    procedure LoadMenuItemClick(Sender: TObject);
    procedure SaveAsMenuItemClick(Sender: TObject);
    procedure SaveMenuItemClick(Sender: TObject);
    procedure ExitMenuItemClick(Sender: TObject);
    procedure Print1Click(Sender: TObject);
  private
    { Private declarations }
  public
    SourceFileName : string;
    procedure SetSourceFileName( FN : String);
    procedure FormatLineAt( Red: TRichEdit; num : LongInt );
    procedure SetNormalAttributes( atts : TTextAttributes );
    procedure SetKeywordAttributes( atts : TTextAttributes );
    procedure LoadFile(FN : string );
    procedure OnChangeHandler(Sender: TObject);
    function NeedsColouring( atts : TTextAttributes ) : boolean;
  end;

const
     APPNAME = 'Huw''s Colour-coded thing';
     INFILE = '';
var
   Form1 : TForm1;

implementation
  {$R *.DFM}

function TForm1.NeedsColouring( atts : TTextAttributes ) : boolean;
{ NOTE: This function is a bit of a cheat. It simply does not attempt
        to recolour existing strings or comments - that is, if the
        selected text has the attributes of a comment or string, it
        doesn't attempt to do any recolouring.

        The problem with this is that:
        a) it does not colour newly added strings or comments
        b) it does not un-colour code that when the string or
           comment delimiters are deleted. }
begin
  if ((atts.Color = STRINGCOL) and (atts.Style = STRINGSTYLE))
     or  ((atts.Color = COMMENTCOL) and (atts.Style = COMMENTSTYLE)) then
     result := false
  else
     result := true;
end;

procedure TForm1.setNormalAttributes( atts : TTextAttributes );
begin
 // recolour selected text using plain text attributes unless
 // the selected text already has those attributes, in which case, do nothing
  if not ((atts.Color = PLAINCOL) and (atts.Style = PLAINSTYLE)) then
  begin
    RichEdit1.SelAttributes.Style := PLAINSTYLE;
    RichEdit1.selAttributes.Color := PLAINCOL;
  end;
end;

procedure TForm1.setKeyWordAttributes( atts : TTextAttributes );
begin
 // recolour selected text using keyword text attributes unless
 // the selected text already has those attributes, in which case, do nothing
if not ((atts.Color = KWCOL) and (atts.Style = KWSTYLE)) then
  begin
    RichEdit1.SelAttributes.Style := KWSTYLE;
    RichEdit1.selAttributes.Color := KWCOL;
  end;
end;


procedure TForm1.FormatLineAt( Red: TRichEdit; num : LongInt );
                                    // num is RichEdit1.Lines[num]
var
   ti : tokenindexes;
   i, numfound : integer;
   StartIndex : LongInt;
   s : string;
   textatts : TTextAttributes;
begin
  s := red.Lines[num];
  TokensFoundAt( s, numfound, ti );
  StartIndex := GetLineSelStartIndex( Red, num );
  for i := 1 to numfound do
  begin
     Red.SelStart := StartIndex + ti[i].tstart;
     Red.SelLength := ti[i].tend;
     textatts := Red.SelAttributes;
     if NeedsColouring( textatts ) then //!! This is my quick getout clause!
     begin
       if KeyWord( Red.SelText ) then
       begin
          //!! Here test for existing attributes and only reformat if necessary
           SetKeyWordAttributes( textatts );
           //!! move selection to end of keyword and re-set normal attributes
           Red.SelStart := Red.SelStart + Red.SelLength;
           Red.SelLength := 1;
           SetNormalAttributes( textatts );
       end
       else
           SetNormalAttributes( textatts );
      end; // if NeedsColouring
   end;
end;


procedure TForm1.LoadFile( FN : string );
var
   msin, msout : TMemoryStream;
begin
   msin := TMemoryStream.Create;
   msout := TMemoryStream.Create;
   msin.LoadFromFile(FN);
   msin.Position := 0;  // set pos to 0 prior to loading from stream
   msout.Position := 0;
   WriteRTFHeader( msout );
   processStream(msin, msout);
   WriteRTFTerminator( msout );
   msout.Position := 0;
   RichEdit1.Lines.LoadFromStream(msout);
   msin.Free;
   msout.Free;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  RichEdit1.Plaintext := false;
  SetSourceFileName( 'Untitled' );
  RichEdit1.OnChange := OnChangeHandler;
end;

procedure TForm1.OnChangeHandler(Sender: TObject);
var
   startSelPos : Longint;
begin
   RichEdit1.OnChange := nil;
   HideSelection(RichEdit1);
   startSelPos := RichEdit1.SelStart;
   FormatLineAt(RichEdit1,GetCurrLineNum(RichEdit1));
   RichEdit1.SelStart := startSelPos;
   ShowSelection(RichEdit1);
   RichEdit1.OnChange := OnChangeHandler;
end;

procedure TForm1.SetSourceFileName(FN: String);
begin
  SourceFileName := FN;
  Caption := Format('%s [ %s ]', [APPNAME,ExtractFileName(FN)]);
end;

procedure TForm1.NewMenuItemClick(Sender: TObject);
begin
  SetSourceFileName( 'Untitled' );
  RichEdit1.Lines.Clear;
end;

procedure TForm1.LoadMenuItemClick(Sender: TObject);
begin
  if OpenDialog1.Execute then
  begin
     LoadFile( OpenDialog1.FileName );
     SetSourceFileName(OpenDialog1.FileName);
  end;
end;

procedure TForm1.SaveAsMenuItemClick(Sender: TObject);
begin
  if SaveDialog1.Execute then
  begin
    if FileExists(SaveDialog1.FileName) then
      if MessageDlg(Format('Save over existing %s?', [SaveDialog1.FileName]),
        mtConfirmation, mbYesNoCancel, 0) = idYes then
    begin
       RichEdit1.PlainText := true;
       RichEdit1.Lines.SaveToFile(SaveDialog1.FileName);
       RichEdit1.PlainText := false;
       SetSourceFileName(SaveDialog1.FileName);
    end;
  end;
end;

procedure TForm1.SaveMenuItemClick(Sender: TObject);
begin
  if SourceFileName = 'Untitled' then
    SaveAsMenuItemClick(Sender)
  else
  begin
     RichEdit1.PlainText := true;
     RichEdit1.Lines.SaveToFile(SaveDialog1.FileName);
     RichEdit1.PlainText := false;
  end;
end;

procedure TForm1.ExitMenuItemClick(Sender: TObject);
begin
  if MessageDlg('Exit the Editor?',mtConfirmation,[mbYes, mbNo],0) = mrYes then
    Close;
end;

procedure TForm1.Print1Click(Sender: TObject);
begin
  if PrintDialog1.Execute then
    RichEdit1.Print(SourceFileName);
end;

end.