------------------------------------------------------------------------------
--                                                                          --
--                            GNATPP COMPONENTS                             --
--                                                                          --
--                  G N A T P P . D I C T I O N A R I E S                   --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                    Copyright (C) 2001-2016, AdaCore                      --
--                                                                          --
-- GNATPP is free software; you can redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
-- sion.  GNATPP is  distributed in the  hope that it will  be  useful, but --
-- WITHOUT ANY WARRANTY; without even the implied warranty of  MERCHANTABI- --
-- LITY or  FITNESS  FOR A  PARTICULAR  PURPOSE. See the GNU General Public --
-- License  for more details. You  should  have  received a copy of the GNU --
-- General Public License  distributed with GNAT; see file COPYING. If not, --
-- write to the Free Software Foundation,  51 Franklin Street, Fifth Floor, --
-- Boston,                                                                  --
--                                                                          --
-- GNATPP is maintained by AdaCore (http://www.adacore.com)                 --
--                                                                          --
------------------------------------------------------------------------------

pragma Ada_2012;

with Ada.Text_IO;             use Ada.Text_IO;
with Ada.Characters.Handling; use Ada.Characters.Handling;
with Ada.Containers.Hashed_Sets; use Ada.Containers;
pragma Warnings (Off, "internal GNAT unit");
with System.String_Hash;
pragma Warnings (On, "internal GNAT unit");

package body Pp.Formatting.Dictionaries is

   subtype Name_Id is Namet.Name_Id;

   function Hash_String is new System.String_Hash.Hash
     (Character, String, Hash_Type);

   function Hash (Name : Name_Id) return Hash_Type is
     (Hash_String (To_Lower (Namet.Get_Name_String (Name))));

   function Same_Name (Left, Right : Name_Id) return Boolean is
     (To_Lower (Namet.Get_Name_String (Left)) =
      To_Lower (Namet.Get_Name_String (Right)));

   package Name_Sets is new Ada.Containers.Hashed_Sets
     (Name_Id, Hash, Same_Name, Namet."=");

   use Name_Sets;
   subtype Name_Set is Name_Sets.Set;
   Whole_Word_Exceptions, Subword_Exceptions : Name_Set;

   type Opt_Casing_Exception_Kinds is
     (Not_A_Casing_Exception,  -- Wrong syntax of the exception string
      Whole_Word,              -- Name to be replaced as a whole
      Subword);
   subtype Casing_Exception_Kinds is Opt_Casing_Exception_Kinds
     range Whole_Word .. Subword;

   --  Subword is a part of the name delimited by '_' or by the beginning or
   --  end of the word and which does not contain any '_' inside.

   -----------------------
   -- Local subprograms --
   -----------------------

   function Present (Id : Name_Id) return Boolean;
   --  Checks if the argument is not equal to No_String

   procedure Add_To_Dictionary
     (Name           : String;
      Exception_Kind : Casing_Exception_Kinds);
   --  If Name does not exist in the dictionary, adds the corresponding
   --  dictionary entry. Otherwise replace the casing defined by the
   --  existing occurrence of this name by the casing given by Name

   function Find_In_Dictionary
     (Name           : String;
      Exception_Kind : Casing_Exception_Kinds)
      return           Name_Id;
   --  Tries to find in the dictionary the entry which corresponds to Name
   --  without taking into account the character casing. (Exception_Kind
   --  is used to limit the search by the corresponding kind of dictionary
   --  entries). Return the Id of the corresponding dictionary entry, returns
   --  No_String if the dictionary does not contain such an entry.

   -----------------------
   -- Add_To_Dictionary --
   -----------------------

   procedure Add_To_Dictionary
     (Name           : String;
      Exception_Kind : Casing_Exception_Kinds)
   is
      Id : constant Name_Id := Namet.Name_Find (Name);
   begin
      case Exception_Kind is
         when Whole_Word =>
            Include (Whole_Word_Exceptions, Id);
         when Subword =>
            Include (Subword_Exceptions, Id);
      end case;
   end Add_To_Dictionary;

   ---------------------------
   -- Check_With_Dictionary --
   ---------------------------

   procedure Check_With_Dictionary
     (Ada_Name : in out Wide_String;
      Casing   : PP_Casing)
   is
      Name : String := To_String (Ada_Name);

      Name_Last : constant Natural := Name'Last;
      SW_Start  : Integer          := Name'First;
      SW_End    : Integer          := Name_Last;
      --  Indexes of a subword in the Name

      Dictionary_String : Name_Id;

      procedure Set_Subword;
      --  Provided that Name has subwords, and that the current settings of
      --  SW_Start and SW_End point to some subword, sets these indexes to
      --  point to the next subword. Set SW_Start and SW_End to 0 if there
      --  is no subwords any more

      --  This procedure does not check if we have one more subword to move
      --  these indexes to.

      function Capitalize_Subword
        (SW     : String;
         Casing : PP_Casing)
         return   String;
      --  Supposing that SW is a (sub)word having no '_' inside, returns
      --  the capitalized version of this subword according to the casing
      --  represented by Casing

      -----------------
      -- Set_Subword --
      -----------------

      procedure Set_Subword is
      begin

         if SW_End = Name_Last then
            --  There is no more subwords
            SW_Start := 0;
            SW_End   := 0;
         else
            SW_Start := SW_End + 2;
            SW_End   := Name_Last;

            for J in SW_Start + 1 .. SW_End loop
               if Name (J) = '_' then
                  SW_End := J - 1;

                  exit;
               end if;
            end loop;

         end if;

      end Set_Subword;

      ------------------------
      -- Capitalize_Subword --
      ------------------------

      function Capitalize_Subword
        (SW     : String;
         Casing : PP_Casing)
         return   String
      is
         Result    : String           := SW;
         First_Idx : constant Natural := Result'First;

      begin
         case Casing is
            when Lower_Case =>
               Result := To_Lower (Result);
            when Upper_Case =>
               Result := To_Upper (Result);
            when Mixed =>
               Result             := To_Lower (Result);
               Result (First_Idx) := To_Upper (Result (First_Idx));

            when As_Declared =>
               --  Nothing to do!
               null;
         end case;

         return Result;
      end Capitalize_Subword;

   begin  --  Check_With_Dictionary
      for J in Name'Range loop
         if Name (J) = '_' then
            SW_End := J - 1;
            exit;
         end if;
      end loop;

      Dictionary_String :=
        Find_In_Dictionary (Name => Name, Exception_Kind => Whole_Word);

      if not Present (Dictionary_String) then
         --  May be we can apply the subword exception to the whole word
         Dictionary_String :=
           Find_In_Dictionary (Name => Name, Exception_Kind => Subword);
      end if;

      if Present (Dictionary_String) then
         Name := Namet.Get_Name_String (Dictionary_String);
      else

         if SW_End < Name'Last then
            --  That is, the whole word is not in the dictionary and it has at
            --  least two subwords, and Name (SW_Start .. SW) is the first one

            while SW_End /= 0 loop
               Dictionary_String :=
                 Find_In_Dictionary
                   (Name           => Name (SW_Start .. SW_End),
                    Exception_Kind => Subword);

               if Present (Dictionary_String) then
                  Name (SW_Start .. SW_End) :=
                    Namet.Get_Name_String (Dictionary_String);
               else
                  Name (SW_Start .. SW_End) :=
                    Capitalize_Subword (Name (SW_Start .. SW_End), Casing);
               end if;

               Set_Subword;
            end loop;

         else
            --  The case of a word with no subwords, the word is not in the
            --  dictionary

            Name := Capitalize_Subword (Name, Casing);
         end if;
      end if;

      Ada_Name := To_Wide_String (Name);
   end Check_With_Dictionary;

   ------------------------
   -- Find_In_Dictionary --
   ------------------------

   function Find_In_Dictionary
     (Name           : String;
      Exception_Kind : Casing_Exception_Kinds)
      return           Name_Id
   is
      Id : constant Name_Id := Namet.Name_Find (Name);
      C : constant Name_Sets.Cursor :=
        (case Exception_Kind is
            when Whole_Word =>
                Find (Whole_Word_Exceptions, Id),
            when Subword =>
                Find (Subword_Exceptions, Id));
   begin
      return (if Has_Element (C) then Element (C) else Namet.No_Name);
   end Find_In_Dictionary;

   -------------
   -- Present --
   -------------

   function Present (Id : Name_Id) return Boolean is
      use type Name_Id;
   begin
      return Id /= Namet.No_Name;
   end Present;

   ----------------------
   -- Reset_Dictionary --
   ----------------------

   procedure Reset_Dictionary is
   begin
      Clear (Whole_Word_Exceptions);
      Clear (Subword_Exceptions);
   end Reset_Dictionary;

   ---------------------
   -- Scan_Dictionary --
   ---------------------

   procedure Scan_Dictionary (Dictionary_Name : String) is
      String_Buffer_Max_Len : constant Natural := 1024;
      --  Should be enough, I hope...

      String_Buffer : String (1 .. String_Buffer_Max_Len);

      Len : Natural range 0 .. String_Buffer_Max_Len := 0;
      --  The length of the dictionary file line which is being processed

      Line_Num : Natural := 0;
      --  The number of the currently processed line

      Dictionary_File : File_Type;

      procedure Process_Dictionary_File_Line;
      --  Reads the next line from the dictionary file, parses it, and
      --  if founds the new definition of the casing exception, puts the
      --  corresponding word in the exception table

      ----------------------------------
      -- Process_Dictionary_File_Line --
      ----------------------------------

      procedure Process_Dictionary_File_Line is
         Start_Word : Natural := 0;
         End_Word   : Natural := 0;

         Exc_Kind : Opt_Casing_Exception_Kinds;

         function Skip_White_Spaces (Idx : Natural) return Natural;
         --  Starting from Idx (which is treated as an index in String_Buffer
         --  bounded by the current value of Len), computes the index of the
         --  first non-blank character. If there is no non-blank character on
         --  the right from Idx, or if the actual is greater than Len returns
         --  zero.

         function Skip_Non_Space_Chars (Idx : Natural) return Natural;
         --  Starting from Idx (which is treated as an index in String_Buffer
         --  bounded by the current value of Len, Idx is supposed to point to
         --  non-blank character), return the index of the character preceding
         --  the first white space character (or Ada comment beginning) being
         --  on the right of Idx (returns Len if there is no such white space).

         function Get_Exception_Kind return Opt_Casing_Exception_Kinds;
         --  Checks if String_Buffer (Start_Word .. End_Word) has a syntax of
         --  a casing exception and return the corresponding exception kind.
         --  Returns Not_A_Casing_Exception if this word can not be interpreted
         --  as a casing exception. As a side effect, this function may correct
         --  the values of Start_Word and End_Word to skip '*' in case of a
         --  subword.

         function Is_White_Space (Ch : Character) return Boolean;
         --  Checks if Ch is a white space

         --------------------
         -- Is_White_Space --
         --------------------

         function Is_White_Space (Ch : Character) return Boolean is
         begin
            return False or else Ch = ' ' or else Ch = ASCII.HT;
         end Is_White_Space;

         -----------------------
         -- Skip_White_Spaces --
         -----------------------

         function Skip_White_Spaces (Idx : Natural) return Natural is
            Result : Natural := Idx;
         begin
            while Is_White_Space (String_Buffer (Result)) and then Result < Len
            loop
               Result := Result + 1;
            end loop;

            if Result > Len
              or else
              (Result = Len and then Is_White_Space (String_Buffer (Result)))
            then
               Result := 0;
            end if;

            return Result;
         end Skip_White_Spaces;

         --------------------------
         -- Skip_Non_Space_Chars --
         --------------------------

         function Skip_Non_Space_Chars (Idx : Natural) return Natural is
            Result : Natural := Idx;
         begin
            while Result < Len
              and then not
              (Is_White_Space (String_Buffer (Result))
               or else
               (String_Buffer (Result) = '-'
                and then String_Buffer (Result + 1) = '-'))
            loop
               Result := Result + 1;
            end loop;

            if Is_White_Space (String_Buffer (Result))
              or else String_Buffer (Result) = '-'
            then
               Result := Result - 1;
            end if;

            return Result;
         end Skip_Non_Space_Chars;

         ------------------------
         -- Get_Exception_Kind --
         ------------------------

         function Get_Exception_Kind return Opt_Casing_Exception_Kinds is
            Result : Opt_Casing_Exception_Kinds;

            Prev_Char_Is_Underline : Boolean := False;
         begin

            if String_Buffer (Start_Word) = '*'
              and then String_Buffer (End_Word) = '*'
            then
               Result     := Subword;
               Start_Word := Start_Word + 1;
               End_Word   := End_Word - 1;
            else
               Result := Whole_Word;
            end if;

            --  And now we have to check that String_Buffer (First_Idx ..
            --  Last_Idx) has a syntax of an identifier

            if Start_Word > End_Word
              or else String_Buffer (Start_Word) = '_'
              or else String_Buffer (End_Word) = '_'
            then
               Result := Not_A_Casing_Exception;
            else

               for J in Start_Word .. End_Word loop

                  if Is_Alphanumeric (String_Buffer (J)) then
                     Prev_Char_Is_Underline := False;
                  elsif String_Buffer (J) = '_' then

                     if not Prev_Char_Is_Underline then

                        Prev_Char_Is_Underline := True;

                        if Result = Subword then
                           Result := Not_A_Casing_Exception;
                           exit;
                        end if;

                     else
                        Result := Not_A_Casing_Exception;
                        exit;
                     end if;

                  else
                     Result := Not_A_Casing_Exception;
                     exit;
                  end if;
               end loop;
            end if;

            return Result;
         end Get_Exception_Kind;

      begin  --  Process_Dictionary_File_Line
         Get_Line (Dictionary_File, String_Buffer, Len);

         if Len = 0 then
            --  This is an empty line
            return;
         end if;

         Start_Word := Skip_White_Spaces (1);

         if Start_Word = 0
           or else
           (Start_Word < Len
            and then String_Buffer (Start_Word) = '-'
            and then String_Buffer (Start_Word + 1) = '-')
         then
            --  blank or comment line
            return;
         end if;

         End_Word := Skip_Non_Space_Chars (Start_Word);

         Exc_Kind := Get_Exception_Kind;

         if Exc_Kind = Not_A_Casing_Exception then
            Ada.Text_IO.Put_Line
              (Standard_Error,
               Dictionary_Name &
               ':' &
               Image (Line_Num) &
               ':' &
               Image (Start_Word) &
               ": wrong syntax of a casing exception, line ignored");

         else
            Add_To_Dictionary
              (String_Buffer (Start_Word .. End_Word),
               Exc_Kind);

            --  We have to check if we have something else in the dictionary
            --  file line. The only possible things are blank characters and
            --  comments

            if End_Word < Len and then String_Buffer (End_Word + 1) = '*' then
               --  Taking into account the side effect of Get_Exception_Kind
               End_Word := End_Word + 1;
            end if;

            if End_Word < Len then
               --  We have something else in this line

               Start_Word := Skip_White_Spaces (End_Word + 1);

               if not
                 (Start_Word = 0
                  or else
                  (Start_Word < Len
                   and then String_Buffer (Start_Word) = '-'
                   and then String_Buffer (Start_Word + 1) = '-'))
               then
                  Ada.Text_IO.Put_Line
                    (Standard_Error,
                     Dictionary_Name &
                     ':' &
                     Image (Line_Num) &
                     ':' &
                     Image (Start_Word) &
                     ": only one casing exception per line is allowed");
                  Ada.Text_IO.Put_Line
                    (Standard_Error,
                     Dictionary_Name &
                     ':' &
                     Image (Line_Num) &
                     ':' &
                     Image (Start_Word) &
                     ": end of line ignored");
               end if;
            end if;
         end if;
      end Process_Dictionary_File_Line;

   begin  --  Scan_Dictionary

      --  First trying to open the dictionary file: ???It would be cleaner to
      --  keep the file opening and error message handling in gnatpp.

      begin
         Open
           (File => Dictionary_File,
            Mode => In_File,
            Name => Dictionary_Name);
      exception
         when Name_Error =>
            Ada.Text_IO.Put_Line
              (Standard_Error,
               "gnatpp: can not find dictionary file " & Dictionary_Name);
            return;

         when Status_Error =>
            Ada.Text_IO.Put_Line
              (Standard_Error,
               "gnatpp: can not open dictionary file " & Dictionary_Name);
            Ada.Text_IO.Put_Line
              (Standard_Error,
               "        the file may be used by another process");
            return;
      end;

      while not End_Of_File (Dictionary_File) loop
         Line_Num := Line_Num + 1;
         Process_Dictionary_File_Line;
      end loop;

      if Is_Open (Dictionary_File) then
         Close (Dictionary_File);
      end if;

   end Scan_Dictionary;

end Pp.Formatting.Dictionaries;