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
open B0_std
open B00_serialk_json
open B000
let fpath p = Jsong.string (Fpath.to_string p)
let jsong_cmd c = Jsong.(list string (Cmd.to_list c))
module Trace_event = struct
let str pp get o = Jsong.strf "%a" pp (get o)
let span_us s =
let span_us = Int64.(to_int @@ div (Mtime.Span.to_uint64_ns s) 1000L) in
Jsong.int span_us
let result ~ok = function
| Error e -> Jsong.string e | Ok v -> Jsong.string (ok v)
let unit_result = result ~ok:(fun () -> "ok")
let bool_result = result ~ok:string_of_bool
let string_result = result ~ok:(fun s -> s)
let spawn_exit = function
| None -> Jsong.(obj |> obj_end)
| Some (`Exited c) -> Jsong.(obj |> mem "exited" (int c) |> obj_end)
| Some (`Signaled c) -> Jsong.(obj |> mem "signaled" (int c) |> obj_end)
let spawn_stdo_ui s = match Op.Spawn.stdo_ui s with
| None -> "none"
| Some (Ok d) -> d
| Some (Error e) -> Fmt.str "error: %s" e
let writes_manifest_root o obj = match Op.writes_manifest_root o with
| None -> obj
| Some root -> Jsong.mem "writes-manifest-root" (fpath root) obj
let args o =
let kind_mems obj = match Op.kind o with
| Op.Copy c ->
obj
|> Jsong.mem "src" (fpath (Op.Copy.src c))
|> Jsong.mem "dst" (fpath (Op.Copy.dst c))
|> Jsong.mem "mode" (Jsong.strf "%o" (Op.Copy.mode c))
|> Jsong.mem "linenum" (Jsong.(option int) (Op.Copy.linenum c))
| Op.Delete d ->
obj |> Jsong.mem "path" (fpath (Op.Delete.path d))
| Op.Mkdir m ->
obj |> Jsong.mem "dir" (fpath (Op.Mkdir.dir m))
| Op.Notify n ->
obj
|> Jsong.mem "kind"
(Jsong.string
(B000_conv.Op.notify_kind_to_string (B000.Op.Notify.kind n)))
|> Jsong.mem "msg" (Jsong.string (Op.Notify.msg n))
| Op.Read r ->
obj |> Jsong.mem "file" (fpath (Op.Read.file r))
| Op.Spawn s ->
let cmd = Cmd.(path (Op.Spawn.tool s) %% (Op.Spawn.args s)) in
obj
|> Jsong.mem "cmd" (jsong_cmd cmd)
|> Jsong.mem "exit" (spawn_exit (Op.Spawn.exit s))
|> Jsong.mem "cwd" (fpath (Op.Spawn.cwd s))
|> Jsong.mem "env" (Jsong.(list string) (Op.Spawn.env s))
|> Jsong.mem "success-exits"
(Jsong.(list int) (Op.Spawn.success_exits s))
|> Jsong.mem "stdo-ui" (Jsong.string (spawn_stdo_ui s))
| Op.Wait_files _ -> obj
| Op.Write w ->
obj
|> Jsong.mem "file" (fpath (Op.Write.file w))
|> Jsong.mem "stamp" (Jsong.string (Op.Write.stamp w))
|> Jsong.mem "mode" (Jsong.strf "%o" (Op.Write.mode w))
in
Jsong.obj
|> Jsong.mem "kind" (Jsong.string (Op.kind_name (Op.kind o)))
|> Jsong.mem "mark" (Jsong.string (Op.mark o))
|> Jsong.mem "status"
(Jsong.string (B000_conv.Op.status_to_string (Op.status o)))
|> Jsong.mem "revived" (Jsong.bool (Op.revived o))
|> Jsong.mem "writes" (Jsong.(list fpath) (Op.writes o))
|> writes_manifest_root o
|> Jsong.mem "time-created" (span_us (Op.time_created o))
|> kind_mems
|> Jsong.mem "reads" (Jsong.(list fpath) (Op.reads o))
|> Jsong.mem "hash" (Jsong.string (Hash.to_hex (Op.hash o)))
|> Jsong.obj_end
let op o =
let id o = Jsong.string (string_of_int @@ Op.id o) in
let cat o = Jsong.string @@ Op.kind_name (Op.kind o) in
Jsong.obj
|> Jsong.mem "name" (id o)
|> Jsong.mem "cat" (cat o)
|> Jsong.mem "ph" (Jsong.string "X")
|> Jsong.mem "ts" (span_us (Op.time_started o))
|> Jsong.mem "dur" (span_us (Op.duration o))
|> Jsong.mem "pid" (Jsong.int 1)
|> Jsong.mem "tid" (Jsong.int 1)
|> Jsong.mem "args" (args o)
|> Jsong.obj_end
let of_ops os = Jsong.list op os
end
module Compilation_database = struct
let spawn_out o spawn src arr out_file =
let cmd = Cmd.(path (Op.Spawn.tool spawn) %% (Op.Spawn.args spawn)) in
arr |> Jsong.el begin
Jsong.obj
|> Jsong.mem "directory" (fpath (Op.Spawn.cwd spawn))
|> Jsong.mem "file" (fpath src)
|> Jsong.mem "arguments" (jsong_cmd cmd)
|> Jsong.mem "output" (fpath out_file)
|> Jsong.mem "id" (Jsong.int (Op.id o))
|> Jsong.obj_end
end
let add_op arr o = match Op.kind o with
| Op.Spawn s ->
let src = match Op.reads o with [] -> Fpath.null | fs -> List.hd fs in
List.fold_left (spawn_out o s src) arr (Op.writes o)
| _ -> arr
let of_ops os = Jsong.array_end (List.fold_left add_op Jsong.array os)
end