-------------------------------------------------------------------------------
--
--  This file is part of AdaBrowse.
--
-- <STRONG>Copyright (c) 2002 by Thomas Wolf.</STRONG>
-- <BLOCKQUOTE>
--    AdaBrowse is free software; you can redistribute it and/or modify it
--    under the terms of the  GNU General Public License as published by the
--    Free Software  Foundation; either version 2, or (at your option) any
--    later version. AdaBrowse is distributed in the hope that it will be
--    useful, but <EM>without any warranty</EM>; without even the implied
--    warranty of <EM>merchantability or fitness for a particular purpose.</EM>
--    See the GNU General Public License for  more details. You should have
--    received a copy of the GNU General Public License with this distribution,
--    see file "<A HREF="GPL.txt">GPL.txt</A>". If not, write to the Free
--    Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307,
--    USA.
-- </BLOCKQUOTE>
--
-- <DL><DT><STRONG>
-- Author:</STRONG><DD>
--   Thomas Wolf  (TW)
--   <ADDRESS><A HREF="mailto:twolf@acm.org">twolf@acm.org</A></ADDRESS></DL>
--
-- <DL><DT><STRONG>
-- Purpose:</STRONG><DD>
--   HTML output helper routines.</DL>
--
-- <!--
-- Revision History
--
--   02-FEB-2002   TW  First release.
--   04-FEB-2002   TW  Added 'Get_Compile_Command' for V1.01.
--   13-MAR-2002   TW  Added 'Header' and 'Footer' with file parameter.
--                     Also added key 'Index_XRef'.
--   14-MAR-2002   TW  Added key 'Index_Title'.
--   18-MAR-2002   TW  Correction in HTMLize: only replace & by &amp; if it
--                     isn't already the start of a named character entity
--                     (e.g., if the original comment is "&lt;", we *don't*
--                     want to replace the '&', and the same goes for "&#34;").
--                        Also changed HTMLize_Comment to replace pairs of '@'
--                     without white-space in between by <CODE> and </CODE>.
--   03-APR-2002   TW  Moved all items for indices to package AD.Indices.
--   18-JUN-2002   TW  Removed a bunch of unused operations.
--   24-JUn-2002   TW  Changed 'Is_Named_Char' to also handle numeric character
--                     entities in hexadecimal format ("&#xE5;" or &#XE5;").
--   04-JUL-2002   TW  Changed the 'Header' and 'Footer' routines by factoring
--                     their bodies into generic procedures such that there's
--                     only one place in the sources where these string occur,
--                     not two. Also added a "STYLE" element to the header.
--   07-JUL-2003   TW  Added a new "UL.index" style to the STYLE element in the
--                     header.
-- -->
-------------------------------------------------------------------------------

pragma License (GPL);

with Ada.Characters.Handling;
with Ada.Calendar;
with Ada.Strings.Fixed;
with Ada.Strings.Maps;
with Ada.Strings.Unbounded;
with Ada.Text_IO;

with AD.Config;
with AD.Version;

with Util.Calendar.IO;

with Util.Strings;

package body AD.HTML is

   package ASF renames Ada.Strings.Fixed;
   package ASM renames Ada.Strings.Maps;
   package ASU renames Ada.Strings.Unbounded;

   use Util.Strings;

   type HTML_Tag is array (HTML_Tag_Kind) of ASU.Unbounded_String;

   Style_Sheet : ASU.Unbounded_String;

   Body_Start  : ASU.Unbounded_String;

   Char_Set    : ASU.Unbounded_String;

   Title       : HTML_Tag;
   Sub_Title   : HTML_Tag;
   Keyword     : HTML_Tag;
   Attribute   : HTML_Tag;
   Definition  : HTML_Tag;
   Comment     : HTML_Tag;
   Literal     : HTML_Tag;
   Ending      : HTML_Tag;

   function Character_Set
     return String
   is
   begin
      return ASU.To_String (Char_Set);
   end Character_Set;

   generic
      with procedure Line (S : in String);
   procedure Dump_Header
     (Title : in String);

   procedure Dump_Header
     (Title : in String)
   is
   begin
      Line
        ("<!DOCTYPE HTML PUBLIC ""-//W3C//DTD HTML 4.01 Transitional//EN"">");
      Line ("");
      Line ("<HTML>");
      Line ("");
      Line ("<HEAD>");
      Line ("<TITLE>" & HTMLize (Title) & "</TITLE>");
      Line ("<META NAME=""generator"" CONTENT=""AdaBrowse " &
            AD.Version.Get_Version & ' ' & AD.Version.Get_URL & """>");
      if ASU.Length (Char_Set) /= 0 then
         Line ("<META http-equiv=""Content-Type"" content=""" &
               "text/html; charset=" & ASU.To_String (Char_Set) & """>");
      end if;
      Line ("<LINK REV=""made"" HREF=""" & AD.Version.Get_URL & """>");
      --  Now put the default styles here. They can be overwritten by a user-
      --  defined style sheet containing !important rules.
      Line ("<STYLE TYPE=""text/css"">");
      Line ("  TABLE.title  { background-color : #99CCFF }");
      Line ("  TABLE.footer { background-color : #99CCFF }");
      Line ("  TD.type { background-color : #CCEEFF }");
      Line ("  TD.odd { background-color : #99CCFF }");
      Line ("  TD.even { background-color : #CCEEFF }");
      Line ("  TD.code { background-color : #EEEEEE }");
      Line ("  SPAN.comment { color : red }");
      Line ("  SPAN.literal { color : green }");
      Line ("  SPAN.definition { color : purple }");
      Line ("  H3.subtitle  { background-color : #CCEEFF }");
      Line ("  UL.index { list-style: none }");
      Line ("</STYLE>");
      declare
         S : constant String := ASU.To_String (Style_Sheet);
      begin
         if S'Last >= S'First then
            Line ("<LINK REL=""stylesheet"" HREF=""" & S &
                  """ TYPE=""text/css"">");
         end if;
      end;
      Line ("</HEAD>");
      Line ("");
      Line (ASU.To_String (Body_Start));
      Line ("");
      Line (ASU.To_String (AD.HTML.Title (Before)) & HTMLize (Title) &
            ASU.To_String (AD.HTML.Title (After)));
      Line ("");
      Line ("<!-- Generated by AdaBrowse " & AD.Version.Get_Version &
            ' ' & AD.Version.Get_URL & " -->");
   end Dump_Header;

   procedure Header
     (File  : in Ada.Text_IO.File_Type;
      Title : in String)
   is
      procedure Write_Line
        (S : in String)
      is
      begin
         Ada.Text_IO.Put_Line (File, S);
      end Write_Line;

      procedure Dump is new Dump_Header (Write_Line);

   begin
      Dump (Title);
   end Header;

   generic
      with procedure Write (S : in String);
      with procedure Line  (S : in String);
   procedure Dump_Footer;

   procedure Dump_Footer
   is
      T          : constant Ada.Calendar.Time := Ada.Calendar.Clock;
      Debug_Mode : constant Boolean :=
        False;
   begin
      --  Make sure we're no longer in an HTML comment!
      Write ("<!-- -->" &
             ASU.To_String (Ending (Before)) & "<!-- -->" &
             "Generated");
      if not Debug_Mode then
         Write
            (" on " & Util.Calendar.IO.Image (T) &
             " at " & Util.Calendar.IO.Image (Ada.Calendar.Seconds (T)));
      end if;
      Write (" by <A HREF=""" & AD.Version.Get_URL & """ TARGET=""_top""" &
             ">AdaBrowse " & AD.Version.Get_Version & "</A>");
      if not Debug_Mode then
         if AD.Config.Get_Nof_Config_Files = 1 then
            Write (" using configuration file " &
                   HTMLize (AD.Config.Get_Config_Files));
         elsif AD.Config.Get_Nof_Config_Files > 1 then
            Write (" using configuration files " &
                   HTMLize (AD.Config.Get_Config_Files));
         end if;
      end if;
      Line ('.' & ASU.To_String (Ending (After)));
      Line ("</BODY>");
      Line ("</HTML>");
   end Dump_Footer;

   procedure Footer
     (File : in Ada.Text_IO.File_Type)
   is
      procedure Write
        (S : in String)
      is
      begin
         Ada.Text_IO.Put (File, S);
      end Write;

      procedure Write_Line
        (S : in String)
      is
      begin
         Ada.Text_IO.Put_Line (File, S);
      end Write_Line;

      procedure Dump is new Dump_Footer (Write, Write_Line);

   begin
      Dump;
   end Footer;

   procedure Subtitle
     (File : in Ada.Text_IO.File_Type;
      Text : in String)
   is
   begin
      Ada.Text_IO.Put_Line
        (File,
         ASU.To_String (Sub_Title (Before)) &
         HTMLize (Text) &
         ASU.To_String (Sub_Title (After)));
   end Subtitle;

   ----------------------------------------------------------------------------

   HTML_Special_Chars : constant ASM.Character_Set :=
     ASM.To_Set ("&<>""");
   Is_8_Bit           : constant ASM.Character_Set :=
     ASM.To_Set (ASM.Character_Range'(Low  => Character'Val (160),
                                      High => Character'Last));

   subtype Var_String_Length is Natural range 0 .. 6;

   type Variable_String (N : Var_String_Length := 0) is
      record
         S : String (1 .. N);
      end record;

   type Replacement_Table is array (Character) of Variable_String;

   Replacement : constant Replacement_Table :=
     ('&' => (5, "&amp;"),
      '"' => (6, "&quot;"),
      '<' => (4, "&lt;"),
      '>' => (4, "&gt;"),
      others => (0, ""));

   function Get_Replacement
     (Ch : in Character)
     return String
   is
   begin
      if Replacement (Ch).N > 0 then
         return Replacement (Ch).S;
      else
         return "&#" & Trim (Natural'Image (Character'Pos (Ch))) & ';';
      end if;
   end Get_Replacement;

   function Is_Named_Char
     (S : in String)
     return Boolean
   is
   begin
      if S'Last < S'First then return False; end if;
      if S (S'First) = '#' then
         declare
            Start : Natural;
            I     : Natural := S'First + 1;
         begin
            if I <= S'Last and then (S (I) = 'x' or else S (I) = 'X') then
               --  Hex number
               I := I + 1; Start := I;
               while I <= S'Last and then
                     Ada.Characters.Handling.Is_Hexadecimal_Digit (S (I))
               loop
                  I := I + 1;
               end loop;
            else
               --  Decimal number
               Start := I;
               while I <= S'Last and then
                     Ada.Characters.Handling.Is_Decimal_Digit (S (I))
               loop
                  I := I + 1;
               end loop;
            end if;
            return I > Start and then I > S'Last;
         end;
      else
         declare
            I : Natural := S'First;
         begin
            while I <= S'Last and then Is_In (Letters, S (I)) loop
               I := I + 1;
            end loop;
            return I > S'Last;
         end;
      end if;
   end Is_Named_Char;

   function HTMLize
     (S             : in String;
      Keep_Entities : in Boolean := True)
     return String
   is
      use ASM;
      I : constant Natural := ASF.Index (S, HTML_Special_Chars or Is_8_Bit);
   begin
      if I = 0 then return S; end if;
      declare
         R : constant String := Get_Replacement (S (I));
      begin
         if S (I) = '&' and then Keep_Entities then
            --  Crap. What if we already have "&lt;" or "&#34;" in the source?
            declare
               J : constant Natural := First_Index (S (I + 1 .. S'Last), ';');
            begin
               if J > I + 1 and then
                  --  Check that we have either: # followed by decimal digits,
                  --  # followed by 'x' or 'X' and hex digits, or sequence of
                  --  letters.
                  Is_Named_Char (S (I + 1 .. J - 1))
               then
                  return S (S'First .. J) &
                         HTMLize (S (J + 1 .. S'Last), Keep_Entities);
               end if;
            end;
         end if;
         if I = S'First then
            return R & HTMLize (S (I + 1 .. S'Last), Keep_Entities);
         else
            return S (S'First .. I - 1) & R &
                   HTMLize (S (I + 1 .. S'Last), Keep_Entities);
         end if;
      end;
   end HTMLize;

   function Find_Tag_End
     (S      : in String;
      Is_End : in Boolean := False)
     return Natural
   is
      I : Natural := S'First;
   begin
      if Is_End then
         --  Scan ahead to the next '>'.
         I := First_Index (S, '>');
      else
         declare
            In_String : Boolean   := False;
            Delim     : Character := ' ';
         begin
            while I <= S'Last loop
               if In_String and then S (I) = Delim then
                  In_String := False;
               elsif not In_String then
                  Delim := S (I);
                  if Delim = '"' or else Delim = ''' then
                     In_String := True;
                  else
                     exit when Delim = '>';
                  end if;
               end if;
               I := I + 1;
            end loop;
         end;
         if I > S'Last then I := 0; end if;
      end if;
      return I;
   end Find_Tag_End;

   ----------------------------------------------------------------------------

   function Attributes
     (Source : in String)
     return String
   is
      I : Natural := Next_Non_Blank (Source);
   begin
      if I = 0 then return ""; end if;
      declare
         Result : String (I .. Source'Last);
         J      : Natural := Result'First - 1;
      begin
         --  Replace all LFs or TABs by a space.
         while I <= Source'Last loop
            J := J + 1;
            if Is_In (Blanks, Source (I)) then
               Result (J) := ' ';
            else
               Result (J) := Source (I);
            end if;
            I := I + 1;
         end loop;
         --  Strip trailing white space:
         while J >= Result'First and then Result (J) = ' ' loop
            J := J - 1;
         end loop;
         return Result (Result'First .. J);
      end;
   end Attributes;

   ----------------------------------------------------------------------------

   function Get_Keyword
     (What : in HTML_Tag_Kind)
     return String
   is
   begin
      return ASU.To_String (Keyword (What));
   end Get_Keyword;

   function Get_Attribute
     (What : in HTML_Tag_Kind)
     return String
   is
   begin
      return ASU.To_String (Attribute (What));
   end Get_Attribute;

   function Get_Definition
     (What : in HTML_Tag_Kind)
     return String
   is
   begin
      return ASU.To_String (Definition (What));
   end Get_Definition;

   function Get_Comment
     (What : in HTML_Tag_Kind)
     return String
   is
   begin
      return ASU.To_String (Comment (What));
   end Get_Comment;

   function Get_Literal
     (What : in HTML_Tag_Kind)
     return String
   is
   begin
      return ASU.To_String (Literal (What));
   end Get_Literal;

   ----------------------------------------------------------------------------

   procedure Set_Char_Set
     (Id : in String)
   is
   begin
      Char_Set := ASU.To_Unbounded_String (Id);
   end Set_Char_Set;

   procedure Set_Style_Sheet
     (URL : in String)
   is
   begin
      Style_Sheet := ASU.To_Unbounded_String (URL);
   end Set_Style_Sheet;

   procedure Set_Body
     (S : in String)
   is
   begin
      Body_Start := ASU.To_Unbounded_String (S);
   end Set_Body;

   procedure Set_Title
     (What : in HTML_Tag_Kind;
      S    : in String)
   is
   begin
      Title (What) := ASU.To_Unbounded_String (S);
   end Set_Title;

   procedure Set_Subtitle
     (What : in HTML_Tag_Kind;
      S    : in String)
   is
   begin
      Sub_Title (What) := ASU.To_Unbounded_String (S);
   end Set_Subtitle;

   procedure Set_Keyword
     (What : in HTML_Tag_Kind;
      S    : in String)
   is
   begin
      Keyword (What) := ASU.To_Unbounded_String (S);
   end Set_Keyword;

   procedure Set_Attribute
     (What : in HTML_Tag_Kind;
      S    : in String)
   is
   begin
      Attribute (What) := ASU.To_Unbounded_String (S);
   end Set_Attribute;

   procedure Set_Definition
     (What : in HTML_Tag_Kind;
      S    : in String)
   is
   begin
      Definition (What) := ASU.To_Unbounded_String (S);
   end Set_Definition;

   procedure Set_Comment
     (What : in HTML_Tag_Kind;
      S    : in String)
   is
   begin
      Comment (What) := ASU.To_Unbounded_String (S);
   end Set_Comment;

   procedure Set_Literal
     (What : in HTML_Tag_Kind;
      S    : in String)
   is
   begin
      Literal (What) := ASU.To_Unbounded_String (S);
   end Set_Literal;

begin
   Set_Char_Set    ("ISO-8859-1"); --  Latin 1
   Set_Style_Sheet ("adabrowse.css");
   Set_Body        ("<BODY BGCOLOR=""#FFFFF4"">");

   Set_Title (Before,
              "<TABLE WIDTH=""100%"" CLASS=""title"" " &
              "BORDER=0 CELLSPACING=0 CELLPADDING=5><TR><TD><H2>");
   Set_Title (After, "</H2></TD></TR></TABLE>");

   Set_Subtitle (Before, "<H3 CLASS=""subtitle"">");
   Set_Subtitle (After, "</H3>");

   Set_Keyword (Before, "<STRONG>");
   Set_Keyword (After, "</STRONG>");

   Set_Attribute (Before, "<STRONG>");
   Set_Attribute (After, "</STRONG>");

   Set_Definition (Before, "<SPAN CLASS=""definition"">");
   Set_Definition (After, "</SPAN>");

   Set_Comment (Before, "<EM><SPAN CLASS=""comment"">");
   Set_Comment (After, "</SPAN></EM>");

   Set_Literal (Before, "<SPAN CLASS=""literal"">");
   Set_Literal (After, "</SPAN>");

   Ending (Before) :=
     ASU.To_Unbounded_String
       ("<HR><TABLE WIDTH=""100%"" CLASS=""footer"" " &
        "BORDER=0 CELLSPACING=0 CELLPADDING=5><TR><TD><FONT SIZE=-1>");

   Ending (After) :=
     ASU.To_Unbounded_String ("</FONT></TD></TR></TABLE>");
end AD.HTML;


