------------------------------------------------------------------------------
--                             G N A T C O L L                              --
--                                                                          --
--                     Copyright (C) 2010-2015, AdaCore                     --
--                                                                          --
-- 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.                            --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
-- You should have received a copy of the GNU General Public License and    --
-- a copy of the GCC Runtime Library Exception along with this program;     --
-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
-- <http://www.gnu.org/licenses/>.                                          --
--                                                                          --
------------------------------------------------------------------------------

--  This software was originally contributed by William A. Duff

with Ada.Command_Line;
with Ada.Command_Line.Remove;
with Ada.Strings.Unbounded;    use Ada.Strings.Unbounded;
with Ada.Text_IO;              use Ada, Ada.Text_IO;
with Ada.Text_IO.Unbounded_IO; use Ada.Text_IO.Unbounded_IO;
with GNAT.Command_Line;        use GNAT.Command_Line;
with GNAT.OS_Lib;
with GNAT.Regpat;              use GNAT.Regpat;
with GNATCOLL.Mmap;            use GNATCOLL.Mmap;

package body GNATCOLL.Paragraph_Filling.Tests is

   procedure Command_Line_Error;
   pragma No_Return (Command_Line_Error);
   --  Print usage message and exit with bad status code

   type File_Mapping is record
      Str  : GNATCOLL.Mmap.Str_Access;
      Last : Integer;
   end record;

   function Get_EOL
     (File  : File_Mapping;
      Start : Integer) return Integer;
   --  Return the last character of the line starting at Start.
   --  The last character is, in general, the trailing ASCII.LF

   function Get_Paragraph
     (File  : File_Mapping;
      Start : Integer) return Integer;
   --  Find the last character of the paragraph starting at Start.
   --  Paragraphs are separated by blank lines. Considers extra blank lines to
   --  be paragraphs.

   function Pretty_Fill_Wrapper
      (Paragraph       : String;
       Max_Line_Length : Positive := Default_Max_Line_Length;
       Line_Prefix     : String := "")
       return Ada.Strings.Unbounded.Unbounded_String;
   --  Makes Pretty_Fill compatible with the Formatter profile.

   procedure Format_Ada_File
     (Input, Output   : Text_IO.File_Type;
      Format          : Formatter;
      Max_Line_Length : Positive;
      Line_Prefix     : String);
   --  Same as above, except it takes open Input and Output files

   type Item_Kind is (End_Of_File, Single_Line, Comment, Dummy_Kind);
   --  Dummy_Kind is not really used; it is just there because we need a
   --  default for the Kind discriminant.

   --  We parse the input file into a sequence of "items". Each item is a
   --  single non-comment line of code (which could have a comment at the end),
   --  a comment, or the end-of-file mark.

   --  Comments are treated differently by Get_Line and Get_Item, both of which
   --  return an Item. Get_Line recognizes a single comment line, with nothing
   --  but whitespace before the "--". Get_Item (which calls Get_Line) collects
   --  multiple comment lines that form a block into a single Comment item.

   --  Example: Suppose the input contains:
   --    --  This is
   --    --  a comment.
   --    if Blah then  --  Non-comment line
   --  ^
   --  |
   --  start of line is here.
   --  Then Get_Line will return these Items:
   --
   --    (Kind => Comment, Prefix => "  --  ", Text => "This is" & NL)
   --    (Kind => Comment, Prefix => "  --  ", Text => "a comment." & NL)
   --    (Kind => Single_Line, Line => "if Blah then  --  Non-comment line");
   --    (Kind => End_Of_File)
   --
   --  Get_Item will combine the first two into one:
   --
   --    (Kind => Comment, Prefix => "  --  ",
   --      Text => "This is" & NL & "a comment." & NL)
   --    (Kind => Single_Line, Line => "if Blah then  --  Non-comment line");
   --    (Kind => End_Of_File)
   --
   --  The comment Text is suitable for passing to the paragraph formatting
   --  routine.  We need to reattach the Prefix on output.

   type Item (Kind : Item_Kind := Dummy_Kind) is record
      case Kind is
         when End_Of_File | Dummy_Kind =>
            null;

         when Single_Line =>
            Line : Unbounded_String;
         --  The text of the line, with no LF terminator

         when Comment =>
            Prefix : Unbounded_String;
            --  The prefix of the comment line or comment block
            Text : Unbounded_String;
            --  For Get_Line: the text of the comment line followed by NL.
            --  For Get_Item: the text of the comment block, with NL used as
            --  line terminator.
            --  In both cases, the Prefix has been removed.
      end case;
   end record;

   Cur_Line : Item;
   --  Current item read by Get_Line. Used as a lookahead by Get_Item
   --
   Comment_Pattern : constant Pattern_Matcher := Compile ("^\s*--\s\s?[^\s]");
   --  Start of line, followed by zero or more spaces, followed by the Ada
   --  comment marker "--", followed by one or two spaces, followed by a
   --  non-space. If there are more than two spaces after "--", then we don't
   --  recognize it as a comment line (it's an indented comment, which should
   --  not be reformatted). We also don't recognize it as a comment line if
   --  there is no space after "--".

   procedure Put_Item (Output : Text_IO.File_Type; X : Item);
   --  Send X to the Output. Single_Lines are sent unchanged. For Comments, we
   --  convert NL's to New_Line calls, and prefix each line with Prefix.

   function Comment_Prefix_Last (Line : String) return Natural;
   --  If Line is a comment line, this returns the index of the last character
   --  of the comment prefix. Example: for " -- xxx", returns 4, pointing just
   --  before the first x. If it's not a comment line, returns 0.

   procedure Get_Line (Input : Text_IO.File_Type; Line_Item : out Item);
   --  Get the next item from the Input, treating a comment line as a single
   --  Item.

   procedure Get_Item (Input : Text_IO.File_Type; Result : out Item);
   --  Same as Get_Line, except this combines multiple comment lines that form
   --  a comment block into a single Comment Item.

   ------------------------
   -- Command_Line_Error --
   ------------------------

   procedure Command_Line_Error is
   begin
      Put_Line ("Usage: "
        & Ada.Command_Line.Command_Name & " [options] infile [outfile]");
      Put_Line ("  options:");
      Put_Line ("    --none -- no formatting");
      Put_Line ("    --greedy");
      Put_Line ("    --pretty");
      Put_Line ("    --knuth");
      New_Line;
      Put_Line ("    -L n (n = maximum line length; default ="
              & Default_Max_Line_Length'Img & ")");
      New_Line;
      Put_Line
         ("If outfile is not specified, the output is displayed on stdout");
      GNAT.OS_Lib.OS_Exit (Status => -1);
   end Command_Line_Error;

   -------------------------
   -- Comment_Prefix_Last --
   -------------------------

   function Comment_Prefix_Last (Line : String) return Natural is
      Matches : Match_Array (0 .. 0);
   begin
      Match (Comment_Pattern, Line, Matches);
      if Matches (0) /= No_Match then
         pragma Assert (Matches (0).First = Line'First);

         --  If the comment line ends with "--", we don't recognize it as a
         --  comment line, because it's probably part of the copyright header,
         --  which we don't want to reformat.

         if Line (Line'Last - 1 .. Line'Last) = "--" then
            Matches (0) := No_Match;
         end if;
      end if;

      return Matches (0).Last;
      --  Note that Matches (0).Last will be 0 if it didn't match
   end Comment_Prefix_Last;

   ---------------------
   -- Format_Ada_File --
   ---------------------

   procedure Format_Ada_File
     (Input, Output   : Text_IO.File_Type;
      Format          : Formatter;
      Max_Line_Length : Positive;
      Line_Prefix     : String)
   is

      procedure Form
        (Text            : in out Unbounded_String;
         Max_Line_Length : Positive);
      --  Wrapper to call Format converting the types as necessary

      ----------
      -- Form --
      ----------

      procedure Form
        (Text            : in out Unbounded_String;
         Max_Line_Length : Positive)
      is
      begin
         Text := Format (To_String (Text), Max_Line_Length, Line_Prefix);
      end Form;

      Cur_Item : Item;

   --  Start of processing for Format_Ada_File

   begin
      --  Initialize the lookahead

      Get_Line (Input, Cur_Line);

      --  Loop through all the Items, and send them to the Output, calling
      --  Format first for Comment items.

      loop
         Get_Item (Input, Cur_Item);
         exit when Cur_Item.Kind = End_Of_File;
         if Cur_Item.Kind = Comment then
            Form
              (Cur_Item.Text,
               Max_Line_Length => Max_Line_Length - Length (Cur_Item.Prefix));
         end if;
         Put_Item (Output, Cur_Item);
      end loop;
   end Format_Ada_File;

   ---------------------
   -- Format_Ada_File --
   ---------------------

   procedure Format_Ada_File (Context : Formatting_Context) is
      Input, Output : Text_IO.File_Type;
   begin
      Open (Input, In_File, Name => Context.Input_Name.all);

      if Context.Output_Name.all = "" then
         Format_Ada_File
           (Input, Text_IO.Current_Output,
            Context.Format, Context.Max_Line_Length,
            Line_Prefix => Context.Line_Prefix.all);
      else
         Create
           (Output,
            Out_File,
            Name => Context.Output_Name.all,
            Form => "Text_Translation=No");
         Format_Ada_File
           (Input, Output, Context.Format, Context.Max_Line_Length,
            Line_Prefix => Context.Line_Prefix.all);
         Close (Output);
      end if;

      Close (Input);
   end Format_Ada_File;

   ----------------------
   -- Format_Text_File --
   ----------------------

   procedure Format_Text_File (Context : Formatting_Context) is
      Input   : Mapped_File;
      Input_M : File_Mapping;
      Output  : File_Access;
      Real    : aliased File_Type;
      Index   : Integer;
      Para    : Integer;
   begin
      Input := Open_Read (Filename => Context.Input_Name.all);
      Read (Input);
      Input_M := (Str => Data (Input), Last => Last (Input));

      if Context.Output_Name.all = "" then
         Output := Standard_Output;
      else
         Create
           (Real, Out_File, Context.Output_Name.all,
            Form => "Text_Translation=No");
         Output := Real'Unchecked_Access;
      end if;

      Index := Input_M.Str'First;
      while Index <= Input_M.Last loop
         Para := Get_Paragraph (Input_M, Start => Index);

         --  ??? Where do empty paragraphs come from, and should the Fill
         --  subprograms work on empty paragraphs?

         if Para <= Index then
            New_Line (Output.all);
            Para := Index;
         else
            Put_Line
              (Output.all,
               Context.Format
                 (String (Input_M.Str (Index .. Para)),
                  Context.Max_Line_Length,
                  Line_Prefix => Context.Line_Prefix.all));
         end if;

         Index := Para + 1;
      end loop;

      Close (Input);

      if Context.Output_Name.all /= "" then
         Close (Real);
      end if;
   end Format_Text_File;

   --------------
   -- Get_Item --
   --------------

   procedure Get_Item (Input : Text_IO.File_Type; Result : out Item) is
   begin
      Result := Cur_Line;
      case Result.Kind is
         when End_Of_File =>
            null;

         when Dummy_Kind =>
            raise Program_Error;

         when Single_Line =>
            Get_Line (Input, Cur_Line);

         --  Combine multiple comment lines into a comment block if they have
         --  the same Prefix.

         when Comment =>
            loop
               Get_Line (Input, Cur_Line);
               exit when Cur_Line.Kind /= Comment
                        or else Cur_Line.Prefix /= Result.Prefix;
               Append (Result.Text, Cur_Line.Text);
            end loop;
      end case;
   end Get_Item;

   --------------
   -- Get_Line --
   --------------

   procedure Get_Line (Input : Text_IO.File_Type; Line_Item : out Item) is
   begin
      if End_Of_File (Input) then
         Line_Item := (Kind => End_Of_File);
      else
         declare
            Line : constant String  := Get_Line (Input);
            Last : constant Natural := Comment_Prefix_Last (Line);
         begin
            --  Not a comment line; return Single_Line
            if Last = 0 then
               Line_Item :=
                 (Kind => Single_Line,
                  Line => To_Unbounded_String (Line));

            --  A comment line. Split it into two parts, the prefix and the
            --  comment text, and terminate with LF.

            else
               declare
                  Prefix : String renames Line (Line'First .. Last - 1);
                  Suffix : String renames Line (Last .. Line'Last);
               begin
                  Line_Item :=
                    (Kind   => Comment,
                     Prefix => To_Unbounded_String (Prefix),
                     Text   => To_Unbounded_String (Suffix));
                  Append (Line_Item.Text, ASCII.LF);
               end;
            end if;
         end;
      end if;
   end Get_Line;

   -------------
   -- Get_EOL --
   -------------

   function Get_EOL
     (File  : File_Mapping;
      Start : Integer) return Integer
   is
      Last : Integer := Start;
   begin
      while Last <= File.Last
        and then File.Str (Last) /= ASCII.LF
      loop
         Last := Last + 1;
      end loop;

      if Last <= File.Last then
         return Last;
      else
         return File.Last;
      end if;
   end Get_EOL;

   -------------------
   -- Get_Paragraph --
   -------------------

   function Get_Paragraph
     (File  : File_Mapping;
      Start : Integer) return Integer
   is
      Paragraph : Unbounded_String := Null_Unbounded_String;
      Last      : Integer := Start;
      EOL       : Integer;
   begin
      while Last <= File.Last loop
         EOL := Get_EOL (File, Last);
         exit when EOL <= Last;  --  a blank line

         Last := EOL + 1;
      end loop;

      --  Current line is empty, end of paragraph is end of previous line
      return Last - 1;
   end Get_Paragraph;

   -------------------------
   -- Pretty_Fill_Wrapper --
   -------------------------

   function Pretty_Fill_Wrapper
      (Paragraph       : String;
       Max_Line_Length : Positive := Default_Max_Line_Length;
       Line_Prefix     : String := "")
       return Ada.Strings.Unbounded.Unbounded_String
   is
      pragma Unreferenced (Line_Prefix);
   begin
      return Pretty_Fill (Paragraph, Max_Line_Length);
   end Pretty_Fill_Wrapper;

   --------------------------
   -- Process_Command_Line --
   --------------------------

   function Process_Command_Line return Formatting_Context is
      type Formatting_Methods is (None, Greedy, Pretty, Knuth);

      Context   : Formatting_Context;
      Opts      : constant String :=
         "-none -greedy -pretty -knuth L? -prefix=";
      Arg_Index : Positive := 1;
      Method    : Formatting_Methods := Knuth;
   begin
      loop
         case Getopt (Opts) is
            when 'L' =>
               Context.Max_Line_Length := Positive'Value (Parameter);
            when '-' =>
               if Full_Switch = "-none" then
                  Method := None;
               elsif Full_Switch = "-greedy" then
                  Method := Greedy;
               elsif Full_Switch = "-pretty" then
                  Method := Pretty;
               elsif Full_Switch = "-knuth" then
                  Method := Knuth;
               elsif Full_Switch = "-prefix" then
                  Context.Line_Prefix := new String'(Parameter);
               end if;
            when others =>
               exit;
         end case;
      end loop;

      Context.Input_Name  := new String'(Get_Argument);
      Context.Output_Name := new String'(Get_Argument);

      if Context.Line_Prefix = null then
         Context.Line_Prefix := new String'("");
      end if;

      if Context.Input_Name.all = "" then
         raise Invalid_Parameter;
      end if;

      case Method is
         when None =>
            Context.Format := No_Fill'Access;

         when Greedy =>
            Context.Format := Greedy_Fill'Access;

         when Pretty =>
            Context.Format := Pretty_Fill_Wrapper'Access;

         when Knuth =>
            Context.Format := Knuth_Fill'Access;
      end case;

      return Context;

   exception
      when Invalid_Switch | Invalid_Parameter =>
         Command_Line_Error;
   end Process_Command_Line;

   --------------
   -- Put_Item --
   --------------

   procedure Put_Item (Output : Text_IO.File_Type; X : Item) is
   begin
      case X.Kind is
         when End_Of_File | Dummy_Kind =>
            raise Program_Error;

         when Single_Line =>
            Put_Line (Output, X.Line);

         when Comment =>
            Put (Output, X.Prefix);
            for J in 1 .. Length (X.Text) loop
               declare
                  C : constant Character := Element (X.Text, J);
               begin
                  case C is
                     when ASCII.LF =>
                        New_Line (Output);
                        if J < Length (X.Text) then
                           Put (Output, X.Prefix);
                        end if;
                     when others =>
                        Put (Output, C);
                  end case;
               end;
            end loop;
      end case;
   end Put_Item;

end GNATCOLL.Paragraph_Filling.Tests;
