--
--  Copyright (C) 2023, AdaCore
--
--  SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
--
with System;

with Ada.Characters.Conversions;
with Ada.Exceptions;
with Ada.Containers.Vectors;
with Ada.Strings.Unbounded;

with Gpr_Parser_Support.File_Readers; use Gpr_Parser_Support.File_Readers;
with Gpr_Parser_Support.Diagnostics;  use Gpr_Parser_Support.Diagnostics;
with Gpr_Parser.Lexer_State_Machine;  use Gpr_Parser.Lexer_State_Machine;
with Gpr_Parser.Common;               use Gpr_Parser.Common;
with Gpr_Parser_Support.Text;         use Gpr_Parser_Support.Text;
with Gpr_Parser_Support.Slocs;        use Gpr_Parser_Support.Slocs;
with Gpr_Parser_Support.Token_Data_Handlers;
use Gpr_Parser_Support.Token_Data_Handlers;
with Gpr_Parser.Public_Converters; use Gpr_Parser.Public_Converters;
with Gpr_Parser.Implementation;    use Gpr_Parser.Implementation;
with Gpr_Parser.Analysis;

package body Gpr_Parser.Basic_Ada_Parser is

   package GPS renames Gpr_Parser_Support;

   package Lexed_Token_Vectors is new
     Ada.Containers.Vectors
       (Index_Type   => Natural,
        Element_Type => Lexed_Token);

   subtype Lexed_Token_Vector is Lexed_Token_Vectors.Vector;

   function Encode (Text  : Gpr_Parser.Text.Text_Type;
                    State : GNATCOLL.Iconv.Iconv_T) return String;

   function Encode_String_Without_Whitespaces
     (Contents            : Decoded_File_Contents;
      First_Idx, Last_Idx : Natural;
      Whitespaces         : Lexed_Token_Vector;
      States              : Iconv_States) return String;
   --  Encode the substring from the first to the last specified index,
   --  excluding any whitespace characters. The indexes of these whitespace
   --  characters are contained in `Whitespaces`.

   -----------
   -- Close --
   -----------

   procedure Close (States : in out Iconv_States) is
   begin
      GNATCOLL.Iconv.Iconv_Close (States.From_State);
      GNATCOLL.Iconv.Iconv_Close (States.To_State);
   end Close;

   ------------
   -- Create --
   ------------

   function Create
     (From_Charset : String;
      To_Charset   : String) return Iconv_States is
   begin
      return Result : Iconv_States do
         Result := (From_State  =>
                      GNATCOLL.Iconv.Iconv_Open
                        (To_Code   => Gpr_Parser_Support.Text.Text_Charset,
                         From_Code => From_Charset),
                    To_State    =>
                      GNATCOLL.Iconv.Iconv_Open
                        (To_Code   => To_Charset,
                         From_Code => Gpr_Parser_Support.Text.Text_Charset));
      end return;
   end Create;

   ------------
   -- Encode --
   ------------

   function Encode (Text  : Gpr_Parser.Text.Text_Type;
                    State : GNATCOLL.Iconv.Iconv_T) return String
   is
      S : String (1 .. 4 * Text'Length) with Import, Address => Text'Address;
   begin
      GNATCOLL.Iconv.Reset (State);
      return GNATCOLL.Iconv.Iconv
        (State     => State,
         Input     => S);
   end Encode;

   ---------------------------------------
   -- Encode_String_Without_Whitespaces --
   ---------------------------------------

   function Encode_String_Without_Whitespaces
     (Contents            : Decoded_File_Contents;
      First_Idx, Last_Idx : Natural;
      Whitespaces         : Lexed_Token_Vector;
      States              : Iconv_States) return String
   is
      use Ada.Strings.Unbounded;

      Current_Idx : Natural := First_Idx;
      Result : Unbounded_String;
   begin
      if Whitespaces.Is_Empty then
         return Encode
                  (Contents.Buffer (First_Idx .. Last_Idx),
                   States.To_State);
      end if;

      --  Remove all whitespace characters

      for Wspace of Whitespaces loop
         if Current_Idx < Wspace.Text_First then
            Append
              (Result,
               Encode
                 (Contents.Buffer (Current_Idx .. Wspace.Text_First - 1),
                  States.To_State));
         end if;

         Current_Idx := Wspace.Text_Last + 1;
      end loop;

      --  Encode the remaining text

      if Current_Idx <= Last_Idx then
         Append
           (Result,
            Encode
              (Contents.Buffer (Current_Idx .. Last_Idx),
               States.To_State));
      end if;

      return To_String (Result);
   end Encode_String_Without_Whitespaces;

   --------------------------
   -- Parse_Context_Clause --
   --------------------------

   procedure Parse_Context_Clauses
     (Filename       : String;
      Context        : Gpr_Parser.Analysis.Analysis_Context'Class;
      States         : Iconv_States;
      Log_Error      : access procedure (Message : String);
      With_Clause_CB : access procedure (Unit_Name  : String;
                                         Is_Limited : Boolean) := null;
      Unit_Name_CB   : access procedure (Unit_Name     : String;
                                         Separate_From : String;
                                         Generic_Unit  : Boolean) := null;
      No_Body_CB               : access procedure := null)
   is
      Contents     : Decoded_File_Contents;
      State        : Lexer_State;
      Internal_Ctx : Internal_Context := Unwrap_Context (Context);
      Has_Error    : Boolean := False;

      subtype Specific_Identifier is Text_Type;

      Procedure_Token : aliased Specific_Identifier := "procedure";
      Function_Token  : aliased Specific_Identifier := "function";
      Generic_Token   : aliased Specific_Identifier := "generic";
      Separate_Token  : aliased Specific_Identifier := "separate";
      No_Body_Token   : aliased Specific_Identifier := "no_body";
      Body_Token      : aliased Specific_Identifier := "body";
      Access_Token    : aliased Specific_Identifier := "access";
      Protected_Token : aliased Specific_Identifier := "protected";
      Task_Token      : aliased Specific_Identifier := "task";

      type Specific_Identifier_Access is access all Specific_Identifier;

      type Specific_Identifier_Access_Array is
        array (Positive range <>) of Specific_Identifier_Access;

      type Token_Kind_Array is array (Positive range <>) of Token_Kind;

      procedure Log_Error_Internal (Message : String);

      function Skip_Until
        (Kinds       :     Token_Kind_Array;
         T           : out Lexed_Token;
         Identifiers :     Specific_Identifier_Access_Array := (2 .. 1 => <>);
         Expected    :     Boolean                          := True)
         return Boolean;
      --  Skip tokens until one of the specified token is encountered. Because
      --  identifiers token regroup several specific tokens, like separate,
      --  generic, etc, we may want to skip until specific identifiers. Last
      --  token read is stored in T. Identifiers is the list of specific
      --  identifier. It only has effect if one of the specified tokens kind in
      --  Kinds is Gpr_Identifier. If Expected is True, then if the last token
      --  read is an identifier, then it must match with one of the specified
      --  identifiers. Otherwise, the last identifier token read must NOT match
      --  with all the specified identifiers. If all tokens have been read
      --  without finding one of the expected tokens, then False is returned.

      function Parse_Library_Item_And_Subunit_Pre_Cond
         return Boolean;
      --  Pre condition function for Parse_Library_Item_And_Subunit. Ensure
      --  that the current token is valid as a first library item or subunit
      --  token.

      procedure Parse_Library_Item_And_Subunit with
        Pre => Parse_Library_Item_And_Subunit_Pre_Cond;
      --  Parse the library item unit name, or the subunit and the parent unit
      --  name. Call Unit_Name_CB if it is not null.

      function Parse_Static_Name
        (T           : in out Lexed_Token;
         Whitespaces : out Lexed_Token_Vector) return Natural with
        Pre => Last_Token (State).Kind = Gpr_Identifier;
      --  Return the last token text of the static name which begins at the
      --  current identifier token. Whitespaces contains the indexes of all
      --  the whitespace characters tokens encountered.

      procedure Parse_With_Clause with
        Pre =>
         Last_Token (State).Kind = Gpr_With
         or else Last_Token (State).Kind = Gpr_Limited;
      --  Parse "with" clause, and calls With_Clause_CB if the callback is
      --  not null.

      ------------------------
      -- Log_Error_Internal --
      ------------------------

      procedure Log_Error_Internal (Message : String) is
      begin
         Has_Error := True;

         if Log_Error /= null then
            Log_Error (Message);
         end if;
      end Log_Error_Internal;

      ------------------------------------
      -- Parse_Library_Item_And_Subunit --
      ------------------------------------

      procedure Parse_Library_Item_And_Subunit is

         T                    : Lexed_Token := Last_Token (State);
         Separate_From_First  : Natural     := 0;
         Separate_From_Last   : Natural     := 0;
         Separate_Whitespaces : Lexed_Token_Vector;
         Generic_Unit         : Boolean     := False;

         procedure Skip_Generic with
           Pre =>
            T.Kind = Gpr_Identifier
            and then To_Lower (Contents.Buffer (T.Text_First .. T.Text_Last)) =
              Generic_Token;
         --  Skip tokens related to the generic part of a unit

         procedure Parse_Separate with
           Pre =>
            T.Kind = Gpr_Identifier
            and then To_Lower (Contents.Buffer (T.Text_First .. T.Text_Last)) =
              Separate_Token;
         --  Set Separate_From_First and Separate_From_Last with indexes of the
         --  separate argument.

         function Parse_Unit_Pre_Cond
            return Boolean;
         --  Pre-condition function for Parse_Unit. Ensure that the current
         --  token is either "package", "function" or "procedure".

         procedure Parse_Unit with
           Pre => Parse_Unit_Pre_Cond;
         --  Parse the mandatory part of the library item which contains the
         --  compilation unit name. Calls the library item callback if it is
         --  not null.

         procedure Parse_Separate is
         begin
            if not Skip_Until ((1 => Gpr_Par_Open), T) then
               Log_Error_Internal
                 ("no opening parenthesis after the 'separate' keyword");
               return;
            end if;

            if not Skip_Until ((1 => Gpr_Identifier), T) then
               Log_Error_Internal
                 ("no identifier after the 'separate' keyword");
               return;
            end if;

            Separate_From_First := T.Text_First;
            Separate_From_Last  := Parse_Static_Name (T, Separate_Whitespaces);

            if not Skip_Until
              ((Gpr_Identifier, Gpr_Package), T,
               (Function_Token'Access, Procedure_Token'Access,
                Task_Token'Access, Protected_Token'Access))
            then
               Log_Error_Internal
                 ("missing the subunit kind (package / function / procedure)");
               return;
            end if;
         end Parse_Separate;

         ----------------
         -- Parse_Unit --
         ----------------

         procedure Parse_Unit is
            Whitespaces : Lexed_Token_Vector;
         begin
            --  At this step, current token is either "function", "procedure",
            --  "package", "protected" or "task". Skip token until the next
            --  identifier is different from body, as it contains the unit
            --  name.

            if not Skip_Until
              ((1 => Gpr_Identifier), T, (1 => Body_Token'Access),
               Expected => False)
            then
               Log_Error_Internal
                 ("missing the unit or subunit identifier");

               return;
            end if;

            declare
               Unit_First : Positive := T.Text_First;
               Unit_Last  : Positive := Parse_Static_Name (T, Whitespaces);

            begin
               declare
                  U_Name : String :=
                             Encode_String_Without_Whitespaces
                               (Contents    => Contents,
                                First_Idx   => Unit_First,
                                Last_Idx    => Unit_Last,
                                Whitespaces => Whitespaces,
                                States      => States);
                  Sep_Name : constant String :=
                               (if Separate_From_First /= 0
                                then Encode_String_Without_Whitespaces
                                   (Contents    => Contents,
                                    First_Idx   => Separate_From_First,
                                    Last_Idx    => Separate_From_Last,
                                    Whitespaces => Separate_Whitespaces,
                                    States      => States)
                                else "");
               begin
                  Unit_Name_CB
                    (Unit_Name     => U_Name,
                     Separate_From => Sep_Name,
                     Generic_Unit  => Generic_Unit);
               end;
            end;
         end Parse_Unit;

         -------------------------
         -- Parse_Unit_Pre_Cond --
         -------------------------

         function Parse_Unit_Pre_Cond return Boolean is
            T           : Lexed_Token := Last_Token (State);
            Valid_Token : Boolean     := False;

         begin
            if T.Kind = Gpr_Package then
               Valid_Token := True;

            elsif T.Kind = Gpr_Identifier then
               declare
                  Token_Text : Text_Type :=
                                 To_Lower
                                   (Contents.Buffer
                                      (T.Text_First .. T.Text_Last));

               begin
                  if Token_Text = Procedure_Token
                    or else Token_Text = Function_Token
                  then
                     Valid_Token := True;
                  end if;
               end;
            end if;

            return Valid_Token;
         end Parse_Unit_Pre_Cond;

         ------------------
         -- Skip_Generic --
         ------------------

         procedure Skip_Generic is
         begin
            --  With and access content should be skipped, but as it may
            --  contain the "function", "procedure" or "package" keyword,
            --  we can not skip these keywords.

            loop
               if not Skip_Until
                 ((Gpr_Identifier, Gpr_With, Gpr_Package), T,
                  (Function_Token'Access, Procedure_Token'Access,
                   Access_Token'Access))
               then
                  Log_Error_Internal
                    ("failed to skip the generic formal parameters part");

                  exit;
               end if;

               if T.Kind = Gpr_Package then
                  --  "Package" not preceded by a with token is the start of
                  --  the mandatory library item part.

                  exit;

               elsif T.Kind = Gpr_Identifier then
                  declare
                     T_Content : Text_Type :=
                       To_Lower
                         (Contents.Buffer (T.Text_First .. T.Text_Last));

                  begin
                     exit when T_Content = Function_Token
                       or else T_Content = Procedure_Token;
                     --  If we reach this part of the code, then the current
                     --  token shall be an access token.

                     if not Skip_Until ((1 => Gpr_Semicolon), T) then
                        Log_Error_Internal
                          ("in formal generic parameters, missing ':' after " &
                             "variable declaration");

                        exit;
                     end if;
                  end;

               elsif T.Kind = Gpr_With then
                  if not Skip_Until ((1 => Gpr_Semicolon), T) then
                     Log_Error_Internal
                       ("missing ';' after a formal generic parameter " &
                          "declaration");
                     exit;
                  end if;
               end if;
            end loop;
         end Skip_Generic;

      begin
         --  Optional generic part

         if T.Kind = Gpr_Identifier
           and then To_Lower (Contents.Buffer (T.Text_First .. T.Text_Last)) =
             Generic_Token
         then
            Skip_Generic;
            Generic_Unit := True;
            --  Optional separate part

         elsif T.Kind = Gpr_Identifier
           and then To_Lower (Contents.Buffer (T.Text_First .. T.Text_Last)) =
             Separate_Token
         then
            Parse_Separate;
         end if;

         --  Mandatory library item part begins with: - function / procedure -
         --  package body - [private] package In subunit case, so if separate
         --  is present, the tokens we can expect are: - procedure / function
         --  - package body - task body - protected body.

         Parse_Unit;
      end Parse_Library_Item_And_Subunit;

      ---------------------------------------------
      -- Parse_Library_Item_And_Subunit_Pre_Cond --
      ---------------------------------------------

      function Parse_Library_Item_And_Subunit_Pre_Cond
         return Boolean
      is
         T           : Lexed_Token := Last_Token (State);
         Valid_Token : Boolean     := False;

      begin
         if T.Kind = Gpr_Package then
            Valid_Token := True;

         elsif T.Kind = Gpr_Identifier then
            declare
               Token_Text : Text_Type :=
                            To_Lower (Contents.Buffer
                              (T.Text_First .. T.Text_Last));

            begin
               if Token_Text = Procedure_Token
                 or else Token_Text = Function_Token
                 or else Token_Text = Separate_Token
                 or else Token_Text = Generic_Token
               then
                  Valid_Token := True;
               end if;
            end;
         end if;

         return Valid_Token;
      end Parse_Library_Item_And_Subunit_Pre_Cond;

      -----------------------
      -- Parse_Static_Name --
      -----------------------

      function Parse_Static_Name
        (T           : in out Lexed_Token;
         Whitespaces : out Lexed_Token_Vector) return Natural is
         Static_Name_Expected_Token : Token_Kind := Gpr_Dot;
         Last                       : Natural    := T.Text_Last;
      begin
         Whitespaces.Clear;

         while Has_Next (State) loop
            Next_Token (State, T);

            if T.Kind = Gpr_Whitespace then
               Whitespaces.Append (T);
            else
               if T.Kind /= Static_Name_Expected_Token then
                  return Last;
               else
                  Last := T.Text_Last;

                  if Static_Name_Expected_Token = Gpr_Dot then
                     Static_Name_Expected_Token := Gpr_Identifier;
                  else
                     Static_Name_Expected_Token := Gpr_Dot;
                  end if;
               end if;
            end if;
         end loop;

         return Last;
      end Parse_Static_Name;

      -----------------------
      -- Parse_With_Clause --
      -----------------------

      procedure Parse_With_Clause
      is
         T                 : Lexed_Token := Last_Token (State);
         Withed_Unit_First : Positive;
         Withed_Unit_Last  : Positive;
         Lim               : Boolean     := False;
         Whitespaces       : Lexed_Token_Vector;

      begin
         if T.Kind = Gpr_Limited then
            Lim := True;

            if not Skip_Until ((1 => Gpr_With), T) then
               Log_Error_Internal
                 ("expecting a with token after 'limited'");

               return;
            end if;
         end if;

         --  "With" token location is returned as source location, even for
         --  several units in the same with clause.

         loop
            if not Skip_Until ((1 => Gpr_Identifier), T) then
               Log_Error_Internal
                 ("with clause is missing a unit identifier");

               return;
            end if;
            --  Current token shall be an identifier

            Withed_Unit_First := T.Text_First;
            Withed_Unit_Last  := Parse_Static_Name (T, Whitespaces);

            if With_Clause_CB /= null then
               With_Clause_CB
                  (Encode_String_Without_Whitespaces
                     (Contents    => Contents,
                      First_Idx   => Withed_Unit_First,
                      Last_Idx    => Withed_Unit_Last,
                      Whitespaces => Whitespaces,
                      States      => States),
                  Lim);
            end if;

            if T.Kind /= Gpr_Semicolon and then T.Kind /= Gpr_Comma then
               if not Skip_Until ((Gpr_Semicolon, Gpr_Comma), T) then
                  Log_Error_Internal
                    ("missing ';' or ',' in a with clause");

                  return;
               end if;
            end if;

            if T.Kind = Gpr_Semicolon then

               --  No more unit within this "with" clause

               exit;
            end if;
         end loop;
      end Parse_With_Clause;

      ----------------
      -- Skip_Until --
      ----------------

      function Skip_Until
        (Kinds       :     Token_Kind_Array;
         T           : out Lexed_Token;
         Identifiers :     Specific_Identifier_Access_Array := (2 .. 1 => <>);
         Expected    :     Boolean                          := True)
         return Boolean is
      begin
         while Has_Next (State) loop
            Next_Token (State, T);

            for I in Kinds'Range loop
               if Kinds (I) = T.Kind then
                  --  In case of identifiers, two scenarios: - If a list of
                  --  identifiers has been specified,
                  --    then current identifier is checked.
                  --  - If the list of expected identifiers is empty,
                  --    then only check for the identifier token kind.

                  if T.Kind = Gpr_Identifier and then Identifiers'Length > 0
                  then
                     declare
                        Text : Text_Type :=
                          To_Lower
                            (Contents.Buffer (T.Text_First .. T.Text_Last));

                     begin
                        --  First case: we expect to find a specific identifier

                        if Expected then
                           for J in Identifiers'Range loop
                              if Text = Identifiers (J).all then
                                 return True;
                              end if;
                           end loop;

                        else
                           --  Second case: We expect to find all identifier
                           --  except the identifiers specified.

                           declare
                              Found : Boolean := False;

                           begin
                              --  Check all the unwanted identifiers

                              for J in Identifiers'Range loop
                                 if Text = Identifiers (J).all then
                                    Found := True;
                                 end if;
                              end loop;
                              --  Current token does not match with one of the
                              --  unwanted identifiers.

                              if not Found then
                                 return True;
                              end if;
                           end;
                        end if;
                     end;

                  else
                     --  Current token is one of the expected tokens

                     return True;
                  end if;
               end if;
            end loop;
         end loop;

         --  Token was not found and Lexer is empty

         return False;
      end Skip_Until;

   begin
      --  Fill the Contents buffer with specified file content. If a file
      --  reader is provided, it is used instead to read source file.

      declare
         use Ada.Characters.Conversions;

         Diagnostics : GPS.Diagnostics.Diagnostics_Vectors.Vector;
      begin

         if Internal_Ctx.File_Reader /= null then
            Read
              (Internal_Ctx.File_Reader.all, Filename, "iso-8859-15", True,
               Contents, Diagnostics);
         else
            Direct_Read (Filename, States.From_State, True, Contents, Diagnostics);
         end if;

         if not Diagnostics.Is_Empty then
            for D of Diagnostics loop
               Log_Error_Internal (To_String (To_Text (D.Message)));
            end loop;

            return;
         end if;
      exception
         when E : others =>
            Log_Error_Internal
              ("exception while parsing " & String (Filename) & ASCII.LF &
                 Ada.Exceptions.Exception_Information (E));
      end;

      --  Initialize the lexer

      Initialize (State, Contents.Buffer, Contents.First, Contents.Last);

      while Has_Next (State) and then not Has_Error loop

         --  Parse 0, 1 or more withed clauses, and one library item or
         --  subunit. The parser may detect compilation units for invalid
         --  files, as tokens are skipped until a wanted token is found.

         declare
            T : Lexed_Token;

         begin
            if not Skip_Until
                ((Gpr_With, Gpr_Identifier, Gpr_Package, Gpr_Limited,
                  Gpr_Pragma),
                 T,
                 (Procedure_Token'Access, Function_Token'Access,
                  Separate_Token'Access, Generic_Token'Access))
            then
               Log_Error_Internal ("Unexpected preamble");

               exit;
            end if;

            if T.Kind = Gpr_With or else T.Kind = Gpr_Limited then
               if With_Clause_CB /= null then
                  Parse_With_Clause;

               elsif not Skip_Until ((1 => Gpr_Semicolon), T) then
                  Log_Error_Internal
                    ("missing ';' or ',' in a with clause");

                  exit;
               end if;

            elsif T.Kind = Gpr_Identifier or else T.Kind = Gpr_Package then
               Parse_Library_Item_And_Subunit;

               --  We do not need to parse after the library item and subunit
               --  parsing, because "with" clauses precede them. Moreover, as
               --  we do not support multi-unit here, only one compilation unit
               --  can exist per file.

               exit;

            elsif T.Kind = Gpr_Pragma then

               --  Two cases:
               --  - pragma No_Body: The source can only contain this pragma
               --    and possibly comments. The parsing is ended.
               --  - pragma XXX: No effect on parsing. Note that the parsing is
               --  correct only if the file is valid. If the file has a "with
               --  XXX; pragma No_Body", then the file will be categorized has
               --  No_Body, despite it is an invalid file.

               if not Skip_Until ((1 => Gpr_Identifier), T) then
                  Log_Error_Internal
                    ("pragma should be followed by an identifier");

                  exit;

               else
                  declare
                     Text : Text_Type :=
                              To_Lower
                                (Contents.Buffer
                                   (T.Text_First .. T.Text_Last));

                  begin
                     if Text = No_Body_Token then
                        if No_Body_CB /= null then
                           No_Body_CB.all;
                        end if;

                        exit;
                     end if;
                  end;
               end if;
            end if;
         end;
      end loop;

      Gpr_Parser_Support.Text.Free (Contents.Buffer);
   end Parse_Context_Clauses;

end Gpr_Parser.Basic_Ada_Parser;
