------------------------------------------------------------------------------
--                                                                          --
--                 An Ada2005 binding to the Qt C++ library                 --
--                                                                          --
------------------------------------------------------------------------------
--                                                                          --
-- Copyright © 2007-2010 Vadim Godunko <vgodunko@gmail.com>                 --
--                                                                          --
-- QtAda 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. QtAda is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- 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 QtAda;  see file COPYING.  If not, write --
-- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
-- Boston, MA 02110-1301, USA.                                              --
--                                                                          --
-- As a special exception,  if other files  instantiate  generics from this --
-- unit, or you link  this unit with other files  to produce an executable, --
-- this  unit  does not  by itself cause  the resulting  executable  to  be --
-- covered  by the  GNU  General  Public  License.  This exception does not --
-- however invalidate  any other reasons why  the executable file  might be --
-- covered by the  GNU Public License.                                      --
--                                                                          --
------------------------------------------------------------------------------
with Ada.Containers.Hashed_Maps;
with Ada.Containers.Indefinite_Hashed_Maps;
with Ada.Strings.Hash;
with Interfaces.C.Strings;

with Qt4_Debug;

package body Qt_Ada.Internals.Object_Registry is

   type Class_Info is record
     Meta_Cast : Qt_Metacast_Operation;
     Meta_Call : Qt_Metacall_Operation;
   end record;

   package String_Proxy_Maps is
     new Ada.Containers.Indefinite_Hashed_Maps
          (Key_Type        => String,
           Element_Type    => Q_Object_Proxy_Constructor,
           Hash            => Ada.Strings.Hash,
           Equivalent_Keys => "=");

   package String_Director_Maps is
     new Ada.Containers.Indefinite_Hashed_Maps
          (Key_Type        => String,
           Element_Type    => Class_Info,
           Hash            => Ada.Strings.Hash,
           Equivalent_Keys => "=");

   function Hash (Tag : Ada.Tags.Tag) return Ada.Containers.Hash_Type;

   package Tag_Class_Maps is
     new Ada.Containers.Hashed_Maps
          (Key_Type        => Ada.Tags.Tag,
           Element_Type    => Q_Object_Meta_Descriptor_Access,
           Hash            => Hash,
           Equivalent_Keys => Ada.Tags."=");

   Proxy_Registry    : String_Proxy_Maps.Map;
   Director_Registry : String_Director_Maps.Map;
   Derived_Registry  : Tag_Class_Maps.Map;

   function Get_Associate
    (Cpp_Object : not null access Qt_Ada.Internals.Objects.QObject)
       return Qt_Ada.Internals.Objects.Q_Object_Base_Access;
   pragma Import (C, Get_Associate, "__QtAda_get_QObject_LimitedEntity");
   pragma Warnings (Off, Get_Associate);
   --  Returns associated Ada proxy or director object.

   function metaObject_dispatch
    (Self : not null Qt_Ada.Internals.Objects.Q_Object_Base_Access)
       return not null access constant Qt4.Meta_Objects.Q_Meta_Object;
   pragma Export
    (C, metaObject_dispatch, "__Qt4Ada_QObject_metaObject_dispatch");
   pragma Warnings (Off, metaObject_dispatch);
   --  Dispatch of the QObject::metaObject() call to the Ada object.

   function metaObject_virtual
    (This : not null access Qt_Ada.Internals.Objects.QObject)
       return not null access constant Qt4.Meta_Objects.Q_Meta_Object;
   pragma Import
    (C, metaObject_virtual, "__Qt4Ada_QObject_metaObject_virtual");
   --  Doing virtual call of the QObject::metaObject() method.

   function qt_metacast_dispatch
    (Self  : not null Qt_Ada.Internals.Objects.Q_Object_Base_Access;
     Class : Interfaces.C.Strings.chars_ptr)
       return System.Address;
   pragma Export
    (C, qt_metacast_dispatch, "__Qt4Ada_QObject_qt_metacast_dispatch");
   pragma Warnings (Off, qt_metacast_dispatch);
   --  Dispatch of the QObject::qt_metacast() call to the Ada object.

   function qt_metacall_dispatch
    (Self : not null Qt_Ada.Internals.Objects.Q_Object_Base_Access;
     Kind : Qt4.Meta_Objects.Call;
     Id   : Qt4.Q_Integer;
     Args : Qt4.Address_Pointer)
       return Qt4.Q_Integer;
   pragma Export
    (C, qt_metacall_dispatch, "__Qt4Ada_QObject_qt_metacall_dispatch");
   pragma Warnings (Off, qt_metacall_dispatch);
   --  Dispatch of the QObject::qt_metacall() call to the Ada object.

   ----------
   -- Hash --
   ----------

   function Hash (Tag : Ada.Tags.Tag) return Ada.Containers.Hash_Type is
   begin
      return Ada.Strings.Hash (Ada.Tags.External_Tag (Tag));
   end Hash;

   ---------------------
   -- Meta_Descriptor --
   ---------------------

   function Meta_Descriptor (Item : Ada.Tags.Tag)
     return Q_Object_Meta_Descriptor_Access
   is
      Position : constant Tag_Class_Maps.Cursor
        := Derived_Registry.Find (Item);

   begin
      if Tag_Class_Maps.Has_Element (Position) then
         return Tag_Class_Maps.Element (Position);

      else
         Qt4_Debug.Output
          ("Meta information for tagged type with tag "
             & Ada.Tags.External_Tag (Item)
             & " not registered.");
         Qt4_Debug.Output
          ("Do you ""with"" corresponding MOC child package somewhere"
             & " in the partition?");

         raise Program_Error
           with "Meta information for tagged type with tag "
                  & Ada.Tags.External_Tag (Item)
                  & " not registered.";
      end if;
   end Meta_Descriptor;

   -------------------------
   -- metaObject_dispatch --
   -------------------------

   function metaObject_dispatch
    (Self : not null Qt_Ada.Internals.Objects.Q_Object_Base_Access)
       return not null access constant Qt4.Meta_Objects.Q_Meta_Object
   is
   begin
      return Meta_Descriptor (Self'Tag).Meta_Object;
   end metaObject_dispatch;

   --------------------------
   -- qt_metacall_dispatch --
   --------------------------

   function qt_metacall_dispatch
    (Self : not null Qt_Ada.Internals.Objects.Q_Object_Base_Access;
     Kind : Qt4.Meta_Objects.Call;
     Id   : Qt4.Q_Integer;
     Args : Qt4.Address_Pointer)
       return Qt4.Q_Integer
   is

      function Call_Metacall
       (Descriptor : Q_Object_Meta_Descriptor_Access;
        Self       : not null Qt_Ada.Internals.Objects.Q_Object_Base_Access;
        Kind       : Qt4.Meta_Objects.Call;
        Id         : Qt4.Q_Integer;
        Args       : Qt4.Address_Pointer)
          return Qt4.Q_Integer;

      -------------------
      -- Call_Metacall --
      -------------------

      function Call_Metacall
       (Descriptor : Q_Object_Meta_Descriptor_Access;
        Self       : not null Qt_Ada.Internals.Objects.Q_Object_Base_Access;
        Kind       : Qt4.Meta_Objects.Call;
        Id         : Qt4.Q_Integer;
        Args       : Qt4.Address_Pointer)
          return Qt4.Q_Integer
      is
         use type Qt4.Q_Integer;

         Aux : Qt4.Q_Integer := Id;

      begin
         if Descriptor.Parent /= null then
            Aux := Call_Metacall (Descriptor.Parent, Self, Kind, Aux, Args);

         else
            Aux :=
              Director_Registry.Element
               (Qt4.Meta_Objects.Class_Name
                 (Descriptor.Meta_Object.Super_Data)).Meta_Call
                   (Self.QObject_View, Kind, Aux, Args);
         end if;

         if Aux < 0 then
            return Aux;

         else
            return Descriptor.Meta_Call (Self, Kind, Aux, Args);
         end if;
      end Call_Metacall;

      Position : constant Tag_Class_Maps.Cursor
        := Derived_Registry.Find (Self'Tag);

   begin
      if not Tag_Class_Maps.Has_Element (Position) then
         Qt4_Debug.Output
          ("Meta information for tagged type with tag "
             & Ada.Tags.External_Tag (Self'Tag)
             & " not registered.");
         Qt4_Debug.Output
          ("Do you ""with"" corresponding MOC child package somewhere"
             & " in the partition?");

         raise Program_Error
           with "Meta information for tagged type with tag "
                  & Ada.Tags.External_Tag (Self'Tag)
                  & " not registered.";
      end if;

      return
        Call_Metacall
         (Tag_Class_Maps.Element (Position),
          Self,
          Kind,
          Id,
          Args);
   end qt_metacall_dispatch;

   --------------------------
   -- qt_metacast_dispatch --
   --------------------------

   function qt_metacast_dispatch
    (Self  : not null Qt_Ada.Internals.Objects.Q_Object_Base_Access;
     Class : Interfaces.C.Strings.chars_ptr)
       return System.Address
   is
      use type Interfaces.C.Strings.chars_ptr;

   begin
      if Class = Interfaces.C.Strings.Null_Ptr then
         return System.Null_Address;
         --  Protect from crash in the Mac OS X port.

      else
         declare
            Class_Name : constant String := Interfaces.C.Strings.Value (Class);
            Position   : constant Tag_Class_Maps.Cursor
              := Derived_Registry.Find (Self'Tag);

         begin
            if Class_Name = "" then
               return System.Null_Address;
            end if;

            if not Tag_Class_Maps.Has_Element (Position) then
               Qt4_Debug.Output
                ("Meta information for tagged type with tag "
                   & Ada.Tags.External_Tag (Self'Tag)
                   & " not registered.");
               Qt4_Debug.Output
                ("Do you ""with"" corresponding MOC child package somewhere"
                   & " in the partition?");

               raise Program_Error
                 with "Meta information for tagged type with tag "
                        & Ada.Tags.External_Tag (Self'Tag)
                        & " not registered.";
            end if;

            declare
               use type System.Address;

               Descriptor : Q_Object_Meta_Descriptor_Access
                 := Tag_Class_Maps.Element (Position);
               Aux        : System.Address := System.Null_Address;

            begin
               while Aux = System.Null_Address loop
                  Aux        := Descriptor.Meta_Cast (Self, Class_Name);

                  exit when Descriptor.Parent = null;

                  Descriptor := Descriptor.Parent;
               end loop;

               if Aux = System.Null_Address then
                  Aux :=
                    Director_Registry.Element
                     (Qt4.Meta_Objects.Class_Name
                       (Descriptor.Meta_Object.Super_Data)).Meta_Cast
                         (Self.QObject_View, Interfaces.C.To_C (Class_Name));
               end if;

               return Aux;
            end;
         end;
      end if;
   end qt_metacast_dispatch;

   -----------------------
   -- Register_Director --
   -----------------------

   procedure Register_Director
    (Class_Name : String;
     Meta_Cast  : Qt_Metacast_Operation;
     Meta_Call  : Qt_Metacall_Operation)
   is
   begin
      Director_Registry.Insert (Class_Name, (Meta_Cast, Meta_Call));
   end Register_Director;

   --------------------
   -- Register_Proxy --
   --------------------

   procedure Register_Proxy
    (Class_Name  : String;
     Constructor : Q_Object_Proxy_Constructor)
   is
   begin
      Proxy_Registry.Insert (Class_Name, Constructor);
   end Register_Proxy;

   -----------------------------------
   -- Register_QObject_Derived_Type --
   -----------------------------------

   procedure Register_QObject_Derived_Type
    (Tag        : Ada.Tags.Tag;
     Descriptor : Q_Object_Meta_Descriptor_Access)
   is
   begin
      Derived_Registry.Insert (Tag, Descriptor);
   end Register_QObject_Derived_Type;

   -----------------
   -- To_Q_Object --
   -----------------

   function To_Q_Object
    (Item : not null access Qt_Ada.Internals.Objects.QObject)
       return not null access Qt_Ada.Internals.Objects.Q_Object_Base'Class
   is
      use type Qt_Ada.Internals.Objects.Q_Object_Base_Access;

      Entity : Qt_Ada.Internals.Objects.Q_Object_Base_Access;

   begin
      Entity := Get_Associate (Item);

      if Entity = null then
         --  Если объект C++ ещё не был ассоциирован с объектом Ada, то
         --  создаём объект Ada соответствующего типа и устанавливаем
         --  асоциацию.

         declare
            Item_Data : access constant Qt4.Meta_Objects.Q_Meta_Object
              := metaObject_virtual (Item);

         begin
            --  Переход вверх по иерархии классов, пока не будет найден
            --  зарегистрированный класс или не будет достигнут QObject.

            while Item_Data /= null loop
               declare
                  Position : constant String_Proxy_Maps.Cursor
                    := Proxy_Registry.Find
                        (Qt4.Meta_Objects.Class_Name (Item_Data));

               begin
                  if String_Proxy_Maps.Has_Element (Position) then
                     Entity :=
                       String_Proxy_Maps.Element (Position).all
                        (Qt_Ada.Internals.Objects.QObject_Access (Item));

                     exit;
                  end if;

                  Qt4_Debug.Output
                   ("No proxy constructor for class '"
                      & Qt4.Meta_Objects.Class_Name (Item_Data)
                      & "' (object has '"
                      & Qt4.Meta_Objects.Class_Name (metaObject_virtual (Item))
                      & "' class). Fallback to superclass '"
                      & Qt4.Meta_Objects.Class_Name (Item_Data.Super_Data)
                      & "'.");

                  Item_Data := Item_Data.Super_Data;
               end;
            end loop;
         end;
      end if;

      return Qt_Ada.Internals.Objects.Q_Object_Base'Class (Entity.all)'Access;
   end To_Q_Object;

   -----------------
   -- To_Q_Object --
   -----------------

   function To_Q_Object
    (Item        : not null access Qt_Ada.Internals.Objects.QObject;
     Known_Class : String)
       return not null access Qt_Ada.Internals.Objects.Q_Object_Base'Class
   is
      use type Qt_Ada.Internals.Objects.Q_Object_Base_Access;

      Entity : Qt_Ada.Internals.Objects.Q_Object_Base_Access;

   begin
      Entity := Get_Associate (Item);

      if Entity = null then
         --  Если объект C++ ещё не был ассоциирован с объектом Ada, то
         --  создаём объект Ada соответствующего типа и устанавливаем
         --  асоциацию.

         declare
            Item_Data : access constant Qt4.Meta_Objects.Q_Meta_Object
              := metaObject_virtual (Item);

         begin
            --  Переход вверх по иерархии классов, пока не будет найден
            --  зарегистрированный класс или не будет достигнут QObject.

            while Item_Data /= null loop
               declare
                  Position : String_Proxy_Maps.Cursor
                    := Proxy_Registry.Find
                        (Qt4.Meta_Objects.Class_Name (Item_Data));

               begin
                  if String_Proxy_Maps.Has_Element (Position) then
                     if String_Proxy_Maps.Key (Position) = "QObject" then
                        Position := Proxy_Registry.Find (Known_Class);
                     end if;

                     Entity :=
                       String_Proxy_Maps.Element (Position).all
                        (Qt_Ada.Internals.Objects.QObject_Access (Item));

                     exit;
                  end if;

                  Qt4_Debug.Output
                   ("No proxy constructor for class '"
                      & Qt4.Meta_Objects.Class_Name (Item_Data)
                      & "' (object has '"
                      & Qt4.Meta_Objects.Class_Name (metaObject_virtual (Item))
                      & "' class). Fallback to superclass '"
                      & Qt4.Meta_Objects.Class_Name (Item_Data.Super_Data)
                      & "'.");

                  Item_Data := Item_Data.Super_Data;
               end;
            end loop;
         end;
      end if;

      return Qt_Ada.Internals.Objects.Q_Object_Base'Class (Entity.all)'Access;
   end To_Q_Object;
end Qt_Ada.Internals.Object_Registry;
