viewcvs.cgi/types/sample.ml

open Ident

type t = Types.t

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

module D = Set.Make(Types)
  
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
  let fields = function
    | (true,_) -> assert false (* absent *)
    | (false,t) -> cons t in
  let record (r,some,none) = 
    let r = LabelMap.filter (fun l (o,t) -> not o) r in
    Types.record' (not none, LabelMap.map fields r) in
  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 ->
  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 ->
  try Types.Arrow.sample t with Not_found ->
    t
(*
  raise Not_found
*)
     
let get = get D.empty

let print = Types.Print.print


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
1	abate	407	open Ident
2
3	abate	653	type t = Types.t
4	abate	407
5			let rec try_seq f = function
6			\| [] -> raise Not_found
7			\| hd::tl -> try f hd with Not_found -> try_seq f tl
8
9	abate	653	module D = Set.Make(Types)
10	abate	407
11			let absent = Types.cons (Types.Record.or_absent Types.empty)
12
13			let rec get memo t =
14			if D.mem t memo then raise Not_found;
15			let memo = D.add t memo in
16			let cons t = Types.cons (get memo t) in
17			let pair (t1,t2) = Types.times (cons t1) (cons t2) in
18			let xml (t1,t2) = Types.xml (cons t1) (cons t2) in
19	abate	1352	let fields = function
20			\| (true,_) -> assert false (* absent *)
21	abate	407	\| (false,t) -> cons t in
22	abate	639	let record (r,some,none) =
23			let r = LabelMap.filter (fun l (o,t) -> not o) r in
24			Types.record' (not none, LabelMap.map fields r) in
25	abate	407	let typ u =
26			let u = Types.cap t u in
27			if Types.is_empty u then raise Not_found else u in
28			try try_seq typ [ Types.Int.any; Types.Atom.any; Types.Char.any ] with Not_found ->
29			try try_seq pair (Types.Product.get t) with Not_found ->
30			try try_seq xml (Types.Product.get ~kind:`XML t) with Not_found ->
31	abate	409	try
32			let r = Types.Record.get t in
33			let r = List.sort (fun (_,_,n1) (_,_,n2) -> -(compare n1 n2)) r in
34			try_seq record r with Not_found ->
35	abate	407	try Types.Arrow.sample t with Not_found ->
36	abate	1151	t
37			(*
38	abate	407	raise Not_found
39	abate	1151	*)
40	abate	407
41			let get = get D.empty
42
43			let print = Types.Print.print
44	abate	1352
45
46			let try_single r f x =
47			try
48			let v = f x in
49			match !r with
50			\| None -> r := Some v
51			\| Some v' -> if (Types.Const.compare v v' !=0) then raise Exit
52			with Not_found -> ()
53
54			let rec single memo t =
55			if D.mem t memo then raise Exit;
56			let memo = D.add t memo in
57			let pair (t1,t2) = Types.Pair (single memo t1, single memo t2) in
58			let xml (t1,t2) = Types.Xml (single memo t1, single memo t2) in
59			let int t = Types.Integer (Intervals.single (Types.Int.get t)) in
60			let atom t = Types.Atom (Atoms.single (Types.Atom.get t)) in
61			let char t = Types.Char (Chars.single (Types.Char.get t)) in
62			let fields = function
63			\| (true,_) -> assert false
64			\| (false,t) -> single memo t in
65			let record = function
66			\| (r,false,true) ->
67			let r =
68			LabelMap.filter
69			(fun l (o,t) ->
70			if o then if (Types.non_empty t) then raise Exit else false
71			else true) r in
72			Types.Record (LabelMap.map fields r)
73			\| _ -> raise Exit in
74			let r = ref None in
75			try_single r int t;
76			try_single r char t;
77			try_single r atom t;
78			List.iter (try_single r pair) (Types.Product.get t);
79			List.iter (try_single r xml) (Types.Product.get ~kind:`XML t);
80			List.iter (try_single r record) (Types.Record.get t);
81			(try ignore (Types.Arrow.sample t); raise Exit with Not_found -> ());
82			match !r with
83			\| None -> raise Not_found
84			\| Some c -> c
85
86			let single = single D.empty
87
88			let single_opt t =
89			try Some (single t)
90			with Not_found \| Exit -> None