--
-- @filename module-texinfo.adb
-- @author Stephane Riviere
-- @date 26/08/04
-- @brief AdaDoc Texinfo writer module
--
-- History  :
-- Date     Modification               Author
--

with Ada.Text_IO; use Ada.Text_IO;
with Ada.Strings.Unbounded;  use Ada.Strings.Unbounded;
with Ada.Strings.Fixed; use Ada.Strings.Fixed;
with Ada.Characters.Latin_1; use Ada.Characters.Latin_1;

with Ada.Integer_Text_Io; use Ada.Integer_Text_Io;

package body Module.Texinfo is

   Tmp_Comments : Unbounded_String := Null_Unbounded_String; -- Header comments buffer
   File : Ada.Text_IO.File_Type;                             -- File to write Texinfo

   -------------------------------------------------------------------------------
   -- RTL procedures overload
   -------------------------------------------------------------------------------

   -------------------------------------------------------------------------------
   -- Description : Text_IO Put overload Clear the screen to replace some symbols.
   -- Item : Item to output.
   -------------------------------------------------------------------------------
   procedure Put(Item : String) is

      String_Tmp : Unbounded_String := To_Unbounded_String(Item);
      Pattern_Char : String := (1 => Paragraph_Sign);

   begin -- Replacement of Paragrah symbol by "@*" (Texinfo new line)

      while Index(String_Tmp, (1 => Paragraph_Sign)) /= 0 loop
        Replace_Slice (String_Tmp, Index(String_Tmp, (1 => Paragraph_Sign)),
                       Index(String_Tmp, (1 => Paragraph_Sign)), "@*");
      end loop;

      while Index(String_Tmp, "=>") /= 0 loop

         Replace_Slice (String_Tmp, Index(String_Tmp, "=>"),
                        Index(String_Tmp, "=>")+1, "@result{}");
      end loop;

      Ada.Text_IO.Put(To_String(String_Tmp));

   end Put;

   -------------------------------------------------------------------------------
   -- Description : Text_IO Put_Line overload Clear the screen to replace some symbols.
   -- Item : Item to output.
   -------------------------------------------------------------------------------
   procedure Put_Line(Item: String) is
   begin

      Put(Item);
      Ada.Text_IO.New_Line;

   end Put_Line;

   -------------------------------------------------------------------------------
   -- Services procedures for Texinfo page make-up
   -------------------------------------------------------------------------------

   -------------------------------------------------------------------------------
   -- Description : Print subheading title.
   -- Title : Title to print.
   -- Options : Texinfo options from command line
   -------------------------------------------------------------------------------
   procedure Title (Title : String ; Options : String) is
   begin

      New_line;

      -- Replace subheading by subsection if numbered output needed

      if Index(Options, "n") /= 0 then
         Put("@subsection");
      else
         Put("@Subheading");
      end if;

      Put_Line(" " & Title);

   end Title;

   -------------------------------------------------------------------------------
   -- Description} : Print subtitle.
   -- Subtitle} : Subitle to print.
   -------------------------------------------------------------------------------
   procedure Subtitle (Subtitle : String) is
   begin

      New_Line;
      Put_Line("@noindent");
      Put_Line("@strong{" & Subtitle & "}");

   end subtitle;

   -------------------------------------------------------------------------------
   -- Description : Print procedure title.
   -- Name : Procedure name to print.
   -- Options : Texinfo options from command line.
   -------------------------------------------------------------------------------
   procedure Proctitle (Name : String ; Options : String) is
   begin

      New_Line;

      -- Replace procedure header if numbered output needed

      if Index(Options, "n") /= 0 then
         Put_Line("@subsubsection " & Name);
      end if;

      Put_Line("@noindent");
      Put_Line("@cartouche");
      Put_Line("@strong{procedure} " & Name);
      Put_Line("@end cartouche");

   end Proctitle;

   -------------------------------------------------------------------------------
   -- Description : Print function title.
   -- Name : Function name to print.
   -- RetName : Return string to print.
   -- Options : Texinfo options from command line
   -------------------------------------------------------------------------------
   procedure Functitle (Name : String ; RetName : String ; Options : String) is
   begin

      New_Line;

      -- Replace function header if numbered output needed

      if Index(Options, "n") /= 0 then
         Put_Line("@subsubsection " & Name);
      end if;

      Put_Line("@noindent");
      Put_Line("@cartouche");
      Put_Line("@strong{function} " & Name & " @emph{return} " & RetName);
      Put_Line("@end cartouche");

   end Functitle;

   -------------------------------------------------------------------------------
   -- Description : Common print comments.
   -- Atts : Comments container.
   -------------------------------------------------------------------------------
   procedure Print_Comment (Atts : Dict_Type) is
   begin

      if Exist(Atts,"comment") then
         Put("@tab @code{" & Value_Of(Atts,"comment") & "}");
      end if;

   end Print_Comment;

   -------------------------------------------------------------------------------
   -- Description : Common print comments.
   -- Insert comments after} parameters list, as all reference manual usually do.
   -- This is implemented by an awfull global package variable Tmp_Comments.
   -- It's done it this way to avoid heavy code modifications above this module level.
   -------------------------------------------------------------------------------
   procedure Print_Header is

      Begin_Pattern : String := 2 * Paragraph_Sign; -- Two consecutives lines skip

   begin

      if Tmp_Comments /= Null_Unbounded_String then

         if Index(Tmp_Comments,Begin_Pattern) /= 0 then

            Tmp_Comments := delete( Source  => Tmp_Comments, From => 1,
                                    Through => Index(Source => Tmp_Comments, Pattern => Begin_Pattern, Going => Ada.Strings.Backward) + 1
                );

         end if;

         Put_Line("@* " & To_String(Tmp_Comments) & "@*");

         Tmp_Comments := Null_Unbounded_String;

      end if;

   end Print_Header;

   -------------------------------------------------------------------------------
   -- Notifications handlers
   -------------------------------------------------------------------------------


   --------------
   -- A_Choice --
   --------------
   -- Receive notification of each variant part choice.

   procedure A_Choice (Self : Object; Atts : Dict_Type; Its_Value : String) is
   begin

      Put("<!-- CHOICE -->");
      Put("Its_Value");
--    Print_Comment(Atts);

   end A_Choice;

   --------------
   -- A_Clause --
   --------------
   -- Receive notification of each clause.

   procedure A_Clause (Self : Object; Atts : Dict_Type; Its_Value : String) is
   begin
      Put_line("@item " & Its_Value);
--    Print_Comment(Atts);

   end A_Clause;

   ----------------
   -- A_Function --
   ----------------
   -- Receive notification of each function.

   procedure A_Function (Self : Object; Atts : Dict_Type;
                         Its_Name, Its_Return_Type : String; In_Prot_Obj : Boolean) is
   begin

      Print_Header;

      Functitle(Its_Name, Its_Return_Type, Self.Options.All);

      Tmp_Comments := To_Unbounded_String(Value_Of(Atts,"comment"));

   end A_Function;

   ------------------------
   -- A_Generic_Instance --
   ------------------------
   -- Receive notification of each generic instance.

   procedure A_Generic_Instance (Self : Object;  Atts : Dict_Type; Its_Name : String) is
   begin

      Put_line("@item " & Its_Name);
--    Print_Comment(Atts);

   end A_Generic_Instance;

   ------------------------------
   -- A_Package_Subprogram_Gen --
   ------------------------------
   -- Receive notification of each generic package or subprogram.

   procedure A_Package_Subprogram_Gen (Self : Object; Atts : Dict_Type;
                                       Its_Name : String) is
   begin

      Put_line("@item " & Its_Name);
--    Print_Comment(Atts);

   end A_Package_Subprogram_Gen;

   -----------------
   -- A_Parameter --
   -----------------
   -- Receive notification of each parameter (procedure, function, entry).

   procedure A_Parameter (Self : Object; Atts : Dict_Type;
                          Its_Name, Its_Type, Its_Mode : String) is
   begin

      Put_Line("@item " & Its_Name & " @tab " & Its_Type & " @tab @strong{" & Its_Mode & "} @tab " & Value_Of(Atts, "init"));
--    Print_Comment(Atts);

   end A_Parameter;

   -----------------
   -- A_Procedure --
   -----------------
   -- Receive notification of each procedure.

   procedure A_Procedure (Self : Object; Atts : Dict_Type; Its_Name : String;
                                                           In_Prot_Obj : Boolean) is
   begin

      Print_Header;

      Proctitle(Its_Name, Self.Options.All);
      Tmp_Comments := To_Unbounded_String(Value_Of(Atts,"comment"));

--      Put_Line(To_String(Tmp_Comments));

   end A_Procedure;

   --------------
   -- A_Record --
   --------------
   -- Receive notification of each record.

   procedure A_Record (Self : Object; Atts : Dict_Type; Its_Name : String) is
   begin

      New_Line;
      Put_Line("@noindent");

      if Exist(Atts,"null") then
         Put("@strong{Null} ");
      end if;
      if Exist(Atts,"limited") then
         Put("@strong{Limited} ");
      end if;
      if Exist(Atts,"private") then
         Put("@strong{Private} ");
      end if;
      if Exist(Atts,"abstract") then
         Put("@strong{Abstract} ");
      end if;

      if Exist(Atts,"tagged") then
         Put("@strong{Tagged Record} ");
         if Exist(Atts,"inheritance") then
            Put("@strong{Inheritance " & Value_Of(Atts,"inheritance") & "}");
         end if;
      else
         Put("@strong{Record}");
      end if;

      Put_Line(" " & Its_Name);

--    Print_Comment(Atts);

   end A_Record;

   --------------
   -- A_Rename --
   --------------
   -- Receive notification of each rename.

   procedure A_Rename (Self : Object; Atts : Dict_Type; Its_Name : String) is
   begin

      Put_line("@item " & Its_Name);
--      Print_Comment(Atts);

   end A_Rename;

   --
   -- Purpose : Receive notification of each task.
   --
   -- Self     : Object itself.
   -- Atts     : The attributs dictionary of the XML current element.
   -- Its_Name : the task name
   --

   procedure A_Task (Self : Object; Atts : Dict_Type; Its_Name : String) is
   begin

      Put("<!-- TASK -->");
      Put_Line(Its_Name);
      Put_Line("task");
--    Print_Comment(Atts);

   end A_Task;


   -----------------------
   -- A_Type_Definition --
   -----------------------
   -- Receive notification of each type definition.
   procedure A_Type_Definition (Self : Object; Atts : Dict_Type;
                                Its_Name, Its_Def : String) is
   begin

      Put_line("@item " & Its_Name & " @tab " & Its_Def);
--    Print_Comment(Atts);

   end A_Type_Definition;

   --
   -- Purpose : Receive notification of each protected type.
   --
   -- Self     : Object itself.
   -- Atts     : The attributs dictionary of the XML current element.
   -- Its_Name : the protected object name
   --
   procedure A_Protected_Object (Self : Object; Atts : Dict_Type; Its_Name : String) is
   begin

      Put("<!-- PROTECTED OBJECT -->");
      Put_Line(Its_Name);
      Put_Line("protected object");

--      Print_Comment(Atts);

   end A_Protected_Object;

   --------------------
   -- A_Variant_Part --
   --------------------
   -- Receive notification of each variant part.

   procedure A_Variant_Part (Self : Object; Atts : Dict_Type; Its_Discriminant : String)
   is
   begin
      Put("<!-- VARIANT PART -->");
      Put_Line("Variant part " & Its_Discriminant);
--    Print_Comment(Atts);

   end A_Variant_Part;

   --------------
   -- An_Entry --
   --------------
   -- Receive notification of each entry.

   procedure An_Entry (Self : Object; Atts : Dict_Type; Its_Name : String) is
   begin

      Put("<!-- ENTRY -->");
      Put_Line(Its_Name & "Entry");
--    Print_Comment(Atts);

   end An_Entry;

   ------------------
   -- An_Exception --
   ------------------
   -- Receive notification of each exception.

   procedure An_Exception (Self : Object; Atts : Dict_Type; Its_Name : String) is
   begin

      Put_line("@item " & Its_Name);
--    Print_Comment(Atts);

   end An_Exception;

   --------------
   -- A_Pragma --
   --------------
   -- Receive notification of each pragma.

   procedure A_Pragma (Self : Object; Atts : Dict_Type; Its_Name : String) is
   begin

      Put("@item " & Its_Name);

      if Exist(Atts,"args") then
         Put(" @tab " & Value_Of(Atts,"args"));
      end if;

      Print_Comment(Atts);
      New_Line;

   end A_Pragma;

   ---------------------
   -- An_Basic_Object --
   ---------------------
   -- Receive notification of each object.

   procedure An_Object (Self : Object; Atts : Dict_Type; Its_Name,
                        Its_Type : String; Is_Component : Boolean) is

      Col : Natural := 3; -- Number of columns

   begin

      if Exist(Atts,"comment") then
         New_Line;
         Put_Line("@item " & Value_Of(Atts,"comment"));
      end if;

      Put("@item " & Its_Name & " @tab " & Its_Type);
      Put(" @tab " & Value_Of(Atts,"init"));

      if Exist(Atts,"constant") then
         Put(" @tab constant");
         Col := Col + 1;
      end if;
      if Exist(Atts,"mode") then
         Put(" @tab " & Value_Of(Atts,"mode"));
         Col := Col + 1;
      end if;

      New_Line;


   end An_Object;

   -------------------------------------------------------------------------------
   -- Start a group & end an element
   -------------------------------------------------------------------------------

   -------------------------------------------------------------------------------
   -- Description : Receive notification of the beginning of a group of elements.
   -- Self :
   -- Group :
   -------------------------------------------------------------------------------
   procedure Start_Group (Self : Object; Group : Element_Type) is
   begin

      case Group is
         when Is_Clauses =>
            Title("Clauses",Self.Options.All);

         when Is_ContextClauses =>
            Subtitle("Context clauses");
            Put_Line("@itemize @bullet");

         when Is_UseClauses =>
            Subtitle("Use clauses");
            Put_Line("@itemize @bullet");

         when Is_UseTypeClauses =>
            Subtitle("Use type clauses");

         when Is_RepClauses =>
            Subtitle("Representation clauses");

         when Is_GenericParameters =>
            Title("Generics",Self.Options.All);

         when Is_SubpGenericParameters =>
            null;

         when Is_Definitions =>
            Title("Definitions",Self.Options.All);

         when Is_Subprograms =>
            Title("Subprograms",Self.Options.All);

         when Is_Types =>
            Subtitle("Types");
            Put_Line("@multitable @columnfractions .25 .75");
            Put_Line("@item @emph{Name} @tab @emph{Declaration}");

         when Is_Objects =>
            Subtitle("Objects");
            Put_Line("@multitable @columnfractions .25 .25 .25 .25");
            Put_Line("@item @emph{Objects} @tab @emph{Name} @tab @emph{Type} @tab @emph{Default}");

         when Is_GenericInstanciations =>
            Title("Generic instanciations",Self.Options.All);
            Put_Line("@itemize @bullet");

         when Is_PackagesSubprograms =>
            Subtitle("Generic parameters");
            Put_Line("@itemize @bullet");

         when Is_BasicObjects =>
            Title("Basic objects",Self.Options.All);
--          Put_Line("@multitable @columnfractions .25 .15 .10 .25 .15 .10");
            Put_Line("@multitable @columnfractions .40 .20 .25 .15");
            Put_Line("@item @emph{Name} @tab @emph{Type} @tab @emph{Default}");

         when Is_Components =>
            Put_Line("@multitable @columnfractions .25 .25 .50");
            Put_Line("@item @emph{Component} @tab @emph{Type} @tab @emph{Default}");

         when Is_Discriminants =>
            Subtitle("Discriminants");

            Put("<tr><tr><td width=""200"" class=""Clr1""><b><i>Discriminant</i></b></td>");
            Put("    <td width=""200"" class=""Clr2""><b><i>Type</i></b></td>");
            Put_Line("    <td width=""200"" class=""Clr3""><b><i>Default</i></b></td></tr>");

         when Is_Parameters =>
            New_Line;
            Put_Line("@multitable @columnfractions .25 .35 .10 .35");
            Put_Line("@item @emph{Parameter name} @tab @emph{Type} @tab @emph{Mode} @tab @emph{Default}");

         when Is_Exceptions =>
            Subtitle("Exceptions");
            Put_Line("@itemize @bullet");

         when Is_Pragmas =>
            Subtitle("Pragmas");
            Put_Line("@multitable @columnfractions .25 .25 .50");

         when Is_Renames =>
            Subtitle("Renames");
            Put_Line("@itemize @bullet");

         when others =>
            null;

      end case;

   end Start_Group;

   -------------------------------------------------------------------------------
   -- Description : Receive notification of the end of each elements (Module.Element_Type).
   -- Self :
   -- Element :
   -------------------------------------------------------------------------------
   procedure End_Element (Self : Object; Element : Element_Type) is
   begin

      case Element is
         when Is_UseTypeClauses | Is_RepClauses |
              Is_Entry | Is_GenericParameters =>

            null;

         when Is_UseClauses |Is_ContextClauses | Is_Renames | Is_Exceptions |
              Is_PackagesSubprograms | Is_GenericInstanciations =>

            Put_Line("@end itemize");

         when  Is_Parameters | Is_Types | Is_Objects | Is_BasicObjects |
               Is_Components | Is_Pragmas | Is_Task | Is_ProtectedObject =>

            Put_Line("@end multitable");

         when others =>

            null;

      end case;

   end End_Element;

   -------------------------------------------------------------------------------
   -- Initialize and finalize Texinfo document
   -------------------------------------------------------------------------------

   -------------------------------------------------------------------------------
   -- Receive notification of the beginning of a document.
   -- This callback will be called only once.
   -------------------------------------------------------------------------------
   procedure Begin_Document (Self : Object;
                             Package_Name : String;
                             Atts, Tags: Dict_Type) is

      procedure Write_Tag (Title, Value : String) is

      begin
         Put_Line("@item " & Title & " @tab " & Value);
      end Write_Tag;

      procedure Write_Tags is new Run_Through(Write_Tag);

   begin

      Ada.Text_IO.Create(File, Name => Value_Of(Atts, "file")&".texi");
      Ada.Text_IO.Set_Output(File);

      --- Add Texinfo header if stand-alone output needed

      if Index(Self.Options.All, "s") /= 0 then
         Put_Line("\input texinfo   @c -*-texinfo-*-");
         Put_Line("@c %**start of header");
         Put_Line("@setfilename " & Package_Name & ".info"); -- Believe it or not, this line is mandatory to get valid underscore characters
         Put_Line("@afourpaper");
         Put_Line("@c %**end of header");
         New_Line;
      end if;

      Put_Line("@c-----------------------------------------------------------");
      Put_Line("@c Texinfo by AdaDoc (c) 2002 Julien Burdy & Vincent Decorges");
      Put_Line("@c Texinfo module    (c) 2004 Stephane Riviere");
      Put_Line("@c http://adadoc.sf.net");
      Put_Line("@c-----------------------------------------------------------");
      Put_Line("@c Package : " & Package_Name);
      Put_Line("@c-----------------------------------------------------------");

      New_Line;

      --- Add Texinfo contents keyword if stand-alone output needed

      if Index(Self.Options.All, "s") /= 0 then
         Put_Line("@contents");
      end if;

      -- Replace heading by section if numbered output needed

      if Index(Self.Options.All, "n") /= 0 then
         Put("@section");
      else
         Put("@heading");
      end if;
      Put_Line(" Package " & Package_Name);

      --- Header tags output

      if not Is_Empty(Tags) then
         New_Line;
         Put_Line("@cartouche");
         Put_Line("@multitable @columnfractions .15 .85");
         Write_Tags(Tags);
         Put_Line("@end multitable");
         Put_Line("@end cartouche");
      end if;

   end Begin_Document;

   ------------------
   -- End_Document --
   ------------------

   -- Receive notification of the end of a document.
   -- This callback will be called only once.

   procedure End_Document (Self : Object) is
   begin

      Print_Header;

      New_line;
      Put_Line("@c End of Texinfo generation");
      Put_Line("@c-----------------------------------------------------------");

      --- Add Texinfo footer if stand-alone output needed

      if Index(Self.Options.All, "s") /= 0 then
         Put_Line("@bye");
      end if;

      Ada.Text_IO.Set_Output(Ada.Text_IO.Standard_Output);
      Ada.Text_IO.Close(File);

      -- Now console output

      Put_Line("Texinfo is Done !");

   end End_Document;

end Module.Texinfo;
-------------------------------------------------------------------------------

