Merge branch 'topic/new_gpr_attributes' into 'master'

Add 'Rules' and 'Rule_File' GPR attributes support in GNATcheck

Closes #327

See merge request eng/libadalang/langkit-query-language!320

Author: HugoGGuerrier

lkql_checker/doc/gnatcheck_rm/using_gnatcheck.rst

@@ -331,27 +331,49 @@ the ``Check`` package in the GPR file you're providing to GNATcheck through the
 Inside this package you can define the following attributes to configure
 GNATcheck:
 
-* ``Switches``
+``Rules``
+  Value is a list of rules to enable when invoking ``gnatcheck`` on this
+  project. Values provided in this attribute behave as the ones provided with
+  the ``--rule`` switch.
+
+  If the ``--rule`` switch is set when calling ``gnatcheck`` on a project file
+  defining this attribute, then, values are concatenated.
+
+``Rule_File``
+  Value is a path to a LKQL rule file. The path is relative to the project
+  file that defines this attribute. See :ref:`LKQL_options_file` for more
+  information.
+
+  If the ``--rule-file`` switch is set when calling ``gnatcheck`` on a project
+  file defining this attribute, then, an error is emitted and ``gnatcheck``
+  will exit with an error code.
+
+``Switches``
   Index is a language name. Value is a list of additional switches to be used
   when invoking ``gnatcheck``.
 
+  If a switch is provided in both command-line and ``Switches`` attribute,
+  then, the value provided through the command-line is used.
+
   .. attention::
 
     There are several command-line switches that you cannot pass through the
     ``Switches`` attribute:
 
+    * ``--version``
+    * ``--help``
     * ``-P``
     * ``-U``
     * ``-Xname=value``
     * ``-eL``
-    * ``-r, --rule [rule_name]``
-    * ``--rule-file=filename``
+    * ``-r, --rule [rule_name]`` (use ``Rules`` attribute instead)
+    * ``--rule-file=filename`` (use ``Rule_File`` attribute instead)
 
     If you're providing one of those switches through the ``Switches`` or the
-    ``Default_Switches`` attribute, GNATcheck will raise an error message and
+    ``Default_Switches`` attribute, GNATcheck will emit an error message and
     exit with an error code.
 
-* ``Default_Switches``
+``Default_Switches``
   Same as ``Switches``, but provided additional switches will apply only if
   there is no applicable ``Switches`` attribute.
 

lkql_checker/src/gnatcheck-projects.adb

@@ -66,6 +66,10 @@ package body Gnatcheck.Projects is
    Project_File_Set : Boolean := False;
    Project_Options  : GPR2.Options.Object;
 
+   Rules_Attr            : constant GPR2.Q_Attribute_Id :=
+     (GPR2."+"("Check"), GPR2."+"("Rules"));
+   Rule_File_Attr        : constant GPR2.Q_Attribute_Id :=
+     (GPR2."+"("Check"), GPR2."+"("Rule_File"));
    Default_Switches_Attr : constant GPR2.Q_Attribute_Id :=
      (GPR2."+"("Check"), GPR2."+"("Default_Switches"));
    Switches_Attr         : constant GPR2.Q_Attribute_Id :=
@@ -179,39 +183,102 @@ package body Gnatcheck.Projects is
    --------------------------
 
    procedure Extract_Tool_Options (My_Project : in out Arg_Project_Type) is
-      Proj : constant GPR2.Project.View.Object :=
-               My_Project.Tree.Namespace_Root_Projects.First_Element;
-
       use GPR2;
       use GPR2.Project.Registry.Attribute;
 
-      Ada_Idx          : constant GPR2.Project.Attribute_Index.Object :=
+      Proj     : constant GPR2.Project.View.Object :=
+        My_Project.Tree.Namespace_Root_Projects.First_Element;
+      Ada_Idx  : constant GPR2.Project.Attribute_Index.Object :=
         GPR2.Project.Attribute_Index.Create (Ada_Language);
-      Attr             : GPR2.Project.Attribute.Object;
-      Command_Line     : GNAT.OS_Lib.Argument_List_Access;
-
-   begin
-      if Proj.Has_Attribute (Switches_Attr, Ada_Idx) then
-         Attr := Proj.Attribute (Switches_Attr, Ada_Idx);
-
-         if Attr.Kind = Single then
+      List_Val : GNAT.OS_Lib.Argument_List_Access;
+
+      function Load_List_Attribute
+        (Attr_Id : GPR2.Q_Attribute_Id;
+         Indexed : Boolean := False) return GNAT.OS_Lib.Argument_List_Access;
+      --  Load the attribute designated by ``Attr_Id`` in the project ``Proj``
+      --  as a list value, allocating and returning an ``Argument_List_Access``
+      --  that the caller must free after usage.
+      --  ``Indexed`` indicates whether the attribute ``Attr_Id`` is an indexed
+      --  attribute, if ``True`` this procedure will look at the "ada" index of
+      --  this attribute. See ``GPR2.Project.Attribute_Index`` package for more
+      --  information about attribute indexes.
+
+      function Load_Single_Attribute
+        (Attr_Id : GPR2.Q_Attribute_Id) return String;
+      --  Load the attribute designated by ``Attr_Id`` in the project ``Proj``
+      --  as a single value, returning is as a ``String``.
+
+      function Load_List_Attribute
+        (Attr_Id : GPR2.Q_Attribute_Id;
+         Indexed : Boolean := False) return GNAT.OS_Lib.Argument_List_Access
+      is
+         Attr    : constant GPR2.Project.Attribute.Object :=
+           (if Indexed
+            then Proj.Attribute (Attr_Id, Ada_Idx)
+            else Proj.Attribute (Attr_Id));
+         Res     : GNAT.OS_Lib.Argument_List_Access;
+      begin
+         if Attr.Kind /= List then
             Error
-              (String (Proj.Path_Name.Simple_Name)
-               & ": Check.Default_Switches value must be a list");
+              (String (Proj.Path_Name.Simple_Name) & ": " & Image (Attr_Id) &
+               " value must be a list");
             raise Parameter_Error;
          end if;
 
-         Command_Line := new String_List
+         Res := new String_List
            (Attr.Values.First_Index .. Attr.Values.Last_Index);
          for J in Attr.Values.First_Index .. Attr.Values.Last_Index loop
-            Command_Line (J) := new String'(Attr.Values.Element (J).Text);
+            Res (J) := new String'(Attr.Values.Element (J).Text);
+         end loop;
+
+         return Res;
+      end Load_List_Attribute;
+
+      function Load_Single_Attribute
+        (Attr_Id : GPR2.Q_Attribute_Id) return String
+      is
+         Attr : constant GPR2.Project.Attribute.Object :=
+           Proj.Attribute (Attr_Id);
+      begin
+         if Attr.Kind /= Single then
+            Error
+              (String (Proj.Path_Name.Simple_Name) & ": " & Image (Attr_Id) &
+               " value must be a single value");
+            raise Parameter_Error;
+         end if;
+
+         return Attr.Value.Text;
+      end Load_Single_Attribute;
+
+   begin
+      --  Process the rule list
+      if Proj.Has_Attribute (Rules_Attr) then
+         List_Val := Load_List_Attribute (Rules_Attr);
+         for Rule of List_Val.all loop
+            Add_Rule_By_Name (Rule.all, Prepend => True);
          end loop;
+         Free (List_Val);
+      end if;
+
+      --  Process the LKQL rule file
+      --  Process the rule list
+      if Proj.Has_Attribute (Rule_File_Attr) then
+         declare
+            Rule_File : constant String :=
+              Load_Single_Attribute (Rule_File_Attr);
+         begin
+            Set_LKQL_Rule_File
+              (My_Project.Get_Project_Relative_File (Rule_File));
+         end;
+      end if;
 
+      --  Process additional GNATcheck switches
+      if Proj.Has_Attribute (Switches_Attr, Ada_Idx) then
+         List_Val := Load_List_Attribute (Switches_Attr, Indexed => True);
          Scan_Arguments
            (My_Project => My_Project,
-            Args       => Command_Line);
-
-         Free (Command_Line);
+            Args       => List_Val);
+         Free (List_Val);
       end if;
    end Extract_Tool_Options;
 
@@ -666,6 +733,26 @@ package body Gnatcheck.Projects is
            "Builder. The first string should always be -rules to specify " &
            "that all the other options belong to the -rules section of " &
            "the parameters to 'gnatcheck'.");
+      Add
+        (Rules_Attr,
+         Index_Type           => GPR2.Project.Registry.Attribute.No_Index,
+         Value                => List,
+         Value_Case_Sensitive => False,
+         Is_Allowed_In        => Everywhere);
+      GPR2.Project.Registry.Attribute.Description.Set_Attribute_Description
+        (Rules_Attr,
+         "Value is a list of GNATcheck rule names to enable when running " &
+         "GNATcheck on this project.");
+      Add
+        (Rule_File_Attr,
+         Index_Type           => GPR2.Project.Registry.Attribute.No_Index,
+         Value                => Single,
+         Value_Case_Sensitive => True,
+         Is_Allowed_In        => Everywhere);
+      GPR2.Project.Registry.Attribute.Description.Set_Attribute_Description
+        (Rule_File_Attr,
+         "Value is the name of an LKQL rule file to use when running " &
+         "GNATcheck in this project.");
       Add
         (Switches_Attr,
          Index_Type           => Language_Index,
@@ -1002,6 +1089,21 @@ package body Gnatcheck.Projects is
       end if;
    end Add_Rule_Option;
 
+   ----------------------
+   -- Add_Rule_By_Name --
+   ----------------------
+
+   procedure Add_Rule_By_Name
+     (Rule_Name : String;
+      Prepend   : Boolean := False)
+   is
+      Lower_Rule : constant String := To_Lower (Rule_Name);
+      Prefix     : constant String :=
+        (if Lower_Rule = "all" then "+" else "+R");
+   begin
+      Add_Rule_Option (Prefix & Lower_Rule, Prepend => Prepend);
+   end Add_Rule_By_Name;
+
    ------------------------
    -- Set_LKQL_Rule_File --
    ------------------------
@@ -1152,15 +1254,16 @@ package body Gnatcheck.Projects is
       --  loop
       if Args_From_Project then
          declare
-            In_Project_Msg : constant String := "forbidden in project file";
+            In_Project_Msg : constant String :=
+              " is forbidden in project file";
          begin
-            Disallow (Arg.Aggregate_Subproject.This, In_Project_Msg);
-            Disallow (Arg.Project_File.This, In_Project_Msg);
-            Disallow (Arg.Transitive_Closure.This, In_Project_Msg);
-            Disallow (Arg.Scenario_Vars.This, In_Project_Msg);
-            Disallow (Arg.Follow_Symbolic_Links.This, In_Project_Msg);
-            Disallow (Arg.Rules.This, In_Project_Msg);
-            Disallow (Arg.Rule_File.This, In_Project_Msg);
+            Disallow (Arg.Aggregate_Subproject.This, "-A" & In_Project_Msg);
+            Disallow (Arg.Project_File.This, "-P" & In_Project_Msg);
+            Disallow (Arg.Transitive_Closure.This, "-U" & In_Project_Msg);
+            Disallow (Arg.Scenario_Vars.This, "-Xname=val" & In_Project_Msg);
+            Disallow (Arg.Follow_Symbolic_Links.This, "-eL" & In_Project_Msg);
+            Disallow (Arg.Rules.This, "-r" & In_Project_Msg);
+            Disallow (Arg.Rule_File.This, "--rule-file" & In_Project_Msg);
          end;
       end if;
 

lkql_checker/src/gnatcheck-projects.ads

@@ -249,6 +249,12 @@ package Gnatcheck.Projects is
    --  If ``Prepend`` is set to True, add the rule option at the start of
    --  the processing list.
 
+   procedure Add_Rule_By_Name
+     (Rule_Name : String;
+      Prepend   : Boolean := False);
+   --  Use ``Add_Rule_Option`` to forge a new rule option enabling the given
+   --  rule without any parameter.
+
    procedure Set_LKQL_Rule_File (File : String);
    --  Set the given ``File`` as the LKQL rule file to process during the
    --  execution of ``Process_Rule_Options``.

lkql_checker/src/gnatcheck_main.adb

@@ -4,7 +4,6 @@
 --
 
 with Ada.Calendar;
-with Ada.Characters.Handling; use Ada.Characters.Handling;
 with Ada.Command_Line;
 with Ada.Directories;
 with Ada.Environment_Variables;
@@ -468,13 +467,7 @@ begin
    --  second argument parsing to avoid duplicate rule names coming from the
    --  command-line.
    for Rule of Arg.Rules.Get loop
-      declare
-         Lower_Rule : constant String := To_Lower (To_String (Rule));
-         Prefix : constant String :=
-           (if Lower_Rule = "all" then "+" else "+R");
-      begin
-         Add_Rule_Option (Prefix & Lower_Rule, Prepend => True);
-      end;
+      Add_Rule_By_Name (To_String (Rule), Prepend => True);
    end loop;
 
    --  Then analyze the command-line parameters

testsuite/tests/gnatcheck/check_package/rule_file_attr/invalid.gpr

@@ -0,0 +1,7 @@
+project Invalid is
+   for Source_Dirs use ("src");
+
+   package Check is
+      for Rule_File use ("rule_config.lkql");
+   end Check;
+end Invalid;

testsuite/tests/gnatcheck/check_package/rule_file_attr/prj.gpr

@@ -0,0 +1,7 @@
+project Prj is
+   for Source_Dirs use ("src");
+
+   package Check is
+      for Rule_File use "rule_config.lkql";
+   end Check;
+end Prj;

testsuite/tests/gnatcheck/check_package/rule_file_attr/rule_config.lkql

@@ -0,0 +1,3 @@
+val rules = @{
+    goto_statements
+}

testsuite/tests/gnatcheck/check_package/rule_file_attr/src/main.adb

@@ -0,0 +1,5 @@
+procedure Main is
+begin
+   goto lbl;   --  FLAG (2)
+   <<lbl>>
+end Main;

testsuite/tests/gnatcheck/check_package/rule_file_attr/test.out

@@ -0,0 +1,18 @@
+Without additional rule file
+============================
+
+main.adb:3:04: goto statement
+
+With additional rule file
+=========================
+
+gnatcheck: only one LKQL configuration file is allowed
+main.adb:3:04: goto statement
+>>>program returned status code 6
+
+With invalid attribute value
+============================
+
+gnatcheck: invalid.gpr:5:11: error: attribute "Check'Rule_File" expects a single value
+try "gnatcheck --help" for more information.
+>>>program returned status code 2

testsuite/tests/gnatcheck/check_package/rule_file_attr/test.yaml

@@ -0,0 +1,9 @@
+driver: gnatcheck
+format: brief
+project: prj.gpr
+tests:
+  - label: Without additional rule file
+  - label: With additional rule file
+    lkql_rule_file: other.lkql
+  - label: With invalid attribute value
+    project: invalid.gpr