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
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
|
open StdLabels
module Table = ImportDataTypes.Table
module Path = ImportDataTypes.Path
module ExpressionParser : sig
type 'a path_builder
val path : Path.t path_builder
val column : Path.column path_builder
val of_string :
'a path_builder -> string -> ('a ImportExpression.T.t, string) result
end = struct
module MI = Expression_parser.MenhirInterpreter
module E = MenhirLib.ErrorReports
module L = MenhirLib.LexerUtil
type error = {
message : string;
start_line : int;
start_pos : int;
end_pos : int;
}
let range_message start_pos end_pos message =
let start_c = start_pos.Lexing.pos_cnum - start_pos.Lexing.pos_bol
and end_c = end_pos.Lexing.pos_cnum - end_pos.Lexing.pos_bol in
{
message;
start_line = start_pos.Lexing.pos_bol;
start_pos = start_c;
end_pos = end_c;
}
(** Extract the line in error from the whole expression, and print some
characters just under the faulty part *)
let get_line_error : error -> string -> string =
fun error content ->
let sub_text =
try
let end_pos = String.index_from content error.start_line '\n' in
String.sub content ~pos:error.start_line
~len:(end_pos - error.start_line)
with
| Not_found ->
(* There is no new line, extract the ending part *)
let len = String.length content - error.start_line in
String.sub content ~pos:error.start_line ~len
in
(* I’m not sure how to produce it, but the error may be over two lines.
This line is here to prevent the underline to overflow. *)
let stop_pos = min error.end_pos (String.length sub_text) in
let error_length = stop_pos - error.start_pos in
String.concat ~sep:""
[
sub_text;
"\n";
String.make error.start_pos ' ';
String.make error_length '^';
]
let get_parse_error default_position env : error =
match MI.stack env with
| (lazy Nil) ->
range_message default_position.Lexing.lex_start_p
default_position.Lexing.lex_curr_p "Invalid syntax\n"
| (lazy (Cons (MI.Element (state, _, start_pos, end_pos), _))) ->
let message =
try Expression_parser_messages.message (MI.number state) with
| Not_found -> "Invalid syntax (no specific message for this eror)\n"
in
range_message start_pos end_pos message
type 'a path_builder =
Lexing.position -> 'a ImportExpression.T.t MI.checkpoint
let rec _parse lexbuf (checkpoint : 'a ImportExpression.T.t MI.checkpoint) =
match checkpoint with
| MI.InputNeeded _env ->
let token = Expression_lexer.token lexbuf in
let startp = lexbuf.lex_start_p and endp = lexbuf.lex_curr_p in
let checkpoint = MI.offer checkpoint (token, startp, endp) in
_parse lexbuf checkpoint
| MI.Shifting _ | MI.AboutToReduce _ ->
let checkpoint = MI.resume checkpoint in
_parse lexbuf checkpoint
| MI.HandlingError _env ->
let err = get_parse_error lexbuf _env in
Error err
| MI.Accepted v -> Ok v
| MI.Rejected ->
let err =
range_message lexbuf.lex_start_p lexbuf.lex_curr_p
"invalid syntax (parser rejected the input)"
in
Error err
let of_string :
'a path_builder -> string -> ('a ImportExpression.T.t, string) result =
fun f str_expression ->
try
let lexbuf = Lexing.from_string str_expression in
let init = f lexbuf.lex_curr_p in
match _parse lexbuf init with
| Ok res -> Ok res
| Error e ->
let message =
String.concat ~sep:"\n"
[ e.message; get_line_error e str_expression ]
in
Error message
with
| Expression_lexer.UnclosedQuote { line; content } ->
let message =
Printf.sprintf "Unclosed quote at line %d : \"%s\"" line content
in
Error message
| e ->
let message = Printexc.to_string e in
Error message
let path = Expression_parser.Incremental.path_expr
let column = Expression_parser.Incremental.column_expr
end
module Make (S : Decoders.Decode.S) = struct
let ( let* ) = S.( let* )
let ( and* ) = S.( and* )
let ( >>= ) = S.( >>= )
let ( >|= ) = S.( >|= )
class loader =
object (self)
method parse_expression : type a.
a ExpressionParser.path_builder ->
S.value ->
(a ImportExpression.T.t, S.value Decoders.Error.t) result =
fun path ->
S.string >>= fun v ->
match ExpressionParser.of_string path v with
| Ok expr -> S.succeed expr
| Error e -> S.fail_with Decoders.Error.(make e)
method source =
let* file = S.field "file" S.string
and* name = S.field "name" S.string
and* tab = S.field_opt_or ~default:1 "tab" S.int in
S.succeed { Table.file; name; tab }
method external_ name =
let* intern_key =
S.field "intern_key" (self#parse_expression ExpressionParser.path)
and* extern_key =
S.field "extern_key" (self#parse_expression ExpressionParser.column)
and* file = S.field "file" S.string
and* tab = S.field_opt_or ~default:1 "tab" S.int
and* allow_missing =
S.field_opt_or ~default:false "allow_missing" S.bool
in
S.succeed
Syntax.
{
intern_key;
extern_key;
target = { name; file; tab };
allow_missing;
match_rule = None;
}
method sheet =
let* columns =
S.field "columns"
@@ S.list (self#parse_expression ExpressionParser.path)
and* filters =
S.field_opt_or ~default:[] "filters"
@@ S.list (self#parse_expression ExpressionParser.path)
and* sort =
S.field_opt_or ~default:[] "sort"
@@ S.list (self#parse_expression ExpressionParser.path)
and* uniq =
S.field_opt_or ~default:[] "uniq"
@@ S.list (self#parse_expression ExpressionParser.path)
in
S.succeed @@ fun version source externals ->
Syntax.{ version; source; externals; columns; filters; sort; uniq }
method conf =
let* source = S.field "source" self#source
and* externals =
S.field_opt_or ~default:[] "externals"
(S.key_value_pairs_seq self#external_)
in
let* sheet =
S.field "sheet" self#sheet >|= fun v -> v 1 source externals
in
S.succeed sheet
end
let read_file file =
S.decode_file (new loader)#conf file
|> Result.map_error (fun v ->
let formatter = Format.str_formatter in
Format.fprintf formatter "%a@." S.pp_error v;
Format.flush_str_formatter ())
let read toml =
S.decode_value (new loader)#conf toml
|> Result.map_error (fun v ->
let formatter = Format.str_formatter in
Format.fprintf formatter "%a@." S.pp_error v;
Format.flush_str_formatter ())
end
|
