Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 153 lines (130 sloc) 4.766 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
21 (* refactoring in progress *)
22
23 (* shorthands *)
24 module Q = QmlAst
25
26 (* -- *)
27
28 type options = {
29 dump_found : bool ;
30 dump_not_found : bool ;
31 pat_not_found_are_ok : bool ;
32 freshness_only : bool ;
33 dump_position : bool
34 }
35
36 let default = {
37 dump_found = false ;
38 dump_not_found = true ;
39 pat_not_found_are_ok = false ;
40 freshness_only = false ;
41 dump_position = false
42 }
43
44 type 'a annotation_checker = ?options:options -> QmlAst.annotmap -> 'a -> bool
45
46 let _annots_found = ref AnnotSet.empty
47
48 (* let init () = prerr_endline "=== ANNOT CHECKUP ===" *)
49 let short s =
50 let len = 40 in
51 let t = String.length s in
52 if t > 3 * len then (String.sub s 0 len)^" ... (expr too long) ..."^(String.sub s (t - 1 - len) len) else s
53
54 let check_gen_annot get_label options annots printer ?(pattern_case=false) pointer exp =
55 let label = get_label exp in
56 let pos = Annot.pos label in
57 let annot = Annot.annot label in
58 (if AnnotSet.mem annot !_annots_found
59 then
60 begin
61 if options.dump_not_found then
62 OManager.verbose "AnnotCheckup: %s | %s"
63 (Ansi.print `red (Printf.sprintf "[NON FRESH ANNOT : a %s]" (Annot.to_string annot)))
64 (short (printer exp));
65 false
66 end
67 else
68 begin
69 _annots_found := AnnotSet.add annot !_annots_found;
70 true
71 end)
72 &&
73 (options.freshness_only ||
74 let position =
75 if options.dump_position
76 then Ansi.print `green (Printf.sprintf "/ position : %s"
77 (FilePos.to_string pos))
78 else ""
79 in
80 match QmlAnnotMap.find_ty_opt annot annots with
81 | Some ty ->
82 let _ =
83 if options.dump_found
84 then
85 let found = Ansi.print `green (Printf.sprintf "[FOUND : a %s]" (Annot.to_string annot)) in
86 OManager.verbose "AnnotCheckup: %s | %s : %s %s %s %s" found
87 (short (printer exp)) (Format.to_string QmlPrint.pp#ty ty) "" "" position
88 else if options.dump_position && FilePos.is_empty pos
89 then OManager.verbose "AnnotCheckup: %s | %s"
90 (Ansi.print `red (Printf.sprintf "[POS-NOT-FOUND : a %s]" (Annot.to_string annot))) (short (printer exp)) in
91 true
92 | None ->
93 if options.pat_not_found_are_ok && pattern_case then true
94 else
95 let _ =
96 if options.dump_not_found
97 then
98 let not_found = Ansi.print `red (Printf.sprintf "[NOT-FOUND : a %s]" (Annot.to_string annot)) in
99 OManager.verbose "AnnotCheckup: %s | in %s : %s %s"
100 not_found pointer (short (printer exp)) position in
101 false
102 )
103
104 let check_expr ?(options=default) annots =
105 check_gen_annot Q.Label.expr options annots (Format.to_string QmlPrint.pp#expr0) "an EXPR"
106 let check_pat ?(options=default) annots =
107 check_gen_annot Q.Label.pat options annots (Format.to_string QmlPrint.pp#pat0) ~pattern_case:true "a PAT"
108
109 let expr ?(options=default) annots e =
110 let _ok = ref true in
111 let ok t = _ok := !_ok && t in
112 let iter_expr e = ok (check_expr ~options annots e) in
113 let iter_pat p = ok (check_pat ~options annots p) in
114 let _ = QmlAstWalk.ExprPatt.iter_down iter_expr iter_pat e in
115 !_ok
116
117 let pat ?options annots p =
118 let _ok = ref true in
119 let ok t = _ok := !_ok && t in
120 let iter_pat p = ok (check_pat ?options annots p) in
121 let _ = QmlAstWalk.Pattern.iter_down iter_pat p in
122 !_ok
123
124 let code_elt ?options annots code_elt =
125 let _ok = ref true in
126 let ok t = _ok := !_ok && t in
127 let iter_check = (fun e -> ok (expr ?options annots e) ; e ) in
128 let _ = QmlAstWalk.Top.map_expr iter_check code_elt in
129 !_ok
130
131 let code ?options annots code =
132 let _ok = ref true in
133 let ok t = _ok := !_ok && t in
134 let iter c = ok (code_elt ?options annots c) in
135 let _ = List.iter iter code in
136 !_ok
137
138 let expr ?options annots e =
139 _annots_found := AnnotSet.empty;
140 expr ?options annots e
141
142 let pat ?options annots e =
143 _annots_found := AnnotSet.empty;
144 pat ?options annots e
145
146 let code_elt ?options annots e =
147 _annots_found := AnnotSet.empty;
148 code_elt ?options annots e
149
150 let code ?options annots e =
151 _annots_found := AnnotSet.empty;
152 code ?options annots e
Something went wrong with that request. Please try again.