path: root/src/packrat-lexer.adb

package body Packrat.Lexer 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;





    function Stamp
           (Input   : in     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 (Gen_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     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;





    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 : 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 := +Label_Enum'Image (Label_List.Element (I));
            Error_Info_List (I).Position := Position;
        end loop;
        raise Lexer_Error with Errors.Encode_Array (Error_Info_List);
    end Raise_Lexer_Error;


    function Token_Vector_To_Array
           (Input_Vector : in Token_Vectors.Vector)
        return Gen_Tokens.Token_Array
    is
        Result_Array : Gen_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     Gen_Tokens.Token;
            Output_Array :    out Gen_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 Element_Array)
        return Element_Array
    is
        subtype Slider is Element_Array (1 .. Input'Length);
    begin
        return Slider (Input);
    end Slide;


    procedure Internal_Scan_Core
           (Input      : in     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;





    function Scan
           (Input   : in     Element_Array;
            Context : in out Lexer_Context)
        return Gen_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;


    function Scan_Only
           (Input   : in     Element_Array;
            Context : in out Lexer_Context)
        return Gen_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_Only;


    function Scan_With
           (Input   : in     With_Input;
            Context : in out Lexer_Context)
        return Gen_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_With;


    procedure Scan_Set
           (Input   : in     Element_Array;
            Context : in out Lexer_Context;
            Output  :    out Gen_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_Set;


    procedure Scan_Set_With
           (Input   : in     With_Input;
            Context : in out Lexer_Context;
            Output  :    out Gen_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_Set_With;





    function Sequence
           (Input : in 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 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 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 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 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 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 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 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 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 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 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 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 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 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.Lexer;