cduce.ml 2.05 KB
Newer Older
1
open Location
2
exception Usage
3

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

9

10
11
12
13
14
15
16
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
17

18
19
20
21
let ppf = Format.std_formatter
let prog () = 
  try Parser.prog input
  with
22
    | Stdpp.Exc_located (loc, e) -> raise (Location (loc, e))
23
24
25
26
27

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
28
29
30
31
  | Typer.ShouldHave (t,msg) ->
      Format.fprintf ppf "This expression should have type %a@\n%s@\n" 
        Types.Print.print_descr t
      msg
32
  | Typer.Constraint (s,t,msg) ->
33
34
35
36
37
38
39
      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
40
41
42
43
44
45
  | 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)
46
47
48
49
50
51
52
  | 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
53
	let t = Typer.type_check Typer.Env.empty e Types.any true in
54
	Format.fprintf ppf "%a@\n" Types.Print.print_descr t
55
    | Ast.TypeDecl _ -> ()
56
57
58
    | _ -> assert false

let () = 
59
60
61
62
63
64
65
66
67
68
  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
69
  with (Failure _) as e -> raise e | exn -> print_exn ppf exn
70
	
71
72
73
74