taste-backend-skeletons.adb

with Text_IO; use Text_IO;
with Ada.Strings.Unbounded,
     Ada.Characters.Handling,
     Ada.Exceptions,
     Ada.Directories,
     TASTE.Parser_Utils;

use Ada.Characters.Handling,
    Ada.Exceptions,
    Ada.Directories,
    TASTE.Parser_Utils;

--  This package covers the generation of skeletons for all supported languages
--  There is no code that is specific to one particular language. The package
--  looks for a sub-directory with the name of the language and checks that all
--  skeleton-related template files are present. Then it fills the Template
--  mappings and generate the corresponding code.

package body TASTE.Backend.Skeletons is
   procedure Generate (Model : TASTE_Model) is
      Template : constant IV_As_Template :=
        Interface_View_Template (Model.Interface_View);

      Prefix : constant String := Model.Configuration.Binary_Path.all
        & "templates/skeletons/";

      use Ada.Strings.Unbounded;
      type Output is (Header, Code);

      --  Function checking that all templates files are available to support
      --  a given language (based on the directory name).
      function Is_Template_Present (Path : String) return Boolean is
        (Exists (Path) and then Kind (Path) = Directory and then
         Exists (Path & "interface-signature.tmplt") and then
         Exists (Path & "header.tmplt") and then
         Exists (Path & "body.tmplt") and then
         Exists (Path & "body-filename.tmplt") and then
         Exists (Path & "header-filename.tmplt") and then
         Exists (Path & "interface-body-parameter.tmplt") and then
         Exists (Path & "interface-header-parameter.tmplt"));

      function Process_Interfaces (Interfaces : Interface_Vectors.Vector;
                                   Path       : String;
                                   Target     : Output) return Tag
      is
         Interfaces_Tag : Tag;
         Tmplt_Param : constant String :=
           Path & "interface-" & (if Target = Header then "header" else "body")
           & "-parameter.tmplt";
         Tmplt_Sign  : constant String := Path & "interface-signature.tmplt";
      begin
         for Each of Interfaces loop
            declare
               Pool   : Translate_Set := Each.Header;
               Params : Tag;
            begin
               for Param of Each.Params loop
                  declare
                     P : constant String := Parse (Tmplt_Param, Param);
                  begin
                     Params := Params & P;
                  end;
               end loop;
               Pool := Pool & Assoc ("Parameters", Params);
               declare
                  New_Interface : constant String := Parse (Tmplt_Sign, Pool);
               begin
                  Interfaces_Tag := Interfaces_Tag & New_Interface;
               end;
            end;
         end loop;
         return Interfaces_Tag;
      end Process_Interfaces;

      --  Return a Tag list of ASN.1 Modules for the skeleton headers
      function Get_Module_List return Tag is
         Result : Tag;
      begin
         for Each of Model.Data_View.ASN1_Files loop
            for Module of Each.Modules loop
               Result := Result & Module.Name;
            end loop;
         end loop;
         return Result;
      end Get_Module_List;

   begin
      Put_Info ("=== Generate skeletons ===");
      for Each of Model.Interface_View.Flat_Functions loop
         declare
            Language   : constant String := Language_Spelling (Each);
            Path       : constant String := Prefix & To_Lower (Language) & "/";
            Proceed    : constant Boolean := Is_Template_Present (Path);
            Hdr_Tmpl   : constant Translate_Set := +Assoc ("Name", Each.Name);

            Func_Tmpl  : constant Func_As_Template :=
              Template.Funcs.Element (To_String (Each.Name));

            Func_Hdr   : constant Translate_Set :=
              (if Proceed then Func_Tmpl.Header
               & Assoc ("Provided_Interfaces",
                 Process_Interfaces (Func_Tmpl.Provided, Path, Header))
               & Assoc ("Required_Interfaces",
                 Process_Interfaces (Func_Tmpl.Required, Path, Header))
               & Assoc ("ASN1_Modules", Get_Module_List)
               else Null_Set);

            Header_Text : constant String :=
             (if Proceed then Parse (Path & "header.tmplt", Func_Hdr) else "");

            Func_Body  : constant Translate_Set :=
              (if Proceed then Func_Tmpl.Header
              & Assoc ("Provided_Interfaces",
                       Process_Interfaces (Func_Tmpl.Provided, Path, Code))
              & Assoc ("Required_Interfaces",
                 Process_Interfaces (Func_Tmpl.Required, Path, Code))
               else Null_Set);
            Body_Text   : constant String :=
                            (if Proceed
                             then Parse (Path & "body.tmplt", Func_Body)
                             else "");
            Output_Src  : constant String :=
                            Model.Configuration.Output_Dir.all
                            & "/" & To_Lower (To_String (Each.Name))
                            & "/" & Language
                            & "/" & "src" & "/";
            --  Get header and body filenames from templates
            Header_File : constant String :=
                            (if Proceed then Parse
                               (Path & "header-filename.tmplt", Hdr_Tmpl)
                             else "");
            Body_File   : constant String :=
                            (if Proceed then Parse
                               (Path & "body-filename.tmplt", Hdr_Tmpl)
                             else "");
            Output      : File_Type;
         begin
            if Proceed then
               --  Create directory tree (output/function/language/src)
               Create_Path (Output_Src);
               Put_Info ("Generating " & Header_File);
               Create (File => Output,
                       Mode => Out_File,
                       Name => Output_Src & Header_File);
               Put_Line (Output, Header_Text);
               Close (Output);
               if not Exists (Output_Src & Body_File) then
                  Put_Info ("Generating " & Body_File);
                  Create (File => Output,
                          Mode => Out_File,
                          Name => Output_Src & Body_File);
                  Put_Line (Output, Body_Text);
                  Close (Output);
               else
                  Put_Info (Body_File & " already exists, ignoring");
               end if;
            else
               Put_Info ("Ignoring function " & To_String (Each.Name));
            end if;
         exception
            when E : End_Error
               | Text_IO.Use_Error =>
               if Is_Open (Output) then
                  Close (Output);
               end if;
               raise Skeleton_Error with "Generation of skeleton for function "
                 & To_String (Each.Name) & " failed : "
                 & Exception_Message (E);
         end;
      end loop;
   end Generate;

   function Parameter_Template (Param : ASN1_Parameter) return Translate_Set is
     (+Assoc ("Type", Param.Sort) & Assoc ("Name", Param.Name)
     & Assoc ("Direction", Param.Direction'Img));

   function Interface_Template (TI : Taste_Interface)
                                return Interface_As_Template
   is
      use Template_Vectors;
      Result : Interface_As_Template;
   begin
      Result.Header :=  +Assoc ("Name",             TI.Name)
                        & Assoc ("Parent_Function", TI.Parent_Function);
      for Each of TI.Params loop
         Result.Params := Result.Params & Parameter_Template (Each);
      end loop;
      return Result;
   end Interface_Template;

   function Func_Template (F : Taste_Terminal_Function) return Func_As_Template
   is
      use Interface_Vectors;
      use Ctxt_Params;
      Result      : Func_As_Template;
      List_Of_PIs : Tag;
      List_Of_RIs : Tag;
      Timers      : Tag;
   begin
      Result.Header := +Assoc ("Name", F.Name)
        & Assoc ("Language", Language_Spelling (F))
        & Assoc ("Has_Context", (Length (F.Context_Params) > 0));
      for Each of F.Provided loop
         Result.Provided := Result.Provided & Interface_Template (Each);
         List_Of_PIs := List_Of_PIs & Each.Name;
      end loop;
      for Each of F.Required loop
         Result.Required := Result.Required & Interface_Template (Each);
         List_Of_RIs := List_Of_RIs & Each.Name;
      end loop;
      for Each of F.Timers loop
         Timers := Timers & Each;
      end loop;
      Result.Header := Result.Header
        & Assoc ("List_Of_PIs", List_Of_PIs)
        & Assoc ("List_Of_RIs", List_Of_RIs)
        & Assoc ("Timers", Timers);
      return Result;
   end Func_Template;

   function Interface_View_Template (IV : Complete_Interface_View)
                                     return IV_As_Template is
      use Func_Maps;
      use Ada.Strings.Unbounded;
      Result : IV_As_Template;
   begin
      for Each of IV.Flat_Functions loop
         Result.Funcs.Insert (Key      => To_String (Each.Name),
                              New_Item => Func_Template (Each));
      end loop;
      return Result;
   end Interface_View_Template;

   --  Define a custom "Strip" filter for the templates
   function Custom_Strip_Filter (Value   : String;
                                 Context : Filter_Context) return String is
      pragma Unreferenced (Context);
      Pre_Count, Post_Count : Natural := 0;
      Index   : Natural := 0;
      Discard : Boolean := True;
      Result  : String (1 .. Value'Length);
   begin
      for Each of Value loop
         exit when Discard = False;
         if Is_Line_Terminator (Each) or Is_Space (Each) then
            Pre_Count := Pre_Count + 1;
         else
            Discard := False;
         end if;
      end loop;
      Discard := True;
      for Each of reverse Value loop
         exit when Discard = False;
         if Is_Line_Terminator (Each) or Is_Space (Each) then
            Post_Count := Post_Count + 1;
         else
            Discard := False;
         end if;
      end loop;
      for I in Value'First + Pre_Count .. Value'Last - Post_Count loop
         Index := Index + 1;
         Result (Index) := Value (I);
      end loop;
      return Result (1 .. Index);
   end Custom_Strip_Filter;
begin
   Register_Filter ("STRIP", Custom_Strip_Filter'Access);

end TASTE.Backend.Skeletons;