------------------------------------------------------------------------------
-- Copyright (c) 2013-2014, Natacha Porté                                   --
--                                                                          --
-- Permission to use, copy, modify, and distribute this software for any    --
-- purpose with or without fee is hereby granted, provided that the above   --
-- copyright notice and this permission notice appear in all copies.        --
--                                                                          --
-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES --
-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF         --
-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR  --
-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES   --
-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN    --
-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF  --
-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.           --
------------------------------------------------------------------------------

package body Natools.S_Expressions.Generic_Caches is

   --------------------
   -- Tree Interface --
   --------------------

   procedure Append
     (Exp : in out Tree;
      Kind : in Node_Kind;
      Data : in Atom_Access := null)
   is
      N : Node_Access;
   begin
      case Kind is
         when Atom_Node =>
            N := new Node'(Kind => Atom_Node,
              Parent | Next => null, Data => Data);
         when List_Node =>
            N := new Node'(Kind => List_Node, Parent | Next | Child => null);
      end case;

      if Exp.Root = null then
         pragma Assert (Exp.Last = null);
         Exp.Root := N;
      else
         pragma Assert (Exp.Last /= null);

         if Exp.Opening then
            pragma Assert (Exp.Last.Kind = List_Node);
            pragma Assert (Exp.Last.Child = null);
            Exp.Last.Child := N;
            N.Parent := Exp.Last;
         else
            pragma Assert (Exp.Last.Next = null);
            Exp.Last.Next := N;
            N.Parent := Exp.Last.Parent;
         end if;
      end if;

      Exp.Last := N;
      Exp.Opening := Kind = List_Node;
   end Append;

   procedure Close_List (Exp : in out Tree) is
   begin
      if Exp.Opening then
         Exp.Opening := False;
      elsif Exp.Last /= null and then Exp.Last.Parent /= null then
         Exp.Last := Exp.Last.Parent;
      end if;
   end Close_List;

   function Create_Tree return Tree is
   begin
      return Tree'(Ada.Finalization.Limited_Controlled
        with Root | Last => null, Opening => False);
   end Create_Tree;

   function Duplicate (Source : Tree) return Tree is
      function Dup_List (First, Parent : Node_Access) return Node_Access;
      function Dup_Node (N, Parent : Node_Access) return Node_Access;

      New_Last : Node_Access := null;

      function Dup_List (First, Parent : Node_Access) return Node_Access is
         Source : Node_Access := First;
         Result, Target : Node_Access;
      begin
         if First = null then
            return null;
         end if;
         Result := Dup_Node (First, Parent);
         Target := Result;
         loop
            Source := Source.Next;
            exit when Source = null;
            Target.Next := Dup_Node (Source, Parent);
            Target := Target.Next;
         end loop;
         return Result;
      end Dup_List;

      function Dup_Node (N, Parent : Node_Access) return Node_Access is
         Result : Node_Access;
      begin
         if N = null then
            return null;
         end if;

         case N.Kind is
            when Atom_Node =>
               Result := new Node'(Kind => Atom_Node,
                 Parent => Parent,
                 Next => null,
                 Data => new Atom'(N.Data.all));
            when List_Node =>
               Result := new Node'(Kind => List_Node,
                 Parent => Parent,
                 Next => null,
                 Child => Dup_List (N.Child, N));
         end case;

         if N = Source.Last then
            New_Last := Result;
         end if;

         return Result;
      end Dup_Node;
   begin
      return Result : Tree do
         Result.Root := Dup_List (Source.Root, null);
         pragma Assert ((New_Last = null) = (Source.Last = null));
         Result.Last := New_Last;
         Result.Opening := Source.Opening;
      end return;
   end Duplicate;

   overriding procedure Finalize (Object : in out Tree) is
      procedure List_Free (First : in out Node_Access);

      procedure List_Free (First : in out Node_Access) is
         Next : Node_Access := First;
         Cur : Node_Access;
      begin
         while Next /= null loop
            Cur := Next;

            case Cur.Kind is
               when Atom_Node =>
                  Unchecked_Free (Cur.Data);
               when List_Node =>
                  List_Free (Cur.Child);
            end case;

            Next := Cur.Next;
            Unchecked_Free (Cur);
         end loop;

         First := null;
      end List_Free;
   begin
      List_Free (Object.Root);
      Object.Last := null;
      Object.Opening := False;
   end Finalize;

   -----------------------
   -- Writing Interface --
   -----------------------

   function Duplicate (Cache : Reference) return Reference is
      function Dup_Tree return Tree;

      function Dup_Tree return Tree is
      begin
         return Duplicate (Cache.Exp.Query.Data.all);
      end Dup_Tree;
   begin
      return Reference'(Exp => Trees.Create (Dup_Tree'Access));
   end Duplicate;

   -----------------------
   -- Printer Interface --
   -----------------------

   overriding procedure Open_List (Output : in out Reference) is
   begin
      Output.Exp.Update.Data.Append (List_Node);
   end Open_List;

   overriding procedure Append_Atom
     (Output : in out Reference; Data : in Atom) is
   begin
      if Output.Exp.Is_Empty then
         Output.Exp.Replace (Create_Tree'Access);
      end if;

      Output.Exp.Update.Data.Append (Atom_Node, new Atom'(Data));
   end Append_Atom;

   overriding procedure Close_List (Output : in out Reference) is
   begin
      Output.Exp.Update.Data.Close_List;
   end Close_List;

   -------------------------
   -- Reading Subprograms --
   -------------------------

   function First (Cache : Reference'Class) return Cursor is
      N : Node_Access;
   begin
      if Cache.Exp.Is_Empty then
         return Cursor'(others => <>);
      else
         N := Cache.Exp.Query.Data.Root;
         pragma Assert (N /= null);
         return Cursor'(Exp => Cache.Exp, Position => N,
           Opening => N.Kind = List_Node);
      end if;
   end First;

   --------------------------
   -- Descriptor Interface --
   --------------------------

   overriding function Current_Event (Object : in Cursor)
     return Events.Event is
   begin
      if Object.Position = null then
         return Events.End_Of_Input;
      end if;

      case Object.Position.Kind is
         when Atom_Node =>
            return Events.Add_Atom;
         when List_Node =>
            if Object.Opening then
               return Events.Open_List;
            else
               return Events.Close_List;
            end if;
      end case;
   end Current_Event;

   overriding function Current_Atom (Object : in Cursor) return Atom is
   begin
      if Object.Position = null or else Object.Position.Kind /= Atom_Node then
         raise Program_Error;
      end if;

      return Object.Position.Data.all;
   end Current_Atom;

   overriding function Current_Level (Object : in Cursor) return Natural is
      Result : Natural := 0;
      N : Node_Access := Object.Position;
   begin
      while N /= null loop
         Result := Result + 1;
         N := N.Parent;
      end loop;

      return Natural'Max (Result, 1) - 1;
   end Current_Level;

   overriding procedure Query_Atom
     (Object : in Cursor;
      Process : not null access procedure (Data : in Atom)) is
   begin
      if Object.Position = null or else Object.Position.Kind /= Atom_Node then
         raise Program_Error;
      end if;

      Process.all (Object.Position.Data.all);
   end Query_Atom;

   overriding procedure Read_Atom
     (Object : in Cursor;
      Data : out Atom;
      Length : out Count)
   is
      Transferred : Count;
   begin
      if Object.Position = null or else Object.Position.Kind /= Atom_Node then
         raise Program_Error;
      end if;

      Length := Object.Position.Data'Length;
      Transferred := Count'Min (Data'Length, Length);
      Data (Data'First .. Data'First + Transferred - 1)
        := Object.Position.Data (Object.Position.Data'First
             .. Object.Position.Data'First + Transferred - 1);
   end Read_Atom;

   overriding procedure Next
     (Object : in out Cursor;
      Event : out Events.Event) is
   begin
      if Object.Position = null then
         Event := Events.Error;
         return;
      end if;

      if Object.Opening then
         pragma Assert (Object.Position.Kind = List_Node);
         if Object.Position.Child = null then
            Object.Opening := False;
         else
            pragma Assert (Object.Position.Child.Parent = Object.Position);
            Object.Position := Object.Position.Child;
            Object.Opening := Object.Position.Kind = List_Node;
         end if;
      elsif Object.Position.Next /= null then
         pragma Assert (Object.Position.Next.Parent = Object.Position.Parent);
         Object.Position := Object.Position.Next;
         Object.Opening := Object.Position.Kind = List_Node;
      elsif Object.Position.Parent /= null then
         pragma Assert (Object.Position.Parent.Kind = List_Node);
         Object.Position := Object.Position.Parent;
         Object.Opening := False;
      else
         Object.Position := null;
      end if;

      Event := Object.Current_Event;
   end Next;

end Natools.S_Expressions.Generic_Caches;

------------------------------------------------------------------------------
-- Copyright (c) 2013-2014, Natacha Porté                                   --
--                                                                          --
-- Permission to use, copy, modify, and distribute this software for any    --
-- purpose with or without fee is hereby granted, provided that the above   --
-- copyright notice and this permission notice appear in all copies.        --
--                                                                          --
-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES --
-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF         --
-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR  --
-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES   --
-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN    --
-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF  --
-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.           --
------------------------------------------------------------------------------

package body Natools.S_Expressions.Generic_Caches is

   --------------------
   -- Tree Interface --
   --------------------

   procedure Append
     (Exp : in out Tree;
      Kind : in Node_Kind;
      Data : in Atom_Access := null)
   is
      N : Node_Access;
   begin
      case Kind is
         when Atom_Node =>
            N := new Node'(Kind => Atom_Node,
              Parent | Next => null, Data => Data);
         when List_Node =>
            N := new Node'(Kind => List_Node, Parent | Next | Child => null);
      end case;

      if Exp.Root = null then
         pragma Assert (Exp.Last = null);
         Exp.Root := N;
      else
         pragma Assert (Exp.Last /= null);

         if Exp.Opening then
            pragma Assert (Exp.Last.Kind = List_Node);
            pragma Assert (Exp.Last.Child = null);
            Exp.Last.Child := N;
            N.Parent := Exp.Last;
         else
            pragma Assert (Exp.Last.Next = null);
            Exp.Last.Next := N;
            N.Parent := Exp.Last.Parent;
         end if;
      end if;

      Exp.Last := N;
      Exp.Opening := Kind = List_Node;
   end Append;

   procedure Close_List (Exp : in out Tree) is
   begin
      if Exp.Opening then
         Exp.Opening := False;
      elsif Exp.Last /= null and then Exp.Last.Parent /= null then
         Exp.Last := Exp.Last.Parent;
      end if;
   end Close_List;

   function Create_Tree return Tree is
   begin
      return Tree'(Ada.Finalization.Limited_Controlled
        with Root | Last => null, Opening => False);
   end Create_Tree;

   function Duplicate (Source : Tree) return Tree is
      function Dup_List (First, Parent : Node_Access) return Node_Access;
      function Dup_Node (N, Parent : Node_Access) return Node_Access;

      New_Last : Node_Access := null;

      function Dup_List (First, Parent : Node_Access) return Node_Access is
         Source : Node_Access := First;
         Result, Target : Node_Access;
      begin
         if First = null then
            return null;
         end if;
         Result := Dup_Node (First, Parent);
         Target := Result;
         loop
            Source := Source.Next;
            exit when Source = null;
            Target.Next := Dup_Node (Source, Parent);
            Target := Target.Next;
         end loop;
         return Result;
      end Dup_List;

      function Dup_Node (N, Parent : Node_Access) return Node_Access is
         Result : Node_Access;
      begin
         if N = null then
            return null;
         end if;

         case N.Kind is
            when Atom_Node =>
               Result := new Node'(Kind => Atom_Node,
                 Parent => Parent,
                 Next => null,
                 Data => new Atom'(N.Data.all));
            when List_Node =>
               Result := new Node'(Kind => List_Node,
                 Parent => Parent,
                 Next => null,
                 Child => null);
               Result.Child := Dup_List (N.Child, Result);
         end case;

         if N = Source.Last then
            New_Last := Result;
         end if;

         return Result;
      end Dup_Node;
   begin
      return Result : Tree do
         Result.Root := Dup_List (Source.Root, null);
         pragma Assert ((New_Last = null) = (Source.Last = null));
         Result.Last := New_Last;
         Result.Opening := Source.Opening;
      end return;
   end Duplicate;

   overriding procedure Finalize (Object : in out Tree) is
      procedure List_Free (First : in out Node_Access);

      procedure List_Free (First : in out Node_Access) is
         Next : Node_Access := First;
         Cur : Node_Access;
      begin
         while Next /= null loop
            Cur := Next;

            case Cur.Kind is
               when Atom_Node =>
                  Unchecked_Free (Cur.Data);
               when List_Node =>
                  List_Free (Cur.Child);
            end case;

            Next := Cur.Next;
            Unchecked_Free (Cur);
         end loop;

         First := null;
      end List_Free;
   begin
      List_Free (Object.Root);
      Object.Last := null;
      Object.Opening := False;
   end Finalize;

   -----------------------
   -- Writing Interface --
   -----------------------

   function Duplicate (Cache : Reference) return Reference is
      function Dup_Tree return Tree;

      function Dup_Tree return Tree is
      begin
         return Duplicate (Cache.Exp.Query.Data.all);
      end Dup_Tree;
   begin
      return Reference'(Exp => Trees.Create (Dup_Tree'Access));
   end Duplicate;

   -----------------------
   -- Printer Interface --
   -----------------------

   overriding procedure Open_List (Output : in out Reference) is
   begin
      Output.Exp.Update.Data.Append (List_Node);
   end Open_List;

   overriding procedure Append_Atom
     (Output : in out Reference; Data : in Atom) is
   begin
      if Output.Exp.Is_Empty then
         Output.Exp.Replace (Create_Tree'Access);
      end if;

      Output.Exp.Update.Data.Append (Atom_Node, new Atom'(Data));
   end Append_Atom;

   overriding procedure Close_List (Output : in out Reference) is
   begin
      Output.Exp.Update.Data.Close_List;
   end Close_List;

   -------------------------
   -- Reading Subprograms --
   -------------------------

   function First (Cache : Reference'Class) return Cursor is
      N : Node_Access;
   begin
      if Cache.Exp.Is_Empty then
         return Cursor'(others => <>);
      else
         N := Cache.Exp.Query.Data.Root;
         pragma Assert (N /= null);
         return Cursor'(Exp => Cache.Exp, Position => N,
           Opening => N.Kind = List_Node);
      end if;
   end First;

   --------------------------
   -- Descriptor Interface --
   --------------------------

   overriding function Current_Event (Object : in Cursor)
     return Events.Event is
   begin
      if Object.Position = null then
         return Events.End_Of_Input;
      end if;

      case Object.Position.Kind is
         when Atom_Node =>
            return Events.Add_Atom;
         when List_Node =>
            if Object.Opening then
               return Events.Open_List;
            else
               return Events.Close_List;
            end if;
      end case;
   end Current_Event;

   overriding function Current_Atom (Object : in Cursor) return Atom is
   begin
      if Object.Position = null or else Object.Position.Kind /= Atom_Node then
         raise Program_Error;
      end if;

      return Object.Position.Data.all;
   end Current_Atom;

   overriding function Current_Level (Object : in Cursor) return Natural is
      Result : Natural := 0;
      N : Node_Access := Object.Position;
   begin
      while N /= null loop
         Result := Result + 1;
         N := N.Parent;
      end loop;

      return Natural'Max (Result, 1) - 1;
   end Current_Level;

   overriding procedure Query_Atom
     (Object : in Cursor;
      Process : not null access procedure (Data : in Atom)) is
   begin
      if Object.Position = null or else Object.Position.Kind /= Atom_Node then
         raise Program_Error;
      end if;

      Process.all (Object.Position.Data.all);
   end Query_Atom;

   overriding procedure Read_Atom
     (Object : in Cursor;
      Data : out Atom;
      Length : out Count)
   is
      Transferred : Count;
   begin
      if Object.Position = null or else Object.Position.Kind /= Atom_Node then
         raise Program_Error;
      end if;

      Length := Object.Position.Data'Length;
      Transferred := Count'Min (Data'Length, Length);
      Data (Data'First .. Data'First + Transferred - 1)
        := Object.Position.Data (Object.Position.Data'First
             .. Object.Position.Data'First + Transferred - 1);
   end Read_Atom;

   overriding procedure Next
     (Object : in out Cursor;
      Event : out Events.Event) is
   begin
      if Object.Position = null then
         Event := Events.Error;
         return;
      end if;

      if Object.Opening then
         pragma Assert (Object.Position.Kind = List_Node);
         if Object.Position.Child = null then
            Object.Opening := False;
         else
            pragma Assert (Object.Position.Child.Parent = Object.Position);
            Object.Position := Object.Position.Child;
            Object.Opening := Object.Position.Kind = List_Node;
         end if;
      elsif Object.Position.Next /= null then
         pragma Assert (Object.Position.Next.Parent = Object.Position.Parent);
         Object.Position := Object.Position.Next;
         Object.Opening := Object.Position.Kind = List_Node;
      elsif Object.Position.Parent /= null then
         pragma Assert (Object.Position.Parent.Kind = List_Node);
         Object.Position := Object.Position.Parent;
         Object.Opening := False;
      else
         Object.Position := null;
      end if;

      Event := Object.Current_Event;
   end Next;

end Natools.S_Expressions.Generic_Caches;

fix duplication of child lists

s_expressions-generic_caches: fix duplication of child lists


-----------------------------------------------------------------------
--  awa-wikis-beans -- Beans for module wikis
--  Copyright (C) 2015 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with Ada.Strings.Unbounded;

with Util.Beans.Basic;
with Util.Beans.Objects;
with Util.Beans.Objects.Time;

with ADO;

with AWA.Wikis.Modules;
with AWA.Wikis.Models;
with AWA.Tags.Beans;

package AWA.Wikis.Beans is

   type Wiki_View_Bean is new AWA.Wikis.Models.Wiki_View_Info with record
      --  The wiki module instance.
      Module        : Modules.Wiki_Module_Access := null;

      --  The wiki space identifier.
      Wiki_Space_Id : ADO.Identifier;

      --  List of tags associated with the wiki page.
      Tags          : aliased AWA.Tags.Beans.Tag_List_Bean;
      Tags_Bean     : Util.Beans.Basic.Readonly_Bean_Access;
   end record;
   type Wiki_View_Bean_Access is access all Wiki_View_Bean'Class;

   --  Get the value identified by the name.
   overriding
   function Get_Value (From : in Wiki_View_Bean;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Set the value identified by the name.
   overriding
   procedure Set_Value (From  : in out Wiki_View_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object);

   --  Load the information about the wiki page to display it.
   overriding
   procedure Load (Bean    : in out Wiki_View_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   --  Create the Wiki_View_Bean bean instance.
   function Create_Wiki_View_Bean (Module : in AWA.Wikis.Modules.Wiki_Module_Access)
                                  return Util.Beans.Basic.Readonly_Bean_Access;

   type Wiki_Space_Bean is new AWA.Wikis.Models.Wiki_Space_Bean with record
      Service   : Modules.Wiki_Module_Access := null;

      --  List of tags associated with the question.
      Tags      : aliased AWA.Tags.Beans.Tag_List_Bean;
      Tags_Bean : Util.Beans.Basic.Readonly_Bean_Access;
   end record;
   type Wiki_Space_Bean_Access is access all Wiki_Space_Bean'Class;

   --  Get the value identified by the name.
   overriding
   function Get_Value (From : in Wiki_Space_Bean;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Set the value identified by the name.
   overriding
   procedure Set_Value (From  : in out Wiki_Space_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object);

   --  Create or save the wiki space.
   overriding
   procedure Save (Bean    : in out Wiki_Space_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   --  Delete the wiki space.
   procedure Delete (Bean    : in out Wiki_Space_Bean;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   --  Create the Wiki_Space_Bean bean instance.
   function Create_Wiki_Space_Bean (Module : in AWA.Wikis.Modules.Wiki_Module_Access)
                                  return Util.Beans.Basic.Readonly_Bean_Access;

   type Wiki_Page_Bean is new AWA.Wikis.Models.Wiki_Page_Bean with record
      Service    : Modules.Wiki_Module_Access := null;

      --  The page content.
      Content     : Models.Wiki_Content_Ref;
      Has_Content : Boolean := False;

      Wiki_Space  : Wiki_Space_Bean;

      --  List of tags associated with the question.
      Tags        : aliased AWA.Tags.Beans.Tag_List_Bean;
      Tags_Bean   : Util.Beans.Basic.Readonly_Bean_Access;
   end record;
   type Wiki_Page_Bean_Access is access all Wiki_Page_Bean'Class;

   --  Get the value identified by the name.
   overriding
   function Get_Value (From : in Wiki_Page_Bean;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Set the value identified by the name.
   overriding
   procedure Set_Value (From  : in out Wiki_Page_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object);

   --  Create or save the wiki page.
   overriding
   procedure Save (Bean    : in out Wiki_Page_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   --  Load the wiki page.
   overriding
   procedure Load (Bean    : in out Wiki_Page_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   --  Delete the wiki page.
   overriding
   procedure Delete (Bean    : in out Wiki_Page_Bean;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   --  Create the Wiki_Page_Bean bean instance.
   function Create_Wiki_Page_Bean (Module : in AWA.Wikis.Modules.Wiki_Module_Access)
                                    return Util.Beans.Basic.Readonly_Bean_Access;
   --  ------------------------------
   --  Wiki List Bean
   --  ------------------------------
   --  The Wiki_List_Bean gives a list of visible wikis to be displayed to users.
   --  The list can be filtered by a given tag.  The list pagination is supported.
   type Wiki_List_Bean is new AWA.Wikis.Models.Wiki_Page_List_Bean with record
      Pages      : aliased AWA.Wikis.Models.Wiki_Page_Info_List_Bean;
      Service    : Modules.Wiki_Module_Access := null;
      Tags       : AWA.Tags.Beans.Entity_Tag_Map;
      Pages_Bean : AWA.Wikis.Models.Wiki_Page_Info_List_Bean_Access;
   end record;
   type Wiki_List_Bean_Access is access all Wiki_List_Bean'Class;

   --  Get the value identified by the name.
   overriding
   function Get_Value (From : in Wiki_List_Bean;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Set the value identified by the name.
   overriding
   procedure Set_Value (From  : in out Wiki_List_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object);

   overriding
   procedure Load (From    : in out Wiki_List_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   --  Load the list of pages.  If a tag was set, filter the list of pages with the tag.
   procedure Load_List (Into : in out Wiki_List_Bean);

   --  Create the Post_List_Bean bean instance.
   function Create_Wiki_List_Bean (Module : in AWA.Wikis.Modules.Wiki_Module_Access)
                                   return Util.Beans.Basic.Readonly_Bean_Access;

   type Init_Flag is (INIT_WIKI_LIST);
   type Init_Map is array (Init_Flag) of Boolean;

   --  ------------------------------
   --  Admin List Bean
   --  ------------------------------
   --  The Wiki_Admin_Bean is used for the administration of a wiki.  It gives the
   --  list of wikis and pages that are created, published or not.
   type Wiki_Admin_Bean is new Util.Beans.Basic.Bean with record
      Module : AWA.Wikis.Modules.Wiki_Module_Access := null;

      --  The wiki space identifier.
      Wiki_Id          : ADO.Identifier := ADO.NO_IDENTIFIER;

      --  List of blogs.
      Wiki_List        : aliased AWA.Wikis.Models.Wiki_Info_List_Bean;
      Wiki_List_Bean   : AWA.Wikis.Models.Wiki_Info_List_Bean_Access;

      --  Initialization flags.
      Init_Flags       : aliased Init_Map := (others => False);
      Flags            : access Init_Map;
   end record;
   type Wiki_Admin_Bean_Access is access all Wiki_Admin_Bean;

   --  Get the wiki space identifier.
   function Get_Wiki_Id (List : in Wiki_Admin_Bean) return ADO.Identifier;

   overriding
   function Get_Value (List : in Wiki_Admin_Bean;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Set the value identified by the name.
   overriding
   procedure Set_Value (From  : in out Wiki_Admin_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object);

   --  Load the list of wikis.
   procedure Load_Wikis (List : in Wiki_Admin_Bean);

   --  Create the Wiki_Admin_Bean bean instance.
   function Create_Wiki_Admin_Bean (Module : in AWA.Wikis.Modules.Wiki_Module_Access)
                                    return Util.Beans.Basic.Readonly_Bean_Access;

end AWA.Wikis.Beans;

-----------------------------------------------------------------------
--  awa-wikis-beans -- Beans for module wikis
--  Copyright (C) 2015 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with Ada.Strings.Unbounded;

with Util.Beans.Basic;
with Util.Beans.Objects;
with Util.Beans.Objects.Time;

with ADO;

with AWA.Wikis.Modules;
with AWA.Wikis.Models;
with AWA.Tags.Beans;

package AWA.Wikis.Beans is

   type Wiki_View_Bean is new AWA.Wikis.Models.Wiki_View_Info with record
      --  The wiki module instance.
      Module        : Modules.Wiki_Module_Access := null;

      --  The wiki space identifier.
      Wiki_Space_Id : ADO.Identifier;

      --  List of tags associated with the wiki page.
      Tags          : aliased AWA.Tags.Beans.Tag_List_Bean;
      Tags_Bean     : Util.Beans.Basic.Readonly_Bean_Access;
   end record;
   type Wiki_View_Bean_Access is access all Wiki_View_Bean'Class;

   --  Get the value identified by the name.
   overriding
   function Get_Value (From : in Wiki_View_Bean;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Set the value identified by the name.
   overriding
   procedure Set_Value (From  : in out Wiki_View_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object);

   --  Load the information about the wiki page to display it.
   overriding
   procedure Load (Bean    : in out Wiki_View_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   --  Create the Wiki_View_Bean bean instance.
   function Create_Wiki_View_Bean (Module : in AWA.Wikis.Modules.Wiki_Module_Access)
                                  return Util.Beans.Basic.Readonly_Bean_Access;

   type Wiki_Space_Bean is new AWA.Wikis.Models.Wiki_Space_Bean with record
      Module    : Modules.Wiki_Module_Access := null;

      --  List of tags associated with the question.
      Tags      : aliased AWA.Tags.Beans.Tag_List_Bean;
      Tags_Bean : Util.Beans.Basic.Readonly_Bean_Access;
   end record;
   type Wiki_Space_Bean_Access is access all Wiki_Space_Bean'Class;

   --  Get the value identified by the name.
   overriding
   function Get_Value (From : in Wiki_Space_Bean;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Set the value identified by the name.
   overriding
   procedure Set_Value (From  : in out Wiki_Space_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object);

   --  Create or save the wiki space.
   overriding
   procedure Save (Bean    : in out Wiki_Space_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   --  Delete the wiki space.
   procedure Delete (Bean    : in out Wiki_Space_Bean;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   --  Create the Wiki_Space_Bean bean instance.
   function Create_Wiki_Space_Bean (Module : in AWA.Wikis.Modules.Wiki_Module_Access)
                                  return Util.Beans.Basic.Readonly_Bean_Access;

   type Wiki_Page_Bean is new AWA.Wikis.Models.Wiki_Page_Bean with record
      Module     : Modules.Wiki_Module_Access := null;

      --  The page content.
      Content     : Models.Wiki_Content_Ref;
      Has_Content : Boolean := False;

      Wiki_Space  : Wiki_Space_Bean;

      --  List of tags associated with the question.
      Tags        : aliased AWA.Tags.Beans.Tag_List_Bean;
      Tags_Bean   : Util.Beans.Basic.Readonly_Bean_Access;
   end record;
   type Wiki_Page_Bean_Access is access all Wiki_Page_Bean'Class;

   --  Get the value identified by the name.
   overriding
   function Get_Value (From : in Wiki_Page_Bean;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Set the value identified by the name.
   overriding
   procedure Set_Value (From  : in out Wiki_Page_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object);

   --  Create or save the wiki page.
   overriding
   procedure Save (Bean    : in out Wiki_Page_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   --  Load the wiki page.
   overriding
   procedure Load (Bean    : in out Wiki_Page_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   --  Delete the wiki page.
   overriding
   procedure Delete (Bean    : in out Wiki_Page_Bean;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   --  Create the Wiki_Page_Bean bean instance.
   function Create_Wiki_Page_Bean (Module : in AWA.Wikis.Modules.Wiki_Module_Access)
                                    return Util.Beans.Basic.Readonly_Bean_Access;
   --  ------------------------------
   --  Wiki List Bean
   --  ------------------------------
   --  The Wiki_List_Bean gives a list of visible wikis to be displayed to users.
   --  The list can be filtered by a given tag.  The list pagination is supported.
   type Wiki_List_Bean is new AWA.Wikis.Models.Wiki_Page_List_Bean with record
      Module     : Modules.Wiki_Module_Access := null;
      Pages      : aliased AWA.Wikis.Models.Wiki_Page_Info_List_Bean;
      Tags       : AWA.Tags.Beans.Entity_Tag_Map;
      Pages_Bean : AWA.Wikis.Models.Wiki_Page_Info_List_Bean_Access;
   end record;
   type Wiki_List_Bean_Access is access all Wiki_List_Bean'Class;

   --  Get the value identified by the name.
   overriding
   function Get_Value (From : in Wiki_List_Bean;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Set the value identified by the name.
   overriding
   procedure Set_Value (From  : in out Wiki_List_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object);

   overriding
   procedure Load (From    : in out Wiki_List_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   --  Load the list of pages.  If a tag was set, filter the list of pages with the tag.
   procedure Load_List (Into : in out Wiki_List_Bean);

   --  Create the Post_List_Bean bean instance.
   function Create_Wiki_List_Bean (Module : in AWA.Wikis.Modules.Wiki_Module_Access)
                                   return Util.Beans.Basic.Readonly_Bean_Access;

   type Init_Flag is (INIT_WIKI_LIST);
   type Init_Map is array (Init_Flag) of Boolean;

   --  ------------------------------
   --  Admin List Bean
   --  ------------------------------
   --  The Wiki_Admin_Bean is used for the administration of a wiki.  It gives the
   --  list of wikis and pages that are created, published or not.
   type Wiki_Admin_Bean is new Util.Beans.Basic.Bean with record
      Module : AWA.Wikis.Modules.Wiki_Module_Access := null;

      --  The wiki space identifier.
      Wiki_Id          : ADO.Identifier := ADO.NO_IDENTIFIER;

      --  List of blogs.
      Wiki_List        : aliased AWA.Wikis.Models.Wiki_Info_List_Bean;
      Wiki_List_Bean   : AWA.Wikis.Models.Wiki_Info_List_Bean_Access;

      --  Initialization flags.
      Init_Flags       : aliased Init_Map := (others => False);
      Flags            : access Init_Map;
   end record;
   type Wiki_Admin_Bean_Access is access all Wiki_Admin_Bean;

   --  Get the wiki space identifier.
   function Get_Wiki_Id (List : in Wiki_Admin_Bean) return ADO.Identifier;

   overriding
   function Get_Value (List : in Wiki_Admin_Bean;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Set the value identified by the name.
   overriding
   procedure Set_Value (From  : in out Wiki_Admin_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object);

   --  Load the list of wikis.
   procedure Load_Wikis (List : in Wiki_Admin_Bean);

   --  Create the Wiki_Admin_Bean bean instance.
   function Create_Wiki_Admin_Bean (Module : in AWA.Wikis.Modules.Wiki_Module_Access)
                                    return Util.Beans.Basic.Readonly_Bean_Access;

end AWA.Wikis.Beans;

Rename Service into Module in the bean record declarations


-----------------------------------------------------------------------
--  gen-model -- Model for Code Generator
--  Copyright (C) 2009, 2010, 2011, 2012, 2018 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Finalization;
with Ada.Strings.Unbounded;

with Util.Log;
with Util.Beans.Basic;
with Util.Beans.Objects;
with Util.Beans.Objects.Maps;

with DOM.Core;
package Gen.Model is

   --  Exception raised if a name is already registered in the model.
   --  This exception is raised if a table, an enum is already defined.
   Name_Exist : exception;

   --  ------------------------------
   --  Model Definition
   --  ------------------------------
   type Definition is new Ada.Finalization.Limited_Controlled
     and Util.Beans.Basic.Readonly_Bean with private;
   type Definition_Access is access all Definition'Class;

   --  Prepare the generation of the model.
   procedure Prepare (O : in out Definition) is null;

   --  Get the object unique name.
   function Get_Name (From : in Definition) return String;
   function Name (From : in Definition) return Ada.Strings.Unbounded.Unbounded_String;

   --  Set the object unique name.
   procedure Set_Name (Def  : in out Definition;
                       Name : in String);
   procedure Set_Name (Def  : in out Definition;
                       Name : in Ada.Strings.Unbounded.Unbounded_String);

   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   function Get_Value (From : in Definition;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   function Get_Attribute (From : in Definition;
                           Name : in String) return String;

   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   function Get_Attribute (From : in Definition;
                           Name : in String) return Ada.Strings.Unbounded.Unbounded_String;

   --  Set the comment associated with the element.
   procedure Set_Comment (Def     : in out Definition;
                          Comment : in String);

   --  Get the comment associated with the element.
   function Get_Comment (Def : in Definition) return Util.Beans.Objects.Object;

   --  Set the location (file and line) where the model element is defined in the XMI file.
   procedure Set_Location (Node     : in out Definition;
                           Location : in String);

   --  Get the location file and line where the model element is defined.
   function Get_Location (Node : in Definition) return String;

   --  Initialize the definition from the DOM node attributes.
   procedure Initialize (Def  : in out Definition;
                         Name : in Ada.Strings.Unbounded.Unbounded_String;
                         Node : in DOM.Core.Node);

   --  Validate the definition by checking and reporting problems to the logger interface.
   procedure Validate (Def : in out Definition;
                       Log : in out Util.Log.Logging'Class);

private

   type Definition is new Ada.Finalization.Limited_Controlled
     and Util.Beans.Basic.Readonly_Bean with record
      Row_Index  : Natural;
      Def_Name   : Ada.Strings.Unbounded.Unbounded_String;
      Attrs      : Util.Beans.Objects.Maps.Map_Bean;
      Comment    : Util.Beans.Objects.Object;
      Location   : Ada.Strings.Unbounded.Unbounded_String;
   end record;

end Gen.Model;

-----------------------------------------------------------------------
--  gen-model -- Model for Code Generator
--  Copyright (C) 2009, 2010, 2011, 2012, 2018, 2020 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Finalization;
with Ada.Strings.Unbounded;

with Util.Log;
with Util.Beans.Basic;
with Util.Beans.Objects;
with Util.Beans.Objects.Maps;

with DOM.Core;
package Gen.Model is

   --  Exception raised if a name is already registered in the model.
   --  This exception is raised if a table, an enum is already defined.
   Name_Exist : exception;

   --  ------------------------------
   --  Model Definition
   --  ------------------------------
   type Definition is new Ada.Finalization.Limited_Controlled
     and Util.Beans.Basic.Readonly_Bean with private;
   type Definition_Access is access all Definition'Class;

   --  Prepare the generation of the model.
   procedure Prepare (O : in out Definition) is null;

   --  Get the object unique name.
   function Get_Name (From : in Definition) return String;
   function Name (From : in Definition) return Ada.Strings.Unbounded.Unbounded_String;

   --  Set the object unique name.
   procedure Set_Name (Def  : in out Definition;
                       Name : in String);
   procedure Set_Name (Def  : in out Definition;
                       Name : in Ada.Strings.Unbounded.Unbounded_String);

   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   function Get_Value (From : in Definition;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   function Get_Attribute (From : in Definition;
                           Name : in String) return String;

   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   function Get_Attribute (From : in Definition;
                           Name : in String) return Ada.Strings.Unbounded.Unbounded_String;

   --  Set the comment associated with the element.
   procedure Set_Comment (Def     : in out Definition;
                          Comment : in String);

   --  Get the comment associated with the element.
   function Get_Comment (Def : in Definition) return Util.Beans.Objects.Object;

   --  Set the location (file and line) where the model element is defined in the XMI file.
   procedure Set_Location (Node     : in out Definition;
                           Location : in String);

   --  Get the location file and line where the model element is defined.
   function Get_Location (Node : in Definition) return String;

   --  Initialize the definition from the DOM node attributes.
   procedure Initialize (Def  : in out Definition;
                         Name : in Ada.Strings.Unbounded.Unbounded_String;
                         Node : in DOM.Core.Node);

   --  Validate the definition by checking and reporting problems to the logger interface.
   procedure Validate (Def : in out Definition;
                       Log : in out Util.Log.Logging'Class);

private

   procedure Set_Index (Def   : in out Definition;
                        Index : in Natural);

   type Definition is new Ada.Finalization.Limited_Controlled
     and Util.Beans.Basic.Readonly_Bean with record
      Row_Index  : Natural;
      Def_Name   : Ada.Strings.Unbounded.Unbounded_String;
      Attrs      : Util.Beans.Objects.Maps.Map_Bean;
      Comment    : Util.Beans.Objects.Object;
      Location   : Ada.Strings.Unbounded.Unbounded_String;
   end record;

end Gen.Model;

Declare the Set_Index procedure for a workarround on GNAT 2020 issue


------------------------------------------------------------------------------
--                                                                          --
--                    Copyright (C) 2015-2018, AdaCore                      --
--                                                                          --
--  Redistribution and use in source and binary forms, with or without      --
--  modification, are permitted provided that the following conditions are  --
--  met:                                                                    --
--     1. Redistributions of source code must retain the above copyright    --
--        notice, this list of conditions and the following disclaimer.     --
--     2. Redistributions in binary form must reproduce the above copyright --
--        notice, this list of conditions and the following disclaimer in   --
--        the documentation and/or other materials provided with the        --
--        distribution.                                                     --
--     3. Neither the name of the copyright holder nor the names of its     --
--        contributors may be used to endorse or promote products derived   --
--        from this software without specific prior written permission.     --
--                                                                          --
--   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS    --
--   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT      --
--   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR  --
--   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT   --
--   HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, --
--   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT       --
--   LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,  --
--   DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY  --
--   THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT    --
--   (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE  --
--   OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.   --
--                                                                          --
------------------------------------------------------------------------------

with Ada.Unchecked_Conversion;
with HAL.GPIO;                   use HAL.GPIO;

package body MCP23x08 is

   function To_UInt8 is
      new Ada.Unchecked_Conversion (Source => ALl_IO_Array,
                                    Target => UInt8);
   function To_All_IO_Array is
      new Ada.Unchecked_Conversion (Source => UInt8,
                                    Target => ALl_IO_Array);
   procedure Loc_IO_Write
     (This      : in out MCP23x08_IO_Expander'Class;
      WriteAddr : Register_Address;
      Value     : UInt8)
     with Inline_Always;

   procedure Loc_IO_Read
     (This     : MCP23x08_IO_Expander'Class;
      ReadAddr : Register_Address;
      Value    : out UInt8)
     with Inline_Always;

   procedure Set_Bit
     (This    : in out MCP23x08_IO_Expander;
      RegAddr : Register_Address;
      Pin     : MCP23x08_Pin);

   procedure Clear_Bit
     (This    : in out MCP23x08_IO_Expander;
      RegAddr : Register_Address;
      Pin     : MCP23x08_Pin);

   function Read_Bit
     (This    : MCP23x08_IO_Expander;
      RegAddr : Register_Address;
      Pin     : MCP23x08_Pin)
      return Boolean;

   ------------------
   -- Loc_IO_Write --
   ------------------

   procedure Loc_IO_Write
     (This      : in out MCP23x08_IO_Expander'Class;
      WriteAddr : Register_Address;
      Value     : UInt8)
   is

   begin
      IO_Write (This, WriteAddr, Value);
   end Loc_IO_Write;

   -----------------
   -- Loc_IO_Read --
   -----------------

   procedure Loc_IO_Read
     (This     : MCP23x08_IO_Expander'Class;
      ReadAddr : Register_Address;
      Value    : out UInt8)
      is
   begin
      IO_Read (This, ReadAddr, Value);
   end Loc_IO_Read;

   -------------
   -- Set_Bit --
   -------------

   procedure Set_Bit
     (This    : in out MCP23x08_IO_Expander;
      RegAddr : Register_Address;
      Pin     : MCP23x08_Pin)
   is
      Prev, Next : UInt8;
   begin
      Loc_IO_Read (This, RegAddr, Prev);
      Next := Prev or Pin'Enum_Rep;
      if Next /= Prev then
         Loc_IO_Write (This, RegAddr, Next);
      end if;
   end Set_Bit;

   ---------------
   -- Clear_Bit --
   ---------------

   procedure Clear_Bit
     (This    : in out MCP23x08_IO_Expander;
      RegAddr : Register_Address;
      Pin     : MCP23x08_Pin)
   is
      Prev, Next : UInt8;
   begin
      Loc_IO_Read (This, RegAddr, Prev);
      Next := Prev and (not  Pin'Enum_Rep);
      if Next /= Prev then
         Loc_IO_Write (This, RegAddr, Next);
      end if;
   end Clear_Bit;

   --------------
   -- Read_Bit --
   --------------

   function Read_Bit
     (This    : MCP23x08_IO_Expander;
      RegAddr : Register_Address;
      Pin     : MCP23x08_Pin)
      return Boolean
   is
      Reg : UInt8;
   begin
      Loc_IO_Read (This, RegAddr, Reg);
      return (Reg and Pin'Enum_Rep) /= 0;
   end Read_Bit;

   ---------------
   -- Configure --
   ---------------

   procedure Configure (This    : in out MCP23x08_IO_Expander;
                        Pin     : MCP23x08_Pin;
                        Output  : Boolean;
                        Pull_Up : Boolean)
   is
   begin
      This.Configure_Mode (Pin, Output);
      This.Configure_Pull (Pin, Pull_Up);
   end Configure;

   procedure Configure_Mode (This    : in out MCP23x08_IO_Expander;
                             Pin     : MCP23x08_Pin;
                             Output  : Boolean)
   is
   begin
      if Output then
         Clear_Bit (This, IO_DIRECTION_REG, Pin);
      else
         Set_Bit (This, IO_DIRECTION_REG, Pin);
      end if;
   end Configure_Mode;

   ---------------
   -- Is_Output --
   ---------------

   function Is_Output (This : in out MCP23x08_IO_Expander;
                       Pin  : MCP23x08_Pin)
                       return Boolean
   is
   begin
      return not Read_Bit (This, IO_DIRECTION_REG, Pin);
   end Is_Output;

   --------------------
   -- Configure_Pull --
   --------------------

   procedure Configure_Pull (This    : in out MCP23x08_IO_Expander;
                             Pin     : MCP23x08_Pin;
                             Pull_Up : Boolean)
   is
   begin
      if Pull_Up then
         Set_Bit (This, PULL_UP_REG, Pin);
      else
         Clear_Bit (This, PULL_UP_REG, Pin);
      end if;
   end Configure_Pull;

   -------------
   -- Pull_Up --
   -------------

   function Pull_Up (This : MCP23x08_IO_Expander;
                     Pin  : MCP23x08_Pin) return Boolean
   is
   begin
      return Read_Bit (This, PULL_UP_REG, Pin);
   end Pull_Up;

   ---------
   -- Set --
   ---------

   function Set (This  : MCP23x08_IO_Expander;
                 Pin   : MCP23x08_Pin) return Boolean
   is
      Val : UInt8;
   begin
      Loc_IO_Read (This, LOGIC_LEVLEL_REG, Val);
      return (Pin'Enum_Rep and Val) /= 0;
   end Set;

   ---------
   -- Set --
   ---------

   procedure Set (This  : in out MCP23x08_IO_Expander;
                  Pin   : MCP23x08_Pin)
   is
   begin
      Set_Bit (This, LOGIC_LEVLEL_REG, Pin);
   end Set;

   -----------
   -- Clear --
   -----------

   procedure Clear (This  : in out MCP23x08_IO_Expander;
                    Pin   : MCP23x08_Pin)
   is
   begin
      Clear_Bit (This, LOGIC_LEVLEL_REG, Pin);
   end Clear;

   ------------
   -- Toggle --
   ------------

   procedure Toggle (This  : in out MCP23x08_IO_Expander;
                     Pin   : MCP23x08_Pin)
   is
   begin
      if This.Set (Pin) then
         This.Clear (Pin);
      else
         This.Set (Pin);
      end if;
   end Toggle;

   ------------
   -- All_IO --
   ------------

   function All_IO (This : in out MCP23x08_IO_Expander) return ALl_IO_Array is
      Val : UInt8;
   begin
      Loc_IO_Read (This, LOGIC_LEVLEL_REG, Val);
      return To_All_IO_Array (Val);
   end All_IO;

   ----------------
   -- Set_All_IO --
   ----------------

   procedure Set_All_IO (This : in out MCP23x08_IO_Expander; IOs : ALl_IO_Array) is
   begin
      Loc_IO_Write (This, LOGIC_LEVLEL_REG, To_UInt8 (IOs));
   end Set_All_IO;

   -------------------
   -- As_GPIO_Point --
   -------------------

   function As_GPIO_Point (This : in out MCP23x08_IO_Expander;
                            Pin  : MCP23x08_Pin)
                            return not null HAL.GPIO.Any_GPIO_Point
   is
   begin
      This.Points (Pin) := (Device => This'Unchecked_Access,
                            Pin    => Pin);
      return This.Points (Pin)'Unchecked_Access;
   end As_GPIO_Point;

   ----------
   -- Mode --
   ----------

   overriding
   function Mode (This : MCP23_GPIO_Point) return HAL.GPIO.GPIO_Mode is
      pragma Unreferenced (This);
   begin
      return HAL.GPIO.Output;
   end Mode;

   --------------
   -- Set_Mode --
   --------------

   overriding
   procedure Set_Mode (This : in out MCP23_GPIO_Point;
                       Mode : HAL.GPIO.GPIO_Config_Mode)
   is
   begin
      This.Device.Configure_Mode (Pin    => This.Pin,
                                  Output => (Mode = HAL.GPIO.Output));
   end Set_Mode;

   -------------------
   -- Pull_Resistor --
   -------------------

   overriding
   function Pull_Resistor (This : MCP23_GPIO_Point)
                           return HAL.GPIO.GPIO_Pull_Resistor
   is
   begin
      return (if This.Device.Pull_Up (This.Pin) then
                 HAL.GPIO.Pull_Up
              else
                 HAL.GPIO.Floating);
   end Pull_Resistor;

   -----------------------
   -- Set_Pull_Resistor --
   -----------------------

   overriding
   procedure Set_Pull_Resistor (This : in out MCP23_GPIO_Point;
                                Pull : HAL.GPIO.GPIO_Pull_Resistor)
   is
   begin
      This.Device.Configure_Pull (This.Pin, Pull = HAL.GPIO.Pull_Up);
   end Set_Pull_Resistor;

   ---------
   -- Set --
   ---------

   overriding
   function Set (This : MCP23_GPIO_Point) return Boolean is
   begin
      return This.Device.Set (This.Pin);
   end Set;

   ---------
   -- Set --
   ---------

   overriding
   procedure Set (This : in out MCP23_GPIO_Point) is
   begin
      This.Device.Set (This.Pin);
   end Set;

   -----------
   -- Clear --
   -----------

   overriding
   procedure Clear (This : in out MCP23_GPIO_Point) is
   begin
      This.Device.Clear (This.Pin);
   end Clear;

   ------------
   -- Toggle --
   ------------

   overriding
   procedure Toggle (This : in out MCP23_GPIO_Point) is
   begin
      This.Device.Toggle (This.Pin);
   end Toggle;

end MCP23x08;

------------------------------------------------------------------------------
--                                                                          --
--                    Copyright (C) 2015-2018, 2022, AdaCore                --
--                                                                          --
--  Redistribution and use in source and binary forms, with or without      --
--  modification, are permitted provided that the following conditions are  --
--  met:                                                                    --
--     1. Redistributions of source code must retain the above copyright    --
--        notice, this list of conditions and the following disclaimer.     --
--     2. Redistributions in binary form must reproduce the above copyright --
--        notice, this list of conditions and the following disclaimer in   --
--        the documentation and/or other materials provided with the        --
--        distribution.                                                     --
--     3. Neither the name of the copyright holder nor the names of its     --
--        contributors may be used to endorse or promote products derived   --
--        from this software without specific prior written permission.     --
--                                                                          --
--   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS    --
--   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT      --
--   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR  --
--   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT   --
--   HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, --
--   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT       --
--   LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,  --
--   DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY  --
--   THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT    --
--   (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE  --
--   OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.   --
--                                                                          --
------------------------------------------------------------------------------

with Ada.Unchecked_Conversion;
with HAL.GPIO;                   use HAL.GPIO;

package body MCP23x08 is

   function To_UInt8 is
      new Ada.Unchecked_Conversion (Source => ALl_IO_Array,
                                    Target => UInt8);
   function To_All_IO_Array is
      new Ada.Unchecked_Conversion (Source => UInt8,
                                    Target => ALl_IO_Array);
   procedure Loc_IO_Write
     (This      : in out MCP23x08_IO_Expander'Class;
      WriteAddr : Register_Address;
      Value     : UInt8)
     with Inline_Always;

   procedure Loc_IO_Read
     (This     : MCP23x08_IO_Expander'Class;
      ReadAddr : Register_Address;
      Value    : out UInt8)
     with Inline_Always;

   procedure Set_Bit
     (This    : in out MCP23x08_IO_Expander;
      RegAddr : Register_Address;
      Pin     : MCP23x08_Pin);

   procedure Clear_Bit
     (This    : in out MCP23x08_IO_Expander;
      RegAddr : Register_Address;
      Pin     : MCP23x08_Pin);

   function Read_Bit
     (This    : MCP23x08_IO_Expander;
      RegAddr : Register_Address;
      Pin     : MCP23x08_Pin)
      return Boolean;

   ------------------
   -- Loc_IO_Write --
   ------------------

   procedure Loc_IO_Write
     (This      : in out MCP23x08_IO_Expander'Class;
      WriteAddr : Register_Address;
      Value     : UInt8)
   is

   begin
      IO_Write (This, WriteAddr, Value);
   end Loc_IO_Write;

   -----------------
   -- Loc_IO_Read --
   -----------------

   procedure Loc_IO_Read
     (This     : MCP23x08_IO_Expander'Class;
      ReadAddr : Register_Address;
      Value    : out UInt8)
      is
   begin
      IO_Read (This, ReadAddr, Value);
   end Loc_IO_Read;

   -------------
   -- Set_Bit --
   -------------

   procedure Set_Bit
     (This    : in out MCP23x08_IO_Expander;
      RegAddr : Register_Address;
      Pin     : MCP23x08_Pin)
   is
      Prev, Next : UInt8;
   begin
      Loc_IO_Read (This, RegAddr, Prev);
      Next := Prev or Pin'Enum_Rep;
      if Next /= Prev then
         Loc_IO_Write (This, RegAddr, Next);
      end if;
   end Set_Bit;

   ---------------
   -- Clear_Bit --
   ---------------

   procedure Clear_Bit
     (This    : in out MCP23x08_IO_Expander;
      RegAddr : Register_Address;
      Pin     : MCP23x08_Pin)
   is
      Prev, Next : UInt8;
   begin
      Loc_IO_Read (This, RegAddr, Prev);
      Next := Prev and (not  Pin'Enum_Rep);
      if Next /= Prev then
         Loc_IO_Write (This, RegAddr, Next);
      end if;
   end Clear_Bit;

   --------------
   -- Read_Bit --
   --------------

   function Read_Bit
     (This    : MCP23x08_IO_Expander;
      RegAddr : Register_Address;
      Pin     : MCP23x08_Pin)
      return Boolean
   is
      Reg : UInt8;
   begin
      Loc_IO_Read (This, RegAddr, Reg);
      return (Reg and Pin'Enum_Rep) /= 0;
   end Read_Bit;

   ---------------
   -- Configure --
   ---------------

   procedure Configure (This    : in out MCP23x08_IO_Expander;
                        Pin     : MCP23x08_Pin;
                        Output  : Boolean;
                        Pull_Up : Boolean)
   is
   begin
      This.Configure_Mode (Pin, Output);
      This.Configure_Pull (Pin, Pull_Up);
   end Configure;

   procedure Configure_Mode (This    : in out MCP23x08_IO_Expander;
                             Pin     : MCP23x08_Pin;
                             Output  : Boolean)
   is
   begin
      if Output then
         Clear_Bit (This, IO_DIRECTION_REG, Pin);
      else
         Set_Bit (This, IO_DIRECTION_REG, Pin);
      end if;
   end Configure_Mode;

   ---------------
   -- Is_Output --
   ---------------

   function Is_Output (This : in out MCP23x08_IO_Expander;
                       Pin  : MCP23x08_Pin)
                       return Boolean
   is
   begin
      return not Read_Bit (This, IO_DIRECTION_REG, Pin);
   end Is_Output;

   --------------------
   -- Configure_Pull --
   --------------------

   procedure Configure_Pull (This    : in out MCP23x08_IO_Expander;
                             Pin     : MCP23x08_Pin;
                             Pull_Up : Boolean)
   is
   begin
      if Pull_Up then
         Set_Bit (This, PULL_UP_REG, Pin);
      else
         Clear_Bit (This, PULL_UP_REG, Pin);
      end if;
   end Configure_Pull;

   -------------
   -- Pull_Up --
   -------------

   function Pull_Up (This : MCP23x08_IO_Expander;
                     Pin  : MCP23x08_Pin) return Boolean
   is
   begin
      return Read_Bit (This, PULL_UP_REG, Pin);
   end Pull_Up;

   ---------
   -- Set --
   ---------

   function Set (This  : MCP23x08_IO_Expander;
                 Pin   : MCP23x08_Pin) return Boolean
   is
      Val : UInt8;
   begin
      Loc_IO_Read (This, LOGIC_LEVLEL_REG, Val);
      return (Pin'Enum_Rep and Val) /= 0;
   end Set;

   ---------
   -- Set --
   ---------

   procedure Set (This  : in out MCP23x08_IO_Expander;
                  Pin   : MCP23x08_Pin)
   is
   begin
      Set_Bit (This, LOGIC_LEVLEL_REG, Pin);
   end Set;

   -----------
   -- Clear --
   -----------

   procedure Clear (This  : in out MCP23x08_IO_Expander;
                    Pin   : MCP23x08_Pin)
   is
   begin
      Clear_Bit (This, LOGIC_LEVLEL_REG, Pin);
   end Clear;

   ------------
   -- Toggle --
   ------------

   procedure Toggle (This  : in out MCP23x08_IO_Expander;
                     Pin   : MCP23x08_Pin)
   is
   begin
      if This.Set (Pin) then
         This.Clear (Pin);
      else
         This.Set (Pin);
      end if;
   end Toggle;

   ------------
   -- All_IO --
   ------------

   function All_IO (This : in out MCP23x08_IO_Expander) return ALl_IO_Array is
      Val : UInt8;
   begin
      Loc_IO_Read (This, LOGIC_LEVLEL_REG, Val);
      return To_All_IO_Array (Val);
   end All_IO;

   ----------------
   -- Set_All_IO --
   ----------------

   procedure Set_All_IO (This : in out MCP23x08_IO_Expander; IOs : ALl_IO_Array) is
   begin
      Loc_IO_Write (This, LOGIC_LEVLEL_REG, To_UInt8 (IOs));
   end Set_All_IO;

   -------------------
   -- As_GPIO_Point --
   -------------------

   function As_GPIO_Point (This : in out MCP23x08_IO_Expander;
                            Pin  : MCP23x08_Pin)
                            return not null HAL.GPIO.Any_GPIO_Point
   is
   begin
      This.Points (Pin) := (Device => This'Unchecked_Access,
                            Pin    => Pin);
      return This.Points (Pin)'Unchecked_Access;
   end As_GPIO_Point;

   ----------
   -- Mode --
   ----------

   overriding
   function Mode (This : MCP23_GPIO_Point) return HAL.GPIO.GPIO_Mode is
   begin
      if This.Device.Is_Output (This.Pin) then
         return HAL.GPIO.Output;
      else
         return HAL.GPIO.Input;
      end if;
   end Mode;

   --------------
   -- Set_Mode --
   --------------

   overriding
   procedure Set_Mode (This : in out MCP23_GPIO_Point;
                       Mode : HAL.GPIO.GPIO_Config_Mode)
   is
   begin
      This.Device.Configure_Mode (Pin    => This.Pin,
                                  Output => (Mode = HAL.GPIO.Output));
   end Set_Mode;

   -------------------
   -- Pull_Resistor --
   -------------------

   overriding
   function Pull_Resistor (This : MCP23_GPIO_Point)
                           return HAL.GPIO.GPIO_Pull_Resistor
   is
   begin
      return (if This.Device.Pull_Up (This.Pin) then
                 HAL.GPIO.Pull_Up
              else
                 HAL.GPIO.Floating);
   end Pull_Resistor;

   -----------------------
   -- Set_Pull_Resistor --
   -----------------------

   overriding
   procedure Set_Pull_Resistor (This : in out MCP23_GPIO_Point;
                                Pull : HAL.GPIO.GPIO_Pull_Resistor)
   is
   begin
      This.Device.Configure_Pull (This.Pin, Pull = HAL.GPIO.Pull_Up);
   end Set_Pull_Resistor;

   ---------
   -- Set --
   ---------

   overriding
   function Set (This : MCP23_GPIO_Point) return Boolean is
   begin
      return This.Device.Set (This.Pin);
   end Set;

   ---------
   -- Set --
   ---------

   overriding
   procedure Set (This : in out MCP23_GPIO_Point) is
   begin
      This.Device.Set (This.Pin);
   end Set;

   -----------
   -- Clear --
   -----------

   overriding
   procedure Clear (This : in out MCP23_GPIO_Point) is
   begin
      This.Device.Clear (This.Pin);
   end Clear;

   ------------
   -- Toggle --
   ------------

   overriding
   procedure Toggle (This : in out MCP23_GPIO_Point) is
   begin
      This.Device.Toggle (This.Pin);
   end Toggle;

end MCP23x08;

implement function Mode to fix issue #412 (#413)


------------------------------------------------------------------------------
-- Copyright (c) 2014, Natacha Porté                                        --
--                                                                          --
-- Permission to use, copy, modify, and distribute this software for any    --
-- purpose with or without fee is hereby granted, provided that the above   --
-- copyright notice and this permission notice appear in all copies.        --
--                                                                          --
-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES --
-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF         --
-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR  --
-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES   --
-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN    --
-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF  --
-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.           --
------------------------------------------------------------------------------

with Natools.S_Expressions.File_Readers;
with Natools.S_Expressions.Interpreter_Loop;
with Natools.S_Expressions.Atom_Ref_Constructors;
with Natools.Static_Maps.Web.Pages;
with Natools.Web.Error_Pages;
with Natools.Web.Exchanges;

package body Natools.Web.Pages is

   procedure Append
     (Exchange : in out Sites.Exchange;
      Page : in Page_Data;
      Data : in S_Expressions.Atom);

   procedure Execute
     (Data : in out Page_Data;
      Context : in Meaningless_Type;
      Name : in S_Expressions.Atom;
      Arguments : in out S_Expressions.Lockable.Descriptor'Class);

   procedure Render
     (Exchange : in out Sites.Exchange;
      Page : in Page_Data;
      Name : in S_Expressions.Atom;
      Arguments : in out S_Expressions.Lockable.Descriptor'Class);

   procedure Sub_Render
     (Exchange : in out Sites.Exchange;
      Page : in Page_Data;
      Expression : in out S_Expressions.Lockable.Descriptor'Class;
      Lookup_Element : in Boolean := False;
      Lookup_Template : in Boolean := False);

   procedure Sub_Render
     (Exchange : in out Sites.Exchange;
      Page : in Page_Data;
      Name : in S_Expressions.Atom;
      Fallback : in out S_Expressions.Lockable.Descriptor'Class;
      Lookup_Element : in Boolean;
      Lookup_Template : in Boolean)
     with Pre => Lookup_Element or Lookup_Template;

   ---------------------------
   -- Page Data Constructor --
   ---------------------------

   procedure Execute
     (Data : in out Page_Data;
      Context : in Meaningless_Type;
      Name : in S_Expressions.Atom;
      Arguments : in out S_Expressions.Lockable.Descriptor'Class)
   is
      pragma Unreferenced (Context);
      package Components renames Natools.Static_Maps.Web.Pages;
   begin
      case Components.To_Component (S_Expressions.To_String (Name)) is
         when Components.Error =>
            Log (Severities.Error, "Unknown page component """
              & S_Expressions.To_String (Name) & '"');

         when Components.Elements =>
            Containers.Set_Expressions (Data.Elements, Arguments);

         when Components.Tags =>
            Tags.Append (Data.Tags, Arguments);
      end case;
   end Execute;

   procedure Read_Page is new S_Expressions.Interpreter_Loop
     (Page_Data, Meaningless_Type, Execute);

   -------------------
   -- Page Renderer --
   -------------------

   procedure Append
     (Exchange : in out Sites.Exchange;
      Page : in Page_Data;
      Data : in S_Expressions.Atom)
   is
      pragma Unreferenced (Page);
   begin
      Exchange.Append (Data);
   end Append;

   procedure Render
     (Exchange : in out Sites.Exchange;
      Page : in Page_Data;
      Name : in S_Expressions.Atom;
      Arguments : in out S_Expressions.Lockable.Descriptor'Class)
   is
      use type S_Expressions.Events.Event;
      package Commands renames Natools.Static_Maps.Web.Pages;
   begin
      case Commands.To_Command (S_Expressions.To_String (Name)) is
         when Commands.Unknown_Command =>
            null;

         when Commands.Element =>
            Sub_Render (Exchange, Page, Arguments, Lookup_Element => True);

         when Commands.Element_Or_Template =>
            Sub_Render
              (Exchange, Page, Arguments,
               Lookup_Element => True,
               Lookup_Template => True);

         when Commands.My_Tags =>
            if Arguments.Current_Event = S_Expressions.Events.Add_Atom then
               declare
                  Prefix : constant S_Expressions.Atom
                    := Arguments.Current_Atom;
               begin
                  Arguments.Next;
                  Tags.Render
                    (Exchange,
                     Page.Tags,
                     Exchange.Site.Get_Tags,
                     Prefix,
                     Arguments);
               end;
            end if;

         when Commands.Tags =>
            Tags.Render
              (Exchange,
               Exchange.Site.Get_Tags,
               Arguments,
               Page.Tags);

         when Commands.Template =>
            Sub_Render (Exchange, Page, Arguments, Lookup_Template => True);
      end case;
   end Render;

   procedure Render_Page is new S_Expressions.Interpreter_Loop
     (Sites.Exchange, Page_Data, Render, Append);

   procedure Sub_Render
     (Exchange : in out Sites.Exchange;
      Page : in Page_Data;
      Expression : in out S_Expressions.Lockable.Descriptor'Class;
      Lookup_Element : in Boolean := False;
      Lookup_Template : in Boolean := False)
   is
      use type S_Expressions.Events.Event;
   begin
      if (Lookup_Element or Lookup_Template)
        and then Expression.Current_Event = S_Expressions.Events.Add_Atom
      then
         declare
            Name : constant S_Expressions.Atom := Expression.Current_Atom;
         begin
            Expression.Next;
            Sub_Render
              (Exchange, Page,
               Name, Expression,
               Lookup_Element, Lookup_Template);
         end;
      else
         Render_Page (Expression, Exchange, Page);
      end if;
   end Sub_Render;

   procedure Sub_Render
     (Exchange : in out Sites.Exchange;
      Page : in Page_Data;
      Name : in S_Expressions.Atom;
      Fallback : in out S_Expressions.Lockable.Descriptor'Class;
      Lookup_Element : in Boolean;
      Lookup_Template : in Boolean)
   is
      Template : S_Expressions.Caches.Cursor;
      Found : Boolean;
   begin
      if Lookup_Element then
         Page.Get_Element (Name, Template, Found);

         if Found then
            Render_Page (Template, Exchange, Page);
            return;
         end if;
      end if;

      if Lookup_Template then
         Exchange.Site.Get_Template (Name, Template, Found);

         if Found then
            Render_Page (Template, Exchange, Page);
            return;
         end if;
      end if;

      case Fallback.Current_Event is
         when S_Expressions.Events.Close_List
           | S_Expressions.Events.End_Of_Input
           | S_Expressions.Events.Error
         =>
            Log (Severities.Error,
              "Page expression """
              & S_Expressions.To_String (Name)
              & """ not found");
            return;

         when S_Expressions.Events.Open_List
           | S_Expressions.Events.Add_Atom
         =>
            Render_Page (Fallback, Exchange, Page);
      end case;
   end Sub_Render;

   -------------------------
   -- Page_Data Interface --
   -------------------------

   procedure Get_Element
     (Data : in Page_Data;
      Name : in S_Expressions.Atom;
      Element : out S_Expressions.Caches.Cursor;
      Found : out Boolean)
   is
      Cursor : constant Containers.Expression_Maps.Cursor
        := Data.Elements.Find (Name);
   begin
      Found := Containers.Expression_Maps.Has_Element (Cursor);

      if Found then
         Element := Containers.Expression_Maps.Element (Cursor);
      end if;
   end Get_Element;

   ----------------------
   -- Public Interface --
   ----------------------

   function Create
     (File_Path, Web_Path : in S_Expressions.Atom)
     return Page_Ref
   is
      function Create_Page return Page_Data;

      function Create_Page return Page_Data is
         Reader : Natools.S_Expressions.File_Readers.S_Reader
           := Natools.S_Expressions.File_Readers.Reader
              (S_Expressions.To_String (File_Path));
      begin
         return Result : Page_Data
           := (File_Path =>
                  S_Expressions.Atom_Ref_Constructors.Create (File_Path),
               Web_Path =>
                  S_Expressions.Atom_Ref_Constructors.Create (Web_Path),
               Tags => <>,
               Elements => <>)
         do
            Read_Page (Reader, Result, Meaningless_Value);
         end return;
      end Create_Page;
   begin
      return (Ref => Data_Refs.Create (Create_Page'Access));
   end Create;

   overriding procedure Render
     (Exchange : in out Sites.Exchange;
      Object : in Page_Ref;
      Expression : in out S_Expressions.Lockable.Descriptor'Class) is
   begin
      Render_Page
        (Expression,
         Exchange,
         Object.Ref.Query.Data.all);
   end Render;

   overriding procedure Respond
     (Object : in out Page_Ref;
      Exchange : in out Sites.Exchange;
      Extra_Path : in S_Expressions.Atom) is
   begin
      if Extra_Path'Length > 0 then
         return;
      end if;

      declare
         Accessor : constant Data_Refs.Accessor := Object.Ref.Query;
         Null_Expression : S_Expressions.Caches.Cursor;
      begin
         Check_Method :
         declare
            use Exchanges;
            Allowed : Boolean;
         begin
            Error_Pages.Check_Method
              (Exchange,
               Exchange.Site,
               (GET, HEAD),
               Allowed);

            if not Allowed then
               return;
            end if;
         end Check_Method;

         Sub_Render
           (Exchange,
            Accessor.Data.all,
            Exchange.Site.Default_Template,
            Null_Expression,
            Lookup_Element => True,
            Lookup_Template => True);
      end;
   end Respond;

end Natools.Web.Pages;

------------------------------------------------------------------------------
-- Copyright (c) 2014, Natacha Porté                                        --
--                                                                          --
-- Permission to use, copy, modify, and distribute this software for any    --
-- purpose with or without fee is hereby granted, provided that the above   --
-- copyright notice and this permission notice appear in all copies.        --
--                                                                          --
-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES --
-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF         --
-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR  --
-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES   --
-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN    --
-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF  --
-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.           --
------------------------------------------------------------------------------

with Natools.S_Expressions.File_Readers;
with Natools.S_Expressions.Interpreter_Loop;
with Natools.S_Expressions.Atom_Ref_Constructors;
with Natools.Static_Maps.Web.Pages;
with Natools.Web.Error_Pages;
with Natools.Web.Exchanges;

package body Natools.Web.Pages is

   procedure Append
     (Exchange : in out Sites.Exchange;
      Page : in Page_Data;
      Data : in S_Expressions.Atom);

   procedure Execute
     (Data : in out Page_Data;
      Context : in Meaningless_Type;
      Name : in S_Expressions.Atom;
      Arguments : in out S_Expressions.Lockable.Descriptor'Class);

   procedure Render
     (Exchange : in out Sites.Exchange;
      Page : in Page_Data;
      Name : in S_Expressions.Atom;
      Arguments : in out S_Expressions.Lockable.Descriptor'Class);

   procedure Read_Page is new S_Expressions.Interpreter_Loop
     (Page_Data, Meaningless_Type, Execute);

   procedure Render_Page is new S_Expressions.Interpreter_Loop
     (Sites.Exchange, Page_Data, Render, Append);

   ---------------------------
   -- Page Data Constructor --
   ---------------------------

   procedure Execute
     (Data : in out Page_Data;
      Context : in Meaningless_Type;
      Name : in S_Expressions.Atom;
      Arguments : in out S_Expressions.Lockable.Descriptor'Class)
   is
      pragma Unreferenced (Context);
      package Components renames Natools.Static_Maps.Web.Pages;
   begin
      case Components.To_Component (S_Expressions.To_String (Name)) is
         when Components.Error =>
            Log (Severities.Error, "Unknown page component """
              & S_Expressions.To_String (Name) & '"');

         when Components.Elements =>
            Containers.Set_Expressions (Data.Elements, Arguments);

         when Components.Tags =>
            Tags.Append (Data.Tags, Arguments);
      end case;
   end Execute;

   -------------------
   -- Page Renderer --
   -------------------

   procedure Append
     (Exchange : in out Sites.Exchange;
      Page : in Page_Data;
      Data : in S_Expressions.Atom)
   is
      pragma Unreferenced (Page);
   begin
      Exchange.Append (Data);
   end Append;

   procedure Render
     (Exchange : in out Sites.Exchange;
      Page : in Page_Data;
      Name : in S_Expressions.Atom;
      Arguments : in out S_Expressions.Lockable.Descriptor'Class)
   is
      use type S_Expressions.Events.Event;
      package Commands renames Natools.Static_Maps.Web.Pages;
   begin
      case Commands.To_Command (S_Expressions.To_String (Name)) is
         when Commands.Unknown_Command =>
            null;

         when Commands.Element =>
            declare
               Template : S_Expressions.Caches.Cursor
                 := Exchange.Site.Get_Template
                    (Page.Elements,
                     Arguments,
                     Lookup_Template => False);
            begin
               Render_Page (Template, Exchange, Page);
            end;

         when Commands.Element_Or_Template =>
            declare
               Template : S_Expressions.Caches.Cursor
                 := Exchange.Site.Get_Template (Page.Elements, Arguments);
            begin
               Render_Page (Template, Exchange, Page);
            end;

         when Commands.My_Tags =>
            if Arguments.Current_Event = S_Expressions.Events.Add_Atom then
               declare
                  Prefix : constant S_Expressions.Atom
                    := Arguments.Current_Atom;
               begin
                  Arguments.Next;
                  Tags.Render
                    (Exchange,
                     Page.Tags,
                     Exchange.Site.Get_Tags,
                     Prefix,
                     Arguments);
               end;
            end if;

         when Commands.Tags =>
            Tags.Render
              (Exchange,
               Exchange.Site.Get_Tags,
               Arguments,
               Page.Tags);

         when Commands.Template =>
            declare
               Template : S_Expressions.Caches.Cursor
                 := Exchange.Site.Get_Template
                    (Page.Elements,
                     Arguments,
                     Lookup_Element => False);
            begin
               Render_Page (Template, Exchange, Page);
            end;
      end case;
   end Render;

   -------------------------
   -- Page_Data Interface --
   -------------------------

   procedure Get_Element
     (Data : in Page_Data;
      Name : in S_Expressions.Atom;
      Element : out S_Expressions.Caches.Cursor;
      Found : out Boolean)
   is
      Cursor : constant Containers.Expression_Maps.Cursor
        := Data.Elements.Find (Name);
   begin
      Found := Containers.Expression_Maps.Has_Element (Cursor);

      if Found then
         Element := Containers.Expression_Maps.Element (Cursor);
      end if;
   end Get_Element;

   ----------------------
   -- Public Interface --
   ----------------------

   function Create
     (File_Path, Web_Path : in S_Expressions.Atom)
     return Page_Ref
   is
      function Create_Page return Page_Data;

      function Create_Page return Page_Data is
         Reader : Natools.S_Expressions.File_Readers.S_Reader
           := Natools.S_Expressions.File_Readers.Reader
              (S_Expressions.To_String (File_Path));
      begin
         return Result : Page_Data
           := (File_Path =>
                  S_Expressions.Atom_Ref_Constructors.Create (File_Path),
               Web_Path =>
                  S_Expressions.Atom_Ref_Constructors.Create (Web_Path),
               Tags => <>,
               Elements => <>)
         do
            Read_Page (Reader, Result, Meaningless_Value);
         end return;
      end Create_Page;
   begin
      return (Ref => Data_Refs.Create (Create_Page'Access));
   end Create;

   overriding procedure Render
     (Exchange : in out Sites.Exchange;
      Object : in Page_Ref;
      Expression : in out S_Expressions.Lockable.Descriptor'Class) is
   begin
      Render_Page
        (Expression,
         Exchange,
         Object.Ref.Query.Data.all);
   end Render;

   overriding procedure Respond
     (Object : in out Page_Ref;
      Exchange : in out Sites.Exchange;
      Extra_Path : in S_Expressions.Atom) is
   begin
      if Extra_Path'Length > 0 then
         return;
      end if;

      declare
         Accessor : constant Data_Refs.Accessor := Object.Ref.Query;
         Expression : S_Expressions.Caches.Cursor;
      begin
         Check_Method :
         declare
            use Exchanges;
            Allowed : Boolean;
         begin
            Error_Pages.Check_Method
              (Exchange,
               Exchange.Site,
               (GET, HEAD),
               Allowed);

            if not Allowed then
               return;
            end if;
         end Check_Method;

         Expression := Exchange.Site.Get_Template
           (Accessor.Data.Elements,
            Expression,
            Exchange.Site.Default_Template,
            Lookup_Element => True,
            Lookup_Template => True,
            Lookup_Name => True);

         Render_Page (Expression, Exchange, Accessor.Data.all);
      end;
   end Respond;

end Natools.Web.Pages;

pages: replace Sub_Render by calls using the new Sites.Get_Template high-level accessor