Source file ppx_h5struct.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
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
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
# 1 "ppx_h5struct.cppo.ml"
open Migrate_parsetree
open Ast_406
open Ast_mapper
open Ast_helper
open Asttypes
open Parsetree
open Longident
module Type = struct
type t =
| Float64
| Int
| Int64
| String of int
let to_string = function
| Float64 -> "Float64"
| Int -> "Int"
| Int64 -> "Int64"
| String _ -> "String"
let wsize = function
| Float64 | Int | Int64 -> 1
| String length -> (length + 7) / 8
end
module Field = struct
type t = {
id : string;
name : string;
type_ : Type.t;
ocaml_type : Longident.t;
seek : bool;
}
end
# 42 "ppx_h5struct.cppo.ml"
let rec extract_fields expression =
match expression.pexp_desc with
| Pexp_sequence (expression1, expression2) ->
extract_fields expression1 @ extract_fields expression2
| Pexp_apply ({ pexp_desc = Pexp_ident { txt = id; _ }; pexp_loc; _ }, expressions) ->
let id =
match id with
| Lident id -> id
| _ ->
raise (Location.Error (Location.error ~loc:pexp_loc (Printf.sprintf
"[%%h5struct] invalid field %s, field identifiers must be simple"
(Longident.last id))))
in
begin match expressions with
| (_, name) :: (_, type_) :: expressions ->
let name =
match name.pexp_desc with
| Pexp_constant (Pconst_string (name, _)) -> name
| _ ->
raise (Location.Error (Location.error ~loc:name.pexp_loc (Printf.sprintf
"[%%h5struct] invalid field %s, field name must be a string constant" id)))
in
let type_, ocaml_type =
match type_ with
| { pexp_desc = Pexp_construct (type_, expression_opt); pexp_loc = loc; _ } ->
begin match type_.txt with
| Lident type_ ->
begin match type_ with
| "Discrete" ->
let ocaml_type =
match expression_opt with
| Some { pexp_desc = Pexp_ident { txt; _ }; _ } -> txt
| _ ->
raise (Location.Error (Location.error ~loc (Printf.sprintf
"[%%h5struct] invalid field %s, field type Discrete requires type"
id)))
in
Type.Int, ocaml_type
| "Float64" -> Type.Float64, Longident.Lident "float"
| "Int" -> Type.Int , Longident.Lident "int"
| "Int64" -> Type.Int64 , Longident.Lident "int64"
| "String" ->
let type_ =
match expression_opt with
# 87 "ppx_h5struct.cppo.ml"
| Some { pexp_desc = Pexp_constant (Pconst_integer (length, _)); _ } ->
Type.String (int_of_string length)
# 93 "ppx_h5struct.cppo.ml"
| _ ->
raise (Location.Error (Location.error ~loc (Printf.sprintf
"[%%h5struct] invalid field %s, field type String requires length"
id)))
in
type_, Longident.Lident "string"
| _ ->
raise (Location.Error (Location.error ~loc (Printf.sprintf
"[%%h5struct] invalid field %s, unrecognized type %s" id type_)))
end
| _ ->
raise (Location.Error (Location.error ~loc (Printf.sprintf
"[%%h5struct] invalid field %s, field type must be simple" id)))
end
| _ ->
raise (Location.Error (Location.error ~loc:type_.pexp_loc (Printf.sprintf
"[%%h5struct] invalid field %s, field type must be a construct" id)))
in
let seek = ref false in
List.iter (fun (_, expression) ->
match expression.pexp_desc with
| Pexp_construct ({ txt = Lident "Seek"; _ }, None) -> seek := true
| _ ->
raise (Location.Error (Location.error ~loc:expression.pexp_loc (Printf.sprintf
"[%%h5struct] invalid field %s, unexpected modifiers" id)))) expressions;
[ { Field.id; name; type_; ocaml_type; seek = !seek } ]
| _ ->
raise (Location.Error (Location.error ~loc:pexp_loc (Printf.sprintf
"[%%h5struct] invalid field %s, exactly two arguments expected: name and type"
id)))
end
| _ ->
raise (Location.Error (Location.error ~loc:expression.pexp_loc
"[%h5struct] accepts a list of fields, \
e.g. [%h5struct time \"Time\" Int; price \"Price\" Float64]"))
let rec construct_fields_list fields loc =
match fields with
| [] -> Exp.construct ~loc { txt = Longident.Lident "[]"; loc } None;
| field :: fields ->
Exp.construct ~loc { txt = Longident.Lident "::"; loc } (Some (
Exp.tuple ~loc [
Exp.apply ~loc
(Exp.ident { txt = Longident.(
Ldot (Ldot (Lident "Hdf5_caml", "Field"), "create")); loc })
[ Nolabel, Exp.constant ~loc (Pconst_string (field.Field.name, None));
Nolabel,
Exp.construct ~loc
{ loc; txt = Longident.(
Ldot (Ldot (Lident "Hdf5_caml", "Type"),
match field.Field.type_ with
| Type.Float64 -> "Float64"
| Type.Int -> "Int"
| Type.Int64 -> "Int64"
| Type.String _ -> "String")) }
( match field.Field.type_ with
# 150 "ppx_h5struct.cppo.ml"
| Type.String length ->
Some (Exp.constant ~loc (Pconst_integer (string_of_int length, None)))
# 155 "ppx_h5struct.cppo.ml"
| _ -> None ) ];
construct_fields_list fields loc ]))
let construct_function ~loc name args body =
let rec construct_args = function
| [] -> body
| (arg, typ) :: args ->
Exp.fun_ ~loc Nolabel None
(Pat.constraint_ ~loc (Pat.var ~loc { txt = arg; loc })
(Typ.constr ~loc { txt = typ; loc } []) )
(construct_args args)
in
Str.value ~loc Nonrecursive [
Vb.mk ~loc
(Pat.var ~loc { txt = name; loc }) (construct_args args) ]
let rec construct_function_call ~loc name args =
Exp.apply ~loc
(Exp.ident ~loc { txt = name; loc })
(List.map (fun arg ->
Nolabel,
match arg with
| `Exp e -> e
# 179 "ppx_h5struct.cppo.ml"
| `Int i -> Exp.constant ~loc (Pconst_integer (string_of_int i, None))
# 183 "ppx_h5struct.cppo.ml"
| `Var v -> Exp.ident ~loc { txt = Longident.Lident v; loc }
| `Mgc v -> obj_magic ~loc (Exp.ident ~loc { txt = Longident.Lident v; loc })) args)
and obj_magic ~loc exp =
construct_function_call ~loc Longident.(Ldot (Lident "Obj", "magic")) [`Exp exp]
let construct_field_get field pos loc =
construct_function ~loc field.Field.id [ "t", Longident.Lident "t" ] (
Exp.constraint_ ~loc
(obj_magic ~loc (
construct_function_call ~loc
Longident.(Ldot (Ldot (Ldot (Lident "Hdf5_caml", "Struct"), "Ptr"),
( match field.Field.type_ with
| Type.Float64 -> "get_float64"
| Type.Int -> "get_int"
| Type.Int64 -> "get_int64"
| Type.String _ -> "get_string" )))
( [ `Mgc "t" ]
@ ( match field.Field.type_ with
| Type.Float64
| Type.Int
| Type.Int64 -> [ `Int pos ]
| Type.String length -> [ `Int pos; `Int length ] ) )))
(Typ.constr ~loc { txt = field.Field.ocaml_type; loc } []))
let construct_field_set field pos loc =
construct_function ~loc ("set_" ^ field.Field.id)
[ "t", Longident.Lident "t"; "v", field.Field.ocaml_type ]
(construct_function_call ~loc
Longident.(Ldot (Ldot (Ldot (Lident "Hdf5_caml", "Struct"), "Ptr"),
( match field.Field.type_ with
| Type.Float64 -> "set_float64"
| Type.Int -> "set_int"
| Type.Int64 -> "set_int64"
| Type.String _ -> "set_string" )))
( [ `Mgc "t" ]
@ ( match field.Field.type_ with
| Type.Float64
| Type.Int
| Type.Int64 -> [ `Int pos ]
| Type.String length -> [ `Int pos; `Int length ] )
@ [ `Mgc "v" ] ))
let construct_field_seek field ~bsize pos loc =
construct_function ~loc ("seek_" ^ field.Field.id)
[ "t", Longident.Lident "t"; "v", field.Field.ocaml_type ]
(construct_function_call ~loc
Longident.(Ldot (Ldot (Ldot (Lident "Hdf5_caml", "Struct"), "Ptr"),
( match field.Field.type_ with
| Type.Float64 -> "seek_float64"
| Type.Int -> "seek_int"
| Type.Int64 -> "seek_int64"
| Type.String _ -> "seek_string" )))
( [ `Mgc "t"; `Int (bsize / 2) ]
@ (
match field.Field.type_ with
| Type.Float64
| Type.Int
| Type.Int64 -> [ `Int pos ]
| Type.String len -> [ `Int pos; `Int len ] )
@ [ `Mgc "v" ] ))
let construct_set_all_fields fields loc =
let rec construct_sets = function
| [] -> assert false
| field :: fields ->
let set =
Exp.apply ~loc
(Exp.ident ~loc { txt = Longident.Lident ("set_" ^ field.Field.id); loc })
[ Nolabel, Exp.ident ~loc { txt = Longident.Lident "t"; loc };
Nolabel, Exp.ident ~loc { txt = Longident.Lident field.Field.id; loc } ] in
match fields with
| [] -> set
| _ -> Exp.sequence ~loc set (construct_sets fields)
in
let rec construct_funs = function
| [] -> construct_sets fields
| field :: fields ->
# 274 "ppx_h5struct.cppo.ml"
Exp.fun_ ~loc (Labelled field.Field.id) None
# 278 "ppx_h5struct.cppo.ml"
(Pat.var ~loc { txt = field.Field.id; loc })
(construct_funs fields)
in
[ Str.value ~loc Nonrecursive [
Vb.mk ~loc (Pat.var ~loc { txt = "set"; loc })
(Exp.fun_ ~loc Nolabel None (Pat.var ~loc { txt = "t"; loc })
(construct_funs fields)) ];
Str.value ~loc Nonrecursive [
Vb.mk ~loc (Pat.var ~loc { txt = "_"; loc })
(Exp.ident ~loc { txt = Longident.Lident "set"; loc }) ] ]
let construct_size_dependent_fun name ~bsize ~index loc =
let call =
Exp.apply ~loc
(Exp.ident ~loc
{ loc; txt =
Longident.(Ldot (Ldot (Ldot (Lident "Hdf5_caml", "Struct"), "Ptr"), name)) })
( [ Nolabel, obj_magic ~loc (Exp.ident ~loc { txt = Longident.Lident "t"; loc }) ]
@ (
if index
then [ Nolabel, Exp.ident ~loc { txt = Longident.Lident "i"; loc } ]
else [])
@ [ Nolabel,
# 304 "ppx_h5struct.cppo.ml"
Exp.constant ~loc (Pconst_integer (string_of_int (bsize / 2), None)) ])
# 308 "ppx_h5struct.cppo.ml"
in
[ Str.value ~loc Nonrecursive [
Vb.mk ~loc (Pat.var ~loc { txt = name; loc })
(Exp.fun_ ~loc Nolabel None
(Pat.constraint_ ~loc
(Pat.var ~loc { txt = "t"; loc })
(Typ.constr ~loc { txt = Longident.Lident "t"; loc } []))
( if index
then Exp.fun_ ~loc Nolabel None (Pat.var ~loc { txt = "i"; loc }) call
else call )) ];
Str.value ~loc Nonrecursive [
Vb.mk ~loc (Pat.var ~loc { txt = "_"; loc })
(Exp.ident ~loc { txt = Longident.Lident name; loc }) ] ]
let map_structure_item mapper structure_item =
match structure_item with
| { pstr_desc = Pstr_extension (({txt = "h5struct"; _}, payload), attrs);
pstr_loc = loc } ->
let fields =
match payload with
| PStr [{ pstr_desc = Pstr_eval (expression, _); _ }] ->
extract_fields expression
| _ ->
raise (Location.Error (Location.error ~loc
"[%h5struct] accepts a list of fields, \
e.g. [%h5struct time \"Time\" Int; price \"Price\" Float64]"))
in
let include_ =
Str.include_ ~loc (
Incl.mk ~loc
(Mod.apply ~loc
(Mod.ident ~loc { loc; txt = Longident.(
Ldot (Ldot (Lident "Hdf5_caml", "Struct"), "Make")) })
(Mod.structure ~loc [
Str.value ~loc Nonrecursive [
Vb.mk ~loc (Pat.var ~loc { txt = "fields"; loc })
(construct_fields_list fields loc)]])))
in
let bsize = 8 *
List.fold_left (fun sum field -> sum + Type.wsize field.Field.type_) 0 fields in
let pos = ref 0 in
let functions =
List.map (fun field ->
let functions =
[ construct_field_get field !pos loc;
construct_field_set field !pos loc ]
@ (
if field.Field.seek then [ construct_field_seek field ~bsize !pos loc ]
else [] ) in
pos := !pos + (
match field.Field.type_ with
| Type.Float64 | Type.Int | Type.Int64 -> 4
| Type.String length -> (length + 7) / 8 * 4);
functions) fields
|> List.concat
in
Str.include_ ~loc (Incl.mk ~loc ~attrs (Mod.structure ~loc (
include_ :: functions
@ (construct_set_all_fields fields loc)
@ (construct_size_dependent_fun "unsafe_next" ~bsize ~index:false loc)
@ (construct_size_dependent_fun "unsafe_prev" ~bsize ~index:false loc)
@ (construct_size_dependent_fun "unsafe_move" ~bsize ~index:true loc)
@ (construct_size_dependent_fun "next" ~bsize ~index:false loc)
@ (construct_size_dependent_fun "prev" ~bsize ~index:false loc)
@ (construct_size_dependent_fun "move" ~bsize ~index:true loc))))
| s -> default_mapper.structure_item mapper s
let h5struct_mapper _config _cookies = { default_mapper with structure_item = map_structure_item }
let () = Driver.register ~name:"h5struct" Versions.ocaml_406 h5struct_mapper