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))
  | Typer.NonExhaustive t ->
      Format.fprintf ppf "This pattern matching is not exhaustive@\n";
      Format.fprintf ppf "Residual type: %a@\n"
        Types.Print.print_descr t;
      Format.fprintf ppf "Sample value: %a@\n" 
        Types.Print.print_sample (Types.Sample.get 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;
    | Ast.TypeDecl _ -> ()
    | _ -> assert false

let () = 
  try 
    let p = prog () in
    let type_decls = 
      List.fold_left
        (fun accu ph -> match ph.descr with
           | Ast.TypeDecl (x,t) -> (x,t) :: accu
           | _ -> accu
        ) [] p in
    Typer.register_global_types type_decls;
    List.iter phrase p
  with (Failure _) as e -> raise e | exn -> print_exn ppf exn
        
1	abate	10	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	abate	17	\| Typer.NonExhaustive t ->
23			Format.fprintf ppf "This pattern matching is not exhaustive@\n";
24			Format.fprintf ppf "Residual type: %a@\n"
25			Types.Print.print_descr t;
26			Format.fprintf ppf "Sample value: %a@\n"
27			Types.Print.print_sample (Types.Sample.get t)
28	abate	10	\| exn ->
29			Format.fprintf ppf "%s@\n" (Printexc.to_string exn)
30
31			let phrase ph =
32			match ph.descr with
33			\| Ast.EvalStatement e ->
34			let (fv,e) = Typer.expr e in
35			let t = Typer.compute_type Typer.Env.empty e in
36			Format.fprintf ppf "%a@\n" Types.Print.print_descr t;
37	abate	13	\| Ast.TypeDecl _ -> ()
38	abate	10	\| _ -> assert false
39
40			let () =
41	abate	13	try
42			let p = prog () in
43			let type_decls =
44			List.fold_left
45			(fun accu ph -> match ph.descr with
46			\| Ast.TypeDecl (x,t) -> (x,t) :: accu
47			\| _ -> accu
48			) [] p in
49			Typer.register_global_types type_decls;
50			List.iter phrase p
51	abate	17	with (Failure _) as e -> raise e \| exn -> print_exn ppf exn
52	abate	10