Print more informative error messages.

This commit is contained in:
Olivier 2022-01-26 17:51:18 +01:00
parent 4327183d2c
commit 2963a5e853
1 changed files with 17 additions and 11 deletions

View File

@ -1,5 +1,7 @@
open Client
module LexUtil = MenhirLib.LexerUtil
(* -------------------------------------------------------------------------- *)
(* A wrapper over the client's [translate] function. We consider ill-typedness
@ -13,15 +15,22 @@ let translate ~rectypes e t =
try
Some (Infer.translate ~rectypes e t)
with
| Infer.Cycle (_range, ty) ->
| Infer.Unbound (range, s) ->
Printf.eprintf "%!%sType error: unbound variable \"%s\".\n"
(LexUtil.range range) s;
None
| Infer.Cycle (range, ty) ->
if Config.verbose then begin
Printf.eprintf "%!%sType error: cyclic type.\n"
(LexUtil.range range);
Printf.fprintf stdout "Type error: a cyclic type arose.\n";
print_type ty
end;
None
| Infer.Unify (_range, ty1, ty2) ->
| Infer.Unify (range, ty1, ty2) ->
if Config.verbose then begin
Printf.fprintf stdout "Type error: type mismatch.\n";
Printf.eprintf "%!%sType error: type mismatch.\n"
(LexUtil.range range);
Printf.fprintf stdout "Type error: mismatch between the type:\n";
print_type ty1;
Printf.fprintf stdout "and the type:\n";
@ -35,8 +44,6 @@ let equal_term t1 t2 =
(* -------------------------------------------------------------------------- *)
module LexUtil = MenhirLib.LexerUtil
let wrap parser lexbuf =
let lexbuf = LexUtil.init "test" lexbuf in
try parser MLLexer.read lexbuf
@ -90,12 +97,11 @@ let from_string typedecl s =
let from_file filename =
let ch = open_in filename in
let lexbuf = Lexing.from_channel ch in
try let (uses, typedecl_env, xts) = program lexbuf in
close_in ch;
let typedecl_env' = open_uses uses in
let ast = letify xts in
(Datatype.Env.union typedecl_env typedecl_env', ast)
with _ -> raise ParsingError
let (uses, typedecl_env, xts) = program lexbuf in
close_in ch;
let typedecl_env' = open_uses uses in
let ast = letify xts in
(Datatype.Env.union typedecl_env typedecl_env', ast)
(* -------------------------------------------------------------------------- *)