-------------------------------------------------------------------------------
--
--  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>
--   Storage of user-defined HTML tags.</DL>
--
-- <!--
-- Revision History
--
--   29-APR-2002   TW  Initial version.
--   01-MAY-2002   TW  Changed format of include and execute user-tags from
--                     rather cryptic stuff to more readable selector notation.
--                     Added environment variable expansion.
--   03-MAY-2002   TW  Changed interface to use new environment variable
--                     expander.
--   14-MAY-2002   TW  Expand the definition for ".Enabled".
--   26-NOV-2002   TW  New subtype 'Taggy' as a legal work-around for a GNAT
--                     3.14p/3.15p bug.
-- -->
-------------------------------------------------------------------------------

pragma License (GPL);

with Ada.Exceptions;

with GAL.Storage.Standard;
with GAL.Support.Hashing;
with GAL.ADT.Hash_Tables;

with Util.Environment;
with Util.Strings;

pragma Elaborate_All (GAL.ADT.Hash_Tables);

package body AD.User_Tags is

   --  Idea: handle each tag separately. Maintain state as you go: for all
   --  containers, push content type: inline, block, flow or pre. Whenever
   --  text is to be written, no <P>s are inserted for inline, pre, or
   --  special. If inline, empty lines generate <BR><BR>. If in block or
   --  flow, then do <P> handling. Whenever flow or pre is pushed, push
   --  also In_Para = False. Whenever you insert a <P>, also push it!
   --
   --  At end tag of container, pop to corresponding begin tag (if any,
   --  if none, ignore and emit a warning). If type is ?, the end tag is
   --  optional. Use the follow set: if block nesting is the same and we
   --  hit a tag from the follow set, pop. When popping: if In_Para = true,
   --  emit </P>, then emit closing tag.
   --
   --  These rules should in fact make sure that we only insert <P> where
   --  they are legal. In fact, since <P> may contain only inline, use <DIV>
   --  instead! More precisely, use <DIV CLASS="para_graph"> as a
   --  replacement and emit the following in the <HEAD> section:
   --
   --    <STYLE TYPE="text/css">
   --      DIV.para_graph {margin: 0.5em 0}
   --    </STYLE>
   --
   --  or whatever is appropriate.

   subtype Tag_Class is Tag'Class;
   --  Work-around for a bug in GNAT 3.14p and 3.15p, which have problems
   --  when the hash table below is instantiated directly with Tag'Class.
   --  (The problem is that the compiler rejects the 'Action' operations
   --  of the types 'Resetter' and 'Verifier' below if they are properly
   --  declared with "Value : access Tag'Class".)

   package Hashing is
      new GAL.ADT.Hash_Tables
            (Key_Type     => String,
             Item         => Tag_Class,
             Memory       => GAL.Storage.Standard,
             Initial_Size => 101,
             Hash         => GAL.Support.Hashing.Hash);

   Tags : Hashing.Hash_Table;

   package UT renames Util.Text;

   use Util.Strings;

   procedure Parse_Tag
     (Key        : in     String;
      Definition : in     String;
      Expander   : access Util.Environment.String_Expander'Class)
   is
      I : Natural := Last_Index (Key, '.');
   begin
      if I > 0 then
         if I = Key'First or else I = Key'Last then
            Ada.Exceptions.Raise_Exception
              (Invalid_Tag'Identity,
               '"' & Key & """ is an invalid tag specification");
         end if;
         I := I - 1;
      else
         I := Key'Last;
      end if;
      if Identifier (Key (Key'First .. I)) /= I then
         Ada.Exceptions.Raise_Exception
           (Invalid_Tag'Identity,
            '"' & Key (Key'First .. I) & """ is not an identifier");
      end if;
      declare
         Tag_Key      : constant String := To_Upper (Key (Key'First .. I));
         Tag_Selector : constant String := To_Lower (Key (I + 2 .. Key'Last));
         Ptr          : Hashing.Item_Ptr;
         T            : aliased User_Defined_Tag (N => Tag_Key'Length);
         P            : User_Tag_Ptr;
         use type Hashing.Item_Ptr;
      begin
         Ptr := Hashing.Unsafe.Retrieve (Tags, Tag_Key);
         if Ptr = null then
            P      := T'Unchecked_Access;
            T.Name := Tag_Key;
         else
            if Ptr.all in Standard_Tag'Class then
               Ada.Exceptions.Raise_Exception
                 (Invalid_Tag'Identity,
                  "cannot redefine a standard HTML 4.0 tag (" & Tag_Key & ")");
            end if;
            P := User_Defined_Tag (Ptr.all)'Access;
         end if;
         if Tag_Selector'Last < Tag_Selector'First then
            P.Kind  := Normal;
            UT.Set (P.Start, Definition);
         elsif Tag_Selector = "enabled" then
            declare
               Value : Boolean;
            begin
               begin
                  Value :=
                    Boolean'Value
                      (To_Upper
                         (Util.Environment.Expand (Expander, Definition)));
               exception
                  when others =>
                     Ada.Exceptions.Raise_Exception
                       (Invalid_Tag'Identity,
                        "Value must be one of True or False");
               end;
               P.Enabled := Value;
            end;
         elsif Tag_Selector = "before" then
            P.Kind  := Container;
            UT.Set (P.Start, Definition);
         elsif Tag_Selector = "after" then
            if P.Kind /= Container then
               P.Start := UT.Null_Unbounded_String;
            end if;
            P.Kind  := Container;
            UT.Set (P.Final, Definition);
         elsif Tag_Selector = "include" then
            P.Kind  := Include;
            UT.Set (P.Start, Util.Environment.Expand (Expander, Definition));
         elsif Tag_Selector = "execute" then
            P.Kind := Execute;
            UT.Set
              (P.Start,
               Util.Environment.Expand
                 (Expander, Unquote_All (Definition, Shell_Quotes)));
         elsif Tag_Selector = "variable" then
            P.Kind := Normal;
            UT.Set (P.Start, Util.Environment.Expand (Expander, Definition));
         elsif Tag_Selector = "set" then
            P.Kind := Initialize;
            UT.Set
              (P.Start,
               Util.Environment.Expand
                 (Expander, Unquote_All (Definition, Shell_Quotes)));
         else
            Ada.Exceptions.Raise_Exception
              (Invalid_Tag'Identity,
               '"' & Tag_Selector & """ is an invalid selector");
         end if;
         if Ptr = null then
            Hashing.Insert (Tags, Tag_Key, T);
         elsif P.Kind = Normal then
            P.Final := UT.Null_Unbounded_String;
         end if;
      end;
   end Parse_Tag;

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

   function Find_Tag
     (Key : in String)
     return Tag_Ptr
   is
      P : constant Hashing.Item_Ptr :=
        Hashing.Unsafe.Retrieve (Tags, To_Upper (Key));
   begin
      return Tag_Ptr (P);
   end Find_Tag;

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

   type Verifier is new Hashing.Visitor with null record;

   --  There's a problem here with GNAT 3.14p and 3.15p; it refuses to accept
   --  the declaration with the (correct) "Value : access Tag'Class". Hence
   --  the ugly work-around using 'Tag_Class' below.
   --    Note: encapsulating the type in a package doesn't help either.

   procedure Action
     (V     : in out Verifier;
      Key   : in     String;
      Value : access Tag_Class; --  Tag'Class
      Quit  : in out Boolean)
   is
      Q : constant Tag_Ptr := Tag_Ptr (Value);
      P : User_Tag_Ptr;
   begin
      if Q.all not in User_Defined_Tag'Class then return; end if;
      P := User_Defined_Tag (Q.all)'Access;
      if P.Kind = Container and then P.Enabled then
         if UT.Length (P.Start) = 0 then
            Ada.Exceptions.Raise_Exception
              (Invalid_Tag'Identity,
               "user-defined tag """ & Key &
               """ has no "".Before"" definition");
            Quit := True; --  Silence GNAT's "-gnatwa" option
         elsif UT.Length (P.Final) = 0 then
            Ada.Exceptions.Raise_Exception
              (Invalid_Tag'Identity,
               "user-defined tag """ & Key &
               """ has no "".After"" definition");
            if V not in Verifier'Class then --  Silence GNAT's "-gnatwa"
               Quit := True;
            end if;
         end if;
      end if;
   end Action;

   procedure Verify
   is
      V : Verifier;
   begin
      Hashing.Traverse (Tags, V, True);
   end Verify;

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

   type Resetter is new Hashing.Visitor with null record;

   --  See comments above about 'Tag_Class'!

   procedure Action
     (V     : in out Resetter;
      Key   : in     String;
      Value : access Tag_Class; --  Tag'Class
      Quit  : in out Boolean)
   is
      Q : constant Tag_Ptr := Tag_Ptr (Value);
   begin
      if Key'Last < Key'First or else V not in Resetter'Class then
         Quit := True; --  Silence GNAT's -gnatwa
      end if;
      if Q.all in User_Defined_Tag'Class then
         declare
            P : constant User_Tag_Ptr := User_Tag_Ptr (Q);
         begin
            P.In_Expansion := False;
         end;
      end if;
   end Action;

   procedure Reset_Tags
   is
      R : Resetter;
   begin
      Hashing.Traverse (Tags, R, True);
   end Reset_Tags;

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

begin
   Hashing.Set_Resize (Tags, 0.75);
   declare
      Linear_Growth : GAL.Support.Hashing.Linear_Growth_Policy (100);
   begin
      Hashing.Set_Growth_Policy (Tags, Linear_Growth);
   end;
   --  Now enter all standard HTML tags.
   Add_Predefined :
   declare
      No_Follow : constant Follow_Set (1 .. 0) := (others => null);

      procedure Enter
        (Name    : in String;
         Class   : in HTML_Content;
         Syntax  : in HTML_Container;
         Content : in HTML_Content;
         Follow  : in Follow_Set := No_Follow)
      is
      begin
         Hashing.Insert
           (Tags, Name,
            Standard_Tag'(N        => Name'Length,
                          Name     => Name,
                          F        => Follow'Length,
                          Syntax   => Syntax,
                          Class    => Class,
                          Contains => Content,
                          Follow   => Follow));
      end Enter;

      procedure Inline_Tag
        (Name : in String)
      is
      begin
         Enter (Name, Inline, Begin_End, Inline);
      end Inline_Tag;

      procedure Block_Tag
        (Name : in String)
      is
      begin
         Enter (Name, Block, Begin_End, Inline);
      end Block_Tag;

      procedure Container
        (Name : in String)
      is
      begin
         Enter (Name, Block, Begin_End, Flow);
      end Container;

      procedure Singleton
        (Name : in String)
      is
      begin
         Enter (Name, Inline, Single, Inline);
      end Singleton;

   begin
      Inline_Tag ("A");
      Inline_Tag ("ABBR");
      Inline_Tag ("ACRONYM");
      Block_Tag  ("ADDRESS");
      Enter      ("APPLET",  Inline, Begin_End, Flow);
      Singleton  ("AREA");
      Inline_Tag ("B");
      Inline_Tag ("BASE");
      Singleton  ("BASEFONT");
      Inline_Tag ("BDO");
      Inline_Tag ("BIG");
      --  Inline_Tag ("BLINK");
      Container  ("BLOCKQUOTE");
      Container  ("BODY");
      --  Actually, we should never encounter a BODY tag.
      Singleton  ("BR");
      Enter      ("BUTTON", Inline, Begin_End, Flow);
      Block_Tag  ("CAPTION");
      Container  ("CENTER");
      Inline_Tag ("CITE");
      Inline_Tag ("CODE");
      Singleton  ("COL");
      Enter      ("COLGROUP", Block, End_Optional, Pure, (1 .. 4 => null));
      Enter      ("DD", Block, End_Optional, Flow,
                  (1 .. 2 => null));
      Container  ("DEL");
      Inline_Tag ("DFN");
      Enter      ("DIR",  Block, Begin_End, Pure); --  Only LI allowed.
      Container  ("DIV");
      Enter      ("DL", Block, Begin_End, Pure);   --  Only DD or DT allowed.
      Enter      ("DT", Block, End_Optional, Inline,
                  (1 .. 2 => null));
      Inline_Tag ("EM");
      Container  ("FIELDSET");
      Inline_Tag ("FONT");
      Container  ("FORM");
      Enter      ("FRAME", Block, Single, Flow);
      Enter      ("FRAME_SET", Block, Begin_End, Pure);
      --  May contain only FRAMEs and NOFRAMEs.
      Block_Tag  ("H1");
      Block_Tag  ("H2");
      Block_Tag  ("H3");
      Block_Tag  ("H4");
      Block_Tag  ("H5");
      Block_Tag  ("H6");
      Enter      ("HEAD", Block, Begin_End, Pure);
      --  We shouldn't ever encounter this one.
      Enter      ("HR", Block, Single, Inline);
      Enter      ("HTML", Block, Begin_End, Flow);
      --  Should never occur!
      Inline_Tag ("I");
      Container  ("IFRAME");
      Singleton  ("IMG");
      Singleton  ("INPUT");
      Container  ("INS");
      Enter      ("ISINDEX", Block, Single, Inline);
      Inline_Tag ("KBD");
      Block_Tag  ("LEGEND");
      Enter      ("LI", Block, End_Optional, Flow,
                  (1 .. 1 => null));
      Singleton  ("LINK");
      Enter      ("MAP", Block, Begin_End, Pure);
      Enter      ("MENU", Block, Begin_End, Pure); --  Only LI allowed
      Singleton  ("META");
      Container  ("NOFRAMES");
      Container  ("NOSCRIPT");
      Enter      ("OBJECT", Inline, Begin_End, Flow);
      Enter      ("OL", Block, Begin_End, Pure); --  Only LI allowed
      Enter      ("OPTGROUP", Block, Begin_End, Pure); --  Only OPTION allowed
      Enter      ("OPTION", Block, End_Optional, Inline,
                  (1 .. 2 => null));
      Enter      ("P", Block, End_Optional, Inline, (1 .. 1 => null));
      Singleton  ("PARAM");
      Enter      ("PRE", Block, Begin_End, Pure);
      --  Pure because we want to maintain line structure as is!
      Inline_Tag ("Q");
      Inline_Tag ("S");
      Inline_Tag ("SAMP");
      Enter      ("SCRIPT", Inline, Begin_End, Dont_Touch);
      --  Pure because it may only be a script.
      Enter      ("SELECT", Inline, Begin_End, Pure);
      --  Pure because only OPTGROUP and OPTION are allowed.
      Inline_Tag ("SMALL");
      Inline_Tag ("SPAN");
      Inline_Tag ("STRIKE");
      Inline_Tag ("STRONG");
      Enter      ("STYLE", Block, Begin_End, Dont_Touch);
      Inline_Tag ("SUB");
      Inline_Tag ("SUP");
      Enter      ("TABLE", Block, Begin_End, Pure);
      Enter      ("TBODY", Block, End_Optional, Pure,
                  (1 .. 2 => null));
      Enter      ("TD", Block, End_Optional, Flow,
                  (1 .. 3 => null));
      Enter      ("TEXTAREA", Inline, Begin_End, Pure);
      Enter      ("TFOOT", Block, End_Optional, Pure,
                  (1 .. 2 => null));
      Enter      ("TH", Block, End_Optional, Flow,
                  (1 .. 3 => null));
      Enter      ("THEAD", Block, End_Optional, Pure,
                  (1 .. 2 => null));
      Enter      ("TITLE", Block, Begin_End, Pure);
      Enter      ("TR", Block, End_Optional, Pure,
                  (1 .. 4 => null));
      Inline_Tag ("TT");
      Inline_Tag ("U");
      Enter      ("UL", Block, Begin_End, Pure); --  Only LI allowed.
      Inline_Tag ("VAR");
      --  All right. Now retrieve some and set up the follow sets.
      Define_Follow_Sets :
      declare
         P : Standard_Ptr;
      begin
         P := Standard_Ptr (Find_Tag ("COLGROUP"));
         P.Follow (1) := Find_Tag ("THEAD");
         P.Follow (2) := Find_Tag ("TFOOT");
         P.Follow (3) := Find_Tag ("TBODY");
         P.Follow (4) := Find_Tag ("TR");
         P := Standard_Ptr (Find_Tag ("DD"));
         P.Follow (1) := Find_Tag ("DT");
         P.Follow (2) := Tag_Ptr (P);
         P := Standard_Ptr (Find_Tag ("DT"));
         P.Follow (1) := Find_Tag ("DD");
         P.Follow (2) := Tag_Ptr (P);
         P := Standard_Ptr (Find_Tag ("LI"));
         P.Follow (1) := Tag_Ptr (P);
         P := Standard_Ptr (Find_Tag ("OPTION"));
         P.Follow (1) := Find_Tag ("OPTGROUP");
         P.Follow (2) := Tag_Ptr (P);
         P := Standard_Ptr (Find_Tag ("TBODY"));
         P.Follow (1) := Find_Tag ("TFOOT");
         P.Follow (2) := Find_Tag ("THEAD");
         P := Standard_Ptr (Find_Tag ("TD"));
         P.Follow (1) := Tag_Ptr (P);
         P.Follow (2) := Find_Tag ("TR");
         P.Follow (3) := Find_Tag ("TH");
         P := Standard_Ptr (Find_Tag ("TFOOT"));
         P.Follow (1) := Find_Tag ("TBODY");
         P.Follow (2) := Find_Tag ("THEAD");
         P := Standard_Ptr (Find_Tag ("TH"));
         P.Follow (1) := Tag_Ptr (P);
         P.Follow (2) := Find_Tag ("TR");
         P.Follow (3) := Find_Tag ("TD");
         P := Standard_Ptr (Find_Tag ("THEAD"));
         P.Follow (1) := Find_Tag ("TFOOT");
         P.Follow (2) := Find_Tag ("TBODY");
         P := Standard_Ptr (Find_Tag ("TR"));
         P.Follow (1) := Tag_Ptr (P);
         P.Follow (2) := Find_Tag ("TFOOT");
         P.Follow (3) := Find_Tag ("TBODY");
         P.Follow (4) := Find_Tag ("THEAD");
      end Define_Follow_Sets;
   end Add_Predefined;
end AD.User_Tags;
