package core_extended

  1. Overview
  2. Docs

Source file selector.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
module Stable = struct
  open Core_kernel.Core_kernel_stable
  open Sexplib.Type

  module Date_selector = struct
    module V1 = struct
      type t =
        | GT of Date.V1.t
        | LT of Date.V1.t
        | Between of Date.V1.t * Date.V1.t
        | On of Date.V1.t
        [@@deriving bin_io, compare, sexp]

      let t_of_sexp sexp =
        let module Date = Core_kernel.Date in
        match sexp with
        | Atom _ as d -> On (Date.t_of_sexp d)
        | List [Atom ">"; Atom _ as d]      -> GT (Date.t_of_sexp d)
        | List [Atom ">="; Atom _ as d]     -> GT (Date.add_days (Date.t_of_sexp d) (-1))
        | List [Atom "<"; Atom _ as d]      -> LT (Date.t_of_sexp d)
        | List [Atom "<="; Atom _ as d]     -> LT (Date.add_days (Date.t_of_sexp d) (1))
        | List [Atom _ as d1; Atom "><"; Atom _ as d2]
        | List [Atom "><"; Atom _ as d1; Atom _ as d2]
        | List [Atom _ as d1; Atom _ as d2] ->
          (* The basic cases (GT, LT etc.) are being matched here, since
             they are lists of two atoms. Here the check whether the first
             atom is a date is done with try-with. *)
          begin
            try
              Between ((Date.t_of_sexp d1), (Date.t_of_sexp d2))
            with _ -> t_of_sexp sexp
          end
        | _ -> t_of_sexp sexp
    end
    module Current = V1
  end

  module String_selector = struct
    module Regexp = struct
      module V1 = struct
        module T = struct
          (* This type is stable in spite of using the Re2's non-stable type because
             bin_io and sexp conversion functions are explicitly defined below. *)
          type t = string * Re.re

          let to_string (s, _) = s
          let of_regexp s = s, Re.Perl.compile_pat s
          let of_string s = of_regexp s
          let compare t1 t2 = String.V1.compare (to_string t1) (to_string t2)
        end
        include T
        include (Binable.Of_stringable.V1 [@alert "-legacy"])(T)

        let t_of_sexp sexp =
          let open Core_kernel in
          let open Poly in
          let fail () =
            of_sexp_error "expected string bounded with / on both sides" sexp
          in
          match sexp with
          | List _ -> of_sexp_error "expected Atom" sexp
          | Atom s ->
            if String.length s < 2 then fail ()
            else if s.[0] = '/' && s.[String.length s - 1] = '/' then
              let s = String.sub s ~pos:1 ~len:(String.length s - 2) in
              of_regexp s
            else fail ()

        let sexp_of_t (s, _) = Sexp.V1.Atom ("/" ^ s ^ "/")
      end

      module Current = V1
    end

    module V1 = struct
      type t =
        | Equal of string list
        | Matches of Regexp.V1.t list
        | Mixed of [ `Regexp of Regexp.V1.t | `Literal of string ] list
        [@@deriving bin_io, compare, sexp]

      let t_of_sexp sexp =
        let parse_atom a =
          match a with
          | List _ -> assert false
          | Atom s ->
            if Core_kernel.(let open Poly in
               String.length s >= 1 && s.[0] = '/')
            then `Regexp (Regexp.V1.t_of_sexp a)
            else `Literal s
        in
        try
          match sexp with
          | Atom _ as a ->
            begin match parse_atom a with
            | `Regexp r -> Matches [r]
            | `Literal s -> Equal [s]
            end
          | List l ->
            Mixed
              (Core_kernel.List.map l ~f:(fun sexp ->
                match sexp with
                | List _ -> Core_kernel.of_sexp_error "expected Atom" sexp
                | Atom _ as a -> parse_atom a))
        with
        | e -> try t_of_sexp sexp with _ -> raise e
    end
    module Current = V1
  end

  module String_list_selector = struct
    module V1 = struct
      type t = string list [@@deriving bin_io, sexp]

      let t_of_sexp sexp =
        match sexp with
        | Sexp.V1.Atom s -> [s]
        | _ -> t_of_sexp sexp
    end
    module Current = V1
  end

end


open Core_kernel
open Poly



module type Selector = sig
  type selector
  type value

  val eval : selector -> value -> bool
end

module Date_selector = struct
  include Stable.Date_selector.Current

  type selector = t
  type value = Date.t

  let eval t d =
    match t with
    | GT gtd           -> Date.(>) d gtd
    | LT ltd           -> Date.(<) d ltd
    | Between (d1, d2) -> Date.(>=) d d1 && Date.(<=) d d2
    | On ond           -> Date.(=) d ond
end

module String_selector = struct
  module Regexp : sig
    type t = Stable.String_selector.Regexp.Current.t
    [@@deriving bin_io, sexp]

    val of_regexp : string -> t
    val to_string : t -> string
    val matches   : t -> string -> bool
    val to_regexp : t -> Re.re
  end = struct
    include Stable.String_selector.Regexp.Current

    let to_regexp (_, p) = p
    let matches (_, rex) s =
      Re.execp rex s
  end

  include Stable.String_selector.Current

  type selector = t
  type value = String.t

  let eval t s =
    match t with
    | Equal el -> Option.is_some (List.find el ~f:(fun e -> e = s))
    | Matches ml -> Option.is_some (List.find ml ~f:(fun rex -> Regexp.matches rex s))
    | Mixed ml ->
      Option.is_some (List.find ml ~f:(function
        | `Regexp rex -> Regexp.matches rex s
        | `Literal l -> l = s))
end

module String_list_selector = struct
  include Stable.String_list_selector.Current

  type selector = t
  type value = string

  let eval t s =
    match List.find t ~f:(fun m -> m = s) with
    | None   -> false
    | Some _ -> true
end
OCaml

Innovation. Community. Security.