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
open Printf
let syntax_error (lexbuf : Lexing.lexbuf) =
let pos = lexbuf.lex_curr_p in
let msg = sprintf "Syntax error:\n%s" (Ast.string_of_loc (pos, pos)) in
Ast.error msg
let read_lexbuf
?annot_schema
?(expand = false)
?keep_builtins
?keep_poly
?(xdebug = false)
?(inherit_fields = false)
?(inherit_variants = false)
?(pos_fname = "")
?(pos_lnum = 1)
lexbuf =
Lexer.init_fname lexbuf pos_fname pos_lnum;
let module_ =
try Parser.module_ Lexer.token lexbuf
with Parser.Error -> syntax_error lexbuf
in
Check.check module_;
let locals = Imports.load module_.imports in
Imports.check_type_refs locals module_.type_defs;
Imports.warn_unused_imports locals module_.type_defs;
let type_defs =
if inherit_fields || inherit_variants then
Inherit.expand_module_body ~inherit_fields ~inherit_variants
module_.imports module_.type_defs
else
module_.type_defs
in
let type_defs =
if expand then
Expand.expand_type_defs ?keep_builtins ?keep_poly ~debug: xdebug
type_defs
else
type_defs
in
let module_ =
{ module_ with type_defs }
in
(match annot_schema with
| None -> ()
| Some schema ->
Annot.validate schema (Ast.Module module_)
);
module_
let read_channel
?annot_schema ?expand ?keep_builtins ?keep_poly ?xdebug
?inherit_fields ?inherit_variants
?pos_fname ?pos_lnum
ic =
let lexbuf = Lexing.from_channel ic in
let pos_fname =
if pos_fname = None && ic == stdin then
Some "<stdin>"
else
pos_fname
in
read_lexbuf ?annot_schema ?expand ?keep_builtins ?keep_poly ?xdebug
?inherit_fields ?inherit_variants ?pos_fname ?pos_lnum lexbuf
let load_file
?annot_schema ?expand ?keep_builtins ?keep_poly ?xdebug
?inherit_fields ?inherit_variants
?pos_fname ?pos_lnum
file =
let ic = open_in file in
let finally () = close_in_noerr ic in
try
let pos_fname =
match pos_fname with
None -> Some file
| Some _ -> pos_fname
in
let ast =
read_channel
?annot_schema ?expand ?keep_builtins ?keep_poly ?xdebug
?inherit_fields ?inherit_variants ?pos_fname ?pos_lnum ic
in
finally ();
ast
with e ->
finally ();
raise e
let load_string
?annot_schema ?expand ?keep_builtins ?keep_poly ?xdebug
?inherit_fields ?inherit_variants
?pos_fname ?pos_lnum
s =
let lexbuf = Lexing.from_string s in
read_lexbuf ?annot_schema ?expand ?keep_builtins ?keep_poly ?xdebug
?inherit_fields ?inherit_variants ?pos_fname ?pos_lnum lexbuf
module Tsort = Sort.Make (
struct
type t = Ast.type_def
type id = Ast.type_name
let id (x : t) = x.name
let to_string name = Print.tn name
end
)
let tsort ?(all_rec = false) type_defs0 =
let ignorable : Ast.type_name list = [
TN ["unit"];
TN ["bool"];
TN ["int"];
TN ["float"];
TN ["string"];
TN ["abstract"]
] in
if all_rec then
[(true, type_defs0)]
else
let type_defs =
List.map (fun (x : Ast.type_def) ->
let deps = Ast.extract_type_names ~ignorable x.value in
(x, deps)
) type_defs0
in
List.rev (Tsort.sort type_defs)