Skip to content

Commit

Permalink
Merge branch 'topic/opt_parse_ref' into 'master'
Browse files Browse the repository at this point in the history 
New series of enhancements in Opt_Parse

See merge request eng/toolchain/gnatcoll-core!107
  • Loading branch information
@raph-amiard
raph-amiard committed Jun 7, 2024
2 parents 3a96c75 + 33c96fd commit 9d8dd9c
Show file tree
Hide file tree
Showing 78 changed files with 1,029 additions and 618 deletions.
100 changes: 65 additions & 35 deletions src/gnatcoll-opt_parse.adb
View file
Original file line number Diff line number Diff line change
Expand Up @@ -33,15 +33,41 @@ with GNATCOLL.VFS;

package body GNATCOLL.Opt_Parse is

generic
Short : String;
Long : String;
Name : String;
package Flag_Invariants is
pragma Assertion_Policy (Assert => Check);
-- We always want to check those assertions

pragma Assert
(Short'Length = 0 or else Short (1) = '-',
"Short flag should start with a dash");

pragma Assert
(Long'Length = 0 or else Long (1 .. 2) = "--",
"Long flag should start with two dashes");

pragma Assert
(Long'Length > 0 or else Name'Length > 0,
"Name should be non empty if there is no long flag");

pragma Assert
(Long'Length > 0 or else Short'Length > 0,
"You should have either a long or a short flag");
end Flag_Invariants;
-- This package is an helper package, helping check some invariants at
-- runtime. The neat thing about using `pragma Assert` is that in a wide
-- variety of use cases, GNAT is actually able to warn you about violating
-- those invariants at compile time.

package Cmd_Line renames Ada.Command_Line;

type XString_Vector_Access is access all XString_Vector;

function "+"
(Self : String) return XString renames To_XString;

function "+"
(Self : XString) return String renames To_String;
function "+" (Self : String) return XString renames To_XString;
function "+" (Self : XString) return String renames To_String;

function Get_Arguments (Arguments : XString_Array) return XString_Array;
-- Return the arguments in ``Arguments``, if it's not an empty array. Else,
Expand All @@ -52,6 +78,13 @@ package body GNATCOLL.Opt_Parse is
Args : XString_Array;
Pos : Positive;
New_Pos : out Parser_Return) return XString;
-- Parse one flag option, with the given ``Short`` & ``Long``
-- specifications, from the ``Args`` array, starting at ``Pos``.
-- Put the new position in ``New_Pos``. Return the option's raw value
--
-- For short arguments, this handles both ``-a B`` and ``-aB`` forms.
-- For long arguments, this handles both ``--long B`` and ``--long=B``
-- forms.

------------------
-- Text wrapper --
Expand Down Expand Up @@ -451,8 +484,9 @@ package body GNATCOLL.Opt_Parse is

procedure Handle_Failure (Error_Msg : String) is
begin
Self.Data.Last_Error := +Error_Msg;
Put_Line
("Argument parsing failed: " & Error_Msg);
(Standard_Error, "Argument parsing failed: " & Error_Msg);
end Handle_Failure;

function Internal return Boolean is
Expand Down Expand Up @@ -812,6 +846,9 @@ package body GNATCOLL.Opt_Parse is

package body Parse_Flag is

package I is new Flag_Invariants (Short, Long, Name);
pragma Unreferenced (I);

Self_Val : aliased Flag_Parser := Flag_Parser'
(Name => +(if Name /= "" then Name
else Long (3 .. Long'Last)),
Expand Down Expand Up @@ -846,13 +883,7 @@ package body GNATCOLL.Opt_Parse is
end Get;

begin
if Long = "" and Short = "" then
raise Opt_Parse_Error
with "A long or short flag must be provided for Parse_Flag";
elsif Long = "" and Name = "" then
raise Opt_Parse_Error
with "Either Long or Name must be provided for Parse_Flag";
elsif Enabled then
if Enabled then
Parser.Data.Opts_Parsers.Append (Self);
Parser.Data.All_Parsers.Append (Self);
Self.Position := Parser.Data.All_Parsers.Last_Index;
Expand All @@ -865,6 +896,9 @@ package body GNATCOLL.Opt_Parse is

package body Parse_Option is

package I is new Flag_Invariants (Short, Long, Name);
pragma Unreferenced (I);

type Option_Parser is new Parser_Type with record
null;
end record;
Expand Down Expand Up @@ -989,20 +1023,18 @@ package body GNATCOLL.Opt_Parse is
end Parse_Args;

begin
if Long = "" and Short = "" then
raise Opt_Parse_Error
with "A long or short flag must be provided for Parse_Option";
elsif Long = "" and Name = "" then
raise Opt_Parse_Error
with "Either Long or Name must be provided for Parse_Option";
elsif Enabled then
if Enabled then
Parser.Data.Opts_Parsers.Append (Self);
Parser.Data.All_Parsers.Append (Self);
Self.Position := Parser.Data.All_Parsers.Last_Index;
end if;
end Parse_Option;

package body Parse_Enum_Option is

package I is new Flag_Invariants (Short, Long, Name);
pragma Unreferenced (I);

function Convert (Arg : String) return Arg_Type;

-------------
Expand Down Expand Up @@ -1054,14 +1086,6 @@ package body GNATCOLL.Opt_Parse is
(Args : Parsed_Arguments := No_Parsed_Arguments) return Arg_Type
renames Internal_Option.Get;

begin
if Long = "" and Short = "" then
raise Opt_Parse_Error
with "A long or short flag must be provided for Parse_Enum_Option";
elsif Long = "" and Name = "" then
raise Opt_Parse_Error
with "Either Long or Name must be provided for Parse_Enum_Option";
end if;
end Parse_Enum_Option;

-----------------------
Expand All @@ -1070,6 +1094,9 @@ package body GNATCOLL.Opt_Parse is

package body Parse_Option_List is

package I is new Flag_Invariants (Short, Long, Name);
pragma Unreferenced (I);

package Result_Vectors
is new Ada.Containers.Vectors (Positive, Arg_Type);

Expand Down Expand Up @@ -1249,13 +1276,7 @@ package body GNATCOLL.Opt_Parse is
end Parse_Args;

begin
if Long = "" and Short = "" then
raise Opt_Parse_Error
with "A long or short flag must be provided for Parse_Option_List";
elsif Long = "" and Name = "" then
raise Opt_Parse_Error
with "Either Long or Name must be provided for Parse_Option_List";
elsif Enabled then
if Enabled then
Parser.Data.Opts_Parsers.Append (Self);
Parser.Data.All_Parsers.Append (Self);
Self.Position := Parser.Data.All_Parsers.Last_Index;
Expand Down Expand Up @@ -1297,6 +1318,15 @@ package body GNATCOLL.Opt_Parse is
end return;
end Create_Argument_Parser;

----------------
-- Last_Error --
----------------

function Last_Error (Self : Argument_Parser) return String is
begin
return Self.Data.Last_Error.To_String;
end Last_Error;

----------
-- Help --
----------
Expand Down
83 changes: 70 additions & 13 deletions src/gnatcoll-opt_parse.ads
View file
Original file line number Diff line number Diff line change
Expand Up @@ -107,6 +107,22 @@ package GNATCOLL.Opt_Parse is
-- raise a ``Disabled_Error`` exception. This feature is useful to disable
-- one or several options depending on some compile-time configuration
-- without using complex declarations blocks nested in ``if`` statements.
--
-- .. note:: If you can, you should activate the ``-gnatw.a`` warning when
-- using ``GNATCOLL.Opt_Parse``. This will emit warnings when you're not
-- respecting invariants in your parser declaration. For example:
--
-- .. code:: ada
--
-- package Opt is new Parse_Option
-- (Parser => Parser,
-- Arg_Type => Unbounded_String,
-- Name => "Option",
-- Help => "Help");
--
-- Will emit a warning because your option has neither a short or a long
-- flag name.


------------------------
-- General API types --
Expand Down Expand Up @@ -136,6 +152,23 @@ package GNATCOLL.Opt_Parse is
subtype XString_Vector is XString_Vectors.Vector;
-- Vector of XStrings. Used to fill unknown args in calls to ``Parse``.

-------------------------------
-- General parser primitives --
-------------------------------

function Create_Argument_Parser
(Help : String;
Command_Name : String := "";
Help_Column_Limit : Col_Type := 80) return Argument_Parser;
-- Create an argument parser with the provided help string.

function Help (Self : Argument_Parser) return String;
-- Return the help for this parser as a String.

function Last_Error (Self : Argument_Parser) return String;
-- Return the last error produced by this parser if there is one, the empty
-- string otherwise.

------------------------
-- Parse entry points --
------------------------
Expand Down Expand Up @@ -176,15 +209,6 @@ package GNATCOLL.Opt_Parse is
-- Parse command line arguments for Self. Return arguments explicitly in
-- ``Result``.

function Create_Argument_Parser
(Help : String;
Command_Name : String := "";
Help_Column_Limit : Col_Type := 80) return Argument_Parser;
-- Create an argument parser with the provided help string.

function Help (Self : Argument_Parser) return String;
-- Return the help for this parser as a String.

--------------------------
-- Conversion functions --
--------------------------
Expand Down Expand Up @@ -289,10 +313,13 @@ package GNATCOLL.Opt_Parse is
Short : String := "";
-- Short form for this flag. Should start with one dash and be followed
-- by one or two alphanumeric characters.
--
-- This can be left empty (i.e. ``Short = ""``) if you don't want this
-- argument to have a short form.

Long : String := "";
-- Long form for this flag. Should start with two dashes.
-- This can be left empty (i.e. Long = "") if you don't want this
-- This can be left empty (i.e. ``Long = ""``) if you don't want this
-- argument to have a long form. In this case you must provide a
-- non-empty Name (i.e. Name /= "") to be used in help text.

Expand All @@ -308,8 +335,14 @@ package GNATCOLL.Opt_Parse is
-- Name will be used if both Name and Long are non-empty strings.

package Parse_Flag is

----------------------
-- Public interface --
----------------------

function Get
(Args : Parsed_Arguments := No_Parsed_Arguments) return Boolean;

end Parse_Flag;
-- Parse a Flag option. A flag takes no other argument, and its result is a
-- boolean: False if the flag is not passed, True otherwise.
Expand All @@ -321,10 +354,13 @@ package GNATCOLL.Opt_Parse is
Short : String := "";
-- Short form for this flag. Should start with one dash and be followed
-- by one or two alphanumeric characters.
--
-- This can be left empty (i.e. ``Short = ""``) if you don't want this
-- argument to have a short form.

Long : String := "";
-- Long form for this flag. Should start with two dashes.
-- This can be left empty (i.e. Long = "") if you don't want this
-- This can be left empty (i.e. ``Long = ""``) if you don't want this
-- argument to have a long form. In this case you must provide a
-- non-empty Name (i.e. Name /= "") to be used in help text.

Expand Down Expand Up @@ -354,6 +390,11 @@ package GNATCOLL.Opt_Parse is
-- Name will be used if both Name and Long are non-empty strings.

package Parse_Option is

----------------------
-- Public interface --
----------------------

function Get
(Args : Parsed_Arguments := No_Parsed_Arguments) return Arg_Type;
end Parse_Option;
Expand All @@ -368,10 +409,13 @@ package GNATCOLL.Opt_Parse is
Short : String := "";
-- Short form for this flag. Should start with one dash and be followed
-- by one or two alphanumeric characters.
--
-- This can be left empty (i.e. ``Short = ""``) if you don't want this
-- argument to have a short form.

Long : String := "";
-- Long form for this flag. Should start with two dashes.
-- This can be left empty (i.e. Long = "") if you don't want this
-- This can be left empty (i.e. ``Long = ""``) if you don't want this
-- argument to have a long form. In this case you must provide a
-- non-empty Name (i.e. Name /= "") to be used in help text.

Expand Down Expand Up @@ -416,10 +460,13 @@ package GNATCOLL.Opt_Parse is
Short : String := "";
-- Short form for this flag. Should start with one dash and be followed
-- by one or two alphanumeric characters.
--
-- This can be left empty (i.e. ``Short = ""``) if you don't want this
-- argument to have a short form.

Long : String := "";
-- Long form for this flag. Should start with two dashes.
-- This can be left empty (i.e. Long = "") if you don't want this
-- This can be left empty (i.e. ``Long = ""``) if you don't want this
-- argument to have a long form. In this case you must provide a
-- non-empty Name (i.e. Name /= "") to be used in help text.

Expand Down Expand Up @@ -456,8 +503,13 @@ package GNATCOLL.Opt_Parse is

No_Results : constant Result_Array (1 .. 0) := (others => <>);

----------------------
-- Public interface --
----------------------

function Get
(Args : Parsed_Arguments := No_Parsed_Arguments) return Result_Array;

end Parse_Option_List;
-- Parse an option list. A regular option is of the form
-- "--option val, val2, val3", or "-O val val2 val3".
Expand Down Expand Up @@ -540,6 +592,10 @@ private

type Argument_Parser_Data is record
Help, Command_Name : XString;

Last_Error : XString;
-- Last error that was generated by the parser

Positional_Args_Parsers, Opts_Parsers : Parser_Vector;
All_Parsers : Parser_Vector;
Default_Result : Parsed_Arguments
Expand All @@ -549,6 +605,7 @@ private
Mutex : aliased Mutual_Exclusion;
-- Mutex used to make Get_Result thread safe
Help_Column_Limit : Col_Type := 80;

end record;

type Parser_Result is abstract tagged record
Expand Down
Loading

0 comments on commit 9d8dd9c

Please sign in to comment.