sample.ml 2.73 KB
Newer Older
1
2
open Ident

3
type t = Types.t
4
5
6
7
8

let rec try_seq f = function
  | [] -> raise Not_found
  | hd::tl -> try f hd with Not_found -> try_seq f tl

9
module D = Set.Make(Types)
10
11
12
13
14
15
16
17
18
  
let absent = Types.cons (Types.Record.or_absent Types.empty)

let rec get memo t =
  if D.mem t memo then raise Not_found;
  let memo = D.add t memo in
  let cons t = Types.cons (get memo t) in
  let pair (t1,t2) = Types.times (cons t1) (cons t2) in
  let xml (t1,t2) = Types.xml (cons t1) (cons t2) in
19
20
  let fields = function
    | (true,_) -> assert false (* absent *)
21
    | (false,t) -> cons t in
22
23
  let record (r,some,none) = 
    let r = LabelMap.filter (fun l (o,t) -> not o) r in
24
    Types.record_fields (not none, LabelMap.map fields r) in
25
26
27
28
29
30
  let typ u = 
    let u = Types.cap t u in 
    if Types.is_empty u then raise Not_found else u in
  try try_seq typ [ Types.Int.any; Types.Atom.any; Types.Char.any ] with Not_found ->
  try try_seq pair (Types.Product.get t) with Not_found ->
  try try_seq xml (Types.Product.get ~kind:`XML t) with Not_found ->
31
32
33
34
  try 
    let r = Types.Record.get t in
    let r = List.sort (fun (_,_,n1) (_,_,n2) -> -(compare n1 n2)) r in
    try_seq record r with Not_found ->
35
36
37
38
  try Types.Arrow.sample t with Not_found -> raise Not_found
(* t *)
(*  raise Not_found *)

39
40
41
42
     
let get = get D.empty

let print = Types.Print.print
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


let try_single r f x =
  try
    let v = f x in
    match !r with
      | None -> r := Some v
      | Some v' -> if (Types.Const.compare v v' !=0) then raise Exit
  with Not_found -> ()

let rec single memo t =
  if D.mem t memo then raise Exit;
  let memo = D.add t memo in
  let pair (t1,t2) = Types.Pair (single memo t1, single memo t2) in
  let xml (t1,t2) = Types.Xml (single memo t1, single memo t2) in
  let int t = Types.Integer (Intervals.single (Types.Int.get t)) in
  let atom t = Types.Atom (Atoms.single (Types.Atom.get t)) in
  let char t = Types.Char (Chars.single (Types.Char.get t)) in
  let fields = function
    | (true,_) -> assert false
    | (false,t) -> single memo t in
  let record = function
    | (r,false,true) -> 
	let r = 
	  LabelMap.filter 
	    (fun l (o,t) -> 
	       if o then if (Types.non_empty t) then raise Exit else false
	       else true) r in
	Types.Record (LabelMap.map fields r)
    | _ -> raise Exit in
  let r = ref None in
  try_single r int t;
  try_single r char t;
  try_single r atom t;
  List.iter (try_single r pair) (Types.Product.get t);
  List.iter (try_single r xml) (Types.Product.get ~kind:`XML t);
  List.iter (try_single r record) (Types.Record.get t);
  (try ignore (Types.Arrow.sample t); raise Exit with Not_found -> ());
  match !r with
    | None -> raise Not_found
    | Some c -> c

let single = single D.empty

let single_opt t =
  try Some (single t)
  with Not_found | Exit -> None