path: root/src/packrat-lexers.adb

with

    Packrat.Errors;


package body Packrat.Lexers is


    function Join
           (Left, Right : in Combinator_Result)
        return Combinator_Result is
    begin
        if Left.Status = Success or Left.Status = Optional_More then
            return (Integer'Max (Left.Finish, Right.Finish), Right.Status);
        elsif Left.Status = Needs_More then
            return (Left.Finish, Failure);
        else
            return Left;
        end if;
    end Join;





    procedure Tidy_Context
           (Details     : in out Lexer_Context;
            Number_Comp : in     Ada.Containers.Count_Type) is
    begin
        Details.Pass_Forward.Clear;

        Details.Empty_Labels.Clear;
        Details.Error_Labels.Clear;
        Details.Error_Labels.Reserve_Capacity (Number_Comp);

        Details.Offset := Details.Offset + Details.Position - 1;
        Details.Position := 1;
        Details.Status := Success;
    end Tidy_Context;


    procedure Raise_Lexer_Error
           (Label_List : in Label_Vectors.Vector;
            Position   : in Positive)
    is
        Error_Info_List : Packrat.Errors.Error_Info_Array
           (Label_List.First_Index .. Label_List.Last_Index);
    begin
        for I in Integer range Error_Info_List'First .. Error_Info_List'Last loop
            Error_Info_List (I).Symbol := +Traits.Label_Enum'Image (Label_List.Element (I));
            Error_Info_List (I).Position := Position;
        end loop;
        raise Lexer_Error with Packrat.Errors.Encode_Array (Error_Info_List);
    end Raise_Lexer_Error;


    function Token_Vector_To_Array
           (Input_Vector : in Token_Vectors.Vector)
        return Traits.Tokens.Token_Array
    is
        Result_Array : Traits.Tokens.Token_Array (1 .. Integer (Input_Vector.Length));
    begin
        for I in Integer range 1 .. Integer (Input_Vector.Length) loop
            Result_Array (I) := Input_Vector.Element (I);
        end loop;
        return Result_Array;
    end Token_Vector_To_Array;


    procedure Token_Vector_To_Array
           (Input_Vector : in     Token_Vectors.Vector;
            Padding      : in     Traits.Tokens.Token_Type;
            Output_Array :    out Traits.Tokens.Token_Array) is
    begin
        for N in Integer range 1 .. Output_Array'Length loop
            if N <= Integer (Input_Vector.Length) then
                Output_Array (Output_Array'First + N - 1) := Input_Vector.Element (N);
            else
                Output_Array (Output_Array'First + N - 1) := Padding;
            end if;
        end loop;
    end Token_Vector_To_Array;


    function Slide
           (Input : in Traits.Element_Array)
        return Traits.Element_Array
    is
        subtype Slider is Traits.Element_Array (1 .. Input'Length);
    begin
        return Slider (Input);
    end Slide;


    procedure Internal_Scan_Core
           (Input      : in     Traits.Element_Array;
            Context    : in out Lexer_Context;
            Components : in     Component_Array)
    is
        Raise_Error : Boolean;
    begin
        Raise_Error := True;
        for C of Components loop
            if C (Input, Context) = Component_Success then
                Raise_Error := False;
                exit;
            end if;
        end loop;
        if Raise_Error then
            Raise_Lexer_Error (Context.Error_Labels, Context.Position);
        end if;
    end Internal_Scan_Core;





    package body Scan_Parts is

        Context : Lexer_Context := Empty_Context;

        function Scan
               (Input : in Traits.Element_Array)
            return Traits.Tokens.Token_Array
        is
            Real_Input : Input_Holders.Holder;
        begin
            if not Context.Pass_Forward.Is_Empty then
                Real_Input.Replace_Element (Slide (Context.Pass_Forward.Element) & Input);
            else
                Real_Input.Replace_Element (Input);
            end if;
            Tidy_Context (Context, Components'Length);
            Context.Result_So_Far.Clear;
            Context.Allow_Incomplete := Input'Length > 0;
            while Context.Status = Success and Context.Position <= Real_Input.Element'Length loop
                Internal_Scan_Core (Real_Input.Element, Context, Components);
            end loop;
            return Token_Vector_To_Array (Context.Result_So_Far);
        end Scan;

        procedure Reset is
        begin
            Context := Empty_Context;
        end Reset;

    end Scan_Parts;


    package body Scan_Once is

        Context : Lexer_Context := Empty_Context;

        function Scan
               (Input : in Traits.Element_Array)
            return Traits.Tokens.Token_Array
        is
            Real_Input : Input_Holders.Holder;
        begin
            if not Context.Pass_Forward.Is_Empty then
                Real_Input.Replace_Element (Slide (Context.Pass_Forward.Element) & Input);
            else
                Real_Input.Replace_Element (Input);
            end if;
            Tidy_Context (Context, Components'Length);
            Context.Result_So_Far.Clear;
            Context.Allow_Incomplete := False;
            while Context.Status = Success and Context.Position <= Real_Input.Element'Length loop
                Internal_Scan_Core (Real_Input.Element, Context, Components);
            end loop;
            return Token_Vector_To_Array (Context.Result_So_Far);
        end Scan;

        procedure Reset is
        begin
            Context := Empty_Context;
        end Reset;

    end Scan_Once;


    package body Scan_With is

        Context : Lexer_Context := Empty_Context;

        function Scan
               (Input : in With_Input)
            return Traits.Tokens.Token_Array
        is
            Real_Input : Input_Holders.Holder;
            Empty_Input : Boolean;
        begin
            Context.Result_So_Far.Clear;
            loop
                Real_Input.Replace_Element (Input.all);
                Empty_Input := Real_Input.Element'Length = 0;
                if not Context.Pass_Forward.Is_Empty then
                    Real_Input.Replace_Element
                        (Slide (Context.Pass_Forward.Element) & Real_Input.Element);
                end if;
                Tidy_Context (Context, Components'Length);
                Context.Allow_Incomplete := not Empty_Input;
                while Context.Status = Success and
                    Context.Position <= Real_Input.Element'Length
                loop
                    Internal_Scan_Core (Real_Input.Element, Context, Components);
                end loop;
                if Empty_Input then
                    exit;
                end if;
            end loop;
            return Token_Vector_To_Array (Context.Result_So_Far);
        end Scan;

        procedure Reset is
        begin
            Context := Empty_Context;
        end Reset;

    end Scan_With;


    package body Scan_Set is

        Context : Lexer_Context := Empty_Context;

        procedure Scan
               (Input  : in     Traits.Element_Array;
                Output :    out Traits.Tokens.Token_Array)
        is
            Real_Input : Input_Holders.Holder;
        begin
            if not Context.Pass_Forward.Is_Empty then
                Real_Input.Replace_Element (Slide (Context.Pass_Forward.Element) & Input);
            else
                Real_Input.Replace_Element (Input);
            end if;
            Tidy_Context (Context, Components'Length);
            Context.Result_So_Far.Clear;
            Context.Allow_Incomplete := not (Input'Length = 0 or else Input (Input'First) = Pad_In);
            while Context.Status = Success and then
                Integer (Context.Result_So_Far.Length) < Output'Length and then
                Context.Position <= Real_Input.Element'Length and then
                Real_Input.Element (Context.Position) /= Pad_In
            loop
                Internal_Scan_Core (Real_Input.Element, Context, Components);
            end loop;
            if Integer (Context.Result_So_Far.Length) = Output'Length then
                Context.Pass_Forward.Replace_Element
                    (Real_Input.Element (Context.Position .. Real_Input.Element'Last));
            end if;
            Token_Vector_To_Array (Context.Result_So_Far, Pad_Out, Output);
        end Scan;

        procedure Reset is
        begin
            Context := Empty_Context;
        end Reset;

    end Scan_Set;


    package body Scan_Set_With is

        Context : Lexer_Context := Empty_Context;

        procedure Scan
               (Input  : in     With_Input;
                Output :    out Traits.Tokens.Token_Array)
        is
            Real_Input : Input_Holders.Holder;
            Empty_Input : Boolean;
        begin
            Context.Result_So_Far.Clear;
            loop
                Real_Input.Replace_Element (Input.all);
                Empty_Input := Real_Input.Element'Length = 0 or else
                    Real_Input.Element (Real_Input.Element'First) = Pad_In;
                if not Context.Pass_Forward.Is_Empty then
                    Real_Input.Replace_Element
                        (Slide (Context.Pass_Forward.Element) & Real_Input.Element);
                end if;
                Tidy_Context (Context, Components'Length);
                Context.Allow_Incomplete := not Empty_Input;
                while Context.Status = Success and then
                    Integer (Context.Result_So_Far.Length) < Output'Length and then
                    Context.Position <= Real_Input.Element'Length and then
                    Real_Input.Element (Context.Position) /= Pad_In
                loop
                    Internal_Scan_Core (Real_Input.Element, Context, Components);
                end loop;
                if Empty_Input then
                    exit;
                end if;
                if Integer (Context.Result_So_Far.Length) = Output'Length then
                    Context.Pass_Forward.Replace_Element
                        (Real_Input.Element (Context.Position .. Real_Input.Element'Last));
                    exit;
                end if;
            end loop;
            Token_Vector_To_Array (Context.Result_So_Far, Pad_Out, Output);
        end Scan;

        procedure Reset is
        begin
            Context := Empty_Context;
        end Reset;

    end Scan_Set_With;





    function Stamp
           (Input   : in     Traits.Element_Array;
            Context : in out Lexer_Context)
        return Component_Result
    is
        Current_Result : Combinator_Result :=
            Combo (Input, Context.Position);
    begin
        if  Context.Status /= Success or Context.Position > Input'Last or
            Context.Empty_Labels.Contains (Label)
        then
            return Component_Failure;
        end if;

        if (Current_Result.Status = Needs_More and not Context.Allow_Incomplete) or
            Current_Result.Status = Failure
        then
            Context.Error_Labels.Append (Label);
            return Component_Failure;
        end if;

        if (Current_Result.Status = Optional_More and not Context.Allow_Incomplete) or
            Current_Result.Status = Success
        then
            Context.Result_So_Far.Append (Traits.Tokens.Create
               (Label,
                Context.Position + Context.Offset,
                Input (Context.Position .. Current_Result.Finish)));
            if Current_Result.Finish = 0 then
                Context.Empty_Labels.Insert (Label);
            else
                Context.Empty_Labels.Clear;
                Context.Position := Current_Result.Finish + 1;
            end if;
        else
            Context.Status := Current_Result.Status;
            Context.Pass_Forward.Replace_Element
                (Input (Context.Position .. Current_Result.Finish));
            Context.Empty_Labels.Clear;
        end if;

        Context.Error_Labels.Clear;
        return Component_Success;
    end Stamp;


    function Ignore
           (Input   : in     Traits.Element_Array;
            Context : in out Lexer_Context)
        return Component_Result
    is
        Current_Result : Combinator_Result :=
            Combo (Input, Context.Position);
    begin
        if  Context.Status /= Success or Context.Position > Input'Last or
            Context.Empty_Labels.Contains (Label)
        then
            return Component_Failure;
        end if;

        if (Current_Result.Status = Needs_More and not Context.Allow_Incomplete) or
            Current_Result.Status = Failure
        then
            Context.Error_Labels.Append (Label);
            return Component_Failure;
        end if;

        if (Current_Result.Status = Optional_More and not Context.Allow_Incomplete) or
            Current_Result.Status = Success
        then
            if Current_Result.Finish = 0 then
                Context.Empty_Labels.Insert (Label);
            else
                Context.Empty_Labels.Clear;
                Context.Position := Current_Result.Finish + 1;
            end if;
        else
            Context.Status := Current_Result.Status;
            Context.Pass_Forward.Replace_Element
                (Input (Context.Position .. Current_Result.Finish));
            Context.Empty_Labels.Clear;
        end if;

        Context.Error_Labels.Clear;
        return Component_Success;
    end Ignore;





    function Sequence
           (Input : in Traits.Element_Array;
            Start : in Positive)
        return Combinator_Result
    is
        Result : Combinator_Result := (0, Success);
        Position : Positive := Start;
    begin
        if Start > Input'Last then
            return Empty_Fail;
        end if;
        for C of Params loop
            if Position > Input'Last then
                Result.Status := Needs_More;
                exit;
            end if;
            Result := Join (Result, C (Input, Position));
            exit when Result.Status = Failure;
            Position := Result.Finish + 1;
        end loop;
        return Result;
    end Sequence;


    function Count
           (Input : in Traits.Element_Array;
            Start : in Positive)
        return Combinator_Result
    is
        Result : Combinator_Result := (0, Success);
        Position : Positive := Start;
    begin
        if Start > Input'Last then
            return Empty_Fail;
        end if;
        for I in Integer range 1 .. Number loop
            if Position > Input'Last then
                Result.Status := Needs_More;
                exit;
            end if;
            Result := Join (Result, Param (Input, Position));
            exit when Result.Status = Failure;
            Position := Result.Finish + 1;
        end loop;
        return Result;
    end Count;


    function Many
           (Input : in Traits.Element_Array;
            Start : in Positive)
        return Combinator_Result
    is
        Result : Combinator_Result := (0, Success);
        Temp   : Combinator_Result;
        Position : Positive := Start;
        Counter  : Natural := 0;
    begin
        if Start > Input'Last then
            return Empty_Fail;
        end if;
        loop
            exit when Position > Input'Last;
            Temp := Param (Input, Position);
            exit when Temp.Status = Failure or Temp.Status = Needs_More;
            Result := Join (Result, Temp);
            Counter := Counter + 1;
            Position := Result.Finish + 1;
        end loop;
        if Counter < Minimum then
            if Position > Input'Last or Temp.Status = Needs_More then
                Result.Status := Needs_More;
            else
                Result.Status := Failure;
            end if;
        elsif Position > Input'Last or Temp.Status = Needs_More then
            Result.Status := Optional_More;
        else
            Result.Status := Success;
        end if;
        return Result;
    end Many;


    function Many_Until
           (Input : in Traits.Element_Array;
            Start : in Positive)
        return Combinator_Result
    is
        Result : Combinator_Result := (0, Success);
        Temp   : Combinator_Result;
        Position : Positive := Start;
        Counter  : Natural := 0;
    begin
        if Start > Input'Last then
            return Empty_Fail;
        end if;
        loop
            exit when Position > Input'Last;
            Temp := Param (Input, Position);
            exit when Temp.Status = Failure or Temp.Status = Needs_More or Test (Input (Position));
            Result := Join (Result, Temp);
            Counter := Counter + 1;
            Position := Result.Finish + 1;
        end loop;
        if Counter < Minimum then
            if Position > Input'Last or Temp.Status = Needs_More then
                Result.Status := Needs_More;
            else
                Result.Status := Failure;
            end if;
        elsif Position > Input'Last then
            Result.Status := Needs_More;
        elsif Temp.Status = Needs_More and Test (Input (Position)) then
            Result.Status := Optional_More;
        elsif Test (Input (Position)) then
            Result.Status := Success;
        else
            Result.Status := Failure;
        end if;
        return Result;
    end Many_Until;





    function Satisfy
           (Input : in Traits.Element_Array;
            Start : in Positive)
        return Combinator_Result is
    begin
        if Start > Input'Last then
            return Empty_Fail;
        elsif Test (Input (Start)) then
            return (Start, Success);
        else
            return Empty_Fail;
        end if;
    end Satisfy;


    function Satisfy_With
           (Input : in Traits.Element_Array;
            Start : in Positive)
        return Combinator_Result is
    begin
        if Start > Input'Last then
            return Empty_Fail;
        elsif Test (Change (Input (Start))) then
            return (Start, Success);
        else
            return Empty_Fail;
        end if;
    end Satisfy_With;


    function Match
           (Input : in Traits.Element_Array;
            Start : in Positive)
        return Combinator_Result is
    begin
        if Start > Input'Last then
            return Empty_Fail;
        elsif Input (Start) = Item then
            return (Start, Success);
        else
            return Empty_Fail;
        end if;
    end Match;


    function Match_With
           (Input : in Traits.Element_Array;
            Start : in Positive)
        return Combinator_Result is
    begin
        if Start > Input'Last then
            return Empty_Fail;
        elsif Change (Input (Start)) = Item then
            return (Start, Success);
        else
            return Empty_Fail;
        end if;
    end Match_With;


    function Multimatch
           (Input : in Traits.Element_Array;
            Start : in Positive)
        return Combinator_Result
    is
        Current_Offset : Natural := 0;
    begin
        if Items'Length = 0 then
            return (0, Success);
        end if;

        if Input'Last - Start + 1 <= 0 then
            return Empty_Fail;
        end if;

        while Input (Start + Current_Offset) = Items (Items'First + Current_Offset) loop
            if Items'First + Current_Offset = Items'Last then
                return (Start + Current_Offset, Success);
            elsif Start + Current_Offset = Input'Last then
                return (Start + Current_Offset, Needs_More);
            end if;
            Current_Offset := Current_Offset + 1;
        end loop;
        if Current_Offset = 0 then
            return Empty_Fail;
        else
            return (Start + Current_Offset - 1, Failure);
        end if;
    end Multimatch;


    function Take
           (Input : in Traits.Element_Array;
            Start : in Positive)
        return Combinator_Result is
    begin
        if Start > Input'Last then
            return Empty_Fail;
        elsif Start + Number - 1 > Input'Last then
            return (Input'Last, Needs_More);
        else
            return (Start + Number - 1, Success);
        end if;
    end Take;


    function Take_While
           (Input : in Traits.Element_Array;
            Start : in Positive)
        return Combinator_Result
    is
        Finish : Positive := Start;
        Status : Result_Status;
    begin
        if Start > Input'Last or else not Test (Input (Start)) then
            return Empty_Fail;
        end if;
        while Finish <= Input'Last and then Test (Input (Finish)) loop
            Finish := Finish + 1;
        end loop;
        if Finish > Input'Last then
            Status := Optional_More;
        else
            Status := Success;
        end if;
        return (Finish - 1, Status);
    end Take_While;


    function Take_Until
           (Input : in Traits.Element_Array;
            Start : in Positive)
        return Combinator_Result
    is
        Finish : Positive := Start;
        Status : Result_Status;
    begin
        if Start > Input'Last or else Test (Input (Start)) then
            return Empty_Fail;
        end if;
        while Finish <= Input'Last and then not Test (Input (Finish)) loop
            Finish := Finish + 1;
        end loop;
        if Finish > Input'Last then
            Status := Optional_More;
        else
            Status := Success;
        end if;
        return (Finish - 1, Status);
    end Take_Until;





    function Line_End
           (Input : in Traits.Element_Array;
            Start : in Positive)
        return Combinator_Result is
    begin
        if Start > Input'Last then
            return Empty_Fail;
        elsif Input (Start) = EOL_Item then
            return (Start, Success);
        else
            return Empty_Fail;
        end if;
    end Line_End;


    function Input_End
           (Input : in Traits.Element_Array;
            Start : in Positive)
        return Combinator_Result is
    begin
        if Start > Input'Last then
            return Empty_Fail;
        elsif Input (Start) = EOF_Item then
            return (Start, Success);
        else
            return Empty_Fail;
        end if;
    end Input_End;


end Packrat.Lexers;