Langkit_Support.Slocs: add Value (string parsing) functions

For GitHub issue AdaCore#492

support/langkit_support-slocs.adb

@@ -21,6 +21,8 @@
 -- <http://www.gnu.org/licenses/>.                                          --
 ------------------------------------------------------------------------------
 
+with Ada.Strings.Wide_Wide_Fixed; use Ada.Strings.Wide_Wide_Fixed;
+
 package body Langkit_Support.Slocs is
 
    -------------
@@ -73,4 +75,52 @@ package body Langkit_Support.Slocs is
                     else Inside));
    end Compare;
 
+   -----------
+   -- Value --
+   -----------
+
+   function Value (T : Text_Type) return Source_Location is
+      Colon_Index  : constant Natural := Index (T, ":");
+      Line_Slice   : Text_Type renames T (T'First .. Colon_Index - 1);
+      Column_Slice : Text_Type renames T (Colon_Index + 1 .. T'Last);
+      Line         : Line_Number;
+      Column       : Column_Number;
+   begin
+      if Colon_Index = 0 then
+         raise Constraint_Error with "invalid source location";
+      end if;
+
+      begin
+         Line := Line_Number'Wide_Wide_Value (Line_Slice);
+      exception
+         when Constraint_Error =>
+            raise Constraint_Error with
+               "invalid line number: "
+               & Image (Line_Slice, With_Quotes => True);
+      end;
+
+      begin
+         Column := Column_Number'Wide_Wide_Value (Column_Slice);
+      exception
+         when Constraint_Error =>
+            raise Constraint_Error with
+               "invalid column number: "
+               & Image (Column_Slice, With_Quotes => True);
+      end;
+
+      return (Line, Column);
+   end Value;
+
+   -----------
+   -- Value --
+   -----------
+
+   function Value (T : Text_Type) return Source_Location_Range is
+      Dash_Index  : constant Natural := Index (T, "-");
+      Start_Slice : Text_Type renames T (T'First .. Dash_Index - 1);
+      End_Slice   : Text_Type renames T (Dash_Index + 1 .. T'Last);
+   begin
+      return Make_Range (Value (Start_Slice), Value (End_Slice));
+   end Value;
+
 end Langkit_Support.Slocs;

support/langkit_support-slocs.ads

@@ -48,6 +48,10 @@ package Langkit_Support.Slocs is
    No_Source_Location       : constant Source_Location       := (0, 0);
    No_Source_Location_Range : constant Source_Location_Range := (0, 0, 0, 0);
 
+   --------------------------
+   -- Constructors/getters --
+   --------------------------
+
    function Start_Sloc
      (Sloc_Range : Source_Location_Range) return Source_Location
    is ((Line => Sloc_Range.Start_Line, Column => Sloc_Range.Start_Column));
@@ -63,6 +67,10 @@ package Langkit_Support.Slocs is
         Start_Column => Start_Sloc.Column,
         End_Column   => End_Sloc.Column));
 
+   --------------------------
+   -- Location comparisons --
+   --------------------------
+
    function Compare
      (Reference, Compared : Source_Location) return Relative_Position
       with Pre => (Reference /= No_Source_Location
@@ -86,6 +94,16 @@ package Langkit_Support.Slocs is
                   and then Sloc /= No_Source_Location);
    --  Tell where Sloc is with respect to Sloc_Range
 
+   ------------------------
+   -- String conversions --
+   ------------------------
+
+   --  All functions below assume that the textual representation of
+   --  Source_Location values have the form "L:C" (L being the line number, C
+   --  the column number) and Source_Location_Range have the form
+   --  "L1:C1-L2-C2" (L1 and C1 are numbers for the start sloc, L2 and C2 are
+   --  the numbers for the end sloc).
+
    function Image (Sloc : Source_Location) return String is
      (Ada.Strings.Fixed.Trim (Line_Number'Image (Sloc.Line), Left) & ':'
       & Ada.Strings.Fixed.Trim (Column_Number'Image (Sloc.Column), Left));
@@ -95,7 +113,17 @@ package Langkit_Support.Slocs is
       & Image (End_Sloc (Sloc_Range)));
 
    function Image (Sloc : Source_Location) return Text_Type
-   is
-     (To_Text (Image (Sloc)));
+   is (To_Text (Image (Sloc)));
+
+   function Image (Sloc_Range : Source_Location_Range) return Text_Type
+   is (To_Text (Image (Sloc_Range)));
+
+   function Value (T : Text_Type) return Source_Location;
+   function Value (S : String) return Source_Location
+   is (Value (To_Text (S)));
+
+   function Value (T : Text_Type) return Source_Location_Range;
+   function Value (S : String) return Source_Location_Range
+   is (Value (To_Text (S)));
 
 end Langkit_Support.Slocs;

testsuite/tests/langkit_support/slocs/main.adb

@@ -0,0 +1,58 @@
+with Ada.Exceptions; use Ada.Exceptions;
+with Ada.Text_IO;    use Ada.Text_IO;
+
+with Langkit_Support.Slocs; use Langkit_Support.Slocs;
+with Langkit_Support.Text;  use Langkit_Support.Text;
+
+procedure Main is
+
+   procedure Check_Sloc (S : String);
+   procedure Check_Sloc_Range (S : String);
+
+   ----------------
+   -- Check_Sloc --
+   ----------------
+
+   procedure Check_Sloc (S : String) is
+      Sloc : Source_Location;
+   begin
+      Put ("""" & S & """ -> ");
+      Sloc := Value (S);
+      Put_Line (Image (Sloc));
+   exception
+      when Exc : Constraint_Error =>
+         Put_Line ("error: " & Exception_Message (Exc));
+   end Check_Sloc;
+
+   ----------------------
+   -- Check_Sloc_Range --
+   ----------------------
+
+   procedure Check_Sloc_Range (S : String) is
+      SR : Source_Location_Range;
+   begin
+      Put ("""" & S & """ -> ");
+      SR := Value (S);
+      Put_Line (Image (SR));
+   exception
+      when Exc : Constraint_Error =>
+         Put_Line ("error: " & Exception_Message (Exc));
+   end Check_Sloc_Range;
+
+begin
+   Check_Sloc ("0:0");
+   Check_Sloc ("123:456");
+   Check_Sloc ("");
+   Check_Sloc ("1");
+   Check_Sloc (":1");
+   Check_Sloc ("-1:2");
+   Check_Sloc ("a:2");
+
+   Check_Sloc_Range ("1:2-3:4");
+   Check_Sloc_Range ("1:2-3:");
+   Check_Sloc_Range (":2-3:4");
+   Check_Sloc_Range ("1:-3:4");
+   Check_Sloc_Range ("1:2-:4");
+   Check_Sloc_Range ("1:2-3:");
+   Check_Sloc_Range ("1:2-3:-1");
+end Main;

testsuite/tests/langkit_support/slocs/test.out

@@ -0,0 +1,14 @@
+"0:0" -> 0:0
+"123:456" -> 123:456
+"" -> error: invalid source location
+"1" -> error: invalid source location
+":1" -> error: invalid line number: ""
+"-1:2" -> error: invalid line number: "-1"
+"a:2" -> error: invalid line number: "a"
+"1:2-3:4" -> 1:2-3:4
+"1:2-3:" -> error: invalid column number: ""
+":2-3:4" -> error: invalid line number: ""
+"1:-3:4" -> error: invalid column number: ""
+"1:2-:4" -> error: invalid line number: ""
+"1:2-3:" -> error: invalid column number: ""
+"1:2-3:-1" -> error: invalid column number: "-1"

testsuite/tests/langkit_support/slocs/test.yaml

@@ -0,0 +1 @@
+driver: langkit_support