path: root/src/adapad.adb

with FLTK;
with Editors;
use Editors;
with FLTK.Text_Buffers;
use FLTK.Text_Buffers;
with FLTK.Widgets;
use FLTK.Widgets;
with FLTK.Widgets.Menus;
use FLTK.Widgets.Menus;
with FLTK.Popups;
use FLTK.Popups;
with Ada.Strings.Unbounded;
use Ada.Strings.Unbounded;


with Ada.Text_IO;


function AdaPad return Integer is


    Pad : aliased Editor_Window := Create (0, 0, 640, 400, "(Untitled)");
    Buff : aliased Text_Buffer := Create;

    --  these globals make me feel dirty
    --  like they should be in the buffer class or something
    Changed : Boolean := False;
    Filename : Unbounded_String := To_Unbounded_String (0);




    procedure Set_Title (Editor : access Editor_Window);
    function Cancel_Save_Discard return Choice;
    procedure Load_File (Buffer : access Text_Buffer; Name : in String);
    procedure Save_File (Buffer : access Text_Buffer; Name : in String);




    type Editor_Callback is abstract new Widget_Callback with
        record
            Editor : access Editor_Window := Pad'Access;
            Buffer : access Text_Buffer := Buff'Access;
        end record;




    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

        New_Filename : String := File_Chooser
               ("Save File As?", "*", To_String (Filename));

    begin
        if New_Filename /= "" then
            Save_File (This.Buffer, New_Filename);
        end if;
    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
        if Filename = "" then
            Save_As_CB.Call (Item);
        else
            Save_File (This.Buffer, To_String (Filename));
        end if;
    end Call;




    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
        case Cancel_Save_Discard is
            when First => return;
            when Second => Save_CB.Call (Item);
            when Third => null;
        end case;
        Filename := To_Unbounded_String (0);
        This.Buffer.Set_Selection (0, This.Buffer.Length);
        This.Buffer.Remove_Selected_Text;
        Changed := False;
        This.Buffer.Call_Modify_Callbacks;
    end Call;




    type Open_Callback is new Editor_Callback with null record;
    Open_CB : aliased Open_Callback;

    overriding procedure Call
           (This : in     Open_Callback;
            Item : in out Widget'Class) is
    begin
        case Cancel_Save_Discard is
            when First => return;
            when Second => Save_CB.Call (Item);
            when Third => null;
        end case;
        declare
            New_Filename : String := File_Chooser ("Open File?", "*", To_String (Filename));
        begin
            if New_Filename /= "" then
                Load_File (This.Buffer, New_Filename);
            end if;
        end;
    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
        case Cancel_Save_Discard is
            when First => return;
            when Second => Save_CB.Call (Item);
            when Third => null;
        end case;
        This.Editor.Hide;
    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
        This.Editor.Undo;
    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
        record
            Editor : access Editor_Window := Pad'Access;
        end 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
        if Action = Insert or Action = Delete then
            Changed := True;
        end if;
        Set_Title (This.Editor);
    end Call;




    procedure Set_Title
           (Editor : access Editor_Window) is

        Title : Unbounded_String := To_Unbounded_String (0);

    begin
        if Changed then
            Append (Title, "*");
        end if;

        if Filename = "" then
            Append (Title, "(Untitled)");
        else
            Append (Title, Filename);
        end if;

        Editor.Set_Label (To_String (Title));
    end Set_Title;




    function Cancel_Save_Discard
        return Choice is
    begin
        if not Changed then
            return Third;
        else
            return Three_Way_Choice
                   ("The current file has not been saved." & Character'Val (10) &
                    "Would you like to save it now?",
                    "Cancel", "Save", "Discard");
        end if;
    end Cancel_Save_Discard;




    procedure Load_File
           (Buffer : access Text_Buffer;
            Name   : in     String) is
    begin
        Buffer.Load_File (Name);
        Filename := To_Unbounded_String (Name);
        Changed := False;
        Buffer.Call_Modify_Callbacks;
    exception
        when Storage_Error =>
            Alert ("Error reading from file " & Name);
    end Load_File;




    procedure Save_File
           (Buffer : access Text_Buffer;
            Name   : in     String) is
    begin
        Buffer.Save_File (Name);
        Filename := To_Unbounded_String (Name);
        Changed := False;
        Buffer.Call_Modify_Callbacks;
    exception
        when Storage_Error =>
            Alert ("Error writing to file " & Name);
    end Save_File;


begin


    declare
        Bar : Menu_Cursor := Pad.Get_Menu;
    begin
        Bar.Add (Text => "&File",   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",   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", 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",   Flags => Flag_Submenu);
        Bar.Add ("Help/&About",        About_CB'Access);
    end;


    Buff.Add_Modify_Callback (Mod_CB'Access);
    Pad.Set_Buffer (Buff);
    Pad.Show;
    return FLTK.Run;


end AdaPad;