------------------------------------------------------------------------------
-- Copyright (c) 2011, Natacha Porté                                        --
--                                                                          --
-- Permission to use, copy, modify, and distribute this software for any    --
-- purpose with or without fee is hereby granted, provided that the above   --
-- copyright notice and this permission notice appear in all copies.        --
--                                                                          --
-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES --
-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF         --
-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR  --
-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES   --
-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN    --
-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF  --
-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.           --
------------------------------------------------------------------------------

------------------------------------------------------------------------------
-- Natools.Getopt_Long is a native Ada implementation of getopt_long()      --
-- processor for command line arguments.                                    --
--                                                                          --
-- This package is generic, and its only formal parameter is a descrete     --
-- type supposed to cover all command-line options.                         --
--                                                                          --
-- Configuration objects hold the list of recognized options and parameters --
-- about how to process them. Options can have a single-character short     --
-- name or a multiple-character long name. Moreover, there is no limit to   --
-- the number of flag names referring to the same Option_Id value.          --
--                                                                          --
-- Once the Configuration object has been filled with flags recognized      --
-- by the client, the actual command-line arguments can be processed,       --
-- using the handler callbacks from a Handlers.Callback'Class object.       --
--                                                                          --
-- Callback subprograms for normal operation are Option, for command-line   --
-- flags identified by their Option_Id, and Argument, for top-level command --
-- line arguments. There are also callbacks for error conditions (missing   --
-- or unexpected argument, unknown option), whose implementation in         --
-- Handlers.Callback are simply to raise Option_Error with an appropriate   --
-- message.                                                                 --
------------------------------------------------------------------------------


with Ada.Command_Line;
private with Ada.Containers.Indefinite_Ordered_Maps;

generic
   type Option_Id is (<>);

package Natools.Getopt_Long is
   pragma Preelaborate (Getopt_Long);

   Null_Long_Name : constant String := "";
   Null_Short_Name : constant Character := Character'Val (0);



   ------------------------------------------
   -- Holder for both short and long names --
   ------------------------------------------

   type Name_Style is (Long, Short);

   type Any_Name (Style : Name_Style; Size : Positive) is record
      case Style is
         when Short =>
            Short : Character;
         when Long =>
            Long : String (1 .. Size);
      end case;
   end record;

   function To_Name (Long_Name : String) return Any_Name;
   function To_Name (Short_Name : Character) return Any_Name;
   function Image (Name : Any_Name) return String;



   ------------------------
   -- Callback interface --
   ------------------------

   Option_Error : exception;

   package Handlers is

      type Callback is abstract tagged null record;

      procedure Option
        (Handler  : in out Callback;
         Id       : Option_Id;
         Argument : String)
         is abstract;
         --  Callback for successfully-parsed options.

      procedure Argument
        (Handler  : in out Callback;
         Argument : String)
         is abstract;
         --  Callback for non-flag arguments.

      procedure Missing_Argument
        (Handler : in out Callback;
         Id      : Option_Id;
         Name    : Any_Name);
         --  Raise Option_Error (default error handler).

      procedure Unexpected_Argument
        (Handler  : in out Callback;
         Id       : Option_Id;
         Name     : Any_Name;
         Argument : String);
         --  Raise Option_Error (default error handler).

      procedure Unknown_Option
        (Handler : in out Callback;
         Name    : Any_Name);
         --  Raise Option_Error (default error handler).

   end Handlers;



   ----------------------------
   -- Configuration database --
   ----------------------------

   type Argument_Requirement is
     (No_Argument, Required_Argument, Optional_Argument);

   type Configuration is tagged private;

   procedure Add_Option
     (Config     : in out Configuration;
      Long_Name  : String;
      Short_Name : Character;
      Has_Arg    : Argument_Requirement;
      Id         : Option_Id);
      --  Add an option with both a short and a long name to the database.

   procedure Add_Option
     (Config     : in out Configuration;
      Long_Name  : String;
      Has_Arg    : Argument_Requirement;
      Id         : Option_Id);
      --  Add an option with only a long name to the database.

   procedure Add_Option
     (Config     : in out Configuration;
      Short_Name : Character;
      Has_Arg    : Argument_Requirement;
      Id         : Option_Id);
      --  Add an option with only a short name to the database.

   procedure Del_Option
     (Config     : in out Configuration;
      Id         : Option_Id);
      --  Remove from the database an option identified by its id.

   procedure Del_Option
     (Config     : in out Configuration;
      Long_Name  : String);
      --  Remove from the database an option identified by its long name.

   procedure Del_Option
     (Config     : in out Configuration;
      Short_Name : Character);
      --  Remove from the database an option identified by its short name.

   function Format_Long_Names
     (Config      : Configuration;
      Id          : Option_Id;
      Separator   : String := ", ";
      Name_Prefix : String := "--")
      return String;
      --  Return a human-readable list of long names for the given option.

   function Format_Names
     (Config            : Configuration;
      Id                : Option_Id;
      Separator         : String := ", ";
      Long_Name_Prefix  : String := "--";
      Short_Name_Prefix : String := "-";
      Short_First       : Boolean := True)
      return String;
      --  Return a human-readable list of all names for the given option.

   function Format_Short_Names
     (Config      : Configuration;
      Id          : Option_Id;
      Separator   : String := ", ";
      Name_Prefix : String := "-")
      return String;
      --  Return a human-readable list of short names for the given option.

   function Get_Long_Name
     (Config     : Configuration;
      Id         : Option_Id;
      Index      : Positive := 1)
      return String;
      --  Return the "Index"th long name for the given option id.
      --  Raise Constraint_Error when Index is not
      --     in range 1 .. Get_Long_Name_Count (Config, Id)

   function Get_Long_Name_Count
     (Config     : Configuration;
      Id         : Option_Id)
      return Natural;
      --  Return the number of long names for the given option id.

   function Get_Short_Name_Count
     (Config     : Configuration;
      Id         : Option_Id)
      return Natural;
      --  Return the number of short names for the given option id.

   function Get_Short_Names
     (Config     : Configuration;
      Id         : Option_Id)
      return String;
      --  Return a string containing the characters for short names for
      --    the given option id.

   procedure Iterate
     (Config  : Configuration;
      Process : not null access procedure (Id : Option_Id;
                                           Long_Name : String;
                                           Short_Name : Character;
                                           Has_Arg : Argument_Requirement));
      --  Iterate over all options, starting with options having a short name,
      --    followed by options having only a long name, sorted respectively by
      --    short and long name.
      --  Process is called for each option; for options lacking a long name,
      --    Long_Name is "", and for options lacking a short name, Short_Name
      --    is Character'Val (0).



   --------------------------------------
   -- Command line argument processing --
   --------------------------------------

   procedure Process
     (Config : Configuration;
      Handler : in out Handlers.Callback'Class;
      Posixly_Correct : Boolean := True;
      Long_Only : Boolean := False;
      Argument_Count : not null access function return Natural
        := Ada.Command_Line.Argument_Count'Access;
      Argument : not null access function (Number : Positive) return String
        := Ada.Command_Line.Argument'Access);
      --  Process system command line argument list, using the provided option
      --    definitions and handler callbacks.

private

   type Option (Long_Name_Length : Natural) is record
      Id : Option_Id;
      Has_Arg : Argument_Requirement;
      Long_Name : String (1 .. Long_Name_Length);
      Short_Name : Character;
   end record;

   package Long_Option_Maps is
      new Ada.Containers.Indefinite_Ordered_Maps (String, Option);

   package Short_Option_Maps is
      new Ada.Containers.Indefinite_Ordered_Maps (Character, Option);

   type Configuration is tagged record
      By_Long_Name : Long_Option_Maps.Map;
      By_Short_Name : Short_Option_Maps.Map;
   end record;

end Natools.Getopt_Long;
