UB30-006 GNATpp partial formatting integration

joaopsazevedo · AnthonyLeonardoGracio · commit 70e06b435c1b · 2022-06-24T14:49:45.000+02:00
diff --git a/source/ada/lsp-ada_contexts.adb b/source/ada/lsp-ada_contexts.adb
@@ -779,6 +779,37 @@ package body LSP.Ada_Contexts is
          Messages => Messages);
    end Format;
 
+   ------------------
+   -- Range_Format --
+   ------------------
+
+   procedure Range_Format
+     (Self     : in out Context;
+      Document : LSP.Ada_Documents.Document_Access;
+      Span     : LSP.Messages.Span;
+      Options  : LSP.Messages.FormattingOptions;
+      Edit     : out LSP.Messages.TextEdit_Vector;
+      Success  : out Boolean;
+      Messages : out VSS.String_Vectors.Virtual_String_Vector) is
+   begin
+      Pp.Command_Lines.Pp_Nat_Switches.Set_Arg
+        (Self.PP_Options,
+         Pp.Command_Lines.Indentation,
+         Natural (Options.tabSize));
+
+      Pp.Command_Lines.Pp_Flag_Switches.Set_Arg
+        (Self.PP_Options,
+         Pp.Command_Lines.No_Tab,
+         Options.insertSpaces);
+
+      Success := Document.Range_Formatting
+        (Context    => Self,
+         Span       => Span,
+         PP_Options => Self.PP_Options,
+         Edit       => Edit,
+         Messages   => Messages);
+   end Range_Format;
+
    ----------
    -- Free --
    ----------
diff --git a/source/ada/lsp-ada_contexts.ads b/source/ada/lsp-ada_contexts.ads
@@ -111,6 +111,15 @@ package LSP.Ada_Contexts is
       Success  : out Boolean;
       Messages : out VSS.String_Vectors.Virtual_String_Vector);
 
+   procedure Range_Format
+     (Self     : in out Context;
+      Document : LSP.Ada_Documents.Document_Access;
+      Span     : LSP.Messages.Span;
+      Options  : LSP.Messages.FormattingOptions;
+      Edit     : out LSP.Messages.TextEdit_Vector;
+      Success  : out Boolean;
+      Messages : out VSS.String_Vectors.Virtual_String_Vector);
+
    procedure Find_All_References
      (Self       : Context;
       Definition : Libadalang.Analysis.Defining_Name;
diff --git a/source/ada/lsp-ada_documents.adb b/source/ada/lsp-ada_documents.adb
@@ -33,6 +33,7 @@ with Libadalang.Sources;
 with Libadalang.Iterators;
 
 with Laltools.Common;
+with Laltools.Partial_GNATPP;
 
 with VSS.Strings.Character_Iterators;
 with VSS.Strings.Line_Iterators;
@@ -45,7 +46,9 @@ with LSP.Ada_Documents.LAL_Diagnostics;
 with LSP.Common; use LSP.Common;
 with LSP.Lal_Utils;
 
+with Pp.Actions;
 with Pp.Scanner;
+
 with Utils.Char_Vectors;
 
 package body LSP.Ada_Documents is
@@ -671,7 +674,7 @@ package body LSP.Ada_Documents is
          Out_Sloc  => Out_Sloc,
          Messages  => PP_Messages);
 
-      --  Prolerly format the messages received from gnatpp, using the
+      --  Properly format the messages received from gnatpp, using the
       --  the GNAT standard way for messages (i.e: <filename>:<sloc>: <msg>)
 
       if not PP_Messages.Is_Empty then
@@ -732,6 +735,154 @@ package body LSP.Ada_Documents is
          return False;
    end Formatting;
 
+   ----------------------
+   -- Range_Formatting --
+   ----------------------
+
+   function Range_Formatting
+     (Self       : Document;
+      Context    : LSP.Ada_Contexts.Context;
+      Span       : LSP.Messages.Span;
+      PP_Options : Pp.Command_Lines.Cmd_Line;
+      Edit       : out LSP.Messages.TextEdit_Vector;
+      Messages   : out VSS.String_Vectors.Virtual_String_Vector)
+      return Boolean
+   is
+      use Langkit_Support.Slocs;
+      use Laltools.Partial_GNATPP;
+      use LSP.Types;
+      use LSP.Messages;
+      use Utils.Char_Vectors;
+      use Utils.Char_Vectors.Char_Vectors;
+
+      procedure Append_PP_Messages
+        (PP_Messages : Pp.Scanner.Source_Message_Vector);
+      --  Append any message of PP_Messages to Messages properly formatting
+      --  them using the GNAT standard way for messages
+      --  (i.e: <filename>:<sloc>: <msg>)
+
+      ------------------------
+      -- Append_PP_Messages --
+      ------------------------
+
+      procedure Append_PP_Messages
+        (PP_Messages : Pp.Scanner.Source_Message_Vector)
+      is
+         Filename : constant String :=
+           Context.URI_To_File (Self.URI);
+         File     : constant GNATCOLL.VFS.Virtual_File :=
+           GNATCOLL.VFS.Create_From_UTF8 (Filename);
+
+      begin
+         for Message of PP_Messages loop
+            Messages.Append
+              (VSS.Strings.Conversions.To_Virtual_String
+                 (File.Display_Base_Name
+                  & ":"
+                  & Pp.Scanner.Sloc_Image (Message.Sloc)
+                  & ": "
+                  & String (To_Array (Message.Text))));
+         end loop;
+      end Append_PP_Messages;
+
+      Input  : Char_Vector;
+      Output : Char_Vector;
+
+      PP_Messages : Pp.Scanner.Source_Message_Vector;
+
+      Input_Selection_Range : constant Source_Location_Range :=
+        (if Span = LSP.Messages.Empty_Span then
+           No_Source_Location_Range
+         else
+           Make_Range
+             (Self.Get_Source_Location (Span.first),
+              Self.Get_Source_Location (Span.last)));
+
+      Output_Selection_Range : Source_Location_Range;
+
+      Unit                 : constant Analysis_Unit :=
+        Self.Unit (Context);
+      Start_Node, End_Node : Ada_Node;
+      Enclosing_Node       : Ada_Node;
+
+      Offset : Natural := 0;
+
+   begin
+      Context.Trace.Trace ("On Range_Formatting");
+
+      Context.Trace.Trace ("Get_Selected_Region_Enclosing_Node");
+      Get_Selected_Region_Enclosing_Node
+        (Unit             => Unit,
+         SL_Range         => Input_Selection_Range,
+         Start_Node       => Start_Node,
+         End_Node         => End_Node,
+         Enclosing_Node   => Enclosing_Node,
+         Input_Sel        => Input,
+         Output_Sel_Range => Output_Selection_Range);
+      Context.Trace.Trace ("Start_Node: " & Start_Node.Image);
+      Context.Trace.Trace ("End_Node: " & End_Node.Image);
+      Context.Trace.Trace ("Enclosing_Node: " & Enclosing_Node.Image);
+      Context.Trace.Trace
+        ("Output_Selection_Range: " & Image (Output_Selection_Range));
+
+      Context.Trace.Trace
+        ("Get_Starting_Offset and Set_Partial_Gnatpp_Offset");
+      Offset :=
+        Get_Starting_Offset
+          (Node                   => Enclosing_Node,
+           PP_Indent              =>
+             Pp.Command_Lines.PP_Indentation (PP_Options),
+           PP_Indent_Continuation =>
+             Pp.Command_Lines.PP_Indent_Continuation (PP_Options));
+      Context.Trace.Trace (Offset'Image);
+      if Offset /= 0 then
+         Pp.Actions.Set_Partial_Gnatpp_Offset (Offset - 1);
+      end if;
+
+      Context.Trace.Trace ("Format_Vector");
+      begin
+         Pp.Actions.Format_Vector
+           (Cmd            => PP_Options,
+            Input          => Input,
+            Node           => Enclosing_Node,
+            Output         => Output,
+            Messages       => PP_Messages,
+            Partial_Gnatpp => True);
+      exception
+         when others =>
+            Append_PP_Messages (PP_Messages);
+            return False;
+      end;
+
+      if not PP_Messages.Is_Empty then
+         Context.Trace.Trace
+           ("Non empty PP_Messages - appending them to Messages");
+         Append_PP_Messages (PP_Messages);
+         return False;
+      end if;
+
+      Context.Trace.Trace ("Computing Range_Formatting Text_Edits");
+      declare
+         Edit_Span  : constant LSP.Messages.Span :=
+           Self.To_LSP_Range (Output_Selection_Range);
+         Output_Str : constant String :=
+           Char_Vectors.Elems (Output)
+             (1 .. Char_Vectors.Last_Index (Output) - 1);
+         Edit_Text  : constant VSS.Strings.Virtual_String :=
+           VSS.Strings.Conversions.To_Virtual_String (Output_Str);
+         Text_Edit  : constant LSP.Messages.TextEdit := (Edit_Span, Edit_Text);
+
+      begin
+         Edit.Append (Text_Edit);
+      end;
+
+      return True;
+
+   exception
+      when others =>
+         return False;
+   end Range_Formatting;
+
    ------------------------
    -- Get_Imported_Units --
    ------------------------
diff --git a/source/ada/lsp-ada_documents.ads b/source/ada/lsp-ada_documents.ads
@@ -181,6 +181,16 @@ package LSP.Ada_Documents is
       return Boolean;
    --  Format document or its part defined in Span
 
+   function Range_Formatting
+     (Self       : Document;
+      Context    : LSP.Ada_Contexts.Context;
+      Span       : LSP.Messages.Span;
+      PP_Options : Pp.Command_Lines.Cmd_Line;
+      Edit       : out LSP.Messages.TextEdit_Vector;
+      Messages   : out VSS.String_Vectors.Virtual_String_Vector)
+      return Boolean;
+   --  Format document or its part defined in Span
+
    procedure Get_Imported_Units
      (Self          : Document;
       Context       : LSP.Ada_Contexts.Context;
@@ -353,9 +363,9 @@ private
       New_Span : LSP.Messages.Span := LSP.Messages.Empty_Span;
       Edit     : out LSP.Messages.TextEdit_Vector);
    --  Create a diff between document Text and New_Text and return Text_Edit
-   --  based on Needleman-Wunsch algorithm
+   --  based on Needleman-Wunsch algorithm.
    --  Old_Span and New_Span are used when we need to compare certain
-   --  old/new lines instead of whole buffers
+   --  old/new lines instead of whole buffers.
 
    function URI (Self : Document) return LSP.Messages.DocumentUri is
      (Self.URI);
diff --git a/source/ada/lsp-ada_handlers.adb b/source/ada/lsp-ada_handlers.adb
@@ -117,6 +117,12 @@ package body LSP.Ada_Handlers is
                              GNATCOLL.Traces.On);
    --  Trace to enable/disable runtime indexing. Useful for the testsuite.
 
+   Partial_GNATpp : constant GNATCOLL.Traces.Trace_Handle :=
+     GNATCOLL.Traces.Create ("ALS.PARTIAL_GNATPP",
+                             GNATCOLL.Traces.Off);
+   --  Use partial formatting mode of gnatpp if On. Otherwise, use diff
+   --  algorithm.
+
    Is_Parent : constant LSP.Messages.AlsReferenceKind_Set :=
      (Is_Server_Side => True,
       As_Flags => [LSP.Messages.Parent => True, others => False]);
@@ -232,6 +238,14 @@ package body LSP.Ada_Handlers is
       return LSP.Messages.Server_Responses.Formatting_Response;
    --  Format the text of the given document in the given range (span).
 
+   function Range_Format
+     (Self     : in out LSP.Ada_Contexts.Context;
+      Document : LSP.Ada_Documents.Document_Access;
+      Span     : LSP.Messages.Span;
+      Options  : LSP.Messages.FormattingOptions)
+      return LSP.Messages.Server_Responses.Formatting_Response;
+   --  Format the text of the given document in the given range (span).
+
    type File_Span is record
       File : GNATCOLL.VFS.Virtual_File;
       Span : LSP.Messages.Span;
@@ -800,7 +814,7 @@ package body LSP.Ada_Handlers is
       Document : LSP.Ada_Documents.Document_Access;
       Span     : LSP.Messages.Span;
       Options  : LSP.Messages.FormattingOptions)
-         return LSP.Messages.Server_Responses.Formatting_Response
+      return LSP.Messages.Server_Responses.Formatting_Response
    is
       Response : LSP.Messages.Server_Responses.Formatting_Response
         (Is_Error => False);
@@ -840,6 +854,56 @@ package body LSP.Ada_Handlers is
       return Response;
    end Format;
 
+   ------------------
+   -- Range_Format --
+   ------------------
+
+   function Range_Format
+     (Self     : in out LSP.Ada_Contexts.Context;
+      Document : LSP.Ada_Documents.Document_Access;
+      Span     : LSP.Messages.Span;
+      Options  : LSP.Messages.FormattingOptions)
+      return LSP.Messages.Server_Responses.Formatting_Response
+   is
+      Response : LSP.Messages.Server_Responses.Formatting_Response
+        (Is_Error => False);
+      Success  : Boolean;
+      Messages : VSS.String_Vectors.Virtual_String_Vector;
+
+   begin
+      Self.Range_Format
+        (Document => Document,
+         Span     => Span,
+         Options  => Options,
+         Edit     => Response.result,
+         Success  => Success,
+         Messages => Messages);
+
+      if not Success then
+         declare
+            use VSS.Strings;
+
+            Response  : LSP.Messages.Server_Responses.Formatting_Response
+              (Is_Error => True);
+            Error_Msg : VSS.Strings.Virtual_String;
+         begin
+            --  Display error messages from gnatpp, if any
+            for Msg of Messages loop
+               Error_Msg := Error_Msg & Msg;
+            end loop;
+
+            Response.error :=
+              (True,
+               (code    => LSP.Errors.InternalError,
+                message => Error_Msg,
+                data    => <>));
+            return Response;
+         end;
+      end if;
+
+      return Response;
+   end Range_Format;
+
    ------------------------
    -- Initialize_Request --
    ------------------------
@@ -5798,7 +5862,7 @@ package body LSP.Ada_Handlers is
             Response.error :=
               (True,
                (code    => LSP.Errors.InternalError,
-                message => "Incorrect code can't be formatted",
+                message => "Syntactically incorrect code can't be formatted",
                 data    => <>));
          end return;
       end if;
@@ -5807,11 +5871,18 @@ package body LSP.Ada_Handlers is
          use LSP.Messages;
 
          Result   : constant Server_Responses.Formatting_Response :=
-           Format
-             (Self     => Context.all,
-              Document => Document,
-              Span     => Request.params.span,
-              Options  => Request.params.options);
+           (if Partial_GNATpp.Is_Active then
+              Range_Format
+                (Self     => Context.all,
+                 Document => Document,
+                 Span     => Request.params.span,
+                 Options  => Request.params.options)
+            else
+              Format
+                (Self     => Context.all,
+                 Document => Document,
+                 Span     => Request.params.span,
+                 Options  => Request.params.options));
          Response : Server_Responses.Range_Formatting_Response
            (Is_Error => Result.Is_Error);
       begin
