Chain of Responsibility

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;