Source file instrumentation.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
type t = { mutable backend : Dune.Instrumentation.Backend.t } [@@deriving sexp_of]
let create ~backend = { backend }
let backend t = t.backend
let set_backend t ~backend = t.backend <- backend
let field_name = "instrumentation"
let read ~sexps_rewriter ~field =
let args = Dunolinter.Sexp_handler.get_args ~field_name ~sexps_rewriter ~field in
match
List.find_map args ~f:(function
| List (Atom "backend" :: Atom name :: flag_sexps) ->
Some
(Dune.Instrumentation.Backend.create
~name:(Dune.Instrumentation.Backend.Name.v name)
~flags:(List.map flag_sexps ~f:Dune.Instrumentation.Backend.Flag.t_of_sexp))
| _ -> None)
with
| Some backend -> create ~backend
| None ->
let loc = Sexps_rewriter.loc sexps_rewriter field in
Err.raise
~loc
Pp.O.
[ Pp.text "Required "
++ Pp_tty.kwd (module String) "backend"
++ Pp.text " value in instrumentation."
]
;;
let write (t : t) =
let name = Dune.Instrumentation.Backend.name t.backend in
let flags = Dune.Instrumentation.Backend.flags t.backend in
Sexp.List
[ Atom field_name
; List
(Atom "backend"
:: Atom (Dune.Instrumentation.Backend.Name.to_string name)
:: List.map flags ~f:Dune.Instrumentation.Backend.Flag.sexp_of_t)
]
;;
let is_atom_and_equal sexp ~to_:text =
match (sexp : Sexp.t) with
| Atom s -> String.equal s text
| List _ -> false
;;
let rewrite_flags ~file_rewriter ~sexps_rewriter ~prev_sexp ~desired ~actual =
let rec iter ~prev_sexp desired actual =
match desired, actual with
| [], [] -> ()
| desired_flag :: rest_desired, actual_flag :: rest_actual ->
if not (is_atom_and_equal actual_flag ~to_:desired_flag)
then
File_rewriter.replace
file_rewriter
~range:(Sexps_rewriter.range sexps_rewriter actual_flag)
~text:desired_flag;
iter ~prev_sexp:actual_flag rest_desired rest_actual
| rest_desired, [] ->
let insert_offset = Sexps_rewriter.stop_offset sexps_rewriter prev_sexp in
let text =
List.map rest_desired ~f:(fun flag -> " " ^ flag) |> String.concat ~sep:""
in
File_rewriter.insert file_rewriter ~offset:insert_offset ~text
| [], (_ :: _ as remaining_actual) ->
let last_arg = List.last_exn remaining_actual in
let range =
{ Loc.Range.start = Sexps_rewriter.stop_offset sexps_rewriter prev_sexp
; stop = Sexps_rewriter.stop_offset sexps_rewriter last_arg
}
in
File_rewriter.remove file_rewriter ~range
in
iter ~prev_sexp desired actual
;;
let rewrite t ~sexps_rewriter ~field =
let args = Dunolinter.Sexp_handler.get_args ~field_name ~sexps_rewriter ~field in
let file_rewriter = Sexps_rewriter.file_rewriter sexps_rewriter in
let desired_name =
Dune.Instrumentation.Backend.Name.to_string
(Dune.Instrumentation.Backend.name t.backend)
in
let desired_flags = Dune.Instrumentation.Backend.flags t.backend in
List.iter args ~f:(function
| List (Atom "backend" :: (Atom actual_name as name_sexp) :: actual_flags) ->
if not (String.equal actual_name desired_name)
then
File_rewriter.replace
file_rewriter
~range:(Sexps_rewriter.range sexps_rewriter name_sexp)
~text:desired_name;
rewrite_flags
~file_rewriter
~sexps_rewriter
~prev_sexp:name_sexp
~desired:desired_flags
~actual:actual_flags
| _ -> ())
;;
type predicate = Dune.Instrumentation.Predicate.t
let eval t ~predicate =
match (predicate : predicate) with
| `backend backend ->
Dune.Instrumentation.Backend.equal backend t.backend |> Dunolint.Trilang.const
;;
let enforce =
Dunolinter.Linter.enforce
(module Dune.Instrumentation.Predicate)
~eval
~enforce:(fun t predicate ->
match predicate with
| Not (`backend _) -> Eval
| T (`backend backend) ->
t.backend <- backend;
Ok)
;;
let default_backend = Dune.Instrumentation.Backend.v "bisect_ppx"
let initialize ~condition =
let backend =
Dunolinter.Linter.find_init_value condition ~f:(function `backend backend ->
Some backend)
|> Option.value ~default:default_backend
in
{ backend }
;;