blob: b78cf5f4c470109bc9ba86a0bc1aa89c42748fcb (
plain)
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
|
(*─────────────────────────────────────────────────────────────────────────────┐
│ SPDX-FileCopyrightText: 2025 toastal <https://toast.al/contact/> │
│ SPDX-License-Identifier: LGPL-2.1-or-later WITH OCaml-LGPL-linking-exception │
└─────────────────────────────────────────────────────────────────────────────*)
module Name = struct
type t =
Name of UTF8.t
[@@unboxed]
[@@deriving eq, qcheck]
let [@inline]make n = Name n
let [@inline]take (Name n) = n
let pp fmt name =
(* it’s okay to have fun *)
Fmt.pf fmt "「%s」" (take name)
let show = Fmt.str "%a" pp
(* String.compare but with nixpkgs at the top *)
let compare (Name a) (Name b) =
let prio x =
if x = "nixpkgs" then
0
else if String.starts_with ~prefix: "nixpkgs" x then
1
else
2
in
match Stdlib.compare (prio a) (prio b) with
| 0 -> String.compare a b
| d -> d
end
module NameHashtbl : sig
type key = Name.t
include Hashtbl.S with type key := Name.t
end
= Hashtbl.Make(struct
type t = Name.t
let equal = Name.equal
let hash n = Hashtbl.hash (Name.take n)
let gen gen_val =
let open QCheck.Gen in
let* n = int_bound 32 in
let* vals = list_size (return n) (pair Name.gen gen_val) in
let htbl = Hashtbl.create n in
List.iter (fun (k, v) -> Hashtbl.add htbl k v) vals;
return htbl
end)
module NameMap = struct
module Impl = Map.Make(struct
type t = Name.t
let compare = Name.compare
end)
include Impl
type 'a t = 'a Impl.t
let pp pp_value fmt map =
Fmt.list
~sep: (Fmt.any "; ")
(fun ppf (key, value) -> Fmt.pf ppf "%s ↦ %a" (Name.take key) pp_value value)
fmt
(bindings map)
let gen gen_val =
let open QCheck.Gen in
let* n = int_bound 32 in
let* vals = list_size (return n) (pair Name.gen gen_val) in
return (List.fold_left (fun m (k, v) -> Impl.add k v m) Impl.empty vals)
let jsont ?kind ?doc (type' : 'a Jsont.t) : 'a t Jsont.t =
let name_map =
let dec_empty () = empty
and dec_add _meta key value mems = add (Name.make key) value mems
and dec_finish _meta mems = mems
and enc f mems acc =
fold (fun n v acc -> f Jsont.Meta.none (Name.take n) v acc) mems acc
in
Jsont.Object.Mems.map type' ~dec_empty ~dec_add ~dec_finish ~enc: {enc}
in
Jsont.Object.map ?kind ?doc Fun.id
|> Jsont.Object.keep_unknown name_map ~enc: Fun.id
|> Jsont.Object.finish
end
|
