-------------------------------------------------------------------------------
--
--  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>
--   Storage of description definitions.</DL>
--
-- <!--
-- Revision History
--
--   06-FEB-2002   TW  Initial version.
--   26-FEB-2002   TW  Added 'A_Component_Declaration' to function
--                     'Item_Class' (components of protected objs or types).
--   19-MAR-2002   TW  Added 'An_Object_Renaming_Declaration' to function
--                     'Item_Class'.
--   25-MAR-2002   TW  Changed the item class for task (type) declarations
--                     without content ("task type X;") to Item_Type or
--                     Item_Object instead of Item_Task.
--   11-NOV-2002   TW  Added 'Item_Context_Clause'.
--   22-FEB-2005   TW  Minor bug fix: for library items, 'Inside' wasn't
--                     working because the search backwards started at 'Front'
--                     instead of at 'Inner'.
-- -->
-------------------------------------------------------------------------------

pragma License (GPL);

with Ada.Exceptions;
with Ada.Strings.Maps;
with Ada.Unchecked_Deallocation;

with AD.Config;
with AD.Text_Utilities;

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

with Asis2.Spans;

with Util.Strings;

package body AD.Descriptions is

   package ASM renames Ada.Strings.Maps;

   use Asis;
   use Asis.Declarations;
   use Asis.Elements;
   use Asis.Text;

   use Asis2.Spans;
   use AD.Text_Utilities;

   use Util.Strings;

   procedure Free is new
     Ada.Unchecked_Deallocation (Finders, Finders_Ptr);

   type Handle is access Finders_Ptr;

   procedure Free is new
     Ada.Unchecked_Deallocation (Finders_Ptr, Handle);

   type Desc is
      record
         Is_Default : Boolean;
         Ptr        : Handle;
      end record;

   Comment_Finders : array (Item_Classes) of Desc;

   subtype Default_Count is Natural range 0 .. 2;

   type Default_Desc (N : Default_Count := 0) is
      record
         Super : Item_Classes;
         Find  : Finders (1 .. N);
      end record;

   Defaults : constant array (Item_Classes) of Default_Desc :=
     (No_Item_Class =>
        (0, No_Item_Class, (others => (None, 0))),
      Item_Context_Clause =>
        (1, Item_Context_Clause, (1 => (After, 1))),
      Item_Clause     =>
        (1, Item_Clause, (1 => (After, 1))),
      Item_Constant =>
        (1, Item_Constant, (1 => (After, 1))),
      Item_Container  =>
        (2, Item_Container, ((Before, Unlimited), (Inside, Unlimited))),
      Item_Exception  =>
        (1, Item_Exception, (1 => (After, 1))),
      Item_Instantiation =>
        (1, Item_Subprogram, (1 => (After, 1))),
      Item_Library    =>
        (2, Item_Library, ((Before, Unlimited), (After, Unlimited))),
      Item_Library_Instantiation =>
        (0, Item_Library, (others => (None, 0))),
      Item_Library_Package =>
        (0, Item_Library, (others => (None, 0))),
      Item_Library_Renaming =>
        (0, Item_Library, (others => (None, 0))),
      Item_Library_Subprogram =>
        (0, Item_Library, (others => (None, 0))),
      Item_Object =>
        (1, Item_Object, (1 => (After, 1))),
      Item_Package =>
        (0, Item_Container, (others => (None, 0))),
      Item_Pragma     =>
        (1, Item_Pragma, (1 => (After, 1))),
      Item_Protected =>
        (0, Item_Container, (others => (None, 0))),
      Item_Renaming =>
        (1, Item_Subprogram, (1 => (After, 1))),
      Item_Rep_Clause =>
        (1, Item_Rep_Clause, (1 => (After, 1))),
      Item_Subprogram =>
        (1, Item_Subprogram, (1 => (After, 1))),
      Item_Task =>
        (0, Item_Container, (others => (None, 0))),
      Item_Type       =>
        (2, Item_Type, ((After, 1), (Before, Unlimited)))
     );

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

   procedure Reset
     (The_Class : in Item_Classes)
   is
   begin
      if Comment_Finders (The_Class).Is_Default then
         return;
      end if;
      if Defaults (The_Class).Super = The_Class then
         Free (Comment_Finders (The_Class).Ptr.all);
         Comment_Finders (The_Class).Ptr.all :=
           new Finders'(Defaults (The_Class).Find);
      else
         Free (Comment_Finders (The_Class).Ptr.all);
         Free (Comment_Finders (The_Class).Ptr);
         Comment_Finders (The_Class).Ptr :=
           Comment_Finders (Defaults (The_Class).Super).Ptr;
      end if;
      Comment_Finders (The_Class).Is_Default := True;
   end Reset;

   procedure Set
     (The_Class : in Item_Classes;
      To        : in Finders)
   is
   begin
      if The_Class = No_Item_Class then raise Program_Error; end if;
      if Comment_Finders (The_Class).Is_Default and then
         Defaults (The_Class).Super /= The_Class
      then
         --  A subclass at its default setting: shares the parent data
         --  structure. Hence we need to create a new one.
         Comment_Finders (The_Class).Ptr := new Finders_Ptr;
      else
         --  It has its own data structure.
         Free (Comment_Finders (The_Class).Ptr.all);
      end if;
      Comment_Finders (The_Class).Ptr.all    := new Finders'(To);
      Comment_Finders (The_Class).Is_Default := False;
   end Set;

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

   procedure Parse
     (Selector : in String;
      Value    : in String)
   is

      function Parse_List
        (Value : in String)
        return Finders
      is

         function Parse_Finder
           (Value : in String)
           return Comment_Finder
         is
            Result : Comment_Finder := (None, 0);
            N      : Natural;
         begin
            if Is_Prefix (Value, "after") then
               Result.Where := After; N := 5;
            elsif Is_Prefix (Value, "before") then
               Result.Where := Before; N := 6;
            elsif Is_Prefix (Value, "inside") then
               Result.Where := Inside; N := 6;
            elsif Value = "none" then
               return Result;
            end if;
            if Result.Where = None then
               Ada.Exceptions.Raise_Exception
                 (AD.Config.Invalid_Config'Identity,
                  "unknown location """ & Value & '"');
            end if;
            if Value'Length = N then
               Result.How_Far := Unlimited;
               return Result;
            end if;
            --  "(number)" must be following.
            N := Index (Value (Value'First + N .. Value'Last), '(');
            if N = 0 then
               Ada.Exceptions.Raise_Exception
                 (AD.Config.Invalid_Config'Identity,
                  "invalid location """ & Value & '"');
            end if;
            declare
               I : constant Natural := N;
               J : constant Natural :=
                 Index (Value (N + 1 .. Value'Last), ')');
               Limit : Integer := -1;
            begin
               if J = Value'Last then
                  begin
                     Limit := Integer'Value (Value (I + 1 .. J - 1));
                  exception
                     when others =>
                        Limit := -1;
                  end;
               end if;
               if Limit < 0 then
                  Ada.Exceptions.Raise_Exception
                    (AD.Config.Invalid_Config'Identity,
                     "invalid location """ & Value & '"');
               end if;
               Result.How_Far := Limit;
            end;
            return Result;
         end Parse_Finder;

         I, J : Natural;

      begin --  Parse_List
         I := Value'First;
         while I <= Value'Last loop
            J := Index (Value, ',');
            if J = 0 then J := Value'Last + 1; end if;
            declare
               Item : constant String :=
                 To_Lower (Trim (Value (I .. J - 1)));
            begin
               if Item'Last >= Item'First then
                  return Parse_Finder (Item) &
                         Parse_List (Value (J + 1 .. Value'Last));
               end if;
            end;
            I := J + 1;
         end loop;
         declare
            Null_Finders : Finders (2 .. 1);
         begin
            return Null_Finders;
         end;
      end Parse_List;

      The_Class : Item_Classes;

   begin --  Parse
      begin
         The_Class := Item_Classes'Value ("ITEM_" & To_Upper (Selector));
      exception
         when Constraint_Error =>
            Ada.Exceptions.Raise_Exception
              (AD.Config.Invalid_Config'Identity,
               "unknown selector """ & Selector & '"');
      end;
      declare
         Where : constant Finders := Parse_List (Value);
      begin
         if Where'Last < Where'First then
            Reset (The_Class);
         else
            --  Check semantics: only containers and library items can have
            --  'Inside'!
            if Defaults (The_Class).Super /= Item_Container and then
               Defaults (The_Class).Super /= Item_Library
            then
               for I in Where'Range loop
                  if Where (I).Where = Inside then
                     Ada.Exceptions.Raise_Exception
                       (AD.Config.Invalid_Config'Identity,
                        "this description selector cannot have an " &
                        """Inside"" location");
                  end if;
               end loop;
            end if;
            --  It's ok.
            Set (The_Class, Where);
         end if;
      end;
   end Parse;

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

   function Item_Class
     (Item : in Asis.Element)
     return Item_Classes
   is
   begin
      case Element_Kind (Item) is
         when A_Clause =>
            case Clause_Kind (Item) is
               when A_Representation_Clause |
                    A_Component_Clause =>
                  return Item_Rep_Clause;
               when A_With_Clause =>
                  return Item_Context_Clause;
               when A_Use_Package_Clause | A_Use_Type_Clause =>
                  --  It's a context clause if it occurs before the start
                  --  of that compilation unit's declaration.
                  declare
                     Decl : constant Declaration :=
                       Unit_Declaration (Enclosing_Compilation_Unit (Item));
                  begin
                     if Is_Nil (Decl) or else
                        Start (Get_Span (Decl)) > Stop (Get_Span (Item))
                     then
                        return Item_Context_Clause;
                     end if;
                     return Item_Clause;
                  end;
               when others =>
                  return Item_Clause;
            end case;

         when A_Pragma =>
            return Item_Pragma;

         when A_Declaration =>
            case Declaration_Kind (Item) is
               when An_Exception_Renaming_Declaration |
                    An_Exception_Declaration =>
                  return Item_Exception;

               when A_Task_Type_Declaration =>
                  if Is_Nil (Type_Declaration_View (Item)) then
                     return Item_Type;
                  else
                     return Item_Task;
                  end if;

               when A_Single_Task_Declaration =>
                  if Is_Nil (Object_Declaration_View (Item)) then
                     return Item_Object;
                  else
                     return Item_Task;
                  end if;

               when A_Protected_Type_Declaration |
                    A_Single_Protected_Declaration =>
                  return Item_Protected;

               when A_Package_Declaration |
                    A_Generic_Package_Declaration =>
                  if Is_Equal
                       (Item,
                        Unit_Declaration  (Enclosing_Compilation_Unit (Item)))
                  then
                     return Item_Library_Package;
                  else
                     return Item_Package;
                  end if;

               when A_Procedure_Declaration |
                    A_Function_Declaration |
                    A_Generic_Procedure_Declaration |
                    A_Generic_Function_Declaration =>
                  if Is_Equal
                       (Item,
                        Unit_Declaration  (Enclosing_Compilation_Unit (Item)))
                  then
                     return Item_Library_Subprogram;
                  else
                     return Item_Subprogram;
                  end if;

               when A_Procedure_Renaming_Declaration |
                    A_Function_Renaming_Declaration |
                    A_Package_Renaming_Declaration |
                    A_Generic_Procedure_Renaming_Declaration |
                    A_Generic_Function_Renaming_Declaration |
                    A_Generic_Package_Renaming_Declaration =>
                  if Is_Equal
                       (Item,
                        Unit_Declaration  (Enclosing_Compilation_Unit (Item)))
                  then
                     return Item_Library_Renaming;
                  else
                     return Item_Renaming;
                  end if;

               when A_Procedure_Instantiation |
                    A_Function_Instantiation |
                    A_Package_Instantiation =>
                  if Is_Equal
                       (Item,
                        Unit_Declaration  (Enclosing_Compilation_Unit (Item)))
                  then
                     return Item_Library_Instantiation;
                  else
                     return Item_Instantiation;
                  end if;

               when An_Entry_Declaration =>
                  return Item_Subprogram;

               when A_Constant_Declaration |
                    A_Deferred_Constant_Declaration |
                    An_Integer_Number_Declaration |
                    A_Real_Number_Declaration =>
                  return Item_Constant;

               when A_Variable_Declaration |
                    A_Component_Declaration |
                    An_Object_Renaming_Declaration =>
                  --  Components can occur as the items in the private part of
                  --  a protected type or object.
                  return Item_Object;

               when others =>
                  if (Declaration_Kind (Item) in A_Type_Declaration) or else
                     (Declaration_Kind (Item) = A_Subtype_Declaration)
                  then
                     return Item_Type;
                  end if;

            end case; --  Declaration_Kind

         when others =>
            null;

      end case; --  Element_Kind
      return No_Item_Class;
   end Item_Class;

   function Is_Container
     (Class : in Item_Classes)
     return Boolean
   is
   begin
      return Defaults (Class).Super = Item_Container or else
             Class = Item_Library_Package;
   end Is_Container;

   function Get_Finders
     (The_Class : in Item_Classes)
     return Finders_Ptr
   is
   begin
      return Comment_Finders (The_Class).Ptr.all;
   end Get_Finders;

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

   type Text_Range;
   type Range_Ptr is access Text_Range;
   type Text_Range is
      record
         Start : Asis.Text.Line_Number;
         Stop  : Asis.Text.Line_Number;
         Next  : Range_Ptr;
      end record;

   procedure Free is
      new Ada.Unchecked_Deallocation (Text_Range, Range_Ptr);

   Anchor : Range_Ptr;

   procedure Take
     (Span : Asis.Text.Span)
   is
      P, Q  : Range_Ptr;
      First : constant Line_Number := Start (Span).Line;
      Last  : constant Line_Number := Stop (Span).Line;
   begin
      P := Anchor;
      --  There can be no overlaps!
      while P /= null and then Last < P.Stop loop
         Q := P; P := P.Next;
      end loop;
      if Q = null then
         Anchor := new Text_Range'(First, Last, P);
      else
         Q.Next := new Text_Range'(First, Last, P);
      end if;
   end Take;

   function Is_Taken
     (Pos : Asis.Text.Line_Number)
     return Boolean
   is
      P : Range_Ptr := Anchor;
   begin
      while P /= null and then Pos <= P.Stop loop
         if Pos >= P.Start then return True; end if;
         P := P.Next;
      end loop;
      return False;
   end Is_Taken;

   procedure Clear_Comments
   is
      P, Q : Range_Ptr;
   begin
      P := Anchor;
      while P /= null loop
         Q := P; P := P.Next; Free (Q);
      end loop;
      Anchor := null;
   end Clear_Comments;

   function Get_Name
     (Decl : in Asis.Declaration)
     return Asis.Element
   is
      All_Names : constant Name_List := Names (Decl);
   begin
      return All_Names (All_Names'First);
   end Get_Name;

   procedure Find_Comment
     (Unit      : in     Asis.Element;
      From      : in     Position;
      Limit     : in     Integer;
      Span      : in out Asis.Text.Span;
      Direction : in     Ada.Strings.Direction := Ada.Strings.Forward)
   is
      --  'Span' is initially nil!

      use type Ada.Strings.Direction;

      Comment_Pos : Position;

   begin
      if Is_Nil (From) then return; end if;
      if Direction = Ada.Strings.Backward then
         Comment_Pos :=
           Find_Comment (Unit, From.Line, Ada.Strings.Backward);
         if Is_Nil (Comment_Pos) or else
            (Limit >= 0 and then
             Integer (From.Line - Comment_Pos.Line - 1) > Limit) or else
            Is_Taken (Comment_Pos.Line)
         then
            return;
         end if;
         Set_Stop (Span, Comment_Pos);
         Set_Start
           (Span, Expand_Comment (Unit, Comment_Pos, Ada.Strings.Backward));
      else
         Comment_Pos := Find_Comment (Unit, From.Line);
         if Is_Nil (Comment_Pos) or else
            (Limit >= 0 and then
             Integer (Comment_Pos.Line - From.Line - 1) > Limit) or else
            Is_Taken (Comment_Pos.Line)
         then
            return;
         end if;
         Set_Start (Span, Comment_Pos);
         Set_Stop  (Span, Expand_Comment (Unit, Comment_Pos));
      end if;
      Comment_Pos := Start (Span);
      if Comment_Pos.Line = Stop (Span).Line then
         --  A one-liner... if it is empty after we've stripped out any blanks
         --  and dashes, it is not a comment after all!
         declare
            use type ASM.Character_Set;
            L : constant Line_List := Asis.Text.Lines (Unit, Span);
            S : constant String :=
              Trim (To_String (Comment_Image (L (L'First))),
                    Blanks or ASM.To_Set ("-"),
                    Blanks or ASM.To_Set ("-"));
         begin
            if S'Last < S'First then
               Span := Asis.Text.Nil_Span;
            end if;
         end;
      end if;
   end Find_Comment;

   procedure Find
     (Self       : in     Comment_Finder;
      Item       : in     Asis.Element;
      Span       :    out Asis.Text.Span;
      Class      : in     Item_Classes := No_Item_Class)
   is
   begin
      Span  := Asis.Text.Nil_Span;
      if Self.Where = None then return; end if;
      declare
         The_Span : constant Asis.Text.Span := Get_Span (Item);
      begin
         Find (Self, Item, Start (The_Span), Stop (The_Span), Span, Class);
      end;
   end Find;

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

   procedure Find
     (Self  : in     Comment_Finder;
      Item  : in     Asis.Element;
      From  : in     Asis2.Spans.Position;
      To    : in     Asis2.Spans.Position;
      Span  :    out Asis.Text.Span;
      Class : in     Item_Classes := No_Item_Class)
   is
      The_Class          : Item_Classes := Class;
      Front, Back, Inner : Position;
   begin
      Span  := Asis.Text.Nil_Span;
      if Self.Where = None then return; end if;
      Front := From;
      Back  := To;
      if The_Class = No_Item_Class then
         The_Class := Item_Class (Item);
      end if;
      if The_Class = No_Item_Class then return; end if;
      if Defaults (The_Class).Super = Item_Container then
         --  Find the end of the header
         case Declaration_Kind (Item) is
            when A_Task_Type_Declaration |
                 A_Protected_Type_Declaration =>
               declare
                  Before_Is : Asis.Element :=
                    Discriminant_Part (Item);
               begin
                  if Is_Nil (Before_Is) then
                     Before_Is := Get_Name (Item);
                  end if;
                  Inner :=
                    Stop (Through (Item, "is",
                                   From => Stop (Get_Span (Before_Is))));
               end;

            when A_Single_Task_Declaration |
                 A_Single_Protected_Declaration |
                 A_Package_Declaration |
                 A_Generic_Package_Declaration =>
               Inner :=
                 Stop
                   (Through (Item, "is",
                             From => Stop (Get_Span (Get_Name (Item)))));

            when others =>
               --  Not a container
               null;

         end case;
      elsif Defaults (The_Class).Super = Item_Library then
         --  Front is before the context clauses; Inner is the beginning of
         --  the item, Back is the end of the item, or, if it is a package,
         --  the end of the header.
         Inner := Front;
         declare
            Clauses : constant Context_Clause_List :=
              Context_Clause_Elements (Enclosing_Compilation_Unit (Item),
                                       True);
         begin
            if Clauses'Last >= Clauses'First then
               Front := Start (Get_Span (Clauses (Clauses'First)));
               if Is_Nil (Front) then Front := Inner; end if;
            end if;
         end;
         if The_Class = Item_Library_Package then
            --  Find the end of the header, i.e. the "is" after the package
            --  name.
            Back :=
              Stop (Through (Item, "is",
                             From => Stop (Get_Span (Get_Name (Item)))));
         end if;
      end if;
      --  All right, we now have the three positions we (may) need.
      declare
         Unit : constant Declaration :=
           Unit_Declaration (Enclosing_Compilation_Unit (Item));
      begin
         case Self.Where is
            when Before =>
               Find_Comment
                 (Unit, Front, Self.How_Far, Span, Ada.Strings.Backward);

            when Inside =>
               if Defaults (The_Class).Super = Item_Library then
                  --  Search backwards; 'Inner' is the beginning of the unit.
                  Find_Comment
                    (Unit, Inner, Self.How_Far, Span, Ada.Strings.Backward);
               else
                  Find_Comment (Unit, Inner, Self.How_Far, Span);
               end if;

            when After =>
               Find_Comment (Unit, Back, Self.How_Far, Span);

            when None =>
               raise Program_Error;

         end case;
      end;
      if not Is_Nil (Span) then
         Take (Span);
      end if;
   end Find;

begin --  AD.Descriptions.BODY
   for I in Comment_Finders'Range loop
      if I = No_Item_Class then
         Comment_Finders (I).Ptr := null;
      elsif Defaults (I).Super = I then
         Comment_Finders (I).Ptr     := new Finders_Ptr;
         Comment_Finders (I).Ptr.all := new Finders'(Defaults (I).Find);
      end if;
   end loop;
   for I in Comment_Finders'Range loop
      Comment_Finders (I).Is_Default := True;
      if Defaults (I).Super /= I then
         Comment_Finders (I).Ptr := Comment_Finders (Defaults (I).Super).Ptr;
      end if;
   end loop;
end AD.Descriptions;

