Natools

------------------------------------------------------------------------------
-- 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.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;

------------------------------------------------------------------------------
-- 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.           --
------------------------------------------------------------------------------

------------------------------------------------------------------------------
-- Natools.String_Slices provide an object that represents a substring of a --
-- shared parent string.                                                    --
------------------------------------------------------------------------------

private with Natools.References;

package Natools.String_Slices is
   pragma Preelaborate (String_Slices);

   -----------------------
   -- String range type --
   -----------------------

   type String_Range is record
      First  : Positive;
      Length : Natural;
   end record;

   function Is_In (Point : Natural; Reference : String_Range) return Boolean;
   function Is_Subrange (Sample, Reference : String_Range) return Boolean;
      --  Inclusion tests

   function Last (Self : String_Range) return Natural;
      --  Return last bound of the given range

   function To_Range (First : Positive; Last : Natural) return String_Range;
      --  Create a range with the given bounds

   function Get_Range (S : String) return String_Range;
      --  Return the String_Range representation of S index range.
      --  Semantically equivalent to (To_Range (S'First, S'Last))
      --  and to (String_Range'(First => S'First, Length => S'Length)).

   procedure Set_First (Self : in out String_Range; New_First : in Positive);
      --  Update first bound keeping last bound intact

   procedure Set_Last (Self : in out String_Range; New_Last : in Natural);
      --  Update range for the given last bound, keeping the first one intact

   procedure Set_Length (Self : in out String_Range; New_Length : in Natural);
      --  Basic mutator included for completeness sake

   function Image (Interval : String_Range) return String;
      --  Interval representation of the given range


   ----------------
   -- Slice type --
   ----------------

   type Slice is tagged private;

   Null_Slice : constant Slice;


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

   function To_Slice (S : String) return Slice;
      --  Create a new slice containing the whole given string

   function To_String (S : Slice) return String;
      --  Return the string represented by the slice


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

   procedure Export (S : in Slice; Output : out String);
      --  Fill Output with string contents in S
      --  Raise Constraint_Error when Output'Length /= Length(S)

   procedure Query
     (S : in Slice;
      Process : not null access procedure (Text : in String));
      --  Query the string object directly from memory

   function Get_Range (S : Slice) return String_Range;
      --  Return the range embedded in S

   function First (S : Slice) return Positive;
      --  Return the lowest index of S

   function Last (S : Slice) return Natural;
      --  Return the largest index of S

   function Length (S : Slice) return Natural;
      --  Return the length of S


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

   --  These subprograms allow access to the parent string beyond the
   --  current range. However Constraint_Error is raised when trying to reach
   --  beyond the parent string range.

   function Parent (S : Slice) return Slice;
      --  Return a slice representing the whole string available

   function Extend (S : Slice; New_Range : in String_Range) return Slice;
   function Extend (S : Slice; First : Positive; Last : Natural) return Slice;
   procedure Extend (S : in out Slice; New_Range : in String_Range);
   procedure Extend (S : in out Slice; First : in Positive; Last : in Natural);
      --  Extend the range represented by S


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

   --  All the subprograms here raise Constraint_Error when the new range
   --  is not a subrange of the source range.

   function Subslice (S : Slice; New_Range : String_Range) return Slice;
   function Subslice (S : Slice; First : Positive; Last : Natural)
     return Slice;
      --  Return a subslice of S

   procedure Restrict (S : in out Slice; New_Range : in String_Range);
   procedure Restrict
     (S : in out Slice; First : in Positive; Last : in Natural);
      --  Update the range in S

   procedure Set_First (S : in out Slice; New_First : in Positive);
      --  Update the range of S keeping the upper bound intact

   procedure Set_Last (S : in out Slice; New_Last : in Natural);
      --  Update the range of S keeping the lower bound intact

   procedure Set_Length (S : in out Slice; New_Length : in Natural);
      --  Truncate S range to the given length, keeping the lower bound intact


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

   function Is_Empty (S : Slice) return Boolean;
      --  Return whether the slice represents an empty string.
      --  Semantically equivalent to (To_String (S) = "").

   function Is_Null (S : Slice) return Boolean;
      --  Return whether the slice has a parent string

   function Is_Related (Left, Right : Slice) return Boolean;
      --  Return whether both slices have the same parent string

   function Is_Subslice (S, Reference : Slice) return Boolean;
      --  Return whether S represent of a subrange of Reference with the
      --  same parent string.

   function Duplicate (S : Slice) return Slice;
      --  Create a new parent string and a slice designating it.
      --  This does not copy parts of S parent string outside of S range.
      --  Semantically equivalent to (To_Slice (To_String (S))).

private

   type Access_In_Default_Pool is access Boolean;
      --  Access type only used to infer default storage pool

   package String_Refs is new References
     (String,
      Access_In_Default_Pool'Storage_Pool,
      Access_In_Default_Pool'Storage_Pool);

   type Slice is tagged record
      Bounds : String_Range := (1, 0);
      Ref : String_Refs.Reference;
   end record;

   Null_Slice : constant Slice := ((1, 0), Ref => <>);

end Natools.String_Slices;