unit dpglib.Tool;

interface
uses
   System.Classes,
   System.SysUtils,
   dpgrtl.types,
   dpgrtl.exception,
   dpglib.Types;

type
   // =========================================================================
   // Class TTool declaration
   // =========================================================================
   TTool = class( TInterfacedObject,
                     ITool)

   protected
      fModuleStream  : TStream;
      fModuleName    : AnsiString;
      fOutputDir     : AnsiString;
      fExchangeDir   : AnsiString;
      fErrorHandler  : IToolErrorHandler;

   protected
      fWarningCount  : integer;
      fErrorCount    : integer;

   protected
      // ------------------------------------------------------------
      // members
      // ------------------------------------------------------------
      fGrammarFile   : AnsiString;
      fGrammar       : IGrammar;

      function    GetWarningCount   : integer;
      function    GetErrorCount     : integer;

      // ------------------------------------------------------------
      // Exception handling
      // ------------------------------------------------------------
      procedure   exMismatchedChar(    mc: EMismatchedChar);
      procedure   exMismatchedToken(   mt: EMismatchedToken);

      procedure   dumpSets(               pGrammar : IGrammar;
                                          pLexical : boolean;
                                          pSets    : TInterfaceList;
                                          pDepth   : integer);

   public
      // ------------------------------------------------------------
      // Constructor/destructor
      // ------------------------------------------------------------
      constructor Create(  pFile          : AnsiString;
                           pErrorHandler  : IToolErrorHandler); overload;

      constructor Create(  pModuleStream  : TStream;
                           pModuleName    : AnsiString;
                           pOutputDir     : AnsiString;
                           pExchangeDir   : AnsiString;
                           pErrorHandler  : IToolErrorHandler); overload;

      destructor  Destroy; override;

   public
      // ------------------------------------------------------------
      // ITool methods
      // ------------------------------------------------------------
      procedure   Go;
      function    Get_ErrorHandler: IToolErrorHandler;

      procedure   Debug(                  pMessage : AnsiString);
      procedure   Error(                  pMessage : AnsiString;
                                          pFileName: AnsiString    = '';
                                          pLine    : integer   = 0;
                                          pColumn  : integer   = 0);

      procedure   Warning(                pMessage : AnsiString;
                                          pFileName: AnsiString    = '';
                                          pLine    : integer   = 0;
                                          pColumn  : integer   = 0);

      procedure   Panic(                  pMessage : AnsiString);

      procedure   WarnAltAmbiguity(       pGrammar : IGrammar;
                                          pBlock   : IAlternativeBlock;
                                          pLexical : boolean;
                                          pDepth   : integer;
                                          pSets    : TInterfaceList;
                                          pAltIdx1 : integer;
                                          pAltIdx2 : integer);

      procedure   WarnAltExitAmbiguity(   pGrammar : IGrammar;
                                          pBlock   : IBlockWithImpliedExitPath;
                                          pLexical : boolean;
                                          pDepth   : integer;
                                          pSets    : TInterfaceList;
                                          pAltIdx  : integer);
   end;

implementation
uses
   dpglib.DpgLexer,
   dpglib.DpgParser,
   dpglib.CodeGenerator,
   dpglib.Utils,
   dpglib.LLkAnalyzer,
   dpglib.GrammarMaker,
   dpglib.DelphiGenerator,
   dpglib.PrettyPrinter;
//   dpgExceptionPanic;

// ****************************************************************************
//
//                                                       Constructor/destructor
//
// ****************************************************************************
// ============================================================================
// Constructor
// ============================================================================
constructor TTool.Create(  pFile          : AnsiString;
                              pErrorHandler  : IToolErrorHandler);
begin
   inherited Create;

   fGrammar       := nil;
   fGrammarFile   := pFile;
   fErrorHandler  := pErrorHandler;

   fWarningCount  := 0;
   fErrorCount    := 0;
end;

// ============================================================================
// Constructor
// ============================================================================
constructor TTool.Create(  pModuleStream     : TStream;
                              pModuleName       : AnsiString;
                              pOutputDir        : AnsiString;
                              pExchangeDir      : AnsiString;
                              pErrorHandler     : IToolErrorHandler);
begin
   fGrammar       := nil;
   fWarningCount  := 0;
   fErrorCount    := 0;

   fModuleStream  := pModuleStream;
   fModuleName    := pModuleName;
   fOutputDir     := pOutputDir;
   fExchangeDir   := pExchangeDir;
   fErrorHandler  := pErrorHandler;   
end;

// ============================================================================
// Destructor
// ============================================================================
destructor TTool.Destroy;
begin
   fGrammar       := nil;
   fErrorHandler  := nil;

   inherited;
end;

// ****************************************************************************
//
//                                                      ITool implementation
//
// ****************************************************************************
// ============================================================================
// Go
// ============================================================================
procedure TTool.Go;
var
   parser   : TDpgParser;
   lexer    : TDpgLexer;

   gmaker   : IGrammarBehavior;
   analyzer : ILLkAnalyzer;
   gen      : ICodeGenerator;

begin
   fWarningCount  := 0;
   fErrorCount    := 0;

   if (fModuleStream <> nil) and (fModuleName <> '') then
   begin
      try
         analyzer := TLLkAnalyzer      .Create( self);
         gmaker   := TGrammarMaker     .Create( self, analyzer, fExchangeDir);
         gen      := TDelphiGenerator  .Create( fOutputDir, fExchangeDir);

         lexer    := TDpgLexer         .Create( fModuleStream);
         parser   := TDpgParser        .Create( lexer, gmaker, self, fExchangeDir);

         lexer.InputState.FileName  := fModuleName;
         parser.InputState.FileName := fModuleName;

      except
         if fErrorHandler <> nil then
            fErrorHandler.Error('Internal error');
         exit;
      end;

      try
         parser.grammar;

      except
         on mc: EMismatchedChar  do begin exMismatchedChar( mc); exit; end;
         on mt: EMismatchedToken do begin exMismatchedToken(mt); exit; end;
         else
         begin
            if fErrorHandler <> nil then
               fErrorHandler.Error('Error: Unexpected exception...');
            exit;
         end;
      end;

      if fErrorCount = 0 then
      begin
         fGrammar := gmaker.Grammar;

         try
            gen.Gen( gmaker.Grammar);

         except
            if fErrorHandler <> nil then
               fErrorHandler.Error('Unexpected exception in generator');
         end;
      end
   end;
end;

// ============================================================================
// Get_ErrorHandler
// ============================================================================
function TTool.Get_ErrorHandler: IToolErrorHandler;
begin
   result := nil;
end;

// ============================================================================
// Error
// ============================================================================
procedure TTool.Error(     pMessage : AnsiString;
                              pFileName: AnsiString;
                              pLine    : integer;
                              pColumn  : integer);
var
   msg: AnsiString;

begin
   INC(fErrorCount);

   if pColumn > 0
      then msg := pFileName +'(' +IntToStr(pLine) +',' +IntToStr(pColumn) +'): ' + pMessage
      else msg := pFileName +'(' +IntToStr(pLine) +'): ' + pMessage;

   if fErrorHandler <> nil then
      fErrorHandler.Error( msg, pFileName, pLine, pColumn);
end;

// ============================================================================
// Warning
// ============================================================================
procedure TTool.Warning(   pMessage : AnsiString;
                              pFileName: AnsiString;
                              pLine    : integer;
                              pColumn  : integer);
var
   msg: AnsiString;

begin
   INC(fWarningCount);

   msg := pFileName + '(' + IntToStr( pLine) + '): ' + pMessage;
   if fErrorHandler <> nil then
      fErrorHandler.Warning( msg, pFileName, pLine, pColumn);
end;

// ============================================================================
// Panic
// ============================================================================
procedure TTool.Panic( pMessage : AnsiString);
var
   msg: AnsiString;

begin
   msg := pMessage;
   if fErrorHandler <> nil then
      fErrorHandler.Panic( msg);

//   Raise EPanic.Create(msg);
end;

// ============================================================================
// dumpSets
// ============================================================================
procedure TTool.dumpSets(  pGrammar : IGrammar;
                              pLexical : boolean;
                              pSets    : TInterfaceList;
                              pDepth   : integer);
var
   i     : integer;
   msg   : AnsiString;
   la    : ILookahead;

begin
   for i:=0 to pDepth-1 do
   begin
      la  := pSets[i] as ILookahead;
      msg := Format('         k=%d ', [i+1]);

      if la.LaSet = [] then
         msg := msg + '<EPS>'

      else
         if pLexical
            then msg := msg + CharSetToStr( la.LaSet)
            else msg := msg + TokenSetToStr( la.LaSet, fGrammar.TokenManager);

      fErrorHandler.Warning( msg);
   end;
end;

// ============================================================================
// WarnAltAmbiguity
// ============================================================================
procedure TTool.WarnAltAmbiguity(      pGrammar    : IGrammar;
                                          pBlock      : IAlternativeBlock;
                                          pLexical    : boolean;
                                          pDepth      : integer;
                                          pSets       : TInterfaceList;
                                          pAltIdx1    : integer;
                                          pAltIdx2    : integer);
var
   rb:   IRuleBlock;
   msg:  AnsiString;
   ai    : IAlternative;
   aj    : IAlternative;
   rri   : IRuleRefElem;
   rrj   : IRuleRefElem;
   ri    : AnsiString;
   rj    : AnsiString;

begin
   if fErrorHandler = nil then
      exit;

   pBlock.QueryInterface(IRuleBlock, rb);


   // ---------------------------------------------------------------
   // prepare locals
   // ---------------------------------------------------------------
   ai    := pBlock.Alternative[pAltIdx1];
   aj    := pBlock.Alternative[pAltIdx2];

   ai.Head.QueryInterface(IRuleRefElem, rri);
   aj.Head.QueryInterface(IRuleRefElem, rrj);

   // ---------------------------------------------------------------
   // Handle ambiguity of rules.
   // ---------------------------------------------------------------
   if (rb <> nil)    and
      (rri <> nil)   and
      (rrj <> nil)   and
      (pLexical)     and
      pBlock.AutoGen then
   begin
      ri    := TCodeGenerator.decodeLexerRuleName( rri.TargetRule);
      rj    := TCodeGenerator.decodeLexerRuleName( rrj.TargetRule);
      msg   := fGrammarFile +'(1): ';

      fErrorHandler.Warning('');
      msg   := msg + 'Lexical nondeterminism between rules "'   +
               ri + '" and "' + rj + '"';// upon:';

      fErrorHandler.Warning( msg);
   end

   // ---------------------------------------------------------------
   // Handle ambiguity of alternatives.
   // ---------------------------------------------------------------
   else
   begin

      fErrorHandler.Warning('');
      msg   := pGrammar.GrammarFile (*fGrammarFile*) + '(' +
               IntToStr( pBlock.Line) + '): ';

      if pLexical then
         msg := msg + 'lexical ';

      msg   := msg + 'nondeterminism between alts '   +
               IntToStr( pAltIdx1+1) + ' and ' + IntToStr( pAltIdx2+1) +
               ' of block in rule "'  + pBlock.EnclosingRule + '"';// upon:';

      fErrorHandler.Warning( msg);
   end;

   dumpSets( pGrammar, pLexical, pSets, pDepth);
end;

// ============================================================================
// WarnAltExitAmbiguity
// ============================================================================
procedure TTool.WarnAltExitAmbiguity(  pGrammar    : IGrammar;
                                          pBlock      : IBlockWithImpliedExitPath;
                                          pLexical    : boolean;
                                          pDepth      : integer;
                                          pSets       : TInterfaceList;
                                          pAltIdx     : integer);
var
   fileline : AnsiString;
   msg      : AnsiString;

begin
   if fErrorHandler <> nil then
   begin
      fileline := fGrammarFile + '(' + IntToStr( pBlock.Line) + '):';

      msg := fileline;

      if pLexical then
         msg := msg + 'lexical';

      msg := msg +' nondeterminism between alt ' + IntToStr( pAltIdx) +
                  ' and exit branch of block in rule ' + pBlock.EnclosingRule + '.';

      fErrorHandler.Warning('');
      fErrorHandler.Warning(msg);
      dumpSets( pGrammar, pLexical, pSets, pDepth);
   end;
end;

// ============================================================================
// Debug
// ============================================================================
procedure TTool.Debug(pMessage: AnsiString);
begin
   if fErrorHandler <> nil then
      fErrorHandler.Error(pMessage);
end;

// ============================================================================
// exMismatchedChar
//
// Handle lexer mismatched char exception.
// ============================================================================
procedure TTool.exMismatchedChar(mc: EMismatchedChar);
var
   msg      : AnsiString;
   filename : AnsiString;
begin
   fileName := ExtractFileName(mc.FileName);

   // ---------------------------------------------------------------
   // Handle AnsiString
   // ---------------------------------------------------------------
   if mc.FoundString <> '' then
      msg := 'Unexpected AnsiString token: ' + mc.FoundString

   // ---------------------------------------------------------------
   // Handle char
   // ---------------------------------------------------------------
   else
   begin
      if not mc.Inverted then
         msg :=   'Expecting [' + CharSetToStr( mc.CharSet) + '] but found ' +
                  CharSetToStr([mc.FoundChar])
      else
         msg :=   'Not expecting [' + CharSetToStr( mc.CharSet) + '] and found ' +
                  CharSetToStr([mc.FoundChar])
   end;

   Error( msg, fileName, mc.Line, mc.Column);
(*
   // ---------------------------------------------------------------
   // Unexpected AnsiString, AnsiString
   // ---------------------------------------------------------------
   if mc.ExpCode = EC_CHAR then
      msg := 'Unexpected token: ' + CharSetToStr([mc.FoundChar])

   // ---------------------------------------------------------------
   // Unexpected char, charset
   // ---------------------------------------------------------------
   else if mc.ExpCode = EC_CHARSET then
      if not mc.Invert then
         msg :=   'Expecting [' + CharSetToStr( mc.CharSet) + '] but found ' +
                  CharSetToStr([mc.FoundChar])
      else
         msg :=   'Not expecting [' + CharSetToStr( mc.CharSet) + '] and found ' +
                  CharSetToStr([mc.FoundChar])

   // ---------------------------------------------------------------
   // Unexpected char, char range
   // ---------------------------------------------------------------
   else if mc.ExpCode = EC_CHARRANGE then
      if not mc.Invert then
         msg :=   'Expecting [' + CharSetToStr( mc.CharSet) + '] but found ' +
                  CharSetToStr([mc.FoundChar])
      else
         msg :=   'Not expecting [' + CharSetToStr( mc.CharSet) + '] and found ' +
                  CharSetToStr([mc.FoundChar])

   // ---------------------------------------------------------------
   // Unexpected AnsiString
   // ---------------------------------------------------------------
   else if mc.ExpCode = EC_STRING then
      msg := 'Unexpected AnsiString token: ' + mc.FoundStr

   // ---------------------------------------------------------------
   // Something wrong...
   // ---------------------------------------------------------------
   else
      msg := 'Internal error: Unknown lexer exception.';

   Error( msg, fileName, mc.Line, mc.Column);
*)
end;

// ============================================================================
// exMismatchedToken
//
// Handle parser mismatched token exception.
//
// Note: the member fGrammar now valid at this point, so we can use the
//       grammar's token manager.
// ============================================================================
procedure TTool.exMismatchedToken(mt: EMismatchedToken);
var
   fileName : string;
   msg      : string;

begin
   fileName := ExtractFileName( mt.FileName);
   msg      := 'Unexpected token: ' +  mt.FoundToken.TokenText;

   Error( msg, fileName, mt.Line, mt.Column);
end;


function TTool.GetErrorCount: integer;
begin
   result := fErrorCount;
end;

function TTool.GetWarningCount: integer;
begin
   result := fWarningCount;
end;

end.