path: root/src/packrat-errors.adb

--  This source is licensed under the Sunset License v1.0


with

    Ada.Strings.Fixed,
    Ada.Characters.Handling,
    Ada.Characters.Latin_1;


package body Packrat.Errors is


    package SU renames Ada.Strings.Unbounded;
    package SF renames Ada.Strings.Fixed;
    package CH renames Ada.Characters.Handling;
    package Latin renames Ada.Characters.Latin_1;





    function Image
           (Num : in Natural)
        return String
    is
        Raw : String := Integer'Image (Num);
    begin
        return Raw (Raw'First + 1 .. Raw'Last);
    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;





    function Valid_Identifier
           (Check : in String)
        return Boolean
    is
        All_Digit : Boolean;
    begin
        if Check'Length < 1 then
            return False;
        end if;

        --  Have to relax requirements to allow Integers and such
        --  since there is no way to require a generic parameter to
        --  *only* be an enumeration.
        All_Digit := True;
        for N in Integer range Check'First .. Check'Last loop
            if not Is_Digit (Check (N)) then
                All_Digit := False;
                exit;
            end if;
        end loop;
        if All_Digit then
            return True;
        end if;

        --  Regular checks for a valid identifier.
        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;


    function Valid_Identifier
           (Check : in SU.Unbounded_String)
        return Boolean is
    begin
        return Valid_Identifier (-Check);
    end Valid_Identifier;


    function Valid_Identifier_Array
           (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
        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'Last or else not Is_Digit (Check (P_Place)) then
                return False;
            end if;
            loop
                P_Place := P_Place + 1;
                exit when P_Place > Check'Last or else not Is_Digit (Check (P_Place));
            end loop;
            S_Place := P_Place;
        end loop;
        return True;
    end Valid_Message;


    function Debug_String
           (This : in Error_Message)
        return String
    is
        Result : SU.Unbounded_String := +"";
        Info : Error_Info_Array := Decode (This);
    begin
        for E of Info loop
            SU.Append (Result, "Expected " & (-E.Symbol) &
                " at input position" & Integer'Image (E.Position) & Latin.LF);
        end loop;
        return -Result;
    end Debug_String;





    function Join
           (Left, Right : in Error_Message)
        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
        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;





    function Encode
           (Name : in String;
            Pos  : in Natural)
        return Error_Message is
    begin
        return "s" & CH.To_Upper (Name) & "p" & Image (Pos);
    end Encode;


    function Encode
           (Name : in SU.Unbounded_String;
            Pos  : in Natural)
        return Error_Message is
    begin
        return Encode (-Name, Pos);
    end Encode;


    function Encode
           (Info : in Error_Info)
        return Error_Message is
    begin
        return Encode (-Info.Symbol, Info.Position);
    end Encode;


    function Encode_Array
           (Info : in Error_Info_Array)
        return Error_Message
    is
        Result : SU.Unbounded_String := SU.To_Unbounded_String (0);
    begin
        for EI of Info loop
            SU.Append (Result, (Encode (-EI.Symbol, EI.Position)));
        end loop;
        return -Result;
    end Encode_Array;


    function Decode
           (Msg : in Error_Message)
        return Error_Info_Array
    is
        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;


end Packrat.Errors;