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
|
(* TEST
toplevel;
*)
(* Typed names *)
module Msg : sig
type 'a tag = private ..
type result = Result : 'a tag * 'a -> result
val write : 'a tag -> 'a -> unit
val read : unit -> result
type 'a tag += Int : int tag
module type Desc = sig
type t
val label : string
val write : t -> string
val read : string -> t
end
module Define (D : Desc) : sig
type 'a tag += C : D.t tag
end
end = struct
type 'a tag = ..
type ktag = T : 'a tag -> ktag
type 'a kind =
{ tag : 'a tag;
label : string;
write : 'a -> string;
read : string -> 'a; }
type rkind = K : 'a kind -> rkind
type wkind = { f : 'a . 'a tag -> 'a kind }
let readTbl : (string, rkind) Hashtbl.t = Hashtbl.create 13
let writeTbl : (ktag, wkind) Hashtbl.t = Hashtbl.create 13
let read_raw () : string * string = raise (Failure "Not implemented")
type result = Result : 'a tag * 'a -> result
let read () =
let label, content = read_raw () in
let K k = Hashtbl.find readTbl label in
let body = k.read content in
Result(k.tag, body)
let write_raw (label : string) (content : string) =
raise (Failure "Not implemented")
let write (tag : 'a tag) (body : 'a) =
let {f} = Hashtbl.find writeTbl (T tag) in
let k = f tag in
let content = k.write body in
write_raw k.label content
(* Add int kind *)
type 'a tag += Int : int tag
let ik =
{ tag = Int;
label = "int";
write = Int.to_string;
read = int_of_string }
let () = Hashtbl.add readTbl "int" (K ik)
let () =
let f (type t) (i : t tag) : t kind =
match i with
Int -> ik
| _ -> assert false
in
Hashtbl.add writeTbl (T Int) {f}
(* Support user defined kinds *)
module type Desc = sig
type t
val label : string
val write : t -> string
val read : string -> t
end
module Define (D : Desc) = struct
type 'a tag += C : D.t tag
let k =
{ tag = C;
label = D.label;
write = D.write;
read = D.read }
let () = Hashtbl.add readTbl D.label (K k)
let () =
let f (type t) (c : t tag) : t kind =
match c with
C -> k
| _ -> assert false
in
Hashtbl.add writeTbl (T C) {f}
end
end;;
let write_int i = Msg.write Msg.Int i;;
module StrM = Msg.Define(struct
type t = string
let label = "string"
let read s = s
let write s = s
end);;
type 'a Msg.tag += String = StrM.C;;
let write_string s = Msg.write String s;;
let read_one () =
let Msg.Result(tag, body) = Msg.read () in
match tag with
Msg.Int -> print_int body
| String -> print_string body
| _ -> print_string "Unknown";;
|
