Natools

natools-string_slices.adb at [53a6d91b09]
Login

File src/natools-string_slices.adb artifact c5e18cd3df part of check-in 53a6d91b09


------------------------------------------------------------------------------
-- Copyright (c) 2013, 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.String_Slices is

   use type String_Refs.Reference;


   -----------------------------
   -- String_Range primitives --
   -----------------------------

   function Is_In (Point : Natural; Reference : String_Range) return Boolean is
   begin
      return Point >= Reference.First
        and Point < Reference.First + Reference.Length;
   end Is_In;


   function Is_Subrange (Sample, Reference : String_Range) return Boolean is
   begin
      return Sample.Length = 0
        or else (Sample.First >= Reference.First
                 and then Sample.First + Sample.Length
                            <= Reference.First + Reference.Length);
   end Is_Subrange;


   function Last (Self : String_Range) return Natural is
   begin
      return Self.First + Self.Length - 1;
   end Last;


   function To_Range (First : Positive; Last : Natural) return String_Range is
   begin
      if Last >= First then
         return (First => First, Length => Last - First + 1);
      else
         return (First => First, Length => 0);
      end if;
   end To_Range;


   function Get_Range (S : String) return String_Range is
   begin
      return (S'First, S'Length);
   end Get_Range;


   procedure Set_First (Self : in out String_Range; New_First : in Positive) is
   begin
      if New_First >= Self.First + Self.Length then
         Self.Length := 0;
      else
         Self.Length := Self.Length - (New_First - Self.First);
      end if;

      Self.First := New_First;
   end Set_First;


   procedure Set_Last (Self : in out String_Range; New_Last : in Natural) is
   begin
      if New_Last < Self.First then
         Self.Length := 0;
      else
         Self.Length := New_Last - Self.First + 1;
      end if;
   end Set_Last;


   procedure Set_Length
     (Self : in out String_Range; New_Length : in Natural) is
   begin
      Self.Length := New_Length;
   end Set_Length;


   function Image (Interval : String_Range) return String is
      First_Img : String := Integer'Image (Interval.First);
   begin
      pragma Assert (First_Img (First_Img'First) = ' ');

      if Interval.Length = 0 then
         return "empty at" & First_Img;
      end if;

      First_Img (First_Img'First) := '[';

      if Interval.Length = 1 then
         return First_Img & ']';
      else
         return First_Img
           & ','
           & Integer'Image (Last (Interval))
           & ']';
      end if;
   end Image;



   --------------------------
   -- Conversion functions --
   --------------------------

   function To_Slice (S : String) return Slice is
      function Create return String;

      function Create return String is
      begin
         return S;
      end Create;
   begin
      return Slice'(Bounds => (S'First, S'Length),
                    Ref    => String_Refs.Create (Create'Access));
   end To_Slice;


   function To_String (S : Slice) return String is
   begin
      if S.Ref.Is_Empty then
         return "";
      else
         return S.Ref.Query.Data.all (S.Bounds.First .. Last (S.Bounds));
      end if;
   end To_String;



   ---------------
   -- Accessors --
   ---------------

   procedure Export (S : in Slice; Output : out String) is
   begin
      if not S.Ref.Is_Empty then
         Output := S.Ref.Query.Data.all (S.Bounds.First .. Last (S.Bounds));
      end if;
   end Export;


   procedure Query
     (S : in Slice;
      Process : not null access procedure (Text : in String)) is
   begin
      if S.Bounds.Length = 0 or else S.Ref.Is_Empty then
         Process.all ("");
      else
         Process.all
           (S.Ref.Query.Data.all (S.Bounds.First .. Last (S.Bounds)));
      end if;
   end Query;


   function Get_Range (S : Slice) return String_Range is
   begin
      return S.Bounds;
   end Get_Range;


   function First (S : Slice) return Positive is
   begin
      return S.Bounds.First;
   end First;


   function Last (S : Slice) return Natural is
   begin
      return Last (S.Bounds);
   end Last;


   function Length (S : Slice) return Natural is
   begin
      return S.Bounds.Length;
   end Length;



   ---------------
   -- Extenders --
   ---------------

   function Parent (S : Slice) return Slice is
   begin
      if S.Ref.Is_Empty then
         return Slice'(others => <>);
      else
         return Slice'(Bounds => Get_Range (S.Ref.Query.Data.all),
                       Ref    => S.Ref);
      end if;
   end Parent;


   function Extend (S : Slice; New_Range : in String_Range) return Slice is
   begin
      if not Is_Subrange (New_Range, Get_Range (S.Ref.Query.Data.all)) then
         raise Constraint_Error with "Extend slice beyond complete range";
      end if;

      return Slice'(Bounds => New_Range,
                    Ref    => S.Ref);
   end Extend;


   function Extend (S : Slice; First : Positive; Last : Natural)
     return Slice is
   begin
      return Extend (S, To_Range (First, Last));
   end Extend;


   procedure Extend (S : in out Slice; New_Range : in String_Range) is
   begin
      if not Is_Subrange (New_Range, Get_Range (S.Ref.Query.Data.all)) then
         raise Constraint_Error with "Extend slice beyond complete range";
      end if;

      S.Bounds := New_Range;
   end Extend;


   procedure Extend
     (S : in out Slice; First : in Positive; Last : in Natural) is
   begin
      Extend (S, To_Range (First, Last));
   end Extend;



   -----------------
   -- Restrictors --
   -----------------

   function Subslice (S : Slice; New_Range : String_Range) return Slice is
   begin
      if S.Ref.Is_Empty then
         if New_Range.Length = 0 then
            return Slice'(Bounds => New_Range, Ref => <>);
         else
            raise Constraint_Error with "Subslice of null slice";
         end if;
      end if;

      if not Is_Subrange (New_Range, S.Bounds) then
         raise Constraint_Error with "Subslice out of parent range";
      end if;

      return Slice'(Bounds => New_Range,
                    Ref    => S.Ref);
   end Subslice;


   function Subslice (S : Slice; First : Positive; Last : Natural)
     return Slice is
   begin
      return Subslice (S, To_Range (First, Last));
   end Subslice;


   procedure Restrict (S : in out Slice; New_Range : in String_Range) is
   begin
      if S.Ref.Is_Empty and New_Range.Length /= 0 then
         raise Constraint_Error with "Restrict of null slice";
      end if;

      if not Is_Subrange (New_Range, S.Bounds) then
         raise Constraint_Error with "Restriction with not a subrange";
      end if;

      S.Bounds := New_Range;
   end Restrict;


   procedure Restrict
     (S : in out Slice; First : in Positive; Last : in Natural) is
   begin
      Restrict (S, To_Range (First, Last));
   end Restrict;


   procedure Set_First (S : in out Slice; New_First : in Positive) is
   begin
      if New_First < S.Bounds.First then
         raise Constraint_Error with "New_First out of slice range";
      end if;

      Set_First (S.Bounds, New_First);
   end Set_First;


   procedure Set_Last (S : in out Slice; New_Last : in Natural) is
   begin
      if New_Last > Last (S.Bounds) then
         raise Constraint_Error with "New_Last out of slice range";
      end if;

      Set_Last (S.Bounds, New_Last);
   end Set_Last;


   procedure Set_Length (S : in out Slice; New_Length : in Natural) is
   begin
      if New_Length > S.Bounds.Length then
         raise Constraint_Error with "New_Length out of slice range";
      end if;

      S.Bounds.Length := New_Length;
   end Set_Length;



   ----------------------
   -- Slice comparison --
   ----------------------

   function Is_Empty (S : Slice) return Boolean is
   begin
      return S.Bounds.Length = 0 or else S.Ref.Is_Empty;
   end Is_Empty;


   function Is_Null (S : Slice) return Boolean is
   begin
      return S.Ref.Is_Empty;
   end Is_Null;


   function Is_Related (Left, Right : Slice) return Boolean is
   begin
      return Left.Ref = Right.Ref;
   end Is_Related;


   function Is_Subslice (S, Reference : Slice) return Boolean is
   begin
      return S.Ref = Reference.Ref
        and then Is_Subrange (S.Bounds, Reference.Bounds);
   end Is_Subslice;



   ------------------
   -- Constructors --
   ------------------

   function Duplicate (S : Slice) return Slice is
      function Factory return String;

      function Factory return String is
      begin
         return S.Ref.Query.Data.all;
      end Factory;
   begin
      if S.Bounds.Length = 0 or else S.Ref.Is_Empty then
         return Null_Slice;
      else
         return Slice'(Bounds => S.Bounds,
                       Ref => String_Refs.Create (Factory'Access));
      end if;
   end Duplicate;

end Natools.String_Slices;