with Xt.Intrinsic;             use Xt.Intrinsic;
with Ada.Unchecked_Conversion;

package Callbacks is


   function To_XtPointer is
         new Ada.Unchecked_Conversion (
               Source => Widget,
               Target => XtPointer);


   --  Used whent he callback is called
   function To_Widget is
         new Ada.Unchecked_Conversion (
               Source => XtPointer,
               Target => Widget);


   --  Designed to simplify the passing of callback data
   --  Previous problems with passing call back data often related to
   --  the varying sizes of pointers (e.g. fat pointers, thin pointers as
   --  implemented by Gnat).
   --  The main idea is to wrap _all_ values up inside a Callback_Item,
   --  and then pass (a standard sized) pointer to that.

   type Callback_Data is tagged null record;

   type Callback_Data_Ptr is access all Callback_Data'class;


   --  Used when the callback is registered
   function To_XtPointer is
         new Ada.Unchecked_Conversion (
               Source => Callback_Data_Ptr,
               Target => XtPointer);


   --  Used whent he callback is called
   function To_Callback_Data_Ptr is
         new Ada.Unchecked_Conversion (
               Source => XtPointer,
               Target => Callback_Data_Ptr);



   ----------------------------------------
   --  Example derived type

   type String_Access is access all String;

   type String_Callback_Data is new Callback_Data with
      record
         Ptr : String_Access;
      end record;

   type String_Callback_Data_Ptr is access all String_Callback_Data;


   -- At the called site, you will get an XtPointer as the client_data parameter.
   -- To convert back to the original type you can do a number of things. 
   --
   -- 1. Checked dynamic cast (downcast) to the type you expect to be passed.
   --    An exception (Constraint_Error) may be raised if the tags don't match.
   --
   -- 2. Manually check the tags (same as above, except you check it)
   --
   -- 3. Suppress the check, and get efficient downcast if you are 100%
   --    sure what you are doing.

   -- Let's assume passing a string ptr. Examples...
   -- 1. Checked dynamic cast...
   --
   --    procedure Callback (
   --                        W           : Xt.Intrinsic.Widget;
   --                        client_data : Xt.Intrinsic.XtPointer;
   --                        call_data  : Xt.Intrinsic.XtPointer) is
   --
   --      Data       : Callback_Data_Ptr        := To_Callback_Data_Ptr (Client_data);
   --   begin
   --      declare
   --         --  Convert the class wide pointer into a pointer to a specific type.
   --         --  This causes a check to ensure that what the item points at is a
   --         --  String_Callback_Data. A Constraint_Error is raised if this is not the
   --         --  case.
   --
   --         String_Ptr : String_Callback_Data_Ptr := String_Callback_Data_Ptr'(Data);
   --      begin
   --         Put_Line ("the client data is " & String_Ptr.Ptr.all);
   --      end;
   --   exception
   --      when  Constraint_Error =>
   --         Put_Line ("Error in downcast");
   --   end;

   -- 2. Manually check the tags...
   --
   --    procedure Callback (
   --                        W           : Xt.Intrinsic.Widget;
   --                        client_data : Xt.Intrinsic.XtPointer;
   --                        call_data  : Xt.Intrinsic.XtPointer) is
   --
   --      Data       : Callback_Data_Ptr        := To_Callback_Data_Ptr (Client_data);
   --   begin
   --      if Data.all'Tag = String_Callback_Data'Tag then
   --         --  downcast is safe
   --         ... as before
   --      else
   --         --  something has gone seriously wrong!
   --      end if;
   --   end;

   -- 3. Suppress the check...
   --
   --    procedure Callback (
   --                        W           : Xt.Intrinsic.Widget;
   --                        client_data : Xt.Intrinsic.XtPointer;
   --                        call_data  : Xt.Intrinsic.XtPointer) is
   --
   --      Data       : Callback_Data_Ptr        := To_Callback_Data_Ptr (Client_data);
   --
   --      pragma Suppress (Tag_Check);
   --      String_Ptr : String_Callback_Data_Ptr := String_Callback_Data_Ptr'(Data);
   --
   --   begin
   --      Put_Line ("I hope this worked ok!!!");
   --      Put_Line ("The client data is " & String_Ptr.Ptr.all);
   --   end;

end Callbacks;