viewcvs.cgi/driver/cduce.ml

open Location
exception Usage

let () =
  List.iter 
    (fun (n,t) -> Typer.register_global_types [n, mk noloc (Ast.Internal t)])
    Builtin.types


let input_channel = 
  match Array.length Sys.argv with
    | 1 -> stdin
    | 2 -> open_in Sys.argv.(1)
    | _ -> raise Usage

let input = Stream.of_channel input_channel

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.ShouldHave (t,msg) ->
      Format.fprintf ppf "This expression should have type %a@\n%s@\n" 
        Types.Print.print_descr t
      msg
  | Typer.Constraint (s,t,msg) ->
      Format.fprintf ppf "This expression should have type %a@\n" 
        Types.Print.print_descr t;
      Format.fprintf ppf "but its infered type is: %a@\n" 
        Types.Print.print_descr s;
      Format.fprintf ppf "which is not a subtype, as shown by the value %a@\n" 
        Types.Print.print_sample (Types.Sample.get (Types.diff s t));
      Format.fprintf ppf "%s@\n" msg
  | 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.type_check Typer.Env.empty e Types.any true 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	abate	23	exception Usage
3	abate	10
4	abate	18	let () =
5			List.iter
6			(fun (n,t) -> Typer.register_global_types [n, mk noloc (Ast.Internal t)])
7			Builtin.types
8
9	abate	21
10	abate	23	let input_channel =
11			match Array.length Sys.argv with
12			\| 1 -> stdin
13			\| 2 -> open_in Sys.argv.(1)
14			\| _ -> raise Usage
15	abate	21
16	abate	23	let input = Stream.of_channel input_channel
17
18	abate	10	let ppf = Format.std_formatter
19			let prog () =
20			try Parser.prog input
21			with
22	abate	21	\| Stdpp.Exc_located (loc, e) -> raise (Location (loc, e))
23	abate	10
24			let rec print_exn ppf = function
25			\| Location ((i,j), exn) ->
26			Format.fprintf ppf "Error at chars %i-%i@\n" i j;
27			print_exn ppf exn
28	abate	19	\| Typer.ShouldHave (t,msg) ->
29			Format.fprintf ppf "This expression should have type %a@\n%s@\n"
30			Types.Print.print_descr t
31			msg
32	abate	10	\| Typer.Constraint (s,t,msg) ->
33	abate	19	Format.fprintf ppf "This expression should have type %a@\n"
34			Types.Print.print_descr t;
35			Format.fprintf ppf "but its infered type is: %a@\n"
36			Types.Print.print_descr s;
37			Format.fprintf ppf "which is not a subtype, as shown by the value %a@\n"
38			Types.Print.print_sample (Types.Sample.get (Types.diff s t));
39			Format.fprintf ppf "%s@\n" msg
40	abate	17	\| Typer.NonExhaustive t ->
41			Format.fprintf ppf "This pattern matching is not exhaustive@\n";
42			Format.fprintf ppf "Residual type: %a@\n"
43			Types.Print.print_descr t;
44			Format.fprintf ppf "Sample value: %a@\n"
45			Types.Print.print_sample (Types.Sample.get t)
46	abate	10	\| exn ->
47			Format.fprintf ppf "%s@\n" (Printexc.to_string exn)
48
49			let phrase ph =
50			match ph.descr with
51			\| Ast.EvalStatement e ->
52			let (fv,e) = Typer.expr e in
53	abate	19	let t = Typer.type_check Typer.Env.empty e Types.any true in
54	abate	22	Format.fprintf ppf "%a@\n" Types.Print.print_descr t
55	abate	13	\| Ast.TypeDecl _ -> ()
56	abate	10	\| _ -> assert false
57
58			let () =
59	abate	13	try
60			let p = prog () in
61			let type_decls =
62			List.fold_left
63			(fun accu ph -> match ph.descr with
64			\| Ast.TypeDecl (x,t) -> (x,t) :: accu
65			\| _ -> accu
66			) [] p in
67			Typer.register_global_types type_decls;
68			List.iter phrase p
69	abate	17	with (Failure _) as e -> raise e \| exn -> print_exn ppf exn
70	abate	10
71	abate	21
72
73
74