Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 119 lines (112 sloc) 4.524 kb
fccc685 Initial open-source release
MLstate authored
1 (*
2 Copyright © 2011 MLstate
3
4 This file is part of OPA.
5
6 OPA is free software: you can redistribute it and/or modify it under the
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
10 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
13 more details.
14
15 You should have received a copy of the GNU Affero General Public License
16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 *)
18 module P = Passes
19 module Q = QmlAst
20
21 module S =
22 struct
23 type t = {
24 pesc_code : QmlAst.code;
25 pesc_doc_types : Ident.t P.doc_types;
26 pesc_annotmap : QmlAst.annotmap;
27 pesc_gamma : QmlTypes.gamma;
28 pesc_schema : QmlDbGen.Schema.t;
29 }
30 let pass = ObjectFiles.last_pass
31 let pp f _ = Format.pp_print_string f "<dummy>"
32 end
33 module R = ObjectFiles.Make(S)
34
35 let process_code :
36 'tmp_env Passes.env_Gen ->
37 ('tmp_env Passes.env_Gen -> unit) ->
38 unit =
39 fun env k ->
40 let initial =
41 { S.pesc_doc_types = []
42 ; S.pesc_code = []
43 ; S.pesc_annotmap = QmlAnnotMap.empty
44 ; S.pesc_gamma = QmlTypes.Env.empty
45 ; S.pesc_schema = QmlDbGen.Schema.initial } in
46 let merge_code_annotmap ?package (code1,annotmap1,s1) (code2,annotmap2,s2) =
47 let annotmap, code2, s2 =
48 match package with
49 | Some package ->
50 let code2 = QmlRefresh.refresh_typevars_from_code package code2 in
51 let annotmap2 = QmlRefresh.refresh_annotmap package annotmap2 in
52 let annotmap, code2 =
53 QmlAstCons.TypedCode.copy_new_when_possible
54 ~annotmap_old:annotmap2 annotmap1 code2 in
55 let annotmap, s2 =
56 QmlRefresh.refresh_schema2 package ~refreshed_annotmap_old:annotmap2
57 annotmap s2 in
58 annotmap, code2, s2
59 | None ->
60 QmlAnnotMap.merge annotmap1 annotmap2, code2, s2 in
61 (code1 @ code2, annotmap, QmlDbGen.Schema.merge s1 s2) in
62 let merge_gamma ?package gamma1 gamma2 =
63 let gamma2 =
64 match package with
65 | Some package -> QmlRefresh.refresh_gamma package gamma2
66 | None -> gamma2 in
67 QmlTypes.Env.append gamma1 gamma2 in
68 let merge_doc = (@) in
69 let merge ?package
70 {S.pesc_code=code1; S.pesc_doc_types=doc1;
71 S.pesc_annotmap=annotmap1;
72 S.pesc_gamma=gamma1; S.pesc_schema = schema1}
73 {S.pesc_code=code2; S.pesc_doc_types=doc2;
74 S.pesc_annotmap=annotmap2;
75 S.pesc_gamma=gamma2; S.pesc_schema = schema2} =
76 let code,annotmap,schema = merge_code_annotmap ?package (code1,annotmap1,schema1) (code2,annotmap2,schema2) in
77 {S.pesc_code = code;
78 S.pesc_doc_types = merge_doc doc1 doc2;
79 S.pesc_annotmap = annotmap;
80 S.pesc_gamma = merge_gamma ?package gamma1 gamma2;
81 S.pesc_schema = schema;
82 } in
83 if ObjectFiles.Arg.is_fully_separated () then
84 k env
85 else (
86 match ObjectFiles.compilation_mode () with
87 | `init ->
88 k env
89 | `linking | `prelude ->
90 QmlRefresh.load ();
91 (*Format.printf "show:%t@." M_typ.show;*)
92 let acc = R.fold_with_name ~packages:true ~deep:true (fun package -> merge ~package) initial in
93 let code,annotmap,schema =
94 merge_code_annotmap
95 (acc.S.pesc_code,acc.S.pesc_annotmap,acc.S.pesc_schema)
96 (env.P.qmlAst,env.P.typerEnv.QmlTypes.annotmap,env.P.typerEnv.QmlTypes.schema) in
97 let env = {env with P.
98 doc_types = merge_doc acc.S.pesc_doc_types env.P.doc_types;
99 qmlAst = code;
100 typerEnv = {env.P.typerEnv with QmlTypes.annotmap = annotmap;
101 QmlTypes.gamma = merge_gamma acc.S.pesc_gamma env.P.typerEnv.QmlTypes.gamma;
102 QmlTypes.schema = schema;
103 };
104 } in
105 ObjectFiles.end_of_separate_compilation ();
106 QmlRefresh.clear ();
107 k env
108 | `compilation ->
109 QmlRefresh.save ();
110 let t = {S.pesc_code = env.P.qmlAst;
111 S.pesc_doc_types = env.P.doc_types;
112 S.pesc_annotmap = env.P.typerEnv.QmlTypes.annotmap;
113 S.pesc_gamma = env.P.typerEnv.QmlTypes.gamma;
114 S.pesc_schema = env.P.typerEnv.QmlTypes.schema;
115 } in
116 R.save t;
117 ObjectFiles.compilation_is_successfull ()
118 )
Something went wrong with that request. Please try again.