forked from rescript-lang/rescript
-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathjs_implementation.ml
184 lines (157 loc) · 7 KB
/
js_implementation.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
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
(***********************************************************************)
(* *)
(* OCaml *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 2002 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed *)
(* under the terms of the Q Public License version 1.0. *)
(* *)
(***********************************************************************)
(* adapted by bucklescript from [driver/compile.ml] for convenience *)
open Format
open Typedtree
open Compenv
let fprintf = Format.fprintf
let dummy_unused_attribute : Warnings.t = (Bs_unused_attribute "")
let print_if ppf flag printer arg =
if !flag then fprintf ppf "%a@." printer arg;
arg
let after_parsing_sig ppf sourcefile outputprefix ast =
if !Js_config.binary_ast then
begin
Binary_ast.write_ast
Mli
~fname:sourcefile
~output:(outputprefix ^ Literals.suffix_mliast)
(* to support relocate to another directory *)
ast
end;
if !Js_config.syntax_only then () else
begin
if Warnings.is_active dummy_unused_attribute then
Bs_ast_invariant.emit_external_warnings.signature Bs_ast_invariant.emit_external_warnings ast ;
if Js_config.get_diagnose () then
Format.fprintf Format.err_formatter "Building %s@." sourcefile;
let modulename = module_of_filename ppf sourcefile outputprefix in
Lam_compile_env.reset () ;
let initial_env = Compmisc.initial_env () in
Env.set_unit_name modulename;
let tsg = Typemod.type_interface initial_env ast in
if !Clflags.dump_typedtree then fprintf ppf "%a@." Printtyped.interface tsg;
let sg = tsg.sig_type in
if !Clflags.print_types then
Printtyp.wrap_printing_env initial_env (fun () ->
fprintf std_formatter "%a@."
Printtyp.signature (Typemod.simplify_signature sg));
ignore (Includemod.signatures initial_env sg sg);
Typecore.force_delayed_checks ();
Warnings.check_fatal ();
if not !Clflags.print_types then begin
let sg = Env.save_signature sg modulename (outputprefix ^ ".cmi") in
Typemod.save_signature modulename tsg outputprefix sourcefile
initial_env sg ;
end
end
let interface ppf sourcefile outputprefix =
Compmisc.init_path false;
Ocaml_parse.parse_interface ppf sourcefile
|> print_if ppf Clflags.dump_parsetree Printast.interface
|> print_if ppf Clflags.dump_source Pprintast.signature
|> after_parsing_sig ppf sourcefile outputprefix
let interface_mliast ppf sourcefile outputprefix =
Compmisc.init_path false;
Binary_ast.read_ast Mli sourcefile
|> print_if ppf Clflags.dump_parsetree Printast.interface
|> print_if ppf Clflags.dump_source Pprintast.signature
|> after_parsing_sig ppf sourcefile outputprefix
let after_parsing_impl ppf sourcefile outputprefix ast =
if !Js_config.binary_ast then
Binary_ast.write_ast ~fname:sourcefile
Ml ~output:(outputprefix ^ Literals.suffix_mlast)
ast ;
if !Js_config.syntax_only then () else
begin
if Warnings.is_active dummy_unused_attribute then
Bs_ast_invariant.emit_external_warnings.structure Bs_ast_invariant.emit_external_warnings ast ;
if Js_config.get_diagnose () then
Format.fprintf Format.err_formatter "Building %s@." sourcefile;
let modulename = Compenv.module_of_filename ppf sourcefile outputprefix in
Lam_compile_env.reset () ;
let env = Compmisc.initial_env() in
Env.set_unit_name modulename;
try
let (typedtree, coercion, finalenv, current_signature) =
ast
|> Typemod.type_implementation_more sourcefile outputprefix modulename env
|> print_if ppf Clflags.dump_typedtree
(fun fmt (ty,co,_,_) -> Printtyped.implementation_with_coercion fmt (ty,co))
in
if !Clflags.print_types then begin
Warnings.check_fatal ();
end else begin
(typedtree, coercion)
|> Translmod.transl_implementation modulename
|> print_if ppf Clflags.dump_rawlambda Printlambda.lambda
|> (fun lambda ->
try
Lam_compile_main.lambda_as_module
finalenv current_signature
sourcefile outputprefix lambda with
| e ->
(* Save to a file instead so that it will not scare user *)
(if Js_config.get_diagnose () then
begin
let file = "bsc.dump" in
Ext_pervasives.with_file_as_chan file
(fun ch -> output_string ch @@
Printexc.raw_backtrace_to_string (Printexc.get_raw_backtrace ()));
Ext_log.err __LOC__
"Compilation fatal error, stacktrace saved into %s when compiling %s"
file sourcefile;
end;
raise e)
);
end;
Stypes.dump (Some (outputprefix ^ ".annot"));
with x ->
Stypes.dump (Some (outputprefix ^ ".annot"));
raise x
end
let implementation ppf sourcefile outputprefix =
Compmisc.init_path false;
Ocaml_parse.parse_implementation ppf sourcefile
|> print_if ppf Clflags.dump_parsetree Printast.implementation
|> print_if ppf Clflags.dump_source Pprintast.structure
|> after_parsing_impl ppf sourcefile outputprefix
let implementation_mlast ppf sourcefile outputprefix =
Compmisc.init_path false;
Binary_ast.read_ast Ml sourcefile
|> print_if ppf Clflags.dump_parsetree Printast.implementation
|> print_if ppf Clflags.dump_source Pprintast.structure
|> after_parsing_impl ppf sourcefile outputprefix
let make_structure_item ~ns cunit : Parsetree.structure_item =
let open Ast_helper in
let loc = Location.none in
Str.module_
(Mb.mk {txt = cunit; loc }
(Mod.ident
{txt = Lident
( Ext_namespace.make ~ns cunit)
; loc}))
let implementation_map ppf sourcefile outputprefix =
let list_of_modules = Ext_io.rev_lines_of_file sourcefile
in
let ns =
Ext_string.capitalize_ascii
(Filename.chop_extension (Filename.basename sourcefile)) in
let ml_ast = List.fold_left (fun acc module_name ->
if Ext_string.is_empty module_name then acc
else make_structure_item ~ns module_name :: acc
) [] list_of_modules in
Compmisc.init_path false;
ml_ast
|> print_if ppf Clflags.dump_parsetree Printast.implementation
|> print_if ppf Clflags.dump_source Pprintast.structure
|> after_parsing_impl ppf sourcefile outputprefix