ada_language_server_22.0.0_ef4bdf41/source/ada/lsp-common.adb

------------------------------------------------------------------------------
--                         Language Server Protocol                         --
--                                                                          --
--                     Copyright (C) 2018-2021, AdaCore                     --
--                                                                          --
-- This is free software;  you can redistribute it  and/or modify it  under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
-- sion.  This software is distributed in the hope  that it will be useful, --
-- but WITHOUT ANY WARRANTY;  without even the implied warranty of MERCHAN- --
-- TABILITY 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  software;   see  file --
-- COPYING3.  If not, go to http://www.gnu.org/licenses for a complete copy --
-- of the license.                                                          --
------------------------------------------------------------------------------

with Ada.Characters.Latin_1;
with Ada.Exceptions;           use Ada.Exceptions;
with GNAT.Expect.TTY;
with GNAT.Traceback.Symbolic;  use GNAT.Traceback.Symbolic;
with GNATCOLL.Utils;           use GNATCOLL.Utils;

with VSS.String_Vectors;
with VSS.Strings.Character_Iterators;

with Langkit_Support.Text;
with Libadalang.Common;        use Libadalang.Common;

with LSP.Lal_Utils;

package body LSP.Common is

   function Get_Hover_Text_For_Node
     (Node : Ada_Node'Class) return VSS.String_Vectors.Virtual_String_Vector;
   --  Return a pretty printed version of the node's text to be
   --  displayed on hover requests, removing unnecessary indentation
   --  whitespaces if needed and attaching extra information in some cases.

   procedure Append_To_Last_Line
     (Lines : in out VSS.String_Vectors.Virtual_String_Vector;
      Item  : VSS.Characters.Virtual_Character);
   --  Append given Item to the last line of the vector. Append new line when
   --  vector is empty.

   procedure Append_To_Last_Line
     (Lines : in out VSS.String_Vectors.Virtual_String_Vector;
      Item  : VSS.Strings.Virtual_String);
   --  Append given Item to the last line of the vector. Append new line when
   --  vector is empty.

   -------------------------
   -- Append_To_Last_Line --
   -------------------------

   procedure Append_To_Last_Line
     (Lines : in out VSS.String_Vectors.Virtual_String_Vector;
      Item  : VSS.Characters.Virtual_Character)
   is
      Line : VSS.Strings.Virtual_String :=
        (if Lines.Is_Empty
           then VSS.Strings.Empty_Virtual_String
           else Lines.Element (Lines.Length));

   begin
      Line.Append (Item);

      if Lines.Is_Empty then
         Lines.Append (Line);

      else
         Lines.Replace (Lines.Length, Line);
      end if;
   end Append_To_Last_Line;

   -------------------------
   -- Append_To_Last_Line --
   -------------------------

   procedure Append_To_Last_Line
     (Lines : in out VSS.String_Vectors.Virtual_String_Vector;
      Item  : VSS.Strings.Virtual_String)
   is
      Line : VSS.Strings.Virtual_String :=
        (if Lines.Is_Empty
           then VSS.Strings.Empty_Virtual_String
           else Lines.Element (Lines.Length));

   begin
      Line.Append (Item);

      if Lines.Is_Empty then
         Lines.Append (Line);

      else
         Lines.Replace (Lines.Length, Line);
      end if;
   end Append_To_Last_Line;

   ---------
   -- Log --
   ---------

   procedure Log
     (Trace   : GNATCOLL.Traces.Trace_Handle;
      E       : Ada.Exceptions.Exception_Occurrence;
      Message : String := "") is
   begin
      if Message /= "" then
         Trace.Trace (Message);
      end if;

      Trace.Trace (Exception_Name (E) & ": " & Exception_Message (E)
                   & Ada.Characters.Latin_1.LF & Symbolic_Traceback (E));
   end Log;

   ----------------
   -- Get_Output --
   ----------------

   function Get_Output
     (Exe  : Virtual_File;
      Args : GNAT.OS_Lib.Argument_List) return String
   is
   begin
      if Exe = No_File then
         return "";
      end if;

      declare
         Fd : aliased GNAT.Expect.TTY.TTY_Process_Descriptor;
      begin
         GNAT.Expect.Non_Blocking_Spawn
           (Descriptor  => Fd,
            Command     => Exe.Display_Full_Name,
            Buffer_Size => 0,
            Args        => Args,
            Err_To_Out  => True);
         declare
            S : constant String :=
              GNATCOLL.Utils.Get_Command_Output (Fd'Access);
         begin
            GNAT.Expect.TTY.Close (Fd);

            return S;
         end;
      exception
         when GNAT.Expect.Process_Died =>
            GNAT.Expect.TTY.Close (Fd);
            return "";
      end;
   end Get_Output;

   -----------------------------
   -- Get_Hover_Text_For_Node --
   -----------------------------

   function Get_Hover_Text_For_Node
     (Node : Ada_Node'Class) return VSS.String_Vectors.Virtual_String_Vector
   is
      Result : VSS.String_Vectors.Virtual_String_Vector;

      function Is_Space
        (Char : VSS.Characters.Virtual_Character) return Boolean;
      --  Check if given character is a whitespace

      function Get_Indent
        (Line : VSS.Strings.Virtual_String) return Natural;
      --  Count number of starting spaces

      function Tail_From
        (Line : VSS.Strings.Virtual_String;
         Skip : Natural) return VSS.Strings.Virtual_String;
      --  Return slice of Line from given index to the end of Line

      procedure Get_Basic_Decl_Hover_Text;
      --  Create the hover text for for basic declarations

      procedure Get_Subp_Spec_Hover_Text;
      --  Create the hover text for subprogram declarations

      procedure Get_Package_Decl_Hover_Text;
      --  Create the hover text  for package declarations

      procedure Get_Loop_Var_Hover_Text;
      --  Create the hover text for loop variable declarations

      procedure Get_Aspect_Hover_Text;
      --  Create the hover text for aspect statement

      -------------------------------
      -- Get_Basic_Decl_Hover_Text --
      -------------------------------

      procedure Get_Basic_Decl_Hover_Text is
         Text   : constant VSS.Strings.Virtual_String :=
           LSP.Lal_Utils.To_Virtual_String (Node.Text);

         Lines  : constant VSS.String_Vectors.Virtual_String_Vector :=
           Text.Split_Lines;

      begin
         case Node.Kind is
            when Ada_Package_Body =>

               --  This means that user is hovering on the package declaration
               --  itself: in this case, return a empty response since all the
               --  relevant information is already visible to the user.
               return;

            when others =>
               --  Return an empty hover text if there is no text for this
               --  delclaration (only for safety).
               if Text.Is_Empty then
                  return;
               end if;

               --  If it's a single-line declaration, replace all the
               --  series of whitespaces by only one blankspace. If it's
               --  a multi-line declaration, remove only the unneeded
               --  indentation whitespaces.

               if Lines.Length = 1 then
                  declare
                     Char  : VSS.Characters.Virtual_Character;
                     Line  : constant VSS.Strings.Virtual_String := Lines (1);
                     Value : VSS.Strings.Virtual_String;

                     Skip_Space : Boolean := True;

                     J : VSS.Strings.Character_Iterators.Character_Iterator :=
                       Line.First_Character;
                  begin
                     while J.Has_Element loop
                        Char := J.Element;

                        if not Is_Space (Char) then
                           Skip_Space := False;
                           Value.Append (Char);
                        elsif not Skip_Space then
                           Skip_Space := True;
                           Value.Append (' ');
                        end if;

                        exit when not J.Forward;
                     end loop;

                     Result.Append (Value);
                  end;

               else
                  declare
                     Indent : Natural := Natural'Last;
                  begin
                     Result.Append (Lines (1));

                     --  Count the blankspaces per line and track how many
                     --  blankspaces we should remove on each line by
                     --  finding the common indentation blankspaces.

                     for J in 2 .. Lines.Length loop
                        Indent := Natural'Min (Indent, Get_Indent (Lines (J)));
                     end loop;

                     for J in 2 .. Lines.Length loop
                        declare
                           Line : constant VSS.Strings.Virtual_String :=
                             Lines (J);

                           Value : constant VSS.Strings.Virtual_String :=
                             Tail_From (Line, Indent);
                        begin
                           Result.Append (Value);
                        end;
                     end loop;
                  end;
               end if;
         end case;
      end Get_Basic_Decl_Hover_Text;

      ----------------
      -- Get_Indent --
      ----------------

      function Get_Indent
        (Line : VSS.Strings.Virtual_String) return Natural
      is
         Result : Natural := 0;
         J      : VSS.Strings.Character_Iterators.Character_Iterator :=
           Line.First_Character;
      begin
         if J.Has_Element then
            while Is_Space (J.Element) loop
               Result := Result + 1;

               exit when not J.Forward;
            end loop;
         end if;

         return Result;
      end Get_Indent;

      ------------------------------
      -- Get_Subp_Spec_Hover_Text --
      ------------------------------

      procedure Get_Subp_Spec_Hover_Text is
         Text   : constant VSS.Strings.Virtual_String :=
           LSP.Lal_Utils.To_Virtual_String (Node.Text);

         Lines  : constant VSS.String_Vectors.Virtual_String_Vector :=
           Text.Split_Lines;

      begin
         --  For single-line subprogram specifications, we display the
         --  associated text directly.
         --  For multi-line ones, remove the identation blankspaces to replace
         --  them by a fixed number of blankspaces.

         if Lines.Length = 1 then
            Result.Append (Text);

         else
            Result.Append (Lines (1));

            for J in 2 .. Lines.Length loop
               declare
                  Line   : VSS.Strings.Virtual_String := Lines (J);
                  Indent : constant Natural := Get_Indent (Line);
               begin
                  if not Line.Is_Empty then
                     Line := Tail_From (Line, Indent);

                     if Line.Starts_With ("(") then
                        Line.Prepend ("  ");
                     else
                        Line.Prepend ("   ");
                     end if;

                     Result.Append (Line);
                  end if;
               end;
            end loop;
         end if;

         --  Append "is abstract" to the resulting hover text if the subprogram
         --  specificiation node belongs to an abstract subprogram declaration.
         if not Node.Parent.Is_Null
           and then Node.Parent.Kind in Ada_Abstract_Subp_Decl_Range
         then
            Append_To_Last_Line (Result, " is abstract");
         end if;

         --  Append "is null" to the resulting hover text if the subprogram
         --  specificiation node belongs to an null subprogram declaration.
         if not Node.Parent.Is_Null
           and then Node.Parent.Kind in Ada_Null_Subp_Decl_Range
         then
            Append_To_Last_Line (Result, " is null");
         end if;
      end Get_Subp_Spec_Hover_Text;

      ---------------------------------
      -- Get_Package_Decl_Hover_Text --
      ---------------------------------

      procedure Get_Package_Decl_Hover_Text is
         Text   : VSS.Strings.Virtual_String;
         Decl   : constant Base_Package_Decl := Node.As_Base_Package_Decl;
         Aspect : constant Aspect_Spec := Decl.F_Aspects;
         Name   : constant Defining_Name := Decl.F_Package_Name;
         To     : Token_Reference := --  token before `IS`
           (if not Aspect.Is_Null then
              Aspect.Token_End
            elsif not Name.Is_Null then
              Name.Token_End
            else  --  just-in-case fallback
              Decl.Token_End);
      begin
         --  Return the first line of the package declaration and its
         --  generic parameters if any.
         To := Next (To, Exclude_Trivia => True);   --  Jump to IS
         To := Previous (To, Exclude_Trivia => False);  --  Jump before IS

         if Node.Parent.Kind in Ada_Generic_Decl then
            Text := LSP.Lal_Utils.To_Virtual_String
              (Node.Parent.As_Generic_Decl.F_Formal_Part.Text);

            Result.Append (Text);
         end if;

         Text := LSP.Lal_Utils.To_Virtual_String
           (Libadalang.Common.Text (Node.Token_Start, To));

         Result.Append (Text);
      end Get_Package_Decl_Hover_Text;

      -----------------------------
      -- Get_Loop_Var_Hover_Text --
      -----------------------------

      procedure Get_Loop_Var_Hover_Text is
         Parent_Text : constant Langkit_Support.Text.Text_Type :=
           Node.Parent.Text;

      begin
         Result.Append (LSP.Lal_Utils.To_Virtual_String (Parent_Text));
      end Get_Loop_Var_Hover_Text;

      ---------------------------
      -- Get_Aspect_Hover_Text --
      ---------------------------

      procedure Get_Aspect_Hover_Text is
         Text   : constant VSS.Strings.Virtual_String :=
           LSP.Lal_Utils.To_Virtual_String (Node.Text);

         Lines  : constant VSS.String_Vectors.Virtual_String_Vector :=
           Text.Split_Lines;

         --  Get the indentation for the first line
         Indentation : Integer := Get_Indent (Lines (1));
         Idx         : Integer;
         Line        : VSS.Strings.Virtual_String;
      begin
         Line := Tail_From (Lines (1), Indentation);
         --  Force an indentation of 2 for the first line
         Line.Prepend ("  ");
         Result.Append (Line);

         --  The next line should have one more indentation level
         Indentation := Indentation + 3;

         for J in 2 .. Lines.Length loop
            Line := Lines (J);
            Idx := Get_Indent (Line);

            if Indentation > Idx then
               --  Uncommon indentation: just print the line
               Result.Append (Line);
            else
               --  Remove the uneeded indentation
               Result.Append (Tail_From (Line, Indentation));
            end if;
         end loop;
      end Get_Aspect_Hover_Text;

      --------------
      -- Is_Space --
      --------------

      function Is_Space
        (Char : VSS.Characters.Virtual_Character) return Boolean is
      begin
         return VSS.Characters.Get_General_Category (Char) in
           VSS.Characters.Space_Separator;
      end Is_Space;

      ---------------
      -- Tail_From --
      ---------------

      function Tail_From
        (Line : VSS.Strings.Virtual_String;
         Skip : Natural) return VSS.Strings.Virtual_String
      is
         From : VSS.Strings.Character_Iterators.
           Character_Iterator := Line.First_Character;

         To   : constant VSS.Strings.Character_Iterators.
           Character_Iterator := Line.Last_Character;

      begin
         for J in 1 .. Skip loop
            exit when not From.Forward;
         end loop;

         return Line.Slice (From, To);
      end Tail_From;

   begin

      case Node.Kind is
         when Ada_Package_Body =>

            --  This means that the user is hovering on the package declaration
            --  itself: in this case, return a empty response since all the
            --  relevant information is already visible to the user.
            null;

         when Ada_Base_Package_Decl =>
            Get_Package_Decl_Hover_Text;

         when Ada_For_Loop_Var_Decl =>
            Get_Loop_Var_Hover_Text;

         when Ada_Base_Subp_Spec =>
            Get_Subp_Spec_Hover_Text;

         when Ada_Aspect_Assoc =>
            Get_Aspect_Hover_Text;

         when others =>
            Get_Basic_Decl_Hover_Text;
      end case;

      return Result;
   end Get_Hover_Text_For_Node;

   --------------------
   -- Get_Hover_Text --
   --------------------

   function Get_Hover_Text
     (Decl : Basic_Decl'Class) return VSS.Strings.Virtual_String
   is
      Decl_Text      : VSS.String_Vectors.Virtual_String_Vector;
      Subp_Spec_Node : Base_Subp_Spec;

   begin
      --  Try to retrieve the subprogram spec node, if any : if it's a
      --  subprogram node that does not have any separate declaration we
      --  only want to display its specification, not the body.
      Subp_Spec_Node := Decl.P_Subp_Spec_Or_Null;

      if Subp_Spec_Node /= No_Base_Subp_Spec then
         Decl_Text := Get_Hover_Text_For_Node (Subp_Spec_Node);

         --  Append the aspects to the declaration text, if any.
         declare
            Aspects      : constant Aspect_Spec := Decl.F_Aspects;
            Aspects_Text : VSS.String_Vectors.Virtual_String_Vector;

         begin
            if not Aspects.Is_Null then
               for Aspect of Aspects.F_Aspect_Assocs loop
                  if not Aspects_Text.Is_Empty then
                     --  need to add "," for the highlighting

                     Append_To_Last_Line (Aspects_Text, ',');
                  end if;

                  Aspects_Text.Append (Get_Hover_Text_For_Node (Aspect));
               end loop;

               if not Aspects_Text.Is_Empty then
                  Decl_Text.Append ("with");
                  Decl_Text.Append (Aspects_Text);
               end if;
            end if;
         end;

      else
         Decl_Text := Get_Hover_Text_For_Node (Decl);
      end if;

      return Decl_Text.Join_Lines (Document_LSP_New_Line_Function, False);
   end Get_Hover_Text;

   ----------------------
   -- Is_Ada_Separator --
   ----------------------

   function Is_Ada_Separator
     (Item : VSS.Characters.Virtual_Character) return Boolean is
   begin
      --  Ada 2012's RM defines separator as 'separator_space',
      --  'format_efector' or end of a line, with some exceptions inside
      --  comments.
      --
      --  'separator_space' is defined as a set of characters with
      --  'General Category' defined as 'Separator, Space'.
      --
      --  'format_effector' is set of characters:
      --    - CHARACTER TABULATION
      --    - LINE FEED
      --    - LINE TABULATION
      --    - FORM FEED
      --    - CARRIAGE RETURN
      --    - NEXT LINE
      --    - characters with General Category defined as
      --      'Separator, Line'
      --    - characters with General Category defined as
      --      'Separator, Paragraph'

      return
        Item in
            VSS.Characters.Virtual_Character'Val (16#09#)
          | VSS.Characters.Virtual_Character'Val (16#0A#)
          | VSS.Characters.Virtual_Character'Val (16#0B#)
          | VSS.Characters.Virtual_Character'Val (16#0C#)
          | VSS.Characters.Virtual_Character'Val (16#0D#)
          | VSS.Characters.Virtual_Character'Val (16#85#)
        or VSS.Characters.Get_General_Category (Item) in
            VSS.Characters.Space_Separator
          | VSS.Characters.Line_Separator
          | VSS.Characters.Paragraph_Separator;
   end Is_Ada_Separator;

end LSP.Common;