-------------------------------------------------------------------------------
--
--  This file is part of AdaBrowse.
--
-- <STRONG>Copyright (c) 2002 by Thomas Wolf.</STRONG>
-- <BLOCKQUOTE>
--    AdaBrowse 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, or (at your option) any
--    later version. AdaBrowse is distributed in the hope that it will be
--    useful, but <EM>without any warranty</EM>; without even the implied
--    warranty of <EM>merchantability or fitness for a particular purpose.</EM>
--    See the GNU General Public License for  more details. You should have
--    received a copy of the GNU General Public License with this distribution,
--    see file "<A HREF="GPL.txt">GPL.txt</A>". If not, write to the Free
--    Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307,
--    USA.
-- </BLOCKQUOTE>
--
-- <DL><DT><STRONG>
-- Author:</STRONG><DD>
--   Thomas Wolf  (TW)
--   <ADDRESS><A HREF="mailto:twolf@acm.org">twolf@acm.org</A></ADDRESS></DL>
--
-- <DL><DT><STRONG>
-- Purpose:</STRONG><DD>
--   Managing indices.</DL>
--
-- <!--
-- Revision History
--
--   27-JUN-2003   TW  Initial version.
--   09-JUL-2003   TW  Special handling for empty indices and incomplete or
--                     private types.
--   22-FEB-2005   TW  Minor bug fix: set 'Is_Index' to True in call to
--                     'Put_XRef', so that links in indices get the Index_XRef
--                     stuff.
-- -->
-------------------------------------------------------------------------------

pragma License (GPL);

with Ada.Characters.Handling;
with Ada.Finalization;
with Ada.Strings.Maps;
with Ada.Strings.Unbounded;
with Ada.Strings.Wide_Unbounded;
with Ada.Unchecked_Deallocation;

with Asis;
with Asis.Declarations;
with Asis.Elements;

with Asis2.Declarations;
with Asis2.Naming;
with Asis2.Spans;

with AD.Crossrefs;
with AD.Exclusions;
with AD.Expressions;
with AD.Messages;
with AD.Options;
with AD.Predicates;
with AD.Printers;
with AD.Text_Utilities;

with GAL.ADT.Hash_Tables;
with GAL.Support.Hashing;

with Util.Pathes;
with Util.Strings;

pragma Elaborate_All (GAL.ADT.Hash_Tables);

package body AD.Indices is

   package ACH  renames Ada.Characters.Handling;
   package ASM  renames Ada.Strings.Maps;
   package ASU  renames Ada.Strings.Unbounded;
   package WASU renames Ada.Strings.Wide_Unbounded;

   Enabled : Boolean := True;

   procedure Disable
   is
   begin
      Enabled := False;
   end Disable;

   ----------------------------------------------------------------------------

   type Index_Ref is new Ada.Finalization.Controlled with
      record
         Ptr : Index_Ptr;
      end record;

   procedure Adjust   (Ref : in out Index_Ref);
   procedure Finalize (Ref : in out Index_Ref);

   procedure Adjust
     (Ref : in out Index_Ref)
   is
   begin
      if Ref.Ptr /= null then
         Ref.Ptr.Ref_Count := Ref.Ptr.Ref_Count + 1;
      end if;
   end Adjust;

   procedure Finalize
     (Ref : in out Index_Ref)
   is
      procedure Free is
         new Ada.Unchecked_Deallocation (Index'Class, Index_Ptr);
   begin
      if Ref.Ptr /= null then
         if Ref.Ptr.Ref_Count > 0 then
            Ref.Ptr.Ref_Count := Ref.Ptr.Ref_Count - 1;
         end if;
         if Ref.Ptr.Ref_Count = 0 then
            Free (Ref.Ptr);
         end if;
      end if;
   end Finalize;

   package Index_Tables is
      new GAL.ADT.Hash_Tables
            (Key_Type => String,
             Item     => Index_Ref,
             Memory   => GAL.Storage.Standard,
             Hash     => GAL.Support.Hashing.Hash_Case_Insensitive,
             "="      => Util.Strings.Equal);
   --  Initial_Size is the default (23)

   All_Indices : Index_Tables.Hash_Table;

   function Get
     (Name : in String)
     return Index_Ptr
   is
      Ref : Index_Ref;
   begin
      Ref := Index_Tables.Retrieve (All_Indices, Name);
      return Ref.Ptr;
   exception
      when Index_Tables.Container_Empty |
           Index_Tables.Not_Found =>
         declare
            P : constant Index_Ptr := new Index;
         begin
            Set_Empty (P, "Nothing");
            Ref.Ptr := P;
            Index_Tables.Insert (All_Indices, Name, Ref);
            return P;
         end;
   end Get;

   function Find
     (Name : in String)
     return Index_Ptr
   is
      Ref : Index_Ref;
   begin
      Ref := Index_Tables.Retrieve (All_Indices, Name);
      return Ref.Ptr;
   exception
      when Index_Tables.Container_Empty |
           Index_Tables.Not_Found =>
         return null;
   end Find;

   function Has_Indices
     return Boolean
   is
   begin
      return not Index_Tables.Is_Empty (All_Indices);
   end Has_Indices;

   procedure Add
     (Element    : in Asis.Element;
      XRef       : in AD.Crossrefs.Cross_Reference;
      Is_Private : in Boolean := False)
   is

      procedure Add_Item
        (Name  : in     String;
         Index : in out Index_Ref;
         Quit  : in out Boolean)
      is
         pragma Warnings (Off, Name); --  silence -gnatwa
         pragma Warnings (Off, Quit); --  silence -gnatwa
      begin
         if Index.Ptr = null then return; end if;
         Add (Index.Ptr, Element, XRef, Is_Private);
      end Add_Item;

      procedure Traverse is new Index_Tables.Traverse_G (Add_Item);

   begin
      if not Enabled then return; end if;
      Traverse (All_Indices);
   end Add;

   procedure Verify
   is
      procedure Verify_One
        (Name : in     String;
         Idx  : in out Index_Ref;
         Quit : in out Boolean)
      is
         pragma Warnings (Off, Quit); --  silence -gnatwa
      begin
         --  File name is the index name by default.
         if Idx.Ptr /= null and then
            AD.Expressions.Is_Nil (Idx.Ptr.Rule)
         then
            AD.Messages.Warn
              ("Index """ & Name & """ has no rule; IGNORED!");
            return;
         end if;
         --  Title will be determined automatically, if none is given.
      end Verify_One;

      procedure Traverse is new Index_Tables.Traverse_G (Verify_One);

   begin
      if not Enabled then return; end if;
      Traverse (All_Indices);
   end Verify;

   ----------------------------------------------------------------------------

   package Index_Lists is
      new GAL.Containers.Simple (Index_Ptr, GAL.Storage.Standard);

   Index_List : Index_Lists.Simple_Container;

   function Get_Title
     (Contained : in Contents)
     return String
   is
      Found : Boolean := False;
      J     : Item_Type;
   begin
      for I in Contained'Range loop
         if Contained (I) then
            if Found then
               Found := False; exit;
            end if;
            Found := True;
            J := I;
         end if;
      end loop;
      if Found then
         --  There was exactly one True element, and it is J:
         declare
            Result : constant String :=
              Util.Strings.To_Mixed (Item_Type'Image (J));
         begin
            --  The enumeration literals use the plural: strip off
            --  the trailing 's'.
            return Result (Result'First .. Result'Last - 1);
         end;
      end if;
      --  Special case: Procedures and functions together are subprograms
      if Contained = Contents'(Procedures | Functions => True,
                               others => False)
      then
         return "Subprogram";
      end if;
      return "";
   end Get_Title;

   procedure Write
     (Printer : access AD.Printers.Printer'Class)
   is
      procedure Write_Index
        (Name  : in     String;
         Index : in out Index_Ref;
         Quit  : in out Boolean)
      is
         pragma Warnings (Off, Quit); --  silence -gnatwa
      begin
         if Index.Ptr = null or else
            AD.Expressions.Is_Nil (Index.Ptr.Rule)
         then
            return;
         end if;
         Write (Index.Ptr, Printer, Name);
      end Write_Index;

      procedure Write is new Index_Tables.Traverse_G (Write_Index);

      function "<"
        (Left, Right : Index_Ptr)
        return Boolean
      is
      begin
         return ASU."<" (Left.Title, Right.Title);
      end "<";

      procedure Sort is new Index_Lists.Sort;

      procedure Get_Title
        (Name  : in     String;
         Index : in out Index_Ref;
         Quit  : in out Boolean)
      is
         pragma Warnings (Off, Quit); --  silence -gnatwa

         Idx : constant Index_Ptr := Index.Ptr;

      begin
         if Idx = null or else AD.Expressions.Is_Nil (Idx.Rule) then
            return;
         end if;
         if ASU.Length (Idx.Title) = 0 then
            if Index_Items.Nof_Elements (Idx.Items) = 0 then
               Idx.Title := ASU.To_Unbounded_String ("Empty Index");
            else
               declare
                  Title : constant String := Get_Title (Idx.Contained);
               begin
                  if Title'Length = 0 then
                     AD.Messages.Warn
                       ("Index '" & Name & "' has no title; " &
                        "using ""Index"".");
                     Idx.Title := ASU.To_Unbounded_String ("Index");
                  else
                     Idx.Title := ASU.To_Unbounded_String (Title & " Index");
                  end if;
               end;
            end if;
         end if;
         if ASU.Length (Idx.File_Name) = 0 then
            Idx.File_Name := ASU.To_Unbounded_String (Name);
         end if;
         Index_Lists.Add (Idx, Index_List);
      end Get_Title;

      procedure Get_Titles is new Index_Tables.Traverse_G (Get_Title);

   begin
      if not Enabled then return; end if;
      Index_Lists.Reset (Index_List);
      Get_Titles (All_Indices);
      Sort (Index_List);
      Write (All_Indices);
      Index_Lists.Reset (Index_List);
   end Write;

   ----------------------------------------------------------------------------

   procedure Finalize (Idx : in out Index)
   is
   begin
      Index_Items.Reset (Idx.Items);
   end Finalize;

   ----------------------------------------------------------------------------

   procedure Set_Empty
     (Idx  : access Index;
      Text : in     String)
   is
   begin
      Idx.Empty := ASU.To_Unbounded_String (Text);
   end Set_Empty;

   procedure Set_Title
     (Idx   : access Index;
      Title : in     String)
   is
   begin
      Idx.Title := ASU.To_Unbounded_String (Title);
   end Set_Title;

   procedure Set_File_Name
     (Idx  : access Index;
      Name : in     String)
   is
      S : constant String := AD.Text_Utilities.Canonical (Name);
   begin
      Idx.File_Name :=
        ASU.To_Unbounded_String
          (Util.Pathes.Concat
             (Util.Pathes.Path (S), Util.Pathes.Base_Name (S)));
   end Set_File_Name;

   procedure Set_Rule
     (Idx  : access Index;
      Rule : in     AD.Expressions.Expression)
   is
   begin
      Idx.Rule := Rule;
   end Set_Rule;

   procedure Set_Structured
     (Idx  : access Index;
      Flag : in     Boolean)
   is
   begin
      Idx.Structured := Flag;
   end Set_Structured;

   ----------------------------------------------------------------------------

   procedure Add
     (Idx        : access Index;
      Element    : in     Asis.Element;
      XRef       : in     AD.Crossrefs.Cross_Reference;
      Is_Private : in     Boolean := False)
   is
      use Asis;
      use Asis.Declarations;
      use Asis.Elements;

      Use_It : Boolean              := False;
      Pos    : Asis2.Spans.Position := XRef.Position;
   begin
      if AD.Expressions.Is_Nil (Idx.Rule) or else
         WASU.Length (XRef.Image) = 0
      then
         return;
      end if;
      if not AD.Exclusions.No_XRef
              (Util.Strings.To_Lower
                 (ACH.To_String (WASU.To_Wide_String (XRef.Full_Unit_Name))))
         and then
         not XRef.Ignore
      then
         Use_It := AD.Expressions.Evaluate (Idx.Rule, Element);
         if not Use_It and then AD.Predicates.Is_Type (Element) then
            --  Ok, now come some rather special cases for incomplete and
            --  private types:
            --    (1) Add is called for incomplete types only if there is no
            --        corresponding full type. Otherwise, we always call Add
            --        with the full type. However, if we now have a full type,
            --        and it didn't match, then we should check whether the
            --        incomplete type might match.
            --    (2) If we have a private type declaration, we don't call Add
            --        again for the full type declaration in the private part.
            --        But here, we should really check whether that one might
            --        match... but only, if we are processing private parts at
            --        all!
            declare
               Decl : Asis.Element := Element;
            begin
               if Element_Kind (Decl) /= A_Declaration then
                  Decl := Asis2.Declarations.Enclosing_Declaration (Decl);
               end if;
               declare
                  Other : constant Declaration :=
                    Corresponding_Type_Declaration (Decl);
               begin
                  if not Is_Nil (Other) and then
                     not Is_Equal (Decl, Other)
                  then
                     if Declaration_Kind (Other) =
                        An_Incomplete_Type_Declaration
                     then
                        Use_It := True;
                     else
                        case Declaration_Kind (Decl) is
                           when A_Private_Type_Declaration |
                                A_Private_Extension_Declaration =>
                              Use_It := AD.Options.Private_Too;
                           when others =>
                              Use_It := False;
                        end case;
                     end if;
                  end if;
                  if Use_It then
                     Use_It := AD.Expressions.Evaluate (Idx.Rule, Other);
                     if Use_It then
                        --  Correct the position! (Everything else in the XRef
                        --  remains the same, because necessarily the two
                        --  declarations are in the same unit.)
                        Pos :=
                          Asis2.Spans.Start
                            (Asis2.Spans.Get_Span
                               (Asis2.Naming.Get_Name (Other)));
                        if Asis2.Spans.Is_Nil (Pos) then
                           --  Oops! Revert!
                           Pos := XRef.Position;
                        end if;
                     end if;
                  end if;
               end;
            end;
         end if;
      end if;
      if Use_It then
         Index_Items.Add
           (Index_Item'(XRef       =>
                          (Full_Unit_Name => XRef.Full_Unit_Name,
                           Image          => XRef.Image,
                           Position       => Pos,
                           Is_Local       => False,
                           Is_Top_Unit    => XRef.Is_Top_Unit,
                           Ignore         => XRef.Ignore),
                        Is_Private => Is_Private),
            Idx.Items);
         declare
            use ASM;
         begin
            Idx.Present :=
              Idx.Present or
              To_Set (ACH.To_Character (WASU.Element (XRef.Image, 1)));
         end;
         declare
            use AD.Predicates;
         begin
            if Is_Unit (Element) then
               Idx.Contained (Units) := True;
            elsif Is_Package (Element) then
               Idx.Contained (Packages) := True;
            elsif Is_Type (Element) or else Is_Subtype (Element) then
               Idx.Contained (Types) := True;
            elsif Is_Procedure (Element) then
               Idx.Contained (Procedures) := True;
            elsif Is_Function (Element) then
               Idx.Contained (Functions) := True;
            elsif Is_Entry (Element) then
               Idx.Contained (Entrys) := True;
            elsif Is_Exception (Element) then
               Idx.Contained (Exceptions) := True;
            elsif Is_Constant (Element) then
               Idx.Contained (Constants) := True;
            elsif Is_Variable (Element) then
               Idx.Contained (Variables) := True;
            elsif Is_Pragma (Element) then
               Idx.Contained (Pragmas) := True;
            elsif Is_Clause (Element) then
               Idx.Contained (Clauses) := True;
            end if;
         end;
      end if;
   end Add;

   ----------------------------------------------------------------------------

   procedure Write
     (Idx     : access Index;
      Printer : access AD.Printers.Printer'Class;
      Name    : in     String)
   is
      pragma Warnings (Off, Name); --  silence -gnatwa

      type Nesting_Desc;
      type Nesting_Ptr is access Nesting_Desc;
      type Nesting_Desc is
         record
            Name : ASU.Unbounded_String;
            Next : Nesting_Ptr;
         end record;

      procedure Free is
         new Ada.Unchecked_Deallocation (Nesting_Desc, Nesting_Ptr);

      Nesting_Stack : Nesting_Ptr;

      function Find
        (S    : in Nesting_Ptr;
         Name : in String)
        return Nesting_Ptr
      is
         P : Nesting_Ptr := S;
      begin
         while P /= null loop
            exit when
              Util.Strings.Is_Prefix (Name, ASU.To_String (P.Name) & '.');
            P := P.Next;
         end loop;
         return P;
      end Find;

      procedure Clear_Stack
      is
         P : Nesting_Ptr;
      begin
         while Nesting_Stack /= null loop
            P := Nesting_Stack; Nesting_Stack := P.Next; Free (P);
         end loop;
      end Clear_Stack;

   begin
      Sort_Items :
      declare

         function "<"
           (Left, Right : in Index_Item)
           return Boolean
         is
            use type Asis2.Spans.Position;
         begin
            if WASU."=" (Left.XRef.Image, Right.XRef.Image) then
               if WASU."=" (Left.XRef.Full_Unit_Name,
                            Right.XRef.Full_Unit_Name)
               then
                  return Left.XRef.Position < Right.XRef.Position;
               else
                  return WASU."<" (Left.XRef.Full_Unit_Name,
                                   Right.XRef.Full_Unit_Name);
               end if;
            else
               return WASU."<" (Left.XRef.Image, Right.XRef.Image);
            end if;
         end "<";

         procedure Sort is new Index_Items.Sort;

      begin
         Sort (Idx.Items);
      end Sort_Items;
      AD.Printers.Open_Index
        (Printer,
         ASU.To_String (Idx.File_Name),
         ASU.To_String (Idx.Title),
         Idx.Present);
      Index_XRef_Section :
      declare

         procedure XRef_Index
           (Item : in out Index_Ptr;
            Quit : in out Boolean)
         is
            pragma Warnings (Off, Quit); --  silence -gnatwa
         begin
            if Item.all'Access /= Idx then
               AD.Printers.XRef_Index
                 (Printer,
                  ASU.To_String (Item.File_Name),
                  ASU.To_String (Item.Title));
            end if;
         end XRef_Index;

         procedure Traverse is new Index_Lists.Traverse_G (XRef_Index);

      begin
         if Index_Lists.Nof_Elements (Index_List) > 1 then
            AD.Printers.Open_Section
              (Printer, AD.Printers.Index_XRef_Section);
            Traverse (Index_List);
            AD.Printers.Close_Section
              (Printer, AD.Printers.Index_XRef_Section);
         end if;
      end Index_XRef_Section;
      declare
         Last_Char  : Character := ASCII.NUL;
         Items      : array (Boolean) of Index_Item;
         Curr_Item  : Boolean := False;
         First      : Boolean := True;
         Last_Image : WASU.Unbounded_Wide_String;

         procedure Write_Item
           (Item : in Index_Item;
            Last : in Boolean)
         is
            First_Char : constant Character :=
              ACH.To_Character (WASU.Element (Item.XRef.Image, 1));
         begin
            if Last_Char /= First_Char then
               AD.Printers.Close_Char_Section (Printer);
               Last_Char := First_Char;
               AD.Printers.Open_Char_Section (Printer, Last_Char);
               Clear_Stack;
            end if;
            if Idx.Structured then
               declare
                  Name     : constant String :=
                    ACH.To_String (WASU.To_Wide_String (Item.XRef.Image));
                  Top_Most : constant Nesting_Ptr :=
                    Find (Nesting_Stack, Name);
                  P        : Nesting_Ptr;
               begin
                  if Nesting_Stack = Top_Most then
                     --  Add another level.
                     AD.Printers.Open_Index_Structure (Printer);
                     Nesting_Stack :=
                       new Nesting_Desc'(ASU.To_Unbounded_String (Name),
                                         Nesting_Stack);
                  else
                     --  Close levels until the topmost entry is 'Top_Most'
                     while Nesting_Stack.Next /= Top_Most loop
                        AD.Printers.Close_Index_Structure (Printer);
                        P := Nesting_Stack; Nesting_Stack := P.Next;
                        Free (P);
                     end loop;
                     Nesting_Stack.Name := ASU.To_Unbounded_String (Name);
                  end if;
               end;
            end if;
            AD.Printers.Open_Index_Item (Printer);
            AD.Printers.Put_XRef (Printer, Item.XRef, Is_Index => True);
            if Item.Is_Private then
               AD.Printers.Write_Plain (Printer, " (private)");
            end if;
            if not (Last and then First) --   Only one item!
               and then
               (WASU."=" (Item.XRef.Image, Items (Curr_Item).XRef.Image)
                or else
                WASU."=" (Item.XRef.Image, Last_Image))
            then
               --  Add the unit.
               AD.Printers.Write_Plain (Printer, " in ");
               AD.Printers.Write_Code
                 (Printer,
                  ACH.To_String
                    (WASU.To_Wide_String (Item.XRef.Full_Unit_Name)));
            end if;
            Last_Image := Item.XRef.Image;
            AD.Printers.Close_Index_Item (Printer);
         end Write_Item;

         procedure Handle_Item
           (Item : in out Index_Item;
            Quit : in out Boolean)
         is
            pragma Warnings (Off, Quit); --  silence -gnatwa

         begin
            Curr_Item := not Curr_Item;
            Items (Curr_Item) := Item;
            if not First then
               Write_Item (Items (not Curr_Item), False);
            end if;
            First := False;
         end Handle_Item;

         procedure Write_Items is new Index_Items.Traverse_G (Handle_Item);

      begin
         if Index_Items.Nof_Elements (Idx.Items) > 0 then
            Write_Items (Idx.Items);
            Curr_Item := not Curr_Item;
            Write_Item (Items (not Curr_Item), True);
         else
            if ASU.Length (Idx.Empty) > 0 then
               AD.Printers.Open_Index_Item (Printer);
               AD.Printers.Dump (Printer, ASU.To_String (Idx.Empty));
               AD.Printers.Close_Index_Item (Printer);
            end if;
         end if;
      end;
      AD.Printers.Close_Index (Printer);
      Clear_Stack;
   end Write;

begin
   Index_Tables.Set_Resize (All_Indices, 0.75);
   declare
      Linear_Growth : GAL.Support.Hashing.Linear_Growth_Policy (20);
   begin
      Index_Tables.Set_Growth_Policy (All_Indices, Linear_Growth);
   end;
end AD.Indices;
