-
Notifications
You must be signed in to change notification settings - Fork 1
/
ppx_minidebug.ml
1733 lines (1672 loc) · 67.7 KB
/
ppx_minidebug.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
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
open Ppxlib
module A = Ast_builder.Default
(* module H = Ast_helper *)
type log_value = Sexp | Show | Pp
type toplevel_opt_arg = Nested | Toplevel_no_arg | Runtime_passing | Runtime_local
let is_local_debug_runtime = function Runtime_local -> true | _ -> false
let global_log_count = ref 0
type log_level = Comptime of int | Runtime of expression
type context = {
log_value : log_value;
track_or_explicit : [ `Diagn | `Debug | `Track ];
output_type_info : bool;
interrupts : bool;
log_level : log_level;
entry_log_level : log_level;
hidden : bool;
toplevel_opt_arg : toplevel_opt_arg;
}
let init_context =
ref
{
log_value = Sexp;
track_or_explicit = `Debug;
output_type_info = false;
interrupts = false;
log_level = Comptime 9;
entry_log_level = Comptime 1;
hidden = false;
toplevel_opt_arg = Toplevel_no_arg;
}
let parse_log_level = function
| { pexp_desc = Pexp_constant (Pconst_integer (i, None)); _ } ->
Comptime (int_of_string i)
| ll -> Runtime ll
let rec last_ident = function
| Lident id -> id
| Ldot (_, id) -> id
| Lapply (_, lid) -> last_ident lid
let rec typ2str typ =
match typ.ptyp_desc with
| Ptyp_any -> "_"
| Ptyp_var x -> "'" ^ x
| Ptyp_arrow (_, a, b) -> typ2str a ^ " -> " ^ typ2str b
| Ptyp_tuple typs -> "(" ^ String.concat " * " (List.map typ2str typs) ^ ")"
| Ptyp_constr (lid, []) -> last_ident lid.txt
| Ptyp_constr (lid, typs) ->
last_ident lid.txt ^ "(" ^ String.concat " * " (List.map typ2str typs) ^ ")"
| Ptyp_object (_, _) -> "<object>"
| Ptyp_class (_, _) -> "<class>"
| Ptyp_alias (typ, x) -> typ2str typ ^ " as '" ^ x
| Ptyp_variant (_, _, _) -> "<poly-variant>"
| Ptyp_poly (vs, typ) ->
String.concat " " (List.map (fun v -> "'" ^ v.txt) vs) ^ "." ^ typ2str typ
| Ptyp_package _ -> "<module val>"
| Ptyp_extension _ -> "<extension>"
let rec pat2descr ~default pat =
let loc = pat.ppat_loc in
match pat.ppat_desc with
| Ppat_constraint (pat', _) -> pat2descr ~default pat'
| Ppat_alias (_, ident) | Ppat_var ident -> ident
| Ppat_tuple tups ->
let dscrs = List.map (fun p -> (pat2descr ~default:"_" p).txt) tups in
{ txt = "(" ^ String.concat ", " dscrs ^ ")"; loc }
| Ppat_record (fields, _) ->
let dscrs =
List.map
(fun (id, p) ->
let label = last_ident id.txt in
let pat = (pat2descr ~default:"_" p).txt in
if String.equal label pat then pat else label ^ "=" ^ pat)
fields
in
{ txt = "{" ^ String.concat "; " dscrs ^ "}"; loc }
| Ppat_construct (lid, None) -> { txt = last_ident lid.txt; loc }
| Ppat_construct (lid, Some (_abs_tys, pat)) ->
let dscr = pat2descr ~default pat in
{ txt = last_ident lid.txt ^ " " ^ dscr.txt; loc }
| Ppat_variant (lid, None) -> { txt = lid; loc }
| Ppat_variant (lid, Some pat) ->
let dscr = pat2descr ~default pat in
{ txt = lid ^ " " ^ dscr.txt; loc }
| Ppat_array tups ->
let dscrs = List.map (fun p -> (pat2descr ~default:"_" p).txt) tups in
{ txt = "[|" ^ String.concat ", " dscrs ^ "|]"; loc }
| Ppat_or (pat1, pat2) ->
let dscr1 = pat2descr ~default pat1 in
let dscr2 = pat2descr ~default pat2 in
{ txt = dscr1.txt ^ "|" ^ dscr2.txt; loc }
| Ppat_exception pat ->
let dscr = pat2descr ~default pat in
{ txt = "exception " ^ dscr.txt; loc }
| Ppat_lazy pat ->
let dscr = pat2descr ~default pat in
{ txt = "lazy " ^ dscr.txt; loc }
| Ppat_open (_, pat) -> pat2descr ~default pat
| Ppat_type _ | Ppat_extension _ | Ppat_unpack _ | Ppat_any | Ppat_constant _
| Ppat_interval _ ->
{ txt = default; loc }
let rec pat2expr pat =
let loc = pat.ppat_loc in
match pat with
| [%pat? ()] -> [%expr ()]
| { ppat_desc = Ppat_constraint (pat', typ); _ } ->
A.pexp_constraint ~loc (pat2expr pat') typ
| { ppat_desc = Ppat_alias (_, ident) | Ppat_var ident; _ } ->
A.pexp_ident ~loc { ident with txt = Lident ident.txt }
| _ ->
A.pexp_extension ~loc
@@ Location.error_extensionf ~loc
"ppx_minidebug requires a pattern identifier here: try using an `as` alias."
let lift_track_or_explicit ~loc = function
| `Diagn -> [%expr `Diagn]
| `Debug -> [%expr `Debug]
| `Track -> [%expr `Track]
let ll_to_expr ~digit_loc = function
| Comptime ll -> A.eint ~loc:digit_loc ll
| Runtime e -> e
let open_log ?(message = "") ~loc ~log_level track_or_explicit =
if String.contains message '\n' then
A.pexp_extension ~loc
@@ Location.error_extensionf ~loc
{|ppx_minidebug: multiline messages in log entry headers not allowed, found: "%s"|}
message
else
[%expr
Debug_runtime.open_log
~fname:[%e A.estring ~loc loc.loc_start.pos_fname]
~start_lnum:[%e A.eint ~loc loc.loc_start.pos_lnum]
~start_colnum:[%e A.eint ~loc (loc.loc_start.pos_cnum - loc.loc_start.pos_bol)]
~end_lnum:[%e A.eint ~loc loc.loc_end.pos_lnum]
~end_colnum:[%e A.eint ~loc (loc.loc_end.pos_cnum - loc.loc_end.pos_bol)]
~message:[%e A.estring ~loc message] ~entry_id:__entry_id
~log_level:[%e ll_to_expr ~digit_loc:loc log_level]
[%e lift_track_or_explicit ~loc track_or_explicit]]
let open_log_no_source ~message ~loc ~log_level track_or_explicit =
[%expr
Debug_runtime.open_log_no_source ~message:[%e message] ~entry_id:__entry_id
~log_level:[%e ll_to_expr ~digit_loc:loc log_level]
[%e lift_track_or_explicit ~loc track_or_explicit]]
let close_log ~loc =
[%expr
Debug_runtime.close_log
~fname:[%e A.estring ~loc loc.loc_start.pos_fname]
~start_lnum:[%e A.eint ~loc loc.loc_start.pos_lnum]
~entry_id:__entry_id]
let to_descr context ~loc ~descr_loc typ =
match descr_loc with
| None -> [%expr None]
| Some descr_loc ->
let descr =
if context.output_type_info then descr_loc.txt ^ " : " ^ typ2str typ
else descr_loc.txt
in
let loc = descr_loc.loc in
if String.contains descr '\n' then
A.pexp_extension ~loc
@@ Location.error_extensionf ~loc
{|ppx_minidebug: multiline log descriptions not allowed, found: "%s"|} descr
else [%expr Some [%e A.estring ~loc:descr_loc.loc descr]]
let check_comptime_log_level context ~is_explicit ~is_result:_ ~log_level exp thunk =
let loc = exp.pexp_loc in
match (context.track_or_explicit, context.log_level, log_level) with
| `Diagn, _, _ when not is_explicit -> [%expr ()]
| _, Comptime c_ll, Comptime e_ll when c_ll < e_ll -> [%expr ()]
| _ -> thunk ()
(* *** The sexplib-based variant. *** *)
let log_value_sexp context ~loc ~typ ?descr_loc ~is_explicit ~is_result ~log_level exp =
check_comptime_log_level context ~is_explicit ~is_result ~log_level exp @@ fun () ->
match typ with
| {
ptyp_desc = Ptyp_poly (_, { ptyp_desc = Ptyp_extension ext; _ });
ptyp_loc = loc;
_;
}
| { ptyp_desc = Ptyp_extension ext; ptyp_loc = loc; _ } ->
(* Propagate error if the type could not be found. *)
A.pexp_extension ~loc ext
| { ptyp_desc = Ptyp_poly (_, typ); _ } | typ ->
(* [%sexp_of: typ] does not work with `Ptyp_poly`. Misleading error "Let with no
bindings". *)
incr global_log_count;
[%expr
Debug_runtime.log_value_sexp
?descr:[%e to_descr context ~loc ~descr_loc typ]
~entry_id:__entry_id
~log_level:[%e ll_to_expr ~digit_loc:loc log_level]
~is_result:[%e A.ebool ~loc is_result]
([%sexp_of: [%t typ]] [%e exp])]
(* *** The deriving.show pp-based variant. *** *)
let rec splice_lident ~id_prefix ident =
let splice id =
if String.equal id_prefix "pp_" && String.equal id "t" then "pp" else id_prefix ^ id
in
match ident with
| Lident id -> Lident (splice id)
| Ldot (path, id) -> Ldot (path, splice id)
| Lapply (f, a) -> Lapply (splice_lident ~id_prefix f, a)
let log_value_pp context ~loc ~typ ?descr_loc ~is_explicit ~is_result ~log_level exp =
check_comptime_log_level context ~is_explicit ~is_result ~log_level exp @@ fun () ->
match typ with
| {
ptyp_desc =
( Ptyp_constr (t_lident_loc, [])
| Ptyp_poly (_, { ptyp_desc = Ptyp_constr (t_lident_loc, []); _ }) );
_;
} ->
let converter =
A.pexp_ident ~loc
{ t_lident_loc with txt = splice_lident ~id_prefix:"pp_" t_lident_loc.txt }
in
incr global_log_count;
[%expr
Debug_runtime.log_value_pp
?descr:[%e to_descr context ~loc ~descr_loc typ]
~entry_id:__entry_id
~log_level:[%e ll_to_expr ~digit_loc:loc log_level]
~pp:[%e converter] ~is_result:[%e A.ebool ~loc is_result] [%e exp]]
| _ ->
A.pexp_extension ~loc
@@ Location.error_extensionf ~loc
"ppx_minidebug: cannot find a concrete type to _pp log this value: try _show \
or _sexp"
(* *** The deriving.show string-based variant. *** *)
let log_value_show context ~loc ~typ ?descr_loc ~is_explicit ~is_result ~log_level exp =
check_comptime_log_level context ~is_explicit ~is_result ~log_level exp @@ fun () ->
match typ with
| {
ptyp_desc = Ptyp_poly (_, { ptyp_desc = Ptyp_extension ext; _ });
ptyp_loc = loc;
_;
}
| { ptyp_desc = Ptyp_extension ext; ptyp_loc = loc; _ } ->
(* Propagate error if the type could not be found. *)
A.pexp_extension ~loc ext
| { ptyp_desc = Ptyp_poly (_, typ); _ } | typ ->
(* Defensive in case there's problems with poly types. *)
incr global_log_count;
[%expr
Debug_runtime.log_value_show
?descr:[%e to_descr context ~loc ~descr_loc typ]
~entry_id:__entry_id
~log_level:[%e ll_to_expr ~digit_loc:loc log_level]
~is_result:[%e A.ebool ~loc is_result]
([%show: [%t typ]] [%e exp])]
let log_value context =
match context.log_value with
| Sexp -> log_value_sexp context
| Show -> log_value_show context
| Pp -> log_value_pp context
(* *** The sexplib-based variant. *** *)
let log_value_printbox context ~loc ~log_level exp =
check_comptime_log_level context ~is_explicit:true ~is_result:false ~log_level exp
@@ fun () ->
incr global_log_count;
[%expr
Debug_runtime.log_value_printbox ~entry_id:__entry_id
~log_level:[%e ll_to_expr ~digit_loc:loc log_level]
[%e exp]]
let log_string ~loc ~descr_loc ~log_level s =
if String.contains descr_loc.txt '\n' then
A.pexp_extension ~loc
@@ Location.error_extensionf ~loc
{|ppx_minidebug: unexpected multiline internal message: "%s"|} descr_loc.txt
else
[%expr
Debug_runtime.log_value_show
~descr:[%e A.estring ~loc:descr_loc.loc descr_loc.txt]
~entry_id:__entry_id
~log_level:[%e ll_to_expr ~digit_loc:loc log_level]
~is_result:false [%e A.estring ~loc s]]
let log_string_with_descr ~loc ~message ~log_level s =
[%expr
Debug_runtime.log_value_show ~descr:[%e message] ~entry_id:__entry_id
~log_level:[%e ll_to_expr ~digit_loc:loc log_level]
~is_result:false [%e A.estring ~loc s]]
type fun_arg =
| Pexp_fun_arg of
arg_label * expression option * pattern * location * location_stack * attributes
| Pexp_newtype_arg of label loc * location * location_stack * attributes
let rec collect_fun accu = function
| {
pexp_desc = Pexp_fun (arg_label, default, pat, body);
pexp_loc;
pexp_loc_stack;
pexp_attributes;
} ->
collect_fun
(Pexp_fun_arg (arg_label, default, pat, pexp_loc, pexp_loc_stack, pexp_attributes)
:: accu)
body
| {
pexp_desc = Pexp_newtype (type_label, body);
pexp_loc;
pexp_loc_stack;
pexp_attributes;
} ->
collect_fun
(Pexp_newtype_arg (type_label, pexp_loc, pexp_loc_stack, pexp_attributes) :: accu)
body
| [%expr ([%e? body] : [%t? typ])] -> (List.rev accu, body, Some typ)
| body -> (List.rev accu, body, None)
let rec expand_fun body = function
| [] -> body
| Pexp_fun_arg (arg_label, arg, opt_val, pexp_loc, pexp_loc_stack, pexp_attributes)
:: args ->
{
pexp_desc = Pexp_fun (arg_label, arg, opt_val, expand_fun body args);
pexp_loc;
pexp_loc_stack;
pexp_attributes;
}
| Pexp_newtype_arg (type_label, pexp_loc, pexp_loc_stack, pexp_attributes) :: args ->
{
pexp_desc = Pexp_newtype (type_label, expand_fun body args);
pexp_loc;
pexp_loc_stack;
pexp_attributes;
}
let rec pick ~typ ?alt_typ () =
let rec deref typ =
match typ.ptyp_desc with
| Ptyp_alias (typ, _) | Ptyp_poly (_, typ) -> deref typ
| _ -> typ
in
let typ = deref typ
and alt_typ = match alt_typ with None -> None | Some t -> Some (deref t) in
let alt_or_typ = match alt_typ with None -> typ | Some t -> t in
let loc = typ.ptyp_loc in
match typ.ptyp_desc with
| Ptyp_any -> alt_or_typ
| Ptyp_var _ -> alt_or_typ
| Ptyp_extension _ -> alt_or_typ
| Ptyp_arrow (_, arg, ret) -> (
match alt_typ with
| Some { ptyp_desc = Ptyp_arrow (_, arg2, ret2); _ } ->
let arg = pick ~typ:arg ~alt_typ:arg2 () in
let ret = pick ~typ:ret ~alt_typ:ret2 () in
A.ptyp_arrow ~loc Nolabel arg ret
| _ -> typ)
| Ptyp_tuple args -> (
match alt_typ with
| Some { ptyp_desc = Ptyp_tuple args2; _ } when List.length args = List.length args2
->
let args = List.map2 (fun typ alt_typ -> pick ~typ ~alt_typ ()) args args2 in
A.ptyp_tuple ~loc args
| _ -> typ)
| Ptyp_constr (c, args) -> (
match alt_typ with
| Some { ptyp_desc = Ptyp_constr (c2, args2); _ }
when String.equal (last_ident c.txt) (last_ident c2.txt)
&& List.length args = List.length args2 ->
let args = List.map2 (fun typ alt_typ -> pick ~typ ~alt_typ ()) args args2 in
A.ptyp_constr ~loc c args
| _ -> typ)
| _ -> typ
let rec has_unprintable_type typ =
match typ.ptyp_desc with
| Ptyp_alias (typ, _) | Ptyp_poly (_, typ) -> has_unprintable_type typ
| Ptyp_any | Ptyp_var _ | Ptyp_package _ | Ptyp_extension _ -> true
| Ptyp_arrow (_, arg, ret) ->
(* TODO: maybe add Ptyp_object, Ptyp_class? *)
has_unprintable_type arg || has_unprintable_type ret
| Ptyp_tuple args | Ptyp_constr (_, args) -> List.exists has_unprintable_type args
| _ -> false
let bound_patterns ~alt_typ pat =
let rec loop ?alt_typ pat =
let loc = pat.ppat_loc in
let typ, pat =
match pat with
| [%pat? ([%p? pat] : [%t? typ])] -> (Some (pick ~typ ?alt_typ ()), pat)
| _ -> (alt_typ, pat)
in
match (typ, pat) with
| Some t, { ppat_desc = Ppat_var _ | Ppat_alias (_, _); _ }
when has_unprintable_type t ->
(* Skip abstract types and types unlikely to have derivable printers. *)
(A.ppat_any ~loc, [])
| Some typ, ({ ppat_desc = Ppat_var descr_loc | Ppat_alias (_, descr_loc); _ } as pat)
->
(A.ppat_var ~loc descr_loc, [ (descr_loc, pat, typ) ])
| ( Some { ptyp_desc = Ptyp_tuple typs; _ },
{ ppat_desc = Ppat_tuple pats; ppat_loc; _ } ) ->
let pats, bindings =
List.split @@ List.map2 (fun pat typ -> loop ~alt_typ:typ pat) pats typs
in
(A.ppat_tuple ~loc:ppat_loc pats, List.concat bindings)
| _, { ppat_desc = Ppat_tuple pats; ppat_loc; _ } ->
let pats, bindings = List.split @@ List.map (fun pat -> loop pat) pats in
(A.ppat_tuple ~loc:ppat_loc pats, List.concat bindings)
| _, { ppat_desc = Ppat_record (fields, closed); ppat_loc; _ } ->
let pats, bindings = List.split @@ List.map (fun (_, pat) -> loop pat) fields in
let fields = List.map2 (fun (id, _) pat -> (id, pat)) fields pats in
(A.ppat_record ~loc:ppat_loc fields closed, List.concat bindings)
| Some [%type: [%t? alt_typ] option], [%pat? Some [%p? pat]] ->
let pat, bindings = loop ~alt_typ pat in
([%pat? Some [%p pat]], bindings)
| Some [%type: [%t? alt_typ] list], [%pat? [%p? hd] :: [%p? tl]] ->
let hd, bindings1 = loop ~alt_typ hd in
let tl, bindings2 = loop ?alt_typ:typ tl in
([%pat? [%p hd] :: [%p tl]], bindings1 @ bindings2)
| _, { ppat_desc = Ppat_construct (_lid, None); _ } -> (pat, [])
| _, { ppat_desc = Ppat_construct (lid, Some (_abs_tys, pat)); _ } ->
let pat, bindings = loop pat in
(A.ppat_construct ~loc lid (Some pat), bindings)
| _, { ppat_desc = Ppat_variant (_lid, None); _ } -> (pat, [])
| _, { ppat_desc = Ppat_variant (lid, Some pat); _ } ->
let pat, bindings = loop pat in
(A.ppat_variant ~loc lid (Some pat), bindings)
| Some [%type: [%t? alt_typ] array], { ppat_desc = Ppat_array pats; ppat_loc; _ } ->
let pats, bindings = List.split @@ List.map (fun pat -> loop ~alt_typ pat) pats in
(A.ppat_array ~loc:ppat_loc pats, List.concat bindings)
| _, { ppat_desc = Ppat_array pats; ppat_loc; _ } ->
let pats, bindings = List.split @@ List.map (fun pat -> loop pat) pats in
(A.ppat_array ~loc:ppat_loc pats, List.concat bindings)
| _, { ppat_desc = Ppat_or (pat1, pat2); _ } ->
let pat1, binds1 = loop ?alt_typ:typ pat1 in
let binds1 =
List.map (fun (({ txt = descr; _ }, _, _) as b) -> (descr, b)) binds1
in
let pat2, binds2 = loop ?alt_typ:typ pat2 in
let binds2 =
List.map (fun (({ txt = descr; _ }, _, _) as b) -> (descr, b)) binds2
in
let bindings =
List.sort_uniq (fun (k1, _) (k2, _) -> String.compare k1 k2) @@ binds1 @ binds2
in
(A.ppat_or ~loc pat1 pat2, List.map snd bindings)
| _, { ppat_desc = Ppat_exception pat; _ } ->
let pat, bindings = loop pat in
(A.ppat_exception ~loc pat, bindings)
| Some [%type: [%t? alt_typ] Lazy.t], { ppat_desc = Ppat_lazy pat; _ } ->
let pat, bindings = loop ~alt_typ pat in
(A.ppat_lazy ~loc pat, bindings)
| _, { ppat_desc = Ppat_lazy pat; _ } ->
let pat, bindings = loop pat in
(A.ppat_lazy ~loc pat, bindings)
| _, { ppat_desc = Ppat_open (m, pat); _ } ->
let pat, bindings = loop ?alt_typ:typ pat in
(A.ppat_open ~loc m pat, bindings)
| _, { ppat_desc = Ppat_constraint (_, _); _ } -> assert false
| ( _,
{
ppat_desc =
( Ppat_var _
| Ppat_alias (_, _)
| Ppat_type _ | Ppat_extension _ | Ppat_unpack _ | Ppat_any | Ppat_constant _
| Ppat_interval _ );
_;
} ) ->
(* The pattern is only used to bind values that will be logged. *)
(A.ppat_any ~loc, [])
in
let bind_pat, bound = loop ?alt_typ pat in
let loc = pat.ppat_loc in
(A.ppat_alias ~loc bind_pat { txt = "__res"; loc }, bound)
let entry_with_interrupts context ~loc ?descr_loc ?message ~log_count_before ?header
~preamble ~entry ~result ~log_result () =
let log_string =
match (descr_loc, message) with
| Some descr_loc, None -> log_string ~loc ~descr_loc
| None, Some message -> log_string_with_descr ~loc ~message
| _ -> assert false
in
if
context.track_or_explicit <> `Track
&& log_count_before = !global_log_count
&& message = None
then entry
else
let header = match header with Some h -> h | None -> [%expr ()] in
if context.interrupts then
[%expr
let __entry_id = Debug_runtime.get_entry_id () in
[%e header];
if Debug_runtime.exceeds_max_children () then (
[%e log_string ~log_level:context.entry_log_level "<max_num_children exceeded>"];
failwith "ppx_minidebug: max_num_children exceeded")
else (
[%e preamble];
if Debug_runtime.exceeds_max_nesting () then (
[%e
log_string ~log_level:context.entry_log_level "<max_nesting_depth exceeded>"];
[%e close_log ~loc];
failwith "ppx_minidebug: max_nesting_depth exceeded")
else
match [%e entry] with
| [%p result] ->
[%e log_result];
[%e close_log ~loc];
[%e pat2expr result]
| exception e ->
[%e close_log ~loc];
raise e)]
else
[%expr
let __entry_id = Debug_runtime.get_entry_id () in
[%e header];
[%e preamble];
match [%e entry] with
| [%p result] ->
[%e log_result];
[%e close_log ~loc];
[%e pat2expr result]
| exception e ->
[%e close_log ~loc];
raise e]
let debug_body context callback ~loc ~message ~descr_loc ~log_count_before ~arg_logs typ
body =
let message =
match typ with
| Some t when context.output_type_info -> message ^ " : " ^ typ2str t
| _ -> message
in
let preamble =
open_log ~message ~loc ~log_level:context.entry_log_level context.track_or_explicit
in
let preamble =
List.fold_left
(fun e1 e2 ->
[%expr
[%e e1];
[%e e2]])
preamble arg_logs
in
let result =
let loc = descr_loc.loc in
A.ppat_var ~loc { loc; txt = "__res" }
in
let body, log_result =
match typ with
| None -> (body, [%expr ()])
| Some ({ ptyp_desc = Ptyp_package _; _ } as typ) ->
(* Restore an obligatory type annotation. *)
([%expr ([%e body] : [%t typ])], [%expr ()])
| Some typ when has_unprintable_type typ -> (body, [%expr ()])
| Some typ ->
( body,
log_value context ~loc ~typ ~descr_loc ~is_explicit:false ~is_result:true
~log_level:context.entry_log_level (pat2expr result) )
in
entry_with_interrupts context ~loc ~descr_loc ~log_count_before ~preamble
~entry:(callback context body) ~result ~log_result ()
let rec collect_fun_typs arg_typs typ =
match typ.ptyp_desc with
| Ptyp_alias (typ, _) | Ptyp_poly (_, typ) -> collect_fun_typs arg_typs typ
| Ptyp_arrow (_, arg_typ, typ) -> collect_fun_typs (arg_typ :: arg_typs) typ
| _ -> (List.rev arg_typs, typ)
let pass_runtime ?(always = false) toplevel_opt_arg exp =
let loc = exp.pexp_loc in
(* Only pass runtime to functions. *)
match (always, toplevel_opt_arg, exp) with
| true, Runtime_passing, _
| _, Runtime_passing, { pexp_desc = Pexp_newtype _ | Pexp_fun _ | Pexp_function _; _ }
->
[%expr fun (_debug_runtime : (module Minidebug_runtime.Debug_runtime)) -> [%e exp]]
| _ -> exp
let unpack_runtime toplevel_opt_arg exp =
let loc = exp.pexp_loc in
match toplevel_opt_arg with
| Nested | Toplevel_no_arg -> exp
| Runtime_local ->
[%expr
let module Debug_runtime = (val _get_local_debug_runtime ()) in
[%e exp]]
| Runtime_passing ->
[%expr
let module Debug_runtime = (val _debug_runtime) in
[%e exp]]
let has_runtime_arg = function
| { toplevel_opt_arg = Runtime_passing; _ } -> true
| _ -> false
let loc_to_name loc =
let fname = Filename.basename loc.loc_start.pos_fname |> Filename.remove_extension in
fname ^ ":" ^ Int.to_string loc.loc_start.pos_lnum
let is_comptime_nothing context =
match context.log_level with Comptime i when i <= 0 -> true | _ -> false
let debug_fun context callback ?typ ?ret_descr ?ret_typ exp =
let log_count_before = !global_log_count in
let args, body, ret_typ2 = collect_fun [] exp in
let nested = { context with toplevel_opt_arg = Nested } in
let no_change_exp () =
let body = callback nested body in
let body =
match ret_typ2 with
| Some typ ->
let loc = body.pexp_loc in
[%expr ([%e body] : [%t typ])]
| None -> body
in
pass_runtime context.toplevel_opt_arg @@ expand_fun body args
in
if is_comptime_nothing context then no_change_exp ()
else
let arg_typs, ret_typ3 =
match typ with
| None -> ([], None)
| Some typ ->
let arg_typs, ret_typ = collect_fun_typs [] typ in
(arg_typs, Some ret_typ)
in
let loc = exp.pexp_loc in
let typ =
match (ret_typ, ret_typ2, ret_typ3) with
| _, Some typ, _ ->
Some (pick ~typ:(pick ~typ ?alt_typ:ret_typ ()) ?alt_typ:ret_typ3 ())
| _, None, None -> ret_typ
| None, None, Some t -> Some t
| Some typ, None, _ -> Some (pick ~typ ?alt_typ:ret_typ3 ())
in
if
(not (context.track_or_explicit = `Track))
&& (context.toplevel_opt_arg = Nested || ret_descr = None)
&& Option.is_none typ
then no_change_exp ()
else
let ret_descr =
match ret_descr with
| None (* when context.track_branches *) ->
let txt = "fun:" ^ loc_to_name loc in
{ txt; loc }
| Some descr -> descr
in
let rec arg_log = function
| arg_typs, Pexp_newtype_arg _ :: args -> arg_log (arg_typs, args)
| ( alt_typ :: arg_typs,
Pexp_fun_arg
(_arg_label, _opt_val, pat, pexp_loc, _pexp_loc_stack, _pexp_attributes)
:: args ) ->
let _, bound = bound_patterns ~alt_typ:(Some alt_typ) pat in
List.map
(fun (descr_loc, pat, typ) ->
log_value context ~loc:pexp_loc ~typ ~descr_loc ~is_explicit:false
~is_result:false ~log_level:context.entry_log_level (pat2expr pat))
bound
@ arg_log (arg_typs, args)
| ( [],
Pexp_fun_arg
(_arg_label, _opt_val, pat, pexp_loc, _pexp_loc_stack, _pexp_attributes)
:: args ) ->
let _, bound = bound_patterns ~alt_typ:None pat in
List.map
(fun (descr_loc, pat, typ) ->
log_value context ~loc:pexp_loc ~typ ~descr_loc ~is_explicit:false
~is_result:false ~log_level:context.entry_log_level (pat2expr pat))
bound
@ arg_log ([], args)
| _, [] -> []
in
let arg_logs = arg_log (arg_typs, args) in
let body =
debug_body nested callback ~loc ~message:ret_descr.txt ~descr_loc:ret_descr
~log_count_before ~arg_logs typ body
in
let body =
match ret_typ2 with None -> body | Some typ -> [%expr ([%e body] : [%t typ])]
in
let exp = expand_fun (unpack_runtime context.toplevel_opt_arg body) args in
pass_runtime context.toplevel_opt_arg exp
let debug_case ?(unpack_context = Nested) context callback ?ret_descr ?ret_typ ?arg_typ
kind i { pc_lhs; pc_guard; pc_rhs } =
let log_count_before = !global_log_count in
let pc_guard = Option.map (callback context) pc_guard in
let loc = pc_lhs.ppat_loc in
let _, bound = bound_patterns ~alt_typ:arg_typ pc_lhs in
let arg_logs =
List.map
(fun (descr_loc, pat, typ) ->
log_value context ~loc ~typ ~descr_loc ~is_explicit:false ~is_result:false
~log_level:context.entry_log_level (pat2expr pat))
bound
in
let message = pat2descr ~default:"_" pc_lhs in
let message = if String.equal message.txt "_" then "" else " " ^ message.txt in
let message = "<" ^ kind ^ " -- branch " ^ string_of_int i ^ ">" ^ message in
let ret_descr =
match ret_descr with
| None -> { loc = pc_rhs.pexp_loc; txt = kind ^ "__res" }
| Some ret -> ret
in
let pc_rhs =
debug_body context callback ~loc:pc_rhs.pexp_loc ~message ~descr_loc:ret_descr
~log_count_before ~arg_logs ret_typ pc_rhs
in
let pc_rhs =
if is_local_debug_runtime unpack_context then unpack_runtime unpack_context pc_rhs
else if is_local_debug_runtime context.toplevel_opt_arg then
unpack_runtime context.toplevel_opt_arg pc_rhs
else pc_rhs
in
{ pc_lhs; pc_guard; pc_rhs }
let debug_function ?unpack_context context callback ~loc ?ret_descr ?ret_typ ?arg_typ
cases =
let unpack_context =
match unpack_context with None -> context.toplevel_opt_arg | Some ctx -> ctx
in
let nested = { context with toplevel_opt_arg = Nested } in
let exp =
A.pexp_function ~loc
(List.mapi
(debug_case ~unpack_context nested callback ?ret_descr ?ret_typ ?arg_typ
"function")
cases)
in
match context.toplevel_opt_arg with
| Nested | Toplevel_no_arg | Runtime_local -> exp
| Runtime_passing ->
[%expr
fun (_debug_runtime : (module Minidebug_runtime.Debug_runtime)) ->
let module Debug_runtime = (val _debug_runtime) in
[%e exp]]
let debug_binding context callback vb =
let nested = { context with toplevel_opt_arg = Nested } in
let pvb_pat =
(* FIXME(#18): restoring a modified type constraint breaks typing. *)
match (vb.pvb_pat, context.toplevel_opt_arg) with
| [%pat? ([%p? pat] : [%t? _typ])], Runtime_passing ->
pat
(* [%pat? ([%p pat] : (module Minidebug_runtime.Debug_runtime) -> [%t typ])] *)
| _ -> vb.pvb_pat
in
if is_comptime_nothing context then
{
vb with
pvb_pat;
pvb_expr = pass_runtime context.toplevel_opt_arg @@ callback nested vb.pvb_expr;
}
else
let loc = vb.pvb_loc in
let pat, ret_descr, typ =
match vb.pvb_pat with
| [%pat?
([%p? { ppat_desc = Ppat_var descr_loc | Ppat_alias (_, descr_loc); _ } as pat] :
[%t? typ])] ->
(pat, Some descr_loc, Some typ)
| { ppat_desc = Ppat_var descr_loc | Ppat_alias (_, descr_loc); _ } as pat ->
(pat, Some descr_loc, None)
| pat -> (pat, None, None)
in
let exp, typ2 =
match vb.pvb_expr with
| [%expr ([%e? exp] : [%t? typ])] -> (exp, Some typ)
| exp -> (exp, None)
in
let typ =
match typ with Some typ -> Some (pick ~typ ?alt_typ:typ2 ()) | None -> typ2
in
let arg_typ, ret_typ =
match typ with
| Some { ptyp_desc = Ptyp_arrow (_, arg_typ, ret_typ); _ } ->
(Some arg_typ, Some ret_typ)
| _ -> (None, None)
in
let exp =
match exp with
| { pexp_desc = Pexp_newtype _ | Pexp_fun _; _ } ->
(* [ret_typ] is not the return type if the function has more arguments. *)
(* [debug_fun] handles the runtime passing configuration. *)
debug_fun context callback ?typ ?ret_descr exp
| { pexp_desc = Pexp_function cases; _ } ->
debug_function context callback ~loc:vb.pvb_expr.pexp_loc ?ret_descr ?ret_typ
?arg_typ cases
| _
when context.toplevel_opt_arg = Nested
&& (is_comptime_nothing context || context.track_or_explicit = `Diagn) ->
callback nested exp
| _ ->
let result, bound = bound_patterns ~alt_typ:typ pat in
if bound = [] && context.toplevel_opt_arg = Nested then callback nested exp
else
let log_count_before = !global_log_count in
let descr_loc = pat2descr ~default:"__val" pat in
let log_result =
List.map
(fun (descr_loc, pat, typ) ->
log_value context ~loc:vb.pvb_expr.pexp_loc ~typ ~descr_loc
~is_explicit:false ~is_result:true ~log_level:context.entry_log_level
(pat2expr pat))
bound
|> List.fold_left
(fun e1 e2 ->
[%expr
[%e e1];
[%e e2]])
[%expr ()]
in
let preamble =
open_log ~message:descr_loc.txt ~loc:descr_loc.loc
~log_level:context.entry_log_level context.track_or_explicit
in
entry_with_interrupts context ~loc ~descr_loc ~log_count_before ~preamble
~entry:(callback nested exp) ~result ~log_result ()
in
let pvb_expr =
match (typ2, context.toplevel_opt_arg) with
| None, (Nested | Toplevel_no_arg | Runtime_local) -> exp
| Some typ, (Nested | Toplevel_no_arg | Runtime_local) ->
[%expr ([%e exp] : [%t typ])]
| Some typ, Runtime_passing ->
[%expr ([%e exp] : (module Minidebug_runtime.Debug_runtime) -> [%t typ])]
| None, Runtime_passing ->
[%expr ([%e exp] : (module Minidebug_runtime.Debug_runtime) -> _)]
in
{ vb with pvb_expr; pvb_pat }
let extract_type ?default ~alt_typ exp =
let default =
let loc = exp.pexp_loc in
match default with None -> [%type: string] | Some typ -> typ
in
let exception Not_transforming in
let rec loop ~use_default ?alt_typ exp =
let loc = exp.pexp_loc in
let typ, exp =
match exp with
| [%expr ([%e? exp] : [%t? typ])] -> (Some (pick ~typ ?alt_typ ()), exp)
| _ -> (alt_typ, exp)
in
match (typ, exp) with
| ( Some { ptyp_desc = Ptyp_tuple typs; _ },
{ pexp_desc = Pexp_tuple exps; pexp_loc; _ } ) ->
let typs =
List.map2 (fun exp typ -> loop ~use_default:true ~alt_typ:typ exp) exps typs
in
A.ptyp_tuple ~loc:pexp_loc typs
| _, { pexp_desc = Pexp_tuple exps; pexp_loc; _ } -> (
try
let typs = List.map (fun exp -> loop ~use_default:true exp) exps in
A.ptyp_tuple ~loc:pexp_loc typs
with Not_transforming -> (
match typ with Some typ -> typ | None -> raise Not_transforming))
| Some [%type: [%t? alt_typ] list], [%expr [%e? hd] :: [%e? tl]] -> (
let typ =
try Some (loop ~use_default:false ~alt_typ hd) with Not_transforming -> None
in
let typl =
try Some (loop ~use_default:false ?alt_typ:typ tl)
with Not_transforming -> None
in
match (typ, typl) with
| Some typ, _ -> pick ~typ:[%type: [%t typ] list] ?alt_typ:typl ()
| None, Some typl -> typl
| None, None -> raise Not_transforming)
| _, [%expr [%e? hd] :: [%e? tl]] -> (
let alt_typ =
try Some (loop ~use_default:false hd) with Not_transforming -> None
in
let typl =
try Some (loop ~use_default:false ?alt_typ tl) with Not_transforming -> None
in
match (alt_typ, typl, typ) with
| Some typ, _, _ -> pick ~typ:[%type: [%t typ] list] ?alt_typ:typl ()
| None, Some typl, _ -> typl
| None, None, Some typ -> typ
| None, None, None -> raise Not_transforming)
| Some typ, [%expr []] -> typ
| None, [%expr []] -> [%type: _ list]
| Some [%type: [%t? alt_typ] array], { pexp_desc = Pexp_array exps; _ } ->
let typs =
List.filter_map
(fun exp ->
try Some (loop ~use_default:false ~alt_typ exp)
with Not_transforming -> None)
exps
in
List.fold_left (fun typ alt_typ -> pick ~typ ~alt_typ ()) alt_typ typs
| _, { pexp_desc = Pexp_array exps; _ } -> (
try
let typs =
List.filter_map
(fun exp ->
try Some (loop ~use_default:false exp) with Not_transforming -> None)
exps
in
match typs with
| [] -> raise Not_transforming
| typ :: typs ->
let typ =
List.fold_left (fun typ alt_typ -> pick ~typ ~alt_typ ()) typ typs
in
[%type: [%t typ] array]
with Not_transforming -> (
match typ with Some typ -> typ | None -> raise Not_transforming))
| _, { pexp_desc = Pexp_constant (Pconst_integer _); _ } -> [%type: int]
| _, { pexp_desc = Pexp_constant (Pconst_char _); _ } -> [%type: char]
| _, { pexp_desc = Pexp_constant (Pconst_float _); _ } -> [%type: float]
| _, { pexp_desc = Pexp_constant (Pconst_string _); _ } -> [%type: string]
| Some [%type: [%t? alt_typ] Lazy.t], { pexp_desc = Pexp_lazy exp; _ } ->
let typ = loop ~use_default:false ~alt_typ exp in
[%type: [%t typ] Lazy.t]
| _, { pexp_desc = Pexp_lazy exp; _ } -> (
try
let typ = loop ~use_default:false exp in
[%type: [%t typ] Lazy.t]
with Not_transforming -> (
match typ with Some typ -> typ | None -> raise Not_transforming))
| Some { ptyp_desc = Ptyp_any | Ptyp_var _ | Ptyp_package _ | Ptyp_extension _; _ }, _
->
raise Not_transforming
| Some typ, _ -> typ
| None, _ when use_default ->
{ default with ptyp_loc = exp.pexp_loc; ptyp_loc_stack = exp.pexp_loc_stack }
| None, _ -> raise Not_transforming
in
try loop ~use_default:true ?alt_typ exp
with Not_transforming ->
let loc = exp.pexp_loc in
A.ptyp_extension ~loc
@@ Location.error_extensionf ~loc
"ppx_minidebug: cannot find a type to log this value"
type rule = {
ext_point : string;
track_or_explicit : [ `Diagn | `Debug | `Track ];
toplevel_opt_arg : toplevel_opt_arg;
expander : [ `Debug | `Str ];
log_value : log_value;
entry_log_level : log_level option;
}
let rules =
List.concat
@@ List.map
(fun track_or_explicit ->
List.concat
@@ List.map
(fun log_level ->
List.concat
@@ List.map
(fun toplevel_opt_arg ->
List.concat
@@ List.map
(fun expander ->
List.map
(fun log_value ->
let ext_point =
match track_or_explicit with
| `Debug -> "debug"
| `Track -> "track"
| `Diagn -> "diagn"
in
let ext_point =
ext_point
^
if log_level <= 0 then "" else string_of_int log_level
in
(* The expander currently does not affect the extension
point name. *)
let ext_point =
match toplevel_opt_arg with
| Nested -> assert false
| Toplevel_no_arg -> ext_point
| Runtime_passing -> ext_point ^ "_rt"
| Runtime_local -> ext_point ^ "_l"
in
let ext_point =
ext_point ^ "_"
^