--  Abstract :
--
--  See spec.
--
--  Copyright (C) 2018, 2021 Free Software Foundation, Inc.
--
--  This library is free software;  you can redistribute it and/or modify it
--  under terms of the  GNU General Public License  as published by the Free
--  Software  Foundation;  either version 3,  or (at your  option) any later
--  version. This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY;  without even the implied warranty of MERCHAN-
--  TABILITY or FITNESS FOR A PARTICULAR PURPOSE.

--  As a special exception under Section 7 of GPL version 3, you are granted
--  additional permissions described in the GCC Runtime Library Exception,
--  version 3.1, as published by the Free Software Foundation.

pragma License (Modified_GPL);

package body WisiToken.Generate.Packrat is

   function Potential_Direct_Right_Recursive
     (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
      Empty   : in Token_ID_Set)
     return Token_ID_Set
   is
      subtype Nonterminal is Token_ID range Grammar.First_Index .. Grammar.Last_Index;
   begin
      return Result : Token_ID_Set (Nonterminal) := (others => False) do
         for Prod of Grammar loop
            RHS_Loop :
            for RHS of Prod.RHSs loop
               ID_Loop :
               for I in reverse RHS.Tokens.First_Index + 1 .. RHS.Tokens.Last_Index loop
                  declare
                     ID : constant Token_ID := RHS.Tokens (I);
                  begin
                     if ID = Prod.LHS then
                        Result (ID) := True;
                        exit RHS_Loop;
                     elsif not (ID in Nonterminal) then
                        exit ID_Loop;
                     elsif not Empty (ID) then
                        exit ID_Loop;
                     end if;
                  end;
               end loop ID_Loop;
            end loop RHS_Loop;
         end loop;
      end return;
   end Potential_Direct_Right_Recursive;

   procedure Indirect_Left_Recursive (Data : in out Packrat.Data)
   is
   begin
      for Prod_I of Data.Grammar loop
         for Prod_J of Data.Grammar loop
            Data.Involved (Prod_I.LHS, Prod_J.LHS) :=
              Data.First (Prod_I.LHS, Prod_J.LHS) and
              Data.First (Prod_J.LHS, Prod_I.LHS);
         end loop;
      end loop;
   end Indirect_Left_Recursive;

   ----------
   --  Public subprograms

   function Initialize
     (Source_File_Name : in String;
      Grammar          : in WisiToken.Productions.Prod_Arrays.Vector;
      Source_Line_Map  : in Productions.Source_Line_Maps.Vector;
      First_Terminal   : in Token_ID)
     return Packrat.Data
   is
      Empty : constant Token_ID_Set := WisiToken.Generate.Has_Empty_Production (Grammar);
   begin
      return Result : Packrat.Data :=
        (First_Terminal        => First_Terminal,
         First_Nonterminal     => Grammar.First_Index,
         Last_Nonterminal      => Grammar.Last_Index,
         Source_File_Name      => +Source_File_Name,
         Grammar               => Grammar,
         Source_Line_Map       => Source_Line_Map,
         Empty                 => Empty,
         Direct_Left_Recursive => Potential_Direct_Left_Recursive (Grammar, Empty),
         First                 => WisiToken.Generate.First (Grammar, Empty, First_Terminal => First_Terminal),
         Involved              => (others => (others => False)))
      do
         Indirect_Left_Recursive (Result);
      end return;
   end Initialize;

   procedure Check_Recursion (Data : in Packrat.Data; Descriptor : in WisiToken.Descriptor)
   is
      Right_Recursive : constant Token_ID_Set := Potential_Direct_Right_Recursive (Data.Grammar, Data.Empty);
   begin
      for Prod of Data.Grammar loop
         if Data.Direct_Left_Recursive (Prod.LHS) and Right_Recursive (Prod.LHS) then
            --  We only implement the simplest left recursion solution ([warth
            --  2008] figure 3); [tratt 2010] section 6.3 gives this condition for
            --  that to be valid.
            --  FIXME packrat: not quite? definite direct right recursive ok?
            --  FIXME packrat: for indirect left recursion, need potential indirect right recursive check?
            Put_Error
              (Error_Message
                 (-Data.Source_File_Name, Data.Source_Line_Map (Prod.LHS).Line, "'" & Image (Prod.LHS, Descriptor) &
                    "' is both left and right recursive; not supported."));
         end if;

         for I in Data.Involved'Range (2) loop
            if Prod.LHS /= I and then Data.Involved (Prod.LHS, I) then
               Put_Error
                 (Error_Message
                    (-Data.Source_File_Name, Data.Source_Line_Map (Prod.LHS).Line, "'" & Image (Prod.LHS, Descriptor) &
                       "' is indirect recursive with " & Image (I, Descriptor) & ", not supported"));
            end if;
         end loop;
      end loop;
   end Check_Recursion;

   procedure Check_RHS_Order
     (Data       : in Packrat.Data;
      Descriptor : in WisiToken.Descriptor;
      Suppress   : in WisiToken.BNF.String_Pair_Lists.List)
   is
      use all type Ada.Containers.Count_Type;
   begin
      for Prod of Data.Grammar loop
         --  Empty must be last
         for I in Prod.RHSs.First_Index .. Prod.RHSs.Last_Index - 1 loop
            if Prod.RHSs (I).Tokens.Length = 0 then
               Put_Error
                 (Error_Message
                    (-Data.Source_File_Name, Data.Source_Line_Map (Prod.LHS).RHS_Map (I),
                     "right hand side" & Integer'Image (I) & " in " & Image (Prod.LHS, Descriptor) &
                       " is empty, but not last; no later right hand side will match."));
               WisiToken.Generate.Error := True;
            end if;
         end loop;

         for I in Prod.RHSs.First_Index + 1 .. Prod.RHSs.Last_Index loop
            declare
               Cur : Token_ID_Arrays.Vector renames Prod.RHSs (I).Tokens;
            begin
               --  Shared prefix; longer must be first. Sometimes this is a useful
               --  message, for example:
               --
               --  NAME
               --    : IDENTIFIER
               --    | IDENTIFIER TICK IDENTIFIER
               --
               --  The second will never get a chance to match. Other times it is
               --  wrong, because other tokens distinguish the RHSs:
               --
               --  Object_Decl
               --    : IDENTIFIER ':' IDENTIFIER ';'
               --    | IDENTIFIER ':' IDENTIFIER := expression ';'
               --
               --  So we make it a warning, and provide %suppress.
               --  See test/bnf/object_declaration for a working example.

               for J in Prod.RHSs.First_Index .. I - 1 loop
                  declare
                     Prev : Token_ID_Arrays.Vector renames Prod.RHSs (J).Tokens;
                     K    : constant Natural := Shared_Prefix (Prev, Cur);
                  begin
                     if K > 0 and Prev.Length < Cur.Length then
                        if not Suppress.Contains
                          ((Name => +Descriptor.Image (Prod.LHS).all,
                            Value => +"may never match; it shares a prefix"))
                        then
                           Put_Warning
                             (Error_Message
                                (-Data.Source_File_Name, Data.Source_Line_Map (Prod.LHS).RHS_Map (I),
                                 "right hand side" & Integer'Image (I) & " in " & Image (Prod.LHS, Descriptor) &
                                   " may never match; it shares a prefix with a shorter previous rhs" &
                                   Integer'Image (J) & ".",
                                 Warning => True));
                        end if;
                     end if;
                  end;
               end loop;

               --  recursion; typical LALR list is written:
               --
               --  statement_list
               --    : statement
               --    | statement_list statement
               --    ;
               --  association_list
               --    : association
               --    | association_list COMMA association
               --    ;
               --
               --  a different recursive definition:
               --
               --  name
               --    : IDENTIFIER
               --    | name LEFT_PAREN range_list RIGHT_PAREN
               --    | name actual_parameter_part
               --    ...
               --    ;
               --
               --  For packrat, the recursive RHSs must come before others:
               --
               --  statement_list
               --    : statement_list statement
               --    | statement
               --    ;
               --  association_list
               --    : association_list COMMA association
               --    | association
               --    ;
               --  name
               --    : name LEFT_PAREN range_list RIGHT_PAREN
               --    | name actual_parameter_part
               --    | IDENTIFIER
               --    ...
               --    ;
               declare
                  Prev : Token_ID_Arrays.Vector renames Prod.RHSs (I - 1).Tokens;
               begin
                  if Cur.Length > 0 and then Prev.Length > 0 and then
                    Cur (1) = Prod.LHS and then Prev (1) /= Prod.LHS
                  then
                     Put_Error
                       (Error_Message
                          (-Data.Source_File_Name, Data.Source_Line_Map (Prod.LHS).Line,
                           "recursive right hand sides must be before others."));
                  end if;
               end;
            end;
         end loop;
      end loop;
   end Check_RHS_Order;

   procedure Check_All
     (Data       : in Packrat.Data;
      Descriptor : in WisiToken.Descriptor;
      Suppress   : in WisiToken.BNF.String_Pair_Lists.List)
   is begin
      Check_Recursion (Data, Descriptor);
      Check_RHS_Order (Data, Descriptor, Suppress);
   end Check_All;

   function Potential_Direct_Left_Recursive
     (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
      Empty   : in Token_ID_Set)
     return Token_ID_Set
   is
      subtype Nonterminal is Token_ID range Grammar.First_Index .. Grammar.Last_Index;
   begin
      --  FIXME packrat: this duplicates the computation of Data.First; if keep Data.First,
      --  change this to use it.
      return Result : Token_ID_Set (Nonterminal) := (others => False) do
         for Prod of Grammar loop
            RHS_Loop :
            for RHS of Prod.RHSs loop
               ID_Loop :
               for ID of RHS.Tokens loop
                  if ID = Prod.LHS then
                     Result (ID) := True;
                     exit RHS_Loop;
                  elsif not (ID in Nonterminal) then
                     exit ID_Loop;
                  elsif not Empty (ID) then
                     exit ID_Loop;
                  end if;
               end loop ID_Loop;
            end loop RHS_Loop;
         end loop;
      end return;
   end Potential_Direct_Left_Recursive;

end WisiToken.Generate.Packrat;
