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
open ExtLib
include Util.Logging (struct
let label = "dose_common.format822"
end)
type loc = Lexing.position * Lexing.position
type value = loc * string
type field = string * value
type stanza = field list
type doc = stanza list
let dummy_loc : loc = (Lexing.dummy_pos, Lexing.dummy_pos)
exception Parse_error_822 of string
exception Syntax_error of string
exception Type_error of string
(** ParseError context list, field name * error *)
exception ParseError of string list * string * string
let error lexbuf msg =
let curr = lexbuf.Lexing.lex_curr_p in
let start = lexbuf.Lexing.lex_start_p in
if curr.Lexing.pos_fname = "" then
Printf.sprintf
"character %d-%d: %s."
(start.Lexing.pos_cnum - start.Lexing.pos_bol)
(curr.Lexing.pos_cnum - curr.Lexing.pos_bol)
msg
else
Printf.sprintf
"File %S, line %d, character %d-%d: %s."
curr.Lexing.pos_fname
start.Lexing.pos_lnum
(start.Lexing.pos_cnum - start.Lexing.pos_bol)
(curr.Lexing.pos_cnum - curr.Lexing.pos_bol)
msg
let raise_error lexbuf c =
let msg = Printf.sprintf "Unexpected token : '%c'" c in
raise (Parse_error_822 (error lexbuf msg))
let error_wrapper t f lexer lexbuf =
let syntax_error msg =
raise (Syntax_error (Printf.sprintf "%s (%s)" (error lexbuf msg) t))
in
try f lexer lexbuf with
| Parsing.Parse_error -> syntax_error "parse error"
| Parse_error_822 s -> syntax_error s
| Failure _m when String.starts_with _m "lexing" -> syntax_error "lexer error"
| Type_error _ -> syntax_error "type error"
let lexbuf_wrapper type_parser type_lexer (label, (_loc, s)) =
try type_parser type_lexer (Lexing.from_string s) with
| Syntax_error m ->
let msg =
Printf.sprintf "Field %s has a wrong value (%s): '%s'" label m s
in
raise (ParseError ([], label, msg))
| Parsing.Parse_error ->
let msg = Printf.sprintf "Field %s has a wrong value: '%s'" label s in
raise (ParseError ([], label, msg))
let string_of_loc (start_pos, end_pos) =
let line { Lexing.pos_lnum = l; _ } = l in
if line start_pos = line end_pos then
Printf.sprintf "line: %d" (line start_pos)
else Printf.sprintf "lines: %d-%d" (line start_pos) (line end_pos)
type f822_parser = { lexbuf : Lexing.lexbuf; fname : string }
let from_channel ic =
let f s n = try IO.input ic s 0 n with IO.No_more_input -> 0 in
{ lexbuf = Lexing.from_function f; fname = "from-input-channel" }
let parser_wrapper_ch ic _parser = _parser (from_channel ic)
let parse_from_ch _parser ic =
try parser_wrapper_ch ic _parser with
| Syntax_error msg -> fatal "%s" msg
| Parse_error_822 msg -> fatal "%s" msg
let timer = Util.Timer.create "Format822"
module RawInput (Set : Set.S) = struct
let input_raw parse files =
Util.Timer.start timer ;
if List.length files > 1 then info "Merging repositories" ;
let s =
List.fold_left
(fun acc file ->
try
let ch =
match file with
| "-" -> IO.input_channel stdin
| _ -> Input.open_file file
in
let l = parse file ch in
let _ = Input.close_ch ch in
List.fold_left (fun s x -> Set.add x s) acc l
with Input.File_empty -> acc)
Set.empty
files
in
Parsing.clear_parser () ;
info "total packages %n" (Set.cardinal s) ;
Util.Timer.stop timer (Set.elements s)
let input_raw_in parse ch =
Util.Timer.start timer ;
let s =
let l = parse "" ch in
List.fold_left (fun s x -> Set.add x s) Set.empty l
in
info "total packages %n" (Set.cardinal s) ;
Util.Timer.stop timer (Set.elements s)
end