Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 312 lines (286 sloc) 9.879 kb
fccc685 Initial open-source release
MLstate authored
1 (*
81e2a87 @BourgerieQuentin [enhance] compiler: updating to big_int
BourgerieQuentin authored
2 Copyright © 2011, 2012 MLstate
fccc685 Initial open-source release
MLstate authored
3
5bb0f1a @Aqua-Ye [cleanup] compiler: typo on Opa
Aqua-Ye authored
4 This file is part of Opa.
fccc685 Initial open-source release
MLstate authored
5
5bb0f1a @Aqua-Ye [cleanup] compiler: typo on Opa
Aqua-Ye authored
6 Opa is free software: you can redistribute it and/or modify it under the
fccc685 Initial open-source release
MLstate authored
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
5bb0f1a @Aqua-Ye [cleanup] compiler: typo on Opa
Aqua-Ye authored
10 Opa is distributed in the hope that it will be useful, but WITHOUT ANY
fccc685 Initial open-source release
MLstate authored
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
5bb0f1a @Aqua-Ye [cleanup] compiler: typo on Opa
Aqua-Ye authored
16 along with Opa. If not, see <http://www.gnu.org/licenses/>.
fccc685 Initial open-source release
MLstate authored
17 *)
18 (* depends *)
19 module List = Base.List
20 let (|>) x f = f x
21
22 (* alias *)
23 module Q = QmlAst
24
25 (* refactoring in progress *)
26
27 (*
28 Utils
29 *)
30 let wclass = WarningClass.pattern
31
32 let dead =
33 let doc = "A branch of a match can never be matched" in
34 WarningClass.create ~parent:wclass ~name:"dead" ~doc ~err:true ~enable:true ()
35
36 let obfuscation =
37 let doc = "A variable matching an expr of a sum type is nammed like one of the sum case" in
38 WarningClass.create ~parent:wclass ~name:"obfuscation" ~doc ~err:true ~enable:true ()
39
40 let warning_set =
41 WarningClass.Set.create_from_list [
42 wclass;
43 ]
44
45 let is_label_in_simple_case searched_label annotkey annotmap gamma =
46 match QmlAnnotMap.find_ty_opt annotkey annotmap with
47 | None -> false
48 | Some ty -> (
49 (* We are only interrested in sum types. But in case of names type, we
50 must first get its effective representation. *)
51 match QmlTypesUtils.Inspect.follow_alias_noopt gamma ty with
52 | QmlAst.TypeSum (QmlAst.TyCol (cases, _)) ->
53 List.exists
54 (fun case_fields ->
55 (* For each case of the sum, i.e. each list of fields of this
56 case, we check if the searched label belongs to list of
57 fields of this case. We stop searching as soon as we find a
58 positive hit. *)
59 List.exists
60 (fun (lbl, lbl_ty) ->
61 (* Found if the labels have the same name and the type of
62 this label is the empty record. Attention, we must
63 unwind named types before testing. *)
64 (lbl = searched_label) &&
65 (match QmlTypesUtils.Inspect.follow_alias_noopt gamma lbl_ty with
66 | QmlAst.TypeRecord (QmlAst.TyRow ([], None)) -> true
67 | _ -> false))
68 case_fields)
69 cases
70 | _ -> false
71 )
72
73 (*
74 Imperative simplification:
75 [gamma] and [annotmap] are available as global variables.
76 It is simplier to proced so, instead of passing [gamma] and [annotmap] around.
77 The [free_gamma_annotmap] function is for relaxing the GC.
78 *)
79 let gamma = ref ( QmlTypes.Env.empty : QmlTypes.gamma )
80 let annotmap = ref ( QmlAnnotMap.empty : QmlAst.annotmap )
81 let set_gamma g = gamma := g
82 let set_annotmap a = annotmap := a
83 let free_gamma_annotmap () =
84 gamma := QmlTypes.Env.empty ;
85 annotmap := QmlAnnotMap.empty
86
87 (*
88 This function tells if a pattern [p] hides a another pattern [p'].
89 For example, in :
90 {[
91 match e with
92 | _ -> "toto"
93 | 6 -> "tutu"
94 ]}
95 The pattern [_] hids the pattern [6]
96
97 The question answered by this function is :
98 Does p kills (hides) p' ?
99
100 <!> beware with rowvar,
101 {[
102 | { a }
103 | { a ; ... }
104 ]}
105 The second case in general is not killed by the first case. (depending on the type).
106 The check is syntactic.
107 *)
108 let rec is_killed_by p p' =
109 match p, p' with
110 | Q.PatCoerce (_, p, _), _ -> is_killed_by p p'
111 | _, Q.PatCoerce(_, p', _) -> is_killed_by p p'
112
113 | (Q.PatAny _ | Q.PatVar _), _ -> true
114
115 | Q.PatRecord _, Q.PatRecord _ -> all_fields_killed_by p p'
81e2a87 @BourgerieQuentin [enhance] compiler: updating to big_int
BourgerieQuentin authored
116 | Q.PatConst (_, Q.Int i), Q.PatConst (_, Q.Int i') -> Big_int.eq_big_int i i'
fccc685 Initial open-source release
MLstate authored
117 | Q.PatConst (_, c0), Q.PatConst (_, c1) -> c0 = c1
118
119 | _ -> false
120
121 (* This function is called whith complexe patterns, i.e with fields *)
122 and all_fields_killed_by p p' =
123 (*
124 gather all field of a pattern, and return an extra bool,
125 [true] if the pattern is strict (without { ; ...} )
126 *)
127 let fields_list p =
128 match p with
129 | Q.PatRecord (_, fields, rowvar) -> fields, rowvar = `closed
130 | _ ->
131 let context = QmlError.Context.annoted_pat !annotmap p in
132 QmlError.i_error None context (
133 "This pattern is not well formed.@\n%a"
134 )
135 QmlPrint.pp#pat p
136 in
137 let l1, strict1 = fields_list p in
138 let l2, strict2 = fields_list p' in
139
140 if strict1
141 then
142 if strict2
143 then
144 (*
145 All field of p' should be in p, and all should be killed.
146 The two list should have the same length.
147 *)
148 let cmp (a, _) (b, _) = String.compare a b in
149 let l1 = List.sort cmp l1 in
150 let l2 = List.sort cmp l2 in
151 Return.set_checkpoint (
152 fun label ->
153 let iter2 (a, p) (b, p') =
154 if a <> b || not (is_killed_by p p')
155 then Return.return label false
156 in
157 try
158 List.iter2 iter2 l1 l2 ;
159 true
160 with
161 | Invalid_argument _ -> false
162 )
163 else
164 (*
165 Syntactic check only.
166 No matter what fields are in p', if p is strict, and p' not,
167 the second pattern cover more cases than the first, so
168 is not hidden.
169 *)
170 false
171 else
172 (*
173 In this case, no matter the row variable of p', if all field p
174 are also present in p', and killed by p, the pattern is killed.
175 The fields present in p' but not in p would be matched inside
176 the row var of p.
177 *)
178 List.for_all (
179 fun (n, p)->
180 match List.assoc_opt n l2 with
181 | None -> false
182 | Some p' -> is_killed_by p p'
183 ) l1
184
185 (*
186 Given a pattern [p] and a list of patterns [li] return the filtered list of [li],
187 containing only the pattern hidden by [p]
188 *)
189 let killed_patterns p li =
190 List.filter (fun (p', _) -> is_killed_by p p') li
191
192 (*
193 Given an ordered list of patterns, will return the assoc list of type : [(pat * pat list) list]
194 if [(p, li)] is in this list, that means that in the pattern matching, all pattern of [li]
195 are hidden by [p]
196 *)
197 let collect_killed_patterns li =
198 let rec aux acc = function
199 | [] -> List.rev acc
200 | (hd, _) :: tl ->
201 let killed_patterns = killed_patterns hd tl in
202 let acc =
203 if killed_patterns <> [] then (hd, killed_patterns)::acc else acc
204 in
205 aux acc tl
206 in
207 aux [] li
208
209 (*
210 Given an expression, check.
211 This is meant to be used with Traverse functions,
212 that's why the function is not recursive.
213 *)
214 let check_expr e =
215 match e with
216 | Q.Match (_, _, li) ->
217 (* First check: dead patterns *)
218 let iter (p, li) =
219 let iter (p', _) =
220 let c1 = QmlError.Context.annotmap !annotmap in
221 let c2 = QmlError.Context.pat p in
222 let c3 = QmlError.Context.pat p' in
223 let context = QmlError.Context.merge c1 [c2 ; c3] in
224 QmlError.warning ~wclass:dead context (
225 "@[<2>This kind of pattern matching is not allowed@\n"^^
226 "The first pattern hides the second one.@]"
227 )
228 in
229 List.iter iter li
230 in
231 List.iter iter (collect_killed_patterns li)
232 ;
233 (* Second check: obfuscation *)
234 let iter (p, _) =
235 let iter p =
236 match p with
237 | Q.PatVar (_, ident) | Q.PatAs (_, _, ident) ->
238 let label = Ident.original_name ident in
239 if is_label_in_simple_case label (Q.QAnnot.pat p) !annotmap !gamma
240 then
241 let context = QmlError.Context.annoted_pat !annotmap p in
242 QmlError.warning ~wclass:obfuscation context (
243 "You should not name this pattern variable @{<bright>%s@} because@\n"^^
244 "the type of the matched expression contain a sum case @{<bright>{ %s }@}."
245 )
246 label label
247 | _ -> ()
248 in
249 QmlAstWalk.Pattern.iter_down iter p
250 in
251 let doit = match li with | _::_::_ -> true | _ -> false in
252 if doit then
253 List.iter iter li
254 | _ -> ()
255
256 (*
257 The function returns unit.
258 In case of illicit pattern, fail using QmlError with located error messages.
259 *)
260 let process_code gamma annotmap code =
261 if WarningClass.is_warn wclass then (
262 set_gamma gamma;
263 set_annotmap annotmap;
264 QmlAstWalk.CodeExpr.iter (QmlAstWalk.Expr.iter check_expr) code;
265 free_gamma_annotmap ()
266 )
267
268 (*
269 New pass of analysis. Testing
270 *)
271 let process_code gamma annotmap code =
272 process_code gamma annotmap code ;
273 if WarningClass.is_warn wclass then (
274 let foldmap annotmap = function
275 | Q.Match (label, matched_expr, patterns) as expr ->
276 let pattern_matching =
277 QmlPatternAnalysis.conversion ~gamma ~annotmap ~label ~matched_expr ~patterns
278 in
279 let normalized = QmlPatternAnalysis.normalize pattern_matching in
280 let () =
281 if QmlPatternAnalysis.has_public_exceptions () then (
282 let ctx = QmlError.Context.label label in
283 QmlError.warning ~wclass:wclass ctx "%a"
284 QmlPatternAnalysis.flush_exceptions_fmt ()
285 ) in
286 let acc =
287 #<If:PATTERNS_NORMALIZE>
288 QmlPatternAnalysis.generation normalized
289 #<Else>
290 ignore normalized ;
291 annotmap, expr
292 #<End>
293 in
294 acc
295 | expr ->
296 annotmap, expr
297 in
298 let norm_annotmap, norm_code =
299 QmlAstWalk.CodeExpr.fold_map (QmlAstWalk.Expr.foldmap foldmap) annotmap code
300 in
301 let () = QmlPatternAnalysis.Env.reset () in
302 #<If:PATTERNS_NORMALIZE>
303 norm_annotmap, norm_code
304 #<Else> (
305 ignore norm_annotmap ;
306 ignore norm_code ;
307 annotmap, code
308 )
309 #<End>
310 ) else
311 annotmap, code
Something went wrong with that request. Please try again.