{
 Test all with:
   ./runtests --format=plain --suite=TTestPascalParser

 Test specific with:
   ./runtests --format=plain --suite=TestRecord_ClassOperators
}
unit TestPascalParser;

{$i runtestscodetools.inc}

interface

uses
  Classes, SysUtils, math, CodeToolManager, CodeCache, CodeAtom,
  LazLogger, fpcunit, testregistry, TestGlobals;

type

  { TCustomTestPascalParser }

  TCustomTestPascalParser = class(TTestCase)
  private
    FCode: TCodeBuffer;
  protected
    procedure SetUp; override;
    procedure TearDown; override;
    procedure DoParseModule(aCode: TCodeBuffer; out Tool: TCodeTool);
  public
    procedure Add(const s: string);
    procedure Add(Args: array of const);
    procedure StartUnit;
    function StartProgram: boolean; virtual;
    procedure ParseModule;
    procedure CheckParseError(const CursorPos: TCodeXYPosition; Msg: string);
    procedure WriteSource(CleanPos: integer; Tool: TCodeTool);
    procedure WriteSource(const CursorPos: TCodeXYPosition);
    property Code: TCodeBuffer read FCode;
  end;

  { TTestPascalParser }

  TTestPascalParser = class(TCustomTestPascalParser)
  published
    procedure TestAtomRing;
    procedure TestRecord_ClassOperators;
    procedure TestRecord_Nonkeywords;
    procedure TestRecord_Align;
    procedure TestDeprecated;
    procedure TestMissingGenericKeywordObjFPCFail;
    procedure TestParseGenericsDelphi;
    procedure TestParseExternalConcat;
    procedure TestParseExternalConst;
    procedure TestParseModeTP;
    procedure TestParseIFOpt;
    procedure TestParseProcAnoAssign;
    procedure TestParseProcAnoArg;
    procedure TestParseProcAnoArgSubFunc;
    procedure TestParseThreadVar;
    procedure TestParseMultilineStringFPC;
    procedure TestParseMultilineStringDelphi;
    procedure TestParseUnderscoreIsSeparator;
    procedure TestParseDirective_IF_SizeOf_Char;
    procedure TestParseObjectSealedAbstract;
  end;

implementation

{ TCustomTestPascalParser }

procedure TCustomTestPascalParser.SetUp;
begin
  inherited SetUp;
  FCode:=CodeToolBoss.CreateFile('test1.pas');
end;

procedure TCustomTestPascalParser.TearDown;
begin
  inherited TearDown;
end;

procedure TCustomTestPascalParser.DoParseModule(aCode: TCodeBuffer; out
  Tool: TCodeTool);
var
  i: Integer;
  Line: String;
begin
  if not CodeToolBoss.Explore(aCode,Tool,true) then begin
    debugln(aCode.Filename+'------------------------------------------');
    for i:=1 to aCode.LineCount do begin
      Line:=aCode.GetLine(i-1,false);
      if i=CodeToolBoss.ErrorLine then
        System.Insert('|',Line,CodeToolBoss.ErrorColumn);
      debugln(Format('%:4d: ',[i]),Line);
    end;
    debugln('Error: '+CodeToolBoss.ErrorDbgMsg);
    Fail('PascalParser failed: '+CodeToolBoss.ErrorMessage);
  end;
end;

procedure TCustomTestPascalParser.Add(const s: string);
begin
  FCode.Source:=FCode.Source+s+LineEnding;
end;

procedure TCustomTestPascalParser.Add(Args: array of const);
begin
  FCode.Source:=FCode.Source+LinesToStr(Args);
end;

procedure TCustomTestPascalParser.StartUnit;
begin
  Add('unit test1;');
  Add('');
  Add('{$mode objfpc}{$H+}');
  Add('');
  Add('interface');
  Add('');
end;

function TCustomTestPascalParser.StartProgram: boolean;
begin
  Result:=true;
  Add('program test1;');
  Add('');
  Add('{$mode objfpc}{$H+}');
  Add('');
end;

procedure TCustomTestPascalParser.ParseModule;
var
  Tool: TCodeTool;
begin
  Add('end.');
  DoParseModule(Code,Tool);
end;

procedure TCustomTestPascalParser.CheckParseError(
  const CursorPos: TCodeXYPosition; Msg: string);
var
  Tool: TCodeTool;
begin
  if CodeToolBoss.Explore(Code,Tool,true) then begin
    WriteSource(CursorPos);
    Fail('missing parser error "'+Msg+'"');
  end;
  if Tool=nil then begin
    WriteSource(CursorPos);
    Fail('missing Tool, Msg="'+Msg+'"');
  end;
  if CursorPos.Code<>CodeToolBoss.ErrorCode then begin
    WriteSource(CursorPos);
    Fail('expected parser error "'+Msg+'" in "'+CursorPos.Code.Filename+'", not in "'+CodeToolBoss.ErrorCode.Filename+'"');
  end;
  if (CursorPos.Y<>CodeToolBoss.ErrorLine) or (CursorPos.X<>CodeToolBoss.ErrorColumn) then begin
    WriteSource(CursorPos);
    Fail('expected parser error "'+Msg+'" at line='+IntToStr(CursorPos.Y)+' col='+IntToStr(CursorPos.X)+', but got line='+IntToStr(CodeToolBoss.ErrorLine)+' col='+IntToStr(CodeToolBoss.ErrorColumn));
  end;
  if (Msg<>CodeToolBoss.ErrorMessage) then begin
    WriteSource(CursorPos);
    Fail('expected parser error "'+Msg+'" instead of "'+CodeToolBoss.ErrorMessage+'"');
  end;
end;

procedure TCustomTestPascalParser.WriteSource(CleanPos: integer; Tool: TCodeTool
  );
var
  Caret: TCodeXYPosition;
begin
  if Tool=nil then
    Fail('TCustomTestPascalParser.WriteSource: missing Tool');
  if not Tool.CleanPosToCaret(CleanPos,Caret) then
    Fail('TCustomTestPascalParser.WriteSource: invalid cleanpos '+IntToStr(CleanPos)+' Tool='+Tool.MainFilename);
  WriteSource(Caret);
end;

procedure TCustomTestPascalParser.WriteSource(const CursorPos: TCodeXYPosition);
var
  CurCode: TCodeBuffer;
  i: Integer;
  Line: String;
begin
  CurCode:=CursorPos.Code;
  if CurCode=nil then
    Fail('TCustomTestPascalParser.WriteSource CurCode=nil');
  for i:=1 to CurCode.LineCount do begin
    Line:=CurCode.GetLine(i-1,false);
    if (i=CursorPos.Y) then begin
      write('*');
      Line:=LeftStr(Line,CursorPos.X-1)+'|'+copy(Line,CursorPos.X,length(Line));
    end;
    writeln(Format('%:4d: ',[i]),Line);
  end;
end;

{ TTestPascalParser }

procedure TTestPascalParser.TestAtomRing;

  procedure CheckAtom(Msg: String; const Expected, Actual: TAtomPosition);
  begin
    AssertEquals(Msg+' StartPos',Expected.StartPos,Actual.StartPos);
    AssertEquals(Msg+' EndPos',Expected.EndPos,Actual.EndPos);
    if Expected.Flag<>Actual.Flag then
      Fail(Msg+' Flag Expected='+CommonAtomFlagNames[Expected.Flag]+' but found '+CommonAtomFlagNames[Actual.Flag]);
  end;

  procedure CheckIndexOf(Msg: string; R: TAtomRing);
  var
    i, Actual: Integer;
    P: TAtomPosition;
  begin
    for i:=1-R.PriorCount to R.NextCount do begin
      P:=R.GetAtomAt(i);
      if not R.IndexOf(P.StartPos,Actual) then
        Fail(Msg+' CheckIndexOf i='+IntToStr(i)+' IndexOf failed');
      AssertEquals(Msg+' CheckIndexOf',i,Actual);
    end;
  end;

var
  R: TAtomRing;
  P, P1, P2: TAtomPosition;
  i: Integer;
begin
  R:=TAtomRing.Create;
  try
    R.Size:=4;
    AssertEquals('1-empty count',0,R.PriorCount);
    AssertEquals('1-empty nextcount',0,R.NextCount);

    P1:=AtomPosition(1,2,cafWord);
    R.Add(P1);
    AssertEquals('2-first atom count',1,R.PriorCount);
    AssertEquals('2-first atom nextcount',0,R.NextCount);
    P:=R.GetAtomAt(0);
    CheckAtom('2-first atom',P1,P);

    CheckIndexOf('2-first atom',R);

    R.UndoLastAdd;
    //R.WriteDebugReport;
    AssertEquals('3-empty after undo count',0,R.PriorCount);
    AssertEquals('3-empty after undo nextcount',0,R.NextCount);

    P1:=AtomPosition(1,2,cafWord);
    R.Add(P1);
    //R.WriteDebugReport;
    AssertEquals('4-first atom count',1,R.PriorCount);
    AssertEquals('4-first atom nextcount',0,R.NextCount);
    P:=R.GetAtomAt(0);
    CheckAtom('4-first atom',P1,P);
    CheckIndexOf('4-first atom',R);

    P2:=AtomPosition(3,4,cafWord);
    R.Add(P2);
    //R.WriteDebugReport;

    AssertEquals('5-second atom count',2,R.PriorCount);
    AssertEquals('5-second atom nextcount',0,R.NextCount);
    P:=R.GetAtomAt(0);
    CheckAtom('5-second atom 0',P2,P);
    P:=R.GetAtomAt(-1);
    CheckAtom('5-second atom -1',P1,P);
    CheckIndexOf('5-second atom',R);

    R.UndoLastAdd;
    //R.WriteDebugReport;
    AssertEquals('6-undo after add two: count',1,R.PriorCount);
    AssertEquals('6-undo after add two: nextcount',1,R.NextCount);
    P:=R.GetAtomAt(0);
    CheckAtom('6-undo after add two: atom 0',P1,P);
    P:=R.GetAtomAt(1);
    CheckAtom('6-undo after add two: atom +1',P2,P);
    CheckIndexOf('6-undo after add two',R);

    P2:=AtomPosition(5,6,cafWord);
    R.Add(P2);
    //R.WriteDebugReport;

    AssertEquals('7-second atom count',2,R.PriorCount);
    AssertEquals('7-second atom nextcount',0,R.NextCount);
    P:=R.GetAtomAt(0);
    CheckAtom('7-second atom 0',P2,P);
    P:=R.GetAtomAt(-1);
    CheckAtom('7-second atom -1',P1,P);
    CheckIndexOf('7-second atom',R);

    R.Clear;
    //R.WriteDebugReport;
    for i:=1 to 5 do begin
      // add first
      P1:=AtomPosition(i*4,i*4+1,cafWord);
      R.Add(P1);
      //R.WriteDebugReport;
      AssertEquals('8-Added first: '+IntToStr(i)+' count',Min(i,R.Size),R.PriorCount);
      AssertEquals('8-Added first: '+IntToStr(i)+' nextcount',0,R.NextCount);
      P:=R.GetAtomAt(0);
      CheckAtom('8-Added first: atom 0',P1,P);
      CheckIndexOf('8-Added first',R);

      // add two
      P2:=AtomPosition(i*4+2,i*4+3,cafWord);
      R.Add(P2);
      //R.WriteDebugReport;
      AssertEquals('9-Added second: '+IntToStr(i)+' count',Min(i+1,R.Size),R.PriorCount);
      AssertEquals('9-Added second: '+IntToStr(i)+' nextcount',0,R.NextCount);
      P:=R.GetAtomAt(0);
      CheckAtom('9-Added second: '+IntToStr(i)+' atom 0',P2,P);
      P:=R.GetAtomAt(-1);
      CheckAtom('9-Added second: '+IntToStr(i)+' atom -1',P1,P);
      CheckIndexOf('9-Added second',R);

      // undo one
      R.UndoLastAdd;
      //R.WriteDebugReport;
      AssertEquals('10-Undo: '+IntToStr(i)+' count',Min(i,R.Size-1),R.PriorCount);
      AssertEquals('10-Undo: '+IntToStr(i)+' nextcount',1,R.NextCount);
      P:=R.GetAtomAt(0);
      CheckAtom('10-Undo: '+IntToStr(i)+' atom 0',P1,P);
      P:=R.GetAtomAt(1);
      CheckAtom('10-Undo: '+IntToStr(i)+' atom +1',P2,P);
      CheckIndexOf('10-Undo',R);
    end;

    FreeAndNil(R);
  finally
    if R<>nil then begin
      R.WriteDebugReport;
      R.Free;
    end;
  end;
end;

procedure TTestPascalParser.TestRecord_ClassOperators;
begin
  StartProgram;
  Add([
    '{$modeswitch advancedrecords}',
    'type',
    '  TFlag = (flag1);',
    '{$Define FPC_HAS_MANAGEMENT_OPERATORS}',
    '  TMyRecord = record',
    '    class operator Implicit(t: TMyRecord): TMyRecord;',
    '    class operator Explicit(t: TMyRecord): TMyRecord;',
    '    class operator Negative(t: TMyRecord): TMyRecord;',
    '    class operator Positive(t: TMyRecord): TMyRecord;',
    '    class operator Inc(t: TMyRecord): TMyRecord;',
    '    class operator Dec(t: TMyRecord): TMyRecord;',
    '    class operator LogicalNot(t: TMyRecord): TMyRecord;',
    '    class operator Trunc(t: TMyRecord): TMyRecord;',
    '    class operator Round(t: TMyRecord): TMyRecord;',
    '    class operator In(f: TFlag; t: TMyRecord): boolean;',
    '    class operator Equal(t1, t2: TMyRecord): boolean;',
    '    class operator NotEqual(t1, t2: TMyRecord): boolean;',
    '    class operator GreaterThan(t1, t2: TMyRecord): boolean;',
    '    class operator GreaterThanOrEqual(t1, t2: TMyRecord): boolean;',
    '    class operator LessThan(t1, t2: TMyRecord): boolean;',
    '    class operator LessThanOrEqual(t1, t2: TMyRecord): boolean;',
    '    class operator Add(t1, t2: TMyRecord): TMyRecord;',
    '    class operator Subtract(t1, t2: TMyRecord): TMyRecord;',
    '    class operator Multiply(t1, t2: TMyRecord): TMyRecord;',
    '    class operator Divide(t1, t2: TMyRecord): TMyRecord;',
    '    class operator IntDivide(t1, t2: TMyRecord): TMyRecord;',
    '    class operator Modulus(t1, t2: TMyRecord): TMyRecord;',
    '    class operator LeftShift(t1, t2: TMyRecord): TMyRecord;',
    '    class operator RightShift(t1, t2: TMyRecord): TMyRecord;',
    '    class operator LogicalAnd(b: boolean; t: TMyRecord): TMyRecord;',
    '    class operator LogicalOr(b: boolean; t: TMyRecord): TMyRecord;',
    '    class operator LogicalXor(b: boolean; t: TMyRecord): TMyRecord;',
    '    class operator BitwiseAnd(t1, t2: TMyRecord): TMyRecord;',
    '    class operator BitwiseOr(t1, t2: TMyRecord): TMyRecord;',
    '    class operator BitwiseXor(t1, t2: TMyRecord): TMyRecord;',
    '    // only IFDEF FPC_HAS_MANAGEMENT_OPERATORS',
    '    class operator Initialize(var t: TMyRecord);',
    '    class operator Finalize(var t: TMyRecord);',
    '    class operator Copy(var t: TMyRecord);',
    '    class operator AddRef(constref t1: TMyRecord ; var t2: TMyRecord);',
    '  end;',
    '',
    'class operator TMyRecord.Implicit(t: TMyRecord): TMyRecord;',
    'begin end;',
    '',
    '// only IFDEF FPC_HAS_MANAGEMENT_OPERATORS',
    'class operator TMyRecord.Initialize(var t: TMyRecord);',
    'begin end;',
    '',
    'begin'
    ]);
  ParseModule;
end;

procedure TTestPascalParser.TestRecord_Nonkeywords;
begin
  StartProgram;
  Add([
  'type',
  '  t = record',
  '    public: word;',
  '    private: word;',
  '    protected: word;',
  '    published: word;',
  '  end;',
  'begin']);
  ParseModule;
end;

procedure TTestPascalParser.TestRecord_Align;
begin
  StartProgram;
  Add([
  'type',
  '  t = record',
  '    pad: word;',
  '  end align 16;',
  'begin']);
  ParseModule;
end;

procedure TTestPascalParser.TestDeprecated;
begin
  StartProgram;
  Add([
  'type',
  '  t = string deprecated ''t'';',
  '  TBird = class',
  '    FA: longint deprecated;',
  '    Deprecated: longint;',
  '    procedure SetA; deprecated;',
  '    property A: longint read FA; deprecated;',
  '    property B: string; experimental; platform;',
  '    property C: char; experimental platform;',
  '    property D: double; platform; experimental; ',
  '  end deprecated ''tbird'';',
  'var',
  '  c: char deprecated;',
  '  b: boolean deprecated ''b'';',
  '  deprecated: boolean;',
  '  e: word platform = 1 deprecated;',
  'procedure DoIt; deprecated;',
  'begin end;',
  'begin']);
  ParseModule;
end;

procedure TTestPascalParser.TestMissingGenericKeywordObjFPCFail;
begin
  Add([
  'program test1;',
  '{$mode objfpc}',
  'type',
  '  TList<T> = class end;',
  'begin']);
  CheckParseError(CodeXYPosition(8,4,Code),'expected =, but < found');
end;

procedure TTestPascalParser.TestParseGenericsDelphi;
begin
  Add([
  'program test1;',
  '{$mode delphi}',
  'type',
  '  TRec = record',
  '    procedure Proc<T>;', // generic proc inside normal record
  '  end;',
  '  TBird<B> = class(TAnimal<B>)',
  '    procedure DoIt;', // normal proc inside generic class
  '    procedure DoSome<T>;', // generic proc inside generic class
  '    generic class procedure DoGen<P>(i: P);',
  '  end;',
  'procedure TRec.Proc<T>;', // generic proc inside normal record
  'begin',
  'end;',
  'procedure TBird<B>.DoIt;', // normal proc inside generic class
  'begin',
  'end;',
  'procedure TBird<B>.DoSome<T>;', // generic proc inside generic class
  'begin',
  'end;',
  'generic class procedure TBird<B>.DoGen<P>(i: P);',
  'begin',
  'end;',
  'begin']);
  ParseModule;
end;

procedure TTestPascalParser.TestParseExternalConcat;
begin
  Add([
  'program test1;',
  '{$mode objfpc}',
  'procedure foo; cdecl; external name concat(''foo'', ''bar'');',
  'begin']);
  ParseModule;
end;

procedure TTestPascalParser.TestParseExternalConst;
begin
  Add([
  'program test1;',
  'const NaN: double; external;',
  'const nan: double; external name ''NaN'';',
  '{$modeswitch externalclass}',
  'type',
  '  TExtA = class external name ''ExtA''',
  '    const id;',
  '  end;',
  'begin']);
  ParseModule;
end;

procedure TTestPascalParser.TestParseModeTP;
begin
  Add([
  'program test1;',
  '{$mode tp}',
  '{ {}',
  'begin']);
  ParseModule;
end;

procedure TTestPascalParser.TestParseIFOpt;
begin
  Add([
  'program test1;',
  '{$IFOPT R+}',
  'RNothingError',
  '{$ENDIF}',
  '{$R+}',
  '{$IFOPT R-}',
  'RMinusError',
  '{$ENDIF}',
  '{$R-}',
  '{$IFOPT R+}',
  'RPlusError',
  '{$ENDIF}',
  'begin']);
  ParseModule;
end;

procedure TTestPascalParser.TestParseProcAnoAssign;
begin
  Add([
  'program test1;',
  '{$modeswitch anonymousfunctions}',
  'procedure DoIt;',
  'begin',
  '  p:=procedure begin end;',
  '  p:=procedure(w: word) begin end;',
  '  p:=procedure assembler asm end;',
  '  p:=procedure var w:word; begin end;',
  '  p:=procedure const c=3; begin end;',
  '  p:=procedure type p=procedure; begin end;',
  '  p:=procedure begin p:=function:word begin end end;',
  '  p:=procedure begin p:=procedure(w:word) begin end; end;',
  'end;',
  'begin',
  '  p:=procedure begin end;',
  '  p:=procedure begin p:=procedure(w:word) begin end; end;',
  '']);
  ParseModule;
end;

procedure TTestPascalParser.TestParseProcAnoArg;
begin
  Add([
  'program test1;',
  '{$mode objfpc}',
  '{$modeswitch anonymousfunctions}',
  'procedure DoIt;',
  'begin',
  '  DoIt(procedure begin end);',
  '  DoIt(procedure(var v: word; const c: word; out o: word) begin end);',
  '  DoIt(procedure assembler asm end);',
  '  DoIt(procedure var w:word; begin end);',
  '  DoIt(procedure const c=3; begin end);',
  '  DoIt(procedure type p=procedure; begin end);',
  '  DoIt(procedure begin p:=function:word begin end end);',
  '  DoIt(procedure begin p:=procedure(w:word) begin end; end);',
  'end;',
  'begin',
  '  DoIt(procedure begin end);',
  '  DoIt(procedure begin p:=procedure(w:word) begin end; end);',
  '']);
  ParseModule;
end;

procedure TTestPascalParser.TestParseProcAnoArgSubFunc;
begin
  Add([
  'program test1;',
  '{$mode objfpc}',
  '{$modeswitch anonymousfunctions}',
  'procedure DoIt;',
  'begin',
  '  DoIt(',
  '    procedure',
  '      function Fly: word;',
  '      begin InFly; end;',
  '    begin InAno1;',
  '    end);',
  '  DoIt(',
  '    procedure(v: word)',
  '      function Run: word;',
  '      begin InRun end;',
  '    begin InAno2;',
  '    end);',
  'end;',
  'begin',
  '  DoIt(',
  '    procedure',
  '      function Say: word;',
  '      begin InSay; end;',
  '    begin InAno3;',
  '    end);',
  '']);
  ParseModule;
end;

procedure TTestPascalParser.TestParseThreadVar;
begin
  Add([
  'program test1;',
  'type',
  '  TTestClass = class',
  '    private class threadvar',
  '      foo:Boolean;',
  '  end;',
  '',
  'begin',
  '']);
  ParseModule;
end;

procedure TTestPascalParser.TestParseMultilineStringFPC;
begin
  Add([
  'program test1;',
  '{$modeswitch multilinestrings}',
  'const',
  '  s = `First',
  'Second',
  'Third`;',
  '  a = ``;',
  '  b = `',
  '`#10`',
  'line`;',
  '  c = ''''``;',
  'begin',
  '']);
  ParseModule;
end;

procedure TTestPascalParser.TestParseMultilineStringDelphi;
begin
  Add([
  'program test1;',
  '{$TEXTBLOCK Native comment: could be native/cr/lf/crlf}',
  'const',
  '  s = ''''''',
  '    First',
  '    Second''Lit', // skip single apostroph
  '    Third''''Lit', // skip double apostroph
  '    '''''';', // last line defines ignored indentation. here: cut 4
  '  a = ''''''OneLine'''''';',
  '  b = ''''; // empty string literal',
  '  c = ''''''''; // string literal in string literal',
  'begin',
  '']);
  ParseModule;
end;

procedure TTestPascalParser.TestParseUnderscoreIsSeparator;
begin
  Add([
  'program test1;',
  '{$modeswitch underscoreisseparator}',
  'const',
  '  a = 1_000;',
  '  b = 1__0;',
  '  c = 1_0.3_4E5_6;',
  'begin',
  '']);
  ParseModule;
end;

procedure TTestPascalParser.TestParseDirective_IF_SizeOf_Char;
begin
  Add([
  'program test1;',
  '{$modeswitch unicodestrings}',
  '{$if sizeof(char)=2}',
  'const t = 2;',
  '{$else}',
  'sizeof failed',
  '{$endif}',
  'begin',
  '']);
  ParseModule;
end;

procedure TTestPascalParser.TestParseObjectSealedAbstract;
begin
  StartProgram;
  Add([
  'type',
  'TFoo = object',
  'end;',
  'TBar = object sealed (TFoo)',
  '  Field1:boolean;',
  'end;',
  'TBar2 = object abstract (TFoo)',
  '  Field1:boolean;',
  'end;',
  'begin']);
  ParseModule;
end;

initialization
  RegisterTest(TTestPascalParser);

end.