Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 272 lines (240 sloc) 10.033 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
19 (* see .mli *)
20
21 (* depends *)
22 module Format = Base.Format
23 module List = BaseList
24
25 (* shorthands *)
26 module Q = QmlAst
27
28 (* aliases *)
29 module TypeIdent = QmlAst.TypeIdent
30 module TypeIdentSet = QmlAst.TypeIdentSet
31 module TypeVarSet = QmlTypeVars.TypeVarSet
32
33 (* refactoring in progress *)
34 let (|>) = InfixOperator.(|>)
35 let (@*) = InfixOperator.(@*)
36
37 (* go *)
38
39 module Basic = struct
40 let string = Q.TypeConst(Q.TyString)
41 end
42
43 module Inspect =
44 struct
45 (** Way too many functions with very close names !! Which one should I use ? Needs doc !! *)
46 (* Here there are many function in "*_no_sum" version, which are
47 intended for compatibility with old qmlkernel (where there were lists
48 instead of sums). There is no good reason to use them any more.
49 *)
50
51 (* Can raise exception [QmlTyperException.Exception]. *)
52 let find_and_specialize gamma typeident args =
53 (* This function is used by the back-end and needs to access representation
54 of types anyway. The typechecking will have to have ensured that types
55 even if not legally visible were used in a consistent way. *)
b12589b @fpessaux [feature] Typer: Height of type abbreviation to balance unwinding dur…
fpessaux authored
56 let (typescheme, _) =
fccc685 Initial open-source release
MLstate authored
57 QmlTypes.Env.TypeIdent.find ~visibility_applies: false typeident gamma in
58 let out = QmlTypes.Scheme.specialize ~typeident ~ty: args typescheme in
59 begin
60 #<If:TYPER>
61 let compare_record (a, _) (b, _) = Pervasives.compare a b in
62 let sort_record r = List.sort compare_record r in
63 let compare_sum a b =
64 let a = sort_record a in
65 let b = sort_record b in
66 (List.make_compare compare_record) a b
67 in
68 let check compare print li =
69 match li with
70 | hd::tl ->
71 if List.fold_left
72 (fun (b, s) s2 ->
73 let c = compare s s2 in
74 if c >= 0 then (true, s2)
75 else (b, s2)
76 )
77 (false, hd) tl
78 |> fst
79 then (
80 print ();
81 let err_ctxt = QmlError.Context.ty out in
82 QmlError.i_error
83 None err_ctxt
84 "the typename : %s has non-ordonned fields"
85 (TypeIdent.to_string typeident)
86 )
87 else ()
88 | _ -> ()
89 in
90 begin match out with
91 | Q.TypeSum (Q.TyCol (li, _)) ->
92 check compare_sum (fun () ->
93 List.iter (fun li ->
94 prerr_endline (String.concat ", " (List.map fst li))
95 ) li
96 ) li
97 | Q.TypeRecord (Q.TyRow (li, _) ) ->
98 check compare_record (fun () -> List.iter (prerr_endline @* fst) li) li
99 | _ -> ()
100 end;
101 #<End>;
102 out
103 end
104
105 let follow_alias gamma = function
106 | Q.TypeName (l, s)-> Some (find_and_specialize gamma s l)
107 | _ -> None
108
109 let follow_alias_noopt gamma t =
110 let rec aux memo t =
111 match t with
112 | Q.TypeName (l, s) ->
113 if TypeIdentSet.mem s memo then t (* infinite named type *) else
114 let memo = TypeIdentSet.add s memo in
115 aux memo (find_and_specialize gamma s l)
116 | ty -> ty
117 in
118 aux TypeIdentSet.empty t
119
120 let follow_alias_noopt_private gamma t =
121 let rec aux memo t =
122 match t with
123 | Q.TypeName (l, s) ->
124 if TypeIdentSet.mem s memo then t (* infinite named type *) else
125 let memo = TypeIdentSet.add s memo in
126 aux memo (find_and_specialize gamma s l)
127 | ty -> ty
128 in
129 aux TypeIdentSet.empty t
130
131
132
133 (* ************************************************************************ *)
134 (** {b Descr}: See .mli file.
135 {b Visibility}: Exported outside this module. *)
136 (* ************************************************************************ *)
137 exception Escaping_private_type of QmlAst.ty
138
139
140
141 (* ************************************************************************ *)
142 (** {b Descr}: See .mli file.
143 This function makes a descent on the type. Each time it finds a named type
144 it looks in the environment for the bound type definition and visibility.
145 If the visibility is @private, an error is raise.
146 If the visibility is @abstract, then since the abstraction hides anything,
147 it also hides possibly present private types that are hence not visible
148 anymore.
149 If it is @public, it continues descending on the body of the scheme
150 bound to the name. Note that we do not specialize the scheme: we only
151 inspect the arguments of the named type expression and the body of the
152 scheme, telling that if there is no escaping type in the arguments, then
153 when these arguments instantiate the scheme, they wont add any escaping
154 possibility. And by inspecting the body of the scheme, we inspect its
155 structure without boring about the arguments since they were already
156 checked. If the structure of the scheme's body doesn't cause escaping,
157 then finally all is fine.
158 {b Visibility}: Exported outside this module. *)
159 (* ************************************************************************ *)
160 let check_no_private_type_escaping gamma initial_ty =
161 let rec inspect memo ty =
162 match ty with
163 | Q.TypeConst _ | Q.TypeVar _ | Q.TypeAbstract -> ()
164 | Q.TypeArrow (args_ty, res_ty) ->
165 List.iter (inspect memo) args_ty ;
166 inspect memo res_ty
167 | Q.TypeRecord (Q.TyRow (fields, _)) ->
168 List.iter (fun (_, field_ty) -> inspect memo field_ty) fields
169 | Q.TypeSum (Q.TyCol (cases, _)) ->
170 List.iter
171 (fun fields ->
172 List.iter (fun (_, field_ty) -> inspect memo field_ty) fields)
173 cases
174 | Q.TypeSumSugar _ -> assert false (* Should not remain some. *)
175 | Q.TypeName (args_ty, name) ->
176 let memo' =
177 if not (TypeIdentSet.mem name memo) then (
178 (* Recover the definition bound to this name. *)
b12589b @fpessaux [feature] Typer: Height of type abbreviation to balance unwinding dur…
fpessaux authored
179 let (sch, _, visibility) =
fccc685 Initial open-source release
MLstate authored
180 QmlTypes.Env.TypeIdent.raw_find name gamma in
181 let extended_memo = TypeIdentSet.add name memo in
182 (match visibility with
183 | Q.TDV_public ->
184 (* As writen in the header of this function, since we always
185 inspect the arguments of the named type expression, we
186 don't need to explicitely instantiate the scheme and
187 directly inspect its body. Instantiation would only have
188 grafted in the body the arguments types. And because these
189 ones will be checked apart, no need to do the job twice. *)
190 let (_, body, _) = QmlGenericScheme.export_unsafe sch in
191 inspect extended_memo body
192 | Q.TDV_private _ ->
193 (* This type being private, we can't allow it. *)
194 raise (Escaping_private_type ty)
195 | Q.TDV_abstract _ ->
196 (* Ok, no need to descend deeper since the abstraction hides
197 anything, also possibly present private types. *)
198 ()) ;
199 extended_memo
200 )
201 else memo in
202 (* In any case, inspect the arguments of the named type expression. *)
203 List.iter (inspect memo') args_ty
204 | Q.TypeForall (_, _, _, body_ty) -> inspect memo body_ty in
205 inspect TypeIdentSet.empty initial_ty
206
207 let rec get_deeper_typename gamma ty =
208 match ty with
209 | Q.TypeName (args, n) -> (
b12589b @fpessaux [feature] Typer: Height of type abbreviation to balance unwinding dur…
fpessaux authored
210 let (_, _, vis) = QmlTypes.Env.TypeIdent.raw_find n gamma in
211 match vis with
fccc685 Initial open-source release
MLstate authored
212 | QmlAst.TDV_public -> (
213 let aliased_ty = find_and_specialize gamma n args in
214 match aliased_ty with
215 | Q.TypeName _ -> get_deeper_typename gamma aliased_ty
216 | _ -> ty
217 )
218 | QmlAst.TDV_abstract _ | QmlAst.TDV_private _ -> ty
219 )
220 | _ -> ty
221
222 let rec get_deeper_type_until gamma f ty =
223 if f ty then ty
224 else
225 match follow_alias gamma ty with
226 | Some ty -> get_deeper_type_until gamma f ty
227 | None -> ty
228
229 let rec is_type_arrow gamma ty =
230 match follow_alias_noopt gamma ty with
231 | Q.TypeArrow _ -> true
232 | _ -> false
233
234 let is_type_void gamma ty =
235 match follow_alias_noopt gamma ty with
236 | Q.TypeRecord (Q.TyRow ([], None)) ->
237 true
238 | Q.TypeSum (Q.TyCol ([ [ ] ], None)) ->
239 true
240 | _ -> false
241
242 let rec is_type_bool gamma ty =
243 match follow_alias_noopt gamma ty with
244 | Q.TypeRecord (Q.TyRow ([ ( "false" | "true" ), ty], None)) ->
245 is_type_void gamma ty
246 | Q.TypeSum (Q.TyCol ([ ["false", tyf ] ; ["true", tyt ] ], None)) ->
247 (is_type_void gamma tyt) && (is_type_void gamma tyf)
248 | _ -> false
249
250 let get_arrow_params gamma ty =
251 match follow_alias_noopt gamma ty with
252 | Q.TypeArrow (tl, _t2) -> Some tl
253 | _ -> None
254
255 let rec get_arrow_through_alias_and_private gamma ty =
256 match follow_alias_noopt gamma ty with
257 | Q.TypeArrow (tl, t2) -> Some (tl,t2)
258 | _ -> None
259 end
260
261 module TypeArrow =
262 struct
263 type 'a type_arrow_utils = Q.ty list -> Q.ty -> 'a
264
265 let curryfied_arity args ty =
266 let rec aux cpt = function
267 | Q.TypeArrow (args,t) -> aux (cpt + (List.length args)) t
268 | _ -> cpt
269 in
270 aux (List.length args) ty
271 end
Something went wrong with that request. Please try again.