-------------------------------------------------------------------------------
-- (C) Altran Praxis Limited
-------------------------------------------------------------------------------
--
-- The SPARK toolset 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. The SPARK toolset is distributed in the hope that it will be
-- useful, but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General
-- Public License for more details. You should have received a copy of the GNU
-- General Public License distributed with the SPARK toolset; see file
-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy of
-- the license.
--
--=============================================================================

with E_Strings;

--# inherit Ada.Characters.Latin_1,
--#         E_Strings,
--#         SPARK_IO;

package SPARK_XML is

   Max_Tags               : constant Integer := 100;
   Max_Attributes_Per_Tag : constant Integer := 7;
   Max_Attributes         : constant Integer := Max_Tags * Max_Attributes_Per_Tag;

   subtype Tag_ID is Integer range 0 .. Max_Tags;
   subtype Attribute_ID is Integer range 0 .. Max_Attributes;

   Null_Tag       : constant Tag_ID       := Tag_ID'First;
   Null_Attribute : constant Attribute_ID := Attribute_ID'First;

   -- Simple attribute types.
   type Attribute_Type is (At_Null, At_String, At_Integer, At_Float);

   type Schema_Status is (
                          SS_OK,
                          SS_Invalid_Attribute,
                          SS_Invalid_Tag,
                          SS_To_Many_Attributes,
                          SS_Wrong_Content_Type,
                          SS_Stack_Full,
                          SS_Stack_Empty,
                          SS_Tag_Incomplete,
                          SS_Invalid_Depth,
                          SS_No_Such_Tag,
                          SS_Tag_Not_Found);

   type Up_Or_Down is (Up, Down);

   Max_Tag_Depth : constant Integer := 100;

   type Tag_Depth is range 0 .. Max_Tag_Depth;

   type Schema_Record is private;
   type Schema_State_Record is private;

   function X_Str (Str : in String) return E_Strings.T;
   function Filter_String (Str : in E_Strings.T) return E_Strings.T;

   ---------------------
   -- Schema creation --
   ---------------------

   procedure Init_Schema (Schema : out Schema_Record);
   --# derives Schema from ;

   procedure Add_Tag (Schema : in out Schema_Record;
                      Name   : in     E_Strings.T;
                      ID     :    out Tag_ID);
   --# derives ID     from Schema &
   --#         Schema from *,
   --#                     Name;

   function Is_Null_Tag (TID : in Tag_ID) return Boolean;

   procedure Add_Attribute_To_Tag
     (Schema       : in out Schema_Record;
      TID          : in     Tag_ID;
      Name         : in     E_Strings.T;
      Content_Type : in     Attribute_Type;
      Required     : in     Boolean;
      ID           :    out Attribute_ID;
      Success      :    out Boolean);
   --# derives ID      from Schema &
   --#         Schema,
   --#         Success from Content_Type,
   --#                      Name,
   --#                      Required,
   --#                      Schema,
   --#                      TID;

   procedure Add_Child_Tag
     (Schema   : in out Schema_Record;
      TID      : in     Tag_ID;
      Child    : in     Tag_ID;
      Required : in     Boolean;
      Success  :    out Boolean);
   --# derives Schema  from *,
   --#                      Child,
   --#                      Required,
   --#                      TID &
   --#         Success from Schema,
   --#                      TID;

   procedure Add_CDATA (Schema : in out Schema_Record;
                        TID    : in     Tag_ID);
   --# derives Schema from *,
   --#                     TID;

   function CDATA (Schema : in Schema_Record;
                   TID    : in Tag_ID) return Boolean;

   ------------------
   -- Tag Creation --
   ------------------

   procedure Init_Schema_State (Schema_State : out Schema_State_Record);
   --# derives Schema_State from ;

   -- Opening tags:
   -- 1) Initialise the opening tag
   -- 2) Add attributes to it
   -- 3) Call Output_Opening_Tag to return the string.
   procedure Init_Opening_Tag
     (Schema       : in     Schema_Record;
      Schema_State : in out Schema_State_Record;
      Name         : in     E_Strings.T;
      Status       :    out Schema_Status);
   --# derives Schema_State,
   --#         Status       from Name,
   --#                           Schema,
   --#                           Schema_State;

   procedure Init_Opening_Tag_By_ID
     (Schema       : in     Schema_Record;
      Schema_State : in out Schema_State_Record;
      TID          : in     Tag_ID;
      Status       :    out Schema_Status);
   --# derives Schema_State,
   --#         Status       from Schema,
   --#                           Schema_State,
   --#                           TID;

   procedure Init_Opening_Tag_No_Check (Schema_State : in out Schema_State_Record;
                                        TID          : in     Tag_ID;
                                        Status       :    out Schema_Status);
   --# derives Schema_State,
   --#         Status       from Schema_State,
   --#                           TID;

   procedure Add_Attribute_Int
     (Schema       : in     Schema_Record;
      Schema_State : in out Schema_State_Record;
      Name         : in     E_Strings.T;
      Value        : in     Integer;
      Status       :    out Schema_Status);
   --# derives Schema_State from *,
   --#                           Name,
   --#                           Schema,
   --#                           Value &
   --#         Status       from Name,
   --#                           Schema,
   --#                           Schema_State;

   procedure Add_Attribute_Str
     (Schema       : in     Schema_Record;
      Schema_State : in out Schema_State_Record;
      Name         : in     E_Strings.T;
      Value        : in     E_Strings.T;
      Status       :    out Schema_Status);
   --# derives Schema_State from *,
   --#                           Name,
   --#                           Schema,
   --#                           Value &
   --#         Status       from Name,
   --#                           Schema,
   --#                           Schema_State;

   procedure Output_Opening_Tag
     (Schema       : in     Schema_Record;
      Schema_State : in out Schema_State_Record;
      XML          :    out E_Strings.T;
      Depth        :    out Tag_Depth;
      Status       :    out Schema_Status);
   --# derives Depth,
   --#         Schema_State,
   --#         Status,
   --#         XML          from Schema,
   --#                           Schema_State;

   -- Closing tags
   procedure Close_Tag
     (Schema       : in     Schema_Record;
      Schema_State : in out Schema_State_Record;
      Depth        : in     Tag_Depth;
      XML          :    out E_Strings.T;
      Status       :    out Schema_Status);
   --# derives Schema_State,
   --#         Status       from Depth,
   --#                           Schema_State &
   --#         XML          from Depth,
   --#                           Schema,
   --#                           Schema_State;

   procedure Close_Tag_By_ID
     (Schema       : in     Schema_Record;
      Schema_State : in out Schema_State_Record;
      TID          : in     Tag_ID;
      XML          :    out E_Strings.T;
      Status       :    out Schema_Status);
   --# derives Schema_State,
   --#         Status       from Schema_State,
   --#                           TID &
   --#         XML          from Schema,
   --#                           Schema_State,
   --#                           TID;

   procedure Close_Top_Tag_By_ID
     (Schema       : in     Schema_Record;
      Schema_State : in out Schema_State_Record;
      TID          : in     Tag_ID;
      XML          :    out E_Strings.T;
      Status       :    out Schema_Status);
   --# derives Schema_State,
   --#         Status       from Schema_State,
   --#                           TID &
   --#         XML          from Schema,
   --#                           Schema_State,
   --#                           TID;

   procedure Close_Tag_By_Name
     (Schema       : in     Schema_Record;
      Schema_State : in out Schema_State_Record;
      Name         : in     E_Strings.T;
      XML          :    out E_Strings.T;
      Status       :    out Schema_Status);
   --# derives Schema_State,
   --#         Status,
   --#         XML          from Name,
   --#                           Schema,
   --#                           Schema_State;

   -----------
   -- Debug --
   -----------

   function Is_Error (Error : in Schema_Status) return Boolean;

   procedure Print_Schema_Error (Error : in Schema_Status);
   --# derives null from Error;

   procedure Print_Working_State (Schema       : in Schema_Record;
                                  Schema_State : in Schema_State_Record);
   --# derives null from Schema,
   --#                   Schema_State;

private

   -----------------------
   -- Schema Structures --
   -----------------------

   subtype Tag_Attribute_Array_Index is Integer range 0 .. Max_Attributes_Per_Tag;

   Max_Child_Tags : constant Integer := 10;

   subtype Child_Tag_Array_Index is Integer range 0 .. Max_Child_Tags;

   type Child_Tag is record
      Child    : Tag_ID;
      Required : Boolean;
   end record;

   type Tag_Attribute_Array is array (Tag_Attribute_Array_Index) of Attribute_ID;

   type Child_Tag_Array is array (Child_Tag_Array_Index) of Child_Tag;

   type Tag is record
      Name               : E_Strings.T;
      Tag_Attributes     : Tag_Attribute_Array;
      Last_Tag_Attribute : Tag_Attribute_Array_Index;
      Child_Tags         : Child_Tag_Array;
      Last_Child         : Child_Tag_Array_Index;
      Allow_CDATA        : Boolean;
   end record;

   Empty_Tag : constant Tag :=
     Tag'
     (Name               => E_Strings.Empty_String,
      Tag_Attributes     => Tag_Attribute_Array'(others => Null_Attribute),
      Last_Tag_Attribute => Tag_Attribute_Array_Index'First,
      Child_Tags         => Child_Tag_Array'(others => Child_Tag'(Child    => Null_Tag,
                                                                  Required => False)),
      Last_Child         => Child_Tag_Array_Index'First,
      Allow_CDATA        => False);

   type Tag_Array_Type is array (Tag_ID) of Tag;

   type Tag_List is record
      Tag_Array : Tag_Array_Type;
      Last_Tag  : Tag_ID;
   end record;

   Empty_Tag_List : constant Tag_List := Tag_List'(Tag_Array => Tag_Array_Type'(others => Empty_Tag),
                                                   Last_Tag  => 0);

   type Attribute is record
      Name         : E_Strings.T;
      Content_Type : Attribute_Type;
      Required     : Boolean;
   end record;

   type Attribute_Array_Type is array (Attribute_ID) of Attribute;

   type Attribute_List is record
      Attribute_Array : Attribute_Array_Type;
      Last_Attribute  : Attribute_ID;
   end record;

   Empty_Attribute_List : constant Attribute_List :=
     Attribute_List'
     (Attribute_Array => Attribute_Array_Type'(others => Attribute'(Name         => E_Strings.Empty_String,
                                                                    Content_Type => At_Null,
                                                                    Required     => False)),
      Last_Attribute  => 0);

   type Schema_Record is record
      Attributes : Attribute_List;
      Tags       : Tag_List;
   end record;

   Empty_Schema_Record : constant Schema_Record := Schema_Record'(Attributes => Empty_Attribute_List,
                                                                  Tags       => Empty_Tag_List);

   ----------------------------
   -- Schema_State Structures --
   ----------------------------

   -- Tag_Stack records the hierarcy from the present tag to the root.
   -- This allows us to enforce child tag relations.
   -- If a tag is closed that is not the emmediate parent, we can itterate through the stack
   -- until we find which one it was and close all the intermediate tags.
   -- This isn't perfect, it will have problems with cycles, but will be fine with simple
   -- recursion with a single tag that can be the child of itself (A -> B -> B -> B) but not
   -- (A -> B -> A -> B ->).

   type Tag_Stack_Array is array (Tag_Depth) of Tag_ID;

   type Tag_Stack_Type is record
      Stack   : Tag_Stack_Array;
      Current : Tag_Depth;
   end record;

   Empty_Tag_Stack : constant Tag_Stack_Type := Tag_Stack_Type'(Stack   => Tag_Stack_Array'(others => 0),
                                                                Current => 0);

   subtype Tag_Count is Integer range 0 .. 100;
   type Tag_Count_Array is array (Tag_ID) of Tag_Count;

   type Working_Attribute is record
      AID : Attribute_ID;
      Val : E_Strings.T;
   end record;

   type Working_Attribute_Array is array (Tag_Attribute_Array_Index) of Working_Attribute;

   type Working_Tag_Type is record
      TID     : Tag_ID;
      Attribs : Working_Attribute_Array;
   end record;

   Empty_Working_Tag : constant Working_Tag_Type :=
     Working_Tag_Type'
     (TID     => Null_Tag,
      Attribs => Working_Attribute_Array'(others => Working_Attribute'(AID => Null_Attribute,
                                                                       Val => E_Strings.Empty_String)));

   type Schema_State_Record is record
      Tag_Stack   : Tag_Stack_Type;
      Working_Tag : Working_Tag_Type;
   end record;

   Empty_Schema_State_Record : constant Schema_State_Record :=
     Schema_State_Record'(Tag_Stack   => Empty_Tag_Stack,
                          Working_Tag => Empty_Working_Tag);

end SPARK_XML;
