package ppx_inline_test_nobase

  1. Overview
  2. Docs
Legend:
Page
Library
Module
Module type
Parameter
Class
Class type
Source

Source file search_pattern.ml

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
259
260
261
262
263
264
265
266
267
open String
let caseless_equal c1 c2 =
  Char.equal (Char.lowercase_ascii c1) (Char.lowercase_ascii c2)

module Search_pattern0 = struct
  type t =
    { pattern : string
    ; case_sensitive : bool
    ; kmp_array : int array
    }

(*   let sexp_of_t { pattern; case_sensitive; kmp_array = _ } : Sexp.t =
    List
      [ List [ Atom "pattern"; sexp_of_string pattern ]
      ; List [ Atom "case_sensitive"; sexp_of_bool case_sensitive ]
      ]
  ;; *)

  let pattern t = t.pattern
  let case_sensitive t = t.case_sensitive

  (* Find max number of matched characters at [next_text_char], given the current
     [matched_chars]. Try to extend the current match, if chars don't match, try to match
     fewer chars. If chars match then extend the match. *)
  let kmp_internal_loop ~matched_chars ~next_text_char ~pattern ~kmp_array ~char_equal =
    let matched_chars = ref matched_chars in
    while
      !matched_chars > 0
      && not (char_equal next_text_char (String.unsafe_get pattern !matched_chars))
    do
      matched_chars := Array.unsafe_get kmp_array (!matched_chars - 1)
    done;
    if char_equal next_text_char (String.unsafe_get pattern !matched_chars)
    then matched_chars := !matched_chars + 1;
    !matched_chars
  ;;

  let get_char_equal ~case_sensitive =
    match case_sensitive with
    | true -> Char.equal
    | false -> caseless_equal
  ;;

  (* Classic KMP pre-processing of the pattern: build the int array, which, for each i,
     contains the length of the longest non-trivial prefix of s which is equal to a suffix
     ending at s.[i] *)
  let create pattern ~case_sensitive =
    let n = length pattern in
    let kmp_array = Stdlib.Array.make n (-1) in
    if n > 0
    then (
      let char_equal = get_char_equal ~case_sensitive in
      Array.unsafe_set kmp_array 0 0;
      let matched_chars = ref 0 in
      for i = 1 to n - 1 do
        matched_chars
        := kmp_internal_loop
             ~matched_chars:!matched_chars
             ~next_text_char:(unsafe_get pattern i)
             ~pattern
             ~kmp_array
             ~char_equal;
        Array.unsafe_set kmp_array i !matched_chars
      done);
    { pattern; case_sensitive; kmp_array }
  ;;

  (* Classic KMP: use the pre-processed pattern to optimize look-behinds on non-matches.
     We return int to avoid allocation in [index_exn]. -1 means no match. *)
  let index_internal ?(pos = 0) { pattern; case_sensitive; kmp_array } ~in_:text =
    if pos < 0 || pos > length text - length pattern
    then -1
    else (
      let char_equal = get_char_equal ~case_sensitive in
      let j = ref pos in
      let matched_chars = ref 0 in
      let k = length pattern in
      let n = length text in
      while !j < n && !matched_chars < k do
        let next_text_char = unsafe_get text !j in
        matched_chars
        := kmp_internal_loop
             ~matched_chars:!matched_chars
             ~next_text_char
             ~pattern
             ~kmp_array
             ~char_equal;
        j := !j + 1
      done;
      if !matched_chars = k then !j - k else -1)
  ;;

  let matches t str = index_internal t ~in_:str >= 0

  let index ?pos t ~in_ =
    let p = index_internal ?pos t ~in_ in
    if p < 0 then None else Some p
  ;;

  let index_exn ?pos t ~in_ =
    let p = index_internal ?pos t ~in_ in
    if p >= 0
    then p
    else
      failwith (Printf.sprintf  "Substring %S not found " t.pattern)
      (* raise_s
        (Sexp.message "Substring not found" [ "substring", sexp_of_string t.pattern ]) *)
  ;;

  let index_all { pattern; case_sensitive; kmp_array } ~may_overlap ~in_:text =
    if length pattern = 0
    then List.init (1 + length text) Fun.id
    else (
      let char_equal = get_char_equal ~case_sensitive in
      let matched_chars = ref 0 in
      let k = length pattern in
      let n = length text in
      let found = ref [] in
      for j = 0 to n do
        if !matched_chars = k
        then (
          found := (j - k) :: !found;
          (* we just found a match in the previous iteration *)
          match may_overlap with
          | true -> matched_chars := Array.unsafe_get kmp_array (k - 1)
          | false -> matched_chars := 0);
        if j < n
        then (
          let next_text_char = unsafe_get text j in
          matched_chars
          := kmp_internal_loop
               ~matched_chars:!matched_chars
               ~next_text_char
               ~pattern
               ~kmp_array
               ~char_equal)
      done;
      List.rev !found)
  ;;

  let replace_first ?pos t ~in_:s ~with_ =
    match index ?pos t ~in_:s with
    | None -> s
    | Some i ->
      let len_s = length s in
      let len_t = length t.pattern in
      let len_with = length with_ in
      let dst = Bytes.create (len_s + len_with - len_t) in
      BytesLabels.blit_string ~src:s ~src_pos:0 ~dst ~dst_pos:0 ~len:i;
      BytesLabels.blit_string ~src:with_ ~src_pos:0 ~dst ~dst_pos:i ~len:len_with;
      BytesLabels.blit_string
        ~src:s
        ~src_pos:(i + len_t)
        ~dst
        ~dst_pos:(i + len_with)
        ~len:(len_s - i - len_t);
      Bytes.unsafe_to_string dst
  ;;


  let replace_all t ~in_:s ~with_ =
    let matches = index_all t ~may_overlap:false ~in_:s in
    match matches with
    | [] -> s
    | _ :: _ ->
      let len_s = length s in
      let len_t = length t.pattern in
      let len_with = length with_ in
      let num_matches = List.length matches in
      let dst = Bytes.create (len_s + ((len_with - len_t) * num_matches)) in
      let next_dst_pos = ref 0 in
      let next_src_pos = ref 0 in
      ListLabels.iter matches ~f:(fun i ->
        let len = i - !next_src_pos in
        BytesLabels.blit_string ~src:s ~src_pos:!next_src_pos ~dst ~dst_pos:!next_dst_pos ~len;
        BytesLabels.blit_string
          ~src:with_
          ~src_pos:0
          ~dst
          ~dst_pos:(!next_dst_pos + len)
          ~len:len_with;
        next_dst_pos := !next_dst_pos + len + len_with;
        next_src_pos := !next_src_pos + len + len_t);
      BytesLabels.blit_string
        ~src:s
        ~src_pos:!next_src_pos
        ~dst
        ~dst_pos:!next_dst_pos
        ~len:(len_s - !next_src_pos);
      Bytes.unsafe_to_string dst
  ;;

  let split_on t s =
    let pattern_len = String.length t.pattern in
    let matches = index_all t ~may_overlap:false ~in_:s in
    ListLabels.map2
      (-pattern_len :: matches)
      (matches @ [ String.length s ])
      ~f:(fun i j -> StringLabels.sub s ~pos:(i + pattern_len) ~len:(j - i - pattern_len))
  ;;
(*
  module Private = struct
    type public = t

    type nonrec t = t =
      { pattern : string
      ; case_sensitive : bool
      ; kmp_array : int array
      }
    [@@deriving_inline equal, sexp_of]

    let equal =
      (fun a__003_ b__004_ ->
         if Stdlib.( == ) a__003_ b__004_
         then true
         else
           Stdlib.( && )
             (equal_string a__003_.pattern b__004_.pattern)
             (Stdlib.( && )
                (equal_bool a__003_.case_sensitive b__004_.case_sensitive)
                (equal_array equal_int a__003_.kmp_array b__004_.kmp_array))
           : t -> t -> bool)
    ;;

    let sexp_of_t =
      (fun { pattern = pattern__008_
           ; case_sensitive = case_sensitive__010_
           ; kmp_array = kmp_array__012_
           } ->
        let bnds__007_ = ([] : _ Stdlib.List.t) in
        let bnds__007_ =
          let arg__013_ = sexp_of_array sexp_of_int kmp_array__012_ in
          (Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "kmp_array"; arg__013_ ] :: bnds__007_
           : _ Stdlib.List.t)
        in
        let bnds__007_ =
          let arg__011_ = sexp_of_bool case_sensitive__010_ in
          (Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "case_sensitive"; arg__011_ ]
           :: bnds__007_
           : _ Stdlib.List.t)
        in
        let bnds__007_ =
          let arg__009_ = sexp_of_string pattern__008_ in
          (Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "pattern"; arg__009_ ] :: bnds__007_
           : _ Stdlib.List.t)
        in
        Sexplib0.Sexp.List bnds__007_
        : t -> Sexplib0.Sexp.t)
    ;;

    [@@@end]

    let representation = Fun.id
  end *)
end
  include Search_pattern0

  let create ?(case_sensitive = true) pattern = create pattern ~case_sensitive

let substr_index_gen ~case_sensitive ?pos t ~pattern =
  index ?pos (create ~case_sensitive pattern) ~in_:t
;;

let is_substring_gen ~case_sensitive t ~substring =
  Option.is_some (substr_index_gen t ~pattern:substring ~case_sensitive)
;;
let is_substring = is_substring_gen ~case_sensitive:true
OCaml

Innovation. Community. Security.