Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 300 lines (261 sloc) 11.195 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 Format = Base.Format
20 module List = Base.List
21
22 (* alias *)
23
24 (* shorthands *)
25 module Q = QmlAst
26
27 (* -- *)
28 type flag = [`closed | `open_]
29 type colvar = flag
30 type rowvar = flag
31
32 let pp_flag fmt = function
33 | `closed -> Format.pp_print_string fmt "`closed"
34 | `open_ -> Format.pp_print_string fmt "`open"
35
36 type label = Annot.label
37
38 module T =
39 struct
40 type pat =
41 | Const of label * QmlAst.const_expr
42 | Var of label * Ident.t
43 | Any of label
44 | As of label * pat * Ident.t
45
46 let rec pp fmt = function
47 | Const (_, const) -> QmlPrint.pp#const fmt const
48 | Var (_, ident) -> Format.pp_print_string fmt (Ident.stident ident)
49 | Any _ -> Format.pp_print_string fmt "_"
50 | As (_, pat, ident) -> Format.fprintf fmt "%a as %s" pp pat (Ident.stident ident)
51 end
52
53 type pat =
54 | Fields of label * (string * pat) array * rowvar * colvar
55 | Const of label * QmlAst.const_expr
56 | Var of label * Ident.t
57 | Any of label
58 | As of label * pat * Ident.t
59
60 let more_flag sep var fmt = function
61 | `closed -> ()
62 | `open_ -> Format.fprintf fmt " %s %s" sep var
63
64 let rec pp fmt = function
65 | Fields (_, fields, rowvar, colvar) ->
66 Format.fprintf fmt (
67 "{ %a%a }%a"
68 )
69 (Format.pp_list " ; " pp_field_pat) (Array.to_list fields)
70 (more_flag ";" "...") rowvar
71 (more_flag "/" ".") colvar
72
73 | Const (_, const) -> QmlPrint.pp#const fmt const
74 | Var (_, ident) -> Format.pp_print_string fmt (Ident.stident ident)
75 | Any _ -> Format.pp_print_string fmt "_"
76 | As (_, pat, ident) ->
77 Format.fprintf fmt "%a as %s" pp pat (Ident.stident ident)
78
79 and pp_field_pat fmt (field, pat) =
80 match pat with
81 | Fields (_, [||], _, _) ->
82 Format.pp_print_string fmt field
83 | _ ->
84 Format.fprintf fmt "%s = %a" field pp pat
85
86 type ('pat, 'right_hand) matching = ('pat * 'right_hand) list
87
88 type 'right_hand t =
89 | Trivial of (T.pat, 'right_hand) matching
90 | Pat of (pat, 'right_hand) matching
91
92 module Projection :
93 sig
94 val trivial : QmlAst.pat -> T.pat option
95 val pat : gamma:QmlTypes.gamma -> annotmap:QmlAst.annotmap -> ty:QmlAst.ty -> QmlAst.pat -> pat
96 end =
97 struct
98 (* ************************************************************************ *)
99 (** {b Descr}: Returns the list of labels (strings) contained in a record
100 pattern. It doesn't descend recursively in the sub-patterns. In other
101 words, it returns the list of field names the record pattern has.
102 {b Visibility}: Not exported outside this module. *)
103 (* ************************************************************************ *)
104 let labels_of_record_pat p =
105 match p with
106 | Q.PatRecord (_, names, _) -> List.map fst names
107 | _ -> assert false
108
109
110
111 (* ************************************************************************ *)
112 (** {b Descr}: Find in the list of cases of a sum, the (first) one
113 containing all the labels of the list [labels]. If no case is found,
114 this function returns [None].
115 {b Visibility}: Not exported outside this module. *)
116 (* ************************************************************************ *)
117 let find_case_having_labels labels sum_cases =
118 (* Local function trying to see if one case has all the labels. *)
119 let deal_one_case case =
120 (* All the labels must belong to the case. *)
121 List.for_all
122 (fun lbl -> List.exists (fun (lb, _) -> lb = lbl) case)
123 labels in
124 (* Now, check each case until we find one matching. *)
125 let rec find_in_cases = function
126 | [] -> None
127 | h :: q -> if deal_one_case h then Some h else find_in_cases q in
128 (* And now, really do the job. *)
129 find_in_cases sum_cases
130
131
132
133 exception Not_trivial
134 let trivial p =
135 let rec aux p =
136 match p with
137 | Q.PatRecord _ -> raise Not_trivial
138 | Q.PatConst (label, const) ->
139 T.Const (label, const)
140 | Q.PatVar (label, ident) ->
141 T.Var (label, ident)
142 | Q.PatAny label ->
143 T.Any label
144 | Q.PatCoerce (_, pat, _) -> aux pat
145 | Q.PatAs (label, pat, id) ->
146 let pat = aux pat in
147 T.As (label, pat, id)
148 in
149 try
150 Some (aux p)
151 with
152 | Not_trivial -> None
153
154 let cmp (fa, _) (fb, _) = String.compare fa fb
155 let sort tl = List.sort cmp tl
156
157 let pat ~gamma ~annotmap:_ ~ty pat =
158 let rec aux level_all_cases_ty p =
159 match p with
160 | Q.PatRecord _ ->
161 record p level_all_cases_ty
162 | Q.PatConst (label, const) ->
163 Const (label, const)
164 | Q.PatVar (label, ident) ->
165 Var (label, ident)
166 | Q.PatAny label ->
167 Any label
168 | Q.PatCoerce (_, pat, _) -> aux level_all_cases_ty pat
169 | Q.PatAs (label, pat, ident) ->
170 let pat = aux level_all_cases_ty pat in
171 As (label, pat, ident)
172
173 and record a expected_sum_ty =
174 (* We are processing a pattern being a record. It is a case of a sum.
175 This sum can be opened or closed depending on the sequence of record
176 patterns at this level (presence or absence of catchall making the
177 difference. However, this opening or closing is explicit in the type
178 given to patterns of this level.
d3757ec [fix] typos: various corrections
Arthur Milchior authored
179 So, to know if the column is opened or closed, we will inspect the
fccc685 Initial open-source release
MLstate authored
180 type of the current level of pattern.
181 If the patterns at this level have a named type, then we must inspect
182 this named type definition to know if it corresponds to a closed or
183 opened sum type. To do so, we first "expand" the type then only
184 inspect its structure after. *)
185 let expanded_ty =
186 QmlTypesUtils.Inspect.follow_alias_noopt_private gamma expected_sum_ty in
187 let (sum_cases, colvar) =
188 (match expanded_ty with
189 | Q.TypeSum (Q.TyCol (cases, opt_var)) ->
190 let ending = if opt_var = None then `closed else `open_ in
191 (cases, ending)
192 | Q.TypeRecord (Q.TyRow (case, _)) ->
193 (* If the type of the pattern is a record, then because QML types
194 algebra cosiders that record do not have column variables, we
195 will say that the corresponding column ending is closed. *)
196 ([case], `closed)
197 | Q.TypeVar _ ->
198 (* May arise because some passes make code transformation and do
199 not type again. Say that the corresponding column ending is
200 open since this is the most restrictive choice. In effect, this
201 will trigger more checks in coming processing which is
202 satisfactory since we do not know the type here. *)
203 ([], `open_)
204 | Q.TypeName _ | Q.TypeConst _
205 | Q.TypeArrow _ | Q.TypeSumSugar _ | Q.TypeAbstract | Q.TypeForall _ ->
206 (* Assuming the typechecking is already done and successfull, a
207 record pattern can't have these types. *)
208 OManager.printf "ty:%a@." QmlPrint.pp#ty expanded_ty;
209 assert false) in
210
211 (* Local function processing sequentially all the patterns representing
212 the fields of a record pattern. *)
213 let rec fields current_record_list_of_fields_tys p =
214 match p with
215 | Q.PatRecord (label, fields, rowvar) ->
216 let map (field, pat) =
217 let sub_level_cases_ty =
218 (try List.assoc field current_record_list_of_fields_tys
219 with Not_found ->
220 (* The type of this field was not found in the list of fields
221 making up the current sum case. We are missing information,
222 so be restrictive and say that the type is a variable (i.e.
223 we don't known anything about it). *)
224 QmlAst.TypeVar (QmlAst.TypeVar.next ())) in
225 let pat = aux sub_level_cases_ty pat in
226 field, pat
227 in
228 let fields = List.rev_map map fields in
229 let fields = sort fields in
230 Fields (label, Array.of_list fields, rowvar, colvar)
231
232 | Q.PatCoerce (_, pat, _) ->
233 fields current_record_list_of_fields_tys pat
234
235 | Q.PatConst _ -> assert false
236 | Q.PatVar _ -> assert false
237 | Q.PatAny _ -> assert false
238 | Q.PatAs _ -> assert false
239
240 in
241
242 (* Effective body of the [record] function. We must find the case
243 corresponding to this sequence of fields in the sum type.
244 By invariant, we always arrive here with a pattern that is a record,
245 and this pattern represents one case of pattern matching. *)
246 (match a with
247
248 | Q.PatRecord (label, [], rowvar) ->
249 Fields (label, [||], rowvar, colvar)
250
251 | Q.PatRecord _ ->
252 (* Get the list of all the fields names in this record pattern. *)
253 let labels = labels_of_record_pat a in
254 (* Recover the list of fields and types that represent the type of
255 this record among the cases found as belonging to the current
256 sum type. *)
257 let list_of_fields_tys =
258 match find_case_having_labels labels sum_cases with
259 | None ->
260 (* No sum case with these labels found. In this case, we
261 will use an empty list of fields name and the function
262 processing fields ([fields]) will have to fallback to
263 restrictive approximation if it needs the type of a field
264 that won't obviously appears in our list. *)
265 []
266 | Some case -> case
267 in
268 fields list_of_fields_tys a
269
270 | _ ->
271 (*
272 Internal error
273 If we end-up there, that means that there is a bug in structure and
274 call interaction between the function [pat], [aux], [fields], and [record]
275 *)
276 assert false
277 ) in
278 aux ty pat
279
280 end
281
282 let analysis ~gamma ~annotmap ~ty patterns =
283 let is_trivial =
284 let rec aux acc = function
285 | [] -> Some ( List.rev acc )
286 | (pat, e) :: tl -> (
287 match Projection.trivial pat with
288 | Some trivial -> aux ( (trivial, e)::acc ) tl
289 | None -> None
290 )
291 in
292 aux [] patterns
293 in
294 match is_trivial with
295 | Some patterns ->
296 Trivial patterns
297 | None ->
298 let patterns = List.tail_map (fun (pat, e) -> Projection.pat ~gamma ~annotmap ~ty pat, e) patterns in
299 Pat patterns
Something went wrong with that request. Please try again.