Packrat.Errors functionality complete and tested

1 files changed, 186 insertions, 10 deletions

diff --git a/src/packrat-errors.adb b/src/packrat-errors.adb
index 44b9202..cb54e97 100644
--- a/src/packrat-errors.adb
+++ b/src/packrat-errors.adb
@@ -1,10 +1,94 @@
 
 
+with
+
+    Ada.Strings.Fixed,
+    Ada.Characters.Handling;
+
+
 separate (Packrat)
 package body Errors is
 
 
     package SU renames Ada.Strings.Unbounded;
+    package SF renames Ada.Strings.Fixed;
+    package CH renames Ada.Characters.Handling;
+
+
+
+
+
+    function Image
+           (Num : in Natural)
+        return String
+    is
+        Raw : String := Integer'Image (Num);
+    begin
+        return Raw (1 + 1 .. Raw'Length);
+    end Image;
+
+
+    function Is_Upper
+           (Char : in Character)
+        return Boolean is
+    begin
+        return Char >= 'A' and Char <= 'Z';
+    end Is_Upper;
+
+
+    function Is_Lower
+           (Char : in Character)
+        return Boolean is
+    begin
+        return Char >= 'a' and Char <= 'z';
+    end Is_Lower;
+
+
+    function Is_Letter
+           (Char : in Character)
+        return Boolean is
+    begin
+        return Is_Upper (Char) or Is_Lower (Char);
+    end Is_Letter;
+
+
+    function Is_Digit
+           (Char : in Character)
+        return Boolean is
+    begin
+        return Char >= '0' and Char <= '9';
+    end Is_Digit;
+
+
+
+
+
+    generic
+        Message : in String;
+    package Parts is
+
+        function Length
+            return Natural;
+
+        procedure Reset_Position;
+
+        procedure Set_Position
+               (To : in Positive);
+
+        procedure Next_ID_Token
+               (Start  : out Positive;
+                Finish : out Natural);
+
+        procedure Next_Pos_Token
+               (Start  : out Positive;
+                Finish : out Natural);
+
+        procedure Next_Full_Token
+               (Start  : out Positive;
+                Finish : out Natural);
+
+    end Parts;
+    package body Parts is separate;
 
 
 
@@ -14,6 +98,29 @@ package body Errors is
            (Check : in String)
         return Boolean is
     begin
+        if Check'Length < 1 then
+            return False;
+        end if;
+        if not Is_Letter (Check (Check'First)) then
+            return False;
+        end if;
+        for N in Integer range Check'First + 1 .. Check'Last - 1 loop
+            if  not Is_Letter (Check (N)) and
+                not Is_Digit (Check (N)) and
+                Check (N) /= '_'
+            then
+                return False;
+            end if;
+            if  Check (N) = '_' and
+                ((not Is_Letter (Check (N - 1)) and not Is_Digit (Check (N - 1))) or
+                 (not Is_Letter (Check (N + 1)) and not Is_Digit (Check (N + 1))))
+            then
+                return False;
+            end if;
+        end loop;
+        if not Is_Letter (Check (Check'Last)) and not Is_Digit (Check (Check'Last)) then
+            return False;
+        end if;
         return True;
     end Valid_Identifier;
 
@@ -22,7 +129,7 @@ package body Errors is
            (Check : in SU.Unbounded_String)
         return Boolean is
     begin
-        return True;
+        return Valid_Identifier (-Check);
     end Valid_Identifier;
 
 
@@ -30,14 +137,46 @@ package body Errors is
            (Check : in Error_Info_Array)
         return Boolean is
     begin
+        for EI of Check loop
+            if not Valid_Identifier (-EI.Symbol) then
+                return False;
+            end if;
+        end loop;
         return True;
     end Valid_Identifier_Array;
 
 
     function Valid_Message
            (Check : in String)
-        return Boolean is
+        return Boolean
+    is
+        S_Place, P_Place : Natural := 1;
     begin
+        while S_Place <= Check'Length loop
+            if Check (S_Place) /= 's' then
+                return False;
+            end if;
+            P_Place := SF.Index (Check, "p", S_Place);
+            if (P_Place < S_Place) then
+                return False;
+            end if;
+            declare
+                ID : String := Check (S_Place + 1 .. P_Place - 1);
+            begin
+                if not Valid_Identifier (ID) or ID /= CH.To_Upper (ID) then
+                    return False;
+                end if;
+            end;
+            P_Place := P_Place + 1;
+            if P_Place > Check'Length or else not Is_Digit (Check (P_Place)) then
+                return False;
+            end if;
+            loop
+                P_Place := P_Place + 1;
+                exit when P_Place > Check'Length or else not Is_Digit (Check (P_Place));
+            end loop;
+            S_Place := P_Place;
+        end loop;
         return True;
     end Valid_Message;
 
@@ -47,9 +186,32 @@ package body Errors is
 
     function Join
            (Left, Right : in Error_Message)
-        return Error_Message is
+        return Error_Message
+    is
+        package Left_Parts is new Parts (Left);
+        package Right_Parts is new Parts (Right);
+
+        LS, LF, RS, RF : Natural;
+        Add : Boolean;
+
+        Result : SU.Unbounded_String := +Left;
     begin
-        return "";
+        for R in Integer range 1 .. Right_Parts.Length loop
+            Add := True;
+            Right_Parts.Next_Full_Token (RS, RF);
+            for L in Integer range 1 .. Left_Parts.Length loop
+                Left_Parts.Next_Full_Token (LS, LF);
+                if Left (LS .. LF) = Right (RS .. RF) then
+                    Add := False;
+                    exit;
+                end if;
+            end loop;
+            if Add then
+                SU.Append (Result, +Right (RS .. RF));
+            end if;
+            Left_Parts.Reset_Position;
+        end loop;
+        return -Result;
     end Join;
 
 
@@ -61,7 +223,7 @@ package body Errors is
             Pos  : in Natural)
         return Error_Message is
     begin
-        return "";
+        return "s" & CH.To_Upper (Name) & "p" & Image (Pos);
     end Encode;
 
 
@@ -70,7 +232,7 @@ package body Errors is
             Pos  : in Natural)
         return Error_Message is
     begin
-        return "";
+        return Encode (-Name, Pos);
     end Encode;
 
 
@@ -78,15 +240,20 @@ package body Errors is
            (Info : in Error_Info)
         return Error_Message is
     begin
-        return "";
+        return Encode (-Info.Symbol, Info.Position);
     end Encode;
 
 
     function Encode_Array
            (Info : in Error_Info_Array)
-        return Error_Message is
+        return Error_Message
+    is
+        Result : SU.Unbounded_String := SU.To_Unbounded_String (0);
     begin
-        return "";
+        for EI of Info loop
+            SU.Append (Result, (Encode (-EI.Symbol, EI.Position)));
+        end loop;
+        return -Result;
     end Encode_Array;
 
 
@@ -94,8 +261,17 @@ package body Errors is
            (Msg : in Error_Message)
         return Error_Info_Array
     is
-        Result : Error_Info_Array (1 .. 0);
+        package Msg_Parts is new Parts (Msg);
+
+        Result : Error_Info_Array (1 .. Msg_Parts.Length);
+        Start, Finish : Natural;
     begin
+        for EI of Result loop
+            Msg_Parts.Next_ID_Token (Start, Finish);
+            EI.Symbol := +Msg (Start .. Finish);
+            Msg_Parts.Next_Pos_Token (Start, Finish);
+            EI.Position := Integer'Value (Msg (Start .. Finish));
+        end loop;
         return Result;
     end Decode;