viewcvs.cgi/driver/cduce.ml

open Location
open Sys
exception Usage of unit

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


let input = if Array.length argv = 1 then (Stream.of_channel stdin) 
            else if (Array.length argv > 2)  or
               not (file_exists (Array.get argv 1)) then raise(Usage () )
            else (Stream.of_channel (open_in (Array.get argv 1)))

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