emacs_gpr_query_1.0.2_9619300c/gpr_query.adb

--  Abstract :
--
--  Support Emacs Ada mode and gpr-query minor mode queries about
--  GNAT projects and cross reference data
--
--  Copyright (C) 2014 - 2022 Free Software Foundation All Rights Reserved.
--
--  This program is free software; you can redistribute it and/or
--  modify it under terms of the GNU General Public License as
--  published by the Free Software Foundation; either version 3, or (at
--  your option) any later version. This program is distributed in the
--  hope that it will be useful, but WITHOUT ANY WARRANTY; without even
--  the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
--  PURPOSE. See the GNU General Public License for more details. You
--  should have received a copy of the GNU General Public License
--  distributed with this program; see file COPYING. If not, write to
--  the Free Software Foundation, 51 Franklin Street, Suite 500, Boston,
--  MA 02110-1335, USA.

pragma License (GPL);

with Ada.Characters.Handling;
with Ada.Command_Line;
with Ada.Directories;
with Ada.Environment_Variables;
with Ada.Exceptions.Traceback;
with Ada.IO_Exceptions;
with Ada.Strings.Fixed;
with Ada.Strings.Unbounded;
with Ada.Text_IO;
with GNAT.Command_Line;
with GNAT.Directory_Operations;
with GNAT.OS_Lib;
with GNAT.Strings;
with GNAT.Traceback.Symbolic;
with GNATCOLL.Arg_Lists;
with GNATCOLL.Paragraph_Filling;
with GNATCOLL.Projects;
with GNATCOLL.SQL.Exec;
with GNATCOLL.SQL.Sqlite;
with GNATCOLL.Traces;
with GNATCOLL.Utils;
with GNATCOLL.VFS;
with GNATCOLL.VFS_Utils;
with GNATCOLL.Xref;
procedure Gpr_Query is
   use all type GNATCOLL.VFS.File_Array;
   use GNATCOLL;

   Version : constant String := "3";
   --  Changes once per release when the API (commands and responses)
   --  changes; must match gpr-query.el gpr-query-protocol-version

   Me : constant GNATCOLL.Traces.Trace_Handle := GNATCOLL.Traces.Create ("gpr_query");
   --  See gnatcoll-xref.adb for xref traces.

   DB_Error        : exception;
   Invalid_Command : exception;

   function "+" (Item : in Ada.Strings.Unbounded.Unbounded_String) return String
     renames Ada.Strings.Unbounded.To_String;

   function "+" (Item : in String) return Ada.Strings.Unbounded.Unbounded_String
     renames Ada.Strings.Unbounded.To_Unbounded_String;

   function "+" (Item : in GNATCOLL.VFS.Filesystem_String) return String
   is begin
      return String (Item);
   end "+";

   procedure Process_Line (Line : String);
   --  Process a full line of commands.
   --  Raise Invalid_Command when the command is invalid.

   function Get_Entity (Arg : String) return GNATCOLL.Xref.Entity_Information;
   --  Return the entity matching the "name:file:line[:column]" argument

   type My_Xref_Database is new GNATCOLL.Xref.Xref_Database with null record;
   --  Derived so we can override Image to output full paths

   Short_File_Names : Boolean; -- set by each command that calls Image
   --  Full_File_Names_Arg : constant String := "full_file_names";
   Short_File_Names_Arg : constant String := "short_file_names";

   overriding function Image (Self : My_Xref_Database; File : GNATCOLL.VFS.Virtual_File) return String;
   function Image (Self : GNATCOLL.Xref.Entity_Information) return String;
   --  Return a display version of the argument

   Xref               : aliased My_Xref_Database;
   Env                : GNATCOLL.Projects.Project_Environment_Access;
   Tree               : aliased GNATCOLL.Projects.Project_Tree;
   Source_Search_Path : GNATCOLL.VFS.File_Array_Access;

   Previous_Progress : Natural := 0;
   Progress_Reporter : access procedure (Current, Total : Integer) := null;

   --  Subprogram specs for subprograms used before bodies
   procedure Check_Arg_Count (Args : in GNATCOLL.Arg_Lists.Arg_List; Expected : in Integer);
   procedure Dump (Curs : in out GNATCOLL.Xref.Entities_Cursor'Class);
   procedure Dump (Refs : in out GNATCOLL.Xref.References_Cursor'Class; Controlling_Type_Name : in String := "");
   procedure Dump_Local (Refs : in out GNATCOLL.Xref.References_Cursor'Class; Local_File_Name : in String);
   --  Display the results of a query

   procedure Put (Item : GNATCOLL.VFS.File_Array);

   generic
      with function Compute
        (Self   : in GNATCOLL.Xref.Xref_Database'Class;
         Entity : in GNATCOLL.Xref.Entity_Information)
        return GNATCOLL.Xref.Entity_Information;
   procedure Process_Command_Single (Args : GNATCOLL.Arg_Lists.Arg_List);
   --  Get the entity identified by Args, which must contain a single
   --  argument. Then call Compute, and output the result.
   --
   --  Appropriate for queries that return a single entity result.

   procedure Process_Command_Single (Args : GNATCOLL.Arg_Lists.Arg_List)
   is
      use GNATCOLL.Arg_Lists;
      use GNATCOLL.Xref;

      Entity : Entity_Information;
      Comp   : Entity_Information;
   begin
      Check_Arg_Count (Args, 2);

      Short_File_Names := Nth_Arg (Args, 2) = Short_File_Names_Arg;

      Entity := Get_Entity (Nth_Arg (Args, 1));
      Comp := Compute (Xref, Entity);
      if Comp /= No_Entity then
         Ada.Text_IO.Put_Line (Image (Comp));
      end if;
   end Process_Command_Single;

   generic
      with procedure Compute
        (Self   : in     GNATCOLL.Xref.Xref_Database'Class;
         Entity : in     GNATCOLL.Xref.Entity_Information;
         Cursor :    out GNATCOLL.Xref.Entities_Cursor'Class);
   procedure Process_Command_Multiple (Args : GNATCOLL.Arg_Lists.Arg_List);

   procedure Process_Command_Multiple (Args : GNATCOLL.Arg_Lists.Arg_List)
   is
      use GNATCOLL.Arg_Lists;
      use GNATCOLL.Xref;

      Entity      : Entity_Information;
      Descendants : Recursive_Entities_Cursor;

      --  Apparently a generic formal parameter cannot match a subprogram access type, so we need this:
      procedure Do_Compute
        (Self   : in     GNATCOLL.Xref.Xref_Database'Class;
         Entity : in     GNATCOLL.Xref.Entity_Information;
         Cursor :    out GNATCOLL.Xref.Entities_Cursor'Class)
      is begin
         Compute (Self, Entity, Cursor);
      end Do_Compute;
   begin
      Check_Arg_Count (Args, 2);

      Short_File_Names := Nth_Arg (Args, 2) = Short_File_Names_Arg;

      Entity := Get_Entity (Nth_Arg (Args, 1));

      Recursive
        (Self    => Xref'Unchecked_Access,
         Entity  => Entity,
         Compute => Do_Compute'Unrestricted_Access,
         Cursor  => Descendants);

      Dump (Descendants);

   end Process_Command_Multiple;

   --  Command procedures; Args is the command line.
   --
   --  Infrastructure commands
   procedure Process_Help (Args : GNATCOLL.Arg_Lists.Arg_List);
   procedure Process_Refresh (Args : GNATCOLL.Arg_Lists.Arg_List);
   procedure Process_DB_Name (Args : GNATCOLL.Arg_Lists.Arg_List);

   --  Queries; alphabetical
   procedure Process_Complete (Args : GNATCOLL.Arg_Lists.Arg_List);
   procedure Process_Overridden is new Process_Command_Single (GNATCOLL.Xref.Overrides);
   procedure Process_Overriding is new Process_Command_Multiple (GNATCOLL.Xref.Overridden_By);
   procedure Process_Parent_Types is new Process_Command_Multiple (GNATCOLL.Xref.Parent_Types);
   procedure Process_Project_Path (Args : GNATCOLL.Arg_Lists.Arg_List);
   procedure Process_Refs (Args : GNATCOLL.Arg_Lists.Arg_List);      -- wisi-xref-all
   procedure Process_Tree_Defs (Args : GNATCOLL.Arg_Lists.Arg_List); -- wisi-xref-definitions
   procedure Process_Tree_Refs (Args : GNATCOLL.Arg_Lists.Arg_List); -- wisi-xref-references
   procedure Process_Source_Dirs (Args : GNATCOLL.Arg_Lists.Arg_List);

   type Command_Descr is record
      Name    : GNAT.Strings.String_Access;
      Args    : GNAT.Strings.String_Access;
      Help    : GNAT.Strings.String_Access;
      Handler : not null access procedure (Args : GNATCOLL.Arg_Lists.Arg_List);
   end record;

   Commands : constant array (Natural range <>) of Command_Descr :=
     ((new String'("help"),
       new String'("[command or variable name]"),
       new String'("Display the list of commands and their syntax."),
       Process_Help'Access),

      (new String'("refresh"),
       null,
       new String'("Refresh the contents of the xref database."),
       Process_Refresh'Access),

      (new String'("db_name"),
       null,
       new String'("Report the root name of the database files."),
       Process_DB_Name'Access),

      --  queries

      (new String'("complete"),
       new String'("pattern"),
       new String'("Names that complete the pattern."),
       Process_Complete'Access),

      (new String'("overridden"),
       new String'("name:file:line[:column] {full_file_names | short_file_names}"),
       new String'("The entity that is overridden by the parameter"),
       Process_Overridden'Access),

      (new String'("overriding"),
       new String'("name:file:line[:column] {full_file_names | short_file_names}"),
       new String'("The entities that override the parameter"),
       Process_Overriding'Access),

      (new String'("parent_types"),
       new String'("name:file:line[:column] {full_file_names | short_file_names}"),
       new String'("The parent types of the entity."),
       Process_Parent_Types'Access),

      (new String'("project_path"),
       null,
       new String'("The project search path."),
       Process_Project_Path'Access),

      (new String'("refs"),
       new String'("name:file:line[:column] {global | local_only} {full_file_names | short_file_names}"),
       new String'("All known references to the entity."),
       Process_Refs'Access),

      (new String'("tree_defs"),
       new String'("name:file[:line[:column]] {full_file_names | short_file_names}"),
       new String'
         ("All known references to the entity, and to child types or overridden/overriding operations."),
       Process_Tree_Defs'Access),

      (new String'("tree_refs"),
       new String'("name:file:line[:column] {full_file_names | short_file_names}"),
       new String'
         ("All known references to the entity, and to parent/child types or overridden/overriding operations."),
       Process_Tree_Refs'Access),

      (new String'("source_dirs"),
       null,
       new String'("The project source directories, recursively."),
       Process_Source_Dirs'Access));

   --  Parsed command line info
   Cmdline              : GNAT.Command_Line.Command_Line_Configuration;

   ALI_Encoding         : aliased GNAT.Strings.String_Access := new String'("");
   Commands_From_Switch : aliased GNAT.Strings.String_Access;
   DB_Name              : aliased GNAT.Strings.String_Access := new String'("gpr_query.db");
   Force_Refresh        : aliased Boolean;
   Gpr_Config_File      : aliased GNAT.Strings.String_Access;
   Nightly_DB_Name      : aliased GNAT.Strings.String_Access;
   Project_File_Name    : aliased GNAT.Strings.String_Access;
   Show_Progress        : aliased Boolean;
   Traces_Config_File   : aliased GNAT.Strings.String_Access;

   ----------
   --  Procedure bodies, alphabetical

   procedure Check_Arg_Count (Args : in GNATCOLL.Arg_Lists.Arg_List; Expected : in Integer)
   is
      Count : constant Integer := GNATCOLL.Arg_Lists.Args_Length (Args);
   begin
      if Count /= Expected then
         raise Invalid_Command with "Invalid number of arguments" & Integer'Image (Count) &
           "; expecting" & Integer'Image (Expected);
      end if;
   end Check_Arg_Count;

   procedure Display_Progress (Current, Total : Integer) is
      Now : constant Integer := Integer (Float'Floor (Float (Current) / Float (Total) * 100.0));
   begin
      if Now /= Previous_Progress then
         Ada.Text_IO.Put_Line
           ("completed" & Current'Img
              & " out of" & Total'Img
              & " (" & GNATCOLL.Utils.Image (Now, Min_Width => 0) & "%)...");
         Previous_Progress := Now;
      end if;
   end Display_Progress;

   procedure Dump (Curs : in out GNATCOLL.Xref.Entities_Cursor'Class)
   is
      use GNATCOLL.Xref;
   begin
      while Curs.Has_Element loop
         Ada.Text_IO.Put_Line (Image (Curs.Element));
         Curs.Next;
      end loop;
   end Dump;

   procedure Dump (Refs : in out GNATCOLL.Xref.References_Cursor'Class; Controlling_Type_Name : in String := "")
   is
      use GNATCOLL.Xref;
   begin
      while Has_Element (Refs) loop
         declare
            Ref : constant Entity_Reference := Refs.Element;
         begin
            Ada.Text_IO.Put_Line
              (Xref.Image (Ref) & " (" &
                 (if Controlling_Type_Name'Length = 0
                  then ""
                  else Controlling_Type_Name & "; ") &
                 (+Ref.Kind) & ")");
         end;
         Next (Refs);
      end loop;
   end Dump;

   procedure Dump_Local (Refs : in out GNATCOLL.Xref.References_Cursor'Class; Local_File_Name : in String)
   is
      use GNATCOLL.Xref;
   begin
      while Has_Element (Refs) loop
         declare
            Ref : constant Entity_Reference := Refs.Element;
         begin
            if Local_File_Name = "" or else Local_File_Name = Ref.File.Display_Base_Name then
               Ada.Text_IO.Put_Line (Xref.Image (Ref) & " (" & (+Ref.Kind) & ")");
            end if;
         end;
         Next (Refs);
      end loop;
   end Dump_Local;

   function Get_Entity (Arg : String) return GNATCOLL.Xref.Entity_Information
   is
      use GNAT.Directory_Operations;
      use GNATCOLL.Xref;

      Words : GNAT.Strings.String_List_Access := GNATCOLL.Utils.Split (Arg, On => ':');
      Ref   : GNATCOLL.Xref.Entity_Reference;
   begin
      case Words'Length is
      when 4         =>
         Ref := Xref.Get_Entity
           (Name     => Words (Words'First).all,
            File     => Format_Pathname
              (Style => UNIX,
               Path  => Words (Words'First + 1).all),
            Project  => GNATCOLL.Projects.No_Project,
            Line     => Integer'Value (Words (Words'First + 2).all),
            Column   => Visible_Column
              (Integer'Value (Words (Words'First + 3).all)));

      when 3 =>
         --  No column; assume good enough for a precise match
         Ref := Xref.Get_Entity
           (Name     => Words (Words'First).all,
            File     => Format_Pathname
              (Style => UNIX,
               Path  => Words (Words'First + 1).all),
            Project  => GNATCOLL.Projects.No_Project,
            Line     => Integer'Value (Words (Words'First + 2).all));

      when 2 =>
         --  No line or column; error.
         GNAT.Strings.Free (Words);
         raise Invalid_Command with "Invalid parameter '" & Arg & "', expecting name:file:line[:column]]";

      when others =>
         --  No file, or bad args.
         --
         --  Xref.Get_Entity treats 'File => ""' as searching for pre-defined entities such as "Integer".
         --
         --  To search for a name in all files, use "complete" command.
         GNAT.Strings.Free (Words);

         raise Invalid_Command with "Invalid parameter '" & Arg & "', expecting name:file:line[:column]]";
      end case;

      GNAT.Strings.Free (Words);

      if Ref.Entity = GNATCOLL.Xref.No_Entity then
         Ada.Text_IO.Put_Line ("Error: entity not found '" & Arg & "'");

      elsif GNATCOLL.Xref.Is_Fuzzy_Match (Ref.Entity) then
         Ada.Text_IO.Put_Line ("warning: fuzzy match for the entity");
      end if;

      return Ref.Entity;
   end Get_Entity;

   overriding function Image (Self : My_Xref_Database; File : GNATCOLL.VFS.Virtual_File) return String
   is
      pragma Unreferenced (Self);
   begin
      if Short_File_Names then
         return File.Display_Base_Name;
      else
         return File.Display_Full_Name;
      end if;
   end Image;

   function Image (Self : GNATCOLL.Xref.Entity_Information) return String
   is
      use GNATCOLL.Xref;
   begin
      if Self = No_Entity then
         return "Unknown entity";
      else
         declare
            Decl : constant Entity_Declaration := Xref.Declaration (Self);
         begin
            if Is_Predefined_Entity (Decl) then
               return "predefined entity: " & (+Decl.Name);
            else
               return Xref.Image (Decl.Location);
            end if;
         end;
      end if;
   end Image;

   procedure Process_DB_Name (Args : GNATCOLL.Arg_Lists.Arg_List)
   is
      pragma Unreferenced (Args);
   begin
      Ada.Text_IO.Put_Line (DB_Name.all);
   end Process_DB_Name;

   procedure Process_Help (Args : GNATCOLL.Arg_Lists.Arg_List)
   is
      use Ada.Text_IO;
      use GNATCOLL.Arg_Lists;
      use type GNAT.Strings.String_Access;
   begin
      for C in Commands'Range loop
         if Args_Length (Args) <= 0 -- Empty_Command_Line returns -1
           or else Nth_Arg (Args, 1) = Commands (C).Name.all
         then
            Put ("  " & Commands (C).Name.all);
            if Commands (C).Args = null then
               New_Line;
            else
               Put_Line (" " & Commands (C).Args.all);
            end if;

            Put
              (Ada.Strings.Unbounded.To_String
                 (GNATCOLL.Paragraph_Filling.Knuth_Fill
                    (Commands (C).Help.all,
                     Max_Line_Length => 70,
                     Line_Prefix     => "      ")));
         end if;
      end loop;
      New_Line;
      Put_Line ("'exit' to quit");
   end Process_Help;

   procedure Process_Line (Line : String)
   is
      Expr : GNAT.Strings.String_List_Access;
   begin
      if Ada.Strings.Fixed.Trim (Line, Ada.Strings.Both) = "" then
         return;
      end if;

      Expr := GNATCOLL.Utils.Split (Line, On => ';');

      for C in Expr'Range loop
         if Ada.Strings.Fixed.Trim (Expr (C).all, Ada.Strings.Both) = "" then
            null;

         else
            declare
               use GNATCOLL.Arg_Lists;
               List  : constant Arg_List := Parse_String (Expr (C).all, Mode => Separate_Args);
               Cmd   : constant String   := Ada.Characters.Handling.To_Lower (Get_Command (List));
               Found : Boolean           := False;
            begin
               for Co in Commands'Range loop
                  if Commands (Co).Name.all = Cmd then
                     Commands (Co).Handler (List);
                     Found := True;
                     exit;
                  end if;
               end loop;

               if not Found then
                  raise Invalid_Command with "Invalid command: '" & Cmd & "'";
               end if;
            end;

         end if;
      end loop;

      GNAT.Strings.Free (Expr);
   end Process_Line;

   function Get_Parameters (Entity : GNATCOLL.Xref.Entity_Information) return String
   is
      use Ada.Strings.Unbounded;
      use GNATCOLL.Xref;
      Params     : Parameters_Cursor := GNATCOLL.Xref.Parameters (Xref, Entity);
      Result     : Unbounded_String;
      Need_Paren : Boolean           := True;
   begin
      loop
         exit when not Has_Element (Params);
         Result := Result &
           ((if Need_Paren
             then (if Length (Result) > 0 then " (" else "(")
             else ", ") &
              Xref.Declaration (Element (Params).Parameter).Name);
         Need_Paren := False;
         Next (Params);
      end loop;
      if not Need_Paren then
         Result := Result & ")";
      end if;
      return +Result;
   end Get_Parameters;

   procedure Process_Complete (Args : GNATCOLL.Arg_Lists.Arg_List)
   is
      use Ada.Text_IO;
      use GNATCOLL.Arg_Lists;
      use GNATCOLL.Xref;
      Prefix  : constant String := Nth_Arg (Args, 1);
      Matches : Entities_Cursor;
      Count   : Integer         := 0;
   begin
      Short_File_Names := False;

      --  First count all matches, so Emacs can show progress
      Xref.From_Prefix
        (Prefix,
         Is_Partial => True,
         Cursor     => Matches);
      loop
         exit when not Has_Element (Matches);
         Count := @ + 1;
         Next (Matches);
      end loop;

      Ada.Text_IO.Put_Line ("element count" & Count'Image);

      Xref.From_Prefix
        (Prefix,
         Is_Partial => True,
         Cursor     => Matches);
      loop
         exit when not Has_Element (Matches);
         declare
            Decl : constant Entity_Declaration := Xref.Declaration (Element (Matches));
         begin
            Put (Xref.Qualified_Name (Element (Matches)));
            if Decl.Flags.Is_Subprogram then
               Ada.Text_IO.Put (Get_Parameters (Decl.Location.Entity));
            end if;
         end;
         Ada.Text_IO.Put_Line (" " & Image (Element (Matches)));
         Next (Matches);
      end loop;
   end Process_Complete;

   procedure Process_Project_Path (Args : GNATCOLL.Arg_Lists.Arg_List)
   is
      pragma Unreferenced (Args);
      Dirs : constant GNATCOLL.VFS.File_Array := GNATCOLL.Projects.Predefined_Project_Path (Env.all);
   begin
      Short_File_Names := False;
      Put (Dirs);
   end Process_Project_Path;

   procedure Process_Refresh (Args : GNATCOLL.Arg_Lists.Arg_List)
   is
      pragma Unreferenced (Args);
   begin
      Parse_All_LI_Files
        (Self                => Xref,
         Project             => Tree.Root_Project,
         Parse_Runtime_Files => False,
         Show_Progress       => Progress_Reporter,
         ALI_Encoding        => ALI_Encoding.all,
         From_DB_Name        => Nightly_DB_Name.all,
         To_DB_Name          => DB_Name.all,
         Force_Refresh       => Force_Refresh);
   end Process_Refresh;

   procedure Process_Refs (Args : GNATCOLL.Arg_Lists.Arg_List)
   is
      use GNATCOLL.Arg_Lists;
   begin
      Check_Arg_Count (Args, 3); --  entity, local/global, full/short

      Short_File_Names := Nth_Arg (Args, 3) = Short_File_Names_Arg;

      declare
         use GNATCOLL.Xref;
         Entity : constant Entity_Information := Get_Entity (Nth_Arg (Args, 1));
         Refs   : References_Cursor;
      begin
         Xref.References (Entity, Refs);
         if Nth_Arg (Args, 2) = "local_only" then
            --  Xref doesn't let us get the full file name of Entity (sigh)
            declare
               use Ada.Strings.Fixed;
               First           : constant Integer := 1 + Index (Nth_Arg (Args, 1), ":");
               Last            : constant Integer := -1 + Index (Nth_Arg (Args, 1), ":", First);
               Local_File_Name : constant String  := Nth_Arg (Args, 1) (First .. Last);
            begin
               Dump_Local (Refs, Local_File_Name);
            end;
         else
            Dump (Refs);
         end if;
      end;
   end Process_Refs;

   function Has_Op
     (Entity            : in GNATCOLL.Xref.Entity_Information;
      Primitive_Op_Name : in String := "")
     return Boolean
   is
      use GNATCOLL.Xref;
      Ops : Entities_Cursor;
   begin
      Xref.Methods (Entity, Ops);
      loop
         exit when not Has_Element (Ops);
         if Primitive_Op_Name = +Xref.Declaration (Element (Ops)).Name then
            return True;
         end if;
         Next (Ops);
      end loop;
      return False;
   end Has_Op;

   function Root_Parent_Type
     (Entity            : in GNATCOLL.Xref.Entity_Information;
      Primitive_Op_Name : in String  := "")
     return GNATCOLL.Xref.Entity_Information
   is
      use GNATCOLL.Xref;
      Result  : Entity_Information := Entity;
      Parents : Entities_Cursor;
   begin
      loop
         Xref.Parent_Types (Result, Parents);
         --  There is more than one parent when the type inherits interfaces.
         --  We assume the first parent is a non-interface (if there is one),
         --  and ignore the rest.
         exit when (not Parents.Has_Element) or else
           (Primitive_Op_Name'Length > 0 and then not Has_Op (Parents.Element, Primitive_Op_Name));
         Result := Parents.Element;
      end loop;
      return Result;
   end Root_Parent_Type;

   procedure All_Child_Types
     (Entity : in GNATCOLL.Xref.Entity_Information;
      Cursor : in out GNATCOLL.Xref.Recursive_Entities_Cursor)
   is begin
      GNATCOLL.Xref.Recursive
        (Self    => Xref'Unchecked_Access,
         Entity  => Entity,
         Compute => GNATCOLL.Xref.Child_Types'Access,
         Cursor  => Cursor);
   end All_Child_Types;

   function Controlling_Type (Entity : in GNATCOLL.Xref.Entity_Information) return GNATCOLL.Xref.Entity_Information
   is
      use GNATCOLL.Xref;
      --  Method_Of returns a derived type if the subprogram is not
      --  overridden for the child; the type we want is the non-child; the
      --  last item in Controlling_Types.
      Types  : Entities_Cursor;
      Result : Entity_Information := No_Entity;
   begin
      Xref.Method_Of (Entity, Types);
      loop
         exit when not Has_Element (Types);
         Result := Types.Element;
         Next (Types);
      end loop;
      return Result;
   end Controlling_Type;

   procedure Dump_Decl (Decl : in GNATCOLL.Xref.Entity_Declaration; Annotation : in String := "")
   is begin
      Ada.Text_IO.Put_Line
        (Xref.Image (Decl.Location) & " (" &
           (+Decl.Name) & " " &
           (if Annotation'Length = 0
            then ""
            else Annotation & " ") &
           (+Decl.Kind) & ")");
   end Dump_Decl;

   procedure Dump_Ref (Ref : in GNATCOLL.Xref.Entity_Reference; Annotation : in String := "")
   is begin
      Ada.Text_IO.Put_Line
        (Xref.Image (Ref) & " (" &
           (+Xref.Declaration (Ref.Entity).Name) & " " &
           (if Annotation'Length = 0
            then ""
            else Annotation & " ") &
           (+Ref.Kind) & ")");
   end Dump_Ref;

   procedure Dump_Entity (Entity : in GNATCOLL.Xref.Entity_Information; Controlling_Type_Name : in String := "")
   is
      use Ada.Strings.Unbounded;
      use GNATCOLL.Xref;
      Spec_Decl : constant Entity_Declaration := Xref.Declaration (Entity);
      Body_Decls : References_Cursor;
      Parameters : Unbounded_String;
   begin
      if Controlling_Type_Name'Length > 0 then
         Parameters := +Controlling_Type_Name & ";";
      end if;

      if Spec_Decl.Flags.Is_Subprogram then
         Parameters := Parameters & Get_Parameters (Spec_Decl.Location.Entity);
      end if;

      Xref.Bodies (Entity, Body_Decls);
      if not Has_Element (Body_Decls) then
         Dump_Decl (Spec_Decl, +Parameters);
      else
         declare
            use all type GNATCOLL.VFS.Virtual_File;
            First_Body_Ref : constant Entity_Reference := Body_Decls.Element;
         begin
            if First_Body_Ref.File = Spec_Decl.Location.File and
              First_Body_Ref.Line = Spec_Decl.Location.Line and
              First_Body_Ref.Column = Spec_Decl.Location.Column
            then
               Ada.Text_IO.Put_Line
                 (Xref.Image (First_Body_Ref) & " (" & (+Spec_Decl.Name) & " " &
                    (if Length (Parameters) = 0
                     then ""
                     else +Parameters & " ") &
                    (+Spec_Decl.Kind) & "/" & (+First_Body_Ref.Kind) & ")");
            else
               Dump_Decl (Spec_Decl, +Parameters);
               Dump_Ref (First_Body_Ref, +Parameters);
            end if;
         end;

         Next (Body_Decls);

         loop
            exit when not Has_Element (Body_Decls);
            Dump_Ref (Body_Decls.Element, +Parameters);
            Next (Body_Decls);
         end loop;
      end if;
   end Dump_Entity;

   procedure Process_Tree_Defs (Args : GNATCOLL.Arg_Lists.Arg_List)
   is
      --  "tree_defs" <name:loc> {short_file_names | full_file_names}

      use GNATCOLL.Arg_Lists;
      use GNATCOLL.Xref;

      Words       : GNAT.Strings.String_List_Access := GNATCOLL.Utils.Split (Nth_Arg (Args, 1), On => ':');
      Root_Parent : Entity_Information;

      procedure One_Entity (Orig_Entity : in Entity_Information; No_Children : in Boolean := False)
      is
         Orig_Decl       : constant Entity_Declaration := Xref.Declaration (Orig_Entity);
         Orig_Short_Name : constant String             := +Orig_Decl.Name;

         procedure Dump_Method
           (Type_Entity       : in GNATCOLL.Xref.Entity_Information;
            Primitive_Op_Name : in String)
         is
            Type_Name : constant String := Xref.Qualified_Name (Type_Entity);
            Ops       : Entities_Cursor;
         begin
            Xref.Methods (Type_Entity, Ops);
            loop
               exit when not Has_Element (Ops);
               declare
                  Method_Name : constant String := +Xref.Declaration (Element (Ops)).Name;
               begin
                  if Primitive_Op_Name = Method_Name then
                     --  IMPROVEME: if the method is inherited but not overridden, use the
                     --  type location.
                     Dump_Entity (Element (Ops), Type_Name);
                  end if;
               end;
               Next (Ops);
            end loop;
         end Dump_Method;

         procedure Dump_Entities (Entities : in out Recursive_Entities_Cursor)
         is begin
            loop
               exit when not Has_Element (Entities);
               if Orig_Decl.Flags.Is_Subprogram then
                  Dump_Method (Entities.Element, Primitive_Op_Name => Orig_Short_Name);
               else
                  Dump_Entity (Entities.Element);
               end if;
               Next (Entities);
            end loop;
         end Dump_Entities;
      begin

         if Orig_Decl.Flags.Is_Type then
            --  It is tempting to find the highest ancestor type here, then show
            --  all types derived from that. But in Ada, that root ancestor is
            --  often Ada.Finalization.[Limited_]Controlled (or some similar root
            --  type), so the tree is much larger than we really want. So we just
            --  show all children of the given type; the user can then climb the
            --  tree if they want to enlarge it. This also allows the user to
            --  choose which anscestor to examine when there is more than one,
            --  with interfaces.
            Root_Parent := Orig_Entity;

         elsif Orig_Decl.Flags.Is_Subprogram then
            declare
               Controlling : constant Entity_Information := Controlling_Type (Orig_Entity);
            begin
               if Controlling = No_Entity then
                  --  Not a primitive subprogram
                  Dump_Entity (Orig_Entity);
                  return;
               else
                  if No_Children then
                     Root_Parent := Controlling; -- for type name
                  else
                     --  Here we find the highest ancestor type that has this method.
                     --  gnatcoll.xref does not let us get the type of each parameter, so
                     --  we can't match profiles, just names.
                     Root_Parent := Root_Parent_Type (Controlling, Primitive_Op_Name => Orig_Short_Name);
                  end if;
               end if;
            end;
         else
            --  Something else (variable, package, ...)
            Dump_Decl (Orig_Decl);
            return;
         end if;

         if No_Children then
            if Orig_Decl.Flags.Is_Type then
               Dump_Entity (Orig_Entity);
            else
               Dump_Entity (Orig_Entity, Controlling_Type_Name => Xref.Qualified_Name (Root_Parent));
            end if;
         else
            declare
               Child_Types : Recursive_Entities_Cursor;
            begin
               --  "Child_Types" includes generic formal parameters (ie
               --  gen_run_wisi_lr_parse.ads Parse_Data_Type) in addition to the
               --  actual parameters.
               All_Child_Types (Root_Parent, Child_Types);
               if Orig_Decl.Flags.Is_Type then
                  Dump_Entity (Root_Parent);
               else
                  Dump_Method (Root_Parent, +Orig_Decl.Name);
               end if;
               Dump_Entities (Child_Types);
            end;
         end if;
      end One_Entity;

      use GNAT.Directory_Operations;
   begin
      Short_File_Names := Nth_Arg (Args, 2) = Short_File_Names_Arg;

      case Words'Length is
      when 3 | 4         =>
         One_Entity
           (Xref.Get_Entity
              (Name     => Words (Words'First).all,
               File     => Format_Pathname
                 (Style => UNIX,
                  Path  => Words (Words'First + 1).all),
               Project  => GNATCOLL.Projects.No_Project,
               Line     => Integer'Value (Words (Words'First + 2).all),
               Column   =>
                 (if Words'Length = 4
                  then Visible_Column (Integer'Value (Words (Words'First + 3).all))
                  else -1)) --  No column; assume good enough for a precise match
              .Entity);

      when 2 =>
         --  No line or column; find all matching names in file
         declare
            use GNATCOLL.VFS;

            Multiple       : Entities_Cursor;
            Orig_File      : constant Virtual_File      := Locate_Regular_File
              (File_Name => +Words (Words'First + 1).all,
               Path      => Source_Search_Path.all);
            Orig_File_Name : constant Filesystem_String := Full_Name (Orig_File);
         begin
            From_Prefix (Xref, Words (Words'First).all, Is_Partial => False, Cursor => Multiple);

            loop
               exit when not Has_Element (Multiple);
               declare
                  Decl : constant Entity_Declaration := Xref.Declaration (Element (Multiple));

                  function Check_Body_File return Boolean
                  is
                     Bodies : References_Cursor;
                  begin
                     Xref.Bodies (Decl.Location.Entity, Bodies);
                     loop
                        exit when not Has_Element (Bodies);
                        declare
                           Ref : Entity_Reference renames Element (Bodies);
                        begin
                           if Orig_File_Name = Full_Name (Ref.File) then
                              return True;
                           end if;
                        end;
                        Next (Bodies);
                     end loop;
                     return False;
                  end Check_Body_File;

               begin
                  if Orig_File_Name = Full_Name (Decl.Location.File) or else
                    Check_Body_File
                  then
                     One_Entity (Element (Multiple), No_Children => True);
                  end if;
               end;
               Next (Multiple);
            end loop;
         end;

      when others =>
         --  No file or bad arg.
         GNAT.Strings.Free (Words);
         raise Invalid_Command with "Invalid parameter '" & Nth_Arg (Args, 1) &
           "', expecting name:file:[line[:column]]";
      end case;

   end Process_Tree_Defs;

   procedure Process_Tree_Refs (Args : GNATCOLL.Arg_Lists.Arg_List)
   is
      --  "tree_refs" <name:loc> {short_file_names | full_file_names}

      use GNATCOLL.Arg_Lists;
      use GNATCOLL.Xref;

      Orig_Entity : constant Entity_Information := Get_Entity (Nth_Arg (Args, 1));
      Orig_Decl   : constant Entity_Declaration := Xref.Declaration (Orig_Entity);
      Root_Parent : Entity_Information;

      procedure Dump_Type (Type_Entity : in Entity_Information)
      is
         Methods : Entities_Cursor;
      begin
         if Orig_Decl.Flags.Is_Subprogram then
            Xref.Methods (Type_Entity, Methods);
            loop
               exit when not Has_Element (Methods);
               declare
                  Method_Name : constant String := +Xref.Declaration (Methods.Element).Name;
                  Refs : References_Cursor;
               begin
                  if Method_Name = +Orig_Decl.Name then
                     Xref.References (Methods.Element, Refs);
                     Dump (Refs, +Xref.Declaration (Type_Entity).Name);
                  end if;
               end;
               Next (Methods);
            end loop;
         else
            Dump_Entity (Type_Entity);
         end if;
      end Dump_Type;

      procedure Dump_Types (Types : in out Recursive_Entities_Cursor)
      is begin
         loop
            exit when not Has_Element (Types);
            Dump_Type (Types.Element);
            Next (Types);
         end loop;
      end Dump_Types;
   begin
      Short_File_Names := Nth_Arg (Args, 2) = Short_File_Names_Arg;

      if Orig_Decl.Flags.Is_Type then
         --  See comment in Process_Tree_Defs
         Root_Parent := Orig_Entity;

      elsif Orig_Decl.Flags.Is_Subprogram then
         declare
            Controlling : constant Entity_Information := Controlling_Type (Orig_Entity);
         begin
            if Controlling = No_Entity then
               --  Not a primitive subprogram
               declare
                  Refs : References_Cursor;
               begin
                  Xref.References (Orig_Entity, Refs);
                  Dump (Refs);
                  return;
               end;
            else
               Root_Parent := Root_Parent_Type (Controlling, Primitive_Op_Name => +Orig_Decl.Name);
            end if;
         end;
      else
         --  A variable
         declare
            Refs : References_Cursor;
         begin
            Xref.References (Orig_Entity, Refs);
            Dump (Refs);
            return;
         end;
      end if;

      declare
         Child_Types : Recursive_Entities_Cursor;
      begin
         All_Child_Types (Root_Parent, Child_Types);

         Dump_Type (Root_Parent);
         Dump_Types (Child_Types);
      end;
   end Process_Tree_Refs;

   procedure Process_Source_Dirs (Args : GNATCOLL.Arg_Lists.Arg_List)
   is
      pragma Unreferenced (Args);
   begin
      Put (Source_Search_Path.all);
   end Process_Source_Dirs;

   procedure Put (Item : GNATCOLL.VFS.File_Array)
   is
      use GNATCOLL.VFS;
   begin
      for I in Item'Range loop
         Ada.Text_IO.Put_Line (+Full_Name (Item (I)));
      end loop;
   end Put;

   ----------
   --  SQL error reporting
   type SQL_Error_Reporter is new GNATCOLL.SQL.Exec.Error_Reporter with null record;

   overriding procedure On_Error
     (Self : in out SQL_Error_Reporter;
      Connection : access GNATCOLL.SQL.Exec.Database_Connection_Record'Class;
      Message    : in String)
   is
      pragma Unreferenced (Self, Connection);
   begin
      Ada.Text_IO.Put_Line ("gpr_query: sql error on create database: " & Message);
   end On_Error;

   --  For some reason, gnat community 2020 doesn't like this:
   --  overriding procedure On_Warning
   --    (Self : in out SQL_Error_Reporter;
   --     Connection : access GNATCOLL.SQL.Exec.Database_Connection_Record'Class;
   --     Message    : in String)
   --  is begin
   --     Ada.Text_IO.Put_Line ("gpr_query: sql warning on create database: " & Message);
   --  end On_Warning;

   Error_Reporter : aliased SQL_Error_Reporter;

begin
   Ada.Text_IO.Put_Line ("version: " & Version);

   declare
      use GNAT.Command_Line;
   begin
      Set_Usage
        (Cmdline,
         Help => "Query project info and cross-references on source code. See ada-mode docs for more help.");

      --  Switch variable alphabetic order
      Define_Switch
        (Cmdline,
         Output      => ALI_Encoding'Access,
         Long_Switch => "--encoding=",
         Switch      => "-e=",
         Help        => "The character encoding used for source and ALI files");
      Define_Switch
        (Cmdline,
         Output      => Commands_From_Switch'Access,
         Switch      => "-c:",
         Long_Switch => "--command=",
         Help        => "Execute the commands from ARG, and exit");
      Define_Switch
        (Cmdline,
         Output      => DB_Name'Access,
         Long_Switch => "--db=",
         Help        => "Specifies the name of the database file (or ':memory:')");
      Define_Switch
        (Cmdline,
         Output      => Force_Refresh'Access,
         Long_Switch => "--force_refresh",
         Help        => "Force rebuilding the database.");
      Define_Switch
        (Cmdline,
         Output      => Gpr_Config_File'Access,
         Long_Switch => "--autoconf=",
         Help        => "Specify the gpr configuration file (.cgpr)");
      Define_Switch
        (Cmdline,
         Output      => Nightly_DB_Name'Access,
         Long_Switch => "--nightlydb=",
         Help        => "Specifies the name of a prebuilt database");
      Define_Switch
        (Cmdline,
         Output      => Project_File_Name'Access,
         Switch      => "-P:",
         Long_Switch => "--project=",
         Help        => "Load the given project (mandatory)");
      Define_Switch
        (Cmdline,
         Output      => Show_Progress'Access,
         Long_Switch => "--display_progress",
         Switch      => "-d",
         Help        => "Show progress as LI files are parsed");
      Define_Switch
        (Cmdline,
         Output      => Traces_Config_File'Access,
         Long_Switch => "--tracefile=",
         Help        =>
           "Specify a traces configuration file, set projects lib verbose. File should contain ""gpr_query=yes""");

      Getopt (Cmdline, Callback => null);
   exception
   when Exit_From_Command_Line =>
      --  from "--help"
      return;
   end;

   if Project_File_Name.all = "" then
      Ada.Text_IO.Put_Line ("No project file specified");
      GNAT.Command_Line.Display_Help (Cmdline);
      return;
   end if;

   --  Only trace if user specifies --tracefile
   if Traces_Config_File.all /= "" and then GNAT.OS_Lib.Is_Regular_File (Traces_Config_File.all) then
      GNATCOLL.Traces.Parse_Config_File
        (Filename         => Traces_Config_File.all,
         Force_Activation => False);
      GNATCOLL.Traces.Trace (Me, "trace enabled");
      GNATCOLL.Traces.Trace (Me, "current directory: " & Ada.Directories.Current_Directory);
   end if;

   GNATCOLL.Projects.Initialize (Env); -- for register_default_language

   if Gpr_Config_File.all /= "" and then GNAT.OS_Lib.Is_Regular_File (Gpr_Config_File.all) then
      Env.Set_Config_File
        (GNATCOLL.VFS.Create_From_UTF8
           (GNAT.OS_Lib.Normalize_Pathname
              (Name      => Gpr_Config_File.all,
               Directory => GNAT.Directory_Operations.Get_Current_Dir)));
   else
      --  Apparently Ada language extensions are already registered (sigh)

      Env.Register_Default_Language_Extension
        (Language_Name       => "C",
         Default_Spec_Suffix => ".h",
         Default_Body_Suffix => ".c");

      Env.Register_Default_Language_Extension
        (Language_Name       => "C++",
         Default_Spec_Suffix => ".hh",
         Default_Body_Suffix => ".cpp");

   end if;

   declare
      use Ada.Environment_Variables;
      use Ada.Text_IO;
      use GNATCOLL.VFS;
      use GNATCOLL.VFS_Utils;

      Gpr_Project_Path : constant String :=
        (if Exists ("GPR_PROJECT_PATH") then Ada.Directories.Current_Directory &
            GNAT.OS_Lib.Path_Separator &
            Value ("GPR_PROJECT_PATH")
         else Ada.Directories.Current_Directory);

      Path : constant Virtual_File := -- must be an absolute file name
        (if Is_Absolute_Path (+Project_File_Name.all) then
            Create_From_UTF8 (Project_File_Name.all, Normalize => True)
         else
            Locate_Regular_File (+Project_File_Name.all, From_Path (+Gpr_Project_Path)));
   begin
      GNATCOLL.Traces.Trace (Me, "GPR_PROJECT_PATH " & Gpr_Project_Path);

      if not Path.Is_Regular_File then
         declare
            Path : constant File_Array := From_Path (+Gpr_Project_Path);
         begin
            Put_Line (Project_File_Name.all & ": not found on path:");
            for P of Path loop
               Put_Line (+Full_Name (P));
            end loop;
         end;
         Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);
         return;
      end if;

      GNATCOLL.Traces.Trace (Me, "project file " & (+Path.Full_Name));

      if Show_Progress then
         Progress_Reporter := Display_Progress'Unrestricted_Access;
      end if;

      begin
         --  Recompute_View => True registers all the source files
         --  (among other things), so we will know that a .[ag]li
         --  belongs to this project
         Tree.Load
           (Path, Env,
            Errors         => Ada.Text_IO.Put_Line'Access,
            Recompute_View => True);
      exception
      when GNATCOLL.Projects.Invalid_Project =>
         Ada.Text_IO.Put_Line ("project search path:");
         Put (GNATCOLL.Projects.Predefined_Project_Path (Env.all));
         raise GNATCOLL.Projects.Invalid_Project with +Path.Full_Name & ": invalid project";
      end;
   end;

   if DB_Name.all /= ":memory:" then
      declare
         use GNATCOLL.VFS;

         N    : constant String := DB_Name.all;
         Temp : Virtual_File    := Tree.Root_Project.Object_Dir;
         Dir2 : Virtual_File;
      begin
         GNAT.Strings.Free (DB_Name);

         --  If the project does not have an object directory, create
         --  the database in the directory containing the project file.
         if Temp = No_File then
            Temp := Tree.Root_Project.Project_Path.Dir;
         end if;

         Temp := Create_From_Base (Base_Dir => Temp.Full_Name.all, Base_Name => +N);
         Dir2 := Create (Temp.Dir_Name);

         if not Dir2.Is_Directory then
            Dir2.Make_Dir (Recursive => True);
         end if;

         DB_Name := new String'(Temp.Display_Full_Name);
      end;
   end if;

   declare
      --  Error if DB_Name does not exist but is in a read-only directory.
      --  The Errors parameter to Sqlite.Setup does not help here; it
      --  reports no error. Ada.Directories does not support a "writeable"
      --  query.
      use Ada.Directories;
   begin
      if DB_Name.all = ":memory:" then
         null;

      elsif Exists (DB_Name.all) then
         --  If this is read-only, we assume it is up to date and the user is
         --  just browsing.
         null;

      else
         declare
            use GNATCOLL.VFS;
            Dir_Name : constant String       := Containing_Directory (DB_Name.all);
            Dir_File : constant Virtual_File := Create (Filesystem_String (Dir_Name));
         begin
            if Is_Writable (Dir_File) then
               null;
            else
               raise DB_Error with "database file '" & DB_Name.all & "' does not exist, and directory is not writeable";
            end if;
         end;
      end if;
   end;

   declare
      use type GNAT.Strings.String_Access;
      Error : GNAT.Strings.String_Access;
   begin
      GNATCOLL.Traces.Trace (Me, "using database " & DB_Name.all);

      Setup_DB
        (Self        => Xref,
         Tree        => Tree'Unchecked_Access,
         DB          => GNATCOLL.SQL.Sqlite.Setup
           (Database => DB_Name.all,
            Errors   => Error_Reporter'Unchecked_Access),
         Error       => Error);

      if Error /= null then
         --  old db schema
         raise DB_Error with Error.all;
      end if;
   end;

   Process_Refresh (GNATCOLL.Arg_Lists.Empty_Command_Line);

   Source_Search_Path := new GNATCOLL.VFS.File_Array'
     (GNATCOLL.Projects.Source_Dirs
        (Project   => Tree.Root_Project,
         Recursive => True) &
        GNATCOLL.Projects.Predefined_Source_Path (Env.all));

   if Commands_From_Switch.all /= "" then
      Process_Line (Commands_From_Switch.all);
      return;
   end if;

   loop
      Ada.Text_IO.Put (">>> ");
      declare
         Input : constant String := Ada.Text_IO.Get_Line;
      begin
         exit when Input = "exit";
         Process_Line (Input);
      exception
      when E : Invalid_Command =>
         Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Message (E));
         Process_Help (GNATCOLL.Arg_Lists.Empty_Command_Line);
      end;
   end loop;

exception
when Ada.IO_Exceptions.End_Error =>
   null;
when E : GNATCOLL.Projects.Invalid_Project =>
   Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Message (E));
   Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);
when E : DB_Error =>
   Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Message (E));
   Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);
when E : Invalid_Command =>
   Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Message (E));
   Process_Help (GNATCOLL.Arg_Lists.Empty_Command_Line);
   Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);
when GNAT.Command_Line.Invalid_Switch =>
   GNAT.Command_Line.Display_Help (Cmdline);
   Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);
when E : others =>
   Ada.Text_IO.Put_Line ("Unexpected exception");
   Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E));
   Ada.Text_IO.Put_Line (GNAT.Traceback.Symbolic.Symbolic_Traceback (Ada.Exceptions.Traceback.Tracebacks (E)));
   Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);
end Gpr_Query;