Skip to content
This repository
tag: v1147
Fetching contributors…

Cannot retrieve contributors at this time

file 152 lines (130 sloc) 4.766 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152
(*
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 <http://www.gnu.org/licenses/>.
*)
(* 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
  then
    begin
      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));
      false
    end
  else
    begin
      _annots_found := AnnotSet.add annot !_annots_found;
      true
    end)
  &&
  (options.freshness_only ||
  let position =
    if options.dump_position
    then Ansi.print `green (Printf.sprintf "/ position : %s"
      (FilePos.to_string pos))
    else ""
  in
  match QmlAnnotMap.find_ty_opt annot annots with
  | Some ty ->
      let _ =
        if options.dump_found
        then
          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
        true
  | None ->
      if options.pat_not_found_are_ok && pattern_case then true
      else
        let _ =
          if options.dump_not_found
          then
            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
        false
  )

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
  !_ok

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
  !_ok

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
  !_ok

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
  !_ok

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
Something went wrong with that request. Please try again.