Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 311 lines (285 sloc) 9.792 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 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'
116 | Q.PatConst (_, c0), Q.PatConst (_, c1) -> c0 = c1
117
118 | _ -> false
119
120 (* This function is called whith complexe patterns, i.e with fields *)
121 and all_fields_killed_by p p' =
122 (*
123 gather all field of a pattern, and return an extra bool,
124 [true] if the pattern is strict (without { ; ...} )
125 *)
126 let fields_list p =
127 match p with
128 | Q.PatRecord (_, fields, rowvar) -> fields, rowvar = `closed
129 | _ ->
130 let context = QmlError.Context.annoted_pat !annotmap p in
131 QmlError.i_error None context (
132 "This pattern is not well formed.@\n%a"
133 )
134 QmlPrint.pp#pat p
135 in
136 let l1, strict1 = fields_list p in
137 let l2, strict2 = fields_list p' in
138
139 if strict1
140 then
141 if strict2
142 then
143 (*
144 All field of p' should be in p, and all should be killed.
145 The two list should have the same length.
146 *)
147 let cmp (a, _) (b, _) = String.compare a b in
148 let l1 = List.sort cmp l1 in
149 let l2 = List.sort cmp l2 in
150 Return.set_checkpoint (
151 fun label ->
152 let iter2 (a, p) (b, p') =
153 if a <> b || not (is_killed_by p p')
154 then Return.return label false
155 in
156 try
157 List.iter2 iter2 l1 l2 ;
158 true
159 with
160 | Invalid_argument _ -> false
161 )
162 else
163 (*
164 Syntactic check only.
165 No matter what fields are in p', if p is strict, and p' not,
166 the second pattern cover more cases than the first, so
167 is not hidden.
168 *)
169 false
170 else
171 (*
172 In this case, no matter the row variable of p', if all field p
173 are also present in p', and killed by p, the pattern is killed.
174 The fields present in p' but not in p would be matched inside
175 the row var of p.
176 *)
177 List.for_all (
178 fun (n, p)->
179 match List.assoc_opt n l2 with
180 | None -> false
181 | Some p' -> is_killed_by p p'
182 ) l1
183
184 (*
185 Given a pattern [p] and a list of patterns [li] return the filtered list of [li],
186 containing only the pattern hidden by [p]
187 *)
188 let killed_patterns p li =
189 List.filter (fun (p', _) -> is_killed_by p p') li
190
191 (*
192 Given an ordered list of patterns, will return the assoc list of type : [(pat * pat list) list]
193 if [(p, li)] is in this list, that means that in the pattern matching, all pattern of [li]
194 are hidden by [p]
195 *)
196 let collect_killed_patterns li =
197 let rec aux acc = function
198 | [] -> List.rev acc
199 | (hd, _) :: tl ->
200 let killed_patterns = killed_patterns hd tl in
201 let acc =
202 if killed_patterns <> [] then (hd, killed_patterns)::acc else acc
203 in
204 aux acc tl
205 in
206 aux [] li
207
208 (*
209 Given an expression, check.
210 This is meant to be used with Traverse functions,
211 that's why the function is not recursive.
212 *)
213 let check_expr e =
214 match e with
215 | Q.Match (_, _, li) ->
216 (* First check: dead patterns *)
217 let iter (p, li) =
218 let iter (p', _) =
219 let c1 = QmlError.Context.annotmap !annotmap in
220 let c2 = QmlError.Context.pat p in
221 let c3 = QmlError.Context.pat p' in
222 let context = QmlError.Context.merge c1 [c2 ; c3] in
223 QmlError.warning ~wclass:dead context (
224 "@[<2>This kind of pattern matching is not allowed@\n"^^
225 "The first pattern hides the second one.@]"
226 )
227 in
228 List.iter iter li
229 in
230 List.iter iter (collect_killed_patterns li)
231 ;
232 (* Second check: obfuscation *)
233 let iter (p, _) =
234 let iter p =
235 match p with
236 | Q.PatVar (_, ident) | Q.PatAs (_, _, ident) ->
237 let label = Ident.original_name ident in
238 if is_label_in_simple_case label (Q.QAnnot.pat p) !annotmap !gamma
239 then
240 let context = QmlError.Context.annoted_pat !annotmap p in
241 QmlError.warning ~wclass:obfuscation context (
242 "You should not name this pattern variable @{<bright>%s@} because@\n"^^
243 "the type of the matched expression contain a sum case @{<bright>{ %s }@}."
244 )
245 label label
246 | _ -> ()
247 in
248 QmlAstWalk.Pattern.iter_down iter p
249 in
250 let doit = match li with | _::_::_ -> true | _ -> false in
251 if doit then
252 List.iter iter li
253 | _ -> ()
254
255 (*
256 The function returns unit.
257 In case of illicit pattern, fail using QmlError with located error messages.
258 *)
259 let process_code gamma annotmap code =
260 if WarningClass.is_warn wclass then (
261 set_gamma gamma;
262 set_annotmap annotmap;
263 QmlAstWalk.CodeExpr.iter (QmlAstWalk.Expr.iter check_expr) code;
264 free_gamma_annotmap ()
265 )
266
267 (*
268 New pass of analysis. Testing
269 *)
270 let process_code gamma annotmap code =
271 process_code gamma annotmap code ;
272 if WarningClass.is_warn wclass then (
273 let foldmap annotmap = function
274 | Q.Match (label, matched_expr, patterns) as expr ->
275 let pattern_matching =
276 QmlPatternAnalysis.conversion ~gamma ~annotmap ~label ~matched_expr ~patterns
277 in
278 let normalized = QmlPatternAnalysis.normalize pattern_matching in
279 let () =
280 if QmlPatternAnalysis.has_public_exceptions () then (
281 let ctx = QmlError.Context.label label in
282 QmlError.warning ~wclass:wclass ctx "%a"
283 QmlPatternAnalysis.flush_exceptions_fmt ()
284 ) in
285 let acc =
286 #<If:PATTERNS_NORMALIZE>
287 QmlPatternAnalysis.generation normalized
288 #<Else>
289 ignore normalized ;
290 annotmap, expr
291 #<End>
292 in
293 acc
294 | expr ->
295 annotmap, expr
296 in
297 let norm_annotmap, norm_code =
298 QmlAstWalk.CodeExpr.fold_map (QmlAstWalk.Expr.foldmap foldmap) annotmap code
299 in
300 let () = QmlPatternAnalysis.Env.reset () in
301 #<If:PATTERNS_NORMALIZE>
302 norm_annotmap, norm_code
303 #<Else> (
304 ignore norm_annotmap ;
305 ignore norm_code ;
306 annotmap, code
307 )
308 #<End>
309 ) else
310 annotmap, code
Something went wrong with that request. Please try again.