viewcvs.cgi/driver/cduce.ml

open Location

let input = Stream.of_channel stdin
let ppf = Format.std_formatter
let prog () = 
  try Parser.prog input
  with
    | Stdpp.Exc_located (loc, e) -> 
        raise (Location (loc, e))

let rec print_exn ppf = function
  | Location ((i,j), exn) ->
      Format.fprintf ppf "Error at chars %i-%i@\n" i j;
      print_exn ppf exn
  | Typer.Constraint (s,t,msg) ->
      Format.fprintf ppf "%s@\n" msg;
      Format.fprintf ppf "%a is not a subtype of %a@\n" 
        Types.Print.print_descr s 
        Types.Print.print_descr t;
      Format.fprintf ppf "as shown by %a@\n" 
        Types.Print.print_sample (Types.Sample.get (Types.diff s t))
  | exn ->
      Format.fprintf ppf "%s@\n" (Printexc.to_string exn)

let phrase ph =
  match ph.descr with
    | Ast.EvalStatement e ->
        let (fv,e) = Typer.expr e in
        let t = Typer.compute_type Typer.Env.empty e in
        Format.fprintf ppf "%a@\n" Types.Print.print_descr t;
    | _ -> assert false

let () = 
  try List.iter phrase (prog ())
  with exn -> print_exn ppf exn
        
1	open Location
2
3	let input = Stream.of_channel stdin
4	let ppf = Format.std_formatter
5	let prog () =
6	try Parser.prog input
7	with
8	\| Stdpp.Exc_located (loc, e) ->
9	raise (Location (loc, e))
10
11	let rec print_exn ppf = function
12	\| Location ((i,j), exn) ->
13	Format.fprintf ppf "Error at chars %i-%i@\n" i j;
14	print_exn ppf exn
15	\| Typer.Constraint (s,t,msg) ->
16	Format.fprintf ppf "%s@\n" msg;
17	Format.fprintf ppf "%a is not a subtype of %a@\n"
18	Types.Print.print_descr s
19	Types.Print.print_descr t;
20	Format.fprintf ppf "as shown by %a@\n"
21	Types.Print.print_sample (Types.Sample.get (Types.diff s t))
22	\| exn ->
23	Format.fprintf ppf "%s@\n" (Printexc.to_string exn)
24
25	let phrase ph =
26	match ph.descr with
27	\| Ast.EvalStatement e ->
28	let (fv,e) = Typer.expr e in
29	let t = Typer.compute_type Typer.Env.empty e in
30	Format.fprintf ppf "%a@\n" Types.Print.print_descr t;
31	\| _ -> assert false
32
33	let () =
34	try List.iter phrase (prog ())
35	with exn -> print_exn ppf exn
36