Source file common.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
open! Core
open Stable_witness.Export
include Common_intf

module Make (T : Types.Type) (Basis : Basis) = struct
  module Stable = struct
    (* Our stable serializations are not straightforward, as they parse and canonicalize
       strings. Rather than opening only [Core.Core_stable], we use as much of [Core] as
       we need, and make sure to write thorough tests for the stable serializations. *)

    module V1 = struct
      include T

      let[@cold] raise_invalid ~name string =
        raise_s
          [%sexp
            (Printf.sprintf "%s.%s: invalid string" Basis.module_name name : string)
            , (string : string)]
      ;;

      let[@cold] raise_non_canonical ~name string =
        raise_s
          [%sexp
            (Printf.sprintf "%s.%s: non-canonical representation" Basis.module_name name
              : string)
            , (string : string)]
      ;;

      let of_string string =
        if not (Basis.is_valid string)
        then raise_invalid ~name:"of_string" string
        else if not (Basis.is_canonical string)
        then Expert.unchecked_of_canonical_string (Basis.canonicalize string)
        else Expert.unchecked_of_canonical_string string
      ;;

      let invariant t =
        let string = to_string t in
        if not (Basis.is_valid string)
        then raise_invalid ~name:"invariant" string
        else if not (Basis.is_canonical string)
        then raise_non_canonical ~name:"invariant" string
      ;;

      include Binable.Of_stringable_with_uuid (struct
        type nonrec t = t

        let of_string = of_string
        let to_string = to_string
        let caller_identity = Basis.caller_identity
      end)

      include Sexpable.Of_stringable (struct
        type nonrec t = t

        let of_string = of_string
        let to_string = to_string
      end)

      (* Path types are serialized using [of_string/to_string], and derive their stability
         from the fact that string is a primitive type. *)
      let stable_witness =
        Stable_witness.of_serializable [%stable_witness: string] of_string to_string
      ;;

      include Identifiable.Make_using_comparator (struct
        type nonrec t = t [@@deriving bin_io, compare, hash, sexp]
        type nonrec comparator_witness = comparator_witness

        let of_string = of_string
        let to_string = to_string
        let comparator = comparator
        let module_name = Basis.module_name
      end)

      (* Include [T] again to make sure we export the fast versions of any underlying
         operations. *)
      include T
    end
  end

  include Stable.V1

  let arg_type =
    Command.Arg_type.create of_string ~complete:(fun (_ : Univ_map.t) ~part ->
      try Basis.autocomplete part with
      | (_ : exn)
      (* don't mask exceptions during inline tests *)
        when not Ppx_inline_test_lib.am_running -> [])
  ;;
end