Source

ocaml-core / base / type_conv / syntax / pa_type_conv.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
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
(* Pa_type_conv: Preprocessing Module for Registering Type Conversions *)

open Printf
open Lexing

open Camlp4
open PreCast
open Ast

(* Utility functions *)

let both fa fb (a, b) = fa a, fb b

let get_loc_err loc msg =
  sprintf "File \"%s\", line %d, characters %d-%d: %s"
    (Loc.file_name loc) (Loc.start_line loc)
    (Loc.start_off loc - Loc.start_bol loc)
    (Loc.stop_off loc - Loc.stop_bol loc)
    msg

(* To be deleted once the OCaml team fixes Mantis issue #4751. *)
let hash_variant str =
  let acc_ref = ref 0 in
  for i = 0 to String.length str - 1 do
    acc_ref := 223 * !acc_ref + Char.code str.[i]
  done;
  if Sys.word_size = 32 then !acc_ref
  else !acc_ref land int_of_string "0x7FFFFFFF"


(* Module/File path management *)

type path =
  | Not_initialized  (* Initial state *)
  | Too_late  (* already in a submodule, too late to initialize *)
  | Path of string * string list  (* Actually initialized *)

(* Reference storing the path to the currently preprocessed module *)
let conv_path_ref = ref Not_initialized

let get_conv_path_el () =
  match !conv_path_ref with
  | Path (e, el) -> e, el
  | _ -> failwith "Pa_type_conv: path not set"

(* Get path to the currently preprocessed module *)
let get_conv_path () = fst (get_conv_path_el ())

(* Set path to the currently preprocessed module *)
let set_conv_path conv_path =
  if !conv_path_ref = Not_initialized || !Sys.interactive then
    conv_path_ref := Path (conv_path, [conv_path])
  else failwith "Pa_type_conv: module name set twice"

let () = if !Sys.interactive then set_conv_path "Toplevel"

let push_conv_path mod_name =
  match !conv_path_ref with
  | Not_initialized -> conv_path_ref := Too_late (* Entered a submodule *)
  | Too_late -> ()
  | Path (str, rev_lst) ->
      conv_path_ref := Path (str ^ "." ^ mod_name, mod_name :: rev_lst)

let pop_conv_path () =
  match !conv_path_ref with
  | Path (_, _ :: rev_lst) ->
      conv_path_ref := Path (String.concat "." (List.rev rev_lst), rev_lst)
  | _ -> ()


(* Generator registration *)


(* Map of "with"-generators for types in structures *)
let generators = Hashtbl.create 0

(* Map of "with"-generators for types in signatures *)
let sig_generators = Hashtbl.create 0

(* Map of "with"-generators for exceptions in structures *)
let exn_generators = Hashtbl.create 0

(* Map of "with"-generators for exceptions in signatures *)
let sig_exn_generators = Hashtbl.create 0

(* Map of "with"-generators for record fields *)
type record_field_generator = Loc.t -> unit

let record_field_generators = Hashtbl.create 0

(* Check that there is no argument for generators that do not expect any *)
let no_arg id e arg typ =
  if arg = None then e typ
  else
    failwith (
      "Pa_type_conv: generator '" ^ id ^ "' does not expect an argument")

(* Parse a list of tokens with the given grammar entry *)
let parse_with entry = function
  | Some tokens ->
      Some (Gram.parse_tokens_after_filter entry (Stream.of_list tokens))
  | None -> None

(* Entry which ignores its input *)
let ignore_tokens = Gram.Entry.of_parser "ignore_tokens" ignore

(* Add new generator, fail if already defined *)
let safe_add_gen gens id entry e =
  if Hashtbl.mem gens id then
    failwith ("Pa_type_conv: generator '" ^ id ^ "' defined multiple times")
  else Hashtbl.add gens id (fun arg typ -> e (parse_with entry arg) typ)

(* Register a "with"-generator for types in structures *)
let add_generator_with_arg ?(is_exn = false) id entry e =
  let gens = if is_exn then exn_generators else generators in
  safe_add_gen gens id entry e

let add_generator ?is_exn id e =
  add_generator_with_arg ?is_exn id ignore_tokens (no_arg id e)

(* Remove a "with"-generator for types in structures *)
let rm_generator ?(is_exn = false) id =
  let gens = if is_exn then exn_generators else generators in
  Hashtbl.remove gens id

(* Register a "with"-generator for types in signatures *)
let add_sig_generator_with_arg ?(is_exn = false) id entry e =
  let gens = if is_exn then sig_exn_generators else sig_generators in
  safe_add_gen gens id entry e

let add_sig_generator ?is_exn id e =
  add_sig_generator_with_arg ?is_exn id ignore_tokens (no_arg id e)

(* Remove a "with"-generator for types in signatures *)
let rm_sig_generator ?(is_exn = false) id =
  let gens = if is_exn then sig_exn_generators else sig_generators in
  Hashtbl.remove gens id

(* Register a "with"-generator for record fields *)
let add_record_field_generator_with_arg id entry e =
  safe_add_gen record_field_generators id entry e

let add_record_field_generator id e =
  add_record_field_generator_with_arg id ignore_tokens (no_arg id e)

(* Remove a "with"-generator for record fields *)
let rm_record_field_generator id = Hashtbl.remove record_field_generators id


(* General purpose code generation module *)

module Gen = struct
  (* Map of record field source locations to their default expression *)
  let record_defaults = Hashtbl.create 0

  let find_record_default loc =
    try Some (Hashtbl.find record_defaults loc) with Not_found -> None

  let gensym =
    let cnt = ref 0 in
    fun ?(prefix = "_x") () ->
      incr cnt;
      sprintf "%s__%03i_" prefix !cnt

  (* Like Ast.exSem_of_list but for application *)
  let exApp_of_list l =
    let rec aux = function
      | [] -> Ast.ExNil Loc.ghost
      | [x] -> x
      | x :: xs ->
        let loc = Ast.loc_of_expr x in
        <:expr@loc< $aux xs$ $x$ >>
    in
    aux (List.rev l)

  let rec tyArr_of_list = function
    | [] -> Ast.TyNil Loc.ghost
    | [x] -> x
    | x :: xs ->
      let loc = loc_of_ctyp x in
      <:ctyp@loc< $x$ -> $tyArr_of_list xs$ >>

  let rec paOr_of_list = function
    | [] -> Ast.PaNil Loc.ghost
    | [x] -> x
    | x :: xs ->
      let loc = loc_of_patt x in
      <:patt@loc< $x$ | $paOr_of_list xs$ >>

  module PP = Camlp4.Printers.OCaml.Make (Syntax)
  let conv_ctyp = (new PP.printer ())#ctyp

  let string_of_ctyp ctyp =
    try
      let buffer = Buffer.create 32 in
      Format.bprintf buffer "%a@?" conv_ctyp ctyp;
      Some (Buffer.contents buffer)
    with _ -> None

  let error tp ~fn ~msg =
    let loc = Ast.loc_of_ctyp tp in
    let failure =
      match string_of_ctyp tp with
      | Some tp_str -> sprintf "%s: %s\n%s" fn msg tp_str
      | None -> sprintf "%s: %s" fn msg
    in
    Loc.raise loc (Failure failure)

  let unknown_type tp fn = error tp ~fn ~msg:"unknown type"

  let rec ty_var_list_of_ctyp tp acc =
    match tp with
    | <:ctyp< $tp1$ $tp2$ >> ->
        ty_var_list_of_ctyp tp1 (ty_var_list_of_ctyp tp2 acc)
    | <:ctyp< '$param$ >> -> param :: acc
    | _ -> invalid_arg "ty_var_list_of_ctyp"

  let rec get_rev_id_path tp acc =
    match tp with
    | <:ident< $id1$ . $id2$ >> -> get_rev_id_path id2 (get_rev_id_path id1 acc)
    | <:ident< $lid:id$ >> | <:ident< $uid:id$ >> -> id :: acc
    | _ -> invalid_arg "get_rev_id_path"

  let mk_ident _loc str =
    let first = str.[0] in
    if first >= 'A' && first <= 'Z' then <:ident< $uid:str$ >>
    else <:ident< $lid:str$ >>

  let rec ident_of_rev_path _loc = function
    | [str] -> mk_ident _loc str
    | str :: strs ->
        <:ident< $ident_of_rev_path _loc strs$ . $mk_ident _loc str$ >>
    | _ -> invalid_arg "ident_of_rev_path"

  let rec get_appl_path _loc = function
    | <:ctyp< $id:id$ >> -> id
    | <:ctyp< $tp$ $_$ >> -> get_appl_path _loc tp
    | _ -> failwith "get_appl_path: unknown type"

  let abstract _loc = List.fold_right (fun p e -> <:expr< fun $p$ -> $e$ >>)
  let apply _loc = List.fold_left (fun f arg -> <:expr< $f$ $arg$ >>)

  let switch_tp_def ~alias ~sum ~record ~variants ~mani ~nil tp =
    let rec loop = function
      | <:ctyp< private $tp$ >> -> loop tp
      | <:ctyp@loc< [ $alts$ ] >> -> sum loc alts
      | <:ctyp@loc< [< $row_fields$ ] >> | <:ctyp@loc< [> $row_fields$ ] >>
      | <:ctyp@loc< [= $row_fields$ ] >> -> variants loc row_fields
      | <:ctyp@loc< $id:_$ >>
      | <:ctyp@loc< ( $tup:_$ ) >>
      | <:ctyp@loc< $_$ -> $_$ >>
      | <:ctyp@loc< '$_$ >>
      | <:ctyp@loc< $_$ $_$ >> as tp_def -> alias loc tp_def
      | <:ctyp@loc< { $flds$ } >> -> record loc flds
      | <:ctyp@loc< $tp1$ == $tp2$ >> -> mani loc tp1 tp2
      | <:ctyp@loc< >> -> nil loc
      | tp -> unknown_type tp "switch_tp_def"
    in
    loop tp

  let rec mk_expr_lst _loc = function
    | [] -> <:expr< [] >>
    | e :: es -> <:expr< [$e$ :: $mk_expr_lst _loc es$] >>

  let rec mk_patt_lst _loc = function
    | [] -> <:patt< [] >>
    | p :: ps -> <:patt< [$p$ :: $mk_patt_lst _loc ps$] >>

  let get_tparam_id = function
    | <:ctyp< '$id$ >> | <:ctyp< +'$id$ >> | <:ctyp< -'$id$ >> -> id
    | tp -> error tp ~fn:"get_tparam_id" ~msg:"not a type parameter"

  let type_is_recursive type_name tp =
    let bad_type tp = unknown_type tp "type_is_recursive" in
    let rec loop = function
      | <:ctyp< private $tp$>> -> loop tp
      | <:ctyp< $tp1$ $tp2$ >>
      | <:ctyp< $tp1$ * $tp2$ >>
      | <:ctyp< $tp1$; $tp2$ >>
      | <:ctyp< $tp1$ -> $tp2$ >>
      | <:ctyp< $tp1$ == $tp2$ >>
      | <:ctyp< $tp1$ and $tp2$ >>
      | <:ctyp< $tp1$ & $tp2$ >>
      | <:ctyp< $tp1$, $tp2$ >>
      | <:ctyp< [ < $tp1$ > $tp2$ ] >>
      | <:ctyp< $tp1$ | $tp2$ >> -> loop tp1 || loop tp2
      | <:ctyp< ( $tup:tp$ ) >> | <:ctyp< { $tp$ } >>
      | <:ctyp< [ $tp$ ] >>
      | <:ctyp< $_$ : $tp$ >>
      | <:ctyp< ~ $_$ : $tp$ >>
      | <:ctyp< ? $_$ : $tp$ >>
      | <:ctyp< < $tp$; $..:_$ > >>
      | <:ctyp< mutable $tp$ >>
      | <:ctyp< $_$ of & $tp$ >>
      | <:ctyp< $_$ of $tp$ >>
      | <:ctyp< $tp$ as $_$ >>
      | <:ctyp< [< $tp$ ] >> | <:ctyp< [> $tp$ ] >> | <:ctyp< [= $tp$ ] >>
      | <:ctyp< ! $_$ . $tp$ >> -> loop tp
      | <:ctyp< $lid:id$ >> -> id = type_name
      | <:ctyp< $id:_$ >>
      | <:ctyp< #$id:_$ >>
      | <:ctyp< `$_$ >>
      | <:ctyp< '$_$ >>
      | <:ctyp< -'$_$ >>
      | <:ctyp< +'$_$ >>
      | <:ctyp< _ >>
      | <:ctyp< >> -> false
      | <:ctyp< (module $module_type$) >> -> loop_module_type module_type
      | Ast.TyDcl _
      | Ast.TyAnt _ as tp -> bad_type tp
    and loop_module_type = function
      | <:module_type< $module_type$ with $with_constr$ >> ->
          let rec loop_with_constr = function
            | <:with_constr< type $_$ = $tp$ >>
            | <:with_constr< type $_$ := $tp$ >> -> loop tp
            | <:with_constr< $wc1$ and $wc2$ >> ->
                loop_with_constr wc1 || loop_with_constr wc2
            | <:with_constr< module $_$ = $_$ >>
            | <:with_constr< module $_$ := $_$ >>
            | <:with_constr< >> -> false
            | Ast.WcAnt _ -> bad_type tp
          in
          loop_with_constr with_constr || loop_module_type module_type
      | <:module_type< $id:_$ >>
      | <:module_type< '$_$ >>
      | <:module_type< >> -> false
      | <:module_type< functor ($_$ : $_$) -> $_$ >>
      | <:module_type< sig $_$ end >>
      | <:module_type< module type of $_$ >>
      | Ast.MtAnt _ -> bad_type tp
    in
    loop tp

  let drop_variance_annotations =
    (map_ctyp (function
      | <:ctyp@loc< +'$var$ >> | <:ctyp@loc< -'$var$ >> -> <:ctyp@loc< '$var$ >>
      | tp -> tp))#ctyp
end


(* Functions for interpreting derivation types *)

let find_generator ~name haystack = (); fun entry (needle, arg) ->
  let genf =
    try Hashtbl.find haystack needle
    with Not_found ->
      let keys = Hashtbl.fold (fun key _ acc -> key :: acc) haystack [] in
      let gen_names = String.concat ", " keys in
      let msg =
        Printf.sprintf
          "Pa_type_conv: \
          %S is not a supported %s generator. (supported generators: %s)"
          needle
          name
          gen_names
      in
      failwith msg
  in
  genf arg entry

let generate = find_generator ~name:"type" generators

let gen_derived_defs _loc tp drvs =
  let coll drv der_sis = <:str_item< $der_sis$; $generate tp drv$ >> in
  List.fold_right coll drvs <:str_item< >>

let generate_exn = find_generator ~name:"exception" exn_generators

let gen_derived_exn_defs _loc tp drvs =
  let coll drv der_sis = <:str_item< $der_sis$; $generate_exn tp drv$ >> in
  List.fold_right coll drvs <:str_item< >>

let sig_generate = find_generator ~name:"signature" sig_generators

let gen_derived_sigs _loc tp drvs =
  let coll drv der_sis = <:sig_item< $der_sis$; $sig_generate tp drv$ >> in
  List.fold_right coll drvs (SgNil _loc)

let sig_exn_generate =
  find_generator ~name:"signature exception" sig_exn_generators

let gen_derived_exn_sigs _loc tp drvs =
  let coll drv der_sis = <:sig_item< $der_sis$; $sig_exn_generate tp drv$ >> in
  List.fold_right coll drvs (SgNil _loc)

let remember_record_field_generators el drvs =
  let act drv =
    let gen = find_generator ~name:"record field" record_field_generators in
    gen el drv
  in
  List.iter act drvs


(* Syntax extension *)

open Syntax

let is_prefix ~prefix x =
  let prefix_len = String.length prefix in
  String.length x >= prefix_len && prefix = String.sub x 0 prefix_len

let chop_prefix ~prefix x =
  if is_prefix ~prefix x then
    let prefix_len = String.length prefix in
    Some (String.sub x prefix_len (String.length x - prefix_len))
  else None

let get_default_path _loc =
  try
    let prefix = Sys.getenv "TYPE_CONV_ROOT" in
    match chop_prefix ~prefix (Loc.file_name (Loc.make_absolute _loc)) with
    | Some x -> x ^ "#"
    | None -> Loc.file_name _loc
  with _ -> Loc.file_name _loc

let set_conv_path_if_not_set _loc =
  if !conv_path_ref = Not_initialized || !Sys.interactive then
    let conv_path = get_default_path _loc in
    conv_path_ref := Path (conv_path, [conv_path])

let found_module_name =
  Gram.Entry.of_parser "found_module_name" (fun strm ->
    match Stream.npeek 1 strm with
    | [(UIDENT name, token_info)] ->
        set_conv_path_if_not_set (Gram.token_location token_info);
        push_conv_path name;
        Stream.junk strm;
        name
    | _ -> raise Stream.Failure)

let rec fetch_generator_arg paren_count strm =
  match Stream.next strm with
  | KEYWORD "(", _ -> fetch_generator_arg (paren_count + 1) strm
  | KEYWORD ")", token_info ->
      if paren_count = 1 then [(EOI, token_info)]
      else fetch_generator_arg (paren_count - 1) strm
  | EOI, token_info ->
      Loc.raise (Gram.token_location token_info) (Stream.Error "')' missing")
  | x -> x :: fetch_generator_arg paren_count strm

let generator_arg =
  Gram.Entry.of_parser "generator_arg" (fun strm ->
    match Stream.peek strm with
    | Some (KEYWORD "(", _) ->
        Stream.junk strm;
        Some (fetch_generator_arg 1 strm)
    | _ -> None)

DELETE_RULE Gram str_item: "module"; a_UIDENT; module_binding0 END;

EXTEND Gram
  GLOBAL: str_item sig_item label_declaration;

  str_item:
    [[
      "TYPE_CONV_PATH"; conv_path = STRING ->
        set_conv_path conv_path;
        <:str_item< >>
    ]];

  generator: [[ id = LIDENT; arg = generator_arg -> (id, arg) ]];

  str_item:
    [[
      "type"; tds = type_declaration; "with"; drvs = LIST1 generator SEP "," ->
        set_conv_path_if_not_set _loc;
        <:str_item< type $tds$; $gen_derived_defs _loc tds drvs$ >>
    ]];

  str_item:
    [[
      "exception"; tds = constructor_declaration; "with";
      drvs = LIST1 generator SEP "," ->
        set_conv_path_if_not_set _loc;
        <:str_item< exception $tds$; $gen_derived_exn_defs _loc tds drvs$ >>
    ]];

  str_item:
    [[
      "module"; i = found_module_name; mb = module_binding0 ->
        pop_conv_path ();
        <:str_item< module $i$ = $mb$ >>
    ]];

  sig_item:
    [[
      "type"; tds = type_declaration; "with"; drvs = LIST1 generator SEP "," ->
        set_conv_path_if_not_set _loc;
        <:sig_item< type $tds$; $gen_derived_sigs _loc tds drvs$ >>
    ]];

  sig_item:
    [[
      "exception"; cd = constructor_declaration; "with";
      drvs = LIST1 generator SEP "," ->
        set_conv_path_if_not_set _loc;
        <:sig_item< exception $cd$; $gen_derived_exn_sigs _loc cd drvs$ >>
    ]];

  label_declaration:
    [[
      name = a_LIDENT; ":"; tp = poly_type;
      "with"; drvs = LIST1 generator SEP "," ->
        remember_record_field_generators _loc drvs;
        <:ctyp< $lid:name$ : $tp$ >>
    | "mutable"; name = a_LIDENT; ":"; tp = poly_type;
      "with"; drvs = LIST1 generator SEP "," ->
        remember_record_field_generators _loc drvs;
        <:ctyp< $lid:name$ : mutable $tp$ >>
    ]];
END

(* Record field defaults *)

(* Add "default" to set of record field generators *)
let () =
  add_record_field_generator_with_arg "default" Syntax.expr
    (fun expr_opt loc ->
      let default =
        match expr_opt with
        | Some expr -> expr
        | None -> Loc.raise loc (Failure "could not parse default expression")
      in
      Hashtbl.replace Gen.record_defaults loc default)
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.