Natools

natools-s_expressions-conditionals-strings.adb at [2a24860505]
Login

File src/natools-s_expressions-conditionals-strings.adb artifact 52b9048770 part of check-in 2a24860505


------------------------------------------------------------------------------
-- Copyright (c) 2015, 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 Ada.Characters.Handling;
with Ada.Strings.Fixed;
with Natools.Static_Maps.S_Expressions.Conditionals.Strings;

package body Natools.S_Expressions.Conditionals.Strings is

   package Fixed renames Ada.Strings.Fixed;


   function Conditional_On_Atoms
     (Context : in Strings.Context;
      Arguments : in out Lockable.Descriptor'Class;
      Element : access function (Context : in Strings.Context;
                                 Data : in Atom)
                                return Boolean;
      Conjunction : in Boolean)
     return Boolean;
      --  Evaluate Element on all atoms of Arguments and combine them

   function Contains (Context : in Strings.Context; Data : in Atom)
     return Boolean;
      --  Check whether Context contains Data

   function Is_Prefix (Context : in Strings.Context; Data : in Atom)
     return Boolean;
      --  Check whether Context starts with Data

   function To_Lower (Item : in Character) return Character
     renames Ada.Characters.Handling.To_Lower;
      --  Clearer name for lower case translation, used for case-insentivity



   ------------------------------
   -- Local Helper Subprograms --
   ------------------------------

   function Conditional_On_Atoms
     (Context : in Strings.Context;
      Arguments : in out Lockable.Descriptor'Class;
      Element : access function (Context : in Strings.Context;
                                 Data : in Atom)
                                return Boolean;
      Conjunction : in Boolean)
     return Boolean
   is
      Result : Boolean := not Conjunction;
      Event : Events.Event := Arguments.Current_Event;
   begin
      while Event = Events.Add_Atom loop
         Result := Element.all (Context, Arguments.Current_Atom);
         exit when Result /= Conjunction;
         Arguments.Next (Event);
      end loop;

      return Result;
   end Conditional_On_Atoms;


   function Contains (Context : in Strings.Context; Data : in Atom)
     return Boolean
   is
      Str_Value : String := To_String (Data);
   begin
      if Context.Settings.Case_Sensitive then
         return Fixed.Index
           (Context.Data.all,
            Str_Value,
            Str_Value'First,
            Ada.Strings.Forward) > 0;
      else
         Fixed.Translate (Str_Value, To_Lower'Access);
         return Fixed.Index
           (Context.Data.all,
            Str_Value,
            Str_Value'First,
            Ada.Strings.Forward,
            Ada.Characters.Handling.To_Lower'Access) > 0;
      end if;
   end Contains;


   function Is_Prefix (Context : in Strings.Context; Data : in Atom)
     return Boolean is
   begin
      if Context.Data.all'Length < Data'Length then
         return False;
      end if;

      declare
         Prefix : String renames Context.Data.all
           (Context.Data.all'First
            .. Context.Data.all'First + Data'Length - 1);
      begin
         if Context.Settings.Case_Sensitive then
            return Prefix = To_String (Data);
         else
            return Fixed.Translate (Prefix, To_Lower'Access)
              = Fixed.Translate (To_String (Data), To_Lower'Access);
         end if;
      end;
   end Is_Prefix;



   ---------------------------
   -- Evaluation Primitives --
   ---------------------------

   function Parametric_Evaluate
     (Context : in Strings.Context;
      Name : in Atom;
      Arguments : in out Lockable.Descriptor'Class)
     return Boolean
   is
      use Natools.Static_Maps.S_Expressions.Conditionals.Strings;
   begin
      case To_Parametric (To_String (Name)) is
         when Unknown_Parametric_Condition =>
            if Context.Parametric_Fallback /= null then
               return Context.Parametric_Fallback
                 (Context.Settings, Name, Arguments);
            else
               raise Constraint_Error with "Unknown parametric condition """
                 & To_String (Name) & '"';
            end if;

         when Case_Insensitive =>
            declare
               New_Context : Strings.Context := Context;
            begin
               New_Context.Settings.Case_Sensitive := False;
               return Evaluate (New_Context, Arguments);
            end;

         when Case_Sensitive =>
            declare
               New_Context : Strings.Context := Context;
            begin
               New_Context.Settings.Case_Sensitive := True;
               return Evaluate (New_Context, Arguments);
            end;

         when Contains_All =>
            return Conditional_On_Atoms
              (Context, Arguments, Contains'Access, True);

         when Contains_Any =>
            return Conditional_On_Atoms
              (Context, Arguments, Contains'Access, False);

         when Starts_With =>
            return Conditional_On_Atoms
              (Context, Arguments, Is_Prefix'Access, False);
      end case;
   end Parametric_Evaluate;


   function Simple_Evaluate
     (Context : in Strings.Context;
      Name : in Atom)
     return Boolean
   is
      use Natools.Static_Maps.S_Expressions.Conditionals.Strings;
   begin
      case To_Simple (To_String (Name)) is
         when Unknown_Simple_Condition =>
            if Context.Parametric_Fallback /= null then
               return Context.Simple_Fallback (Context.Settings, Name);
            else
               raise Constraint_Error with "Unknown simple condition """
                 & To_String (Name) & '"';
            end if;

         when Is_ASCII =>
            for I in Context.Data.all'Range loop
               if Context.Data (I)
                 not in Character'Val (0) .. Character'Val (127)
               then
                  return False;
               end if;
            end loop;
            return True;

         when Is_Empty =>
            return Context.Data.all'Length = 0;
      end case;
   end Simple_Evaluate;



   --------------------------
   -- Evaluation Shortcuts --
   --------------------------

   function Evaluate
     (Text : in String;
      Expression : in out Lockable.Descriptor'Class)
     return Boolean
   is
      Aliased_Text : aliased constant String := Text;
      Context : constant Strings.Context
        := (Data => Aliased_Text'Access,
            Parametric_Fallback => null,
            Simple_Fallback => null,
            Settings => <>);
   begin
      return Evaluate (Context, Expression);
   end Evaluate;

end Natools.S_Expressions.Conditionals.Strings;