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
let sprintf = Printf.sprintf
module Message = struct
type level =
[ `Warn
| `Info
| `Verbose
]
let string_of_level = function
| `Warn -> "Warn"
| `Info -> "Info"
| `Verbose -> "Verbose"
;;
type t =
{ level : level
; message : string
; args : (string * Dyn.t) list
}
let ocamlparam () =
{ level = `Info
; message = "ocamlparam"
; args =
[ ( "OCAMLPARAM"
, Dyn.string
(match Env.get Env.initial "OCAMLPARAM" with
| Some s -> Printf.sprintf "%S" s
| None -> "unset") )
]
}
;;
let create level message args = { level; message; args }
end
module File = struct
type t =
| Redirect of (Message.t -> unit)
| No_log_file
| Stderr
| Both of t * t
end
type real =
| No_log_file
| Redirect of (Message.t -> unit)
| Output of out_channel
| Both of real * real
let t = Fdecl.create Dyn.opaque
let verbose = ref false
let format_args args =
List.map args ~f:(fun (k, v) -> Printf.sprintf "%s: %s" k (Dyn.to_string v))
|> String.concat ~sep:" "
;;
let write_oc oc { Message.level; message; args } =
output_string
oc
(sprintf "%s %s | %s\n" (Message.string_of_level level) message (format_args args))
;;
let rec emit (t : real) (message : Message.t) =
match t with
| No_log_file -> ()
| Redirect w -> w message
| Output oc -> write_oc oc message
| Both (x, y) ->
emit x message;
emit y message
;;
let init (dst : File.t) =
let rec make (dst : File.t) =
match dst with
| No_log_file -> No_log_file
| Stderr -> Output stderr
| Redirect w -> Redirect w
| Both (x, y) -> Both (make x, make y)
in
Fdecl.set t (make dst);
emit (Fdecl.get t) (Message.ocamlparam ())
;;
let t () = Fdecl.get t
let forward_verbose = Fdecl.create Dyn.opaque
let set_forward_verbose = Fdecl.set forward_verbose
let log f = emit (t ()) (f ())
let info message args =
emit (t ()) { Message.level = `Info; message; args };
if !verbose then (Fdecl.get forward_verbose) message args
;;
let warn message args = info ("Warning: " ^ message) args
let command ~command_line ~output ~exit_status =
if !verbose
then (
let command_line = Ansi_color.strip command_line in
let exit_status =
match (exit_status : Unix.process_status) with
| WEXITED n -> Printf.sprintf "[%d]" n
| WSIGNALED n ->
let name = Signal.of_int n |> Signal.name in
Printf.sprintf "[got signal %s]" name
| WSTOPPED _ -> assert false
in
emit
(t ())
{ Message.level = `Info
; message = "command"
; args =
[ "command_line", Dyn.string command_line
; "outupt", Dyn.string output
; "exit_status", Dyn.string exit_status
]
})
;;
let verbose_message m args = if !verbose then info m args