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
type t =
| Null
| Bool of bool
| Int of int
| Float of float
| String of string
| List of t list
| Record of (string * t) list
let rec equal a b =
match a, b with
| Null, Null -> true
| Bool a, Bool b -> Bool.equal a b
| Int a, Int b -> Int.equal a b
| Float a, Float b -> Float.equal a b
| String a, String b -> String.equal a b
| List a, List b -> List.equal equal a b
| Record a, Record b ->
List.equal (fun (ka, va) (kb, vb) -> String.equal ka kb && equal va vb) a b
| Null, _
| Bool _, _
| Int _, _
| Float _, _
| String _, _
| List _, _
| Record _, _ -> false
;;
let rec to_string = function
| Null -> "null"
| Bool true -> "true"
| Bool false -> "false"
| Int i -> string_of_int i
| Float f -> string_of_float f
| String s -> "\"" ^ s ^ "\""
| List xs -> "[" ^ Misc.concat_with ~sep:";" to_string xs ^ "]"
| Record xs ->
"{"
^ Misc.concat_with
~sep:";"
(fun (k, v) -> "\"" ^ k ^ "\": " ^ to_string v)
xs
^ "}"
;;
type 'a conv = 'a -> t
module type PROJECTABLE = sig
type t
val to_pidgin : t conv
end
let into (type a) (module P : PROJECTABLE with type t = a) x = P.to_pidgin x
let using f conv x = conv (f x)
let replace n = using (fun _ -> n)
let null _ = Null
let bool b = Bool b
let int i = Int i
let float f = Float f
let string s = String s
let list l = List l
let list_of conv l = list @@ List.map conv l
let nel l = list (Nel.to_list l)
let nel_of conv l = list_of conv (Nel.to_list l)
let char c = string (String.make 1 c)
let record ?(normalize_keys = true) assoc =
let assoc =
if normalize_keys
then List.map (fun (k, v) -> Misc.strim k, v) assoc
else assoc
in
Record assoc
;;
let option conv = function
| None -> null ()
| Some x -> conv x
;;
let sum f x =
let constr, value = f x in
record
~normalize_keys:true
[ "constr", constr |> Misc.strim |> string; "value", value ]
;;
let pair fst snd (a, b) =
record ~normalize_keys:true [ "first", fst a; "second", snd b ]
;;
let result ~ok ~error =
sum (function
| Ok x -> "ok", ok x
| Error x -> "error", error x)
;;
let either ~left ~right =
sum (function
| Either.Left x -> "left", left x
| Either.Right x -> "right", right x)
;;
let triple f g h (a, b, c) = pair f (pair g h) (a, (b, c))
let int32 = sum (fun x -> "int32", x |> Int32.to_string |> string)
let int64 = sum (fun x -> "int64", x |> Int64.to_string |> string)
let fold ~null ~bool ~int ~float ~string ~list ~record = function
| Null -> null ()
| Bool b -> bool b
| Int i -> int i
| Float f -> float f
| String s -> string s
| List l -> list l
| Record f -> record f
;;
let fold_partial ?null ?bool ?int ?float ?string ?list ?record default x =
let default _ = default x in
let opt_or = function
| None -> default
| Some f -> f
in
fold
~null:(opt_or null)
~bool:(opt_or bool)
~int:(opt_or int)
~float:(opt_or float)
~string:(opt_or string)
~list:(opt_or list)
~record:(opt_or record)
x
;;
module Infix = struct
let ( <$> ) = using
end
include Infix