Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 302 lines (279 sloc) 11.179 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 List = Base.List
19
20 module Q = QmlAst
21 module PackageTbl = ObjectFiles.PackageTbl
22 module Package = ObjectFiles.Package
23
24 let map_on_type_from_pat f pat =
25 QmlAstWalk.Pattern.map_down
26 (fun pat ->
27 match pat with
28 | Q.PatCoerce (label, p, ty) ->
29 let fty = f ty in
30 if ty == fty then pat else
31 Q.PatCoerce (label, p, fty)
32 | _ -> pat)
33 pat
34 let map_on_type_from_expr f expr =
35 QmlAstWalk.ExprPatt.map_down
36 (fun expr ->
37 match expr with
38 | Q.Coerce (label, e, ty) ->
39 let fty = f ty in
40 if ty == fty then expr else
41 Q.Coerce (label, e, fty)
42 | _ -> expr)
43 (fun pat ->
44 match pat with
45 | Q.PatCoerce (label, p, ty) ->
46 let fty = f ty in
47 if ty == fty then pat else
48 Q.PatCoerce (label, p, fty)
49 | _ -> pat)
50 expr
51
52 module MakeFind(Tbl:Hashtbl.S)(Map:BaseMapSig.S with type key = Tbl.key)(Var:Fresh.FRESH with type t = Tbl.key) =
53 struct
54 let h = PackageTbl.create 10
55 let clear () = PackageTbl.clear h
56 let rec just_find (typevar, package_being_refreshed) =
57 try just_find (Tbl.find (PackageTbl.find h package_being_refreshed) typevar)
58 with Not_found -> typevar, package_being_refreshed
59 let find package_being_refreshed typevar =
60 try
61 let (old_var,original_package) =
62 Tbl.find (PackageTbl.find h package_being_refreshed) typevar in
63 assert (original_package = ObjectFiles.get_current_package ());
64 old_var
65 with
66 Not_found ->
67 (* the var is defined in package_being_refreshed *)
68 let newvar = Var.refresh typevar in
69 let h2 =
70 try
71 PackageTbl.find h package_being_refreshed
72 with Not_found ->
73 let h2 = Tbl.create 10 in
74 PackageTbl.add h package_being_refreshed h2;
75 h2 in
76 Tbl.add h2 typevar (newvar, ObjectFiles.get_current_package ());
77 newvar
78 let rec fill package_being_refreshed typevar (old_var, original_package) =
79 let old_var, original_package = just_find (old_var,original_package) in
80 let current_package = ObjectFiles.get_current_package () in
81 if Package.equal original_package current_package then (
82 let h2 =
83 try PackageTbl.find h package_being_refreshed
84 with Not_found ->
85 let h2 = Tbl.create 10 in
86 PackageTbl.add h package_being_refreshed h2;
87 h2 in
88 Tbl.add h2 typevar (old_var, original_package)
89 ) else (
90 let h2 =
91 try PackageTbl.find h original_package
92 with Not_found ->
93 let h2 = Tbl.create 10 in
94 PackageTbl.add h original_package h2;
95 h2 in
96 let newvar = Var.refresh old_var in
97 Tbl.add h2 old_var (newvar,current_package);
98 fill package_being_refreshed typevar (old_var, original_package)
99 )
100 let reverse () =
101 PackageTbl.fold
102 (fun package h2 acc ->
103 Tbl.fold
104 (fun oldvar (freshvar,its_package) acc ->
105 if Package.equal its_package (ObjectFiles.get_current_package ()) then
106 Map.add freshvar (oldvar,package) acc
107 else
108 acc
109 ) h2 acc
110 ) h Map.empty
111 let show f =
112 PackageTbl.iter
113 (fun ident acc ->
114 Format.fprintf f "@\n@[<2>package: %a" Package.pp ident;
115 Tbl.iter
116 (fun var (freshvar,package) ->
117 Format.fprintf f "@\n%s -> %s-%a" (Var.to_string var) (Var.to_string freshvar) Package.pp package;
118 ) acc;
119 Format.fprintf f "@]"
120 ) h
121 end
122 module M_typ = MakeFind(QmlTypeVars.TypeVarTbl)(QmlTypeVars.TypeVarMap)(QmlTypeVars.TypeVar)
123 module M_row = MakeFind(QmlTypeVars.RowVarTbl)(QmlTypeVars.RowVarMap)(QmlTypeVars.RowVar)
124 module M_col = MakeFind(QmlTypeVars.ColVarTbl)(QmlTypeVars.ColVarMap)(QmlTypeVars.ColVar)
125 let find_t = M_typ.find
126 let find_r = M_row.find
127 let find_c = M_col.find
128
129 let refresh_typevars_from_ty package ty =
130 QmlAstWalk.Type.map
131 (function
132 | Q.TypeVar typevar ->
133 let typevar = find_t package typevar in
134 Q.TypeVar typevar
135 | Q.TypeRecord (Q.TyRow (f,Some rowvar)) ->
136 let rowvar = find_r package rowvar in
137 Q.TypeRecord (Q.TyRow (f,Some rowvar))
138 | Q.TypeSum (Q.TyCol (f,Some colvar)) ->
139 let colvar = find_c package colvar in
140 Q.TypeSum (Q.TyCol (f,Some colvar))
141 | Q.TypeForall (ts,rows,cols,ty) ->
142 let ts = List.map (find_t package) ts in
143 let rows = List.map (find_r package) rows in
144 let cols = List.map (find_c package) cols in
145 Q.TypeForall (ts,rows,cols,ty)
146 | typ -> typ
147 ) ty
148 let refresh_typevars_from_expr package expr =
149 map_on_type_from_expr (refresh_typevars_from_ty package) expr
150 let refresh_typevars_from_pat package pat =
151 map_on_type_from_pat (refresh_typevars_from_ty package) pat
152
153 let refresh_typevars_from_tsc package tsc =
154 let {QmlTypeVars.typevar=tl;
155 QmlTypeVars.rowvar=rl;
156 QmlTypeVars.colvar=cl;
157 } = QmlGenericScheme.export_ordered_quantif tsc in
158 let _,ty,() = QmlGenericScheme.export_unsafe tsc in
159 let tl = List.map (find_t package) tl in
160 let rl = List.map (find_r package) rl in
161 let cl = List.map (find_c package) cl in
162 let ty = refresh_typevars_from_ty package ty in
163 let ts = QmlTypeVars.TypeVarSet.from_list tl in
164 let rs = QmlTypeVars.RowVarSet.from_list rl in
165 let cs = QmlTypeVars.ColVarSet.from_list cl in
166 let tsc = QmlGenericScheme.import (QmlTypeVars.FreeVars.import_from_sets ts rs cs) ty () in
167 tsc
168
169 let refresh_gamma package gamma =
170 let refresh_tsc = refresh_typevars_from_tsc package in
171 let gamma = QmlTypes.Env.Ident.map refresh_tsc gamma in
172 QmlTypes.Env.TypeIdent.map
b12589b @fpessaux [feature] Typer: Height of type abbreviation to balance unwinding dur…
fpessaux authored
173 (fun (tsc, height, visibility) -> ((refresh_tsc tsc), height, visibility))
174 gamma
fccc685 Initial open-source release
MLstate authored
175
176 let refresh_typevars_from_code package code =
177 List.map
178 (function
179 | Q.Database _ as c -> c
180 | Q.NewDbValue (a,db_def) ->
181 let (), db_def =
182 Q.Db.foldmap_expr
183 (fun () v -> (), refresh_typevars_from_expr package v) () db_def in
184 let (), db_def =
185 Q.Db.foldmap_ty
186 (fun () v -> (), refresh_typevars_from_ty package v) () db_def in
187 Q.NewDbValue (a, db_def)
188 | Q.NewType (a, ty_defs) ->
189 let ty_defs' =
190 List.map
191 (fun ty_def ->
192 let params' =
193 List.map (find_t package) ty_def.QmlAst.ty_def_params in
194 let body' =
195 refresh_typevars_from_ty package ty_def.QmlAst.ty_def_body in
196 { ty_def with
197 QmlAst.ty_def_params = params' ;
198 QmlAst.ty_def_body = body' })
199 ty_defs in
200 Q.NewType (a, ty_defs')
201 | Q.NewVal (a, iel) ->
202 let iel =
203 List.map
204 (fun (i, e) ->
205 let e = refresh_typevars_from_expr package e in
206 (i,e)) iel in
207 Q.NewVal (a, iel)
208 | Q.NewValRec (a, iel) ->
209 let iel =
210 List.map
211 (fun (i, e) ->
212 let e = refresh_typevars_from_expr package e in
213 (i, e)) iel in
214 Q.NewValRec (a, iel))
215 code
216
217 let refresh_annotmap package annotmap =
218 QmlAnnotMap.map_ty_tsc
219 ~ty: (refresh_typevars_from_ty package)
220 ~tsc: (refresh_typevars_from_tsc package)
221 annotmap
222
223 let refresh_pat package ~annotmap_old annotmap pat =
224 let pat = refresh_typevars_from_pat package pat in
225 let (annotmap, pat) =
226 QmlAstCons.TypedPat.copy_new_when_possible ~annotmap_old annotmap pat in
227 (annotmap, pat)
228
229 let refresh_expr package ~annotmap_old annotmap expr =
230 let expr = refresh_typevars_from_expr package expr in
231 let (annotmap, expr) =
232 QmlAstCons.TypedExpr.copy_new_when_possible ~annotmap_old annotmap expr in
233 (annotmap, expr)
234
235 let refresh_expr_no_annotmap package expr =
236 let expr = refresh_typevars_from_expr package expr in
237 QmlAstWalk.ExprPatt.map Q.QAnnot.Refresh.expr Q.QAnnot.Refresh.pat expr
238
239 let refresh_schema2 package ~refreshed_annotmap_old annotmap schema =
240 let schema =
241 QmlDbGen.Schema.map_types (refresh_typevars_from_ty package) schema in
242 QmlDbGen.Schema.foldmap_expr
243 (refresh_expr package ~annotmap_old: refreshed_annotmap_old) annotmap schema
244
245 let refresh_schema package ~annotmap_old annotmap schema =
246 let annotmap_old = refresh_annotmap package annotmap_old in
247 refresh_schema2 package ~refreshed_annotmap_old: annotmap_old annotmap schema
248
249
250 let restrict_annotmap_expr annotmap ?(acc=QmlAnnotMap.empty) expr =
251 let f extract acc e =
252 let annot = extract e in
253 let annot_content = QmlAnnotMap.find annot annotmap in
254 QmlAnnotMap.add annot annot_content acc in
255 QmlAstWalk.ExprPatt.fold (f Q.QAnnot.expr) (f Q.QAnnot.pat) acc expr
256 let restrict_annotmap_fold_expr fold annotmap ?(acc=QmlAnnotMap.empty) v =
257 fold (fun acc e -> restrict_annotmap_expr annotmap ~acc e) acc v
258
259 let restrict_annotmap_pat annotmap ?(acc=QmlAnnotMap.empty) expr =
260 let f acc e =
261 let annot = Q.QAnnot.pat e in
262 let annot_content = QmlAnnotMap.find annot annotmap in
263 QmlAnnotMap.add annot annot_content acc in
264 QmlAstWalk.Pattern.fold_down f acc expr
265 let restrict_annotmap_fold_pat fold annotmap ?(acc=QmlAnnotMap.empty) v =
266 fold (fun acc e -> restrict_annotmap_pat annotmap ~acc e) acc v
267
268 module Ssubst =
269 struct
270 type t = (
271 (QmlTypeVars.TypeVar.t * Package.t) QmlTypeVars.TypeVarMap.t *
272 (QmlTypeVars.RowVar.t * Package.t) QmlTypeVars.RowVarMap.t *
273 (QmlTypeVars.ColVar.t * Package.t) QmlTypeVars.ColVarMap.t
274 )
275 let pass = "subst"
276 let pp f _ = Format.pp_print_string f "<dummy>"
277 end
278 module Rsubst = ObjectFiles.Make(Ssubst)
279
280 let clear () =
281 M_typ.clear (); M_row.clear (); M_col.clear ()
282 let save () =
283 (*let pp f (v,p) =
284 Format.fprintf f "(%s,%a)" (QmlTypeVars.TypeVar.to_string v) Package.pp p in*)
285 let m1 = M_typ.reverse () in
286 let m2 = M_row.reverse () in
287 let m3 = M_col.reverse () in
288 (*Format.printf "@[<2>saving:@\n";
289 QmlTypeVars.TypeVarMap.iter (fun k v -> Format.printf "%s -> %a@\n" (QmlTypeVars.TypeVar.to_string k) pp v) m1;
290 Format.printf "@]@.";*)
291 Rsubst.save (m1, m2, m3);
292 clear ()
293 let load () =
294 Rsubst.iter_with_name
295 ~packages:true
296 ~deep:true (* this is probably unneeded when the frontier is after ei *)
297 (fun package (ty,row,col) ->
298 QmlTypeVars.TypeVarMap.iter (M_typ.fill package) ty;
299 QmlTypeVars.RowVarMap.iter (M_row.fill package) row;
300 QmlTypeVars.ColVarMap.iter (M_col.fill package) col
301 )
Something went wrong with that request. Please try again.