Skip to content
This repository
tag: v783
Fetching contributors…

Cannot retrieve contributors at this time

file 258 lines (197 sloc) 7.657 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 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258
(*
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/>.
*)

let (!!) = Annot.annot

type trace = Annot.t AnnotMap.t

exception AnnotNotFound of string * Annot.t
exception ConflictingAnnotations of Annot.t

(* For the semantics, have a look at the .mli. *)


type 'a typed_annot =
    {
      a_ty : 'a option ;
      (* TODO: rename a_tsc to a_tsc_gen and perhaps change it's type
to [TypeVar.t list] and rename even more *)
      a_tsc : ('a, unit) QmlGenericScheme.tsc option ;
      a_tsc_inst : ('a, unit) QmlGenericScheme.tsc option ;
    }

type 'a gen_annotmap = ('a typed_annot) AnnotMap.t

(* registering exception printers *)
let () = Printexc.register_printer
  (function
     | AnnotNotFound (s,annot) -> Some (Printf.sprintf "QmlAnnotMap.AnnotNotFound (%S,%s)" s (Annot.to_string annot))
     | ConflictingAnnotations annot -> Some (Printf.sprintf "QmlAnnotMap.ConflictingAnnotations %s" (Annot.to_string annot))
     | _ -> None
  )

let default_annot = {
  a_ty = None ;
  a_tsc = None ;
  a_tsc_inst = None ;
}

let empty = AnnotMap.empty

let is_empty am = AnnotMap.is_empty am
let size am = AnnotMap.size am

let rec lift f f_tsc annot = {
  a_ty = Option.map f annot.a_ty ;
  a_tsc = Option.map f_tsc annot.a_tsc ;
  a_tsc_inst = Option.map f_tsc annot.a_tsc_inst ;
}
and map f f_tsc annotmap =
  AnnotMap.map (lift f f_tsc) annotmap

let map_ty_tsc ~ty:f ~tsc:f_tsc annotmap =
  map f f_tsc annotmap
let map f annotmap =
  map_ty_tsc ~ty:f ~tsc:(QmlGenericScheme.map_body_unsafe f) annotmap

let annot_merge conflict_t conflict_s i annot1 annot2 =
  let { a_ty = t1 ; a_tsc = tsc1 ; a_tsc_inst = tsc_inst1 } = annot1
  and { a_ty = t2 ; a_tsc = tsc2 ; a_tsc_inst = tsc_inst2 } = annot2 in
  {
    a_ty = Option.merge (conflict_t i) t1 t2 ;
    a_tsc = Option.merge (conflict_s i) tsc1 tsc2 ;
    a_tsc_inst = Option.merge (conflict_s i) tsc_inst1 tsc_inst2 ;
  }

let merge_i f annotmap1 annotmap2 =
 AnnotMap.merge_i f annotmap1 annotmap2

let merge ?(no_conflict_if_equal=false) annotmap1 annotmap2 =
  let f i x y =
    if no_conflict_if_equal && (x = y) then y
    else raise (ConflictingAnnotations i)
  in
  merge_i (annot_merge f f) annotmap1 annotmap2

let overwrite annotmap1 annotmap2 =
  let f _ _ y = y in
  merge_i (annot_merge f f) annotmap1 annotmap2

let unsafe_overwrite annotmap1 annotmap2 =
  let f _ _ y = y in
  merge_i f annotmap1 annotmap2

let find_opt i annotmap = AnnotMap.find_opt i annotmap
let find_opt_label label = find_opt (!! label)
let find i annotmap = Option.get_exn (AnnotNotFound ("annot", i)) (find_opt i annotmap)
let find_label label = find (!! label)
let add i annot annotmap = AnnotMap.add i annot annotmap
let add_label label = add (!! label)
let remove i annotmap = AnnotMap.remove i annotmap

let find_opt_factory _name accessor i annotmap =
  Option.join (Option.map accessor (find_opt i annotmap))
let find_factory name accessor i annotmap =
  Option.get_exn (AnnotNotFound (name, i)) (accessor (find i annotmap))
let add_factory _name builder i t annotmap =
  match find_opt i annotmap with
  | None -> add i (builder default_annot t) annotmap
  | Some annot -> add i (builder annot t) annotmap

let find_ty_opt i annotmap =
  find_opt_factory "ty"
    (fun x -> x.a_ty)
    i annotmap

let find_ty_opt_label label = find_ty_opt (!! label)

let find_ty i annotmap =
  find_factory "ty"
    (fun x -> x.a_ty)
    i annotmap

let find_ty_label label = find_ty (!! label)

let add_ty i t annotmap =
  add_factory "ty"
    (fun annot t -> { annot with a_ty = Some t })
    i t annotmap

let add_ty_label label = add_ty (!! label)

let find_tsc_opt i annotmap =
  find_opt_factory "tsc"
    (fun x -> x.a_tsc)
    i annotmap

let find_tsc_opt_label label = find_tsc_opt (!! label)

let find_tsc i annotmap =
  find_factory "tsc"
    (fun x -> x.a_tsc)
    i annotmap

let find_tsc_label label = find_tsc (!! label)

let add_tsc i t annotmap =
  add_factory "tsc"
    (fun annot t -> { annot with a_tsc = Some t } )
    i t annotmap
let add_tsc_label label = add_tsc (!! label)
let add_tsc_opt i t annotmap =
  Option.default annotmap (Option.map (fun t -> add_tsc i t annotmap) t)
let add_tsc_opt_label label = add_tsc_opt (!! label)

let find_tsc_inst_opt i annotmap =
  find_opt_factory "tsc_inst"
    (fun x -> x.a_tsc_inst)
    i annotmap

let find_tsc_inst_opt_label label = find_tsc_inst_opt (!! label)

let find_tsc_inst i annotmap =
  find_factory "tsc_inst"
    (fun x -> x.a_tsc_inst)
    i annotmap

let find_tsc_inst_label label = find_tsc_inst (!! label)

let add_tsc_inst i t annotmap =
  add_factory "tsc_inst"
    (fun annot t -> { annot with a_tsc_inst = Some t })
    i t annotmap

let add_tsc_inst_label label = add_tsc_inst (!! label)

let add_tsc_inst_opt i t annotmap =
  Option.default annotmap (Option.map (fun t -> add_tsc_inst i t annotmap) t)

let add_tsc_inst_opt_label label = add_tsc_inst_opt (!! label)

let remove_tsc i annotmap =
  match find_opt i annotmap with
  | None -> annotmap
  | Some annot -> add i { annot with a_tsc = None } annotmap

let remove_tsc_label label = remove_tsc (!! label)

let remove_tsc_inst i annotmap =
  match find_opt i annotmap with
  | None -> annotmap
  | Some annot -> add i { annot with a_tsc_inst = None } annotmap

let remove_tsc_inst_label label = remove_tsc_inst (!! label)

let iteri ~f_for_key ~f_for_ty ~f_for_tsc ~f_for_tsc_inst
    annotmap =
  AnnotMap.iter
    (fun key bound_value ->
       f_for_key key ;
       f_for_ty bound_value.a_ty ;
       f_for_tsc bound_value.a_tsc ;
       f_for_tsc_inst bound_value.a_tsc_inst)
    annotmap



module Ref = struct

module type REF = sig type ty val _global : (ty gen_annotmap) ref end

module type ANNOTMAPREF =
sig
  type ty

  val clear : unit -> unit
  val import : ty gen_annotmap -> unit
  val merge : ty gen_annotmap -> unit
  val overwrite : ty gen_annotmap -> unit
  val export : unit -> ty gen_annotmap
  val get_opt : Annot.t -> (ty typed_annot) option
  val get : Annot.t -> ty typed_annot
  val set : Annot.t -> ty typed_annot -> unit

(* specific functions: please add more if useful *)
  val set_ty : Annot.t -> ty -> unit
  val get_ty : Annot.t -> ty
  val get_ty_opt : Annot.t -> ty option
  val get_tsc_opt : Annot.t -> (ty, unit) QmlGenericScheme.tsc option

(* we don't provide Ref interface for everything -- please add if you need *)
end

module Make (Ref: REF) : (ANNOTMAPREF with type ty = Ref.ty) =
struct
  type ty = Ref.ty

  let clear () = Ref._global := empty
  let import annotmap = Ref._global := annotmap
  let merge annotmap = Ref._global := merge !Ref._global annotmap
  let overwrite annotmap = Ref._global := overwrite !Ref._global annotmap
  let export () = !Ref._global
  let get_opt i = find_opt i !Ref._global
  let get i = find i !Ref._global
  let set i annot = Ref._global := add i annot !Ref._global

  let set_ty i t = Ref._global := add_ty i t !Ref._global
  let get_ty i = find_ty i !Ref._global
  let get_ty_opt i = find_ty_opt i !Ref._global
  let get_tsc_opt i = find_tsc_opt i !Ref._global

end

end (* module Ref *)
Something went wrong with that request. Please try again.