From 395e2de5b0d834091637820fc04d731721c771b7 Mon Sep 17 00:00:00 2001 From: Jed Barber Date: Fri, 16 Sep 2016 04:10:49 +1000 Subject: Adapad menus and callbacks now present in skeleton form, also Text_Buffers have callbacks too --- src/adapad.adb | 241 ++++++++++++++++++++- src/editors.adb | 53 ++++- src/editors.ads | 26 ++- src/fltk_binding/c_fl_text_buffer.cpp | 10 + src/fltk_binding/c_fl_text_buffer.h | 4 + src/fltk_binding/c_fl_text_editor.cpp | 22 ++ src/fltk_binding/c_fl_text_editor.h | 6 + src/fltk_binding/fltk-text_buffers.adb | 125 +++++++++++ src/fltk_binding/fltk-text_buffers.ads | 55 ++++- ...k-widgets-groups-text_displays-text_editors.adb | 52 +++++ ...k-widgets-groups-text_displays-text_editors.ads | 16 ++ 11 files changed, 597 insertions(+), 13 deletions(-) diff --git a/src/adapad.adb b/src/adapad.adb index 2f4c483..f1425f9 100644 --- a/src/adapad.adb +++ b/src/adapad.adb @@ -18,17 +18,36 @@ function AdaPad return Integer is Pad : aliased Editor_Window := Create (0, 0, 640, 400, "AdaPad"); - Buffer : Text_Buffer := Create; + Buff : aliased Text_Buffer := Create; + + type Editor_Callback is abstract new Widget_Callback with record - Editor : access Editor_Window; + Editor : access Editor_Window := Pad'Access; + Buffer : access Text_Buffer := Buff'Access; end record; + + + type New_Callback is new Editor_Callback with null record; + New_CB : aliased New_Callback; + + + overriding procedure Call + (This : in New_Callback; + Item : in out Widget'Class) is + begin + Ada.Text_IO.Put_Line ("New callback executed."); + end Call; + + + + type Open_Callback is new Editor_Callback with null record; - Open_CB : aliased Open_Callback := (Editor => Pad'Access); + Open_CB : aliased Open_Callback; overriding procedure Call @@ -39,17 +58,229 @@ function AdaPad return Integer is end Call; + + + type Save_Callback is new Editor_Callback with null record; + Save_CB : aliased Save_Callback; + + + overriding procedure Call + (This : in Save_Callback; + Item : in out Widget'Class) is + begin + Ada.Text_IO.Put_Line ("Save callback executed."); + end Call; + + + + + type Save_As_Callback is new Editor_Callback with null record; + Save_As_CB : aliased Save_As_Callback; + + + overriding procedure Call + (This : in Save_As_Callback; + Item : in out Widget'Class) is + begin + Ada.Text_IO.Put_Line ("Save As callback executed."); + end Call; + + + + + type Quit_Callback is new Editor_Callback with null record; + Quit_CB : aliased Quit_Callback; + + + overriding procedure Call + (This : in Quit_Callback; + Item : in out Widget'Class) is + begin + Ada.Text_IO.Put_Line ("Quit callback executed."); + end Call; + + + + + type Undo_Callback is new Editor_Callback with null record; + Undo_CB : aliased Undo_Callback; + + + overriding procedure Call + (This : in Undo_Callback; + Item : in out Widget'Class) is + begin + Ada.Text_IO.Put_Line ("Undo callback executed."); + end Call; + + + + + type Cut_Callback is new Editor_Callback with null record; + Cut_CB : aliased Cut_Callback; + + + overriding procedure Call + (This : in Cut_Callback; + Item : in out Widget'Class) is + begin + This.Editor.Cut; + end Call; + + + + + type Copy_Callback is new Editor_Callback with null record; + Copy_CB : aliased Copy_Callback; + + + overriding procedure Call + (This : in Copy_Callback; + Item : in out Widget'Class) is + begin + This.Editor.Copy; + end Call; + + + + + type Paste_Callback is new Editor_Callback with null record; + Paste_CB : aliased Paste_Callback; + + + overriding procedure Call + (This : in Paste_Callback; + Item : in out Widget'Class) is + begin + This.Editor.Paste; + end Call; + + + + + type Delete_Callback is new Editor_Callback with null record; + Delete_CB : aliased Delete_Callback; + + + overriding procedure Call + (This : in Delete_Callback; + Item : in out Widget'Class) is + begin + This.Editor.Delete; + end Call; + + + + + type Find_Callback is new Editor_Callback with null record; + Find_CB : aliased Find_Callback; + + + overriding procedure Call + (This : in Find_Callback; + Item : in out Widget'Class) is + begin + Ada.Text_IO.Put_Line ("Find callback executed."); + end Call; + + + + + type Replace_Callback is new Editor_Callback with null record; + Replace_CB : aliased Replace_Callback; + + + overriding procedure Call + (This : in Replace_Callback; + Item : in out Widget'Class) is + begin + Ada.Text_IO.Put_Line ("Replace callback executed."); + end Call; + + + + + type About_Callback is new Editor_Callback with null record; + About_CB : aliased About_Callback; + + + overriding procedure Call + (This : in About_Callback; + Item : in out Widget'Class) is + begin + Ada.Text_IO.Put_Line ("About callback executed."); + end Call; + + + + + type Mod_Callback is new Modify_Callback with null record; + Mod_CB : aliased Mod_Callback; + + + overriding procedure Call + (This : in Mod_Callback; + Action : in Modification; + Place : in Position; + Length : in Natural; + Deleted_Text : in String) is + begin + Ada.Text_IO.Put_Line ("Modify of Type: " & Modification'Image (Action) & + " Place: " & Position'Image (Place) & + " Length: " & Integer'Image (Length)); + end Call; + + + + + type Pre_Callback is new Predelete_Callback with null record; + Pre_CB : aliased Pre_Callback; + + + overriding procedure Call + (This : in Pre_Callback; + Place : in Position; + Length : in Natural) is + begin + Ada.Text_IO.Put_Line ("Predelete at Place: " & Position'Image (Place) & + " Length: " & Integer'Image (Length)); + end Call; + + begin + Buff.Add_Modify_Callback (Mod_CB'Access); + Buff.Add_Predelete_Callback (Pre_CB'Access); + + declare Bar : Menu_Cursor := Pad.Get_Menu; begin - Bar.Add ("File/Open", Open_CB'Access); + Bar.Add (Text => "&File", Shortcut => Mod_Alt + 'f', Flags => Flag_Submenu); + Bar.Add ("File/&New", New_CB'Access, Mod_Ctrl + 'n'); + Bar.Add ("File/&Open...", Open_CB'Access, Mod_Ctrl + 'o'); + Bar.Add ("File/&Save", Save_CB'Access, Mod_Ctrl + 's'); + Bar.Add ("File/Save &As...", Save_As_CB'Access, Mod_Shift + Mod_Ctrl + 's'); + Bar.Add ("File/&Quit", Quit_CB'Access, Mod_Ctrl + 'q'); + + Bar.Add (Text => "&Edit", Shortcut => Mod_Alt + 'e', Flags => Flag_Submenu); + Bar.Add ("Edit/&Undo", Undo_CB'Access, Mod_Ctrl + 'z'); + Bar.Add ("Edit/Cu&t", Cut_CB'Access, Mod_Ctrl + 'x'); + Bar.Add ("Edit/&Copy", Copy_CB'Access, Mod_Ctrl + 'c'); + Bar.Add ("Edit/&Paste", Paste_CB'Access, Mod_Ctrl + 'v'); + Bar.Add ("Edit/&Delete", Delete_CB'Access); + + Bar.Add (Text => "&Search", Shortcut => Mod_Alt + 's', Flags => Flag_Submenu); + Bar.Add ("Search/&Find...", Find_CB'Access, Mod_Ctrl + 'f'); + Bar.Add ("Search/&Replace...", Replace_CB'Access, Mod_Ctrl + 'h'); + + Bar.Add (Text => "&Help", Shortcut => Mod_Alt + 'h', Flags => Flag_Submenu); + Bar.Add ("Help/&About", About_CB'Access); end; - Pad.Set_Buffer (Buffer); + Pad.Set_Buffer (Buff); Pad.Show; return FLTK.Run; diff --git a/src/editors.adb b/src/editors.adb index 9400016..42b89ed 100644 --- a/src/editors.adb +++ b/src/editors.adb @@ -1,5 +1,9 @@ +with FLTK.Enums; +use FLTK.Enums; + + package body Editors is @@ -7,13 +11,20 @@ package body Editors is (X, Y, W, H : in Integer; Label_Text : in String) return Editor_Window is + + Width, Height : Integer; + begin + if W < 300 then Width := 300; else Width := W; end if; + if H < 60 then Height := 60; else Height := H; end if; + return This : Editor_Window := - (Double_Window'(Create (X, Y, W, H, Label_Text)) with - Editor => Text_Editor'(Create (0, 30, 640, 370, "")), - Bar => Menu_Bar'(Create (0, 0, 640, 30, ""))) do + (Double_Window'(Create (X, Y, Width, Height, Label_Text)) with + Editor => Text_Editor'(Create (0, 30, Width, Height - 30, "")), + Bar => Menu_Bar'(Create (0, 0, Width, 30, ""))) do This.Add (This.Editor); This.Add (This.Bar); + This.Editor.Set_Text_Font (Courier); end return; end Create; @@ -58,5 +69,41 @@ package body Editors is end Get_Menu; + + + procedure Cut + (This : in out Editor_Window) is + begin + This.Editor.Cut; + end Cut; + + + + + procedure Copy + (This : in out Editor_Window) is + begin + This.Editor.Copy; + end Copy; + + + + + procedure Paste + (This : in out Editor_Window) is + begin + This.Editor.Paste; + end Paste; + + + + + procedure Delete + (This : in out Editor_Window) is + begin + This.Editor.Delete; + end Delete; + + end Editors; diff --git a/src/editors.ads b/src/editors.ads index fb8b7ae..c3b6655 100644 --- a/src/editors.ads +++ b/src/editors.ads @@ -2,14 +2,12 @@ with FLTK.Widgets.Groups.Windows.Double; use FLTK.Widgets.Groups.Windows.Double; -with FLTK.Widgets.Groups.Text_Displays.Text_Editors; -use FLTK.Widgets.Groups.Text_Displays.Text_Editors; with FLTK.Widgets.Menus; use FLTK.Widgets.Menus; -with FLTK.Widgets.Menus.Menu_Bars; -use FLTK.Widgets.Menus.Menu_Bars; with FLTK.Text_Buffers; use FLTK.Text_Buffers; +private with FLTK.Widgets.Groups.Text_Displays.Text_Editors; +private with FLTK.Widgets.Menus.Menu_Bars; package Editors is @@ -44,9 +42,29 @@ package Editors is return Menu_Cursor; + procedure Cut + (This : in out Editor_Window); + + + procedure Copy + (This : in out Editor_Window); + + + procedure Paste + (This : in out Editor_Window); + + + procedure Delete + (This : in out Editor_Window); + + private + use FLTK.Widgets.Groups.Text_Displays.Text_Editors; + use FLTK.Widgets.Menus.Menu_Bars; + + type Editor_Window is new Double_Window with record Bar : aliased Menu_Bar; diff --git a/src/fltk_binding/c_fl_text_buffer.cpp b/src/fltk_binding/c_fl_text_buffer.cpp index 791e0ab..0da63c2 100644 --- a/src/fltk_binding/c_fl_text_buffer.cpp +++ b/src/fltk_binding/c_fl_text_buffer.cpp @@ -14,3 +14,13 @@ void free_fl_text_buffer(TEXTBUFFER tb) { delete reinterpret_cast(tb); } + +void fl_text_buffer_add_modify_callback(TEXTBUFFER tb, void * cb, void * ud) { + reinterpret_cast(tb)->add_modify_callback(reinterpret_cast(cb), ud); +} + + +void fl_text_buffer_add_predelete_callback(TEXTBUFFER tb, void * cb, void * ud) { + reinterpret_cast(tb)->add_predelete_callback(reinterpret_cast(cb), ud); +} + diff --git a/src/fltk_binding/c_fl_text_buffer.h b/src/fltk_binding/c_fl_text_buffer.h index 23daa03..8c1483e 100644 --- a/src/fltk_binding/c_fl_text_buffer.h +++ b/src/fltk_binding/c_fl_text_buffer.h @@ -11,5 +11,9 @@ extern "C" TEXTBUFFER new_fl_text_buffer(int rs, int pgs); extern "C" void free_fl_text_buffer(TEXTBUFFER tb); +extern "C" void fl_text_buffer_add_modify_callback(TEXTBUFFER tb, void * cb, void * ud); +extern "C" void fl_text_buffer_add_predelete_callback(TEXTBUFFER tb, void * cb, void * ud); + + #endif diff --git a/src/fltk_binding/c_fl_text_editor.cpp b/src/fltk_binding/c_fl_text_editor.cpp index 797035e..6754695 100644 --- a/src/fltk_binding/c_fl_text_editor.cpp +++ b/src/fltk_binding/c_fl_text_editor.cpp @@ -14,3 +14,25 @@ void free_fl_text_editor(TEXTEDITOR te) { delete reinterpret_cast(te); } + + + +void fl_text_editor_cut (TEXTEDITOR te) { + Fl_Text_Editor::kf_cut(0, reinterpret_cast(te)); +} + + +void fl_text_editor_copy (TEXTEDITOR te) { + Fl_Text_Editor::kf_copy(0, reinterpret_cast(te)); +} + + +void fl_text_editor_paste (TEXTEDITOR te) { + Fl_Text_Editor::kf_paste(0, reinterpret_cast(te)); +} + + +void fl_text_editor_delete (TEXTEDITOR te) { + Fl_Text_Editor::kf_delete(0, reinterpret_cast(te)); +} + diff --git a/src/fltk_binding/c_fl_text_editor.h b/src/fltk_binding/c_fl_text_editor.h index 2eda9f3..7c7cee5 100644 --- a/src/fltk_binding/c_fl_text_editor.h +++ b/src/fltk_binding/c_fl_text_editor.h @@ -11,5 +11,11 @@ extern "C" TEXTEDITOR new_fl_text_editor(int x, int y, int w, int h, char* label extern "C" void free_fl_text_editor(TEXTEDITOR te); +extern "C" void fl_text_editor_cut (TEXTEDITOR te); +extern "C" void fl_text_editor_copy (TEXTEDITOR te); +extern "C" void fl_text_editor_paste (TEXTEDITOR te); +extern "C" void fl_text_editor_delete (TEXTEDITOR te); + + #endif diff --git a/src/fltk_binding/fltk-text_buffers.adb b/src/fltk_binding/fltk-text_buffers.adb index 52f475d..fa2a259 100644 --- a/src/fltk_binding/fltk-text_buffers.adb +++ b/src/fltk_binding/fltk-text_buffers.adb @@ -1,8 +1,17 @@ with Interfaces.C; +with Interfaces.C.Strings; +with Ada.Strings.Unbounded; +with Ada.Containers; with System; use type System.Address; +use type Interfaces.C.int; +use type Interfaces.C.Strings.chars_ptr; +use type Ada.Containers.Count_Type; + + +with Ada.Text_IO; package body FLTK.Text_Buffers is @@ -17,6 +26,16 @@ package body FLTK.Text_Buffers is (TB : in System.Address); pragma Import (C, free_fl_text_buffer, "free_fl_text_buffer"); + procedure fl_text_buffer_add_modify_callback + (TB, CB, UD : in System.Address); + pragma Import (C, fl_text_buffer_add_modify_callback, + "fl_text_buffer_add_modify_callback"); + + procedure fl_text_buffer_add_predelete_callback + (TB, CB, UD : in System.Address); + pragma Import (C, fl_text_buffer_add_predelete_callback, + "fl_text_buffer_add_predelete_callback"); + @@ -33,6 +52,77 @@ package body FLTK.Text_Buffers is + procedure Modify_Callback_Hook + (Pos, Inserted, Deleted, Restyled : in Interfaces.C.int; + Text : in Interfaces.C.Strings.chars_ptr; + UD : in System.Address); + pragma Convention (C, Modify_Callback_Hook); + + procedure Modify_Callback_Hook + (Pos : in Interfaces.C.int; + Inserted, Deleted, Restyled : in Interfaces.C.int; + Text : in Interfaces.C.Strings.chars_ptr; + UD : in System.Address) is + + package UStr renames Ada.Strings.Unbounded; + + Action : Modification; + Place : Position := Position (Pos); + Length : Natural; + Deleted_Text : UStr.Unbounded_String := UStr.To_Unbounded_String (""); + + Ada_Text_Buffer : access Text_Buffer := + Text_Buffer_Convert.To_Pointer (UD); + + begin + if Inserted > 0 then + Length := Natural (Inserted); + Action := Insert; + elsif Deleted > 0 then + Length := Natural (Deleted); + Action := Delete; + if Text /= Interfaces.C.Strings.Null_Ptr then + Deleted_Text := UStr.To_Unbounded_String (Interfaces.C.Strings.Value (Text)); + end if; + elsif Restyled > 0 then + Length := Natural (Restyled); + Action := Restyle; + else + raise Program_Error; + end if; + + for CB of Ada_Text_Buffer.Modify_CBs loop + CB.Call (Action, Place, Length, UStr.To_String (Deleted_Text)); + end loop; + end Modify_Callback_Hook; + + + + + procedure Predelete_Callback_Hook + (Pos, Deleted : in Interfaces.C.int; + UD : in System.Address); + pragma Convention (C, Predelete_Callback_Hook); + + procedure Predelete_Callback_Hook + (Pos, Deleted : in Interfaces.C.int; + UD : in System.Address) is + + Place : Position := Position (Pos); + Length : Natural := Natural (Deleted); + + Ada_Text_Buffer : access Text_Buffer := + Text_Buffer_Convert.To_Pointer (UD); + + begin + for CB of Ada_Text_Buffer.Predelete_CBs loop + CB.Call (Place, Length); + end loop; + end Predelete_Callback_Hook; + + + + function Create (Requested_Size : in Natural := 0; Preferred_Gap_Size : in Natural := 1024) @@ -42,9 +132,44 @@ package body FLTK.Text_Buffers is This.Void_Ptr := new_fl_text_buffer (Interfaces.C.int (Requested_Size), Interfaces.C.int (Preferred_Gap_Size)); + + This.Modify_CBs := Modify_Vectors.Empty_Vector; + This.Predelete_CBs := Predelete_Vectors.Empty_Vector; end return; end Create; + + + procedure Add_Modify_Callback + (This : in out Text_Buffer; + Func : not null access Modify_Callback'Class) is + begin + if This.Modify_CBs.Length = 0 then + fl_text_buffer_add_modify_callback + (This.Void_Ptr, + Modify_Callback_Hook'Address, + This'Address); + end if; + This.Modify_CBs.Append (Func); + end Add_Modify_Callback; + + + + + procedure Add_Predelete_Callback + (This : in out Text_Buffer; + Func : not null access Predelete_Callback'Class) is + begin + if This.Predelete_CBs.Length = 0 then + fl_text_buffer_add_predelete_callback + (This.Void_Ptr, + Predelete_Callback_Hook'Address, + This'Address); + end if; + This.Predelete_CBs.Append (Func); + end Add_Predelete_Callback; + + end FLTK.Text_Buffers; diff --git a/src/fltk_binding/fltk-text_buffers.ads b/src/fltk_binding/fltk-text_buffers.ads index 2dae75d..aa6a49f 100644 --- a/src/fltk_binding/fltk-text_buffers.ads +++ b/src/fltk_binding/fltk-text_buffers.ads @@ -1,5 +1,9 @@ +private with Ada.Containers.Vectors; +private with System.Address_To_Access_Conversions; + + package FLTK.Text_Buffers is @@ -8,21 +12,70 @@ package FLTK.Text_Buffers is with Implicit_Dereference => Data; + type Position is new Natural; + + + type Modification is (Insert, Restyle, Delete); + type Modify_Callback is interface; + procedure Call + (This : in Modify_Callback; + Action : in Modification; + Place : in Position; + Length : in Natural; + Deleted_Text : in String) is abstract; + + + type Predelete_Callback is interface; + procedure Call + (This : in Predelete_Callback; + Place : in Position; + Length : in Natural) is abstract; + + function Create (Requested_Size : in Natural := 0; Preferred_Gap_Size : in Natural := 1024) return Text_Buffer; + procedure Add_Modify_Callback + (This : in out Text_Buffer; + Func : not null access Modify_Callback'Class); + + + procedure Add_Predelete_Callback + (This : in out Text_Buffer; + Func : not null access Predelete_Callback'Class); + + private - type Text_Buffer is new Wrapper with null record; + type Modify_Access is access all Modify_Callback'Class; + type Predelete_Access is access all Predelete_Callback'Class; + + + package Modify_Vectors is new Ada.Containers.Vectors + (Index_Type => Positive, + Element_Type => Modify_Access); + package Predelete_Vectors is new Ada.Containers.Vectors + (Index_Type => Positive, + Element_Type => Predelete_Access); + + + type Text_Buffer is new Wrapper with + record + Modify_CBs : Modify_Vectors.Vector; + Predelete_CBs : Predelete_Vectors.Vector; + end record; overriding procedure Finalize (This : in out Text_Buffer); + package Text_Buffer_Convert is new System.Address_To_Access_Conversions (Text_Buffer); + + end FLTK.Text_Buffers; diff --git a/src/fltk_binding/fltk-widgets-groups-text_displays-text_editors.adb b/src/fltk_binding/fltk-widgets-groups-text_displays-text_editors.adb index 447da2c..7969f27 100644 --- a/src/fltk_binding/fltk-widgets-groups-text_displays-text_editors.adb +++ b/src/fltk_binding/fltk-widgets-groups-text_displays-text_editors.adb @@ -18,6 +18,22 @@ package body FLTK.Widgets.Groups.Text_Displays.Text_Editors is (TE : in System.Address); pragma Import (C, free_fl_text_editor, "free_fl_text_editor"); + procedure fl_text_editor_cut + (TE : in System.Address); + pragma Import (C, fl_text_editor_cut, "fl_text_editor_cut"); + + procedure fl_text_editor_copy + (TE : in System.Address); + pragma Import (C, fl_text_editor_copy, "fl_text_editor_copy"); + + procedure fl_text_editor_paste + (TE : in System.Address); + pragma Import (C, fl_text_editor_paste, "fl_text_editor_paste"); + + procedure fl_text_editor_delete + (TE : in System.Address); + pragma Import (C, fl_text_editor_delete, "fl_text_editor_delete"); + @@ -55,5 +71,41 @@ package body FLTK.Widgets.Groups.Text_Displays.Text_Editors is end Create; + + + procedure Cut + (This : in out Text_Editor) is + begin + fl_text_editor_cut (This.Void_Ptr); + end Cut; + + + + + procedure Copy + (This : in out Text_Editor) is + begin + fl_text_editor_copy (This.Void_Ptr); + end Copy; + + + + + procedure Paste + (This : in out Text_Editor) is + begin + fl_text_editor_paste (This.Void_Ptr); + end Paste; + + + + + procedure Delete + (This : in out Text_Editor) is + begin + fl_text_editor_delete (This.Void_Ptr); + end Delete; + + end FLTK.Widgets.Groups.Text_Displays.Text_Editors; diff --git a/src/fltk_binding/fltk-widgets-groups-text_displays-text_editors.ads b/src/fltk_binding/fltk-widgets-groups-text_displays-text_editors.ads index 5b179b9..37e5464 100644 --- a/src/fltk_binding/fltk-widgets-groups-text_displays-text_editors.ads +++ b/src/fltk_binding/fltk-widgets-groups-text_displays-text_editors.ads @@ -12,6 +12,22 @@ package FLTK.Widgets.Groups.Text_Displays.Text_Editors is return Text_Editor; + procedure Cut + (This : in out Text_Editor); + + + procedure Copy + (This : in out Text_Editor); + + + procedure Paste + (This : in out Text_Editor); + + + procedure Delete + (This : in out Text_Editor); + + private -- cgit