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
open Core
module Syntax = Webidl_syntax
type data = Data.definitions [@@deriving sexp]
type src_type =
| File
| Channel
| String
[@@deriving sexp]
type syntax_error =
{ src : string
; src_type : src_type
; start_pos : int * int
; end_pos : int * int
; token : string
; strict : bool
; around : string
}
[@@deriving sexp]
exception Syntax_error of syntax_error
let get_around get_substr sp ep =
let around_sp = max (sp - 20) 0 in
let around_ep = ep + 20 in
let around =
try get_substr around_sp around_ep with
| _ -> get_substr around_sp ep
in
"..." ^ around ^ "..."
;;
let get_error_info strict src src_type get_substr lexbuf =
let open Lexing in
let start = Lexing.lexeme_start_p lexbuf in
let end_ = Lexing.lexeme_end_p lexbuf in
let token = Lexing.lexeme lexbuf in
let start_pos = start.pos_lnum, start.pos_cnum - start.pos_bol + 1 in
let end_pos = end_.pos_lnum, end_.pos_cnum - end_.pos_bol + 1 in
let around = get_around get_substr start.pos_cnum end_.pos_cnum in
{ src; src_type; start_pos; end_pos; token; strict; around }
;;
let main ?(strict = true) src src_type lexbuf get_substr =
let module Strict = struct
let strict = strict
end
in
let module Parser_basic_extend = Syntax.Parser_extend.Make (Strict) in
let module Parser_extend = struct
let main sp ep =
let ext = get_substr sp ep in
let lexbuf = Lexing.from_string ext in
try Parser_basic_extend.ext_main Syntax.Lexer.read lexbuf with
| Parser_basic_extend.Error | Caml.Parsing.Parse_error -> `Custom ext
;;
end
in
let module Parser = Syntax.Parser.Make (Strict) (Parser_extend) in
try Parser.main Syntax.Lexer.read lexbuf with
| Parser.Error | Caml.Parsing.Parse_error ->
let syntax_error =
get_error_info strict src src_type get_substr lexbuf
in
raise (Syntax_error syntax_error)
;;
let ast_from_string ?(strict = true) src_name input_string =
let get_substr sp ep = String.sub input_string ~pos:sp ~len:(ep - sp) in
let lexbuf = Lexing.from_string input_string in
main ~strict src_name String lexbuf get_substr
;;
let ast_from_channel ?(strict = true) src_name input_channel =
let input_string =
Stdlib.really_input_string
input_channel
(In_channel.length input_channel |> Int64.to_int_exn)
in
let get_substr sp ep = String.sub input_string ~pos:sp ~len:(ep - sp) in
let lexbuf = Lexing.from_string input_string in
main ~strict src_name Channel lexbuf get_substr
;;
let ast_from_file ?(strict = true) file_name =
let input_channel = Stdlib.open_in file_name in
let lexbuf = Lexing.from_channel input_channel in
let get_substr sp ep =
let now_pos = Stdlib.pos_in input_channel in
Stdlib.seek_in input_channel sp;
let ans = Stdlib.really_input_string input_channel (ep - sp) in
Stdlib.seek_in input_channel now_pos;
ans
in
main ~strict file_name File lexbuf get_substr
;;
let data_from_string ?(strict = true) src_name input_string =
ast_from_string ~strict src_name input_string
|> Ast_to_data.of_difinitions
;;
let data_from_channel ?(strict = true) src_name input_channel =
ast_from_channel ~strict src_name input_channel
|> Ast_to_data.of_difinitions
;;
let data_from_file ?(strict = true) file_name =
ast_from_file ~strict file_name |> Ast_to_data.of_difinitions
;;