libadalang_tools_22.0.0_c9028428/src/utils-string_utilities.ads

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
------------------------------------------------------------------------------
--                                                                          --
--                             Libadalang Tools                             --
--                                                                          --
--                      Copyright (C) 2012-2021, AdaCore                    --
--                                                                          --
-- Libadalang Tools  is free software; you can redistribute it and/or modi- --
-- fy  it  under  terms of the  GNU General Public License  as published by --
-- the Free Software Foundation;  either version 3, or (at your option) any --
-- later version. This software  is distributed in the hope that it will be --
-- useful but  WITHOUT  ANY  WARRANTY; without even the implied warranty of --
-- MERCHANTABILITY  or  FITNESS  FOR A PARTICULAR PURPOSE.                  --
--                                                                          --
-- As a special  exception  under  Section 7  of  GPL  version 3,  you are  --
-- granted additional  permissions described in the  GCC  Runtime  Library  --
-- Exception, version 3.1, as published by the Free Software Foundation.    --
--                                                                          --
-- You should have received a copy of the GNU General Public License and a  --
-- copy of the GCC Runtime Library Exception along with this program;  see  --
-- the files COPYING3 and COPYING.RUNTIME respectively.  If not, see        --
-- <http://www.gnu.org/licenses/>.                                          --
------------------------------------------------------------------------------

with Unchecked_Deallocation;
with Ada.Containers.Hashed_Maps;
with Ada.Containers.Ordered_Sets;
with Ada.Containers.Indefinite_Ordered_Sets;
with Ada.Containers.Indefinite_Vectors;
with Ada.Strings.UTF_Encoding.Wide_Strings;
with Ada.Strings.Wide_Fixed;

with GNAT.OS_Lib; use GNAT.OS_Lib;
with GNAT.String_Hash;

package Utils.String_Utilities is

   --  String-related utilities

   subtype W_Char is Wide_Character;
   subtype W_Str is Wide_String;
   type W_Str_Access is access all W_Str;
   procedure Free is new Unchecked_Deallocation (W_Str, W_Str_Access);

   W_NUL : constant W_Char := W_Char'Val (Character'Pos (ASCII.NUL));
   W_LF  : constant W_Char := W_Char'Val (Character'Pos (ASCII.LF));
   W_CR  : constant W_Char := W_Char'Val (Character'Pos (ASCII.CR));
   W_FF  : constant W_Char := W_Char'Val (Character'Pos (ASCII.FF));

   W_HT : constant W_Char := W_Char'Val (Character'Pos (ASCII.HT));
   W_VT : constant W_Char := W_Char'Val (Character'Pos (ASCII.VT));

   NL : constant W_Char := W_LF;
   --  Character used to represent new-line in output.

   function Image (X : Integer) return String;
   --  Return X'Img without the annoying blank.

   type Modular is mod 2**32;
   function Image (X : Modular) return String;

   function Capitalize (S : String) return String;
   function Capitalize (S : W_Str) return W_Str;
   procedure Capitalize (S : in out String);
   procedure Capitalize (S : in out W_Str);
   --  Capitalizes the first letter, and all letters following a
   --  non-letter-or-digit. Converts all others to lower case.

   procedure To_Lower (S : in out String);
   procedure To_Lower (S : in out W_Str);
   --  Same as the ones in Ada.[Wide_]Characters.Handling, except we use a
   --  procedure to avoid inefficient secondary stack usage.

   function Escape_String_Literal (S : String) return String;
   --  Double all the double quotes

   function Slide (X : String) return String;
   function Slide (X : W_Str) return W_Str;
   --  Return X with X'First = 1

   function Find
     (Source : Wide_String;
      Pattern : Wide_String) return Natural is
      (Ada.Strings.Wide_Fixed.Index (Source, Pattern));

   function Has_Prefix (X, Prefix : String) return Boolean;
   function Has_Prefix (X, Prefix : W_Str) return Boolean;
   --  True if Prefix is at the beginning of X, case insensitive. For example,
   --  Has_Prefix("An_Identifier", Prefix => "an_") is True.

   function Has_Suffix (X, Suffix : String) return Boolean;
   function Has_Suffix (X, Suffix : W_Str) return Boolean;
   --  True if Suffix is at the end of X, case insensitive

   function Strip_Prefix (X, Prefix : String) return String;
   function Strip_Prefix (X, Prefix : W_Str) return W_Str;
   --  If Prefix is at the beginning of X (case insensitive), strip it off

   function Strip_Suffix (X, Suffix : String) return String;
   function Strip_Suffix (X, Suffix : W_Str) return W_Str;
   --  If Suffix is at the end of X (case insensitive), strip it off

   function Strip_Article (S : String) return String;
   function Strip_Article (S : W_Str) return W_Str;
   --  Removes a leading "A_" or "An_" from the string. Case insensitive.

   function Replace_All (S, From, To : W_Str) return W_Str;
   function Replace_All
     (S        : W_Str_Access;
      From, To : W_Str)
      return     W_Str_Access;
   --  Replaces all occurrences of From in S with To. In the second form, S is
   --  freed.

   function Must_Replace (S, From, To : W_Str) return W_Str;
   function Must_Replace
     (S        : W_Str_Access;
      From, To : W_Str)
      return     W_Str_Access;
   --  Same as Replace_All, except these require that at least one substring be
   --  replaced.

   function Replace_String (S, From, To : String) return String;
   --  Same as Replace_All, but for String

   subtype Digit is Integer range 0 .. 9;
   function Char_To_Digit (C : Character) return Digit;
   function Char_To_Digit (C : W_Char) return Digit;
   --  Converts '0' ==> 0, etc

   function Count_Chars (S : String; C : Character) return Natural;
   --  Number of occurrences of C in S

   BOM_8 : constant Ada.Strings.UTF_Encoding.UTF_8_String :=
     Ada.Strings.UTF_Encoding.BOM_8;

   function To_UTF8
     (Item       : W_Str;
      Output_BOM : Boolean := False)
      return       Ada.Strings.UTF_Encoding.UTF_8_String renames
     Ada.Strings.UTF_Encoding.Wide_Strings.Encode;

   function From_UTF8
     (Item : Ada.Strings.UTF_Encoding.UTF_8_String)
      return W_Str renames
     Ada.Strings.UTF_Encoding.Wide_Strings.Decode;

   procedure Text_IO_Put_Char (C : Character);
   procedure Wide_Text_IO_Put_Char (C : Character);
   procedure Wide_Text_IO_Put_Char (C : W_Char);
   --  Put C to Current_Output. Used to instantiate Formatted_Output.

   procedure Std_Err_Put_Char (C : Character);
   --  Put C to Standard_Error. Used to instantiate Formatted_Stderr and
   --  Dbg_Out.

   function Read_File (FD : File_Descriptor) return String_Access;
   function Read_File (File_Name : String) return String_Access;
   --  Reads the entire contents of the file

   File_Not_Found : exception;
   --  Raised by Read_File if it can't find the file. The Exception_Message is
   --  appropriate for printing.

   procedure Write_File (FD : File_Descriptor; S : String);
   procedure Write_File (File_Name : String; S : String);
   --  Write S to the file, overwriting it if it already exists

   procedure Parallel_Make_Dir
     (New_Directory : String; Give_Message : Boolean := False);
   --  Creates a new directory with the given name if it does not already
   --  exist, creating parent directories as necessary. This is safe for
   --  parallel processing in the following sense: if two or more processes try
   --  to create the same directory name at the same time, the directory will
   --  be created (once), and no exception will be raised. We use this in case
   --  an ASIS tool is called from gprbuild in parallel using the -j switch.
   --  If Give_Message is True and the directory is successfully created, a
   --  message saying so is printed.
   --  Why don't we create the directory in the outer invocation, so it won't
   --  happen in parallel???

   Move_Failure : exception;
   procedure Move_File (Old_Name : String; New_Name : String);
   --  Same as GNAT.OS_Lib.Rename_File, but overwrites New_Name if it
   --  already exists. On failure, raises Move_Failure with an appropriate
   --  Exception_Message.

   package String_Vectors is
      new Ada.Containers.Indefinite_Vectors (Positive, String);
   subtype String_Vector is String_Vectors.Vector;

   package String_Sets is new Ada.Containers.Indefinite_Ordered_Sets (String);
   subtype String_Set is String_Sets.Set;

   function String_Less
     (S1, S2 : String_Access) return Boolean is
       (S1.all < S2.all);

   function String_Equal
     (S1, S2 : String_Access) return Boolean is
       (S1.all = S2.all);

   package String_Access_Sets is new Ada.Containers.Ordered_Sets
     (String_Access, "<" => String_Less, "=" => String_Equal);
   subtype String_Access_Set is String_Access_Sets.Set;

   function Hash is new GNAT.String_Hash.Hash
     (Character, String, Ada.Containers.Hash_Type);

   function Hash
     (S : String_Access) return Ada.Containers.Hash_Type is
       (Hash (S.all));

   function Equivalent_Strings
     (S1, S2 : String_Access) return Boolean is
       (S1.all = S2.all);

   package String_String_Maps is new Ada.Containers.Hashed_Maps
     (Key_Type        => String_Access,
      Element_Type    => String_Access,
      Hash            => Hash,
      Equivalent_Keys => Equivalent_Strings);
   subtype String_String_Map is String_String_Maps.Map;

   package String_String_List_Maps is new Ada.Containers.Hashed_Maps
     (Key_Type        => String_Access,
      Element_Type    => String_List_Access,
      Hash            => Hash,
      Equivalent_Keys => Equivalent_Strings);
   subtype String_String_List_Map is String_String_List_Maps.Map;

   ---------------------
   -- Bounded Strings --
   ---------------------

   --  Ada.Strings.Bounded_Strings is too much hassle; we use a simple
   --  bounded string type here.

   type Bounded_Str (Max_Length : Natural := 2**16 - 1) is limited record
      Length : Natural := 0;
      Chars  : String (1 .. Max_Length);
   end record;

   procedure Append (X : in out Bounded_Str; C : Character);
   procedure Append (X : in out Bounded_Str; S : String);
   function To_String (X : Bounded_Str) return String;
   function "+" (X : Bounded_Str) return String renames To_String;

   type Bounded_W_Str (Max_Length : Natural := 2**16 - 1) is limited record
      Length : Natural := 0;
      Chars  : W_Str (1 .. Max_Length);
   end record;

   procedure Append (X : in out Bounded_W_Str; C : W_Char);
   procedure Append (X : in out Bounded_W_Str; S : W_Str);
   function To_String (X : Bounded_W_Str) return W_Str;
   function "+" (X : Bounded_W_Str) return W_Str renames To_String;

end Utils.String_Utilities;