path: root/src/fltk-widgets-menus-menu_bars-systemwide.adb

--  Programmed by Jedidiah Barber
--  Released into the public domain


with

    Ada.Assertions,
    Ada.Unchecked_Deallocation,
    FLTK.Widgets.Groups,
    Interfaces.C;

use type

    Interfaces.C.int;


package body FLTK.Widgets.Menus.Menu_Bars.Systemwide is


    package Chk renames Ada.Assertions;

    procedure Free_Item is new Ada.Unchecked_Deallocation
        (Object => FLTK.Menu_Items.Menu_Item, Name => Item_Access);




    ------------------------
    --  Functions From C  --
    ------------------------

    function new_fl_sys_menu_bar
           (X, Y, W, H : in Interfaces.C.int;
            Text       : in Interfaces.C.char_array)
        return Storage.Integer_Address;
    pragma Import (C, new_fl_sys_menu_bar, "new_fl_sys_menu_bar");
    pragma Inline (new_fl_sys_menu_bar);

    procedure free_fl_sys_menu_bar
           (M : in Storage.Integer_Address);
    pragma Import (C, free_fl_sys_menu_bar, "free_fl_sys_menu_bar");
    pragma Inline (free_fl_sys_menu_bar);




    function fl_sys_menu_bar_add
           (M : in Storage.Integer_Address;
            T : in Interfaces.C.char_array)
        return Interfaces.C.int;
    pragma Import (C, fl_sys_menu_bar_add, "fl_sys_menu_bar_add");
    pragma Inline (fl_sys_menu_bar_add);

    function fl_sys_menu_bar_add2
           (M : in Storage.Integer_Address;
            T : in Interfaces.C.char_array;
            S : in Interfaces.C.int;
            U : in Storage.Integer_Address;
            F : in Interfaces.C.int)
        return Interfaces.C.int;
    pragma Import (C, fl_sys_menu_bar_add2, "fl_sys_menu_bar_add2");
    pragma Inline (fl_sys_menu_bar_add2);

    function fl_sys_menu_bar_add3
           (M    : in Storage.Integer_Address;
            T, S : in Interfaces.C.char_array;
            U    : in Storage.Integer_Address;
            F    : in Interfaces.C.int)
        return Interfaces.C.int;
    pragma Import (C, fl_sys_menu_bar_add3, "fl_sys_menu_bar_add3");
    pragma Inline (fl_sys_menu_bar_add3);

    function fl_sys_menu_bar_insert
           (M : in Storage.Integer_Address;
            P : in Interfaces.C.int;
            T : in Interfaces.C.char_array;
            S : in Interfaces.C.int;
            U : in Storage.Integer_Address;
            F : in Interfaces.C.int)
        return Interfaces.C.int;
    pragma Import (C, fl_sys_menu_bar_insert, "fl_sys_menu_bar_insert");
    pragma Inline (fl_sys_menu_bar_insert);

    function fl_sys_menu_bar_insert2
           (M    : in Storage.Integer_Address;
            P    : in Interfaces.C.int;
            T, S : in Interfaces.C.char_array;
            U    : in Storage.Integer_Address;
            F    : in Interfaces.C.int)
        return Interfaces.C.int;
    pragma Import (C, fl_sys_menu_bar_insert2, "fl_sys_menu_bar_insert2");
    pragma Inline (fl_sys_menu_bar_insert2);

    procedure fl_sys_menu_bar_set_menu
           (M, D : in Storage.Integer_Address);
    pragma Import (C, fl_sys_menu_bar_set_menu, "fl_sys_menu_bar_set_menu");
    pragma Inline (fl_sys_menu_bar_set_menu);

    procedure fl_sys_menu_bar_remove
           (M : in Storage.Integer_Address;
            P : in Interfaces.C.int);
    pragma Import (C, fl_sys_menu_bar_remove, "fl_sys_menu_bar_remove");
    pragma Inline (fl_sys_menu_bar_remove);

    procedure fl_sys_menu_bar_clear
           (M : in Storage.Integer_Address);
    pragma Import (C, fl_sys_menu_bar_clear, "fl_sys_menu_bar_clear");
    pragma Inline (fl_sys_menu_bar_clear);

    function fl_sys_menu_bar_clear_submenu
           (M : in Storage.Integer_Address;
            I : in Interfaces.C.int)
        return Interfaces.C.int;
    pragma Import (C, fl_sys_menu_bar_clear_submenu, "fl_sys_menu_bar_clear_submenu");
    pragma Inline (fl_sys_menu_bar_clear_submenu);




    function fl_sys_menu_bar_get_item
           (M : in Storage.Integer_Address;
            I : in Interfaces.C.int)
        return Storage.Integer_Address;
    pragma Import (C, fl_sys_menu_bar_get_item, "fl_sys_menu_bar_get_item");
    pragma Inline (fl_sys_menu_bar_get_item);




    procedure fl_sys_menu_bar_setonly
           (M, I : in Storage.Integer_Address);
    pragma Import (C, fl_sys_menu_bar_setonly, "fl_sys_menu_bar_setonly");
    pragma Inline (fl_sys_menu_bar_setonly);

    procedure fl_sys_menu_bar_replace
           (M : in Storage.Integer_Address;
            I : in Interfaces.C.int;
            T : in Interfaces.C.char_array);
    pragma Import (C, fl_sys_menu_bar_replace, "fl_sys_menu_bar_replace");
    pragma Inline (fl_sys_menu_bar_replace);

    procedure fl_sys_menu_bar_shortcut
           (M : in Storage.Integer_Address;
            I : in Interfaces.C.int;
            S : in Interfaces.C.int);
    pragma Import (C, fl_sys_menu_bar_shortcut, "fl_sys_menu_bar_shortcut");
    pragma Inline (fl_sys_menu_bar_shortcut);

    function fl_sys_menu_bar_get_mode
           (M : in Storage.Integer_Address;
            I : in Interfaces.C.int)
        return Interfaces.C.int;
    pragma Import (C, fl_sys_menu_bar_get_mode, "fl_sys_menu_bar_get_mode");
    pragma Inline (fl_sys_menu_bar_get_mode);

    procedure fl_sys_menu_bar_set_mode
           (M : in Storage.Integer_Address;
            I : in Interfaces.C.int;
            F : in Interfaces.C.int);
    pragma Import (C, fl_sys_menu_bar_set_mode, "fl_sys_menu_bar_set_mode");
    pragma Inline (fl_sys_menu_bar_set_mode);




    procedure fl_sys_menu_bar_global
           (M : in Storage.Integer_Address);
    pragma Import (C, fl_sys_menu_bar_global, "fl_sys_menu_bar_global");
    pragma Inline (fl_sys_menu_bar_global);

    procedure fl_sys_menu_bar_update
           (M : in Storage.Integer_Address);
    pragma Import (C, fl_sys_menu_bar_update, "fl_sys_menu_bar_update");
    pragma Inline (fl_sys_menu_bar_update);




    procedure fl_sys_menu_bar_draw
           (M : in Storage.Integer_Address);
    pragma Import (C, fl_sys_menu_bar_draw, "fl_sys_menu_bar_draw");
    pragma Inline (fl_sys_menu_bar_draw);

    function fl_sys_menu_bar_handle
           (M : in Storage.Integer_Address;
            E : in Interfaces.C.int)
        return Interfaces.C.int;
    pragma Import (C, fl_sys_menu_bar_handle, "fl_sys_menu_bar_handle");
    pragma Inline (fl_sys_menu_bar_handle);




    function fl_menu_value
           (M : in Storage.Integer_Address)
        return Interfaces.C.int;
    pragma Import (C, fl_menu_value, "fl_menu_value");
    pragma Inline (fl_menu_value);




    -------------------
    --  Destructors  --
    -------------------

    procedure Extra_Final
           (This : in out System_Menu_Bar) is
    begin
        Extra_Final (Menu_Bar (This));
    end Extra_Final;


    procedure Finalize
           (This : in out System_Menu_Bar) is
    begin
        Extra_Final (This);
        if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then
            free_fl_sys_menu_bar (This.Void_Ptr);
            This.Void_Ptr := Null_Pointer;
        end if;
    end Finalize;




    --------------------
    --  Constructors  --
    --------------------

    procedure Extra_Init
           (This       : in out System_Menu_Bar;
            X, Y, W, H : in     Integer;
            Text       : in     String) is
    begin
        Extra_Init (Menu_Bar (This), X, Y, W, H, Text);
    end Extra_Init;


    procedure Initialize
           (This : in out System_Menu_Bar) is
    begin
        This.Draw_Ptr     := fl_sys_menu_bar_draw'Address;
        This.Handle_Ptr   := fl_sys_menu_bar_handle'Address;
        This.Get_Item_Ptr := fl_sys_menu_bar_get_item'Address;
        This.Value_Ptr    := fl_menu_value'Address;
    end Initialize;


    package body Forge is

        function Create
               (X, Y, W, H : in Integer;
                Text       : in String := "")
            return System_Menu_Bar is
        begin
            return This : System_Menu_Bar do
                This.Void_Ptr := new_fl_sys_menu_bar
                   (Interfaces.C.int (X),
                    Interfaces.C.int (Y),
                    Interfaces.C.int (W),
                    Interfaces.C.int (H),
                    Interfaces.C.To_C (Text));
                Extra_Init (This, X, Y, W, H, Text);
            end return;
        end Create;


        function Create
               (Parent     : in out FLTK.Widgets.Groups.Group'Class;
                X, Y, W, H : in     Integer;
                Text       : in     String := "")
            return System_Menu_Bar is
        begin
            return This : System_Menu_Bar := Create (X, Y, W, H, Text) do
                Parent.Add (This);
            end return;
        end Create;

    end Forge;




    -----------------------
    --  API Subprograms  --
    -----------------------

    procedure Add
           (This : in out System_Menu_Bar;
            Text : in     String)
    is
        Added_Spot : Interfaces.C.int := fl_sys_menu_bar_add
            (This.Void_Ptr, Interfaces.C.To_C (Text));
    begin
        This.Adjust_Item_Store;
    end Add;


    function Add
           (This : in out System_Menu_Bar;
            Text : in     String)
        return Index
    is
        Added_Spot : Interfaces.C.int := fl_sys_menu_bar_add
            (This.Void_Ptr, Interfaces.C.To_C (Text));
    begin
        This.Adjust_Item_Store;
        return Index (Added_Spot + 1);
    end Add;


    procedure Add
           (This     : in out System_Menu_Bar;
            Text     : in     String;
            Action   : in     Widget_Callback := null;
            Shortcut : in     Key_Combo := No_Key;
            Flags    : in     Menu_Flag := Flag_Normal)
    is
        Added_Spot : Interfaces.C.int := fl_sys_menu_bar_add2
           (This.Void_Ptr,
            Interfaces.C.To_C (Text),
            To_C (Shortcut),
            Callback_Convert.To_Address (Action),
            Interfaces.C.int (Flags));
    begin
        This.Adjust_Item_Store;
    end Add;


    function Add
           (This     : in out System_Menu_Bar;
            Text     : in     String;
            Action   : in     Widget_Callback := null;
            Shortcut : in     Key_Combo := No_Key;
            Flags    : in     Menu_Flag := Flag_Normal)
        return Index
    is
        Added_Spot : Interfaces.C.int := fl_sys_menu_bar_add2
           (This.Void_Ptr,
            Interfaces.C.To_C (Text),
            To_C (Shortcut),
            Callback_Convert.To_Address (Action),
            Interfaces.C.int (Flags));
    begin
        This.Adjust_Item_Store;
        return Index (Added_Spot + 1);
    end Add;


    procedure Add
           (This     : in out System_Menu_Bar;
            Text     : in     String;
            Action   : in     Widget_Callback := null;
            Shortcut : in     String;
            Flags    : in     Menu_Flag := Flag_Normal)
    is
        Added_Spot : Interfaces.C.int := fl_sys_menu_bar_add3
           (This.Void_Ptr,
            Interfaces.C.To_C (Text),
            Interfaces.C.To_C (Shortcut),
            Callback_Convert.To_Address (Action),
            Interfaces.C.int (Flags));
    begin
        This.Adjust_Item_Store;
    end Add;


    function Add
           (This     : in out System_Menu_Bar;
            Text     : in     String;
            Action   : in     Widget_Callback := null;
            Shortcut : in     String;
            Flags    : in     Menu_Flag := Flag_Normal)
        return Index
    is
        Added_Spot : Interfaces.C.int := fl_sys_menu_bar_add3
           (This.Void_Ptr,
            Interfaces.C.To_C (Text),
            Interfaces.C.To_C (Shortcut),
            Callback_Convert.To_Address (Action),
            Interfaces.C.int (Flags));
    begin
        This.Adjust_Item_Store;
        return Index (Added_Spot + 1);
    end Add;


    procedure Insert
           (This     : in out System_Menu_Bar;
            Place    : in     Index;
            Text     : in     String;
            Action   : in     Widget_Callback := null;
            Shortcut : in     Key_Combo := No_Key;
            Flags    : in     Menu_Flag := Flag_Normal)
    is
        Added_Spot : Interfaces.C.int := fl_sys_menu_bar_insert
           (This.Void_Ptr,
            Interfaces.C.int (Place) - 1,
            Interfaces.C.To_C (Text),
            To_C (Shortcut),
            Callback_Convert.To_Address (Action),
            Interfaces.C.int (Flags));
    begin
        This.Adjust_Item_Store;
    end Insert;


    function Insert
           (This     : in out System_Menu_Bar;
            Place    : in     Index;
            Text     : in     String;
            Action   : in     Widget_Callback := null;
            Shortcut : in     Key_Combo := No_Key;
            Flags    : in     Menu_Flag := Flag_Normal)
        return Index
    is
        Added_Spot : Interfaces.C.int := fl_sys_menu_bar_insert
           (This.Void_Ptr,
            Interfaces.C.int (Place) - 1,
            Interfaces.C.To_C (Text),
            To_C (Shortcut),
            Callback_Convert.To_Address (Action),
            Interfaces.C.int (Flags));
    begin
        This.Adjust_Item_Store;
        return Index (Added_Spot + 1);
    end Insert;


    procedure Insert
           (This     : in out System_Menu_Bar;
            Place    : in     Index;
            Text     : in     String;
            Action   : in     Widget_Callback := null;
            Shortcut : in     String;
            Flags    : in     Menu_Flag := Flag_Normal)
    is
        Added_Spot : Interfaces.C.int := fl_sys_menu_bar_insert2
           (This.Void_Ptr,
            Interfaces.C.int (Place) - 1,
            Interfaces.C.To_C (Text),
            Interfaces.C.To_C (Shortcut),
            Callback_Convert.To_Address (Action),
            Interfaces.C.int (Flags));
    begin
        This.Adjust_Item_Store;
    end Insert;


    function Insert
           (This     : in out System_Menu_Bar;
            Place    : in     Index;
            Text     : in     String;
            Action   : in     Widget_Callback := null;
            Shortcut : in     String;
            Flags    : in     Menu_Flag := Flag_Normal)
        return Index
    is
        Added_Spot : Interfaces.C.int := fl_sys_menu_bar_insert2
           (This.Void_Ptr,
            Interfaces.C.int (Place) - 1,
            Interfaces.C.To_C (Text),
            Interfaces.C.To_C (Shortcut),
            Callback_Convert.To_Address (Action),
            Interfaces.C.int (Flags));
    begin
        This.Adjust_Item_Store;
        return Index (Added_Spot + 1);
    end Insert;


    procedure Use_Same_Items
           (This  : in out System_Menu_Bar;
            Donor : in     Menu'Class) is
    begin
        --  Donor menu() pointer will be obtained in C++
        fl_sys_menu_bar_set_menu (This.Void_Ptr, Donor.Void_Ptr);
        This.Adjust_Item_Store;
    end Use_Same_Items;


    procedure Remove
           (This  : in out System_Menu_Bar;
            Place : in     Index) is
    begin
        fl_sys_menu_bar_remove (This.Void_Ptr, Interfaces.C.int (Place) - 1);
        This.Adjust_Item_Store;
    end Remove;


    procedure Clear
           (This : in out System_Menu_Bar) is
    begin
        for Item of This.My_Items loop
            Free_Item (Item);
        end loop;
        This.My_Items.Clear;
        fl_sys_menu_bar_clear (This.Void_Ptr);
    end Clear;


    procedure Clear_Submenu
           (This  : in out System_Menu_Bar;
            Place : in     Index)
    is
        Result : Interfaces.C.int := fl_sys_menu_bar_clear_submenu
           (This.Void_Ptr,
            Interfaces.C.int (Place) - 1);
    begin
        if Result = -1 then
            raise No_Reference_Error;
        else
            pragma Assert (Result = 0);
            This.Adjust_Item_Store;
        end if;
    exception
    when Chk.Assertion_Error => raise Internal_FLTK_Error with
        "Call to Fl_Sys_Menu_Bar::clear_submenu returned unexpected int result of " &
        Interfaces.C.int'Image (Result);
    end Clear_Submenu;




    function Item
           (This  : in System_Menu_Bar;
            Place : in Index)
        return FLTK.Menu_Items.Menu_Item_Reference is
    begin
        return Menu_Bar (This).Item (Place);
    end Item;




    procedure Set_Only
           (This : in out System_Menu_Bar;
            Item : in out FLTK.Menu_Items.Menu_Item) is
    begin
        fl_sys_menu_bar_setonly (This.Void_Ptr, Wrapper (Item).Void_Ptr);
    end Set_Only;


    procedure Set_Label
           (This  : in out System_Menu_Bar;
            Place : in     Index;
            Text  : in     String) is
    begin
        fl_sys_menu_bar_replace
           (This.Void_Ptr,
            Interfaces.C.int (Place) - 1,
            Interfaces.C.To_C (Text));
    end Set_Label;


    procedure Set_Shortcut
           (This  : in out System_Menu_Bar;
            Place : in     Index;
            Press : in     Key_Combo) is
    begin
        fl_sys_menu_bar_shortcut
           (This.Void_Ptr,
            Interfaces.C.int (Place) - 1,
            To_C (Press));
    end Set_Shortcut;


    function Get_Flags
           (This  : in System_Menu_Bar;
            Place : in Index)
        return Menu_Flag is
    begin
        return Menu_Flag (fl_sys_menu_bar_get_mode (This.Void_Ptr, Interfaces.C.int (Place) - 1));
    end Get_Flags;


    procedure Set_Flags
           (This  : in out System_Menu_Bar;
            Place : in     Index;
            Flags : in     Menu_Flag) is
    begin
        fl_sys_menu_bar_set_mode
           (This.Void_Ptr,
            Interfaces.C.int (Place) - 1,
            Interfaces.C.int (Flags));
    end Set_Flags;




    procedure Make_Global
           (This : in out System_Menu_Bar) is
    begin
        fl_sys_menu_bar_global (This.Void_Ptr);
    end Make_Global;


    procedure Update
           (This : in out System_Menu_Bar) is
    begin
        fl_sys_menu_bar_update (This.Void_Ptr);
    end Update;




    procedure Draw
           (This : in out System_Menu_Bar) is
    begin
        Menu_Bar (This).Draw;
    end Draw;


end FLTK.Widgets.Menus.Menu_Bars.Systemwide;