atoms.ml 2.81 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
12

module SymbolSet = SortedList.FiniteCofinite(V)
13

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

29
30
31
32
33
34
35
include SortedList.FiniteCofiniteMap(Ns.Uri)(SymbolSet)

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

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

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

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

let print s = match get s with
  | `Finite l -> 
      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";
	  List.iter 
	    (fun (ns,s) -> 
61
	       Format.fprintf ppf " \\@ (%a)" (print_symbolset ns) s)
62
63
	    l ]

64
type 'a map = 'a Imap.t * 'a Imap.t * 'a option
65

66
67
68
69
let map_map f (m1,m2,o) =
  Imap.map f m1, Imap.map f m2, 
  (match o with Some x -> Some (f x) | None -> None)

70
71
72
73
74
75
76
77
(* TODO: optimize this get_map *)
let get_map q (mtags,mns,def) =   
  try Imap.find mtags (Upool.int q)
  with Not_found -> 
    try Imap.find mns (Upool.int (fst (V.value q)))
    with Not_found -> match def with
      | None -> assert false
      | Some x -> x
78
79


80
let mk_map l =
81
82
  let all_ns = ref [] in
  let all_tags = ref [] in
83
  let def = ref None in
84
  List.iter 
85
86
87
    (function (s,x) ->
       match get s with
       | `Finite s -> 
88
89
90
91
92
93
94
95
96
	   List.iter 
	     (function 
		| (_, SymbolSet.Finite t) ->
		   List.iter 
		     (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
97
    ) l;
98

99
100
101
  let mtags = Imap.create (Array.of_list !all_tags) in
  let mns = Imap.create (Array.of_list !all_ns) in
  (mtags,mns,!def)
102
103
104
105
106
107
108
109
110

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)