-----------------------------------------------------------------------
--  awa-questions-beans -- Beans for module questions
--  Copyright (C) 2012, 2013 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 ADO.Queries;
with ADO.Utils;
with ADO.Sessions;
with ADO.Sessions.Entities;

with AWA.Tags.Modules;
with AWA.Services.Contexts;
package body AWA.Questions.Beans is

   package ASC renames AWA.Services.Contexts;

   --  ------------------------------
   --  Get the value identified by the name.
   --  ------------------------------
   overriding
   function Get_Value (From : in Question_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "tags" then
         return Util.Beans.Objects.To_Object (From.Tags_Bean, Util.Beans.Objects.STATIC);
      elsif From.Is_Null then
         return Util.Beans.Objects.Null_Object;
      else
         return AWA.Questions.Models.Question_Bean (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Question_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "title" then
         From.Set_Title (Util.Beans.Objects.To_String (Value));

      elsif Name = "description" then
         From.Set_Description (Util.Beans.Objects.To_String (Value));

      elsif Name = "id" and not Util.Beans.Objects.Is_Empty (Value) then
         declare
            Ctx : constant ASC.Service_Context_Access := AWA.Services.Contexts.Current;
            DB  : constant ADO.Sessions.Session := AWA.Services.Contexts.Get_Session (Ctx);
            Id  : constant ADO.Identifier := ADO.Utils.To_Identifier (Value);
         begin
            From.Service.Load_Question (From, Id);
            From.Tags.Load_Tags (DB, Id);
         end;
      end if;
   end Set_Value;

   --  ------------------------------
   --  Create or save the question.
   --  ------------------------------
   procedure Save (Bean    : in out Question_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      pragma Unreferenced (Outcome);
   begin
      Bean.Service.Save_Question (Bean);
      Bean.Tags.Update_Tags (Bean.Get_Id);
   end Save;

   --  ------------------------------
   --  Delete the question.
   --  ------------------------------
   procedure Delete (Bean    : in out Question_Bean;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      pragma Unreferenced (Outcome);
   begin
      Bean.Service.Delete_Question (Bean);
   end Delete;

   --  ------------------------------
   --  Create the Question_Bean bean instance.
   --  ------------------------------
   function Create_Question_Bean (Module : in AWA.Questions.Modules.Question_Module_Access)
      return Util.Beans.Basic.Readonly_Bean_Access is
      Object : constant Question_Bean_Access := new Question_Bean;
   begin
      Object.Service   := Module;
      Object.Tags_Bean := Object.Tags'Access;
      Object.Tags.Set_Entity_Type (AWA.Questions.Models.QUESTION_TABLE);
      Object.Tags.Set_Permission ("question-edit");
      return Object.all'Access;
   end Create_Question_Bean;

   --  Get the value identified by the name.
   overriding
   function Get_Value (From : in Answer_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "question_id" then
         return Util.Beans.Objects.To_Object (Long_Long_Integer (From.Question.Get_Id));
      elsif From.Is_Null then
         return Util.Beans.Objects.Null_Object;
      else
         return AWA.Questions.Models.Answer_Bean (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Answer_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "id" and not Util.Beans.Objects.Is_Empty (Value) then
         From.Service.Load_Answer (From, From.Question,
                                   ADO.Utils.To_Identifier (Value));

      elsif Name = "answer" then
         From.Set_Answer (Util.Beans.Objects.To_String (Value));

      elsif Name = "question_id" and not Util.Beans.Objects.Is_Null (Value) then
         From.Service.Load_Question (From.Question,
                                     ADO.Utils.To_Identifier (Value));
      end if;
   end Set_Value;

   --  ------------------------------
   --  Create or save the answer.
   --  ------------------------------
   procedure Save (Bean    : in out Answer_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      pragma Unreferenced (Outcome);
   begin
      Bean.Service.Save_Answer (Question => Bean.Question,
                                Answer   => Bean);
   end Save;

   --  ------------------------------
   --  Delete the question.
   --  ------------------------------
   procedure Delete (Bean    : in out Answer_Bean;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      pragma Unreferenced (Outcome);
   begin
      Bean.Service.Delete_Answer (Answer => Bean);
   end Delete;

   --  ------------------------------
   --  Create the answer bean instance.
   --  ------------------------------
   function Create_Answer_Bean (Module : in AWA.Questions.Modules.Question_Module_Access)
                                return Util.Beans.Basic.Readonly_Bean_Access is
      Object : constant Answer_Bean_Access := new Answer_Bean;
   begin
      Object.Service := Module;
      return Object.all'Access;
   end Create_Answer_Bean;

   --  ------------------------------
   --  Get the value identified by the name.
   --  ------------------------------
   overriding
   function Get_Value (From : in Question_List_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      return AWA.Questions.Models.Question_Info_List_Bean (From).Get_Value (Name);
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Question_List_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "tag" then
         From.Tag := Util.Beans.Objects.To_Unbounded_String (Value);
         From.Load_List;
      end if;
   end Set_Value;

   --  ------------------------------
   --  Load the list of question.  If a tag was set, filter the list of questions with the tag.
   --  ------------------------------
   procedure Load_List (Into : in out Question_List_Bean) is
      use AWA.Questions.Models;
      use AWA.Services;
      use type ADO.Identifier;

      Session : ADO.Sessions.Session := Into.Service.Get_Session;
      Query   : ADO.Queries.Context;
      Tag_Id  : ADO.Identifier;
   begin
      AWA.Tags.Modules.Find_Tag_Id (Session, Ada.Strings.Unbounded.To_String (Into.Tag), Tag_Id);
      if Tag_Id /= ADO.NO_IDENTIFIER then
         Query.Set_Query (AWA.Questions.Models.Query_Question_Tag_List);
         Query.Bind_Param (Name => "tag", Value => Tag_Id);
      else
         Query.Set_Query (AWA.Questions.Models.Query_Question_List);
      end if;
      ADO.Sessions.Entities.Bind_Param (Params  => Query,
                                        Name    => "entity_type",
                                        Table   => AWA.Questions.Models.QUESTION_TABLE,
                                        Session => Session);
      AWA.Questions.Models.List (Into, Session, Query);
   end Load_List;

   --  ------------------------------
   --  Create the Question_Info_List_Bean bean instance.
   --  ------------------------------
   function Create_Question_List_Bean (Module : in AWA.Questions.Modules.Question_Module_Access)
                                       return Util.Beans.Basic.Readonly_Bean_Access is
      use AWA.Questions.Models;
      use AWA.Services;

      Object  : constant Question_List_Bean_Access := new Question_List_Bean;
      Session : ADO.Sessions.Session := Module.Get_Session;
      Query   : ADO.Queries.Context;
   begin
      Object.Service := Module;
      Query.Set_Query (AWA.Questions.Models.Query_Question_List);
      ADO.Sessions.Entities.Bind_Param (Params  => Query,
                                        Name    => "entity_type",
                                        Table   => AWA.Questions.Models.QUESTION_TABLE,
                                        Session => Session);
      AWA.Questions.Models.List (Object.all, Session, Query);
      return Object.all'Access;
   end Create_Question_List_Bean;

   --  ------------------------------
   --  Get the value identified by the name.
   --  ------------------------------
   overriding
   function Get_Value (From : in Question_Display_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "answers" then
         return Util.Beans.Objects.To_Object (Value   => From.Answer_List_Bean,
                                              Storage => Util.Beans.Objects.STATIC);

      elsif Name = "question" then
         return Util.Beans.Objects.To_Object (Value   => From.Question_Bean,
                                              Storage => Util.Beans.Objects.STATIC);

      elsif Name = "tags" then
         return Util.Beans.Objects.To_Object (Value   => From.Tags_Bean,
                                              Storage => Util.Beans.Objects.STATIC);

      else
         return Util.Beans.Objects.Null_Object;
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Question_Display_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "id" and not Util.Beans.Objects.Is_Empty (Value) then
         declare
            package ASC renames AWA.Services.Contexts;
            use AWA.Questions.Models;
            use AWA.Services;

            Session : ADO.Sessions.Session := From.Service.Get_Session;
            Query   : ADO.Queries.Context;
            List    : AWA.Questions.Models.Question_Display_Info_List_Bean;
            Ctx     : constant ASC.Service_Context_Access := ASC.Current;
            Id      : constant ADO.Identifier := ADO.Utils.To_Identifier (Value);
         begin
            Query.Set_Query (AWA.Questions.Models.Query_Question_Info);
            Query.Bind_Param ("question_id", Id);
            Query.Bind_Param ("user_id", Ctx.Get_User_Identifier);
            ADO.Sessions.Entities.Bind_Param (Params  => Query,
                                              Name    => "entity_type",
                                              Table   => AWA.Questions.Models.QUESTION_TABLE,
                                              Session => Session);
            AWA.Questions.Models.List (List, Session, Query);
            if not List.List.Is_Empty then
               From.Question := List.List.Element (0);
            end if;
            Query.Clear;
            Query.Bind_Param ("question_id", Util.Beans.Objects.To_Integer (Value));
            Query.Bind_Param ("user_id", Ctx.Get_User_Identifier);
            ADO.Sessions.Entities.Bind_Param (Params  => Query,
                                              Name    => "entity_type",
                                              Table   => AWA.Questions.Models.ANSWER_TABLE,
                                              Session => Session);

            Query.Set_Query (AWA.Questions.Models.Query_Answer_List);
            AWA.Questions.Models.List (From.Answer_List, Session, Query);

            --  Load the tags if any.
            From.Tags.Load_Tags (Session, Id);
         end;
      end if;
   end Set_Value;

   --  ------------------------------
   --  Create the Question_Display_Bean bean instance.
   --  ------------------------------
   function Create_Question_Display_Bean (Module : in AWA.Questions.Modules.Question_Module_Access)
                                       return Util.Beans.Basic.Readonly_Bean_Access is
      Object  : constant Question_Display_Bean_Access := new Question_Display_Bean;
   begin
      Object.Service          := Module;
      Object.Question_Bean    := Object.Question'Access;
      Object.Answer_List_Bean := Object.Answer_List'Access;
      Object.Tags_Bean        := Object.Tags'Access;
      Object.Tags.Set_Entity_Type (AWA.Questions.Models.QUESTION_TABLE);
      return Object.all'Access;
   end Create_Question_Display_Bean;

end AWA.Questions.Beans;

-----------------------------------------------------------------------
--  awa-questions-beans -- Beans for module questions
--  Copyright (C) 2012, 2013 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 ADO.Queries;
with ADO.Utils;
with ADO.Sessions;
with ADO.Sessions.Entities;

with Util.Beans.Lists.Strings;

with AWA.Tags.Modules;
with AWA.Services.Contexts;
package body AWA.Questions.Beans is

   package ASC renames AWA.Services.Contexts;

   --  ------------------------------
   --  Get the value identified by the name.
   --  ------------------------------
   overriding
   function Get_Value (From : in Question_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "tags" then
         return Util.Beans.Objects.To_Object (From.Tags_Bean, Util.Beans.Objects.STATIC);
      elsif From.Is_Null then
         return Util.Beans.Objects.Null_Object;
      else
         return AWA.Questions.Models.Question_Bean (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Question_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "title" then
         From.Set_Title (Util.Beans.Objects.To_String (Value));

      elsif Name = "description" then
         From.Set_Description (Util.Beans.Objects.To_String (Value));

      elsif Name = "id" and not Util.Beans.Objects.Is_Empty (Value) then
         declare
            Ctx : constant ASC.Service_Context_Access := AWA.Services.Contexts.Current;
            DB  : constant ADO.Sessions.Session := AWA.Services.Contexts.Get_Session (Ctx);
            Id  : constant ADO.Identifier := ADO.Utils.To_Identifier (Value);
         begin
            From.Service.Load_Question (From, Id);
            From.Tags.Load_Tags (DB, Id);
         end;
      end if;
   end Set_Value;

   --  ------------------------------
   --  Create or save the question.
   --  ------------------------------
   procedure Save (Bean    : in out Question_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      pragma Unreferenced (Outcome);
   begin
      Bean.Service.Save_Question (Bean);
      Bean.Tags.Update_Tags (Bean.Get_Id);
   end Save;

   --  ------------------------------
   --  Delete the question.
   --  ------------------------------
   procedure Delete (Bean    : in out Question_Bean;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      pragma Unreferenced (Outcome);
   begin
      Bean.Service.Delete_Question (Bean);
   end Delete;

   --  ------------------------------
   --  Create the Question_Bean bean instance.
   --  ------------------------------
   function Create_Question_Bean (Module : in AWA.Questions.Modules.Question_Module_Access)
      return Util.Beans.Basic.Readonly_Bean_Access is
      Object : constant Question_Bean_Access := new Question_Bean;
   begin
      Object.Service   := Module;
      Object.Tags_Bean := Object.Tags'Access;
      Object.Tags.Set_Entity_Type (AWA.Questions.Models.QUESTION_TABLE);
      Object.Tags.Set_Permission ("question-edit");
      return Object.all'Access;
   end Create_Question_Bean;

   --  Get the value identified by the name.
   overriding
   function Get_Value (From : in Answer_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "question_id" then
         return Util.Beans.Objects.To_Object (Long_Long_Integer (From.Question.Get_Id));
      elsif From.Is_Null then
         return Util.Beans.Objects.Null_Object;
      else
         return AWA.Questions.Models.Answer_Bean (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Answer_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "id" and not Util.Beans.Objects.Is_Empty (Value) then
         From.Service.Load_Answer (From, From.Question,
                                   ADO.Utils.To_Identifier (Value));

      elsif Name = "answer" then
         From.Set_Answer (Util.Beans.Objects.To_String (Value));

      elsif Name = "question_id" and not Util.Beans.Objects.Is_Null (Value) then
         From.Service.Load_Question (From.Question,
                                     ADO.Utils.To_Identifier (Value));
      end if;
   end Set_Value;

   --  ------------------------------
   --  Create or save the answer.
   --  ------------------------------
   procedure Save (Bean    : in out Answer_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      pragma Unreferenced (Outcome);
   begin
      Bean.Service.Save_Answer (Question => Bean.Question,
                                Answer   => Bean);
   end Save;

   --  ------------------------------
   --  Delete the question.
   --  ------------------------------
   procedure Delete (Bean    : in out Answer_Bean;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      pragma Unreferenced (Outcome);
   begin
      Bean.Service.Delete_Answer (Answer => Bean);
   end Delete;

   --  ------------------------------
   --  Create the answer bean instance.
   --  ------------------------------
   function Create_Answer_Bean (Module : in AWA.Questions.Modules.Question_Module_Access)
                                return Util.Beans.Basic.Readonly_Bean_Access is
      Object : constant Answer_Bean_Access := new Answer_Bean;
   begin
      Object.Service := Module;
      return Object.all'Access;
   end Create_Answer_Bean;

   --  ------------------------------
   --  Get the value identified by the name.
   --  ------------------------------
   overriding
   function Get_Value (From : in Question_List_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
      Pos : Natural;
   begin
      if Name = "tags" then
         Pos := From.Questions.Get_Row_Index;
         if Pos = 0 then
            return Util.Beans.Objects.Null_Object;
         end if;
         declare
            Item : constant Models.Question_Info := From.Questions.List.Element (Pos);
         begin
            return From.Tags.Get_Tags (Item.Id);
         end;
      elsif Name = "questions" then
         return Util.Beans.Objects.To_Object (Value   => From.Questions_Bean,
                                              Storage => Util.Beans.Objects.STATIC);
      else
         return From.Questions.Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Question_List_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "tag" then
         From.Tag := Util.Beans.Objects.To_Unbounded_String (Value);
         From.Load_List;
      end if;
   end Set_Value;

   --  ------------------------------
   --  Load the list of question.  If a tag was set, filter the list of questions with the tag.
   --  ------------------------------
   procedure Load_List (Into : in out Question_List_Bean) is
      use AWA.Questions.Models;
      use AWA.Services;
      use type ADO.Identifier;

      Session : ADO.Sessions.Session := Into.Service.Get_Session;
      Query   : ADO.Queries.Context;
      Tag_Id  : ADO.Identifier;
   begin
      AWA.Tags.Modules.Find_Tag_Id (Session, Ada.Strings.Unbounded.To_String (Into.Tag), Tag_Id);
      if Tag_Id /= ADO.NO_IDENTIFIER then
         Query.Set_Query (AWA.Questions.Models.Query_Question_Tag_List);
         Query.Bind_Param (Name => "tag", Value => Tag_Id);
      else
         Query.Set_Query (AWA.Questions.Models.Query_Question_List);
      end if;
      ADO.Sessions.Entities.Bind_Param (Params  => Query,
                                        Name    => "entity_type",
                                        Table   => AWA.Questions.Models.QUESTION_TABLE,
                                        Session => Session);
      AWA.Questions.Models.List (Into.Questions, Session, Query);
      declare
         List : ADO.Utils.Identifier_Vector;
         Iter : Question_Info_Vectors.Cursor := Into.Questions.List.First;
      begin
         while Question_Info_Vectors.Has_Element (Iter) loop
            List.Append (Question_Info_Vectors.Element (Iter).Id);
            Question_Info_Vectors.Next (Iter);
         end loop;
         Into.Tags.Load_Tags (Session, AWA.Questions.Models.QUESTION_TABLE.Table.all,
                              List);
      end;
   end Load_List;

   --  ------------------------------
   --  Create the Question_Info_List_Bean bean instance.
   --  ------------------------------
   function Create_Question_List_Bean (Module : in AWA.Questions.Modules.Question_Module_Access)
                                       return Util.Beans.Basic.Readonly_Bean_Access is
      use AWA.Questions.Models;
      use AWA.Services;

      Object  : constant Question_List_Bean_Access := new Question_List_Bean;
--        Session : ADO.Sessions.Session := Module.Get_Session;
--        Query   : ADO.Queries.Context;
   begin
      Object.Service := Module;
      Object.Questions_Bean := Object.Questions'Unchecked_Access;
--        Query.Set_Query (AWA.Questions.Models.Query_Question_List);
--        ADO.Sessions.Entities.Bind_Param (Params  => Query,
--                                          Name    => "entity_type",
--                                          Table   => AWA.Questions.Models.QUESTION_TABLE,
--                                          Session => Session);
--        AWA.Questions.Models.List (Object.Questions, Session, Query);
      Object.Load_List;
      return Object.all'Access;
   end Create_Question_List_Bean;

   --  ------------------------------
   --  Get the value identified by the name.
   --  ------------------------------
   overriding
   function Get_Value (From : in Question_Display_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "answers" then
         return Util.Beans.Objects.To_Object (Value   => From.Answer_List_Bean,
                                              Storage => Util.Beans.Objects.STATIC);

      elsif Name = "question" then
         return Util.Beans.Objects.To_Object (Value   => From.Question_Bean,
                                              Storage => Util.Beans.Objects.STATIC);

      elsif Name = "tags" then
         return Util.Beans.Objects.To_Object (Value   => From.Tags_Bean,
                                              Storage => Util.Beans.Objects.STATIC);

      else
         return Util.Beans.Objects.Null_Object;
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Question_Display_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "id" and not Util.Beans.Objects.Is_Empty (Value) then
         declare
            package ASC renames AWA.Services.Contexts;
            use AWA.Questions.Models;
            use AWA.Services;

            Session : ADO.Sessions.Session := From.Service.Get_Session;
            Query   : ADO.Queries.Context;
            List    : AWA.Questions.Models.Question_Display_Info_List_Bean;
            Ctx     : constant ASC.Service_Context_Access := ASC.Current;
            Id      : constant ADO.Identifier := ADO.Utils.To_Identifier (Value);
         begin
            Query.Set_Query (AWA.Questions.Models.Query_Question_Info);
            Query.Bind_Param ("question_id", Id);
            Query.Bind_Param ("user_id", Ctx.Get_User_Identifier);
            ADO.Sessions.Entities.Bind_Param (Params  => Query,
                                              Name    => "entity_type",
                                              Table   => AWA.Questions.Models.QUESTION_TABLE,
                                              Session => Session);
            AWA.Questions.Models.List (List, Session, Query);
            if not List.List.Is_Empty then
               From.Question := List.List.Element (0);
            end if;
            Query.Clear;
            Query.Bind_Param ("question_id", Util.Beans.Objects.To_Integer (Value));
            Query.Bind_Param ("user_id", Ctx.Get_User_Identifier);
            ADO.Sessions.Entities.Bind_Param (Params  => Query,
                                              Name    => "entity_type",
                                              Table   => AWA.Questions.Models.ANSWER_TABLE,
                                              Session => Session);

            Query.Set_Query (AWA.Questions.Models.Query_Answer_List);
            AWA.Questions.Models.List (From.Answer_List, Session, Query);

            --  Load the tags if any.
            From.Tags.Load_Tags (Session, Id);
         end;
      end if;
   end Set_Value;

   --  ------------------------------
   --  Create the Question_Display_Bean bean instance.
   --  ------------------------------
   function Create_Question_Display_Bean (Module : in AWA.Questions.Modules.Question_Module_Access)
                                       return Util.Beans.Basic.Readonly_Bean_Access is
      Object  : constant Question_Display_Bean_Access := new Question_Display_Bean;
   begin
      Object.Service          := Module;
      Object.Question_Bean    := Object.Question'Access;
      Object.Answer_List_Bean := Object.Answer_List'Access;
      Object.Tags_Bean        := Object.Tags'Access;
      Object.Tags.Set_Entity_Type (AWA.Questions.Models.QUESTION_TABLE);
      return Object.all'Access;
   end Create_Question_Display_Bean;

end AWA.Questions.Beans;

Load the tags associated with the list of question being displayed Return the tags associated with the current question when iterating over the list of questions


------------------------------------------------------------------------------
--                                                                          --
--                    Copyright (C) 2015-2016, 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.   --
--                                                                          --
------------------------------------------------------------------------------

--  This package defines an abstract data type for a "serial port" providing
--  non-blocking input (Get) and output (Put) procedures. The procedures are
--  considered non-blocking because they return to the caller (potentially)
--  before the entire message is received or sent.
--
--  The serial port abstraction is a wrapper around a USART peripheral,
--  described by a value of type Peripheral_Descriptor.
--
--  Interrupts are used to send and receive characters.
--
--  NB: clients must not send or receive messages until any prior sending or
--  receiving is completed. See the two functions Sending and Receiving and
--  the preconditions on Put and Get.

with Message_Buffers; use Message_Buffers;
with Ada.Interrupts;  use Ada.Interrupts;

package Serial_IO.Nonblocking is
   pragma Elaborate_Body;

   type Serial_Port
     (IRQ    : Interrupt_ID;
      Device : not null access Peripheral_Descriptor)
   is tagged limited private;

   procedure Initialize (This : in out Serial_Port) with
     Post => Initialized (This);

   function Initialized (This : Serial_Port) return Boolean with Inline;

   Serial_Port_Uninitialized : exception;

   procedure Configure
     (This      : in out Serial_Port;
      Baud_Rate : Baud_Rates;
      Parity    : Parities     := No_Parity;
      Data_Bits : Word_Lengths := Word_Length_8;
      End_Bits  : Stop_Bits    := Stopbits_1;
      Control   : Flow_Control := No_Flow_Control)
     with
       Pre => (Initialized (This) or else raise Serial_Port_Uninitialized);

   procedure Put (This : in out Serial_Port; Msg : not null access Message) with
     Pre => (Initialized (This) or else raise Serial_Port_Uninitialized)
            and then
            not Sending (This),
     Inline;

   procedure Get (This : in out Serial_Port;  Msg : not null access Message) with
     Pre => (Initialized (This) or else raise Serial_Port_Uninitialized)
            and then
            not Receiving (This),
     Inline;

   function Sending (This : in out Serial_Port) return Boolean;
   --  Returns whether This is currently sending a message.

   function Receiving (This : in out Serial_Port) return Boolean;
   --  Returns whether This is currently receiving a message.

private

   --  The protected type defining the interrupt handling for sending and
   --  receiving characters via the USART attached to the serial port. Each
   --  serial port type a component of this protected type.
   protected type Controller (IRQ : Interrupt_ID;  Port : access Serial_Port) is

      pragma Interrupt_Priority;

      procedure Start_Sending (Msg : not null access Message) with
        Pre => not Sending;

      procedure Start_Receiving (Msg : not null access Message) with
        Pre => not Receiving;

      function Sending   return Boolean;
      function Receiving return Boolean;

   private

      Next_Out          : Positive;
      Awaiting_Transfer : Natural;
      Outgoing_Msg      : access Message;
      Incoming_Msg      : access Message;

      procedure Handle_Transmission with Inline;
      procedure Handle_Reception with Inline;
      procedure Detect_Errors (Is_Xmit_IRQ : Boolean) with Inline;

      procedure IRQ_Handler with Attach_Handler => IRQ;

   end Controller;

   type Serial_Port
     (IRQ    : Interrupt_ID;
      Device : not null access Peripheral_Descriptor)
   is tagged limited record
      Initialized : Boolean := False;
      Control     : Controller (IRQ, Serial_Port'Access);
   end record;

end Serial_IO.Nonblocking;

------------------------------------------------------------------------------
--                                                                          --
--                    Copyright (C) 2015-2016, 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.   --
--                                                                          --
------------------------------------------------------------------------------

--  This package defines an abstract data type for a "serial port" providing
--  non-blocking input (Get) and output (Put) procedures. The procedures are
--  considered non-blocking because they return to the caller (potentially)
--  before the entire message is received or sent.
--
--  The serial port abstraction is a wrapper around a USART peripheral,
--  described by a value of type Peripheral_Descriptor.
--
--  Interrupts are used to send and receive characters.
--
--  NB: clients must not send or receive messages until any prior sending or
--  receiving is completed. See the two functions Sending and Receiving and
--  the preconditions on Put and Get.

with Message_Buffers; use Message_Buffers;
with Ada.Interrupts;  use Ada.Interrupts;

package Serial_IO.Nonblocking is
   pragma Elaborate_Body;

   type Serial_Port
     (IRQ    : Interrupt_ID;
      Device : not null access Peripheral_Descriptor)
   is tagged limited private;

   procedure Initialize (This : in out Serial_Port) with
     Post => Initialized (This);

   function Initialized (This : Serial_Port) return Boolean with Inline;

   Serial_Port_Uninitialized : exception;

   procedure Configure
     (This      : in out Serial_Port;
      Baud_Rate : Baud_Rates;
      Parity    : Parities     := No_Parity;
      Data_Bits : Word_Lengths := Word_Length_8;
      End_Bits  : Stop_Bits    := Stopbits_1;
      Control   : Flow_Control := No_Flow_Control)
     with
       Pre => (Initialized (This) or else raise Serial_Port_Uninitialized);

   procedure Put (This : in out Serial_Port; Msg : not null access Message) with
     Pre => (Initialized (This) or else raise Serial_Port_Uninitialized)
            and then
            not Sending (This),
     Inline;

   procedure Get (This : in out Serial_Port;  Msg : not null access Message) with
     Pre => (Initialized (This) or else raise Serial_Port_Uninitialized)
            and then
            not Receiving (This),
     Inline;

   function Sending (This : in out Serial_Port) return Boolean;
   --  Returns whether This is currently sending a message.

   function Receiving (This : in out Serial_Port) return Boolean;
   --  Returns whether This is currently receiving a message.

private

   --  The protected type defining the interrupt handling for sending and
   --  receiving characters via the USART attached to the serial port. Each
   --  serial port type a component of this protected type.
   protected type Controller (IRQ : Interrupt_ID;  Port : access Serial_Port) is

      pragma Interrupt_Priority;

      procedure Start_Sending (Msg : not null access Message);
      --  error: internal call cannot appear in precondition of protected operation
      --  with Pre => not Sending;

      procedure Start_Receiving (Msg : not null access Message);
      --  error: internal call cannot appear in precondition of protected operation
      --  with Pre => not Receiving;

      function Sending   return Boolean;
      function Receiving return Boolean;

   private

      Next_Out          : Positive;
      Awaiting_Transfer : Natural;
      Outgoing_Msg      : access Message;
      Incoming_Msg      : access Message;

      procedure Handle_Transmission with Inline;
      procedure Handle_Reception with Inline;
      procedure Detect_Errors (Is_Xmit_IRQ : Boolean) with Inline;

      procedure IRQ_Handler with Attach_Handler => IRQ;

   end Controller;

   type Serial_Port
     (IRQ    : Interrupt_ID;
      Device : not null access Peripheral_Descriptor)
   is tagged limited record
      Initialized : Boolean := False;
      Control     : Controller (IRQ, Serial_Port'Access);
   end record;

end Serial_IO.Nonblocking;

Fix build error about PO contracts

serial_io-nonblocking.ads: Fix build error about PO contracts

I didn't investigate at all.


------------------------------------------------------------------------------
--                                                                          --
--                        Copyright (C) 2020, AdaCore                       --
--           Copyright (C) 2020, Simon Wright (simon@pushface.org)          --
--                                                                          --
--  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.   --
--                                                                          --
------------------------------------------------------------------------------

--  The algorithms used here are derived from Pimoroni's code at
--  https://github.com/pimoroni/pmw3901-python.

with Ada.Unchecked_Conversion;

package body PMW3901 is

   --  Some registers
   Reg_ID             : constant := 16#00#;
   Reg_ID_Inverted    : constant := 16#5f#;
   Reg_Data_Ready     : constant := 16#02#;
   Reg_Motion_Burst   : constant := 16#16#;
   Reg_Power_Up_Reset : constant := 16#3a#;
   --  Reg_Orientation    : constant := 16#5b#;

   Power_Up_Reset_Key : constant := 16#5a#;

   function Read (This     : in out PMW3901_Flow_Sensor;
                  Register :        HAL.UInt8) return HAL.UInt8;

   procedure Write (This     : in out PMW3901_Flow_Sensor;
                    Register :        HAL.UInt8;
                    Value    :        HAL.UInt8);

   --------------
   -- Is_Valid --
   --------------

   function Is_Valid (M : Motion) return Boolean
   is
      use type HAL.UInt8;
   begin
      return M.Motion_Occurred
        and not (M.S_Qual < 19 and M.Shutter_Upper = 16#1f#);
   end Is_Valid;

   ----------------
   -- Initialize --
   ----------------

   procedure Initialize (This : in out PMW3901_Flow_Sensor)
   is
   begin
      This.CS.Clear;
      This.Timing.Delay_Milliseconds (50);
      This.CS.Set;

      declare
         Chip_ID          : HAL.UInt8;
         Revision         : HAL.UInt8;
         Inverted_Chip_ID : HAL.UInt8;
         use type HAL.UInt8;
      begin
         Chip_ID := Read (This, Reg_ID);
         Revision := Read (This, Reg_ID + 1);
         Inverted_Chip_ID := Read (This, Reg_ID_Inverted);
         if Chip_ID /= 16#49#
           or Revision /= 16#00#
           or Inverted_Chip_ID /= 16#b6#
         then
            --  Can't initialize the wrong sort of chip!
            raise SPI_Error with "no PMW3901 found";
         end if;
      end;

      Write (This, Reg_Power_Up_Reset, Power_Up_Reset_Key);
      This.Timing.Delay_Milliseconds (20);

      --  Read the registers once
      declare
         Buff : HAL.SPI.SPI_Data_8b (0 .. 4);
         use type HAL.UInt8;
      begin
         for J in Buff'Range loop
            Buff (J) := Read (This, Reg_Data_Ready + HAL.UInt8 (J));
         end loop;
      end;

      This.Initialized := True;
   end Initialize;

   ---------------
   -- Calibrate --
   ---------------

   procedure Calibrate (This : in out PMW3901_Flow_Sensor)
   is
      type Magic is record
         Register : HAL.UInt8;
         Value : HAL.UInt8;
      end record;
      type Magics is array (Natural range <>) of Magic;
      procedure Write_Magics (Data : Magics);
      procedure Write_Magics (Data : Magics) is
      begin
         for J in Data'Range loop
            Write (This, Data (J).Register, Data (J).Value);
         end loop;
      end Write_Magics;
      use type HAL.UInt8;
   begin
      Write_Magics (((16#7f#, 16#00#),
                     (16#55#, 16#01#),
                     (16#50#, 16#07#),
                     (16#7f#, 16#0e#),
                     (16#43#, 16#10#)));
      declare
         Check : constant HAL.UInt8 := Read (This, 16#67#);
      begin
         if (Check and 2#1000_0000#) /= 0 then
            Write (This, 16#48#, 16#04#);
         else
            Write (This, 16#48#, 16#02#);
         end if;
      end;
      if Read (This, 16#73#) = 0 then
         declare
            C1, C2 : HAL.UInt8;
         begin
            C1 := Read (This, 16#70#);
            C2 := Read (This, 16#71#);
            if C1 <= 28 then
               C1 := C1 + 14;
            end if;
            if C1 > 28 then
               C1 := C1 + 11;
            end if;
            C2 := (C2 * 45) / 100;
            Write_Magics (((16#7f#, 16#00#),
                           (16#51#, 16#7b#),
                           (16#50#, 16#00#),
                           (16#55#, 16#00#),
                           (16#7f#, 16#0E#),
                           (16#70#, C1),
                           (16#71#, C2)));
         end;
      end if;
      Write_Magics (((16#7f#, 16#00#),
                     (16#61#, 16#ad#),
                     (16#7f#, 16#03#),
                     (16#40#, 16#00#),
                     (16#7f#, 16#05#),
                     (16#41#, 16#b3#),
                     (16#43#, 16#f1#),
                     (16#45#, 16#14#),
                     (16#5b#, 16#32#),
                     (16#5f#, 16#34#),
                     (16#7b#, 16#08#),
                     (16#7f#, 16#06#),
                     (16#44#, 16#1b#),
                     (16#40#, 16#bf#),
                     (16#4e#, 16#3f#),
                     (16#7f#, 16#08#),
                     (16#65#, 16#20#),
                     (16#6a#, 16#18#),
                     (16#7f#, 16#09#),
                     (16#4f#, 16#af#),
                     (16#5f#, 16#40#),
                     (16#48#, 16#80#),
                     (16#49#, 16#80#),
                     (16#57#, 16#77#),
                     (16#60#, 16#78#),
                     (16#61#, 16#78#),
                     (16#62#, 16#08#),
                     (16#63#, 16#50#),
                     (16#7f#, 16#0a#),
                     (16#45#, 16#60#),
                     (16#7f#, 16#00#),
                     (16#4d#, 16#11#),
                     (16#55#, 16#80#),
                     (16#74#, 16#21#),
                     (16#75#, 16#1f#),
                     (16#4a#, 16#78#),
                     (16#4b#, 16#78#),
                     (16#44#, 16#08#),
                     (16#45#, 16#50#),
                     (16#64#, 16#ff#),
                     (16#65#, 16#1f#),
                     (16#7f#, 16#14#),
                     (16#65#, 16#67#),
                     (16#66#, 16#08#),
                     (16#63#, 16#70#),
                     (16#7f#, 16#15#),
                     (16#48#, 16#48#),
                     (16#7f#, 16#07#),
                     (16#41#, 16#0d#),
                     (16#43#, 16#14#),
                     (16#4b#, 16#0e#),
                     (16#45#, 16#0f#),
                     (16#44#, 16#42#),
                     (16#4c#, 16#80#),
                     (16#7f#, 16#10#),
                     (16#5b#, 16#02#),
                     (16#7f#, 16#07#),
                     (16#40#, 16#41#),
                     (16#70#, 16#00#)));
      This.Timing.Delay_Milliseconds (16#0a#);
      Write_Magics (((16#32#, 16#44#),
                     (16#7f#, 16#07#),
                     (16#40#, 16#40#),
                     (16#7f#, 16#06#),
                     (16#62#, 16#f0#),
                     (16#63#, 16#00#),
                     (16#7f#, 16#0d#),
                     (16#48#, 16#c0#),
                     (16#6f#, 16#d5#),
                     (16#7f#, 16#00#),
                     (16#5b#, 16#a0#),
                     (16#4e#, 16#a8#),
                     (16#5a#, 16#50#),
                     (16#40#, 16#80#)));
      This.Timing.Delay_Milliseconds (16#f0#);
      --  enable LED pulsing??? what LED?
      Write_Magics (((16#7f#, 16#14#),
                     (16#6f#, 16#1c#),
                     (16#7f#, 16#00#)));
   end Calibrate;

   -----------------
   -- Read_Motion --
   -----------------

   function Read_Motion  (This : in out PMW3901_Flow_Sensor) return Motion is
      subtype Buffer is HAL.SPI.SPI_Data_8b (1 .. 12);
      function Convert is new Ada.Unchecked_Conversion (Buffer, Motion);
      Buff : Buffer := (others => 0);
      Status : HAL.SPI.SPI_Status;
      use all type HAL.SPI.SPI_Status;
   begin
      This.CS.Clear;
      This.Port.Transmit (HAL.SPI.SPI_Data_8b'((1 => Reg_Motion_Burst)),
                          Status);
      if Status /= Ok then
         raise SPI_Error with "PMW3901 SPI transmit failure";
      end if;
      This.Port.Receive (Buff, Status);
      if Status /= Ok then
         raise SPI_Error with "PMW3901 SPI receive burst failure";
      end if;
      This.CS.Set;
      return Convert (Buff);
   end Read_Motion;

   ----------
   -- Read --
   ----------

   function Read (This     : in out PMW3901_Flow_Sensor;
                  Register : HAL.UInt8) return HAL.UInt8
   is
      use type HAL.UInt8;
      Register_For_Read : constant HAL.UInt8 := Register and 16#7f#;
      Data   : HAL.SPI.SPI_Data_8b (0 .. 0);
      Status : HAL.SPI.SPI_Status;
      use all type HAL.SPI.SPI_Status;
   begin
      This.CS.Clear;
      This.Port.Transmit (HAL.SPI.SPI_Data_8b'(1 => Register_For_Read),
                          Status);
      if Status /= Ok then
         raise SPI_Error with "PMW3901 SPI transmit failure";
      end if;
      This.Port.Receive (Data, Status);
      if Status /= Ok then
         raise SPI_Error with "PMW3901 SPI receive failure";
      end if;
      This.CS.Set;
      return Data (Data'First);
   end Read;

   -----------
   -- Write --
   -----------

   procedure Write (This     : in out PMW3901_Flow_Sensor;
                    Register :        HAL.UInt8;
                    Value    :        HAL.UInt8)
   is
      use type HAL.UInt8;
      Register_For_Write : constant HAL.UInt8 := Register or 16#80#;
      Status : HAL.SPI.SPI_Status;
      use all type HAL.SPI.SPI_Status;
   begin
      This.CS.Clear;
      This.Port.Transmit (HAL.SPI.SPI_Data_8b'(1 => Register_For_Write),
                          Status);
      if Status /= Ok then
         raise SPI_Error with "PMW3901 SPI transmit failure";
      end if;
      This.Port.Transmit (HAL.SPI.SPI_Data_8b'(1 => Value),
                          Status);
      if Status /= Ok then
         raise SPI_Error with "PMW3901 SPI transmit failure";
      end if;
      This.CS.Set;
   end Write;

end PMW3901;

------------------------------------------------------------------------------
--                                                                          --
--                        Copyright (C) 2020, AdaCore                       --
--         Copyright (C) 2020-2021, Simon Wright (simon@pushface.org)       --
--                                                                          --
--  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.   --
--                                                                          --
------------------------------------------------------------------------------

--  The algorithms used here are derived from Pimoroni's code at
--  https://github.com/pimoroni/pmw3901-python.
--  Calibration data from PX4: https://github.com/PX4/PX4-Autopilot/
--   blob/master/src/drivers/optical_flow/pmw3901/PMW3901.cpp

with Ada.Unchecked_Conversion;

package body PMW3901 is

   --  Some registers
   Reg_ID             : constant := 16#00#;
   Reg_ID_Inverted    : constant := 16#5f#;
   Reg_Data_Ready     : constant := 16#02#;
   Reg_Motion_Burst   : constant := 16#16#;
   Reg_Power_Up_Reset : constant := 16#3a#;
   --  Reg_Orientation    : constant := 16#5b#;

   Power_Up_Reset_Key : constant := 16#5a#;

   function Read (This     : in out PMW3901_Flow_Sensor;
                  Register :        HAL.UInt8) return HAL.UInt8;

   procedure Write (This     : in out PMW3901_Flow_Sensor;
                    Register :        HAL.UInt8;
                    Value    :        HAL.UInt8);

   --------------
   -- Is_Valid --
   --------------

   function Is_Valid (M : Motion) return Boolean
   is
      use type HAL.UInt8;
   begin
      return M.Motion_Occurred
        and not (M.S_Qual < 19 and M.Shutter_Upper = 16#1f#);
   end Is_Valid;

   ----------------
   -- Initialize --
   ----------------

   procedure Initialize (This : in out PMW3901_Flow_Sensor)
   is
   begin
      This.CS.Clear;
      This.Timing.Delay_Milliseconds (50);
      This.CS.Set;

      declare
         Chip_ID          : HAL.UInt8;
         Revision         : HAL.UInt8;
         Inverted_Chip_ID : HAL.UInt8;
         use type HAL.UInt8;
      begin
         Chip_ID := Read (This, Reg_ID);
         Revision := Read (This, Reg_ID + 1);
         Inverted_Chip_ID := Read (This, Reg_ID_Inverted);
         if Chip_ID /= 16#49#
           or Revision /= 16#00#
           or Inverted_Chip_ID /= 16#b6#
         then
            --  Can't initialize the wrong sort of chip!
            raise SPI_Error with "no PMW3901 found";
         end if;
      end;

      Write (This, Reg_Power_Up_Reset, Power_Up_Reset_Key);
      This.Timing.Delay_Milliseconds (5);

      --  Read the registers once
      declare
         Buff : HAL.SPI.SPI_Data_8b (0 .. 4);
         use type HAL.UInt8;
      begin
         for J in Buff'Range loop
            Buff (J) := Read (This, Reg_Data_Ready + HAL.UInt8 (J));
         end loop;
      end;
      This.Timing.Delay_Milliseconds (1);

      This.Initialized := True;
   end Initialize;

   ---------------
   -- Calibrate --
   ---------------

   procedure Calibrate (This : in out PMW3901_Flow_Sensor)
   is
      type Magic is record
         Register : HAL.UInt8;
         Value : HAL.UInt8;
      end record;
      type Magics is array (Natural range <>) of Magic;
      procedure Write_Magics (Data : Magics);
      procedure Write_Magics (Data : Magics) is
      begin
         for J in Data'Range loop
            Write (This, Data (J).Register, Data (J).Value);
         end loop;
      end Write_Magics;
      use type HAL.UInt8;
   begin
      Write_Magics (((16#7f#, 16#00#),
                     (16#55#, 16#01#),
                     (16#50#, 16#07#),
                     (16#7f#, 16#0e#),
                     (16#43#, 16#10#)));

      declare
         Check : constant HAL.UInt8 := Read (This, 16#67#);
      begin
         if (Check and 2#1000_0000#) /= 0 then
            Write (This, 16#48#, 16#04#);
         else
            Write (This, 16#48#, 16#02#);
         end if;
      end;

      Write_Magics (((16#7f#, 16#00#),
                     (16#51#, 16#7b#),
                     (16#50#, 16#00#),
                     (16#55#, 16#00#),
                     (16#7f#, 16#0e#)));

      if Read (This, 16#73#) = 0 then
         declare
            C1, C2 : HAL.UInt8;
         begin
            C1 := Read (This, 16#70#);
            if C1 <= 28 then
               C1 := C1 + 14;
            else
               C1 := C1 + 11;
            end if;
            C1 := HAL.UInt8'Min (16#3f#, C1);
            C2 := Read (This, 16#71#);
            C2 := (C2 * 45) / 100;
            Write_Magics (((16#7f#, 16#00#),
                           (16#61#, 16#ad#),
                           (16#51#, 16#70#),
                           (16#7f#, 16#0E#),
                           (16#70#, C1),
                           (16#71#, C2)));
         end;
      end if;

      Write_Magics (((16#7F#, 16#00#),
                     (16#61#, 16#AD#),
                     (16#7F#, 16#03#),
                     (16#40#, 16#00#),
                     (16#7F#, 16#05#),
                     (16#41#, 16#B3#),
                     (16#43#, 16#F1#),
                     (16#45#, 16#14#),
                     (16#5B#, 16#32#),
                     (16#5F#, 16#34#),
                     (16#7B#, 16#08#),
                     (16#7F#, 16#06#),
                     (16#44#, 16#1B#),
                     (16#40#, 16#BF#),
                     (16#4E#, 16#3F#),
                     (16#7F#, 16#08#),
                     (16#65#, 16#20#),
                     (16#6A#, 16#18#),
                     (16#7F#, 16#09#),
                     (16#4F#, 16#AF#),
                     (16#5F#, 16#40#),
                     (16#48#, 16#80#),
                     (16#49#, 16#80#),
                     (16#57#, 16#77#),
                     (16#60#, 16#78#),
                     (16#61#, 16#78#),
                     (16#62#, 16#08#),
                     (16#63#, 16#50#),
                     (16#7F#, 16#0A#),
                     (16#45#, 16#60#),
                     (16#7F#, 16#00#),
                     (16#4D#, 16#11#),
                     (16#55#, 16#80#),
                     (16#74#, 16#21#),
                     (16#75#, 16#1F#),
                     (16#4A#, 16#78#),
                     (16#4B#, 16#78#),
                     (16#44#, 16#08#),
                     (16#45#, 16#50#),
                     (16#64#, 16#FF#),
                     (16#65#, 16#1F#),
                     (16#7F#, 16#14#),
                     (16#65#, 16#67#),
                     (16#66#, 16#08#),
                     (16#63#, 16#70#),
                     (16#7F#, 16#15#),
                     (16#48#, 16#48#),
                     (16#7F#, 16#07#),
                     (16#41#, 16#0D#),
                     (16#43#, 16#14#),
                     (16#4B#, 16#0E#),
                     (16#45#, 16#0F#),
                     (16#44#, 16#42#),
                     (16#4C#, 16#80#),
                     (16#7F#, 16#10#),
                     (16#5B#, 16#02#),
                     (16#7F#, 16#07#),
                     (16#40#, 16#41#),
                     (16#70#, 16#00#)));

      This.Timing.Delay_Milliseconds (10);

      Write_Magics (((16#32#, 16#44#),
                     (16#7F#, 16#07#),
                     (16#40#, 16#40#),
                     (16#7F#, 16#06#),
                     (16#62#, 16#F0#),
                     (16#63#, 16#00#),
                     (16#7F#, 16#0D#),
                     (16#48#, 16#C0#),
                     (16#6F#, 16#D5#),
                     (16#7F#, 16#00#),
                     (16#5B#, 16#A0#),
                     (16#4E#, 16#A8#),
                     (16#5A#, 16#50#),
                     (16#40#, 16#80#)));
   end Calibrate;

   -----------------
   -- Read_Motion --
   -----------------

   function Read_Motion  (This : in out PMW3901_Flow_Sensor) return Motion is
      subtype Buffer is HAL.SPI.SPI_Data_8b (1 .. 12);
      function Convert is new Ada.Unchecked_Conversion (Buffer, Motion);
      Buff : Buffer := (others => 0);
      Status : HAL.SPI.SPI_Status;
      use all type HAL.SPI.SPI_Status;
   begin
      This.CS.Clear;
      This.Port.Transmit (HAL.SPI.SPI_Data_8b'((1 => Reg_Motion_Burst)),
                          Status);
      if Status /= Ok then
         raise SPI_Error with "PMW3901 SPI transmit failure";
      end if;
      This.Port.Receive (Buff, Status);
      if Status /= Ok then
         raise SPI_Error with "PMW3901 SPI receive burst failure";
      end if;
      This.CS.Set;
      return Convert (Buff);
   end Read_Motion;

   ----------
   -- Read --
   ----------

   function Read (This     : in out PMW3901_Flow_Sensor;
                  Register : HAL.UInt8) return HAL.UInt8
   is
      use type HAL.UInt8;
      Register_For_Read : constant HAL.UInt8 := Register and 16#7f#;
      Data   : HAL.SPI.SPI_Data_8b (0 .. 0);
      Status : HAL.SPI.SPI_Status;
      use all type HAL.SPI.SPI_Status;
   begin
      This.CS.Clear;
      This.Port.Transmit (HAL.SPI.SPI_Data_8b'(1 => Register_For_Read),
                          Status);
      if Status /= Ok then
         raise SPI_Error with "PMW3901 SPI transmit failure";
      end if;
      This.Port.Receive (Data, Status);
      if Status /= Ok then
         raise SPI_Error with "PMW3901 SPI receive failure";
      end if;
      This.CS.Set;
      return Data (Data'First);
   end Read;

   -----------
   -- Write --
   -----------

   procedure Write (This     : in out PMW3901_Flow_Sensor;
                    Register :        HAL.UInt8;
                    Value    :        HAL.UInt8)
   is
      use type HAL.UInt8;
      Register_For_Write : constant HAL.UInt8 := Register or 16#80#;
      Status : HAL.SPI.SPI_Status;
      use all type HAL.SPI.SPI_Status;
   begin
      This.CS.Clear;
      This.Port.Transmit (HAL.SPI.SPI_Data_8b'(1 => Register_For_Write),
                          Status);
      if Status /= Ok then
         raise SPI_Error with "PMW3901 SPI transmit failure";
      end if;
      This.Port.Transmit (HAL.SPI.SPI_Data_8b'(1 => Value),
                          Status);
      if Status /= Ok then
         raise SPI_Error with "PMW3901 SPI transmit failure";
      end if;
      This.CS.Set;
   end Write;

end PMW3901;

Rework PMW3901 calibration parameters.

Rework PMW3901 calibration parameters.

Uses timing/calibration parameters from github PX4/PX4-Autopilot\
/blob/master/src/drivers/optical_flow/pmw3901/PMW3901.cpp.

  * components/src/motion/pmw3901/pmw3901.adb (Initialize): delays to
      match PX4 code.
    (Calibrate): likewise, plus calibration data.


-----------------------------------------------------------------------
--  util-beans-objects-readers -- Datasets
--  Copyright (C) 2013 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 Util.Beans.Objects.Maps;
with Util.Beans.Objects.Vectors;
with Util.Serialize.IO;
with Util.Stacks;
package Util.Beans.Objects.Readers is

   type Reader is limited new Util.Serialize.IO.Reader with private;

   --  Start a document.
   overriding
   procedure Start_Document (Handler : in out Reader);

   --  Start a new object associated with the given name.  This is called when
   --  the '{' is reached.  The reader must be updated so that the next
   --  Set_Member procedure will associate the name/value pair on the
   --  new object.
   overriding
   procedure Start_Object (Handler : in out Reader;
                           Name    : in String);

   --  Finish an object associated with the given name.  The reader must be
   --  updated to be associated with the previous object.
   overriding
   procedure Finish_Object (Handler : in out Reader;
                            Name    : in String);

   overriding
   procedure Start_Array (Handler : in out Reader;
                          Name    : in String);

   overriding
   procedure Finish_Array (Handler : in out Reader;
                           Name    : in String;
                           Count   : in Natural);

   --  Set the name/value pair on the current object.  For each active mapping,
   --  find whether a rule matches our name and execute it.
   overriding
   procedure Set_Member (Handler   : in out Reader;
                         Name      : in String;
                         Value     : in Util.Beans.Objects.Object;
                         Attribute : in Boolean := False);

   --  Report an error while parsing the input stream.  The error message will be reported
   --  on the logger associated with the parser.  The parser will be set as in error so that
   --  the Has_Error function will return True after parsing the whole file.
   procedure Error (Handler : in out Reader;
                    Message : in String);

private

   type Object_Context is record
      Map  : Util.Beans.Objects.Maps.Map_Bean_Access;
      List : Util.Beans.Objects.Vectors.Vector_Bean_Access;
   end record;
   type Object_Context_Access is access all Object_Context;

   package Object_Stack is new Util.Stacks (Element_Type        => Object_Context,
                                            Element_Type_Access => Object_Context_Access);

   type Reader is limited new Util.Serialize.IO.Reader with record
      Context  : Object_Stack.Stack;
   end record;

end Util.Beans.Objects.Readers;

-----------------------------------------------------------------------
--  util-beans-objects-readers -- Datasets
--  Copyright (C) 2013 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 Util.Beans.Objects.Maps;
with Util.Beans.Objects.Vectors;
with Util.Serialize.IO;
with Util.Stacks;
with Util.Log;
package Util.Beans.Objects.Readers is

   type Reader is limited new Util.Serialize.IO.Reader with private;

   --  Start a document.
   overriding
   procedure Start_Document (Handler : in out Reader);

   --  Start a new object associated with the given name.  This is called when
   --  the '{' is reached.  The reader must be updated so that the next
   --  <b>Set_Member</b> procedure will associate the name/value pair on the
   --  new object.
   overriding
   procedure Start_Object (Handler : in out Reader;
                           Name    : in String;
                           Logger  : in out Util.Log.Logging'Class);

   --  Finish an object associated with the given name.  The reader must be
   --  updated to be associated with the previous object.
   overriding
   procedure Finish_Object (Handler : in out Reader;
                            Name    : in String;
                            Logger  : in out Util.Log.Logging'Class);

   overriding
   procedure Start_Array (Handler : in out Reader;
                          Name    : in String;
                          Logger  : in out Util.Log.Logging'Class);

   overriding
   procedure Finish_Array (Handler : in out Reader;
                           Name    : in String;
                           Count   : in Natural;
                           Logger  : in out Util.Log.Logging'Class);

   --  Set the name/value pair on the current object.  For each active mapping,
   --  find whether a rule matches our name and execute it.
   overriding
   procedure Set_Member (Handler   : in out Reader;
                         Name      : in String;
                         Value     : in Util.Beans.Objects.Object;
                         Logger    : in out Util.Log.Logging'Class;
                         Attribute : in Boolean := False);

private

   type Object_Context is record
      Map  : Util.Beans.Objects.Maps.Map_Bean_Access;
      List : Util.Beans.Objects.Vectors.Vector_Bean_Access;
   end record;
   type Object_Context_Access is access all Object_Context;

   package Object_Stack is new Util.Stacks (Element_Type        => Object_Context,
                                            Element_Type_Access => Object_Context_Access);

   type Reader is limited new Util.Serialize.IO.Reader with record
      Context  : Object_Stack.Stack;
   end record;

end Util.Beans.Objects.Readers;

Add a Logger parameter to the Reader operations Remove the Error procedure which is no longer necessary