atoms.ml 3.34 KB
Newer Older
1
open Encodings
2

3
module Symbol = Utf8
4

5
module V = struct
6 7 8
  include Ns.Label
  let print = print_tag
  let to_string = string_of_tag
9
end
10

11
module SymbolSet = SortedList.FiniteCofinite(V)
12

13 14 15 16
let rec iter_sep sep f = function
  | [] -> ()
  | [ h ] -> f h
  | h :: t -> f h; sep (); iter_sep sep f t
17

18
let print_symbolset ns ppf = function
19 20 21
  | SymbolSet.Finite l ->
      iter_sep
	(fun () -> Format.fprintf ppf " |@ ")
22
	(V.print_quote ppf) l
23
  | SymbolSet.Cofinite t ->
24 25
      Format.fprintf ppf "@[`%a" Ns.InternalPrinter.print_any_ns ns;
      List.iter (fun x -> Format.fprintf ppf " \\@ %a" V.print_quote x) t;
26 27
      Format.fprintf ppf "@]"

28 29
include SortedList.FiniteCofiniteMap(Ns.Uri)(SymbolSet)

30
let atom l = atom (fst (V.value l), l)
31

Pietro Abate's avatar
Pietro Abate committed
32 33 34 35
(* this is to have a uniform signature of all basic types *)
type elem = V.t
let full = any

36
let contains l t = contains (fst (V.value l), l) t
37

38
let single s = match get s with
39
  | `Finite [_, SymbolSet.Finite [a]] -> a
40 41 42
  | `Finite [] -> raise Not_found
  | _ -> raise Exit

43
let print_tag s = match get s with
44
  | `Finite [_, SymbolSet.Finite [a]] ->
45
      Some (fun ppf -> Ns.InternalPrinter.print_tag ppf (V.value a))
46
  | `Finite [ns, SymbolSet.Cofinite []] ->
47
      Some (fun ppf -> Ns.InternalPrinter.print_any_ns ppf ns)
48 49 50 51 52
  | `Cofinite [] ->
      Some (fun ppf -> Format.fprintf ppf "_")
  | _ -> None

let print s = match get s with
53
  | `Finite l ->
54 55 56 57 58 59
      List.map (fun (ns,s) ppf -> print_symbolset ns ppf s) l
  | `Cofinite [] ->
      [ fun ppf -> Format.fprintf ppf "Atom" ]
  | `Cofinite l ->
      [ fun ppf ->
	  Format.fprintf ppf "Atom";
60 61
	  List.iter
	    (fun (ns,s) ->
62
	       Format.fprintf ppf " \\@ (%a)" (print_symbolset ns) s)
63 64
	    l ]

65 66 67 68 69 70 71 72 73 74 75 76
let extract s =
  let tr l =
    List.map (fun (ns, ss) -> ns, match ss with
        SymbolSet.Finite l -> `Finite l
    | SymbolSet.Cofinite l -> `Cofinite l) l
  in
  match get s with
    `Finite l -> `Finite (tr l)
  | `Cofinite l -> `Cofinite (tr l)



77
type 'a map = 'a Imap.t * 'a Imap.t * 'a option
78

79
let map_map f (m1,m2,o) =
80
  Imap.map f m1, Imap.map f m2,
81 82
  (match o with Some x -> Some (f x) | None -> None)

83
(* TODO: optimize this get_map *)
84
let get_map q (mtags,mns,def) =
85
  try Imap.find mtags (Upool.int q)
86
  with Not_found ->
87 88 89 90
    try Imap.find mns (Upool.int (fst (V.value q)))
    with Not_found -> match def with
      | None -> assert false
      | Some x -> x
91

92
let mk_map l =
93 94
  let all_ns = ref [] in
  let all_tags = ref [] in
95
  let def = ref None in
96
  List.iter
97 98
    (function (s,x) ->
       match get s with
99 100 101
       | `Finite s ->
	   List.iter
	     (function
102
		| (_, SymbolSet.Finite t) ->
103
		   List.iter
104 105 106 107 108
		     (fun tag -> all_tags := (Upool.int tag,x)::!all_tags) t
		| (ns, _) ->
		    all_ns := (Upool.int ns,x)::!all_ns
	     ) s
       | `Cofinite _ -> def := Some x
109
    ) l;
110

111 112 113
  let mtags = Imap.create (Array.of_list !all_tags) in
  let mns = Imap.create (Array.of_list !all_ns) in
  (mtags,mns,!def)
114 115 116 117 118 119 120 121 122

type sample = (Ns.Uri.t * Ns.Label.t option) option

let contains_sample s t =
  match s,(get t) with
    | None, `Cofinite _ -> true
    | None, `Finite _ -> false
    | Some (_,Some tag),_ -> contains tag t
    | Some (ns, None),_ -> is_empty (diff (any_in_ns ns) t)
123 124

let trivially_disjoint = disjoint
125 126 127 128
let is_finite m =
  match get m with
  `Finite _ -> true
  | _ -> false
129 130 131 132

let compute ~empty ~full ~cup ~cap ~diff ~atom b = assert false
let get _ = assert false
let iter _ = assert false