A collection of experiments, more or less organized.
Initialize Pidgin
+227
+105
lib/pidgin/repr.ml
+105
lib/pidgin/repr.ml
···
1
+
module Fields = Stdlib.Map.Make (String)
2
+
3
+
type t =
4
+
| Null
5
+
| Unit
6
+
| Bool of bool
7
+
| Int of int
8
+
| Int64 of int64
9
+
| Float of float
10
+
| Char of char
11
+
| String of string
12
+
| Pair of t * t
13
+
| List of t list
14
+
| Constr of string * t option
15
+
| Record of fields
16
+
17
+
and fields = t Fields.t
18
+
19
+
type 'a conv = 'a -> t
20
+
21
+
let use f conv x = conv (f x)
22
+
23
+
module Lit = struct
24
+
let null = Null
25
+
let unit = Unit
26
+
let true_ = Bool true
27
+
let false_ = Bool false
28
+
let pair' (a, b) = Pair (a, b)
29
+
let pair a b = pair' (a, b)
30
+
let triple' (a, b, c) = pair a (pair b c)
31
+
let triple a b c = triple' (a, b, c)
32
+
let quad' (a, b, c, d) = pair a (pair b (pair c d))
33
+
let quad a b c d = quad' (a, b, c, d)
34
+
let quint' (a, b, c, d, e) = pair a (pair b (pair c (pair d e)))
35
+
let quint a b c d e = quint' (a, b, c, d, e)
36
+
let constr ?value key = Constr (String.(trim @@ lowercase_ascii key), value)
37
+
let list xs = List xs
38
+
let left value = constr ~value "left"
39
+
let right value = constr ~value "right"
40
+
let ok value = constr ~value "ok"
41
+
let error value = constr ~value "error"
42
+
end
43
+
44
+
let null _ = Lit.null
45
+
let unit _ = Lit.unit
46
+
let bool b = Bool b
47
+
let int i = Int i
48
+
let int64 i = Int64 i
49
+
let float f = Float f
50
+
let string s = String s
51
+
let char c = Char c
52
+
let pair' conv_a conv_b (a, b) = Lit.pair (conv_a a) (conv_b b)
53
+
let pair conv_a conv_b a b = pair' conv_a conv_b (a, b)
54
+
55
+
let triple' conv_a conv_b conv_c (a, b, c) =
56
+
pair' conv_a (pair' conv_b conv_c) (a, (b, c))
57
+
;;
58
+
59
+
let quad' conv_a conv_b conv_c conv_d (a, b, c, d) =
60
+
pair' conv_a (pair' conv_b (pair' conv_c conv_d)) (a, (b, (c, d)))
61
+
;;
62
+
63
+
let quint' conv_a conv_b conv_c conv_d conv_e (a, b, c, d, e) =
64
+
pair'
65
+
conv_a
66
+
(pair' conv_b (pair' conv_c (pair' conv_d conv_e)))
67
+
(a, (b, (c, (d, e))))
68
+
;;
69
+
70
+
let triple conv_a conv_b conv_c a b c = triple' conv_a conv_b conv_c (a, b, c)
71
+
72
+
let quad conv_a conv_b conv_c conv_d a b c d =
73
+
quad' conv_a conv_b conv_c conv_d (a, b, c, d)
74
+
;;
75
+
76
+
let quint conv_a conv_b conv_c conv_d conv_e a b c d e =
77
+
quint' conv_a conv_b conv_c conv_d conv_e (a, b, c, d, e)
78
+
;;
79
+
80
+
let sum f x =
81
+
let name, value = f x in
82
+
Lit.constr ?value name
83
+
;;
84
+
85
+
let list conv xs = xs |> List.map conv |> Lit.list
86
+
let record fields = Record (Fields.of_list fields)
87
+
let option some = Option.fold ~none:Lit.null ~some
88
+
89
+
let result ok err =
90
+
sum (function
91
+
| Ok x -> "ok", Some (ok x)
92
+
| Error x -> "error", Some (err x))
93
+
;;
94
+
95
+
let either left right =
96
+
sum (function
97
+
| Either.Left x -> "left", Some (left x)
98
+
| Right x -> "right", Some (right x))
99
+
;;
100
+
101
+
module Infix = struct
102
+
let ( <$> ) = use
103
+
end
104
+
105
+
include Infix
+119
lib/pidgin/repr.mli
+119
lib/pidgin/repr.mli
···
1
+
(** Representation of generic language. *)
2
+
3
+
(** {1 Types} *)
4
+
5
+
(** All the terms of the language. *)
6
+
type t = private
7
+
| Null
8
+
| Unit
9
+
| Bool of bool
10
+
| Int of int
11
+
| Int64 of int64
12
+
| Float of float
13
+
| Char of char
14
+
| String of string
15
+
| Pair of t * t
16
+
| List of t list
17
+
| Constr of string * t option
18
+
| Record of fields
19
+
20
+
(** Map for record fields. *)
21
+
and fields
22
+
23
+
(** A converter from regular OCaml value to {!type:t}. *)
24
+
type 'a conv = 'a -> t
25
+
26
+
(** {1 Building values} *)
27
+
28
+
(** {2 Literal values}
29
+
Describes literal terms, without helpers *)
30
+
31
+
module Lit : sig
32
+
val null : t
33
+
val unit : t
34
+
val true_ : t
35
+
val false_ : t
36
+
val pair' : t * t -> t
37
+
val pair : t -> t -> t
38
+
val triple' : t * t * t -> t
39
+
val triple : t -> t -> t -> t
40
+
val quad' : t * t * t * t -> t
41
+
val quad : t -> t -> t -> t -> t
42
+
val quint' : t * t * t * t * t -> t
43
+
val quint : t -> t -> t -> t -> t -> t
44
+
val list : t list -> t
45
+
val constr : ?value:t -> string -> t
46
+
val left : t -> t
47
+
val right : t -> t
48
+
val ok : t -> t
49
+
val error : t -> t
50
+
end
51
+
52
+
(** {2 Converters} *)
53
+
54
+
val null : 'a conv
55
+
val unit : 'a conv
56
+
val bool : bool conv
57
+
val int : int conv
58
+
val int64 : int64 conv
59
+
val float : float conv
60
+
val string : string conv
61
+
val char : char conv
62
+
val pair' : 'a conv -> 'b conv -> ('a * 'b) conv
63
+
val pair : 'a conv -> 'b conv -> 'a -> 'b conv
64
+
val triple' : ('a -> t) -> ('b -> t) -> ('c -> t) -> ('a * 'b * 'c) conv
65
+
val triple : ('a -> t) -> ('b -> t) -> ('c -> t) -> 'a -> 'b -> 'c conv
66
+
67
+
val quad'
68
+
: ('a -> t)
69
+
-> ('b -> t)
70
+
-> ('c -> t)
71
+
-> ('d -> t)
72
+
-> ('a * 'b * 'c * 'd) conv
73
+
74
+
val quad
75
+
: ('a -> t)
76
+
-> ('b -> t)
77
+
-> ('c -> t)
78
+
-> ('d -> t)
79
+
-> 'a
80
+
-> 'b
81
+
-> 'c
82
+
-> 'd conv
83
+
84
+
val quint'
85
+
: ('a -> t)
86
+
-> ('b -> t)
87
+
-> ('c -> t)
88
+
-> ('d -> t)
89
+
-> ('e -> t)
90
+
-> ('a * 'b * 'c * 'd * 'e) conv
91
+
92
+
val quint
93
+
: ('a -> t)
94
+
-> ('b -> t)
95
+
-> ('c -> t)
96
+
-> ('d -> t)
97
+
-> ('e -> t)
98
+
-> 'a
99
+
-> 'b
100
+
-> 'c
101
+
-> 'd
102
+
-> 'e conv
103
+
104
+
val sum : ('a -> string * t option) -> 'a conv
105
+
val list : 'a conv -> 'a list conv
106
+
val record : (string * t) list conv
107
+
val option : 'a conv -> 'a option conv
108
+
val result : 'ok conv -> 'err conv -> ('ok, 'err) result conv
109
+
val either : 'left conv -> 'right conv -> ('left, 'right) Either.t conv
110
+
111
+
(** {1 Helpers} *)
112
+
113
+
val use : ('b -> 'a) -> 'a conv -> 'b conv
114
+
115
+
module Infix : sig
116
+
val ( <$> ) : ('b -> 'a) -> 'a conv -> 'b conv
117
+
end
118
+
119
+
include module type of Infix