--
-- @filename adadoc_tree-xml.ads
-- @author Julien Burdy & Vincent Decorges
-- @date 10.4.02
-- @brief Write a xml file from the parse tree
--
-- History  :
-- Date     Modification               Author
--
with Ada95_Parser; --To have the tree and the private tree given by the parser
with AdaDoc_Tree.List; use AdaDoc_Tree.List;
with Xml_Writer, Dict_TDA; use Xml_Writer, Dict_TDA;
with Ada.Tags; use Ada.Tags;

package body AdaDoc_Tree.Xml is

   --
   -- Name    : Write_Clauses
   -- Purpose : Write the clauses token
   --
   -- in      : File : File type to write to
   --
   procedure Write_Clauses (Tree : in out Tree_Type; File : File_Type) is

      Current_Object : Object_Token_Ptr;

   begin

      if Exist(Tree, "ADADOC_TREE.WITH_CLAUSE_TOKEN") or else
         Exist(Tree, "ADADOC_TREE.USE_CLAUSE_TOKEN") or else
         Exist(Tree, "ADADOC_TREE.USE_TYPE_CLAUSE_TOKEN") or else
         Exist(Tree, "ADADOC_TREE.REP_CLAUSE_TOKEN") then


         Create_Tag(File, "Clauses", Empty_Dict);

         --Context Clause
         if Exist(Tree, "ADADOC_TREE.WITH_CLAUSE_TOKEN") then
            Create_Tag(File, "ContextClauses", Empty_Dict);
            loop
               Find_Next(Tree, "ADADOC_TREE.WITH_CLAUSE_TOKEN", Current_Object);
               exit when Current_Object = null;
               Put_Xml(Object_Token'Class(Current_Object.all), File);
               free(Current_Object);
            end loop;
            Close_Tag(File, "ContextClauses");
         end if;

         --Use Clause
         if Exist(Tree, "ADADOC_TREE.USE_CLAUSE_TOKEN") then
            Create_Tag(File, "UseClauses", Empty_Dict);
            loop
               Find_Next(Tree, "ADADOC_TREE.USE_CLAUSE_TOKEN", Current_Object);
               exit when Current_Object = null;
               Put_Xml(Object_Token'Class(Current_Object.all), File);
               free(Current_Object);
            end loop;
            Close_Tag(File, "UseClauses");
         end if;

         --Use Type
         if Exist(Tree, "ADADOC_TREE.USE_TYPE_CLAUSE_TOKEN") then
            Create_Tag(File, "UseTypeClauses", Empty_Dict);
            loop
               Find_Next(Tree, "ADADOC_TREE.USE_TYPE_CLAUSE_TOKEN", Current_Object);
               exit when Current_Object = null;
               Put_Xml(Object_Token'Class(Current_Object.all), File);
               free(Current_Object);
            end loop;
            Close_Tag(File, "UseTypeClauses");
         end if;

         --Use Type
         if Exist(Tree, "ADADOC_TREE.REP_CLAUSE_TOKEN") then
            Create_Tag(File, "RepClauses", Empty_Dict);
            loop
               Find_Next(Tree, "ADADOC_TREE.REP_CLAUSE_TOKEN", Current_Object);
               exit when Current_Object = null;
               Put_Xml(Object_Token'Class(Current_Object.all), File);
               free(Current_Object);
            end loop;
            Close_Tag(File, "RepClauses");
         end if;

         Close_Tag(File, "Clauses");
      end if;
   end Write_Clauses;

   --
   -- Name    : Write_Package
   -- Purpose : Write the Package token and the
   --           Generic parameters associate
   --
   -- in out  : File : File type to write to
   --                  It's an in in out mode because
   --                  we want to delete the xml file before
   --                  we raise Package_Spec_Error
   --
   procedure Write_Package (Tree : in out Tree_Type; File : in out File_Type) is

      Current_Object : Object_Token_Ptr;

   begin

      if Exist(Tree, "ADADOC_TREE.PACKAGE_SPEC_TOKEN") then

         Find_Next(Tree, "ADADOC_TREE.PACKAGE_SPEC_TOKEN", Current_Object);
         Put_Xml(Object_Token'Class(Current_Object.all), File);

         if Exist(Tree, "ADADOC_TREE.WITH_CLAUSE_TOKEN")
            or else Exist(Tree, "ADADOC_TREE.USE_CLAUSE_TOKEN")
            or else Exist(Tree, "ADADOC_TREE.USE_TYPE_CLAUSE_TOKEN") then

            Write_Clauses(Tree, File);
         end if;

         --The Package have generic parameters
         if Package_Spec_Token_Ptr(Current_Object).Generic_Part /= null then
            Create_Tag(File, "GenericParameters", Empty_Dict);
            Put_Xml(Package_Spec_Token_Ptr(Current_Object).Generic_Part, File);
            free(Object_Token_Ptr(Package_Spec_Token_Ptr(Current_Object).Generic_Part));
            Close_Tag(File, "GenericParameters");
         end if;
         free(Current_Object);

      --The parsed file is not a package spec
      else
         --Free both trees
         Empty(Ada95_Parser.Tree);
         Empty(Ada95_Parser.Private_Tree);
         --Delete the temp xml file
         Delete(File);
         raise Package_Spec_Error;
      end if;

   end Write_Package;

   --
   -- Name    : Write_Type
   -- Purpose : Write the type token
   --
   -- in      : File : File type to write to
   --
   procedure Write_Type (Tree : in out Tree_Type; File : File_Type) is

      Current_Object : Object_Token_Ptr;

   begin



      --Context Clause
      if Exist(Tree, "ADADOC_TREE.SIMPLE_TYPE_TOKEN") or else
         Exist(Tree, "ADADOC_TREE.SUBTYPE_DECL_TOKEN") or else
         Exist(Tree, "ADADOC_TREE.DERIVED_TYPE_TOKEN") then

         Create_Tag(File, "Types", Empty_Dict);

         --Type simple
         loop
            Find_Next(Tree, "ADADOC_TREE.SIMPLE_TYPE_TOKEN", Current_Object);
            exit when Current_Object = null;
            Put_Xml(Object_Token'Class(Current_Object.all), File);
            free(Current_Object);
         end loop;

         --Sub-type
          loop
            Find_Next(Tree, "ADADOC_TREE.SUBTYPE_DECL_TOKEN", Current_Object);
            exit when Current_Object = null;
            Put_Xml(Object_Token'Class(Current_Object.all), File);
            free(Current_Object);
         end loop;

         --Type tagged
          loop
            Find_Next(Tree, "ADADOC_TREE.DERIVED_TYPE_TOKEN", Current_Object);
            exit when Current_Object = null;
            Put_Xml(Object_Token'Class(Current_Object.all), File);
            free(Current_Object);
         end loop;

         Close_Tag(File, "Types");
      end if;

   end Write_Type;

   --
   -- Name    : Write_Subp
   -- Purpose : Write the subprogram token
   --
   -- in      : File : File type to write to
   --
   procedure Write_Subp (Tree : in out Tree_Type; File : File_Type) is

      Current_Object : Object_Token_Ptr;

   begin

      if Exist(Tree, "ADADOC_TREE.PROCEDURE_DECL_TOKEN") or else
         Exist(Tree, "ADADOC_TREE.FUNCTION_DECL_TOKEN") then

         Create_Tag(File, "Subprograms", Empty_Dict);

         loop
            Find_Next(Tree, "ADADOC_TREE.PROCEDURE_DECL_TOKEN",
                      "ADADOC_TREE.FUNCTION_DECL_TOKEN", Current_Object);
            exit when Current_Object = null;
            Put_Xml(Object_Token'Class(Current_Object.all), File);
            free(Current_Object);
         end loop;

         Close_Tag(File, "Subprograms");
      end if;

   end Write_Subp;

   --
   -- Name    : Write_Basic_Object
   -- Purpose : Write the basic object token
   --
   -- in      : File : File type to write to
   --
   procedure Write_Basic_Object (Tree : in out Tree_Type; File : File_Type) is

      Current_Object : Object_Token_Ptr;

   begin

      --Basic Object
      if Exist(Tree, "ADADOC_TREE.OBJECT_DECLARATION_TOKEN") then
         Create_Tag(File, "BasicObjects", Empty_Dict);
         loop
            Find_Next(Tree, "ADADOC_TREE.OBJECT_DECLARATION_TOKEN", Current_Object);
            exit when Current_Object = null;
            Put_Xml(Object_Token'Class(Current_Object.all), File);
            free(Current_Object);
         end loop;
         Close_Tag(File, "BasicObjects");
      end if;

   end Write_Basic_Object;

   --
   -- Name    : Write_Exception
   -- Purpose : Write the exception token
   --
   -- in      : File : File type to write to
   --
   procedure Write_Exception (Tree : in out Tree_Type; File : File_Type) is

      Current_Object : Object_Token_Ptr;

   begin

      if Exist(Tree, "ADADOC_TREE.EXCEPTION_DECLARATION_TOKEN") then
         Create_Tag(File, "Exceptions", Empty_Dict);
         loop
            Find_Next(Tree, "ADADOC_TREE.EXCEPTION_DECLARATION_TOKEN", Current_Object);
            exit when Current_Object = null;
            Put_Xml(Object_Token'Class(Current_Object.all), File);
            Free(Current_Object);
         end loop;
         Close_Tag(File, "Exceptions");
      end if;

   end Write_Exception;


   --
   -- Name    : Write_Pragma
   -- Purpose : Write the pragma token
   --
   -- in      : File : File type to write to
   --
   procedure Write_Pragma (Tree : in out Tree_Type; File : File_Type) is

      Current_Object : Object_Token_Ptr;

   begin

      if Exist(Tree, "ADADOC_TREE.PRAGMA_DECL_TOKEN") then
         Create_Tag(File, "Pragmas", Empty_Dict);
         loop
            Find_Next(Tree, "ADADOC_TREE.PRAGMA_DECL_TOKEN", Current_Object);
            exit when Current_Object = null;
            Put_Xml(Object_Token'Class(Current_Object.all), File);
            Free(Current_Object);
         end loop;
         Close_Tag(File, "Pragmas");
      end if;

   end Write_Pragma;

   --
   -- Name    : Write_Renames
   -- Purpose : Write the renames token
   --
   -- in      : File : File type to write to
   --
   procedure Write_Renames(Tree : in out Tree_Type; File : File_Type) is

      Current_Object : Object_Token_Ptr;

   begin

      if Exist(Tree, "ADADOC_TREE.RENAMES_EXCEPTION_TOKEN") or else
         Exist(Tree, "ADADOC_TREE.RENAMES_OBJECT_TOKEN") or else
         Exist(Tree, "ADADOC_TREE.RENAMES_PACKAGE_TOKEN") or else
         Exist(Tree, "ADADOC_TREE.RENAMES_GENERIC_PACKAGE_TOKEN") or else
         Exist(Tree, "ADADOC_TREE.RENAMES_SUBP_TOKEN") or else
         Exist(Tree, "ADADOC_TREE.RENAMES_GENERIC_SUBP_TOKEN") then

         Create_Tag(File, "Renames", Empty_Dict);

         loop
            Find_Next(Tree, "ADADOC_TREE.RENAMES_EXCEPTION_TOKEN", Current_Object);
            exit when Current_Object = null;
            Put_Xml(Object_Token'Class(Current_Object.all), File);
            Free(Current_Object);
         end loop;

         loop
            Find_Next(Tree, "ADADOC_TREE.RENAMES_OBJECT_TOKEN", Current_Object);
            exit when Current_Object = null;
            Put_Xml(Object_Token'Class(Current_Object.all), File);
            Free(Current_Object);
         end loop;

         loop
            Find_Next(Tree, "ADADOC_TREE.RENAMES_PACKAGE_TOKEN", Current_Object);
            exit when Current_Object = null;
            Put_Xml(Object_Token'Class(Current_Object.all), File);
            Free(Current_Object);
         end loop;

         loop
            Find_Next(Tree, "ADADOC_TREE.RENAMES_GENERIC_PACKAGE_TOKEN", Current_Object);
            exit when Current_Object = null;
            Put_Xml(Object_Token'Class(Current_Object.all), File);
            Free(Current_Object);
         end loop;

         loop
            Find_Next(Tree, "ADADOC_TREE.RENAMES_SUBP_TOKEN", Current_Object);
            exit when Current_Object = null;
            Put_Xml(Object_Token'Class(Current_Object.all), File);
            Free(Current_Object);
         end loop;

         loop
            Find_Next(Tree, "ADADOC_TREE.RENAMES_GENERIC_SUBP_TOKEN", Current_Object);
            exit when Current_Object = null;
            Put_Xml(Object_Token'Class(Current_Object.all), File);
            Free(Current_Object);
         end loop;

         Close_Tag(File, "Renames");
      end if;

   end Write_Renames;

   --
   -- Name    : Write_Record
   -- Purpose : Write the record object token
   --
   -- in      : File : File type to write to
   --
   procedure Write_Record (Tree : in out Tree_Type; File : File_Type) is

      Current_Object : Object_Token_Ptr;

   begin

      --Procedure
      if Exist(Tree, "ADADOC_TREE.RECORD_TYPE_TOKEN") then
         Create_Tag(File, "Records", Empty_Dict);
         loop
            Find_Next(Tree, "ADADOC_TREE.RECORD_TYPE_TOKEN", Current_Object);
            exit when Current_Object = null;
            Put_Xml(Object_Token'Class(Current_Object.all), File);
            free(Current_Object);
         end loop;
         Close_Tag(File, "Records");
      end if;

   end Write_Record;

   --
   -- Name    : Write_Task
   -- Purpose : Write the task token
   --
   -- in      : File : File type to write to
   --
   procedure Write_Task (Tree : in out Tree_Type; File : File_Type) is

      Current_Object : Object_Token_Ptr;

   begin

      if Exist(Tree, "ADADOC_TREE.TASK_DECL_TOKEN") or else
         Exist(Tree, "ADADOC_TREE.TASK_TYPE_DECL_TOKEN") then

         Create_Tag(File, "Tasks", Empty_Dict);

         loop
            Find_Next(Tree, "ADADOC_TREE.TASK_DECL_TOKEN",
                      "ADADOC_TREE.TASK_TYPE_DECL_TOKEN", Current_Object);
            exit when Current_Object = null;
            Put_Xml(Object_Token'Class(Current_Object.all), File);
            Free(Current_Object);
         end loop;

         Close_Tag(File, "Tasks");
      end if;
   end Write_Task;

   --
   -- Name    : Write_Protected
   -- Purpose : Write the protected token
   --
   -- in      : File : File type to write to
   --
   procedure Write_Protected (Tree : in out Tree_Type; File : File_Type) is

      Current_Object : Object_Token_Ptr;

   begin

      if Exist(Tree, "ADADOC_TREE.PROTECTED_DECL_TOKEN") or else
         Exist(Tree, "ADADOC_TREE.PROTECTED_TYPE_DECL_TOKEN") then

         Create_Tag(File, "ProtectedObjects", Empty_Dict);

         loop
            Find_Next(Tree, "ADADOC_TREE.PROTECTED_DECL_TOKEN",
                      "ADADOC_TREE.PROTECTED_TYPE_DECL_TOKEN", Current_Object);
            exit when Current_Object = null;
            Put_Xml(Object_Token'Class(Current_Object.all), File);
            Free(Current_Object);
         end loop;

         Close_Tag(File, "ProtectedObjects");
      end if;
   end Write_Protected;


   --
   -- Name    : Write_GenericInstanciation
   -- Purpose : Write the generic instanciation token
   --
   -- in      : File : File type to write to
   --
   procedure Write_GenericInstanciation (Tree : in out Tree_Type; File : File_Type) is

      Current_Object : Object_Token_Ptr;

   begin

      if Exist(Tree, "ADADOC_TREE.GENERIC_SUBP_INST_TOKEN") or else
         Exist(Tree, "ADADOC_TREE.GENERIC_PKG_INST_TOKEN") then

         Create_Tag(File, "GenericInstanciations", Empty_Dict);
         loop
            Find_Next(Tree, "ADADOC_TREE.GENERIC_PKG_INST_TOKEN", Current_Object);
            exit when Current_Object = null;
            Put_Xml(Object_Token'Class(Current_Object.all), File);
            Free(Current_Object);
         end loop;

         loop
            Find_Next(Tree, "ADADOC_TREE.GENERIC_SUBP_INST_TOKEN", Current_Object);
            exit when Current_Object = null;
            Put_Xml(Object_Token'Class(Current_Object.all), File);
            Free(Current_Object);
         end loop;

         Close_Tag(File, "GenericInstanciations");
      end if;
   end Write_GenericInstanciation;

   --
   -- Name    : Write_Xml
   -- Purpose : Write a Xml file from the parse tree
   --
   -- in      : File_Name : Name of the xml file to write
   --
   procedure Write_Xml (File_Name : String) is

      File : File_Type;

   begin

      --Create file
      Create (File, Name => File_Name);


      --Write all Token
      Write_Package(Ada95_Parser.Tree, File);
      Write_GenericInstanciation(Ada95_Parser.Tree, File);
      Write_Basic_Object(Ada95_Parser.Tree, File);
      Create_Tag(File, "Definitions", Empty_Dict);
      Write_Type(Ada95_Parser.Tree, File);
      Write_Record(Ada95_Parser.Tree, File);
      Write_Task(Ada95_Parser.Tree, File);
      Write_Protected(Ada95_Parser.Tree, File);
      Write_Exception(Ada95_Parser.Tree, File);
      Write_Pragma(Ada95_Parser.Tree, File);
      Write_Renames(Ada95_Parser.Tree, File);
      Close_Tag(File, "Definitions");
      Write_Subp(Ada95_Parser.Tree, File);

      --Write the private part token
      if not Is_Empty(Ada95_Parser.Private_Tree) then

         Create_Tag(File, "Private", Empty_Dict);
         Write_GenericInstanciation(Ada95_Parser.Private_Tree, File);
         Write_Basic_Object(Ada95_Parser.Private_Tree, File);
         Create_Tag(File, "Definitions", Empty_Dict);
         Write_Type(Ada95_Parser.Private_Tree, File);
         Write_Record(Ada95_Parser.Private_Tree, File);
         Write_Task(Ada95_Parser.Private_Tree, File);
         Write_Protected(Ada95_Parser.Private_Tree, File);
         Write_Subp(Ada95_Parser.Private_Tree, File);
         Write_Exception(Ada95_Parser.Private_Tree, File);
         Write_Pragma(Ada95_Parser.Private_Tree, File);
         Write_Renames(Ada95_Parser.Private_Tree, File);
         Close_Tag(File, "Definitions");
         Write_Subp(Ada95_Parser.Private_Tree, File);
         Close_Tag(File, "Private");

      end if;

      --Terminate the xml file
      End_File(File);

      Close(File);

      --Free both trees
      Empty(Ada95_Parser.Tree);
      Empty(Ada95_Parser.Private_Tree);

   end Write_Xml;

end AdaDoc_Tree.Xml;