lazarus/ide/checklfmdlg.pas

{  $Id$  }
{
 /***************************************************************************
                            checklfmdlg.pas
                            ---------------

 ***************************************************************************/

 ***************************************************************************
 *                                                                         *
 *   This source is free software; you can redistribute it and/or modify   *
 *   it under the terms of the GNU General Public License as published by  *
 *   the Free Software Foundation; either version 2 of the License, or     *
 *   (at your option) any later version.                                   *
 *                                                                         *
 *   This code is distributed in the hope that it will be useful, but      *
 *   WITHOUT ANY WARRANTY; without even the implied warranty of            *
 *   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU     *
 *   General Public License for more details.                              *
 *                                                                         *
 *   A copy of the GNU General Public License is available on the World    *
 *   Wide Web at <http://www.gnu.org/copyleft/gpl.html>. You can also      *
 *   obtain it by writing to the Free Software Foundation,                 *
 *   Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.        *
 *                                                                         *
 ***************************************************************************
}
unit CheckLFMDlg;

{$mode objfpc}{$H+}

interface

uses
  // FCL+LCL
  Classes, SysUtils, Math, LCLProc, LResources, Forms, Controls, Graphics,
  Dialogs, Buttons, StdCtrls,
  // components
  SynHighlighterLFM, SynEdit, BasicCodeTools, CodeCache, CodeToolManager,
  LFMTrees,
  // IDE
  ComponentReg, PackageIntf,
  LazarusIDEStrConsts, OutputFilter, IDEProcs, IDEOptionDefs, EditorOptions;

type
  TCheckLFMDialog = class(TForm)
    CancelButton: TButton;
    ErrorsGroupBox: TGroupBox;
    ErrorsListBox: TListBox;
    NoteLabel: TLabel;
    LFMGroupBox: TGroupBox;
    LFMSynEdit: TSynEdit;
    RemoveAllButton: TButton;
    SynLFMSyn1: TSynLFMSyn;
    procedure ErrorsListBoxClick(Sender: TObject);
    procedure LFMSynEditSpecialLineColors(Sender: TObject; Line: integer;
      var Special: boolean; var FG, BG: TColor);
    procedure RemoveAllButtonClick(Sender: TObject);
    procedure CheckLFMDialogCREATE(Sender: TObject);
  private
    FLFMSource: TCodeBuffer;
    FLFMTree: TLFMTree;
    procedure SetLFMSource(const AValue: TCodeBuffer);
    procedure SetLFMTree(const AValue: TLFMTree);
    procedure SetupComponents;
    function FindListBoxError: TLFMError;
    procedure JumpToError(LFMError: TLFMError);
    procedure FindNiceNodeBounds(LFMNode: TLFMTreeNode;
                                 var StartPos, EndPos: integer);
    procedure AddReplacement(LFMChangeList: TList; StartPos, EndPos: integer;
                             const NewText: string);
    function ApplyReplacements(LFMChangeList: TList): boolean;
  public
    procedure LoadLFM;
    procedure FillErrorsListBox;
    function AutomaticFixIsPossible: boolean;
    property LFMTree: TLFMTree read FLFMTree write SetLFMTree;
    property LFMSource: TCodeBuffer read FLFMSource write SetLFMSource;
  end;
  
function CheckLFMBuffer(PascalBuffer, LFMBuffer: TCodeBuffer;
  const OnOutput: TOnOutputString;
  RootMustBeClassInIntf, ObjectsMustExists: boolean): TModalResult;
function CheckLFMText(PascalBuffer: TCodeBuffer; var LFMText: string;
  const OnOutput: TOnOutputString;
  RootMustBeClassInIntf, ObjectsMustExists: boolean): TModalResult;
function ShowRepairLFMWizard(LFMBuffer: TCodeBuffer;
  LFMTree: TLFMTree): TModalResult;


implementation

type
  TLFMChangeEntry = class
  public
    StartPos, EndPos: integer;
    NewText: string;
  end;

function CheckLFMBuffer(PascalBuffer, LFMBuffer: TCodeBuffer;
  const OnOutput: TOnOutputString;
  RootMustBeClassInIntf, ObjectsMustExists: boolean): TModalResult;
var
  LFMTree: TLFMTree;
  
  procedure WriteLFMErrors;
  var
    CurError: TLFMError;
    Dir: String;
    Msg: String;
    Filename: String;
  begin
    if not Assigned(OnOutput) then exit;
    CurError:=LFMTree.FirstError;
    Dir:=ExtractFilePath(LFMBuffer.Filename);
    Filename:=ExtractFilename(LFMBuffer.Filename);
    while CurError<>nil do begin
      Msg:=Filename
           +'('+IntToStr(CurError.Caret.Y)+','+IntToStr(CurError.Caret.X)+')'
           +' Error: '
           +CurError.ErrorMessage;
      debugln('WriteLFMErrors ',Msg);
      OnOutput(Msg,Dir);
      CurError:=CurError.NextError;
    end;
  end;
  
  function FixMissingComponentClasses: TModalResult;
  // returns true, if after adding units to uses section all errors are fixed
  var
    CurError: TLFMError;
    MissingObjectTypes: TStringList;
    TypeName: String;
    RegComp: TRegisteredComponent;
    i: Integer;
  begin
    Result:=mrCancel;
    MissingObjectTypes:=TStringList.Create;
    try
      // collect all missing object types
      CurError:=LFMTree.FirstError;
      while CurError<>nil do begin
        if CurError.IsMissingObjectType then begin
          TypeName:=(CurError.Node as TLFMObjectNode).TypeName;
          if MissingObjectTypes.IndexOf(TypeName)<0 then
            MissingObjectTypes.Add(TypeName);
        end;
        CurError:=CurError.NextError;
      end;
      
      // keep all object types with a registered component class
      for i:=MissingObjectTypes.Count-1 downto 0 do begin
        RegComp:=IDEComponentPalette.FindComponent(MissingObjectTypes[i]);
        if (RegComp=nil) or (RegComp.GetUnitName='') then
          MissingObjectTypes.Delete(i);
      end;
      if MissingObjectTypes.Count=0 then exit;
      
      // there are missing object types with registered component classes
      Result:=PackageEditingInterface.AddUnitDependenciesForComponentClasses(
           PascalBuffer.Filename,MissingObjectTypes);
      if Result<>mrOk then exit;

      // check LFM again
      LFMTree.Free;
      LFMTree:=nil;
      if CodeToolBoss.CheckLFM(PascalBuffer,LFMBuffer,LFMTree,
                                    RootMustBeClassInIntf,ObjectsMustExists)
      then
        Result:=mrOk;
    finally
      MissingObjectTypes.Free;
    end;
  end;
  
begin
  Result:=mrCancel;
  LFMTree:=nil;
  try
    if CodeToolBoss.CheckLFM(PascalBuffer,LFMBuffer,LFMTree,
                                  RootMustBeClassInIntf,ObjectsMustExists)
    then begin
      Result:=mrOk;
      exit;
    end;
    Result:=FixMissingComponentClasses;
    if Result in [mrAbort,mrOk] then exit;
    WriteLFMErrors;
    Result:=ShowRepairLFMWizard(LFMBuffer,LFMTree);
  finally
    LFMTree.Free;
  end;
end;

function CheckLFMText(PascalBuffer: TCodeBuffer; var LFMText: string;
  const OnOutput: TOnOutputString;
  RootMustBeClassInIntf, ObjectsMustExists: boolean): TModalResult;
var
  LFMBuf: TCodeBuffer;
begin
  Result:=mrCancel;
  LFMBuf:=CodeToolBoss.CreateTempFile('temp.lfm');
  try
    LFMBuf.Source:=LFMText;
    Result:=CheckLFMBuffer(PascalBuffer,LFMBuf,OnOutput,RootMustBeClassInIntf,
                           ObjectsMustExists);
    LFMText:=LFMBuf.Source;
  finally
    CodeToolBoss.ReleaseTempFile(LFMBuf);
  end;
end;

function ShowRepairLFMWizard(LFMBuffer: TCodeBuffer;
  LFMTree: TLFMTree): TModalResult;
var
  CheckLFMDialog: TCheckLFMDialog;
begin
  Result:=mrCancel;
  CheckLFMDialog:=TCheckLFMDialog.Create(nil);
  CheckLFMDialog.LFMTree:=LFMTree;
  CheckLFMDialog.LFMSource:=LFMBuffer;
  CheckLFMDialog.LoadLFM;
  Result:=CheckLFMDialog.ShowModal;
  CheckLFMDialog.Free;
end;

{ TCheckLFMDialog }

procedure TCheckLFMDialog.RemoveAllButtonClick(Sender: TObject);
var
  CurError: TLFMError;
  DeleteNode: TLFMTreeNode;
  StartPos, EndPos: integer;
  Replacements: TList;
begin
  Replacements:=TList.Create;
  try
    // automatically delete each error location
    CurError:=LFMTree.LastError;
    while CurError<>nil do begin
      DeleteNode:=CurError.FindContextNode;
      if (DeleteNode<>nil) and (DeleteNode.Parent<>nil) then begin
        FindNiceNodeBounds(DeleteNode,StartPos,EndPos);
        AddReplacement(Replacements,StartPos,EndPos,'');
      end;
      CurError:=CurError.PrevError;
    end;

    if ApplyReplacements(Replacements) then
      ModalResult:=mrOk;
  finally
    Replacements.Free;
  end;
end;

procedure TCheckLFMDialog.ErrorsListBoxClick(Sender: TObject);
begin
  JumpToError(FindListBoxError);
end;

procedure TCheckLFMDialog.LFMSynEditSpecialLineColors(Sender: TObject;
  Line: integer; var Special: boolean; var FG, BG: TColor);
var
  CurError: TLFMError;
begin
  CurError:=LFMTree.FindErrorAtLine(Line);
  if CurError<>nil then begin
    EditorOpts.GetSpecialLineColors(SynLFMSyn1,ahaErrorLine,Special,FG,BG);
  end;
end;

procedure TCheckLFMDialog.CheckLFMDialogCREATE(Sender: TObject);
begin
  Caption:=lisFixLFMFile;
  Position:=poScreenCenter;
  IDEDialogLayoutList.ApplyLayout(Self,600,400);
  SetupComponents;
end;

procedure TCheckLFMDialog.SetLFMSource(const AValue: TCodeBuffer);
begin
  if FLFMSource=AValue then exit;
  FLFMSource:=AValue;
end;

procedure TCheckLFMDialog.SetLFMTree(const AValue: TLFMTree);
begin
  if FLFMTree=AValue then exit;
  FLFMTree:=AValue;
  RemoveAllButton.Enabled:=AutomaticFixIsPossible;
end;

procedure TCheckLFMDialog.SetupComponents;
begin
  NoteLabel.Caption:=lisTheLFMLazarusFormFileContainsInvalidPropertiesThis;
  CancelButton.Caption:=dlgCancel;
  ErrorsGroupBox.Caption:=lisErrors;
  LFMGroupBox.Caption:=lisLFMFile;
  RemoveAllButton.Caption:=lisRemoveAllInvalidProperties;
  
  EditorOpts.GetHighlighterSettings(SynLFMSyn1);
  EditorOpts.GetSynEditSettings(LFMSynEdit);
end;

function TCheckLFMDialog.FindListBoxError: TLFMError;
var
  i: Integer;
begin
  Result:=nil;
  i:=ErrorsListBox.ItemIndex;
  if (i<0) or (i>=ErrorsListBox.Items.Count) then exit;
  Result:=LFMTree.FirstError;
  while Result<>nil do begin
    if i=0 then exit;
    Result:=Result.NextError;
    dec(i);
  end;
end;

procedure TCheckLFMDialog.JumpToError(LFMError: TLFMError);
begin
  if LFMError=nil then exit;
  LFMSynEdit.CaretXY:=LFMError.Caret;
end;

procedure TCheckLFMDialog.FindNiceNodeBounds(LFMNode: TLFMTreeNode;
  var StartPos, EndPos: integer);
var
  Src: String;
begin
  Src:=LFMSource.Source;
  StartPos:=FindLineEndOrCodeInFrontOfPosition(Src,LFMNode.StartPos,1,false,true);
  EndPos:=FindLineEndOrCodeInFrontOfPosition(Src,LFMNode.EndPos,1,false,true);
  EndPos:=FindLineEndOrCodeAfterPosition(Src,EndPos,length(Src),false);
end;

procedure TCheckLFMDialog.AddReplacement(LFMChangeList: TList;
  StartPos, EndPos: integer; const NewText: string);
var
  Entry: TLFMChangeEntry;
  NewEntry: TLFMChangeEntry;
  i: Integer;
begin
  if StartPos>EndPos then
    RaiseException('TCheckLFMDialog.AddReplaceMent StartPos>EndPos');

  // check for intersection
  for i:=0 to LFMChangeList.Count-1 do begin
    Entry:=TLFMChangeEntry(LFMChangeList[i]);
    if ((Entry.StartPos<EndPos) and (Entry.EndPos>StartPos)) then begin
      // New and Entry intersects
      if (Entry.NewText='') and (NewText='') then begin
        // both are deletes => combine
        debugln('TCheckLFMDialog.AddReplacement Combine Deletion: Old=',dbgs(Entry.StartPos),'-',dbgs(Entry.EndPos),' New=',dbgs(StartPos),'-',dbgs(EndPos));
        StartPos:=Min(StartPos,Entry.StartPos);
        EndPos:=Max(EndPos,Entry.EndPos);
      end else begin
        // not allowed
        RaiseException('TCheckLFMDialog.AddReplaceMent invalid Intersection');
      end;
    end;
  end;

  // combine deletions
  if NewText='' then begin
    for i:=LFMChangeList.Count-1 downto 0 do begin
      Entry:=TLFMChangeEntry(LFMChangeList[i]);
      if ((Entry.StartPos<EndPos) and (Entry.EndPos>StartPos)) then begin
        // New and Entry intersects
        // -> remove Entry
        debugln('TCheckLFMDialog.AddReplacement Intersecting Deletion: Old=',dbgs(Entry.StartPos),'-',dbgs(Entry.EndPos),' New=',dbgs(StartPos),'-',dbgs(EndPos));
        LFMChangeList.Delete(i);
        Entry.Free;
      end;
    end;
  end;
  
  // insert new entry
  NewEntry:=TLFMChangeEntry.Create;
  NewEntry.NewText:=NewText;
  NewEntry.StartPos:=StartPos;
  NewEntry.EndPos:=EndPos;
  if LFMChangeList.Count=0 then begin
    LFMChangeList.Add(NewEntry);
  end else begin
    for i:=0 to LFMChangeList.Count-1 do begin
      Entry:=TLFMChangeEntry(LFMChangeList[i]);
      if EndPos<=Entry.StartPos then begin
        // insert in front
        LFMChangeList.Insert(i,NewEntry);
        break;
      end else if i=LFMChangeList.Count-1 then begin
        // insert behind
        LFMChangeList.Add(NewEntry);
        break;
      end;
    end;
  end;
end;

function TCheckLFMDialog.ApplyReplacements(LFMChangeList: TList): boolean;
var
  i: Integer;
  Entry: TLFMChangeEntry;
begin
  Result:=false;
  //writeln(LFMSource.Source);
  for i:=LFMChangeList.Count-1 downto 0 do begin
    Entry:=TLFMChangeEntry(LFMChangeList[i]);
    DebugLn('TCheckLFMDialog.ApplyReplacements A ',IntToStr(i),' ',
      IntToStr(Entry.StartPos),',',IntToStr(Entry.EndPos),
      ' "',copy(LFMSource.Source,Entry.StartPos,Entry.EndPos-Entry.StartPos),'" -> "',Entry.NewText,'"');
    LFMSource.Replace(Entry.StartPos,Entry.EndPos-Entry.StartPos,Entry.NewText);
  end;
  //writeln(LFMSource.Source);
  Result:=true;
end;

procedure TCheckLFMDialog.LoadLFM;
begin
  LFMSynEdit.Lines.Text:=LFMSource.Source;
  FillErrorsListBox;
end;

procedure TCheckLFMDialog.FillErrorsListBox;
var
  CurError: TLFMError;
  Filename: String;
  Msg: String;
begin
  ErrorsListBox.Items.BeginUpdate;
  ErrorsListBox.Items.Clear;
  if LFMTree<>nil then begin
    Filename:=ExtractFileName(LFMSource.Filename);
    CurError:=LFMTree.FirstError;
    while CurError<>nil do begin
      Msg:=Filename
           +'('+IntToStr(CurError.Caret.Y)+','+IntToStr(CurError.Caret.X)+')'
           +' Error: '
           +CurError.ErrorMessage;
      ErrorsListBox.Items.Add(Msg);
      CurError:=CurError.NextError;
    end;
  end;
  ErrorsListBox.Items.EndUpdate;
end;

function TCheckLFMDialog.AutomaticFixIsPossible: boolean;
var
  CurError: TLFMError;
begin
  Result:=true;
  CurError:=LFMTree.FirstError;
  while CurError<>nil do begin
    if CurError.ErrorType in [lfmeNoError,lfmeIdentifierNotFound,
      lfmeObjectNameMissing,lfmeObjectIncompatible,lfmePropertyNameMissing,
      lfmePropertyHasNoSubProperties,lfmeIdentifierNotPublished]
    then begin
      // these things can be fixed automatically
    end else begin
      // these not
      Result:=false;
      exit;
    end;
    CurError:=CurError.NextError;
  end;
end;

initialization
  {$I checklfmdlg.lrs}

end.