A set of objects are organized into a chain through which events can
propagate. The object that receives an event can either handle the
event itself, or propagate it to the next object in the chain.
In this example we model application help. If a widget receives a help
request that it can satisfy itself, it does so, providing some
context-sensitive help. Otherwise, the widget just forwards the help
request to its parent.
Implementation
Help behavior is defined by a help handler type:
package Help_Handlers is
type Help_Handler_Type is
abstract tagged limited private;
...
procedure Set_Help_Topic
(Handler : in out Help_Handler_Type;
Topic : in Help_Topic);
procedure Handle_Help
(Handler : in Help_Handler_Type) is abstract;
end Help_Handlers;
A help request is made by calling Handle_Help. Types in the derivation
class override Handle_Help to provide help if a help topic is defined
for the object, and if not, to forward the request to the next help
handler.
Widget types use an access discriminant to connect a widget to its
parent, which is also the widget's help successor:
package Widgets is
type Root_Widget_Type is
abstract new Help_Handler_Type with private;
type Widget_Type (Parent : access Root_Widget_Type'Class) is
abstract new Root_Widget_Type with private;
...
end Widgets;
Widget types that derive from Widget_Type override the Help_Handler
operation to provide type-specific help:
package Widgets.Buttons is
type Button_Widget is new Widget_Type with null record;
procedure Handle_Help (Widget : in Button_Widget);
end Widgets.Buttons;
If the button can't handle the help request itself, it forwards it to
the next help handler in the chain, its parent:
procedure Handle_Help (Widget : in Button_Widget) is
begin
if Has_Help (Widget) then
<show button help>
else
Handle_Help (Widget.Parent.all);
end if;
end Handle_Help;
The dialog widget is a top-level widget, so it doesn't have a widget
parent to whom to forward a help request. Instead, its successor is any
help handler:
package Widgets.Dialogs is
type Dialog_Widget (Handler : access Help_Handler_Type'Class) is
new Root_Widget_Type with null record;
procedure Handle_Help (Dialog : in Dialog_Widget);
end Widgets.Dialogs;
The Application_Type derives from help handler, allowing it to handle
help requests forwarded by top-level widgets:
package Applications is
type Application_Type is new Help_Handler_Type with null record;
procedure Handle_Help (Application : in Application_Type);
end Applications;
An application object is the end of the chain. It doesn't have a parent
and can't forward help requests any further, so it just displays general
help:
procedure Handle_Help (Application : in Application_Type) is
begin
<display application help>
end;
The test driver creates a widget hierarchy comprising a dialog widget
and a button widget, and binds it to an application:
procedure Test_Help is
Application : aliased Application_Type;
Dialog : aliased Dialog_Widget (Application'Access);
Button : aliased Button_Widget (Dialog'Access);
begin
Handle_Help (Button);
...
end;
The help request is propagated up the chain, until a help handler to
actually service the request is found.
The following code is ready for GNAT Chop:
--STX
with Ada.Text_IO; use Ada.Text_IO;
package body Applications is
procedure Handle_Help (Application : in Application_Type) is
begin
Put_Line ("this is help for the application");
end;
end Applications;
with Help_Handlers; use Help_Handlers;
package Applications is
type Application_Type is new Help_Handler_Type with null record;
procedure Handle_Help (Application : in Application_Type);
end Applications;
with Ada.Text_IO; use Ada.Text_IO;
package body Help_Handlers is
function Has_Help
(Handler : Help_Handler_Type) return Boolean is
begin
return Handler.Topic /= No_Help_Topic;
end;
procedure Set_Help_Topic
(Handler : in out Help_Handler_Type;
Topic : in Help_Topic) is
begin
Handler.Topic := Topic;
end;
end Help_Handlers;
with Help_Topics; use Help_Topics;
package Help_Handlers is
pragma Elaborate_Body;
type Help_Handler_Type is
abstract tagged limited private;
type Help_Handler_Access is
access all Help_Handler_Type'Class;
function Has_Help
(Handler : Help_Handler_Type) return Boolean;
procedure Set_Help_Topic
(Handler : in out Help_Handler_Type;
Topic : in Help_Topic);
procedure Handle_Help
(Handler : in Help_Handler_Type) is abstract;
private
type Help_Handler_Type is
abstract tagged limited record
Topic : Help_Topic := No_Help_Topic;
end record;
end Help_Handlers;
package Help_Topics is
pragma Pure;
type Help_Topic is new Natural;
No_Help_Topic : constant Help_Topic := 0;
end Help_Topics;
with Ada.Text_IO; use Ada.Text_IO;
with Widgets.Dialogs; use Widgets.Dialogs;
with Widgets.Buttons; use Widgets.Buttons;
with Applications; use Applications;
with Help_Topics; use Help_Topics;
procedure Test_Help is
Application : aliased Application_Type;
Dialog : aliased Dialog_Widget (Application'Access);
Button : aliased Button_Widget (Dialog'Access);
begin
Handle_Help (Button);
New_Line;
Set_Help_Topic (Dialog, 1);
Handle_Help (Button);
New_Line;
Set_Help_Topic (Button, 1);
Handle_Help (Button);
New_Line;
end Test_Help;
with Ada.Text_IO; use Ada.Text_IO;
package body Widgets.Buttons is
procedure Handle_Help (Widget : in Button_Widget) is
begin
if Has_Help (Widget) then
Put_Line ("this is help for buttons");
else
Put_Line ("button is forwarding help to its parent");
Handle_Help (Widget.Parent.all);
end if;
end Handle_Help;
end Widgets.Buttons;
package Widgets.Buttons is
type Button_Widget is new Widget_Type with null record;
procedure Handle_Help (Widget : in Button_Widget);
end Widgets.Buttons;
with Ada.Text_IO; use Ada.Text_IO;
package body Widgets.Dialogs is
procedure Handle_Help
(Dialog : in Dialog_Widget) is
begin
if Has_Help (Dialog) then
Put_Line ("this is help for dialog");
else
Put_Line ("dialog is forwarding help request to successor");
Handle_Help (Dialog.Handler.all);
end if;
end Handle_Help;
end Widgets.Dialogs;
package Widgets.Dialogs is
type Dialog_Widget (Handler : access Help_Handler_Type'Class) is
new Root_Widget_Type with null record;
procedure Handle_Help (Dialog : in Dialog_Widget);
end Widgets.Dialogs;
with Help_Handlers; use Help_Handlers;
package Widgets is
type Root_Widget_Type is
abstract new Help_Handler_Type with private;
type Widget_Type (Parent : access Root_Widget_Type'Class) is
abstract new Root_Widget_Type with private;
private
type Root_Widget_Type is
abstract new Help_Handler_Type with null record;
type Widget_Type (Parent : access Root_Widget_Type'Class) is
abstract new Root_Widget_Type with null record;
end Widgets;
|
