Skip to content


Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

153 lines (130 sloc) 4.766 kb
Copyright © 2011 MLstate
This file is part of OPA.
OPA is free software: you can redistribute it and/or modify it under the
terms of the GNU Affero General Public License, version 3, as published by
the Free Software Foundation.
OPA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
more details.
You should have received a copy of the GNU Affero General Public License
along with OPA. If not, see <>.
(* depends *)
module Format = Base.Format
(* refactoring in progress *)
(* shorthands *)
module Q = QmlAst
(* -- *)
type options = {
dump_found : bool ;
dump_not_found : bool ;
pat_not_found_are_ok : bool ;
freshness_only : bool ;
dump_position : bool
let default = {
dump_found = false ;
dump_not_found = true ;
pat_not_found_are_ok = false ;
freshness_only = false ;
dump_position = false
type 'a annotation_checker = ?options:options -> QmlAst.annotmap -> 'a -> bool
let _annots_found = ref AnnotSet.empty
(* let init () = prerr_endline "=== ANNOT CHECKUP ===" *)
let short s =
let len = 40 in
let t = String.length s in
if t > 3 * len then (String.sub s 0 len)^" ... (expr too long) ..."^(String.sub s (t - 1 - len) len) else s
let check_gen_annot get_label options annots printer ?(pattern_case=false) pointer exp =
let label = get_label exp in
let pos = Annot.pos label in
let annot = Annot.annot label in
(if AnnotSet.mem annot !_annots_found
if options.dump_not_found then
OManager.verbose "AnnotCheckup: %s | %s"
(Ansi.print `red (Printf.sprintf "[NON FRESH ANNOT : a %s]" (Annot.to_string annot)))
(short (printer exp));
_annots_found := AnnotSet.add annot !_annots_found;
(options.freshness_only ||
let position =
if options.dump_position
then Ansi.print `green (Printf.sprintf "/ position : %s"
(FilePos.to_string pos))
else ""
match QmlAnnotMap.find_ty_opt annot annots with
| Some ty ->
let _ =
if options.dump_found
let found = Ansi.print `green (Printf.sprintf "[FOUND : a %s]" (Annot.to_string annot)) in
OManager.verbose "AnnotCheckup: %s | %s : %s %s %s %s" found
(short (printer exp)) (Format.to_string QmlPrint.pp#ty ty) "" "" position
else if options.dump_position && FilePos.is_empty pos
then OManager.verbose "AnnotCheckup: %s | %s"
(Ansi.print `red (Printf.sprintf "[POS-NOT-FOUND : a %s]" (Annot.to_string annot))) (short (printer exp)) in
| None ->
if options.pat_not_found_are_ok && pattern_case then true
let _ =
if options.dump_not_found
let not_found = Ansi.print `red (Printf.sprintf "[NOT-FOUND : a %s]" (Annot.to_string annot)) in
OManager.verbose "AnnotCheckup: %s | in %s : %s %s"
not_found pointer (short (printer exp)) position in
let check_expr ?(options=default) annots =
check_gen_annot Q.Label.expr options annots (Format.to_string QmlPrint.pp#expr0) "an EXPR"
let check_pat ?(options=default) annots =
check_gen_annot Q.Label.pat options annots (Format.to_string QmlPrint.pp#pat0) ~pattern_case:true "a PAT"
let expr ?(options=default) annots e =
let _ok = ref true in
let ok t = _ok := !_ok && t in
let iter_expr e = ok (check_expr ~options annots e) in
let iter_pat p = ok (check_pat ~options annots p) in
let _ = QmlAstWalk.ExprPatt.iter_down iter_expr iter_pat e in
let pat ?options annots p =
let _ok = ref true in
let ok t = _ok := !_ok && t in
let iter_pat p = ok (check_pat ?options annots p) in
let _ = QmlAstWalk.Pattern.iter_down iter_pat p in
let code_elt ?options annots code_elt =
let _ok = ref true in
let ok t = _ok := !_ok && t in
let iter_check = (fun e -> ok (expr ?options annots e) ; e ) in
let _ = QmlAstWalk.Top.map_expr iter_check code_elt in
let code ?options annots code =
let _ok = ref true in
let ok t = _ok := !_ok && t in
let iter c = ok (code_elt ?options annots c) in
let _ = List.iter iter code in
let expr ?options annots e =
_annots_found := AnnotSet.empty;
expr ?options annots e
let pat ?options annots e =
_annots_found := AnnotSet.empty;
pat ?options annots e
let code_elt ?options annots e =
_annots_found := AnnotSet.empty;
code_elt ?options annots e
let code ?options annots e =
_annots_found := AnnotSet.empty;
code ?options annots e
Jump to Line
Something went wrong with that request. Please try again.