paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-11-04 11:24:40 +01:00
Code Issues Packages Projects Releases Wiki Activity
3102805a43
lazarus/components/codetools/codebeautifier.pas
juha e800a738ad Copy AVL_Tree from FPC trunk and replace classes in AvgLvlTree and in CodetoolsStructs with it. 
The unit in FPC packages will be used directly later.

git-svn-id: trunk@54524 -
2017-04-05 08:34:48 +00:00

2455 lines
76 KiB
ObjectPascal
Raw Blame History

{
***************************************************************************
* *
* 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., 51 Franklin Street - Fifth Floor, Boston, MA 02110-1335, USA. *
* *
***************************************************************************
Author: Mattias Gaertner
}
(*
Abstract:
Functions to beautify code.
Goals:
- fully automatic (instead of fixed rules mimic the indentation of example code(s))
- when target source is within example source use the nearest match.
- Customizable (e.g. use boolean: check the global example code, boolean)
- Beautification of whole sources. For example a unit, or several
sources.
- Beautification of parts of sources. For example selections.
- Beautification of insertion source (Paste). For example beautifying
code, that will be inserted in another source.
- Find a nice indendation for empty line (e.g. after pressing return)
- Inside comments: use indentation of last non empty line
- Working with syntax errors. The beautification will try its best to
work, even if the source contains errors.
- Comments are special statements.
Line break:
1. indent to the smallest indent
For example, when there is always an indent after 'try':
try|
|
For example when sometimes no indent is after 'then':
if expr then|
|
2. unindent when block was closed
For example after closing blocks with a semicolon:
if expr then
if expr then
doit;|
|
Closing the corresponding block, not all blocks:
if expr then
if expr then begin|
|end
3. optional 'UseLineStart': when next token in line closes block:
repeat|
|until
When 'until' is not current line, ignore it:
repeat|
|
until
4. When unsure, tell that and use identation of last non empty line
5. Nested blocks do not need to be indented monoton:
if expr
or expr then
statement;
begin
//comment
statement;
//comment
statement;
{$IFDEF expr}
statement;
{$ENDIF}
end;
Examples for beautification styles: see examples/scanexamples/indentation.pas
ToDo:
* LineBreak:
- Optional: indent last line after pressing return key:
if true then
exit;|
|
* long lines
DoSomething(Param1,
Param2);
*)
unit CodeBeautifier;
{$mode objfpc}{$H+}
interface
{ $DEFINE ShowCodeBeautifier}
{ $DEFINE ShowCodeBeautifierParser}
{ $DEFINE ShowCodeBeautifierLearn}
{ $DEFINE VerboseIndenter}
{$IFDEF ShowCodeBeautifierParser}
{$DEFINE ShowCodeBeautifierLearn}
{$ENDIF}
{$IF defined(VerboseIndenter) or defined(ShowCodeBeautifierLearn)}
{$DEFINE StoreLearnedPositions}
{$ENDIF}
uses
Classes, SysUtils, Laz_AVL_Tree,
// Codetools
FileProcs, KeywordFuncLists, CodeCache, BasicCodeTools,
// LazUtils
LazUtilities;
type
TWordPolicy = (
wpNone,
wpLowerCase,
wpUpperCase,
wpLowerCaseFirstLetterUp
);
TFABBlockType = (
bbtNone, // all else (comments, enums, continued lines, ...)
// code sections
bbtInterface,
bbtImplementation,
bbtInitialization,
bbtFinalization,
// identifier sections
bbtUsesSection,
bbtTypeSection,
bbtConstSection,
bbtVarSection,
bbtResourceStringSection,
bbtLabelSection,
bbtDefinition, // child of bbtTypeSection,bbtConstSection,bbtVarSection,bbtResourceStringSection,bbtLabelSection
// type blocks
bbtRecord,
bbtClass, // class, object, objcclass, objccategory
bbtClassInterface, // interface, dispinterface, objcprotocol
bbtClassSection, // public, private, protected, published
bbtTypeRoundBracket,
bbtTypeEdgedBracket,
// statement blocks
bbtProcedure, // procedure, constructor, destructor
bbtFunction, // function, operator
bbtProcedureHead, // child of bbtProcedure or bbtFunction
bbtProcedureParamList, // child of bbtProcedureHead
bbtProcedureModifiers, // child of bbtProcedureHead
bbtProcedureBegin, // child of bbtProcedure or bbtFunction
bbtMainBegin,
bbtFreeBegin, // a normal begin
bbtRepeat,
bbtWhile,
bbtWhileDo, // child of bbtWhile
bbtFor,
bbtForDo, // child of bbtFor
bbtWith,
bbtWithDo, // child of bbtWith
bbtCase,
bbtCaseOf, // child of bbtCase
bbtCaseLabel, // child of bbtCaseOf
bbtCaseColon, // child of bbtCaseLabel
bbtCaseElse, // child of bbtCase
bbtTry,
bbtFinally, // sibling of bbtTry
bbtExcept, // sibling of bbtTry
bbtIf,
bbtIfThen, // child of bbtIf
bbtIfElse, // child of bbtIf
bbtIfBegin, // child of bbtIfThen or bbtIfElse
bbtStatement,
bbtStatementRoundBracket,
bbtStatementEdgedBracket,
bbtProperty // global or class property
);
TFABBlockTypes = set of TFABBlockType;
const
bbtAllIdentifierSections = [bbtTypeSection,bbtConstSection,bbtVarSection,
bbtResourceStringSection,bbtLabelSection,bbtClassSection];
bbtAllProcedures = [bbtProcedure,bbtFunction];
bbtAllCodeSections = [bbtInterface,bbtImplementation,bbtInitialization,
bbtFinalization];
bbtAllStatementParents = [bbtMainBegin,bbtFreeBegin,bbtProcedureBegin,
bbtRepeat,bbtWhileDo,bbtForDo,bbtWithDo,
bbtCaseColon,bbtCaseElse,
bbtTry,bbtFinally,bbtExcept,
bbtIfThen,bbtIfElse,bbtIfBegin];
bbtAllStatements = bbtAllStatementParents+[
bbtStatement,bbtStatementRoundBracket,bbtStatementEdgedBracket];
bbtAllBrackets = [bbtTypeRoundBracket,bbtTypeEdgedBracket,
bbtStatementRoundBracket,bbtStatementEdgedBracket];
bbtAllAutoEnd = [bbtStatement,bbtIf,bbtIfThen,bbtIfElse,bbtWhile,bbtWhileDo,
bbtFor,bbtForDo,bbtWith,bbtWithDo,bbtCaseLabel,bbtCaseColon];
bbtAllAlignToSibling = [bbtNone]+bbtAllStatements;
type
TOnGetFABExamples = procedure(Sender: TObject; Code: TCodeBuffer;
Step: integer; // starting at 0
var CodeBuffers: TFPList; // stopping when CodeBuffers=nil
var ExpandedFilenames: TStrings // and ExpandedFilenames=nil
) of object;
TOnGetFABNestedComments = procedure(Sender: TObject; Code: TCodeBuffer;
out NestedComments: boolean) of object;
TOnLoadCTFile = procedure(Sender: TObject; const ExpandedFilename: string;
out Code: TCodeBuffer; var Abort: boolean) of object;
TFABIndentationPolicy = record
Indent: integer;
IndentValid: boolean;
end;
TFABFoundIndentationPolicy = packed record
Typ, SubTyp: TFABBlockType;
Indent: integer;
{$IFDEF StoreLearnedPositions}
SrcPos: integer;
{$ENDIF}
end;
PFABFoundIndentationPolicy = ^TFABFoundIndentationPolicy;
{ TFABPolicies }
TFABPolicies = class
private
function FindIndentation(Typ, SubType: TFABBlockType;
out InsertPos: integer): boolean;
public
IndentationCount, IndentationCapacity: integer;
Indentations: PFABFoundIndentationPolicy; // sorted ascending
Code: TCodeBuffer;
CodeChangeStep: integer;
constructor Create;
destructor Destroy; override;
procedure Clear;
procedure AddIndent(Typ, SubType: TFABBlockType; SrcPos, Indent: integer);
function GetSmallestIndent(Typ: TFABBlockType): integer;// -1 if none found
function GetIndent(Typ, SubType: TFABBlockType;
UseNoneIfNotFound,
UseSmallestIfNotFound: boolean): integer;// -1 if none found
function CodePosToStr(p: integer): string;
procedure ConsistencyCheck;
procedure WriteDebugReport;
end;
type
TBlock = record
Typ: TFABBlockType;
StartPos: integer;
Indent: integer;
Trailing: boolean; // true = StartPos is not first atom in line
InnerStartPos: integer;
InnerIdent: integer; // valid if >=0
end;
PBlock = ^TBlock;
const
CleanBlock: TBlock = (
Typ: bbtNone;
StartPos: -1;
Indent: -1;
Trailing: false;
InnerStartPos: -1;
InnerIdent: -1
);
type
TFABPositionIndent = record
CleanPos: integer;
Indent: TFABIndentationPolicy;
Block: TBlock;
SubType: TFABBlockType;
SubTypeValid: boolean;
end;
PFABPositionIndent = ^TFABPositionIndent;
{ TFABPositionIndents }
TFABPositionIndents = class
private
FCount: integer;
procedure SetCount(const AValue: integer);
public
Items: PFABPositionIndent;
constructor Create;
destructor Destroy; override;
procedure Clear;
property Count: integer read FCount write SetCount;
end;
{ TFABBlockStack }
TFABBlockStack = class
public
Stack: PBlock;
Capacity: integer;
Top: integer; // -1 = empty, 0 = 1 item
TopType: TFABBlockType;
LastBlockClosed: TBlock;
LastBlockClosedAt: integer;
constructor Create;
destructor Destroy; override;
procedure BeginBlock(Typ: TFABBlockType; StartPos: integer;
Trailing: boolean; Indent: integer);
procedure EndBlock(EndPos: integer);
function TopMostIndexOf(Typ: TFABBlockType): integer;
function EndTopMostBlock(Typ: TFABBlockType; EndPos: integer): boolean;
{$IFDEF ShowCodeBeautifier}
Src: string;
function PosToStr(p: integer): string;
{$ENDIF}
procedure WriteDebugReport(Prefix: string);
end;
{ TFullyAutomaticBeautifier }
TFullyAutomaticBeautifier = class
private
FOnGetExamples: TOnGetFABExamples;
FCodePolicies: TAVLTree;// tree of TFABPolicies sorted for Code
FOnGetNestedComments: TOnGetFABNestedComments;
FOnLoadFile: TOnLoadCTFile;
FUseDefaultIndentForTypes: TFABBlockTypes;
procedure ParseSource(const Src: string; StartPos, EndPos: integer;
NestedComments: boolean;
Stack: TFABBlockStack; Policies: TFABPolicies;
out LastAtomStart, LastAtomEnd: integer; // set if LastAtomStart<EndPos<LastAtomEnd
LearnFromFirstLine: boolean = true
);
procedure ParseSource(const Src: string; StartPos, EndPos: integer;
NestedComments: boolean;
Stack: TFABBlockStack; Policies: TFABPolicies;
LearnFromFirstLine: boolean = true);
function FindPolicyInExamples(StartCode: TCodeBuffer;
Typ, SubTyp: TFABBlockType;
UseNoneIfNotFound,
UseSmallestIfNotFound: boolean): TFABPolicies;
function GetNestedCommentsForCode(Code: TCodeBuffer): boolean;
function AdjustByNextAtom(const Source: string;
CleanPos: integer; NestedComments: boolean;
Stack: TFABBlockStack;
out TopType: TFABBlockType;
out TopTypeValid: boolean): integer;
procedure WriteDebugReport(Msg: string; Stack: TFABBlockStack);
public
DefaultTabWidth: integer;
constructor Create;
destructor Destroy; override;
procedure Clear;
function GetIndent(const Source: string; CleanPos: integer;
NewNestedComments: boolean; UseLineStart: boolean;
out Indent: TFABIndentationPolicy;
ContextLearn: boolean = true; // true = learn policies from Source
const InsertText: string = ''
): boolean;
function GetIndents(const Source: string; Positions: TFABPositionIndents;
NewNestedComments: boolean; UseLineStart: boolean;
ContextLearn: boolean = true // true = learn policies from Source
): boolean;
procedure GetDefaultSrcIndent(const Source: string; CleanPos: integer;
{%H-}NewNestedComments: boolean;
out Indent: TFABIndentationPolicy);
procedure GetDefaultIndentPolicy(Typ, SubTyp: TFABBlockType;
out Indent: TFABIndentationPolicy);
property OnGetExamples: TOnGetFABExamples read FOnGetExamples
write FOnGetExamples;
property OnGetNestedComments: TOnGetFABNestedComments
read FOnGetNestedComments write FOnGetNestedComments;
property OnLoadFile: TOnLoadCTFile read FOnLoadFile write FOnLoadFile;
property UseDefaultIndentForTypes: TFABBlockTypes
read FUseDefaultIndentForTypes write FUseDefaultIndentForTypes;
end;
function EnumToStr(BlockType: TFABBlockType): string;
function CompareFABPoliciesWithCode(Data1, Data2: Pointer): integer;
function CompareCodeWithFABPolicy(Key, Data: Pointer): integer;
implementation
function EnumToStr(BlockType: TFABBlockType): string;
begin
WriteStr(Result, BlockType);
end;
function CompareFABPoliciesWithCode(Data1, Data2: Pointer): integer;
var
Policies1: TFABPolicies absolute Data1;
Policies2: TFABPolicies absolute Data2;
begin
Result:=ComparePointers(Policies1.Code,Policies2.Code);
end;
function CompareCodeWithFABPolicy(Key, Data: Pointer): integer;
var
Policies: TFABPolicies absolute Data;
begin
Result:=ComparePointers(Key,Policies.Code);
end;
{ TFABBlockStack }
constructor TFABBlockStack.Create;
begin
Top:=-1;
end;
destructor TFABBlockStack.Destroy;
begin
ReAllocMem(Stack,0);
Capacity:=0;
Top:=-1;
inherited Destroy;
end;
procedure TFABBlockStack.BeginBlock(Typ: TFABBlockType; StartPos: integer;
Trailing: boolean; Indent: integer);
var
Block: PBlock;
begin
inc(Top);
if Top>=Capacity then begin
if Capacity=0 then
Capacity:=16
else
Capacity:=Capacity*2;
ReAllocMem(Stack,SizeOf(TBlock)*Capacity);
end;
{$IFDEF ShowCodeBeautifier}
DebugLn([GetIndentStr(Top*2),'TFABBlockStack.BeginBlock ',EnumToStr(Typ),' ',StartPos,' at ',PosToStr(StartPos)]);
{$ENDIF}
Block:=@Stack[Top];
Block^.Typ:=Typ;
Block^.StartPos:=StartPos;
Block^.Indent:=Indent;
Block^.Trailing:=Trailing;
Block^.InnerIdent:=-1;
Block^.InnerStartPos:=-1;
TopType:=Typ;
LastBlockClosed.Typ:=bbtNone;
LastBlockClosed.StartPos:=0;
LastBlockClosedAt:=0;
end;
procedure TFABBlockStack.EndBlock(EndPos: integer);
begin
{$IFDEF ShowCodeBeautifier}
DebugLn([GetIndentStr(Top*2),'TFABBlockStack.EndBlock ',EnumToStr(TopType)]);
{$ENDIF}
if Top<0 then
exit;
if Top>=0 then begin
LastBlockClosed:=Stack[Top];
LastBlockClosedAt:=EndPos;
end;
dec(Top);
if Top>=0 then
TopType:=Stack[Top].Typ
else
TopType:=bbtNone;
end;
function TFABBlockStack.TopMostIndexOf(Typ: TFABBlockType): integer;
begin
Result:=Top;
while (Result>=0) and (Stack[Result].Typ<>Typ) do dec(Result);
end;
function TFABBlockStack.EndTopMostBlock(Typ: TFABBlockType;
EndPos: integer): boolean;
// check if there is this type on the stack and if yes, end it
var
i: LongInt;
begin
i:=TopMostIndexOf(Typ);
if i<0 then exit(false);
Result:=true;
while Top>=i do EndBlock(EndPos);
end;
procedure TFABBlockStack.WriteDebugReport(Prefix: string);
var
i: Integer;
begin
for i:=0 to Top do begin
debugln([Prefix+GetIndentStr(i*2),EnumToStr(Stack[i].Typ),
' StartPos=',Stack[i].StartPos,
' Indent=',Stack[i].Indent,
' Trailing=',Stack[i].Trailing,
' Indent=',Stack[i].Indent,
' InnerStartPos=',Stack[i].InnerStartPos,
' InnerIdent=',Stack[i].InnerIdent,
'']);
end;
end;
{$IFDEF ShowCodeBeautifier}
function TFABBlockStack.PosToStr(p: integer): string;
var
X: integer;
Y: LongInt;
begin
Result:='';
if Src='' then exit;
Y:=LineEndCount(Src,1,p,X)+1;
Result:='y='+dbgs(Y)+',x='+dbgs(X+1);
end;
{$ENDIF}
{ TFullyAutomaticBeautifier }
procedure TFullyAutomaticBeautifier.ParseSource(const Src: string;
StartPos, EndPos: integer; NestedComments: boolean; Stack: TFABBlockStack;
Policies: TFABPolicies; out LastAtomStart, LastAtomEnd: integer;
LearnFromFirstLine: boolean);
var
p: Integer;
AtomStart: integer;
AtomStartedBlock, AtomEndedBlock: boolean;
FirstAtomOnNewLine: Boolean;
InFirstLine: boolean;
{$IFDEF ShowCodeBeautifierLearn}
function PosToStr(p: integer): string;
var
X: integer;
Y: LongInt;
begin
Y:=LineEndCount(Src,1,p,X)+1;
Result:='Line='+dbgs(Y)+' Col='+dbgs(X+1);
end;
{$ENDIF}
procedure UpdateBlockInnerIndent;
var
Block: PBlock;
BlockStartPos: LongInt;
i: LongInt;
begin
i:=Stack.Top;
Block:=@Stack.Stack[i];
if Block^.InnerIdent<0 then begin
while (i>0) and Stack.Stack[i].Trailing do dec(i);
BlockStartPos:=Stack.Stack[i].StartPos;
if not PositionsInSameLine(Src,BlockStartPos,Block^.InnerStartPos) then
Block^.InnerIdent:=
GetLineIndentWithTabs(Src,Block^.InnerStartPos,DefaultTabWidth)
-GetLineIndentWithTabs(Src,BlockStartPos,DefaultTabWidth);
end;
end;
procedure BeginBlock(Typ: TFABBlockType);
var
Block: PBlock;
Indent: Integer;
i: LongInt;
BaseBlock: PBlock;
begin
AtomStartedBlock:=true;
i:=Stack.Top;
Indent:=-1;
if (Policies<>nil) and (i>=0) and FirstAtomOnNewLine then begin
Block:=@Stack.Stack[i];
{ For example:
if expr
or expr then
Code;
Learn that ifThen/Statement is indented by two
The indentation is taken from the IF, because the THEN is trailing.
}
while (i>0) and Stack.Stack[i].Trailing do dec(i);
BaseBlock:=@Stack.Stack[i];
if BaseBlock^.Indent<0 then
BaseBlock^.Indent:=GetLineIndentWithTabs(Src,BaseBlock^.StartPos,DefaultTabWidth);
Indent:=GetLineIndentWithTabs(Src,AtomStart,DefaultTabWidth);
if BaseBlock^.Indent<=Indent then begin
if (not InFirstLine) or LearnFromFirstLine then
Policies.AddIndent(Block^.Typ,Typ,AtomStart,Indent-BaseBlock^.Indent);
{$IFDEF ShowCodeBeautifierLearn}
DebugLn([GetIndentStr(Stack.Top*2),'nested indentation learned ',EnumToStr(Block^.Typ),'/',EnumToStr(Typ),': ',GetAtomString(@Src[AtomStart],NestedComments),' at ',PosToStr(AtomStart),' Indent=',Indent,'-',BaseBlock^.Indent,'=',Indent-BaseBlock^.Indent]);
debugln([GetIndentStr(Stack.Top*2),' Src=',dbgstr(copy(Src,AtomStart-10,10)),'|',copy(Src,AtomStart,p-AtomStart),' BaseBlock=',EnumToStr(BaseBlock^.Typ)]);
if Typ=bbtCaseLabel then
Stack.WriteDebugReport(GetIndentStr(Stack.Top*2));
{$ENDIF}
end;
end;
//if not FirstAtomOnNewLine then DebugLn([GetIndentStr(Stack.Top*2),'TRAILING BeginBlock ',EnumToStr(Typ),' ',GetAtomString(@Src[AtomStart],NestedComments),' at ',PosToStr(AtomStart)]);
Stack.BeginBlock(Typ,AtomStart,not FirstAtomOnNewLine,Indent);
{$IFDEF ShowCodeBeautifierParser}
DebugLn([GetIndentStr(Stack.Top*2),'BeginBlock ',EnumToStr(Typ),' ',GetAtomString(@Src[AtomStart],NestedComments),' at ',PosToStr(AtomStart)]);
{$ENDIF}
end;
procedure EndBlock;
begin
{$IFDEF ShowCodeBeautifierParser}
DebugLn([GetIndentStr(Stack.Top*2),'EndBlock ',EnumToStr(Stack.TopType),' ',GetAtomString(@Src[AtomStart],NestedComments),' at ',PosToStr(AtomStart)]);
{$ENDIF}
AtomEndedBlock:=true;
Stack.EndBlock(p);
end;
procedure EndTopMostBlock(Typ: TFABBlockType);
var
i: LongInt;
begin
i:=Stack.TopMostIndexOf(Typ);
if i<0 then exit;
while Stack.Top>=i do EndBlock;
end;
procedure BeginClass;
begin
BeginBlock(bbtClass);
// the first section is created automatically
BeginBlock(bbtClassSection);
end;
procedure EndStatements;
begin
while Stack.TopType in bbtAllStatements do EndBlock;
end;
function IsProcedureImplementation: boolean;
// check if current bbtProcedure/bbtFunction expects a begin..end
begin
Result:=(Stack.Top=0)
or (Stack.Stack[Stack.Top-1].Typ in (bbtAllProcedures+[bbtImplementation]));
end;
procedure EndIdentifierSectionAndProc;
begin
EndStatements; // fix dangling statements
if Stack.TopType=bbtProcedureModifiers then
EndBlock;
if Stack.TopType=bbtProcedureHead then
EndBlock;
if Stack.TopType in bbtAllProcedures then begin
if IsProcedureImplementation then begin
// procedure with begin..end
end else begin
// procedure without begin..end
EndBlock;
end;
end;
if Stack.TopType=bbtDefinition then
EndBlock;
if Stack.TopType in bbtAllIdentifierSections then
EndBlock;
end;
procedure StartIdentifierSection(Section: TFABBlockType);
begin
EndIdentifierSectionAndProc;
if Stack.TopType in (bbtAllCodeSections+bbtAllProcedures+[bbtNone]) then
BeginBlock(Section);
end;
procedure StartProcedure(Typ: TFABBlockType);
begin
if not (Stack.TopType in [bbtDefinition,bbtClassSection]) then
EndIdentifierSectionAndProc;
if Stack.TopType in (bbtAllCodeSections+bbtAllProcedures+[bbtNone,bbtDefinition,bbtClassSection])
then begin
BeginBlock(Typ);
BeginBlock(bbtProcedureHead);
end;
end;
procedure StartProperty;
begin
if Stack.TopType in [bbtNone, bbtClassSection] then
BeginBlock(bbtProperty);
end;
procedure StartClassSection;
begin
if (LastAtomStart>0) and (CompareIdentifiers('STRICT',@Src[LastAtomStart])=0)
then begin
exit;
end;
if Stack.TopType=bbtClassSection then
EndBlock;
if Stack.TopType=bbtClass then
BeginBlock(bbtClassSection);
end;
procedure EndProcedureHead;
begin
if Stack.TopType=bbtProcedureModifiers then
EndBlock;
if Stack.TopType=bbtProcedureHead then
EndBlock;
if (Stack.TopType in bbtAllProcedures) and (not IsProcedureImplementation)
then begin
EndBlock;
if Stack.TopType=bbtDefinition then
EndBlock;
end;
end;
function CheckProcedureModifiers: boolean;
var
NextAtomStart: LongInt;
NextAtomEnd: LongInt;
i: LongInt;
ParentTyp: TFABBlockType;
begin
Result:=false;
i:=Stack.Top;
if Stack.TopType=bbtProcedureModifiers then
dec(i);
if (i<0) then exit;
if Stack.Stack[i].Typ<>bbtProcedureHead then exit;
dec(i);
if i<0 then exit;
if not (Stack.Stack[i].Typ in bbtAllProcedures) then exit;
dec(i);
if i<0 then exit;
if Stack.Stack[i].Typ=bbtDefinition then begin
dec(i);
if i<0 then exit;
end;
// cursor is on the semicolon, peek next atom
NextAtomStart:=AtomStart;
NextAtomEnd:=p;
ReadRawNextPascalAtom(Src,NextAtomEnd,NextAtomStart,NestedComments);
if NextAtomStart>length(Src) then exit;
ParentTyp:=Stack.Stack[i].Typ;
case ParentTyp of
bbtClassSection:
if not IsKeyWordMethodSpecifier.DoItCaseInsensitive(@Src[NextAtomStart])
then exit;
bbtProcedure,bbtFunction,bbtImplementation,bbtInterface:
if not IsKeyWordProcedureSpecifier.DoItCaseInsensitive(@Src[NextAtomStart])
then exit;
bbtTypeSection:
if not IsKeyWordProcedureTypeSpecifier.DoItCaseInsensitive(@Src[NextAtomStart])
then exit;
else
exit;
end;
Result:=true;
end;
var
r: PChar;
Block: PBlock;
CommentStartPos: LongInt;
CommentEndPos: LongInt;
begin
p:=StartPos;
if EndPos>length(Src) then EndPos:=length(Src)+1;
AtomStart:=p;
InFirstLine:=true;
repeat
LastAtomStart:=AtomStart;
LastAtomEnd:=p;
AtomStartedBlock:=false;
AtomEndedBlock:=false;
ReadRawNextPascalAtom(Src,p,AtomStart,NestedComments);
if InFirstLine and (not PositionsInSameLine(Src,LastAtomEnd,AtomStart)) then
InFirstLine:=false;
//DebugLn(['TFullyAutomaticBeautifier.ParseSource Atom=',copy(Src,AtomStart,p-AtomStart)]);
if p>EndPos then begin
if (AtomStart<EndPos) then begin
LastAtomStart:=AtomStart;
LastAtomEnd:=p;
end else begin
// EndPos between two atom: in space or comment
CommentStartPos:=FindNextNonSpace(Src,LastAtomEnd);
LastAtomStart:=0;
LastAtomEnd:=0;
if CommentStartPos<EndPos then begin
CommentEndPos:=FindCommentEnd(Src,CommentStartPos,NestedComments);
if CommentEndPos>EndPos then begin
// EndPos is in comment => return bounds of comment
LastAtomStart:=CommentStartPos;
LastAtomEnd:=CommentEndPos;
end;
end;
end;
break;
end else if AtomStart=EndPos then
break;
// check if found first inner atom of current block
FirstAtomOnNewLine:=IsFirstNonSpaceCharInLine(Src,AtomStart);
if FirstAtomOnNewLine and (Stack.Top>=0) then begin
Block:=@Stack.Stack[Stack.Top];
if (Block^.InnerStartPos<0) then
Block^.InnerStartPos:=AtomStart;
end;
r:=@Src[AtomStart];
case UpChars[r^] of
'B':
if CompareIdentifiers('BEGIN',r)=0 then begin
while Stack.TopType
in (bbtAllIdentifierSections+bbtAllCodeSections+bbtAllBrackets
+[bbtDefinition,bbtProcedureModifiers,bbtProcedureHead,bbtStatement])
do
EndBlock;
case Stack.TopType of
bbtNone:
BeginBlock(bbtMainBegin);
bbtProcedure,bbtFunction:
BeginBlock(bbtProcedureBegin);
bbtMainBegin,bbtProcedureBegin,bbtStatement:
BeginBlock(bbtFreeBegin);
bbtIfThen,bbtIfElse:
BeginBlock(bbtIfBegin);
else
if Stack.TopType in bbtAllStatements then
BeginBlock(bbtFreeBegin);
end;
end;
'C':
case UpChars[r[1]] of
'A': // CA
if CompareIdentifiers('CASE',r)=0 then begin
if Stack.TopType in bbtAllStatements then
BeginBlock(bbtCase);
end;
'L': // CL
if CompareIdentifiers('CLASS',r)=0 then begin
if Stack.TopType=bbtDefinition then
BeginClass;
end;
'O': // CO
if CompareIdentifiers('CONST',r)=0 then
StartIdentifierSection(bbtConstSection)
else if CompareIdentifiers('CONSTRUCTOR',r)=0 then
StartProcedure(bbtProcedure);
'P': // CP
if CompareIdentifiers('CPPCLASS',r)=0 then begin
if Stack.TopType=bbtDefinition then
BeginClass;
end;
end;
'D':
case UpChars[r[1]] of
'O':
if CompareIdentifiers('DO',r)=0 then begin
case Stack.TopType of
bbtWhile: BeginBlock(bbtWhileDo);
bbtFor: BeginBlock(bbtForDo);
bbtWith: BeginBlock(bbtWithDo);
end;
end;
'E':
if CompareIdentifiers('DESTRUCTOR',r)=0 then
StartProcedure(bbtProcedure);
'I':
if CompareIdentifiers('DISPINTERFACE',r)=0 then begin
if Stack.TopType=bbtDefinition then begin
BeginBlock(bbtClassInterface);
end;
end;
end;
'E':
case UpChars[r[1]] of
'L': // EL
if CompareIdentifiers('ELSE',r)=0 then begin
// common syntax error: open brackets in IF expression => ignore
while Stack.TopType in bbtAllBrackets do
EndBlock;
if Stack.TopType=bbtStatement then
EndBlock;
while Stack.TopType in [bbtFor,bbtForDo] do EndBlock;
case Stack.TopType of
bbtIfThen:
begin
EndBlock;
BeginBlock(bbtIfElse);
end;
bbtCaseOf,bbtCaseLabel,bbtCaseColon:
begin
if Stack.TopType=bbtCaseColon then
EndBlock;
if Stack.TopType=bbtCaseLabel then
EndBlock;
EndBlock; // close bbtCaseOf
BeginBlock(bbtCaseElse);
end;
end;
end;
'N': // EN
if CompareIdentifiers('END',r)=0 then begin
// common syntax error: open brackets in statements => ignore
while Stack.TopType in bbtAllBrackets do
EndBlock;
// statements can be closed by end without semicolon
while Stack.TopType in bbtAllAutoEnd do
EndBlock;
if Stack.TopType=bbtProcedureModifiers then
EndBlock;
if Stack.TopType=bbtProcedureHead then
EndBlock;
if Stack.TopType in bbtAllProcedures then
EndBlock;
if Stack.TopType=bbtClassSection then
EndBlock;
case Stack.TopType of
bbtMainBegin,bbtFreeBegin,
bbtRecord,bbtClass,bbtClassInterface,bbtTry,bbtFinally,bbtExcept,
bbtCase,bbtIfBegin:
EndBlock;
bbtCaseLabel,bbtCaseColon:
begin
if Stack.TopType=bbtCaseColon then
EndBlock;
EndBlock; // close bbtCaseLabel
EndBlock; // close bbtCaseOf
EndBlock; // close bbtCase
end;
bbtCaseElse,bbtCaseOf:
begin
EndBlock;
EndBlock; // close bbtCase
end;
bbtProcedureBegin:
begin
EndBlock;
if Stack.TopType in bbtAllProcedures then
EndBlock;
end;
bbtInterface,bbtImplementation,bbtInitialization,bbtFinalization:
EndBlock;
end;
while Stack.TopType in bbtAllAutoEnd do
EndBlock;
end;
'X': // EX
if CompareIdentifiers('EXCEPT',r)=0 then begin
if Stack.TopType=bbtTry then begin
EndBlock;
BeginBlock(bbtExcept);
end;
end;
end;
'F':
case UpChars[r[1]] of
'I': // FI
if CompareIdentifiers('FINALIZATION',r)=0 then begin
while Stack.Top>=0 do
EndBlock;
if Stack.TopType=bbtNone then
BeginBlock(bbtFinalization);
end else if CompareIdentifiers('FINALLY',r)=0 then begin
if Stack.TopType=bbtTry then begin
EndBlock;
BeginBlock(bbtFinally);
end;
end;
'O': // FO
if CompareIdentifiers('FOR',r)=0 then begin
if Stack.TopType in bbtAllStatements then
BeginBlock(bbtFor)
end else if CompareIdentifiers('FORWARD',r)=0 then begin
if Stack.TopType=bbtProcedureModifiers then
EndBlock;
if Stack.TopType=bbtProcedureHead then
EndBlock;
if Stack.TopType in bbtAllProcedures then
EndBlock;
end;
'U': // FU
if CompareIdentifiers('FUNCTION',r)=0 then
StartProcedure(bbtFunction);
end;
'I':
case UpChars[r[1]] of
'F': // IF
if p-AtomStart=2 then begin
// 'IF'
if Stack.TopType in bbtAllStatements then
BeginBlock(bbtIf);
end;
'N': // IN
case UpChars[r[2]] of
'I': // INI
if CompareIdentifiers('INITIALIZATION',r)=0 then begin
while Stack.Top>=0 do
EndBlock;
if Stack.TopType=bbtNone then
BeginBlock(bbtInitialization);
end;
'T': // INT
if CompareIdentifiers('INTERFACE',r)=0 then begin
case Stack.TopType of
bbtNone:
BeginBlock(bbtInterface);
bbtDefinition:
BeginBlock(bbtClassInterface);
end;
end;
end;
'M': // IM
if CompareIdentifiers('IMPLEMENTATION',r)=0 then begin
while Stack.Top>=0 do
EndBlock;
if Stack.TopType=bbtNone then
BeginBlock(bbtImplementation);
end;
end;
'L':
if CompareIdentifiers('LABEL',r)=0 then
StartIdentifierSection(bbtLabelSection);
'O':
case UpChars[r[1]] of
'B':
case UpChars[r[2]] of
'J':
case UpChars[r[3]] of
'C':
case UpChars[r[4]] of
'C':
if (CompareIdentifiers('ObjCCategory',r)=0)
or (CompareIdentifiers('ObjCClass',r)=0) then begin
if Stack.TopType=bbtDefinition then
BeginClass;
end;
'P':
if CompareIdentifiers('ObjCProtocol',r)=0 then begin
if Stack.TopType=bbtDefinition then
BeginBlock(bbtClassInterface);
end;
end;
'E':
if CompareIdentifiers('OBJECT',r)=0 then begin
if Stack.TopType=bbtDefinition then
BeginClass;
end;
end;
end;
'F': // OF
if CompareIdentifiers('OF',r)=0 then begin
case Stack.TopType of
bbtCase:
BeginBlock(bbtCaseOf);
bbtClass,bbtClassInterface:
EndBlock;
end;
end;
'P': // OP
if CompareIdentifiers('OPERATOR',r)=0 then
StartProcedure(bbtFunction);
end;
'P':
case UpChars[r[1]] of
'R': // PR
case UpChars[r[2]] of
'I': // PRI
if (CompareIdentifiers('PRIVATE',r)=0) then
StartClassSection;
'O': // PRO
case UpChars[r[3]] of
'P': // PROP
if (CompareIdentifiers('PROPERTY',r)=0) then
StartProperty;
'T': // PROT
if (CompareIdentifiers('PROTECTED',r)=0) then
StartClassSection;
'C': // PROC
if CompareIdentifiers('PROCEDURE',r)=0 then
StartProcedure(bbtProcedure);
end;
end;
'U': // PU
if (CompareIdentifiers('PUBLIC',r)=0)
or (CompareIdentifiers('PUBLISHED',r)=0) then
StartClassSection;
end;
'R':
case UpChars[r[1]] of
'E': // RE
case UpChars[r[2]] of
'C': // REC
if CompareIdentifiers('RECORD',r)=0 then
BeginBlock(bbtRecord);
'P': // REP
if CompareIdentifiers('REPEAT',r)=0 then
if Stack.TopType in bbtAllStatements then
BeginBlock(bbtRepeat);
'S': // RES
if CompareIdentifiers('RESOURCESTRING',r)=0 then
StartIdentifierSection(bbtResourceStringSection);
end;
end;
'S':
if (CompareIdentifiers('STRICT',r)=0) then
StartClassSection;
'T':
case UpChars[r[1]] of
'H': // TH
if CompareIdentifiers('THEN',r)=0 then begin
// common syntax error: open brackets in if expression => ignore
while Stack.TopType in bbtAllBrackets do
EndBlock;
if Stack.TopType=bbtIf then
BeginBlock(bbtIfThen);
end;
'R': // TR
if CompareIdentifiers('TRY',r)=0 then begin
if Stack.TopType in bbtAllStatements then
BeginBlock(bbtTry);
end;
'Y': // TY
if CompareIdentifiers('TYPE',r)=0 then begin
if Stack.TopType<>bbtDefinition then
StartIdentifierSection(bbtTypeSection);
end;
end;
'U':
case UpChars[r[1]] of
'S': // US
if CompareIdentifiers('USES',r)=0 then begin
if Stack.TopType in [bbtNone,bbtInterface,bbtImplementation] then
BeginBlock(bbtUsesSection);
end;
'N': // UN
if CompareIdentifiers('UNTIL',r)=0 then begin
EndTopMostBlock(bbtRepeat);
end;
end;
'V':
if CompareIdentifiers('VAR',r)=0 then begin
StartIdentifierSection(bbtVarSection);
end;
'W':
case UpChars[r[1]] of
'H': // WH
if CompareIdentifiers('WHILE',r)=0 then begin
if Stack.TopType in bbtAllStatements then
BeginBlock(bbtWhile)
end;
'I': // WI
if CompareIdentifiers('WITH',r)=0 then begin
if Stack.TopType in bbtAllStatements then
BeginBlock(bbtWith)
end;
end;
';':
begin
// common syntax error: unclosed bracket => ignore it
while Stack.TopType in [bbtStatementRoundBracket,bbtStatementEdgedBracket] do
EndBlock;
case Stack.TopType of
bbtUsesSection,bbtDefinition,bbtProperty:
EndBlock;
bbtIfThen,bbtIfElse,bbtStatement,bbtFor,bbtForDo,bbtCaseColon,bbtCaseLabel:
begin
while Stack.TopType in bbtAllAutoEnd do
EndBlock;
end;
bbtProcedureHead:
if CheckProcedureModifiers then
BeginBlock(bbtProcedureModifiers)
else
EndProcedureHead;
bbtProcedureModifiers:
if not CheckProcedureModifiers then
EndProcedureHead;
bbtClassSection,bbtClass:
begin
if Stack.TopType=bbtClassSection then
EndBlock;
EndBlock;
if Stack.TopType=bbtDefinition then
EndBlock;
end;
end;
end;
':':
if p-AtomStart=1 then begin
// colon
case Stack.TopType of
bbtCaseLabel:
BeginBlock(bbtCaseColon);
bbtIf:
EndBlock;
bbtIfThen,bbtIfElse:
begin
EndBlock;
if Stack.TopType=bbtIf then
EndBlock;
end;
end;
end;
'(':
if p-AtomStart=1 then begin
// round bracket open
case Stack.TopType of
bbtProcedureHead:
BeginBlock(bbtProcedureParamList);
else
if Stack.TopType in bbtAllStatements then begin
// ignore brackets in statements, there are no consistent rules
// to indent them
// Note: keep in mind: bbtCaseLabel
end else
BeginBlock(bbtTypeRoundBracket);
end;
end;
')':
if p-AtomStart=1 then begin
// round bracket close
EndTopMostBlock(bbtStatementEdgedBracket);
case Stack.TopType of
bbtProcedureParamList,bbtTypeRoundBracket,bbtStatementRoundBracket:
EndBlock;
end;
end;
'[':
if p-AtomStart=1 then begin
// edge bracket open
if Stack.TopType in bbtAllStatements then
BeginBlock(bbtStatementEdgedBracket)
else
BeginBlock(bbtTypeEdgedBracket);
end;
']':
if p-AtomStart=1 then begin
// edge bracket close
EndTopMostBlock(bbtStatementRoundBracket);
case Stack.TopType of
bbtTypeEdgedBracket,bbtStatementEdgedBracket:
EndBlock;
end;
end;
end;
// check blocks that start without keyword/symbol
if (not AtomStartedBlock) and (not AtomEndedBlock)
and (r^<>';') then begin
if (Stack.TopType in bbtAllIdentifierSections)
and (IsIdentStartChar[Src[AtomStart]]) then begin
// new definition
BeginBlock(bbtDefinition);
end else if (Stack.TopType=bbtCaseOf) then begin
// new case label
BeginBlock(bbtCaseLabel);
end else if (Stack.TopType in bbtAllStatementParents) then begin
// new statement
BeginBlock(bbtStatement);
end;
end;
if FirstAtomOnNewLine and (Stack.Top>=0)
and (not AtomStartedBlock) and (not AtomEndedBlock)
and ((not InFirstLine) or LearnFromFirstLine)
and (Policies<>nil)
then begin
Block:=@Stack.Stack[Stack.Top];
if Block^.InnerIdent<0 then begin
UpdateBlockInnerIndent;
if (Block^.InnerIdent>=0) then begin
Policies.AddIndent(Block^.Typ,bbtNone,AtomStart,Block^.InnerIdent);
{$IFDEF ShowCodeBeautifierLearn}
DebugLn([GetIndentStr(Stack.Top*2),'Indentation learned for bbtNone: ',EnumToStr(Block^.Typ),' Indent=',Block^.InnerIdent,' at ',PosToStr(p)]);
{$ENDIF}
end;
end;
end;
until false;
end;
procedure TFullyAutomaticBeautifier.ParseSource(const Src: string; StartPos,
EndPos: integer; NestedComments: boolean; Stack: TFABBlockStack;
Policies: TFABPolicies; LearnFromFirstLine: boolean);
var
LastAtomStart, LastAtomEnd: integer;
begin
ParseSource(Src,StartPos,EndPos,NestedComments,Stack,Policies,
LastAtomStart,LastAtomEnd,LearnFromFirstLine);
end;
function TFullyAutomaticBeautifier.FindPolicyInExamples(StartCode: TCodeBuffer;
Typ, SubTyp: TFABBlockType; UseNoneIfNotFound, UseSmallestIfNotFound: boolean
): TFABPolicies;
function CheckCode(Code: TCodeBuffer; out Policies: TFABPolicies): boolean;
// result=false : abort
var
AVLNode: TAVLTreeNode;
Stack: TFABBlockStack;
begin
Policies:=nil;
if Code=nil then exit(true);
{$IFDEF VerboseIndenter}
DebugLn(['TFullyAutomaticBeautifier.FindPolicyInExamples ',Code.Filename]);
{$ENDIF}
// search Policies for code
AVLNode:=FCodePolicies.FindKey(Code,@CompareCodeWithFABPolicy);
if AVLNode=nil then begin
Policies:=TFABPolicies.Create;
Policies.Code:=Code;
FCodePolicies.Add(Policies);
end else
Policies:=TFABPolicies(AVLNode.Data);
if Policies.CodeChangeStep<>Code.ChangeStep then begin
// parse code
Policies.Clear;
Policies.CodeChangeStep:=Code.ChangeStep;
Stack:=TFABBlockStack.Create;
try
ParseSource(Code.Source,1,length(Code.Source)+1,
GetNestedCommentsForCode(Code),Stack,Policies);
finally
Stack.Free;
end;
end;
// search policy
if Policies.GetIndent(Typ,SubTyp,UseNoneIfNotFound,UseSmallestIfNotFound)>=0
then begin
{$IFDEF VerboseIndenter}
DebugLn(['TFullyAutomaticBeautifier.FindPolicyInExamples found in ',
Code.Filename,' ',EnumToStr(Typ),'/',EnumToStr(SubTyp)]);
{$ENDIF}
exit;
end;
Policies:=nil;
Result:=true;
end;
var
CodeBuffers: TFPList;
i: Integer;
Code: TCodeBuffer;
Step: Integer;
Filenames: TStrings;
Abort: boolean;
begin
Result:=nil;
if not Assigned(OnGetExamples) then exit;
Step:=0;
repeat
// get examples for current step
CodeBuffers:=nil;
Filenames:=nil;
try
OnGetExamples(Self,StartCode,Step,CodeBuffers,Filenames);
if (CodeBuffers=nil) and (Filenames=nil) then exit;
// search policy in every example
if CodeBuffers<>nil then
for i:=0 to CodeBuffers.Count-1 do begin
Code:=TCodeBuffer(CodeBuffers[i]);
if not CheckCode(Code,Result) then exit;
if Result<>nil then exit;
end;
if (Filenames<>nil) and Assigned(OnLoadFile) then
for i:=0 to Filenames.Count-1 do begin
Abort:=false;
Code:=nil;
OnLoadFile(Self,Filenames[i],Code,Abort);
if Abort then exit;
if Code=nil then continue;
if not CheckCode(Code,Result) then exit;
if Result<>nil then exit;
end;
finally
CodeBuffers.Free;
Filenames.Free;
end;
// next step
inc(Step);
until false;
end;
function TFullyAutomaticBeautifier.GetNestedCommentsForCode(Code: TCodeBuffer
): boolean;
begin
Result:=true;
if Assigned(OnGetNestedComments) then
OnGetNestedComments(Self,Code,Result);
end;
function TFullyAutomaticBeautifier.AdjustByNextAtom(
const Source: string; CleanPos: integer; NestedComments: boolean;
Stack: TFABBlockStack; out TopType: TFABBlockType; out TopTypeValid: boolean
): integer;
{ For example:
if expr then
begin
|DoSomething;
if expr then
begin
|end;
}
function StackTopType: TFABBlockType;
var
i: Integer;
begin
i:=AdjustByNextAtom;
if (i>=0) and (i<=Stack.Top) then
Result:=Stack.Stack[i].Typ
else
Result:=bbtNone;
end;
procedure EndBlock(aCount: integer = 1);
begin
dec(AdjustByNextAtom,aCount);
TopTypeValid:=false;
end;
procedure BeginBlock(Typ: TFABBlockType);
begin
TopType:=Typ;
TopTypeValid:=true;
end;
procedure EndIdentifierSectionAndProc;
begin
if StackTopType=bbtDefinition then
EndBlock;
if StackTopType in bbtAllIdentifierSections then
EndBlock;
end;
procedure StartProcedure;
begin
if StackTopType=bbtDefinition then
EndBlock;
if StackTopType in (bbtAllIdentifierSections-[bbtClassSection]) then
EndBlock;
BeginBlock(bbtProcedure);
end;
function IsMethodDeclaration: boolean;
var
i: Integer;
begin
i:=AdjustByNextAtom;
Result:=(StackTopType in bbtAllProcedures)
and (i>0)
and (Stack.Stack[i-1].Typ=bbtClassSection);
end;
procedure EndClassSection;
begin
if StackTopType=bbtClassSection then
EndBlock
else if IsMethodDeclaration then
EndBlock(2);
end;
procedure EndBigSection;
var
i: Integer;
begin
i:=AdjustByNextAtom;
if i>=0 then
EndBlock(i+1);
end;
procedure EndTopMostBlock(BlockTyp: TFABBlockType);
var
i: LongInt;
begin
i:=Stack.TopMostIndexOf(BlockTyp);
if i>=0 then
AdjustByNextAtom:=i-1;
end;
var
AtomStart: integer;
r: PChar;
p: LongInt;
begin
{$IFDEF VerboseIndenter}
DebugLn(['TFullyAutomaticBeautifier.AdjustByNextAtom START']);
{$ENDIF}
Result:=Stack.Top;
TopType:=bbtNone;
TopTypeValid:=false;
if Result<0 then exit;
if (CleanPos<1) or (CleanPos>length(Source))
or (Source[CleanPos] in [#0..#31,' ']) then
exit;
p:=CleanPos;
ReadRawNextPascalAtom(Source,p,AtomStart,NestedComments);
{$IFDEF VerboseIndenter}
DebugLn(['TFullyAutomaticBeautifier.AdjustByNextAtom ',AtomStart<>CleanPos,' CleanPos=',dbgstr(copy(Source,CleanPos,10)),' AtomStart=',dbgstr(copy(Source,AtomStart,10))]);
{$ENDIF}
if AtomStart<>CleanPos then exit;
{$IFDEF VerboseIndenter}
DebugLn(['TFullyAutomaticBeautifier.AdjustByNextAtom Atom=',copy(Source,AtomStart,p-AtomStart)]);
{$ENDIF}
TopTypeValid:=true;
r:=@Source[AtomStart];
case UpChars[r^] of
'B':
if CompareIdentifiers('BEGIN',r)=0 then begin
if StackTopType=bbtDefinition then
EndBlock;
if StackTopType in bbtAllIdentifierSections then
EndBlock;
case StackTopType of
bbtIfThen:
BeginBlock(bbtIfBegin);
bbtProcedure:
BeginBlock(bbtProcedureBegin);
end;
end;
'C':
if CompareIdentifiers('CONST',r)=0 then begin
EndIdentifierSectionAndProc;
if StackTopType=bbtProcedure then
BeginBlock(bbtLabelSection);
end;
'E':
case UpChars[r[1]] of
'L': // EL
if CompareIdentifiers('ELSE',r)=0 then begin
// common syntax error: open brackets in statements => ignore
while StackTopType in bbtAllBrackets do
EndBlock;
while StackTopType in [bbtFor,bbtForDo,bbtStatement] do
EndBlock;
case StackTopType of
bbtCaseOf,bbtCaseLabel,bbtCaseColon:
begin
if StackTopType=bbtCaseColon then
EndBlock;
if StackTopType=bbtCaseLabel then
EndBlock;
EndBlock; // close bbtCaseOf
BeginBlock(bbtCaseElse);
end;
bbtIfThen:
EndBlock;
end;
end;
'N': // EN
if CompareIdentifiers('END',r)=0 then begin
// common syntax error: open brackets in statements => ignore
while StackTopType in bbtAllBrackets do
EndBlock;
// statements can be closed by end without semicolon
while StackTopType in bbtAllAutoEnd do
EndBlock;
if IsMethodDeclaration then
EndBlock;
if StackTopType=bbtClassSection then
EndBlock;
case StackTopType of
bbtMainBegin,bbtFreeBegin,
bbtRecord,bbtClass,bbtClassInterface,bbtTry,bbtFinally,bbtExcept,
bbtCase,bbtIfBegin:
EndBlock;
bbtCaseOf,bbtCaseLabel,bbtCaseColon:
begin
if StackTopType=bbtCaseColon then
EndBlock;
if StackTopType=bbtCaseLabel then
EndBlock;
EndBlock; // close bbtCaseOf
EndBlock; // close bbtCase
end;
bbtCaseElse:
begin
EndBlock;
EndBlock; // close bbtCase
end;
bbtProcedureBegin:
EndBlock;
bbtInterface,bbtImplementation,bbtInitialization,bbtFinalization:
EndBlock;
end;
end;
'X': // EX
if CompareIdentifiers('EXCEPT',r)=0 then begin
if StackTopType=bbtTry then
EndBlock;
end;
end;
'F':
case UpChars[r[1]] of
'I': // FI
if CompareIdentifiers('FINALIZATION',r)=0 then begin
EndBigSection;
end else if CompareIdentifiers('FINALLY',r)=0 then begin
if StackTopType=bbtTry then
EndBlock;
end;
end;
'I':
case UpChars[r[1]] of
'F': // IF
if p-AtomStart=2 then begin
BeginBlock(bbtIf);
end;
'N': // IN
case UpChars[r[2]] of
'I': // INI
if CompareIdentifiers('INITIALIZATION',r)=0 then
EndBigSection;
end;
'M': // IM
if CompareIdentifiers('IMPLEMENTATION',r)=0 then begin
EndBigSection;
end;
end;
'L':
if CompareIdentifiers('LABEL',r)=0 then begin
EndIdentifierSectionAndProc;
if StackTopType=bbtProcedure then
BeginBlock(bbtLabelSection);
end;
'P':
case UpChars[r[1]] of
'R': // PR
case UpChars[r[2]] of
'I': // PRI
if CompareIdentifiers('PRIVATE',r)=0 then
EndClassSection;
'O': // PRO
case UpChars[r[3]] of
'C': // PROC
if CompareIdentifiers('PROCEDURE',r)=0 then
StartProcedure;
'T': // PROT
if CompareIdentifiers('PROTECTED',r)=0 then
EndClassSection;
end;
end;
'U': // PU
if (CompareIdentifiers('PUBLIC',r)=0)
or (CompareIdentifiers('PUBLISHED',r)=0) then
EndClassSection;
end;
'R':
case UpChars[r[1]] of
'E': // RE
case UpChars[r[2]] of
'S': // RES
if CompareIdentifiers('RESOURCESTRING',r)=0 then
EndIdentifierSectionAndProc;
end;
end;
'S':
if (CompareIdentifiers('STRICT',r)=0) then
EndClassSection;
'T':
case UpChars[r[1]] of
'Y': // TY
if CompareIdentifiers('TYPE',r)=0 then begin
EndIdentifierSectionAndProc;
if StackTopType=bbtProcedure then
BeginBlock(bbtTypeSection);
end;
end;
'U':
case UpChars[r[1]] of
'N': // UN
if CompareIdentifiers('UNTIL',r)=0 then begin
EndTopMostBlock(bbtRepeat);
end;
end;
'V':
if CompareIdentifiers('VAR',r)=0 then begin
EndIdentifierSectionAndProc;
if StackTopType=bbtProcedure then
BeginBlock(bbtVarSection);
end;
end;
{$IFDEF VerboseIndenter}
if (Stack.Top<>Result) then
DebugLn(['TFullyAutomaticBeautifier.AdjustByNextAtom block close: Stack.Top=',Stack.Top,' Result=',Result]);
if TopTypeValid then
DebugLn(['TFullyAutomaticBeautifier.AdjustByNextAtom block open: TopType=',EnumToStr(TopType)]);
{$ENDIF}
end;
procedure TFullyAutomaticBeautifier.WriteDebugReport(Msg: string;
Stack: TFABBlockStack);
var
i: Integer;
Block: PBlock;
begin
DebugLn(['TFullyAutomaticBeautifier.WriteDebugReport ',Msg]);
if Stack<>nil then begin
for i:=0 to Stack.Top do begin
Block:=@Stack.Stack[i];
DebugLn([GetIndentStr(i*2),' : Typ=',EnumToStr(Block^.Typ),' StartPos=',Block^.StartPos,' InnerIdent=',Block^.InnerIdent,' InnerStartPos=',Block^.InnerStartPos]);
end;
end;
end;
constructor TFullyAutomaticBeautifier.Create;
begin
FCodePolicies:=TAVLTree.Create(@CompareFABPoliciesWithCode);
DefaultTabWidth:=4;
UseDefaultIndentForTypes:=[bbtStatement,bbtStatementRoundBracket,
bbtStatementEdgedBracket,bbtTypeRoundBracket,bbtTypeEdgedBracket];
end;
destructor TFullyAutomaticBeautifier.Destroy;
begin
Clear;
FreeAndNil(FCodePolicies);
inherited Destroy;
end;
procedure TFullyAutomaticBeautifier.Clear;
begin
FCodePolicies.FreeAndClear;
end;
function TFullyAutomaticBeautifier.GetIndent(const Source: string;
CleanPos: integer; NewNestedComments: boolean;
UseLineStart: boolean; out Indent: TFABIndentationPolicy;
ContextLearn: boolean; const InsertText: string): boolean;
var
Block: TBlock;
SubType: TFABBlockType;
SubTypeValid: Boolean;
function CheckPolicies(Policies: TFABPolicies; var Found: boolean;
UseSmallestIfNotFound: boolean): boolean;
// returns true to stop searching
var
BlockIndent: LongInt;
begin
Result:=false;
Found:=false;
if (Policies=nil) then exit;
if SubTypeValid then
BlockIndent:=Policies.GetIndent(Block.Typ,SubType,true,UseSmallestIfNotFound)
else
BlockIndent:=Policies.GetSmallestIndent(Block.Typ);
if (BlockIndent<0) then exit;
// policy found
{$IFDEF VerboseIndenter}
if SubTypeValid then
DebugLn(['TFullyAutomaticBeautifier.GetIndent policy found: Block.Typ=',EnumToStr(Block.Typ),'/',EnumToStr(SubType),' BlockIndent=',BlockIndent])
else
DebugLn(['TFullyAutomaticBeautifier.GetIndent policy found: Block.Typ=',EnumToStr(Block.Typ),' BlockIndent=',BlockIndent]);
//Policies.WriteDebugReport;
{$ENDIF}
Indent.Indent:=GetLineIndentWithTabs(Source,Block.StartPos,DefaultTabWidth)
+BlockIndent;
Indent.IndentValid:=true;
Result:=true;
Found:=true;
end;
var
Stack: TFABBlockStack;
Policies: TFABPolicies;
LastAtomStart, LastAtomEnd: integer;
StackIndex: LongInt;
PrevLineAtomEndPos: LongInt;
InsertTextStartPos: Integer;
ExamplePolicies: TFABPolicies;
begin
Result:=false;
FillByte(Indent,SizeOf(Indent),0);
CleanPos:=FindStartOfAtom(Source,CleanPos);
//DebugLn(['TFullyAutomaticBeautifier.GetIndent ']);
if CleanPos<1 then exit;
if UseLineStart and (InsertText='') then begin
while (CleanPos<=length(Source)) and (Source[CleanPos] in [' ',#9]) do
inc(CleanPos);
end;
Block:=CleanBlock;
Policies:=nil;
Stack:=TFABBlockStack.Create;
try
if ContextLearn then
Policies:=TFABPolicies.Create;
{$IFDEF ShowCodeBeautifierLearn}
if Policies=nil then
Policies:=TFABPolicies.Create;
Policies.Code:=TCodeBuffer.Create;
Policies.Code.Source:=Source;
{$ENDIF}
// parse source in front
{$IFDEF VerboseIndenter}
DebugLn(['TFullyAutomaticBeautifier.GetIndent "',dbgstr(copy(Source,CleanPos-10,10)),'|',dbgstr(copy(Source,CleanPos,10)),'"']);
{$ENDIF}
ParseSource(Source,1,CleanPos,NewNestedComments,Stack,Policies,
LastAtomStart,LastAtomEnd);
{$IFDEF VerboseIndenter}
WriteDebugReport('After parsing code in front:',Stack);
{$ENDIF}
if (LastAtomStart>0) and (CleanPos>LastAtomStart) then begin
// in comment or atom
{$IFDEF VerboseIndenter}
DebugLn(['TFullyAutomaticBeautifier.GetIndent parsed code in front: position in middle of atom, e.g. comment']);
{$ENDIF}
GetDefaultSrcIndent(Source,CleanPos,NewNestedComments,Indent);
exit(Indent.IndentValid);
end;
if LastAtomStart>0 then CleanPos:=LastAtomStart;
StackIndex:=Stack.Top;
SubType:=bbtNone;
SubTypeValid:=false;
if UseLineStart then begin
if InsertText='' then begin
StackIndex:=AdjustByNextAtom(Source,CleanPos,
NewNestedComments,Stack,SubType,SubTypeValid);
end else begin
InsertTextStartPos:=1;
while (InsertTextStartPos<=length(InsertText))
and (InsertText[InsertTextStartPos] in [' ',#9]) do
inc(InsertTextStartPos);
StackIndex:=AdjustByNextAtom(InsertText,InsertTextStartPos,
NewNestedComments,Stack,SubType,SubTypeValid);
end;
end;
if (StackIndex<0) then begin
// no context
{$IFDEF VerboseIndenter}
DebugLn(['TFullyAutomaticBeautifier.GetIndent parsed code in front: no context']);
{$ENDIF}
Indent.Indent:=0;
Indent.IndentValid:=true;
exit(Indent.IndentValid);
end;
if (Stack.Stack[StackIndex].Typ in UseDefaultIndentForTypes) then begin
// use default indent
{$IFDEF VerboseIndenter}
DebugLn(['TFullyAutomaticBeautifier.GetIndent use default for this type: ',EnumToStr(Stack.Stack[StackIndex].Typ)]);
{$ENDIF}
GetDefaultSrcIndent(Source,CleanPos,NewNestedComments,Indent);
exit(Indent.IndentValid);
end;
if (StackIndex<Stack.Top) and (not SubTypeValid) then begin
// block(s) closed by next token
// use indent of block start
Block:=Stack.Stack[StackIndex+1];
{$IFDEF VerboseIndenter}
DebugLn(['TFullyAutomaticBeautifier.GetIndent next token close block: ',EnumToStr(Stack.TopType),' Block=',dbgstr(copy(Source,Block.StartPos,20))]);
{$ENDIF}
Indent.Indent:=GetLineIndentWithTabs(Source,Block.StartPos,DefaultTabWidth);
Indent.IndentValid:=true;
exit(true);
end;
Block:=Stack.Stack[StackIndex];
// search last non empty line start
PrevLineAtomEndPos:=CleanPos;
while (PrevLineAtomEndPos>0)
and (not (Source[PrevLineAtomEndPos] in [#10,#13])) do
dec(PrevLineAtomEndPos);
if (PrevLineAtomEndPos>0) then
PrevLineAtomEndPos:=FindPrevNonSpace(Source,PrevLineAtomEndPos);
//debugln(['TFullyAutomaticBeautifier.GetIndent BEFORE check for last sibling ',Stack.LastBlockClosed.StartPos,' ',PositionsInSameLine(Source,Stack.LastBlockClosed.StartPos,Block.StartPos),' SubTypeValid=',SubTypeValid]);
if (Stack.LastBlockClosed.StartPos>0)
and (not PositionsInSameLine(Source,Stack.LastBlockClosed.StartPos,Block.StartPos))
and ((not SubTypeValid) or (SubType in bbtAllAlignToSibling))
then begin
//debugln(['TFullyAutomaticBeautifier.GetIndent BEFORE2 check for last sibling ',Stack.LastBlockClosedAt,' ',PositionsInSameLine(Source,Stack.LastBlockClosedAt,PrevLineAtomEndPos)]);
// a child block was closed that was started in another line than current block
// and this subtype aligns as its siblings
if (Stack.LastBlockClosedAt>0)
and PositionsInSameLine(Source,Stack.LastBlockClosedAt,PrevLineAtomEndPos)
then begin
// between block end and CleanPos are only empty lines
// => indent like the last child block one
{$IFDEF VerboseIndenter}
DebugLn(['TFullyAutomaticBeautifier.GetIndent line after end of last sibling block, copy indent']);
{$ENDIF}
Indent.Indent:=GetLineIndentWithTabs(Source,
Stack.LastBlockClosed.StartPos,DefaultTabWidth);
end else begin
// between block end and CleanPos are non empty lines
// => indent like the last non empty line
{$IFDEF VerboseIndenter}
DebugLn(['TFullyAutomaticBeautifier.GetIndent unstructural code found, indent as last line: LastBlockClosedAt=',dbgstr(copy(Source,Stack.LastBlockClosedAt,10)),' PrevAtom=',dbgstr(copy(Source,PrevLineAtomEndPos,10))]);
{$ENDIF}
Indent.Indent:=GetLineIndentWithTabs(Source,
PrevLineAtomEndPos,DefaultTabWidth);
end;
Indent.IndentValid:=true;
exit(true);
end;
{$IFDEF VerboseIndenter}
DebugLn(['TFullyAutomaticBeautifier.GetIndent parsed code in front: context=',EnumToStr(Block.Typ),'/',EnumToStr(SubType),' indent=',GetLineIndentWithTabs(Source,Block.StartPos,DefaultTabWidth)]);
{$ENDIF}
if Policies<>nil then begin
// check source in front for good match
if CheckPolicies(Policies,Result,false) then exit;
// parse source behind
ParseSource(Source,CleanPos,length(Source)+1,NewNestedComments,Stack,
Policies,false);
{$IFDEF VerboseIndenter}
DebugLn(['TFullyAutomaticBeautifier.GetIndent parsed source behind']);
{$ENDIF}
// check source for good match
if CheckPolicies(Policies,Result,false) then exit;
end;
{$IFDEF VerboseIndenter}
DebugLn(['TFullyAutomaticBeautifier.GetIndent Valid=',Indent.IndentValid,' Indent=',Indent.Indent]);
{$ENDIF}
// parse examples for good match
ExamplePolicies:=FindPolicyInExamples(nil,Block.Typ,SubType,true,false);
{$IFDEF VerboseIndenter}
DebugLn(['TFullyAutomaticBeautifier.GetIndent searched examples for exact match: context=',EnumToStr(Block.Typ),'/',EnumToStr(SubType),' contextindent=',GetLineIndentWithTabs(Source,Block.StartPos,DefaultTabWidth)]);
{$ENDIF}
if CheckPolicies(ExamplePolicies,Result,false) then exit;
if Policies<>nil then begin
// check current source for any match
{$IFDEF VerboseIndenter}
DebugLn(['TFullyAutomaticBeautifier.GetIndent check current source for any match: context=',EnumToStr(Block.Typ),'/',EnumToStr(SubType),' contextindent=',GetLineIndentWithTabs(Source,Block.StartPos,DefaultTabWidth)]);
{$ENDIF}
if CheckPolicies(Policies,Result,true) then exit;
end;
// parse examples for any match
ExamplePolicies:=FindPolicyInExamples(nil,Block.Typ,SubType,true,true);
{$IFDEF VerboseIndenter}
DebugLn(['TFullyAutomaticBeautifier.GetIndent searching examples for any match: context=',EnumToStr(Block.Typ),'/',EnumToStr(SubType),' contextindent=',GetLineIndentWithTabs(Source,Block.StartPos,DefaultTabWidth)]);
{$ENDIF}
if CheckPolicies(ExamplePolicies,Result,true) then exit;
finally
Stack.Free;
if Policies<>nil then
FreeAndNil(Policies.Code);
Policies.Free;
end;
{$IFDEF VerboseIndenter}
DebugLn(['TFullyAutomaticBeautifier.GetIndent no example found : context=',EnumToStr(Block.Typ),'/',EnumToStr(SubType),' contextindent=',GetLineIndentWithTabs(Source,Block.StartPos,DefaultTabWidth)]);
{$ENDIF}
if SubTypeValid then
GetDefaultIndentPolicy(Block.Typ,SubType,Indent)
else
GetDefaultIndentPolicy(Block.Typ,bbtNone,Indent);
if Indent.IndentValid then begin
{$IFDEF VerboseIndenter}
DebugLn(['TFullyAutomaticBeautifier.GetIndent using default ',Indent.Indent]);
{$ENDIF}
inc(Indent.Indent,GetLineIndentWithTabs(Source,Block.StartPos,DefaultTabWidth));
Result:=true;
end;
end;
function TFullyAutomaticBeautifier.GetIndents(const Source: string;
Positions: TFABPositionIndents; NewNestedComments: boolean;
UseLineStart: boolean; ContextLearn: boolean): boolean;
var
Needed: LongInt;
function CheckPolicies(Policies: TFABPolicies;
Item: PFABPositionIndent): boolean;
// returns true to stop searching
var
BlockIndent: LongInt;
begin
Result:=false;
if (Policies=nil) then exit;
if Item^.SubTypeValid then
BlockIndent:=Policies.GetIndent(Item^.Block.Typ,Item^.SubType,true,true)
else
BlockIndent:=Policies.GetSmallestIndent(Item^.Block.Typ);
if (BlockIndent<0) then exit;
// policy found
{$IFDEF VerboseIndenter}
DebugLn(['TFullyAutomaticBeautifier.GetIndent policy found: Block.Typ=',EnumToStr(Item^.Block.Typ),' BlockIndent=',BlockIndent]);
{$ENDIF}
Item^.Indent.Indent:=GetLineIndentWithTabs(Source,Item^.Block.StartPos,DefaultTabWidth)
+BlockIndent;
Item^.Indent.IndentValid:=true;
dec(Needed);
Result:=Needed=0;
end;
var
Item: PFABPositionIndent;
ItemIndex: Integer;
LastAtomStart, LastAtomEnd: integer;
Stack: TFABBlockStack;
StackIndex: LongInt;
Policies: TFABPolicies;
begin
Result:=false;
if (Positions=nil) or (Positions.Count=0) then exit;
Needed:=Positions.Count;
for ItemIndex:=0 to Positions.Count-1 do begin
Item:=@Positions.Items[ItemIndex];
Item^.CleanPos:=FindStartOfAtom(Source,Item^.CleanPos);
if Item^.CleanPos<1 then exit;
FillByte(Item^.Indent,SizeOf(Item^.Indent),0);
if (ItemIndex>0)
and (Item^.CleanPos<=Positions.Items[ItemIndex-1].CleanPos) then
exit;
Item^.Block:=CleanBlock;
Item^.SubType:=bbtNone;
Item^.SubTypeValid:=false;
end;
if UseLineStart then begin
Item:=@Positions.Items[0];
while (Item^.CleanPos<=length(Source))
and (Source[Item^.CleanPos] in [' ',#9]) do
inc(Item^.CleanPos);
end;
Policies:=nil;
Stack:=TFABBlockStack.Create;
try
if ContextLearn then
Policies:=TFABPolicies.Create;
{$IFDEF ShowCodeBeautifierLearn}
Policies.Code:=TCodeBuffer.Create;
Policies.Code.Source:=Source;
{$ENDIF}
for ItemIndex:=0 to Positions.Count-1 do begin
Item:=@Positions.Items[ItemIndex];
if ItemIndex=0 then begin
// parse source in front
{$IFDEF VerboseIndenter}
DebugLn(['TFullyAutomaticBeautifier.GetIndent Index=',ItemIndex,' "',dbgstr(copy(Source,Item^.CleanPos-10,10)),'|',dbgstr(copy(Source,Item^.CleanPos,10)),'"']);
{$ENDIF}
ParseSource(Source,1,Item^.CleanPos,NewNestedComments,Stack,Policies,
LastAtomStart,LastAtomEnd);
end else begin
// parse to next position
ParseSource(Source,Positions.Items[ItemIndex-1].CleanPos,
Item^.CleanPos,NewNestedComments,Stack,nil,
LastAtomStart,LastAtomEnd);
end;
{$IFDEF VerboseIndenter}
WriteDebugReport('After parsing code: ',Stack);
{$ENDIF}
if (LastAtomStart>0) and (Item^.CleanPos>LastAtomStart) then begin
// in comment or atom
{$IFDEF VerboseIndenter}
DebugLn(['TFullyAutomaticBeautifier.GetIndent Index=',ItemIndex,' parsed code in front: position in middle of atom, e.g. comment']);
{$ENDIF}
GetDefaultSrcIndent(Source,Item^.CleanPos,NewNestedComments,Item^.Indent);
if Item^.Indent.IndentValid then begin
dec(Needed);
if Needed=0 then exit;
end;
end;
if not Item^.Indent.IndentValid then begin
if LastAtomStart>0 then Item^.CleanPos:=LastAtomStart;
Item^.SubType:=bbtNone;
Item^.SubTypeValid:=false;
if UseLineStart then
StackIndex:=AdjustByNextAtom(Source,Item^.CleanPos,
NewNestedComments,Stack,Item^.SubType,Item^.SubTypeValid);
if (StackIndex<0) then begin
// no context
{$IFDEF VerboseIndenter}
DebugLn(['TFullyAutomaticBeautifier.GetIndent Index=',ItemIndex,' parsed code in front: no context']);
{$ENDIF}
GetDefaultSrcIndent(Source,Item^.CleanPos,NewNestedComments,Item^.Indent);
if Item^.Indent.IndentValid then begin
dec(Needed);
if Needed=0 then exit(true);
end;
end;
end;
StackIndex:=Stack.Top;
if not Item^.Indent.IndentValid then begin
if StackIndex=0 then begin
dec(Needed);
if Needed=0 then exit(true);
end else begin
Item^.Block:=Stack.Stack[StackIndex];
{$IFDEF VerboseIndenter}
DebugLn(['TFullyAutomaticBeautifier.GetIndent parsed code in front: context=',EnumToStr(Item^.Block.Typ),'/',EnumToStr(Item^.SubType),' indent=',GetLineIndentWithTabs(Source,Item^.Block.StartPos,DefaultTabWidth)]);
{$ENDIF}
if CheckPolicies(Policies,Item) then exit(true);
end;
end;
end;
if Policies<>nil then begin
// parse source behind
ParseSource(Source,Item^.CleanPos,length(Source)+1,NewNestedComments,
Stack,Policies,false);
{$IFDEF VerboseIndenter}
DebugLn(['TFullyAutomaticBeautifier.GetIndent parsed source behind']);
{$ENDIF}
for ItemIndex:=0 to Positions.Count-1 do begin
Item:=@Positions.Items[ItemIndex];
if (not Item^.Indent.IndentValid) and (Item^.Block.Typ<>bbtNone) then
if CheckPolicies(Policies,Item) then exit(true);
end;
end;
finally
Stack.Free;
if Policies<>nil then
FreeAndNil(Policies.Code);
Policies.Free;
end;
// parse examples
for ItemIndex:=0 to Positions.Count-1 do begin
Item:=@Positions.Items[ItemIndex];
if (not Item^.Indent.IndentValid) and (Item^.Block.Typ<>bbtNone) then begin
Policies:=FindPolicyInExamples(nil,Item^.Block.Typ,Item^.SubType,true,true);
{$IFDEF VerboseIndenter}
DebugLn(['TFullyAutomaticBeautifier.GetIndent parsed examples']);
{$ENDIF}
if (Policies<>nil) and CheckPolicies(Policies,Item) then
exit(true);
end;
end;
end;
procedure TFullyAutomaticBeautifier.GetDefaultSrcIndent(const Source: string;
CleanPos: integer; NewNestedComments: boolean; out
Indent: TFABIndentationPolicy);
// return indent of last non empty line
begin
Indent.Indent:=0;
Indent.IndentValid:=false;
// go to start of line
while (CleanPos>1) and (not (Source[CleanPos-1] in [#10,#13])) do
dec(CleanPos);
while CleanPos>1 do begin
// skip line end
dec(CleanPos);
if (CleanPos>1) and (Source[CleanPos-1] in [#10,#13])
and (Source[CleanPos]<>Source[CleanPos-1]) then
dec(CleanPos);
// read line
while (CleanPos>1) do begin
case Source[CleanPos-1] of
' ',#9: dec(CleanPos);
#10,#13:
begin
// empty line
break;
end;
else
dec(CleanPos);
Indent.Indent:=GetLineIndentWithTabs(Source,CleanPos,DefaultTabWidth);
Indent.IndentValid:=true;
exit;
end;
dec(CleanPos);
end;
end;
// only empty lines in front
end;
procedure TFullyAutomaticBeautifier.GetDefaultIndentPolicy(Typ,
SubTyp: TFABBlockType; out Indent: TFABIndentationPolicy);
begin
Indent.IndentValid:=false;
Indent.Indent:=0;
case Typ of
bbtInterface,
bbtImplementation,
bbtInitialization,
bbtFinalization,
bbtClass,
bbtClassInterface,
bbtProcedure,
bbtFunction,
bbtCaseOf,
bbtCaseLabel,
bbtIf:
begin
Indent.Indent:=0;
Indent.IndentValid:=true;
end;
bbtUsesSection,
bbtTypeSection,
bbtConstSection,
bbtVarSection,
bbtResourceStringSection,
bbtLabelSection,
bbtDefinition,
bbtRecord,
bbtClassSection,
bbtMainBegin,
bbtFreeBegin,
bbtRepeat,
bbtForDo,
bbtProcedureBegin,
bbtCase,
bbtCaseColon,
bbtCaseElse,
bbtTry,
bbtFinally,
bbtExcept,
bbtIfBegin:
begin
Indent.Indent:=2;
Indent.IndentValid:=true;
end;
bbtIfThen,
bbtIfElse:
if SubTyp=bbtIfBegin then begin
Indent.Indent:=0;
Indent.IndentValid:=true;
end else begin
Indent.Indent:=2;
Indent.IndentValid:=true;
end;
end;
end;
{ TFABPolicies }
function TFABPolicies.FindIndentation(Typ, SubType: TFABBlockType;
out InsertPos: integer): boolean;
// binary search
var
l: Integer;
r: Integer;
m: Integer;
Ind: PFABFoundIndentationPolicy;
begin
l:=0;
r:=IndentationCount-1;
while l<=r do begin
m:=(l+r) div 2;
Ind:=@Indentations[m];
if (Typ<Ind^.Typ) then
r:=m-1
else if (Typ>Ind^.Typ) then
l:=m+1
else if SubType<Ind^.SubTyp then
r:=m-1
else if SubType>Ind^.SubTyp then
l:=m+1
else begin
InsertPos:=m;
exit(true);
end;
end;
Result:=false;
if IndentationCount=0 then
InsertPos:=0
else if r<m then
InsertPos:=m
else
InsertPos:=m+1;
end;
constructor TFABPolicies.Create;
begin
end;
destructor TFABPolicies.Destroy;
begin
Clear;
inherited Destroy;
end;
procedure TFABPolicies.Clear;
begin
IndentationCount:=0;
ReAllocMem(Indentations,0);
IndentationCapacity:=0;
end;
procedure TFABPolicies.AddIndent(Typ, SubType: TFABBlockType;
SrcPos, Indent: integer);
var
i: Integer;
Ind: PFABFoundIndentationPolicy;
begin
if not FindIndentation(Typ,SubType,i) then begin
inc(IndentationCount);
if IndentationCount>IndentationCapacity then begin
IndentationCapacity:=IndentationCapacity*2+12;
ReAllocMem(Indentations,SizeOf(TFABFoundIndentationPolicy)*IndentationCapacity);
end;
if i<IndentationCount-1 then
System.Move(Indentations[i],Indentations[i+1],
SizeOf(TFABFoundIndentationPolicy)*(IndentationCount-i-1));
Ind:=@Indentations[i];
Ind^.Typ:=Typ;
Ind^.SubTyp:=SubType;
Ind^.Indent:=Indent;
{$IFDEF StoreLearnedPositions}
Ind^.SrcPos:=SrcPos;
{$ENDIF}
{$IFDEF ShowCodeBeautifierLearn}
DebugLn(['TFABPolicies.AddIndent New SubTyp ',EnumToStr(Typ),'-',EnumToStr(SubType),': indent=',Indent,' ',CodePosToStr(SrcPos)]);
ConsistencyCheck;
{$ENDIF}
end else begin
Ind:=@Indentations[i];
if Ind^.Indent<>Indent then begin
Ind^.Indent:=Indent;
{$IFDEF ShowCodeBeautifierLearn}
DebugLn(['TFABPolicies.AddIndent Changed SubTyp ',EnumToStr(Typ),'-',EnumToStr(SubType),': indent=',Indent,' ',CodePosToStr(SrcPos)]);
{$ENDIF}
end;
end;
end;
function TFABPolicies.GetSmallestIndent(Typ: TFABBlockType): integer;
var
i: Integer;
begin
Result:=High(integer);
for i:=0 to IndentationCount-1 do begin
if (Indentations[i].Typ<>Typ) or (Indentations[i].Indent<0) then continue;
{$IFDEF VerboseIndenter}
debugln(['TFABPolicies.GetSmallestIndent ',EnumToStr(Indentations[i].Typ),'/',EnumToStr(Indentations[i].SubTyp),' Indent=',Indentations[i].Indent
{$IFDEF StoreLearnedPositions}
,' SrcPos=',CodePosToStr(Indentations[i].SrcPos)
{$ENDIF}
]);
{$ENDIF}
if Indentations[i].Indent<Result then
Result:=Indentations[i].Indent;
end;
if Result=High(integer) then
Result:=-1;
end;
function TFABPolicies.GetIndent(Typ, SubType: TFABBlockType;
UseNoneIfNotFound, UseSmallestIfNotFound: boolean): integer;
var
i: integer;
begin
if FindIndentation(Typ,SubType,i) then begin
Result:=Indentations[i].Indent;
{$IFDEF VerboseIndenter}
debugln(['TFABPolicies.GetIndent ',EnumToStr(Typ),'/',EnumToStr(SubType),' learned at ',CodePosToStr(Indentations[i].SrcPos),' Result=',Result]);
{$ENDIF}
end else if UseNoneIfNotFound and FindIndentation(Typ,bbtNone,i) then begin
Result:=Indentations[i].Indent;
{$IFDEF VerboseIndenter}
debugln(['TFABPolicies.GetIndent ',EnumToStr(Typ),'/',EnumToStr(bbtNone),' learned at ',CodePosToStr(Indentations[i].SrcPos),' Result=',Result]);
{$ENDIF}
end else if UseSmallestIfNotFound then
Result:=GetSmallestIndent(Typ)
else
Result:=-1;
end;
function TFABPolicies.CodePosToStr(p: integer): string;
var
Line: integer;
Col: integer;
begin
if Code<>nil then begin
Code.AbsoluteToLineCol(p,Line,Col);
Result:='('+IntToStr(Line)+','+IntToStr(Col)+')';
end else begin
Result:='(p='+IntToStr(p)+')';
end;
end;
procedure TFABPolicies.ConsistencyCheck;
procedure Error;
begin
WriteDebugReport;
RaiseCatchableException('');
end;
var
i: Integer;
Ind1: PFABFoundIndentationPolicy;
Ind2: PFABFoundIndentationPolicy;
InsertPos: integer;
begin
for i:=0 to IndentationCount-1 do begin
Ind1:=@Indentations[i];
if Ind1^.Indent=High(Ind1^.Indent) then
Error;
if Ind1^.Indent<0 then
Error;
if i<IndentationCount-1 then begin
// check for duplicates and sorted
Ind2:=@Indentations[i+1];
if Ind1^.Typ>Ind2^.Typ then
Error;
if Ind1^.Typ=Ind2^.Typ then begin
if Ind1^.SubTyp>=Ind2^.SubTyp then
Error;
end;
end;
if not FindIndentation(Ind1^.Typ,Ind1^.SubTyp,InsertPos) then
Error;
if InsertPos<>i then
Error;
end;
end;
procedure TFABPolicies.WriteDebugReport;
var
i: Integer;
Ind: PFABFoundIndentationPolicy;
begin
debugln(['TFABPolicies.WriteDebugReport ']);
for i:=0 to IndentationCount-1 do begin
Ind:=@Indentations[i];
debugln([' ',i,'/',IndentationCount,' ',EnumToStr(Ind^.Typ),'=',ord(Ind^.Typ),' ',EnumToStr(Ind^.SubTyp),'=',ord(Ind^.SubTyp),' Indent=',Ind^.Indent]);
end;
end;
{ TFABPositionIndents }
procedure TFABPositionIndents.SetCount(const AValue: integer);
begin
if FCount=AValue then exit;
ReAllocMem(Items,SizeOf(TFABPositionIndent)*AValue);
if AValue>FCount then
FillByte(Items[FCount],SizeOf(TFABPositionIndent)*(AValue-FCount),0);
FCount:=AValue;
end;
constructor TFABPositionIndents.Create;
begin
end;
destructor TFABPositionIndents.Destroy;
begin
Clear;
inherited Destroy;
end;
procedure TFABPositionIndents.Clear;
begin
Count:=0;
end;
end.
Reference in New Issue View Git Blame Copy Permalink