Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100755 216 lines (190 sloc) 9.075 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 module Q = QmlAst
21 module List = BaseList
22
23
24 let equal_ty ?(gamma = QmlTypes.Env.empty) t1 t2 =
25 QmlTypesCompare.equal_ty gamma t1 t2
26
27
28
29 (* this function is used instead of unification because:
30 - we don't want unification, although we can use it because
31 instantiation happens only on one side
32 - we want to make sure only the type vars on one side are substituted
33 this would require some big old hack to incorporate that into the typer
34 *)
35 let compare_field (s1,_) (s2,_) = String.compare s1 s2
36 let compare_rec l1 l2 = List.make_compare compare_field l1 l2
37
38 let is_private_or_external gamma n =
39 let tsc = QmlTypes.Env.TypeIdent.find ~visibility_applies:false n gamma in
40 let _, body, () = QmlGenericScheme.export_unsafe tsc in
41 match body with
42 | Q.TypeAbstract -> true
43 | _ -> false
44
45 let show_instantiation ~allow_partial_application gamma quant vars rows cols spec gen =
46 let need_expansion expansion_history t1 t2 =
47 let cpl = (t1,t2) in
48 if List.mem (t1,t2) expansion_history then None
49 else Some (cpl::expansion_history)
50 in
51 let rec aux eh(* expansion history *) spec gen =
52 let aux_eh = aux in
53 let aux = aux_eh eh in
54 match spec, gen with
55 | t, Q.TypeVar v ->
56 if QmlTypeVars.FreeVars.mem_typevar v quant then
57 vars := QmlTypeVars.TypeVarMap.add v t !vars
58 | Q.TypeConst _ , Q.TypeConst _ -> ()
59
60 | Q.TypeArrow (tyl1,ty1), Q.TypeArrow (tyl2,ty2) ->
61 if allow_partial_application then (
62 aux_arrow eh ty1 ty2 tyl1 tyl2
63 ) else (
64 List.iter2 aux tyl1 tyl2;
65 aux ty1 ty2
66 )
8efccdc [fix] ei: show_instantiation was returning wrong substitutions in some c...
Valentin Gatien-Baron authored
67 (* we need to look at that case after the one with two arrows
68 * so that unify -> 'a and -> 'b unify 'a with 'b and not 'a with -> 'b
69 * actually i am not sure that this cases are needed anymore...
70 * if ei was patched to generate real n-ary types this 'partial' flag
71 * could be removed altogether *)
72 | ty1, Q.TypeArrow ([],ty2)
73 | Q.TypeArrow ([],ty1), ty2 when allow_partial_application ->
74 aux ty1 ty2
fccc685 Initial open-source release
MLstate authored
75
76 (* casting typerecord into typesum if needed and possible *)
77 | Q.TypeRecord (Q.TyRow (fields,None)), Q.TypeSum _ ->
78 aux (Q.TypeSum (Q.TyCol ([fields],None))) gen
79 | Q.TypeSum _, Q.TypeRecord (Q.TyRow (fields,None)) ->
80 aux spec (Q.TypeSum (Q.TyCol ([fields],None)))
81
82 (* casting typesum into typerecord if needed and possible *)
83 | Q.TypeRecord _, Q.TypeSum (Q.TyCol ([fields],None)) ->
84 aux spec (Q.TypeRecord (Q.TyRow (fields, None)))
85 | Q.TypeSum (Q.TyCol ([fields],None)), Q.TypeRecord _ ->
86 aux (Q.TypeRecord (Q.TyRow (fields, None))) gen
87
88 | Q.TypeRecord row1, Q.TypeRecord row2 ->
89 aux_row eh row1 row2
90 | Q.TypeSum sum1, Q.TypeSum sum2 ->
91 aux_sum eh sum1 sum2
92 | Q.TypeSumSugar _, _
93 | _, Q.TypeSumSugar _ -> assert false
94 | Q.TypeName (tyl1, n1), Q.TypeName (tyl2, n2) when Q.TypeIdent.equal n1 n2 ->
95 List.iter2 aux tyl1 tyl2
96 | Q.TypeName (tyl1, n1), t2 when not (is_private_or_external gamma n1) ->
97 begin match need_expansion eh spec gen with
98 | None -> ()
99 | Some eh ->
100 let tsc = QmlTypes.Env.TypeIdent.find ~visibility_applies:false n1 gamma in
101 let t1 = QmlTypes.Scheme.specialize ~typeident:n1 ~ty:tyl1 tsc in
102 aux_eh eh t1 t2
103 end
104 | t1, Q.TypeName (tyl2, n2) when not (is_private_or_external gamma n2) ->
105 begin match need_expansion eh spec gen with
106 | None -> ()
107 | Some eh ->
108 let tsc = QmlTypes.Env.TypeIdent.find ~visibility_applies:false n2 gamma in
109 let t2 = QmlTypes.Scheme.specialize ~typeident:n2 ~ty:tyl2 tsc in
110 aux_eh eh t1 t2
111 end
112 | Q.TypeForall (_,_,_,t1), Q.TypeForall (_,_,_,t2) ->
113 (* assuming unicity of vars *)
114 aux t1 t2
115 | _ ->
116 OManager.i_error "Fail to instantiate1:@\n%a@\nvs@\n%a@." QmlPrint.pp_base#ty spec QmlPrint.pp_base#ty gen
117
118 and aux_arrow eh ret1 ret2 l1 l2 =
119 match l1, l2 with
120 | [], [] -> aux eh ret1 ret2
121 | _, [] -> aux eh (Q.TypeArrow (l1,ret1)) ret2
122 | [], _ -> aux eh ret1 (Q.TypeArrow (l2,ret2))
123 | h1 :: l1, h2 :: l2 -> aux eh h1 h2; aux_arrow eh ret1 ret2 l1 l2
124
125 and aux_row eh (Q.TyRow (fields1,o1) as row1) (Q.TyRow (fields2,o2) as row2) =
126 let fields1 = List.StringAssoc.sort fields1 in
127 let fields2 = List.StringAssoc.sort fields2 in
128 let rec aux_left_only acc (fields1:(string*Q.ty) list) (fields2:(string*Q.ty) list) =
129 match fields1, fields2 with
130 | l, [] -> List.rev_append l acc
131 | [], _ ->
132 OManager.i_error "Fail to instantiate2:@\n%a@\nvs@\n%a@."
133 QmlPrint.pp_base#tyrow row1 QmlPrint.pp_base#tyrow row2
134 | (s1,ty1) :: t1, (s2,ty2) :: t2 ->
135 assert (s1 <= s2);
136 if s1 = s2 then (
137 aux eh ty1 ty2;
138 aux_left_only acc t1 t2
139 ) else
140 aux_left_only ((s1,ty1) :: acc) t1 fields2 in
141 let left_only = aux_left_only [] fields1 fields2 in
142 match left_only, o1, o2 with
143 | l, o, Some v ->
144 if QmlTypeVars.FreeVars.mem_rowvar v quant then
145 rows := QmlTypeVars.RowVarMap.add v (Q.TyRow (l, o)) !rows
146 | [], None, None -> ()
147 | _, _, None -> assert false
148
149 and aux_sum eh (Q.TyCol (fieldss1,o1) as col1) (Q.TyCol (fieldss2,o2) as col2) =
150 let fieldss1 = List.sort compare_rec (List.map List.StringAssoc.sort fieldss1) in
151 let fieldss2 = List.sort compare_rec (List.map List.StringAssoc.sort fieldss2) in
152 let rec aux_rec l1 l2 =
153 List.iter2
154 (fun ((s1:string),ty1) (s2,ty2) ->
155 assert (s1 = s2);
156 aux eh ty1 ty2) l1 l2 in
157 let rec aux_left_only acc (fieldss1:(string*Q.ty) list list) (fieldss2:(string*Q.ty) list list) =
158 match fieldss1, fieldss2 with
159 | l, [] -> List.rev_append l acc
160 | [], _ ->
161 OManager.i_error "Fail to instantiate3:@\n%a@\nvs@\n%a.@\nThese records should not be present: %a@."
162 QmlPrint.pp_base#tycol col1 QmlPrint.pp_base#tycol col2 QmlPrint.pp_base#tycol (Q.TyCol (fieldss2, None))
163 | rec1 :: t1, rec2 :: t2 ->
164 let c = compare_rec rec1 rec2 in
165 assert (c <= 0);
166 if c = 0 then (
167 aux_rec rec1 rec2;
168 aux_left_only acc t1 t2
169 ) else
170 aux_left_only (rec1 :: acc) t1 fieldss2 in
171 let left_only = aux_left_only [] fieldss1 fieldss2 in
172 match left_only, o1, o2 with
173 | l, o, Some v ->
174 if QmlTypeVars.FreeVars.mem_colvar v quant then
175 cols := QmlTypeVars.ColVarMap.add v (Q.TyCol (l, o)) !cols
176 | [], None, None -> ()
177 | _, _, None -> assert false in
178 aux [] spec gen
179
180
181
182 let unifiable ?(gamma = QmlTypes.Env.empty) t1 t2 =
183 let env = W_TypingEnv.from_qml_typing_env gamma in
184 (* Attention, since we transform QML types into W types, we must create a
185 variables mapping. Since the present function is used outside the context
186 of type inference, there is no previously existing mapping, so a fresh new
187 empty one is fully suitable. *)
188 W_TypingEnv.new_empty_variables_mapping () ;
189 let ty1 =
190 W_TypingEnv.qml_type_to_simple_type env t1 ~is_type_annotation: false in
191 let ty2 =
192 W_TypingEnv.qml_type_to_simple_type env t2 ~is_type_annotation: false in
193 try
194 W_Unify.unify_simple_type env ty1 ty2 ;
195 (* Release the variables mapping not useful anymore. *)
196 W_TypingEnv.release_variables_mapping () ;
197 true
198 with W_Unify.Unification_simple_type_conflict (_, _, _) ->
199 (* In case of error, reset the variables mappings stack to empty. *)
200 W_TypingEnv.reset_empty_variables_mapping_on_error () ;
201 false
202
203
204
205 let unify_and_show_instantiation ~(gamma:QmlTypes.gamma) ~allow_partial_application spec tsc =
206 let (quant, gen, ()) = QmlGenericScheme.export_unsafe tsc in
207 let vars = ref QmlTypeVars.TypeVarMap.empty in
208 let rows = ref QmlTypeVars.RowVarMap.empty in
209 let cols = ref QmlTypeVars.ColVarMap.empty in
210 show_instantiation ~allow_partial_application gamma quant vars rows cols spec gen;
211 let (v,r,c) = QmlTypeVars.FreeVars.export_as_lists quant in
212 let lt = List.map (fun v -> try QmlTypeVars.TypeVarMap.find v !vars with Not_found -> Q.TypeVar v) v in
213 let lrow = List.map (fun v -> try QmlTypeVars.RowVarMap.find v !rows with Not_found -> Q.TyRow ([], Some v)) r in
214 let lcol = List.map (fun v -> try QmlTypeVars.ColVarMap.find v !cols with Not_found -> Q.TyCol ([], Some v)) c in
215 (lt, lrow, lcol)
Something went wrong with that request. Please try again.