Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 84 lines (74 sloc) 3.053 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 (* depends *)
19 module List = Base.List
20
21 (* shorthands *)
22 module Q = QmlAst
23
24
25 module S =
26 struct
27 type t = QmlTypes.gamma
28 let pass = "pass_TypeDefinition"
29 let pp f _ = Format.pp_print_string f "<dummy>"
30 end
31
32 module R = ObjectFiles.Make(S)
33
34 let process_code register typerEnv code =
35 let new_gamma = QmlTypes.Env.empty in
36 let gamma = typerEnv.QmlTypes.gamma in
37 let gamma =
38 (* during pre_linking, the whole gamma is loaded
39 because dbGen loads the whole database schema *)
40 let options_packages = ObjectFiles.compilation_mode() = `init in
41 R.fold_with_name
42 ~packages: options_packages
43 ~deep:true (* need to go deep because you can depend directly on a unit
44 * that says type t = u
45 * when u is defined in another package saying type u = v
46 * when v is defined in another package etc.
47 *)
48 (fun package acc_gamma gamma ->
49 let gamma = QmlRefresh.refresh_gamma package gamma in
50 QmlTypes.Env.append acc_gamma gamma)
51 gamma in
52 let typerEnv = { typerEnv with QmlTypes.gamma = gamma } in
53 (* Rgeister fields declared on [ty] *)
54 let rec register_type ty =
55 let reg_fields = List.iter (fun (x,_) -> register x) in
56 QmlAstWalk.Type.iter
57 (function
58 | Q.TypeRecord (Q.TyRow (fields, _)) -> reg_fields fields
59 | Q.TypeSum (Q.TyCol (fields, _)) -> List.iter reg_fields fields
60 | _ -> ()
61 )
62 ty
63 in
64 let ((local_typedefs, new_gamma, typerEnv), code) =
65 let aux ((local_typedefs, new_gamma, typerEnv) as acc) = function
66 | Q.NewType (_, typedefs) as code_elt ->
67 (* BEWARE: types such as #private_Date.date are not considered as being locals *)
68 let local_typedefs =
69 List.fold_left
70 (fun acc ty_def ->
71 register_type ty_def.Q.ty_def_body;
72 Q.TypeIdentSet.add ty_def.QmlAst.ty_def_name acc)
73 local_typedefs
74 typedefs in
75 let (new_gamma, typerEnv) =
76 QmlTyper.OfficialTyper.type_newtype_for_separation
77 ~more_gamma: new_gamma typerEnv code_elt typedefs in
78 (local_typedefs, new_gamma, typerEnv), None
79 | code_elt -> (acc, (Some code_elt)) in
80 List.fold_left_filter_map
81 aux (Q.TypeIdentSet.empty,new_gamma,typerEnv) code in
82 R.save new_gamma ;
83 (local_typedefs, typerEnv, code)
Something went wrong with that request. Please try again.