--
-- @filename module-html.adb
-- @author Julien Burdy & Vincent Decorges
-- @date 17.6.02
-- @brief AdaDoc HTML writer module
--
-- History  :
-- Date     Modification               Author
--
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Strings.Unbounded;  use Ada.Strings.Unbounded;

package body Module.HTML is

   -- File to write HTML
   File : Ada.Text_IO.File_Type;

   --
   -- Purpose : Write a title with quick access to others titles.
   --
   -- Name : Name of the current title.
   --
   procedure Title_And_Quick_Access (Name : String) is
   begin
      Put_Line("<!-- Title + quick access -->");
      Put_Line("&nbsp;");
      Put_Line("<h1>"&Name&"<a name="""&Name&"""></a></h1>");
      Put_Line("<h2>Quick access :");
      Put_Line("<a href=""#Clauses"">Clauses</a> -&nbsp;");
      Put_Line("<a href=""#Generics"">Generics</a> -&nbsp;");
      Put_Line("<a href=""#Definitions"">Definitions</a> -&nbsp;");
      Put_Line("<a href=""#Subprograms"">Subprograms</a></h2><hr>");
   end Title_And_Quick_Access;


   --
   -- Purpose : Overload of the Text_IO put to replace some symbols.
   --
   -- Item : Item to put.
   --
   procedure Put(Item: String) is

      String_Tmp : Unbounded_String := To_Unbounded_String(Item);

   begin -- Replacement of some symbols

      while Index(String_Tmp, "¶") /= 0 loop
         Replace_Slice (String_Tmp, Index(String_Tmp, "¶"),
                        Index(String_Tmp, "¶"), "<BR>");
      end loop;

      while Index(String_Tmp, "<>") /= 0 loop
         Replace_Slice (String_Tmp, Index(String_Tmp, "<>"),
                        Index(String_Tmp, "<>")+1, "&lt;&gt;");
      end loop;

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

   end Put;


   --
   -- Purpose : Overload of the Text_IO put_line.
   --
   -- Item : Item to put.
   --
   procedure Put_Line(Item: String) is
   begin
      Put(Item);
      Ada.Text_IO.New_Line;
   end Put_Line;


   --------------
   -- A_Choice --
   --------------
   -- Receive notification of each variant part choice.
   procedure A_Choice (Self : Object; Atts : Dict_Type; Its_Value : String) is
   begin
      Put("<tr></tr><tr><td class=""Clr3""><b>Variant part => "&Its_Value&"</b></td>");
      if Exist(Atts,"comment") then
         Put("<td colspan=""2"" class=""Comm"" >"&Value_Of(Atts,"comment")&"</td>");
      end if;
      Put_Line("</tr>");
   end A_Choice;


   --------------
   -- A_Clause --
   --------------
   -- Receive notification of each clause.
   procedure A_Clause (Self : Object; Atts : Dict_Type; Its_Value : String) is
   begin
      Put("<tr><td class=""Clr4"">"&Its_Value&"</td>");
      if Exist(Atts,"comment") then
         Put("<td colspan=""2"" class=""Comm"" >"&Value_Of(Atts,"comment")&"</td>");
      end if;
      Put_Line("</tr>");
   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
      Put_Line("&nbsp;&nbsp;<table><tr><td><table><tr><th width=""200"" class=""Clr1""><b>"&Its_Name&
                               "</b></th><td width=""200"" class=""Clr5""> <i>function</i></td></tr>");
      Put_Line("<tr><td class=""Clr2""><b><i>Return</i></b></td><td class=""Clr3"">"&
                   "<a href=""#"&Its_Return_Type&""">"&Its_Return_Type&"</a></td></tr>");
      if Exist(Atts,"comment") then
         Put("<tr><td colspan=""2"" class=""Comm"" >"&Value_Of(Atts,"comment")&
                                                                           "</td></tr>");
      end if;
      Put_Line("</table>");
   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("<tr><td class=""Clr4"">"&Its_Name&"</td></tr>");
      if Exist(Atts,"comment") then
         Put_Line(" <tr><td colspan=""2"" class=""Comm"">"&Value_Of(Atts,"comment")&
                                                                  "</td></tr><tr></tr>");
      end if;
   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("<tr><td class=""Clr4"">"&Its_Name&"</td></tr>");
      if Exist(Atts,"comment") then
         Put_Line(" <tr><td colspan=""2"" class=""Comm"">"&Value_Of(Atts,"comment")&
                                                                  "</td></tr><tr></tr>");
      end if;
   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("<tr><td class=""Clr2"">"&Its_Name&"</td><td class=""Clr3"">");
      Put("<a href=""#"&Its_Type&""">"&Its_Type&"</a></td><td class=""Clr4""><b>");
      Put(Its_Mode&"</b></td><td class=""Clr5"">");
      Put(Value_Of(Atts, "init")&"</td></tr>");
      if Exist(Atts,"comment") then
         Put("<tr><td colspan=""2"" class=""Comm"" >"&Value_Of(Atts,"comment")
                                                                 &"</td></tr><tr></tr>");
      end if;
      New_Line;
   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
      Put_Line("&nbsp;&nbsp;<table><tr><td><table><tr><th width=""200"" class=""Clr1""><b>"&Its_Name
                             &"</b></th><td width=""200"" class=""Clr5""> <i>procedure</i></td></tr>");
      if Exist(Atts,"comment") then
         Put("<tr><td colspan=""2"" class=""Comm"" >"&Value_Of(Atts,"comment")&
                                                                           "</td></tr>");
      end if;
      Put_Line("</table>");

   end A_Procedure;


   --------------
   -- A_Record --
   --------------
   -- Receive notification of each record.
   procedure A_Record (Self : Object; Atts : Dict_Type; Its_Name : String) is
   begin
      Put_Line("&nbsp;&nbsp;&nbsp;<table><tr><td><table><tr><th width=""200"" class=""Clr1""><b>" &
               "<a name="""&Its_Name&""">"&
               Its_Name&"</a></b></th><td width=""200"" class=""Clr5""><i>");

      if Exist(Atts,"null") then
         Put("null ");
      end if;
      if Exist(Atts,"limited") then
         Put("limited ");
      end if;
      if Exist(Atts,"private") then
         Put("private ");
      end if;
      if Exist(Atts,"abstract") then
         Put("abstract ");
      end if;
      if Exist(Atts,"tagged") then
         Put_Line("tagged record</i></td></tr>");
         if Exist(Atts,"inheritance") then
            Put_Line("<tr><td width=""200"" class=""Clr4""><b>inheritance from </b></td>"&
                             "<td width=""200"" class=""Clr5""><a href=""#"&
                             Value_Of(Atts,"inheritance")&""">"&
                             Value_Of(Atts,"inheritance")&"</a>"&
                             "</td></tr>");
         end if;
      else
         Put_Line("record</i></td></tr>");
      end if;

      if Exist(Atts,"comment") then
         Put("<tr><td colspan=""2"" class=""Comm"" >"&Value_Of(Atts,"comment")&
                                                                           "</td></tr>");
      end if;
   end A_Record;

   --------------
   -- A_Rename --
   --------------
   -- Receive notification of each rename.
   procedure A_Rename (Self : Object; Atts : Dict_Type; Its_Name : String) is
   begin
      Put("<tr><td class=""Clr4"">"&Its_Name&"</td></tr>");

      if Exist(Atts,"comment") then
         Put_Line(" <tr><td class=""Comm"">"&Value_Of(Atts,"comment")&"</td></tr><tr>");
      end if;
   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_Line("&nbsp;&nbsp;&nbsp;<table><tr><td><table><tr><th width=""200"" class=""Clr1""><b>" &
               "<a name="""&Its_Name&""">"&
               Its_Name&"</a></b></th><td class=""Clr5""><i>");

      Put_Line("task</i></td></tr>");

      if Exist(Atts,"comment") then
         Put("<tr><td colspan=""2"" class=""Comm"" >"&Value_Of(Atts,"comment")&
                                                                           "</td></tr>");
      end if;
   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("<tr><td class=""Clr3""><a name="""&Its_Name&""">"&Its_Name&"</a></td>");
      Put_Line("<td width=""600"" class=""Clr4"">"&Its_Def&"</td></tr>");
      if Exist(Atts,"comment") then
         Put_Line("<tr><td colspan=""2"" class=""Comm"" >"&Value_Of(Atts,"comment")&"</td></tr><tr></tr>");
      end if;
   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_Line("&nbsp;&nbsp;&nbsp;<table><tr><td><table><tr><th width=""200"" class=""Clr1""><b>" &
               "<a name="""&Its_Name&""">"&
               Its_Name&"</a></b></th><td class=""Clr5""><i>");

      Put_Line("protected object</i></td></tr>");

      if Exist(Atts,"comment") then
         Put("<tr><td colspan=""2"" class=""Comm"" >"&Value_Of(Atts,"comment")&
                                                                           "</td></tr>");
      end if;
   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_Line("<tr></tr><tr><td class=""Clr4""><b>Variant part</b></td>"&
                             "<td class=""Clr5""><b>"&Its_Discriminant&"</b></td></tr>");
      if Exist(Atts,"comment") then
         Put_Line(" <tr><td colspan=""1"" class=""Comm"">"&Value_Of(Atts,"comment")
                                                                          &"</td></tr>");
      end if;
   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_Line("&nbsp;&nbsp;<table><tr><th width=""200"" class=""Clr1""><b>"&Its_Name
                                 &"</b></th><td class=""Clr5""> <i>entry</i></td></tr>");
      if Exist(Atts,"comment") then
         Put("<tr><td colspan=""2"" class=""Comm"" >"&Value_Of(Atts,"comment")&
                                                                           "</td></tr>");
      end if;
   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("<tr><td class=""Clr4"">"&Its_Name&"</td></tr>");
      if Exist(Atts,"comment") then
         Put_Line(" <tr><td class=""Comm"">"&Value_Of(Atts,"comment")&"</td></tr><tr>");
      end if;
   end An_Exception;

   --------------
   -- A_Pragma --
   --------------
   -- Receive notification of each pragma.
   procedure A_Pragma (Self : Object; Atts : Dict_Type; Its_Name : String) is
   begin
      Put("<tr><td class=""Clr4"">"&Its_Name&"</td>");
      if Exist(Atts,"args") then
         Put("<td class=""Clr3"">"&Value_Of(Atts,"args")&"</td>");
      end if;
      Put_Line("</tr>");
      if Exist(Atts,"comment") then
         Put_Line(" <tr><td class=""Comm"">"&Value_Of(Atts,"comment")&"</td></tr><tr>");
      end if;
   end A_Pragma;


   ---------------
   -- An_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
      Put("<tr><td class=""Clr2"">"&Its_Name&"</td>");
      Put("<td class=""Clr3""><a href=""#"&Its_Type&""">"&Its_Type&"</a></td>");
      Put("<td class=""Clr4"">"&Value_Of(Atts,"init")&"</td>");
      if Exist(Atts,"constant") then
         Put("<td width=""200"">constant</td>");
         Col := Col + 1;
      end if;
      if Exist(Atts,"mode") then
         Put("<td width=""200"">"&Value_Of(Atts,"mode")&"</td>");
         Col := Col + 1;
      end if;
      Put_Line("</tr>");
      if Exist(Atts,"comment") then
         Put("<tr><td colspan="""&Natural'Image(Col)&""" class=""Comm"">"&
         Value_Of(Atts,"comment")&"</td></tr><tr></tr>");
      end if;
   end An_Object;


   --------------------
   -- Begin_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("<tr><td><b>"&Title&"</b></td><td>"&Value&"</td></tr></p>");
      end Write_Tag;

      procedure Write_Tags is new Run_Through(Write_Tag);

   begin

      Ada.Text_IO.Create(File, Name => Value_Of(Atts, "file")&".html");
      Ada.Text_IO.Set_Output(File);
      Put_Line("<html><head>");
      Put_Line("<!-- HTML by AdaDoc (c)2002 Julien Burdy & Vincent Decorges -->");
      Put_Line("<!-- http://adadoc.sf.net -->");
      Put_Line("<title>"&Package_Name&" (Package ADA 95)</title>");
      if Self.Options.All'Length = 0 then
         Put_Line("<!-- Default StyleSheet -->");
         Put_Line("<style type=""text/css"">");
         Put_Line("Body{font-size:medium;font-family:'Arial Ce';background-color:white;}");
         Put_Line("H1 {font-size : large;font-family : 'Arial Black';}");
         Put_Line("H2 {font-size : small;font-family : 'Arial Narow';}");
         Put_Line("Th {font-size : small;font-weight : bold;text-align : left;}");
         Put_Line("Td {font-size : x-small;border : 0.1em solid ;border-color : #aaaaff;}");
         Put_Line("A:link {color : #2d37ff;text-decoration : none;}");
         Put_Line("A:visited {color : #2d37ff;text-decoration : none;}");
         Put_Line("A:hover {color : #696dff;text-decoration : none;}");
         Put_Line(".Clr0 {background : #696dff;}");
         Put_Line(".Clr1 {background : #aaaaff;}");
         Put_Line(".Clr2 {background : #bbbbff;}");
         Put_Line(".Clr3 {background : #ccccff;}");
         Put_Line(".Clr4 {background : #ddddff;}");
         Put_Line(".Clr5 {background : #eeeeff;}");
         Put_Line(".Comm {background : #eeeeff; font-style: italic}");
         Put_Line("</style>");
      else
         Put_Line("<link rel=""stylesheet"" type=""text/css"" href="""&Self.Options.All&""">");
      end if;
      
      Put_Line("</head><body>");
      Put_Line("<h1>Package "&Package_Name&"</h1>");

      if Exist(Atts, "comment") then
         Put_Line("<!-- Table  comment -->");
         Put_Line("<table width = 590><tr><td class=""Comm"">");
         Put_Line(Value_Of(Atts,"comment"));
         Put_Line("</td></tr></table>");
      end if;

      if not Is_Empty(Tags) then
         Put_Line("<table>");
         Write_Tags(Tags);
         Put_Line("</table>");
      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
      Put_Line("</body></html>");
      Ada.Text_IO.Set_Output(Ada.Text_IO.Standard_Output);
      Ada.Text_IO.Close(File);
      Put_Line("HTML is Done!");
   end End_Document;


   -----------------
   -- End_Element --
   -----------------
   -- Receive notification of the end of each elements (Module.Element_Type).
   procedure End_Element (Self : Object; Element : Element_Type) is
   begin
      case Element is
         when Is_ContextClauses | Is_UseClauses | Is_UseTypeClauses | Is_RepClauses |
              Is_GenericInstanciations | Is_Entry |
              Is_PackagesSubprograms | Is_Renames |
              Is_Exceptions | Is_GenericParameters | Is_Pragmas =>

            Put_Line("</table>");
         when Is_Task | Is_ProtectedObject =>
            Put_Line("</td></tr></table>");
         when Is_Objects | Is_BasicObjects | Is_Types |Is_Function | Is_Procedure | Is_Record =>
            Put_Line("</table></td></tr></table>");
         when others => null;
      end case;
   end End_Element;


   -----------------
   -- Start_Group --
   -----------------
   -- Receive notification of the beginning of a group of elements.
   procedure Start_Group (Self : Object; Group : Element_Type) is
   begin
      case Group is
         when Is_Clauses => Title_And_Quick_Access("Clauses");
         when Is_ContextClauses =>
            Put_Line("&nbsp;<table><tr><th width=""200"" class=""Clr1"">"&
                                                     "<b>Context clauses</b></th></tr>");
         when Is_UseClauses =>
            Put_Line("&nbsp;<table><tr><th width=""200"" class=""Clr1"">"&
                                                         "<b>Use clauses</b></th></tr>");
         when Is_UseTypeClauses =>
            Put_Line("&nbsp;<table><tr><th width=""200"" class=""Clr1"">"&
                                                    "<b>Use type clauses</b></th></tr>");

         when Is_RepClauses =>
            Put_Line("&nbsp;<table><tr><th width=""200"" class=""Clr1"">"&
                                              "<b>Representation clauses</b></th></tr>");

         when Is_GenericParameters =>
            Title_And_Quick_Access("Generics");
            Put_Line("<table>");
         when Is_SubpGenericParameters =>
            null;--Put_Line("<table>");
         when Is_Definitions => Title_And_Quick_Access("Definitions");
         when Is_Subprograms => Title_And_Quick_Access("Subprograms");
         when Is_Types =>
            Put("<table><tr><td><table><tr><th width=""200"" class=""Clr1""><b>Types</b></th></tr>");
            Put("<tr><td width=""200"" class=""Clr3""><b><i>Name</i></b></td>");
            Put_Line("    <td width=""600"" class=""Clr4""><b><i>Declaration</i></b></td></tr>");
         when Is_Objects =>
            Put("<table><tr><td><table><tr><th width=""200"" class=""Clr1""><b>Objects</b></th></tr>");
            Put("<tr><td width=""200"" class=""Clr3""><b><i>Name</i></b></td>");
            Put("    <td width=""200"" class=""Clr4""><b><i>Type</i></b></td>");
            Put("    <td width=""200"" class=""Clr5""><b><i>Default</i></b></td></tr>");
            New_Line;
         when Is_GenericInstanciations =>
            Title_And_Quick_Access("Generic Instanciations");
            Put_Line("<table><tr><th width=""200"" class=""Clr1"">"&
                                              "<b>Generic Instanciations</b></th></tr>");
         when Is_PackagesSubprograms =>
            Put_Line("<table><tr><th width=""200"" class=""Clr1"">"&
                                             "<b>Generic parameters</b></th></tr>");
         when Is_BasicObjects =>
            Title_And_Quick_Access("Basic Objects");
            Put("<table><tr><td><table><tr><th width=""200"" class=""Clr1""><b>Basic Objects</b></th>");
            Put("<tr><td width=""200"" class=""Clr2""><b><i>Name</i></b></td>");
            Put("    <td width=""200"" class=""Clr3""><b><i>Type</i></b></td>");
            Put_Line("    <td width=""200"" class=""Clr4""><b><i>Default</i></b></td></tr>");
         when Is_Components =>
            Put("<tr><tr><td width=""200"" class=""Clr1""><b><i>Component</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_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 =>
            Put_Line("<table>");
            Put("<tr><td width=""200"" class=""Clr2""><b><i>Parameter name</i></b>"&
                                                                                "</td>");
            Put("    <td width=""200"" class=""Clr3""><b><i>Type</i></b></td>");
            Put("    <td width=""200"" class=""Clr4""><b><i>Mode</i></b></td>");
            Put_Line("    <td width=""200"" class=""Clr5""><b><i>Default</i></b></td>"&
                                                                                "</tr>");
         when Is_Exceptions =>
            Put_Line("&nbsp;&nbsp;<table><tr><th width=""200"" class=""Clr1""><b>Exceptions</b></th>"&
                                                                                "</tr>");
         when Is_Pragmas =>
            Put_Line("&nbsp;&nbsp;<table><tr><th width=""200"" class=""Clr1""><b>Pragmas</b></th>"&
                                                                                "</tr>");
         when Is_Renames =>
            Put_Line("&nbsp;&nbsp;<table><tr><th width=""200"" class=""Clr1""><b>Renames</b></th>"&
                                                                                "</tr>");
         when others => null;
      end case;
   end Start_Group;

end Module.HTML;

