with GNAT.Command_Line; use GNAT.Command_Line;
with GNAT.OS_Lib;       use GNAT.OS_Lib;
with Ada.Exceptions;    use Ada.Exceptions;
with Ada.Strings.Fixed; use Ada.Strings.Fixed;
with Ada.Text_IO;       use Ada.Text_IO;

with Projects.Editor; use Projects, Projects.Editor;
with Projects.Registry; use Projects.Registry;
with Projects.Support; use Projects.Support;
with Prj.Ext;       use Prj.Ext;
with Text_IO;       use Text_IO;
with Traces;        use Traces;

procedure Testsuite is
   Use_Error : exception;

   Registry     : Project_Registry;
   Root_Project : Project_Type := No_Project;

   procedure Help;
   --  Display the help message

   function Get_Argument_Advanced return String;
   --  Return the next argument on the command line, or raises Use_Error if
   --  there is none.

   function Parse_Project
     (Name : String; Append : Boolean) return Project_Type;
   --  Parse the project, and outputs any possible error directly on standard
   --  output.
   --  If Append is False, then the current tree is first deleted.

   procedure Test_Normalize;
   --  Test the normalization of project files (NORM command)

   procedure Add_Single;
   --  Test the addition of a new attribute with a single value (SINGLE
   --  command)

   procedure Add_List;
   --  Test the addition of a new attribute with a list value (LIST
   --  command)

   procedure Add_With;
   --  Add a new dependency between two project files (WITH command)

   procedure Remove_With;
   --  Remove a dependency between two project files (REMOVE_WITH command)

   procedure Add_Var;
   --  Add a new scenario variable to the project (VAR command)

   procedure Rename;
   --  Rename a project (RENAME command)

   procedure Rename_Var;
   --  Rename an external variable (RENAME_VAR command)

   procedure Add_Value;
   --  Add new values for a variable (VALUE command)

   procedure Rename_Value;
   --  Rename one of the possible values for a variable (MODIFY command)

   procedure Delete_Attribute;
   --  Remove an attribute from the current scenario (DELETE_ATTR command)

   procedure Set_Environment (Definition : String);
   --  Set a new environment variable based on the definition.
   --  Definition must be of the form "name=value"

   procedure Delete_Var;
   --  Remove one of the scenario variables (DELETE_VAR command)

   procedure Remove_Value;
   --  Remove on of the value of the variable (REMOVE_VALUE command);
   --  If the value is the last possible one for the variable, the variable
   --  itself is removed.

   procedure Pretty (Project : Project_Type);
   --  Pretty print project and its imported projects;

   function Scenario_Variables (Project : Project_Type)
      return Scenario_Variable_Array;
   --  Return the list of scenario variables (either from the root project or
   --  from Project. The root project has priority.

   procedure Report_Error2 (Line : String);
   --  Print an error message while processing a project

   function Get_Scenario_Variable (Project : Project_Type; Name : String)
      return Scenario_Variable;
   --  Search the variable Name in Project or its imported projects

   ----------
   -- Help --
   ----------

   procedure Help is
   begin
      Put_Line ("Syntax: testsuite [switches] [command] [args...]");
      New_Line;
      Put_Line ("where switches is one of");
      Put_Line ("  -Dname=value");
      Put_Line ("      set the environment variable name to value.");
      Put_Line ("  -root=project");
      Put_Line ("      define the root of the project tree, that should");
      Put_Line ("      be used for instance to find scenario variables.");
      New_Line;
      Put_Line ("and command is one of");
      Put_Line ("------ Projects ------");
      Put_Line ("  NORM file.gpr");
      Put_Line ("      normalize the file, and outputs the result.");
      Put_Line ("  WITH file.gpr [file2.gpr file3.gpr ...]");
      Put_Line ("      add new depencies in file.");
      Put_Line ("  REMOVE_WITH file.gpr file2.gpr");
      Put_Line ("      Remove a dependency from file");
      Put_Line ("  RENAME file.gpr root_project.gpr new_name");
      Put_Line ("      rename a project, in the project tree of root_project");
      Put_Line ("      prints out the modified project and the modified root");
      New_Line;
      Put_Line ("------ Attributes ------");
      Put_Line ("  SINGLE file.gpr [INDEX=idx_name] [pkg#]attr_name "
                & "attr_value");
      Put_Line ("      add an attribute with a single value to the");
      Put_Line ("      normalized project.");
      Put_Line ("      If pkg_name is specified, then the attribute is added");
      Put_Line ("      in that package.");
      Put_Line ("      If idx_name is specified, then a specific index is");
      Put_Line ("      used for the index.");
      Put_Line ("  LIST file.gpr [INDEX=idx_name] [pkg#]attr_name "
                & "[value1 value2...]");
      Put_Line ("      add an attribute with a list value to the");
      Put_Line ("      normalized project.");
      Put_Line ("  DELETE_ATTR file.gpr [pkg#]attr_name "
                & "[INDEX=idx_name]");
      Put_Line ("      Remove an attribute in the current scenario, ie fall");
      Put_Line ("      back to the default value");
      New_Line;
      Put_Line ("------ Variables ------");
      Put_Line ("  ADD_VAR file.gpr external_var list_of_values...");
      Put_Line ("      add a new scenario variable to the project");
      Put_Line ("  RENAME_VAR file.gpr ext_var_name new_name");
      Put_Line ("      Rename an external variable.");
      Put_Line ("  DELETE_VAR file.gpr ext_var_name keep_choice direct_ref");
      Put_Line ("      Remove a scenario variable. The resulting project");
      Put_Line ("      behaves as the old one when the value was keep_choice");
      Put_Line ("      If direct_ref is True, then all direct references to");
      Put_Line ("      ext_var_name are also removed.");
      Put_Line ("  MODIFY file.gpr ext_var_name old_value new_value");
      Put_Line ("      Rename one of the possible value for ext_var_name");
      Put_Line ("  VALUE file.gpr ext_var_name [value1 value2 ...]");
      Put_Line ("      Add new possible values for var_name.");
      Put_Line ("  REMOVE_VALUE file.gpr ext_var_name value");
      Put_Line ("      Remove one of the possible values for ext_var_name");
      Put_Line ("      Removing the last possible value deletes the variable");
      OS_Exit (1);
   end Help;

   ---------------------------
   -- Get_Argument_Advanced --
   ---------------------------

   function Get_Argument_Advanced return String is
      S : constant String := Get_Argument;
   begin
      if S'Length = 0 then
         raise Use_Error;
      end if;
      return S;
   end Get_Argument_Advanced;

   -------------------
   -- Report_Error2 --
   -------------------

   procedure Report_Error2 (Line : String) is
   begin
      Put_Line ("Process error: " & Line);
   end Report_Error2;

   ------------
   -- Pretty --
   ------------

   procedure Pretty (Project : Project_Type) is
      Iter : Imported_Project_Iterator := Start (Project, True);
   begin
      --  Process the project just to test we still have a valid tree.
      --  However, we do not pass these currently, since there are some
      --  duplicate sources, duplicate directories, undefined external
      --  references,...
      --  Prj.Proc.Process
      --    (Processed_Project, Project, Report_Error'Unrestricted_Access);

      while Current (Iter) /= No_Project loop
         Pretty_Print
           (Current (Iter), Eliminate_Empty_Case_Constructions => True);
         Next (Iter);
      end loop;
   end Pretty;

   -------------------
   -- Parse_Project --
   -------------------

   function Parse_Project
     (Name : String; Append : Boolean) return Project_Type
   is
      Project : Project_Type := No_Project;
      New_Project_Loaded : Boolean;
   begin
      if Append then
         Project := Load_Or_Find (Registry, Name);
      end if;

      if Project = No_Project then
         Load (Registry, Name, null, New_Project_Loaded);
         Project := Get_Root_Project (Registry);
      end if;

      pragma Assert (Project /= No_Project);

      return Project;
   end Parse_Project;

   --------------------
   -- Test_Normalize --
   --------------------

   procedure Test_Normalize is
      Project_Name : constant String := Get_Argument_Advanced;
      Project : Project_Type;
      Var     : Scenario_Variable;
      pragma Unreferenced (Var);
   begin
      Project := Parse_Project (Project_Name, False);

      --  Any modification, just to force the normalization
      Var := Create_Environment_Variable (Project, "foo", "foo_t", "foo");
      Delete_External_Variable (Project, "foo", "");

      Pretty (Project);

      if not Is_Normalized (Project) then
         Put_Line ("Project is not normalized: ");
      end if;

   exception
      when E : Normalize_Error =>
         Put_Line (Exception_Message (E));
   end Test_Normalize;

   ----------------
   -- Add_Single --
   ----------------

   procedure Add_Single is
      Project_Name : constant String := Get_Argument_Advanced;
      Arg2         : String_Access := new String'(Get_Argument_Advanced);
      Var_Name     : String_Access;
      Project      : Project_Type;
      Idx_Name     : String_Access;
   begin
      if Arg2'Length > 6
        and then Arg2 (Arg2'First .. Arg2'First + 5) = "INDEX="
      then
         Idx_Name := new String'(Arg2 (Arg2'First + 6 .. Arg2'Last));
         Free (Arg2);
         Arg2 := new String'(Get_Argument_Advanced);
      else
         Idx_Name := new String'("");
      end if;

      Var_Name := Arg2;

      declare
         Value : constant String := Get_Argument_Advanced;
      begin
         Project := Parse_Project (Project_Name, Root_Project /= No_Project);

         Update_Attribute_Value_In_Scenario
           (Project            => Project,
            Scenario_Variables => Scenario_Variables (Project),
            Attribute          => To_Attribute_Pkg (Var_Name.all),
            Value              => Value,
            Attribute_Index    => Idx_Name.all);
         Pretty (Project);
      end;

      Free (Idx_Name);
      Free (Var_Name);
   end Add_Single;

   --------------
   -- Add_List --
   --------------

   procedure Add_List is
      Project_Name : constant String := Get_Argument_Advanced;
      Arg2         : String_Access := new String'(Get_Argument_Advanced);
      Var_Name     : String_Access;
      Project      : Project_Type;
      Args : Argument_List (1 .. 100);
      Last_Args : Natural := Args'First - 1;
      Idx_Name     : String_Access;
   begin
      if Arg2'Length > 6
        and then Arg2 (Arg2'First .. Arg2'First + 5) = "INDEX="
      then
         Idx_Name := new String'(Arg2 (Arg2'First + 6 .. Arg2'Last));
         Free (Arg2);
         Arg2 := new String'(Get_Argument_Advanced);
      else
         Idx_Name := new String'("");
      end if;

      Var_Name := Arg2;

      Project := Parse_Project (Project_Name, False);

      loop
         declare
            Value : constant String := Get_Argument;
         begin
            exit when Value'Length = 0
              or else Last_Args = Args'Last;
            Last_Args := Last_Args + 1;
            Args (Last_Args) := new String'(Value);
         end;
      end loop;

      Update_Attribute_Value_In_Scenario
        (Project            => Project,
         Scenario_Variables => Scenario_Variables (Project),
         Attribute          => To_Attribute_Pkg (Var_Name.all),
         Values             => Args (1 .. Last_Args),
         Attribute_Index    => Idx_Name.all);
      Pretty (Project);

      Free (Idx_Name);
      Free (Var_Name);
   end Add_List;

   ---------------------
   -- Set_Environment --
   ---------------------

   procedure Set_Environment (Definition : String) is
      Equal_Sign_Index : constant Natural := Index (Definition, "=");
   begin
      if Equal_Sign_Index = 0 then
         raise Use_Error;
      end if;

      Prj.Ext.Add
        (Definition (Definition'First .. Equal_Sign_Index - 1),
         Definition (Equal_Sign_Index + 1 .. Definition'Last));
   end Set_Environment;

   --------------
   -- Add_With --
   --------------

   procedure Add_With is
      Original : constant String := Get_Argument_Advanced;
      Original_Project : Project_Type;
      Success : Boolean := True;
   begin
      Original_Project := Parse_Project (Original, False);

      loop
         declare
            Dep : constant String := Get_Argument;
         begin
            exit when Dep'Length = 0;
            Success := Success
              and then Add_Imported_Project
              (Original_Project, Dep, Report_Error2'Unrestricted_Access,
               Use_Relative_Path => False) = Projects.Editor.Success;
         end;
      end loop;

      if Success then
         Pretty (Original_Project);
      end if;
   end Add_With;

   -----------------
   -- Remove_With --
   -----------------

   procedure Remove_With is
      Original : constant String := Get_Argument_Advanced;
      Project  : Project_Type;
      Imported : Project_Type;
   begin
      Project := Parse_Project (Original, False);

      loop
         declare
            Dep : constant String := Get_Argument;
         begin
            exit when Dep'Length = 0;

            Imported := Parse_Project (Dep, Append => True);
            Remove_Imported_Project (Project, Imported);
         end;
      end loop;

      Pretty (Project);
   end Remove_With;

   -------------
   -- Add_Var --
   -------------

   procedure Add_Var is
      Project_Name : constant String := Get_Argument_Advanced;
      Ext_Var_Name : constant String := Get_Argument_Advanced;
      Var_Name     : String          := Ext_Var_Name;
      Project      : Project_Type;
      Var          : Scenario_Variable;
   begin
      Project := Parse_Project (Project_Name, False);

      --  Cleanup the name
      for J in Var_Name'Range loop
         if Var_Name (J) = ' ' then
            Var_Name (J) := '_';
         end if;
      end loop;

      Var := Create_Environment_Variable
        (Project,
         Name      => Var_Name,
         Type_Name => Var_Name & "_Type",
         Env_Name  => Ext_Var_Name);

      loop
         declare
            Value : constant String := Get_Argument;
         begin
            exit when Value'Length = 0;
            Add_Scenario_Variable_Values
              (Project, Var, Values => (1 => Get_String (Value)));
         end;
      end loop;

      Pretty (Project);
   end Add_Var;

   ------------
   -- Rename --
   ------------

   procedure Rename is
      Project_Name  : constant String := Get_Argument_Advanced;
      Root_Name     : constant String := Get_Argument_Advanced;
      New_Name      : constant String := Get_Argument_Advanced;
      Project, Root : Project_Type;
   begin
      Root    := Parse_Project (Root_Name, False);
      Project := Parse_Project (Project_Name, True);
      Rename_And_Move (Root, Project, New_Name, "");
      Pretty (Root);
   end Rename;

   ---------------
   -- Add_Value --
   ---------------

   procedure Add_Value is
      Project_Name : constant String := Get_Argument_Advanced;
      Ext_Var_Name : constant String := Get_Argument_Advanced;
      Project      : Project_Type;

      Values : Name_Id_Array (1 .. 100);
      Last_Values : Natural := Values'First - 1;

   begin
      Project := Parse_Project (Project_Name, False);

      loop
         declare
            Value : constant String := Get_Argument;
         begin
            exit when Value'Length = 0
              or else Last_Values = Values'Last;

            Last_Values := Last_Values + 1;
            Values (Last_Values) := Get_String (Value);
         end;
      end loop;

      Add_Scenario_Variable_Values
        (Project,
         Get_Scenario_Variable (Project, Ext_Var_Name),
         Values (Values'First .. Last_Values));

      Pretty (Project);
   end Add_Value;

   ----------------------
   -- Delete_Attribute --
   ----------------------

   procedure Delete_Attribute is
      Project_Name : constant String := Get_Argument_Advanced;
      Attr_Name    : String_Access := new String'(Get_Argument_Advanced);
      Idx_Id       : String_Access;
      Project      : Project_Type;
   begin
      declare
         Idx_Name : constant String := Get_Argument;
      begin
         if Idx_Name'Length /= 0
           and then Idx_Name'Length > 6
           and then Idx_Name (Idx_Name'First .. Idx_Name'First + 5) = "INDEX="
         then
            Idx_Id := new String'
              (Idx_Name (Idx_Name'First + 6 .. Idx_Name'Last));
         else
            Idx_Id := new String'("");
         end if;
      end;

      Project := Parse_Project (Project_Name, False);

      Delete_Attribute
        (Project,
         Scenario_Variables => Scenario_Variables (Project),
         Attribute          => To_Attribute_Pkg (Attr_Name.all),
         Attribute_Index    => Idx_Id.all);

      Pretty (Project);

      Free (Idx_Id);
      Free (Attr_Name);
   end Delete_Attribute;

   ------------------------
   -- Scenario_Variables --
   ------------------------

   function Scenario_Variables (Project : Project_Type)
      return Scenario_Variable_Array is
   begin
      if Root_Project /= No_Project then
         return Find_Scenario_Variables (Root_Project);
      else
         return Find_Scenario_Variables (Project);
      end if;
   end Scenario_Variables;

   ---------------------------
   -- Get_Scenario_Variable --
   ---------------------------

   function Get_Scenario_Variable (Project : Project_Type; Name : String)
      return Scenario_Variable
   is
      Vars : constant Scenario_Variable_Array :=
        Scenario_Variables (Project);
   begin
      for V in Vars'Range loop
         if External_Reference_Of (Vars (V)) = Name then
            return Vars (V);
         end if;
      end loop;
      return No_Variable;
   end Get_Scenario_Variable;

   ----------------
   -- Rename_Var --
   ----------------

   procedure Rename_Var is
      Project_Name  : constant String := Get_Argument_Advanced;
      Ext_Var_Name  : constant String := Get_Argument_Advanced;
      New_Name      : constant String := Get_Argument_Advanced;
      Project       : constant Project_Type :=
        Parse_Project (Project_Name, False);
      Var           : Scenario_Variable := Get_Scenario_Variable
        (Project, Ext_Var_Name);
   begin
      Rename_External_Variable (Project, Var, Get_String (New_Name));
      Pretty (Project);
   end Rename_Var;

   ----------------
   -- Delete_Var --
   ----------------

   procedure Delete_Var is
      Project_Name : constant String := Get_Argument_Advanced;
      Ext_Var_Name : constant String := Get_Argument_Advanced;
      Keep_Choice  : constant String := Get_Argument_Advanced;
      Direct_Ref   : constant Boolean :=
        Boolean'Value (Get_Argument_Advanced);
      Project      : Project_Type;
   begin
      Project := Parse_Project (Project_Name, False);

      Delete_External_Variable
        (Project, Ext_Var_Name, Keep_Choice, Direct_Ref);

      Pretty (Project);
   end Delete_Var;

   ------------------
   -- Rename_Value --
   ------------------

   procedure Rename_Value is
      Project_Name : constant String := Get_Argument_Advanced;
      Ext_Var_Name : constant String := Get_Argument_Advanced;
      Old_Value    : constant String := Get_Argument_Advanced;
      New_Value    : constant String := Get_Argument_Advanced;
      Project      : Project_Type;
   begin
      Project := Parse_Project (Project_Name, False);

      Rename_Value_For_External_Variable
        (Project, Ext_Var_Name, Old_Value, Get_String (New_Value));

      Pretty (Project);
   end Rename_Value;

   ------------------
   -- Remove_Value --
   ------------------

   procedure Remove_Value is
      Project_Name : constant String := Get_Argument_Advanced;
      Ext_Var_Name : constant String := Get_Argument_Advanced;
      Value        : constant String := Get_Argument_Advanced;
      Project      : Project_Type;
   begin
      Project := Parse_Project (Project_Name, False);

      Remove_Value (Project, Ext_Var_Name, Value);

      Pretty (Project);
   end Remove_Value;

begin
   Projects.Registry.Initialize;
   Traces.Parse_Config_File (".gnatdebug");

   loop
      case Getopt ("D: root:") is
         when 'D' =>
            Set_Environment (GNAT.Command_Line.Parameter);

         when 'r' =>
            declare
               Root_Name : constant String := Parameter;
            begin
               Root_Project := Parse_Project (Root_Name, False);
            end;

         when others =>
            exit;
      end case;
   end loop;

   declare
      Command : constant String := Get_Argument;
   begin
      if Command = "NORM" then
         Test_Normalize;

      elsif Command = "SINGLE" then
         Add_Single;

      elsif Command = "WITH" then
         Add_With;

      elsif Command = "ADD_VAR" then
         Add_Var;

      elsif Command = "RENAME" then
         Rename;

      elsif Command = "LIST" then
         Add_List;

      elsif Command = "VALUE" then
         Add_Value;

      elsif Command = "RENAME_VAR" then
         Rename_Var;

      elsif Command = "DELETE_ATTR" then
         Delete_Attribute;

      elsif Command = "DELETE_VAR" then
         Delete_Var;

      elsif Command = "MODIFY" then
         Rename_Value;

      elsif Command = "REMOVE_VALUE" then
         Remove_Value;

      elsif Command = "REMOVE_WITH" then
         Remove_With;

      elsif Command'Length /= 0 then
         Put_Line ("Unknown command: " & Command);
         Help;

      else
         Put_Line ("Unknown command: " & Command);
         Help;
      end if;
   end;

exception
   when E : Use_Error =>
      Put_Line (Exception_Information (E));
      Help;
end Testsuite;

