Source file cinaps_runtime.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
open StdLabels
let in_place = ref false
let styler = ref None
let diff_command = ref None
let use_color = ref false
let args =
let open Arg in
[ "-i", Set in_place,
" Update the file in-place"
;"-diff-cmd", String (fun s -> diff_command := Some s),
" Diff command when using code expectations"
; "-no-color", Clear use_color,
" Don't use colors when printing errors"
; "-styler", String (fun s -> styler := Some s),
" Code styler"
]
let init () =
let usage =
Printf.sprintf "%s <options>" Sys.executable_name
in
let anon fn =
raise (Arg.Bad (Printf.sprintf "Don't know what to do with %S." fn))
in
Arg.parse (Arg.align args) anon usage
module Print_diff = struct
let patdiff_cmd () =
let args =
List.concat [
["-keep-whitespace"];
["-location-style omake"];
(if !use_color then ["-unrefined"] else ["-ascii"]);
]
in
String.concat ~sep:" " ("patdiff" :: args)
let print ~file1 ~file2 =
let exec cmd =
let cmd =
Printf.sprintf "%s %s %s 1>&2" cmd (Filename.quote file1) (Filename.quote file2)
in
match Sys.command cmd with
| 0 -> true
| 1 -> false
| n -> Printf.eprintf "%S exited with code %d\n" cmd n; exit 2
in
match !diff_command with
| Some s -> ignore (exec s : bool)
| None ->
if exec (patdiff_cmd ()) then (
Printf.eprintf "File \"%s\", line 1, characters 0-0:\n%!" file1;
ignore (exec "diff -u" : bool);
)
end
let failure = ref false
let current_file_contents = ref ""
let copy_input pos len = output_substring stdout !current_file_contents pos len
let input_sub pos len = String.sub !current_file_contents ~pos ~len
let protect ~finally ~f =
match f () with
| x -> finally (); x
| exception e -> finally (); raise e
let read_file fn =
let ic = open_in_bin fn in
let len = in_channel_length ic in
let s = really_input_string ic len in
close_in ic;
s
let write_file fn s =
let oc = open_out_bin fn in
output_string oc s;
close_out oc
let process_file ~file_name ~file_contents f =
let tmp_fn, oc = Filename.open_temp_file "cinaps" (Filename.extension file_name) in
let expected =
protect ~finally:(fun () -> Sys.remove tmp_fn) ~f:(fun () ->
let stdout_copy = Unix.dup Unix.stdout in
Unix.dup2 (Unix.descr_of_out_channel oc) Unix.stdout;
close_out oc;
current_file_contents := file_contents;
f ();
flush stdout;
Unix.close Unix.stdout;
Unix.dup2 stdout_copy Unix.stdout;
Unix.close stdout_copy;
match Filename.extension file_name, !styler with
| (".ml" | ".mli"), Some cmd -> begin
let cmd =
String.concat ~sep:""
(match String.split_on_char cmd ~sep:'%' with
| [] -> assert false
| x :: l ->
x :: List.map l ~f:(fun s ->
let len = String.length s in
if len > 0 && s.[0] = 'i' then
(Filename.quote file_name) ^ String.sub s ~pos:1 ~len:(len - 1)
else
"%" ^ s))
in
let cmd = Printf.sprintf "%s %s" cmd (Filename.quote tmp_fn) in
let ic = Unix.open_process_in cmd in
let s =
let file_len = String.length file_contents in
let buf = Buffer.create file_len in
try
Buffer.add_channel buf ic file_len;
while true do Buffer.add_channel buf ic 65536 done;
assert false
with End_of_file ->
Buffer.contents buf
in
match Unix.close_process_in ic with
| WEXITED 0 -> s
| WEXITED n ->
Printf.eprintf "command exited with code %d: %s\n" n cmd;
exit 1
| WSIGNALED n ->
Printf.eprintf "command got signal %d: %s\n" n cmd;
exit 1
| WSTOPPED _ -> assert false
end
| _ -> read_file tmp_fn)
in
let corrected_fn = file_name ^ ".cinaps-corrected" in
if file_contents = expected then begin
if Sys.file_exists corrected_fn then Sys.remove corrected_fn
end else if !in_place then
write_file file_name expected
else begin
write_file corrected_fn expected;
match !diff_command with
| Some "-" ->
()
| _ ->
failure := true;
Print_diff.print
~file1:file_name
~file2:corrected_fn
end
let exit () =
exit (if !failure then 1 else 0)