| 1 |
open Location
|
| 2 |
exception Usage
|
| 3 |
|
| 4 |
let () =
|
| 5 |
List.iter
|
| 6 |
(fun (n,t) -> Typer.register_global_types [n, mk noloc (Ast.Internal t)])
|
| 7 |
Builtin.types
|
| 8 |
|
| 9 |
|
| 10 |
let (source,input_channel) =
|
| 11 |
match Array.length Sys.argv with
|
| 12 |
| 1 -> ("",stdin)
|
| 13 |
| 2 -> let s = Sys.argv.(1) in (s, open_in s)
|
| 14 |
| _ -> raise Usage
|
| 15 |
|
| 16 |
let input = Stream.of_channel input_channel
|
| 17 |
|
| 18 |
let ppf = Format.std_formatter
|
| 19 |
let prog () =
|
| 20 |
try Parser.prog input
|
| 21 |
with
|
| 22 |
| Stdpp.Exc_located (loc, e) -> raise (Location (loc, e))
|
| 23 |
|
| 24 |
let rec print_exn ppf = function
|
| 25 |
| Location ((i,j), exn) ->
|
| 26 |
if source = "" then
|
| 27 |
Format.fprintf ppf "Error at chars %i-%i@\n" i j
|
| 28 |
else (
|
| 29 |
let (l1,c1) = Location.get_line_number source i
|
| 30 |
and (l2,c2) = Location.get_line_number source j in
|
| 31 |
if l1 = l2 then
|
| 32 |
Format.fprintf ppf "Error at line %i (chars %i-%i)@\n"
|
| 33 |
l1 c1 c2
|
| 34 |
else
|
| 35 |
Format.fprintf ppf "Error at lines %i (char %i) - %i (char %i)@\n"
|
| 36 |
l1 c1 l2 c2
|
| 37 |
);
|
| 38 |
print_exn ppf exn
|
| 39 |
| Typer.WrongLabel (t,l) ->
|
| 40 |
Format.fprintf ppf "Wrong record selection: the label %s@\n"
|
| 41 |
(Types.label_name l);
|
| 42 |
Format.fprintf ppf "applied to an expression of type %a@\n"
|
| 43 |
Types.Print.print_descr t
|
| 44 |
| Typer.MultipleLabel l ->
|
| 45 |
Format.fprintf ppf "Multiple occurences for the record label %s@\n"
|
| 46 |
(Types.label_name l);
|
| 47 |
| Typer.ShouldHave (t,msg) ->
|
| 48 |
Format.fprintf ppf "This expression should have type %a@\n%s@\n"
|
| 49 |
Types.Print.print_descr t
|
| 50 |
msg
|
| 51 |
| Typer.Constraint (s,t,msg) ->
|
| 52 |
Format.fprintf ppf "This expression should have type %a@\n"
|
| 53 |
Types.Print.print_descr t;
|
| 54 |
Format.fprintf ppf "but its infered type is: %a@\n"
|
| 55 |
Types.Print.print_descr s;
|
| 56 |
Format.fprintf ppf "which is not a subtype, as shown by the value %a@\n"
|
| 57 |
Types.Print.print_sample (Types.Sample.get (Types.diff s t));
|
| 58 |
Format.fprintf ppf "%s@\n" msg
|
| 59 |
| Typer.NonExhaustive t ->
|
| 60 |
Format.fprintf ppf "This pattern matching is not exhaustive@\n";
|
| 61 |
Format.fprintf ppf "Residual type: %a@\n"
|
| 62 |
Types.Print.print_descr t;
|
| 63 |
Format.fprintf ppf "Sample value: %a@\n"
|
| 64 |
Types.Print.print_sample (Types.Sample.get t)
|
| 65 |
| exn ->
|
| 66 |
Format.fprintf ppf "%s@\n" (Printexc.to_string exn)
|
| 67 |
|
| 68 |
let phrase ph =
|
| 69 |
match ph.descr with
|
| 70 |
| Ast.EvalStatement e ->
|
| 71 |
let (fv,e) = Typer.expr e in
|
| 72 |
let t = Typer.type_check Typer.Env.empty e Types.any true in
|
| 73 |
Format.fprintf ppf "%a@\n" Types.Print.print_descr t
|
| 74 |
| Ast.TypeDecl _ -> ()
|
| 75 |
| _ -> assert false
|
| 76 |
|
| 77 |
let () =
|
| 78 |
try
|
| 79 |
let p = prog () in
|
| 80 |
let type_decls =
|
| 81 |
List.fold_left
|
| 82 |
(fun accu ph -> match ph.descr with
|
| 83 |
| Ast.TypeDecl (x,t) -> (x,t) :: accu
|
| 84 |
| _ -> accu
|
| 85 |
) [] p in
|
| 86 |
Typer.register_global_types type_decls;
|
| 87 |
List.iter phrase p
|
| 88 |
with
|
| 89 |
| (Failure _) as e -> raise e (* To get the ocamlrun stack trace *)
|
| 90 |
| exn -> print_exn ppf exn
|
| 91 |
|
| 92 |
|
| 93 |
|
| 94 |
|
| 95 |
|
Parent Directory
| 
Revision Log